]> git.uio.no Git - u/mrichter/AliRoot.git/blame - DPMJET/dpmjet3.0-5.f
git://git.uio.no / u / mrichter / AliRoot.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Use std output and MC trigger
[u/mrichter/AliRoot.git] / DPMJET / dpmjet3.0-5.f
CommitLineData
9aaba0d6 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* names of hadrons used in input-cards
58 CHARACTER*8 BTYPE
59 COMMON /DTPAIN/ BTYPE(30)
60* (original name: PAREVT)
61 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
62 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
63 PARAMETER ( NALLWP = 39 )
64 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
65 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
66 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
67 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
68* (original name: INPFLG)
69 COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
70* (original name: FRBKCM)
71 PARAMETER ( MXFFBK = 6 )
72 PARAMETER ( MXZFBK = 9 )
73 PARAMETER ( MXNFBK = 10 )
74 PARAMETER ( MXAFBK = 16 )
75 PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
76 PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
77 PARAMETER ( NXAFBK = MXAFBK + 1 )
78 PARAMETER ( MXPSST = 300 )
79 PARAMETER ( MXPSFB = 41000 )
80 LOGICAL LFRMBK, LNCMSS
81 COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
82 & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
83 & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
84 & IFRBKN (MXPSST), IFRBKZ (MXPSST),
85 & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
86 & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
87 & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
88 & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
89 & IFBFRB, NBUFBK, LFRMBK, LNCMSS
90 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
91* emulsion treatment
92 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
93 & NCOMPO,IEMUL
94* Glauber formalism: parameters
95 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
96 & BMAX(NCOMPX),BSTEP(NCOMPX),
97 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
98 & NSITEB,NSTATB
99* Glauber formalism: cross sections
100 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
101 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
102 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
103 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
104 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
105 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
106 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
107 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
108 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
109 & BSLOPE,NEBINI,NQBINI
110* interface HADRIN-DPM
111 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
112* central particle production, impact parameter biasing
113 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
114* parameter for intranuclear cascade
115 LOGICAL LPAULI
116 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
117* various options for treatment of partons (DTUNUC 1.x)
118* (chain recombination, Cronin,..)
119 LOGICAL LCO2CR,LINTPT
120 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
121 & LCO2CR,LINTPT
122* threshold values for x-sampling (DTUNUC 1.x)
123 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
124 & SSMIMQ,VVMTHR
125* flags for input different options
126 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
127 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
128 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
129* nuclear potential
130 LOGICAL LFERMI
131 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
132 & EBINDP(2),EBINDN(2),EPOT(2,210),
133 & ETACOU(2),ICOUL,LFERMI
134* n-n cross section fluctuations
135 PARAMETER (NBINS = 1000)
136 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
137* flags for particle decays
138 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
139 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
140 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
141* diquark-breaking mechanism
142 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
143* nucleon-nucleon event-generator
144 CHARACTER*8 CMODEL
145 LOGICAL LPHOIN
146 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
147* properties of interacting particles
148 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
149* properties of photon/lepton projectiles
150 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
151* flags for diffractive interactions (DTUNUC 1.x)
152 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
153* parameters for hA-diffraction
154 COMMON /DTDIHA/ DIBETA,DIALPH
155* Lorentz-parameters of the current interaction
156 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
157 & UMO,PPCM,EPROJ,PPROJ
158* kinematical cuts for lepton-nucleus interactions
159 COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
160 & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
161* VDM parameter for photon-nucleus interactions
162 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
163* Glauber formalism: flags and parameters for statistics
164 LOGICAL LPROD
165 CHARACTER*8 CGLB
166 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
167* cuts for variable energy runs
168 COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
169* flags for activated histograms
170 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
171 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
bd378884 172 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
9aaba0d6 173* LEPTO
174**LUND single / double precision
175 REAL CUT,PARL,TMPX,TMPY,TMPW2,TMPQ2,TMPU
176 COMMON /LEPTOU/ CUT(14),LST(40),PARL(30),
177 & TMPX,TMPY,TMPW2,TMPQ2,TMPU
178* LEPTO
179 REAL RPPN
180 COMMON /LEPTOI/ RPPN,LEPIN,INTER
181* steering flags for qel neutrino scattering modules
182 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
183* event flag
184 COMMON /DTEVNO/ NEVENT,ICASCA
185
186 INTEGER PYCOMP
187
188C DIMENSION XPARA(5)
189 DIMENSION XDUMB(40),IPRANG(5)
190
191 PARAMETER (MXCARD=58)
192 CHARACTER*78 CLINE,CTITLE
193 CHARACTER*60 CWHAT
194 CHARACTER*8 BLANK,SDUM
195 CHARACTER*10 CODE,CODEWD
196 CHARACTER*72 HEADER
197 LOGICAL LSTART,LEINP,LXSTAB
198 DIMENSION WHAT(6),CODE(MXCARD)
199 DATA CODE/
200 & 'TITLE ','PROJPAR ','TARPAR ','ENERGY ',
201 & 'MOMENTUM ','CMENERGY ','EMULSION ','FERMI ',
202 & 'TAUFOR ','PAULI ','COULOMB ','HADRIN ',
203 & 'EVAP ','EMCCHECK ','MODEL ','PHOINPUT ',
204 & 'GLAUBERI ','FLUCTUAT ','CENTRAL ','RECOMBIN ',
205 & 'COMBIJET ','XCUTS ','INTPT ','CRONINPT ',
206 & 'SEADISTR ','SEASU3 ','DIQUARKS ','RESONANC ',
207 & 'DIFFRACT ','SINGLECH ','NOFRAGME ','HADRONIZE ',
208 & 'POPCORN ','PARDECAY ','BEAM ','LUND-MSTU ',
209 & 'LUND-MSTJ ','LUND-MDCY ','LUND-PARJ ','LUND-PARU ',
210 & 'OUTLEVEL ','FRAME ','L-TAG ','L-ETAG ',
211 & 'ECMS-CUT ','VDM-PAR1 ','HISTOGRAM ','XS-TABLE ',
212 & 'GLAUB-PAR ','GLAUB-INI ','VDM-PAR2 ','XS-QELPRO ',
213 & 'RNDMINIT ','LEPTO-CUT ','LEPTO-LST ','LEPTO-PARL',
214 & 'START ','STOP '/
215 DATA BLANK /' '/
216
217 DATA LSTART,LXSTAB,IFIRST /.TRUE.,.FALSE.,1/
218 DATA CMEOLD /0.0D0/
219
220*---------------------------------------------------------------------
221* at the first call of INIT: initialize event generation
222 EPNSAV = EPN
223 IF (LSTART) THEN
224 CALL DT_TITLE
225* initialization and test of the random number generator
226 IF (ITRSPT.NE.1) THEN
227 CALL DT_RNDMST(22,54,76,92)
228 CALL DT_RNDMTE(1)
229 ENDIF
230* initialization of BAMJET, DECAY and HADRIN
231 CALL DT_DDATAR
232 CALL DT_DHADDE
233 CALL DT_DCHANT
234 CALL DT_DCHANH
235* set default values for input variables
236 CALL DT_DEFAUL(EPN,PPN)
237 IGLAU = 0
238 IXSQEL = 0
239* flag for collision energy input
240 LEINP = .FALSE.
241 LSTART = .FALSE.
242 ENDIF
243
244*---------------------------------------------------------------------
245 10 CONTINUE
246
247* bypass reading input cards (e.g. for use with Fluka)
248* in this case Epn is expected to carry the beam momentum
249 IF (NCASES.EQ.-1) THEN
250 IP = NPMASS
251 IPZ = NPCHAR
252 PPN = EPNSAV
253 EPN = ZERO
254 CMENER = ZERO
255 LEINP = .TRUE.
256 MKCRON = 0
257 WHAT(1) = 1
258 WHAT(2) = 0
259 CODEWD = 'START '
260 GOTO 900
261 ENDIF
262
263* read control card from input-unit LINP
264 READ(LINP,'(A78)',END=9999) CLINE
265 IF (CLINE(1:1).EQ.'*') THEN
266* comment-line
267 WRITE(LOUT,'(A78)') CLINE
268 GOTO 10
269 ENDIF
270C READ(CLINE,1000,END=9999) CODEWD,(WHAT(I),I=1,6),SDUM
271C1000 FORMAT(A10,6E10.0,A8)
272 DO 1008 I=1,6
273 WHAT(I) = ZERO
274 1008 CONTINUE
275 READ(CLINE,1006,END=9999) CODEWD,CWHAT,SDUM
276 1006 FORMAT(A10,A60,A8)
277 READ(CWHAT,*,END=1007) (WHAT(I),I=1,6)
278 1007 CONTINUE
279 WRITE(LOUT,1001) CODEWD,(WHAT(I),I=1,6),SDUM
280 1001 FORMAT(A10,6G10.3,A8)
281
282 900 CONTINUE
283
284* check for valid control card and get card index
285 ICW = 0
286 DO 11 I=1,MXCARD
287 IF (CODEWD.EQ.CODE(I)) ICW = I
288 11 CONTINUE
289 IF (ICW.EQ.0) THEN
290 WRITE(LOUT,1002) CODEWD
291 1002 FORMAT(/,1X,'---> ',A10,': invalid control-card !',/)
292 GOTO 10
293 ENDIF
294
295 GOTO(
296*------------------------------------------------------------
297* TITLE , PROJPAR , TARPAR , ENERGY , MOMENTUM,
298 & 100 , 110 , 120 , 130 , 140 ,
299*
300*------------------------------------------------------------
301* CMENERGY, EMULSION, FERMI , TAUFOR , PAULI ,
302 & 150 , 160 , 170 , 180 , 190 ,
303*
304*------------------------------------------------------------
305* COULOMB , HADRIN , EVAP , EMCCHECK, MODEL ,
306 & 200 , 210 , 220 , 230 , 240 ,
307*
308*------------------------------------------------------------
309* PHOINPUT, GLAUBERI, FLUCTUAT, CENTRAL , RECOMBIN,
310 & 250 , 260 , 270 , 280 , 290 ,
311*
312*------------------------------------------------------------
313* COMBIJET, XCUTS , INTPT , CRONINPT, SEADISTR,
314 & 300 , 310 , 320 , 330 , 340 ,
315*
316*------------------------------------------------------------
317* SEASU3 , DIQUARKS, RESONANC, DIFFRACT, SINGLECH,
318 & 350 , 360 , 370 , 380 , 390 ,
319*
320*------------------------------------------------------------
321* NOFRAGME, HADRONIZE, POPCORN , PARDECAY, BEAM ,
322 & 400 , 410 , 420 , 430 , 440 ,
323*
324*------------------------------------------------------------
325* LUND-MSTU, LUND-MSTJ, LUND-MDCY, LUND-PARJ, LUND-PARU,
326 & 450 , 451 , 452 , 460 , 470 ,
327*
328*------------------------------------------------------------
329* OUTLEVEL, FRAME , L-TAG , L-ETAG , ECMS-CUT,
330 & 480 , 490 , 500 , 510 , 520 ,
331*
332*------------------------------------------------------------
333* VDM-PAR1, HISTOGRAM, XS-TABLE , GLAUB-PAR, GLAUB-INI,
334 & 530 , 540 , 550 , 560 , 565 ,
335*
336*------------------------------------------------------------
337* , , VDM-PAR2, XS-QELPRO, RNDMINIT ,
338 & 570 , 580 , 590 ,
339*
340*------------------------------------------------------------
341* LEPTO-CUT, LEPTO-LST,LEPTO-PARL, START , STOP )
342 & 600 , 610 , 620 , 630 , 640 ) , ICW
343*
344*------------------------------------------------------------
345
346 GOTO 10
347
348*********************************************************************
349* *
350* control card: codewd = TITLE *
351* *
352* what (1..6), sdum no meaning *
353* *
354* Note: The control-card following this must consist of *
355* a string of characters usually giving the title of *
356* the run. *
357* *
358*********************************************************************
359
360 100 CONTINUE
361 READ(LINP,'(A78)') CTITLE
362 WRITE(LOUT,'(//,5X,A78,//)') CTITLE
363 GOTO 10
364
365*********************************************************************
366* *
367* control card: codewd = PROJPAR *
368* *
369* what (1) = mass number of projectile nucleus default: 1 *
370* what (2) = charge of projectile nucleus default: 1 *
371* what (3..6) no meaning *
372* sdum projectile particle code word *
373* *
374* Note: If sdum is defined what (1..2) have no meaning. *
375* *
376*********************************************************************
377
378 110 CONTINUE
379 IF (SDUM.EQ.BLANK) THEN
380 IP = INT(WHAT(1))
381 IPZ = INT(WHAT(2))
382 IJPROJ = 1
383 IBPROJ = 1
384 ELSE
385 IJPROJ = 0
386 DO 111 II=1,30
387 IF (SDUM.EQ.BTYPE(II)) THEN
388 IP = 1
389 IPZ = 1
390 IF (II.EQ.26) THEN
391 IJPROJ = 135
392 ELSEIF (II.EQ.27) THEN
393 IJPROJ = 136
394 ELSEIF (II.EQ.28) THEN
395 IJPROJ = 133
396 ELSEIF (II.EQ.29) THEN
397 IJPROJ = 134
398 ELSE
399 IJPROJ = II
400 ENDIF
401 IBPROJ = IIBAR(IJPROJ)
402* photon
403 IF ((IJPROJ.EQ.7).AND.(WHAT(1).GT.ZERO)) VIRT = WHAT(1)
404* lepton
405 IF (((IJPROJ.EQ. 3).OR.(IJPROJ.EQ. 4).OR.
406 & (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11)).AND.
407 & (WHAT(1).GT.ZERO)) Q2HI = WHAT(1)
408 ENDIF
409 111 CONTINUE
410 IF (IJPROJ.EQ.0) THEN
411 WRITE(LOUT,1110)
412 1110 FORMAT(/,1X,'invalid PROJPAR card !',/)
413 GOTO 9999
414 ENDIF
415 ENDIF
416 GOTO 10
417
418*********************************************************************
419* *
420* control card: codewd = TARPAR *
421* *
422* what (1) = mass number of target nucleus default: 1 *
423* what (2) = charge of target nucleus default: 1 *
424* what (3..6) no meaning *
425* sdum target particle code word *
426* *
427* Note: If sdum is defined what (1..2) have no meaning. *
428* *
429*********************************************************************
430
431 120 CONTINUE
432 IF (SDUM.EQ.BLANK) THEN
433 IT = INT(WHAT(1))
434 ITZ = INT(WHAT(2))
435 IJTARG = 1
436 IBTARG = 1
437 ELSE
438 IJTARG = 0
439 DO 121 II=1,30
440 IF (SDUM.EQ.BTYPE(II)) THEN
441 IT = 1
442 ITZ = 1
443 IJTARG = II
444 IBTARG = IIBAR(IJTARG)
445 ENDIF
446 121 CONTINUE
447 IF (IJTARG.EQ.0) THEN
448 WRITE(LOUT,1120)
449 1120 FORMAT(/,1X,'invalid TARPAR card !',/)
450 GOTO 9999
451 ENDIF
452 ENDIF
453 GOTO 10
454
455*********************************************************************
456* *
457* control card: codewd = ENERGY *
458* *
459* what (1) = energy (GeV) of projectile in Lab. *
460* if what(1) < 0: |what(1)| = kinetic energy *
461* default: 200 GeV *
462* if |what(2)| > 0: min. energy for variable *
463* energy runs *
464* what (2) = max. energy for variable energy runs *
465* if what(2) < 0: |what(2)| = kinetic energy *
466* *
467*********************************************************************
468
469 130 CONTINUE
470 EPN = WHAT(1)
471 PPN = ZERO
472 CMENER = ZERO
473 IF ((ABS(WHAT(2)).GT.ZERO).AND.
474 & (ABS(WHAT(2)).GT.ABS(WHAT(1)))) THEN
475 VARELO = WHAT(1)
476 VAREHI = WHAT(2)
477 EPN = VAREHI
478 ENDIF
479 LEINP = .TRUE.
480 GOTO 10
481
482*********************************************************************
483* *
484* control card: codewd = MOMENTUM *
485* *
486* what (1) = momentum (GeV/c) of projectile in Lab. *
487* default: 200 GeV/c *
488* what (2..6), sdum no meaning *
489* *
490*********************************************************************
491
492 140 CONTINUE
493 EPN = ZERO
494 PPN = WHAT(1)
495 CMENER = ZERO
496 LEINP = .TRUE.
497 GOTO 10
498
499*********************************************************************
500* *
501* control card: codewd = CMENERGY *
502* *
503* what (1) = energy in nucleon-nucleon cms. *
504* default: none *
505* what (2..6), sdum no meaning *
506* *
507*********************************************************************
508
509 150 CONTINUE
510 EPN = ZERO
511 PPN = ZERO
512 CMENER = WHAT(1)
513 LEINP = .TRUE.
514 GOTO 10
515
516*********************************************************************
517* *
518* control card: codewd = EMULSION *
519* *
520* definition of nuclear emulsions *
521* *
522* what(1) mass number of emulsion component *
523* what(2) charge of emulsion component *
524* what(3) fraction of events in which a scattering on a *
525* nucleus of this properties is performed *
526* what(4,5,6) as what(1,2,3) but for another component *
527* default: no emulsion *
528* sdum no meaning *
529* *
530* Note: If this input-card is once used with valid parameters *
531* TARPAR is obsolete. *
532* Not the absolute values of the fractions are important *
533* but only the ratios of fractions of different comp. *
534* This control card can be repeatedly used to define *
535* emulsions consisting of up to 10 elements. *
536* *
537*********************************************************************
538
539 160 CONTINUE
540 IF ((WHAT(1).GT.ZERO).AND.(WHAT(2).GT.ZERO)
541 & .AND.(ABS(WHAT(3)).GT.ZERO)) THEN
542 NCOMPO = NCOMPO+1
543 IF (NCOMPO.GT.NCOMPX) THEN
544 WRITE(LOUT,1600)
545 STOP
546 ENDIF
547 IEMUMA(NCOMPO) = INT(WHAT(1))
548 IEMUCH(NCOMPO) = INT(WHAT(2))
549 EMUFRA(NCOMPO) = WHAT(3)
550 IEMUL = 1
551C CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO))
552 ENDIF
553 IF ((WHAT(4).GT.ZERO).AND.(WHAT(5).GT.ZERO)
554 & .AND.(ABS(WHAT(6)).GT.ZERO)) THEN
555 NCOMPO = NCOMPO+1
556 IF (NCOMPO.GT.NCOMPX) THEN
557 WRITE(LOUT,1001)
558 STOP
559 ENDIF
560 IEMUMA(NCOMPO) = INT(WHAT(4))
561 IEMUCH(NCOMPO) = INT(WHAT(5))
562 EMUFRA(NCOMPO) = WHAT(6)
563C CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO))
564 ENDIF
565 1600 FORMAT(1X,'too many emulsion components - program stopped')
566 GOTO 10
567
568*********************************************************************
569* *
570* control card: codewd = FERMI *
571* *
572* what (1) = -1 Fermi-motion of nucleons not treated *
573* default: 1 *
574* what (2) = scale factor for Fermi-momentum *
575* default: 0.75 *
576* what (3..6), sdum no meaning *
577* *
578*********************************************************************
579
580 170 CONTINUE
581 IF (WHAT(1).EQ.-1.0D0) THEN
582 LFERMI = .FALSE.
583 ELSE
584 LFERMI = .TRUE.
585 ENDIF
586 XMOD = WHAT(2)
587 IF (XMOD.GE.ZERO) FERMOD = XMOD
588 GOTO 10
589
590*********************************************************************
591* *
592* control card: codewd = TAUFOR *
593* *
594* formation time supressed intranuclear cascade *
595* *
596* what (1) formation time (in fm/c) *
597* note: what(1)=10. corresponds roughly to an *
598* average formation time of 1 fm/c *
599* default: 5. fm/c *
600* what (2) number of generations followed *
601* default: 25 *
602* what (3) = 1. p_t-dependent formation zone *
603* = 2. constant formation zone *
604* default: 1 *
605* what (4) modus of selection of nucleus where the *
606* cascade if followed first *
607* = 1. proj./target-nucleus with probab. 1/2 *
608* = 2. nucleus with highest mass *
609* = 3. proj. nucleus if particle is moving in pos. z *
610* targ. nucleus if particle is moving in neg. z *
611* default: 1 *
612* what (5..6), sdum no meaning *
613* *
614*********************************************************************
615
616 180 CONTINUE
617 TAUFOR = WHAT(1)
618 KTAUGE = INT(WHAT(2))
619 INCMOD = 1
620 IF ((WHAT(3).GE.1.0D0).AND.(WHAT(3).LE.2.0D0))
621 & ITAUVE = INT(WHAT(3))
622 IF ((WHAT(4).GE.1.0D0).AND.(WHAT(4).LE.3.0D0))
623 & INCMOD = INT(WHAT(4))
624 GOTO 10
625
626*********************************************************************
627* *
628* control card: codewd = PAULI *
629* *
630* what (1) = -1 Pauli's principle for secondary *
631* interactions not treated *
632* default: 1 *
633* what (2..6), sdum no meaning *
634* *
635*********************************************************************
636
637 190 CONTINUE
638 IF (WHAT(1).EQ.-1.0D0) THEN
639 LPAULI = .FALSE.
640 ELSE
641 LPAULI = .TRUE.
642 ENDIF
643 GOTO 10
644
645*********************************************************************
646* *
647* control card: codewd = COULOMB *
648* *
649* what (1) = -1. Coulomb-energy treatment switched off *
650* default: 1 *
651* what (2..6), sdum no meaning *
652* *
653*********************************************************************
654
655 200 CONTINUE
656 ICOUL = 1
657 IF (WHAT(1).EQ.-1.0D0) THEN
658 ICOUL = 0
659 ELSE
660 ICOUL = 1
661 ENDIF
662 GOTO 10
663
664*********************************************************************
665* *
666* control card: codewd = HADRIN *
667* *
668* HADRIN module *
669* *
670* what (1) = 0. elastic/inelastic interactions with probab. *
671* as defined by cross-sections *
672* = 1. inelastic interactions forced *
673* = 2. elastic interactions forced *
674* default: 1 *
675* what (2) upper threshold in total energy (GeV) below *
676* which interactions are sampled by HADRIN *
677* default: 5. GeV *
678* what (3..6), sdum no meaning *
679* *
680*********************************************************************
681
682 210 CONTINUE
683 IWHAT = INT(WHAT(1))
684 IF ((IWHAT.GE.0).AND.(IWHAT.LE.2)) INTHAD = IWHAT
685 IF ((WHAT(2).GT.ZERO).AND.(WHAT(2).LT.15.0D0)) EHADTH = WHAT(2)
686 GOTO 10
687
688*********************************************************************
689* *
690* control card: codewd = EVAP *
691* *
692* evaporation module *
693* *
694* what (1) =< -1 ==> evaporation is switched off *
695* >= 1 ==> evaporation is performed *
696* *
697* what (1) = i1 + i2*10 + i3*100 + i4*10000 *
698* (i1, i2, i3, i4 >= 0 ) *
699* *
700* i1 is the flag for selecting the T=0 level density option used *
701* = 1: standard EVAP level densities with Cook pairing *
702* energies *
703* = 2: Z,N-dependent Gilbert & Cameron level densities *
704* (default) *
705* = 3: Julich A-dependent level densities *
706* = 4: Z,N-dependent Brancazio & Cameron level densities *
707* *
708* i2 >= 1: high energy fission activated *
709* (default high energy fission activated) *
710* *
711* i3 = 0: No energy dependence for level densities *
712* = 1: Standard Ignyatuk (1975, 1st) energy dependence *
713* for level densities (default) *
714* = 2: Standard Ignyatuk (1975, 1st) energy dependence *
715* for level densities with NOT used set of parameters *
716* = 3: Standard Ignyatuk (1975, 1st) energy dependence *
717* for level densities with NOT used set of parameters *
718* = 4: Second Ignyatuk (1975, 2nd) energy dependence *
719* for level densities *
720* = 5: Second Ignyatuk (1975, 2nd) energy dependence *
721* for level densities with fit 1 Iljinov & Mebel set of *
722* parameters *
723* = 6: Second Ignyatuk (1975, 2nd) energy dependence *
724* for level densities with fit 2 Iljinov & Mebel set of *
725* parameters *
726* = 7: Second Ignyatuk (1975, 2nd) energy dependence *
727* for level densities with fit 3 Iljinov & Mebel set of *
728* parameters *
729* = 8: Second Ignyatuk (1975, 2nd) energy dependence *
730* for level densities with fit 4 Iljinov & Mebel set of *
731* parameters *
732* *
733* i4 >= 1: Original Gilbert and Cameron pairing energies used *
734* (default Cook's modified pairing energies) *
735* *
736* what (2) = ig + 10 * if (ig and if must have the same sign) *
737* *
738* ig =< -1 ==> deexcitation gammas are not produced *
739* (if the evaporation step is not performed *
740* they are never produced) *
741* if =< -1 ==> Fermi Break Up is not invoked *
742* (if the evaporation step is not performed *
743* it is never invoked) *
744* The default is: deexcitation gamma produced and Fermi break up *
745* activated for the new preequilibrium, not *
746* activated otherwise. *
747* what (3..6), sdum no meaning *
748* *
749*********************************************************************
750
751 220 CONTINUE
752 WRITE(LOUT,1009)
753 1009 FORMAT(1X,/,'Warning! Evaporation request rejected since',
754 & ' evaporation modules not available with this version.')
755 LEVPRT = .FALSE.
756 LDEEXG = .FALSE.
757 LHEAVY = .FALSE.
758 LFRMBK = .FALSE.
759 IFISS = 0
760 IEVFSS = 0
761
762 GOTO 10
763
764*********************************************************************
765* *
766* control card: codewd = EMCCHECK *
767* *
768* extended energy-momentum / quantum-number conservation check *
769* *
770* what (1) = -1 extended check not performed *
771* default: 1. *
772* what (2..6), sdum no meaning *
773* *
774*********************************************************************
775
776 230 CONTINUE
777 IF (WHAT(1).EQ.-1) THEN
778 LEMCCK = .FALSE.
779 ELSE
780 LEMCCK = .TRUE.
781 ENDIF
782 GOTO 10
783
784*********************************************************************
785* *
786* control card: codewd = MODEL *
787* *
788* Model to be used to treat nucleon-nucleon interactions *
789* *
790* sdum = DTUNUC two-chain model *
791* = PHOJET multiple chains including minijets *
792* = LEPTO DIS *
793* = QNEUTRIN quasi-elastic neutrino scattering *
794* default: PHOJET *
795* *
796* if sdum = LEPTO: *
797* what (1) (variable INTER) *
798* = 1 gamma exchange *
799* = 2 W+- exchange *
800* = 3 Z0 exchange *
801* = 4 gamma/Z0 exchange *
802* *
803* if sdum = QNEUTRIN: *
804* what (1) = 0 elastic scattering on nucleon and *
805* tau does not decay (default) *
806* = 1 decay of tau into mu.. *
807* = 2 decay of tau into e.. *
808* = 10 CC events on p and n *
809* = 11 NC events on p and n *
810* *
811* what (2..6) no meaning *
812* *
813*********************************************************************
814
815 240 CONTINUE
816 IF (SDUM.EQ.CMODEL(1)) THEN
817 MCGENE = 1
818 ELSEIF (SDUM.EQ.CMODEL(2)) THEN
819 MCGENE = 2
820 ELSEIF (SDUM.EQ.CMODEL(3)) THEN
821 MCGENE = 3
822 IF ((WHAT(1).GE.1.0D0).AND.(WHAT(1).LE.4.0D0))
823 & INTER = INT(WHAT(1))
824 ELSEIF (SDUM.EQ.CMODEL(4)) THEN
825 MCGENE = 4
826 IWHAT = INT(WHAT(1))
827 IF ((IWHAT.EQ.1 ).OR.(IWHAT.EQ.2 ).OR.
828 & (IWHAT.EQ.10).OR.(IWHAT.EQ.11))
829 & NEUDEC = IWHAT
830 ELSE
831 STOP ' Unknown model !'
832 ENDIF
833 GOTO 10
834
835*********************************************************************
836* *
837* control card: codewd = PHOINPUT *
838* *
839* Start of input-section for PHOJET-specific input-cards *
840* Note: This section will not be finished before giving *
841* ENDINPUT-card *
842* what (1..6), sdum no meaning *
843* *
844*********************************************************************
845
846 250 CONTINUE
847 IF (LPHOIN) THEN
848 CALL PHO_INIT(LINP,LOUT,IREJ1)
849 IF (IREJ1.NE.0) THEN
850 WRITE(LOUT,'(1X,A)')'INIT: reading PHOJET-input failed'
851 STOP
852 ENDIF
853 LPHOIN = .FALSE.
854 ENDIF
855 GOTO 10
856
857*********************************************************************
858* *
859* control card: codewd = GLAUBERI *
860* *
861* Pre-initialization of impact parameter selection *
862* *
863* what (1..6), sdum no meaning *
864* *
865*********************************************************************
866
867 260 CONTINUE
868 IF (IFIRST.NE.99) THEN
869 CALL DT_RNDMST(12,34,56,78)
870 CALL DT_RNDMTE(1)
871 OPEN(40,FILE='outdata0/shm.out',STATUS='UNKNOWN')
872C OPEN(11,FILE='outdata0/shm.dbg',STATUS='UNKNOWN')
873 IFIRST = 99
874 ENDIF
875
876 IPPN = 8
877 PLOW = 10.0D0
878C IPPN = 1
879C PLOW = 100.0D0
880 PHI = 1.0D5
881 APLOW = LOG10(PLOW)
882 APHI = LOG10(PHI)
883 ADP = (APHI-APLOW)/DBLE(IPPN)
884
885 IPLOW = 1
886 IDIP = 1
887 IIP = 5
888C IPLOW = 1
889C IDIP = 1
890C IIP = 1
891 IPRANG(1) = 1
892 IPRANG(2) = 2
893 IPRANG(3) = 5
894 IPRANG(4) = 10
895 IPRANG(5) = 20
896
897 ITLOW = 30
898 IDIT = 3
899 IIT = 60
900C IDIT = 10
901C IIT = 21
902
903 DO 473 NCIT=1,IIT
904 IT = ITLOW+(NCIT-1)*IDIT
905C IPHI = IT
906C IDIP = 10
907C IIP = (IPHI-IPLOW)/IDIP
908C IF (IIP.EQ.0) IIP = 1
909C IF (IT.EQ.IPLOW) IIP = 0
910
911 DO 472 NCIP=1,IIP
912 IP = IPRANG(NCIP)
913CC IF (NCIP.LE.IIP) THEN
914C IP = IPLOW+(NCIP-1)*IDIP
915CC ELSE
916CC IP = IT
917CC ENDIF
918 IF (IP.GT.IT) GOTO 472
919
920 DO 471 NCP=1,IPPN+1
921 APPN = APLOW+DBLE(NCP-1)*ADP
922 PPN = 10**APPN
923
924 OPEN(12,FILE='outdata0/shm.sta',STATUS='UNKNOWN')
925 WRITE(12,'(1X,2I5,E15.3)') IP,IT,PPN
926 CLOSE(12)
927
928 XLIM1 = 0.0D0
929 XLIM2 = 50.0D0
930 XLIM3 = ZERO
931 IBIN = 50
932 CALL DT_NEWHGR(XDUM,XDUM,XDUM,XDUMB,-1,IHDUM)
933 CALL DT_NEWHGR(XLIM1,XLIM2,XLIM3,XDUMB,IBIN,IHSHMA)
934
935 NEVFIT = 5
936C IF ((IP.GT.10).OR.(IT.GT.10)) THEN
937C NEVFIT = 5
938C ELSE
939C NEVFIT = 10
940C ENDIF
941 SIGAV = 0.0D0
942
943 DO 478 I=1,NEVFIT
944 CALL DT_SHMAKI(IP,IDUM1,IT,IDUM1,IJPROJ,PPN,99)
945 SIGAV = SIGAV+XSPRO(1,1,1)
946 DO 479 J=1,50
947 XC = DBLE(J)
948 CALL DT_FILHGR(XC,BSITE(1,1,1,J),IHSHMA,I)
949 479 CONTINUE
950 478 CONTINUE
951
952 CALL DT_EVTHIS(IDUM)
953 HEADER = ' BSITE'
954C CALL OUTGEN(IHSHMA,0,0,0,0,0,HEADER,0,NEVFIT,ONE,0,1,-1)
955
956C CALL GENFIT(XPARA)
957C WRITE(40,'(2I4,E11.3,F6.0,5E11.3)')
958C & IP,IT,PPN,SIGAV/DBLE(NEVFIT),XPARA
959
960 471 CONTINUE
961
962 472 CONTINUE
963
964 473 CONTINUE
965
966 STOP
967
968*********************************************************************
969* *
970* control card: codewd = FLUCTUAT *
971* *
972* Treatment of cross section fluctuations *
973* *
974* what (1) = 1 treat cross section fluctuations *
975* default: 0. *
976* what (1..6), sdum no meaning *
977* *
978*********************************************************************
979
980 270 CONTINUE
981 IFLUCT = 0
982 IF (WHAT(1).EQ.ONE) THEN
983 IFLUCT = 1
984 CALL DT_FLUINI
985 ENDIF
986 GOTO 10
987
988*********************************************************************
989* *
990* control card: codewd = CENTRAL *
991* *
992* what (1) = 1. central production forced default: 0 *
993* if what (1) < 0 and > -100 *
994* what (2) = min. impact parameter default: 0 *
995* what (3) = max. impact parameter default: b_max *
996* if what (1) < -99 *
997* what (2) = fraction of cross section default: 1 *
998* if what (1) = -1 : evaporation/fzc suppressed *
999* if what (1) < -1 : evaporation/fzc allowed *
1000* *
1001* what (4..6), sdum no meaning *
1002* *
1003*********************************************************************
1004
1005 280 CONTINUE
1006 ICENTR = INT(WHAT(1))
1007 IF (ICENTR.LT.0) THEN
1008 IF (ICENTR.GT.-100) THEN
1009 BIMIN = WHAT(2)
1010 BIMAX = WHAT(3)
1011 ELSE
1012 XSFRAC = WHAT(2)
1013 ENDIF
1014 ENDIF
1015 GOTO 10
1016
1017*********************************************************************
1018* *
1019* control card: codewd = RECOMBIN *
1020* *
1021* Chain recombination *
1022* (recombine S-S and V-V chains to V-S chains) *
1023* *
1024* what (1) = -1. recombination switched off default: 1 *
1025* what (2..6), sdum no meaning *
1026* *
1027*********************************************************************
1028
1029 290 CONTINUE
1030 IRECOM = 1
1031 IF (WHAT(1).EQ.-1.0D0) IRECOM = 0
1032 GOTO 10
1033
1034*********************************************************************
1035* *
1036* control card: codewd = COMBIJET *
1037* *
1038* chain fusion (2 q-aq --> qq-aqaq) *
1039* *
1040* what (1) = 1 fusion treated *
1041* default: 0. *
1042* what (2) minimum number of uncombined chains from *
1043* single projectile or target nucleons *
1044* default: 0. *
1045* what (3..6), sdum no meaning *
1046* *
1047*********************************************************************
1048
1049 300 CONTINUE
1050 LCO2CR = .FALSE.
1051 IF (INT(WHAT(1)).EQ.1) LCO2CR = .TRUE.
1052 IF (WHAT(2).GE.ZERO) CUTOF = WHAT(2)
1053 GOTO 10
1054
1055*********************************************************************
1056* *
1057* control card: codewd = XCUTS *
1058* *
1059* thresholds for x-sampling *
1060* *
1061* what (1) defines lower threshold for val.-q x-value (CVQ) *
1062* default: 1. *
1063* what (2) defines lower threshold for val.-qq x-value (CDQ) *
1064* default: 2. *
1065* what (3) defines lower threshold for sea-q x-value (CSEA) *
1066* default: 0.2 *
1067* what (4) sea-q x-values in S-S chains (SSMIMA) *
1068* default: 0.14 *
1069* what (5) not used *
1070* default: 2. *
1071* what (6), sdum no meaning *
1072* *
1073* Note: Lower thresholds (what(1..3)) are def. as x_thr=CXXX/ECM *
1074* *
1075*********************************************************************
1076
1077 310 CONTINUE
1078 IF (WHAT(1).GE.0.5D0) CVQ = WHAT(1)
1079 IF (WHAT(2).GE.ONE) CDQ = WHAT(2)
1080 IF (WHAT(3).GE.0.1D0) CSEA = WHAT(3)
1081 IF (WHAT(4).GE.ZERO) THEN
1082 SSMIMA = WHAT(4)
1083 SSMIMQ = SSMIMA**2
1084 ENDIF
1085 IF (WHAT(5).GT.2.0D0) VVMTHR = WHAT(5)
1086 GOTO 10
1087
1088*********************************************************************
1089* *
1090* control card: codewd = INTPT *
1091* *
1092* what (1) = -1 intrinsic transverse momenta of partons *
1093* not treated default: 1 *
1094* what (2..6), sdum no meaning *
1095* *
1096*********************************************************************
1097
1098 320 CONTINUE
1099 IF (WHAT(1).EQ.-1.0D0) THEN
1100 LINTPT = .FALSE.
1101 ELSE
1102 LINTPT = .TRUE.
1103 ENDIF
1104 GOTO 10
1105
1106*********************************************************************
1107* *
1108* control card: codewd = CRONINPT *
1109* *
1110* Cronin effect (multiple scattering of partons at chain ends) *
1111* *
1112* what (1) = -1 Cronin effect not treated default: 1 *
1113* what (2) = 0 scattering parameter default: 0.64 *
1114* what (3..6), sdum no meaning *
1115* *
1116*********************************************************************
1117
1118 330 CONTINUE
1119 IF (WHAT(1).EQ.-1.0D0) THEN
1120 MKCRON = 0
1121 ELSE
1122 MKCRON = 1
1123 ENDIF
1124 CRONCO = WHAT(2)
1125 GOTO 10
1126
1127*********************************************************************
1128* *
1129* control card: codewd = SEADISTR *
1130* *
1131* what (1) (XSEACO) sea(x) prop. 1/x**what (1) default: 1. *
1132* what (2) (UNON) default: 2. *
1133* what (3) (UNOM) default: 1.5 *
1134* what (4) (UNOSEA) default: 5. *
1135* qdis(x) prop. (1-x)**what (1) etc. *
1136* what (5..6), sdum no meaning *
1137* *
1138*********************************************************************
1139
1140 340 CONTINUE
1141 XSEACO = WHAT(1)
1142 XSEACU = 1.05D0-XSEACO
1143 UNON = WHAT(2)
1144 IF (UNON.LT.0.1D0) UNON = 2.0D0
1145 UNOM = WHAT(3)
1146 IF (UNOM.LT.0.1D0) UNOM = 1.5D0
1147 UNOSEA = WHAT(4)
1148 IF (UNOSEA.LT.0.1D0) UNOSEA = 5.0D0
1149 GOTO 10
1150
1151*********************************************************************
1152* *
1153* control card: codewd = SEASU3 *
1154* *
1155* Treatment of strange-quarks at chain ends *
1156* *
1157* what (1) (SEASQ) strange-quark supression factor *
1158* iflav = 1.+rndm*(2.+SEASQ) *
1159* default: 1. *
1160* what (2..6), sdum no meaning *
1161* *
1162*********************************************************************
1163
1164 350 CONTINUE
1165 SEASQ = WHAT(1)
1166 GOTO 10
1167
1168*********************************************************************
1169* *
1170* control card: codewd = DIQUARKS *
1171* *
1172* what (1) = -1. sea-diquark/antidiquark-pairs not treated *
1173* default: 1. *
1174* what (2..6), sdum no meaning *
1175* *
1176*********************************************************************
1177
1178 360 CONTINUE
1179 IF (WHAT(1).EQ.-1.0D0) THEN
1180 LSEADI = .FALSE.
1181 ELSE
1182 LSEADI = .TRUE.
1183 ENDIF
1184 GOTO 10
1185
1186*********************************************************************
1187* *
1188* control card: codewd = RESONANC *
1189* *
1190* treatment of low mass chains *
1191* *
1192* what (1) = -1 low chain masses are not corrected for resonance *
1193* masses (obsolete for BAMJET-fragmentation) *
1194* default: 1. *
1195* what (2) = -1 massless partons default: 1. (massive) *
1196* default: 1. (massive) *
1197* what (3) = -1 chain-system containing chain of too small *
1198* mass is rejected (note: this does not fully *
1199* apply to S-S chains) default: 0. *
1200* what (4..6), sdum no meaning *
1201* *
1202*********************************************************************
1203
1204 370 CONTINUE
1205 IRESCO = 1
1206 IMSHL = 1
1207 IRESRJ = 0
1208 IF (WHAT(1).EQ.-ONE) IRESCO = 0
1209 IF (WHAT(2).EQ.-ONE) IMSHL = 0
1210 IF (WHAT(3).EQ.-ONE) IRESRJ = 1
1211 GOTO 10
1212
1213*********************************************************************
1214* *
1215* control card: codewd = DIFFRACT *
1216* *
1217* Treatment of diffractive events *
1218* *
1219* what (1) = (ISINGD) 0 no single diffraction *
1220* 1 single diffraction included *
1221* +-2 single diffractive events only *
1222* +-3 projectile single diffraction only *
1223* +-4 target single diffraction only *
1224* -5 double pomeron exchange only *
1225* (neg. sign applies to PHOJET events) *
1226* default: 0. *
1227* *
1228* what (2) = (IDOUBD) 0 no double diffraction *
1229* 1 double diffraction included *
1230* 2 double diffractive events only *
1231* default: 0. *
1232* what (3) = 1 projectile diffraction treated (2-channel form.) *
1233* default: 0. *
1234* what (4) = alpha-parameter in projectile diffraction *
1235* default: 0. *
1236* what (5..6), sdum no meaning *
1237* *
1238*********************************************************************
1239
1240 380 CONTINUE
1241 IF (ABS(WHAT(1)).GT.ZERO) ISINGD = INT(WHAT(1))
1242 IF (ABS(WHAT(2)).GT.ZERO) IDOUBD = INT(WHAT(2))
1243 IF ((ISINGD.GT.1).AND.(IDOUBD.GT.1)) THEN
1244 WRITE(LOUT,1380)
1245 1380 FORMAT(1X,'INIT: inconsistent DIFFRACT - input !',/,
1246 & 11X,'IDOUBD is reset to zero')
1247 IDOUBD = 0
1248 ENDIF
1249 IF (WHAT(3).GT.ZERO) DIBETA = WHAT(3)
1250 IF (WHAT(4).GT.ZERO) DIALPH = WHAT(4)
1251 GOTO 10
1252
1253*********************************************************************
1254* *
1255* control card: codewd = SINGLECH *
1256* *
1257* what (1) = 1. Regge contribution (one chain) included *
1258* default: 0. *
1259* what (2..6), sdum no meaning *
1260* *
1261*********************************************************************
1262
1263 390 CONTINUE
1264 ISICHA = 0
1265 IF (WHAT(1).EQ.ONE) ISICHA = 1
1266 GOTO 10
1267
1268*********************************************************************
1269* *
1270* control card: codewd = NOFRAGME *
1271* *
1272* biased chain hadronization *
1273* *
1274* what (1..6) = -1 no of hadronizsation of S-S chains *
1275* = -2 no of hadronizsation of D-S chains *
1276* = -3 no of hadronizsation of S-D chains *
1277* = -4 no of hadronizsation of S-V chains *
1278* = -5 no of hadronizsation of D-V chains *
1279* = -6 no of hadronizsation of V-S chains *
1280* = -7 no of hadronizsation of V-D chains *
1281* = -8 no of hadronizsation of V-V chains *
1282* = -9 no of hadronizsation of comb. chains *
1283* default: complete hadronization *
1284* sdum no meaning *
1285* *
1286*********************************************************************
1287
1288 400 CONTINUE
1289 DO 401 I=1,6
1290 ICHAIN = INT(WHAT(I))
1291 IF ((ICHAIN.LE.-1).AND.(ICHAIN.GE.-9))
1292 & LHADRO(ABS(ICHAIN)) = .FALSE.
1293 401 CONTINUE
1294 GOTO 10
1295
1296*********************************************************************
1297* *
1298* control card: codewd = HADRONIZE *
1299* *
1300* hadronization model and parameter switch *
1301* *
1302* what (1) = 1 hadronization via BAMJET *
1303* = 2 hadronization via JETSET *
1304* default: 2 *
1305* what (2) = 1..3 parameter set to be used *
1306* JETSET: 3 sets available *
1307* ( = 3 default JETSET-parameters) *
1308* BAMJET: 1 set available *
1309* default: 1 *
1310* what (3..6), sdum no meaning *
1311* *
1312*********************************************************************
1313
1314 410 CONTINUE
1315 IWHAT1 = INT(WHAT(1))
1316 IWHAT2 = INT(WHAT(2))
1317 IF ((IWHAT1.EQ.1).OR.(IWHAT1.EQ.2)) IFRAG(1) = IWHAT1
1318 IF ((IWHAT1.EQ.2).AND.(IWHAT2.GE.1).AND.(IWHAT2.LE.3))
1319 & IFRAG(2) = IWHAT2
1320 GOTO 10
1321
1322*********************************************************************
1323* *
1324* control card: codewd = POPCORN *
1325* *
1326* "Popcorn-effect" in fragmentation and diquark breaking diagrams *
1327* *
1328* what (1) = (PDB) frac. of diquark fragmenting directly into *
1329* baryons (PYTHIA/JETSET fragmentation) *
1330* (JETSET: = 0. Popcorn mechanism switched off) *
1331* default: 0.5 *
1332* what (2) = probability for accepting a diquark breaking *
1333* diagram involving the generation of a u/d quark- *
1334* antiquark pair default: 0.0 *
1335* what (3) = same a what (2), here for s quark-antiquark pair *
1336* default: 0.0 *
1337* what (4..6), sdum no meaning *
1338* *
1339*********************************************************************
1340
1341 420 CONTINUE
1342 IF (WHAT(1).GE.0.0D0) PDB = WHAT(1)
1343 IF (WHAT(2).GE.0.0D0) THEN
1344 PDBSEA(1) = WHAT(2)
1345 PDBSEA(2) = WHAT(2)
1346 ENDIF
1347 IF (WHAT(3).GE.0.0D0) PDBSEA(3) = WHAT(3)
1348 DO 421 I=1,8
1349 DBRKA(1,I) = DBRKR(1,I)*PDBSEA(1)/(1.D0-PDBSEA(1))
1350 DBRKA(2,I) = DBRKR(2,I)*PDBSEA(2)/(1.D0-PDBSEA(2))
1351 DBRKA(3,I) = DBRKR(3,I)*PDBSEA(3)/(1.D0-PDBSEA(3))
1352 421 CONTINUE
1353 GOTO 10
1354
1355*********************************************************************
1356* *
1357* control card: codewd = PARDECAY *
1358* *
1359* what (1) = 1. Sigma0/Asigma0 are decaying within JETSET *
1360* = 2. pion^0 decay after intranucl. cascade *
1361* default: no decay *
1362* what (2..6), sdum no meaning *
1363* *
1364*********************************************************************
1365
1366 430 CONTINUE
1367 IF (WHAT(1).EQ.ONE) ISIG0 = 1
1368 IF (WHAT(1).EQ.2.0D0) IPI0 = 1
1369 GOTO 10
1370
1371*********************************************************************
1372* *
1373* control card: codewd = BEAM *
1374* *
1375* definition of beam parameters *
1376* *
1377* what (1/2) > 0 : energy of beam 1/2 (GeV) *
1378* < 0 : abs(what(1/2)) energy per charge of *
1379* beam 1/2 (GeV) *
1380* (beam 1 is directed into positive z-direction) *
1381* what (3) beam crossing angle, defined as 2x angle between *
1382* one beam and the z-axis (micro rad) *
1383* what (4) angle with x-axis defining the collision plane *
1384* what (5..6), sdum no meaning *
1385* *
1386* Note: this card requires previously defined projectile and *
1387* target identities (PROJPAR, TARPAR) *
1388* *
1389*********************************************************************
1390
1391 440 CONTINUE
1392 CALL DT_BEAMPR(WHAT,PPN,1)
1393 EPN = ZERO
1394 CMENER = ZERO
1395 LEINP = .TRUE.
1396 GOTO 10
1397
1398*********************************************************************
1399* *
1400* control card: codewd = LUND-MSTU *
1401* *
1402* set parameter MSTU in JETSET-common /LUDAT1/ *
1403* *
1404* what (1) = index according to LUND-common block *
1405* what (2) = new value of MSTU( int(what(1)) ) *
1406* what (3), what(4) and what (5), what(6) further *
1407* parameter in the same way as what (1) and *
1408* what (2) *
1409* default: default-Lund or corresponding to *
1410* the set given in HADRONIZE *
1411* *
1412*********************************************************************
1413
1414 450 CONTINUE
1415 IF (WHAT(1).GT.ZERO) THEN
1416 NMSTU = NMSTU+1
1417 IMSTU(NMSTU) = INT(WHAT(1))
1418 MSTUX(NMSTU) = INT(WHAT(2))
1419 ENDIF
1420 IF (WHAT(3).GT.ZERO) THEN
1421 NMSTU = NMSTU+1
1422 IMSTU(NMSTU) = INT(WHAT(3))
1423 MSTUX(NMSTU) = INT(WHAT(4))
1424 ENDIF
1425 IF (WHAT(5).GT.ZERO) THEN
1426 NMSTU = NMSTU+1
1427 IMSTU(NMSTU) = INT(WHAT(5))
1428 MSTUX(NMSTU) = INT(WHAT(6))
1429 ENDIF
1430 GOTO 10
1431
1432*********************************************************************
1433* *
1434* control card: codewd = LUND-MSTJ *
1435* *
1436* set parameter MSTJ in JETSET-common /LUDAT1/ *
1437* *
1438* what (1) = index according to LUND-common block *
1439* what (2) = new value of MSTJ( int(what(1)) ) *
1440* what (3), what(4) and what (5), what(6) further *
1441* parameter in the same way as what (1) and *
1442* what (2) *
1443* default: default-Lund or corresponding to *
1444* the set given in HADRONIZE *
1445* *
1446*********************************************************************
1447
1448 451 CONTINUE
1449 IF (WHAT(1).GT.ZERO) THEN
1450 NMSTJ = NMSTJ+1
1451 IMSTJ(NMSTJ) = INT(WHAT(1))
1452 MSTJX(NMSTJ) = INT(WHAT(2))
1453 ENDIF
1454 IF (WHAT(3).GT.ZERO) THEN
1455 NMSTJ = NMSTJ+1
1456 IMSTJ(NMSTJ) = INT(WHAT(3))
1457 MSTJX(NMSTJ) = INT(WHAT(4))
1458 ENDIF
1459 IF (WHAT(5).GT.ZERO) THEN
1460 NMSTJ = NMSTJ+1
1461 IMSTJ(NMSTJ) = INT(WHAT(5))
1462 MSTJX(NMSTJ) = INT(WHAT(6))
1463 ENDIF
1464 GOTO 10
1465
1466*********************************************************************
1467* *
1468* control card: codewd = LUND-MDCY *
1469* *
1470* set parameter MDCY(I,1) for particle decays in JETSET-common *
1471* /LUDAT3/ *
1472* *
1473* what (1-6) = PDG particle index of particle which should *
1474* not decay *
1475* default: default-Lund or forced in *
1476* DT_INITJS *
1477* *
1478*********************************************************************
1479
1480 452 CONTINUE
1481 DO 4521 I=1,6
1482 IF (WHAT(I).NE.ZERO) THEN
1483 KC = PYCOMP(INT(WHAT(I)))
1484 MDCY(KC,1) = 0
1485 ENDIF
1486 4521 CONTINUE
1487 GOTO 10
1488
1489*********************************************************************
1490* *
1491* control card: codewd = LUND-PARJ *
1492* *
1493* set parameter PARJ in JETSET-common /LUDAT1/ *
1494* *
1495* what (1) = index according to LUND-common block *
1496* what (2) = new value of PARJ( int(what(1)) ) *
1497* what (3), what(4) and what (5), what(6) further *
1498* parameter in the same way as what (1) and *
1499* what (2) *
1500* default: default-Lund or corresponding to *
1501* the set given in HADRONIZE *
1502* *
1503*********************************************************************
1504
1505 460 CONTINUE
1506 IF (WHAT(1).NE.ZERO) THEN
1507 NPARJ = NPARJ+1
1508 IPARJ(NPARJ) = INT(WHAT(1))
1509 PARJX(NPARJ) = WHAT(2)
1510 ENDIF
1511 IF (WHAT(3).NE.ZERO) THEN
1512 NPARJ = NPARJ+1
1513 IPARJ(NPARJ) = INT(WHAT(3))
1514 PARJX(NPARJ) = WHAT(4)
1515 ENDIF
1516 IF (WHAT(5).NE.ZERO) THEN
1517 NPARJ = NPARJ+1
1518 IPARJ(NPARJ) = INT(WHAT(5))
1519 PARJX(NPARJ) = WHAT(6)
1520 ENDIF
1521 GOTO 10
1522
1523*********************************************************************
1524* *
1525* control card: codewd = LUND-PARU *
1526* *
1527* set parameter PARJ in JETSET-common /LUDAT1/ *
1528* *
1529* what (1) = index according to LUND-common block *
1530* what (2) = new value of PARU( int(what(1)) ) *
1531* what (3), what(4) and what (5), what(6) further *
1532* parameter in the same way as what (1) and *
1533* what (2) *
1534* default: default-Lund or corresponding to *
1535* the set given in HADRONIZE *
1536* *
1537*********************************************************************
1538
1539 470 CONTINUE
1540 IF (WHAT(1).GT.ZERO) THEN
1541 NPARU = NPARU+1
1542 IPARU(NPARU) = INT(WHAT(1))
1543 PARUX(NPARU) = WHAT(2)
1544 ENDIF
1545 IF (WHAT(3).GT.ZERO) THEN
1546 NPARU = NPARU+1
1547 IPARU(NPARU) = INT(WHAT(3))
1548 PARUX(NPARU) = WHAT(4)
1549 ENDIF
1550 IF (WHAT(5).GT.ZERO) THEN
1551 NPARU = NPARU+1
1552 IPARU(NPARU) = INT(WHAT(5))
1553 PARUX(NPARU) = WHAT(6)
1554 ENDIF
1555 GOTO 10
1556
1557*********************************************************************
1558* *
1559* control card: codewd = OUTLEVEL *
1560* *
1561* output control switches *
1562* *
1563* what (1) = internal rejection informations default: 0 *
1564* what (2) = energy-momentum conservation check output *
1565* default: 0 *
1566* what (3) = internal warning messages default: 0 *
1567* what (4..6), sdum not yet used *
1568* *
1569*********************************************************************
1570
1571 480 CONTINUE
1572 DO 481 K=1,6
1573 IOULEV(K) = INT(WHAT(K))
1574 481 CONTINUE
1575 GOTO 10
1576
1577*********************************************************************
1578* *
1579* control card: codewd = FRAME *
1580* *
1581* frame in which final state is given in DTEVT1 *
1582* *
1583* what (1) = 1 target rest frame (laboratory) *
1584* = 2 nucleon-nucleon cms *
1585* default: 1 *
1586* *
1587*********************************************************************
1588
1589 490 CONTINUE
1590 KFRAME = INT(WHAT(1))
1591 IF ((KFRAME.GE.1).AND.(KFRAME.LE.2)) IFRAME = KFRAME
1592 GOTO 10
1593
1594*********************************************************************
1595* *
1596* control card: codewd = L-TAG *
1597* *
1598* lepton tagger: *
1599* definition of kinematical cuts for radiated photon and *
1600* outgoing lepton detection in lepton-nucleus interactions *
1601* *
1602* what (1) = y_min *
1603* what (2) = y_max *
1604* what (3) = Q^2_min *
1605* what (4) = Q^2_max *
1606* what (5) = theta_min (Lab) *
1607* what (6) = theta_max (Lab) *
1608* default: no cuts *
1609* sdum no meaning *
1610* *
1611*********************************************************************
1612
1613 500 CONTINUE
1614 YMIN = WHAT(1)
1615 YMAX = WHAT(2)
1616 Q2MIN = WHAT(3)
1617 Q2MAX = WHAT(4)
1618 THMIN = WHAT(5)
1619 THMAX = WHAT(6)
1620 GOTO 10
1621
1622*********************************************************************
1623* *
1624* control card: codewd = L-ETAG *
1625* *
1626* lepton tagger: *
1627* what (1) = min. outgoing lepton energy (in Lab) *
1628* what (2) = min. photon energy (in Lab) *
1629* what (3) = max. photon energy (in Lab) *
1630* default: no cuts *
1631* what (2..6), sdum no meaning *
1632* *
1633*********************************************************************
1634
1635 510 CONTINUE
1636 ELMIN = MAX(WHAT(1),ZERO)
1637 EGMIN = MAX(WHAT(2),ZERO)
1638 EGMAX = MAX(WHAT(3),ZERO)
1639 GOTO 10
1640
1641*********************************************************************
1642* *
1643* control card: codewd = ECMS-CUT *
1644* *
1645* what (1) = min. c.m. energy to be sampled *
1646* what (2) = max. c.m. energy to be sampled *
1647* what (3) = min x_Bj to be sampled *
1648* default: no cuts *
1649* what (3..6), sdum no meaning *
1650* *
1651*********************************************************************
1652
1653 520 CONTINUE
1654 ECMIN = WHAT(1)
1655 ECMAX = WHAT(2)
1656 IF (ECMIN.GT.ECMAX) ECMIN = ECMAX
1657 XBJMIN = MAX(WHAT(3),ZERO)
1658 GOTO 10
1659
1660*********************************************************************
1661* *
1662* control card: codewd = VDM-PAR1 *
1663* *
1664* parameters in gamma-nucleus cross section calculation *
1665* *
1666* what (1) = Lambda^2 default: 2. *
1667* what (2) lower limit in M^2 integration *
1668* = 1 (3m_pi)^2 *
1669* = 2 (m_rho0)^2 *
1670* = 3 (m_phi)^2 default: 1 *
1671* what (3) upper limit in M^2 integration *
1672* = 1 s/2 *
1673* = 2 s/4 *
1674* = 3 s default: 3 *
1675* what (4) CKMT F_2 structure function *
1676* = 2212 proton *
1677* = 100 deuteron default: 2212 *
1678* what (5) calculation of gamma-nucleon xsections *
1679* = 1 according to CKMT-parametrization of F_2 *
1680* = 2 integrating SIGVP over M^2 *
1681* = 3 using SIGGA *
1682* = 4 PHOJET cross sections default: 4 *
1683* *
1684* what (6), sdum no meaning *
1685* *
1686*********************************************************************
1687
1688 530 CONTINUE
1689 IF (WHAT(1).GE.ZERO) RL2 = WHAT(1)
1690 IF ((WHAT(2).GE.1).AND.(WHAT(2).LE.3)) INTRGE(1) = INT(WHAT(2))
1691 IF ((WHAT(3).GE.1).AND.(WHAT(3).LE.3)) INTRGE(2) = INT(WHAT(3))
1692 IF ((WHAT(4).EQ.2212).OR.(WHAT(4).EQ.100)) IDPDF = INT(WHAT(4))
1693 IF ((WHAT(5).GE.1).AND.(WHAT(5).LE.4)) MODEGA = INT(WHAT(5))
1694 GOTO 10
1695
1696*********************************************************************
1697* *
1698* control card: codewd = HISTOGRAM *
1699* *
1700* activate different classes of histograms *
1701* *
1702* default: no histograms *
1703* *
1704*********************************************************************
1705
1706 540 CONTINUE
1707 DO 541 J=1,6
1708 IF ((WHAT(J).GE.100).AND.(WHAT(J).LE.150)) THEN
1709 IHISPP(INT(WHAT(J))-100) = 1
1710 ELSEIF ((ABS(WHAT(J)).GE.200).AND.(ABS(WHAT(J)).LE.250)) THEN
1711 IHISXS(INT(ABS(WHAT(J)))-200) = 1
1712 IF (WHAT(J).LT.ZERO) IXSTBL = 1
1713 ENDIF
1714 541 CONTINUE
1715 GOTO 10
1716
1717*********************************************************************
1718* *
1719* control card: codewd = XS-TABLE *
1720* *
1721* output of cross section table for requested interaction *
1722* - particle production deactivated ! - *
1723* *
1724* what (1) lower energy limit for tabulation *
1725* > 0 Lab. frame *
1726* < 0 nucleon-nucleon cms *
1727* what (2) upper energy limit for tabulation *
1728* > 0 Lab. frame *
1729* < 0 nucleon-nucleon cms *
1730* what (3) > 0 # of equidistant lin. bins in E *
1731* < 0 # of equidistant log. bins in E *
1732* what (4) lower limit of particle virtuality (photons) *
1733* what (5) upper limit of particle virtuality (photons) *
1734* what (6) > 0 # of equidistant lin. bins in Q^2 *
1735* < 0 # of equidistant log. bins in Q^2 *
1736* *
1737*********************************************************************
1738
1739 550 CONTINUE
1740 IF (WHAT(1).EQ.99999.0D0) THEN
1741 IRATIO = INT(WHAT(2))
1742 GOTO 10
1743 ENDIF
1744 CMENER = ABS(WHAT(2))
1745 IF (.NOT.LXSTAB) THEN
1746 CALL DT_BERTTP
1747 CALL DT_INCINI
1748 ENDIF
1749 IF ((.NOT.LXSTAB).OR.(CMENER.NE.CMEOLD)) THEN
1750 CMEOLD = CMENER
1751 IF (WHAT(2).GT.ZERO)
1752 & CMENER = SQRT(2.0D0*AAM(1)**2+2.0D0*WHAT(2)*AAM(1))
1753 EPN = ZERO
1754 PPN = ZERO
1755C WRITE(LOUT,*) 'CMENER = ',CMENER
1756 CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,CMENER,1)
1757 CALL DT_PHOINI
1758 ENDIF
1759 CALL DT_XSTABL(WHAT,IXSQEL,IRATIO)
1760 IXSQEL = 0
1761 LXSTAB = .TRUE.
1762 GOTO 10
1763
1764*********************************************************************
1765* *
1766* control card: codewd = GLAUB-PAR *
1767* *
1768* parameters in Glauber-formalism *
1769* *
1770* what (1) # of nucleon configurations sampled in integration *
1771* over nuclear desity default: 1000 *
1772* what (2) # of bins for integration over impact-parameter and *
1773* for profile-function calculation default: 49 *
1774* what (3) = 1 calculation of tot., el. and qel. cross sections *
1775* default: 0 *
1776* what (4) = 1 read pre-calculated impact-parameter distrib. *
1777* from "sdum".glb *
1778* =-1 dump pre-calculated impact-parameter distrib. *
1779* into "sdum".glb *
1780* = 100 read pre-calculated impact-parameter distrib. *
1781* for variable projectile/target/energy runs *
1782* from "sdum".glb *
1783* default: 0 *
1784* what (5..6) no meaning *
1785* sdum if |what (4)| = 1 name of in/output-file (sdum.glb) *
1786* *
1787*********************************************************************
1788
1789 560 CONTINUE
1790 IF (WHAT(1).GT.ZERO) JSTATB = INT(WHAT(1))
1791 IF (WHAT(2).GT.ZERO) JBINSB = INT(WHAT(2))
1792 IF (WHAT(3).EQ.ONE) LPROD = .FALSE.
1793 IF ((ABS(WHAT(4)).EQ.ONE).OR.(WHAT(4).EQ.100)) THEN
1794 IOGLB = INT(WHAT(4))
1795 CGLB = SDUM
1796 ENDIF
1797 GOTO 10
1798
1799*********************************************************************
1800* *
1801* control card: codewd = GLAUB-INI *
1802* *
1803* pre-initialization of profile function *
1804* *
1805* what (1) lower energy limit for initialization *
1806* > 0 Lab. frame *
1807* < 0 nucleon-nucleon cms *
1808* what (2) upper energy limit for initialization *
1809* > 0 Lab. frame *
1810* < 0 nucleon-nucleon cms *
1811* what (3) > 0 # of equidistant lin. bins in E *
1812* < 0 # of equidistant log. bins in E *
1813* what (4) maximum projectile mass number for which the *
1814* Glauber data are initialized for each *
1815* projectile mass number *
1816* (if <= mass given with the PROJPAR-card) *
1817* default: 18 *
1818* what (5) steps in mass number starting from what (4) *
1819* up to mass number defined with PROJPAR-card *
1820* for which Glauber data are initialized *
1821* default: 5 *
1822* what (6) no meaning *
1823* sdum no meaning *
1824* *
1825*********************************************************************
1826
1827 565 CONTINUE
1828 IOGLB = -100
1829 CALL DT_GLBINI(WHAT)
1830 GOTO 10
1831
1832*********************************************************************
1833* *
1834* control card: codewd = VDM-PAR2 *
1835* *
1836* parameters in gamma-nucleus cross section calculation *
1837* *
1838* what (1) = 0 no suppression of shadowing by direct photon *
1839* processes *
1840* = 1 suppression .. default: 1 *
1841* what (2) = 0 no suppression of shadowing by anomalous *
1842* component if photon-F_2 *
1843* = 1 suppression .. default: 1 *
1844* what (3) = 0 no suppression of shadowing by coherence *
1845* length of the photon *
1846* = 1 suppression .. default: 1 *
1847* what (4) = 1 longitudinal polarized photons are taken into *
1848* account *
1849* eps*R*Q^2/M^2 = what(4)*Q^2/M^2 default: 0 *
1850* what (5..6), sdum no meaning *
1851* *
1852*********************************************************************
1853
1854 570 CONTINUE
1855 IF ((WHAT(1).EQ.ZERO).OR.(WHAT(1).EQ.ONE)) ISHAD(1) = INT(WHAT(1))
1856 IF ((WHAT(2).EQ.ZERO).OR.(WHAT(2).EQ.ONE)) ISHAD(2) = INT(WHAT(2))
1857 IF ((WHAT(3).EQ.ZERO).OR.(WHAT(3).EQ.ONE)) ISHAD(3) = INT(WHAT(3))
1858 EPSPOL = WHAT(4)
1859 GOTO 10
1860
1861*********************************************************************
1862* *
1863* control card: XS-QELPRO *
1864* *
1865* what (1..6), sdum no meaning *
1866* *
1867*********************************************************************
1868
1869 580 CONTINUE
1870 IXSQEL = ABS(WHAT(1))
1871 GOTO 10
1872
1873*********************************************************************
1874* *
1875* control card: RNDMINIT *
1876* *
1877* initialization of random number generator *
1878* *
1879* what (1..4) values for initialization (= 1..168) *
1880* what (5..6), sdum no meaning *
1881* *
1882*********************************************************************
1883
1884 590 CONTINUE
1885 IF ((WHAT(1).LT.1.0D0).OR.(WHAT(1).GT.168.0D0)) THEN
1886 NA1 = 22
1887 ELSE
1888 NA1 = WHAT(1)
1889 ENDIF
1890 IF ((WHAT(2).LT.1.0D0).OR.(WHAT(2).GT.168.0D0)) THEN
1891 NA2 = 54
1892 ELSE
1893 NA2 = WHAT(2)
1894 ENDIF
1895 IF ((WHAT(3).LT.1.0D0).OR.(WHAT(3).GT.168.0D0)) THEN
1896 NA3 = 76
1897 ELSE
1898 NA3 = WHAT(3)
1899 ENDIF
1900 IF ((WHAT(4).LT.1.0D0).OR.(WHAT(4).GT.168.0D0)) THEN
1901 NA4 = 92
1902 ELSE
1903 NA4 = WHAT(4)
1904 ENDIF
1905 CALL DT_RNDMST(NA1,NA2,NA3,NA4)
1906 GOTO 10
1907
1908*********************************************************************
1909* *
1910* control card: codewd = LEPTO-CUT *
1911* *
1912* set parameter CUT in LEPTO-common /LEPTOU/ *
1913* *
1914* what (1) = index in CUT-array *
1915* what (2) = new value of CUT( int(what(1)) ) *
1916* what (3), what(4) and what (5), what(6) further *
1917* parameter in the same way as what (1) and *
1918* what (2) *
1919* default: default-LEPTO parameters *
1920* *
1921*********************************************************************
1922
1923 600 CONTINUE
1924 IF (WHAT(1).GT.ZERO) CUT(INT(WHAT(1))) = WHAT(2)
1925 IF (WHAT(3).GT.ZERO) CUT(INT(WHAT(3))) = WHAT(4)
1926 IF (WHAT(5).GT.ZERO) CUT(INT(WHAT(5))) = WHAT(6)
1927 GOTO 10
1928
1929*********************************************************************
1930* *
1931* control card: codewd = LEPTO-LST *
1932* *
1933* set parameter LST in LEPTO-common /LEPTOU/ *
1934* *
1935* what (1) = index in LST-array *
1936* what (2) = new value of LST( int(what(1)) ) *
1937* what (3), what(4) and what (5), what(6) further *
1938* parameter in the same way as what (1) and *
1939* what (2) *
1940* default: default-LEPTO parameters *
1941* *
1942*********************************************************************
1943
1944 610 CONTINUE
1945 IF (WHAT(1).GT.ZERO) LST(INT(WHAT(1))) = INT(WHAT(2))
1946 IF (WHAT(3).GT.ZERO) LST(INT(WHAT(3))) = INT(WHAT(4))
1947 IF (WHAT(5).GT.ZERO) LST(INT(WHAT(5))) = INT(WHAT(6))
1948 GOTO 10
1949
1950*********************************************************************
1951* *
1952* control card: codewd = LEPTO-PARL *
1953* *
1954* set parameter PARL in LEPTO-common /LEPTOU/ *
1955* *
1956* what (1) = index in PARL-array *
1957* what (2) = new value of PARL( int(what(1)) ) *
1958* what (3), what(4) and what (5), what(6) further *
1959* parameter in the same way as what (1) and *
1960* what (2) *
1961* default: default-LEPTO parameters *
1962* *
1963*********************************************************************
1964
1965 620 CONTINUE
1966 IF (WHAT(1).GT.ZERO) PARL(INT(WHAT(1))) = WHAT(2)
1967 IF (WHAT(3).GT.ZERO) PARL(INT(WHAT(3))) = WHAT(4)
1968 IF (WHAT(5).GT.ZERO) PARL(INT(WHAT(5))) = WHAT(6)
1969 GOTO 10
1970
1971*********************************************************************
1972* *
1973* control card: codewd = START *
1974* *
1975* what (1) = number of events default: 100. *
1976* what (2) = 0 Glauber initialization follows *
1977* = 1 Glauber initialization supressed, fitted *
1978* results are used instead *
1979* (this does not apply if emulsion-treatment *
1980* is requested) *
1981* = 2 Glauber initialization is written to *
1982* output-file shmakov.out *
1983* = 3 Glauber initialization is read from input-file *
1984* shmakov.out default: 0 *
1985* what (3..6) no meaning *
1986* what (3..6) no meaning *
1987* *
1988*********************************************************************
1989
1990 630 CONTINUE
1991
1992* check for cross-section table output only
1993 IF (LXSTAB) STOP
1994
1995 NCASES = INT(WHAT(1))
1996 IF (NCASES.LE.0) NCASES = 100
1997 IGLAU = INT(WHAT(2))
1998 IF ((IGLAU.NE.1).AND.(IGLAU.NE.2).AND.(IGLAU.NE.3))
1999 & IGLAU = 0
2000
2001 NPMASS = IP
2002 NPCHAR = IPZ
2003 NTMASS = IT
2004 NTCHAR = ITZ
2005 IDP = IJPROJ
2006 IDT = IJTARG
2007 IF (IDP.LE.0) IDP = 1
2008* muon neutrinos: temporary (missing index)
2009* (new patch in projpar: therefore the following this is probably not
2010* necessary anymore..)
2011C IF (IDP.EQ.26) IDP = 5
2012C IF (IDP.EQ.27) IDP = 6
2013
2014* redefine collision energy
2015 IF (LEINP) THEN
2016 IF (ABS(VAREHI).GT.ZERO) THEN
2017 PDUM = ZERO
2018 IF (VARELO.LT.EHADLO) VARELO = EHADLO
2019 CALL DT_LTINI(IDP,IDT,VARELO,PDUM,VARCLO,1)
2020 PDUM = ZERO
2021 CALL DT_LTINI(IDP,IDT,VAREHI,PDUM,VARCHI,1)
2022 ENDIF
2023 CALL DT_LTINI(IDP,IDT,EPN,PPN,CMENER,1)
2024 ELSE
2025 WRITE(LOUT,1003)
2026 1003 FORMAT(1X,'INIT: collision energy not defined!',/,
2027 & 1X,' -program stopped- ')
2028 STOP
2029 ENDIF
2030
2031* switch off evaporation (even if requested) if central coll. requ.
2032 IF ((ICENTR.EQ.-1).OR.(ICENTR.GT.0).OR.(XSFRAC.LT.0.5D0)) THEN
2033 IF (LEVPRT) THEN
2034 WRITE(LOUT,1004)
2035 1004 FORMAT(1X,/,'Warning! Evaporation request rejected since',
2036 & ' central collisions forced.')
2037 LEVPRT = .FALSE.
2038 LDEEXG = .FALSE.
2039 LHEAVY = .FALSE.
2040 ENDIF
2041 ENDIF
2042
2043* initialization of evaporation-module
2044
2045 WRITE(LOUT,1010)
2046 1010 FORMAT(1X,/,'Warning! No evaporation performed since',
2047 & ' evaporation modules not available with this version.')
2048 LEVPRT = .FALSE.
2049 LDEEXG = .FALSE.
2050 LHEAVY = .FALSE.
2051 LFRMBK = .FALSE.
2052 IFISS = 0
2053 IEVFSS = 0
2054 CALL DT_BERTTP
2055 CALL DT_INCINI
2056
2057* save the default JETSET-parameter
2058 CALL DT_JSPARA(0)
2059
2060* force use of phojet for g-A
2061 IF ((IDP.EQ.7).AND.(MCGENE.NE.3)) MCGENE = 2
2062* initialization of nucleon-nucleon event generator
2063 IF (MCGENE.EQ.2) CALL DT_PHOINI
2064* initialization of LEPTO event generator
2065 IF (MCGENE.EQ.3) THEN
2066
2067 STOP ' This version does not contain LEPTO !'
2068
2069 ENDIF
2070
2071* initialization of quasi-elastic neutrino scattering
2072 IF (MCGENE.EQ.4) THEN
2073 IF (IJPROJ.EQ.5) THEN
2074 NEUTYP = 1
2075 ELSEIF (IJPROJ.EQ.6) THEN
2076 NEUTYP = 2
2077 ELSEIF (IJPROJ.EQ.135) THEN
2078 NEUTYP = 3
2079 ELSEIF (IJPROJ.EQ.136) THEN
2080 NEUTYP = 4
2081 ELSEIF (IJPROJ.EQ.133) THEN
2082 NEUTYP = 5
2083 ELSEIF (IJPROJ.EQ.134) THEN
2084 NEUTYP = 6
2085 ENDIF
2086 ENDIF
2087
2088* normalize fractions of emulsion components
2089 IF (NCOMPO.GT.0) THEN
2090 SUMFRA = ZERO
2091 DO 491 I=1,NCOMPO
2092 SUMFRA = SUMFRA+EMUFRA(I)
2093 491 CONTINUE
2094 IF (SUMFRA.GT.ZERO) THEN
2095 DO 492 I=1,NCOMPO
2096 EMUFRA(I) = EMUFRA(I)/SUMFRA
2097 492 CONTINUE
2098 ENDIF
2099 ENDIF
2100
2101* disallow Cronin's multiple scattering for nucleus-nucleus interactions
6cf1df4c 2102 IF ((IP.GT.1).AND. (IT.GT.1) .AND. (MKCRON.GT.0)) THEN
9aaba0d6 2103 WRITE(LOUT,1005)
2104 1005 FORMAT(/,1X,'INIT: multiple scattering disallowed',/)
2105 MKCRON = 0
2106 ENDIF
2107
2108* initialization of Glauber-formalism (moved to xAEVT, sr 26.3.96)
2109C IF (NCOMPO.LE.0) THEN
2110C CALL DT_SHMAKI(IP,IPZ,IT,ITZ,IDP,PPN,IGLAU)
2111C ELSE
2112C DO 493 I=1,NCOMPO
2113C CALL DT_SHMAKI(IP,IPZ,IEMUMA(I),IEMUCH(I),IDP,PPN,0)
2114C 493 CONTINUE
2115C ENDIF
2116
2117* pre-tabulation of elastic cross-sections
2118 CALL DT_SIGTBL(JDUM,JDUM,DUM,DUM,-1)
2119
2120 CALL DT_XTIME
2121
2122 RETURN
2123
2124*********************************************************************
2125* *
2126* control card: codewd = STOP *
2127* *
2128* stop of the event generation *
2129* *
2130* what (1..6) no meaning *
2131* *
2132*********************************************************************
2133
2134 9999 CONTINUE
2135 WRITE(LOUT,9000)
2136 9000 FORMAT(1X,'---> unexpected end of input !')
2137
2138 640 CONTINUE
2139 STOP
2140
2141 END
2142
2143*$ CREATE DT_KKINC.FOR
2144*COPY DT_KKINC
2145*
2146*===kkinc==============================================================*
2147*
2148 SUBROUTINE DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,
2149 & IREJ)
2150
2151************************************************************************
2152* Treatment of complete nucleus-nucleus or hadron-nucleus scattering *
2153* This subroutine is an update of the previous version written *
2154* by J. Ranft/ H.-J. Moehring. *
2155* This version dated 19.11.95 is written by S. Roesler *
2156************************************************************************
2157
2158 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2159 SAVE
2160 PARAMETER ( LINP = 10 ,
2161 & LOUT = 6 ,
2162 & LDAT = 9 )
2163 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY5=1.0D-5,
2164 & TINY2=1.0D-2,TINY3=1.0D-3)
2165
2166 LOGICAL LFZC
2167
2168* event history
09b429a4 2169
2170 PARAMETER (NMXHEP=4000)
2171 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
2172 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
2173 & VHEP(4,NMXHEP), NSD1, NSD2, NDD
2174
9aaba0d6 2175 PARAMETER (NMXHKK=200000)
2176 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
2177 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
2178 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
2179* extended event history
2180 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
2181 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
2182 & IHIST(2,NMXHKK)
2183* particle properties (BAMJET index convention)
2184 CHARACTER*8 ANAME
2185 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2186 & IICH(210),IIBAR(210),K1(210),K2(210)
2187* properties of interacting particles
2188 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2189* Lorentz-parameters of the current interaction
2190 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
2191 & UMO,PPCM,EPROJ,PPROJ
2192* flags for input different options
2193 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2194 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2195 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2196* flags for particle decays
2197 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
2198 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
2199 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
2200* cuts for variable energy runs
2201 COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
2202* Glauber formalism: flags and parameters for statistics
2203 LOGICAL LPROD
2204 CHARACTER*8 CGLB
2205 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
2206
2207 DIMENSION WHAT(6)
2208
2209 IREJ = 0
2210 ILOOP = 0
09b429a4 2211 NSD1 = 0
2212 NSD2 = 0
2213 NDD = 0
9aaba0d6 2214 100 CONTINUE
2215 IF (ILOOP.EQ.4) THEN
2216 WRITE(LOUT,1000) NEVHKK
2217 1000 FORMAT(1X,'KKINC: event ',I8,' rejected!')
2218 GOTO 9999
2219 ENDIF
2220 ILOOP = ILOOP+1
2221
2222* variable energy-runs, recalculate parameters for LT's
2223 IF ((ABS(VAREHI).GT.ZERO).OR.(IOGLB.EQ.100)) THEN
2224 PDUM = ZERO
2225 CDUM = ZERO
2226 CALL DT_LTINI(IDP,1,EPN,PDUM,CDUM,1)
2227 ENDIF
2228 IF (EPN.GT.EPROJ) THEN
2229 WRITE(LOUT,'(A,E9.3,2A,E9.3,A)')
2230 & ' Requested energy (',EPN,'GeV) exceeds',
2231 & ' initialization energy (',EPROJ,'GeV) !'
2232 STOP
2233 ENDIF
2234
2235* re-initialize /DTPRTA/
2236 IP = NPMASS
2237 IPZ = NPCHAR
2238 IT = NTMASS
2239 ITZ = NTCHAR
2240 IJPROJ = IDP
2241 IBPROJ = IIBAR(IJPROJ)
2242
2243* calculate nuclear potentials (common /DTNPOT/)
2244 CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
2245
2246* initialize treatment for residual nuclei
2247 CALL DT_RESNCL(EPN,NLOOP,1)
2248
2249* sample hadron/nucleus-nucleus interaction
2250 CALL DT_KKEVNT(KKMAT,IREJ1)
2251 IF (IREJ1.GT.0) THEN
2252 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKINC'
2253 GOTO 9999
2254 ENDIF
2255
2256 IF ((NPMASS.GT.1).OR.(NTMASS.GT.1)) THEN
2257
2258* intranuclear cascade of final state particles for KTAUGE generations
2259* of secondaries
2260 CALL DT_FOZOCA(LFZC,IREJ1)
2261 IF (IREJ1.GT.0) THEN
2262 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKINC'
2263 GOTO 9999
2264 ENDIF
2265
2266* baryons unable to escape the nuclear potential are treated as
2267* excited nucleons (ISTHKK=15,16)
2268 CALL DT_SCN4BA
2269
2270* decay of resonances produced in intranuclear cascade processes
2271**sr 15-11-95 should be obsolete
2272C IF (LFZC) CALL DT_DECAY1
2273
2274 101 CONTINUE
2275* treatment of residual nuclei
2276 CALL DT_RESNCL(EPN,NLOOP,2)
2277
2278* evaporation / fission / fragmentation
2279* (if intranuclear cascade was sampled only)
2280 IF (LFZC) THEN
2281 CALL DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ1)
2282 IF (IREJ1.GT.1) GOTO 101
2283 IF (IREJ1.EQ.1) GOTO 100
2284 ENDIF
2285
2286 ENDIF
2287
2288* rejection of unphysical configurations
2289 CALL DT_REJUCO(1,IREJ1)
2290 IF (IREJ1.GT.0) THEN
2291 IF (IOULEV(1).GT.0)
2292 & WRITE(LOUT,*) 'rejected 3 in KKINC: too large x'
2293 GOTO 100
2294 ENDIF
2295
2296* transform finale state into Lab.
2297 IFLAG = 2
2298 CALL DT_BEAMPR(WHAT,DUM,IFLAG)
2299 IF ((IFRAME.EQ.1).AND.(IFLAG.EQ.-1)) CALL DT_LT2LAB
2300
2301 IF (IPI0.EQ.1) CALL DT_DECPI0
2302
2303C IF (NEVHKK.EQ.5) CALL DT_EVTOUT(4)
9aaba0d6 2304 RETURN
2305 9999 CONTINUE
2306 IREJ = 1
09b429a4 2307
9aaba0d6 2308 RETURN
2309 END
2310
2311*$ CREATE DT_DEFAUL.FOR
2312*COPY DT_DEFAUL
2313*
2314*===defaul=============================================================*
2315*
2316 SUBROUTINE DT_DEFAUL(EPN,PPN)
2317
2318************************************************************************
2319* Variables are set to default values. *
2320* This version dated 8.5.95 is written by S. Roesler. *
2321************************************************************************
2322
2323 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2324 SAVE
2325 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
2326 PARAMETER (TWOPI = 6.283185307179586454D+00)
2327
2328* particle properties (BAMJET index convention)
2329 CHARACTER*8 ANAME
2330 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2331 & IICH(210),IIBAR(210),K1(210),K2(210)
2332* nuclear potential
2333 LOGICAL LFERMI
2334 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
2335 & EBINDP(2),EBINDN(2),EPOT(2,210),
2336 & ETACOU(2),ICOUL,LFERMI
2337* interface HADRIN-DPM
2338 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
2339* central particle production, impact parameter biasing
2340 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
2341* properties of interacting particles
2342 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2343* properties of photon/lepton projectiles
2344 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
2345 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2346* emulsion treatment
2347 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2348 & NCOMPO,IEMUL
2349* parameter for intranuclear cascade
2350 LOGICAL LPAULI
2351 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
2352* various options for treatment of partons (DTUNUC 1.x)
2353* (chain recombination, Cronin,..)
2354 LOGICAL LCO2CR,LINTPT
2355 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
2356 & LCO2CR,LINTPT
2357* threshold values for x-sampling (DTUNUC 1.x)
2358 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
2359 & SSMIMQ,VVMTHR
2360* flags for input different options
2361 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2362 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2363 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2364* n-n cross section fluctuations
2365 PARAMETER (NBINS = 1000)
2366 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
2367* flags for particle decays
2368 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
2369 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
2370 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
2371* diquark-breaking mechanism
2372 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
2373* nucleon-nucleon event-generator
2374 CHARACTER*8 CMODEL
2375 LOGICAL LPHOIN
2376 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
2377* flags for diffractive interactions (DTUNUC 1.x)
2378 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
2379* VDM parameter for photon-nucleus interactions
2380 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
2381* Glauber formalism: flags and parameters for statistics
2382 LOGICAL LPROD
2383 CHARACTER*8 CGLB
2384 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
2385* kinematical cuts for lepton-nucleus interactions
2386 COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
2387 & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
2388* flags for activated histograms
2389 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
2390* cuts for variable energy runs
2391 COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
2392* parameters for hA-diffraction
2393 COMMON /DTDIHA/ DIBETA,DIALPH
2394* LEPTO
2395 REAL RPPN
2396 COMMON /LEPTOI/ RPPN,LEPIN,INTER
2397* steering flags for qel neutrino scattering modules
2398 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
2399* event flag
2400 COMMON /DTEVNO/ NEVENT,ICASCA
2401
2402 DATA POTMES /0.002D0/
2403
2404* common /DTNPOT/
2405 DO 10 I=1,2
2406 PFERMP(I) = ZERO
2407 PFERMN(I) = ZERO
2408 EBINDP(I) = ZERO
2409 EBINDN(I) = ZERO
2410 DO 11 J=1,210
2411 EPOT(I,J) = ZERO
2412 11 CONTINUE
2413* nucleus independent meson potential
2414 EPOT(I,13) = POTMES
2415 EPOT(I,14) = POTMES
2416 EPOT(I,15) = POTMES
2417 EPOT(I,16) = POTMES
2418 EPOT(I,23) = POTMES
2419 EPOT(I,24) = POTMES
2420 EPOT(I,25) = POTMES
2421 10 CONTINUE
2422 FERMOD = 0.55D0
2423 ETACOU(1) = ZERO
2424 ETACOU(2) = ZERO
2425 ICOUL = 1
2426 LFERMI = .TRUE.
2427
2428* common /HNTHRE/
2429 EHADTH = -99.0D0
2430 EHADLO = 4.06D0
2431 EHADHI = 6.0D0
2432 INTHAD = 1
2433 IDXTA = 2
2434
2435* common /DTIMPA/
2436 ICENTR = 0
2437 BIMIN = ZERO
2438 BIMAX = 1.0D10
2439 XSFRAC = 1.0D0
2440
2441* common /DTPRTA/
2442 IP = 1
2443 IPZ = 1
2444 IT = 1
2445 ITZ = 1
2446 IJPROJ = 1
2447 IBPROJ = 1
2448 IJTARG = 1
2449 IBTARG = 1
2450* common /DTGPRO/
2451 VIRT = ZERO
2452 DO 14 I=1,4
2453 PGAMM(I) = ZERO
2454 PLEPT0(I) = ZERO
2455 PLEPT1(I) = ZERO
2456 PNUCL(I) = ZERO
2457 14 CONTINUE
2458 IDIREC = 0
2459
2460* common /DTFOTI/
2461**sr 7.4.98: changed after corrected B-sampling
2462C TAUFOR = 4.4D0
2463 TAUFOR = 3.5D0
2464 KTAUGE = 25
2465 ITAUVE = 1
2466 INCMOD = 1
2467 LPAULI = .TRUE.
2468
2469* common /DTCHAI/
2470 SEASQ = ONE
2471 MKCRON = 1
2472 CRONCO = 0.64D0
2473 ISICHA = 0
2474 CUTOF = 100.0D0
2475 LCO2CR = .FALSE.
2476 IRECOM = 1
2477 LINTPT = .TRUE.
2478
2479* common /DTXCUT/
2480* definition of soft quark distributions
2481 XSEACU = 0.05D0
2482 UNON = 2.0D0
2483 UNOM = 1.5D0
2484 UNOSEA = 5.0D0
2485* cutoff parameters for x-sampling
2486 CVQ = 1.0D0
2487 CDQ = 2.0D0
2488C CSEA = 0.3D0
2489 CSEA = 0.1D0
2490 SSMIMA = 1.2D0
2491 SSMIMQ = SSMIMA**2
2492 VVMTHR = 2.0D0
2493
2494* common /DTXSFL/
2495 IFLUCT = 0
2496
2497* common /DTFRPA/
2498 PDB = 0.15D0
2499 PDBSEA(1) = 0.0D0
2500 PDBSEA(2) = 0.0D0
2501 PDBSEA(3) = 0.0D0
2502 ISIG0 = 0
2503 IPI0 = 0
2504 NMSTU = 0
2505 NPARU = 0
2506 NMSTJ = 0
2507 NPARJ = 0
2508
2509* common /DTDIQB/
2510 DO 15 I=1,8
2511 DBRKR(1,I) = 5.0D0
2512 DBRKR(2,I) = 5.0D0
2513 DBRKR(3,I) = 10.0D0
2514 DBRKA(1,I) = ZERO
2515 DBRKA(2,I) = ZERO
2516 DBRKA(3,I) = ZERO
2517 15 CONTINUE
2518 CHAM1 = 0.2D0
2519 CHAM3 = 0.5D0
2520 CHAB1 = 0.7D0
2521 CHAB3 = 1.0D0
2522
2523* common /DTFLG3/
2524 ISINGD = 0
2525 IDOUBD = 0
2526 IFLAGD = 0
2527 IDIFF = 0
2528
2529* common /DTMODL/
2530 MCGENE = 2
2531 CMODEL(1) = 'DTUNUC '
2532 CMODEL(2) = 'PHOJET '
2533 CMODEL(3) = 'LEPTO '
2534 CMODEL(4) = 'QNEUTRIN'
2535 LPHOIN = .TRUE.
2536 ELOJET = 5.0D0
2537
2538* common /DTLCUT/
2539 ECMIN = 3.5D0
2540 ECMAX = 1.0D10
2541 XBJMIN = ZERO
2542 ELMIN = ZERO
2543 EGMIN = ZERO
2544 EGMAX = 1.0D10
2545 YMIN = TINY10
2546 YMAX = 0.999D0
2547 Q2MIN = TINY10
2548 Q2MAX = 10.0D0
2549 THMIN = ZERO
2550 THMAX = TWOPI
2551 Q2LI = ZERO
2552 Q2HI = 1.0D10
2553 ECMLI = ZERO
2554 ECMHI = 1.0D10
2555
2556* common /DTVDMP/
2557 RL2 = 2.0D0
2558 INTRGE(1) = 1
2559 INTRGE(2) = 3
2560 IDPDF = 2212
2561 MODEGA = 4
2562 ISHAD(1) = 1
2563 ISHAD(2) = 1
2564 ISHAD(3) = 1
2565 EPSPOL = ZERO
2566
2567* common /DTGLGP/
2568 JSTATB = 1000
2569 JBINSB = 49
2570 CGLB = ' '
2571 IF (ITRSPT.EQ.1) THEN
2572 IOGLB = 100
2573 ELSE
2574 IOGLB = 0
2575 ENDIF
2576 LPROD = .TRUE.
2577
2578* common /DTHIS3/
2579 DO 16 I=1,50
2580 IHISPP(I) = 0
2581 IHISXS(I) = 0
2582 16 CONTINUE
2583 IXSTBL = 0
2584
2585* common /DTVARE/
2586 VARELO = ZERO
2587 VAREHI = ZERO
2588 VARCLO = ZERO
2589 VARCHI = ZERO
2590
2591* common /DTDIHA/
2592 DIBETA = -1.0D0
2593 DIALPH = ZERO
2594
2595* common /LEPTOI/
2596 RPPN = 0.0
2597 LEPIN = 0
2598 INTER = 0
2599
2600* common /QNEUTO/
2601 NEUTYP = 1
2602 NEUDEC = 0
2603
2604* common /DTEVNO/
2605 NEVENT = 1
2606 IF (ITRSPT.EQ.1) THEN
2607 ICASCA = 1
2608 ELSE
2609 ICASCA = 0
2610 ENDIF
2611
2612* default Lab.-energy
2613 EPN = 200.0D0
2614 PPN = SQRT((EPN-AAM(IJPROJ))*(EPN+AAM(IJPROJ)))
2615
2616 RETURN
2617 END
2618
2619*$ CREATE DT_AAEVT.FOR
2620*COPY DT_AAEVT
2621*
2622*===aaevt==============================================================*
2623*
2624 SUBROUTINE DT_AAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
2625 & IDP,IGLAU)
2626
2627************************************************************************
2628* This version dated 22.03.96 is written by S. Roesler. *
2629************************************************************************
2630
2631 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2632 SAVE
2633 PARAMETER ( LINP = 10 ,
2634 & LOUT = 6 ,
2635 & LDAT = 9 )
2636
2637 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2638* emulsion treatment
2639 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2640 & NCOMPO,IEMUL
2641* event flag
2642 COMMON /DTEVNO/ NEVENT,ICASCA
9aaba0d6 2643 CHARACTER*8 DATE,HHMMSS
2644 DIMENSION IDMNYR(3)
09b429a4 2645 NSD1 = 0
2646 NSD2 = 0
2647 NDD = 0
9aaba0d6 2648 KKMAT = 1
2649 NMSG = MAX(NEVTS/100,1)
2650
2651* initialization of run-statistics and histograms
2652 CALL DT_STATIS(1)
2653 CALL PHO_PHIST(1000,DUM)
2654
2655* initialization of Glauber-formalism
2656 IF (NCOMPO.LE.0) THEN
2657 CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
2658 ELSE
2659 DO 1 I=1,NCOMPO
2660 CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
2661 1 CONTINUE
2662 ENDIF
2663 CALL DT_SIGEMU
2664
2665 CALL IDATE(IDMNYR)
2666 WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2667 & IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
2668 CALL ITIME(IDMNYR)
2669 WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)')
2670 & IDMNYR(1),IDMNYR(2),IDMNYR(3)
2671 WRITE(LOUT,1001) DATE,HHMMSS
2672 1001 FORMAT(/,' DT_AAEVT: Initialisation finished. ( Date: ',A8,
2673 & ' Time: ',A8,' )')
2674
2675* generate NEVTS events
2676 DO 2 IEVT=1,NEVTS
2677
2678* print run-status message
2679 IF (MOD(IEVT,NMSG).EQ.0) THEN
2680 CALL IDATE(IDMNYR)
2681 WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2682 & IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
2683 CALL ITIME(IDMNYR)
2684 WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)')
2685 & IDMNYR(1),IDMNYR(2),IDMNYR(3)
2686 WRITE(LOUT,1000) IEVT-1,NEVTS,DATE,HHMMSS
2687 1000 FORMAT(/,1X,I8,' out of ',I8,' events sampled ( Date: ',A,
2688 & ' Time: ',A,' )',/)
2689C WRITE(LOUT,1000) IEVT-1
2690C1000 FORMAT(1X,I8,' events sampled')
2691 ENDIF
2692 NEVENT = IEVT
2693* treat nuclear emulsions
2694 IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
2695* composite targets only
2696 KKMAT = -KKMAT
2697* sample this event
2698 CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,IREJ)
2699
2700 CALL PHO_PHIST(2000,DUM)
09b429a4 2701
2702 write(6,*) "Diffractive collisions", NSD1, NSD2, NDD
9aaba0d6 2703
2704 2 CONTINUE
2705
2706* print run-statistics and histograms to output-unit 6
2707 CALL PHO_PHIST(3000,DUM)
2708 CALL DT_STATIS(2)
9aaba0d6 2709 RETURN
2710 END
2711
2712*$ CREATE DT_LAEVT.FOR
2713*COPY DT_LAEVT
2714*
2715*===laevt==============================================================*
2716*
2717 SUBROUTINE DT_LAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
2718 & IDP,IGLAU)
2719
2720************************************************************************
2721* Interface to run DPMJET for lepton-nucleus interactions. *
2722* Kinematics is sampled using the equivalent photon approximation *
2723* Based on GPHERA-routine by R. Engel. *
2724* This version dated 23.03.96 is written by S. Roesler. *
2725************************************************************************
2726
2727 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2728 SAVE
2729 PARAMETER ( LINP = 10 ,
2730 & LOUT = 6 ,
2731 & LDAT = 9 )
2732 PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,
2733 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
2734 PARAMETER (TWOPI = 6.283185307179586454D+00,
2735 & PI = TWOPI/TWO,
2736 & ALPHEM = ONE/137.0D0)
2737
2738C CHARACTER*72 HEADER
2739
2740* particle properties (BAMJET index convention)
2741 CHARACTER*8 ANAME
2742 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2743 & IICH(210),IIBAR(210),K1(210),K2(210)
2744* event history
2745 PARAMETER (NMXHKK=200000)
2746 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
2747 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
2748 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
2749* extended event history
2750 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
2751 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
2752 & IHIST(2,NMXHKK)
2753* kinematical cuts for lepton-nucleus interactions
2754 COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
2755 & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
2756* properties of interacting particles
2757 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2758* properties of photon/lepton projectiles
2759 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
2760* kinematics at lepton-gamma vertex
2761 COMMON /DTLGVX/ PPL0(4),PPL1(4),PPG(4),PPA(4)
2762* flags for activated histograms
2763 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
2764 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2765* emulsion treatment
2766 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2767 & NCOMPO,IEMUL
2768* Glauber formalism: cross sections
2769 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
2770 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
2771 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
2772 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
2773 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
2774 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
2775 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
2776 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
2777 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
2778 & BSLOPE,NEBINI,NQBINI
2779* nucleon-nucleon event-generator
2780 CHARACTER*8 CMODEL
2781 LOGICAL LPHOIN
2782 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
2783* flags for input different options
2784 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2785 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2786 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2787* event flag
2788 COMMON /DTEVNO/ NEVENT,ICASCA
2789
2790 DIMENSION XDUMB(40),BGTA(4)
2791
2792* LEPTO
2793 IF (MCGENE.EQ.3) THEN
2794 STOP ' This version does not contain LEPTO !'
2795 ENDIF
2796
2797 KKMAT = 1
2798 NMSG = MAX(NEVTS/10,1)
2799
2800* mass of incident lepton
2801 AMLPT = AAM(IDP)
2802 AMLPT2 = AMLPT**2
2803 IDPPDG = IDT_IPDGHA(IDP)
2804
2805* consistency of kinematical limits
2806 Q2MIN = MAX(Q2MIN,TINY10)
2807 Q2MAX = MAX(Q2MAX,TINY10)
2808 YMIN = MIN(MAX(YMIN,TINY10),0.999D0)
2809 YMAX = MIN(MAX(YMAX,TINY10),0.999D0)
2810
2811* total energy of the lepton-nucleon system
2812 PTOTLN = SQRT( (PLEPT0(1)+PNUCL(1))**2+(PLEPT0(2)+PNUCL(2))**2
2813 & +(PLEPT0(3)+PNUCL(3))**2 )
2814 ETOTLN = PLEPT0(4)+PNUCL(4)
2815 ECMLN = SQRT((ETOTLN-PTOTLN)*(ETOTLN+PTOTLN))
2816 ECMAX = MIN(ECMAX,ECMLN)
2817 WRITE(LOUT,1003) ECMIN,ECMAX,YMIN,YMAX,Q2MIN,Q2MAX,EGMIN,
2818 & THMIN,THMAX,ELMIN
2819 1003 FORMAT(1X,'LAEVT:',16X,'kinematical cuts',/,22X,
2820 & '------------------',/,9X,'W (min) =',
2821 & F7.1,' GeV (max) =',F7.1,' GeV',/,9X,'y (min) =',
2822 & F7.3,8X,'(max) =',F7.3,/,9X,'Q^2 (min) =',F7.1,
2823 & ' GeV^2 (max) =',F7.1,' GeV^2',/,' (Lab) E_g (min) ='
2824 & ,F7.1,' GeV',/,' (Lab) theta (min) =',F7.4,8X,'(max) =',
2825 & F7.4,' for E_lpt >',F7.1,' GeV',/)
2826
2827* Lorentz-parameter for transf. into Lab
2828 BGTA(1) = PNUCL(1)/AAM(1)
2829 BGTA(2) = PNUCL(2)/AAM(1)
2830 BGTA(3) = PNUCL(3)/AAM(1)
2831 BGTA(4) = PNUCL(4)/AAM(1)
2832* LT of incident lepton into Lab and dump it in DTEVT1
2833 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
2834 & PLEPT0(1),PLEPT0(2),PLEPT0(3),PLEPT0(4),
2835 & PLTOT,PPL0(1),PPL0(2),PPL0(3),PPL0(4))
2836 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
2837 & PNUCL(1),PNUCL(2),PNUCL(3),PNUCL(4),
2838 & PLTOT,PPA(1),PPA(2),PPA(3),PPA(4))
2839* maximum energy of photon nucleon system
2840 PTOTGN = SQRT((YMAX*PPL0(1)+PPA(1))**2+(YMAX*PPL0(2)+PPA(2))**2
2841 & +(YMAX*PPL0(3)+PPA(3))**2)
2842 ETOTGN = YMAX*PPL0(4)+PPA(4)
2843 EGNMAX = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN))
2844 EGNMAX = MIN(EGNMAX,ECMAX)
2845* minimum energy of photon nucleon system
2846 PTOTGN = SQRT((YMIN*PPL0(1)+PPA(1))**2+(YMIN*PPL0(2)+PPA(2))**2
2847 & +(YMIN*PPL0(3)+PPA(3))**2)
2848 ETOTGN = YMIN*PPL0(4)+PPA(4)
2849 EGNMIN = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN))
2850 EGNMIN = MAX(EGNMIN,ECMIN)
2851
2852* limits for Glauber-initialization
2853 Q2LI = Q2MIN
2854 Q2HI = MAX(Q2LI,MIN(Q2HI,Q2MAX))
2855 ECMLI = MAX(EGNMIN,THREE)
2856 ECMHI = EGNMAX
2857 WRITE(LOUT,1004) EGNMIN,EGNMAX,ECMLI,ECMHI,Q2LI,Q2HI
2858 1004 FORMAT(1X,'resulting limits:',/,9X,'W (min) =',F7.1,
2859 & ' GeV (max) =',F7.1,' GeV',/,/,' limits for ',
2860 & 'Glauber-initialization:',/,9X,'W (min) =',F7.1,
2861 & ' GeV (max) =',F7.1,' GeV',/,9X,'Q^2 (min) =',F7.1,
2862 & ' GeV^2 (max) =',F7.1,' GeV^2',/)
2863* initialization of Glauber-formalism
2864 IF (NCOMPO.LE.0) THEN
2865 CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
2866 ELSE
2867 DO 9 I=1,NCOMPO
2868 CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
2869 9 CONTINUE
2870 ENDIF
2871 CALL DT_SIGEMU
2872
2873* initialization of run-statistics and histograms
2874 CALL DT_STATIS(1)
2875 CALL PHO_PHIST(1000,DUM)
2876
2877* maximum photon-nucleus cross section
2878 I1 = 1
2879 I2 = 1
2880 RAT = ONE
2881 IF (EGNMAX.GE.ECMNN(NEBINI)) THEN
2882 I1 = NEBINI
2883 I2 = NEBINI
2884 RAT = ONE
2885 ELSEIF (EGNMAX.GT.ECMNN(1)) THEN
2886 DO 5 I=2,NEBINI
2887 IF (EGNMAX.LT.ECMNN(I)) THEN
2888 I1 = I-1
2889 I2 = I
2890 RAT = (EGNMAX-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
2891 GOTO 6
2892 ENDIF
2893 5 CONTINUE
2894 6 CONTINUE
2895 ENDIF
2896 SIGMAX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
2897 EGNXX = EGNMAX
2898 I1 = 1
2899 I2 = 1
2900 RAT = ONE
2901 IF (EGNMIN.GE.ECMNN(NEBINI)) THEN
2902 I1 = NEBINI
2903 I2 = NEBINI
2904 RAT = ONE
2905 ELSEIF (EGNMIN.GT.ECMNN(1)) THEN
2906 DO 7 I=2,NEBINI
2907 IF (EGNMIN.LT.ECMNN(I)) THEN
2908 I1 = I-1
2909 I2 = I
2910 RAT = (EGNMIN-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
2911 GOTO 8
2912 ENDIF
2913 7 CONTINUE
2914 8 CONTINUE
2915 ENDIF
2916 SIGXX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
2917 IF (SIGXX.GT.SIGMAX) EGNXX = EGNMIN
2918 SIGMAX = MAX(SIGMAX,SIGXX)
2919 WRITE(LOUT,'(9X,A,F8.3,A)') 'Sigma_tot (max) =',SIGMAX,' mb'
2920
2921* plot photon flux table
2922 AYMIN = LOG(YMIN)
2923 AYMAX = LOG(YMAX)
2924 AYRGE = AYMAX-AYMIN
2925 MAXTAB = 50
2926 ADY = LOG(YMAX/YMIN)/DBLE(MAXTAB-1)
2927C WRITE(LOUT,'(/,1X,A)') 'LAEVT: photon flux '
2928 DO 1 I=1,MAXTAB
2929 Y = EXP(AYMIN+ADY*DBLE(I-1))
2930 Q2LOW = MAX(Q2MIN,AMLPT2*Y**2/(ONE-Y))
2931 FF1 = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
2932 & -TWO*AMLPT2*Y*(ONE/Q2LOW-ONE/Q2MAX))
2933 FF2 = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
2934 & -TWO*(ONE-Y)/Y*(ONE-Q2LOW/Q2MAX))
2935C WRITE(LOUT,'(5X,3E15.4)') Y,FF1,FF2
2936 1 CONTINUE
2937
2938* maximum residual weight for flux sampling (dy/y)
2939 YY = YMIN
2940 Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY))
2941 WGHMAX = (ONE+(ONE-YY)**2)*LOG(Q2MAX/Q2LOW)
2942 & -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY
2943
2944 CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY0)
2945 CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY1)
2946 CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY2)
2947 CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ0)
2948 CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ1)
2949 CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ2)
2950 CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE0)
2951 CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE1)
2952 CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE2)
2953 CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU0)
2954 CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU1)
2955 CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU2)
2956 XBLOW = 0.001D0
2957 CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX0)
2958 CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX1)
2959 CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX2)
2960
2961 ITRY = 0
2962 ITRW = 0
2963 NC0 = 0
2964 NC1 = 0
2965
2966* generate events
2967 DO 2 IEVT=1,NEVTS
2968 IF (MOD(IEVT,NMSG).EQ.0) THEN
2969C OPEN(LDAT,FILE='/scrtch3/hr/sroesler/statusd5.out',
2970C & STATUS='UNKNOWN')
2971 WRITE(LOUT,'(1X,I8,A)') IEVT-1,' events sampled'
2972C CLOSE(LDAT)
2973 ENDIF
2974 NEVENT = IEVT
2975
2976 100 CONTINUE
2977 ITRY = ITRY+1
2978
2979* sample y
2980 101 CONTINUE
2981 ITRW = ITRW+1
2982 YY = EXP(AYRGE*DT_RNDM(RAT)+AYMIN)
2983 Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY))
2984 Q2LOG = LOG(Q2MAX/Q2LOW)
2985 WGH = (ONE+(ONE-YY)**2)*Q2LOG
2986 & -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY
2987 IF (WGHMAX.LT.WGH) WRITE(LOUT,1000) YY,WGHMAX,WGH
2988 1000 FORMAT(1X,'LAEVT: weight error!',3E12.5)
2989 IF (DT_RNDM(YY)*WGHMAX.GT.WGH) GOTO 101
2990
2991* sample Q2
2992 YEFF = ONE+(ONE-YY)**2
2993 102 CONTINUE
2994 Q2 = Q2LOW*EXP(Q2LOG*DT_RNDM(YY))
2995 WGH = (YEFF-TWO*(ONE-YY)*Q2LOW/Q2)/YEFF
2996 IF (WGH.LT.DT_RNDM(Q2)) GOTO 102
2997
2998c NC0 = NC0+1
2999c CALL DT_FILHGR(YY,ONE,IHFLY0,NC0)
3000c CALL DT_FILHGR(Q2,ONE,IHFLQ0,NC0)
3001
3002* kinematics at lepton-photon vertex
3003* scattered electron
3004 YQ2 = SQRT((ONE-YY)*Q2)
3005 Q2E = Q2/(4.0D0*PLEPT0(4))
3006 E1Y = (ONE-YY)*PLEPT0(4)
3007 CALL DT_DSFECF(SIF,COF)
3008 PLEPT1(1) = YQ2*COF
3009 PLEPT1(2) = YQ2*SIF
3010 PLEPT1(3) = E1Y-Q2E
3011 PLEPT1(4) = E1Y+Q2E
3012C THETA = ACOS( (E1Y-Q2E)/(E1Y+Q2E) )
3013* radiated photon
3014 PGAMM(1) = -PLEPT1(1)
3015 PGAMM(2) = -PLEPT1(2)
3016 PGAMM(3) = PLEPT0(3)-PLEPT1(3)
3017 PGAMM(4) = PLEPT0(4)-PLEPT1(4)
3018* E_cm cut
3019 PTOTGN = SQRT( (PGAMM(1)+PNUCL(1))**2+(PGAMM(2)+PNUCL(2))**2
3020 & +(PGAMM(3)+PNUCL(3))**2 )
3021 ETOTGN = PGAMM(4)+PNUCL(4)
3022 ECMGN = (ETOTGN-PTOTGN)*(ETOTGN+PTOTGN)
3023 IF (ECMGN.LT.0.1D0) GOTO 101
3024 ECMGN = SQRT(ECMGN)
3025 IF ((ECMGN.LT.ECMIN).OR.(ECMGN.GT.ECMAX)) GOTO 101
3026
3027* Lorentz-transformation into nucleon-rest system
3028 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3029 & PGAMM(1),PGAMM(2),PGAMM(3),PGAMM(4),
3030 & PGTOT,PPG(1),PPG(2),PPG(3),PPG(4))
3031 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3032 & PLEPT1(1),PLEPT1(2),PLEPT1(3),PLEPT1(4),
3033 & PLTOT,PPL1(1),PPL1(2),PPL1(3),PPL1(4))
3034* temporary checks..
3035 Q2TMP = ABS(PPG(4)**2-PGTOT**2)
3036 IF (ABS(Q2-Q2TMP).GT.0.01D0) WRITE(LOUT,1001) Q2,Q2TMP
3037 1001 FORMAT(1X,'LAEVT: inconsistent kinematics (Q2,Q2TMP) ',
3038 & 2F10.4)
3039 ECMTMP = SQRT((PPG(4)+AAM(1)-PGTOT)*(PPG(4)+AAM(1)+PGTOT))
3040 IF (ABS(ECMGN-ECMTMP).GT.TINY10) WRITE(LOUT,1002) ECMGN,ECMTMP
3041 1002 FORMAT(1X,'LAEVT: inconsistent kinematics (ECMGN,ECMTMP) ',
3042 & 2F10.2)
3043 YYTMP = PPG(4)/PPL0(4)
3044 IF (ABS(YY-YYTMP).GT.0.01D0) WRITE(LOUT,1005) YY,YYTMP
3045 1005 FORMAT(1X,'LAEVT: inconsistent kinematics (YY,YYTMP) ',
3046 & 2F10.4)
3047
3048* lepton tagger (Lab)
3049 THETA = ACOS( PPL1(3)/PLTOT )
3050 IF (PPL1(4).GT.ELMIN) THEN
3051 IF ((THETA.LT.THMIN).OR.(THETA.GT.THMAX)) GOTO 101
3052 ENDIF
3053* photon energy-cut (Lab)
3054 IF (PPG(4).LT.EGMIN) GOTO 101
3055 IF (PPG(4).GT.EGMAX) GOTO 101
3056* x_Bj cut
3057 XBJ = ABS(Q2/(1.876D0*PPG(4)))
3058 IF (XBJ.LT.XBJMIN) GOTO 101
3059
3060 NC0 = NC0+1
3061 CALL DT_FILHGR( Q2,ONE,IHFLQ0,NC0)
3062 CALL DT_FILHGR( YY,ONE,IHFLY0,NC0)
3063 CALL DT_FILHGR( XBJ,ONE,IHFLX0,NC0)
3064 CALL DT_FILHGR(PPG(4),ONE,IHFLU0,NC0)
3065 CALL DT_FILHGR( ECMGN,ONE,IHFLE0,NC0)
3066
3067* rotation angles against z-axis
3068 COD = PPG(3)/PGTOT
3069C SID = SQRT((ONE-COD)*(ONE+COD))
3070 PPT = SQRT(PPG(1)**2+PPG(2)**2)
3071 SID = PPT/PGTOT
3072 COF = ONE
3073 SIF = ZERO
3074 IF (PGTOT*SID.GT.TINY10) THEN
3075 COF = PPG(1)/(SID*PGTOT)
3076 SIF = PPG(2)/(SID*PGTOT)
3077 ANORF = SQRT(COF*COF+SIF*SIF)
3078 COF = COF/ANORF
3079 SIF = SIF/ANORF
3080 ENDIF
3081
3082 IF (IXSTBL.EQ.0) THEN
3083* change to photon projectile
3084 IJPROJ = 7
3085* set virtuality
3086 VIRT = Q2
3087* re-initialize LTs with new kinematics
3088* !!PGAMM ist set in cms (ECMGN) along z
3089 EPN = ZERO
3090 PPN = ZERO
3091 CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,ECMGN,0)
3092* force Lab-system
3093 IFRAME = 1
3094* get emulsion component if requested
3095 IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
3096* convolute with cross section
3097 CALL DT_SIGGAT(Q2LOW,EGNXX,STOTX,KKMAT)
3098 CALL DT_SIGGAT(Q2,ECMGN,STOT,KKMAT)
3099 IF (STOTX.LT.STOT) WRITE(LOUT,'(1X,A,/,6E12.3)')
3100 & 'LAEVT: warning STOTX<STOT ! ',Q2LOW,EGNMAX,STOTX,
3101 & Q2,ECMGN,STOT
3102 IF (DT_RNDM(Q2)*STOTX.GT.STOT) GOTO 100
3103 NC1 = NC1+1
3104 CALL DT_FILHGR( Q2,ONE,IHFLQ1,NC1)
3105 CALL DT_FILHGR( YY,ONE,IHFLY1,NC1)
3106 CALL DT_FILHGR( XBJ,ONE,IHFLX1,NC1)
3107 CALL DT_FILHGR(PPG(4),ONE,IHFLU1,NC1)
3108 CALL DT_FILHGR( ECMGN,ONE,IHFLE1,NC1)
3109* composite targets only
3110 KKMAT = -KKMAT
3111* sample this event
3112 CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IJPROJ,EPN,KKMAT,
3113 & IREJ)
3114* rotate momenta of final state particles back in photon-nucleon syst.
3115 DO 4 I=NPOINT(4),NHKK
3116 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
3117 & (ISTHKK(I).EQ.1001)) THEN
3118 PX = PHKK(1,I)
3119 PY = PHKK(2,I)
3120 PZ = PHKK(3,I)
3121 CALL DT_MYTRAN(1,PX,PY,PZ,COD,SID,COF,SIF,
3122 & PHKK(1,I),PHKK(2,I),PHKK(3,I))
3123 ENDIF
3124 4 CONTINUE
3125 ENDIF
3126
3127 CALL DT_FILHGR( Q2,ONE,IHFLQ2,NC1)
3128 CALL DT_FILHGR( YY,ONE,IHFLY2,NC1)
3129 CALL DT_FILHGR( XBJ,ONE,IHFLX2,NC1)
3130 CALL DT_FILHGR(PPG(4),ONE,IHFLU2,NC1)
3131 CALL DT_FILHGR( ECMGN,ONE,IHFLE2,NC1)
3132
3133* dump this event to histograms
3134 CALL PHO_PHIST(2000,DUM)
3135
3136 2 CONTINUE
3137
3138 WGY = ALPHEM/TWOPI*WGHMAX*DBLE(ITRY)/DBLE(ITRW)
3139 WGY = WGY*LOG(YMAX/YMIN)
3140 WEIGHT = WGY*SIGMAX*DBLE(NEVTS)/DBLE(ITRY)
3141
3142C HEADER = ' LAEVT: Q^2 distribution 0'
3143C CALL DT_OUTHGR(IHFLQ0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3144C HEADER = ' LAEVT: Q^2 distribution 1'
3145C CALL DT_OUTHGR(IHFLQ1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3146C HEADER = ' LAEVT: Q^2 distribution 2'
3147C CALL DT_OUTHGR(IHFLQ2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3148C HEADER = ' LAEVT: y distribution 0'
3149C CALL DT_OUTHGR(IHFLY0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3150C HEADER = ' LAEVT: y distribution 1'
3151C CALL DT_OUTHGR(IHFLY1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3152C HEADER = ' LAEVT: y distribution 2'
3153C CALL DT_OUTHGR(IHFLY2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3154C HEADER = ' LAEVT: x distribution 0'
3155C CALL DT_OUTHGR(IHFLX0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3156C HEADER = ' LAEVT: x distribution 1'
3157C CALL DT_OUTHGR(IHFLX1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3158C HEADER = ' LAEVT: x distribution 2'
3159C CALL DT_OUTHGR(IHFLX2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3160C HEADER = ' LAEVT: E_g distribution 0'
3161C CALL DT_OUTHGR(IHFLU0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3162C HEADER = ' LAEVT: E_g distribution 1'
3163C CALL DT_OUTHGR(IHFLU1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3164C HEADER = ' LAEVT: E_g distribution 2'
3165C CALL DT_OUTHGR(IHFLU2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3166C HEADER = ' LAEVT: E_c distribution 0'
3167C CALL DT_OUTHGR(IHFLE0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3168C HEADER = ' LAEVT: E_c distribution 1'
3169C CALL DT_OUTHGR(IHFLE1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3170C HEADER = ' LAEVT: E_c distribution 2'
3171C CALL DT_OUTHGR(IHFLE2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3172
3173* print run-statistics and histograms to output-unit 6
3174 CALL PHO_PHIST(3000,DUM)
3175 IF (IXSTBL.EQ.0) CALL DT_STATIS(2)
3176
3177 RETURN
3178 END
3179
3180*$ CREATE DT_DTUINI.FOR
3181*COPY DT_DTUINI
3182*
3183*===dtuini=============================================================*
3184*
3185 SUBROUTINE DT_DTUINI(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
3186 & IDP,IEMU)
3187
3188 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3189 SAVE
3190
3191 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
3192* emulsion treatment
3193 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
3194 & NCOMPO,IEMUL
3195* Glauber formalism: flags and parameters for statistics
3196 LOGICAL LPROD
3197 CHARACTER*8 CGLB
3198 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
3199
3200 CALL DT_INIT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,IGLAU)
3201 CALL DT_STATIS(1)
3202 CALL PHO_PHIST(1000,DUM)
3203 IF (NCOMPO.LE.0) THEN
3204 CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
3205 ELSE
3206 DO 1 I=1,NCOMPO
3207 CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
3208 1 CONTINUE
3209 ENDIF
3210 IF (IOGLB.NE.100) CALL DT_SIGEMU
3211 IEMU = IEMUL
3212
3213 RETURN
3214 END
3215
3216*$ CREATE DT_DTUOUT.FOR
3217*COPY DT_DTUOUT
3218*
3219*===dtuout=============================================================*
3220*
3221 SUBROUTINE DT_DTUOUT
3222
3223 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3224 SAVE
3225
3226 CALL PHO_PHIST(3000,DUM)
3227 CALL DT_STATIS(2)
3228
3229 RETURN
3230 END
3231
3232*$ CREATE DT_BEAMPR.FOR
3233*COPY DT_BEAMPR
3234*
3235*===beampr=============================================================*
3236*
3237 SUBROUTINE DT_BEAMPR(WHAT,PLAB,MODE)
3238
3239************************************************************************
3240* Initialization of event generation *
3241* This version dated 7.4.98 is written by S. Roesler. *
3242************************************************************************
3243
3244 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3245 SAVE
3246
3247 PARAMETER ( LINP = 10 ,
3248 & LOUT = 6 ,
3249 & LDAT = 9 )
3250 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
3251 PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
3252
3253 LOGICAL LBEAM
3254
3255* event history
3256 PARAMETER (NMXHKK=200000)
3257 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3258 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3259 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3260* extended event history
3261 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3262 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3263 & IHIST(2,NMXHKK)
3264* properties of interacting particles
3265 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
3266* particle properties (BAMJET index convention)
3267 CHARACTER*8 ANAME
3268 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
3269 & IICH(210),IIBAR(210),K1(210),K2(210)
3270* beam momenta
3271 COMMON /DTBEAM/ P1(4),P2(4)
3272
3273C DIMENSION WHAT(6),P1(4),P2(4),P1CMS(4),P2CMS(4)
3274 DIMENSION WHAT(6),P1CMS(4),P2CMS(4)
3275
3276 DATA LBEAM /.FALSE./
3277
3278 GOTO (1,2) MODE
3279
3280 1 CONTINUE
3281
3282 E1 = WHAT(1)
3283 IF (E1.LT.ZERO) E1 = DBLE(IPZ)/DBLE(IP)*ABS(WHAT(1))
3284 E2 = WHAT(2)
3285 IF (E2.LT.ZERO) E2 = DBLE(ITZ)/DBLE(IT)*ABS(WHAT(2))
3286 PP1 = SQRT( (E1+AAM(IJPROJ))*(E1-AAM(IJPROJ)) )
3287 PP2 = SQRT( (E2+AAM(IJTARG))*(E2-AAM(IJTARG)) )
3288 TH = 1.D-6*WHAT(3)/2.D0
3289 PH = WHAT(4)*BOG
3290 P1(1) = PP1*SIN(TH)*COS(PH)
3291 P1(2) = PP1*SIN(TH)*SIN(PH)
3292 P1(3) = PP1*COS(TH)
3293 P1(4) = E1
3294 P2(1) = PP2*SIN(TH)*COS(PH)
3295 P2(2) = PP2*SIN(TH)*SIN(PH)
3296 P2(3) = -PP2*COS(TH)
3297 P2(4) = E2
3298 ECM = SQRT( (P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))**2
3299 & -(P1(3)+P2(3))**2 )
3300 ELAB = (ECM**2-AAM(IJPROJ)**2-AAM(IJTARG)**2)/(2.0D0*AAM(IJTARG))
3301 PLAB = SQRT( (ELAB+AAM(IJPROJ))*(ELAB-AAM(IJPROJ)) )
3302 BGX = (P1(1)+P2(1))/ECM
3303 BGY = (P1(2)+P2(2))/ECM
3304 BGZ = (P1(3)+P2(3))/ECM
3305 BGE = (P1(4)+P2(4))/ECM
3306 CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P1(1),P1(2),P1(3),P1(4),
3307 & P1TOT,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4))
3308 CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P2(1),P2(2),P2(3),P2(4),
3309 & P2TOT,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4))
3310 COD = P1CMS(3)/P1TOT
3311C SID = SQRT((ONE-COD)*(ONE+COD))
3312 PPT = SQRT(P1CMS(1)**2+P1CMS(2)**2)
3313 SID = PPT/P1TOT
3314 COF = ONE
3315 SIF = ZERO
3316 IF (P1TOT*SID.GT.TINY10) THEN
3317 COF = P1CMS(1)/(SID*P1TOT)
3318 SIF = P1CMS(2)/(SID*P1TOT)
3319 ANORF = SQRT(COF*COF+SIF*SIF)
3320 COF = COF/ANORF
3321 SIF = SIF/ANORF
3322 ENDIF
3323**check
3324C WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
3325C WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
3326C WRITE(LOUT,'(5E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),P1TOT
3327C WRITE(LOUT,'(5E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),P2TOT
3328C PAX = ZERO
3329C PAY = ZERO
3330C PAZ = P1TOT
3331C PAE = SQRT(AAM(IJPROJ)**2+PAZ**2)
3332C PBX = ZERO
3333C PBY = ZERO
3334C PBZ = -P2TOT
3335C PBE = SQRT(AAM(IJTARG)**2+PBZ**2)
3336C WRITE(LOUT,'(4E15.4)') PAX,PAY,PAZ,PAE
3337C WRITE(LOUT,'(4E15.4)') PBX,PBY,PBZ,PBE
3338C CALL DT_MYTRAN(1,PAX,PAY,PAZ,COD,SID,COF,SIF,
3339C & P1CMS(1),P1CMS(2),P1CMS(3))
3340C CALL DT_MYTRAN(1,PBX,PBY,PBZ,COD,SID,COF,SIF,
3341C & P2CMS(1),P2CMS(2),P2CMS(3))
3342C WRITE(LOUT,'(4E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4)
3343C WRITE(LOUT,'(4E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4)
3344C CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),
3345C & P1TOT,P1(1),P1(2),P1(3),P1(4))
3346C CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),
3347C & P2TOT,P2(1),P2(2),P2(3),P2(4))
3348C WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
3349C WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
3350C STOP
3351**
3352
3353 LBEAM = .TRUE.
3354
3355 RETURN
3356
3357 2 CONTINUE
3358
3359 IF (LBEAM) THEN
3360 IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
3361 DO 20 I=NPOINT(4),NHKK
430525dd 3362 IF ((ABS(ISTHKK(I)).EQ.1) .OR.
3363 & (ABS(ISTHKK(I)).EQ.2) .OR.
3364 & (ISTHKK(I).EQ.1000) .OR.
3365 & (ISTHKK(I).EQ.1001)) THEN
3366
9aaba0d6 3367 CALL DT_MYTRAN(1,PHKK(1,I),PHKK(2,I),PHKK(3,I),
3368 & COD,SID,COF,SIF,PXCMS,PYCMS,PZCMS)
3369 PECMS = PHKK(4,I)
3370 CALL DT_DALTRA(BGE,BGX,BGY,BGZ,PXCMS,PYCMS,PZCMS,PECMS,
3371 & PTOT,PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I))
3372 ENDIF
3373 20 CONTINUE
3374 ELSE
3375 MODE = -1
3376 ENDIF
3377
3378 RETURN
3379 END
3380
3381*$ CREATE DT_REJUCO.FOR
3382*COPY DT_REJUCO
3383*
3384*===rejuco=============================================================*
3385*
3386 SUBROUTINE DT_REJUCO(MODE,IREJ)
3387
3388************************************************************************
3389* REJection of Unphysical COnfigurations *
3390* MODE = 1 rejection of particles with unphysically large energy *
3391* *
3392* This version dated 27.12.2006 is written by S. Roesler. *
3393************************************************************************
3394
3395 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3396 SAVE
3397
3398 PARAMETER ( LINP = 10 ,
3399 & LOUT = 6 ,
3400 & LDAT = 9 )
3401 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
3402 PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
3403
3404* maximum x_cms of final state particle
3405 PARAMETER (XCMSMX = 1.4D0)
3406
3407* event history
3408 PARAMETER (NMXHKK=200000)
3409 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3410 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3411 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3412* extended event history
3413 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3414 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3415 & IHIST(2,NMXHKK)
3416* Lorentz-parameters of the current interaction
3417 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
3418 & UMO,PPCM,EPROJ,PPROJ
3419
3420 IREJ = 0
3421
3422 IF (MODE.EQ.1) THEN
3423 IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
3424 ECMHLF = UMO/2.0D0
3425 DO 10 I=NPOINT(4),NHKK
3426 IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDHKK(I).NE.80000)) THEN
3427 XCMS = ABS(PHKK(4,I))/ECMHLF
3428 IF (XCMS.GT.XCMSMX) GOTO 9999
3429 ENDIF
3430 10 CONTINUE
3431 ENDIF
3432
3433 RETURN
3434 9999 CONTINUE
3435 IREJ = 1
3436 RETURN
3437 END
3438
3439*$ CREATE DT_EVENTB.FOR
3440*COPY DT_EVENTB
3441*
3442*===eventb=============================================================*
3443*
3444 SUBROUTINE DT_EVENTB(NCSY,IREJ)
3445
3446************************************************************************
3447* Treatment of nucleon-nucleon interactions with full two-component *
3448* Dual Parton Model. *
3449* NCSY number of nucleon-nucleon interactions *
3450* IREJ rejection flag *
3451* This version dated 14.01.2000 is written by S. Roesler *
3452************************************************************************
3453
3454 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3455 SAVE
3456 PARAMETER ( LINP = 10 ,
3457 & LOUT = 6 ,
3458 & LDAT = 9 )
3459 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
3460
3461* event history
3462 PARAMETER (NMXHKK=200000)
3463 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3464 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3465 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3466* extended event history
3467 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3468 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3469 & IHIST(2,NMXHKK)
3470*! uncomment this line for internal phojet-fragmentation
3471C #include "dtu_dtevtp.inc"
3472* particle properties (BAMJET index convention)
3473 CHARACTER*8 ANAME
3474 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
3475 & IICH(210),IIBAR(210),K1(210),K2(210)
3476* flags for input different options
3477 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
3478 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
3479 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
3480* rejection counter
3481 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
3482 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
3483 & IREXCI(3),IRDIFF(2),IRINC
3484* properties of interacting particles
3485 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
3486* properties of photon/lepton projectiles
3487 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
3488* various options for treatment of partons (DTUNUC 1.x)
3489* (chain recombination, Cronin,..)
3490 LOGICAL LCO2CR,LINTPT
3491 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
3492 & LCO2CR,LINTPT
3493* statistics
3494 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
3495 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
3496 & ICEVTG(8,0:30)
3497* DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
3498 COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
3499* Glauber formalism: collision properties
3500 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
3501 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
3502* flags for diffractive interactions (DTUNUC 1.x)
3503 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
3504* statistics: double-Pomeron exchange
3505 COMMON /DTFLG2/ INTFLG,IPOPO
3506* flags for particle decays
3507 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
3508 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
3509 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
3510* nucleon-nucleon event-generator
3511 CHARACTER*8 CMODEL
3512 LOGICAL LPHOIN
3513 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
3514C nucleon-nucleus / nucleus-nucleus interface to DPMJET
3515 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
3516 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
3517 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
3518 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
3519C model switches and parameters
3520 CHARACTER*8 MDLNA
3521 INTEGER ISWMDL,IPAMDL
3522 DOUBLE PRECISION PARMDL
3523 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
3524C initial state parton radiation (internal part)
3525 INTEGER MXISR3,MXISR4
3526 PARAMETER ( MXISR3 = 50, MXISR4 = 100 )
3527 INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC
3528 DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT
3529 COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3),
3530 & ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3),
3531 & IFL1(2,MXISR3),IFL2(2,MXISR3),
3532 & IBRA(2,MXISR4),IFANO(2),ISH(2),NACC
3533C event debugging information
3534 INTEGER NMAXD
3535 PARAMETER (NMAXD=100)
3536 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
3537 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3538 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
3539 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3540C general process information
3541 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
3542 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
3543
3544 DIMENSION PP(4),PT(4),PTOT(4),PP1(4),PP2(4),PT1(4),PT2(4),
3545 & PPNN(4),PTNN(4),PTOTNN(4),PPSUB(4),PTSUB(4),
3546 & PPTCMS(4),PTTCMS(4),PPTMP(4),PTTMP(4),
3547 & KPRON(15),ISINGL(2000)
3548
3549* initial values for max. number of phojet scatterings and dtunuc chains
3550* to be fragmented with one pyexec call
3551 DATA MXPHFR,MXDTFR /10,100/
3552
3553 IREJ = 0
3554* pointer to first parton of the first chain in dtevt common
3555 NPOINT(3) = NHKK+1
3556* special flag for double-Pomeron statistics
3557 IPOPO = 1
3558* counter for low-mass (DTUNUC) interactions
3559 NDTUSC = 0
3560* counter for interactions treated by PHOJET
3561 NPHOSC = 0
3562
3563* scan interactions for single nucleon-nucleon interactions
3564* (this has to be checked here because Cronin modifies parton momenta)
3565 NC = NPOINT(2)
3566 IF (NCSY.GT.2000) STOP ' DT_EVENTB: NCSY > 2000 ! '
3567 DO 8 I=1,NCSY
3568 ISINGL(I) = 0
3569 MOP = JMOHKK(1,NC)
3570 MOT = JMOHKK(1,NC+1)
3571 DIFF1 = ABS(PHKK(4,MOP)-PHKK(4, NC)-PHKK(4,NC+2))
3572 DIFF2 = ABS(PHKK(4,MOT)-PHKK(4,NC+1)-PHKK(4,NC+3))
3573 IF ((DIFF1.LT.TINY10).AND.(DIFF2.LT.TINY10)) ISINGL(I) = 1
3574 NC = NC+4
3575 8 CONTINUE
3576
3577* multiple scattering of chain ends
3578 IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
3579 IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
3580
3581* switch to PHOJET-settings for JETSET parameter
3582 CALL DT_INITJS(1)
3583
3584* loop over nucleon-nucleon interaction
3585 NC = NPOINT(2)
3586 DO 2 I=1,NCSY
3587*
3588* pick up one nucleon-nucleon interaction from DTEVT1
3589* ppnn / ptnn - momenta of the interacting nucleons (cms)
3590* ptotnn - total momentum of the interacting nucleons (cms)
3591* pp1,2 / pt1,2 - momenta of the four partons
3592* pp / pt - total momenta of the proj / targ partons
3593* ptot - total momentum of the four partons
3594 MOP = JMOHKK(1,NC)
3595 MOT = JMOHKK(1,NC+1)
3596 DO 3 K=1,4
3597 PPNN(K) = PHKK(K,MOP)
3598 PTNN(K) = PHKK(K,MOT)
3599 PTOTNN(K) = PPNN(K)+PTNN(K)
3600 PP1(K) = PHKK(K,NC)
3601 PT1(K) = PHKK(K,NC+1)
3602 PP2(K) = PHKK(K,NC+2)
3603 PT2(K) = PHKK(K,NC+3)
3604 PP(K) = PP1(K)+PP2(K)
3605 PT(K) = PT1(K)+PT2(K)
3606 PTOT(K) = PP(K)+PT(K)
3607 3 CONTINUE
3608*
3609*-----------------------------------------------------------------------
3610* this is a complete nucleon-nucleon interaction
3611*
3612 IF (ISINGL(I).EQ.1) THEN
3613*
3614* initialize PHOJET-variables for remnant/valence-partons
3615 IHFLD(1,1) = 0
3616 IHFLD(1,2) = 0
3617 IHFLD(2,1) = 0
3618 IHFLD(2,2) = 0
3619 IHFLS(1) = 1
3620 IHFLS(2) = 1
3621* save current settings of PHOJET process and min. bias flags
3622 DO 9 K=1,11
3623 KPRON(K) = IPRON(K,1)
3624 9 CONTINUE
3625 ISWSAV = ISWMDL(2)
3626*
3627* check if forced sampling of diffractive interaction requested
3628 IF (ISINGD.LT.-1) THEN
3629 DO 90 K=1,11
3630 IPRON(K,1) = 0
3631 90 CONTINUE
3632 IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-3)) IPRON(5,1) = 1
3633 IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-4)) IPRON(6,1) = 1
3634 IF (ISINGD.EQ.-5) IPRON(4,1) = 1
3635 ENDIF
3636*
3637* for photons: a direct/anomalous interaction is not sampled
3638* in PHOJET but already in Glauber-formalism. Here we check if such
3639* an interaction is requested
3640 IF (IJPROJ.EQ.7) THEN
3641* first switch off direct interactions
3642 IPRON(8,1) = 0
3643* this is a direct interactions
3644 IF (IDIREC.EQ.1) THEN
3645 DO 12 K=1,11
3646 IPRON(K,1) = 0
3647 12 CONTINUE
3648 IPRON(8,1) = 1
3649* this is an anomalous interactions
3650* (iswmdl(2) = 0 only hard int. generated ( = 1 min. bias) )
3651 ELSEIF (IDIREC.EQ.2) THEN
3652 ISWMDL(2) = 0
3653 ENDIF
3654 ELSE
3655 IF (IDIREC.NE.0) STOP ' DT_EVENTB: IDIREC > 0 ! '
3656 ENDIF
3657*
3658* make sure that total momenta of partons, pp and pt, are on mass
3659* shell (Cronin may have srewed this up..)
3660 CALL DT_MASHEL(PP,PT,PHKK(5,MOP),PHKK(5,MOT),PPNN,PTNN,IR1)
3661 IF (IR1.NE.0) THEN
3662 IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A)')
3663 & 'EVENTB: mass shell correction rejected'
3664 GOTO 9999
3665 ENDIF
3666*
3667* initialize the incoming particles in PHOJET
3668 IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
3669 CALL PHO_SETPAR(1,22,0,VIRT)
3670 ELSE
3671 CALL PHO_SETPAR(1,IDHKK(MOP),0,ZERO)
3672 ENDIF
3673 CALL PHO_SETPAR(2,IDHKK(MOT),0,ZERO)
3674*
3675* initialize rejection loop counter for anomalous processes
3676 IRJANO = 0
3677 800 CONTINUE
3678 IRJANO = IRJANO+1
3679*
3680* temporary fix for ifano problem
3681 IFANO(1) = 0
3682 IFANO(2) = 0
3683*
3684* generate complete hadron/nucleon/photon-nucleon event with PHOJET
3685 CALL PHO_EVENT(2,PPNN,PTNN,DUM,IREJ1)
3686*
3687* for photons: special consistency check for anomalous interactions
3688 IF (IJPROJ.EQ.7) THEN
3689 IF (IRJANO.LT.30) THEN
3690 IF (IFANO(1).NE.0) THEN
3691* here, an anomalous interaction was generated. Check if it
3692* was also requested. Otherwise reject this event.
3693 IF (IDIREC.EQ.0) GOTO 800
3694 ELSE
3695* here, an anomalous interaction was not generated. Check if it
3696* was requested in which case we need to reject this event.
3697 IF (IDIREC.EQ.2) GOTO 800
3698 ENDIF
3699 ELSE
3700 WRITE(LOUT,*) ' DT_EVENTB: Warning! IRJANO > 30 ',
3701 & IRJANO,IDIREC,NEVHKK
3702 ENDIF
3703 ENDIF
3704*
3705* copy back original settings of PHOJET process and min. bias flags
3706 DO 10 K=1,11
3707 IPRON(K,1) = KPRON(K)
3708 10 CONTINUE
3709 ISWMDL(2) = ISWSAV
3710*
3711* check if PHOJET has rejected this event
3712 IF (IREJ1.NE.0) THEN
3713C IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
3714 WRITE(LOUT,'(1X,A,I4)')
3715 & 'EVENTB: chain system rejected',IDIREC
3716 CALL PHO_PREVNT(0)
3717 GOTO 9999
3718 ENDIF
3719*
3720* copy partons and strings from PHOJET common back into DTEVT for
3721* external fragmentation
3722 MO1 = NC
3723 MO2 = NC+3
3724*! uncomment this line for internal phojet-fragmentation
3725C CALL DT_GETFSP(MO1,MO2,PPNN,PTNN,-1)
3726 NPHOSC = NPHOSC+1
3727 CALL DT_GETPJE(MO1,MO2,PPNN,PTNN,-1,NPHOSC,IREJ1)
3728 IF (IREJ1.NE.0) THEN
3729 IF (IOULEV(1).GT.0)
3730 & WRITE(LOUT,'(1X,A,I4)') 'EVENTB: chain system rejected 1'
3731 GOTO 9999
3732 ENDIF
3733*
3734* update statistics counter
3735 ICEVTG(IDCH(NC),29) = ICEVTG(IDCH(NC),29)+1
3736*
3737*-----------------------------------------------------------------------
3738* this interaction involves "remnants"
3739*
3740 ELSE
3741*
3742* total mass of this system
3743 PPTOT = SQRT(PTOT(1)**2+PTOT(2)**2+PTOT(3)**2)
3744 AMTOT2 = (PTOT(4)-PPTOT)*(PTOT(4)+PPTOT)
3745 IF (AMTOT2.LT.ZERO) THEN
3746 AMTOT = ZERO
3747 ELSE
3748 AMTOT = SQRT(AMTOT2)
3749 ENDIF
3750*
3751* systems with masses larger than elojet are treated with PHOJET
3752 IF (AMTOT.GT.ELOJET) THEN
3753*
3754* initialize PHOJET-variables for remnant/valence-partons
3755* projectile parton flavors and valence flag
3756 IHFLD(1,1) = IDHKK(NC)
3757 IHFLD(1,2) = IDHKK(NC+2)
3758 IHFLS(1) = 0
3759 IF ((IDCH(NC).EQ.6).OR.(IDCH(NC).EQ.7)
3760 & .OR.(IDCH(NC).EQ.8)) IHFLS(1) = 1
3761* target parton flavors and valence flag
3762 IHFLD(2,1) = IDHKK(NC+1)
3763 IHFLD(2,2) = IDHKK(NC+3)
3764 IHFLS(2) = 0
3765 IF ((IDCH(NC).EQ.4).OR.(IDCH(NC).EQ.5)
3766 & .OR.(IDCH(NC).EQ.8)) IHFLS(2) = 1
3767* flag signalizing PHOJET how to treat the remnant:
3768* iremn = -1 sea-quark remnant: PHOJET takes flavors from ihfld
3769* iremn > -1 valence remnant: PHOJET assumes flavors according
3770* to mother particle
3771 IREMN1 = IHFLS(1)-1
3772 IREMN2 = IHFLS(2)-1
3773*
3774* initialize the incoming particles in PHOJET
3775 IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
3776 CALL PHO_SETPAR(1,22,IREMN1,VIRT)
3777 ELSE
3778 CALL PHO_SETPAR(1,IDHKK(MOP),IREMN1,ZERO)
3779 ENDIF
3780 CALL PHO_SETPAR(2,IDHKK(MOT),IREMN2,ZERO)
3781*
3782* calculate Lorentz parameter of the nucleon-nucleon cm-system
3783 PPTOTN = SQRT(PTOTNN(1)**2+PTOTNN(2)**2+PTOTNN(3)**2)
3784 AMNN = SQRT( (PTOTNN(4)-PPTOTN)*(PTOTNN(4)+PPTOTN) )
3785 BGX = PTOTNN(1)/AMNN
3786 BGY = PTOTNN(2)/AMNN
3787 BGZ = PTOTNN(3)/AMNN
3788 GAM = PTOTNN(4)/AMNN
3789* transform interacting nucleons into nucleon-nucleon cm-system
3790 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3791 & PPNN(1),PPNN(2),PPNN(3),PPNN(4),PPCMS,
3792 & PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4))
3793 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3794 & PTNN(1),PTNN(2),PTNN(3),PTNN(4),PTCMS,
3795 & PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4))
3796* transform (total) momenta of the proj and targ partons into
3797* nucleon-nucleon cm-system
3798 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3799 & PP(1),PP(2),PP(3),PP(4),
3800 & PPTSUB,PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4))
3801 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3802 & PT(1),PT(2),PT(3),PT(4),
3803 & PTTSUB,PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4))
3804* energy fractions of the proj and targ partons
3805 XPSUB = MIN(PPSUB(4)/PPTCMS(4),ONE)
3806 XTSUB = MIN(PTSUB(4)/PTTCMS(4),ONE)
3807***
3808* testprint
3809c PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
3810c & (PPTCMS(2)+PTTCMS(2))**2 +
3811c & (PPTCMS(3)+PTTCMS(3))**2 )
3812c EOLDCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
3813c & (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
3814c PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
3815c & (PPSUB(2)+PTSUB(2))**2 +
3816c & (PPSUB(3)+PTSUB(3))**2 )
3817c EOLDSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
3818c & (PPSUB(4)+PTSUB(4)+PTOTSU) )
3819***
3820*
3821* save current settings of PHOJET process and min. bias flags
3822 DO 7 K=1,11
3823 KPRON(K) = IPRON(K,1)
3824 7 CONTINUE
3825* disallow direct photon int. (does not make sense here anyway)
3826 IPRON(8,1) = 0
3827* disallow double pomeron processes (due to technical problems
3828* in PHOJET, needs to be solved sometime)
3829 IPRON(4,1) = 0
3830* disallow diffraction for sea-diquarks
3831 IF ((IABS(IHFLD(1,1)).GT.1100).AND.
3832 & (IABS(IHFLD(1,2)).GT.1100)) THEN
3833 IPRON(3,1) = 0
3834 IPRON(6,1) = 0
3835 ENDIF
3836 IF ((IABS(IHFLD(2,1)).GT.1100).AND.
3837 & (IABS(IHFLD(2,2)).GT.1100)) THEN
3838 IPRON(3,1) = 0
3839 IPRON(5,1) = 0
3840 ENDIF
3841*
3842* we need massless partons: transform them on mass shell
3843 XMP = ZERO
3844 XMT = ZERO
3845 DO 6 K=1,4
3846 PPTMP(K) = PPSUB(K)
3847 PTTMP(K) = PTSUB(K)
3848 6 CONTINUE
3849 CALL DT_MASHEL(PPTMP,PTTMP,XMP,XMT,PPSUB,PTSUB,IREJ1)
3850 PPSUTO = SQRT(PPSUB(1)**2+PPSUB(2)**2+PPSUB(3)**2)
3851 PTSUTO = SQRT(PTSUB(1)**2+PTSUB(2)**2+PTSUB(3)**2)
3852 PSUTOT = SQRT((PPSUB(1)+PTSUB(1))**2+
3853 & (PPSUB(2)+PTSUB(2))**2+(PPSUB(3)+PTSUB(3))**2)
3854* total energy of the subsysten after mass transformation
3855* (should be the same as before..)
3856 SECM = SQRT( (PPSUB(4)+PTSUB(4)-PSUTOT)*
3857 & (PPSUB(4)+PTSUB(4)+PSUTOT) )
3858*
3859* after mass shell transformation the x_sub - relation has to be
3860* corrected. We therefore create "pseudo-momenta" of mother-nucleons.
3861*
3862* The old version was to scale based on the original x_sub and the
3863* 4-momenta of the subsystem. At very high energy this could lead to
3864* "pseudo-cm energies" of the parent system considerably exceeding
3865* the true cm energy. Now we keep the true cm energy and calculate
3866* new x_sub instead.
3867C old version PPTCMS(4) = PPSUB(4)/XPSUB
3868 PPTCMS(4) = MAX(PPTCMS(4),PPSUB(4))
3869 XPSUB = PPSUB(4)/PPTCMS(4)
3870 IF (IJPROJ.EQ.7) THEN
3871 AMP2 = PHKK(5,MOT)**2
3872 PTOT1 = SQRT(PPTCMS(4)**2-AMP2)
3873 ELSE
3874*???????
3875 PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOP))
3876 & *(PPTCMS(4)+PHKK(5,MOP)))
3877C PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOT))
3878C & *(PPTCMS(4)+PHKK(5,MOT)))
3879 ENDIF
3880C old version PTTCMS(4) = PTSUB(4)/XTSUB
3881 PTTCMS(4) = MAX(PTTCMS(4),PTSUB(4))
3882 XTSUB = PTSUB(4)/PTTCMS(4)
3883 PTOT2 = SQRT((PTTCMS(4)-PHKK(5,MOT))
3884 & *(PTTCMS(4)+PHKK(5,MOT)))
3885 DO 4 K=1,3
3886 PPTCMS(K) = PTOT1*PPSUB(K)/PPSUTO
3887 PTTCMS(K) = PTOT2*PTSUB(K)/PTSUTO
3888 4 CONTINUE
3889***
3890* testprint
3891*
3892* ppnn / ptnn - momenta of the int. nucleons (cms, negl. Fermi)
3893* ptotnn - total momentum of the int. nucleons (cms, negl. Fermi)
3894* pptcms/ pttcms - momenta of the interacting nucleons (cms)
3895* pp1,2 / pt1,2 - momenta of the four partons
3896*
3897* pp / pt - total momenta of the pr/ta partons (cms, negl. Fermi)
3898* ptot - total momentum of the four partons (cms, negl. Fermi)
3899* ppsub / ptsub - total momenta of the proj / targ partons (cms)
3900*
3901c PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
3902c & (PPTCMS(2)+PTTCMS(2))**2 +
3903c & (PPTCMS(3)+PTTCMS(3))**2 )
3904c ENEWCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
3905c & (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
3906c PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
3907c & (PPSUB(2)+PTSUB(2))**2 +
3908c & (PPSUB(3)+PTSUB(3))**2 )
3909c ENEWSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
3910c & (PPSUB(4)+PTSUB(4)+PTOTSU) )
3911c IF (ENEWCM/EOLDCM.GT.1.1D0) THEN
3912c WRITE(*,*) ' EOLDCM, ENEWCM : ',EOLDCM,ENEWCM
3913c WRITE(*,*) ' EOLDSU, ENEWSU : ',EOLDSU,ENEWSU
3914c WRITE(*,*) ' XPSUB, XTSUB : ',XPSUB,XTSUB
3915c ENDIF
3916c BBGX = (PPTCMS(1)+PTTCMS(1))/ENEWCM
3917c BBGY = (PPTCMS(2)+PTTCMS(2))/ENEWCM
3918c BBGZ = (PPTCMS(3)+PTTCMS(3))/ENEWCM
3919c BGAM = (PPTCMS(4)+PTTCMS(4))/ENEWCM
3920* transform interacting nucleons into nucleon-nucleon cm-system
3921c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3922c & PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4),PPTOT,
3923c & PPNEW1,PPNEW2,PPNEW3,PPNEW4)
3924c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3925c & PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4),PTTOT,
3926c & PTNEW1,PTNEW2,PTNEW3,PTNEW4)
3927c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3928c & PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4),PPTOT,
3929c & PPSUB1,PPSUB2,PPSUB3,PPSUB4)
3930c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3931c & PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4),PTTOT,
3932c & PTSUB1,PTSUB2,PTSUB3,PTSUB4)
3933c PTSTCM = SQRT( (PPNEW1+PTNEW1)**2 +
3934c & (PPNEW2+PTNEW2)**2 +
3935c & (PPNEW3+PTNEW3)**2 )
3936c ETSTCM = SQRT( (PPNEW4+PTNEW4-PTSTCM) *
3937c & (PPNEW4+PTNEW4+PTSTCM) )
3938c PTSTSU = SQRT( (PPSUB1+PTSUB1)**2 +
3939c & (PPSUB2+PTSUB2)**2 +
3940c & (PPSUB3+PTSUB3)**2 )
3941c ETSTSU = SQRT( (PPSUB4+PTSUB4-PTSTSU) *
3942c & (PPSUB4+PTSUB4+PTSTSU) )
3943C WRITE(*,*) ' mother cmE :'
3944C WRITE(*,*) ETSTCM,ENEWCM
3945C WRITE(*,*) ' subsystem cmE :'
3946C WRITE(*,*) ETSTSU,ENEWSU
3947C WRITE(*,*) ' projectile mother :'
3948C WRITE(*,*) PPNEW1,PPNEW2,PPNEW3,PPNEW4
3949C WRITE(*,*) ' target mother :'
3950C WRITE(*,*) PTNEW1,PTNEW2,PTNEW3,PTNEW4
3951C WRITE(*,*) ' projectile subsystem:'
3952C WRITE(*,*) PPSUB1,PPSUB2,PPSUB3,PPSUB4
3953C WRITE(*,*) ' target subsystem:'
3954C WRITE(*,*) PTSUB1,PTSUB2,PTSUB3,PTSUB4
3955C WRITE(*,*) ' projectile subsystem should be:'
3956C WRITE(*,*) ZERO,ZERO,XPSUB*ETSTCM/2.0D0,
3957C & XPSUB*ETSTCM/2.0D0
3958C WRITE(*,*) ' target subsystem should be:'
3959C WRITE(*,*) ZERO,ZERO,-XTSUB*ETSTCM/2.0D0,
3960C & XTSUB*ETSTCM/2.0D0
3961C WRITE(*,*) ' subsystem cmE should be: '
3962C WRITE(*,*) SQRT(XPSUB*XTSUB)*ETSTCM,XPSUB,XTSUB
3963***
3964*
3965* generate complete remnant - nucleon/remnant event with PHOJET
3966 CALL PHO_EVENT(3,PPTCMS,PTTCMS,DUM,IREJ1)
3967*
3968* copy back original settings of PHOJET process flags
3969 DO 11 K=1,11
3970 IPRON(K,1) = KPRON(K)
3971 11 CONTINUE
3972*
3973* check if PHOJET has rejected this event
3974 IF (IREJ1.NE.0) THEN
3975 IF (IOULEV(1).GT.0)
3976 & WRITE(LOUT,'(1X,A)') 'EVENTB: chain system rejected'
3977 WRITE(LOUT,*)
3978 & 'XPSUB,XTSUB,SECM ',XPSUB,XTSUB,SECM,AMTOT
3979 CALL PHO_PREVNT(0)
3980 GOTO 9999
3981 ENDIF
3982*
3983* copy partons and strings from PHOJET common back into DTEVT for
3984* external fragmentation
3985 MO1 = NC
3986 MO2 = NC+3
3987*! uncomment this line for internal phojet-fragmentation
3988C CALL DT_GETFSP(MO1,MO2,PP,PT,1)
3989 NPHOSC = NPHOSC+1
3990 CALL DT_GETPJE(MO1,MO2,PP,PT,1,NPHOSC,IREJ1)
3991 IF (IREJ1.NE.0) THEN
3992 IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
3993 & 'EVENTB: chain system rejected 2'
3994 GOTO 9999
3995 ENDIF
3996*
3997* update statistics counter
3998 ICEVTG(IDCH(NC),2) = ICEVTG(IDCH(NC),2)+1
3999*
4000*-----------------------------------------------------------------------
4001* two-chain approx. for smaller systems
4002*
4003 ELSE
4004*
4005 NDTUSC = NDTUSC+1
4006* special flag for double-Pomeron statistics
4007 IPOPO = 0
4008*
4009* pick up flavors at the ends of the two chains
4010 IFP1 = IDHKK(NC)
4011 IFT1 = IDHKK(NC+1)
4012 IFP2 = IDHKK(NC+2)
4013 IFT2 = IDHKK(NC+3)
4014* ..and the indices of the mothers
4015 MOP1 = NC
4016 MOT1 = NC+1
4017 MOP2 = NC+2
4018 MOT2 = NC+3
4019 CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
4020 & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
4021*
4022* check if this chain system was rejected
4023 IF (IREJ1.GT.0) THEN
4024 IF (IOULEV(1).GT.0) THEN
4025 WRITE(LOUT,*) 'rejected 1 in EVENTB'
4026 WRITE(LOUT,'(1X,4(I6,4E12.3,/),E12.3)')
4027 & IFP1,PP1,IFT1,PT1,IFP2,PP2,IFT2,PT2,AMTOT
4028 ENDIF
4029 IRHHA = IRHHA+1
4030 GOTO 9999
4031 ENDIF
4032* the following lines are for sea-sea chains rejected in GETCSY
4033 IF (IREJ1.EQ.-1) NDTUSC = NDTUSC-1
4034 ICEVTG(IDCH(NC),1) = ICEVTG(IDCH(NC),1)+1
4035 ENDIF
4036*
4037 ENDIF
4038*
4039* update statistics counter
4040 ICEVTG(IDCH(NC),0) = ICEVTG(IDCH(NC),0)+1
4041*
4042 NC = NC+4
4043*
4044 2 CONTINUE
4045*
4046*-----------------------------------------------------------------------
4047* treatment of low-mass chains (if there are any)
4048*
4049 IF (NDTUSC.GT.0) THEN
4050*
4051* correct chains of very low masses for possible resonances
4052 IF (IRESCO.EQ.1) THEN
4053 CALL DT_EVTRES(IREJ1)
4054 IF (IREJ1.GT.0) THEN
4055 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2a in EVENTB'
4056 IRRES(1) = IRRES(1)+1
4057 GOTO 9999
4058 ENDIF
4059 ENDIF
4060* fragmentation of low-mass chains
4061*! uncomment this line for internal phojet-fragmentation
4062* (of course it will still be fragmented by DPMJET-routines but it
4063* has to be done here instead of further below)
4064C CALL DT_EVTFRA(IREJ1)
4065C IF (IREJ1.GT.0) THEN
4066C IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2b in EVENTB'
4067C IRFRAG = IRFRAG+1
4068C GOTO 9999
4069C ENDIF
4070 ELSE
4071*! uncomment this line for internal phojet-fragmentation
4072C NPOINT(4) = NHKK+1
4073 IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
4074 ENDIF
4075*
4076*-----------------------------------------------------------------------
4077* new di-quark breaking mechanisms
4078*
4079 MXLEFT = 2
4080 CALL DT_CHASTA(0)
4081 IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
4082 & .OR.(PDBSEA(3).GT.0.0D0)) THEN
4083 CALL DT_DIQBRK
4084 MXLEFT = 4
4085 ENDIF
4086*
4087*-----------------------------------------------------------------------
4088* hadronize this event
4089*
4090* hadronize PHOJET chain systems
4091 NPYMAX = 0
4092 NPJE = NPHOSC/MXPHFR
4093 IF (MXPHFR.LT.MXLEFT) MXLEFT = 2
4094 IF (NPJE.GT.1) THEN
4095 NLEFT = NPHOSC-NPJE*MXPHFR
4096 DO 20 JFRG=1,NPJE
4097 NFRG = JFRG*MXPHFR
4098 IF ((JFRG.EQ.NPJE).AND.(NLEFT.LE.MXLEFT)) THEN
4099 CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4100 IF (IREJ1.GT.0) GOTO 22
4101 NLEFT = 0
4102 ELSE
4103 CALL DT_EVTFRG(1,NFRG,NPYMEM,IREJ1)
4104 IF (IREJ1.GT.0) GOTO 22
4105 ENDIF
4106 IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4107 20 CONTINUE
4108 IF (NLEFT.GT.0) THEN
4109 CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4110 IF (IREJ1.GT.0) GOTO 22
4111 IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4112 ENDIF
4113 ELSE
4114 CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4115 IF (IREJ1.GT.0) GOTO 22
4116 IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4117 ENDIF
4118*
4119* check max. filling level of jetset common and
4120* reduce mxphfr if necessary
4121 IF (NPYMAX.GT.3000) THEN
4122 IF (NPYMAX.GT.3500) THEN
4123 MXPHFR = MAX(1,MXPHFR-2)
4124 ELSE
4125 MXPHFR = MAX(1,MXPHFR-1)
4126 ENDIF
4127C WRITE(LOUT,*) ' EVENTB: Mxphfr reduced to ',MXPHFR
4128 ENDIF
4129*
4130* hadronize DTUNUC chain systems
4131 23 CONTINUE
4132 IBACK = MXDTFR
4133 CALL DT_EVTFRG(2,IBACK,NPYMEM,IREJ2)
4134 IF (IREJ2.GT.0) GOTO 22
4135*
4136* check max. filling level of jetset common and
4137* reduce mxdtfr if necessary
4138 IF (NPYMEM.GT.3000) THEN
4139 IF (NPYMEM.GT.3500) THEN
4140 MXDTFR = MAX(1,MXDTFR-20)
4141 ELSE
4142 MXDTFR = MAX(1,MXDTFR-10)
4143 ENDIF
4144C WRITE(LOUT,*) ' EVENTB: Mxdtfr reduced to ',MXDTFR
4145 ENDIF
4146*
4147 IF (IBACK.EQ.-1) GOTO 23
4148*
4149 22 CONTINUE
4150C CALL DT_EVTFRG(1,IREJ1)
4151C CALL DT_EVTFRG(2,IREJ2)
4152 IF ((IREJ1.GT.0).OR.(IREJ2.GT.0)) THEN
4153 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTB'
4154 IRFRAG = IRFRAG+1
4155 GOTO 9999
4156 ENDIF
4157*
4158* get final state particles from /DTEVTP/
4159*! uncomment this line for internal phojet-fragmentation
4160C CALL DT_GETFSP(IDUM,IDUM,PP,PT,2)
4161
4162 IF (IJPROJ.NE.7)
4163 & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,88,IREJ3)
4164C IF (IREJ3.NE.0) GOTO 9999
4165
4166 RETURN
4167
4168 9999 CONTINUE
4169 IREVT = IREVT+1
4170 IREJ = 1
4171 RETURN
4172 END
4173
4174*$ CREATE DT_GETPJE.FOR
4175*COPY DT_GETPJE
4176*
4177*===getpje=============================================================*
4178*
4179 SUBROUTINE DT_GETPJE(MO1,MO2,PP,PT,MODE,IPJE,IREJ)
4180
4181************************************************************************
4182* This subroutine copies PHOJET partons and strings from POEVT1 into *
4183* DTEVT1. *
4184* MO1,MO2 indices of first and last mother-parton in DTEVT1 *
4185* PP,PT 4-momenta of projectile/target being handled by *
4186* PHOJET *
4187* This version dated 11.12.99 is written by S. Roesler *
4188************************************************************************
4189
4190 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4191 SAVE
4192 PARAMETER ( LINP = 10 ,
4193 & LOUT = 6 ,
4194 & LDAT = 9 )
4195 PARAMETER (TINY10=1.0D-10,TINY1=1.0D-1,
4196 & ZERO=0.0D0,ONE=1.0D0,OHALF=0.5D0)
4197
4198 LOGICAL LFLIP
4199
4200* event history
4201 PARAMETER (NMXHKK=200000)
4202 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
4203 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
4204 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
4205* extended event history
4206 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
4207 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
4208 & IHIST(2,NMXHKK)
4209* Lorentz-parameters of the current interaction
4210 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4211 & UMO,PPCM,EPROJ,PPROJ
4212* DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
4213 COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
4214* flags for input different options
4215 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
4216 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
4217 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
4218* statistics: double-Pomeron exchange
4219 COMMON /DTFLG2/ INTFLG,IPOPO
4220* statistics
4221 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
4222 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
4223 & ICEVTG(8,0:30)
4224* rejection counter
4225 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
4226 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
4227 & IREXCI(3),IRDIFF(2),IRINC
4228C standard particle data interface
4229 INTEGER NMXHEP
4230 PARAMETER (NMXHEP=4000)
4231 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
4232 DOUBLE PRECISION PHEP,VHEP
4233 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
4234 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
09b429a4 4235 & VHEP(4,NMXHEP), NSD1, NSD2, NDD
9aaba0d6 4236C extension to standard particle data interface (PHOJET specific)
4237 INTEGER IMPART,IPHIST,ICOLOR
4238 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
4239C color string configurations including collapsed strings and hadrons
4240 INTEGER MSTR
4241 PARAMETER (MSTR=500)
4242 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
4243 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
4244 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
4245 & NNCH(MSTR),IBHAD(MSTR),ISTR
4246C general process information
4247 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
4248 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
4249C model switches and parameters
4250 CHARACTER*8 MDLNA
4251 INTEGER ISWMDL,IPAMDL
4252 DOUBLE PRECISION PARMDL
4253 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4254C event debugging information
4255 INTEGER NMAXD
4256 PARAMETER (NMAXD=100)
4257 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4258 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4259 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4260 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4261
4262 DIMENSION PP(4),PT(4)
4263 DATA MAXLOP /10000/
4264
4265 INHKK = NHKK
4266 LFLIP = .TRUE.
4267 1 CONTINUE
4268 NPVAL = 0
4269 NTVAL = 0
4270 IREJ = 0
4271
4272* store initial momenta for energy-momentum conservation check
4273 IF (LEMCCK) THEN
4274 CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM1,IDUM2)
4275 CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM1,IDUM2)
4276 ENDIF
4277* copy partons and strings from POEVT1 into DTEVT1
4278 DO 11 I=1,ISTR
4279C IF ((NCODE(I).EQ.-99).AND.(IPAMDL(17).EQ.0)) THEN
4280 IF (NCODE(I).EQ.-99) THEN
4281 IDXSTG = NPOS(1,I)
4282 IDSTG = IDHEP(IDXSTG)
4283 PX = PHEP(1,IDXSTG)
4284 PY = PHEP(2,IDXSTG)
4285 PZ = PHEP(3,IDXSTG)
4286 PE = PHEP(4,IDXSTG)
4287 IF (MODE.LT.0) THEN
4288 ISTAT = 70000+IPJE
4289 CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PX,PY,PZ,PE,
4290 & 11,IDSTG,0)
4291 IF (LEMCCK) THEN
4292 PX = -PX
4293 PY = -PY
4294 PZ = -PZ
4295 PE = -PE
4296 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4297 ENDIF
4298 ELSE
4299 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4300 & PPX,PPY,PPZ,PPE)
4301 ISTAT = 70000+IPJE
4302 CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PPX,PPY,PPZ,PPE,
4303 & 11,IDSTG,0)
4304 IF (LEMCCK) THEN
4305 PX = -PPX
4306 PY = -PPY
4307 PZ = -PPZ
4308 PE = -PPE
4309 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4310 ENDIF
4311 ENDIF
4312 NOBAM(NHKK) = 0
4313 IHIST(1,NHKK) = IPHIST(1,IDXSTG)
4314 IHIST(2,NHKK) = 0
4315 ELSEIF (NCODE(I).GE.0) THEN
4316* indices of partons and string in POEVT1
4317 IDX1 = ABS(JMOHEP(1,NPOS(1,I)))
4318 IDX2 = ABS(JMOHEP(2,NPOS(1,I)))
4319 IF ((IDX1.GT.IDX2).OR.(JMOHEP(2,NPOS(1,I)).GT.0)) THEN
4320 WRITE(LOUT,*) ' GETPJE: IDX1.GT.IDX2 ',IDX1,IDX2,
4321 & ' or JMOHEP(2,NPOS(1,I)).GT.0 ',JMOHEP(2,NPOS(1,I)),' ! '
4322 STOP ' GETPJE 1'
4323 ENDIF
4324 IDXSTG = NPOS(1,I)
4325* find "mother" string of the string
4326 IDXMS1 = ABS(JMOHEP(1,IDX1))
4327 IDXMS2 = ABS(JMOHEP(1,IDX2))
4328 IF (IDXMS1.NE.IDXMS2) THEN
4329 IDXMS1 = IDXSTG
4330 IDXMS2 = IDXSTG
4331C STOP ' GETPJE: IDXMS1.NE.IDXMS2 !'
4332 ENDIF
4333* search POEVT1 for the original hadron of the parton
4334 ILOOP = 0
4335 IPOM1 = 0
4336 14 CONTINUE
4337 ILOOP = ILOOP+1
4338 IF (IDHEP(IDXMS1).EQ.990) IPOM1 = 1
4339 IDXMS1 = ABS(JMOHEP(1,IDXMS1))
4340 IF ((IDXMS1.NE.1).AND.(IDXMS1.NE.2).AND.
4341 & (ILOOP.LT.MAXLOP)) GOTO 14
4342 IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 1 ! '
4343 IPOM2 = 0
4344 ILOOP = 0
4345 15 CONTINUE
4346 ILOOP = ILOOP+1
4347 IF (IDHEP(IDXMS2).EQ.990) IPOM2 = 1
4348 IF ((ILOOP.EQ.1).OR.(IDHEP(IDXMS2).GE.7777)) THEN
4349 IDXMS2 = ABS(JMOHEP(2,IDXMS2))
4350 ELSE
4351 IDXMS2 = ABS(JMOHEP(1,IDXMS2))
4352 ENDIF
4353 IF ((IDXMS2.NE.1).AND.(IDXMS2.NE.2).AND.
4354 & (ILOOP.LT.MAXLOP)) GOTO 15
4355 IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 5 ! '
4356* parton 1
4357 IF (IDXMS1.EQ.1) THEN
4358 ISPTN1 = ISTHKK(MO1)
4359 M1PTN1 = MO1
4360 M2PTN1 = MO1+2
4361 ELSE
4362 ISPTN1 = ISTHKK(MO2)
4363 M1PTN1 = MO2-2
4364 M2PTN1 = MO2
4365 ENDIF
4366* parton 2
4367 IF (IDXMS2.EQ.1) THEN
4368 ISPTN2 = ISTHKK(MO1)
4369 M1PTN2 = MO1
4370 M2PTN2 = MO1+2
4371 ELSE
4372 ISPTN2 = ISTHKK(MO2)
4373 M1PTN2 = MO2-2
4374 M2PTN2 = MO2
4375 ENDIF
4376* check for mis-identified mothers and switch mother indices if necessary
4377 IF ((IDXMS1.EQ.IDXMS2).AND.(IPROCE.NE.5).AND.(IPROCE.NE.6)
4378 & .AND.((IDHEP(IDX1).NE.21).OR.(IDHEP(IDX2).NE.21)).AND.
4379 & (LFLIP)) THEN
4380 IF (PHEP(3,IDX1).GT.PHEP(3,IDX2)) THEN
4381 ISPTN1 = ISTHKK(MO1)
4382 M1PTN1 = MO1
4383 M2PTN1 = MO1+2
4384 ISPTN2 = ISTHKK(MO2)
4385 M1PTN2 = MO2-2
4386 M2PTN2 = MO2
4387 ELSE
4388 ISPTN1 = ISTHKK(MO2)
4389 M1PTN1 = MO2-2
4390 M2PTN1 = MO2
4391 ISPTN2 = ISTHKK(MO1)
4392 M1PTN2 = MO1
4393 M2PTN2 = MO1+2
4394 ENDIF
4395 ENDIF
4396* register partons in temporary common
4397* parton at chain end
4398 PX = PHEP(1,IDX1)
4399 PY = PHEP(2,IDX1)
4400 PZ = PHEP(3,IDX1)
4401 PE = PHEP(4,IDX1)
4402* flag only partons coming from Pomeron with 41/42
4403C IF ((IPOM1.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4404 IF (IPOM1.NE.0) THEN
4405 ISTX = ABS(ISPTN1)/10
4406 IMO = ABS(ISPTN1)-10*ISTX
4407 ISPTN1 = -(40+IMO)
4408 ELSE
4409 IF ((ICOLOR(2,IDX1).EQ.0).OR.(IDHEP(IDX1).EQ.21)) THEN
4410 ISTX = ABS(ISPTN1)/10
4411 IMO = ABS(ISPTN1)-10*ISTX
4412 IF ((IDHEP(IDX1).EQ.21).OR.
4413 & (ABS(IPHIST(1,IDX1)).GE.100)) THEN
4414 ISPTN1 = -(60+IMO)
4415 ELSE
4416 ISPTN1 = -(50+IMO)
4417 ENDIF
4418 ENDIF
4419 ENDIF
4420 IF (ISPTN1.EQ.-21) NPVAL = NPVAL+1
4421 IF (ISPTN1.EQ.-22) NTVAL = NTVAL+1
4422 IF (MODE.LT.0) THEN
4423 CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PX,PY,
4424 & PZ,PE,0,0,0)
4425 ELSE
4426 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4427 & PPX,PPY,PPZ,PPE)
4428 CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PPX,PPY,
4429 & PPZ,PPE,0,0,0)
4430 ENDIF
4431 IHIST(1,NHKK) = IPHIST(1,IDX1)
4432 IHIST(2,NHKK) = 0
4433 DO 19 KK=1,4
4434 VHKK(KK,NHKK) = VHKK(KK,M2PTN1)
4435 WHKK(KK,NHKK) = WHKK(KK,M1PTN1)
4436 19 CONTINUE
4437 VHKK(4,NHKK) = VHKK(3,M2PTN1)/BLAB-VHKK(3,M1PTN1)/BGLAB
4438 WHKK(4,NHKK) = -WHKK(3,M1PTN1)/BLAB+WHKK(3,M2PTN1)/BGLAB
4439 M1STRG = NHKK
4440* gluon kinks
4441 NGLUON = IDX2-IDX1-1
4442 IF (NGLUON.GT.0) THEN
4443 DO 17 IGLUON=1,NGLUON
4444 IDX = IDX1+IGLUON
4445 IDXMS = ABS(JMOHEP(1,IDX))
4446 IF ((IDXMS.NE.1).AND.(IDXMS.NE.2)) THEN
4447 ILOOP = 0
4448 16 CONTINUE
4449 ILOOP = ILOOP+1
4450 IDXMS = ABS(JMOHEP(1,IDXMS))
4451 IF ((IDXMS.NE.1).AND.(IDXMS.NE.2).AND.
4452 & (ILOOP.LT.MAXLOP)) GOTO 16
4453 IF (ILOOP.EQ.MAXLOP)
4454 & WRITE(LOUT,*) ' GETPJE: MAXLOP in 3 ! '
4455 ENDIF
4456 IF (IDXMS.EQ.1) THEN
4457 ISPTN = ISTHKK(MO1)
4458 M1PTN = MO1
4459 M2PTN = MO1+2
4460 ELSE
4461 ISPTN = ISTHKK(MO2)
4462 M1PTN = MO2-2
4463 M2PTN = MO2
4464 ENDIF
4465 PX = PHEP(1,IDX)
4466 PY = PHEP(2,IDX)
4467 PZ = PHEP(3,IDX)
4468 PE = PHEP(4,IDX)
4469 IF ((ICOLOR(2,IDX).EQ.0).OR.(IDHEP(IDX).EQ.21)) THEN
4470 ISTX = ABS(ISPTN)/10
4471 IMO = ABS(ISPTN)-10*ISTX
4472 IF ((IDHEP(IDX).EQ.21).OR.
4473 & (ABS(IPHIST(1,IDX)).GE.100)) THEN
4474 ISPTN = -(60+IMO)
4475 ELSE
4476 ISPTN = -(50+IMO)
4477 ENDIF
4478 ENDIF
4479 IF (ISPTN.EQ.-21) NPVAL = NPVAL+1
4480 IF (ISPTN.EQ.-22) NTVAL = NTVAL+1
4481 IF (MODE.LT.0) THEN
4482 CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4483 & PX,PY,PZ,PE,0,0,0)
4484 ELSE
4485 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4486 & PPX,PPY,PPZ,PPE)
4487 CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4488 & PPX,PPY,PPZ,PPE,0,0,0)
4489 ENDIF
4490 IHIST(1,NHKK) = IPHIST(1,IDX)
4491 IHIST(2,NHKK) = 0
4492 DO 20 KK=1,4
4493 VHKK(KK,NHKK) = VHKK(KK,M2PTN)
4494 WHKK(KK,NHKK) = WHKK(KK,M1PTN)
4495 20 CONTINUE
4496 VHKK(4,NHKK)= VHKK(3,M2PTN)/BLAB-VHKK(3,M1PTN)/BGLAB
4497 WHKK(4,NHKK)= -WHKK(3,M1PTN)/BLAB+WHKK(3,M2PTN)/BGLAB
4498 17 CONTINUE
4499 ENDIF
4500* parton at chain end
4501 PX = PHEP(1,IDX2)
4502 PY = PHEP(2,IDX2)
4503 PZ = PHEP(3,IDX2)
4504 PE = PHEP(4,IDX2)
4505* flag only partons coming from Pomeron with 41/42
4506C IF ((IPOM2.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4507 IF (IPOM2.NE.0) THEN
4508 ISTX = ABS(ISPTN2)/10
4509 IMO = ABS(ISPTN2)-10*ISTX
4510 ISPTN2 = -(40+IMO)
4511 ELSE
4512 IF ((ICOLOR(2,IDX2).EQ.0).OR.(IDHEP(IDX2).EQ.21)) THEN
4513 ISTX = ABS(ISPTN2)/10
4514 IMO = ABS(ISPTN2)-10*ISTX
4515 IF ((IDHEP(IDX2).EQ.21).OR.
4516 & (ABS(IPHIST(1,IDX2)).GE.100)) THEN
4517 ISPTN2 = -(60+IMO)
4518 ELSE
4519 ISPTN2 = -(50+IMO)
4520 ENDIF
4521 ENDIF
4522 ENDIF
4523 IF (ISPTN2.EQ.-21) NPVAL = NPVAL+1
4524 IF (ISPTN2.EQ.-22) NTVAL = NTVAL+1
4525 IF (MODE.LT.0) THEN
4526 CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4527 & PX,PY,PZ,PE,0,0,0)
4528 ELSE
4529 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4530 & PPX,PPY,PPZ,PPE)
4531 CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4532 & PPX,PPY,PPZ,PPE,0,0,0)
4533 ENDIF
4534 IHIST(1,NHKK) = IPHIST(1,IDX2)
4535 IHIST(2,NHKK) = 0
4536 DO 21 KK=1,4
4537 VHKK(KK,NHKK) = VHKK(KK,M2PTN2)
4538 WHKK(KK,NHKK) = WHKK(KK,M1PTN2)
4539 21 CONTINUE
4540 VHKK(4,NHKK) = VHKK(3,M2PTN2)/BLAB-VHKK(3,M1PTN2)/BGLAB
4541 WHKK(4,NHKK) = -WHKK(3,M1PTN2)/BLAB+WHKK(3,M2PTN2)/BGLAB
4542 M2STRG = NHKK
4543* register string
4544 JSTRG = 100*IPROCE+NCODE(I)
4545 PX = PHEP(1,IDXSTG)
4546 PY = PHEP(2,IDXSTG)
4547 PZ = PHEP(3,IDXSTG)
4548 PE = PHEP(4,IDXSTG)
4549 IF (MODE.LT.0) THEN
4550 ISTAT = 70000+IPJE
4551 CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4552 & PX,PY,PZ,PE,0,0,0)
4553 IF (LEMCCK) THEN
4554 PX = -PX
4555 PY = -PY
4556 PZ = -PZ
4557 PE = -PE
4558 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4559 ENDIF
4560 ELSE
4561 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4562 & PPX,PPY,PPZ,PPE)
4563 ISTAT = 70000+IPJE
4564 CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4565 & PPX,PPY,PPZ,PPE,0,0,0)
4566 IF (LEMCCK) THEN
4567 PX = -PPX
4568 PY = -PPY
4569 PZ = -PPZ
4570 PE = -PPE
4571 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4572 ENDIF
4573 ENDIF
4574 NOBAM(NHKK) = 0
4575 IHIST(1,NHKK) = 0
4576 IHIST(2,NHKK) = 0
4577 DO 18 KK=1,4
4578 VHKK(KK,NHKK) = VHKK(KK,MO2)
4579 WHKK(KK,NHKK) = WHKK(KK,MO1)
4580 18 CONTINUE
4581 VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
4582 WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
4583 ENDIF
4584 11 CONTINUE
4585
4586 IF ( ((NPVAL.GT.2).OR.(NTVAL.GT.2)).AND.(LFLIP) ) THEN
4587 NHKK = INHKK
4588 LFLIP = .FALSE.
4589 GOTO 1
4590 ENDIF
4591
4592 IF (LEMCCK) THEN
4593 IF (UMO.GT.1.0D5) THEN
4594 CHKLEV = 1.0D0
4595 ELSE
4596 CHKLEV = TINY1
4597 ENDIF
4598 CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,1000,IREJ2)
4599 IF (IREJ2.GT.ZERO) CALL PHO_PREVNT(0)
4600 ENDIF
4601
4602* internal statistics
4603* dble-Po statistics.
4604 IF (IPROCE.NE.4) IPOPO = 0
4605
4606 INTFLG = IPROCE
4607 IDCHSY = IDCH(MO1)
4608 IF ((IPROCE.GE.1).AND.(IPROCE.LE.8)) THEN
4609 ICEVTG(IDCHSY,IPROCE+2) = ICEVTG(IDCHSY,IPROCE+2)+1
4610 ELSE
4611 WRITE(LOUT,1000) IPROCE,NEVHKK,MO1
4612 1000 FORMAT(1X,'GETFSP: warning! incons. process id. (',I2,
4613 & ') at evt(chain) ',I6,'(',I2,')')
4614 ENDIF
4615 IF (IPROCE.EQ.5) THEN
4616 IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3)) THEN
4617 ICEVTG(IDCHSY,18+IDIFR1) = ICEVTG(IDCHSY,18+IDIFR1)+1
4618 ELSE
4619C WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4620 1001 FORMAT(1X,'GETFSP: warning! incons. diffrac. id. ',
4621 & '(IPROCE,IDIFR1,IDIFR2=',3I3,')')
4622 ENDIF
4623 ELSEIF (IPROCE.EQ.6) THEN
4624 IF ((IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4625 ICEVTG(IDCHSY,21+IDIFR2) = ICEVTG(IDCHSY,21+IDIFR2)+1
4626 ELSE
4627C WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4628 ENDIF
4629 ELSEIF (IPROCE.EQ.7) THEN
4630 IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3).AND.
4631 & (IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4632 IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.1))
4633 & ICEVTG(IDCHSY,25) = ICEVTG(IDCHSY,25)+1
4634 IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.2))
4635 & ICEVTG(IDCHSY,26) = ICEVTG(IDCHSY,26)+1
4636 IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.2))
4637 & ICEVTG(IDCHSY,27) = ICEVTG(IDCHSY,27)+1
4638 IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.1))
4639 & ICEVTG(IDCHSY,28) = ICEVTG(IDCHSY,28)+1
4640 ELSE
4641 WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4642 ENDIF
4643 ENDIF
4644 IF ((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GE.1).AND.(KHDIR.LE.3))
4645 & THEN
4646 ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4647 ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4648 ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4649 ENDIF
4650 ICEVTG(IDCHSY,14) = ICEVTG(IDCHSY,14)+KSPOM
4651 ICEVTG(IDCHSY,15) = ICEVTG(IDCHSY,15)+KHPOM
4652 ICEVTG(IDCHSY,16) = ICEVTG(IDCHSY,16)+KSREG
4653 ICEVTG(IDCHSY,17) = ICEVTG(IDCHSY,17)+(KSTRG+KHTRG)
4654 ICEVTG(IDCHSY,18) = ICEVTG(IDCHSY,18)+(KSLOO+KHLOO)
4655
4656 RETURN
4657
4658 9999 CONTINUE
4659 IREJ = 1
4660 RETURN
4661 END
4662
4663*$ CREATE DT_PHOINI.FOR
4664*COPY DT_PHOINI
4665*
4666*===phoini=============================================================*
4667*
4668 SUBROUTINE DT_PHOINI
4669
4670************************************************************************
4671* Initialization PHOJET-event generator for nucleon-nucleon interact. *
4672* This version dated 16.11.95 is written by S. Roesler *
4673* *
4674* Last change 27.12.2006 by S. Roesler. *
4675************************************************************************
4676
4677 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4678 SAVE
4679 PARAMETER ( LINP = 10 ,
4680 & LOUT = 6 ,
4681 & LDAT = 9 )
4682 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
4683
4684* nucleon-nucleon event-generator
4685 CHARACTER*8 CMODEL
4686 LOGICAL LPHOIN
4687 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
4688* particle properties (BAMJET index convention)
4689 CHARACTER*8 ANAME
4690 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
4691 & IICH(210),IIBAR(210),K1(210),K2(210)
4692* Lorentz-parameters of the current interaction
4693 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4694 & UMO,PPCM,EPROJ,PPROJ
4695* properties of interacting particles
4696 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
4697* properties of photon/lepton projectiles
4698 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
4699 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
4700* emulsion treatment
4701 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
4702 & NCOMPO,IEMUL
4703* VDM parameter for photon-nucleus interactions
4704 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
4705* nuclear potential
4706 LOGICAL LFERMI
4707 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
4708 & EBINDP(2),EBINDN(2),EPOT(2,210),
4709 & ETACOU(2),ICOUL,LFERMI
4710* Glauber formalism: flags and parameters for statistics
4711 LOGICAL LPROD
4712 CHARACTER*8 CGLB
4713 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
4714*
4715* parameters for cascade calculations:
4716* maximum mumber of PDF's which can be defined in phojet (limited
4717* by the dimension of ipdfs in pho_setpdf)
4718 PARAMETER (MAXPDF = 20)
4719* PDF parametrization and number of set for the first 30 hadrons in
4720* the bamjet-code list
4721* negative numbers mean that the PDF is set in phojet,
4722* zero stands for "not a hadron"
4723 DIMENSION IPARPD(30),ISETPD(30)
4724* PDF parametrization
4725 DATA IPARPD /
4726 & -5,-5, 0, 0, 0, 0,-5,-5,-5, 0, 0, 5,-5,-5, 5, 5, 5, 5, 5, 5,
4727 & 5, 5,-5, 5, 5, 0, 0, 0, 0, 0/
4728* number of set
4729 DATA ISETPD /
4730 & -6,-6, 0, 0, 0, 0,-3,-6,-6, 0, 0, 2,-2,-2, 2, 2, 6, 6, 2, 6,
4731 & 6, 6,-2, 2, 2, 0, 0, 0, 0, 0/
4732
4733**PHOJET105a
4734C COMMON /GLOCMS/ XECM,XPCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
4735C PARAMETER ( MAXPRO = 16 )
4736C PARAMETER ( MAXTAB = 20 )
4737C COMMON /HAXSEC/ XSECTA(4,-1:MAXPRO,4,MAXTAB),XSECT(6,-1:MAXPRO),
4738C & MXSECT(0:4,-1:MAXPRO,4),ECMSH(4,MAXTAB),ISTTAB
4739C CHARACTER*8 MDLNA
4740C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
4741C COMMON /PROCES/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15)
4742**PHOJET110
4743C global event kinematics and particle IDs
4744 INTEGER IFPAP,IFPAB
4745 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
4746 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
4747C hard cross sections and MC selection weights
4748 INTEGER Max_pro_2
4749 PARAMETER ( Max_pro_2 = 16 )
4750 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
4751 & MH_acc_1,MH_acc_2
4752 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
4753 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
4754 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
4755 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
4756 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
4757 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
4758C model switches and parameters
4759 CHARACTER*8 MDLNA
4760 INTEGER ISWMDL,IPAMDL
4761 DOUBLE PRECISION PARMDL
4762 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4763C general process information
4764 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
4765 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
4766**
4767 DIMENSION PP(4),PT(4)
4768
4769 LOGICAL LSTART
4770 DATA LSTART /.TRUE./
4771
4772 IJP = IJPROJ
4773 IJT = IJTARG
4774 Q2 = VIRT
4775* lepton-projectiles: initialize real photon instead
4776 IF ((IJP.EQ.3).OR.(IJP.EQ.4).OR.(IJP.EQ.10).OR.(IJP.EQ.11)) THEN
4777 IJP = 7
4778 Q2 = ZERO
4779 ENDIF
4780 IF (LPHOIN) CALL PHO_INIT(-1,LOUT,IDUM)
4781* switch Reggeon off
4782C IPAMDL(3)= 0
4783 IF (IP.EQ.1) THEN
4784 IFPAP(1) = IDT_IPDGHA(IJP)
4785 IFPAB(1) = IJP
4786 ELSE
4787 IFPAP(1) = 2212
4788 IFPAB(1) = IDT_ICIHAD(IFPAP(1))
4789 ENDIF
4790 PMASS(1) = AAM(IFPAB(1))-SQRT(Q2)
4791 PVIRT(1) = PMASS(1)**2
4792 IF (IT.EQ.1) THEN
4793 IFPAP(2) = IDT_IPDGHA(IJT)
4794 IFPAB(2) = IJT
4795 ELSE
4796 IFPAP(2) = 2212
4797 IFPAB(2) = IDT_ICIHAD(IFPAP(2))
4798 ENDIF
4799 PMASS(2) = AAM(IFPAB(2))
4800 PVIRT(2) = ZERO
4801 DO 1 K=1,4
4802 PP(K) = ZERO
4803 PT(K) = ZERO
4804 1 CONTINUE
4805* get max. possible momenta of incoming particles to be used for PHOJET ini.
4806 PPF = ZERO
4807 PTF = ZERO
4808 SCPF= 1.5D0
4809 IF (UMO.GE.1.E5) THEN
4810 SCPF= 5.0D0
4811 ENDIF
4812 IF (NCOMPO.GT.0) THEN
4813 DO 2 I=1,NCOMPO
4814 IF (IT.GT.1) THEN
4815 CALL DT_NCLPOT(IEMUCH(I),IEMUMA(I),ITZ,IT,ZERO,ZERO,0)
4816 ELSE
4817 CALL DT_NCLPOT(IPZ,IP,IEMUCH(I),IEMUMA(I),ZERO,ZERO,0)
4818 ENDIF
4819 PPFTMP = MAX(PFERMP(1),PFERMN(1))
4820 PTFTMP = MAX(PFERMP(2),PFERMN(2))
4821 IF (PPFTMP.GT.PPF) PPF = PPFTMP
4822 IF (PTFTMP.GT.PTF) PTF = PTFTMP
4823 2 CONTINUE
4824 ELSE
4825 CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
4826 PPF = MAX(PFERMP(1),PFERMN(1))
4827 PTF = MAX(PFERMP(2),PFERMN(2))
4828 ENDIF
4829 PTF = -PTF
4830 PPF = SCPF*PPF
4831 PTF = SCPF*PTF
4832 IF (IJP.EQ.7) THEN
4833 AMP2 = SIGN(PMASS(1)**2,PMASS(1))
4834 PP(3) = PPCM
4835 PP(4) = SQRT(AMP2+PP(3)**2)
4836 ELSE
4837 EPF = SQRT(PPF**2+PMASS(1)**2)
4838 CALL DT_LTNUC(PPF,EPF,PP(3),PP(4),2)
4839 ENDIF
4840 ETF = SQRT(PTF**2+PMASS(2)**2)
4841 CALL DT_LTNUC(PTF,ETF,PT(3),PT(4),3)
4842 ECMINI = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
4843 & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
4844 IF (LSTART) THEN
4845 WRITE(LOUT,1001) IP,IPZ,SCPF,PPF,PP
4846 1001 FORMAT(
4847 & ' DT_PHOINI: PHOJET initialized for projectile A,Z = ',
4848 & I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
4849 IF (NCOMPO.GT.0) THEN
4850 WRITE(LOUT,1002) SCPF,PTF,PT
4851 ELSE
4852 WRITE(LOUT,1003) IT,ITZ,SCPF,PTF,PT
4853 ENDIF
4854 1002 FORMAT(
4855 & ' DT_PHOINI: PHOJET initialized for target emulsion ',
4856 & /,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
4857 1003 FORMAT(
4858 & ' DT_PHOINI: PHOJET initialized for target A,Z = ',
4859 & I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
4860 WRITE(LOUT,1004) ECMINI
4861 1004 FORMAT(' E_cm = ',E10.3)
4862 IF (IJP.EQ.8) WRITE(LOUT,1005)
4863 1005 FORMAT(
4864 & ' DT_PHOINI: warning! proton parameters used for neutron',
4865 & ' projectile')
4866 LSTART = .FALSE.
4867 ENDIF
4868* switch off new diffractive cross sections at low energies for nuclei
4869* (temporary solution)
4870 IF ((ISWMDL(30).NE.0).AND.((IP.GT.1).OR.(IT.GT.1))) THEN
4871 WRITE(LOUT,'(1X,A)')
4872 & ' DT_PHOINI: model-switch 30 for nuclei re-set !'
4873 CALL PHO_SETMDL(30,0,1)
4874 ENDIF
4875*
4876C IF (IJP.EQ.7) THEN
4877C AMP2 = SIGN(PMASS(1)**2,PMASS(1))
4878C PP(3) = PPCM
4879C PP(4) = SQRT(AMP2+PP(3)**2)
4880C ELSE
4881C PFERMX = ZERO
4882C IF (IP.GT.1) PFERMX = 0.5D0
4883C EFERMX = SQRT(PFERMX**2+PMASS(1)**2)
4884C CALL DT_LTNUC(PFERMX,EFERMX,PP(3),PP(4),2)
4885C ENDIF
4886C PFERMX = ZERO
4887C IF ((IT.GT.1).OR.(NCOMPO.GT.0)) PFERMX = -0.5D0
4888C EFERMX = SQRT(PFERMX**2+PMASS(2)**2)
4889C CALL DT_LTNUC(PFERMX,EFERMX,PT(3),PT(4),3)
4890**sr 26.10.96
4891 ISAV = IPAMDL(13)
4892 IF ((ISHAD(2).EQ.1).AND.
4893 & ((IJPROJ.EQ. 7).OR.(IJPROJ.EQ.3).OR.(IJPROJ.EQ.4).OR.
4894 & (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11))) IPAMDL(13) = 1
4895**
4896 CALL PHO_EVENT(-1,PP,PT,SIGMAX,IREJ1)
4897**sr 26.10.96
4898 IPAMDL(13) = ISAV
4899**
4900*
4901* patch for cascade calculations:
4902* define parton distribution functions for other hadrons, i.e. other
4903* then defined already in phojet
4904 IF (IOGLB.EQ.100) THEN
4905 WRITE(LOUT,1006)
4906 1006 FORMAT(/,1X,'PHOINI: additional parton distribution functions',
4907 & ' assiged (ID,IPAR,ISET)',/)
4908 NPDF = 0
4909 DO 3 I=1,30
4910 IF (IPARPD(I).NE.0) THEN
4911 NPDF = NPDF+1
4912 IF (NPDF.GT.MAXPDF) STOP ' PHOINI: npdf > maxpdf !'
4913 IF ((IPARPD(I).GT.0).AND.(ISETPD(I).GT.0)) THEN
4914 IDPDG = IDT_IPDGHA(I)
4915 IPAR = IPARPD(I)
4916 ISET = ISETPD(I)
4917 WRITE(LOUT,'(13X,A8,3I6)') ANAME(I),IDPDG,IPAR,ISET
4918 CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,0,0,-1)
4919 ENDIF
4920 ENDIF
4921 3 CONTINUE
4922 ENDIF
4923
4924C CALL PHO_PHIST(-1,SIGMAX)
4925 IF (IREJ1.NE.0) THEN
4926 WRITE(LOUT,1000)
4927 1000 FORMAT(1X,'PHOINI: PHOJET event-initialization failed!')
4928 STOP
4929 ENDIF
4930
4931 RETURN
4932 END
4933
4934*$ CREATE DT_EVENTD.FOR
4935*COPY DT_EVENTD
4936*
4937*===eventd=============================================================*
4938*
4939 SUBROUTINE DT_EVENTD(IREJ)
4940
4941************************************************************************
4942* Quasi-elastic neutrino nucleus scattering. *
4943* This version dated 29.04.00 is written by S. Roesler. *
4944************************************************************************
4945
4946 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4947 SAVE
4948 PARAMETER ( LINP = 10 ,
4949 & LOUT = 6 ,
4950 & LDAT = 9 )
4951 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY5=1.0D-5)
4952 PARAMETER (SQTINF=1.0D+15)
4953
4954 LOGICAL LFIRST
4955
4956* event history
4957 PARAMETER (NMXHKK=200000)
4958 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
4959 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
4960 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
4961* extended event history
4962 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
4963 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
4964 & IHIST(2,NMXHKK)
4965* flags for input different options
4966 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
4967 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
4968 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
4969 PARAMETER (MAXLND=4000)
4970 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
4971* properties of interacting particles
4972 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
4973* Lorentz-parameters of the current interaction
4974 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4975 & UMO,PPCM,EPROJ,PPROJ
4976* nuclear potential
4977 LOGICAL LFERMI
4978 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
4979 & EBINDP(2),EBINDN(2),EPOT(2,210),
4980 & ETACOU(2),ICOUL,LFERMI
4981* steering flags for qel neutrino scattering modules
4982 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
4983 COMMON /QNPOL/ POLARX(4),PMODUL
4984 INTEGER PYK
4985
4986 DATA LFIRST /.TRUE./
4987
4988 IREJ = 0
4989
4990 IF (LFIRST) THEN
4991 LFIRST = .FALSE.
4992 CALL DT_MASS_INI
4993 ENDIF
4994
4995* JETSET parameter
4996 CALL DT_INITJS(0)
4997
4998* interacting target nucleon
4999 LTYP = NEUTYP
5000 IF (NEUDEC.LE.9) THEN
5001 IF ((LTYP.EQ.1).OR.(LTYP.EQ.3).OR.(LTYP.EQ.5)) THEN
5002 NUCTYP = 2112
5003 NUCTOP = 2
5004 ELSE
5005 NUCTYP = 2212
5006 NUCTOP = 1
5007 ENDIF
5008 ELSE
5009 RTYP = DT_RNDM(RTYP)
5010 ZFRAC = DBLE(ITZ)/DBLE(IT)
5011 IF (RTYP.LE.ZFRAC) THEN
5012 NUCTYP = 2212
5013 NUCTOP = 1
5014 ELSE
5015 NUCTYP = 2112
5016 NUCTOP = 2
5017 ENDIF
5018 ENDIF
5019
5020* select first nucleon in list with matching id and reset all other
5021* nucleons which have been marked as "wounded" by ININUC
5022 IFOUND = 0
5023 DO 1 I=1,NHKK
5024 IF ((IDHKK(I).EQ.NUCTYP).AND.(IFOUND.EQ.0)) THEN
5025 ISTHKK(I) = 12
5026 IFOUND = 1
5027 IDX = I
5028 ELSE
5029 IF (ISTHKK(I).EQ.12) ISTHKK(I) = 14
5030 ENDIF
5031 1 CONTINUE
5032 IF (IFOUND.EQ.0)
5033 & STOP ' EVENTD: interacting target nucleon not found! '
5034
5035* correct position of proj. lepton: assume position of target nucleon
5036 DO 3 I=1,4
5037 VHKK(I,1) = VHKK(I,IDX)
5038 WHKK(I,1) = WHKK(I,IDX)
5039 3 CONTINUE
5040
5041* load initial momenta for conservation check
5042 IF (LEMCCK) THEN
5043 CALL DT_EVTEMC(ZERO,ZERO,PPROJ,EPROJ,1,IDUM,IDUM)
5044 CALL DT_EVTEMC(PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),PHKK(4,IDX),
5045 & 2,IDUM,IDUM)
5046 ENDIF
5047
5048* quasi-elastic scattering
5049 IF (NEUDEC.LT.9) THEN
5050 CALL DT_QEL_POL(EPROJ,LTYP,PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),
5051 & PHKK(4,IDX),PHKK(5,IDX))
5052* CC event on p or n
5053 ELSEIF (NEUDEC.EQ.10) THEN
5054 CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,1,PHKK(1,IDX),PHKK(2,IDX),
5055 & PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5056* NC event on p or n
5057 ELSEIF (NEUDEC.EQ.11) THEN
5058 CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,2,PHKK(1,IDX),PHKK(2,IDX),
5059 & PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5060 ENDIF
5061
5062* get final state particles from Lund-common and write them into HKKEVT
5063 NPOINT(1) = NHKK+1
5064 NPOINT(4) = NHKK+1
5065 NLINES = PYK(0,1)
5066 NHKK0 = NHKK+1
5067 DO 4 I=4,NLINES
5068 IF (K(I,1).EQ.1) THEN
5069 ID = K(I,2)
5070 PX = P(I,1)
5071 PY = P(I,2)
5072 PZ = P(I,3)
5073 PE = P(I,4)
5074 CALL DT_EVTPUT(1,ID,1,IDX,PX,PY,PZ,PE,0,0,0)
5075 IDBJ = IDT_ICIHAD(ID)
5076 EKIN = PHKK(4,NHKK)-PHKK(5,NHKK)
5077 IF ((IDBJ.EQ.1).OR.(IDBJ.EQ.8)) THEN
5078 IF (EKIN.LE.EPOT(2,IDBJ)) ISTHKK(NHKK) = 16
5079 ENDIF
5080 VHKK(1,NHKK) = VHKK(1,IDX)
5081 VHKK(2,NHKK) = VHKK(2,IDX)
5082 VHKK(3,NHKK) = VHKK(3,IDX)
5083 VHKK(4,NHKK) = VHKK(4,IDX)
5084C IF (I.EQ.4) THEN
5085C WHKK(1,NHKK) = POLARX(1)
5086C WHKK(2,NHKK) = POLARX(2)
5087C WHKK(3,NHKK) = POLARX(3)
5088C WHKK(4,NHKK) = POLARX(4)
5089C ELSE
5090 WHKK(1,NHKK) = WHKK(1,IDX)
5091 WHKK(2,NHKK) = WHKK(2,IDX)
5092 WHKK(3,NHKK) = WHKK(3,IDX)
5093 WHKK(4,NHKK) = WHKK(4,IDX)
5094C ENDIF
5095 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
5096 ENDIF
5097 4 CONTINUE
5098
5099 IF (LEMCCK) THEN
5100 CHKLEV = TINY5
5101 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,778,IREJ1)
5102 IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
5103 ENDIF
5104
5105* transform momenta into cms (as required for inc etc.)
5106 DO 5 I=NHKK0,NHKK
5107 IF (ISTHKK(I).EQ.1) THEN
5108 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,3)
5109 PHKK(3,I) = PZ
5110 PHKK(4,I) = PE
5111 ENDIF
5112 5 CONTINUE
5113
5114 RETURN
5115 END
5116
5117*$ CREATE DT_KKEVNT.FOR
5118*COPY DT_KKEVNT
5119*
5120*===kkevnt=============================================================*
5121*
5122 SUBROUTINE DT_KKEVNT(KKMAT,IREJ)
5123
5124************************************************************************
5125* Treatment of complete nucleus-nucleus or hadron-nucleus scattering *
5126* without nuclear effects (one event). *
5127* This subroutine is an update of the previous version (KKEVT) written *
5128* by J. Ranft/ H.-J. Moehring. *
5129* This version dated 20.04.95 is written by S. Roesler *
5130************************************************************************
5131
5132 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5133 SAVE
5134 PARAMETER ( LINP = 10 ,
5135 & LOUT = 6 ,
5136 & LDAT = 9 )
5137 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10)
5138
5139 PARAMETER ( MAXNCL = 260,
5140 & MAXVQU = MAXNCL,
5141 & MAXSQU = 20*MAXVQU,
5142 & MAXINT = MAXVQU+MAXSQU)
5143* event history
5144 PARAMETER (NMXHKK=200000)
5145 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5146 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5147 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5148* extended event history
5149 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5150 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5151 & IHIST(2,NMXHKK)
5152* flags for input different options
5153 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5154 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5155 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5156* rejection counter
5157 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
5158 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
5159 & IREXCI(3),IRDIFF(2),IRINC
5160* statistics
5161 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5162 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5163 & ICEVTG(8,0:30)
5164* properties of interacting particles
5165 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5166* Lorentz-parameters of the current interaction
5167 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5168 & UMO,PPCM,EPROJ,PPROJ
5169* flags for diffractive interactions (DTUNUC 1.x)
5170 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
5171* interface HADRIN-DPM
5172 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5173* nucleon-nucleon event-generator
5174 CHARACTER*8 CMODEL
5175 LOGICAL LPHOIN
5176 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
5177* coordinates of nucleons
5178 COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
5179* interface between Glauber formalism and DPM
5180 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
5181 & INTER1(MAXINT),INTER2(MAXINT)
5182* Glauber formalism: collision properties
5183 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
7cbda79e 5184 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
5185 & NCP,NCT
9aaba0d6 5186* central particle production, impact parameter biasing
5187 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5188**temporary
5189* statistics: Glauber-formalism
5190 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
5191**
5192
5193 DATA NEVOLD,IPOLD,ITOLD,JJPOLD,EPROLD /4*0,0.0D0/
5194
5195 IREJ = 0
5196 ICREQU = ICREQU+1
5197 NC = 0
7cbda79e 5198 NCP = 0
5199 NCT = 0
9aaba0d6 5200
5201 1 CONTINUE
5202 ICSAMP = ICSAMP+1
5203 NC = NC+1
5204 IF (MOD(NC,10).EQ.0) THEN
5205 WRITE(LOUT,1000) NEVHKK
5206 1000 FORMAT(1X,'KKEVNT: event ',I8,' rejected!')
5207 GOTO 9999
5208 ENDIF
5209
5210* initialize DTEVT1/DTEVT2
5211 CALL DT_EVTINI
5212
5213* We need the following only in order to sample nucleon coordinates.
5214* However we don't have parameters (cross sections, slope etc.)
5215* for neutrinos available. Therefore switch projectile to proton
5216* in this case.
5217 IF (MCGENE.EQ.4) THEN
5218 JJPROJ = 1
5219 ELSE
5220 JJPROJ = IJPROJ
5221 ENDIF
5222
5223 10 CONTINUE
5224 IF ( (NEVHKK.NE.NEVOLD).OR.(ICENTR.GT.0).OR.
5225* make sure that Glauber-formalism is called each time the interaction
5226* configuration changed
5227 & (IP.NE.IPOLD).OR.(IT.NE.ITOLD).OR.(JJPROJ.NE.JJPOLD).OR.
5228 & (ABS(EPROJ-EPROLD).GT.TINY10) ) THEN
5229* sample number of nucleon-nucleon coll. according to Glauber-form.
5230 CALL DT_GLAUBE(IP,IT,JJPROJ,BIMPAC,NN,NP,NT,JSSH,JTSH,KKMAT)
5231 NWTSAM = NN
5232 NWASAM = NP
5233 NWBSAM = NT
5234 NEVOLD = NEVHKK
5235 IPOLD = IP
5236 ITOLD = IT
5237 JJPOLD = JJPROJ
5238 EPROLD = EPROJ
7cbda79e 5239 DO 8 I=1, IP
5240 NCP = NCP+JSSH(I)
5241* WRITE(6,*)' PROJ.NUCL. ',I,' NCOLL = ',NCP
5242 8 CONTINUE
5243 DO 9 I=1, IT
5244 NCT = NCT+JTSH(I)
5245* WRITE(6,*)' TAR.NUCL. ',I,' NCOLL = ',NCT
5246 9 CONTINUE
9aaba0d6 5247 ENDIF
5248
5249* force diffractive particle production in h-K interactions
5250 IF (((ABS(ISINGD).GT.1).OR.(ABS(IDOUBD).GT.1)).AND.
5251 & (IP.EQ.1).AND.(NN.NE.1)) THEN
5252 NEVOLD = 0
5253 GOTO 10
5254 ENDIF
5255
5256* check number of involved proj. nucl. (NP) if central prod.is requested
5257 IF (ICENTR.GT.0) THEN
5258 CALL DT_CHKCEN(IP,IT,NP,NT,IBACK)
5259 IF (IBACK.GT.0) GOTO 10
5260 ENDIF
5261
5262* get initial nucleon-configuration in projectile and target
5263* rest-system (including Fermi-momenta if requested)
5264 CALL DT_ININUC(IJPROJ,IP,IPZ,PKOO,JSSH,1)
5265 MODE = 2
5266 IF (EPROJ.LE.EHADTH) MODE = 3
5267 CALL DT_ININUC(IJTARG,IT,ITZ,TKOO,JTSH,MODE)
5268
5269 IF ((MCGENE.NE.3).AND.(MCGENE.NE.4)) THEN
5270
5271* activate HADRIN at low energies (implemented for h-N scattering only)
5272 IF (EPROJ.LE.EHADHI) THEN
5273 IF (EHADTH.LT.ZERO) THEN
5274* smooth transition btwn. DPM and HADRIN
5275 FRAC = (EPROJ-EHADLO)/(EHADHI-EHADLO)
5276 RR = DT_RNDM(FRAC)
5277 IF (RR.GT.FRAC) THEN
5278 IF (IP.EQ.1) THEN
5279 CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5280 IF (IREJ1.GT.0) GOTO 1
5281 RETURN
5282 ELSE
5283 WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5284 ENDIF
5285 ENDIF
5286 ELSE
5287* fixed threshold for onset of production via HADRIN
5288 IF (EPROJ.LE.EHADTH) THEN
5289 IF (IP.EQ.1) THEN
5290 CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5291 IF (IREJ1.GT.0) GOTO 1
5292 RETURN
5293 ELSE
5294 WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5295 ENDIF
5296 ENDIF
5297 ENDIF
5298 ENDIF
5299 1001 FORMAT(1X,'KKEVNT: warning! interaction of proj. (m=',
5300 & I3,') with target (m=',I3,')',/,11X,
5301 & 'at E_lab=',F5.1,'GeV (threshold-energy: ',F3.1,
5302 & 'GeV) cannot be handled')
5303
5304* sampling of momentum-x fractions & flavors of chain ends
5305 CALL DT_SPLPTN(NN)
5306
5307* Lorentz-transformation of wounded nucleons into nucl.-nucl. cms
5308 CALL DT_NUC2CM
5309
5310* collect momenta of chain ends and put them into DTEVT1
5311 CALL DT_GETPTN(IP,NN,NCSY,IREJ1)
5312 IF (IREJ1.NE.0) GOTO 1
5313
5314 ENDIF
5315
5316* handle chains including fragmentation (two-chain approximation)
5317 IF (MCGENE.EQ.1) THEN
5318* two-chain approximation
5319 CALL DT_EVENTA(IJPROJ,IP,IT,NCSY,IREJ1)
5320 IF (IREJ1.NE.0) THEN
5321 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKEVNT'
5322 GOTO 1
5323 ENDIF
5324 ELSEIF (MCGENE.EQ.2) THEN
5325* multiple-Po exchange including minijets
5326 CALL DT_EVENTB(NCSY,IREJ1)
5327 IF (IREJ1.NE.0) THEN
5328 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKEVNT'
5329 GOTO 1
5330 ENDIF
5331 ELSEIF (MCGENE.EQ.3) THEN
5332 STOP ' This version does not contain LEPTO !'
5333 ELSEIF (MCGENE.EQ.4) THEN
5334* quasi-elastic neutrino scattering
5335 CALL DT_EVENTD(IREJ1)
5336 IF (IREJ1.NE.0) THEN
5337 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 4 in KKEVNT'
5338 GOTO 1
5339 ENDIF
5340 ELSE
5341 WRITE(LOUT,1002) MCGENE
5342 1002 FORMAT(1X,'KKEVNT: warning! event-generator',I4,
5343 & ' not available - program stopped')
5344 STOP
5345 ENDIF
5346
5347 RETURN
5348
5349 9999 CONTINUE
5350 IREJ = 1
5351 RETURN
5352 END
5353
5354*$ CREATE DT_CHKCEN.FOR
5355*COPY DT_CHKCEN
5356*
5357*===chkcen=============================================================*
5358*
5359 SUBROUTINE DT_CHKCEN(IP,IT,NP,NT,IBACK)
5360
5361************************************************************************
5362* Check of number of involved projectile nucleons if central production*
5363* is requested. *
5364* Adopted from a part of the old KKEVT routine which was written by *
5365* J. Ranft/H.-J.Moehring. *
5366* This version dated 13.01.95 is written by S. Roesler *
5367************************************************************************
5368
5369 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5370 SAVE
5371 PARAMETER ( LINP = 10 ,
5372 & LOUT = 6 ,
5373 & LDAT = 9 )
5374
5375* statistics
5376 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5377 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5378 & ICEVTG(8,0:30)
5379* central particle production, impact parameter biasing
5380 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5381
5382 IBACK = 0
5383
5384* old version
5385 IF (ICENTR.EQ.2) THEN
5386 IF (IP.LT.IT) THEN
5387 IF (IP.LE.8) THEN
5388 IF (NP.LT.IP-1) IBACK = 1
5389 ELSEIF (IP.LE.16) THEN
5390 IF (NP.LT.IP-2) IBACK = 1
5391 ELSEIF (IP.LE.32) THEN
5392 IF (NP.LT.IP-3) IBACK = 1
5393 ELSEIF (IP.GE.33) THEN
5394 IF (NP.LT.IP-5) IBACK = 1
5395 ENDIF
5396 ELSEIF (IP.EQ.IT) THEN
5397 IF (IP.EQ.32) THEN
5398 IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5399 ELSE
5400 IF (NP.LT.IP-IP/8) IBACK = 1
5401 ENDIF
5402 ELSEIF (ABS(IP-IT).LT.3) THEN
5403 IF (NP.LT.IP-IP/8) IBACK = 1
5404 ENDIF
5405 ELSE
5406* new version (DPMJET, 5.6.99)
5407 IF (IP.LT.IT) THEN
5408 IF (IP.LE.8) THEN
5409 IF (NP.LT.IP-1) IBACK = 1
5410 ELSEIF (IP.LE.16) THEN
5411 IF (NP.LT.IP-2) IBACK = 1
5412 ELSEIF (IP.LT.32) THEN
5413 IF (NP.LT.IP-3) IBACK = 1
5414 ELSEIF (IP.GE.32) THEN
5415 IF (IT.LE.150) THEN
5416* Example: S-Ag
5417 IF (NP.LT.IP-1) IBACK = 1
5418 ELSE
5419* Example: S-Au
5420 IF (NP.LT.IP) IBACK = 1
5421 ENDIF
5422 ENDIF
5423 ELSEIF (IP.EQ.IT) THEN
5424* Example: S-S
5425 IF (IP.EQ.32) THEN
5426 IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5427* Example: Pb-Pb
5428 ELSE
5429 IF (NP.LT.IP-IP/4) IBACK = 1
5430 ENDIF
5431 ELSEIF (ABS(IP-IT).LT.3) THEN
5432 IF (NP.LT.IP-IP/8) IBACK = 1
5433 ENDIF
5434 ENDIF
5435
5436 ICCPRO = ICCPRO+1
5437
5438 RETURN
5439 END
5440
5441*$ CREATE DT_ININUC.FOR
5442*COPY DT_ININUC
5443*
5444*===ininuc=============================================================*
5445*
5446 SUBROUTINE DT_ININUC(ID,NMASS,NCH,COORD,JS,IMODE)
5447
5448************************************************************************
5449* Samples initial configuration of nucleons in nucleus with mass NMASS *
5450* including Fermi-momenta (if reqested). *
5451* ID BAMJET-code for hadrons (instead of nuclei) *
5452* NMASS mass number of nucleus (number of nucleons) *
5453* NCH charge of nucleus *
5454* COORD(3,NMASS) coordinates of nucleons inside nucleus in fm *
5455* JS(NMASS) > 0 nucleon undergoes nucleon-nucleon interact. *
5456* IMODE = 1 projectile nucleus *
5457* = 2 target nucleus *
5458* = 3 target nucleus (E_lab<E_thr for HADRIN) *
5459* Adopted from a part of the old KKEVT routine which was written by *
5460* J. Ranft/H.-J.Moehring. *
5461* This version dated 13.01.95 is written by S. Roesler *
5462************************************************************************
5463
5464 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5465 SAVE
5466 PARAMETER ( LINP = 10 ,
5467 & LOUT = 6 ,
5468 & LDAT = 9 )
5469 PARAMETER (FM2MM=1.0D-12)
5470
5471 PARAMETER ( MAXNCL = 260,
5472 & MAXVQU = MAXNCL,
5473 & MAXSQU = 20*MAXVQU,
5474 & MAXINT = MAXVQU+MAXSQU)
5475* event history
5476 PARAMETER (NMXHKK=200000)
5477 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5478 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5479 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5480* extended event history
5481 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5482 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5483 & IHIST(2,NMXHKK)
5484* flags for input different options
5485 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5486 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5487 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5488* auxiliary common for chain system storage (DTUNUC 1.x)
5489 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
5490* nuclear potential
5491 LOGICAL LFERMI
5492 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5493 & EBINDP(2),EBINDN(2),EPOT(2,210),
5494 & ETACOU(2),ICOUL,LFERMI
5495* properties of photon/lepton projectiles
5496 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5497* particle properties (BAMJET index convention)
5498 CHARACTER*8 ANAME
5499 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5500 & IICH(210),IIBAR(210),K1(210),K2(210)
5501* Glauber formalism: collision properties
5502 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5503 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
5504* flavors of partons (DTUNUC 1.x)
5505 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5506 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5507 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
5508 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5509 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
5510 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5511 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
5512* interface HADRIN-DPM
5513 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5514
5515 DIMENSION PF(4),PFTOT(4),COORD(3,MAXNCL),JS(MAXNCL)
5516
5517* number of neutrons
5518 NNEU = NMASS-NCH
5519* initializations
5520 NP = 0
5521 NN = 0
5522 DO 1 K=1,4
5523 PFTOT(K) = 0.0D0
5524 1 CONTINUE
5525 MODE = IMODE
5526 IF (IMODE.GT.2) MODE = 2
5527**sr 29.5. new NPOINT(1)-definition
5528C IF (IMODE.GE.2) NPOINT(1) = NHKK+1
5529**
5530 NHADRI = 0
5531 NC = NHKK
5532
5533* get initial configuration
5534 DO 2 I=1,NMASS
5535 NHKK = NHKK+1
5536 IF (JS(I).GT.0) THEN
5537 ISTHKK(NHKK) = 10+MODE
5538 IF (IMODE.EQ.3) THEN
5539* additional treatment if HADRIN-generator is requested
5540 NHADRI = NHADRI+1
5541 IF (NHADRI.EQ.1) IDXTA = NHKK
5542 IF (NHADRI.GT.1) ISTHKK(NHKK) = 14
5543 ENDIF
5544 ELSE
5545 ISTHKK(NHKK) = 12+MODE
5546 ENDIF
5547 IF (NMASS.GE.2) THEN
5548* treatment for nuclei
5549 FRAC = 1.0D0-DBLE(NCH)/DBLE(NMASS)
5550 RR = DT_RNDM(FRAC)
5551 IF ((RR.LT.FRAC).AND.(NN.LT.NNEU)) THEN
5552 IDX = 8
5553 NN = NN+1
5554 ELSEIF ((RR.GE.FRAC).AND.(NP.LT.NCH)) THEN
5555 IDX = 1
5556 NP = NP+1
5557 ELSEIF (NN.LT.NNEU) THEN
5558 IDX = 8
5559 NN = NN+1
5560 ELSEIF (NP.LT.NCH) THEN
5561 IDX = 1
5562 NP = NP+1
5563 ENDIF
5564 IDHKK(NHKK) = IDT_IPDGHA(IDX)
5565 IDBAM(NHKK) = IDX
5566 IF (MODE.EQ.1) THEN
5567 IPOSP(I) = NHKK
5568 KKPROJ(I) = IDX
5569 ELSE
5570 IPOST(I) = NHKK
5571 KKTARG(I) = IDX
5572 ENDIF
5573 IF (IDX.EQ.1) THEN
5574 PFER = PFERMP(MODE)
5575 PBIN = SQRT(2.0D0*EBINDP(MODE)*AAM(1))
5576 ELSE
5577 PFER = PFERMN(MODE)
5578 PBIN = SQRT(2.0D0*EBINDN(MODE)*AAM(8))
5579 ENDIF
5580 CALL DT_FER4M(PFER,PBIN,PF(1),PF(2),PF(3),PF(4),IDX)
5581 DO 3 K=1,4
5582 PFTOT(K) = PFTOT(K)+PF(K)
5583 PHKK(K,NHKK) = PF(K)
5584 3 CONTINUE
5585 PHKK(5,NHKK) = AAM(IDX)
5586 ELSE
5587* treatment for hadrons
5588 IDHKK(NHKK) = IDT_IPDGHA(ID)
5589 IDBAM(NHKK) = ID
5590 PHKK(4,NHKK) = AAM(ID)
5591 PHKK(5,NHKK) = AAM(ID)
5592C* VDM assumption
5593C IF (IDHKK(NHKK).EQ.22) THEN
5594C PHKK(4,NHKK) = AAM(33)
5595C PHKK(5,NHKK) = AAM(33)
5596C ENDIF
5597 IF (MODE.EQ.1) THEN
5598 IPOSP(I) = NHKK
5599 KKPROJ(I) = ID
5600 PHKK(5,NHKK) = PHKK(5,NHKK)-SQRT(VIRT)
5601 ELSE
5602 IPOST(I) = NHKK
5603 KKTARG(I) = ID
5604 ENDIF
5605 ENDIF
5606 DO 4 K=1,3
5607 VHKK(K,NHKK) = COORD(K,I)*FM2MM
5608 WHKK(K,NHKK) = COORD(K,I)*FM2MM
5609 4 CONTINUE
5610 IF (MODE.EQ.2) VHKK(1,NHKK) = VHKK(1,NHKK)+BIMPAC*FM2MM
5611 IF (MODE.EQ.2) WHKK(1,NHKK) = WHKK(1,NHKK)+BIMPAC*FM2MM
5612 VHKK(4,NHKK) = 0.0D0
5613 WHKK(4,NHKK) = 0.0D0
5614 2 CONTINUE
5615
5616* balance Fermi-momenta
5617 IF (NMASS.GE.2) THEN
5618 DO 5 I=1,NMASS
5619 NC = NC+1
5620 DO 6 K=1,3
5621 PHKK(K,NC) = PHKK(K,NC)-PFTOT(K)/DBLE(NMASS)
5622 6 CONTINUE
5623 PHKK(4,NC) = SQRT(PHKK(5,NC)**2+PHKK(1,NC)**2+
5624 & PHKK(2,NC)**2+PHKK(3,NC)**2)
5625 5 CONTINUE
5626 ENDIF
5627
5628 RETURN
5629 END
5630
5631*$ CREATE DT_FER4M.FOR
5632*COPY DT_FER4M
5633*
5634*===fer4m==============================================================*
5635*
5636 SUBROUTINE DT_FER4M(PFERM,PBIND,PXT,PYT,PZT,ET,KT)
5637
5638************************************************************************
5639* Sampling of nucleon Fermi-momenta from distributions at T=0. *
5640* processed by S. Roesler, 17.10.95 *
5641************************************************************************
5642
5643 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5644 SAVE
5645 PARAMETER ( LINP = 10 ,
5646 & LOUT = 6 ,
5647 & LDAT = 9 )
5648
5649 LOGICAL LSTART
5650
5651* particle properties (BAMJET index convention)
5652 CHARACTER*8 ANAME
5653 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5654 & IICH(210),IIBAR(210),K1(210),K2(210)
5655* nuclear potential
5656 LOGICAL LFERMI
5657 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5658 & EBINDP(2),EBINDN(2),EPOT(2,210),
5659 & ETACOU(2),ICOUL,LFERMI
5660
5661 DATA LSTART /.TRUE./
5662
5663 ILOOP = 0
5664 IF (LFERMI) THEN
5665 IF (LSTART) THEN
5666 WRITE(LOUT,1000)
5667 1000 FORMAT(/,1X,'FER4M: sampling of Fermi-momenta activated')
5668 LSTART = .FALSE.
5669 ENDIF
5670 1 CONTINUE
5671 CALL DT_DFERMI(PABS)
5672 PABS = PFERM*PABS
5673C IF (PABS.GE.PBIND) THEN
5674C ILOOP = ILOOP+1
5675C IF (MOD(ILOOP,500).EQ.0) THEN
5676C WRITE(LOUT,1001) PABS,PBIND,ILOOP
5677C1001 FORMAT(1X,'FER4M: Fermi-mom. corr. for binding',
5678C & ' energy ',2E12.3,I6)
5679C ENDIF
5680C GOTO 1
5681C ENDIF
5682 CALL DT_DPOLI(POLC,POLS)
5683 CALL DT_DSFECF(SFE,CFE)
5684 CXTA = POLS*CFE
5685 CYTA = POLS*SFE
5686 CZTA = POLC
5687 ET = SQRT(PABS*PABS+AAM(KT)**2)
5688 PXT = CXTA*PABS
5689 PYT = CYTA*PABS
5690 PZT = CZTA*PABS
5691 ELSE
5692 ET = AAM(KT)
5693 PXT = 0.0D0
5694 PYT = 0.0D0
5695 PZT = 0.0D0
5696 ENDIF
5697
5698 RETURN
5699 END
5700
5701*$ CREATE DT_NUC2CM.FOR
5702*COPY DT_NUC2CM
5703*
5704*===nuc2cm=============================================================*
5705*
5706 SUBROUTINE DT_NUC2CM
5707
5708************************************************************************
5709* Lorentz-transformation of all wounded nucleons from Lab. to nucl.- *
5710* nucl. cms. (This subroutine replaces NUCMOM.) *
5711* This version dated 15.01.95 is written by S. Roesler *
5712************************************************************************
5713
5714 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5715 SAVE
5716 PARAMETER ( LINP = 10 ,
5717 & LOUT = 6 ,
5718 & LDAT = 9 )
5719 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
5720
5721* event history
5722 PARAMETER (NMXHKK=200000)
5723 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5724 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5725 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5726* extended event history
5727 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5728 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5729 & IHIST(2,NMXHKK)
5730* statistics
5731 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5732 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5733 & ICEVTG(8,0:30)
5734* properties of photon/lepton projectiles
5735 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5736* particle properties (BAMJET index convention)
5737 CHARACTER*8 ANAME
5738 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5739 & IICH(210),IIBAR(210),K1(210),K2(210)
5740* Glauber formalism: collision properties
5741 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5742 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
5743**temporary
5744* statistics: Glauber-formalism
5745 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
5746**
5747
5748 ICWP = 0
5749 ICWT = 0
5750 NWTACC = 0
5751 NWAACC = 0
5752 NWBACC = 0
5753
5754 NPOINT(1) = NHKK+1
5755 NEND = NHKK
5756 DO 1 I=1,NEND
5757 IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.12)) THEN
5758 IF (ISTHKK(I).EQ.11) NWAACC = NWAACC+1
5759 IF (ISTHKK(I).EQ.12) NWBACC = NWBACC+1
5760 MODE = ISTHKK(I)-9
5761C IF (IDHKK(I).EQ.22) THEN
5762C* VDM assumption
5763C PEIN = AAM(33)
5764C IDB = 33
5765C ELSE
5766C PEIN = PHKK(4,I)
5767C IDB = IDBAM(I)
5768C ENDIF
5769C CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PEIN,
5770C & PX,PY,PZ,PE,IDB,MODE)
5771 IF (PHKK(5,I).GT.ZERO) THEN
5772 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
5773 & PX,PY,PZ,PE,IDBAM(I),MODE)
5774 ELSE
5775 PX = PGAMM(1)
5776 PY = PGAMM(2)
5777 PZ = PGAMM(3)
5778 PE = PGAMM(4)
5779 ENDIF
5780 IST = ISTHKK(I)-2
5781 ID = IDHKK(I)
5782C* VDM assumption
5783C IF (ID.EQ.22) ID = 113
5784 CALL DT_EVTPUT(IST,ID,I,0,PX,PY,PZ,PE,0,0,0)
5785 IF (ISTHKK(I).EQ.11) ICWP = ICWP+1
5786 IF (ISTHKK(I).EQ.12) ICWT = ICWT+1
5787 ENDIF
5788 1 CONTINUE
5789
5790 NWTACC = MAX(NWAACC,NWBACC)
5791 ICDPR = ICDPR+ICWP
5792 ICDTA = ICDTA+ICWT
5793**temporary
5794 IF ((ICWP.EQ.0).OR.(ICWT.EQ.0)) THEN
5795 CALL DT_EVTOUT(4)
5796 STOP
5797 ENDIF
5798
5799 RETURN
5800 END
5801
5802*$ CREATE DT_SPLPTN.FOR
5803*COPY DT_SPLPTN
5804*
5805*===splptn=============================================================*
5806*
5807 SUBROUTINE DT_SPLPTN(NN)
5808
5809************************************************************************
5810* SamPLing of ParToN momenta and flavors. *
5811* This version dated 15.01.95 is written by S. Roesler *
5812************************************************************************
5813
5814 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5815 SAVE
5816 PARAMETER ( LINP = 10 ,
5817 & LOUT = 6 ,
5818 & LDAT = 9 )
5819
5820* Lorentz-parameters of the current interaction
5821 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5822 & UMO,PPCM,EPROJ,PPROJ
5823
5824* sample flavors of sea-quarks
5825 CALL DT_SPLFLA(NN,1)
5826
5827* sample x-values of partons at chain ends
5828 ECM = UMO
5829 CALL DT_XKSAMP(NN,ECM)
5830
5831* samle flavors
5832 CALL DT_SPLFLA(NN,2)
5833
5834 RETURN
5835 END
5836
5837*$ CREATE DT_SPLFLA.FOR
5838*COPY DT_SPLFLA
5839*
5840*===splfla=============================================================*
5841*
5842 SUBROUTINE DT_SPLFLA(NN,MODE)
5843
5844************************************************************************
5845* SamPLing of FLAvors of partons at chain ends. *
5846* This subroutine replaces FLKSAA/FLKSAM. *
5847* NN number of nucleon-nucleon interactions *
5848* MODE = 1 sea-flavors *
5849* = 2 valence-flavors *
5850* Based on the original version written by J. Ranft/H.-J. Moehring. *
5851* This version dated 16.01.95 is written by S. Roesler *
5852************************************************************************
5853
5854 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5855 SAVE
5856 PARAMETER ( LINP = 10 ,
5857 & LOUT = 6 ,
5858 & LDAT = 9 )
5859
5860 PARAMETER ( MAXNCL = 260,
5861 & MAXVQU = MAXNCL,
5862 & MAXSQU = 20*MAXVQU,
5863 & MAXINT = MAXVQU+MAXSQU)
5864* flavors of partons (DTUNUC 1.x)
5865 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5866 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5867 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
5868 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5869 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
5870 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5871 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
5872* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5873 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
5874 & IXPV,IXPS,IXTV,IXTS,
5875 & INTVV1(MAXVQU),INTVV2(MAXVQU),
5876 & INTSV1(MAXVQU),INTSV2(MAXVQU),
5877 & INTVS1(MAXVQU),INTVS2(MAXVQU),
5878 & INTSS1(MAXSQU),INTSS2(MAXSQU),
5879 & INTDV1(MAXVQU),INTDV2(MAXVQU),
5880 & INTVD1(MAXVQU),INTVD2(MAXVQU),
5881 & INTDS1(MAXSQU),INTDS2(MAXSQU),
5882 & INTSD1(MAXSQU),INTSD2(MAXSQU)
5883* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5884 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
5885 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
5886* particle properties (BAMJET index convention)
5887 CHARACTER*8 ANAME
5888 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5889 & IICH(210),IIBAR(210),K1(210),K2(210)
5890* various options for treatment of partons (DTUNUC 1.x)
5891* (chain recombination, Cronin,..)
5892 LOGICAL LCO2CR,LINTPT
5893 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
5894 & LCO2CR,LINTPT
5895
5896 IF (MODE.EQ.1) THEN
5897* sea-flavors
5898 DO 1 I=1,NN
5899 IPSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
5900 IPSAQ(I) = -IPSQ(I)
5901 1 CONTINUE
5902 DO 2 I=1,NN
5903 ITSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
5904 ITSAQ(I)= -ITSQ(I)
5905 2 CONTINUE
5906 ELSEIF (MODE.EQ.2) THEN
5907* valence flavors
5908 DO 3 I=1,IXPV
5909 CALL DT_FLAHAD(KKPROJ(IFROVP(I)),IPVQ(I),IPPV1(I),IPPV2(I))
5910 3 CONTINUE
5911 DO 4 I=1,IXTV
5912 CALL DT_FLAHAD(KKTARG(IFROVT(I)),ITVQ(I),ITTV1(I),ITTV2(I))
5913 4 CONTINUE
5914 ENDIF
5915
5916 RETURN
5917 END
5918
5919*$ CREATE DT_GETPTN.FOR
5920*COPY DT_GETPTN
5921*
5922*===getptn=============================================================*
5923*
5924 SUBROUTINE DT_GETPTN(IP,NN,NCSY,IREJ)
5925
5926************************************************************************
5927* This subroutine collects partons at chain ends from temporary *
5928* commons and puts them into DTEVT1. *
5929* This version dated 15.01.95 is written by S. Roesler *
5930************************************************************************
5931
5932 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5933 SAVE
5934 PARAMETER ( LINP = 10 ,
5935 & LOUT = 6 ,
5936 & LDAT = 9 )
5937 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0)
5938
5939 LOGICAL LCHK
5940
5941 PARAMETER ( MAXNCL = 260,
5942 & MAXVQU = MAXNCL,
5943 & MAXSQU = 20*MAXVQU,
5944 & MAXINT = MAXVQU+MAXSQU)
5945* event history
5946 PARAMETER (NMXHKK=200000)
5947 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5948 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5949 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5950* extended event history
5951 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5952 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5953 & IHIST(2,NMXHKK)
5954* flags for input different options
5955 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5956 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5957 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5958* auxiliary common for chain system storage (DTUNUC 1.x)
5959 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
5960* statistics
5961 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5962 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5963 & ICEVTG(8,0:30)
5964* flags for diffractive interactions (DTUNUC 1.x)
5965 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
5966* x-values of partons (DTUNUC 1.x)
5967 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
5968 & XTVQ(MAXVQU),XTVD(MAXVQU),
5969 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
5970 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
5971* flavors of partons (DTUNUC 1.x)
5972 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5973 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5974 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
5975 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5976 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
5977 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5978 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
5979* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5980 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
5981 & IXPV,IXPS,IXTV,IXTS,
5982 & INTVV1(MAXVQU),INTVV2(MAXVQU),
5983 & INTSV1(MAXVQU),INTSV2(MAXVQU),
5984 & INTVS1(MAXVQU),INTVS2(MAXVQU),
5985 & INTSS1(MAXSQU),INTSS2(MAXSQU),
5986 & INTDV1(MAXVQU),INTDV2(MAXVQU),
5987 & INTVD1(MAXVQU),INTVD2(MAXVQU),
5988 & INTDS1(MAXSQU),INTDS2(MAXSQU),
5989 & INTSD1(MAXSQU),INTSD2(MAXSQU)
5990* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5991 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
5992 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
5993
5994 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PP(4),PT(4)
5995
5996 DATA AMSS,AMVS,AMDS,AMVD,AMVV/0.4D0,2.0D0,2.0D0,2.5D0,2.0D0/
5997
5998 IREJ = 0
5999 NCSY = 0
6000 NPOINT(2) = NHKK+1
6001
6002* sea-sea chains
6003 DO 10 I=1,NSS
6004 IF (ISKPCH(1,I).EQ.99) GOTO 10
6005 ICCHAI(1,1) = ICCHAI(1,1)+2
6006 IDXP = INTSS1(I)
6007 IDXT = INTSS2(I)
6008 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6009 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6010 DO 11 K=1,4
6011 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6012 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6013 PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6014 PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6015 11 CONTINUE
6016 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6017 & +(PP1(3)+PT1(3))**2)
6018 ECH = PP1(4)+PT1(4)
6019 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6020 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6021 & +(PP2(3)+PT2(3))**2)
6022 ECH = PP2(4)+PT2(4)
6023 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6024 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6025 AM1 = SQRT(AM1)
6026 AM2 = SQRT(AM2)
6027 IF ((AM1.LT.AMSS).OR.(AM2.LT.AMSS)) THEN
6028C WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6029 5000 FORMAT(1X,'incon. chain mass SS: ',2I5,2E10.3)
6030 ENDIF
6031 ELSE
6032 WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6033 ENDIF
6034 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6035 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6036 IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6037 IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6038 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6039 & 0,0,1)
6040 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6041 & 0,0,1)
6042 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6043 & 0,0,1)
6044 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6045 & 0,0,1)
6046 NCSY = NCSY+1
6047 10 CONTINUE
6048
6049* disea-sea chains
6050 DO 20 I=1,NDS
6051 IF (ISKPCH(2,I).EQ.99) GOTO 20
6052 ICCHAI(1,2) = ICCHAI(1,2)+2
6053 IDXP = INTDS1(I)
6054 IDXT = INTDS2(I)
6055 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6056 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6057 DO 21 K=1,4
6058 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6059 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6060 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6061 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6062 21 CONTINUE
6063 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6064 & +(PP1(3)+PT1(3))**2)
6065 ECH = PP1(4)+PT1(4)
6066 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6067 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6068 & +(PP2(3)+PT2(3))**2)
6069 ECH = PP2(4)+PT2(4)
6070 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6071 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6072 AM1 = SQRT(AM1)
6073 AM2 = SQRT(AM2)
6074 IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6075C WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6076 5001 FORMAT(1X,'incon. chain mass DS: ',2I5,2E10.3)
6077 ENDIF
6078 ELSE
6079 WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6080 ENDIF
6081 IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6082 IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6083 IFT1 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6084 IFT2 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6085 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6086 & 0,0,2)
6087 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6088 & 0,0,2)
6089 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6090 & 0,0,2)
6091 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6092 & 0,0,2)
6093 NCSY = NCSY+1
6094 20 CONTINUE
6095
6096* sea-disea chains
6097 DO 30 I=1,NSD
6098 IF (ISKPCH(3,I).EQ.99) GOTO 30
6099 ICCHAI(1,3) = ICCHAI(1,3)+2
6100 IDXP = INTSD1(I)
6101 IDXT = INTSD2(I)
6102 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6103 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6104 DO 31 K=1,4
6105 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6106 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6107 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6108 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6109 31 CONTINUE
6110 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6111 & +(PP1(3)+PT1(3))**2)
6112 ECH = PP1(4)+PT1(4)
6113 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6114 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6115 & +(PP2(3)+PT2(3))**2)
6116 ECH = PP2(4)+PT2(4)
6117 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6118 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6119 AM1 = SQRT(AM1)
6120 AM2 = SQRT(AM2)
6121 IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6122C WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6123 5002 FORMAT(1X,'incon. chain mass SD: ',2I5,2E10.3)
6124 ENDIF
6125 ELSE
6126 WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6127 ENDIF
6128 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6129 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6130 IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6131 IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6132 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6133 & 0,0,3)
6134 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6135 & 0,0,3)
6136 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6137 & 0,0,3)
6138 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6139 & 0,0,3)
6140 NCSY = NCSY+1
6141 30 CONTINUE
6142
6143* disea-valence chains
6144 DO 50 I=1,NDV
6145 IF (ISKPCH(5,I).EQ.99) GOTO 50
6146 ICCHAI(1,5) = ICCHAI(1,5)+2
6147 IDXP = INTDV1(I)
6148 IDXT = INTDV2(I)
6149 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6150 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6151 DO 51 K=1,4
6152 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6153 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6154 PT1(K) = XTVQ(IDXT) *PHKK(K,MOT)
6155 PT2(K) = XTVD(IDXT) *PHKK(K,MOT)
6156 51 CONTINUE
6157 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6158 & +(PP1(3)+PT1(3))**2)
6159 ECH = PP1(4)+PT1(4)
6160 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6161 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6162 & +(PP2(3)+PT2(3))**2)
6163 ECH = PP2(4)+PT2(4)
6164 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6165 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6166 AM1 = SQRT(AM1)
6167 AM2 = SQRT(AM2)
6168 IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6169C WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6170 5003 FORMAT(1X,'incon. chain mass DV: ',2I5,2E10.3)
6171 ENDIF
6172 ELSE
6173 WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6174 ENDIF
6175 IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6176 IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6177 IFT1 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6178 IFT2 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6179 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6180 & 0,0,5)
6181 CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6182 & 0,0,5)
6183 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6184 & 0,0,5)
6185 CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6186 & 0,0,5)
6187 NCSY = NCSY+1
6188 50 CONTINUE
6189
6190* valence-sea chains
6191 DO 60 I=1,NVS
6192 IF (ISKPCH(6,I).EQ.99) GOTO 60
6193 ICCHAI(1,6) = ICCHAI(1,6)+2
6194 IDXP = INTVS1(I)
6195 IDXT = INTVS2(I)
6196 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6197 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6198 DO 61 K=1,4
6199 PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6200 PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6201 PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6202 PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6203 61 CONTINUE
6204 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6205 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6206 IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6207 IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6208 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6209 IF (LCHK) THEN
6210 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6211 & 0,0,6)
6212 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6213 & 0,0,6)
6214 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6215 & 0,0,6)
6216 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6217 & 0,0,6)
6218 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6219 & +(PP1(3)+PT1(3))**2)
6220 ECH = PP1(4)+PT1(4)
6221 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6222 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6223 & +(PP2(3)+PT2(3))**2)
6224 ECH = PP2(4)+PT2(4)
6225 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6226 ELSE
6227 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6228 & 0,0,6)
6229 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6230 & 0,0,6)
6231 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6232 & 0,0,6)
6233 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6234 & 0,0,6)
6235 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6236 & +(PP1(3)+PT2(3))**2)
6237 ECH = PP1(4)+PT2(4)
6238 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6239 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6240 & +(PP2(3)+PT1(3))**2)
6241 ECH = PP2(4)+PT1(4)
6242 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6243 ENDIF
6244 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6245 AM1 = SQRT(AM1)
6246 AM2 = SQRT(AM2)
6247 IF ((AM1.LT.AMSS).OR.(AM2.LT.AMVS)) THEN
6248C WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6249 5004 FORMAT(1X,'incon. chain mass VS: ',2I5,2E10.3)
6250 ENDIF
6251 ELSE
6252 WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6253 ENDIF
6254 NCSY = NCSY+1
6255 60 CONTINUE
6256
6257* sea-valence chains
6258 DO 40 I=1,NSV
6259 IF (ISKPCH(4,I).EQ.99) GOTO 40
6260 ICCHAI(1,4) = ICCHAI(1,4)+2
6261 IDXP = INTSV1(I)
6262 IDXT = INTSV2(I)
6263 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6264 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6265 DO 41 K=1,4
6266 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6267 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6268 PT1(K) = XTVD(IDXT) *PHKK(K,MOT)
6269 PT2(K) = XTVQ(IDXT) *PHKK(K,MOT)
6270 41 CONTINUE
6271 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6272 & +(PP1(3)+PT1(3))**2)
6273 ECH = PP1(4)+PT1(4)
6274 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6275 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6276 & +(PP2(3)+PT2(3))**2)
6277 ECH = PP2(4)+PT2(4)
6278 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6279 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6280 AM1 = SQRT(AM1)
6281 AM2 = SQRT(AM2)
6282 IF ((AM1.LT.AMVS).OR.(AM2.LT.AMSS)) THEN
6283C WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6284 5005 FORMAT(1X,'incon. chain mass SV: ',2I5,2E10.3)
6285 ENDIF
6286 ELSE
6287 WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6288 ENDIF
6289 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6290 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6291 IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6292 IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6293 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6294 & 0,0,4)
6295 CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6296 & 0,0,4)
6297 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6298 & 0,0,4)
6299 CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6300 & 0,0,4)
6301 NCSY = NCSY+1
6302 40 CONTINUE
6303
6304* valence-disea chains
6305 DO 70 I=1,NVD
6306 IF (ISKPCH(7,I).EQ.99) GOTO 70
6307 ICCHAI(1,7) = ICCHAI(1,7)+2
6308 IDXP = INTVD1(I)
6309 IDXT = INTVD2(I)
6310 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6311 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6312 DO 71 K=1,4
6313 PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6314 PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6315 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6316 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6317 71 CONTINUE
6318 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6319 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6320 IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6321 IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6322 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6323 IF (LCHK) THEN
6324 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6325 & 0,0,7)
6326 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6327 & 0,0,7)
6328 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6329 & 0,0,7)
6330 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6331 & 0,0,7)
6332 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6333 & +(PP1(3)+PT1(3))**2)
6334 ECH = PP1(4)+PT1(4)
6335 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6336 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6337 & +(PP2(3)+PT2(3))**2)
6338 ECH = PP2(4)+PT2(4)
6339 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6340 ELSE
6341 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6342 & 0,0,7)
6343 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6344 & 0,0,7)
6345 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6346 & 0,0,7)
6347 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6348 & 0,0,7)
6349 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6350 & +(PP1(3)+PT2(3))**2)
6351 ECH = PP1(4)+PT2(4)
6352 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6353 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6354 & +(PP2(3)+PT1(3))**2)
6355 ECH = PP2(4)+PT1(4)
6356 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6357 ENDIF
6358 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6359 AM1 = SQRT(AM1)
6360 AM2 = SQRT(AM2)
6361 IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6362C WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6363 5006 FORMAT(1X,'incon. chain mass VD: ',2I5,2E10.3)
6364 ENDIF
6365 ELSE
6366 WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6367 ENDIF
6368 NCSY = NCSY+1
6369 70 CONTINUE
6370
6371* valence-valence chains
6372 DO 80 I=1,NVV
6373 IF (ISKPCH(8,I).EQ.99) GOTO 80
6374 ICCHAI(1,8) = ICCHAI(1,8)+2
6375 IDXP = INTVV1(I)
6376 IDXT = INTVV2(I)
6377 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6378 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6379 DO 81 K=1,4
6380 PP1(K) = XPVQ(IDXP)*PHKK(K,MOP)
6381 PP2(K) = XPVD(IDXP)*PHKK(K,MOP)
6382 PT1(K) = XTVD(IDXT)*PHKK(K,MOT)
6383 PT2(K) = XTVQ(IDXT)*PHKK(K,MOT)
6384 81 CONTINUE
6385 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6386 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6387 IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6388 IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6389
6390* check for diffractive event
6391 IDIFF = 0
6392 IF (((ISINGD.GT.0).OR.(IDOUBD.GT.0)).AND.
6393 & (IP.EQ.1).AND.(NN.EQ.1)) THEN
6394 DO 800 K=1,4
6395 PP(K) = PP1(K)+PP2(K)
6396 PT(K) = PT1(K)+PT2(K)
6397 800 CONTINUE
6398 ISTCK = NHKK
6399 CALL DT_DIFEVT(IFP1,IFP2,PP,MOP,
6400 & IFT1,IFT2,PT,MOT,IDIFF,NCSY,IREJ1)
6401C IF (IREJ1.NE.0) GOTO 9999
6402 IF (IREJ1.NE.0) THEN
6403 IDIFF = 0
6404 NHKK = ISTCK
6405 ENDIF
6406 ELSE
6407 IDIFF = 0
6408 ENDIF
6409
6410 IF (IDIFF.EQ.0) THEN
6411* valence-valence chain system
6412 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6413 IF (LCHK) THEN
6414* baryon-baryon
6415 CALL DT_EVTPUT(-21,IFP1,MOP,0,
6416 & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6417 CALL DT_EVTPUT(-22,IFT1,MOT,0,
6418 & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6419 CALL DT_EVTPUT(-21,IFP2,MOP,0,
6420 & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6421 CALL DT_EVTPUT(-22,IFT2,MOT,0,
6422 & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6423 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6424 & +(PP1(3)+PT1(3))**2)
6425 ECH = PP1(4)+PT1(4)
6426 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6427 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6428 & +(PP2(3)+PT2(3))**2)
6429 ECH = PP2(4)+PT2(4)
6430 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6431 ELSE
6432* antibaryon-baryon
6433 CALL DT_EVTPUT(-21,IFP1,MOP,0,
6434 & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6435 CALL DT_EVTPUT(-22,IFT2,MOT,0,
6436 & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6437 CALL DT_EVTPUT(-21,IFP2,MOP,0,
6438 & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6439 CALL DT_EVTPUT(-22,IFT1,MOT,0,
6440 & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6441 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6442 & +(PP1(3)+PT2(3))**2)
6443 ECH = PP1(4)+PT2(4)
6444 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6445 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6446 & +(PP2(3)+PT1(3))**2)
6447 ECH = PP2(4)+PT1(4)
6448 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6449 ENDIF
6450 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6451 AM1 = SQRT(AM1)
6452 AM2 = SQRT(AM2)
6453 IF ((AM1.LT.AMVV).OR.(AM2.LT.AMVV)) THEN
6454C WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6455 5007 FORMAT(1X,'incon. chain mass VV: ',2I5,2E10.3)
6456 ENDIF
6457 ELSE
6458 WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6459 ENDIF
6460 NCSY = NCSY+1
6461 ENDIF
6462 80 CONTINUE
6463 IF (ISTHKK(NPOINT(2)).EQ.1) NPOINT(2) = NPOINT(2)+1
6464
6465* energy-momentum & flavor conservation check
6466 IF (ABS(IDIFF).NE.1) THEN
6467 IF (IDIFF.NE.0) THEN
6468 IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-41,1,0,
6469 & 1,3,10,IREJ)
6470 ELSE
6471 IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-31,-32,0,
6472 & 1,3,10,IREJ)
6473 ENDIF
6474 IF (IREJ.NE.0) THEN
6475 CALL DT_EVTOUT(4)
6476 STOP
6477 ENDIF
6478 ENDIF
6479
6480 RETURN
6481
6482 9999 CONTINUE
6483 IREJ = 1
6484 RETURN
6485 END
6486
6487*$ CREATE DT_CHKCSY.FOR
6488*COPY DT_CHKCSY
6489*
6490*===chkcsy=============================================================*
6491*
6492 SUBROUTINE DT_CHKCSY(ID1,ID2,LCHK)
6493
6494************************************************************************
6495* CHeCk Chain SYstem for consistency of partons at chain ends. *
6496* ID1,ID2 PDG-numbers of partons at chain ends *
6497* LCHK = .true. consistent chain *
6498* = .false. inconsistent chain *
6499* This version dated 18.01.95 is written by S. Roesler *
6500************************************************************************
6501
6502 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6503 SAVE
6504 PARAMETER ( LINP = 10 ,
6505 & LOUT = 6 ,
6506 & LDAT = 9 )
6507
6508 LOGICAL LCHK
6509
6510 LCHK = .TRUE.
6511
6512* q-aq chain
6513 IF ((ABS(ID1).LE.6).AND.(ABS(ID2).LE.6)) THEN
6514 IF (ID1*ID2.GT.0) LCHK = .FALSE.
6515* q-qq, aq-aqaq chain
6516 ELSEIF (((ABS(ID1).LE.6).AND.(ABS(ID2).GT.6)).OR.
6517 & ((ABS(ID1).GT.6).AND.(ABS(ID2).LE.6))) THEN
6518 IF (ID1*ID2.LT.0) LCHK = .FALSE.
6519* qq-aqaq chain
6520 ELSEIF ((ABS(ID1).GT.6).AND.(ABS(ID2).GT.6)) THEN
6521 IF (ID1*ID2.GT.0) LCHK = .FALSE.
6522 ENDIF
6523
6524 RETURN
6525 END
6526
6527*$ CREATE DT_EVENTA.FOR
6528*COPY DT_EVENTA
6529*
6530*===eventa=============================================================*
6531*
6532 SUBROUTINE DT_EVENTA(ID,IP,IT,NCSY,IREJ)
6533
6534************************************************************************
6535* Treatment of nucleon-nucleon interactions in a two-chain *
6536* approximation. *
6537* (input) ID BAMJET-index of projectile hadron (in case of *
6538* h-K scattering) *
6539* IP/IT mass number of projectile/target nucleus *
6540* NCSY number of two chain systems *
6541* IREJ rejection flag *
6542* This version dated 15.01.95 is written by S. Roesler *
6543************************************************************************
6544
6545 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6546 SAVE
6547 PARAMETER ( LINP = 10 ,
6548 & LOUT = 6 ,
6549 & LDAT = 9 )
6550 PARAMETER (TINY10=1.0D-10)
6551
6552* event history
6553 PARAMETER (NMXHKK=200000)
6554 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6555 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6556 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6557* extended event history
6558 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6559 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6560 & IHIST(2,NMXHKK)
6561* rejection counter
6562 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6563 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6564 & IREXCI(3),IRDIFF(2),IRINC
6565* flags for diffractive interactions (DTUNUC 1.x)
6566 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6567* particle properties (BAMJET index convention)
6568 CHARACTER*8 ANAME
6569 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6570 & IICH(210),IIBAR(210),K1(210),K2(210)
6571* flags for input different options
6572 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6573 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6574 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6575* various options for treatment of partons (DTUNUC 1.x)
6576* (chain recombination, Cronin,..)
6577 LOGICAL LCO2CR,LINTPT
6578 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
6579 & LCO2CR,LINTPT
6580
6581 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
6582
6583 IREJ = 0
6584 NPOINT(3) = NHKK+1
6585
6586* skip following treatment for low-mass diffraction
6587 IF (ABS(IFLAGD).EQ.1) THEN
6588 NPOINT(3) = NPOINT(2)
6589 GOTO 5
6590 ENDIF
6591
6592* multiple scattering of chain ends
6593 IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
6594 IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
6595
6596 NC = NPOINT(2)
6597* get a two-chain system from DTEVT1
6598 DO 3 I=1,NCSY
6599 IFP1 = IDHKK(NC)
6600 IFT1 = IDHKK(NC+1)
6601 IFP2 = IDHKK(NC+2)
6602 IFT2 = IDHKK(NC+3)
6603 DO 4 K=1,4
6604 PP1(K) = PHKK(K,NC)
6605 PT1(K) = PHKK(K,NC+1)
6606 PP2(K) = PHKK(K,NC+2)
6607 PT2(K) = PHKK(K,NC+3)
6608 4 CONTINUE
6609 MOP1 = NC
6610 MOT1 = NC+1
6611 MOP2 = NC+2
6612 MOT2 = NC+3
6613 CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
6614 & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
6615 IF (IREJ1.GT.0) THEN
6616 IRHHA = IRHHA+1
6617 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTA'
6618 GOTO 9999
6619 ENDIF
6620 NC = NC+4
6621 3 CONTINUE
6622
6623* meson/antibaryon projectile:
6624* sample single-chain valence-valence systems (Reggeon contrib.)
6625 IF ((IP.EQ.1).AND.(ISICHA.EQ.1)) THEN
6626 IF (IIBAR(ID).LE.0) CALL DT_VV2SCH
6627 ENDIF
6628
6629 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6630* check DTEVT1 for remaining resonance mass corrections
6631 CALL DT_EVTRES(IREJ1)
6632 IF (IREJ1.GT.0) THEN
6633 IRRES(1) = IRRES(1)+1
6634 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in EVENTA'
6635 GOTO 9999
6636 ENDIF
6637 ENDIF
6638
6639* assign p_t to two-"chain" systems consisting of two resonances only
6640* since only entries for chains will be affected, this is obsolete
6641* in case of JETSET-fragmetation
6642 CALL DT_RESPT
6643
6644* combine q-aq chains to color ropes (qq-aqaq) (chain fusion)
6645 IF (LCO2CR) CALL DT_COM2CR
6646
6647 5 CONTINUE
6648
6649* fragmentation of the complete event
6650**uncomment for internal phojet-fragmentation
6651C CALL DT_EVTFRA(IREJ1)
6652 CALL DT_EVTFRG(2,IDUM,NPYMEM,IREJ1)
6653 IF (IREJ1.GT.0) THEN
6654 IRFRAG = IRFRAG+1
6655 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 3 in EVENTA'
6656 GOTO 9999
6657 ENDIF
6658
6659* decay of possible resonances (should be obsolete)
6660 CALL DT_DECAY1
6661
6662 RETURN
6663
6664 9999 CONTINUE
6665 IREVT = IREVT+1
6666 IREJ = 1
6667 RETURN
6668 END
6669
6670*$ CREATE DT_GETCSY.FOR
6671*COPY DT_GETCSY
6672*
6673*===getcsy=============================================================*
6674*
6675 SUBROUTINE DT_GETCSY(IFPR1,PP1,MOP1,IFPR2,PP2,MOP2,
6676 & IFTA1,PT1,MOT1,IFTA2,PT2,MOT2,IREJ)
6677
6678************************************************************************
6679* This version dated 15.01.95 is written by S. Roesler *
6680************************************************************************
6681
6682 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6683 SAVE
6684 PARAMETER ( LINP = 10 ,
6685 & LOUT = 6 ,
6686 & LDAT = 9 )
6687 PARAMETER (TINY10=1.0D-10)
6688
6689* event history
6690 PARAMETER (NMXHKK=200000)
6691 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6692 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6693 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6694* extended event history
6695 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6696 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6697 & IHIST(2,NMXHKK)
6698* rejection counter
6699 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6700 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6701 & IREXCI(3),IRDIFF(2),IRINC
6702* flags for input different options
6703 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6704 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6705 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6706* flags for diffractive interactions (DTUNUC 1.x)
6707 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6708
6709 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),
6710 & IFP1(2),IFP2(2),IFT1(2),IFT2(2),PCH1(4),PCH2(4)
6711
6712 IREJ = 0
6713
6714* get quark content of partons
6715 DO 1 I=1,2
6716 IFP1(I) = 0
6717 IFP2(I) = 0
6718 IFT1(I) = 0
6719 IFT2(I) = 0
6720 1 CONTINUE
6721 IFP1(1) = IDT_IPDG2B(IFPR1,1,2)
6722 IF (ABS(IFPR1).GE.1000) IFP1(2) = IDT_IPDG2B(IFPR1,2,2)
6723 IFP2(1) = IDT_IPDG2B(IFPR2,1,2)
6724 IF (ABS(IFPR2).GE.1000) IFP2(2) = IDT_IPDG2B(IFPR2,2,2)
6725 IFT1(1) = IDT_IPDG2B(IFTA1,1,2)
6726 IF (ABS(IFTA1).GE.1000) IFT1(2) = IDT_IPDG2B(IFTA1,2,2)
6727 IFT2(1) = IDT_IPDG2B(IFTA2,1,2)
6728 IF (ABS(IFTA2).GE.1000) IFT2(2) = IDT_IPDG2B(IFTA2,2,2)
6729
6730* get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq, 3 - qq-aqaq)
6731 IDCH1 = 2
6732 IF ((IFP1(2).EQ.0).AND.(IFT1(2).EQ.0)) IDCH1 = 1
6733 IF ((IFP1(2).NE.0).AND.(IFT1(2).NE.0)) IDCH1 = 3
6734 IDCH2 = 2
6735 IF ((IFP2(2).EQ.0).AND.(IFT2(2).EQ.0)) IDCH2 = 1
6736 IF ((IFP2(2).NE.0).AND.(IFT2(2).NE.0)) IDCH2 = 3
6737
6738* store initial configuration for energy-momentum cons. check
6739 IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IDUM)
6740
6741* sample intrinsic p_t at chain-ends
6742 CALL DT_GETSPT(PP1,IFPR1,IFP1,PP2,IFPR2,IFP2,
6743 & PT1,IFTA1,IFT1,PT2,IFTA2,IFT2,
6744 & AMCH1,IDCH1,AMCH2,IDCH2,IDCH(MOP1),IREJ1)
6745 IF (IREJ1.NE.0) THEN
6746 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in GETCSY'
6747 IRPT = IRPT+1
6748 GOTO 9999
6749 ENDIF
6750
6751C IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6752C IF ((IDCH1.EQ.3).OR.((IDCH1.GT.1).AND.(IDCH2.EQ.1))) THEN
6753C* check second chain for resonance
6754C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6755C & AMCH2,AMCH2N,IDCH2,IREJ1)
6756C IF (IREJ1.NE.0) GOTO 9999
6757C IF (IDR2.NE.0) THEN
6758C CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6759C & AMCH2,AMCH2N,AMCH1,IREJ1)
6760C IF (IREJ1.NE.0) GOTO 9999
6761C ENDIF
6762C* check first chain for resonance
6763C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6764C & AMCH1,AMCH1N,IDCH1,IREJ1)
6765C IF (IREJ1.NE.0) GOTO 9999
6766C IF (IDR1.NE.0) IDR1 = 100*IDR1
6767C ELSE
6768C* check first chain for resonance
6769C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6770C & AMCH1,AMCH1N,IDCH1,IREJ1)
6771C IF (IREJ1.NE.0) GOTO 9999
6772C IF (IDR1.NE.0) THEN
6773C CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6774C & AMCH1,AMCH1N,AMCH2,IREJ1)
6775C IF (IREJ1.NE.0) GOTO 9999
6776C ENDIF
6777C* check second chain for resonance
6778C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6779C & AMCH2,AMCH2N,IDCH2,IREJ1)
6780C IF (IREJ1.NE.0) GOTO 9999
6781C IF (IDR2.NE.0) IDR2 = 100*IDR2
6782C ENDIF
6783C ENDIF
6784
6785 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6786* check chains for resonances
6787 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6788 & AMCH1,AMCH1N,IDCH1,IREJ1)
6789 IF (IREJ1.NE.0) GOTO 9999
6790 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6791 & AMCH2,AMCH2N,IDCH2,IREJ1)
6792 IF (IREJ1.NE.0) GOTO 9999
6793* change kinematics corresponding to resonance-masses
6794 IF ( (IDR1.NE.0).AND.(IDR2.EQ.0) ) THEN
6795 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6796 & AMCH1,AMCH1N,AMCH2,IREJ1)
6797 IF (IREJ1.GT.0) GOTO 9999
6798 IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
6799 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6800 & AMCH2,AMCH2N,IDCH2,IREJ1)
6801 IF (IREJ1.NE.0) GOTO 9999
6802 IF (IDR2.NE.0) IDR2 = 100*IDR2
6803 ELSEIF ( (IDR1.EQ.0).AND.(IDR2.NE.0) ) THEN
6804 CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6805 & AMCH2,AMCH2N,AMCH1,IREJ1)
6806 IF (IREJ1.GT.0) GOTO 9999
6807 IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
6808 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6809 & AMCH1,AMCH1N,IDCH1,IREJ1)
6810 IF (IREJ1.NE.0) GOTO 9999
6811 IF (IDR1.NE.0) IDR1 = 100*IDR1
6812 ELSEIF ( (IDR1.NE.0).AND.(IDR2.NE.0) ) THEN
6813 AMDIF1 = ABS(AMCH1-AMCH1N)
6814 AMDIF2 = ABS(AMCH2-AMCH2N)
6815 IF (AMDIF2.LT.AMDIF1) THEN
6816 CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6817 & AMCH2,AMCH2N,AMCH1,IREJ1)
6818 IF (IREJ1.GT.0) GOTO 9999
6819 IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
6820 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),
6821 & IDR1,IDXR1,AMCH1,AMCH1N,IDCH1,IREJ1)
6822 IF (IREJ1.NE.0) GOTO 9999
6823 IF (IDR1.NE.0) IDR1 = 100*IDR1
6824 ELSE
6825 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6826 & AMCH1,AMCH1N,AMCH2,IREJ1)
6827 IF (IREJ1.GT.0) GOTO 9999
6828 IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
6829 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),
6830 & IDR2,IDXR2,AMCH2,AMCH2N,IDCH2,IREJ1)
6831 IF (IREJ1.NE.0) GOTO 9999
6832 IF (IDR2.NE.0) IDR2 = 100*IDR2
6833 ENDIF
6834 ENDIF
6835 ENDIF
6836
6837* store final configuration for energy-momentum cons. check
6838 IF (LEMCCK) THEN
6839 CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IDUM)
6840 CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
6841 IF (IREJ1.NE.0) GOTO 9999
6842 ENDIF
6843
6844* put partons and chains into DTEVT1
6845 DO 10 I=1,4
6846 PCH1(I) = PP1(I)+PT1(I)
6847 PCH2(I) = PP2(I)+PT2(I)
6848 10 CONTINUE
6849 CALL DT_EVTPUT(-ISTHKK(MOP1),IFPR1,MOP1,0,PP1(1),PP1(2),
6850 & PP1(3),PP1(4),0,0,0)
6851 CALL DT_EVTPUT(-ISTHKK(MOT1),IFTA1,MOT1,0,PT1(1),PT1(2),
6852 & PT1(3),PT1(4),0,0,0)
6853 KCH = 100+IDCH(MOP1)*10+1
6854 CALL DT_EVTPUT(KCH,88888,-2,-1,
6855 & PCH1(1),PCH1(2),PCH1(3),PCH1(4),IDR1,IDXR1,IDCH(MOP1))
6856 CALL DT_EVTPUT(-ISTHKK(MOP2),IFPR2,MOP2,0,PP2(1),PP2(2),
6857 & PP2(3),PP2(4),0,0,0)
6858 CALL DT_EVTPUT(-ISTHKK(MOT2),IFTA2,MOT2,0,PT2(1),PT2(2),
6859 & PT2(3),PT2(4),0,0,0)
6860 KCH = KCH+1
6861 CALL DT_EVTPUT(KCH,88888,-2,-1,
6862 & PCH2(1),PCH2(2),PCH2(3),PCH2(4),IDR2,IDXR2,IDCH(MOP2))
6863
6864 RETURN
6865
6866 9999 CONTINUE
6867 IF ((IDCH(MOP1).LE.3).AND.(IDCH(MOP2).LE.3)) THEN
6868* "cancel" sea-sea chains
6869 CALL DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ1)
6870 IF (IREJ1.NE.0) GOTO 9998
6871**sr 16.5. flag for EVENTB
6872 IREJ = -1
6873 RETURN
6874 ENDIF
6875 9998 CONTINUE
6876 IREJ = 1
6877 RETURN
6878 END
6879
6880*$ CREATE DT_CHKINE.FOR
6881*COPY DT_CHKINE
6882*
6883*===chkine=============================================================*
6884*
6885 SUBROUTINE DT_CHKINE(PP1I,IFP1,PP2I,IFP2,PT1I,IFT1,PT2I,IFT2,
6886 & AMCH1,AMCH1N,AMCH2,IREJ)
6887
6888************************************************************************
6889* This subroutine replaces CORMOM. *
6890* This version dated 05.01.95 is written by S. Roesler *
6891************************************************************************
6892
6893 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6894 SAVE
6895 PARAMETER ( LINP = 10 ,
6896 & LOUT = 6 ,
6897 & LDAT = 9 )
6898 PARAMETER (TINY10=1.0D-10)
6899
6900* flags for input different options
6901 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6902 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6903 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6904* rejection counter
6905 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6906 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6907 & IREXCI(3),IRDIFF(2),IRINC
6908
6909 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),P1(4),P2(4),
6910 & PP1I(4),PP2I(4),PT1I(4),PT2I(4)
6911
6912 IREJ = 0
6913 JMSHL = IMSHL
6914
6915 SCALE = AMCH1N/MAX(AMCH1,TINY10)
6916 DO 10 I=1,4
6917 PP1(I) = PP1I(I)
6918 PP2(I) = PP2I(I)
6919 PT1(I) = PT1I(I)
6920 PT2(I) = PT2I(I)
6921 PP2(I) = PP2(I)+(1.0D0-SCALE)*PP1(I)
6922 PT2(I) = PT2(I)+(1.0D0-SCALE)*PT1(I)
6923 PP1(I) = SCALE*PP1(I)
6924 PT1(I) = SCALE*PT1(I)
6925 10 CONTINUE
6926 IF ((PP1(4).LT.0.0D0).OR.(PP2(4).LT.0.0D0).OR.
6927 & (PT1(4).LT.0.0D0).OR.(PT2(4).LT.0.0D0)) GOTO 9997
6928
6929 ECH = PP2(4)+PT2(4)
6930 PCH = SQRT( (PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2+
6931 & (PP2(3)+PT2(3))**2 )
6932 AMCH22 = (ECH-PCH)*(ECH+PCH)
6933 IF (AMCH22.LT.0.0D0) THEN
6934 IF (IOULEV(1).GT.0)
6935 & WRITE(LOUT,'(1X,A)') 'CHKINE: inconsistent treatment!'
6936 GOTO 9997
6937 ENDIF
6938
6939 AMCH1 = AMCH1N
6940 AMCH2 = SQRT(AMCH22)
6941
6942* put partons again on mass shell
6943 13 CONTINUE
6944 XM1 = 0.0D0
6945 XM2 = 0.0D0
6946 IF (JMSHL.EQ.1) THEN
6947 XM1 = PYMASS(IFP1)
6948 XM2 = PYMASS(IFT1)
6949 ENDIF
6950 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
6951 IF (IREJ1.NE.0) THEN
6952 IF (JMSHL.EQ.0) GOTO 9998
6953 JMSHL = 0
6954 GOTO 13
6955 ENDIF
6956 JMSHL = IMSHL
6957 DO 11 I=1,4
6958 PP1(I) = P1(I)
6959 PT1(I) = P2(I)
6960 11 CONTINUE
6961 14 CONTINUE
6962 XM1 = 0.0D0
6963 XM2 = 0.0D0
6964 IF (JMSHL.EQ.1) THEN
6965 XM1 = PYMASS(IFP2)
6966 XM2 = PYMASS(IFT2)
6967 ENDIF
6968 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P1,P2,IREJ1)
6969 IF (IREJ1.NE.0) THEN
6970 IF (JMSHL.EQ.0) GOTO 9998
6971 JMSHL = 0
6972 GOTO 14
6973 ENDIF
6974 DO 12 I=1,4
6975 PP2(I) = P1(I)
6976 PT2(I) = P2(I)
6977 12 CONTINUE
6978 DO 15 I=1,4
6979 PP1I(I) = PP1(I)
6980 PP2I(I) = PP2(I)
6981 PT1I(I) = PT1(I)
6982 PT2I(I) = PT2(I)
6983 15 CONTINUE
6984 RETURN
6985
6986 9997 IRCHKI(1) = IRCHKI(1)+1
6987**sr
6988C GOTO 9999
6989 IREJ = -1
6990 RETURN
6991**
6992 9998 IRCHKI(2) = IRCHKI(2)+1
6993
6994 9999 CONTINUE
6995 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in CHKINE'
6996 IREJ = 1
6997 RETURN
6998 END
6999
7000*$ CREATE DT_CH2RES.FOR
7001*COPY DT_CH2RES
7002*
7003*===ch2res=============================================================*
7004*
7005 SUBROUTINE DT_CH2RES(IF1,IF2,IF3,IF4,IDR,IDXR,
7006 & AM,AMN,IMODE,IREJ)
7007
7008************************************************************************
7009* Check chains for resonance production. *
7010* This subroutine replaces COMCMA/COBCMA/COMCM2 *
7011* input: *
7012* IF1,2,3,4 input flavors (q,aq in any order) *
7013* AM chain mass *
7014* MODE = 1 check q-aq chain for meson-resonance *
7015* = 2 check q-qq, aq-aqaq chain for baryon-resonance *
7016* = 3 check qq-aqaq chain for lower mass cut *
7017* output: *
7018* IDR = 0 no resonances found *
7019* = -1 pseudoscalar meson/octet baryon *
7020* = 1 vector-meson/decuplet baryon *
7021* IDXR BAMJET-index of corresponding resonance *
7022* AMN mass of corresponding resonance *
7023* *
7024* IREJ rejection flag *
7025* This version dated 06.01.95 is written by S. Roesler *
7026************************************************************************
7027
7028 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7029 SAVE
7030 PARAMETER ( LINP = 10 ,
7031 & LOUT = 6 ,
7032 & LDAT = 9 )
7033
7034* particle properties (BAMJET index convention)
7035 CHARACTER*8 ANAME
7036 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7037 & IICH(210),IIBAR(210),K1(210),K2(210)
7038* quark-content to particle index conversion (DTUNUC 1.x)
7039 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
7040 & IA08(6,21),IA10(6,21)
7041* rejection counter
7042 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7043 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7044 & IREXCI(3),IRDIFF(2),IRINC
7045* flags for input different options
7046 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7047 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7048 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7049
7050 DIMENSION IF(4),JF(4)
7051
7052**sr 4.7. test
7053C DATA AMLOM,AMLOB /0.08D0,0.2D0/
7054 DATA AMLOM,AMLOB /0.1D0,0.7D0/
7055**
7056C DATA AMLOM,AMLOB /0.001D0,0.001D0/
7057
7058 MODE = ABS(IMODE)
7059
7060 IF ((MODE.LT.1).OR.(MODE.GT.3)) THEN
7061 WRITE(LOUT,1000) MODE
7062 1000 FORMAT(1X,'CH2RES: MODE ',I4,' not supported!',/,
7063 & 1X,' program stopped')
7064 STOP
7065 ENDIF
7066
7067 AMX = AM
7068 IREJ = 0
7069 IDR = 0
7070 IDXR = 0
7071 AMN = AMX
7072 IF ((AM.LE.0.0D0).AND.(MODE.EQ.1)) AMX = AMLOM
7073 IF ((AM.LE.0.0D0).AND.(MODE.EQ.2)) AMX = AMLOB
7074
7075 IF(1) = IF1
7076 IF(2) = IF2
7077 IF(3) = IF3
7078 IF(4) = IF4
7079 NF = 0
7080 DO 100 I=1,4
7081 IF (IF(I).NE.0) THEN
7082 NF = NF+1
7083 JF(NF) = IF(I)
7084 ENDIF
7085 100 CONTINUE
7086 IF (NF.LE.MODE) THEN
7087 WRITE(LOUT,1001) MODE,IF
7088 1001 FORMAT(1X,'CH2RES: inconsistent input flavors in MODE ',
7089 & I4,' IF1 = ',I4,' IF2 = ',I4,' IF3 = ',I4,' IF4 = ',I4)
7090 GOTO 9999
7091 ENDIF
7092
7093 GOTO (1,2,3) MODE
7094
7095* check for meson resonance
7096 1 CONTINUE
7097 IFQ = JF(1)
7098 IFAQ = ABS(JF(2))
7099 IF (JF(2).GT.0) THEN
7100 IFQ = JF(2)
7101 IFAQ = ABS(JF(1))
7102 ENDIF
7103 IFPS = IMPS(IFAQ,IFQ)
7104 IFV = IMVE(IFAQ,IFQ)
7105 AMPS = AAM(IFPS)
7106 AMV = AAM(IFV)
7107 AMHI = AMV+0.3D0
7108 IF (AMX.LT.AMV) THEN
7109 IF (AMX.LT.AMPS) THEN
7110 IF (IMODE.GT.0) THEN
7111 IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOM)) GOTO 9999
7112 ELSE
7113 IF (AMX.LT.0.8D0*AMPS) GOTO 9999
7114 ENDIF
7115 LOMRES = LOMRES+1
7116 ENDIF
7117* replace chain by pseudoscalar meson
7118 IDR = -1
7119 IDXR = IFPS
7120 AMN = AMPS
7121 ELSEIF (AMX.LT.AMHI) THEN
7122* replace chain by vector-meson
7123 IDR = 1
7124 IDXR = IFV
7125 AMN = AMV
7126 ENDIF
7127 RETURN
7128
7129* check for baryon resonance
7130 2 CONTINUE
7131 CALL DT_DBKLAS(JF(1),JF(2),JF(3),JB8,JB10)
7132 AM8 = AAM(JB8)
7133 AM10 = AAM(JB10)
7134 AMHI = AM10+0.3D0
7135 IF (AMX.LT.AM10) THEN
7136 IF (AMX.LT.AM8) THEN
7137 IF (IMODE.GT.0) THEN
7138 IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOB)) GOTO 9999
7139 ELSE
7140 IF (AMX.LT.0.8D0*AM8) GOTO 9999
7141 ENDIF
7142 LOBRES = LOBRES+1
7143 ENDIF
7144* replace chain by oktet baryon
7145 IDR = -1
7146 IDXR = JB8
7147 AMN = AM8
7148 ELSEIF (AMX.LT.AMHI) THEN
7149 IDR = 1
7150 IDXR = JB10
7151 AMN = AM10
7152 ENDIF
7153 RETURN
7154
7155* check qq-aqaq for lower mass cut
7156 3 CONTINUE
7157* empirical definition of AMHI to allow for (b-antib)-pair prod.
7158 AMHI = 2.5D0
7159 IF (AMX.LT.AMHI) GOTO 9999
7160 RETURN
7161
7162 9999 CONTINUE
7163 IF ((IOULEV(1).GT.0).AND.(IMODE.GT.0))
7164 & WRITE(LOUT,*) 'rejected 1 in CH2RES',IMODE
7165 IREJ = 1
7166 IRRES(2) = IRRES(2)+1
7167 RETURN
7168 END
7169
7170*$ CREATE DT_RJSEAC.FOR
7171*COPY DT_RJSEAC
7172*
7173*===rjseac=============================================================*
7174*
7175 SUBROUTINE DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ)
7176
7177************************************************************************
7178* ReJection of SEA-sea Chains. *
7179* MOP1/2 entries of projectile sea-partons in DTEVT1 *
7180* MOT1/2 entries of projectile sea-partons in DTEVT1 *
7181* This version dated 16.01.95 is written by S. Roesler *
7182************************************************************************
7183
7184 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7185 SAVE
7186 PARAMETER ( LINP = 10 ,
7187 & LOUT = 6 ,
7188 & LDAT = 9 )
7189 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
7190
7191* event history
7192 PARAMETER (NMXHKK=200000)
7193 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7194 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7195 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7196* extended event history
7197 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7198 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7199 & IHIST(2,NMXHKK)
7200* statistics
7201 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7202 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7203 & ICEVTG(8,0:30)
7204
7205 DIMENSION IDXSEA(2,2),IDXNUC(2),ISTVAL(2)
7206
7207 IREJ = 0
7208
7209* projectile sea q-aq-pair
7210* indices of sea-pair
7211 IDXSEA(1,1) = MOP1
7212 IDXSEA(1,2) = MOP2
7213* index of mother-nucleon
7214 IDXNUC(1) = JMOHKK(1,MOP1)
7215* status of valence quarks to be corrected
7216 ISTVAL(1) = -21
7217
7218* target sea q-aq-pair
7219* indices of sea-pair
7220 IDXSEA(2,1) = MOT1
7221 IDXSEA(2,2) = MOT2
7222* index of mother-nucleon
7223 IDXNUC(2) = JMOHKK(1,MOT1)
7224* status of valence quarks to be corrected
7225 ISTVAL(2) = -22
7226
7227 DO 1 N=1,2
7228 IDONE = 0
7229 DO 2 I=NPOINT(2),NHKK
7230 IF ((ISTHKK(I).EQ.ISTVAL(N)).AND.
7231 & (JMOHKK(1,I).EQ.IDXNUC(N))) THEN
7232* valence parton found
7233* inrease 4-momentum by sea 4-momentum
7234 DO 3 K=1,4
7235 PHKK(K,I) = PHKK(K,I)+PHKK(K,IDXSEA(N,1))+
7236 & PHKK(K,IDXSEA(N,2))
7237 3 CONTINUE
7238 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
7239 & PHKK(2,I)**2-PHKK(3,I)**2))
7240* "cancel" sea-pair
7241 DO 4 J=1,2
7242 ISTHKK(IDXSEA(N,J)) = 100
7243 IDHKK(IDXSEA(N,J)) = 0
7244 JMOHKK(1,IDXSEA(N,J)) = 0
7245 JMOHKK(2,IDXSEA(N,J)) = 0
7246 JDAHKK(1,IDXSEA(N,J)) = 0
7247 JDAHKK(2,IDXSEA(N,J)) = 0
7248 DO 5 K=1,4
7249 PHKK(K,IDXSEA(N,J)) = ZERO
7250 VHKK(K,IDXSEA(N,J)) = ZERO
7251 WHKK(K,IDXSEA(N,J)) = ZERO
7252 5 CONTINUE
7253 PHKK(5,IDXSEA(N,J)) = ZERO
7254 4 CONTINUE
7255 IDONE = 1
7256 ENDIF
7257 2 CONTINUE
7258 IF (IDONE.NE.1) THEN
7259 WRITE(LOUT,1000) NEVHKK,MOP1,MOP2,MOT1,MOT2
7260 1000 FORMAT(1X,'RJSEAC: event ',I8,': inconsistent event',
7261 & '-record!',/,1X,' sea-quark pairs ',
7262 & 2I5,4X,2I5,' could not be canceled!')
7263 GOTO 9999
7264 ENDIF
7265 1 CONTINUE
7266 ICRJSS = ICRJSS+1
7267 RETURN
7268
7269 9999 CONTINUE
7270 IREJ = 1
7271 RETURN
7272 END
7273
7274*$ CREATE DT_VV2SCH.FOR
7275*COPY DT_VV2SCH
7276*
7277*===vv2sch=============================================================*
7278*
7279 SUBROUTINE DT_VV2SCH
7280
7281************************************************************************
7282* Change Valence-Valence chain systems to Single CHain systems for *
7283* hadron-nucleus collisions with meson or antibaryon projectile. *
7284* (Reggeon contribution) *
7285* The single chain system is approximately treated as one chain and a *
7286* meson at rest. *
7287* This version dated 18.01.95 is written by S. Roesler *
7288************************************************************************
7289
7290 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7291 SAVE
7292 PARAMETER ( LINP = 10 ,
7293 & LOUT = 6 ,
7294 & LDAT = 9 )
7295 PARAMETER (ZERO=0.0D0,TINY7=1.0D-7,TINY3=1.0D-3)
7296
7297 LOGICAL LSTART
7298
7299* event history
7300 PARAMETER (NMXHKK=200000)
7301 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7302 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7303 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7304* extended event history
7305 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7306 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7307 & IHIST(2,NMXHKK)
7308* flags for input different options
7309 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7310 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7311 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7312* statistics
7313 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7314 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7315 & ICEVTG(8,0:30)
7316
7317 DIMENSION IF(4,2),MO(4),PP1(4),PP2(4),PT1(4),PT2(4),PCH1(4),
7318 & PCH2(4)
7319
7320 DATA LSTART /.TRUE./
7321
7322 IFSC = 0
7323 IF (LSTART) THEN
7324 WRITE(LOUT,1000)
7325 1000 FORMAT(/,1X,'VV2SCH: Reggeon contribution to valance-',
7326 & 'valence chains treated')
7327 LSTART = .FALSE.
7328 ENDIF
7329
7330 NSTOP = NHKK
7331
7332* get index of first chain
7333 DO 1 I=NPOINT(3),NHKK
7334 IF (IDHKK(I).EQ.88888) THEN
7335 NC = I
7336 GOTO 2
7337 ENDIF
7338 1 CONTINUE
7339
7340 2 CONTINUE
7341 IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)
7342 & .AND.(NC.LT.NSTOP)) THEN
7343* get valence-valence chains
7344 IF ((IDCH(NC).EQ.8).AND.(IDCH(NC+3).EQ.8)) THEN
7345* get "mother"-hadron indices
7346 MO1 = JMOHKK(1,JMOHKK(1,JMOHKK(1,NC)))
7347 MO2 = JMOHKK(1,JMOHKK(1,JMOHKK(2,NC)))
7348 KPROJ = IDT_ICIHAD(IDHKK(MO1))
7349 KTARG = IDT_ICIHAD(IDHKK(MO2))
7350* Lab momentum of projectile hadron
7351 CALL DT_LTNUC(PHKK(3,MO1),PHKK(4,MO1),PPZ,PPE,-3)
7352 PTOT = SQRT(PHKK(1,MO1)**2+PHKK(2,MO1)**2+
7353 & PHKK(3,MO1)**2)
7354
7355 SICHAP = DT_PHNSCH(KPROJ,KTARG,PTOT)
7356 IF (DT_RNDM(PTOT).LE.SICHAP) THEN
7357 ICVV2S = ICVV2S+1
7358* single chain requested
7359* get flavors of chain-end partons
7360 MO(1) = JMOHKK(1,NC)
7361 MO(2) = JMOHKK(2,NC)
7362 MO(3) = JMOHKK(1,NC+3)
7363 MO(4) = JMOHKK(2,NC+3)
7364 DO 3 I=1,4
7365 IF(I,1) = IDT_IPDG2B(IDHKK(MO(I)),1,2)
7366 IF(I,2) = 0
7367 IF (ABS(IDHKK(MO(I))).GE.1000)
7368 & IF(I,2) = IDT_IPDG2B(IDHKK(MO(I)),2,2)
7369 3 CONTINUE
7370* which one is the q-aq chain?
7371* N1,N1+1 - DTEVT1-entries for q-aq system
7372* N2,N2+1 - DTEVT1-entries for the other chain
7373 IF ((IF(1,2).EQ.0).AND.(IF(2,2).EQ.0)) THEN
7374 K1 = 1
7375 K2 = 3
7376 N1 = NC-2
7377 N2 = NC+1
7378 ELSEIF ((IF(3,2).EQ.0).AND.(IF(4,2).EQ.0)) THEN
7379 K1 = 3
7380 K2 = 1
7381 N1 = NC+1
7382 N2 = NC-2
7383 ELSE
7384 GOTO 10
7385 ENDIF
7386 DO 4 K=1,4
7387 PP1(K) = PHKK(K,N1)
7388 PT1(K) = PHKK(K,N1+1)
7389 PP2(K) = PHKK(K,N2)
7390 PT2(K) = PHKK(K,N2+1)
7391 4 CONTINUE
7392 AMCH1 = PHKK(5,N1+2)
7393 AMCH2 = PHKK(5,N2+2)
7394* get meson-identity corresponding to flavors of q-aq chain
7395 ITMP = IRESRJ
7396 IRESRJ = 0
7397 CALL DT_CH2RES(IF(K1,1),IF(K1+1,1),0,0,IDR1,IDXR1,
7398 & ZERO,AMCH1N,1,IDUM)
7399 IRESRJ = ITMP
7400* change kinematics of chains
7401 CALL DT_CHKINE(PP1,IDHKK(N1), PP2,IDHKK(N2),
7402 & PT1,IDHKK(N1+1),PT2,IDHKK(N2+1),
7403 & AMCH1,AMCH1N,AMCH2,IREJ1)
7404 IF (IREJ1.NE.0) GOTO 10
7405* check second chain for resonance
7406 IDCHAI = 2
7407 IF ((IF(K2,2).NE.0).AND.(IF(K2+1,2).NE.0)) IDCHAI = 3
7408 CALL DT_CH2RES(IF(K2,1),IF(K2,2),IF(K2+1,1),IF(K2+1,2),
7409 & IDR2,IDXR2,AMCH2,AMCH2N,IDCHAI,IREJ1)
7410 IF (IREJ1.NE.0) GOTO 10
7411 IF (IDR2.NE.0) IDR2 = 100*IDR2
7412* add partons and chains to DTEVT1
7413 DO 5 K=1,4
7414 PCH1(K) = PP1(K)+PT1(K)
7415 PCH2(K) = PP2(K)+PT2(K)
7416 5 CONTINUE
7417 CALL DT_EVTPUT(ISTHKK(N1),IDHKK(N1),N1,0,PP1(1),PP1(2),
7418 & PP1(3),PP1(4),0,0,0)
7419 CALL DT_EVTPUT(ISTHKK(N1+1),IDHKK(N1+1),N1+1,0,PT1(1),
7420 & PT1(2),PT1(3),PT1(4),0,0,0)
7421 KCH = ISTHKK(N1+2)+100
7422 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH1(1),PCH1(2),PCH1(3),
7423 & PCH1(4),IDR1,IDXR1,IDCH(N1+2))
7424 IDHKK(N1+2) = 22222
7425 CALL DT_EVTPUT(ISTHKK(N2),IDHKK(N2),N2,0,PP2(1),PP2(2),
7426 & PP2(3),PP2(4),0,0,0)
7427 CALL DT_EVTPUT(ISTHKK(N2+1),IDHKK(N2+1),N2+1,0,PT2(1),
7428 & PT2(2),PT2(3),PT2(4),0,0,0)
7429 KCH = ISTHKK(N2+2)+100
7430 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH2(1),PCH2(2),PCH2(3),
7431 & PCH2(4),IDR2,IDXR2,IDCH(N2+2))
7432 IDHKK(N2+2) = 22222
7433 ENDIF
7434 ENDIF
7435 ELSE
7436 GOTO 11
7437 ENDIF
7438 10 CONTINUE
7439 NC = NC+6
7440 GOTO 2
7441
7442 11 CONTINUE
7443
7444 RETURN
7445 END
7446
7447*$ CREATE DT_PHNSCH.FOR
7448*COPY DT_PHNSCH
7449*
7450*=== phnsch ===========================================================*
7451*
7452 DOUBLE PRECISION FUNCTION DT_PHNSCH( KP, KTARG, PLAB )
7453
7454*----------------------------------------------------------------------*
7455* *
7456* Probability for Hadron Nucleon Single CHain interactions: *
7457* *
7458* Created on 30 december 1993 by Alfredo Ferrari & Paola Sala *
7459* Infn - Milan *
7460* *
7461* Last change on 04-jan-94 by Alfredo Ferrari *
7462* *
7463* modified by J.R.for use in DTUNUC 6.1.94 *
7464* *
7465* Input variables: *
7466* Kp = hadron projectile index (Part numbering *
7467* scheme) *
7468* Ktarg = target nucleon index (1=proton, 8=neutron) *
7469* Plab = projectile laboratory momentum (GeV/c) *
7470* Output variable: *
7471* Phnsch = probability per single chain (particle *
7472* exchange) interactions *
7473* *
7474*----------------------------------------------------------------------*
7475
7476 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7477 SAVE
7478
7479 PARAMETER ( LUNOUT = 6 )
7480 PARAMETER ( LUNERR = 6 )
7481 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
7482 PARAMETER ( ZERZER = 0.D+00 )
7483 PARAMETER ( ONEONE = 1.D+00 )
7484 PARAMETER ( TWOTWO = 2.D+00 )
7485 PARAMETER ( FIVFIV = 5.D+00 )
7486 PARAMETER ( HLFHLF = 0.5D+00 )
7487
7488 PARAMETER ( NALLWP = 39 )
7489 PARAMETER ( IDMAXP = 210 )
7490
7491 DIMENSION ICHRGE(39),AM(39)
7492
7493* particle properties (BAMJET index convention)
7494 CHARACTER*8 ANAME
7495 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7496 & IICH(210),IIBAR(210),K1(210),K2(210)
7497
7498 DIMENSION KPTOIP(210)
7499* auxiliary common for reggeon exchange (DTUNUC 1.x)
7500 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
7501 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
7502 & IQTCHR(-6:6),MQUARK(3,39)
7503
7504 DIMENSION SGTCOE (5,33), IHLP (NALLWP)
7505 DIMENSION SGTCO1(5,10),SGTCO2(5,8),SGTCO3(5,15)
454792a9 7506CPH SAVE SGTCOE, IHLP
7507CPH SAVE IQFSC1, IQFSC2, IQBSC1, IQBSC2
9aaba0d6 7508 EQUIVALENCE (SGTCO1(1,1),SGTCOE(1,1))
7509 EQUIVALENCE (SGTCO2(1,1),SGTCOE(1,11))
7510 EQUIVALENCE (SGTCO3(1,1),SGTCOE(1,19))
7511
7512* Conversion from part to paprop numbering
7513 DATA KPTOIP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
7514 & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 66*0,
7515 & 34, 36, 31, 32, 33, 35, 37, 5*0, 38, 5*0, 39, 19*0, 27, 28, 74*0/
7516
7517* 1=baryon, 2=pion, 3=kaon, 4=antibaryon:
7518 DATA IHLP/1,4,5*0,1,4,2*0,3,2*2,2*3,1,4,3,3*1,2,
7519 & 2*3, 2, 4*0, 3*4, 1, 4, 1, 4, 1, 4 /
7520C DATA ( ( SGTCOE (J,I), J=1,5 ), I=1,10 ) /
7521 DATA SGTCO1 /
7522* 1st reaction: gamma p total
7523 &0.147 D+00, ZERZER , ZERZER , 0.0022D+00, -0.0170D+00,
7524* 2nd reaction: gamma d total
7525 &0.300 D+00, ZERZER , ZERZER , 0.0095D+00, -0.057 D+00,
7526* 3rd reaction: pi+ p total
7527 &16.4 D+00, 19.3D+00, -0.42D+00, 0.19 D+00, ZERZER ,
7528* 4th reaction: pi- p total
7529 &33.0 D+00, 14.0D+00, -1.36D+00, 0.456 D+00, -4.03 D+00,
7530* 5th reaction: pi+/- d total
7531 &56.8 D+00, 42.2D+00, -1.45D+00, 0.65 D+00, -5.39 D+00,
7532* 6th reaction: K+ p total
7533 &18.1 D+00, ZERZER , ZERZER , 0.26 D+00, -1.0 D+00,
7534* 7th reaction: K+ n total
7535 &18.7 D+00, ZERZER , ZERZER , 0.21 D+00, -0.89 D+00,
7536* 8th reaction: K+ d total
7537 &34.2 D+00, 7.9 D+00, -2.1 D+00, 0.346 D+00, -0.99 D+00,
7538* 9th reaction: K- p total
7539 &32.1 D+00, ZERZER , ZERZER , 0.66 D+00, -5.6 D+00,
7540* 10th reaction: K- n total
7541 &25.2 D+00, ZERZER , ZERZER , 0.38 D+00, -2.9 D+00/
7542C DATA ( ( SGTCOE (J,I), J=1,5 ), I=11,18 ) /
7543 DATA SGTCO2 /
7544* 11th reaction: K- d total
7545 &57.6 D+00, ZERZER , ZERZER , 1.17 D+00, -9.5 D+00,
7546* 12th reaction: p p total
7547 &48.0 D+00, ZERZER , ZERZER , 0.522 D+00, -4.51 D+00,
7548* 13th reaction: p n total
7549 &47.30 D+00, ZERZER , ZERZER , 0.513 D+00, -4.27 D+00,
7550* 14th reaction: p d total
7551 &91.3 D+00, ZERZER , ZERZER , 1.05 D+00, -8.8 D+00,
7552* 15th reaction: pbar p total
7553 &38.4 D+00, 77.6D+00, -0.64D+00, 0.26 D+00, -1.2 D+00,
7554* 16th reaction: pbar n total
7555 &ZERZER ,133.6D+00, -0.70D+00, -1.22 D+00, 13.7 D+00,
7556* 17th reaction: pbar d total
7557 &112. D+00, 125.D+00, -1.08D+00, 1.14 D+00, -12.4 D+00,
7558* 18th reaction: Lamda p total
7559 &30.4 D+00, ZERZER , ZERZER , ZERZER , 1.6 D+00/
7560C DATA ( ( SGTCOE (J,I), J=1,5 ), I=19,33 ) /
7561 DATA SGTCO3 /
7562* 19th reaction: pi+ p elastic
7563 &ZERZER , 11.4D+00, -0.4 D+00, 0.079 D+00, ZERZER ,
7564* 20th reaction: pi- p elastic
7565 &1.76 D+00, 11.2D+00, -0.64D+00, 0.043 D+00, ZERZER ,
7566* 21st reaction: K+ p elastic
7567 &5.0 D+00, 8.1 D+00, -1.8 D+00, 0.16 D+00, -1.3 D+00,
7568* 22nd reaction: K- p elastic
7569 &7.3 D+00, ZERZER , ZERZER , 0.29 D+00, -2.40 D+00,
7570* 23rd reaction: p p elastic
7571 &11.9 D+00, 26.9D+00, -1.21D+00, 0.169 D+00, -1.85 D+00,
7572* 24th reaction: p d elastic
7573 &16.1 D+00, ZERZER , ZERZER , 0.32 D+00, -3.4 D+00,
7574* 25th reaction: pbar p elastic
7575 &10.2 D+00, 52.7D+00, -1.16D+00, 0.125 D+00, -1.28 D+00,
7576* 26th reaction: pbar p elastic bis
7577 &10.6 D+00, 53.1D+00, -1.19D+00, 0.136 D+00, -1.41 D+00,
7578* 27th reaction: pbar n elastic
7579 &36.5 D+00, ZERZER , ZERZER , ZERZER , -11.9 D+00,
7580* 28th reaction: Lamda p elastic
7581 &12.3 D+00, ZERZER , ZERZER , ZERZER , -2.4 D+00,
7582* 29th reaction: K- p ela bis
7583 &7.24 D+00, 46.0D+00, -4.71D+00, 0.279 D+00, -2.35 D+00,
7584* 30th reaction: pi- p cx
7585 &ZERZER ,0.912D+00, -1.22D+00, ZERZER , ZERZER ,
7586* 31st reaction: K- p cx
7587 &ZERZER , 3.39D+00, -1.75D+00, ZERZER , ZERZER ,
7588* 32nd reaction: K+ n cx
7589 &ZERZER , 7.18D+00, -2.01D+00, ZERZER , ZERZER ,
7590* 33rd reaction: pbar p cx
7591 &ZERZER , 18.8D+00, -2.01D+00, ZERZER , ZERZER /
7592*
7593* +-------------------------------------------------------------------*
7594 ICHRGE(KTARG)=IICH(KTARG)
7595 AM (KTARG)=AAM (KTARG)
7596* | Check for pi0 (d-dbar)
7597 IF ( KP .NE. 26 ) THEN
7598 IP = KPTOIP (KP)
7599 IF(IP.EQ.0)IP=1
7600 ICHRGE(IP)=IICH(KP)
7601 AM (IP)=AAM (KP)
7602* |
7603* +-------------------------------------------------------------------*
7604* |
7605 ELSE
7606 IP = 23
7607 ICHRGE(IP)=0
7608 END IF
7609* |
7610* +-------------------------------------------------------------------*
7611* +-------------------------------------------------------------------*
7612* | No such interactions for baryon-baryon
7613 IF ( IIBAR (KP) .GT. 0 ) THEN
7614 DT_PHNSCH = ZERZER
7615 RETURN
7616* |
7617* +-------------------------------------------------------------------*
7618* | No "annihilation" diagram possible for K+ p/n
7619 ELSE IF ( IP .EQ. 15 ) THEN
7620 DT_PHNSCH = ZERZER
7621 RETURN
7622* |
7623* +-------------------------------------------------------------------*
7624* | No "annihilation" diagram possible for K0 p/n
7625 ELSE IF ( IP .EQ. 24 ) THEN
7626 DT_PHNSCH = ZERZER
7627 RETURN
7628* |
7629* +-------------------------------------------------------------------*
7630* | No "annihilation" diagram possible for Omebar p/n
7631 ELSE IF ( IP .GE. 38 ) THEN
7632 DT_PHNSCH = ZERZER
7633 RETURN
7634 END IF
7635* |
7636* +-------------------------------------------------------------------*
7637* +-------------------------------------------------------------------*
7638* | If the momentum is larger than 50 GeV/c, compute the single
7639* | chain probability at 50 GeV/c and extrapolate to the present
7640* | momentum according to 1/sqrt(s)
7641* | sigma = sigma_sch (50) * sqrt (s(50)/s) + sigma_dch
7642* | P_sch (50) = sigma_sch (50) / ( sigma_dch + sigma_sch (50) )
7643* | sigma_dch / sigma_sch (50) = 1 / P_sch (50) - 1
7644* | sigma_dch / sigma_sch = 1 / P_sch - 1 = ( 1 / P_sch (50) - 1 )
7645* | x sqrt(s/s(50))
7646* | P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
7647 IF ( PLAB .GT. 50.D+00 ) THEN
7648 PLA = 50.D+00
7649 AMPSQ = AM (IP)**2
7650 AMTSQ = AM (KTARG)**2
7651 EPROJ = SQRT ( PLAB**2 + AMPSQ )
7652 UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7653 EPROJ = SQRT ( PLA**2 + AMPSQ )
7654 UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7655 UMORAT = SQRT ( UMOSQ / UMO50 )
7656* |
7657* +-------------------------------------------------------------------*
7658* | P < 3 GeV/c
7659 ELSE IF ( PLAB .LT. 3.D+00 ) THEN
7660 PLA = 3.D+00
7661 AMPSQ = AM (IP)**2
7662 AMTSQ = AM (KTARG)**2
7663 EPROJ = SQRT ( PLAB**2 + AMPSQ )
7664 UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7665 EPROJ = SQRT ( PLA**2 + AMPSQ )
7666 UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7667 UMORAT = SQRT ( UMOSQ / UMO50 )
7668* |
7669* +-------------------------------------------------------------------*
7670* | P < 50 GeV/c
7671 ELSE
7672 PLA = PLAB
7673 UMORAT = ONEONE
7674 END IF
7675* |
7676* +-------------------------------------------------------------------*
7677 ALGPLA = LOG (PLA)
7678* +-------------------------------------------------------------------*
7679* | Pions:
7680 IF ( IHLP (IP) .EQ. 2 ) THEN
7681 ACOF = SGTCOE (1,3)
7682 BCOF = SGTCOE (2,3)
7683 ENNE = SGTCOE (3,3)
7684 CCOF = SGTCOE (4,3)
7685 DCOF = SGTCOE (5,3)
7686* | Compute the pi+ p total cross section:
7687 SPPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7688 & + DCOF * ALGPLA
7689 ACOF = SGTCOE (1,19)
7690 BCOF = SGTCOE (2,19)
7691 ENNE = SGTCOE (3,19)
7692 CCOF = SGTCOE (4,19)
7693 DCOF = SGTCOE (5,19)
7694* | Compute the pi+ p elastic cross section:
7695 SPPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7696 & + DCOF * ALGPLA
7697* | Compute the pi+ p inelastic cross section:
7698 SPPPIN = SPPPTT - SPPPEL
7699 ACOF = SGTCOE (1,4)
7700 BCOF = SGTCOE (2,4)
7701 ENNE = SGTCOE (3,4)
7702 CCOF = SGTCOE (4,4)
7703 DCOF = SGTCOE (5,4)
7704* | Compute the pi- p total cross section:
7705 SPMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7706 & + DCOF * ALGPLA
7707 ACOF = SGTCOE (1,20)
7708 BCOF = SGTCOE (2,20)
7709 ENNE = SGTCOE (3,20)
7710 CCOF = SGTCOE (4,20)
7711 DCOF = SGTCOE (5,20)
7712* | Compute the pi- p elastic cross section:
7713 SPMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7714 & + DCOF * ALGPLA
7715* | Compute the pi- p inelastic cross section:
7716 SPMPIN = SPMPTT - SPMPEL
7717 SIGDIA = SPMPIN - SPPPIN
7718* | +----------------------------------------------------------------*
7719* | | Charged pions: besides isospin consideration it is supposed
7720* | | that (pi+ n)el is almost equal to (pi- p)el
7721* | | and (pi+ p)el " " " " (pi- n)el
7722* | | and all are almost equal among each others
7723* | | (reasonable above 5 GeV/c)
7724 IF ( ICHRGE (IP) .NE. 0 ) THEN
7725 KHELP = KTARG / 8
7726 JREAC = 3 + IP - 13 + ICHRGE (IP) * KHELP
7727 ACOF = SGTCOE (1,JREAC)
7728 BCOF = SGTCOE (2,JREAC)
7729 ENNE = SGTCOE (3,JREAC)
7730 CCOF = SGTCOE (4,JREAC)
7731 DCOF = SGTCOE (5,JREAC)
7732* | | Compute the total cross section:
7733 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7734 & + DCOF * ALGPLA
7735 JREAC = 19 + IP - 13 + ICHRGE (IP) * KHELP
7736 ACOF = SGTCOE (1,JREAC)
7737 BCOF = SGTCOE (2,JREAC)
7738 ENNE = SGTCOE (3,JREAC)
7739 CCOF = SGTCOE (4,JREAC)
7740 DCOF = SGTCOE (5,JREAC)
7741* | | Compute the elastic cross section:
7742 SHNCEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7743 & + DCOF * ALGPLA
7744* | | Compute the inelastic cross section:
7745 SHNCIN = SHNCTT - SHNCEL
7746* | | Number of diagrams:
7747 NDIAGR = 1 + IP - 13 + ICHRGE (IP) * KHELP
7748* | | Now compute the chain end (anti)quark-(anti)diquark
7749 IQFSC1 = 1 + IP - 13
7750 IQFSC2 = 0
7751 IQBSC1 = 1 + KHELP
7752 IQBSC2 = 1 + IP - 13
7753* | |
7754* | +----------------------------------------------------------------*
7755* | | pi0: besides isospin consideration it is supposed that the
7756* | | elastic cross section is not very different from
7757* | | pi+ p and/or pi- p (reasonable above 5 GeV/c)
7758 ELSE
7759 KHELP = KTARG / 8
7760 K2HLP = ( KP - 23 ) / 3
7761* | | Number of diagrams:
7762* | | For u ubar (k2hlp=0):
7763* NDIAGR = 2 - KHELP
7764* | | For d dbar (k2hlp=1):
7765* NDIAGR = 2 + KHELP - K2HLP
7766 NDIAGR = 2 + KHELP * ( 2 * K2HLP - 1 ) - K2HLP
7767 SHNCIN = HLFHLF * ( SPPPIN + SPMPIN )
7768* | | Now compute the chain end (anti)quark-(anti)diquark
7769 IQFSC1 = 1 + K2HLP
7770 IQFSC2 = 0
7771 IQBSC1 = 1 + KHELP
7772 IQBSC2 = 2 - K2HLP
7773 END IF
7774* | |
7775* | +----------------------------------------------------------------*
7776* | end pi's
7777* +-------------------------------------------------------------------*
7778* | Kaons:
7779 ELSE IF ( IHLP (IP) .EQ. 3 ) THEN
7780 ACOF = SGTCOE (1,6)
7781 BCOF = SGTCOE (2,6)
7782 ENNE = SGTCOE (3,6)
7783 CCOF = SGTCOE (4,6)
7784 DCOF = SGTCOE (5,6)
7785* | Compute the K+ p total cross section:
7786 SKPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7787 & + DCOF * ALGPLA
7788 ACOF = SGTCOE (1,21)
7789 BCOF = SGTCOE (2,21)
7790 ENNE = SGTCOE (3,21)
7791 CCOF = SGTCOE (4,21)
7792 DCOF = SGTCOE (5,21)
7793* | Compute the K+ p elastic cross section:
7794 SKPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7795 & + DCOF * ALGPLA
7796* | Compute the K+ p inelastic cross section:
7797 SKPPIN = SKPPTT - SKPPEL
7798 ACOF = SGTCOE (1,9)
7799 BCOF = SGTCOE (2,9)
7800 ENNE = SGTCOE (3,9)
7801 CCOF = SGTCOE (4,9)
7802 DCOF = SGTCOE (5,9)
7803* | Compute the K- p total cross section:
7804 SKMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7805 & + DCOF * ALGPLA
7806 ACOF = SGTCOE (1,22)
7807 BCOF = SGTCOE (2,22)
7808 ENNE = SGTCOE (3,22)
7809 CCOF = SGTCOE (4,22)
7810 DCOF = SGTCOE (5,22)
7811* | Compute the K- p elastic cross section:
7812 SKMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7813 & + DCOF * ALGPLA
7814* | Compute the K- p inelastic cross section:
7815 SKMPIN = SKMPTT - SKMPEL
7816 SIGDIA = HLFHLF * ( SKMPIN - SKPPIN )
7817* | +----------------------------------------------------------------*
7818* | | Charged Kaons: actually only K-
7819 IF ( ICHRGE (IP) .NE. 0 ) THEN
7820 KHELP = KTARG / 8
7821* | | +-------------------------------------------------------------*
7822* | | | Proton target:
7823 IF ( KHELP .EQ. 0 ) THEN
7824 SHNCIN = SKMPIN
7825* | | | Number of diagrams:
7826 NDIAGR = 2
7827* | | |
7828* | | +-------------------------------------------------------------*
7829* | | | Neutron target: besides isospin consideration it is supposed
7830* | | | that (K- n)el is almost equal to (K- p)el
7831* | | | (reasonable above 5 GeV/c)
7832 ELSE
7833 ACOF = SGTCOE (1,10)
7834 BCOF = SGTCOE (2,10)
7835 ENNE = SGTCOE (3,10)
7836 CCOF = SGTCOE (4,10)
7837 DCOF = SGTCOE (5,10)
7838* | | | Compute the total cross section:
7839 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7840 & + DCOF * ALGPLA
7841* | | | Compute the elastic cross section:
7842 SHNCEL = SKMPEL
7843* | | | Compute the inelastic cross section:
7844 SHNCIN = SHNCTT - SHNCEL
7845* | | | Number of diagrams:
7846 NDIAGR = 1
7847 END IF
7848* | | |
7849* | | +-------------------------------------------------------------*
7850* | | Now compute the chain end (anti)quark-(anti)diquark
7851 IQFSC1 = 3
7852 IQFSC2 = 0
7853 IQBSC1 = 1 + KHELP
7854 IQBSC2 = 2
7855* | |
7856* | +----------------------------------------------------------------*
7857* | | K0's: (actually only K0bar)
7858 ELSE
7859 KHELP = KTARG / 8
7860* | | +-------------------------------------------------------------*
7861* | | | Proton target: (K0bar p)in supposed to be given by
7862* | | | (K- p)in - Sig_diagr
7863 IF ( KHELP .EQ. 0 ) THEN
7864 SHNCIN = SKMPIN - SIGDIA
7865* | | | Number of diagrams:
7866 NDIAGR = 1
7867* | | |
7868* | | +-------------------------------------------------------------*
7869* | | | Neutron target: (K0bar n)in supposed to be given by
7870* | | | (K- n)in + Sig_diagr
7871* | | | besides isospin consideration it is supposed
7872* | | | that (K- n)el is almost equal to (K- p)el
7873* | | | (reasonable above 5 GeV/c)
7874 ELSE
7875 ACOF = SGTCOE (1,10)
7876 BCOF = SGTCOE (2,10)
7877 ENNE = SGTCOE (3,10)
7878 CCOF = SGTCOE (4,10)
7879 DCOF = SGTCOE (5,10)
7880* | | | Compute the total cross section:
7881 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7882 & + DCOF * ALGPLA
7883* | | | Compute the elastic cross section:
7884 SHNCEL = SKMPEL
7885* | | | Compute the inelastic cross section:
7886 SHNCIN = SHNCTT - SHNCEL + SIGDIA
7887* | | | Number of diagrams:
7888 NDIAGR = 2
7889 END IF
7890* | | |
7891* | | +-------------------------------------------------------------*
7892* | | Now compute the chain end (anti)quark-(anti)diquark
7893 IQFSC1 = 3
7894 IQFSC2 = 0
7895 IQBSC1 = 1
7896 IQBSC2 = 1 + KHELP
7897 END IF
7898* | |
7899* | +----------------------------------------------------------------*
7900* | end Kaon's
7901* +-------------------------------------------------------------------*
7902* | Antinucleons:
7903 ELSE IF ( IHLP (IP) .EQ. 4 .AND. IP .LE. 9 ) THEN
7904* | For momenta between 3 and 5 GeV/c the use of tabulated data
7905* | should be implemented!
7906 ACOF = SGTCOE (1,15)
7907 BCOF = SGTCOE (2,15)
7908 ENNE = SGTCOE (3,15)
7909 CCOF = SGTCOE (4,15)
7910 DCOF = SGTCOE (5,15)
7911* | Compute the pbar p total cross section:
7912 SAPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7913 & + DCOF * ALGPLA
7914 IF ( PLA .LT. FIVFIV ) THEN
7915 JREAC = 26
7916 ELSE
7917 JREAC = 25
7918 END IF
7919 ACOF = SGTCOE (1,JREAC)
7920 BCOF = SGTCOE (2,JREAC)
7921 ENNE = SGTCOE (3,JREAC)
7922 CCOF = SGTCOE (4,JREAC)
7923 DCOF = SGTCOE (5,JREAC)
7924* | Compute the pbar p elastic cross section:
7925 SAPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7926 & + DCOF * ALGPLA
7927* | Compute the pbar p inelastic cross section:
7928 SAPPIN = SAPPTT - SAPPEL
7929 ACOF = SGTCOE (1,12)
7930 BCOF = SGTCOE (2,12)
7931 ENNE = SGTCOE (3,12)
7932 CCOF = SGTCOE (4,12)
7933 DCOF = SGTCOE (5,12)
7934* | Compute the p p total cross section:
7935 SPPTOT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7936 & + DCOF * ALGPLA
7937 ACOF = SGTCOE (1,23)
7938 BCOF = SGTCOE (2,23)
7939 ENNE = SGTCOE (3,23)
7940 CCOF = SGTCOE (4,23)
7941 DCOF = SGTCOE (5,23)
7942* | Compute the p p elastic cross section:
7943 SPPELA = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7944 & + DCOF * ALGPLA
7945* | Compute the K- p inelastic cross section:
7946 SPPINE = SPPTOT - SPPELA
7947 SIGDIA = ( SAPPIN - SPPINE ) / FIVFIV
7948 KHELP = KTARG / 8
7949* | +----------------------------------------------------------------*
7950* | | Pbar:
7951 IF ( ICHRGE (IP) .NE. 0 ) THEN
7952 NDIAGR = 5 - KHELP
7953* | | +-------------------------------------------------------------*
7954* | | | Proton target:
7955 IF ( KHELP .EQ. 0 ) THEN
7956* | | | Number of diagrams:
7957 SHNCIN = SAPPIN
7958 PUUBAR = 0.8D+00
7959* | | |
7960* | | +-------------------------------------------------------------*
7961* | | | Neutron target: it is supposed that (ap n)el is almost equal
7962* | | | to (ap p)el (reasonable above 5 GeV/c)
7963 ELSE
7964 ACOF = SGTCOE (1,16)
7965 BCOF = SGTCOE (2,16)
7966 ENNE = SGTCOE (3,16)
7967 CCOF = SGTCOE (4,16)
7968 DCOF = SGTCOE (5,16)
7969* | | | Compute the total cross section:
7970 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7971 & + DCOF * ALGPLA
7972* | | | Compute the elastic cross section:
7973 SHNCEL = SAPPEL
7974* | | | Compute the inelastic cross section:
7975 SHNCIN = SHNCTT - SHNCEL
7976 PUUBAR = HLFHLF
7977 END IF
7978* | | |
7979* | | +-------------------------------------------------------------*
7980* | | Now compute the chain end (anti)quark-(anti)diquark
7981* | | there are different possibilities, make a random choiche:
7982 IQFSC1 = -1
7983 RNCHEN = DT_RNDM(PUUBAR)
7984 IF ( RNCHEN .LT. PUUBAR ) THEN
7985 IQFSC2 = -2
7986 ELSE
7987 IQFSC2 = -1
7988 END IF
7989 IQBSC1 = -IQFSC1 + KHELP
7990 IQBSC2 = -IQFSC2
7991* | |
7992* | +----------------------------------------------------------------*
7993* | | nbar:
7994 ELSE
7995 NDIAGR = 4 + KHELP
7996* | | +-------------------------------------------------------------*
7997* | | | Proton target: (nbar p)in supposed to be given by
7998* | | | (pbar p)in - Sig_diagr
7999 IF ( KHELP .EQ. 0 ) THEN
8000 SHNCIN = SAPPIN - SIGDIA
8001 PDDBAR = HLFHLF
8002* | | |
8003* | | +-------------------------------------------------------------*
8004* | | | Neutron target: (nbar n)el is supposed to be equal to
8005* | | | (pbar p)el (reasonable above 5 GeV/c)
8006 ELSE
8007* | | | Compute the total cross section:
8008 SHNCTT = SAPPTT
8009* | | | Compute the elastic cross section:
8010 SHNCEL = SAPPEL
8011* | | | Compute the inelastic cross section:
8012 SHNCIN = SHNCTT - SHNCEL
8013 PDDBAR = 0.8D+00
8014 END IF
8015* | | |
8016* | | +-------------------------------------------------------------*
8017* | | Now compute the chain end (anti)quark-(anti)diquark
8018* | | there are different possibilities, make a random choiche:
8019 IQFSC1 = -2
8020 RNCHEN = DT_RNDM(RNCHEN)
8021 IF ( RNCHEN .LT. PDDBAR ) THEN
8022 IQFSC2 = -1
8023 ELSE
8024 IQFSC2 = -2
8025 END IF
8026 IQBSC1 = -IQFSC1 + KHELP - 1
8027 IQBSC2 = -IQFSC2
8028 END IF
8029* | |
8030* | +----------------------------------------------------------------*
8031* |
8032* +-------------------------------------------------------------------*
8033* | Others: not yet implemented
8034 ELSE
8035 SIGDIA = ZERZER
8036 SHNCIN = ONEONE
8037 NDIAGR = 0
8038 DT_PHNSCH = ZERZER
8039 RETURN
8040 END IF
8041* | end others
8042* +-------------------------------------------------------------------*
8043 DT_PHNSCH = NDIAGR * SIGDIA / SHNCIN
8044 IQECHC = IQECHR (IQFSC1) + IQECHR (IQFSC2) + IQECHR (IQBSC1)
8045 & + IQECHR (IQBSC2)
8046 IQBCHC = IQBCHR (IQFSC1) + IQBCHR (IQFSC2) + IQBCHR (IQBSC1)
8047 & + IQBCHR (IQBSC2)
8048 IQECHC = IQECHC / 3
8049 IQBCHC = IQBCHC / 3
8050 IQSCHC = IQSCHR (IQFSC1) + IQSCHR (IQFSC2) + IQSCHR (IQBSC1)
8051 & + IQSCHR (IQBSC2)
8052 IQSPRO = IQSCHR (MQUARK(1,IP)) + IQSCHR (MQUARK(2,IP))
8053 & + IQSCHR (MQUARK(3,IP))
8054* +-------------------------------------------------------------------*
8055* | Consistency check:
8056 IF ( DT_PHNSCH .LE. ZERZER .OR. DT_PHNSCH .GT. ONEONE ) THEN
8057 WRITE (LUNOUT,*)' *** Phnsch,kp,ktarg,pla',
8058 & DT_PHNSCH,KP,KTARG,PLA,' ****'
8059 WRITE (LUNERR,*)' *** Phnsch,kp,ktarg,pla',
8060 & DT_PHNSCH,KP,KTARG,PLA,' ****'
8061 DT_PHNSCH = MAX ( DT_PHNSCH, ZERZER )
8062 DT_PHNSCH = MIN ( DT_PHNSCH, ONEONE )
8063 END IF
8064* |
8065* +-------------------------------------------------------------------*
8066* +-------------------------------------------------------------------*
8067* | Consistency check:
8068 IF ( IQSPRO .NE. IQSCHC .OR. ICHRGE (IP) + ICHRGE (KTARG)
8069 & .NE. IQECHC .OR. IIBAR (KP) + IIBAR (KTARG) .NE. IQBCHC) THEN
8070 WRITE (LUNOUT,*)
8071 &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8072 & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8073 WRITE (LUNERR,*)
8074 &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8075 & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8076 END IF
8077* |
8078* +-------------------------------------------------------------------*
8079* P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
8080 IF ( UMORAT .GT. ONEPLS )
8081 & DT_PHNSCH = ONEONE / ( ( ONEONE / DT_PHNSCH
8082 & - ONEONE ) * UMORAT + ONEONE )
8083 RETURN
8084*
8085 ENTRY DT_SCHQUA ( JQFSC1, JQFSC2, JQBSC1, JQBSC2 )
8086 DT_SCHQUA = ONEONE
8087 JQFSC1 = IQFSC1
8088 JQFSC2 = IQFSC2
8089 JQBSC1 = IQBSC1
8090 JQBSC2 = IQBSC2
8091*=== End of function Phnsch ===========================================*
8092 RETURN
8093 END
8094
8095*$ CREATE DT_RESPT.FOR
8096*COPY DT_RESPT
8097*
8098*===respt==============================================================*
8099*
8100 SUBROUTINE DT_RESPT
8101
8102************************************************************************
8103* Check DTEVT1 for two-resonance systems and sample intrinsic p_t. *
8104* This version dated 18.01.95 is written by S. Roesler *
8105************************************************************************
8106
8107 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8108 SAVE
8109 PARAMETER ( LINP = 10 ,
8110 & LOUT = 6 ,
8111 & LDAT = 9 )
8112 PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8113
8114* event history
8115 PARAMETER (NMXHKK=200000)
8116 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8117 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8118 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8119* extended event history
8120 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8121 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8122 & IHIST(2,NMXHKK)
8123
8124* get index of first chain
8125 DO 1 I=NPOINT(3),NHKK
8126 IF (IDHKK(I).EQ.88888) THEN
8127 NC = I
8128 GOTO 2
8129 ENDIF
8130 1 CONTINUE
8131
8132 2 CONTINUE
8133 IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)) THEN
8134C WRITE(LOUT,*)NC,NC+3,IDRES(NC),IDRES(NC+3)
8135* skip VV-,SS- systems
8136 IF ((IDCH(NC ).NE.1).AND.(IDCH(NC ).NE.8).AND.
8137 & (IDCH(NC+3).NE.1).AND.(IDCH(NC+3).NE.8)) THEN
8138* check if both "chains" are resonances
8139 IF ((IDRES(NC).NE.0).AND.(IDRES(NC+3).NE.0)) THEN
8140 CALL DT_SAPTRE(NC,NC+3)
8141 ENDIF
8142 ENDIF
8143 ELSE
8144 GOTO 3
8145 ENDIF
8146 NC = NC+6
8147 GOTO 2
8148
8149 3 CONTINUE
8150
8151 RETURN
8152 END
8153
8154*$ CREATE DT_EVTRES.FOR
8155*COPY DT_EVTRES
8156*
8157*===evtres=============================================================*
8158*
8159 SUBROUTINE DT_EVTRES(IREJ)
8160
8161************************************************************************
8162* This version dated 14.12.94 is written by S. Roesler *
8163************************************************************************
8164
8165 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8166 SAVE
8167 PARAMETER ( LINP = 10 ,
8168 & LOUT = 6 ,
8169 & LDAT = 9 )
8170 PARAMETER (TINY5=1.0D-5,TINY10=1.0D-10)
8171
8172* event history
8173 PARAMETER (NMXHKK=200000)
8174 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8175 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8176 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8177* extended event history
8178 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8179 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8180 & IHIST(2,NMXHKK)
8181* flags for input different options
8182 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8183 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8184 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8185* particle properties (BAMJET index convention)
8186 CHARACTER*8 ANAME
8187 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
8188 & IICH(210),IIBAR(210),K1(210),K2(210)
8189
8190 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),IFP(2),IFT(2)
8191
8192 IREJ = 0
8193
8194 DO 1 I=NPOINT(3),NHKK
8195 IF (ABS(IDRES(I)).GE.100) THEN
8196 AMMX = 0.0D0
8197 DO 2 J=NPOINT(3),NHKK
8198 IF (IDHKK(J).EQ.88888) THEN
8199 IF (PHKK(5,J).GT.AMMX) THEN
8200 AMMX = PHKK(5,J)
8201 IMMX = J
8202 ENDIF
8203 ENDIF
8204 2 CONTINUE
8205 IF (IDRES(IMMX).NE.0) THEN
8206 IF (IOULEV(3).GT.0) THEN
8207 WRITE(LOUT,'(1X,A)')
8208 & 'EVTRES: no chain for correc. found'
8209C GOTO 6
8210 GOTO 9999
8211 ELSE
8212 GOTO 9999
8213 ENDIF
8214 ENDIF
8215 IMO11 = JMOHKK(1,I)
8216 IMO12 = JMOHKK(2,I)
8217 IF (PHKK(3,IMO11).LT.0.0D0) THEN
8218 IMO11 = JMOHKK(2,I)
8219 IMO12 = JMOHKK(1,I)
8220 ENDIF
8221 IMO21 = JMOHKK(1,IMMX)
8222 IMO22 = JMOHKK(2,IMMX)
8223 IF (PHKK(3,IMO21).LT.0.0D0) THEN
8224 IMO21 = JMOHKK(2,IMMX)
8225 IMO22 = JMOHKK(1,IMMX)
8226 ENDIF
8227 AMCH1 = PHKK(5,I)
8228 AMCH1N = AAM(IDXRES(I))
8229
8230 IFPR1 = IDHKK(IMO11)
8231 IFPR2 = IDHKK(IMO21)
8232 IFTA1 = IDHKK(IMO12)
8233 IFTA2 = IDHKK(IMO22)
8234 DO 4 J=1,4
8235 PP1(J) = PHKK(J,IMO11)
8236 PP2(J) = PHKK(J,IMO21)
8237 PT1(J) = PHKK(J,IMO12)
8238 PT2(J) = PHKK(J,IMO22)
8239 4 CONTINUE
8240* store initial configuration for energy-momentum cons. check
8241 IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IREJ1)
8242* correct kinematics of second chain
8243 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
8244 & AMCH1,AMCH1N,AMCH2,IREJ1)
8245 IF (IREJ1.NE.0) GOTO 9999
8246* check now this chain for resonance mass
8247 IFP(1) = IDT_IPDG2B(IFPR2,1,2)
8248 IFP(2) = 0
8249 IF (ABS(IFPR2).GE.1000) IFP(2) = IDT_IPDG2B(IFPR2,2,2)
8250 IFT(1) = IDT_IPDG2B(IFTA2,1,2)
8251 IFT(2) = 0
8252 IF (ABS(IFTA2).GE.1000) IFT(2) = IDT_IPDG2B(IFTA2,2,2)
8253 IDCH2 = 2
8254 IF ((IFP(2).EQ.0).AND.(IFT(2).EQ.0)) IDCH2 = 1
8255 IF ((IFP(2).NE.0).AND.(IFT(2).NE.0)) IDCH2 = 3
8256 CALL DT_CH2RES(IFP(1),IFP(2),IFT(1),IFT(2),IDR2,IDXR2,
8257 & AMCH2,AMCH2N,IDCH2,IREJ1)
8258 IF ((IREJ1.NE.0).OR.(IDR2.NE.0)) THEN
8259 IF (IOULEV(1).GT.0)
8260 & WRITE(LOUT,*) ' correction for resonance not poss.'
8261**sr test
8262C GOTO 1
8263C GOTO 9999
8264**
8265 ENDIF
8266* store final configuration for energy-momentum cons. check
8267 IF (LEMCCK) THEN
8268 CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IREJ1)
8269 CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
8270 IF (IREJ1.NE.0) GOTO 9999
8271 ENDIF
8272 DO 5 J=1,4
8273 PHKK(J,IMO11) = PP1(J)
8274 PHKK(J,IMO21) = PP2(J)
8275 PHKK(J,IMO12) = PT1(J)
8276 PHKK(J,IMO22) = PT2(J)
8277 5 CONTINUE
8278* correct entries of chains
8279 DO 3 K=1,4
8280 PHKK(K,I) = PHKK(K,IMO11)+PHKK(K,IMO12)
8281 PHKK(K,IMMX) = PHKK(K,IMO21)+PHKK(K,IMO22)
8282 3 CONTINUE
8283 AM1 = PHKK(4,I)**2-PHKK(1,I)**2-PHKK(2,I)**2-PHKK(3,I)**2
8284 AM2 = PHKK(4,IMMX)**2-PHKK(1,IMMX)**2-PHKK(2,IMMX)**2-
8285 & PHKK(3,IMMX)**2
8286* ?? the following should now be obsolete
8287**sr test
8288C IF ((AM1.LT.0.0D0).OR.(AM2.LT.1.0D0)) THEN
8289 IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8290**
8291 WRITE(LOUT,'(1X,A,4G10.3)')
8292 & 'EVTRES: inonsistent mass-corr.',AM1,AM2
8293C GOTO 9999
8294 GOTO 1
8295 ENDIF
8296 PHKK(5,I) = SQRT(AM1)
8297 PHKK(5,IMMX) = SQRT(AM2)
8298 IDRES(I) = IDRES(I)/100
8299 IF ((ABS(PHKK(5,I)-AMCH1N).GT.TINY5).OR.
8300 & (ABS(PHKK(5,IMMX)-AMCH2).GT.TINY5)) THEN
8301 WRITE(LOUT,'(1X,A,4G10.3)')
8302 & 'EVTRES: inconsistent chain-masses',
8303 & PHKK(5,I),AMCH1N,PHKK(5,IMMX),AMCH2
8304 GOTO 9999
8305 ENDIF
8306 ENDIF
8307 1 CONTINUE
8308 6 CONTINUE
8309 RETURN
8310
8311 9999 CONTINUE
8312 IREJ = 1
8313 RETURN
8314 END
8315
8316*$ CREATE DT_GETSPT.FOR
8317*COPY DT_GETSPT
8318*
8319*===getspt=============================================================*
8320*
8321 SUBROUTINE DT_GETSPT(PP1I,IFPR1,IFP1,PP2I,IFPR2,IFP2,
8322 & PT1I,IFTA1,IFT1,PT2I,IFTA2,IFT2,
8323 & AM1,IDCH1,AM2,IDCH2,IDCHAI,IREJ)
8324
8325************************************************************************
8326* This version dated 12.12.94 is written by S. Roesler *
8327************************************************************************
8328
8329 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8330 SAVE
8331 PARAMETER ( LINP = 10 ,
8332 & LOUT = 6 ,
8333 & LDAT = 9 )
8334 PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,ZERO=0.0D0)
8335
8336* various options for treatment of partons (DTUNUC 1.x)
8337* (chain recombination, Cronin,..)
8338 LOGICAL LCO2CR,LINTPT
8339 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8340 & LCO2CR,LINTPT
8341* flags for input different options
8342 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8343 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8344 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8345* flags for diffractive interactions (DTUNUC 1.x)
8346 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
8347
8348 DIMENSION PP1(4),PP1I(4),PP2(4),PP2I(4),PT1(4),PT1I(4),
8349 & PT2(4),PT2I(4),P1(4),P2(4),
8350 & IFP1(2),IFP2(2),IFT1(2),IFT2(2),
8351 & PTOTI(4),PTOTF(4),DIFF(4)
8352
8353 IC = 0
8354 IREJ = 0
8355C B33P = 4.0D0
8356C B33T = 4.0D0
8357C IF ((IDCHAI.EQ.6).OR.(IDCHAI.EQ.7).OR.(IDCHAI.EQ.8)) B33P = 2.0D0
8358C IF ((IDCHAI.EQ.4).OR.(IDCHAI.EQ.5).OR.(IDCHAI.EQ.8)) B33T = 2.0D0
8359 REDU = 1.0D0
8360C B33P = 3.5D0
8361C B33T = 3.5D0
8362 B33P = 4.0D0
8363 B33T = 4.0D0
8364 IF (IDIFF.NE.0) THEN
8365 B33P = 16.0D0
8366 B33T = 16.0D0
8367 ENDIF
8368
8369 DO 1 I=1,4
8370 PTOTI(I) = PP1I(I)+PP2I(I)+PT1I(I)+PT2I(I)
8371 PP1(I) = PP1I(I)
8372 PP2(I) = PP2I(I)
8373 PT1(I) = PT1I(I)
8374 PT2(I) = PT2I(I)
8375 1 CONTINUE
8376* get initial chain masses
8377 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8378 & +(PP1(3)+PT1(3))**2)
8379 ECH = PP1(4)+PT1(4)
8380 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
8381 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8382 & +(PP2(3)+PT2(3))**2)
8383 ECH = PP2(4)+PT2(4)
8384 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
8385 IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8386 IF (IOULEV(1).GT.0)
8387 & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 1',
8388 & AM1,AM2
8389 GOTO 9999
8390 ENDIF
8391 AM1 = SQRT(AM1)
8392 AM2 = SQRT(AM2)
8393 AM1N = ZERO
8394 AM2N = ZERO
8395
8396 MODE = 0
8397C IF ((AM1.GE.3.0D0).AND.(AM2.GE.3.0D0)) THEN
8398C MODE = 0
8399C ELSE
8400C MODE = 1
8401C IF (AM1.LT.0.6) THEN
8402C B33P = 10.0D0
8403C ELSEIF ((AM1.GE.1.2).AND.(AM1.LT.3.0D0)) THEN
8404CC B33P = 4.0D0
8405C ENDIF
8406C IF (AM2.LT.0.6) THEN
8407C B33T = 10.0D0
8408C ELSEIF ((AM2.GE.1.2).AND.(AM2.LT.3.0D0)) THEN
8409CC B33T = 4.0D0
8410C ENDIF
8411C ENDIF
8412
8413* check chain masses for very low mass chains
8414C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8415C & AM1,DUM,-IDCH1,IREJ1)
8416C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8417C & AM2,DUM,-IDCH2,IREJ2)
8418C IF ((IREJ1.NE.0).OR.(IREJ2.NE.0)) THEN
8419C B33P = 20.0D0
8420C B33T = 20.0D0
8421C ENDIF
8422
8423 JMSHL = IMSHL
8424
8425 2 CONTINUE
8426 IC = IC+1
8427 IF (MOD(IC,15).EQ.0) B33P = 2.0D0*B33P
8428 IF (MOD(IC,15).EQ.0) B33T = 2.0D0*B33T
8429 IF (MOD(IC,18).EQ.0) REDU = 0.0D0
8430C IF (MOD(IC,19).EQ.0) JMSHL = 0
8431 IF (MOD(IC,20).EQ.0) GOTO 7
8432C WRITE(LOUT,'(1X,A)') 'GETSPT: rejection '
8433C RETURN
8434C GOTO 9999
8435C ENDIF
8436
8437* get transverse momentum
8438 IF (LINTPT) THEN
8439 ES = -2.0D0/(B33P**2)
8440 & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8441 HPSP = SQRT(ES*ES+2.0D0*ES*0.94D0)
8442 HPSP = HPSP*REDU
8443 ES = -2.0D0/(B33T**2)
8444 & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8445 HPST = SQRT(ES*ES+2.0D0*ES*0.94D0)
8446 HPST = HPST*REDU
8447 ELSE
8448 HPSP = ZERO
8449 HPST = ZERO
8450 ENDIF
8451 CALL DT_DSFECF(SFE1,CFE1)
8452 CALL DT_DSFECF(SFE2,CFE2)
8453 IF (MODE.EQ.0) THEN
8454 PP1(1) = PP1I(1)+HPSP*CFE1
8455 PP1(2) = PP1I(2)+HPSP*SFE1
8456 PP2(1) = PP2I(1)-HPSP*CFE1
8457 PP2(2) = PP2I(2)-HPSP*SFE1
8458 PT1(1) = PT1I(1)+HPST*CFE2
8459 PT1(2) = PT1I(2)+HPST*SFE2
8460 PT2(1) = PT2I(1)-HPST*CFE2
8461 PT2(2) = PT2I(2)-HPST*SFE2
8462 ELSE
8463 PP1(1) = PP1I(1)+HPSP*CFE1
8464 PP1(2) = PP1I(2)+HPSP*SFE1
8465 PT1(1) = PT1I(1)-HPSP*CFE1
8466 PT1(2) = PT1I(2)-HPSP*SFE1
8467 PP2(1) = PP2I(1)+HPST*CFE2
8468 PP2(2) = PP2I(2)+HPST*SFE2
8469 PT2(1) = PT2I(1)-HPST*CFE2
8470 PT2(2) = PT2I(2)-HPST*SFE2
8471 ENDIF
8472
8473* put partons on mass shell
8474 XMP1 = 0.0D0
8475 XMT1 = 0.0D0
8476 IF (JMSHL.EQ.1) THEN
8477 XMP1 = PYMASS(IFPR1)
8478 XMT1 = PYMASS(IFTA1)
8479 ENDIF
8480 CALL DT_MASHEL(PP1,PT1,XMP1,XMT1,P1,P2,IREJ1)
8481 IF (IREJ1.NE.0) GOTO 2
8482 DO 3 I=1,4
8483 PTOTF(I) = P1(I)+P2(I)
8484 PP1(I) = P1(I)
8485 PT1(I) = P2(I)
8486 3 CONTINUE
8487 XMP2 = 0.0D0
8488 XMT2 = 0.0D0
8489 IF (JMSHL.EQ.1) THEN
8490 XMP2 = PYMASS(IFPR2)
8491 XMT2 = PYMASS(IFTA2)
8492 ENDIF
8493 CALL DT_MASHEL(PP2,PT2,XMP2,XMT2,P1,P2,IREJ1)
8494 IF (IREJ1.NE.0) GOTO 2
8495 DO 4 I=1,4
8496 PTOTF(I) = PTOTF(I)+P1(I)+P2(I)
8497 PP2(I) = P1(I)
8498 PT2(I) = P2(I)
8499 4 CONTINUE
8500
8501* check consistency
8502 DO 5 I=1,4
8503 DIFF(I) = PTOTI(I)-PTOTF(I)
8504 5 CONTINUE
8505 IF ((ABS(DIFF(1)).GT.TINY5).OR.(ABS(DIFF(2)).GT.TINY5).OR.
8506 & (ABS(DIFF(3)).GT.TINY5).OR.(ABS(DIFF(4)).GT.TINY5)) THEN
8507 WRITE(LOUT,'(1X,A,4G10.3)') 'GETSPT: inconsistencies ',DIFF
8508 GOTO 9999
8509 ENDIF
8510 PTOTP1 = SQRT(PP1(1)**2+PP1(2)**2+PP1(3)**2)
8511 AMP1 = SQRT(ABS( (PP1(4)-PTOTP1)*(PP1(4)+PTOTP1) ))
8512 PTOTP2 = SQRT(PP2(1)**2+PP2(2)**2+PP2(3)**2)
8513 AMP2 = SQRT(ABS( (PP2(4)-PTOTP2)*(PP2(4)+PTOTP2) ))
8514 PTOTT1 = SQRT(PT1(1)**2+PT1(2)**2+PT1(3)**2)
8515 AMT1 = SQRT(ABS( (PT1(4)-PTOTT1)*(PT1(4)+PTOTT1) ))
8516 PTOTT2 = SQRT(PT2(1)**2+PT2(2)**2+PT2(3)**2)
8517 AMT2 = SQRT(ABS( (PT2(4)-PTOTT2)*(PT2(4)+PTOTT2) ))
8518 IF ((ABS(AMP1-XMP1).GT.TINY3).OR.(ABS(AMP2-XMP2).GT.TINY3).OR.
8519 & (ABS(AMT1-XMT1).GT.TINY3).OR.(ABS(AMT2-XMT2).GT.TINY3))
8520 & THEN
8521 WRITE(LOUT,'(1X,A,2(4G10.3,/))')
8522 & 'GETSPT: inconsistent masses',
8523 & AMP1,XMP1,AMP2,XMP2,AMT1,XMT1,AMT2,XMT2
8524* sr 22.11.00: commented. It should only have inconsistent masses for
8525* ultrahigh energies due to rounding problems
8526C GOTO 9999
8527 ENDIF
8528
8529* get chain masses
8530 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8531 & +(PP1(3)+PT1(3))**2)
8532 ECH = PP1(4)+PT1(4)
8533 AM1N = (ECH+PTOCH)*(ECH-PTOCH)
8534 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8535 & +(PP2(3)+PT2(3))**2)
8536 ECH = PP2(4)+PT2(4)
8537 AM2N = (ECH+PTOCH)*(ECH-PTOCH)
8538 IF ((AM1N.LT.0.0D0).OR.(AM2N.LT.0.0D0)) THEN
8539 IF (IOULEV(1).GT.0)
8540 & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 2',
8541 & AM1N,AM2N
8542 GOTO 2
8543 ENDIF
8544 AM1N = SQRT(AM1N)
8545 AM2N = SQRT(AM2N)
8546
8547* check chain masses for very low mass chains
8548 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8549 & AM1N,DUM,-IDCH1,IREJ1)
8550 IF (IREJ1.NE.0) GOTO 2
8551 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8552 & AM2N,DUM,-IDCH2,IREJ2)
8553 IF (IREJ2.NE.0) GOTO 2
8554
8555 7 CONTINUE
8556 IF (AM1N.GT.ZERO) THEN
8557 AM1 = AM1N
8558 AM2 = AM2N
8559 ENDIF
8560 DO 6 I=1,4
8561 PP1I(I) = PP1(I)
8562 PP2I(I) = PP2(I)
8563 PT1I(I) = PT1(I)
8564 PT2I(I) = PT2(I)
8565 6 CONTINUE
8566
8567 RETURN
8568
8569 9999 CONTINUE
8570 IREJ = 1
8571 RETURN
8572 END
8573
8574*$ CREATE DT_SAPTRE.FOR
8575*COPY DT_SAPTRE
8576*
8577*===saptre=============================================================*
8578*
8579 SUBROUTINE DT_SAPTRE(IDX1,IDX2)
8580
8581************************************************************************
8582* p-t sampling for two-resonance systems. ("BAMJET-like" method) *
8583* IDX1,IDX2 indices of resonances ("chains") in DTEVT1 *
8584* Adopted from the original SAPTRE written by J. Ranft. *
8585* This version dated 18.01.95 is written by S. Roesler *
8586************************************************************************
8587
8588 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8589 SAVE
8590 PARAMETER ( LINP = 10 ,
8591 & LOUT = 6 ,
8592 & LDAT = 9 )
8593 PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8594
8595* event history
8596 PARAMETER (NMXHKK=200000)
8597 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8598 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8599 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8600* extended event history
8601 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8602 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8603 & IHIST(2,NMXHKK)
8604* flags for input different options
8605 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8606 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8607 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8608
8609 DIMENSION PA1(4),PA2(4),P1(4),P2(4)
8610
8611 DATA B3 /4.0D0/
8612
8613 ESMAX1 = PHKK(4,IDX1)-PHKK(5,IDX1)
8614 ESMAX2 = PHKK(4,IDX2)-PHKK(5,IDX2)
8615 ESMAX = MIN(ESMAX1,ESMAX2)
8616 IF (ESMAX.LE.0.05D0) RETURN
8617
8618 HMA = PHKK(5,IDX1)
8619 DO 1 K=1,4
8620 PA1(K) = PHKK(K,IDX1)
8621 PA2(K) = PHKK(K,IDX2)
8622 1 CONTINUE
8623
8624 IF (LEMCCK) THEN
8625 CALL DT_EVTEMC(PA1(1),PA1(2),PA1(3),PA1(4),1,IDUM,IDUM)
8626 CALL DT_EVTEMC(PA2(1),PA2(2),PA2(3),PA2(4),2,IDUM,IDUM)
8627 ENDIF
8628
8629 EXEB = 0.0D0
8630 IF (B3*ESMAX.LE.60.0D0) EXEB = EXP(-B3*ESMAX)
8631 BEXP = HMA*(1.0D0-EXEB)/B3
8632 AXEXP = (1.0D0-(B3*ESMAX-1.0D0)*EXEB)/B3**2
8633 WA = AXEXP/(BEXP+AXEXP)
8634 XAB = DT_RNDM(WA)
8635 10 CONTINUE
8636* ES is the transverse kinetic energy
8637 IF (XAB.LT.WA)THEN
8638 X = DT_RNDM(WA)
8639 Y = DT_RNDM(WA)
8640 ES = -2.0D0/(B3**2)*LOG(X*Y+TINY7)
8641 ELSE
8642 X = DT_RNDM(Y)
8643 ES = ABS(-LOG(X+TINY7)/B3)
8644 ENDIF
8645 IF (ES.GT.ESMAX) GOTO 10
8646 ES = ES+HMA
8647* transverse momentum
8648 HPS = SQRT((ES-HMA)*(ES+HMA))
8649
8650 CALL DT_DSFECF(SFE,CFE)
8651 HPX = HPS*CFE
8652 HPY = HPS*SFE
8653 PZ1NSQ = PA1(3)**2-HPS**2-2.0D0*PA1(1)*HPX-2.0D0*PA1(2)*HPY
8654 PZ2NSQ = PA2(3)**2-HPS**2+2.0D0*PA2(1)*HPX+2.0D0*PA2(2)*HPY
8655 IF ((PZ1NSQ.LT.TINY3).OR.(PZ2NSQ.LT.TINY3)) RETURN
8656
8657C PA1(3) = SIGN(SQRT(PZ1NSQ),PA1(3))
8658C PA2(3) = SIGN(SQRT(PZ2NSQ),PA2(3))
8659 PA1(1) = PA1(1)+HPX
8660 PA1(2) = PA1(2)+HPY
8661 PA2(1) = PA2(1)-HPX
8662 PA2(2) = PA2(2)-HPY
8663
8664* put resonances on mass-shell again
8665 XM1 = PHKK(5,IDX1)
8666 XM2 = PHKK(5,IDX2)
8667 CALL DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ1)
8668 IF (IREJ1.NE.0) RETURN
8669
8670 IF (LEMCCK) THEN
8671 CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,IDUM,IDUM)
8672 CALL DT_EVTEMC(-P2(1),-P2(2),-P2(3),-P2(4),2,IDUM,IDUM)
8673 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,12,IREJ1)
8674 IF (IREJ1.NE.0) RETURN
8675 ENDIF
8676
8677 DO 2 K=1,4
8678 PHKK(K,IDX1) = P1(K)
8679 PHKK(K,IDX2) = P2(K)
8680 2 CONTINUE
8681
8682 RETURN
8683 END
8684
8685*$ CREATE DT_CRONIN.FOR
8686*COPY DT_CRONIN
8687*
8688*===cronin=============================================================*
8689*
8690 SUBROUTINE DT_CRONIN(INCL)
8691
8692************************************************************************
8693* Cronin-Effect. Multiple scattering of partons at chain ends. *
8694* INCL = 1 multiple sc. in projectile *
8695* = 2 multiple sc. in target *
8696* This version dated 05.01.96 is written by S. Roesler. *
8697************************************************************************
8698
8699 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8700 SAVE
8701 PARAMETER ( LINP = 10 ,
8702 & LOUT = 6 ,
8703 & LDAT = 9 )
8704 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
8705
8706* event history
8707 PARAMETER (NMXHKK=200000)
8708 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8709 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8710 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8711* extended event history
8712 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8713 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8714 & IHIST(2,NMXHKK)
8715* rejection counter
8716 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
8717 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
8718 & IREXCI(3),IRDIFF(2),IRINC
8719* Glauber formalism: collision properties
8720 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
8721 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
8722
8723 DIMENSION R(3),PIN(4),POUT(4),DEV(4)
8724
8725 DO 1 K=1,4
8726 DEV(K) = ZERO
8727 1 CONTINUE
8728
8729 DO 2 I=NPOINT(2),NHKK
8730 IF (ISTHKK(I).LT.0) THEN
8731* get z-position of the chain
8732 R(1) = VHKK(1,I)*1.0D12
8733 IF (INCL.EQ.2) R(1) = VHKK(1,I)*1.0D12-BIMPAC
8734 R(2) = VHKK(2,I)*1.0D12
8735 IDXNU = JMOHKK(1,I)
8736 IF ( (INCL.EQ.1).AND.(ISTHKK(IDXNU).EQ.10) )
8737 & IDXNU = JMOHKK(1,I-1)
8738 IF ( (INCL.EQ.2).AND.(ISTHKK(IDXNU).EQ. 9) )
8739 & IDXNU = JMOHKK(1,I+1)
8740 R(3) = VHKK(3,IDXNU)*1.0D12
8741* position of target parton the chain is connected to
8742 DO 3 K=1,4
8743 PIN(K) = PHKK(K,I)
8744 3 CONTINUE
8745* multiple scattering of parton with DTEVT1-index I
8746 CALL DT_CROMSC(PIN,R,POUT,INCL)
8747**testprint
8748C IF (NEVHKK.EQ.5) THEN
8749C AMIN = PIN(4)**2-PIN(1)**2-PIN(2)**2-PIN(3)**2
8750C AMOU = POUT(4)**2-POUT(1)**2-POUT(2)**2-POUT(3)**2
8751C AMIN = SIGN(SQRT(ABS(AMIN)),AMIN)
8752C AMOU = SIGN(SQRT(ABS(AMOU)),AMOU)
8753C WRITE(6,'(A,I4,2E15.5)')'I,AMIN,AMOU: ',I,AMIN,AMOU
8754C WRITE(6,'(A,4E15.5)')'PIN: ',PIN
8755C WRITE(6,'(A,4E15.5)')'POUT: ',POUT
8756C ENDIF
8757**
8758* increase accumulator by energy-momentum difference
8759 DO 4 K=1,4
8760 DEV(K) = DEV(K)+POUT(K)-PIN(K)
8761 PHKK(K,I) = POUT(K)
8762 4 CONTINUE
8763 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
8764 & PHKK(2,I)**2-PHKK(3,I)**2))
8765 ENDIF
8766 2 CONTINUE
8767
8768* dump accumulator to momenta of valence partons
8769 NVAL = 0
8770 ETOT = 0.0D0
8771 DO 5 I=NPOINT(2),NHKK
8772 IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
8773 NVAL = NVAL+1
8774 ETOT = ETOT+PHKK(4,I)
8775 ENDIF
8776 5 CONTINUE
8777C WRITE(LOUT,1000) NVAL,(DEV(K)/DBLE(NVAL),K=1,4)
8778 1000 FORMAT(1X,'CRONIN : number of val. partons ',I4,/,
8779 & 9X,4E12.4)
8780 DO 6 I=NPOINT(2),NHKK
8781 IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
8782 E = PHKK(4,I)
8783 DO 7 K=1,4
8784C PHKK(K,I) = PHKK(K,I)-DEV(K)/DBLE(NVAL)
8785 PHKK(K,I) = PHKK(K,I)-DEV(K)*E/ETOT
8786 7 CONTINUE
8787 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
8788 & PHKK(2,I)**2-PHKK(3,I)**2))
8789 ENDIF
8790 6 CONTINUE
8791
8792 RETURN
8793 END
8794
8795*$ CREATE DT_CROMSC.FOR
8796*COPY DT_CROMSC
8797*
8798*===cromsc=============================================================*
8799*
8800 SUBROUTINE DT_CROMSC(PIN,R,POUT,INCL)
8801
8802************************************************************************
8803* Cronin-Effect. Multiple scattering of one parton passing through *
8804* nuclear matter. *
8805* PIN(4) input 4-momentum of parton *
8806* POUT(4) 4-momentum of parton after mult. scatt. *
8807* R(3) spatial position of parton in target nucleus *
8808* INCL = 1 multiple sc. in projectile *
8809* = 2 multiple sc. in target *
8810* This is a revised version of the original version written by J. Ranft*
8811* This version dated 17.01.95 is written by S. Roesler. *
8812************************************************************************
8813
8814 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8815 SAVE
8816 PARAMETER ( LINP = 10 ,
8817 & LOUT = 6 ,
8818 & LDAT = 9 )
8819 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
8820
8821 LOGICAL LSTART
8822
8823* rejection counter
8824 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
8825 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
8826 & IREXCI(3),IRDIFF(2),IRINC
8827* Glauber formalism: collision properties
8828 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
8829 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
8830* various options for treatment of partons (DTUNUC 1.x)
8831* (chain recombination, Cronin,..)
8832 LOGICAL LCO2CR,LINTPT
8833 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8834 & LCO2CR,LINTPT
8835
8836 DIMENSION PIN(4),POUT(4),R(3)
8837
8838 DATA LSTART /.TRUE./
8839
8840 IRCRON(1) = IRCRON(1)+1
8841
8842 IF (LSTART) THEN
8843 WRITE(LOUT,1000) CRONCO
8844 1000 FORMAT(/,1X,'CROMSC: multiple scattering of chain ends',
8845 & ' treated',/,10X,'with parameter CRONCO = ',F5.2)
8846 LSTART = .FALSE.
8847 ENDIF
8848
8849 NCBACK = 0
8850 RNCL = RPROJ
8851 IF (INCL.EQ.2) RNCL = RTARG
8852
8853* Lorentz-transformation into Lab.
8854 MODE = -(INCL+1)
8855 CALL DT_LTNUC(PIN(3),PIN(4),PZ,PE,MODE)
8856
8857 PTOT = SQRT(PIN(1)**2+PIN(2)**2+PZ**2)
8858 IF (PTOT.LE.8.0D0) GOTO 9997
8859
8860* direction cosines of parton before mult. scattering
8861 COSX = PIN(1)/PTOT
8862 COSY = PIN(2)/PTOT
8863 COSZ = PZ/PTOT
8864
8865 RTESQ = R(1)**2+R(2)**2+R(3)**2-RNCL**2
8866 IF (RTESQ.GE.-TINY3) GOTO 9999
8867
8868* calculate distance (DIST) from R to surface of nucleus (radius RNCL)
8869* in the direction of particle motion
8870
8871 A = COSX*R(1)+COSY*R(2)+COSZ*R(3)
8872 TMP = A**2-RTESQ
8873 IF (TMP.LT.ZERO) GOTO 9998
8874 DIST = -A+SQRT(TMP)
8875
8876* multiple scattering angle
8877 THETO = CRONCO*SQRT(DIST)/PTOT
8878 IF (THETO.GT.0.1D0) THETO=0.1D0
8879
8880 1 CONTINUE
8881* Gaussian sampling of spatial angle
8882 CALL DT_RANNOR(R1,R2)
8883 THETA = ABS(R1*THETO)
8884 IF (THETA.GT.0.3D0) GOTO 9997
8885 CALL DT_DSFECF(SFE,CFE)
8886 COSTH = COS(THETA)
8887 SINTH = SIN(THETA)
8888
8889* new direction cosines
8890 CALL DT_MYTRAN(1,COSX,COSY,COSZ,COSTH,SINTH,SFE,CFE,
8891 & COSXN,COSYN,COSZN)
8892
8893 POUT(1) = COSXN*PTOT
8894 POUT(2) = COSYN*PTOT
8895 PZ = COSZN*PTOT
8896* Lorentz-transformation into nucl.-nucl. cms
8897 MODE = INCL+1
8898 CALL DT_LTNUC(PZ,PE,POUT(3),POUT(4),MODE)
8899
8900C IF (ABS(PIN(4)-POUT(4)).GT.0.2D0) THEN
8901C IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.1D0 ) THEN
8902 IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.05D0 ) THEN
8903 THETO = THETO/2.0D0
8904 NCBACK = NCBACK+1
8905 IF (MOD(NCBACK,200).EQ.0) THEN
8906 WRITE(LOUT,1001) THETO,PIN,POUT
8907 1001 FORMAT(1X,'CROMSC: inconsistent scattering angle ',
8908 & E12.4,/,1X,' PIN :',4E12.4,/,
8909 & 1X,' POUT:',4E12.4)
8910 GOTO 9997
8911 ENDIF
8912 GOTO 1
8913 ENDIF
8914
8915 RETURN
8916
8917 9997 IRCRON(2) = IRCRON(2)+1
8918 GOTO 9999
8919 9998 IRCRON(3) = IRCRON(3)+1
8920
8921 9999 CONTINUE
8922 DO 100 K=1,4
8923 POUT(K) = PIN(K)
8924 100 CONTINUE
8925 RETURN
8926 END
8927
8928*$ CREATE DT_COM2CR.FOR
8929*COPY DT_COM2CR
8930*
8931*===com2sr=============================================================*
8932*
8933 SUBROUTINE DT_COM2CR
8934
8935************************************************************************
8936* COMbine q-aq chains to Color Ropes (qq-aqaq). *
8937* CUTOF parameter determining minimum number of not *
8938* combined q-aq chains *
8939* This subroutine replaces KKEVCC etc. *
8940* This version dated 11.01.95 is written by S. Roesler. *
8941************************************************************************
8942
8943 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8944 SAVE
8945 PARAMETER ( LINP = 10 ,
8946 & LOUT = 6 ,
8947 & LDAT = 9 )
8948
8949* event history
8950 PARAMETER (NMXHKK=200000)
8951 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8952 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8953 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8954* extended event history
8955 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8956 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8957 & IHIST(2,NMXHKK)
8958* statistics
8959 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
8960 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
8961 & ICEVTG(8,0:30)
8962* various options for treatment of partons (DTUNUC 1.x)
8963* (chain recombination, Cronin,..)
8964 LOGICAL LCO2CR,LINTPT
8965 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8966 & LCO2CR,LINTPT
8967
8968 DIMENSION IDXQA(248),IDXAQ(248)
8969
8970 ICCHAI(1,9) = ICCHAI(1,9)+1
8971 NQA = 0
8972 NAQ = 0
8973* scan DTEVT1 for q-aq, aq-q chains
8974 DO 10 I=NPOINT(3),NHKK
8975* skip "chains" which are resonances
8976 IF ((IDHKK(I).EQ.88888).AND.(IDRES(I).EQ.0)) THEN
8977 MO1 = JMOHKK(1,I)
8978 MO2 = JMOHKK(2,I)
8979 IF ((ABS(IDHKK(MO1)).LE.6).AND.(ABS(IDHKK(MO2)).LE.6)) THEN
8980* q-aq, aq-q chain found, keep index
8981 IF (IDHKK(MO1).GT.0) THEN
8982 NQA = NQA+1
8983 IDXQA(NQA) = I
8984 ELSE
8985 NAQ = NAQ+1
8986 IDXAQ(NAQ) = I
8987 ENDIF
8988 ENDIF
8989 ENDIF
8990 10 CONTINUE
8991
8992* minimum number of q-aq chains requested for the same projectile/
8993* target
8994 NCHMIN = IDT_NPOISS(CUTOF)
8995
8996* combine q-aq chains of the same projectile
8997 CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,1)
8998* combine q-aq chains of the same target
8999 CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,2)
9000* combine aq-q chains of the same projectile
9001 CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,1)
9002* combine aq-q chains of the same target
9003 CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,2)
9004
9005 RETURN
9006 END
9007
9008*$ CREATE DT_SCN4CR.FOR
9009*COPY DT_SCN4CR
9010*
9011*===scn4cr=============================================================*
9012*
9013 SUBROUTINE DT_SCN4CR(NCH,IDXCH,NCHMIN,MODE)
9014
9015************************************************************************
9016* SCan q-aq chains for Color Ropes. *
9017* This version dated 11.01.95 is written by S. Roesler. *
9018************************************************************************
9019
9020 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9021 SAVE
9022 PARAMETER ( LINP = 10 ,
9023 & LOUT = 6 ,
9024 & LDAT = 9 )
9025
9026* event history
9027 PARAMETER (NMXHKK=200000)
9028 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9029 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9030 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9031* extended event history
9032 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9033 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9034 & IHIST(2,NMXHKK)
9035
9036 DIMENSION IDXCH(248),IDXJN(248)
9037
9038 DO 1 I=1,NCH
9039 IF (IDXCH(I).GT.0) THEN
9040 NJOIN = 1
9041 IDXMO = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(I))))
9042 IDXJN(NJOIN) = I
9043 IF (I.LT.NCH) THEN
9044 DO 2 J=I+1,NCH
9045 IF (IDXCH(J).GT.0) THEN
9046 IDXMO1 = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(J))))
9047 IF (IDXMO.EQ.IDXMO1) THEN
9048 NJOIN = NJOIN+1
9049 IDXJN(NJOIN) = J
9050 ENDIF
9051 ENDIF
9052 2 CONTINUE
9053 ENDIF
9054 IF (NJOIN.GE.NCHMIN+2) THEN
9055 NJ = INT(DBLE(NJOIN-NCHMIN)/2.0D0)
9056 DO 3 J=1,2*NJ,2
9057 CALL DT_JOIN(IDXCH(IDXJN(J)),IDXCH(IDXJN(J+1)),IREJ1)
9058 IF (IREJ1.NE.0) GOTO 3
9059 IDXCH(IDXJN(J)) = 0
9060 IDXCH(IDXJN(J+1)) = 0
9061 3 CONTINUE
9062 ENDIF
9063 ENDIF
9064 1 CONTINUE
9065
9066 RETURN
9067 END
9068
9069*$ CREATE DT_JOIN.FOR
9070*COPY DT_JOIN
9071*
9072*===join===============================================================*
9073*
9074 SUBROUTINE DT_JOIN(IDX1,IDX2,IREJ)
9075
9076************************************************************************
9077* This subroutine joins two q-aq chains to one qq-aqaq chain. *
9078* IDX1, IDX2 DTEVT1 indices of chains to be joined *
9079* This version dated 11.01.95 is written by S. Roesler. *
9080************************************************************************
9081
9082 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9083 SAVE
9084 PARAMETER ( LINP = 10 ,
9085 & LOUT = 6 ,
9086 & LDAT = 9 )
9087
9088* event history
9089 PARAMETER (NMXHKK=200000)
9090 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9091 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9092 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9093* extended event history
9094 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9095 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9096 & IHIST(2,NMXHKK)
9097* flags for input different options
9098 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
9099 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
9100 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
9101* statistics
9102 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9103 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9104 & ICEVTG(8,0:30)
9105
9106 DIMENSION MO(2,2),ID(2,2),IDX(2),PCH(4),PP(4),PT(4),P1(4),P2(4)
9107
9108 IREJ = 0
9109
9110 IDX(1) = IDX1
9111 IDX(2) = IDX2
9112 DO 1 I=1,2
9113 DO 2 J=1,2
9114 MO(I,J) = JMOHKK(J,IDX(I))
9115 ID(I,J) = IDT_IPDG2B(IDHKK(MO(I,J)),1,2)
9116 2 CONTINUE
9117 1 CONTINUE
9118
9119* check consistency
9120 IF ((ABS(ID(1,1)).GT.6).OR.(ABS(ID(1,2)).GT.6).OR.
9121 & (ABS(ID(2,1)).GT.6).OR.(ABS(ID(2,2)).GT.6).OR.
9122 & ((ID(1,1)*ID(2,1)).LT.0).OR.
9123 & ((ID(1,2)*ID(2,2)).LT.0)) THEN
9124 WRITE(LOUT,1000) IDX(1),MO(1,1),MO(1,2),IDX(2),MO(2,1),
9125 & MO(2,2)
9126 1000 FORMAT(1X,'JOIN: incons. chain system! chain ',I4,':',
9127 & 2I5,' chain ',I4,':',2I5)
9128 ENDIF
9129
9130* join chains
9131 DO 3 K=1,4
9132 PP(K) = PHKK(K,MO(1,1))+PHKK(K,MO(2,1))
9133 PT(K) = PHKK(K,MO(1,2))+PHKK(K,MO(2,2))
9134 3 CONTINUE
9135 IF1 = IDT_IB2PDG(ID(1,1),ID(2,1),2)
9136 IF2 = IDT_IB2PDG(ID(1,2),ID(2,2),2)
9137 IST1 = ISTHKK(MO(1,1))
9138 IST2 = ISTHKK(MO(1,2))
9139
9140* put partons again on mass shell
9141 XM1 = 0.0D0
9142 XM2 = 0.0D0
9143 IF (IMSHL.EQ.1) THEN
9144 XM1 = PYMASS(IF1)
9145 XM2 = PYMASS(IF2)
9146 ENDIF
9147 CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1)
9148 IF (IREJ1.NE.0) GOTO 9999
9149 DO 4 I=1,4
9150 PP(I) = P1(I)
9151 PT(I) = P2(I)
9152 4 CONTINUE
9153
9154* store new partons in DTEVT1
9155 CALL DT_EVTPUT(IST1,IF1,MO(1,1),MO(2,1),PP(1),PP(2),PP(3),PP(4),
9156 & 0,0,0)
9157 CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4),
9158 & 0,0,0)
9159 DO 5 K=1,4
9160 PCH(K) = PP(K)+PT(K)
9161 5 CONTINUE
9162
9163* check new chain for lower mass limit
9164 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
9165 AMCH = SQRT(ABS(PCH(4)**2-PCH(1)**2-PCH(2)**2-PCH(3)**2))
9166 CALL DT_CH2RES(ID(1,1),ID(2,1),ID(1,2),ID(2,2),IDUM,IDUM,
9167 & AMCH,AMCHN,3,IREJ1)
9168 IF (IREJ1.NE.0) THEN
9169 NHKK = NHKK-2
9170 GOTO 9999
9171 ENDIF
9172 ENDIF
9173
9174 ICCHAI(2,9) = ICCHAI(2,9)+1
9175* store new chain in DTEVT1
9176 KCH = 191
9177 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),0,0,9)
9178 IDHKK(IDX(1)) = 22222
9179 IDHKK(IDX(2)) = 22222
9180* special treatment for space-time coordinates
9181 DO 6 K=1,4
9182 VHKK(K,NHKK) = (VHKK(K,IDX(1))+VHKK(K,IDX(2)))/2.0D0
9183 WHKK(K,NHKK) = (WHKK(K,IDX(1))+WHKK(K,IDX(2)))/2.0D0
9184 6 CONTINUE
9185 RETURN
9186
9187 9999 CONTINUE
9188 IREJ = 1
9189 RETURN
9190 END
9191
9192*$ CREATE DT_XSGLAU.FOR
9193*COPY DT_XSGLAU
9194*
9195*===xsglau=============================================================*
9196*
9197 SUBROUTINE DT_XSGLAU(NA,NB,JJPROJ,XI,Q2I,ECMI,IE,IQ,NIDX)
9198
9199************************************************************************
9200* Total, elastic, quasi-elastic, inelastic cross sections according to *
9201* Glauber's approach. *
9202* NA / NB mass numbers of proj./target nuclei *
9203* JJPROJ bamjet-index of projectile (=1 in case of proj.nucleus) *
9204* XI,Q2I,ECMI kinematical variables x, Q^2, E_cm *
9205* IE,IQ indices of energy and virtuality (the latter for gamma *
9206* projectiles only) *
9207* NIDX index of projectile/target nucleus *
9208* This version dated 17.3.98 is written by S. Roesler *
9209************************************************************************
9210
9211 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9212 SAVE
9213 PARAMETER ( LINP = 10 ,
9214 & LOUT = 6 ,
9215 & LDAT = 9 )
9216
9217 COMPLEX*16 CZERO,CONE,CTWO
9218 CHARACTER*12 CFILE
9219 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
9220 & ONETHI=ONE/THREE,TINY25=1.0D-25)
9221 PARAMETER (TWOPI = 6.283185307179586454D+00,
9222 & PI = TWOPI/TWO,
9223 & GEV2MB = 0.38938D0,
9224 & GEV2FM = 0.1972D0,
9225 & ALPHEM = ONE/137.0D0,
9226* proton mass
9227 & AMP = 0.938D0,
9228 & AMP2 = AMP**2,
9229* approx. nucleon radius
9230 & RNUCLE = 1.12D0)
9231
9232* particle properties (BAMJET index convention)
9233 CHARACTER*8 ANAME
9234 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
9235 & IICH(210),IIBAR(210),K1(210),K2(210)
9236 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
9237 PARAMETER ( MAXNCL = 260,
9238 & MAXVQU = MAXNCL,
9239 & MAXSQU = 20*MAXVQU,
9240 & MAXINT = MAXVQU+MAXSQU)
9241* Glauber formalism: parameters
9242 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
9243 & BMAX(NCOMPX),BSTEP(NCOMPX),
9244 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
9245 & NSITEB,NSTATB
9246* Glauber formalism: cross sections
9247 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
9248 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
9249 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
9250 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
9251 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
9252 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
9253 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
9254 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
9255 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
9256 & BSLOPE,NEBINI,NQBINI
9257* Glauber formalism: flags and parameters for statistics
9258 LOGICAL LPROD
9259 CHARACTER*8 CGLB
9260 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
9261* nucleon-nucleon event-generator
9262 CHARACTER*8 CMODEL
9263 LOGICAL LPHOIN
9264 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
9265* VDM parameter for photon-nucleus interactions
9266 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
9267* parameters for hA-diffraction
9268 COMMON /DTDIHA/ DIBETA,DIALPH
9269
9270 COMPLEX*16 PP11(MAXNCL),PP12(MAXNCL),PP21(MAXNCL),PP22(MAXNCL),
9271 & OMPP11,OMPP12,OMPP21,OMPP22,
9272 & DIPP11,DIPP12,DIPP21,DIPP22,AVDIPP,
9273 & PPTMP1,PPTMP2
9274 COMPLEX*16 C,CA,CI
9275 DIMENSION COOP1(3,MAXNCL),COOT1(3,MAXNCL),
9276 & COOP2(3,MAXNCL),COOT2(3,MAXNCL),
9277 & BPROD(KSITEB)
9278
9279 PARAMETER (NPOINT=16)
9280 DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
9281
9282 LOGICAL LFIRST,LOPEN
9283 DATA LFIRST,LOPEN /.TRUE.,.FALSE./
9284
9285 NTARG = ABS(NIDX)
9286* for quasi-elastic neutrino scattering set projectile to proton
9287* it should not have an effect since the whole Glauber-formalism is
9288* not needed for these interactions..
9289 IF (MCGENE.EQ.4) THEN
9290 IJPROJ = 1
9291 ELSE
9292 IJPROJ = JJPROJ
9293 ENDIF
9294
9295 IF ((ABS(IOGLB).EQ.1).AND.(.NOT.LOPEN)) THEN
9296 I = INDEX(CGLB,' ')
9297 IF (I.EQ.0) THEN
9298 CFILE = CGLB//'.glb'
9299 OPEN(LDAT,FILE=CGLB//'.glb',STATUS='UNKNOWN')
9300 ELSEIF (I.GT.1) THEN
9301 CFILE = CGLB(1:I-1)//'.glb'
9302 OPEN(LDAT,FILE=CGLB(1:I-1)//'.glb',STATUS='UNKNOWN')
9303 ELSE
9304 STOP 'XSGLAU 1'
9305 ENDIF
9306 LOPEN = .TRUE.
9307 ENDIF
9308
9309 CZERO = DCMPLX(ZERO,ZERO)
9310 CONE = DCMPLX(ONE,ZERO)
9311 CTWO = DCMPLX(TWO,ZERO)
9312 NEBINI = IE
9313 NQBINI = IQ
9314
9315* re-define kinematics
9316 S = ECMI**2
9317 Q2 = Q2I
9318 X = XI
9319* g(Q2=0)-A, h-A, A-A scattering
9320 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9321 Q2 = 0.0001D0
9322 X = Q2/(S+Q2-AMP2)
9323* g(Q2>0)-A scattering
9324 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(S.GT.ZERO)) THEN
9325 X = Q2/(S+Q2-AMP2)
9326 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9327 Q2 = (S-AMP2)*X/(ONE-X)
9328 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
9329 S = Q2*(ONE-X)/X+AMP2
9330 ELSE
9331 WRITE(LOUT,*) 'XSGLAU: inconsistent input ',S,Q2,X
9332 STOP
9333 ENDIF
9334 ECMNN(IE) = SQRT(S)
9335 Q2G(IQ) = Q2
9336 XNU = (S+Q2-AMP2)/(TWO*AMP)
9337
9338* parameters determining statistics in evaluating Glauber-xsection
9339 NSTATB = JSTATB
9340 NSITEB = JBINSB
9341 IF (NSITEB.GT.KSITEB) NSITEB = KSITEB
9342
9343* set up interaction geometry (common /DTGLAM/)
9344* projectile/target radii
9345 RPRNCL = DT_RNCLUS(NA)
9346 RTANCL = DT_RNCLUS(NB)
9347 IF (IJPROJ.EQ.7) THEN
9348 RASH(1) = ZERO
9349 RBSH(NTARG) = RTANCL
9350 BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9351 ELSE
9352 IF (NIDX.LE.-1) THEN
9353 RASH(1) = RPRNCL
9354 RBSH(NTARG) = RTANCL
9355 BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9356 ELSE
9357 RASH(NTARG) = RPRNCL
9358 RBSH(1) = RTANCL
9359 BMAX(NTARG) = 2.0D0*(RASH(NTARG)+RBSH(1))
9360 ENDIF
9361 ENDIF
9362* maximum impact-parameter
9363 BSTEP(NTARG)= BMAX(NTARG)/DBLE(NSITEB-1)
9364
9365* slope, rho ( Re(f(0))/Im(f(0)) )
9366 IF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
9367 IF (MCGENE.EQ.2) THEN
9368 ZERO1 = ZERO
9369 CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,SDUM1,SDUM2,SDUM3,
9370 & BSLOPE,0)
9371 ELSE
9372 BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
9373 ENDIF
9374 IF (ECMNN(IE).LE.3.0D0) THEN
9375 ROSH = -0.43D0
9376 ELSEIF ((ECMNN(IE).GT.3.0D0).AND.(ECMNN(IE).LE.50.D0)) THEN
9377 ROSH = -0.63D0+0.175D0*LOG(ECMNN(IE))
9378 ELSEIF (ECMNN(IE).GT.50.0D0) THEN
9379 ROSH = 0.1D0
9380 ENDIF
9381 ELSEIF (IJPROJ.EQ.7) THEN
9382 ROSH = 0.1D0
9383 ELSE
9384 BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
9385 ROSH = 0.01D0
9386 ENDIF
9387
9388* projectile-nucleon xsection (in fm)
9389 IF (IJPROJ.EQ.7) THEN
9390 SIGSH = DT_SIGVP(X,Q2)/10.0D0
9391 ELSE
9392 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
9393 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
9394C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
9395 DUMZER = ZERO
9396 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
9397 SIGSH = SIGSH/10.0D0
9398 ENDIF
9399
9400* parameters for projectile diffraction (hA scattering only)
9401 IF ((MCGENE.EQ.2).AND.(NA.EQ.1).AND.(NB.GT.1).AND.(IJPROJ.NE.7)
9402 & .AND.(DIBETA.GE.ZERO)) THEN
9403 ZERO1 = ZERO
9404 CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,STOT,SDUM2,SDIF1,BDUM,0)
9405C DIBETA = SDIF1/STOT
9406 DIBETA = 0.2D0
9407 DIGAMM = SQRT(DIALPH**2+DIBETA**2)
9408 IF (DIBETA.LE.ZERO) THEN
9409 ALPGAM = ONE
9410 ELSE
9411 ALPGAM = DIALPH/DIGAMM
9412 ENDIF
9413 FACDI1 = ONE-ALPGAM
9414 FACDI2 = ONE+ALPGAM
9415 FACDI = SQRT(FACDI1*FACDI2)
9416 WRITE(LOUT,*)'DIBETA,DIALPH,DIGAMM: ',DIBETA,DIALPH,DIGAMM
9417 ELSE
9418 DIBETA = -1.0D0
9419 DIALPH = ZERO
9420 DIGAMM = ZERO
9421 FACDI1 = ZERO
9422 FACDI2 = 2.0D0
9423 FACDI = ZERO
9424 ENDIF
9425
9426* initializations
9427 DO 10 I=1,NSITEB
9428 BSITE( 0,IQ,NTARG,I) = ZERO
9429 BSITE(IE,IQ,NTARG,I) = ZERO
9430 BPROD(I) = ZERO
9431 10 CONTINUE
9432 STOT = ZERO
9433 STOT2 = ZERO
9434 SELA = ZERO
9435 SELA2 = ZERO
9436 SQEP = ZERO
9437 SQEP2 = ZERO
9438 SQET = ZERO
9439 SQET2 = ZERO
9440 SQE2 = ZERO
9441 SQE22 = ZERO
9442 SPRO = ZERO
9443 SPRO2 = ZERO
9444 SDEL = ZERO
9445 SDEL2 = ZERO
9446 SDQE = ZERO
9447 SDQE2 = ZERO
9448 FACN = ONE/DBLE(NSTATB)
9449
9450 IPNT = 0
9451 RPNT = ZERO
9452
9453* initialize Gauss-integration for photon-proj.
9454 JPOINT = 1
9455 IF (IJPROJ.EQ.7) THEN
9456 IF (INTRGE(1).EQ.1) THEN
9457 AMLO2 = (3.0D0*AAM(13))**2
9458 ELSEIF (INTRGE(1).EQ.2) THEN
9459 AMLO2 = AAM(33)**2
9460 ELSE
9461 AMLO2 = AAM(96)**2
9462 ENDIF
9463 IF (INTRGE(2).EQ.1) THEN
9464 AMHI2 = S/TWO
9465 ELSEIF (INTRGE(2).EQ.2) THEN
9466 AMHI2 = S/4.0D0
9467 ELSE
9468 AMHI2 = S
9469 ENDIF
9470 AMHI20 = (ECMNN(IE)-AMP)**2
9471 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
9472 XAMLO = LOG( AMLO2+Q2 )
9473 XAMHI = LOG( AMHI2+Q2 )
9474**PHOJET105a
9475C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9476**PHOJET112
9477 CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9478**
9479 JPOINT = NPOINT
9480* ratio direct/total photon-nucleon xsection
9481 CALL DT_POILIK(NB,NTARG,ECMNN(IE),Q2,IPNT,RPNT,1)
9482 ENDIF
9483
9484* read pre-initialized profile-function from file
9485 IF (IOGLB.EQ.1) THEN
9486 READ(LDAT,'(5I10,E15.5)') KJPROJ,IA,IB,ISTATB,ISITEB,DUM
9487 IF ((IA.NE.NA).OR.(IB.NE.NB)) THEN
9488 WRITE(LOUT,1000) CFILE,IA,IB,ISTATB,ISITEB,
9489 & NA,NB,NSTATB,NSITEB
9490 1000 FORMAT(' XSGLAU: inconsistent input data in file ',A12,/,
9491 & ' (IA,IB,ISTATB,ISITEB) ',4I10,/,
9492 & ' (NA,NB,NSTATB,NSITEB) ',4I10)
9493 STOP
9494 ENDIF
9495 IF (LFIRST) WRITE(LOUT,1001) CFILE
9496 1001 FORMAT(/,' XSGLAU: impact parameter distribution read from ',
9497 & 'file ',A12,/)
9498 READ(LDAT,'(6E12.5)') XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),
9499 & XSQEP(IE,IQ,NTARG),XSQET(IE,IQ,NTARG),
9500 & XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
9501 READ(LDAT,'(6E12.5)') XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),
9502 & XEQEP(IE,IQ,NTARG),XEQET(IE,IQ,NTARG),
9503 & XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
9504 NLINES = INT(DBLE(NSITEB)/7.0D0)
9505 IF (NLINES.GT.0) THEN
9506 DO 21 I=1,NLINES
9507 ISTART = 7*I-6
9508 READ(LDAT,'(7E11.4)')
9509 & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
9510 21 CONTINUE
9511 ENDIF
9512 ISTART = 7*NLINES+1
9513 IF (ISTART.LE.NSITEB) THEN
9514 READ(LDAT,'(7E11.4)')
9515 & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
9516 ENDIF
9517 LFIRST = .FALSE.
9518 GOTO 100
9519* variable projectile/target/energy runs:
9520* read pre-initialized profile-functions from file
9521 ELSEIF (IOGLB.EQ.100) THEN
9522 CALL DT_GLBSET(IJPROJ,IINA,IINB,RRELAB,0)
9523 GOTO 100
9524 ENDIF
9525
9526* cross sections averaged over NSTATB nucleon configurations
9527 DO 11 IS=1,NSTATB
9528C IF ((NA.EQ.207).AND.(NB.EQ.207)) WRITE(LOUT,*) 'conf. ',IS
9529 STOTN = ZERO
9530 SELAN = ZERO
9531 SQEPN = ZERO
9532 SQETN = ZERO
9533 SQE2N = ZERO
9534 SPRON = ZERO
9535 SDELN = ZERO
9536 SDQEN = ZERO
9537
9538 IF (NIDX.LE.-1) THEN
9539 CALL DT_CONUCL(COOP1,NA,RASH(1),0)
9540 CALL DT_CONUCL(COOT1,NB,RBSH(NTARG),1)
9541 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9542 CALL DT_CONUCL(COOP2,NA,RASH(1),0)
9543 CALL DT_CONUCL(COOT2,NB,RBSH(NTARG),1)
9544 ENDIF
9545 ELSE
9546 CALL DT_CONUCL(COOP1,NA,RASH(NTARG),0)
9547 CALL DT_CONUCL(COOT1,NB,RBSH(1),1)
9548 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9549 CALL DT_CONUCL(COOP2,NA,RASH(NTARG),0)
9550 CALL DT_CONUCL(COOT2,NB,RBSH(1),1)
9551 ENDIF
9552 ENDIF
9553
9554* integration over impact parameter B
9555 DO 12 IB=1,NSITEB-1
9556 STOTB = ZERO
9557 SELAB = ZERO
9558 SQEPB = ZERO
9559 SQETB = ZERO
9560 SQE2B = ZERO
9561 SPROB = ZERO
9562 SDIR = ZERO
9563 SDELB = ZERO
9564 SDQEB = ZERO
9565 B = DBLE(IB)*BSTEP(NTARG)
9566 FACB = 10.0D0*TWOPI*B*BSTEP(NTARG)
9567
9568* integration over M_V^2 for photon-proj.
9569 DO 14 IM=1,JPOINT
9570 PP11(1) = CONE
9571 PP12(1) = CONE
9572 PP21(1) = CONE
9573 PP22(1) = CONE
9574 IF (IJPROJ.EQ.7) THEN
9575 DO 13 K=2,NB
9576 PP11(K) = CONE
9577 PP12(K) = CONE
9578 PP21(K) = CONE
9579 PP22(K) = CONE
9580 13 CONTINUE
9581 ENDIF
9582 SHI = ZERO
9583 FACM = ONE
9584 DCOH = 1.0D10
9585
9586 IF (IJPROJ.EQ.7) THEN
9587 AMV2 = EXP(ABSZX(IM))-Q2
9588 AMV = SQRT(AMV2)
9589 IF (AMV2.LT.16.0D0) THEN
9590 R = TWO
9591 ELSEIF ((AMV2.GE.16.0D0).AND.(AMV2.LT.121.0D0)) THEN
9592 R = 10.0D0/3.0D0
9593 ELSE
9594 R = 11.0D0/3.0D0
9595 ENDIF
9596* define M_V dependent properties of nucleon scattering amplitude
9597* V_M-nucleon xsection
9598 SIGMVD = RPNT*SIGSH/(AMV2+Q2+RL2)*10.0D0
9599 SIGMV = (ONE-RPNT)*SIGSH/(AMV2+Q2+RL2)
9600* slope-parametrisation a la Kaidalov
9601 BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
9602 & +0.25D0*LOG(S/(AMV2+Q2)))
9603* coherence length
9604 IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+Q2)*GEV2FM
9605* integration weight factor
9606 FACM = ALPHEM/(3.0D0*PI*(ONE-X))*
9607 & R*AMV2/(AMV2+Q2)*(ONE+EPSPOL*Q2/AMV2)*WEIGHT(IM)
9608 ENDIF
9609 GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
9610 GAM = GSH
9611 IF (IJPROJ.EQ.7) THEN
9612 RCA = GAM*SIGMV/TWOPI
9613 ELSE
9614 RCA = GAM*SIGSH/TWOPI
9615 ENDIF
9616 FCA = -ROSH*RCA
9617 CA = DCMPLX(RCA,FCA)
9618 CI = CONE
9619
9620 DO 15 INA=1,NA
9621 KK1 = 1
9622 INT1 = 1
9623 KK2 = 1
9624 INT2 = 1
9625 DO 16 INB=1,NB
9626* photon-projectile: check for supression by coherence length
9627 IF (IJPROJ.EQ.7) THEN
9628 IF (ABS(COOT1(3,INB)-COOT1(3,KK1)).GT.DCOH)THEN
9629 KK1 = INB
9630 INT1 = INT1+1
9631 ENDIF
9632 IF (ABS(COOT2(3,INB)-COOT2(3,KK2)).GT.DCOH)THEN
9633 KK2 = INB
9634 INT2 = INT2+1
9635 ENDIF
9636 ENDIF
9637
9638 X11 = B+COOT1(1,INB)-COOP1(1,INA)
9639 Y11 = COOT1(2,INB)-COOP1(2,INA)
9640 XY11 = GAM*(X11*X11+Y11*Y11)
9641 IF (XY11.LE.15.0D0) THEN
9642 C = CONE-CA*EXP(-XY11)
9643 AR = DBLE(PP11(INT1))
9644 AI = DIMAG(PP11(INT1))
9645 IF (ABS(AR).LT.TINY25) AR = ZERO
9646 IF (ABS(AI).LT.TINY25) AI = ZERO
9647 PP11(INT1) = DCMPLX(AR,AI)
9648 PP11(INT1) = PP11(INT1)*C
9649 AR = DBLE(C)
9650 AI = DIMAG(C)
9651 SHI = SHI+LOG(AR*AR+AI*AI)
9652 ENDIF
9653 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9654 X12 = B+COOT2(1,INB)-COOP1(1,INA)
9655 Y12 = COOT2(2,INB)-COOP1(2,INA)
9656 XY12 = GAM*(X12*X12+Y12*Y12)
9657 IF (XY12.LE.15.0D0) THEN
9658 C = CONE-CA*EXP(-XY12)
9659 AR = DBLE(PP12(INT2))
9660 AI = DIMAG(PP12(INT2))
9661 IF (ABS(AR).LT.TINY25) AR = ZERO
9662 IF (ABS(AI).LT.TINY25) AI = ZERO
9663 PP12(INT2) = DCMPLX(AR,AI)
9664 PP12(INT2) = PP12(INT2)*C
9665 ENDIF
9666 X21 = B+COOT1(1,INB)-COOP2(1,INA)
9667 Y21 = COOT1(2,INB)-COOP2(2,INA)
9668 XY21 = GAM*(X21*X21+Y21*Y21)
9669 IF (XY21.LE.15.0D0) THEN
9670 C = CONE-CA*EXP(-XY21)
9671 AR = DBLE(PP21(INT1))
9672 AI = DIMAG(PP21(INT1))
9673 IF (ABS(AR).LT.TINY25) AR = ZERO
9674 IF (ABS(AI).LT.TINY25) AI = ZERO
9675 PP21(INT1) = DCMPLX(AR,AI)
9676 PP21(INT1) = PP21(INT1)*C
9677 ENDIF
9678 X22 = B+COOT2(1,INB)-COOP2(1,INA)
9679 Y22 = COOT2(2,INB)-COOP2(2,INA)
9680 XY22 = GAM*(X22*X22+Y22*Y22)
9681 IF (XY22.LE.15.0D0) THEN
9682 C = CONE-CA*EXP(-XY22)
9683 AR = DBLE(PP22(INT2))
9684 AI = DIMAG(PP22(INT2))
9685 IF (ABS(AR).LT.TINY25) AR = ZERO
9686 IF (ABS(AI).LT.TINY25) AI = ZERO
9687 PP22(INT2) = DCMPLX(AR,AI)
9688 PP22(INT2) = PP22(INT2)*C
9689 ENDIF
9690 ENDIF
9691 16 CONTINUE
9692 15 CONTINUE
9693
9694 OMPP11 = CZERO
9695 OMPP21 = CZERO
9696 DIPP11 = CZERO
9697 DIPP21 = CZERO
9698 DO 17 K=1,INT1
9699 IF (PP11(K).EQ.CZERO) THEN
9700 PPTMP1 = CZERO
9701 PPTMP2 = CZERO
9702 ELSE
9703 PPTMP1 = PP11(K)**(ONE-DIALPH-DIGAMM)
9704 PPTMP2 = PP11(K)**(ONE-DIALPH+DIGAMM)
9705 ENDIF
9706 AVDIPP = 0.5D0*
9707 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9708 OMPP11 = OMPP11+AVDIPP
9709C OMPP11 = OMPP11+(CONE-PP11(K))
9710 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9711 DIPP11 = DIPP11+AVDIPP
9712 IF (PP21(K).EQ.CZERO) THEN
9713 PPTMP1 = CZERO
9714 PPTMP2 = CZERO
9715 ELSE
9716 PPTMP1 = PP21(K)**(ONE-DIALPH-DIGAMM)
9717 PPTMP2 = PP21(K)**(ONE-DIALPH+DIGAMM)
9718 ENDIF
9719 AVDIPP = 0.5D0*
9720 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9721 OMPP21 = OMPP21+AVDIPP
9722C OMPP21 = OMPP21+(CONE-PP21(K))
9723 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9724 DIPP21 = DIPP21+AVDIPP
9725 17 CONTINUE
9726 OMPP12 = CZERO
9727 OMPP22 = CZERO
9728 DIPP12 = CZERO
9729 DIPP22 = CZERO
9730 DO 18 K=1,INT2
9731 IF (PP12(K).EQ.CZERO) THEN
9732 PPTMP1 = CZERO
9733 PPTMP2 = CZERO
9734 ELSE
9735 PPTMP1 = PP12(K)**(ONE-DIALPH-DIGAMM)
9736 PPTMP2 = PP12(K)**(ONE-DIALPH+DIGAMM)
9737 ENDIF
9738 AVDIPP = 0.5D0*
9739 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9740 OMPP12 = OMPP12+AVDIPP
9741C OMPP12 = OMPP12+(CONE-PP12(K))
9742 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9743 DIPP12 = DIPP12+AVDIPP
9744 IF (PP22(K).EQ.CZERO) THEN
9745 PPTMP1 = CZERO
9746 PPTMP2 = CZERO
9747 ELSE
9748 PPTMP1 = PP22(K)**(ONE-DIALPH-DIGAMM)
9749 PPTMP2 = PP22(K)**(ONE-DIALPH+DIGAMM)
9750 ENDIF
9751 AVDIPP = 0.5D0*
9752 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9753 OMPP22 = OMPP22+AVDIPP
9754C OMPP22 = OMPP22+(CONE-PP22(K))
9755 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9756 DIPP22 = DIPP22+AVDIPP
9757 18 CONTINUE
9758
9759 SPROM = ONE-EXP(SHI)
9760 SPROB = SPROB+FACM*SPROM
9761 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9762 STOTM = DBLE(OMPP11+OMPP22)
9763 SELAM = DBLE(OMPP11*DCONJG(OMPP22))
9764 SQEPM = DBLE(OMPP11*DCONJG(OMPP21))-SELAM
9765 SQETM = DBLE(OMPP11*DCONJG(OMPP12))-SELAM
9766 SQE2M = DBLE(OMPP11*DCONJG(OMPP11))-SELAM-SQEPM-SQETM
9767 SDELM = DBLE(DIPP11*DCONJG(DIPP22))
9768 SDQEM = DBLE(DIPP11*DCONJG(DIPP21))-SDELM
9769 STOTB = STOTB+FACM*STOTM
9770 SELAB = SELAB+FACM*SELAM
9771 SDELB = SDELB+FACM*SDELM
9772 IF (NB.GT.1) THEN
9773 SQEPB = SQEPB+FACM*SQEPM
9774 SDQEB = SDQEB+FACM*SDQEM
9775 ENDIF
9776 IF (NA.GT.1) SQETB = SQETB+FACM*SQETM
9777 IF ((NA.GT.1).AND.(NB.GT.1)) SQE2B = SQE2B+FACM*SQE2M
9778 IF (IJPROJ.EQ.7) SDIR = SDIR+FACM*SIGMVD
9779 ENDIF
9780
9781 14 CONTINUE
9782
9783 STOTN = STOTN+FACB*STOTB
9784 SELAN = SELAN+FACB*SELAB
9785 SQEPN = SQEPN+FACB*SQEPB
9786 SQETN = SQETN+FACB*SQETB
9787 SQE2N = SQE2N+FACB*SQE2B
9788 SPRON = SPRON+FACB*SPROB
9789 SDELN = SDELN+FACB*SDELB
9790 SDQEN = SDQEN+FACB*SDQEB
9791
9792 IF (IJPROJ.EQ.7) THEN
9793 BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*(STOTB-SELAB-SQEPB)
9794 ELSE
9795 IF (DIBETA.GT.ZERO) THEN
9796 BPROD(IB+1)= BPROD(IB+1)
9797 & +FACN*FACB*(STOTB-SELAB-SQEPB-SQETB-SQE2B)
9798 ELSE
9799 BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*SPROB
9800 ENDIF
9801 ENDIF
9802
9803 12 CONTINUE
9804
9805 STOT = STOT +FACN*STOTN
9806 STOT2 = STOT2+FACN*STOTN**2
9807 SELA = SELA +FACN*SELAN
9808 SELA2 = SELA2+FACN*SELAN**2
9809 SQEP = SQEP +FACN*SQEPN
9810 SQEP2 = SQEP2+FACN*SQEPN**2
9811 SQET = SQET +FACN*SQETN
9812 SQET2 = SQET2+FACN*SQETN**2
9813 SQE2 = SQE2 +FACN*SQE2N
9814 SQE22 = SQE22+FACN*SQE2N**2
9815 SPRO = SPRO +FACN*SPRON
9816 SPRO2 = SPRO2+FACN*SPRON**2
9817 SDEL = SDEL +FACN*SDELN
9818 SDEL2 = SDEL2+FACN*SDELN**2
9819 SDQE = SDQE +FACN*SDQEN
9820 SDQE2 = SDQE2+FACN*SDQEN**2
9821
9822 11 CONTINUE
9823
9824* final cross sections
9825* 1) total
9826 XSTOT(IE,IQ,NTARG) = STOT
9827 IF (IJPROJ.EQ.7)
9828 & XSTOT(IE,IQ,NTARG) = XSTOT(IE,IQ,NTARG)+DBLE(NB)*SDIR
9829* 2) elastic
9830 XSELA(IE,IQ,NTARG) = SELA
9831* 3) quasi-el.: A+B-->A+X (excluding 2)
9832 XSQEP(IE,IQ,NTARG) = SQEP
9833* 4) quasi-el.: A+B-->X+B (excluding 2)
9834 XSQET(IE,IQ,NTARG) = SQET
9835* 5) quasi-el.: A+B-->X (excluding 2-4)
9836 XSQE2(IE,IQ,NTARG) = SQE2
9837* 6) production (= STOT-SELA-SQEP-SQET-SQE2!)
9838 IF (SDEL.GT.ZERO) THEN
9839 XSPRO(IE,IQ,NTARG) = STOT-SELA-SQEP-SQET-SQE2
9840 ELSE
9841 XSPRO(IE,IQ,NTARG) = SPRO
9842 ENDIF
9843* 7) projectile diffraction (el. scatt. off target)
9844 XSDEL(IE,IQ,NTARG) = SDEL
9845* 8) projectile diffraction (quasi-el. scatt. off target)
9846 XSDQE(IE,IQ,NTARG) = SDQE
9847* stat. errors
9848 XETOT(IE,IQ,NTARG) = SQRT(ABS(STOT2-STOT**2)/DBLE(NSTATB-1))
9849 XEELA(IE,IQ,NTARG) = SQRT(ABS(SELA2-SELA**2)/DBLE(NSTATB-1))
9850 XEQEP(IE,IQ,NTARG) = SQRT(ABS(SQEP2-SQEP**2)/DBLE(NSTATB-1))
9851 XEQET(IE,IQ,NTARG) = SQRT(ABS(SQET2-SQET**2)/DBLE(NSTATB-1))
9852 XEQE2(IE,IQ,NTARG) = SQRT(ABS(SQE22-SQE2**2)/DBLE(NSTATB-1))
9853 XEPRO(IE,IQ,NTARG) = SQRT(ABS(SPRO2-SPRO**2)/DBLE(NSTATB-1))
9854 XEDEL(IE,IQ,NTARG) = SQRT(ABS(SDEL2-SDEL**2)/DBLE(NSTATB-1))
9855 XEDQE(IE,IQ,NTARG) = SQRT(ABS(SDQE2-SDQE**2)/DBLE(NSTATB-1))
9856
9857 IF (IJPROJ.EQ.7) THEN
9858 BNORM = XSTOT(IE,IQ,NTARG)-XSELA(IE,IQ,NTARG)
9859 & -XSQEP(IE,IQ,NTARG)
9860 ELSE
9861 BNORM = XSPRO(IE,IQ,NTARG)
9862 ENDIF
9863 DO 19 I=2,NSITEB
9864 BSITE(IE,IQ,NTARG,I) = BPROD(I)/BNORM+BSITE(IE,IQ,NTARG,I-1)
9865 IF ((IE.EQ.1).AND.(IQ.EQ.1))
9866 & BSITE(0,1,NTARG,I) = BPROD(I)/BNORM+BSITE(0,1,NTARG,I-1)
9867 19 CONTINUE
9868
9869* write profile function data into file
9870 IF ((IOGLB.EQ.-1).OR.(IOGLB.EQ.-100)) THEN
9871 WRITE(LDAT,'(5I10,1P,E15.5)')
9872 & IJPROJ,NA,NB,NSTATB,NSITEB,ECMNN(IE)
9873 WRITE(LDAT,'(1P,6E12.5)')
9874 & XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),XSQEP(IE,IQ,NTARG),
9875 & XSQET(IE,IQ,NTARG),XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
9876 WRITE(LDAT,'(1P,6E12.5)')
9877 & XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),XEQEP(IE,IQ,NTARG),
9878 & XEQET(IE,IQ,NTARG),XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
9879 NLINES = INT(DBLE(NSITEB)/7.0D0)
9880 IF (NLINES.GT.0) THEN
9881 DO 20 I=1,NLINES
9882 ISTART = 7*I-6
9883 WRITE(LDAT,'(1P,7E11.4)')
9884 & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
9885 20 CONTINUE
9886 ENDIF
9887 ISTART = 7*NLINES+1
9888 IF (ISTART.LE.NSITEB) THEN
9889 WRITE(LDAT,'(1P,7E11.4)')
9890 & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
9891 ENDIF
9892 ENDIF
9893
9894 100 CONTINUE
9895
9896C IF (ABS(IOGLB).EQ.1) CLOSE(LDAT)
9897
9898 RETURN
9899 END
9900
9901*$ CREATE DT_GETBXS.FOR
9902*COPY DT_GETBXS
9903*
9904*===getbxs=============================================================*
9905*
9906 SUBROUTINE DT_GETBXS(XSFRAC,BLO,BHI,NIDX)
9907
9908************************************************************************
9909* Biasing in impact parameter space. *
9910* XSFRAC = 0 : BLO - minimum impact parameter (input) *
9911* BHI - maximum impact parameter (input) *
9912* XSFRAC - fraction of cross section corresponding *
9913* to impact parameter range (BLO,BHI) *
9914* (output) *
9915* XSFRAC > 0 : XSFRAC - fraction of cross section (input) *
9916* BHI - maximum impact parameter giving requested *
9917* fraction of cross section in impact *
9918* parameter range (0,BMAX) (output) *
9919* This version dated 17.03.00 is written by S. Roesler *
9920************************************************************************
9921
9922 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9923 SAVE
9924 PARAMETER ( LINP = 10 ,
9925 & LOUT = 6 ,
9926 & LDAT = 9 )
9927
9928 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
9929* Glauber formalism: parameters
9930 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
9931 & BMAX(NCOMPX),BSTEP(NCOMPX),
9932 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
9933 & NSITEB,NSTATB
9934
9935 NTARG = ABS(NIDX)
9936 IF (XSFRAC.LE.0.0D0) THEN
9937 ILO = MIN(NSITEB-1,INT(BLO/BSTEP(NTARG)))
9938 IHI = MIN(NSITEB-1,INT(BHI/BSTEP(NTARG)))
9939 IF (ILO.GE.IHI) THEN
9940 XSFRAC = 0.0D0
9941 RETURN
9942 ENDIF
9943 IF (ILO.EQ.NSITEB-1) THEN
9944 FRCLO = BSITE(0,1,NTARG,NSITEB)
9945 ELSE
9946 FRCLO = BSITE(0,1,NTARG,ILO+1)
9947 & +(BLO-ILO*BSTEP(NTARG))/BSTEP(NTARG)
9948 & *(BSITE(0,1,NTARG,ILO+2)-BSITE(0,1,NTARG,ILO+1))
9949 ENDIF
9950 IF (IHI.EQ.NSITEB-1) THEN
9951 FRCHI = BSITE(0,1,NTARG,NSITEB)
9952 ELSE
9953 FRCHI = BSITE(0,1,NTARG,IHI+1)
9954 & +(BHI-IHI*BSTEP(NTARG))/BSTEP(NTARG)
9955 & *(BSITE(0,1,NTARG,IHI+2)-BSITE(0,1,NTARG,IHI+1))
9956 ENDIF
9957 XSFRAC = FRCHI-FRCLO
9958 ELSE
9959 BLO = 0.0D0
9960 BHI = BMAX(NTARG)
9961 DO 1 I=1,NSITEB-1
9962 IF (XSFRAC.LT.BSITE(0,1,NTARG,I+1)) THEN
9963 FAC = (XSFRAC -BSITE(0,1,NTARG,I))/
9964 & (BSITE(0,1,NTARG,I+1)-BSITE(0,1,NTARG,I))
9965 BHI = DBLE(I-1)*BSTEP(NTARG)+BSTEP(NTARG)*FAC
9966 GOTO 2
9967 ENDIF
9968 1 CONTINUE
9969 2 CONTINUE
9970 ENDIF
9971
9972 RETURN
9973 END
9974
9975*$ CREATE DT_CONUCL.FOR
9976*COPY DT_CONUCL
9977*
9978*===conucl=============================================================*
9979*
9980 SUBROUTINE DT_CONUCL(X,N,R,MODE)
9981
9982************************************************************************
9983* Calculation of coordinates of nucleons within nuclei. *
9984* X(3,N) spatial coordinates of nucleons (in fm) (output) *
9985* N / R number of nucleons / radius of nucleus (input) *
9986* MODE = 0 coordinates not sorted *
9987* = 1 coordinates sorted with increasing X(3,i) *
9988* = 2 coordinates sorted with decreasing X(3,i) *
9989* This version dated 26.10.95 is revised by S. Roesler *
9990************************************************************************
9991
9992 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9993 SAVE
9994 PARAMETER ( LINP = 10 ,
9995 & LOUT = 6 ,
9996 & LDAT = 9 )
9997
9998 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
9999 & ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10000
10001 PARAMETER (TWOPI = 6.283185307179586454D+00 )
10002
10003 PARAMETER (NSRT=10)
10004 DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10005 DIMENSION X(3,N),XTMP(3,260)
10006
10007 CALL DT_COORDI(XTMP,IDXSRT,ICSRT,N,R)
10008
10009 IF ((MODE.NE.0).AND.(N.GT.4)) THEN
10010 K = 0
10011 DO 1 I=1,NSRT
10012 IF (MODE.EQ.2) THEN
10013 ISRT = NSRT+1-I
10014 ELSE
10015 ISRT = I
10016 ENDIF
10017 K1 = K
10018 DO 2 J=1,ICSRT(ISRT)
10019 K = K+1
10020 X(1,K) = XTMP(1,IDXSRT(ISRT,J))
10021 X(2,K) = XTMP(2,IDXSRT(ISRT,J))
10022 X(3,K) = XTMP(3,IDXSRT(ISRT,J))
10023 2 CONTINUE
10024 IF (ICSRT(ISRT).GT.1) THEN
10025 I0 = K1+1
10026 I1 = K
10027 CALL DT_SORT(X,N,I0,I1,MODE)
10028 ENDIF
10029 1 CONTINUE
10030 ELSEIF ((MODE.NE.0).AND.(N.GE.2).AND.(N.LE.4)) THEN
10031 DO 3 I=1,N
10032 X(1,I) = XTMP(1,I)
10033 X(2,I) = XTMP(2,I)
10034 X(3,I) = XTMP(3,I)
10035 3 CONTINUE
10036 CALL DT_SORT(X,N,1,N,MODE)
10037 ELSE
10038 DO 4 I=1,N
10039 X(1,I) = XTMP(1,I)
10040 X(2,I) = XTMP(2,I)
10041 X(3,I) = XTMP(3,I)
10042 4 CONTINUE
10043 ENDIF
10044
10045 RETURN
10046 END
10047
10048*$ CREATE DT_COORDI.FOR
10049*COPY DT_COORDI
10050*
10051*===coordi=============================================================*
10052*
10053 SUBROUTINE DT_COORDI(X,IDXSRT,ICSRT,N,R)
10054
10055************************************************************************
10056* Calculation of coordinates of nucleons within nuclei. *
10057* X(3,N) spatial coordinates of nucleons (in fm) (output) *
10058* N / R number of nucleons / radius of nucleus (input) *
10059* Based on the original version by Shmakov et al. *
10060* This version dated 26.10.95 is revised by S. Roesler *
10061************************************************************************
10062
10063 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10064 SAVE
10065 PARAMETER ( LINP = 10 ,
10066 & LOUT = 6 ,
10067 & LDAT = 9 )
10068
10069 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10070 & ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10071
10072 PARAMETER (TWOPI = 6.283185307179586454D+00 )
10073
10074 LOGICAL LSTART
10075
10076 PARAMETER (NSRT=10)
10077 DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10078 DIMENSION X(3,260),WD(4),RD(3)
10079
10080 DATA PDIF/0.545D0/,R2MIN/0.16D0/
10081 DATA WD / 0.0D0, 0.178D0, 0.465D0, 1.0D0/
10082 DATA RD /2.09D0, 0.935D0, 0.697D0/
10083
10084 X1SUM = ZERO
10085 X2SUM = ZERO
10086 X3SUM = ZERO
10087
10088 IF (N.EQ.1) THEN
10089 X(1,1) = ZERO
10090 X(2,1) = ZERO
10091 X(3,1) = ZERO
10092 ELSEIF (N.EQ.2) THEN
10093 EPS = DT_RNDM(RD(1))
10094 DO 30 I=1,3
10095 IF ((EPS.GE.WD(I)).AND.(EPS.LE.WD(I+1))) GOTO 40
10096 30 CONTINUE
10097 40 CONTINUE
10098 DO 50 J=1,3
10099 CALL DT_RANNOR(X1,X2)
10100 X(J,1) = RD(I)*X1
10101 X(J,2) = -X(J,1)
10102 50 CONTINUE
10103 ELSEIF ((N.EQ.3).OR.(N.EQ.4)) THEN
10104 SIGMA = R/SQRTWO
10105 LSTART = .TRUE.
10106 CALL DT_RANNOR(X3,X4)
10107 DO 100 I=1,N
10108 CALL DT_RANNOR(X1,X2)
10109 X(1,I) = SIGMA*X1
10110 X(2,I) = SIGMA*X2
10111 IF (LSTART) GOTO 80
10112 X(3,I) = SIGMA*X4
10113 CALL DT_RANNOR(X3,X4)
10114 GOTO 90
10115 80 CONTINUE
10116 X(3,I) = SIGMA*X3
10117 90 CONTINUE
10118 LSTART = .NOT.LSTART
10119 X1SUM = X1SUM+X(1,I)
10120 X2SUM = X2SUM+X(2,I)
10121 X3SUM = X3SUM+X(3,I)
10122 100 CONTINUE
10123 X1SUM = X1SUM/DBLE(N)
10124 X2SUM = X2SUM/DBLE(N)
10125 X3SUM = X3SUM/DBLE(N)
10126 DO 101 I=1,N
10127 X(1,I) = X(1,I)-X1SUM
10128 X(2,I) = X(2,I)-X2SUM
10129 X(3,I) = X(3,I)-X3SUM
10130 101 CONTINUE
10131 ELSE
10132
10133* maximum nuclear radius for coordinate sampling
10134 RMAX = R+4.605D0*PDIF
10135
10136* initialize pre-sorting
10137 DO 121 I=1,NSRT
10138 ICSRT(I) = 0
10139 121 CONTINUE
10140 DR = TWO*RMAX/DBLE(NSRT)
10141
10142* sample coordinates for N nucleons
10143 DO 140 I=1,N
10144 120 CONTINUE
10145 RAD = RMAX*(DT_RNDM(DR))**ONETHI
10146 F = DT_DENSIT(N,RAD,R)
10147 IF (DT_RNDM(RAD).GT.F) GOTO 120
10148* theta, phi uniformly distributed
10149 CT = ONE-TWO*DT_RNDM(F)
10150 ST = SQRT((ONE-CT)*(ONE+CT))
10151 CALL DT_DSFECF(SFE,CFE)
10152 X(1,I) = RAD*ST*CFE
10153 X(2,I) = RAD*ST*SFE
10154 X(3,I) = RAD*CT
10155* ensure that distance between two nucleons is greater than R2MIN
10156 IF (I.LT.2) GOTO 122
10157 I1 = I-1
10158 DO 130 I2=1,I1
10159 DIST2 = (X(1,I)-X(1,I2))**2+(X(2,I)-X(2,I2))**2+
10160 & (X(3,I)-X(3,I2))**2
10161 IF (DIST2.LE.R2MIN) GOTO 120
10162 130 CONTINUE
10163 122 CONTINUE
10164* save index according to z-bin
10165 IDXZ = INT( (X(3,I)+RMAX)/DR )+1
10166 ICSRT(IDXZ) = ICSRT(IDXZ)+1
10167 IDXSRT(IDXZ,ICSRT(IDXZ)) = I
10168 X1SUM = X1SUM+X(1,I)
10169 X2SUM = X2SUM+X(2,I)
10170 X3SUM = X3SUM+X(3,I)
10171 140 CONTINUE
10172 X1SUM = X1SUM/DBLE(N)
10173 X2SUM = X2SUM/DBLE(N)
10174 X3SUM = X3SUM/DBLE(N)
10175 DO 141 I=1,N
10176 X(1,I) = X(1,I)-X1SUM
10177 X(2,I) = X(2,I)-X2SUM
10178 X(3,I) = X(3,I)-X3SUM
10179 141 CONTINUE
10180
10181 ENDIF
10182
10183 RETURN
10184 END
10185
10186*$ CREATE DT_DENSIT.FOR
10187*COPY DT_DENSIT
10188*
10189*===densit=============================================================*
10190*
10191 DOUBLE PRECISION FUNCTION DT_DENSIT(NA,R,RA)
10192
10193 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10194 SAVE
10195
10196 PARAMETER ( LINP = 10 ,
10197 & LOUT = 6 ,
10198 & LDAT = 9 )
10199 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10200 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
10201 & PI = TWOPI/TWO)
10202
10203 DIMENSION R0(18),FNORM(18)
10204 DATA R0 / ZERO, ZERO, ZERO, ZERO, 2.12D0,
10205 & 2.56D0, 2.41D0, 2.46D0, 2.52D0, 2.45D0,
10206 & 2.37D0, 2.46D0, 2.44D0, 2.54D0, 2.58D0,
10207 & 2.72D0, 2.66D0, 2.79D0/
10208 DATA FNORM /.1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10209 & .1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10210 & .1012D+01,.1039D+01,.1075D+01,.1118D+01,.1164D+01,
10211 & .1214D+01,.1265D+01,.1318D+01/
10212 DATA PDIF /0.545D0/
10213
10214 DT_DENSIT = ZERO
10215* shell model
10216 IF (NA.LE.4) THEN
10217 STOP 'DT_DENSIT-0'
10218 ELSEIF ((NA.GT.4).AND.(NA.LE.18)) THEN
10219 R1 = R0(NA)/SQRT(2.5D0-4.0D0/DBLE(NA))
10220 DT_DENSIT = (ONE+(DBLE(NA)-4.0D0)/6.0D0*(R/R1)**2)
10221 & *EXP(-(R/R1)**2)/FNORM(NA)
10222* Woods-Saxon
10223 ELSEIF (NA.GT.18) THEN
10224 DT_DENSIT = ONE/(ONE+EXP((R-RA)/PDIF))
10225 ENDIF
10226
10227 RETURN
10228 END
10229
10230*$ CREATE DT_RNCLUS.FOR
10231*COPY DT_RNCLUS
10232*
10233*===rnclus=============================================================*
10234*
10235 DOUBLE PRECISION FUNCTION DT_RNCLUS(N)
10236
10237************************************************************************
10238* Nuclear radius for nucleus with mass number N. *
10239* This version dated 26.9.00 is written by S. Roesler *
10240************************************************************************
10241
10242 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10243 SAVE
10244
10245 PARAMETER (ONE=1.0D0,THREE=3.0D0,ONETHI=ONE/THREE)
10246
10247* nucleon radius
10248 PARAMETER (RNUCLE = 1.12D0)
10249
10250* nuclear radii for selected nuclei
10251 DIMENSION RADNUC(18)
10252 DATA RADNUC / 8*0.0D0,2.52D0,2.45D0,2.37D0,2.45D0,2.44D0,2.55D0,
10253 & 2.58D0,2.71D0,2.66D0,2.71D0/
10254
10255 IF (N.LE.18) THEN
10256 IF (RADNUC(N).GT.0.0D0) THEN
10257 DT_RNCLUS = RADNUC(N)
10258 ELSE
10259 DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10260 ENDIF
10261 ELSE
10262 DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10263 ENDIF
10264
10265 RETURN
10266 END
10267
10268*$ CREATE DT_DENTST.FOR
10269*COPY DT_DENTST
10270*
10271*===dentst=============================================================*
10272*
10273C PROGRAM DT_DENTST
10274 SUBROUTINE DT_DENTST
10275
10276 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10277 SAVE
10278
10279 OPEN(40,FILE='dentst.out',STATUS='UNKNOWN')
10280 OPEN(41,FILE='denmax.out',STATUS='UNKNOWN')
10281
10282 RMIN = 0.0D0
10283 RMAX = 8.0D0
10284 NBINS = 500.0D0
10285 DR = (RMAX-RMIN)/DBLE(NBINS)
10286 DO 1 IA=5,18
10287 FMAX = 0.0D0
10288 DO 2 IR=1,NBINS+1
10289 R = RMIN+DBLE(IR-1)*DR
10290 F = DT_DENSIT(IA,R,R)
10291 IF (F.GT.FMAX) FMAX = F
10292 WRITE(40,'(1X,I3,2E15.5)') IA,R,F
10293 2 CONTINUE
10294 WRITE(41,'(1X,I3,E15.5)') IA,FMAX
10295 1 CONTINUE
10296
10297 CLOSE(40)
10298 CLOSE(41)
10299
10300 END
10301
10302*$ CREATE DT_SHMAKI.FOR
10303*COPY DT_SHMAKI
10304*
10305*===shmaki=============================================================*
10306*
10307 SUBROUTINE DT_SHMAKI(NA,NCA,NB,NCB,IJP,PPN,MODE)
10308
10309************************************************************************
10310* Initialisation of Glauber formalism. This subroutine has to be *
10311* called once (in case of target emulsions as often as many different *
10312* target nuclei are considered) before events are sampled. *
10313* NA / NCA mass number/charge of projectile nucleus *
10314* NB / NCB mass number/charge of target nucleus *
10315* IJP identity of projectile (hadrons/leptons/photons) *
10316* PPN projectile momentum (for projectile nuclei: *
10317* momentum per nucleon) in target rest system *
10318* MODE = 0 Glauber formalism invoked *
10319* = 1 fitted results are loaded from data-file *
10320* = 99 NTARG is forced to be 1 *
10321* (used in connection with GLAUBERI-card only) *
10322* This version dated 22.03.96 is based on the original SHMAKI-routine *
10323* and revised by S. Roesler. *
10324************************************************************************
10325
10326 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10327 SAVE
10328 PARAMETER ( LINP = 10 ,
10329 & LOUT = 6 ,
10330 & LDAT = 9 )
10331 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
10332 & THREE=3.0D0)
10333
10334 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10335* Glauber formalism: parameters
10336 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10337 & BMAX(NCOMPX),BSTEP(NCOMPX),
10338 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10339 & NSITEB,NSTATB
10340* Lorentz-parameters of the current interaction
10341 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10342 & UMO,PPCM,EPROJ,PPROJ
10343* properties of photon/lepton projectiles
10344 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10345* kinematical cuts for lepton-nucleus interactions
10346 COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
10347 & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
10348* Glauber formalism: cross sections
10349 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10350 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10351 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10352 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10353 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10354 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10355 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10356 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10357 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10358 & BSLOPE,NEBINI,NQBINI
10359* cuts for variable energy runs
10360 COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
10361* nucleon-nucleon event-generator
10362 CHARACTER*8 CMODEL
10363 LOGICAL LPHOIN
10364 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10365* Glauber formalism: flags and parameters for statistics
10366 LOGICAL LPROD
10367 CHARACTER*8 CGLB
10368 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10369
10370 DATA NTARG,ICOUT,IVEOUT /0,0,0/
10371
10372C CALL DT_HISHAD
10373C STOP
10374
10375 NTARG = NTARG+1
10376 IF (MODE.EQ.99) NTARG = 1
10377 NIDX = -NTARG
10378 IF (MODE.EQ.-1) NIDX = NTARG
10379
10380 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) ICOUT = ICOUT+1
10381 IF (ICOUT.EQ.1) WRITE(LOUT,1000)
10382 1000 FORMAT(//,1X,'SHMAKI: Glauber formalism (Shmakov et. al) -',
10383 & ' initialization',/,12X,'--------------------------',
10384 & '-------------------------',/)
10385
10386 IF (MODE.EQ.2) THEN
10387 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10388 CALL DT_SHFAST(MODE,PPN,IBACK)
10389 STOP ' Glauber pre-initialization done'
10390 ENDIF
10391 IF (MODE.EQ.1) THEN
10392 CALL DT_PROFBI(NA,NB,PPN,NTARG)
10393 ELSE
10394 IBACK = 1
10395 IF (MODE.EQ.3) CALL DT_SHFAST(MODE,PPN,IBACK)
10396 IF (IBACK.EQ.1) THEN
10397* lepton-nucleus (variable energy runs)
10398 IF ((IJP.EQ. 3).OR.(IJP.EQ. 4).OR.
10399 & (IJP.EQ.10).OR.(IJP.EQ.11)) THEN
10400 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10401 & WRITE(LOUT,1002) NB,NCB
10402 1002 FORMAT(1X,'variable energy run: projectile-id: 7',
10403 & ' target A/Z: ',I3,' /',I3,/,/,8X,
10404 & 'E_cm (GeV) Q^2 (GeV^2)',
10405 & ' Sigma_tot (mb) Sigma_in (mb)',/,7X,
10406 & '--------------------------------',
10407 & '------------------------------')
10408 AECMLO = LOG10(MIN(UMO,ECMLI))
10409 AECMHI = LOG10(MIN(UMO,ECMHI))
10410 IESTEP = NEB-1
10411 DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
10412 IF (AECMLO.EQ.AECMHI) IESTEP = 0
10413 DO 1 I=1,IESTEP+1
10414 ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10415 IF (Q2HI.GT.0.1D0) THEN
10416 IF (Q2LI.LT.0.01D0) THEN
10417 CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10418 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10419 & WRITE(LOUT,1003)
10420 & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10421 Q2LI = 0.01D0
10422 IBIN = 2
10423 ELSE
10424 IBIN = 1
10425 ENDIF
10426 IQSTEP = NQB-IBIN
10427 AQ2LO = LOG10(Q2LI)
10428 AQ2HI = LOG10(Q2HI)
10429 DAQ2 = (AQ2HI-AQ2LO)/MAX(DBLE(IQSTEP),ONE)
10430 DO 2 J=IBIN,IQSTEP+IBIN
10431 Q2 = 10.0D0**(AQ2LO+DBLE(J-IBIN)*DAQ2)
10432 CALL DT_XSGLAU(NA,NB,7,ZERO,Q2,ECM,I,J,NIDX)
10433 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10434 & WRITE(LOUT,1003) ECMNN(I),
10435 & Q2G(J),XSTOT(I,J,NTARG),XSPRO(I,J,NTARG)
10436 2 CONTINUE
10437 ELSE
10438 CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10439 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10440 & WRITE(LOUT,1003)
10441 & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10442 ENDIF
10443 1003 FORMAT(9X,F6.1,9X,F6.2,8X,F8.3,11X,F8.3)
10444 1 CONTINUE
10445 IVEOUT = 1
10446 ELSE
10447* hadron/photon/nucleus-nucleus
10448 IF ((ABS(VAREHI).GT.ZERO).AND.
10449 & (ABS(VAREHI).GT.ABS(VARELO))) THEN
10450 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) THEN
10451 WRITE(LOUT,1004) NA,NB,NCB
10452 1004 FORMAT(1X,'variable energy run: projectile-id:',
10453 & I3,' target A/Z: ',I3,' /',I3,/)
10454 WRITE(LOUT,1005)
10455 1005 FORMAT(' E_cm (GeV) E_Lab (GeV) sig_tot^pp (mb)'
10456 & ,' Sigma_tot (mb) Sigma_prod (mb)',/,
10457 & ' -------------------------------------',
10458 & '--------------------------------------')
10459 ENDIF
10460 AECMLO = LOG10(VARCLO)
10461 AECMHI = LOG10(VARCHI)
10462 IESTEP = NEB-1
10463 DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
10464 IF (AECMLO.EQ.AECMHI) IESTEP = 0
10465 DO 3 I=1,IESTEP+1
10466 ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10467 AMP = 0.938D0
10468 AMT = 0.938D0
10469 AMP2 = AMP**2
10470 AMT2 = AMT**2
10471 ELAB = (ECM**2-AMP2-AMT2)/(TWO*AMT)
10472 PLAB = SQRT((ELAB+AMP)*(ELAB-AMP))
10473 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,ECM,I,1,NIDX)
10474 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10475 & WRITE(LOUT,1006)
10476 & ECM,PLAB,SIGSH,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10477 1006 FORMAT(1X,F9.1,1X,E11.3,1X,F12.2,8X,F10.3,8X,F8.3)
10478 3 CONTINUE
10479 IVEOUT = 1
10480 ELSE
10481 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10482 ENDIF
10483 ENDIF
10484 ENDIF
10485 ENDIF
10486
10487 IF ((ICOUT.LT.15).AND.(IVEOUT.EQ.0).AND.(MCGENE.NE.4).AND.
10488 & (IOGLB.NE.100)) THEN
10489 WRITE(LOUT,1001) NA,NCA,NB,NCB,ECMNN(1),SIGSH*10.0D0,ROSH,
10490 & BSLOPE,NSITEB,NSTATB,XSPRO(1,1,NTARG)
10491 1001 FORMAT(38X,'projectile',
10492 & ' target',/,1X,'Mass number / charge',
10493 & 17X,I3,' /',I3,6X,I3,' /',I3,/,/,1X,
10494 & 'Nucleon-nucleon c.m. energy',9X,F10.2,' GeV',/,/,1X,
10495 & 'Parameters of elastic scattering amplitude:',/,5X,
10496 & 'sigma =',F7.2,' mb',6X,'rho = ',F9.4,6X,'slope = ',
10497 & F4.1,' GeV^-2',/,/,1X,'Number of b-steps',4X,I3,8X,
10498 & 'statistics at each b-step',4X,I5,/,/,1X,
10499 & 'Prod. cross section ',5X,F10.4,' mb',/)
10500 ENDIF
10501
10502 RETURN
10503 END
10504
10505*$ CREATE DT_PROFBI.FOR
10506*COPY DT_PROFBI
10507*
10508*===profbi=============================================================*
10509*
10510 SUBROUTINE DT_PROFBI(NA,NB,PPN,NTARG)
10511
10512************************************************************************
10513* Integral over profile function (to be used for impact-parameter *
10514* sampling during event generation). *
10515* Fitted results are used. *
10516* NA / NB mass numbers of proj./target nuclei *
10517* PPN projectile momentum (for projectile nuclei: *
10518* momentum per nucleon) in target rest system *
10519* NTARG index of target material (i.e. kind of nucleus) *
10520* This version dated 31.05.95 is revised by S. Roesler *
10521************************************************************************
10522
10523 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10524 SAVE
10525 PARAMETER ( LINP = 10 ,
10526 & LOUT = 6 ,
10527 & LDAT = 9 )
454792a9 10528CPH SAVE
9aaba0d6 10529
10530 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
10531
10532 LOGICAL LSTART
10533 CHARACTER CNAME*80
10534
10535 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10536* Glauber formalism: parameters
10537 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10538 & BMAX(NCOMPX),BSTEP(NCOMPX),
10539 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10540 & NSITEB,NSTATB
10541* Glauber formalism: cross sections
10542 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10543 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10544 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10545 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10546 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10547 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10548 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10549 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10550 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10551 & BSLOPE,NEBINI,NQBINI
10552
10553 PARAMETER (NGLMAX=8000)
10554 DIMENSION NGLIT(NGLMAX),NGLIP(NGLMAX),GLAPPN(NGLMAX),
10555 & GLASIG(NGLMAX),GLAFIT(5,NGLMAX)
10556
10557 DATA LSTART /.TRUE./
10558
10559 IF (LSTART) THEN
10560* read fit-parameters from file
10561 OPEN(47,FILE='inpdata/glpara.dat',STATUS='UNKNOWN')
10562 I = 0
10563 1 CONTINUE
10564 READ(47,'(A80)') CNAME
10565 IF (CNAME.EQ.'STOP') GOTO 2
10566 I = I+1
10567 READ(CNAME,*) NGLIP(I),NGLIT(I),GLAPPN(I),GLASIG(I),
10568 & GLAFIT(1,I),GLAFIT(2,I),GLAFIT(3,I),
10569 & GLAFIT(4,I),GLAFIT(5,I)
10570 IF (I+1.GT.NGLMAX) THEN
10571 WRITE(LOUT,1000)
10572 1000 FORMAT(1X,'PROFBI: warning! array size exceeded - ',
10573 & 'program stopped')
10574 STOP
10575 ENDIF
10576 GOTO 1
10577 2 CONTINUE
10578 NGLPAR = I
10579 LSTART = .FALSE.
10580 ENDIF
10581
10582 NNA = NA
10583 NNB = NB
10584 IF (NA.GT.NB) THEN
10585 NNA = NB
10586 NNB = NA
10587 ENDIF
10588 IDXGLA = 0
10589 DO 3 J=1,NGLPAR
10590 IF ((NNB.LT.NGLIT(J)).OR.(J.EQ.NGLPAR)) THEN
10591 IF (NNB.NE.NGLIT(J-1)) NNB = NGLIT(J-1)
10592 DO 4 K=1,J-1
10593 IPOINT = J-K
10594 IF (J.EQ.NGLPAR) IPOINT = J+1-K
10595 IF ((NNA.GT.NGLIP(IPOINT)).OR.
10596 & (NNB.NE.NGLIT(IPOINT)).OR.(IPOINT.EQ.1)) THEN
10597 IF (IPOINT.EQ.1) IPOINT = 0
10598 NATMP = NGLIP(IPOINT+1)
10599 IF (PPN.LT.GLAPPN(IPOINT+1)) THEN
10600 IDXGLA = IPOINT+1
10601 GOTO 6
10602 ELSE
10603 J1BEG = IPOINT+1
10604 J1END = J
10605C IF (J.EQ.NGLPAR) THEN
10606C J1BEG = IPOINT
10607C J1END = J
10608C ENDIF
10609 DO 5 J1=J1BEG,J1END
10610 IF (NGLIP(J1).EQ.NATMP) THEN
10611 IF (PPN.LT.GLAPPN(J1)) THEN
10612 IDXGLA = J1
10613 GOTO 6
10614 ENDIF
10615 ELSE
10616 IDXGLA = J1-1
10617 GOTO 6
10618 ENDIF
10619 5 CONTINUE
10620 IF ((J.EQ.NGLPAR).AND.(PPN.GT.GLAPPN(NGLPAR)))
10621 & IDXGLA = NGLPAR
10622 ENDIF
10623 ENDIF
10624 4 CONTINUE
10625 ENDIF
10626 3 CONTINUE
10627
10628 6 CONTINUE
10629 IF (IDXGLA.EQ.0) THEN
10630 WRITE(LOUT,1001) NNA,NNB,PPN
10631 1001 FORMAT(1X,'PROFBI: configuration (NA,NB,PPN = ',
10632 & 2I4,F6.0,') not found ')
10633 STOP
10634 ENDIF
10635
10636* no interpolation yet available
10637 XSPRO(1,1,NTARG) = GLASIG(IDXGLA)
10638
10639 BSITE(1,1,NTARG,1) = ZERO
10640 DO 10 I=2,NSITEB
10641 XX = DBLE(I)
10642 POLY = GLAFIT(1,IDXGLA)+GLAFIT(2,IDXGLA)*XX+
10643 & GLAFIT(3,IDXGLA)*XX**2+GLAFIT(4,IDXGLA)*XX**3+
10644 & GLAFIT(5,IDXGLA)*XX**4
10645 IF (ABS(POLY).GT.35.0D0) POLY = SIGN(35.0D0,POLY)
10646 BSITE(1,1,NTARG,I) = (1.0D0-EXP(-POLY))
10647 IF (BSITE(1,1,NTARG,I).LT.ZERO) BSITE(1,1,NTARG,I) = ZERO
10648 10 CONTINUE
10649
10650 RETURN
10651 END
10652
10653*$ CREATE DT_GLAUBE.FOR
10654*COPY DT_GLAUBE
10655*
10656*===glaube=============================================================*
10657*
10658 SUBROUTINE DT_GLAUBE(NA,NB,IJPROJ,B,INTT,INTA,INTB,JS,JT,NIDX)
10659
10660************************************************************************
10661* Calculation of configuartion of interacting nucleons for one event. *
10662* NB / NB mass numbers of proj./target nuclei (input) *
10663* B impact parameter (output) *
10664* INTT total number of wounded nucleons " *
10665* INTA / INTB number of wounded nucleons in proj. / target " *
10666* JS / JT(i) number of collisions proj. / target nucleon i is *
10667* involved (output) *
10668* NIDX index of projectile/target material (input) *
10669* = -2 call within FLUKA transport calculation *
10670* This is an update of the original routine SHMAKO by J.Ranft/HJM *
10671* This version dated 22.03.96 is revised by S. Roesler *
10672* *
10673* Last change 27.12.2006 by S. Roesler. *
10674************************************************************************
10675
10676 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10677 SAVE
10678 PARAMETER ( LINP = 10 ,
10679 & LOUT = 6 ,
10680 & LDAT = 9 )
10681 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
10682 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
10683
10684 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10685 PARAMETER ( MAXNCL = 260,
10686 & MAXVQU = MAXNCL,
10687 & MAXSQU = 20*MAXVQU,
10688 & MAXINT = MAXVQU+MAXSQU)
10689* Glauber formalism: parameters
10690 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10691 & BMAX(NCOMPX),BSTEP(NCOMPX),
10692 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10693 & NSITEB,NSTATB
10694* Glauber formalism: cross sections
10695 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10696 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10697 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10698 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10699 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10700 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10701 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10702 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10703 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10704 & BSLOPE,NEBINI,NQBINI
10705* Lorentz-parameters of the current interaction
10706 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10707 & UMO,PPCM,EPROJ,PPROJ
10708* properties of photon/lepton projectiles
10709 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10710* Glauber formalism: collision properties
10711 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
10712 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
10713* Glauber formalism: flags and parameters for statistics
10714 LOGICAL LPROD
10715 CHARACTER*8 CGLB
10716 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10717
10718 DIMENSION JS(MAXNCL),JT(MAXNCL)
10719
10720 NTARG = ABS(NIDX)
10721
10722* get actual energy from /DTLTRA/
10723 ECMNOW = UMO
10724 Q2 = VIRT
10725*
10726* new patch for pre-initialized variable projectile/target/energy runs,
10727* bypassed for use within FLUKA (Nidx=-2)
10728 IF (IOGLB.EQ.100) THEN
10729 IF (NIDX.NE.-2) CALL DT_GLBSET(IJPROJ,NA,NB,EPROJ,1)
10730*
10731* variable energy run, interpolate profile function
10732 ELSE
10733 I1 = 1
10734 I2 = 1
10735 RATE = ONE
10736 IF (NEBINI.GT.1) THEN
10737 IF (ECMNOW.GE.ECMNN(NEBINI)) THEN
10738 I1 = NEBINI
10739 I2 = NEBINI
10740 RATE = ONE
10741 ELSEIF (ECMNOW.GT.ECMNN(1)) THEN
10742 DO 1 I=2,NEBINI
10743 IF (ECMNOW.LT.ECMNN(I)) THEN
10744 I1 = I-1
10745 I2 = I
10746 RATE = (ECMNOW-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
10747 GOTO 2
10748 ENDIF
10749 1 CONTINUE
10750 2 CONTINUE
10751 ENDIF
10752 ENDIF
10753 J1 = 1
10754 J2 = 1
10755 RATQ = ONE
10756 IF (NQBINI.GT.1) THEN
10757 IF (Q2.GE.Q2G(NQBINI)) THEN
10758 J1 = NQBINI
10759 J2 = NQBINI
10760 RATQ = ONE
10761 ELSEIF (Q2.GT.Q2G(1)) THEN
10762 DO 3 I=2,NQBINI
10763 IF (Q2.LT.Q2G(I)) THEN
10764 J1 = I-1
10765 J2 = I
10766 RATQ = LOG10( Q2/MAX(Q2G(J1),TINY14))/
10767 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
10768C RATQ = (Q2-Q2G(J1))/(Q2G(J2)-Q2G(J1))
10769 GOTO 4
10770 ENDIF
10771 3 CONTINUE
10772 4 CONTINUE
10773 ENDIF
10774 ENDIF
10775
10776 DO 5 I=1,KSITEB
10777 BSITE(0,1,NTARG,I) = BSITE(I1,J1,NTARG,I)+
10778 & RATE*(BSITE(I2,J1,NTARG,I)-BSITE(I1,J1,NTARG,I))+
10779 & RATQ*(BSITE(I1,J2,NTARG,I)-BSITE(I1,J1,NTARG,I))+
10780 & RATE*RATQ*(BSITE(I2,J2,NTARG,I)-BSITE(I1,J2,NTARG,I)+
10781 & BSITE(I1,J1,NTARG,I)-BSITE(I2,J1,NTARG,I))
10782 5 CONTINUE
10783 ENDIF
10784
10785 CALL DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,INTT,INTA,INTB,IDIREC,NIDX)
10786 IF (NIDX.LE.-1) THEN
10787 RPROJ = RASH(1)
10788 RTARG = RBSH(NTARG)
10789 ELSE
10790 RPROJ = RASH(NTARG)
10791 RTARG = RBSH(1)
10792 ENDIF
10793
10794 RETURN
10795 END
10796
10797*$ CREATE DT_DIAGR.FOR
10798*COPY DT_DIAGR
10799*
10800*===diagr==============================================================*
10801*
10802 SUBROUTINE DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,JNT,INTA,INTB,IDIREC,
10803 & NIDX)
10804
10805************************************************************************
10806* Based on the original version by Shmakov et al. *
10807* This version dated 21.04.95 is revised by S. Roesler *
10808************************************************************************
10809
10810 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10811 SAVE
10812 PARAMETER ( LINP = 10 ,
10813 & LOUT = 6 ,
10814 & LDAT = 9 )
10815 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10816 PARAMETER (TWOPI = 6.283185307179586454D+00,
10817 & PI = TWOPI/TWO,
10818 & GEV2MB = 0.38938D0,
10819 & GEV2FM = 0.1972D0,
10820 & ALPHEM = ONE/137.0D0,
10821* proton mass
10822 & AMP = 0.938D0,
10823 & AMP2 = AMP**2,
10824* rho0 mass
10825 & AMRHO0 = 0.77D0)
10826
10827 COMPLEX*16 C,CA,CI
10828 PARAMETER ( MAXNCL = 260,
10829 & MAXVQU = MAXNCL,
10830 & MAXSQU = 20*MAXVQU,
10831 & MAXINT = MAXVQU+MAXSQU)
10832* particle properties (BAMJET index convention)
10833 CHARACTER*8 ANAME
10834 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
10835 & IICH(210),IIBAR(210),K1(210),K2(210)
10836 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10837* emulsion treatment
10838 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
10839 & NCOMPO,IEMUL
10840* Glauber formalism: parameters
10841 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10842 & BMAX(NCOMPX),BSTEP(NCOMPX),
10843 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10844 & NSITEB,NSTATB
10845* Glauber formalism: cross sections
10846 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10847 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10848 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10849 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10850 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10851 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10852 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10853 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10854 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10855 & BSLOPE,NEBINI,NQBINI
10856* VDM parameter for photon-nucleus interactions
10857 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
10858* nucleon-nucleon event-generator
10859 CHARACTER*8 CMODEL
10860 LOGICAL LPHOIN
10861 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10862**PHOJET105a
10863C COMMON /CUTOFF/ PTCUT(4),CUTMU(4),FPS(4),FPH(4),PSOMIN,XSOMIN
10864**PHOJET112
10865C obsolete cut-off information
10866 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
10867 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
10868**
10869* coordinates of nucleons
10870 COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
10871* interface between Glauber formalism and DPM
10872 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
10873 & INTER1(MAXINT),INTER2(MAXINT)
10874* statistics: Glauber-formalism
10875 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
10876* n-n cross section fluctuations
10877 PARAMETER (NBINS = 1000)
10878 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
10879
10880 DIMENSION JS(MAXNCL),JT(MAXNCL),
10881 & JS0(MAXNCL),JT0(MAXNCL,MAXNCL),
10882 & JI1(MAXNCL,MAXNCL),JI2(MAXNCL,MAXNCL),JNT0(MAXNCL)
10883 DIMENSION NWA(0:210),NWB(0:210)
10884
10885 LOGICAL LFIRST
10886 DATA LFIRST /.TRUE./
10887
10888 DATA NTARGO,ICNT /0,0/
10889
10890 NTARG = ABS(NIDX)
10891
10892 IF (LFIRST) THEN
10893 LFIRST = .FALSE.
10894 IF (NCOMPO.EQ.0) THEN
10895 NCALL = 0
10896 NWAMAX = NA
10897 NWBMAX = NB
10898 DO 17 I=0,210
10899 NWA(I) = 0
10900 NWB(I) = 0
10901 17 CONTINUE
10902 ENDIF
10903 ENDIF
10904 IF (NTARG.EQ.-1) THEN
10905 IF (NCOMPO.EQ.0) THEN
10906 WRITE(LOUT,*) ' DIAGR: distribution of wounded nucleons'
10907 WRITE(LOUT,'(8X,A,3I7)') 'NCALL,NWAMAX,NWBMAX = ',
10908 & NCALL,NWAMAX,NWBMAX
10909 DO 18 I=1,MAX(NWAMAX,NWBMAX)
10910 WRITE(LOUT,'(8X,2I7,E12.4,I7,E12.4)')
10911 & I,NWA(I),DBLE(NWA(I))/DBLE(NCALL),
10912 & NWB(I),DBLE(NWB(I))/DBLE(NCALL)
10913 18 CONTINUE
10914 ENDIF
10915 RETURN
10916 ENDIF
10917
10918 DCOH = 1.0D10
10919 IPNT = 0
10920
10921 SQ2 = Q2
10922 IF (SQ2.LE.ZERO) SQ2 = 0.0001D0
10923 S = ECMNOW**2
10924 X = SQ2/(S+SQ2-AMP2)
10925 XNU = (S+SQ2-AMP2)/(TWO*AMP)
10926* photon projectiles: recalculate photon-nucleon amplitude
10927 IF (IJPROJ.EQ.7) THEN
10928 15 CONTINUE
10929* VDM assumption: mass of V-meson
10930 AMV2 = DT_SAM2(SQ2,ECMNOW)
10931 AMV = SQRT(AMV2)
10932 IF (AMV.GT.2.0D0*PTCUT(1)) GOTO 15
10933* check for pointlike interaction
10934 CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,1)
10935**sr 27.10.
10936C SIGSH = DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
10937 SIGSH = (ONE-RPNT)*DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
10938**
10939 ROSH = 0.1D0
10940 BSLOPE = 2.0D0*(2.0D0+AMRHO0**2/(AMV2+SQ2)
10941 & +0.25D0*LOG(S/(AMV2+SQ2)))
10942* coherence length
10943 IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+SQ2)*GEV2FM
10944 ELSEIF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
10945 IF (MCGENE.EQ.2) THEN
10946 ZERO1 = ZERO
10947 CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SDUM1,SDUM2,SDUM3,
10948 & BSLOPE,0)
10949 ELSE
10950 BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
10951 ENDIF
10952 IF (ECMNOW.LE.3.0D0) THEN
10953 ROSH = -0.43D0
10954 ELSEIF ((ECMNOW.GT.3.0D0).AND.(ECMNOW.LE.50.D0)) THEN
10955 ROSH = -0.63D0+0.175D0*LOG(ECMNOW)
10956 ELSEIF (ECMNOW.GT.50.0D0) THEN
10957 ROSH = 0.1D0
10958 ENDIF
10959 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
10960 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
10961 IF (MCGENE.EQ.2) THEN
10962 ZERO1 = ZERO
10963 CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SIGSH,SDUM2,SDUM3,
10964 & BDUM,0)
10965 SIGSH = SIGSH/10.0D0
10966 ELSE
10967C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
10968 DUMZER = ZERO
10969 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
10970 SIGSH = SIGSH/10.0D0
10971 ENDIF
10972 ELSE
10973 BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
10974 ROSH = 0.01D0
10975 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
10976 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
10977C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
10978 DUMZER = ZERO
10979 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
10980 SIGSH = SIGSH/10.0D0
10981 ENDIF
10982 GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
10983 GAM = GSH
10984 RCA = GAM*SIGSH/TWOPI
10985 FCA = -ROSH*RCA
10986 CA = DCMPLX(RCA,FCA)
10987 CI = DCMPLX(ONE,ZERO)
10988
10989 16 CONTINUE
10990* impact parameter
10991 IF (MCGENE.NE.3) CALL DT_MODB(B,NIDX)
10992
10993 NTRY = 0
10994 3 CONTINUE
10995 NTRY = NTRY+1
10996* initializations
10997 JNT = 0
10998 DO 1 I=1,NA
10999 JS(I) = 0
11000 1 CONTINUE
11001 DO 2 I=1,NB
11002 JT(I) = 0
11003 2 CONTINUE
11004 IF (IJPROJ.EQ.7) THEN
11005 DO 8 I=1,MAXNCL
11006 JS0(I) = 0
11007 JNT0(I)= 0
11008 DO 9 J=1,NB
11009 JT0(I,J) = 0
11010 9 CONTINUE
11011 8 CONTINUE
11012 ENDIF
11013
11014* nucleon configuration
11015C IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,5).EQ.0)) THEN
11016 IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,1).EQ.0)) THEN
11017C CALL DT_CONUCL(PKOO,NA,RASH,2)
11018C CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),1)
11019 IF (NIDX.LE.-1) THEN
11020 CALL DT_CONUCL(PKOO,NA,RASH(1),0)
11021 CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),0)
11022 ELSE
11023 CALL DT_CONUCL(PKOO,NA,RASH(NTARG),0)
11024 CALL DT_CONUCL(TKOO,NB,RBSH(1),0)
11025 ENDIF
11026 NTARGO = NTARG
11027 ENDIF
11028 ICNT = ICNT+1
11029
11030* LEPTO: pick out one struck nucleon
11031 IF (MCGENE.EQ.3) THEN
11032 JNT = 1
11033 JS(1) = 1
11034 IDX = INT(DT_RNDM(X)*NB)+1
11035 JT(IDX) = 1
11036 B = ZERO
11037 GOTO 19
11038 ENDIF
11039
11040 DO 4 INA=1,NA
11041* cross section fluctuations
11042 AFLUC = ONE
11043 IF (IFLUCT.EQ.1) THEN
11044 IFLUK = INT((DT_RNDM(X)+0.001D0)*1000.0D0)
11045 AFLUC = FLUIXX(IFLUK)
11046 ENDIF
11047 KK1 = 1
11048 KINT = 1
11049 DO 5 INB=1,NB
11050* photon-projectile: check for supression by coherence length
11051 IF (IJPROJ.EQ.7) THEN
11052 IF (ABS(TKOO(3,INB)-TKOO(3,KK1)).GT.DCOH) THEN
11053 KK1 = INB
11054 KINT = KINT+1
11055 ENDIF
11056 ENDIF
11057 QQ1 = B+TKOO(1,INB)-PKOO(1,INA)
11058 QQ2 = TKOO(2,INB)-PKOO(2,INA)
11059 XY = GAM*(QQ1*QQ1+QQ2*QQ2)
11060 IF (XY.LE.15.0D0) THEN
11061 C = CI-CA*AFLUC*EXP(-XY)
11062 AR = DBLE(C)
11063 AI = DIMAG(C)
11064 P = AR*AR+AI*AI
11065 IF (DT_RNDM(XY).GE.P) THEN
11066 JNT = JNT+1
11067 IF (IJPROJ.EQ.7) THEN
11068 JNT0(KINT) = JNT0(KINT)+1
11069 IF (JNT0(KINT).GT.MAXNCL) THEN
11070 WRITE(LOUT,1001) MAXNCL
11071 1001 FORMAT(1X,
11072 & 'DIAGR: no. of requested interactions',
11073 & ' exceeds array dimensions ',I4)
11074 STOP
11075 ENDIF
11076 JS0(KINT) = JS0(KINT)+1
11077 JT0(KINT,INB) = JT0(KINT,INB)+1
11078 JI1(KINT,JNT0(KINT)) = INA
11079 JI2(KINT,JNT0(KINT)) = INB
11080 ELSE
11081 IF (JNT.GT.MAXINT) THEN
11082 WRITE(LOUT,1000) JNT, MAXINT
11083 1000 FORMAT(1X,
11084 & 'DIAGR: no. of requested interactions ('
11085 & ,I4,') exceeds array dimensions (',I4,')')
11086 STOP
11087 ENDIF
11088 JS(INA) = JS(INA)+1
11089 JT(INB) = JT(INB)+1
11090 INTER1(JNT) = INA
11091 INTER2(JNT) = INB
11092 ENDIF
11093 ENDIF
11094 ENDIF
11095 5 CONTINUE
11096 4 CONTINUE
11097
11098 IF (JNT.EQ.0) THEN
11099 IF (NTRY.LT.500) THEN
11100 GOTO 3
11101 ELSE
11102C WRITE(6,*) ' new impact parameter required (old= ',B,')'
11103 GOTO 16
11104 ENDIF
11105 ENDIF
11106
11107 IDIREC = 0
11108 IF (IJPROJ.EQ.7) THEN
11109 K = INT(ONE+DT_RNDM(X)*DBLE(KINT))
11110 10 CONTINUE
11111 IF (JNT0(K).EQ.0) THEN
11112 K = K+1
11113 IF (K.GT.KINT) K = 1
11114 GOTO 10
11115 ENDIF
11116* supress Glauber-cascade by direct photon processes
11117 CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,2)
11118 IF (IPNT.GT.0) THEN
11119 JNT = 1
11120 JS(1) = 1
11121 DO 11 INB=1,NB
11122 JT(INB) = JT0(K,INB)
11123 IF (JT(INB).GT.0) GOTO 12
11124 11 CONTINUE
11125 12 CONTINUE
11126 INTER1(1) = 1
11127 INTER2(1) = INB
11128 IDIREC = IPNT
11129 ELSE
11130 JNT = JNT0(K)
11131 JS(1) = JS0(K)
11132 DO 13 INB=1,NB
11133 JT(INB) = JT0(K,INB)
11134 13 CONTINUE
11135 DO 14 I=1,JNT
11136 INTER1(I) = JI1(K,I)
11137 INTER2(I) = JI2(K,I)
11138 14 CONTINUE
11139 ENDIF
11140 ENDIF
11141
11142 19 CONTINUE
11143 INTA = 0
11144 INTB = 0
11145 DO 6 I=1,NA
11146 IF (JS(I).NE.0) INTA=INTA+1
11147 6 CONTINUE
11148 DO 7 I=1,NB
11149 IF (JT(I).NE.0) INTB=INTB+1
11150 7 CONTINUE
11151 ICWPG = INTA
11152 ICWTG = INTB
11153 ICIG = JNT
11154 IPGLB = IPGLB+INTA
11155 ITGLB = ITGLB+INTB
11156 NGLB = NGLB+1
11157
11158 IF (NCOMPO.EQ.0) THEN
11159 NCALL = NCALL+1
11160 NWA(INTA) = NWA(INTA)+1
11161 NWB(INTB) = NWB(INTB)+1
11162 ENDIF
11163
11164 RETURN
11165 END
11166
11167*$ CREATE DT_MODB.FOR
11168*COPY DT_MODB
11169*
11170*===modb===============================================================*
11171*
11172 SUBROUTINE DT_MODB(B,NIDX)
11173
11174************************************************************************
11175* Sampling of impact parameter of collision. *
11176* B impact parameter (output) *
11177* NIDX index of projectile/target material (input)*
11178* Based on the original version by Shmakov et al. *
11179* This version dated 21.04.95 is revised by S. Roesler *
11180* *
11181* Last change 27.12.2006 by S. Roesler. *
11182************************************************************************
11183
11184 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11185 SAVE
11186 PARAMETER ( LINP = 10 ,
11187 & LOUT = 6 ,
11188 & LDAT = 9 )
11189 PARAMETER (ZERO=0.0D0,TINY15=1.0D-15,ONE=1.0D0,TWO=2.0D0)
11190
11191 LOGICAL LEFT,LFIRST
11192
11193* central particle production, impact parameter biasing
11194 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
11195 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11196* Glauber formalism: parameters
11197 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11198 & BMAX(NCOMPX),BSTEP(NCOMPX),
11199 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11200 & NSITEB,NSTATB
11201* Glauber formalism: cross sections
11202 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11203 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11204 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11205 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11206 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11207 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11208 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11209 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11210 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11211 & BSLOPE,NEBINI,NQBINI
11212
11213 DATA LFIRST /.TRUE./
11214
11215 NTARG = ABS(NIDX)
11216 IF (NIDX.LE.-1) THEN
11217 RA = RASH(1)
11218 RB = RBSH(NTARG)
11219 ELSE
11220 RA = RASH(NTARG)
11221 RB = RBSH(1)
11222 ENDIF
11223
11224 IF (ICENTR.EQ.2) THEN
11225 IF (RA.EQ.RB) THEN
11226 BB = DT_RNDM(B)*(0.3D0*RA)**2
11227 B = SQRT(BB)
11228 ELSEIF(RA.LT.RB)THEN
11229 BB = DT_RNDM(B)*1.4D0*(RB-RA)**2
11230 B = SQRT(BB)
11231 ELSEIF(RA.GT.RB)THEN
11232 BB = DT_RNDM(B)*1.4D0*(RA-RB)**2
11233 B = SQRT(BB)
11234 ENDIF
11235 ELSE
11236 9 CONTINUE
11237 Y = DT_RNDM(BB)
11238 I0 = 1
11239 I2 = NSITEB
11240 10 CONTINUE
11241 I1 = (I0+I2)/2
11242 LEFT = ((BSITE(0,1,NTARG,I0)-Y)
11243 & *(BSITE(0,1,NTARG,I1)-Y)).LT.ZERO
11244 IF (LEFT) GOTO 20
11245 I0 = I1
11246 GOTO 30
11247 20 CONTINUE
11248 I2 = I1
11249 30 CONTINUE
11250 IF (I2-I0-2) 40,50,60
11251 40 CONTINUE
11252 I1 = I2+1
11253 IF (I1.GT.NSITEB) I1 = I0-1
11254 GOTO 70
11255 50 CONTINUE
11256 I1 = I0+1
11257 GOTO 70
11258 60 CONTINUE
11259 GOTO 10
11260 70 CONTINUE
11261 X0 = DBLE(I0-1)*BSTEP(NTARG)
11262 X1 = DBLE(I1-1)*BSTEP(NTARG)
11263 X2 = DBLE(I2-1)*BSTEP(NTARG)
11264 Y0 = BSITE(0,1,NTARG,I0)
11265 Y1 = BSITE(0,1,NTARG,I1)
11266 Y2 = BSITE(0,1,NTARG,I2)
11267 80 CONTINUE
11268 B = X0*(Y-Y1)*(Y-Y2)/((Y0-Y1)*(Y0-Y2)+TINY15)+
11269 & X1*(Y-Y0)*(Y-Y2)/((Y1-Y0)*(Y1-Y2)+TINY15)+
11270 & X2*(Y-Y0)*(Y-Y1)/((Y2-Y0)*(Y2-Y1)+TINY15)
11271**sr 5.4.98: shift B by half the bin width to be in agreement with BPROD
11272 B = B+0.5D0*BSTEP(NTARG)
11273 IF (B.LT.ZERO) B = X1
11274 IF (B.GT.BMAX(NTARG)) B = BMAX(NTARG)
11275 IF (ICENTR.LT.0) THEN
11276 IF (LFIRST) THEN
11277 LFIRST = .FALSE.
11278 IF (ICENTR.LE.-100) THEN
11279 BIMIN = 0.0D0
11280 ELSE
11281 XSFRAC = 0.0D0
11282 ENDIF
11283 CALL DT_GETBXS(XSFRAC,BIMIN,BIMAX,NTARG)
11284 WRITE(LOUT,1000) RASH(1),RBSH(NTARG),BMAX(NTARG),
11285 & BIMIN,BIMAX,XSFRAC*100.0D0,
11286 & XSFRAC*XSPRO(1,1,NTARG)
11287 10000 FORMAT(/,1X,'DT_MODB: Biasing in impact parameter',
11288 & /,15X,'---------------------------'/,/,4X,
11289 & 'average radii of proj / targ :',F10.3,' fm /',
11290 & F7.3,' fm',/,4X,'corresp. b_max (4*(r_p+r_t)) :',
11291 & F10.3,' fm',/,/,21X,'b_lo / b_hi :',
11292 & F10.3,' fm /',F7.3,' fm',/,5X,'percentage of',
11293 & ' cross section :',F10.3,' %',/,5X,
11294 & 'corresponding cross section :',F10.3,' mb',/)
11295 ENDIF
11296 IF (ABS(BIMAX-BIMIN).LT.1.0D-3) THEN
11297 B = BIMIN
11298 ELSE
11299 IF ((B.LT.BIMIN).OR.(B.GT.BIMAX)) GOTO 9
11300 ENDIF
11301 ENDIF
11302 ENDIF
11303
11304 RETURN
11305 END
11306
11307*$ CREATE DT_SHFAST.FOR
11308*COPY DT_SHFAST
11309*
11310*===shfast=============================================================*
11311*
11312 SUBROUTINE DT_SHFAST(MODE,PPN,IBACK)
11313
11314 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11315 SAVE
11316 PARAMETER ( LINP = 10 ,
11317 & LOUT = 6 ,
11318 & LDAT = 9 )
11319 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY1=1.0D-1,
11320 & ONE=1.0D0,TWO=2.0D0)
11321
11322 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11323* Glauber formalism: parameters
11324 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11325 & BMAX(NCOMPX),BSTEP(NCOMPX),
11326 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11327 & NSITEB,NSTATB
11328* properties of interacting particles
11329 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11330* Glauber formalism: cross sections
11331 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11332 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11333 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11334 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11335 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11336 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11337 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11338 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11339 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11340 & BSLOPE,NEBINI,NQBINI
11341
11342 IBACK = 0
11343
11344 IF (MODE.EQ.2) THEN
11345 OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11346 WRITE(47,1000) IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG,PPN
11347 1000 FORMAT(1X,8I5,E15.5)
11348 WRITE(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11349 1001 FORMAT(1X,4E15.5)
11350 WRITE(47,1002) SIGSH,ROSH,GSH
11351 1002 FORMAT(1X,3E15.5)
11352 DO 10 I=1,100
11353 WRITE(47,'(1X,E15.5)') BSITE(1,1,1,I)
11354 10 CONTINUE
11355 WRITE(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11356 1003 FORMAT(1X,2I10,3E15.5)
11357 CLOSE(47)
11358 ELSE
11359 OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11360 READ(47,1000) JT,JTZ,JP,JPZ,JJPROJ,JBPROJ,JJTARG,JBTARG,PP
11361 IF ((JT.EQ.IT).AND.(JTZ.EQ.ITZ).AND.(JP.EQ.IP).AND.
11362 & (JPZ.EQ.IPZ).AND.(JJPROJ.EQ.IJPROJ).AND.(JBPROJ.EQ.IBPROJ)
11363 & .AND.(JJTARG.EQ.IJTARG).AND.(JBTARG.EQ.IBTARG).AND.
11364 & (ABS(PP-PPN).LT.(PPN*0.01D0))) THEN
11365 READ(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11366 READ(47,1002) SIGSH,ROSH,GSH
11367 DO 11 I=1,100
11368 READ(47,'(1X,E15.5)') BSITE(1,1,1,I)
11369 11 CONTINUE
11370 READ(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11371 ELSE
11372 IBACK = 1
11373 ENDIF
11374 CLOSE(47)
11375 ENDIF
11376
11377 RETURN
11378 END
11379
11380*$ CREATE DT_POILIK.FOR
11381*COPY DT_POILIK
11382*
11383*===poilik=============================================================*
11384*
11385 SUBROUTINE DT_POILIK(NB,NTARG,ECM,VIRT,IPNT,RPNT,MODE)
11386
11387 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
11388 SAVE
11389
11390 PARAMETER ( LINP = 10 ,
11391 & LOUT = 6 ,
11392 & LDAT = 9 )
11393 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.0D0)
11394 PARAMETER (NE = 8)
11395
11396**PHOJET105a
11397C CHARACTER*8 MDLNA
11398C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
11399C PARAMETER (IEETAB=10)
11400C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
11401**PHOJET110
11402C model switches and parameters
11403 CHARACTER*8 MDLNA
11404 INTEGER ISWMDL,IPAMDL
11405 DOUBLE PRECISION PARMDL
11406 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11407C energy-interpolation table
11408 INTEGER IEETA2
11409 PARAMETER ( IEETA2 = 20 )
11410 INTEGER ISIMAX
11411 DOUBLE PRECISION SIGTAB,SIGECM
11412 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
11413**
11414* VDM parameter for photon-nucleus interactions
11415 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
11416**sr 22.7.97
11417 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11418* Glauber formalism: cross sections
11419 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11420 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11421 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11422 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11423 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11424 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11425 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11426 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11427 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11428 & BSLOPE,NEBINI,NQBINI
11429**
11430
11431 DATA ECMOLD,Q2OLD /-1.0D0,-1.0D0/
11432
11433 IF ((ECM.EQ.ECMOLD).AND.(VIRT.EQ.Q2OLD)) GOTO 3
11434
11435* load cross sections from interpolation table
11436 IP = 1
11437 IF(ECM.LE.SIGECM(IP,1)) THEN
11438 I1 = 1
11439 I2 = 1
11440 ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
11441 DO 50 I=2,ISIMAX
11442 IF(ECM.LE.SIGECM(IP,I)) GOTO 200
11443 50 CONTINUE
11444 200 CONTINUE
11445 I1 = I-1
11446 I2 = I
11447 ELSE
11448 WRITE(LOUT,'(/1X,A,2E12.3)')
11449 & 'POILIK:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
11450 I1 = ISIMAX
11451 I2 = ISIMAX
11452 ENDIF
11453 FAC2 = ZERO
11454 IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
11455 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
11456 FAC1 = ONE-FAC2
11457
11458 SIGANO = DT_SANO(ECM)
11459
11460* cross section dependence on photon virtuality
11461 FSUP1 = ZERO
11462 DO 150 I=1,3
11463 FSUP1 = FSUP1+PARMDL(26+I)*(ONE+VIRT/(4.D0*PARMDL(30+I)))
11464 & /(ONE+VIRT/PARMDL(30+I))**2
11465 150 CONTINUE
11466 FSUP1 = FSUP1+PARMDL(30)/(ONE+VIRT/PARMDL(34))
11467 FAC1 = FAC1*FSUP1
11468 FAC2 = FAC2*FSUP1
11469 FSUP2 = ONE
11470
11471 ECMOLD = ECM
11472 Q2OLD = VIRT
11473
11474 3 CONTINUE
11475
11476C SIGTOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
11477 CALL DT_SIGGP(ZERO,VIRT,ECM,ZERO,SIGTOT,DUM1,DUM2)
11478 IF (ISHAD(1).EQ.1) THEN
11479 SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
11480 ELSE
11481 SIGDIR = ZERO
11482 ENDIF
11483 SIGANO = FSUP1*FSUP2*SIGANO
11484 SIGTOT = SIGTOT-SIGDIR-SIGANO
11485 SIGDIR = SIGDIR/(FSUP1*FSUP2)
11486 SIGANO = SIGANO/(FSUP1*FSUP2)
11487 SIGTOT = SIGTOT+SIGDIR+SIGANO
11488
11489 RR = DT_RNDM(SIGTOT)
11490 IF (RR.LT.SIGDIR/SIGTOT) THEN
11491 IPNT = 1
11492 ELSEIF ((RR.GE.SIGDIR/SIGTOT).AND.
11493 & (RR.LT.(SIGDIR+SIGANO)/SIGTOT)) THEN
11494 IPNT = 2
11495 ELSE
11496 IPNT = 0
11497 ENDIF
11498 RPNT = (SIGDIR+SIGANO)/SIGTOT
11499C WRITE(LOUT,'(I3,2F15.5)') ISHAD(1),FAC1,FAC2
11500C WRITE(LOUT,'(I3,2F15.5)') MODE,SIGDIR,SIGANO
11501C WRITE(LOUT,'(I3,4F15.5)') MODE,SIGDIR+SIGANO,SIGTOT,RPNT,ECM
11502C WRITE(LOUT,'(1X,6E12.4)') ECM,VIRT,SIGTOT,SIGDIR,SIGANO,RPNT
11503 IF (MODE.EQ.1) RETURN
11504
11505**sr 22.7.97
11506 K1 = 1
11507 K2 = 1
11508 RATE = ZERO
11509 IF (ECM.GE.ECMNN(NEBINI)) THEN
11510 K1 = NEBINI
11511 K2 = NEBINI
11512 RATE = ONE
11513 ELSEIF (ECM.GT.ECMNN(1)) THEN
11514 DO 10 I=2,NEBINI
11515 IF (ECM.LT.ECMNN(I)) THEN
11516 K1 = I-1
11517 K2 = I
11518 RATE = (ECM-ECMNN(K1))/(ECMNN(K2)-ECMNN(K1))
11519 GOTO 11
11520 ENDIF
11521 10 CONTINUE
11522 11 CONTINUE
11523 ENDIF
11524 J1 = 1
11525 J2 = 1
11526 RATQ = ZERO
11527 IF (NQBINI.GT.1) THEN
11528 IF (VIRT.GE.Q2G(NQBINI)) THEN
11529 J1 = NQBINI
11530 J2 = NQBINI
11531 RATQ = ONE
11532 ELSEIF (VIRT.GT.Q2G(1)) THEN
11533 DO 12 I=2,NQBINI
11534 IF (VIRT.LT.Q2G(I)) THEN
11535 J1 = I-1
11536 J2 = I
11537 RATQ = LOG10( VIRT/MAX(Q2G(J1),TINY14))/
11538 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
11539 GOTO 13
11540 ENDIF
11541 12 CONTINUE
11542 13 CONTINUE
11543 ENDIF
11544 ENDIF
11545 SGA = XSPRO(K1,J1,NTARG)+
11546 & RATE*(XSPRO(K2,J1,NTARG)-XSPRO(K1,J1,NTARG))+
11547 & RATQ*(XSPRO(K1,J2,NTARG)-XSPRO(K1,J1,NTARG))+
11548 & RATE*RATQ*(XSPRO(K2,J2,NTARG)-XSPRO(K1,J2,NTARG)+
11549 & XSPRO(K1,J1,NTARG)-XSPRO(K2,J1,NTARG))
11550 SDI = DBLE(NB)*SIGDIR
11551 SAN = DBLE(NB)*SIGANO
11552 SPL = SDI+SAN
11553 RR = DT_RNDM(SPL)
11554 IF (RR.LT.SDI/SGA) THEN
11555 IPNT = 1
11556 ELSEIF ((RR.GE.SDI/SGA).AND.
11557 & (RR.LT.SPL/SGA)) THEN
11558 IPNT = 2
11559 ELSE
11560 IPNT = 0
11561 ENDIF
11562 RPNT = SPL/SGA
11563C WRITE(LOUT,'(I3,4F15.5)') MODE,SPL,SGA,RPNT,ECM
11564**
11565
11566 RETURN
11567 END
11568
11569*$ CREATE DT_GLBINI.FOR
11570*COPY DT_GLBINI
11571*
11572*===glbini=============================================================*
11573*
11574 SUBROUTINE DT_GLBINI(WHAT)
11575
11576************************************************************************
11577* Pre-initialization of profile function *
11578* This version dated 28.11.00 is written by S. Roesler. *
11579* *
11580* Last change 27.12.2006 by S. Roesler. *
11581************************************************************************
11582
11583 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11584 SAVE
11585
11586 PARAMETER ( LINP = 10 ,
11587 & LOUT = 6 ,
11588 & LDAT = 9 )
11589 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.D-14)
11590
11591 LOGICAL LCMS
11592
11593* particle properties (BAMJET index convention)
11594 CHARACTER*8 ANAME
11595 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11596 & IICH(210),IIBAR(210),K1(210),K2(210)
11597* properties of interacting particles
11598 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11599 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11600* emulsion treatment
11601 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11602 & NCOMPO,IEMUL
11603* Glauber formalism: flags and parameters for statistics
11604 LOGICAL LPROD
11605 CHARACTER*8 CGLB
11606 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11607* number of data sets other than protons and nuclei
11608* at the moment = 2 (pions and kaons)
11609 PARAMETER (MAXOFF=2)
11610 DIMENSION IJPINI(5),IOFFST(25)
11611 DATA IJPINI / 13, 15, 0, 0, 0/
11612* Glauber data-set to be used for hadron projectiles
11613* (0=proton, 1=pion, 2=kaon)
11614 DATA (IOFFST(K),K=1,25) /
11615 & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
11616 & 0, 0, 1, 2, 2/
11617* Acceptance interval for target nucleus mass
11618 PARAMETER (KBACC = 6)
11619* flags for input different options
11620 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
11621 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
11622 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
11623
11624 PARAMETER (MAXMSS = 100)
11625 DIMENSION IASAV(MAXMSS),IBSAV(MAXMSS)
11626 DIMENSION WHAT(6)
11627
11628 DATA JPEACH,JPSTEP / 18, 5 /
11629
11630* temporary patch until fix has been implemented in phojet:
11631* maximum energy for pion projectile
11632 DATA ECMXPI / 100000.0D0 /
11633*
11634*--------------------------------------------------------------------------
11635* general initializations
11636*
11637* steps in projectile mass number for initialization
11638 IF (WHAT(4).GT.ZERO) JPEACH = INT(WHAT(4))
11639 IF (WHAT(5).GT.ZERO) JPSTEP = INT(WHAT(5))
11640*
11641* energy range and binning
11642 ELO = ABS(WHAT(1))
11643 EHI = ABS(WHAT(2))
11644 IF (ELO.GT.EHI) ELO = EHI
11645 NEBIN = MAX(INT(WHAT(3)),1)
11646 IF (ELO.EQ.EHI) NEBIN = 0
11647 LCMS = (WHAT(1).LT.ZERO).OR.(WHAT(2).LT.ZERO)
11648 IF (LCMS) THEN
11649 ECMINI = EHI
11650 ELSE
11651 ECMINI = SQRT(AAM(IJPROJ)**2+AAM(IJTARG)**2
11652 & +2.0D0*AAM(IJTARG)*EHI)
11653 ENDIF
11654*
11655* default arguments for Glauber-routine
11656 XI = ZERO
11657 Q2I = ZERO
11658*
11659* initialize nuclear parameters, etc.
11660 CALL DT_BERTTP
11661 CALL DT_INCINI
11662*
11663* open Glauber-data output file
11664 IDX = INDEX(CGLB,' ')
11665 K = 12
11666 IF (IDX.GT.1) K = IDX-1
11667 OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
11668*
11669*--------------------------------------------------------------------------
11670* Glauber-initialization for proton and nuclei projectiles
11671*
11672* initialize phojet for proton-proton interactions
11673 ELAB = ZERO
11674 PLAB = ZERO
11675 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
11676 CALL DT_PHOINI
11677*
11678* record projectile masses
11679 NASAV = 0
11680 NPROJ = MIN(IP,JPEACH)
11681 DO 10 KPROJ=1,NPROJ
11682 NASAV = NASAV+1
11683 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11684 IASAV(NASAV) = KPROJ
11685 10 CONTINUE
11686 IF (IP.GT.JPEACH) THEN
11687 NPROJ = DBLE(IP-JPEACH)/DBLE(JPSTEP)
11688 IF (NPROJ.EQ.0) THEN
11689 NASAV = NASAV+1
11690 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11691 IASAV(NASAV) = IP
11692 ELSE
11693 DO 11 IPROJ=1,NPROJ
11694 KPROJ = JPEACH+IPROJ*JPSTEP
11695 NASAV = NASAV+1
11696 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11697 IASAV(NASAV) = KPROJ
11698 11 CONTINUE
11699 IF (KPROJ.LT.IP) THEN
11700 NASAV = NASAV+1
11701 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11702 IASAV(NASAV) = IP
11703 ENDIF
11704 ENDIF
11705 ENDIF
11706*
11707* record target masses
11708 NBSAV = 0
11709 NTARG = 1
11710 IF (NCOMPO.GT.0) NTARG = NCOMPO
11711 DO 12 ITARG=1,NTARG
11712 NBSAV = NBSAV+1
11713 IF (NBSAV.GT.MAXMSS) STOP ' GLBINI: NBSAV > MAXMSS ! '
11714 IF (NCOMPO.GT.0) THEN
11715 IBSAV(NBSAV) = IEMUMA(ITARG)
11716 ELSE
11717 IBSAV(NBSAV) = IT
11718 ENDIF
11719 12 CONTINUE
11720*
11721* print masses
11722 WRITE(LDAT,1000) NEBIN,': ',SIGN(ELO,WHAT(1)),SIGN(EHI,WHAT(2))
11723 1000 FORMAT(I4,A,1P,2E13.5)
11724 NLINES = DBLE(NASAV)/18.0D0
11725 IF (NLINES.GT.0) THEN
11726 DO 13 I=1,NLINES
11727 IF (I.EQ.1) THEN
11728 WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=1,18)
11729 ELSE
11730 WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=18*I-17,18*I)
11731 ENDIF
11732 13 CONTINUE
11733 ENDIF
11734 I0 = 18*NLINES+1
11735 IF (I0.LE.NASAV) THEN
11736 IF (I0.EQ.1) THEN
11737 WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=I0,NASAV)
11738 ELSE
11739 WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=I0,NASAV)
11740 ENDIF
11741 ENDIF
11742 NLINES = DBLE(NBSAV)/18.0D0
11743 IF (NLINES.GT.0) THEN
11744 DO 14 I=1,NLINES
11745 IF (I.EQ.1) THEN
11746 WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=1,18)
11747 ELSE
11748 WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=18*I-17,18*I)
11749 ENDIF
11750 14 CONTINUE
11751 ENDIF
11752 I0 = 18*NLINES+1
11753 IF (I0.LE.NBSAV) THEN
11754 IF (I0.EQ.1) THEN
11755 WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=I0,NBSAV)
11756 ELSE
11757 WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=I0,NBSAV)
11758 ENDIF
11759 ENDIF
11760*
11761* calculate Glauber-data for each energy and mass combination
11762*
11763* loop over energy bins
11764 ELO = LOG10(ELO)
11765 EHI = LOG10(EHI)
11766 DEBIN = (EHI-ELO)/MAX(DBLE(NEBIN),ONE)
11767 DO 1 IE=1,NEBIN+1
11768 E = ELO+DBLE(IE-1)*DEBIN
11769 E = 10**E
11770 IF (LCMS) THEN
11771 E = MAX(2.0D0*AAM(IJPROJ)+0.1D0,E)
11772 ECM = E
11773 ELSE
11774 PLAB = ZERO
11775 ECM = ZERO
11776 E = MAX(AAM(IJPROJ)+0.1D0,E)
11777 CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
11778 ENDIF
11779*
11780* loop over projectile and target masses
11781 DO 2 ITARG=1,NBSAV
11782 DO 3 IPROJ=1,NASAV
11783 CALL DT_XSGLAU(IASAV(IPROJ),IBSAV(ITARG),IJPROJ,
11784 & XI,Q2I,ECM,1,1,-1)
11785 3 CONTINUE
11786 2 CONTINUE
11787*
11788 1 CONTINUE
11789*
11790*--------------------------------------------------------------------------
11791* Glauber-initialization for pion, kaon, ... projectiles
11792*
11793 DO 6 IJ=1,MAXOFF
11794*
11795* initialize phojet for this interaction
11796 ELAB = ZERO
11797 PLAB = ZERO
11798 IJPROJ = IJPINI(IJ)
11799 IP = 1
11800 IPZ = 1
11801*
11802* temporary patch until fix has been implemented in phojet:
11803 IF (ECMINI.GT.ECMXPI) THEN
11804 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMXPI,1)
11805 ELSE
11806 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
11807 ENDIF
11808 CALL DT_PHOINI
11809*
11810* calculate Glauber-data for each energy and mass combination
11811*
11812* loop over energy bins
11813 DO 4 IE=1,NEBIN+1
11814 E = ELO+DBLE(IE-1)*DEBIN
11815 E = 10**E
11816 IF (LCMS) THEN
11817 E = MAX(2.0D0*AAM(IJPROJ)+TINY14,E)
11818 ECM = E
11819 ELSE
11820 PLAB = ZERO
11821 ECM = ZERO
11822 E = MAX(AAM(IJPROJ)+TINY14,E)
11823 CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
11824 ENDIF
11825*
11826* loop over projectile and target masses
11827 DO 5 ITARG=1,NBSAV
11828 CALL DT_XSGLAU(1,IBSAV(ITARG),IJPROJ,XI,Q2I,ECM,1,1,-1)
11829 5 CONTINUE
11830*
11831 4 CONTINUE
11832*
11833 6 CONTINUE
11834
11835*--------------------------------------------------------------------------
11836* close output unit(s), etc.
11837*
11838 CLOSE(LDAT)
11839
11840 RETURN
11841 END
11842
11843*$ CREATE DT_GLBSET.FOR
11844*COPY DT_GLBSET
11845*
11846*===glbset=============================================================*
11847*
11848 SUBROUTINE DT_GLBSET(IDPROJ,NA,NB,ELAB,MODE)
11849************************************************************************
11850* Interpolation of pre-initialized profile functions *
11851* This version dated 28.11.00 is written by S. Roesler. *
11852************************************************************************
11853
11854 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11855 SAVE
11856
11857 PARAMETER ( LINP = 10 ,
11858 & LOUT = 6 ,
11859 & LDAT = 9 )
11860 PARAMETER (ZERO=0.0D0,ONE=1.0D0)
11861
11862 LOGICAL LCMS,LREAD,LFRST1,LFRST2
11863
11864* particle properties (BAMJET index convention)
11865 CHARACTER*8 ANAME
11866 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11867 & IICH(210),IIBAR(210),K1(210),K2(210)
11868* Glauber formalism: flags and parameters for statistics
11869 LOGICAL LPROD
11870 CHARACTER*8 CGLB
11871 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11872 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11873* Glauber formalism: parameters
11874 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11875 & BMAX(NCOMPX),BSTEP(NCOMPX),
11876 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11877 & NSITEB,NSTATB
11878* Glauber formalism: cross sections
11879 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11880 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11881 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11882 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11883 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11884 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11885 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11886 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11887 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11888 & BSLOPE,NEBINI,NQBINI
11889* number of data sets other than protons and nuclei
11890* at the moment = 2 (pions and kaons)
11891 PARAMETER (MAXOFF=2)
11892 DIMENSION IJPINI(5),IOFFST(25)
11893 DATA IJPINI / 13, 15, 0, 0, 0/
11894* Glauber data-set to be used for hadron projectiles
11895* (0=proton, 1=pion, 2=kaon)
11896 DATA (IOFFST(K),K=1,25) /
11897 & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
11898 & 0, 0, 1, 2, 2/
11899* Acceptance interval for target nucleus mass
11900 PARAMETER (KBACC = 6)
11901* emulsion treatment
11902 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11903 & NCOMPO,IEMUL
11904
11905 PARAMETER (MAXSET=5000,
11906 & MAXBIN=100)
11907 DIMENSION XSIG(MAXSET,6),XERR(MAXSET,6),BPROFL(MAXSET,KSITEB)
11908 DIMENSION IABIN(MAXBIN),IBBIN(MAXBIN),XS(6),XE(6),
11909 & BPRO0(KSITEB),BPRO1(KSITEB),BPRO(KSITEB),
11910 & IAIDX(10)
11911
11912 DATA LREAD,LFRST1,LFRST2 /.FALSE.,.TRUE.,.TRUE./
11913*
11914* read data from file
11915*
11916 IF (MODE.EQ.0) THEN
11917
11918 IF (LREAD) RETURN
11919
11920 DO 1 I=1,MAXSET
11921 DO 2 J=1,6
11922 XSIG(I,J) = ZERO
11923 XERR(I,J) = ZERO
11924 2 CONTINUE
11925 DO 3 J=1,KSITEB
11926 BPROFL(I,J) = ZERO
11927 3 CONTINUE
11928 1 CONTINUE
11929 DO 4 I=1,MAXBIN
11930 IABIN(I) = 0
11931 IBBIN(I) = 0
11932 4 CONTINUE
11933 DO 5 I=1,KSITEB
11934 BPRO0(I) = ZERO
11935 BPRO1(I) = ZERO
11936 BPRO(I) = ZERO
11937 5 CONTINUE
11938
11939 IDX = INDEX(CGLB,' ')
11940 K = 12
11941 IF (IDX.GT.1) K = IDX-1
11942 OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
11943 WRITE(LOUT,1000) CGLB(1:K)//'.glb'
11944 1000 FORMAT(/,' GLBSET: impact parameter distributions read from ',
11945 & 'file ',A12,/)
11946*
11947* read binning information
11948 READ(LDAT,'(I4,2X,2E13.5)') NEBIN,ELO,EHI
11949* return lower energy threshold to Fluka-interface
11950 ELAB = ELO
11951 LCMS = ELO.LT.ZERO
11952 WRITE(LOUT,'(1X,A)') ' equidistant logarithmic energy binning:'
11953 IF (LCMS) THEN
11954 WRITE(LOUT,1001) '(cms)',ABS(ELO),ABS(EHI),NEBIN
11955 ELSE
11956 WRITE(LOUT,1001) '(lab)',ABS(ELO),ABS(EHI),NEBIN
11957 ENDIF
11958 1001 FORMAT(2X,A5,' E_lo = ',1P,E9.3,' E_hi = ',1P,E9.3,4X,
11959 & 'No. of bins:',I5,/)
11960 ELO = LOG10(ABS(ELO))
11961 EHI = LOG10(ABS(EHI))
11962 DEBIN = (EHI-ELO)/ABS(DBLE(NEBIN))
11963 WRITE(LOUT,'(/,1X,A)') ' projectiles: (mass number)'
11964 READ(LDAT,'(I4,2X,18I4)') NABIN,(IABIN(J),J=1,18)
11965 IF (NABIN.LT.18) THEN
11966 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,NABIN)
11967 ELSE
11968 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,18)
11969 ENDIF
11970 IF (NABIN.GT.MAXBIN) STOP ' GLBSET: NABIN > MAXBIN !'
11971 IF (NABIN.GT.18) THEN
11972 NLINES = DBLE(NABIN-18)/18.0D0
11973 IF (NLINES.GT.0) THEN
11974 DO 7 I=1,NLINES
11975 I0 = 18*(I+1)-17
11976 READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
11977 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
11978 7 CONTINUE
11979 ENDIF
11980 I0 = 18*(NLINES+1)+1
11981 IF (I0.LE.NABIN) THEN
11982 READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
11983 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
11984 ENDIF
11985 ENDIF
11986 WRITE(LOUT,'(/,1X,A)') ' targets: (mass number)'
11987 READ(LDAT,'(I4,2X,18I4)') NBBIN,(IBBIN(J),J=1,18)
11988 IF (NBBIN.LT.18) THEN
11989 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,NBBIN)
11990 ELSE
11991 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,18)
11992 ENDIF
11993 IF (NBBIN.GT.MAXBIN) STOP ' GLBSET: NBBIN > MAXBIN !'
11994 IF (NBBIN.GT.18) THEN
11995 NLINES = DBLE(NBBIN-18)/18.0D0
11996 IF (NLINES.GT.0) THEN
11997 DO 8 I=1,NLINES
11998 I0 = 18*(I+1)-17
11999 READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12000 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12001 8 CONTINUE
12002 ENDIF
12003 I0 = 18*(NLINES+1)+1
12004 IF (I0.LE.NBBIN) THEN
12005 READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12006 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12007 ENDIF
12008 ENDIF
12009* number of data sets to follow in the Glauber data file
12010* this variable is used for checks of consistency of projectile
12011* and target mass configurations given in header of Glauber data
12012* file and the data-sets which follow in this file
12013 NSET0 = (NEBIN+1)*(NABIN+MAXOFF)*NBBIN
12014*
12015* read profile function data
12016 NSET = 0
12017 NAIDX = 0
12018 IPOLD = 0
12019 10 CONTINUE
12020 NSET = NSET+1
12021 IF (NSET.GT.MAXSET) STOP ' GLBSET: NSET > MAXSET ! '
12022 READ(LDAT,1002,END=100) IP,IA,IB,ISTATB,ISITEB,ECM
12023 1002 FORMAT(5I10,E15.5)
12024 IF ((IP.NE.1).AND.(IP.NE.IPOLD)) THEN
12025 NAIDX = NAIDX+1
12026 IF (NAIDX.GT.10) STOP ' GLBSET: NAIDX > 10 !'
12027 IAIDX(NAIDX) = IP
12028 IPOLD = IP
12029 ENDIF
12030 READ(LDAT,'(6E12.5)') (XSIG(NSET,I),I=1,6)
12031 READ(LDAT,'(6E12.5)') (XERR(NSET,I),I=1,6)
12032 NLINES = INT(DBLE(ISITEB)/7.0D0)
12033 IF (NLINES.GT.0) THEN
12034 DO 11 I=1,NLINES
12035 READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=7*I-6,7*I)
12036 11 CONTINUE
12037 ENDIF
12038 I0 = 7*NLINES+1
12039 IF (I0.LE.ISITEB)
12040 & READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=I0,ISITEB)
12041 GOTO 10
12042 100 CONTINUE
12043 NSET = NSET-1
12044 IF (NSET.NE.NSET0) STOP ' GLBSET: NSET.NE.NSET0 !'
12045 WRITE(LOUT,'(/,1X,A)')
12046 & ' projectiles other than protons and nuclei: (particle index)'
12047 IF (NAIDX.GT.0) THEN
12048 WRITE(LOUT,'(6X,18I4)') (IAIDX(J),J=1,NAIDX)
12049 ELSE
12050 WRITE(LOUT,'(6X,A)') 'none'
12051 ENDIF
12052*
12053 CLOSE(LDAT)
12054 WRITE(LOUT,*)
12055 LREAD = .TRUE.
12056
12057 IF (NCOMPO.EQ.0) THEN
12058 DO 12 J=1,NBBIN
12059 NCOMPO = NCOMPO+1
12060 IEMUMA(NCOMPO) = IBBIN(J)
12061 IEMUCH(NCOMPO) = IEMUMA(NCOMPO)/2
12062 EMUFRA(NCOMPO) = 1.0D0
12063 12 CONTINUE
12064 IEMUL = 1
12065 ENDIF
12066*
12067* calculate profile function for certain set of parameters
12068*
12069 ELSE
12070
12071c write(*,*) 'glbset called for ',IDPROJ,NA,NB,ELAB,MODE
12072*
12073* check for type of projectile and set index-offset to entry in
12074* Glauber data array correspondingly
12075 IF (IDPROJ.GT.25) STOP ' GLBSET: IDPROJ > 25 !'
12076 IF (IOFFST(IDPROJ).EQ.-1) THEN
12077 STOP ' GLBSET: no data for this projectile !'
12078 ELSEIF (IOFFST(IDPROJ).GT.0) THEN
12079 IDXOFF = (NEBIN+1)*(NABIN+IOFFST(IDPROJ)-1)*NBBIN
12080 ELSE
12081 IDXOFF = 0
12082 ENDIF
12083*
12084* get energy bin and interpolation factor
12085 IF (LCMS) THEN
12086 E = SQRT(AAM(IDPROJ)**2+AAM(1)**2+2.0D0*AAM(1)*ELAB)
12087 ELSE
12088 E = ELAB
12089 ENDIF
12090 E = LOG10(E)
12091 IF (E.LT.ELO) THEN
12092 IF (LFRST1) THEN
12093 WRITE(LOUT,*) ' GLBSET: Too low energy! (E_lo,E) ',ELO,E
12094 LFRST1 = .FALSE.
12095 ENDIF
12096 E = ELO
12097 ENDIF
12098 IF (E.GT.EHI) THEN
12099 IF (LFRST2) THEN
12100 WRITE(LOUT,*) ' GLBSET: Too high energy! (E_hi,E) ',EHI,E
12101 LFRST2 = .FALSE.
12102 ENDIF
12103 E = EHI
12104 ENDIF
12105 IE0 = (E-ELO)/DEBIN+1
12106 IE1 = IE0+1
12107 FACE = (E-(ELO+DBLE(IE0-1)*DEBIN))/DEBIN
12108*
12109* get target nucleus index
12110 KB = 0
12111 NBACC = KBACC
12112 DO 20 I=1,NBBIN
12113 NBDIFF = ABS(NB-IBBIN(I))
12114 IF (NB.EQ.IBBIN(I)) THEN
12115 KB = I
12116 GOTO 21
12117 ELSEIF (NBDIFF.LE.NBACC) THEN
12118 KB = I
12119 NBACC = NBDIFF
12120 ENDIF
12121 20 CONTINUE
12122 IF (KB.NE.0) GOTO 21
12123 WRITE(LOUT,*) ' GLBSET: data not found for target ',NB
12124 STOP
12125 21 CONTINUE
12126*
12127* get projectile nucleus bin and interpolation factor
12128 KA0 = 0
12129 KA1 = 0
12130 FACNA = 0
12131 IF (IDXOFF.GT.0) THEN
12132 KA0 = 1
12133 KA1 = 1
12134 KABIN = 1
12135 ELSE
12136 IF (NA.GT.IABIN(NABIN)) STOP ' GLBSET: NA > IABIN(NABIN) !'
12137 DO 22 I=1,NABIN
12138 IF (NA.EQ.IABIN(I)) THEN
12139 KA0 = I
12140 KA1 = I
12141 GOTO 23
12142 ELSEIF (NA.LT.IABIN(I)) THEN
12143 KA0 = I-1
12144 KA1 = I
12145 GOTO 23
12146 ENDIF
12147 22 CONTINUE
12148 WRITE(LOUT,*) ' GLBSET: data not found for projectile ',NA
12149 STOP
12150 23 CONTINUE
12151 IF (KA0.NE.KA1)
12152 & FACNA = DBLE(NA-IABIN(KA0))/DBLE(IABIN(KA1)-IABIN(KA0))
12153 KABIN = NABIN
12154 ENDIF
12155*
12156* interpolate profile functions for interactions ka0-kb and ka1-kb
12157* for energy E separately
12158 IDX0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12159 IDX1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12160 IDY0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12161 IDY1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12162 DO 30 I=1,ISITEB
12163 BPRO0(I) = BPROFL(IDX0,I)
12164 & +FACE*(BPROFL(IDX1,I)-BPROFL(IDX0,I))
12165 BPRO1(I) = BPROFL(IDY0,I)
12166 & +FACE*(BPROFL(IDY1,I)-BPROFL(IDY0,I))
12167 30 CONTINUE
12168 RADB = DT_RNCLUS(NB)
12169 BSTP0 = 2.0D0*(DT_RNCLUS(IABIN(KA0))+RADB)/DBLE(ISITEB-1)
12170 BSTP1 = 2.0D0*(DT_RNCLUS(IABIN(KA1))+RADB)/DBLE(ISITEB-1)
12171*
12172* interpolate cross sections for energy E and projectile mass
12173 DO 31 I=1,6
12174 XS0 = XSIG(IDX0,I)+FACE*(XSIG(IDX1,I)-XSIG(IDX0,I))
12175 XS1 = XSIG(IDY0,I)+FACE*(XSIG(IDY1,I)-XSIG(IDY0,I))
12176 XS(I) = XS0+FACNA*(XS1-XS0)
12177 XE0 = XERR(IDX0,I)+FACE*(XERR(IDX1,I)-XERR(IDX0,I))
12178 XE1 = XERR(IDY0,I)+FACE*(XERR(IDY1,I)-XERR(IDY0,I))
12179 XE(I) = XE0+FACNA*(XE1-XE0)
12180 31 CONTINUE
12181*
12182* interpolate between ka0 and ka1
12183 RADA = DT_RNCLUS(NA)
12184 BMX = 2.0D0*(RADA+RADB)
12185 BSTP = BMX/DBLE(ISITEB-1)
12186 BPRO(1) = ZERO
12187 DO 32 I=1,ISITEB-1
12188 B = DBLE(I)*BSTP
12189*
12190* calculate values of profile functions at B
12191 IDX0 = B/BSTP0+1
12192 IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12193 IDX1 = MIN(IDX0+1,ISITEB)
12194 FACB = (B-DBLE(IDX0-1)*BSTP0)/BSTP0
12195 BPR0 = BPRO0(IDX0)+FACB*(BPRO0(IDX1)-BPRO0(IDX0))
12196 IDX0 = B/BSTP1+1
12197 IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12198 IDX1 = MIN(IDX0+1,ISITEB)
12199 FACB = (B-DBLE(IDX0-1)*BSTP1)/BSTP1
12200 BPR1 = BPRO1(IDX0)+FACB*(BPRO1(IDX1)-BPRO1(IDX0))
12201*
12202 BPRO(I+1) = BPR0+FACNA*(BPR1-BPR0)
12203 32 CONTINUE
12204*
12205* fill common dtglam
12206 NSITEB = ISITEB
12207 RASH(1) = RADA
12208 RBSH(1) = RADB
12209 BMAX(1) = BMX
12210 BSTEP(1) = BSTP
12211 DO 33 I=1,KSITEB
12212 BSITE(0,1,1,I) = BPRO(I)
12213 33 CONTINUE
12214*
12215* fill common dtglxs
12216 XSTOT(1,1,1) = XS(1)
12217 XSELA(1,1,1) = XS(2)
12218 XSQEP(1,1,1) = XS(3)
12219 XSQET(1,1,1) = XS(4)
12220 XSQE2(1,1,1) = XS(5)
12221 XSPRO(1,1,1) = XS(6)
12222 XETOT(1,1,1) = XE(1)
12223 XEELA(1,1,1) = XE(2)
12224 XEQEP(1,1,1) = XE(3)
12225 XEQET(1,1,1) = XE(4)
12226 XEQE2(1,1,1) = XE(5)
12227 XEPRO(1,1,1) = XE(6)
12228
12229 ENDIF
12230
12231 RETURN
12232 END
12233
12234*$ CREATE DT_XKSAMP.FOR
12235*COPY DT_XKSAMP
12236*
12237*===xksamp=============================================================*
12238*
12239 SUBROUTINE DT_XKSAMP(NN,ECM)
12240
12241************************************************************************
12242* Sampling of parton x-values and chain system for one interaction. *
12243* processed by S. Roesler, 9.8.95 *
12244************************************************************************
12245
12246 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12247 SAVE
12248 PARAMETER ( LINP = 10 ,
12249 & LOUT = 6 ,
12250 & LDAT = 9 )
12251 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
454792a9 12252CPH SAVE
9aaba0d6 12253
12254 PARAMETER (
12255* lower cuts for (valence-sea/sea-valence) chain masses
12256* antiquark-quark (u/d-sea quark) (s-sea quark)
12257 & AMIU = 0.5D0, AMIS = 0.8D0,
12258* quark-diquark (u/d-sea quark) (s-sea quark)
12259 & AMAU = 2.6D0, AMAS = 2.6D0,
12260* maximum lower valence-x threshold
12261 & XVMAX = 0.98D0,
12262* fraction of sea-diquarks sampled out of sea-partons
12263**test
12264C & FRCDIQ = 0.9D0,
12265**
12266*
12267 & SQMA = 0.7D0,
12268*
12269* maximum number of trials to generate x's for the required number
12270* of sea quark pairs for a given hadron
12271 & NSEATY = 12
12272C & NSEATY = 3
12273 & )
12274
12275 LOGICAL ZUOVP,ZUOSP,ZUOVT,ZUOST,INTLO
12276
12277 PARAMETER ( MAXNCL = 260,
12278 & MAXVQU = MAXNCL,
12279 & MAXSQU = 20*MAXVQU,
12280 & MAXINT = MAXVQU+MAXSQU)
12281* event history
12282 PARAMETER (NMXHKK=200000)
12283 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
12284 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
12285 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
12286* particle properties (BAMJET index convention)
12287 CHARACTER*8 ANAME
12288 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12289 & IICH(210),IIBAR(210),K1(210),K2(210)
12290* interface between Glauber formalism and DPM
12291 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
12292 & INTER1(MAXINT),INTER2(MAXINT)
12293* properties of interacting particles
12294 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
12295* threshold values for x-sampling (DTUNUC 1.x)
12296 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
12297 & SSMIMQ,VVMTHR
12298* x-values of partons (DTUNUC 1.x)
12299 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
12300 & XTVQ(MAXVQU),XTVD(MAXVQU),
12301 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
12302 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
12303* flavors of partons (DTUNUC 1.x)
12304 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
12305 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
12306 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
12307 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
12308 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
12309 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
12310 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
12311* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12312 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
12313 & IXPV,IXPS,IXTV,IXTS,
12314 & INTVV1(MAXVQU),INTVV2(MAXVQU),
12315 & INTSV1(MAXVQU),INTSV2(MAXVQU),
12316 & INTVS1(MAXVQU),INTVS2(MAXVQU),
12317 & INTSS1(MAXSQU),INTSS2(MAXSQU),
12318 & INTDV1(MAXVQU),INTDV2(MAXVQU),
12319 & INTVD1(MAXVQU),INTVD2(MAXVQU),
12320 & INTDS1(MAXSQU),INTDS2(MAXSQU),
12321 & INTSD1(MAXSQU),INTSD2(MAXSQU)
12322* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12323 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
12324 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
12325* auxiliary common for chain system storage (DTUNUC 1.x)
12326 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
12327* flags for input different options
12328 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
12329 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
12330 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
12331* various options for treatment of partons (DTUNUC 1.x)
12332* (chain recombination, Cronin,..)
12333 LOGICAL LCO2CR,LINTPT
12334 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
12335 & LCO2CR,LINTPT
12336
12337 DIMENSION ZUOVP(MAXVQU),ZUOSP(MAXSQU),ZUOVT(MAXVQU),ZUOST(MAXSQU),
12338 & INTLO(MAXINT)
12339
12340* (1) initializations
12341*-----------------------------------------------------------------------
12342
12343**test
12344 IF (ECM.LT.4.5D0) THEN
12345C FRCDIQ = 0.6D0
12346 FRCDIQ = 0.4D0
12347 ELSEIF ((ECM.GE.4.5D0).AND.(ECM.LT.7.5)) THEN
12348C FRCDIQ = 0.6D0+(ECM-4.5D0)/3.0D0*0.3D0
12349 FRCDIQ = 0.4D0+(ECM-4.5D0)/3.0D0*0.3D0
12350 ELSE
12351C FRCDIQ = 0.9D0
12352 FRCDIQ = 0.7D0
12353 ENDIF
12354**
12355 DO 30 I=1,MAXSQU
12356 ZUOSP(I) = .FALSE.
12357 ZUOST(I) = .FALSE.
12358 IF (I.LE.MAXVQU) THEN
12359 ZUOVP(I) = .FALSE.
12360 ZUOVT(I) = .FALSE.
12361 ENDIF
12362 30 CONTINUE
12363
12364* lower thresholds for x-selection
12365* sea-quarks (default: CSEA=0.2)
12366 IF (ECM.LT.10.0D0) THEN
12367**!!test
12368 XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM
12369C XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM**2.0D0
12370 NSEA = NSEATY
12371C XSTHR = ONE/ECM**2
12372 ELSE
12373**sr 30.3.98
12374C XSTHR = CSEA/ECM
12375 XSTHR = CSEA/ECM**2
12376C XSTHR = ONE/ECM**2
12377**
12378 IF ((IP.GE.150).AND.(IT.GE.150))
12379 & XSTHR = 2.5D0/(ECM*SQRT(ECM))
12380 NSEA = NSEATY
12381 ENDIF
12382* (default: SSMIMA=0.14) used for sea-diquarks (?)
12383 XSSTHR = SSMIMA/ECM
12384 BSQMA = SQMA/ECM
12385* valence-quarks (default: CVQ=1.0)
12386 XVTHR = CVQ/ECM
12387* valence-diquarks (default: CDQ=2.0)
12388 XDTHR = CDQ/ECM
12389
12390* maximum-x for sea-quarks
12391 XVCUT = XVTHR+XDTHR
12392 IF (XVCUT.GT.XVMAX) THEN
12393 XVCUT = XVMAX
12394 XVTHR = XVCUT/3.0D0
12395 XDTHR = XVCUT-XVTHR
12396 ENDIF
12397 XXSEAM = ONE-XVCUT
12398**sr 18.4. test: DPMJET
12399C XXSEAM=1.0 - XVTHR*(1.D0+0.3D0*DT_RNDM(V1))
12400C & - XDTHR*(1.D0+0.3D0*DT_RNDM(V2))
12401C & -0.01*(1.D0+1.5D0*DT_RNDM(V3))
12402**
12403* maximum number of sea-pairs allowed kinematically
12404C NSMAX = INT(OHALF*XXSEAM/XSTHR)
12405 RNSMAX = OHALF*XXSEAM/XSTHR
12406 IF (RNSMAX.GT.10000.0D0) THEN
12407 NSMAX = 10000
12408 ELSE
12409 NSMAX = INT(OHALF*XXSEAM/XSTHR)
12410 ENDIF
12411* check kinematical limit for valence-x thresholds
12412* (should be obsolete now)
12413 IF (XVCUT.GT.XVMAX) THEN
12414 WRITE(LOUT,1000) XVCUT,ECM
12415 1000 FORMAT(' XKSAMP: kin. limit for valence-x',
12416 & ' thresholds not allowed (',2E9.3,')')
12417C XVTHR = XVMAX-XDTHR
12418C IF (XVTHR.LT.ZERO) STOP
12419 STOP
12420 ENDIF
12421
12422* set eta for valence-x sampling (BETREJ)
12423* (UNON per default, UNOM used for projectile mesons only)
12424 IF ((IJPROJ.NE.0).AND.(IBPROJ.EQ.0)) THEN
12425 UNOPRV = UNOM
12426 ELSE
12427 UNOPRV = UNON
12428 ENDIF
12429
12430* (2) select parton x-values of interacting projectile nucleons
12431*-----------------------------------------------------------------------
12432
12433 IXPV = 0
12434 IXPS = 0
12435
12436 DO 100 IPP=1,IP
12437* get interacting projectile nucleon as sampled by Glauber
12438 IF (JSSH(IPP).NE.0) THEN
12439 IXSTMP = IXPS
12440 IXVTMP = IXPV
12441 99 CONTINUE
12442 IXPS = IXSTMP
12443 IXPV = IXVTMP
12444* JIPP is the actual number of sea-pairs sampled for this nucleon
12445 JIPP = MIN(JSSH(IPP)-1,NSMAX)
12446 41 CONTINUE
12447 XXSEA = ZERO
12448 IF (JIPP.GT.0) THEN
12449 XSMAX = XXSEAM-2.0D0*DBLE(JIPP)*XSTHR
12450*???
12451 IF (XSTHR.GE.XSMAX) THEN
12452 JIPP = JIPP-1
12453 GOTO 41
12454 ENDIF
12455
12456*>>>get x-values of sea-quark pairs
12457 NSCOUN = 0
12458 PLW = 0.5D0
12459 40 CONTINUE
12460* accumulator for sea x-values
12461 XXSEA = ZERO
12462 NSCOUN = NSCOUN+1
12463 IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
12464 IF (NSCOUN.GT.NSEA) THEN
12465* decrease the number of interactions after NSEA trials
12466 JIPP = JIPP-1
12467 NSCOUN = 0
12468 ENDIF
12469 DO 70 ISQ=1,JIPP
12470* sea-quarks
12471 IF (IPSQ(IXPS+1).LE.2) THEN
12472**sr 8.4.98 (1/sqrt(x))
12473C XPSQI = DT_SAMPEX(XSTHR,XSMAX)
12474C XPSQI = DT_SAMSQX(XSTHR,XSMAX)
12475 XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12476**
12477 ELSE
12478 IF (XSMAX.GT.XSTHR+BSQMA) THEN
12479 XPSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12480 ELSE
12481**sr 8.4.98 (1/sqrt(x))
12482C XPSQI = DT_SAMPEX(XSTHR,XSMAX)
12483C XPSQI = DT_SAMSQX(XSTHR,XSMAX)
12484 XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12485**
12486 ENDIF
12487 ENDIF
12488* sea-antiquarks
12489 IF (IPSAQ(IXPS+1).GE.-2) THEN
12490**sr 8.4.98 (1/sqrt(x))
12491C XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
12492C XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
12493 XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12494**
12495 ELSE
12496 IF (XSMAX.GT.XSTHR+BSQMA) THEN
12497 XPSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12498 ELSE
12499**sr 8.4.98 (1/sqrt(x))
12500C XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
12501C XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
12502 XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12503**
12504 ENDIF
12505 ENDIF
12506 XXSEA = XXSEA+XPSQI+XPSAQI
12507* check for maximum allowed sea x-value
12508 IF (XXSEA.GE.XXSEAM) THEN
12509 IXPS = IXPS-ISQ+1
12510 GOTO 40
12511 ENDIF
12512* accept this sea-quark pair
12513 IXPS = IXPS+1
12514 XPSQ(IXPS) = XPSQI
12515 XPSAQ(IXPS) = XPSAQI
12516 IFROSP(IXPS) = IPP
12517 ZUOSP(IXPS) = .TRUE.
12518 70 CONTINUE
12519 ENDIF
12520
12521*>>>get x-values of valence partons
12522* valence quark
12523 IF (XVTHR.GT.0.05D0) THEN
12524 XVHI = ONE-XXSEA-XDTHR
12525 XPVQI = DT_BETREJ(OHALF,UNOPRV,XVTHR,XVHI)
12526 ELSE
12527 90 CONTINUE
12528 XPVQI = DT_DBETAR(OHALF,UNOPRV)
12529 IF ((XPVQI.LT.XVTHR).OR.(ONE-XPVQI-XXSEA.LT.XDTHR))
12530 & GOTO 90
12531 ENDIF
12532* valence diquark
12533 XPVDI = ONE-XPVQI-XXSEA
12534* reject according to x**1.5
12535 XDTMP = XPVDI**1.5D0
12536 IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 99
12537* accept these valence partons
12538 IXPV = IXPV+1
12539 XPVQ(IXPV) = XPVQI
12540 XPVD(IXPV) = XPVDI
12541 IFROVP(IXPV) = IPP
12542 ITOVP(IPP) = IXPV
12543 ZUOVP(IXPV) = .TRUE.
12544
12545 ENDIF
12546 100 CONTINUE
12547
12548* (3) select parton x-values of interacting target nucleons
12549*-----------------------------------------------------------------------
12550
12551 IXTV = 0
12552 IXTS = 0
12553
12554 DO 170 ITT=1,IT
12555* get interacting target nucleon as sampled by Glauber
12556 IF (JTSH(ITT).NE.0) THEN
12557 IXSTMP = IXTS
12558 IXVTMP = IXTV
12559 169 CONTINUE
12560 IXTS = IXSTMP
12561 IXTV = IXVTMP
12562* JITT is the actual number of sea-pairs sampled for this nucleon
12563 JITT = MIN(JTSH(ITT)-1,NSMAX)
12564 111 CONTINUE
12565 XXSEA = ZERO
12566 IF (JITT.GT.0) THEN
12567 XSMAX = XXSEAM-2.0D0*DBLE(JITT)*XSTHR
12568*???
12569 IF (XSTHR.GE.XSMAX) THEN
12570 JITT = JITT-1
12571 GOTO 111
12572 ENDIF
12573
12574*>>>get x-values of sea-quark pairs
12575 NSCOUN = 0
12576 PLW = 0.5D0
12577 110 CONTINUE
12578* accumulator for sea x-values
12579 XXSEA = ZERO
12580 NSCOUN = NSCOUN+1
12581 IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
12582 IF (NSCOUN.GT.NSEA)THEN
12583* decrease the number of interactions after NSEA trials
12584 JITT = JITT-1
12585 NSCOUN = 0
12586 ENDIF
12587 DO 140 ISQ=1,JITT
12588* sea-quarks
12589 IF (ITSQ(IXTS+1).LE.2) THEN
12590**sr 8.4.98 (1/sqrt(x))
12591C XTSQI = DT_SAMPEX(XSTHR,XSMAX)
12592C XTSQI = DT_SAMSQX(XSTHR,XSMAX)
12593 XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12594**
12595 ELSE
12596 IF (XSMAX.GT.XSTHR+BSQMA) THEN
12597 XTSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12598 ELSE
12599**sr 8.4.98 (1/sqrt(x))
12600C XTSQI = DT_SAMPEX(XSTHR,XSMAX)
12601C XTSQI = DT_SAMSQX(XSTHR,XSMAX)
12602 XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12603**
12604 ENDIF
12605 ENDIF
12606* sea-antiquarks
12607 IF (ITSAQ(IXTS+1).GE.-2) THEN
12608**sr 8.4.98 (1/sqrt(x))
12609C XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
12610C XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
12611 XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12612**
12613 ELSE
12614 IF (XSMAX.GT.XSTHR+BSQMA) THEN
12615 XTSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12616 ELSE
12617**sr 8.4.98 (1/sqrt(x))
12618C XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
12619C XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
12620 XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12621**
12622 ENDIF
12623 ENDIF
12624 XXSEA = XXSEA+XTSQI+XTSAQI
12625* check for maximum allowed sea x-value
12626 IF (XXSEA.GE.XXSEAM) THEN
12627 IXTS = IXTS-ISQ+1
12628 GOTO 110
12629 ENDIF
12630* accept this sea-quark pair
12631 IXTS = IXTS+1
12632 XTSQ(IXTS) = XTSQI
12633 XTSAQ(IXTS) = XTSAQI
12634 IFROST(IXTS) = ITT
12635 ZUOST(IXTS) = .TRUE.
12636 140 CONTINUE
12637 ENDIF
12638
12639*>>>get x-values of valence partons
12640* valence quark
12641 IF (XVTHR.GT.0.05D0) THEN
12642 XVHI = ONE-XXSEA-XDTHR
12643 XTVQI = DT_BETREJ(OHALF,UNON,XVTHR,XVHI)
12644 ELSE
12645 160 CONTINUE
12646 XTVQI = DT_DBETAR(OHALF,UNON)
12647 IF ((XTVQI.LT.XVTHR).OR.(ONE-XTVQI-XXSEA.LT.XDTHR))
12648 & GOTO 160
12649 ENDIF
12650* valence diquark
12651 XTVDI = ONE-XTVQI-XXSEA
12652* reject according to x**1.5
12653 XDTMP = XTVDI**1.5D0
12654 IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 169
12655* accept these valence partons
12656 IXTV = IXTV+1
12657 XTVQ(IXTV) = XTVQI
12658 XTVD(IXTV) = XTVDI
12659 IFROVT(IXTV) = ITT
12660 ITOVT(ITT) = IXTV
12661 ZUOVT(IXTV) = .TRUE.
12662
12663 ENDIF
12664 170 CONTINUE
12665
12666* (4) get valence-valence chains
12667*-----------------------------------------------------------------------
12668
12669 NVV = 0
12670 DO 240 I=1,NN
12671 INTLO(I) = .TRUE.
12672 IPVAL = ITOVP(INTER1(I))
12673 ITVAL = ITOVT(INTER2(I))
12674 IF (ZUOVP(IPVAL).AND.ZUOVT(ITVAL)) THEN
12675 INTLO(I) = .FALSE.
12676 ZUOVP(IPVAL) = .FALSE.
12677 ZUOVT(ITVAL) = .FALSE.
12678 NVV = NVV+1
12679 ISKPCH(8,NVV) = 0
12680 INTVV1(NVV) = IPVAL
12681 INTVV2(NVV) = ITVAL
12682 ENDIF
12683 240 CONTINUE
12684
12685* (5) get sea-valence chains
12686*-----------------------------------------------------------------------
12687
12688 NSV = 0
12689 NDV = 0
12690 PLW = 0.5D0
12691 DO 270 I=1,NN
12692 IF (INTLO(I)) THEN
12693 IPVAL = ITOVP(INTER1(I))
12694 ITVAL = ITOVT(INTER2(I))
12695 DO 250 J=1,IXPS
12696 IF (ZUOSP(J).AND.(IFROSP(J).EQ.INTER1(I)).AND.
12697 & ZUOVT(ITVAL)) THEN
12698 ZUOSP(J) = .FALSE.
12699 ZUOVT(ITVAL) = .FALSE.
12700 INTLO(I) = .FALSE.
12701 IF (LSEADI.AND.(DT_RNDM(PLW).GT.FRCDIQ)) THEN
12702* sample sea-diquark pair
12703 CALL DT_SAMSDQ(ECM,ITVAL,J,2,IREJ1)
12704 IF (IREJ1.EQ.0) GOTO 260
12705 ENDIF
12706 NSV = NSV+1
12707 ISKPCH(4,NSV) = 0
12708 INTSV1(NSV) = J
12709 INTSV2(NSV) = ITVAL
12710
12711*>>>correct chain kinematics according to minimum chain masses
12712* the actual chain masses
12713 AMSVQ1 = XPSQ(J) *XTVD(ITVAL)*ECM**2
12714 AMSVQ2 = XPSAQ(J)*XTVQ(ITVAL)*ECM**2
12715* get lower mass cuts
12716 IF (IPSQ(J).EQ.3) THEN
12717* q being s-quark
12718 AMCHK1 = AMAS
12719 AMCHK2 = AMIS
12720 ELSE
12721* q being u/d-quark
12722 AMCHK1 = AMAU
12723 AMCHK2 = AMIU
12724 ENDIF
12725* q-qq chain
12726* chain mass above minimum - resampling of sea-q x-value
12727 IF (AMSVQ1.GT.AMCHK1) THEN
12728 XPSQTH = AMCHK1/(XTVD(ITVAL)*ECM**2)
12729**sr 8.4.98 (1/sqrt(x))
12730C XPSQXX = DT_SAMPEX(XPSQTH,XPSQ(J))
12731C XPSQXX = DT_SAMSQX(XPSQTH,XPSQ(J))
12732 XPSQXX = DT_SAMPLW(XPSQTH,XPSQ(J),PLW)
12733**
12734 XPVD(IPVAL) = XPVD(IPVAL)+XPSQ(J)-XPSQXX
12735 XPSQ(J) = XPSQXX
12736* chain mass below minimum - reset sea-q x-value and correct
12737* diquark-x of the same nucleon
12738 ELSEIF (AMSVQ1.LT.AMCHK1) THEN
12739 XPSQW = AMCHK1/(XTVD(ITVAL)*ECM**2)
12740 DXPSQ = XPSQW-XPSQ(J)
12741 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
12742 XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
12743 XPSQ(J) = XPSQW
12744 ENDIF
12745 ENDIF
12746* aq-q chain
12747* chain mass below minimum - reset sea-aq x-value and correct
12748* diquark-x of the same nucleon
12749 IF (AMSVQ2.LT.AMCHK2) THEN
12750 XPSQW = AMCHK2/(XTVQ(ITVAL)*ECM**2)
12751 DXPSQ = XPSQW-XPSAQ(J)
12752 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
12753 XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
12754 XPSAQ(J) = XPSQW
12755 ENDIF
12756 ENDIF
12757*>>>end of chain mass correction
12758
12759 GOTO 260
12760 ENDIF
12761 250 CONTINUE
12762 ENDIF
12763 260 CONTINUE
12764 270 CONTINUE
12765
12766* (6) get valence-sea chains
12767*-----------------------------------------------------------------------
12768
12769 NVS = 0
12770 NVD = 0
12771 DO 300 I=1,NN
12772 IF (INTLO(I)) THEN
12773 IPVAL = ITOVP(INTER1(I))
12774 ITVAL = ITOVT(INTER2(I))
12775 DO 280 J=1,IXTS
12776 IF (ZUOVP(IPVAL).AND.ZUOST(J).AND.
12777 & (IFROST(J).EQ.INTER2(I))) THEN
12778 ZUOST(J) = .FALSE.
12779 ZUOVP(IPVAL) = .FALSE.
12780 INTLO(I) = .FALSE.
12781 IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
12782* sample sea-diquark pair
12783 CALL DT_SAMSDQ(ECM,IPVAL,J,1,IREJ1)
12784 IF (IREJ1.EQ.0) GOTO 290
12785 ENDIF
12786 NVS = NVS + 1
12787 ISKPCH(6,NVS) = 0
12788 INTVS1(NVS) = IPVAL
12789 INTVS2(NVS) = J
12790
12791*>>>correct chain kinematics according to minimum chain masses
12792* the actual chain masses
12793 AMVSQ1 = XPVQ(IPVAL)*XTSAQ(J)*ECM**2
12794 AMVSQ2 = XPVD(IPVAL)*XTSQ(J) *ECM**2
12795* get lower mass cuts
12796 IF (ITSQ(J).EQ.3) THEN
12797* q being s-quark
12798 AMCHK1 = AMIS
12799 AMCHK2 = AMAS
12800 ELSE
12801* q being u/d-quark
12802 AMCHK1 = AMIU
12803 AMCHK2 = AMAU
12804 ENDIF
12805* q-aq chain
12806* chain mass below minimum - reset sea-aq x-value and correct
12807* diquark-x of the same nucleon
12808 IF (AMVSQ1.LT.AMCHK1) THEN
12809 XTSQW = AMCHK1/(XPVQ(IPVAL)*ECM**2)
12810 DXTSQ = XTSQW-XTSAQ(J)
12811 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
12812 XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
12813 XTSAQ(J) = XTSQW
12814 ENDIF
12815 ENDIF
12816* qq-q chain
12817* chain mass above minimum - resampling of sea-q x-value
12818 IF (AMVSQ2.GT.AMCHK2) THEN
12819 XTSQTH = AMCHK2/(XPVD(IPVAL)*ECM**2)
12820**sr 8.4.98 (1/sqrt(x))
12821C XTSQXX = DT_SAMPEX(XTSQTH,XTSQ(J))
12822C XTSQXX = DT_SAMSQX(XTSQTH,XTSQ(J))
12823 XTSQXX = DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
12824**
12825 XTVD(ITVAL) = XTVD(ITVAL)+XTSQ(J)-XTSQXX
12826 XTSQ(J) = XTSQXX
12827* chain mass below minimum - reset sea-q x-value and correct
12828* diquark-x of the same nucleon
12829 ELSEIF (AMVSQ2.LT.AMCHK2) THEN
12830 XTSQW = AMCHK2/(XPVD(IPVAL)*ECM**2)
12831 DXTSQ = XTSQW-XTSQ(J)
12832 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
12833 XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
12834 XTSQ(J) = XTSQW
12835 ENDIF
12836 ENDIF
12837*>>>end of chain mass correction
12838
12839 GOTO 290
12840 ENDIF
12841 280 CONTINUE
12842 ENDIF
12843 290 CONTINUE
12844 300 CONTINUE
12845
12846* (7) get sea-sea chains
12847*-----------------------------------------------------------------------
12848
12849 NSS = 0
12850 NDS = 0
12851 NSD = 0
12852 DO 420 I=1,NN
12853 IF (INTLO(I)) THEN
12854 IPVAL = ITOVP(INTER1(I))
12855 ITVAL = ITOVT(INTER2(I))
12856* loop over target partons not yet matched
12857 DO 400 J=1,IXTS
12858 IF (ZUOST(J).AND.(IFROST(J).EQ.INTER2(I))) THEN
12859* loop over projectile partons not yet matched
12860 DO 390 JJ=1,IXPS
12861 IF (ZUOSP(JJ).AND.(IFROSP(JJ).EQ.INTER1(I))) THEN
12862 ZUOSP(JJ) = .FALSE.
12863 ZUOST(J) = .FALSE.
12864 INTLO(I) = .FALSE.
12865 NSS = NSS+1
12866 ISKPCH(1,NSS) = 0
12867 INTSS1(NSS) = JJ
12868 INTSS2(NSS) = J
12869
12870*---->chain recombination option
12871 VALFRA = DBLE(NVV/(NVV+IXPS+IXTS))
12872 IF (IRECOM.EQ.1.AND.(DT_RNDM(BSQMA).GT.VALFRA))
12873 & THEN
12874* sea-sea chains may recombine with valence-valence chains
12875* only if they have the same projectile or target nucleon
12876 DO 4201 IVV=1,NVV
12877 IF (ISKPCH(8,IVV).NE.99) THEN
12878 IXVPR = INTVV1(IVV)
12879 IXVTA = INTVV2(IVV)
12880 IF ((INTER1(I).EQ.IFROVP(IXVPR)).OR.
12881 & (INTER2(I).EQ.IFROVT(IXVTA))) THEN
12882* recombination possible, drop old v-v and s-s chains
12883 ISKPCH(1,NSS) = 99
12884 ISKPCH(8,IVV) = 99
12885
12886* (a) assign new s-v chains
12887* ~~~~~~~~~~~~~~~~~~~~~~~~~
12888 IF (LSEADI.AND.
12889 & (DT_RNDM(VALFRA).GT.FRCDIQ))
12890 & THEN
12891* sample sea-diquark pair
12892 CALL DT_SAMSDQ(ECM,IXVTA,JJ,2,
12893 & IREJ1)
12894 IF (IREJ1.EQ.0) GOTO 4202
12895 ENDIF
12896 NSV = NSV+1
12897 ISKPCH(4,NSV) = 0
12898 INTSV1(NSV) = JJ
12899 INTSV2(NSV) = IXVTA
12900*>>>>>>>>>>>correct chain kinematics according to minimum chain masses
12901* the actual chain masses
12902 AMSVQ1 = XPSQ(JJ) *XTVD(IXVTA)
12903 & *ECM**2
12904 AMSVQ2 = XPSAQ(JJ)*XTVQ(IXVTA)
12905 & *ECM**2
12906* get lower mass cuts
12907 IF (IPSQ(JJ).EQ.3) THEN
12908* q being s-quark
12909 AMCHK1 = AMAS
12910 AMCHK2 = AMIS
12911 ELSE
12912* q being u/d-quark
12913 AMCHK1 = AMAU
12914 AMCHK2 = AMIU
12915 ENDIF
12916* q-qq chain
12917* chain mass above minimum - resampling of sea-q x-value
12918 IF (AMSVQ1.GT.AMCHK1) THEN
12919 XPSQTH =
12920 & AMCHK1/(XTVD(IXVTA)*ECM**2)
12921**sr 8.4.98 (1/sqrt(x))
12922 XPSQXX =
12923 & DT_SAMPLW(XPSQTH,XPSQ(JJ),PLW)
12924C & DT_SAMSQX(XPSQTH,XPSQ(JJ))
12925C & DT_SAMPEX(XPSQTH,XPSQ(JJ))
12926**
12927 XPVD(IPVAL) =
12928 & XPVD(IPVAL)+XPSQ(JJ)-XPSQXX
12929 XPSQ(JJ) = XPSQXX
12930* chain mass below minimum - reset sea-q x-value and correct
12931* diquark-x of the same nucleon
12932 ELSEIF (AMSVQ1.LT.AMCHK1) THEN
12933 XPSQW =
12934 & AMCHK1/(XTVD(IXVTA)*ECM**2)
12935 DXPSQ = XPSQW-XPSQ(JJ)
12936 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
12937 & THEN
12938 XPVD(IPVAL) =
12939 & XPVD(IPVAL)-DXPSQ
12940 XPSQ(JJ) = XPSQW
12941 ENDIF
12942 ENDIF
12943* aq-q chain
12944* chain mass below minimum - reset sea-aq x-value and correct
12945* diquark-x of the same nucleon
12946 IF (AMSVQ2.LT.AMCHK2) THEN
12947 XPSQW =
12948 & AMCHK2/(XTVQ(IXVTA)*ECM**2)
12949 DXPSQ = XPSQW-XPSAQ(JJ)
12950 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
12951 & THEN
12952 XPVD(IPVAL) =
12953 & XPVD(IPVAL)-DXPSQ
12954 XPSAQ(JJ) = XPSQW
12955 ENDIF
12956 ENDIF
12957*>>>>>>>>>>>end of chain mass correction
12958 4202 CONTINUE
12959
12960* (b) assign new v-s chains
12961* ~~~~~~~~~~~~~~~~~~~~~~~~~
12962 IF (LSEADI.AND.(
12963 & DT_RNDM(AMSVQ2).GT.FRCDIQ))
12964 & THEN
12965* sample sea-diquark pair
12966 CALL DT_SAMSDQ(ECM,IXVPR,J,1,
12967 & IREJ1)
12968 IF (IREJ1.EQ.0) GOTO 4203
12969 ENDIF
12970 NVS = NVS+1
12971 ISKPCH(6,NVS) = 0
12972 INTVS1(NVS) = IXVPR
12973 INTVS2(NVS) = J
12974*>>>>>>>>>>>correct chain kinematics according to minimum chain masses
12975* the actual chain masses
12976 AMVSQ1 = XPVQ(IXVPR)*XTSAQ(J)*ECM**2
12977 AMVSQ2 = XPVD(IXVPR)*XTSQ(J) *ECM**2
12978* get lower mass cuts
12979 IF (ITSQ(J).EQ.3) THEN
12980* q being s-quark
12981 AMCHK1 = AMIS
12982 AMCHK2 = AMAS
12983 ELSE
12984* q being u/d-quark
12985 AMCHK1 = AMIU
12986 AMCHK2 = AMAU
12987 ENDIF
12988* q-aq chain
12989* chain mass below minimum - reset sea-aq x-value and correct
12990* diquark-x of the same nucleon
12991 IF (AMVSQ1.LT.AMCHK1) THEN
12992 XTSQW =
12993 & AMCHK1/(XPVQ(IXVPR)*ECM**2)
12994 DXTSQ = XTSQW-XTSAQ(J)
12995 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
12996 & THEN
12997 XTVD(ITVAL) =
12998 & XTVD(ITVAL)-DXTSQ
12999 XTSAQ(J) = XTSQW
13000 ENDIF
13001 ENDIF
13002 IF (AMVSQ2.GT.AMCHK2) THEN
13003 XTSQTH =
13004 & AMCHK2/(XPVD(IXVPR)*ECM**2)
13005**sr 8.4.98 (1/sqrt(x))
13006 XTSQXX =
13007 & DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
13008C & DT_SAMSQX(XTSQTH,XTSQ(J))
13009C & DT_SAMPEX(XTSQTH,XTSQ(J))
13010**
13011 XTVD(ITVAL) =
13012 & XTVD(ITVAL)+XTSQ(J)-XTSQXX
13013 XTSQ(J) = XTSQXX
13014 ELSEIF (AMVSQ2.LT.AMCHK2) THEN
13015 XTSQW =
13016 & AMCHK2/(XPVD(IXVPR)*ECM**2)
13017 DXTSQ = XTSQW-XTSQ(J)
13018 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13019 & THEN
13020 XTVD(ITVAL) =
13021 & XTVD(ITVAL)-DXTSQ
13022 XTSQ(J) = XTSQW
13023 ENDIF
13024 ENDIF
13025*>>>>>>>>>end of chain mass correction
13026 4203 CONTINUE
13027* jump out of s-s chain loop
13028 GOTO 420
13029 ENDIF
13030 ENDIF
13031 4201 CONTINUE
13032 ENDIF
13033*---->end of chain recombination option
13034
13035* sample sea-diquark pair (projectile)
13036 IF (LSEADI.AND.(DT_RNDM(BSQMA).GT.FRCDIQ)) THEN
13037 CALL DT_SAMSDQ(ECM,J,JJ,4,IREJ1)
13038 IF (IREJ1.EQ.0) THEN
13039 ISKPCH(1,NSS) = 99
13040 GOTO 410
13041 ENDIF
13042 ENDIF
13043* sample sea-diquark pair (target)
13044 IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
13045 CALL DT_SAMSDQ(ECM,JJ,J,3,IREJ1)
13046 IF (IREJ1.EQ.0) THEN
13047 ISKPCH(1,NSS) = 99
13048 GOTO 410
13049 ENDIF
13050 ENDIF
13051*>>>>>correct chain kinematics according to minimum chain masses
13052* the actual chain masses
13053 SSMA1Q = XPSQ(JJ) *XTSAQ(J)*ECM**2
13054 SSMA2Q = XPSAQ(JJ)*XTSQ(J) *ECM**2
13055* check for lower mass cuts
13056 IF ((SSMA1Q.LT.SSMIMQ).OR.
13057 & (SSMA2Q.LT.SSMIMQ)) THEN
13058 IPVAL = ITOVP(INTER1(I))
13059 ITVAL = ITOVT(INTER2(I))
13060 IF ((XPVD(IPVAL).GT.XDTHR+3.5D0*XSSTHR).AND.
13061 & (XTVD(ITVAL).GT.XDTHR+3.5D0*XSSTHR))THEN
13062* maximum allowed x values for sea quarks
13063 XSPMAX = ONE-XPVQ(IPVAL)-XDTHR-
13064 & 1.2D0*XSSTHR
13065 XSTMAX = ONE-XTVQ(ITVAL)-XDTHR-
13066 & 1.2D0*XSSTHR
13067* resampling of x values not possible - skip sea-sea chains
13068 IF ((XSPMAX.LE.XSSTHR+0.05D0).OR.
13069 & (XSTMAX.LE.XSSTHR+0.05D0)) GOTO 380
13070* resampling of x for projectile sea quark pair
13071 ICOUS = 0
13072 310 CONTINUE
13073 ICOUS = ICOUS+1
13074 IF (XSSTHR.GT.0.05D0) THEN
13075 XPSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13076 & XSPMAX)
13077 XPSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13078 & XSPMAX)
13079 ELSE
13080 320 CONTINUE
13081 XPSQI = DT_DBETAR(XSEACU,UNOSEA)
13082 IF ((XPSQI.LT.XSSTHR).OR.
13083 & (XPSQI.GT.XSPMAX)) GOTO 320
13084 330 CONTINUE
13085 XPSAQI = DT_DBETAR(XSEACU,UNOSEA)
13086 IF ((XPSAQI.LT.XSSTHR).OR.
13087 & (XPSAQI.GT.XSPMAX)) GOTO 330
13088 ENDIF
13089* final test of remaining x for projectile diquark
13090 XPVDCO = XPVD(IPVAL)-XPSQI-XPSAQI
13091 & +XPSQ(JJ)+XPSAQ(JJ)
13092 IF (XPVDCO.LE.XDTHR) THEN
13093*!!!
13094C IF (ICOUS.LT.5) GOTO 310
13095 IF (ICOUS.LT.0.5D0) GOTO 310
13096 GOTO 380
13097 ENDIF
13098* resampling of x for target sea quark pair
13099 ICOUS = 0
13100 350 CONTINUE
13101 ICOUS = ICOUS+1
13102 IF (XSSTHR.GT.0.05D0) THEN
13103 XTSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13104 & XSTMAX)
13105 XTSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13106 & XSTMAX)
13107 ELSE
13108 360 CONTINUE
13109 XTSQI = DT_DBETAR(XSEACU,UNOSEA)
13110 IF ((XTSQI.LT.XSSTHR).OR.
13111 & (XTSQI.GT.XSTMAX)) GOTO 360
13112 370 CONTINUE
13113 XTSAQI = DT_DBETAR(XSEACU,UNOSEA)
13114 IF ((XTSAQI.LT.XSSTHR).OR.
13115 & (XTSAQI.GT.XSTMAX)) GOTO 370
13116 ENDIF
13117* final test of remaining x for target diquark
13118 XTVDCO = XTVD(ITVAL)-XTSQI-XTSAQI
13119 & +XTSQ(J)+XTSAQ(J)
13120 IF (XTVDCO.LT.XDTHR) THEN
13121 IF (ICOUS.LT.5) GOTO 350
13122 GOTO 380
13123 ENDIF
13124 XPVD(IPVAL) = XPVDCO
13125 XTVD(ITVAL) = XTVDCO
13126 XPSQ(JJ) = XPSQI
13127 XPSAQ(JJ) = XPSAQI
13128 XTSQ(J) = XTSQI
13129 XTSAQ(J) = XTSAQI
13130*>>>>>end of chain mass correction
13131 GOTO 410
13132 ENDIF
13133* come here to discard s-s interaction
13134* resampling of x values not allowed or unsuccessful
13135 380 CONTINUE
13136 INTLO(I) = .FALSE.
13137 ZUOST(J) = .TRUE.
13138 ZUOSP(JJ) = .TRUE.
13139 NSS = NSS-1
13140 ENDIF
13141* consider next s-s interaction
13142 GOTO 410
13143 ENDIF
13144 390 CONTINUE
13145 ENDIF
13146 400 CONTINUE
13147 ENDIF
13148 410 CONTINUE
13149 420 CONTINUE
13150
13151* correct x-values of valence quarks for non-matching sea quarks
13152 DO 430 I=1,IXPS
13153 IF (ZUOSP(I)) THEN
13154 IPVAL = ITOVP(IFROSP(I))
13155 XPVQ(IPVAL) = XPVQ(IPVAL)+XPSQ(I)+XPSAQ(I)
13156 XPSQ(I) = ZERO
13157 XPSAQ(I) = ZERO
13158 ZUOSP(I) = .FALSE.
13159 ENDIF
13160 430 CONTINUE
13161 DO 440 I=1,IXTS
13162 IF (ZUOST(I)) THEN
13163 ITVAL = ITOVT(IFROST(I))
13164 XTVQ(ITVAL) = XTVQ(ITVAL)+XTSQ(I)+XTSAQ(I)
13165 XTSQ(I) = ZERO
13166 XTSAQ(I) = ZERO
13167 ZUOST(I) = .FALSE.
13168 ENDIF
13169 440 CONTINUE
13170 DO 450 I=1,IXPV
13171 IF (ZUOVP(I)) ISTHKK(IFROVP(I)) = 13
13172 450 CONTINUE
13173 DO 460 I=1,IXTV
13174 IF (ZUOVT(I)) ISTHKK(IFROVT(I)+IP) = 14
13175 460 CONTINUE
13176
13177 RETURN
13178 END
13179
13180*$ CREATE DT_SAMSDQ.FOR
13181*COPY DT_SAMSDQ
13182*
13183*===samsdq=============================================================*
13184*
13185 SUBROUTINE DT_SAMSDQ(ECM,IDX1,IDX2,MODE,IREJ)
13186
13187************************************************************************
13188* SAMpling of Sea-DiQuarks *
13189* ECM cm-energy of the nucleon-nucleon system *
13190* IDX1,2 indices of x-values of the participating *
13191* partons (IDX2 is always the sea-q-pair to be *
13192* changed to sea-qq-pair) *
13193* MODE = 1 valence-q - sea-diq *
13194* = 2 sea-diq - valence-q *
13195* = 3 sea-q - sea-diq *
13196* = 4 sea-diq - sea-q *
13197* Based on DIQVS, DIQSV, DIQSSD, DIQDSS. *
13198* This version dated 17.10.95 is written by S. Roesler *
13199************************************************************************
13200
13201 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13202 SAVE
13203
13204 PARAMETER (ZERO=0.0D0)
13205
13206* threshold values for x-sampling (DTUNUC 1.x)
13207 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
13208 & SSMIMQ,VVMTHR
13209* various options for treatment of partons (DTUNUC 1.x)
13210* (chain recombination, Cronin,..)
13211 LOGICAL LCO2CR,LINTPT
13212 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
13213 & LCO2CR,LINTPT
13214 PARAMETER ( MAXNCL = 260,
13215 & MAXVQU = MAXNCL,
13216 & MAXSQU = 20*MAXVQU,
13217 & MAXINT = MAXVQU+MAXSQU)
13218* x-values of partons (DTUNUC 1.x)
13219 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
13220 & XTVQ(MAXVQU),XTVD(MAXVQU),
13221 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
13222 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
13223* flavors of partons (DTUNUC 1.x)
13224 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
13225 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
13226 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
13227 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
13228 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
13229 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
13230 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
13231* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13232 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
13233 & IXPV,IXPS,IXTV,IXTS,
13234 & INTVV1(MAXVQU),INTVV2(MAXVQU),
13235 & INTSV1(MAXVQU),INTSV2(MAXVQU),
13236 & INTVS1(MAXVQU),INTVS2(MAXVQU),
13237 & INTSS1(MAXSQU),INTSS2(MAXSQU),
13238 & INTDV1(MAXVQU),INTDV2(MAXVQU),
13239 & INTVD1(MAXVQU),INTVD2(MAXVQU),
13240 & INTDS1(MAXSQU),INTDS2(MAXSQU),
13241 & INTSD1(MAXSQU),INTSD2(MAXSQU)
13242* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13243 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
13244 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
13245* auxiliary common for chain system storage (DTUNUC 1.x)
13246 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
13247
13248 IREJ = 0
13249* threshold-x for valence diquarks
13250 XDTHR = CDQ/ECM
13251
13252 GOTO (1,2,3,4) MODE
13253
13254*---------------------------------------------------------------------
13255* proj. valence partons - targ. sea partons
13256* get x-values and flavors for target sea-diquark pair
13257
13258 1 CONTINUE
13259 IDXVP = IDX1
13260 IDXST = IDX2
13261
13262* index of corr. val-diquark-x in target nucleon
13263 IDXVT = ITOVT(IFROST(IDXST))
13264* available x above diquark thresholds for valence- and sea-diquarks
13265 XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13266
13267 IF (XXD.GE.ZERO) THEN
13268* x-values for the three diquarks of the target nucleon
13269 RR1 = DT_RNDM(XXD)
13270 RR2 = DT_RNDM(RR1)
13271 RR3 = DT_RNDM(RR2)
13272 SR123 = RR1+RR2+RR3
13273 XXTV = XDTHR+RR1*XXD/SR123
13274 XXTSQ = XDTHR+RR2*XXD/SR123
13275 XXTSAQ = XDTHR+RR3*XXD/SR123
13276 ELSE
13277 XXTV = XTVD(IDXVT)
13278 XXTSQ = XTSQ(IDXST)
13279 XXTSAQ = XTSAQ(IDXST)
13280 ENDIF
13281* flavor of the second quarks in the sea-diquark pair
13282 ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13283 ITSAQ2(IDXST) = -ITSQ2(IDXST)
13284* check masses of the new val-q - sea-qq, val-qq - sea-aqaq chains
13285 AM1 = XXTSQ *XPVQ(IDXVP)*ECM**2
13286 AM2 = XXTSAQ*XPVD(IDXVP)*ECM**2
13287 IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13288* ss-asas pair
13289 & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN
13290 IREJ = 1
13291 RETURN
13292 ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13293* at least one strange quark
13294 & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN
13295 IREJ = 1
13296 RETURN
13297 ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13298 IREJ = 1
13299 RETURN
13300 ENDIF
13301* accept the new sea-diquark
13302 XTVD(IDXVT) = XXTV
13303 XTSQ(IDXST) = XXTSQ
13304 XTSAQ(IDXST) = XXTSAQ
13305 NVD = NVD+1
13306 INTVD1(NVD) = IDXVP
13307 INTVD2(NVD) = IDXST
13308 ISKPCH(7,NVD) = 0
13309 RETURN
13310
13311*---------------------------------------------------------------------
13312* proj. sea partons - targ. valence partons
13313* get x-values and flavors for projectile sea-diquark pair
13314
13315 2 CONTINUE
13316 IDXSP = IDX2
13317 IDXVT = IDX1
13318
13319* index of corr. val-diquark-x in projectile nucleon
13320 IDXVP = ITOVP(IFROSP(IDXSP))
13321* available x above diquark thresholds for valence- and sea-diquarks
13322 XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13323
13324 IF (XXD.GE.ZERO) THEN
13325* x-values for the three diquarks of the projectile nucleon
13326 RR1 = DT_RNDM(XXD)
13327 RR2 = DT_RNDM(RR1)
13328 RR3 = DT_RNDM(RR2)
13329 SR123 = RR1+RR2+RR3
13330 XXPV = XDTHR+RR1*XXD/SR123
13331 XXPSQ = XDTHR+RR2*XXD/SR123
13332 XXPSAQ = XDTHR+RR3*XXD/SR123
13333 ELSE
13334 XXPV = XPVD(IDXVP)
13335 XXPSQ = XPSQ(IDXSP)
13336 XXPSAQ = XPSAQ(IDXSP)
13337 ENDIF
13338* flavor of the second quarks in the sea-diquark pair
13339 IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13340 IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13341* check masses of the new sea-qq - val-q, sea-aqaq - val-qq chains
13342 AM1 = XXPSQ *XTVQ(IDXVT)*ECM**2
13343 AM2 = XXPSAQ*XTVD(IDXVT)*ECM**2
13344 IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13345* ss-asas pair
13346 & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN
13347 IREJ = 1
13348 RETURN
13349 ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13350* at least one strange quark
13351 & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN
13352 IREJ = 1
13353 RETURN
13354 ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13355 IREJ = 1
13356 RETURN
13357 ENDIF
13358* accept the new sea-diquark
13359 XPVD(IDXVP) = XXPV
13360 XPSQ(IDXSP) = XXPSQ
13361 XPSAQ(IDXSP) = XXPSAQ
13362 NDV = NDV+1
13363 INTDV1(NDV) = IDXSP
13364 INTDV2(NDV) = IDXVT
13365 ISKPCH(5,NDV) = 0
13366 RETURN
13367
13368*---------------------------------------------------------------------
13369* proj. sea partons - targ. sea partons
13370* get x-values and flavors for target sea-diquark pair
13371
13372 3 CONTINUE
13373 IDXSP = IDX1
13374 IDXST = IDX2
13375
13376* index of corr. val-diquark-x in target nucleon
13377 IDXVT = ITOVT(IFROST(IDXST))
13378* available x above diquark thresholds for valence- and sea-diquarks
13379 XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13380
13381 IF (XXD.GE.ZERO) THEN
13382* x-values for the three diquarks of the target nucleon
13383 RR1 = DT_RNDM(XXD)
13384 RR2 = DT_RNDM(RR1)
13385 RR3 = DT_RNDM(RR2)
13386 SR123 = RR1+RR2+RR3
13387 XXTV = XDTHR+RR1*XXD/SR123
13388 XXTSQ = XDTHR+RR2*XXD/SR123
13389 XXTSAQ = XDTHR+RR3*XXD/SR123
13390 ELSE
13391 XXTV = XTVD(IDXVT)
13392 XXTSQ = XTSQ(IDXST)
13393 XXTSAQ = XTSAQ(IDXST)
13394 ENDIF
13395* flavor of the second quarks in the sea-diquark pair
13396 ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13397 ITSAQ2(IDXST) = -ITSQ2(IDXST)
13398* check masses of the new sea-q - sea-qq, sea-aq - sea-aqaq chains
13399 AM1 = XXTSQ *XPSQ(IDXSP)*ECM**2
13400 AM2 = XXTSAQ*XPSAQ(IDXSP)*ECM**2
13401 IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13402* ss-asas pair
13403 & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN
13404 IREJ = 1
13405 RETURN
13406 ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13407* at least one strange quark
13408 & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN
13409 IREJ = 1
13410 RETURN
13411 ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
13412 IREJ = 1
13413 RETURN
13414 ENDIF
13415* accept the new sea-diquark
13416 XTVD(IDXVT) = XXTV
13417 XTSQ(IDXST) = XXTSQ
13418 XTSAQ(IDXST) = XXTSAQ
13419 NSD = NSD+1
13420 INTSD1(NSD) = IDXSP
13421 INTSD2(NSD) = IDXST
13422 ISKPCH(3,NSD) = 0
13423 RETURN
13424
13425*---------------------------------------------------------------------
13426* proj. sea partons - targ. sea partons
13427* get x-values and flavors for projectile sea-diquark pair
13428
13429 4 CONTINUE
13430 IDXSP = IDX2
13431 IDXST = IDX1
13432
13433* index of corr. val-diquark-x in projectile nucleon
13434 IDXVP = ITOVP(IFROSP(IDXSP))
13435* available x above diquark thresholds for valence- and sea-diquarks
13436 XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13437
13438 IF (XXD.GE.ZERO) THEN
13439* x-values for the three diquarks of the projectile nucleon
13440 RR1 = DT_RNDM(XXD)
13441 RR2 = DT_RNDM(RR1)
13442 RR3 = DT_RNDM(RR2)
13443 SR123 = RR1+RR2+RR3
13444 XXPV = XDTHR+RR1*XXD/SR123
13445 XXPSQ = XDTHR+RR2*XXD/SR123
13446 XXPSAQ = XDTHR+RR3*XXD/SR123
13447 ELSE
13448 XXPV = XPVD(IDXVP)
13449 XXPSQ = XPSQ(IDXSP)
13450 XXPSAQ = XPSAQ(IDXSP)
13451 ENDIF
13452* flavor of the second quarks in the sea-diquark pair
13453 IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13454 IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13455* check masses of the new sea-qq - sea-q, sea-aqaq - sea-qq chains
13456 AM1 = XXPSQ *XTSQ(IDXST)*ECM**2
13457 AM2 = XXPSAQ*XTSAQ(IDXST)*ECM**2
13458 IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13459* ss-asas pair
13460 & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN
13461 IREJ = 1
13462 RETURN
13463 ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13464* at least one strange quark
13465 & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN
13466 IREJ = 1
13467 RETURN
13468 ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
13469 IREJ = 1
13470 RETURN
13471 ENDIF
13472* accept the new sea-diquark
13473 XPVD(IDXVP) = XXPV
13474 XPSQ(IDXSP) = XXPSQ
13475 XPSAQ(IDXSP) = XXPSAQ
13476 NDS = NDS+1
13477 INTDS1(NDS) = IDXSP
13478 INTDS2(NDS) = IDXST
13479 ISKPCH(2,NDS) = 0
13480 RETURN
13481 END
13482
13483*$ CREATE DT_DIFEVT.FOR
13484*COPY DT_DIFEVT
13485*
13486*===difevt=============================================================*
13487*
13488 SUBROUTINE DT_DIFEVT(IFP1,IFP2,PP,MOP,
13489 & IFT1,IFT2,PT,MOT,JDIFF,NCSY,IREJ)
13490
13491************************************************************************
13492* Interface to treatment of diffractive interactions. *
13493* (input) IFP1/2 PDG-indizes of projectile partons *
13494* (baryon: IFP2 - adiquark) *
13495* PP(4) projectile 4-momentum *
13496* IFT1/2 PDG-indizes of target partons *
13497* (baryon: IFT1 - adiquark) *
13498* PT(4) target 4-momentum *
13499* (output) JDIFF = 0 no diffraction *
13500* = 1/-1 LMSD/LMDD *
13501* = 2/-2 HMSD/HMDD *
13502* NCSY counter for two-chain systems *
13503* dumped to DTEVT1 *
13504* This version dated 14.02.95 is written by S. Roesler *
13505************************************************************************
13506
13507 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13508 SAVE
13509 PARAMETER ( LINP = 10 ,
13510 & LOUT = 6 ,
13511 & LDAT = 9 )
13512 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5,
13513 & OHALF=0.5D0)
13514
13515* event history
13516 PARAMETER (NMXHKK=200000)
13517 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
13518 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
13519 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
13520* extended event history
13521 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
13522 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
13523 & IHIST(2,NMXHKK)
13524* flags for diffractive interactions (DTUNUC 1.x)
13525 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
13526
13527 DIMENSION PP(4),PT(4)
13528
13529 LOGICAL LFIRST
13530 DATA LFIRST /.TRUE./
13531
13532 IREJ = 0
13533 JDIFF = 0
13534 IFLAGD = JDIFF
13535
13536* cm. energy
13537 XM = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
13538 & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
13539* identities of projectile hadron / target nucleon
13540 KPROJ = IDT_ICIHAD(IDHKK(MOP))
13541 KTARG = IDT_ICIHAD(IDHKK(MOT))
13542
13543* single diffractive xsections
13544 CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM)
13545* double diffractive xsections
13546**!! no double diff yet
13547C CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM,DDTOT,DDHM)
13548 DDTOT = 0.0D0
13549 DDHM = 0.0D0
13550**!!
13551* total inelastic xsection
13552C SIGIN = DT_SHNTOT(KPROJ,KTARG,XM,ZERO)-DT_SHNELA(KPROJ,KTARG,XM)
13553 DUMZER = ZERO
13554 CALL DT_XSHN(KPROJ,KTARG,DUMZER,XM,SIGTO,SIGEL)
13555 SIGIN = MAX(SIGTO-SIGEL,ZERO)
13556
13557* fraction of diffractive processes
13558 FRADIF = (SDTOT+DDTOT)/SIGIN
13559
13560 IF (LFIRST) THEN
13561 WRITE(LOUT,1000) XM,SDTOT,SIGIN
13562 1000 FORMAT(1X,'DIFEVT: single diffraction requested at E_cm = ',
13563 & F5.1,' GeV',/,9X,'sigma_sd = ',F4.1,' mb, sigma_in = ',
13564 & F5.1,' mb',/)
13565 LFIRST = .FALSE.
13566 ENDIF
13567
13568 IF ((DT_RNDM(DDHM).LE.FRADIF).OR.
13569 & (ISINGD.GT.1).OR.(IDOUBD.GT.1)) THEN
13570* diffractive interaction requested by x-section or by user
13571 FRASD = SDTOT/(SDTOT+DDTOT)
13572 FRASDH = SDHM/SDTOT
13573**sr needs to be specified!!
13574C FRADDH = DDHM/DDTOT
13575 FRADDH = 1.0D0
13576**
13577 IF ((DT_RNDM(FRASD).LE.FRASD).OR.(ISINGD.GT.1)) THEN
13578* single diffraction
13579 KDIFF = 1
13580 IF (DT_RNDM(DDTOT).LE.FRASDH) THEN
13581 KP = 2
13582 KT = 0
13583 IF (((ISINGD.EQ.4).OR.(DT_RNDM(DDTOT).GE.OHALF)).AND.
13584 & ISINGD.NE.3) THEN
13585 KP = 0
13586 KT = 2
13587 ENDIF
13588 ELSE
13589 KP = 1
13590 KT = 0
13591 IF (((ISINGD.EQ.4).OR.(DT_RNDM(FRADDH).GE.OHALF)).AND.
13592 & ISINGD.NE.3) THEN
13593 KP = 0
13594 KT = 1
13595 ENDIF
13596 ENDIF
13597 ELSE
13598* double diffraction
13599 KDIFF = -1
13600 IF (DT_RNDM(FRADDH).LE.FRADDH) THEN
13601 KP = 2
13602 KT = 2
13603 ELSE
13604 KP = 1
13605 KT = 1
13606 ENDIF
13607 ENDIF
13608 CALL DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
13609 & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
13610 IF (IREJ1.EQ.0) THEN
13611 IFLAGD = 2*KDIFF
13612 IF ((KP.EQ.1).OR.(KT.EQ.1)) IFLAGD = KDIFF
13613 ELSE
13614 GOTO 9999
13615 ENDIF
13616 ENDIF
13617 JDIFF = IFLAGD
13618
13619 RETURN
13620
13621 9999 CONTINUE
13622 IREJ = 1
13623 RETURN
13624 END
13625
13626*$ CREATE DT_DIFFKI.FOR
13627*COPY DT_DIFFKI
13628*
13629*===difkin=============================================================*
13630*
13631 SUBROUTINE DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
13632 & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ)
13633
13634************************************************************************
13635* Kinematics of diffractive nucleon-nucleon interaction. *
13636* IFP1/2 PDG-indizes of projectile partons *
13637* (baryon: IFP2 - adiquark) *
13638* PP(4) projectile 4-momentum *
13639* IFT1/2 PDG-indizes of target partons *
13640* (baryon: IFT1 - adiquark) *
13641* PT(4) target 4-momentum *
13642* KP = 0 projectile quasi-elastically scattered *
13643* = 1 excited to low-mass diff. state *
13644* = 2 excited to high-mass diff. state *
13645* KT = 0 target quasi-elastically scattered *
13646* = 1 excited to low-mass diff. state *
13647* = 2 excited to high-mass diff. state *
13648* This version dated 12.02.95 is written by S. Roesler *
13649************************************************************************
13650
13651 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13652 SAVE
13653 PARAMETER ( LINP = 10 ,
13654 & LOUT = 6 ,
13655 & LDAT = 9 )
13656 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5)
13657
13658 LOGICAL LSTART
13659
13660* particle properties (BAMJET index convention)
13661 CHARACTER*8 ANAME
13662 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
13663 & IICH(210),IIBAR(210),K1(210),K2(210)
13664* flags for input different options
13665 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
13666 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
13667 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
13668* rejection counter
13669 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
13670 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
13671 & IREXCI(3),IRDIFF(2),IRINC
13672* kinematics of diffractive interactions (DTUNUC 1.x)
13673 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
13674 & PPF(4),PTF(4),
13675 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
13676 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
13677
13678 DIMENSION PITOT(4),BGTOT(4),PP1(4),PT1(4),PPBLOB(4),PTBLOB(4),
13679 & PP(4),PT(4),PPOM1(4),DEV1(4),DEV2(4)
13680
13681 DATA LSTART /.TRUE./
13682
13683 IF (LSTART) THEN
13684 WRITE(LOUT,2000)
13685 2000 FORMAT(/,1X,'DIFEVT: diffractive interactions treated ')
13686 LSTART = .FALSE.
13687 ENDIF
13688
13689 IREJ = 0
13690
13691* initialize common /DTDIKI/
13692 CALL DT_DIFINI
13693* store momenta of initial incoming particles for emc-check
13694 IF (LEMCCK) THEN
13695 CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM,IDUM)
13696 CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM,IDUM)
13697 ENDIF
13698
13699* masses of initial particles
13700 XMP2 = PP(4)**2-PP(1)**2-PP(2)**2-PP(3)**2
13701 XMT2 = PT(4)**2-PT(1)**2-PT(2)**2-PT(3)**2
13702 IF ((XMP2.LT.ZERO).OR.(XMT2.LT.ZERO)) GOTO 9999
13703 XMP = SQRT(XMP2)
13704 XMT = SQRT(XMT2)
13705* check quark-input (used to adjust coherence cond. for M-selection)
13706 IBP = 0
13707 IF ((ABS(IFP1).GE.1000).OR.(ABS(IFP2).GE.1000)) IBP = 1
13708 IBT = 0
13709 IF ((ABS(IFT1).GE.1000).OR.(ABS(IFT2).GE.1000)) IBT = 1
13710
13711* parameter for Lorentz-transformation into nucleon-nucleon cms
13712 DO 3 K=1,4
13713 PITOT(K) = PP(K)+PT(K)
13714 3 CONTINUE
13715 XMTOT2 = PITOT(4)**2-PITOT(1)**2-PITOT(2)**2-PITOT(3)**2
13716 IF (XMTOT2.LE.ZERO) THEN
13717 WRITE(LOUT,1000) XMTOT2
13718 1000 FORMAT(1X,'DIFEVT: negative cm. energy! ',
13719 & 'XMTOT2 = ',E12.3)
13720 GOTO 9999
13721 ENDIF
13722 XMTOT = SQRT(XMTOT2)
13723 DO 4 K=1,4
13724 BGTOT(K) = PITOT(K)/XMTOT
13725 4 CONTINUE
13726* transformation of nucleons into cms
13727 CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PP(1),PP(2),
13728 & PP(3),PP(4),PPTOT,PP1(1),PP1(2),PP1(3),PP1(4))
13729 CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PT(1),PT(2),
13730 & PT(3),PT(4),PTTOT,PT1(1),PT1(2),PT1(3),PT1(4))
13731* rotation angles
13732 COD = PP1(3)/PPTOT
13733C SID = SQRT((ONE-COD)*(ONE+COD))
13734 PPT = SQRT(PP1(1)**2+PP1(2)**2)
13735 SID = PPT/PPTOT
13736 COF = ONE
13737 SIF = ZERO
13738 IF(PPTOT*SID.GT.TINY10) THEN
13739 COF = PP1(1)/(SID*PPTOT)
13740 SIF = PP1(2)/(SID*PPTOT)
13741 ANORF = SQRT(COF*COF+SIF*SIF)
13742 COF = COF/ANORF
13743 SIF = SIF/ANORF
13744 ENDIF
13745* check consistency
13746 DO 5 K=1,4
13747 DEV1(K) = ABS(PP1(K)+PT1(K))
13748 5 CONTINUE
13749 DEV1(4) = ABS(DEV1(4)-XMTOT)
13750 IF ((DEV1(1).GT.TINY10).OR.(DEV1(2).GT.TINY10).OR.
13751 & (DEV1(3).GT.TINY10).OR.(DEV1(4).GT.TINY10)) THEN
13752 WRITE(LOUT,1001) DEV1
13753 1001 FORMAT(1X,'DIFEVT: inconsitent Lorentz-transformation! ',
13754 & /,8X,4E12.3)
13755 GOTO 9999
13756 ENDIF
13757
13758* select x-fractions in high-mass diff. interactions
13759 IF ((KP.EQ.2).OR.(KT.EQ.2)) CALL DT_XVALHM(KP,KT)
13760
13761* select diffractive masses
13762* - projectile
13763 IF (KP.EQ.1) THEN
13764 XMPF = DT_XMLMD(XMTOT)
13765 CALL DT_LM2RES(IFP1,IFP2,XMPF,IDPR,IDXPR,IREJ1)
13766 IF (IREJ1.GT.0) GOTO 9999
13767 ELSEIF (KP.EQ.2) THEN
13768 XMPF = DT_XMHMD(XMTOT,IBP,1)
13769 ELSE
13770 XMPF = XMP
13771 ENDIF
13772* - target
13773 IF (KT.EQ.1) THEN
13774 XMTF = DT_XMLMD(XMTOT)
13775 CALL DT_LM2RES(IFT1,IFT2,XMTF,IDTR,IDXTR,IREJ1)
13776 IF (IREJ1.GT.0) GOTO 9999
13777 ELSEIF (KT.EQ.2) THEN
13778 XMTF = DT_XMHMD(XMTOT,IBT,2)
13779 ELSE
13780 XMTF = XMT
13781 ENDIF
13782
13783* kinematical treatment of "two-particle" system (masses - XMPF,XMTF)
13784 XMPF2 = XMPF**2
13785 XMTF2 = XMTF**2
13786 PPBLOB(3) = DT_YLAMB(XMTOT2,XMPF2,XMTF2)/(2.D0*XMTOT)
13787 PPBLOB(4) = SQRT(XMPF2+PPBLOB(3)**2)
13788
13789* select momentum transfer (all t-values used here are <0)
13790* minimum absolute value to produce diffractive masses
13791 TMIN = XMP2+XMPF2-2.0D0*(PP1(4)*PPBLOB(4)-PPTOT*PPBLOB(3))
13792 TT = DT_TDIFF(XMTOT,TMIN,XMPF,KP,XMTF,KT,IREJ1)
13793 IF (IREJ1.GT.0) GOTO 9999
13794
13795* longitudinal momentum of excited/elastically scattered projectile
13796 PPBLOB(3) = (TT-XMP2-XMPF2+2.0D0*PP1(4)*PPBLOB(4))/(2.0D0*PPTOT)
13797* total transverse momentum due to t-selection
13798 PPBLT2 = PPBLOB(4)**2-PPBLOB(3)**2-XMPF2
13799 IF (PPBLT2.LT.ZERO) THEN
13800 WRITE(LOUT,1002) PPBLT2,KP,PP1,XMPF,KT,PT1,XMTF,TT
13801 1002 FORMAT(1X,'DIFEVT: inconsistent transverse momentum! ',
13802 & E12.3,2(/,1X,I2,5E12.3),/,1X,E12.3)
13803 GOTO 9999
13804 ENDIF
13805 CALL DT_DSFECF(SINPHI,COSPHI)
13806 PPBLT = SQRT(PPBLT2)
13807 PPBLOB(1) = COSPHI*PPBLT
13808 PPBLOB(2) = SINPHI*PPBLT
13809
13810* rotate excited/elastically scattered projectile into n-n cms.
13811 CALL DT_MYTRAN(1,PPBLOB(1),PPBLOB(2),PPBLOB(3),COD,SID,COF,SIF,
13812 & XX,YY,ZZ)
13813 PPBLOB(1) = XX
13814 PPBLOB(2) = YY
13815 PPBLOB(3) = ZZ
13816
13817* 4-momentum of excited/elastically scattered target and of exchanged
13818* Pomeron
13819 DO 6 K=1,4
13820 IF (K.LT.4) PTBLOB(K) = -PPBLOB(K)
13821 PPOM1(K) = PP1(K)-PPBLOB(K)
13822 6 CONTINUE
13823 PTBLOB(4) = XMTOT-PPBLOB(4)
13824
13825* Lorentz-transformation back into system of initial diff. collision
13826 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13827 & PPBLOB(1),PPBLOB(2),PPBLOB(3),PPBLOB(4),
13828 & PPTOTF,PPF(1),PPF(2),PPF(3),PPF(4))
13829 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13830 & PTBLOB(1),PTBLOB(2),PTBLOB(3),PTBLOB(4),
13831 & PTTOTF,PTF(1),PTF(2),PTF(3),PTF(4))
13832 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13833 & PPOM1(1),PPOM1(2),PPOM1(3),PPOM1(4),
13834 & PPOMTO,PPOM(1),PPOM(2),PPOM(3),PPOM(4))
13835
13836* store 4-momentum of elastically scattered particle (in single diff.
13837* events)
13838 IF (KP.EQ.0) THEN
13839 DO 7 K=1,4
13840 PSC(K) = PPF(K)
13841 7 CONTINUE
13842 ELSEIF (KT.EQ.0) THEN
13843 DO 8 K=1,4
13844 PSC(K) = PTF(K)
13845 8 CONTINUE
13846 ENDIF
13847
13848* check consistency of kinematical treatment so far
13849 IF (LEMCCK) THEN
13850 CALL DT_EVTEMC(-PPF(1),-PPF(2),-PPF(3),-PPF(4),2,IDUM,IDUM)
13851 CALL DT_EVTEMC(-PTF(1),-PTF(2),-PTF(3),-PTF(4),2,IDUM,IDUM)
13852 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,60,IREJ1)
13853 IF (IREJ1.NE.0) GOTO 9999
13854 ENDIF
13855 DO 9 K=1,4
13856 DEV1(K) = ABS(PP(K)-PPF(K)-PPOM(K))
13857 DEV2(K) = ABS(PT(K)-PTF(K)+PPOM(K))
13858 9 CONTINUE
13859 IF ((DEV1(1).GT.TINY5).OR.(DEV1(2).GT.TINY5).OR.
13860 & (DEV1(3).GT.TINY5).OR.(DEV1(4).GT.TINY5).OR.
13861 & (DEV2(1).GT.TINY5).OR.(DEV2(2).GT.TINY5).OR.
13862 & (DEV2(3).GT.TINY5).OR.(DEV2(4).GT.TINY5)) THEN
13863 WRITE(LOUT,1003) DEV1,DEV2
13864 1003 FORMAT(1X,'DIFEVT: inconsitent kinematical treatment! ',
13865 & 2(/,8X,4E12.3))
13866 GOTO 9999
13867 ENDIF
13868
13869* kinematical treatment for low-mass diffraction
13870 CALL DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ1)
13871 IF (IREJ1.NE.0) GOTO 9999
13872
13873* dump diffractive chains into DTEVT1
13874 CALL DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
13875 IF (IREJ1.NE.0) GOTO 9999
13876
13877 RETURN
13878
13879 9999 CONTINUE
13880 IRDIFF(1) = IRDIFF(1)+1
13881 IREJ = 1
13882 RETURN
13883 END
13884
13885*$ CREATE DT_XMHMD.FOR
13886*COPY DT_XMHMD
13887*
13888*===xmhmd==============================================================*
13889*
13890 DOUBLE PRECISION FUNCTION DT_XMHMD(ECM,IB,MODE)
13891
13892************************************************************************
13893* Diffractive mass in high mass single/double diffractive events. *
13894* This version dated 11.02.95 is written by S. Roesler *
13895************************************************************************
13896
13897 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13898 SAVE
13899 PARAMETER ( LINP = 10 ,
13900 & LOUT = 6 ,
13901 & LDAT = 9 )
13902 PARAMETER (OHALF=0.5D0,ONE=1.0D0,ZERO=0.0D0)
13903
13904* kinematics of diffractive interactions (DTUNUC 1.x)
13905 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
13906 & PPF(4),PTF(4),
13907 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
13908 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
13909
13910C DATA XCOLOW /0.05D0/
13911 DATA XCOLOW /0.15D0/
13912
13913 DT_XMHMD = ZERO
13914 XH = XPH(2)
13915 IF (MODE.EQ.2) XH = XTH(2)
13916
13917* minimum Pomeron-x for high-mass diffraction
13918* (adjusted to get a smooth transition between HM and LM component)
13919 R = DT_RNDM(XH)
13920 XDIMIN = (3.0D0+400.0D0*R**2)/(XH*ECM**2)
13921 IF (ECM.LE.300.0D0) THEN
13922 RR = (1.0D0-EXP(-((ECM/140.0D0)**4)))
13923 XDIMIN = (3.0D0+400.0D0*(R**2)*RR)/(XH*ECM**2)
13924 ENDIF
13925* maximum Pomeron-x for high-mass diffraction
13926* (coherence condition, adjusted to fit to experimental data)
13927 IF (IB.NE.0) THEN
13928* baryon-diffraction
13929 XDIMAX = XCOLOW*(1.0D0+EXP(-((ECM/420.0D0)**2)))
13930 ELSE
13931* meson-diffraction
13932 XDIMAX = XCOLOW*(1.0D0+4.0D0*EXP(-((ECM/420.0D0)**2)))
13933 ENDIF
13934* check boundaries
13935 IF (XDIMIN.GE.XDIMAX) THEN
13936 XDIMIN = OHALF*XDIMAX
13937 ENDIF
13938
13939 KLOOP = 0
13940 1 CONTINUE
13941 KLOOP = KLOOP+1
13942 IF (KLOOP.GT.20) RETURN
13943* sample Pomeron-x from 1/x-distribution (critical Pomeron)
13944 XDIFF = DT_SAMPEX(XDIMIN,XDIMAX)
13945* corr. diffr. mass
13946 DT_XMHMD = ECM*SQRT(XDIFF)
13947 IF (DT_XMHMD.LT.2.5D0) GOTO 1
13948
13949 RETURN
13950 END
13951
13952*$ CREATE DT_XMLMD.FOR
13953*COPY DT_XMLMD
13954*
13955*===xmlmd==============================================================*
13956*
13957 DOUBLE PRECISION FUNCTION DT_XMLMD(ECM)
13958
13959************************************************************************
13960* Diffractive mass in high mass single/double diffractive events. *
13961* This version dated 11.02.95 is written by S. Roesler *
13962************************************************************************
13963
13964 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13965 SAVE
13966 PARAMETER ( LINP = 10 ,
13967 & LOUT = 6 ,
13968 & LDAT = 9 )
13969
13970* minimum Pomeron-x for low-mass diffraction
13971C AMO = 1.5D0
13972 AMO = 2.0D0
13973* maximum Pomeron-x for low-mass diffraction
13974* (adjusted to get a smooth transition between HM and LM component)
13975 R = DT_RNDM(AMO)
13976 SAM = 1.0D0
13977 IF (ECM.LE.300.0D0) SAM = 1.0D0-EXP(-((ECM/200.0D0)**4))
13978 R = DT_RNDM(AMO)*SAM
13979 AMAX= (1.0D0-SAM)*SQRT(0.1D0*ECM**2)+SAM*SQRT(400.0D0)
13980 AMU = R*SQRT(100.0D0)+(1.0D0-R)*AMAX
13981
13982* selection of diffractive mass
13983* (adjusted to get a smooth transition between HM and LM component)
13984 R = DT_RNDM(AMU)
13985 IF (ECM.LE.50.0D0) THEN
13986 DT_XMLMD = AMO*(AMU/AMO)**R
13987 ELSE
13988 A = 0.7D0
13989 IF (ECM.LE.300.0D0) A = 0.7D0*(1.0D0-EXP(-((ECM/100.0D0)**2)))
13990 DT_XMLMD = 1.0D0/((R/(AMU**A)+(1.0D0-R)/(AMO**A))**(1.0D0/A))
13991 ENDIF
13992
13993 RETURN
13994 END
13995
13996*$ CREATE DT_TDIFF.FOR
13997*COPY DT_TDIFF
13998*
13999*===tdiff==============================================================*
14000*
14001 DOUBLE PRECISION FUNCTION DT_TDIFF(ECM,TMIN,XM1I,K1,XM2I,K2,IREJ)
14002
14003************************************************************************
14004* t-selection for single/double diffractive interactions. *
14005* ECM cm. energy *
14006* TMIN minimum momentum transfer to produce diff. masses *
14007* XM1/XM2 diffractively produced masses *
14008* (for single diffraction XM2 is obsolete) *
14009* K1/K2= 0 not excited *
14010* = 1 low-mass excitation *
14011* = 2 high-mass excitation *
14012* This version dated 11.02.95 is written by S. Roesler *
14013************************************************************************
14014
14015 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14016 SAVE
14017 PARAMETER ( LINP = 10 ,
14018 & LOUT = 6 ,
14019 & LDAT = 9 )
14020 PARAMETER (ZERO=0.0D0)
14021
14022 PARAMETER ( BTP0 = 3.7D0,
14023 & ALPHAP = 0.24D0 )
14024
14025 IREJ = 0
14026 NCLOOP = 0
14027 DT_TDIFF = ZERO
14028
14029 IF (K1.GT.0) THEN
14030 XM1 = XM1I
14031 XM2 = XM2I
14032 ELSE
14033 XM1 = XM2I
14034 ENDIF
14035 XDI = (XM1/ECM)**2
14036 IF ((K1.EQ.0).OR.(K2.EQ.0)) THEN
14037* slope for single diffraction
14038 SLOPE = BTP0-2.0D0*ALPHAP*LOG(XDI)
14039 ELSE
14040* slope for double diffraction
14041 SLOPE = -2.0D0*ALPHAP*LOG(XDI*XM2**2)
14042 ENDIF
14043
14044 1 CONTINUE
14045 NCLOOP = NCLOOP+1
14046 IF (MOD(NCLOOP,1000).EQ.0) GOTO 9999
14047 Y = DT_RNDM(XDI)
14048 T = -LOG(1.0D0-Y)/SLOPE
14049 IF (ABS(T).LE.ABS(TMIN)) GOTO 1
14050 DT_TDIFF = -ABS(T)
14051
14052 RETURN
14053
14054 9999 CONTINUE
14055 WRITE(LOUT,1000) ECM,TMIN,XM1I,XM2I,K1,K2
14056 1000 FORMAT(1X,'DT_TDIFF: t-selection rejected!',/,
14057 & 1X,'ECM = ',E12.3,' TMIN = ',E12.2,/,1X,'XM1I = ',
14058 & E12.3,' XM2I = ',E12.3,' K1 = ',I2,' K2 = ',I2)
14059 IREJ = 1
14060 RETURN
14061 END
14062
14063*$ CREATE DT_XVALHM.FOR
14064*COPY DT_XVALHM
14065*
14066*===xvalhm=============================================================*
14067*
14068 SUBROUTINE DT_XVALHM(KP,KT)
14069
14070************************************************************************
14071* Sampling of parton x-values in high-mass diffractive interactions. *
14072* This version dated 12.02.95 is written by S. Roesler *
14073************************************************************************
14074
14075 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14076 SAVE
14077 PARAMETER ( LINP = 10 ,
14078 & LOUT = 6 ,
14079 & LDAT = 9 )
14080 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0,TINY2=1.0D-2)
14081
14082* kinematics of diffractive interactions (DTUNUC 1.x)
14083 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14084 & PPF(4),PTF(4),
14085 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14086 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14087* various options for treatment of partons (DTUNUC 1.x)
14088* (chain recombination, Cronin,..)
14089 LOGICAL LCO2CR,LINTPT
14090 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
14091 & LCO2CR,LINTPT
14092
14093 DATA UNON,XVQTHR /2.0D0,0.8D0/
14094
14095 IF (KP.EQ.2) THEN
14096* x-fractions of projectile valence partons
14097 1 CONTINUE
14098 XPH(1) = DT_DBETAR(OHALF,UNON)
14099 IF (XPH(1).GE.XVQTHR) GOTO 1
14100 XPH(2) = ONE-XPH(1)
14101* x-fractions of Pomeron q-aq-pair
14102 XPOLO = TINY2
14103 XPOHI = ONE-TINY2
14104 XPPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14105 XPPO(2) = ONE-XPPO(1)
14106* flavors of Pomeron q-aq-pair
14107 IFLAV = INT(ONE+DT_RNDM(UNON)*(2.0D0+SEASQ))
14108 IFPPO(1) = IFLAV
14109 IFPPO(2) = -IFLAV
14110 IF (DT_RNDM(UNON).GT.OHALF) THEN
14111 IFPPO(1) = -IFLAV
14112 IFPPO(2) = IFLAV
14113 ENDIF
14114 ENDIF
14115
14116 IF (KT.EQ.2) THEN
14117* x-fractions of projectile target partons
14118 2 CONTINUE
14119 XTH(1) = DT_DBETAR(OHALF,UNON)
14120 IF (XTH(1).GE.XVQTHR) GOTO 2
14121 XTH(2) = ONE-XTH(1)
14122* x-fractions of Pomeron q-aq-pair
14123 XPOLO = TINY2
14124 XPOHI = ONE-TINY2
14125 XTPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14126 XTPO(2) = ONE-XTPO(1)
14127* flavors of Pomeron q-aq-pair
14128 IFLAV = INT(ONE+DT_RNDM(XPOLO)*(2.0D0+SEASQ))
14129 IFTPO(1) = IFLAV
14130 IFTPO(2) = -IFLAV
14131 IF (DT_RNDM(XPOLO).GT.OHALF) THEN
14132 IFTPO(1) = -IFLAV
14133 IFTPO(2) = IFLAV
14134 ENDIF
14135 ENDIF
14136
14137 RETURN
14138 END
14139
14140*$ CREATE DT_LM2RES.FOR
14141*COPY DT_LM2RES
14142*
14143*===lm2res=============================================================*
14144*
14145 SUBROUTINE DT_LM2RES(IF1,IF2,XM,IDR,IDXR,IREJ)
14146
14147************************************************************************
14148* Check low-mass diffractive excitation for resonance mass. *
14149* (input) IF1/2 PDG-indizes of valence partons *
14150* (in/out) XM diffractive mass requested/corrected *
14151* (output) IDR/IDXR id./BAMJET-index of resonance *
14152* This version dated 12.02.95 is written by S. Roesler *
14153************************************************************************
14154
14155 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14156 SAVE
14157 PARAMETER ( LINP = 10 ,
14158 & LOUT = 6 ,
14159 & LDAT = 9 )
14160 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14161
14162* kinematics of diffractive interactions (DTUNUC 1.x)
14163 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14164 & PPF(4),PTF(4),
14165 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14166 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14167
14168 IREJ = 0
14169 IF1B = 0
14170 IF2B = 0
14171 XMI = XM
14172
14173* BAMJET indices of partons
14174 IF1A = IDT_IPDG2B(IF1,1,2)
14175 IF (ABS(IF1).GE.1000) IF1B = IDT_IPDG2B(IF1,2,2)
14176 IF2A = IDT_IPDG2B(IF2,1,2)
14177 IF (ABS(IF2).GE.1000) IF2B = IDT_IPDG2B(IF2,2,2)
14178
14179* get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq)
14180 IDCH = 2
14181 IF ((IF1B.EQ.0).AND.(IF2B.EQ.0)) IDCH = 1
14182
14183* check for resonance mass
14184 CALL DT_CH2RES(IF1A,IF1B,IF2A,IF2B,IDR,IDXR,XMI,XMN,IDCH,IREJ1)
14185 IF (IREJ1.NE.0) GOTO 9999
14186
14187 XM = XMN
14188 RETURN
14189
14190 9999 CONTINUE
14191 IREJ = 1
14192 RETURN
14193 END
14194
14195*$ CREATE DT_LMKINE.FOR
14196*COPY DT_LMKINE
14197*
14198*===lmkine=============================================================*
14199*
14200 SUBROUTINE DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ)
14201
14202************************************************************************
14203* Kinematical treatment of low-mass excitations. *
14204* This version dated 12.02.95 is written by S. Roesler *
14205************************************************************************
14206
14207 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14208 SAVE
14209 PARAMETER ( LINP = 10 ,
14210 & LOUT = 6 ,
14211 & LDAT = 9 )
14212 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14213
14214* flags for input different options
14215 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14216 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14217 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14218* kinematics of diffractive interactions (DTUNUC 1.x)
14219 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14220 & PPF(4),PTF(4),
14221 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14222 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14223
14224 DIMENSION P1(4),P2(4)
14225
14226 IREJ = 0
14227
14228 IF (KP.EQ.1) THEN
14229 PABS = SQRT(PPF(1)**2+PPF(2)**2+PPF(3)**2)
14230 POE = PPF(4)/PABS
14231 FAC1 = OHALF*(POE+ONE)
14232 FAC2 = -OHALF*(POE-ONE)
14233 DO 1 K=1,3
14234 PPLM1(K) = FAC1*PPF(K)
14235 PPLM2(K) = FAC2*PPF(K)
14236 1 CONTINUE
14237 PPLM1(4) = FAC1*PABS
14238 PPLM2(4) = -FAC2*PABS
14239 IF (IMSHL.EQ.1) THEN
14240 XM1 = PYMASS(IFP1)
14241 XM2 = PYMASS(IFP2)
14242 CALL DT_MASHEL(PPLM1,PPLM2,XM1,XM2,P1,P2,IREJ1)
14243 IF (IREJ1.NE.0) GOTO 9999
14244 DO 2 K=1,4
14245 PPLM1(K) = P1(K)
14246 PPLM2(K) = P2(K)
14247 2 CONTINUE
14248 ENDIF
14249 ENDIF
14250
14251 IF (KT.EQ.1) THEN
14252 PABS = SQRT(PTF(1)**2+PTF(2)**2+PTF(3)**2)
14253 POE = PTF(4)/PABS
14254 FAC1 = OHALF*(POE+ONE)
14255 FAC2 = -OHALF*(POE-ONE)
14256 DO 3 K=1,3
14257 PTLM2(K) = FAC1*PTF(K)
14258 PTLM1(K) = FAC2*PTF(K)
14259 3 CONTINUE
14260 PTLM2(4) = FAC1*PABS
14261 PTLM1(4) = -FAC2*PABS
14262 IF (IMSHL.EQ.1) THEN
14263 XM1 = PYMASS(IFT1)
14264 XM2 = PYMASS(IFT2)
14265 CALL DT_MASHEL(PTLM1,PTLM2,XM1,XM2,P1,P2,IREJ1)
14266 IF (IREJ1.NE.0) GOTO 9999
14267 DO 4 K=1,4
14268 PTLM1(K) = P1(K)
14269 PTLM2(K) = P2(K)
14270 4 CONTINUE
14271 ENDIF
14272 ENDIF
14273
14274 RETURN
14275
14276 9999 CONTINUE
14277 WRITE(LOUT,'(A)') 'LMKINE: kinematical treatment rejected'
14278 IREJ = 1
14279 RETURN
14280 END
14281
14282*$ CREATE DT_DIFINI.FOR
14283*COPY DT_DIFINI
14284*
14285*===difini=============================================================*
14286*
14287 SUBROUTINE DT_DIFINI
14288
14289************************************************************************
14290* Initialization of common /DTDIKI/ *
14291* This version dated 12.02.95 is written by S. Roesler *
14292************************************************************************
14293
14294 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14295 SAVE
14296 PARAMETER ( LINP = 10 ,
14297 & LOUT = 6 ,
14298 & LDAT = 9 )
14299 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14300
14301* kinematics of diffractive interactions (DTUNUC 1.x)
14302 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14303 & PPF(4),PTF(4),
14304 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14305 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14306
14307 DO 1 K=1,4
14308 PPOM(K) = ZERO
14309 PSC(K) = ZERO
14310 PPF(K) = ZERO
14311 PTF(K) = ZERO
14312 PPLM1(K) = ZERO
14313 PPLM2(K) = ZERO
14314 PTLM1(K) = ZERO
14315 PTLM2(K) = ZERO
14316 1 CONTINUE
14317 DO 2 K=1,2
14318 XPH(K) = ZERO
14319 XPPO(K) = ZERO
14320 XTH(K) = ZERO
14321 XTPO(K) = ZERO
14322 IFPPO(K) = 0
14323 IFTPO(K) = 0
14324 2 CONTINUE
14325 IDPR = 0
14326 IDXPR = 0
14327 IDTR = 0
14328 IDXTR = 0
14329
14330 RETURN
14331 END
14332
14333*$ CREATE DT_DIFPUT.FOR
14334*COPY DT_DIFPUT
14335*
14336*===difput=============================================================*
14337*
14338 SUBROUTINE DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,
14339 & IREJ)
14340
14341************************************************************************
14342* Dump diffractive chains into DTEVT1 *
14343* This version dated 12.02.95 is written by S. Roesler *
14344************************************************************************
14345
14346 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14347 SAVE
14348 PARAMETER ( LINP = 10 ,
14349 & LOUT = 6 ,
14350 & LDAT = 9 )
14351 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14352
14353 LOGICAL LCHK
14354
14355* kinematics of diffractive interactions (DTUNUC 1.x)
14356 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14357 & PPF(4),PTF(4),
14358 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14359 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14360* event history
14361 PARAMETER (NMXHKK=200000)
14362 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14363 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14364 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14365* extended event history
14366 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14367 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14368 & IHIST(2,NMXHKK)
14369* rejection counter
14370 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
14371 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
14372 & IREXCI(3),IRDIFF(2),IRINC
14373
14374 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PCH(4),PP(4),PT(4),
14375 & P1(4),P2(4),P3(4),P4(4)
14376
14377 IREJ = 0
14378
14379 IF (KP.EQ.1) THEN
14380 DO 1 K=1,4
14381 PCH(K) = PPLM1(K)+PPLM2(K)
14382 1 CONTINUE
14383 ID1 = IFP1
14384 ID2 = IFP2
14385 IF (DT_RNDM(PT).GT.OHALF) THEN
14386 ID1 = IFP2
14387 ID2 = IFP1
14388 ENDIF
14389 CALL DT_EVTPUT(21,ID1,MOP,0,PPLM1(1),PPLM1(2),PPLM1(3),
14390 & PPLM1(4),0,0,0)
14391 CALL DT_EVTPUT(21,ID2,MOP,0,PPLM2(1),PPLM2(2),PPLM2(3),
14392 & PPLM2(4),0,0,0)
14393 CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
14394 & IDPR,IDXPR,8)
14395 ELSEIF (KP.EQ.2) THEN
14396 DO 2 K=1,4
14397 PP1(K) = XPH(1)*PP(K)
14398 PP2(K) = XPH(2)*PP(K)
14399 PT1(K) = -XPPO(1)*PPOM(K)
14400 PT2(K) = -XPPO(2)*PPOM(K)
14401 2 CONTINUE
14402 CALL DT_CHKCSY(IFP1,IFPPO(1),LCHK)
14403 XM1 = ZERO
14404 XM2 = ZERO
14405 IF (LCHK) THEN
14406 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
14407 IF (IREJ1.NE.0) GOTO 9999
14408 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
14409 IF (IREJ1.NE.0) GOTO 9999
14410 DO 3 K=1,4
14411 PP1(K) = P1(K)
14412 PT1(K) = P2(K)
14413 PP2(K) = P3(K)
14414 PT2(K) = P4(K)
14415 3 CONTINUE
14416 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
14417 & 0,0,8)
14418 CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
14419 & PT1(4),0,0,8)
14420 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
14421 & 0,0,8)
14422 CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
14423 & PT2(4),0,0,8)
14424 ELSE
14425 CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
14426 IF (IREJ1.NE.0) GOTO 9999
14427 CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
14428 IF (IREJ1.NE.0) GOTO 9999
14429 DO 4 K=1,4
14430 PP1(K) = P1(K)
14431 PT2(K) = P2(K)
14432 PP2(K) = P3(K)
14433 PT1(K) = P4(K)
14434 4 CONTINUE
14435 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
14436 & 0,0,8)
14437 CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
14438 & PT2(4),0,0,8)
14439 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
14440 & 0,0,8)
14441 CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
14442 & PT1(4),0,0,8)
14443 ENDIF
14444 NCSY = NCSY+1
14445 ELSE
14446 CALL DT_EVTPUT(1,IDHKK(MOP),MOP,0,PSC(1),PSC(2),PSC(3),PSC(4),
14447 & 0,0,0)
14448 ENDIF
14449
14450 IF (KT.EQ.1) THEN
14451 DO 5 K=1,4
14452 PCH(K) = PTLM1(K)+PTLM2(K)
14453 5 CONTINUE
14454 ID1 = IFT1
14455 ID2 = IFT2
14456 IF (DT_RNDM(PT).GT.OHALF) THEN
14457 ID1 = IFT2
14458 ID2 = IFT1
14459 ENDIF
14460 CALL DT_EVTPUT(22,ID1,MOT,0,PTLM1(1),PTLM1(2),PTLM1(3),
14461 & PTLM1(4),0,0,0)
14462 CALL DT_EVTPUT(22,ID2,MOT,0,PTLM2(1),PTLM2(2),PTLM2(3),
14463 & PTLM2(4),0,0,0)
14464 CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
14465 & IDTR,IDXTR,8)
14466 ELSEIF (KT.EQ.2) THEN
14467 DO 6 K=1,4
14468 PP1(K) = XTPO(1)*PPOM(K)
14469 PP2(K) = XTPO(2)*PPOM(K)
14470 PT1(K) = XTH(2)*PT(K)
14471 PT2(K) = XTH(1)*PT(K)
14472 6 CONTINUE
14473 CALL DT_CHKCSY(IFTPO(1),IFT1,LCHK)
14474 XM1 = ZERO
14475 XM2 = ZERO
14476 IF (LCHK) THEN
14477 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
14478 IF (IREJ1.NE.0) GOTO 9999
14479 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
14480 IF (IREJ1.NE.0) GOTO 9999
14481 DO 7 K=1,4
14482 PP1(K) = P1(K)
14483 PT1(K) = P2(K)
14484 PP2(K) = P3(K)
14485 PT2(K) = P4(K)
14486 7 CONTINUE
14487 CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
14488 & PP1(4),0,0,8)
14489 CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
14490 & 0,0,8)
14491 CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
14492 & PP2(4),0,0,8)
14493 CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
14494 & 0,0,8)
14495 ELSE
14496 CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
14497 IF (IREJ1.NE.0) GOTO 9999
14498 CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
14499 IF (IREJ1.NE.0) GOTO 9999
14500 DO 8 K=1,4
14501 PP1(K) = P1(K)
14502 PT2(K) = P2(K)
14503 PP2(K) = P3(K)
14504 PT1(K) = P4(K)
14505 8 CONTINUE
14506 CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
14507 & PP1(4),0,0,8)
14508 CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
14509 & 0,0,8)
14510 CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
14511 & PP2(4),0,0,8)
14512 CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
14513 & 0,0,8)
14514 ENDIF
14515 NCSY = NCSY+1
14516 ELSE
14517 CALL DT_EVTPUT(1,IDHKK(MOT),MOT,0,PSC(1),PSC(2),PSC(3),PSC(4),
14518 & 0,0,0)
14519 ENDIF
14520
14521 RETURN
14522
14523 9999 CONTINUE
14524 IRDIFF(2) = IRDIFF(2)+1
14525 IREJ = 1
14526 RETURN
14527 END
14528
14529*$ CREATE DT_EVTFRG.FOR
14530*COPY DT_EVTFRG
14531*
14532*===evtfrg=============================================================*
14533*
14534 SUBROUTINE DT_EVTFRG(KMODE,NFRG,NPYMEM,IREJ)
14535
14536************************************************************************
14537* Hadronization of chains in DTEVT1. *
14538* *
14539* Input: *
14540* KMODE = 1 hadronization of PHOJET-chains (id=77xxx) *
14541* = 2 hadronization of DTUNUC-chains (id=88xxx) *
14542* NFRG if KMODE = 1 : upper index of PHOJET-scatterings to be *
14543* hadronized with one PYEXEC call *
14544* if KMODE = 2 : max. number of DTUNUC-chains to be hadronized *
14545* with one PYEXEC call *
14546* Output: *
14547* NPYMEM number of entries in JETSET-common after hadronization *
14548* IREJ rejection flag *
14549* *
14550* This version dated 17.09.00 is written by S. Roesler *
14551************************************************************************
14552
14553 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14554 SAVE
14555 PARAMETER ( LINP = 10 ,
14556 & LOUT = 6 ,
14557 & LDAT = 9 )
14558 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1)
14559 PARAMETER (ONE=1.0D0,ZERO=0.0D0)
14560
14561 LOGICAL LACCEP
14562
14563 PARAMETER (MXJOIN=200)
14564
14565* event history
14566 PARAMETER (NMXHKK=200000)
14567 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14568 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14569 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14570* extended event history
14571 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14572 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14573 & IHIST(2,NMXHKK)
14574* flags for input different options
14575 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14576 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14577 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14578* statistics
14579 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
14580 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
14581 & ICEVTG(8,0:30)
14582* flags for diffractive interactions (DTUNUC 1.x)
14583 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
14584* nucleon-nucleon event-generator
14585 CHARACTER*8 CMODEL
14586 LOGICAL LPHOIN
14587 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
14588* phojet
14589C model switches and parameters
14590 CHARACTER*8 MDLNA
14591 INTEGER ISWMDL,IPAMDL
14592 DOUBLE PRECISION PARMDL
14593 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14594* jetset
14595 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
1ddc441c 14596 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
9aaba0d6 14597 PARAMETER (MAXLND=4000)
14598 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
14599 INTEGER PYK
14600 DIMENSION IJOIN(MXJOIN),ISJOIN(MXJOIN),IHISMO(8000),IFLG(4000)
1ddc441c 14601 INTEGER PYCOMP
9aaba0d6 14602 MODE = KMODE
14603 ISTSTG = 7
14604 IF (MODE.NE.1) ISTSTG = 8
14605 IREJ = 0
14606
14607 IP = 0
14608 ISH = 0
14609 INIEMC = 1
14610 NEND = NHKK
14611 NACCEP = 0
14612 IFRG = 0
14613 IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
14614 DO 10 I=NPOINT(3),NEND
14615* sr 14.02.00: seems to be not necessary anymore, commented
14616C LACCEP = ((NOBAM(I).EQ.0).AND.(MODE.EQ.1)).OR.
14617C & ((NOBAM(I).NE.0).AND.(MODE.EQ.2))
14618 LACCEP = .TRUE.
14619* pick up chains from dtevt1
14620 IDCHK = IDHKK(I)/10000
14621 IF ((IDCHK.EQ.ISTSTG).AND.LACCEP) THEN
14622 IF (IDCHK.EQ.7) THEN
14623 IPJE = IDHKK(I)-IDCHK*10000
14624 IF (IPJE.NE.IFRG) THEN
14625 IFRG = IPJE
14626 IF (IFRG.GT.NFRG) GOTO 16
14627 ENDIF
14628 ELSE
14629 IPJE = 1
14630 IFRG = IFRG+1
14631 IF (IFRG.GT.NFRG) THEN
14632 NFRG = -1
14633 GOTO 16
14634 ENDIF
14635 ENDIF
14636* statistics counter
14637c IF (IDCH(I).LE.8)
14638c & ICCHAI(2,IDCH(I)) = ICCHAI(2,IDCH(I))+1
14639c IF (IDRES(I).NE.0) ICRES(IDCH(I)) = ICRES(IDCH(I))+1
14640* special treatment for small chains already corrected to hadrons
14641 IF (IDRES(I).NE.0) THEN
14642 IF (IDRES(I).EQ.11) THEN
14643 ID = IDXRES(I)
14644 ELSE
14645 ID = IDT_IPDGHA(IDXRES(I))
14646 ENDIF
14647 IF (LEMCCK) THEN
14648 CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
14649 & PHKK(4,I),INIEMC,IDUM,IDUM)
14650 INIEMC = 2
14651 ENDIF
14652 IP = IP+1
14653 IF (IP.GT.MSTU(4)) STOP ' NEWFRA 1: IP.GT.MSTU(4) !'
14654 P(IP,1) = PHKK(1,I)
14655 P(IP,2) = PHKK(2,I)
14656 P(IP,3) = PHKK(3,I)
14657 P(IP,4) = PHKK(4,I)
14658 P(IP,5) = PHKK(5,I)
14659 K(IP,1) = 1
14660 K(IP,2) = ID
14661 K(IP,3) = 0
14662 K(IP,4) = 0
14663 K(IP,5) = 0
14664 IHIST(2,I) = 10000*IPJE+IP
14665 IF (IHIST(1,I).LE.-100) THEN
14666 ISH = ISH+1
14667 IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
14668 ISJOIN(ISH) = I
14669 ENDIF
14670 N = IP
14671 IHISMO(IP) = I
14672 ELSE
14673 IJ = 0
14674 DO 11 KK=JMOHKK(1,I),JMOHKK(2,I)
14675 IF (LEMCCK) THEN
14676 CALL DT_EVTEMC(PHKK(1,KK),PHKK(2,KK),PHKK(3,KK),
14677 & PHKK(4,KK),INIEMC,IDUM,IDUM)
14678 CALL DT_EVTFLC(IDHKK(KK),1,INIEMC,IDUM,IDUM)
14679 INIEMC = 2
14680 ENDIF
14681 ID = IDHKK(KK)
14682 IF (ID.EQ.0) ID = 21
14683c PTOT = SQRT(PHKK(1,KK)**2+PHKK(2,KK)**2+PHKK(3,KK)**2)
14684c AM0 = SQRT(ABS((PHKK(4,KK)-PTOT)*(PHKK(4,KK)+PTOT)))
14685c AMRQ = PYMASS(ID)
14686c AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
14687c IF ((ABS(AMDIF2).GT.TINY3).AND.(PTOT.GT.ZERO).AND.
14688c & (ABS(IDIFF).EQ.0)) THEN
14689cC WRITE(LOUT,*)'here: ',NEVHKK,AM0,AMRQ
14690c DELTA = -AMDIF2/(2.0D0*(PHKK(4,KK)+PTOT))
14691c PHKK(4,KK) = PHKK(4,KK)+DELTA
14692c PTOT1 = PTOT-DELTA
14693c PHKK(1,KK) = PHKK(1,KK)*PTOT1/PTOT
14694c PHKK(2,KK) = PHKK(2,KK)*PTOT1/PTOT
14695c PHKK(3,KK) = PHKK(3,KK)*PTOT1/PTOT
14696c PHKK(5,KK) = AMRQ
14697c ENDIF
14698 IP = IP+1
14699 IF (IP.GT.MSTU(4)) STOP ' NEWFRA 2: IP.GT.MSTU(4) !'
14700 P(IP,1) = PHKK(1,KK)
14701 P(IP,2) = PHKK(2,KK)
14702 P(IP,3) = PHKK(3,KK)
14703 P(IP,4) = PHKK(4,KK)
14704 P(IP,5) = PHKK(5,KK)
14705 K(IP,1) = 1
14706 K(IP,2) = ID
14707 K(IP,3) = 0
14708 K(IP,4) = 0
14709 K(IP,5) = 0
14710 IHIST(2,KK) = 10000*IPJE+IP
14711 IF (IHIST(1,KK).LE.-100) THEN
14712 ISH = ISH+1
14713 IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
14714 ISJOIN(ISH) = KK
14715 ENDIF
14716 IJ = IJ+1
14717 IF (IJ.GT.MXJOIN) STOP 'IJ > MXJOIN !'
14718 IJOIN(IJ) = IP
14719 IHISMO(IP) = I
14720 11 CONTINUE
14721 N = IP
14722* join the two-parton system
14723 CALL PYJOIN(IJ,IJOIN)
14724 ENDIF
14725 IDHKK(I) = 99999
14726 ENDIF
14727 10 CONTINUE
14728 16 CONTINUE
14729 N = IP
14730
14731 IF (IP.GT.0) THEN
14732
14733* final state parton shower
14734 DO 136 NPJE=1,IPJE
14735 IF ((MCGENE.EQ.2).AND.(ISH.GE.2)) THEN
14736 IF ((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
14737 DO 130 K1=1,ISH
14738 IF (ISJOIN(K1).EQ.0) GOTO 130
14739 I = ISJOIN(K1)
14740 IF ((IPAMDL(102).EQ.1).AND.(IHIST(1,I).NE.-100))
14741 & GOTO 130
14742 IH1 = IHIST(2,I)/10000
14743 IF (IH1.NE.NPJE) GOTO 130
14744 IH1 = IHIST(2,I)-IH1*10000
14745 DO 135 K2=K1+1,ISH
14746 IF (ISJOIN(K2).EQ.0) GOTO 135
14747 II = ISJOIN(K2)
14748 IH2 = IHIST(2,II)/10000
14749 IF (IH2.NE.NPJE) GOTO 135
14750 IH2 = IHIST(2,II)-IH2*10000
14751 IF (IHIST(1,I).EQ.IHIST(1,II)) THEN
14752 PT1 = SQRT(PHKK(1,II)**2+PHKK(2,II)**2)
14753 PT2 = SQRT(PHKK(1, I)**2+PHKK(2, I)**2)
14754 RQLUN = MIN(PT1,PT2)
14755 CALL PYSHOW(IH1,IH2,RQLUN)
14756
14757 ISJOIN(K1) = 0
14758 ISJOIN(K2) = 0
14759 GOTO 130
14760 ENDIF
14761 135 CONTINUE
14762 130 CONTINUE
14763 ENDIF
14764 ENDIF
14765 136 CONTINUE
14766
14767 CALL DT_INITJS(MODE)
14768* hadronization
14769
14770 CALL PYEXEC
14771
14772 IF (MSTU(24).NE.0) THEN
14773 WRITE(LOUT,*) ' JETSET-reject at event',
14774 & NEVHKK,MSTU(24),KMODE
14775C CALL DT_EVTOUT(4)
14776
14777C CALL PYLIST(2)
14778
14779 GOTO 9999
14780 ENDIF
14781
14782* number of entries in LUJETS
14783
14784 NLINES = PYK(0,1)
14785
14786 NPYMEM = NLINES
14787
14788 DO 12 I=1,NLINES
14789 IFLG(I) = 0
14790 12 CONTINUE
14791
14792 DO 13 II=1,NLINES
14793
14794 IF ((PYK(II,7).EQ.1).AND.(IFLG(II).NE.1)) THEN
14795
14796* pick up mother resonance if possible and put it together with
14797* their decay-products into the common
14798 IDXMOR = K(II,3)
14799 IF ((IDXMOR.GE.1).AND.(IDXMOR.LE.MAXLND)) THEN
14800 KFMOR = K(IDXMOR,2)
14801 ISMOR = K(IDXMOR,1)
14802 ELSE
14803 KFMOR = 91
14804 ISMOR = 1
14805 ENDIF
14806 IF ((KFMOR.NE.91).AND.(KFMOR.NE.92).AND.
14807 & (KFMOR.NE.94).AND.(ISMOR.EQ.11)) THEN
14808 ID = K(IDXMOR,2)
14809 MO = IHISMO(PYK(IDXMOR,15))
14810 PX = PYP(IDXMOR,1)
14811 PY = PYP(IDXMOR,2)
14812 PZ = PYP(IDXMOR,3)
14813 PE = PYP(IDXMOR,4)
14814 CALL DT_EVTPUT(2,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14815 IFLG(IDXMOR) = 1
14816 MO = NHKK
14817 DO 15 JDAUG=K(IDXMOR,4),K(IDXMOR,5)
14818 IF (PYK(JDAUG,7).EQ.1) THEN
14819 ID = PYK(JDAUG,8)
14820 PX = PYP(JDAUG,1)
14821 PY = PYP(JDAUG,2)
14822 PZ = PYP(JDAUG,3)
14823 PE = PYP(JDAUG,4)
14824 CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14825 IF (LEMCCK) THEN
14826 PX = -PYP(JDAUG,1)
14827 PY = -PYP(JDAUG,2)
14828 PZ = -PYP(JDAUG,3)
14829 PE = -PYP(JDAUG,4)
14830 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
14831 ENDIF
14832 IFLG(JDAUG) = 1
14833 ENDIF
14834 15 CONTINUE
14835 ELSE
14836* there was no mother resonance
14837 MO = IHISMO(PYK(II,15))
14838 ID = PYK(II,8)
14839 PX = PYP(II,1)
14840 PY = PYP(II,2)
14841 PZ = PYP(II,3)
14842 PE = PYP(II,4)
14843 CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14844 IF (LEMCCK) THEN
14845 PX = -PYP(II,1)
14846 PY = -PYP(II,2)
14847 PZ = -PYP(II,3)
14848 PE = -PYP(II,4)
14849 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
14850 ENDIF
14851 ENDIF
14852 ENDIF
14853 13 CONTINUE
14854 IF (LEMCCK) THEN
14855 CHKLEV = TINY1
14856 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,6,IREJ1)
14857C IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
14858 ENDIF
14859
14860* global energy-momentum & flavor conservation check
14861**sr 16.5. this check is skipped in case of phojet-treatment
14862 IF (MCGENE.EQ.1)
14863 & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,12,IREJ3)
14864
14865* update statistics-counter for diffraction
14866c IF (IFLAGD.NE.0) THEN
14867c ICDIFF(1) = ICDIFF(1)+1
14868c IF (IFLAGD.EQ. 1) ICDIFF(2) = ICDIFF(2)+1
14869c IF (IFLAGD.EQ. 2) ICDIFF(3) = ICDIFF(3)+1
14870c IF (IFLAGD.EQ.-1) ICDIFF(4) = ICDIFF(4)+1
14871c IF (IFLAGD.EQ.-2) ICDIFF(5) = ICDIFF(5)+1
14872c ENDIF
14873
14874 ENDIF
14875
14876 RETURN
14877
14878 9999 CONTINUE
14879 IREJ = 1
14880 RETURN
14881 END
14882
14883*$ CREATE DT_DECAYS.FOR
14884*COPY DT_DECAYS
14885*
14886*===decay==============================================================*
14887*
14888 SUBROUTINE DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
14889
14890************************************************************************
14891* Resonance-decay. *
14892* This subroutine replaces DDECAY/DECHKK. *
14893* PIN(4) 4-momentum of resonance (input) *
14894* IDXIN BAMJET-index of resonance (input) *
14895* POUT(20,4) 4-momenta of decay-products (output) *
14896* IDXOUT(20) BAMJET-indices of decay-products (output) *
14897* NSEC number of secondaries (output) *
14898* Adopted from the original version DECHKK. *
14899* This version dated 09.01.95 is written by S. Roesler *
14900************************************************************************
14901
14902 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14903 SAVE
14904 PARAMETER ( LINP = 10 ,
14905 & LOUT = 6 ,
14906 & LDAT = 9 )
14907 PARAMETER (TINY17=1.0D-17)
14908
14909* HADRIN: decay channel information
14910 PARAMETER (IDMAX9=602)
14911 CHARACTER*8 ZKNAME
14912 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
14913* particle properties (BAMJET index convention)
14914 CHARACTER*8 ANAME
14915 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
14916 & IICH(210),IIBAR(210),K1(210),K2(210)
14917* flags for input different options
14918 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14919 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14920 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14921
14922 DIMENSION PIN(4),PI(20,4),POUT(20,4),IDXOUT(20),
14923 & EF(3),PF(3),PFF(3),IDXSTK(20),IDX(3),
14924 & CODF(3),COFF(3),SIFF(3),DCOS(3),DCOSF(3)
14925
14926* ISTAB = 1 strong and weak decays
14927* = 2 strong decays only
14928* = 3 strong decays, weak decays for charmed particles and tau
14929* leptons only
14930 DATA ISTAB /2/
14931
14932 IREJ = 0
14933 NSEC = 0
14934* put initial resonance to stack
14935 NSTK = 1
14936 IDXSTK(NSTK) = IDXIN
14937 DO 5 I=1,4
14938 PI(NSTK,I) = PIN(I)
14939 5 CONTINUE
14940
14941* store initial configuration for energy-momentum cons. check
14942 IF (LEMCCK) CALL DT_EVTEMC(PI(NSTK,1),PI(NSTK,2),PI(NSTK,3),
14943 & PI(NSTK,4),1,IDUM,IDUM)
14944
14945 100 CONTINUE
14946* get particle from stack
14947 IDXI = IDXSTK(NSTK)
14948* skip stable particles
14949 IF (ISTAB.EQ.1) THEN
14950 IF ((IDXI.EQ.135).OR. (IDXI.EQ.136)) GOTO 10
14951 IF ((IDXI.GE. 1).AND.(IDXI.LE. 7)) GOTO 10
14952 ELSEIF (ISTAB.EQ.2) THEN
14953 IF ((IDXI.GE. 1).AND.(IDXI.LE. 30)) GOTO 10
14954 IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
14955 IF ((IDXI.GE.115).AND.(IDXI.LE.122)) GOTO 10
14956 IF ((IDXI.GE.131).AND.(IDXI.LE.136)) GOTO 10
14957 IF ( IDXI.EQ.109) GOTO 10
14958 IF ((IDXI.GE.137).AND.(IDXI.LE.160)) GOTO 10
14959 ELSEIF (ISTAB.EQ.3) THEN
14960 IF ((IDXI.GE. 1).AND.(IDXI.LE. 23)) GOTO 10
14961 IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
14962 IF ((IDXI.GE.109).AND.(IDXI.LE.115)) GOTO 10
14963 IF ((IDXI.GE.133).AND.(IDXI.LE.136)) GOTO 10
14964 ENDIF
14965
14966* calculate direction cosines and Lorentz-parameter of decaying part.
14967 PTOT = SQRT(PI(NSTK,1)**2+PI(NSTK,2)**2+PI(NSTK,3)**2)
14968 PTOT = MAX(PTOT,TINY17)
14969 DO 1 I=1,3
14970 DCOS(I) = PI(NSTK,I)/PTOT
14971 1 CONTINUE
14972 GAM = PI(NSTK,4)/AAM(IDXI)
14973 BGAM = PTOT/AAM(IDXI)
14974
14975* get decay-channel
14976 KCHAN = K1(IDXI)-1
14977 2 CONTINUE
14978 KCHAN = KCHAN+1
14979 IF ((DT_RNDM(GAM)-TINY17).GT.WT(KCHAN)) GOTO 2
14980
14981* identities of secondaries
14982 IDX(1) = NZK(KCHAN,1)
14983 IDX(2) = NZK(KCHAN,2)
14984 IF (IDX(2).LT.1) GOTO 9999
14985 IDX(3) = NZK(KCHAN,3)
14986
14987* handle decay in rest system of decaying particle
14988 IF (IDX(3).EQ.0) THEN
14989* two-particle decay
14990 NDEC = 2
14991 CALL DT_DTWOPD(AAM(IDXI),EF(1),EF(2),PF(1),PF(2),
14992 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
14993 & AAM(IDX(1)),AAM(IDX(2)))
14994 ELSE
14995* three-particle decay
14996 NDEC = 3
14997 CALL DT_DTHREP(AAM(IDXI),EF(1),EF(2),EF(3),PF(1),PF(2),PF(3),
14998 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
14999 & CODF(3),COFF(3),SIFF(3),
15000 & AAM(IDX(1)),AAM(IDX(2)),AAM(IDX(3)))
15001 ENDIF
15002 NSTK = NSTK-1
15003
15004* transform decay products back
15005 DO 3 I=1,NDEC
15006 NSTK = NSTK+1
15007 CALL DT_DTRAFO(GAM,BGAM,DCOS(1),DCOS(2),DCOS(3),
15008 & CODF(I),COFF(I),SIFF(I),PF(I),EF(I),
15009 & PFF(I),DCOSF(1),DCOSF(2),DCOSF(3),PI(NSTK,4))
15010* add particle to stack
15011 IDXSTK(NSTK) = IDX(I)
15012 DO 4 J=1,3
15013 PI(NSTK,J) = DCOSF(J)*PFF(I)
15014 4 CONTINUE
15015 3 CONTINUE
15016 GOTO 100
15017
15018 10 CONTINUE
15019* stable particle, put to output-arrays
15020 NSEC = NSEC+1
15021 DO 6 I=1,4
15022 POUT(NSEC,I) = PI(NSTK,I)
15023 6 CONTINUE
15024 IDXOUT(NSEC) = IDXSTK(NSTK)
15025* store secondaries for energy-momentum conservation check
15026 IF (LEMCCK)
15027 &CALL DT_EVTEMC(-POUT(NSEC,1),-POUT(NSEC,2),-POUT(NSEC,3),
15028 & -POUT(NSEC,4),2,IDUM,IDUM)
15029 NSTK = NSTK-1
15030 IF (NSTK.GT.0) GOTO 100
15031
15032* check energy-momentum conservation
15033 IF (LEMCCK) THEN
15034 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,5,IREJ1)
15035 IF (IREJ1.NE.0) GOTO 9999
15036 ENDIF
15037
15038 RETURN
15039
15040 9999 CONTINUE
15041 IREJ = 1
15042 RETURN
15043 END
15044
15045*$ CREATE DT_DECAY1.FOR
15046*COPY DT_DECAY1
15047*
15048*===decay1=============================================================*
15049*
15050 SUBROUTINE DT_DECAY1
15051
15052************************************************************************
15053* Decay of resonances stored in DTEVT1. *
15054* This version dated 20.01.95 is written by S. Roesler *
15055************************************************************************
15056
15057 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15058 SAVE
15059 PARAMETER ( LINP = 10 ,
15060 & LOUT = 6 ,
15061 & LDAT = 9 )
15062
15063* event history
15064 PARAMETER (NMXHKK=200000)
15065 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15066 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15067 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15068* extended event history
15069 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15070 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15071 & IHIST(2,NMXHKK)
15072
15073 DIMENSION PIN(4),POUT(20,4),IDXOUT(20)
15074
15075 NEND = NHKK
15076C DO 1 I=NPOINT(5),NEND
15077 DO 1 I=NPOINT(4),NEND
15078 IF (ABS(ISTHKK(I)).EQ.1) THEN
15079 DO 2 K=1,4
15080 PIN(K) = PHKK(K,I)
15081 2 CONTINUE
15082 IDXIN = IDBAM(I)
15083 CALL DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
15084 IF (NSEC.GT.1) THEN
15085 DO 3 N=1,NSEC
15086 IDHAD = IDT_IPDGHA(IDXOUT(N))
15087 CALL DT_EVTPUT(1,IDHAD,I,0,POUT(N,1),POUT(N,2),
15088 & POUT(N,3),POUT(N,4),0,0,0)
15089 3 CONTINUE
15090 ENDIF
15091 ENDIF
15092 1 CONTINUE
15093
15094 RETURN
15095 END
15096
15097*$ CREATE DT_DECPI0.FOR
15098*COPY DT_DECPI0
15099*
15100*===decpi0=============================================================*
15101*
15102 SUBROUTINE DT_DECPI0
15103
15104************************************************************************
15105* Decay of pi0 handled with JETSET. *
15106* This version dated 18.02.96 is written by S. Roesler *
15107************************************************************************
15108
15109 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15110 SAVE
15111 PARAMETER ( LINP = 10 ,
15112 & LOUT = 6 ,
15113 & LDAT = 9 )
15114 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0,ZERO=0.0D0)
15115
15116* event history
15117 PARAMETER (NMXHKK=200000)
15118 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15119 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15120 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15121* extended event history
15122 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15123 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15124 & IHIST(2,NMXHKK)
bd378884 15125 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
9aaba0d6 15126 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15127 PARAMETER (MAXLND=4000)
15128 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
15129* flags for input different options
15130 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15131 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15132 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15133
15134 INTEGER PYCOMP,PYK
15135
15136 DIMENSION IHISMO(NMXHKK),P1(4)
15137
15138 TWOPI = 2.0D0*ATAN2(0.0D0,-1.0D0)
15139
15140 CALL DT_INITJS(2)
15141* allow pi0 decay
15142 KC = PYCOMP(111)
15143 MDCY(KC,1) = 1
15144
15145 NN = 0
15146 INI = 0
15147 DO 1 I=1,NHKK
15148 IF ((ISTHKK(I).EQ.1).AND.(IDHKK(I).EQ.111)) THEN
15149 IF (INI.EQ.0) THEN
15150 INI = 1
15151 ELSE
15152 INI = 2
15153 ENDIF
15154 IF (LEMCCK) CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
15155 & PHKK(4,I),INI,IDUM,IDUM)
15156 PT = SQRT(PHKK(1,I)**2+PHKK(2,I)**2)
15157 PTOT = SQRT(PT**2+PHKK(3,I)**2)
15158 COSTH = PHKK(3,I)/(PTOT+TINY10)
15159 IF (COSTH.GT.ONE) THEN
15160 THETA = ZERO
15161 ELSEIF (COSTH.LT.-ONE) THEN
15162 THETA = TWOPI/2.0D0
15163 ELSE
15164 THETA = ACOS(COSTH)
15165 ENDIF
15166 PHI = ASIN(PHKK(2,I)/(PT +TINY10))
15167 IF (PHKK(1,I).LT.0.0D0)
15168 & PHI = SIGN(TWOPI/2.0D0-ABS(PHI),PHI)
15169 ENER = PHKK(4,I)
15170 NN = NN+1
15171 KTEMP = MSTU(10)
15172 MSTU(10)= 1
15173 P(NN,5) = PHKK(5,I)
15174 CALL PY1ENT(NN,111,ENER,THETA,PHI)
15175 MSTU(10) = KTEMP
15176 IHISMO(NN)= I
15177 ENDIF
15178 1 CONTINUE
15179 IF (NN.GT.0) THEN
15180 CALL PYEXEC
15181 NLINES = PYK(0,1)
15182 DO 2 II=1,NLINES
15183 IF (PYK(II,7).EQ.1) THEN
15184 DO 3 KK=1,4
15185 P1(KK) = PYP(II,KK)
15186 3 CONTINUE
15187 ID = PYK(II,8)
15188 MO = IHISMO(PYK(II,15))
15189 CALL DT_EVTPUT(1,ID,MO,0,P1(1),P1(2),P1(3),P1(4),0,0,0)
15190 IF (LEMCCK)
15191 & CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,
15192 & IDUM,IDUM)
15193*sr: flag with neg. sign (for HELIOS p/A-W jobs)
15194 ISTHKK(MO) = -2
15195 ENDIF
15196 2 CONTINUE
15197 IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,7000,IREJ1)
15198 ENDIF
15199 MDCY(KC,1) = 0
15200
15201 RETURN
15202 END
15203
15204*$ CREATE DT_DTWOPD.FOR
15205*COPY DT_DTWOPD
15206*
15207*===dtwopd=============================================================*
15208*
15209 SUBROUTINE DT_DTWOPD(UMO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,COD2,
15210 & COF2,SIF2,AM1,AM2)
15211
15212************************************************************************
15213* Two-particle decay. *
15214* UMO cm-energy of the decaying system (input) *
15215* AM1/AM2 masses of the decay products (input) *
15216* ECM1,ECM2/PCM1,PCM2 cm-energies/momenta of the decay prod. (output) *
15217* COD,COF,SIF direction cosines of the decay prod. (output) *
15218* Revised by S. Roesler, 20.11.95 *
15219************************************************************************
15220
15221 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15222 SAVE
15223 PARAMETER ( LINP = 10 ,
15224 & LOUT = 6 ,
15225 & LDAT = 9 )
15226 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,ZERO=0.0D0)
15227
15228 IF (UMO.LT.(AM1+AM2)) THEN
15229 WRITE(LOUT,1000) UMO,AM1,AM2
15230 1000 FORMAT(1X,'DTWOPD: inconsistent kinematics - UMO,AM1,AM2 ',
15231 & 3E12.3)
15232 STOP
15233 ENDIF
15234
15235 ECM1 = ((UMO-AM2)*(UMO+AM2)+AM1*AM1)/(TWO*UMO)
15236 ECM2 = UMO-ECM1
15237 PCM1 = SQRT((ECM1-AM1)*(ECM1+AM1))
15238 PCM2 = PCM1
15239 CALL DT_DSFECF(SIF1,COF1)
15240 COD1 = TWO*DT_RNDM(PCM2)-ONE
15241 COD2 = -COD1
15242 COF2 = -COF1
15243 SIF2 = -SIF1
15244
15245 RETURN
15246 END
15247
15248*$ CREATE DT_DTHREP.FOR
15249*COPY DT_DTHREP
15250*
15251*===dthrep=============================================================*
15252*
15253 SUBROUTINE DT_DTHREP(UMO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,
15254 & SIF1,COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
15255
15256************************************************************************
15257* Three-particle decay. *
15258* UMO cm-energy of the decaying system (input) *
15259* AM1/2/3 masses of the decay products (input) *
15260* ECM1/2/2,PCM1/2/3 cm-energies/momenta of the decay prod. (output) *
15261* COD,COF,SIF direction cosines of the decay prod. (output) *
15262* *
15263* Threpd89: slight revision by A. Ferrari *
15264* Last change on 11-oct-93 by Alfredo Ferrari, INFN - Milan *
15265* Revised by S. Roesler, 20.11.95 *
15266************************************************************************
15267
15268 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15269 SAVE
15270 PARAMETER ( LINP = 10 ,
15271 & LOUT = 6 ,
15272 & LDAT = 9 )
15273
15274 PARAMETER ( ANGLSQ = 2.5D-31 )
15275 PARAMETER ( AZRZRZ = 1.0D-30 )
15276 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
15277 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
15278 PARAMETER ( ONEONE = 1.D+00 )
15279 PARAMETER ( TWOTWO = 2.D+00 )
15280 PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
15281
15282 COMMON /HNGAMR/ REDU,AMO,AMM(15)
15283* flags for input different options
15284 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15285 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15286 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15287
15288 DIMENSION F(5),XX(5)
15289 DATA EPS /AZRZRZ/
15290
15291 UMOO=UMO+UMO
15292C***S1, S2, S3 ARE THE INVARIANT MASSES OF THE PARTICLES 1, 2, 3
15293C***J. VON NEUMANN - RANDOM - SELECTION OF S2
15294C***CALCULATION OF THE MAXIMUM OF THE S2 - DISTRIBUTION
15295 UUMO=UMO
15296 AAM1=AM1
15297 AAM2=AM2
15298 AAM3=AM3
15299 GU=(AM2+AM3)**2
15300 GO=(UMO-AM1)**2
15301* UFAK=1.0000000000001D0
15302* IF (GU.GT.GO) UFAK=0.9999999999999D0
15303 IF (GU.GT.GO) THEN
15304 UFAK=ONEMNS
15305 ELSE
15306 UFAK=ONEPLS
15307 END IF
15308 OFAK=2.D0-UFAK
15309 GU=GU*UFAK
15310 GO=GO*OFAK
15311 DS2=(GO-GU)/99.D0
15312 AM11=AM1*AM1
15313 AM22=AM2*AM2
15314 AM33=AM3*AM3
15315 UMO2=UMO*UMO
15316 RHO2=0.D0
15317 S22=GU
15318 DO 124 I=1,100
15319 S21=S22
15320 S22=GU+(I-1.D0)*DS2
15321 RHO1=RHO2
15322 RHO2=DT_YLAMB(S22,UMO2,AM11)*DT_YLAMB(S22,AM22,AM33)/
15323 * (S22+EPS)
15324 IF(RHO2.LT.RHO1) GO TO 125
15325 124 CONTINUE
15326 125 S2SUP=(S22-S21)*.5D0+S21
15327 SUPRHO=DT_YLAMB(S2SUP,UMO2,AM11)*DT_YLAMB(S2SUP,AM22,AM33)/
15328 * (S2SUP+EPS)
15329 SUPRHO=SUPRHO*1.05D0
15330 XO=S21-DS2
15331 IF (GU.LT.GO.AND.XO.LT.GU) XO=GU
15332 IF (GU.GT.GO.AND.XO.GT.GU) XO=GU
15333 XX(1)=XO
15334 XX(3)=S22
15335 X1=(XO+S22)*0.5D0
15336 XX(2)=X1
15337 F(3)=RHO2
15338 F(1)=DT_YLAMB(XO,UMO2,AM11)*DT_YLAMB(XO,AM22,AM33)/(XO+EPS)
15339 F(2)=DT_YLAMB(X1,UMO2,AM11)*DT_YLAMB(X1,AM22,AM33)/(X1+EPS)
15340 DO 126 I=1,16
15341 X4=(XX(1)+XX(2))*0.5D0
15342 X5=(XX(2)+XX(3))*0.5D0
15343 F(4)=DT_YLAMB(X4,UMO2,AM11)*DT_YLAMB(X4,AM22,AM33)/
15344 * (X4+EPS)
15345 F(5)=DT_YLAMB(X5,UMO2,AM11)*DT_YLAMB(X5,AM22,AM33)/
15346 * (X5+EPS)
15347 XX(4)=X4
15348 XX(5)=X5
15349 DO 128 II=1,5
15350 IA=II
15351 DO 128 III=IA,5
15352 IF (F (II).GE.F (III)) GO TO 128
15353 FH=F(II)
15354 F(II)=F(III)
15355 F(III)=FH
15356 FH=XX(II)
15357 XX(II)=XX(III)
15358 XX(III)=FH
15359128 CONTINUE
15360 SUPRHO=F(1)
15361 S2SUP=XX(1)
15362 DO 129 II=1,3
15363 IA=II
15364 DO 129 III=IA,3
15365 IF (XX(II).GE.XX(III)) GO TO 129
15366 FH=F(II)
15367 F(II)=F(III)
15368 F(III)=FH
15369 FH=XX(II)
15370 XX(II)=XX(III)
15371 XX(III)=FH
15372129 CONTINUE
15373126 CONTINUE
15374 AM23=(AM2+AM3)**2
15375 ITH=0
15376 REDU=2.D0
15377 1 CONTINUE
15378 ITH=ITH+1
15379 IF (ITH.GT.200) REDU=-9.D0
15380 IF (ITH.GT.200) GO TO 400
15381 C=DT_RNDM(REDU)
15382* S2=AM23+C*((UMO-AM1)**2-AM23)
15383 S2=AM23+C*(UMO-AM1-AM2-AM3)*(UMO-AM1+AM2+AM3)
15384 Y=DT_RNDM(S2)
15385 Y=Y*SUPRHO
15386 RHO=DT_YLAMB(S2,UMO2,AM11)*DT_YLAMB(S2,AM22,AM33)/S2
15387 IF(Y.GT.RHO) GO TO 1
15388C***RANDOM SELECTION OF S3 AND CALCULATION OF S1
15389 S1=DT_RNDM(S2)
15390 S1=S1*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)/(2.D0*S2)-
15391 &RHO*.5D0
15392 S3=UMO2+AM11+AM22+AM33-S1-S2
15393 ECM1=(UMO2+AM11-S2)/UMOO
15394 ECM2=(UMO2+AM22-S3)/UMOO
15395 ECM3=(UMO2+AM33-S1)/UMOO
15396 PCM1=SQRT((ECM1+AM1)*(ECM1-AM1))
15397 PCM2=SQRT((ECM2+AM2)*(ECM2-AM2))
15398 PCM3=SQRT((ECM3+AM3)*(ECM3-AM3))
15399 CALL DT_DSFECF(SFE,CFE)
15400C***TH IS THE ANGLE BETWEEN PARTICLES 1 AND 2
15401C***TH1, TH2 ARE THE ANGLES BETWEEN PARTICLES 1, 2 AND THE DIRECTION OF
15402 PCM12 = PCM1 * PCM2
15403 IF ( PCM12 .LT. ANGLSQ ) GO TO 200
15404 COSTH=(ECM1*ECM2+0.5D+00*(AM11+AM22-S1))/PCM12
15405 GO TO 300
15406 200 CONTINUE
15407 UW=DT_RNDM(S1)
15408 COSTH=(UW-0.5D+00)*2.D+00
15409 300 CONTINUE
15410* IF(ABS(COSTH).GT.0.9999999999999999D0)
15411* &COSTH=SIGN(0.9999999999999999D0,COSTH)
15412 IF(ABS(COSTH).GT.ONEONE)
15413 &COSTH=SIGN(ONEONE,COSTH)
15414 IF (REDU.LT.1.D+00) RETURN
15415 COSTH2=(PCM3*PCM3+PCM2*PCM2-PCM1*PCM1)/(2.D+00*PCM2*PCM3)
15416* IF(ABS(COSTH2).GT.0.9999999999999999D0)
15417* &COSTH2=SIGN(0.9999999999999999D0,COSTH2)
15418 IF(ABS(COSTH2).GT.ONEONE)
15419 &COSTH2=SIGN(ONEONE,COSTH2)
15420 SINTH2=SQRT((ONEONE-COSTH2)*(ONEONE+COSTH2))
15421 SINTH =SQRT((ONEONE-COSTH)*(ONEONE+COSTH))
15422 SINTH1=COSTH2*SINTH-COSTH*SINTH2
15423 COSTH1=COSTH*COSTH2+SINTH2*SINTH
15424C***RANDOM SELECTION OF THE SPHERICAL COORDINATES OF THE DIRECTION OF PA
15425C***CFE, SFE ARE COS AND SIN OF THE ROTATION ANGLE OF THE SYSTEM 1, 2 AR
15426C***THE DIRECTION OF PARTICLE 3
15427C***CALCULATION OF THE SPHERICAL COORDINATES OF PARTICLES 1, 2
15428 CX11=-COSTH1
15429 CY11=SINTH1*CFE
15430 CZ11=SINTH1*SFE
15431 CX22=-COSTH2
15432 CY22=-SINTH2*CFE
15433 CZ22=-SINTH2*SFE
15434 CALL DT_DSFECF(SIF3,COF3)
15435 COD3=TWOTWO*DT_RNDM(CX11)-ONEONE
15436 SID3=SQRT((1.D+00-COD3)*(1.D+00+COD3))
15437 2 FORMAT(5F20.15)
15438 COD1=CX11*COD3+CZ11*SID3
15439 CHLP=(ONEONE-COD1)*(ONEONE+COD1)
15440 IF(CHLP.LT.1.D-14)WRITE(LOUT,2)COD1,COF3,SID3,
15441 &CX11,CZ11
15442 SID1=SQRT(CHLP)
15443 COF1=(CX11*SID3*COF3-CY11*SIF3-CZ11*COD3*COF3)/SID1
15444 SIF1=(CX11*SID3*SIF3+CY11*COF3-CZ11*COD3*SIF3)/SID1
15445 COD2=CX22*COD3+CZ22*SID3
15446 SID2=SQRT((ONEONE-COD2)*(ONEONE+COD2))
15447 COF2=(CX22*SID3*COF3-CY22*SIF3-CZ22*COD3*COF3)/SID2
15448 SIF2=(CX22*SID3*SIF3+CY22*COF3-CZ22*COD3*SIF3)/SID2
15449 400 CONTINUE
15450* === Energy conservation check: === *
15451 EOCHCK = UMO - ECM1 - ECM2 - ECM3
15452* SID1 = SQRT ( ( ONEONE - COD1 ) * ( ONEONE + COD1 ) )
15453* SID2 = SQRT ( ( ONEONE - COD2 ) * ( ONEONE + COD2 ) )
15454* SID3 = SQRT ( ( ONEONE - COD3 ) * ( ONEONE + COD3 ) )
15455 PZCHCK = PCM1 * COD1 + PCM2 * COD2 + PCM3 * COD3
15456 PXCHCK = PCM1 * COF1 * SID1 + PCM2 * COF2 * SID2
15457 & + PCM3 * COF3 * SID3
15458 PYCHCK = PCM1 * SIF1 * SID1 + PCM2 * SIF2 * SID2
15459 & + PCM3 * SIF3 * SID3
15460 EOCMPR = 1.D-12 * UMO
15461 IF ( ABS (EOCHCK) + ABS (PXCHCK) + ABS (PYCHCK) + ABS (PZCHCK)
15462 & .GT. EOCMPR ) THEN
15463**sr 5.5.95 output-unit changed
15464 IF (IOULEV(1).GT.0) THEN
15465 WRITE(LOUT,*)
15466 & ' *** Threpd: energy/momentum conservation failure! ***',
15467 & EOCHCK,PXCHCK,PYCHCK,PZCHCK
15468 WRITE(LOUT,*)' *** SID1,SID2,SID3',SID1,SID2,SID3
15469 ENDIF
15470**
15471 END IF
15472 RETURN
15473 END
15474
15475*$ CREATE DT_DBKLAS.FOR
15476*COPY DT_DBKLAS
15477*
15478*===dbklas=============================================================*
15479*
15480 SUBROUTINE DT_DBKLAS(I,J,K,I8,I10)
15481
15482 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15483 SAVE
15484 PARAMETER ( LINP = 10 ,
15485 & LOUT = 6 ,
15486 & LDAT = 9 )
15487
15488* quark-content to particle index conversion (DTUNUC 1.x)
15489 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
15490 & IA08(6,21),IA10(6,21)
15491
15492 IF (I) 20,20,10
15493* baryons
15494 10 CONTINUE
15495 CALL DT_INDEXD(J,K,IND)
15496 I8 = IB08(I,IND)
15497 I10 = IB10(I,IND)
15498 IF (I8.LE.0) I8 = I10
15499 RETURN
15500* antibaryons
15501 20 CONTINUE
15502 II = IABS(I)
15503 JJ = IABS(J)
15504 KK = IABS(K)
15505 CALL DT_INDEXD(JJ,KK,IND)
15506 I8 = IA08(II,IND)
15507 I10 = IA10(II,IND)
15508 IF (I8.LE.0) I8 = I10
15509
15510 RETURN
15511 END
15512
15513*$ CREATE DT_INDEXD.FOR
15514*COPY DT_INDEXD
15515*
15516*===indexd=============================================================*
15517*
15518 SUBROUTINE DT_INDEXD(KA,KB,IND)
15519
15520 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15521 SAVE
15522 PARAMETER ( LINP = 10 ,
15523 & LOUT = 6 ,
15524 & LDAT = 9 )
15525
15526 KP = KA*KB
15527 KS = KA+KB
15528 IF (KP.EQ.1) IND=1
15529 IF (KP.EQ.2) IND=2
15530 IF (KP.EQ.3) IND=3
15531 IF ((KP.EQ.4).AND.(KS.EQ.5)) IND=4
15532 IF (KP.EQ.5) IND=5
15533 IF ((KP.EQ.6).AND.(KS.EQ.7)) IND=6
15534 IF ((KP.EQ.4).AND.(KS.EQ.4)) IND=7
15535 IF ((KP.EQ.6).AND.(KS.EQ.5)) IND=8
15536 IF (KP.EQ.8) IND=9
15537 IF (KP.EQ.10) IND=10
15538 IF ((KP.EQ.12).AND.(KS.EQ.8)) IND=11
15539 IF (KP.EQ.9) IND=12
15540 IF ((KP.EQ.12).AND.(KS.EQ.7)) IND=13
15541 IF (KP.EQ.15) IND=14
15542 IF (KP.EQ.18) IND=15
15543 IF (KP.EQ.16) IND=16
15544 IF (KP.EQ.20) IND=17
15545 IF (KP.EQ.24) IND=18
15546 IF (KP.EQ.25) IND=19
15547 IF (KP.EQ.30) IND=20
15548 IF (KP.EQ.36) IND=21
15549
15550 RETURN
15551 END
15552
15553*$ CREATE DT_DCHANT.FOR
15554*COPY DT_DCHANT
15555*
15556*===dchant=============================================================*
15557*
15558 SUBROUTINE DT_DCHANT
15559
15560 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15561 SAVE
15562 PARAMETER ( LINP = 10 ,
15563 & LOUT = 6 ,
15564 & LDAT = 9 )
15565 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15566
15567* HADRIN: decay channel information
15568 PARAMETER (IDMAX9=602)
15569 CHARACTER*8 ZKNAME
15570 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
15571* particle properties (BAMJET index convention)
15572 CHARACTER*8 ANAME
15573 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
15574 & IICH(210),IIBAR(210),K1(210),K2(210)
15575
15576 DIMENSION HWT(IDMAX9)
15577
15578* change of weights wt from absolut values into the sum of wt of a dec.
15579 DO 10 J=1,IDMAX9
15580 HWT(J) = ZERO
15581 10 CONTINUE
15582C DO 999 KKK=1,210
15583C WRITE(LOUT,'(A8,F5.2,2E10.3,2I4,2I10)')
15584C & ANAME(KKK),AAM(KKK),GA(KKK),TAU(KKK),IICH(KKK),IIBAR(KKK),
15585C & K1(KKK),K2(KKK)
15586C 999 CONTINUE
15587C STOP
15588 DO 30 I=1,210
15589 IK1 = K1(I)
15590 IK2 = K2(I)
15591 HV = ZERO
15592 DO 20 J=IK1,IK2
15593 HV = HV+WT(J)
15594 HWT(J) = HV
15595**sr 13.1.95
15596 IF (HWT(J).GT.1.0001) WRITE(LOUT,1000) HWT(J),J,I,IK1
15597 1000 FORMAT(2X,15H ERROR IN HWT =,1F10.5,8H J,I,K1=,3I5)
15598 20 CONTINUE
15599 30 CONTINUE
15600 DO 40 J=1,IDMAX9
15601 WT(J) = HWT(J)
15602 40 CONTINUE
15603
15604 RETURN
15605 END
15606
15607*$ CREATE DT_DDATAR.FOR
15608*COPY DT_DDATAR
15609*
15610*===ddatar=============================================================*
15611*
15612 SUBROUTINE DT_DDATAR
15613
15614 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15615 SAVE
15616 PARAMETER ( LINP = 10 ,
15617 & LOUT = 6 ,
15618 & LDAT = 9 )
15619 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15620
15621* quark-content to particle index conversion (DTUNUC 1.x)
15622 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
15623 & IA08(6,21),IA10(6,21)
15624
15625 DIMENSION IV(36),IP(36),IB(126),IBB(126),IA(126),IAA(126)
15626
15627 DATA IV/ 33, 34, 38,123, 0, 0, 32, 33, 39,124,
15628 & 0, 0, 36, 37, 96,127, 0, 0,126,125,
15629 & 128,129,14*0/
15630 DATA IP/ 23, 14, 16,116, 0, 0, 13, 23, 25,117,
15631 & 0, 0, 15, 24, 31,120, 0, 0,119,118,
15632 & 121,122,14*0/
15633 DATA IB/ 0, 1, 21,140, 0, 0, 8, 22,137, 0,
15634 & 0, 97,138, 0, 0,146, 0, 0, 0, 0,
15635 & 0, 1, 8, 22,137, 0, 0, 0, 20,142,
15636 & 0, 0, 98,139, 0, 0,147, 0, 0, 0,
15637 & 0, 0, 21, 22, 97,138, 0, 0, 20, 98,
15638 & 139, 0, 0, 0,145, 0, 0,148, 0, 0,
15639 & 0, 0, 0,140,137,138,146, 0, 0,142,
15640 & 139,147, 0, 0,145,148, 50*0/
15641 DATA IBB/53, 54,104,161, 0, 0, 55,105,162, 0,
15642 & 0,107,164, 0, 0,167, 0, 0, 0, 0,
15643 & 0, 54, 55,105,162, 0, 0, 56,106,163,
15644 & 0, 0,108,165, 0, 0,168, 0, 0, 0,
15645 & 0, 0,104,105,107,164, 0, 0,106,108,
15646 & 165, 0, 0,109,166, 0, 0,169, 0, 0,
15647 & 0, 0, 0,161,162,164,167, 0, 0,163,
15648 & 165,168, 0, 0,166,169, 0, 0,170,47*0/
15649 DATA IA/ 0, 2, 99,152, 0, 0, 9,100,149, 0,
15650 & 0,102,150, 0, 0,158, 0, 0, 0, 0,
15651 & 0, 2, 9,100,149, 0, 0, 0,101,154,
15652 & 0, 0,103,151, 0, 0,159, 0, 0, 0,
15653 & 0, 0, 99,100,102,150, 0, 0,101,103,
15654 & 151, 0, 0, 0,157, 0, 0,160, 0, 0,
15655 & 0, 0, 0,152,149,150,158, 0, 0,154,
15656 & 151,159, 0, 0,157,160, 50*0/
15657 DATA IAA/67, 68,110,171, 0, 0, 69,111,172, 0,
15658 & 0,113,174, 0, 0,177, 0, 0, 0, 0,
15659 & 0, 68, 69,111,172, 0, 0, 70,112,173,
15660 & 0, 0,114,175, 0, 0,178, 0, 0, 0,
15661 & 0, 0,110,111,113,174, 0, 0,112,114,
15662 & 175, 0, 0,115,176, 0, 0,179, 0, 0,
15663 & 0, 0, 0,171,172,174,177, 0, 0,173,
15664 & 175,178, 0, 0,176,179, 0, 0,180,47*0/
15665
15666 L=0
15667 DO 2 I=1,6
15668 DO 1 J=1,6
15669 L = L+1
15670 IMPS(I,J) = IP(L)
15671 IMVE(I,J) = IV(L)
15672 1 CONTINUE
15673 2 CONTINUE
15674 L=0
15675 DO 4 I=1,6
15676 DO 3 J=1,21
15677 L = L+1
15678 IB08(I,J) = IB(L)
15679 IB10(I,J) = IBB(L)
15680 IA08(I,J) = IA(L)
15681 IA10(I,J) = IAA(L)
15682 3 CONTINUE
15683 4 CONTINUE
15684C A1 = 0.88D0
15685C B1 = 3.0D0
15686C B2 = 3.0D0
15687C B3 = 8.0D0
15688C LT = 0
15689C LB = 0
15690C BET = 12.0D0
15691C AS = 0.25D0
15692C B8 = 0.33D0
15693C AME = 0.95D0
15694C DIQ = 0.375D0
15695C ISU = 4
15696
15697 RETURN
15698 END
15699
15700*$ CREATE DT_INITJS.FOR
15701*COPY DT_INITJS
15702*
15703*===initjs=============================================================*
15704*
15705 SUBROUTINE DT_INITJS(MODE)
15706
15707************************************************************************
15708* Initialize JETSET paramters. *
15709* MODE = 0 default settings *
15710* = 1 PHOJET settings *
15711* = 2 DTUNUC settings *
15712* This version dated 16.02.96 is written by S. Roesler *
15713* *
15714* Last change 27.12.2006 by S. Roesler. *
15715************************************************************************
15716
15717 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15718 SAVE
15719 PARAMETER ( LINP = 10 ,
15720 & LOUT = 6 ,
15721 & LDAT = 9 )
15722 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15723
15724 LOGICAL LFIRST,LFIRDT,LFIRPH
15725
15726 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15727 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
bd378884 15728 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
9aaba0d6 15729* flags for particle decays
15730 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
15731 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
15732 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
15733* flags for input different options
15734 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15735 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15736 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15737
15738 INTEGER PYCOMP
15739
15740 DIMENSION IDXSTA(40)
15741 DATA IDXSTA
15742* K0s pi0 lam alam sig+ asig+ sig- asig- tet0 atet0
15743 & / 310, 111, 3122,-3122, 3222,-3222, 3112,-3112, 3322,-3322,
15744* tet- atet- om- aom- D+ D- D0 aD0 Ds+ aDs+
15745 & 3312,-3312, 3334,-3334, 411, -411, 421, -421, 431, -431,
15746* etac lamc+alamc+sigc++ sigc+ sigc0asigc++asigc+asigc0 Ksic+
15747 & 441, 4122,-4122, 4222, 4212, 4112,-4222,-4212,-4112, 4232,
15748* Ksic0 aKsic+aKsic0 sig0 asig0
15749 & 4132,-4232,-4132, 3212,-3212, 5*0/
15750
15751 DATA LFIRST,LFIRDT,LFIRPH /.TRUE.,.TRUE.,.TRUE./
15752
15753 IF (LFIRST) THEN
15754* save default settings
15755 PDEF1 = PARJ(1)
15756 PDEF2 = PARJ(2)
15757 PDEF3 = PARJ(3)
15758 PDEF5 = PARJ(5)
15759 PDEF6 = PARJ(6)
15760 PDEF7 = PARJ(7)
15761 PDEF18 = PARJ(18)
15762 PDEF19 = PARJ(19)
15763 PDEF21 = PARJ(21)
15764 PDEF42 = PARJ(42)
15765 MDEF12 = MSTJ(12)
15766* LUJETS / PYJETS array-dimensions
15767 MSTU(4) = 4000
15768* increase maximum number of JETSET-error prints
15769 MSTU(22) = 50000
15770* prevent particles decaying
15771 DO 1 I=1,35
15772 IF (I.LT.34) THEN
15773 KC = PYCOMP(IDXSTA(I))
15774 IF (KC.GT.0) THEN
15775 IF (I.EQ.2) THEN
15776* pi0 decay
15777C MDCY(KC,1) = 1
15778 MDCY(KC,1) = 0
15779**cr mode
15780C ELSEIF ((I.EQ.4).OR.(I.EQ. 6).OR.
15781C & (I.EQ.8).OR.(I.EQ.10)) THEN
15782C ELSEIF (I.EQ.4) THEN
15783C MDCY(KC,1) = 1
15784**
15785 ELSE
1ddc441c 15786C AM MDCY(KC,1) = 0
9aaba0d6 15787 ENDIF
15788 ENDIF
15789 ELSEIF (((I.EQ.34).OR.(I.EQ.35)).AND.(ISIG0.EQ.0)) THEN
15790 KC = PYCOMP(IDXSTA(I))
15791 IF (KC.GT.0) THEN
1ddc441c 15792C AM MDCY(KC,1) = 0
9aaba0d6 15793 ENDIF
15794 ENDIF
15795 1 CONTINUE
15796*
15797*
15798* popcorn:
15799 IF (PDB.LE.ZERO) THEN
15800* no popcorn-mechanism
15801 MSTJ(12) = 1
15802 ELSE
15803 MSTJ(12) = 3
15804 PARJ(5) = PDB
15805 ENDIF
15806* set JETSET-parameter requested by input cards
15807 IF (NMSTU.GT.0) THEN
15808 DO 2 I=1,NMSTU
15809 MSTU(IMSTU(I)) = MSTUX(I)
15810 2 CONTINUE
15811 ENDIF
15812 IF (NMSTJ.GT.0) THEN
15813 DO 3 I=1,NMSTJ
15814 MSTJ(IMSTJ(I)) = MSTJX(I)
15815 3 CONTINUE
15816 ENDIF
15817 IF (NPARU.GT.0) THEN
15818 DO 4 I=1,NPARU
15819 PARU(IPARU(I)) = PARUX(I)
15820 4 CONTINUE
15821 ENDIF
15822 LFIRST = .FALSE.
15823 ENDIF
15824*
15825* PARJ(1) suppression of qq-aqaq pair prod. compared to
15826* q-aq pair prod. (default: 0.1)
15827* PARJ(2) strangeness suppression (default: 0.3)
15828* PARJ(3) extra suppression of strange diquarks (default: 0.4)
15829* PARJ(6) extra suppression of sas-pair shared by B and
15830* aB in BMaB (default: 0.5)
15831* PARJ(7) extra suppression of strange meson M in BMaB
15832* configuration (default: 0.5)
15833* PARJ(18) spin 3/2 baryon suppression (default: 1.0)
15834* PARJ(21) width sigma in Gaussian p_x, p_y transverse
15835* momentum distrib. for prim. hadrons (default: 0.35)
15836* PARJ(42) b-parameter for symmetric Lund-fragmentation
15837* function (default: 0.9 GeV^-2)
15838*
15839* PHOJET settings
15840 IF (MODE.EQ.1) THEN
15841* JETSET default
15842C PARJ(1) = PDEF1
15843C PARJ(2) = PDEF2
15844C PARJ(3) = PDEF3
15845C PARJ(6) = PDEF6
15846C PARJ(7) = PDEF7
15847C PARJ(18) = PDEF18
15848C PARJ(21) = PDEF21
15849C PARJ(42) = PDEF42
15850**sr 18.11.98 parameter tuning
15851C PARJ(1) = 0.092D0
15852C PARJ(2) = 0.25D0
15853C PARJ(3) = 0.45D0
15854C PARJ(19) = 0.3D0
15855C PARJ(21) = 0.45D0
15856C PARJ(42) = 1.0D0
15857**sr 28.04.99 parameter tuning (May 99 minor modifications)
15858 PARJ(1) = 0.085D0
15859 PARJ(2) = 0.26D0
15860 PARJ(3) = 0.8D0
15861 PARJ(11) = 0.38D0
15862 PARJ(18) = 0.3D0
15863 PARJ(19) = 0.4D0
15864 PARJ(21) = 0.36D0
15865 PARJ(41) = 0.3D0
15866 PARJ(42) = 0.86D0
15867 IF (NPARJ.GT.0) THEN
15868 DO 10 I=1,NPARJ
15869 IF (IPARJ(I).GT.0) PARJ(IPARJ(I)) = PARJX(I)
15870 10 CONTINUE
15871 ENDIF
15872 IF (LFIRPH) THEN
15873 WRITE(LOUT,'(1X,A)')
15874 & 'DT_INITJS: JETSET-parameter for PHOJET'
15875 CALL DT_JSPARA(0)
15876 LFIRPH = .FALSE.
15877 ENDIF
15878* DTUNUC settings
15879 ELSEIF (MODE.EQ.2) THEN
15880 IF (IFRAG(2).EQ.1) THEN
15881**sr parameters before 9.3.96
15882C PARJ(2) = 0.27D0
15883C PARJ(3) = 0.6D0
15884C PARJ(6) = 0.75D0
15885C PARJ(7) = 0.75D0
15886C PARJ(21) = 0.55D0
15887C PARJ(42) = 1.3D0
15888**sr 18.11.98 parameter tuning
15889C PARJ(1) = 0.05D0
15890C PARJ(2) = 0.27D0
15891C PARJ(3) = 0.4D0
15892C PARJ(19) = 0.2D0
15893C PARJ(21) = 0.45D0
15894C PARJ(42) = 1.0D0
15895**sr 28.04.99 parameter tuning
15896 PARJ(1) = 0.11D0
15897 PARJ(2) = 0.36D0
15898 PARJ(3) = 0.8D0
15899 PARJ(19) = 0.2D0
15900 PARJ(21) = 0.3D0
15901 PARJ(41) = 0.3D0
15902 PARJ(42) = 0.58D0
15903 IF (NPARJ.GT.0) THEN
15904 DO 20 I=1,NPARJ
15905 IF (IPARJ(I).LT.0) THEN
15906 IDX = ABS(IPARJ(I))
15907 PARJ(IDX) = PARJX(I)
15908 ENDIF
15909 20 CONTINUE
15910 ENDIF
15911 IF (LFIRDT) THEN
15912 WRITE(LOUT,'(1X,A)')
15913 & 'DT_INITJS: JETSET-parameter for DTUNUC'
15914 CALL DT_JSPARA(0)
15915 LFIRDT = .FALSE.
15916 ENDIF
15917 ELSEIF (IFRAG(2).EQ.2) THEN
15918 PARJ(1) = 0.11D0
15919 PARJ(2) = 0.27D0
15920 PARJ(3) = 0.3D0
15921 PARJ(6) = 0.35D0
15922 PARJ(7) = 0.45D0
15923 PARJ(18) = 0.66D0
15924C PARJ(21) = 0.55D0
15925C PARJ(42) = 1.0D0
15926 PARJ(21) = 0.60D0
15927 PARJ(42) = 1.3D0
15928 ELSE
15929 PARJ(1) = PDEF1
15930 PARJ(2) = PDEF2
15931 PARJ(3) = PDEF3
15932 PARJ(6) = PDEF6
15933 PARJ(7) = PDEF7
15934 PARJ(18) = PDEF18
15935 PARJ(21) = PDEF21
15936 PARJ(42) = PDEF42
15937 ENDIF
15938 ELSE
15939 PARJ(1) = PDEF1
15940 PARJ(2) = PDEF2
15941 PARJ(3) = PDEF3
15942 PARJ(5) = PDEF5
15943 PARJ(6) = PDEF6
15944 PARJ(7) = PDEF7
15945 PARJ(18) = PDEF18
15946 PARJ(19) = PDEF19
15947 PARJ(21) = PDEF21
15948 PARJ(42) = PDEF42
15949 MSTJ(12) = MDEF12
15950 ENDIF
15951
15952 RETURN
15953 END
15954
15955*$ CREATE DT_JSPARA.FOR
15956*COPY DT_JSPARA
15957*
15958*===jspara=============================================================*
15959*
15960 SUBROUTINE DT_JSPARA(MODE)
15961
15962 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15963 SAVE
15964 PARAMETER ( LINP = 10 ,
15965 & LOUT = 6 ,
15966 & LDAT = 9 )
15967 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1,
15968 & ONE=1.0D0,ZERO=0.0D0)
15969
15970 LOGICAL LFIRST
15971
15972 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15973
15974 DIMENSION ISTU(200),QARU(200),ISTJ(200),QARJ(200)
15975
15976 DATA LFIRST /.TRUE./
15977
15978* save the default JETSET-parameter on the first call
15979 IF (LFIRST) THEN
15980 DO 1 I=1,200
15981 ISTU(I) = MSTU(I)
15982 QARU(I) = PARU(I)
15983 ISTJ(I) = MSTJ(I)
15984 QARJ(I) = PARJ(I)
15985 1 CONTINUE
15986 LFIRST = .FALSE.
15987 ENDIF
15988
15989 WRITE(LOUT,1000)
15990 1000 FORMAT(1X,'DT_JSPARA: new value (default value)')
15991
15992* compare the default JETSET-parameter with the present values
15993 DO 2 I=1,200
15994 IF ((MSTU(I).NE.ISTU(I)).AND.(I.NE.31)) THEN
15995 WRITE(LOUT,1002) 'MSTU(',I,MSTU(I),ISTU(I)
15996C ISTU(I) = MSTU(I)
15997 ENDIF
15998 DIFF = ABS(PARU(I)-QARU(I))
15999 IF ((DIFF.GE.1.0D-5).AND.(I.NE.21)) THEN
16000 WRITE(LOUT,1001) 'PARU(',I,PARU(I),QARU(I)
16001C QARU(I) = PARU(I)
16002 ENDIF
16003 IF (MSTJ(I).NE.ISTJ(I)) THEN
16004 WRITE(LOUT,1002) 'MSTJ(',I,MSTJ(I),ISTJ(I)
16005C ISTJ(I) = MSTJ(I)
16006 ENDIF
16007 DIFF = ABS(PARJ(I)-QARJ(I))
16008 IF (DIFF.GE.1.0D-5) THEN
16009 WRITE(LOUT,1001) 'PARJ(',I,PARJ(I),QARJ(I)
16010C QARJ(I) = PARJ(I)
16011 ENDIF
16012 2 CONTINUE
16013 1001 FORMAT(12X,A5,I3,'): ',F6.3,' (',F6.3,')')
16014 1002 FORMAT(12X,A5,I3,'): ',I6,' (',I6,')')
16015
16016 RETURN
16017 END
16018
16019*$ CREATE DT_FOZOCA.FOR
16020*COPY DT_FOZOCA
16021*
16022*===fozoca=============================================================*
16023*
16024 SUBROUTINE DT_FOZOCA(LFZC,IREJ)
16025
16026************************************************************************
16027* This subroutine treats the complete FOrmation ZOne supressed intra- *
16028* nuclear CAscade. *
16029* LFZC = .true. cascade has been treated *
16030* = .false. cascade skipped *
16031* This is a completely revised version of the original FOZOKL. *
16032* This version dated 18.11.95 is written by S. Roesler *
16033************************************************************************
16034
16035 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16036 SAVE
16037 PARAMETER ( LINP = 10 ,
16038 & LOUT = 6 ,
16039 & LDAT = 9 )
16040 PARAMETER (DLARGE=1.0D10,OHALF=0.5D0,ZERO=0.0D0)
16041 PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16042
16043 LOGICAL LSTART,LCAS,LFZC
16044
16045* event history
16046 PARAMETER (NMXHKK=200000)
16047 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16048 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16049 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16050* extended event history
16051 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16052 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16053 & IHIST(2,NMXHKK)
16054* rejection counter
16055 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
16056 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
16057 & IREXCI(3),IRDIFF(2),IRINC
16058* properties of interacting particles
16059 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
16060* Glauber formalism: collision properties
16061 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
16062 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
16063* flags for input different options
16064 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16065 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16066 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16067* final state after intranuclear cascade step
16068 COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16069* parameter for intranuclear cascade
16070 LOGICAL LPAULI
16071 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16072
16073 DIMENSION NCWOUN(2)
16074
16075 DATA LSTART /.TRUE./
16076
16077 LFZC = .TRUE.
16078 IREJ = 0
16079
16080* skip cascade if hadron-hadron interaction or if supressed by user
16081 IF (((IP.EQ.1).AND.(IT.EQ.1)).OR.(KTAUGE.LT.1)) GOTO 9999
16082* skip cascade if not all possible chains systems are hadronized
16083 DO 1 I=1,8
16084 IF (.NOT.LHADRO(I)) GOTO 9999
16085 1 CONTINUE
16086
16087 IF (LSTART) THEN
16088 WRITE(LOUT,1000) KTAUGE,TAUFOR,INCMOD
16089 1000 FORMAT(/,1X,'FOZOCA: intranuclear cascade treated for a ',
16090 & 'maximum of',I4,' generations',/,10X,'formation time ',
16091 & 'parameter:',F5.1,' fm/c',9X,'modus:',I2)
16092 IF (ITAUVE.EQ.1) WRITE(LOUT,1001)
16093 IF (ITAUVE.EQ.2) WRITE(LOUT,1002)
16094 1001 FORMAT(10X,'p_t dependent formation zone',/)
16095 1002 FORMAT(10X,'constant formation zone',/)
16096 LSTART = .FALSE.
16097 ENDIF
16098
16099* in order to avoid wasting of cpu-time the DTEVT1-indices of nucleons
16100* which may interact with final state particles are stored in a seperate
16101* array - here all proj./target nucleon-indices (just for simplicity)
16102 NOINC = 0
16103 DO 9 I=1,NPOINT(1)-1
16104 NOINC = NOINC+1
16105 IDXINC(NOINC) = I
16106 9 CONTINUE
16107
16108* initialize Pauli-principle treatment (find wounded nucleons)
16109 NWOUND(1) = 0
16110 NWOUND(2) = 0
16111 NCWOUN(1) = 0
16112 NCWOUN(2) = 0
16113 DO 2 J=1,NPOINT(1)
16114 DO 3 I=1,2
16115 IF (ISTHKK(J).EQ.10+I) THEN
16116 NWOUND(I) = NWOUND(I)+1
16117 EWOUND(I,NWOUND(I)) = PHKK(4,J)
16118 IF (IDHKK(J).EQ.2212) NCWOUN(I) = NCWOUN(I)+1
16119 ENDIF
16120 3 CONTINUE
16121 2 CONTINUE
16122
16123* modify nuclear potential for wounded nucleons
16124 IPRCL = IP -NWOUND(1)
16125 IPZRCL = IPZ-NCWOUN(1)
16126 ITRCL = IT -NWOUND(2)
16127 ITZRCL = ITZ-NCWOUN(2)
16128 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
16129
16130 NSTART = NPOINT(4)
16131 NEND = NHKK
16132
16133 7 CONTINUE
16134 DO 8 I=NSTART,NEND
16135
16136 IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDCH(I).LT.KTAUGE)) THEN
16137* select nucleus the cascade starts first (proj. - 1, target - -1)
16138 NCAS = 1
16139* projectile/target with probab. 1/2
16140 IF ((INCMOD.EQ.1).OR.(IDCH(I).GT.0)) THEN
16141 IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16142* in the nucleus with highest mass
16143 ELSEIF (INCMOD.EQ.2) THEN
16144 IF (IP.GT.IT) THEN
16145 NCAS = -NCAS
16146 ELSEIF (IP.EQ.IT) THEN
16147 IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16148 ENDIF
16149* the nucleus the cascade starts first is requested to be the one
16150* moving in the direction of the secondary
16151 ELSEIF (INCMOD.EQ.3) THEN
16152 NCAS = INT(SIGN(1.0D0,PHKK(3,I)))
16153 ENDIF
16154* check that the selected "nucleus" is not a hadron
16155 IF (((NCAS.EQ. 1).AND.(IP.LE.1)).OR.
16156 & ((NCAS.EQ.-1).AND.(IT.LE.1))) NCAS = -NCAS
16157
16158* treat intranuclear cascade in the nucleus selected first
16159 LCAS = .FALSE.
16160 CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
16161 IF (IREJ1.NE.0) GOTO 9998
16162* treat intranuclear cascade in the other nucleus if this isn't a had.
16163 NCAS = -NCAS
16164 IF (((NCAS.EQ. 1).AND.(IP.GT.1)).OR.
16165 & ((NCAS.EQ.-1).AND.(IT.GT.1))) THEN
16166 IF (LCAS) CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
16167 IF (IREJ1.NE.0) GOTO 9998
16168 ENDIF
16169
16170 ENDIF
16171
16172 8 CONTINUE
16173 NSTART = NEND+1
16174 NEND = NHKK
16175 IF (NSTART.LE.NEND) GOTO 7
16176
16177 RETURN
16178
16179 9998 CONTINUE
16180* reject this event
16181 IRINC = IRINC+1
16182 IREJ = 1
16183
16184 9999 CONTINUE
16185* intranucl. cascade not treated because of interaction properties or
16186* it is supressed by user or it was rejected or...
16187 LFZC = .FALSE.
16188* reset flag characterizing direction of motion in n-n-cms
16189**sr14-11-95
16190C DO 9990 I=NPOINT(5),NHKK
16191C IF (ISTHKK(I).EQ.-1) ISTHKK(I)=1
16192C9990 CONTINUE
16193
16194 RETURN
16195 END
16196
16197*$ CREATE DT_INUCAS.FOR
16198*COPY DT_INUCAS
16199*
16200*===inucas=============================================================*
16201*
16202 SUBROUTINE DT_INUCAS(IT,IP,IDXCAS,LCAS,NCAS,IREJ)
16203
16204************************************************************************
16205* Formation zone supressed IntraNUclear CAScade for one final state *
16206* particle. *
16207* IT, IP mass numbers of target, projectile nuclei *
16208* IDXCAS index of final state particle in DTEVT1 *
16209* NCAS = 1 intranuclear cascade in projectile *
16210* = -1 intranuclear cascade in target *
16211* This version dated 18.11.95 is written by S. Roesler *
16212************************************************************************
16213
16214 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16215 SAVE
16216 PARAMETER ( LINP = 10 ,
16217 & LOUT = 6 ,
16218 & LDAT = 9 )
16219
16220 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
16221 & OHALF=0.5D0,ONE=1.0D0)
16222 PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16223 PARAMETER (TWOPI=6.283185307179586454D+00)
16224 PARAMETER (PLOWH=0.01D0,PHIH=9.0D0)
16225
16226 LOGICAL LABSOR,LCAS
16227
16228* event history
16229 PARAMETER (NMXHKK=200000)
16230 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16231 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16232 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16233* extended event history
16234 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16235 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16236 & IHIST(2,NMXHKK)
16237* final state after inc step
16238 PARAMETER (MAXFSP=10)
16239 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
16240* flags for input different options
16241 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16242 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16243 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16244* particle properties (BAMJET index convention)
16245 CHARACTER*8 ANAME
16246 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
16247 & IICH(210),IIBAR(210),K1(210),K2(210)
16248* Glauber formalism: collision properties
16249 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
16250 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
16251* nuclear potential
16252 LOGICAL LFERMI
16253 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
16254 & EBINDP(2),EBINDN(2),EPOT(2,210),
16255 & ETACOU(2),ICOUL,LFERMI
16256* parameter for intranuclear cascade
16257 LOGICAL LPAULI
16258 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16259* final state after intranuclear cascade step
16260 COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16261* nucleon-nucleon event-generator
16262 CHARACTER*8 CMODEL
16263 LOGICAL LPHOIN
16264 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
16265* statistics: residual nuclei
16266 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
16267 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
16268 & NINCST(2,4),NINCEV(2),
16269 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
16270 & NRESPB(2),NRESCH(2),NRESEV(4),
16271 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
16272 & NEVAFI(2,2)
16273
16274 DIMENSION PCAS(2,5),PTOCAS(2),COSCAS(2,3),VTXCAS(2,4),VTXCA1(2,4),
16275 & PCAS1(5),PNUC(5),BGTA(4),
16276 & BGCAS(2),GACAS(2),BECAS(2),
16277 & RNUC(2),BIMPC(2),VTXDST(3),IDXSPE(2),IDSPE(2),NWTMP(2)
16278
16279 DATA PDIF /0.545D0/
16280
16281 IREJ = 0
16282
16283* update counter
16284 IF (NINCEV(1).NE.NEVHKK) THEN
16285 NINCEV(1) = NEVHKK
16286 NINCEV(2) = NINCEV(2)+1
16287 ENDIF
16288
16289* "BAMJET-index" of this hadron
16290 IDCAS = IDBAM(IDXCAS)
16291 IF (IDT_MCHAD(IDCAS).EQ.-1) RETURN
16292
16293* skip gammas, electrons, etc..
16294 IF (AAM(IDCAS).LT.TINY2) RETURN
16295
16296* Lorentz-trsf. into projectile rest system
16297 IF (IP.GT.1) THEN
16298 CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
16299 & PHKK(4,IDXCAS),PCAS(1,1),PCAS(1,2),PCAS(1,3),
16300 & PCAS(1,4),IDCAS,-2)
16301 PTOCAS(1) = SQRT(PCAS(1,1)**2+PCAS(1,2)**2+PCAS(1,3)**2)
16302 PCAS(1,5) = (PCAS(1,4)-PTOCAS(1))*(PCAS(1,4)+PTOCAS(1))
16303 IF (PCAS(1,5).GT.ZERO) THEN
16304 PCAS(1,5) = SQRT(PCAS(1,5))
16305 ELSE
16306 PCAS(1,5) = AAM(IDCAS)
16307 ENDIF
16308 DO 20 K=1,3
16309 COSCAS(1,K) = PCAS(1,K)/MAX(PTOCAS(1),TINY10)
16310 20 CONTINUE
16311* Lorentz-parameters
16312* particle rest system --> projectile rest system
16313 BGCAS(1) = PTOCAS(1)/MAX(PCAS(1,5),TINY10)
16314 GACAS(1) = PCAS(1,4)/MAX(PCAS(1,5),TINY10)
16315 BECAS(1) = BGCAS(1)/GACAS(1)
16316 ELSE
16317 DO 21 K=1,5
16318 PCAS(1,K) = ZERO
16319 IF (K.LE.3) COSCAS(1,K) = ZERO
16320 21 CONTINUE
16321 PTOCAS(1) = ZERO
16322 BGCAS(1) = ZERO
16323 GACAS(1) = ZERO
16324 BECAS(1) = ZERO
16325 ENDIF
16326* Lorentz-trsf. into target rest system
16327 IF (IT.GT.1) THEN
16328* LEPTO: final state particles are already in target rest frame
16329C IF (MCGENE.EQ.3) THEN
16330C PCAS(2,1) = PHKK(1,IDXCAS)
16331C PCAS(2,2) = PHKK(2,IDXCAS)
16332C PCAS(2,3) = PHKK(3,IDXCAS)
16333C PCAS(2,4) = PHKK(4,IDXCAS)
16334C ELSE
16335 CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
16336 & PHKK(4,IDXCAS),PCAS(2,1),PCAS(2,2),PCAS(2,3),
16337 & PCAS(2,4),IDCAS,-3)
16338C ENDIF
16339 PTOCAS(2) = SQRT(PCAS(2,1)**2+PCAS(2,2)**2+PCAS(2,3)**2)
16340 PCAS(2,5) = (PCAS(2,4)-PTOCAS(2))*(PCAS(2,4)+PTOCAS(2))
16341 IF (PCAS(2,5).GT.ZERO) THEN
16342 PCAS(2,5) = SQRT(PCAS(2,5))
16343 ELSE
16344 PCAS(2,5) = AAM(IDCAS)
16345 ENDIF
16346 DO 22 K=1,3
16347 COSCAS(2,K) = PCAS(2,K)/MAX(PTOCAS(2),TINY10)
16348 22 CONTINUE
16349* Lorentz-parameters
16350* particle rest system --> target rest system
16351 BGCAS(2) = PTOCAS(2)/MAX(PCAS(2,5),TINY10)
16352 GACAS(2) = PCAS(2,4)/MAX(PCAS(2,5),TINY10)
16353 BECAS(2) = BGCAS(2)/GACAS(2)
16354 ELSE
16355 DO 23 K=1,5
16356 PCAS(2,K) = ZERO
16357 IF (K.LE.3) COSCAS(2,K) = ZERO
16358 23 CONTINUE
16359 PTOCAS(2) = ZERO
16360 BGCAS(2) = ZERO
16361 GACAS(2) = ZERO
16362 BECAS(2) = ZERO
16363 ENDIF
16364
16365* radii of nuclei (mm) modified by the wall-depth of the Woods-Saxon-
16366* potential (see CONUCL)
16367 RNUC(1) = (RPROJ+4.605D0*PDIF)*FM2MM
16368 RNUC(2) = (RTARG+4.605D0*PDIF)*FM2MM
16369* impact parameter (the projectile moving along z)
16370 BIMPC(1) = ZERO
16371 BIMPC(2) = BIMPAC*FM2MM
16372
16373* get position of initial hadron in projectile/target rest-syst.
16374 DO 3 K=1,4
16375 VTXCAS(1,K) = WHKK(K,IDXCAS)
16376 VTXCAS(2,K) = VHKK(K,IDXCAS)
16377 3 CONTINUE
16378
16379 ICAS = 1
16380 I2 = 2
16381 IF (NCAS.EQ.-1) THEN
16382 ICAS = 2
16383 I2 = 1
16384 ENDIF
16385
16386 IF (PTOCAS(ICAS).LT.TINY10) THEN
16387 WRITE(LOUT,1000) PTOCAS
16388 1000 FORMAT(1X,'INUCAS: warning! zero momentum of initial',
16389 & ' hadron ',/,20X,2E12.4)
16390 GOTO 9999
16391 ENDIF
16392
16393* reset spectator flags
16394 NSPE = 0
16395 IDXSPE(1) = 0
16396 IDXSPE(2) = 0
16397 IDSPE(1) = 0
16398 IDSPE(2) = 0
16399
16400* formation length (in fm)
16401C IF (LCAS) THEN
16402C DEL0 = ZERO
16403C ELSE
16404 DEL0 = TAUFOR*BGCAS(ICAS)
16405 IF (ITAUVE.EQ.1) THEN
16406 AMT = PCAS(ICAS,1)**2+PCAS(ICAS,2)**2+PCAS(ICAS,5)**2
16407 DEL0 = DEL0*PCAS(ICAS,5)**2/AMT
16408 ENDIF
16409C ENDIF
16410* sample from exp(-del/del0)
16411 DEL1 = -DEL0*LOG(MAX(DT_RNDM(DEL0),TINY10))
16412* save formation time
16413 TAUSA1 = DEL1/BGCAS(ICAS)
16414 REL1 = TAUSA1*BGCAS(I2)
16415
16416 DEL = DEL1
16417 TAUSAM = DEL/BGCAS(ICAS)
16418 REL = TAUSAM*BGCAS(I2)
16419
16420* special treatment for negative particles unable to escape
16421* nuclear potential (implemented for ap, pi-, K- only)
16422 LABSOR = .FALSE.
16423 IF ((IICH(IDCAS).EQ.-1).AND.(IDCAS.LT.20)) THEN
16424* threshold energy = nuclear potential + Coulomb potential
16425* (nuclear potential for hadron-nucleus interactions only)
16426 ETHR = AAM(IDCAS)+EPOT(ICAS,IDCAS)+ETACOU(ICAS)
16427 IF (PCAS(ICAS,4).LT.ETHR) THEN
16428 DO 4 K=1,5
16429 PCAS1(K) = PCAS(ICAS,K)
16430 4 CONTINUE
16431* "absorb" negative particle in nucleus
16432 CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,0,IREJ1)
16433 IF (IREJ1.NE.0) GOTO 9999
16434 IF (NSPE.GE.1) LABSOR = .TRUE.
16435 ENDIF
16436 ENDIF
16437
16438* if the initial particle has not been absorbed proceed with
16439* "normal" cascade
16440 IF (.NOT.LABSOR) THEN
16441
16442* calculate coordinates of hadron at the end of the formation zone
16443* transport-time and -step in the rest system where this step is
16444* treated
16445 DSTEP = DEL*FM2MM
16446 DTIME = DSTEP/BECAS(ICAS)
16447 RSTEP = REL*FM2MM
16448 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16449 RTIME = RSTEP/BECAS(I2)
16450 ELSE
16451 RTIME = ZERO
16452 ENDIF
16453* save step whithout considering the overlapping region
16454 DSTEP1 = DEL1*FM2MM
16455 DTIME1 = DSTEP1/BECAS(ICAS)
16456 RSTEP1 = REL1*FM2MM
16457 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16458 RTIME1 = RSTEP1/BECAS(I2)
16459 ELSE
16460 RTIME1 = ZERO
16461 ENDIF
16462* transport to the end of the formation zone in this system
16463 DO 5 K=1,3
16464 VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+DSTEP1*COSCAS(ICAS,K)
16465 VTXCA1(I2,K) = VTXCAS(I2,K) +RSTEP1*COSCAS(I2,K)
16466 VTXCAS(ICAS,K) = VTXCAS(ICAS,K)+DSTEP*COSCAS(ICAS,K)
16467 VTXCAS(I2,K) = VTXCAS(I2,K) +RSTEP*COSCAS(I2,K)
16468 5 CONTINUE
16469 VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME1
16470 VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME1
16471 VTXCAS(ICAS,4) = VTXCAS(ICAS,4)+DTIME
16472 VTXCAS(I2,4) = VTXCAS(I2,4) +RTIME
16473
16474 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16475 XCAS = VTXCAS(ICAS,1)
16476 YCAS = VTXCAS(ICAS,2)
16477 XNCLTA = BIMPAC*FM2MM
16478 RNCLPR = (RPROJ+RNUCLE)*FM2MM
16479 RNCLTA = (RTARG+RNUCLE)*FM2MM
16480C RNCLPR = (RPROJ+1.605D0*PDIF)*FM2MM
16481C RNCLTA = (RTARG+1.605D0*PDIF)*FM2MM
16482C RNCLPR = (RPROJ)*FM2MM
16483C RNCLTA = (RTARG)*FM2MM
16484 RCASPR = SQRT( XCAS**2 +YCAS**2)
16485 RCASTA = SQRT((XCAS-XNCLTA)**2+YCAS**2)
16486 IF ((RCASPR.LT.RNCLPR).AND.(RCASTA.LT.RNCLTA)) THEN
16487 IF (IDCH(IDXCAS).EQ.0) NOBAM(IDXCAS) = 3
16488 ENDIF
16489 ENDIF
16490
16491* check if particle is already outside of the corresp. nucleus
16492 RDIST = SQRT((VTXCAS(ICAS,1)-BIMPC(ICAS))**2+
16493 & VTXCAS(ICAS,2)**2+VTXCAS(ICAS,3)**2)
16494 IF (RDIST.GE.RNUC(ICAS)) THEN
16495* here: IDCH is the generation of the final state part. starting
16496* with zero for hadronization products
16497* flag particles of generation 0 being outside the nuclei after
16498* formation time (to be used for excitation energy calculation)
16499 IF ((IDCH(IDXCAS).EQ.0).AND.(NOBAM(IDXCAS).LT.3))
16500 & NOBAM(IDXCAS) = NOBAM(IDXCAS)+ICAS
16501 GOTO 9997
16502 ENDIF
16503 DIST = DLARGE
16504 DISTP = DLARGE
16505 DISTN = DLARGE
16506 IDXP = 0
16507 IDXN = 0
16508
16509* already here: skip particles being outside HADRIN "energy-window"
16510* to avoid wasting of time
16511 NINCHR(ICAS,1) = NINCHR(ICAS,1)+1
16512 IF ((PTOCAS(ICAS).LE.PLOWH).OR.(PTOCAS(ICAS).GE.PHIH)) THEN
16513 NINCHR(ICAS,2) = NINCHR(ICAS,2)+1
16514C WRITE(LOUT,1002) IDXCAS,IDCAS,ICAS,PTOCAS(ICAS),NEVHKK
16515C1002 FORMAT(1X,'INUCAS: warning! momentum of particle with ',
16516C & 'index ',I5,' (id: ',I3,') ',I3,/,11X,'p_tot = ',
16517C & E12.4,', above or below HADRIN-thresholds',I6)
16518 NSPE = 0
16519 GOTO 9997
16520 ENDIF
16521
16522 DO 7 IDXHKK=1,NOINC
16523 I = IDXINC(IDXHKK)
16524* scan DTEVT1 for unwounded or excited nucleons
16525 IF ((ISTHKK(I).EQ.12+ICAS).OR.(ISTHKK(I).EQ.14+ICAS)) THEN
16526 DO 8 K=1,3
16527 IF (ICAS.EQ.1) THEN
16528 VTXDST(K) = WHKK(K,I)-VTXCAS(1,K)
16529 ELSEIF (ICAS.EQ.2) THEN
16530 VTXDST(K) = VHKK(K,I)-VTXCAS(2,K)
16531 ENDIF
16532 8 CONTINUE
16533 POSNUC = VTXDST(1)*COSCAS(ICAS,1)+
16534 & VTXDST(2)*COSCAS(ICAS,2)+
16535 & VTXDST(3)*COSCAS(ICAS,3)
16536* check if nucleon is situated in forward direction
16537 IF (POSNUC.GT.ZERO) THEN
16538* distance between hadron and this nucleon
16539 DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16540 & VTXDST(3)**2)
16541* impact parameter
16542 BIMNU2 = DISTNU**2-POSNUC**2
16543 IF (BIMNU2.LT.ZERO) THEN
16544 WRITE(LOUT,1001) DISTNU,POSNUC,BIMNU2
16545 1001 FORMAT(1X,'INUCAS: warning! inconsistent impact',
16546 & ' parameter ',/,20X,3E12.4)
16547 GOTO 7
16548 ENDIF
16549 BIMNU = SQRT(BIMNU2)
16550* maximum impact parameter to have interaction
16551 IDNUC = IDT_ICIHAD(IDHKK(I))
16552 IDNUC1 = IDT_MCHAD(IDNUC)
16553 IDCAS1 = IDT_MCHAD(IDCAS)
16554 DO 19 K=1,5
16555 PCAS1(K) = PCAS(ICAS,K)
16556 PNUC(K) = PHKK(K,I)
16557 19 CONTINUE
16558* Lorentz-parameter for trafo into rest-system of target
16559 DO 18 K=1,4
16560 BGTA(K) = PNUC(K)/MAX(PNUC(5),TINY10)
16561 18 CONTINUE
16562* transformation of projectile into rest-system of target
16563 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
16564 & PCAS1(1),PCAS1(2),PCAS1(3),PCAS1(4),
16565 & PPTOT,PX,PY,PZ,PE)
16566**
16567C CALL DT_SIHNIN(IDCAS1,IDNUC1,PPTOT,SIGIN)
16568C CALL DT_SIHNEL(IDCAS1,IDNUC1,PPTOT,SIGEL)
16569 DUMZER = ZERO
16570 CALL DT_XSHN(IDCAS1,IDNUC1,PPTOT,DUMZER,SIGTOT,SIGEL)
16571 CALL DT_SIHNAB(IDCAS1,IDNUC1,PPTOT,SIGAB)
16572 IF (((IDCAS1.EQ.13).OR.(IDCAS1.EQ.14)).AND.
16573 & (PPTOT.LT.0.15D0)) SIGEL = SIGEL/2.0D0
16574 SIGIN = SIGTOT-SIGEL-SIGAB
16575C SIGTOT = SIGIN+SIGEL+SIGAB
16576**
16577 BIMMAX = SQRT(SIGTOT/(5.0D0*TWOPI))*FM2MM
16578* check if interaction is possible
16579 IF (BIMNU.LE.BIMMAX) THEN
16580* get nucleon with smallest distance and kind of interaction
16581* (elastic/inelastic)
16582 IF (DISTNU.LT.DIST) THEN
16583 DIST = DISTNU
16584 BINT = BIMNU
16585 IF (IDNUC.NE.IDSPE(1)) THEN
16586 IDSPE(2) = IDSPE(1)
16587 IDXSPE(2) = IDXSPE(1)
16588 IDSPE(1) = IDNUC
16589 ENDIF
16590 IDXSPE(1) = I
16591 NSPE = 1
16592**sr
16593 SELA = SIGEL
16594 SABS = SIGAB
16595 STOT = SIGTOT
16596C IF ((IDCAS.EQ.2).OR.(IDCAS.EQ.9)) THEN
16597C SELA = SIGEL
16598C STOT = SIGIN+SIGEL
16599C ELSE
16600C SELA = SIGEL+0.75D0*SIGIN
16601C STOT = 0.25D0*SIGIN+SELA
16602C ENDIF
16603**
16604 ENDIF
16605 ENDIf
16606 ENDIF
16607 DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16608 & VTXDST(3)**2)
16609 IDNUC = IDT_ICIHAD(IDHKK(I))
16610 IF (IDNUC.EQ.1) THEN
16611 IF (DISTNU.LT.DISTP) THEN
16612 DISTP = DISTNU
16613 IDXP = I
16614 POSP = POSNUC
16615 ENDIF
16616 ELSEIF (IDNUC.EQ.8) THEN
16617 IF (DISTNU.LT.DISTN) THEN
16618 DISTN = DISTNU
16619 IDXN = I
16620 POSN = POSNUC
16621 ENDIF
16622 ENDIF
16623 ENDIF
16624 7 CONTINUE
16625
16626* there is no nucleon for a secondary interaction
16627 IF (NSPE.EQ.0) GOTO 9997
16628
16629C IF ((IDCAS.EQ.13).AND.((PCAS(ICAS,4)-PCAS(ICAS,5)).LT.0.1D0))
16630C & WRITE(LOUT,*) STOT,SELA,SABS,IDXSPE
16631 IF (IDXSPE(2).EQ.0) THEN
16632 IF ((IDSPE(1).EQ.1).AND.(IDXN.GT.0)) THEN
16633C DO 80 K=1,3
16634C IF (ICAS.EQ.1) THEN
16635C VTXDST(K) = WHKK(K,IDXN)-WHKK(K,IDXSPE(1))
16636C ELSEIF (ICAS.EQ.2) THEN
16637C VTXDST(K) = VHKK(K,IDXN)-VHKK(K,IDXSPE(1))
16638C ENDIF
16639C 80 CONTINUE
16640C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16641C & VTXDST(3)**2)
16642C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSN.GT.ZERO)) THEN
16643 IDXSPE(2) = IDXN
16644 IDSPE(2) = 8
16645C ELSE
16646C STOT = STOT-SABS
16647C SABS = ZERO
16648C ENDIF
16649 ELSEIF ((IDSPE(1).EQ.8).AND.(IDXP.GT.0)) THEN
16650C DO 81 K=1,3
16651C IF (ICAS.EQ.1) THEN
16652C VTXDST(K) = WHKK(K,IDXP)-WHKK(K,IDXSPE(1))
16653C ELSEIF (ICAS.EQ.2) THEN
16654C VTXDST(K) = VHKK(K,IDXP)-VHKK(K,IDXSPE(1))
16655C ENDIF
16656C 81 CONTINUE
16657C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16658C & VTXDST(3)**2)
16659C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSP.GT.ZERO)) THEN
16660 IDXSPE(2) = IDXP
16661 IDSPE(2) = 1
16662C ELSE
16663C STOT = STOT-SABS
16664C SABS = ZERO
16665C ENDIF
16666 ELSE
16667 STOT = STOT-SABS
16668 SABS = ZERO
16669 ENDIF
16670 ENDIF
16671 RR = DT_RNDM(DIST)
16672 IF (RR.LT.SELA/STOT) THEN
16673 IPROC = 2
16674 ELSEIF ((RR.GE.SELA/STOT).AND.(RR.LT.(SELA+SABS)/STOT)) THEN
16675 IPROC = 3
16676 ELSE
16677 IPROC = 1
16678 ENDIF
16679
16680 DO 9 K=1,5
16681 PCAS1(K) = PCAS(ICAS,K)
16682 PNUC(K) = PHKK(K,IDXSPE(1))
16683 9 CONTINUE
16684 IF (IPROC.EQ.3) THEN
16685* 2-nucleon absorption of pion
16686 NSPE = 2
16687 CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,1,IREJ1)
16688 IF (IREJ1.NE.0) GOTO 9999
16689 IF (NSPE.GE.1) LABSOR = .TRUE.
16690 ELSE
16691* sample secondary interaction
16692 IDNUC = IDBAM(IDXSPE(1))
16693 CALL DT_HADRIN(IDCAS,PCAS1,IDNUC,PNUC,IPROC,IREJ1)
16694 IF (IREJ1.EQ.1) GOTO 9999
16695 IF (IREJ1.GT.1) GOTO 9998
16696 ENDIF
16697 ENDIF
16698
16699* update arrays to include Pauli-principle
16700 DO 10 I=1,NSPE
16701 IF (NWOUND(ICAS).LE.299) THEN
16702 NWOUND(ICAS) = NWOUND(ICAS)+1
16703 EWOUND(ICAS,NWOUND(ICAS)) = PHKK(4,IDXSPE(I))
16704 ENDIF
16705 10 CONTINUE
16706
16707* dump initial hadron for energy-momentum conservation check
16708 IF (LEMCCK)
16709 & CALL DT_EVTEMC(PCAS(ICAS,1),PCAS(ICAS,2),PCAS(ICAS,3),
16710 & PCAS(ICAS,4),1,IDUM,IDUM)
16711
16712* dump final state particles into DTEVT1
16713
16714* check if Pauli-principle is fulfilled
16715 NPAULI = 0
16716 NWTMP(1) = NWOUND(1)
16717 NWTMP(2) = NWOUND(2)
16718 DO 111 I=1,NFSP
16719 NPAULI = 0
16720 J1 = 2
16721 IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
16722 & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1
16723 DO 117 J=1,J1
16724 IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 117
16725 IF (J.EQ.1) THEN
16726 IDX = ICAS
16727 PE = PFSP(4,I)
16728 ELSE
16729 IDX = I2
16730 MODE = 1
16731 IF (IDX.EQ.1) MODE = -1
16732 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,MODE)
16733 ENDIF
16734* first check if cascade step is forbidden due to Pauli-principle
16735* (in case of absorpion this step is forced)
16736 IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
16737 & (IDFSP(I).EQ.8))) THEN
16738* get nuclear potential barrier
16739 POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
16740 IF (IDFSP(I).EQ.1) THEN
16741 POTLOW = POT-EBINDP(IDX)
16742 ELSE
16743 POTLOW = POT-EBINDN(IDX)
16744 ENDIF
16745* final state particle not able to escape nucleus
16746 IF (PE.LE.POTLOW) THEN
16747* check if there are wounded nucleons
16748 IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
16749 & EWOUND(IDX,NWOUND(IDX)))) THEN
16750 NPAULI = NPAULI+1
16751 NWOUND(IDX) = NWOUND(IDX)-1
16752 ELSE
16753* interaction prohibited by Pauli-principle
16754 NWOUND(1) = NWTMP(1)
16755 NWOUND(2) = NWTMP(2)
16756 GOTO 9997
16757 ENDIF
16758 ENDIF
16759 ENDIF
16760 117 CONTINUE
16761 111 CONTINUE
16762
16763 NPAULI = 0
16764 NWOUND(1) = NWTMP(1)
16765 NWOUND(2) = NWTMP(2)
16766
16767 DO 11 I=1,NFSP
16768
16769 IST = ISTHKK(IDXCAS)
16770
16771 NPAULI = 0
16772 J1 = 2
16773 IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
16774 & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1
16775 DO 17 J=1,J1
16776 IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 17
16777 IDX = ICAS
16778 PE = PFSP(4,I)
16779 IF (J.EQ.2) THEN
16780 IDX = I2
16781 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,NCAS)
16782 ENDIF
16783* first check if cascade step is forbidden due to Pauli-principle
16784* (in case of absorpion this step is forced)
16785 IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
16786 & (IDFSP(I).EQ.8))) THEN
16787* get nuclear potential barrier
16788 POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
16789 IF (IDFSP(I).EQ.1) THEN
16790 POTLOW = POT-EBINDP(IDX)
16791 ELSE
16792 POTLOW = POT-EBINDN(IDX)
16793 ENDIF
16794* final state particle not able to escape nucleus
16795 IF (PE.LE.POTLOW) THEN
16796* check if there are wounded nucleons
16797 IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
16798 & EWOUND(IDX,NWOUND(IDX)))) THEN
16799 NWOUND(IDX) = NWOUND(IDX)-1
16800 NPAULI = NPAULI+1
16801 IST = 14+IDX
16802 ELSE
16803* interaction prohibited by Pauli-principle
16804 NWOUND(1) = NWTMP(1)
16805 NWOUND(2) = NWTMP(2)
16806 GOTO 9997
16807 ENDIF
16808**sr
16809c ELSEIF (PE.LE.POT) THEN
16810cC ELSEIF ((PE.LE.POT).AND.(NWOUND(IDX).GE.1)) THEN
16811cC NWOUND(IDX) = NWOUND(IDX)-1
16812c**
16813c NPAULI = NPAULI+1
16814c IST = 14+IDX
16815 ENDIF
16816 ENDIF
16817 17 CONTINUE
16818
16819* dump final state particles for energy-momentum conservation check
16820 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),-PFSP(3,I),
16821 & -PFSP(4,I),2,IDUM,IDUM)
16822
16823 PX = PFSP(1,I)
16824 PY = PFSP(2,I)
16825 PZ = PFSP(3,I)
16826 PE = PFSP(4,I)
16827 IF (ABS(IST).EQ.1) THEN
16828* transform particles back into n-n cms
16829* LEPTO: leave final state particles in target rest frame
16830C IF (MCGENE.EQ.3) THEN
16831C PFSP(1,I) = PX
16832C PFSP(2,I) = PY
16833C PFSP(3,I) = PZ
16834C PFSP(4,I) = PE
16835C ELSE
16836 IMODE = ICAS+1
16837 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
16838 & PFSP(4,I),IDFSP(I),IMODE)
16839C ENDIF
16840 ELSEIF ((ICAS.EQ.2).AND.(IST.EQ.15)) THEN
16841* target cascade but fsp got stuck in proj. --> transform it into
16842* proj. rest system
16843 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
16844 & PFSP(4,I),IDFSP(I),-1)
16845 ELSEIF ((ICAS.EQ.1).AND.(IST.EQ.16)) THEN
16846* proj. cascade but fsp got stuck in target --> transform it into
16847* target rest system
16848 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
16849 & PFSP(4,I),IDFSP(I),1)
16850 ENDIF
16851
16852* dump final state particles into DTEVT1
16853 IGEN = IDCH(IDXCAS)+1
16854 ID = IDT_IPDGHA(IDFSP(I))
16855 IXR = 0
16856 IF (LABSOR) IXR = 99
16857 CALL DT_EVTPUT(IST,ID,IDXCAS,IDXSPE(1),PFSP(1,I),
16858 & PFSP(2,I),PFSP(3,I),PFSP(4,I),0,IXR,IGEN)
16859
16860* update the counter for particles which got stuck inside the nucleus
16861 IF ((IST.EQ.15).OR.(IST.EQ.16)) THEN
16862 NOINC = NOINC+1
16863 IDXINC(NOINC) = NHKK
16864 ENDIF
16865 IF (LABSOR) THEN
16866* in case of absorption the spatial treatment is an approximate
16867* solution anyway (the positions of the nucleons which "absorb" the
16868* cascade particle are not taken into consideration) therefore the
16869* particles are produced at the position of the cascade particle
16870 DO 12 K=1,4
16871 WHKK(K,NHKK) = WHKK(K,IDXCAS)
16872 VHKK(K,NHKK) = VHKK(K,IDXCAS)
16873 12 CONTINUE
16874 ELSE
16875* DDISTL - distance the cascade particle moves to the intera. point
16876* (the position where impact-parameter = distance to the interacting
16877* nucleon), DIST - distance to the interacting nucleon at the time of
16878* formation of the cascade particle, BINT - impact-parameter of this
16879* cascade-interaction
16880 DDISTL = SQRT(DIST**2-BINT**2)
16881 DTIME = DDISTL/BECAS(ICAS)
16882 DTIMEL = DDISTL/BGCAS(ICAS)
16883 RDISTL = DTIMEL*BGCAS(I2)
16884 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16885 RTIME = RDISTL/BECAS(I2)
16886 ELSE
16887 RTIME = ZERO
16888 ENDIF
16889* RDISTL, RTIME are this step and time in the rest system of the other
16890* nucleus
16891 DO 13 K=1,3
16892 VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+COSCAS(ICAS,K)*DDISTL
16893 VTXCA1(I2,K) = VTXCAS(I2,K) +COSCAS(I2,K) *RDISTL
16894 13 CONTINUE
16895 VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME
16896 VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME
16897* position of particle production is half the impact-parameter to
16898* the interacting nucleon
16899 DO 14 K=1,3
16900 WHKK(K,NHKK) = OHALF*(VTXCA1(1,K)+WHKK(K,IDXSPE(1)))
16901 VHKK(K,NHKK) = OHALF*(VTXCA1(2,K)+VHKK(K,IDXSPE(1)))
16902 14 CONTINUE
16903* time of production of secondary = time of interaction
16904 WHKK(4,NHKK) = VTXCA1(1,4)
16905 VHKK(4,NHKK) = VTXCA1(2,4)
16906 ENDIF
16907
16908 11 CONTINUE
16909
16910* modify status and position of cascade particle (the latter for
16911* statistics reasons only)
16912 ISTHKK(IDXCAS) = 2
16913 IF (LABSOR) ISTHKK(IDXCAS) = 19
16914 IF (.NOT.LABSOR) THEN
16915 DO 15 K=1,4
16916 WHKK(K,IDXCAS) = VTXCA1(1,K)
16917 VHKK(K,IDXCAS) = VTXCA1(2,K)
16918 15 CONTINUE
16919 ENDIF
16920
16921 DO 16 I=1,NSPE
16922 IS = IDXSPE(I)
16923* dump interacting nucleons for energy-momentum conservation check
16924 IF (LEMCCK)
16925 & CALL DT_EVTEMC(PHKK(1,IS),PHKK(2,IS),PHKK(3,IS),PHKK(4,IS),
16926 & 2,IDUM,IDUM)
16927* modify entry for interacting nucleons
16928 IF (ISTHKK(IS).EQ.12+ICAS) ISTHKK(IS)=16+ICAS
16929 IF (ISTHKK(IS).EQ.14+ICAS) ISTHKK(IS)=2
16930 IF (I.GE.2) THEN
16931 JDAHKK(1,IS) = JDAHKK(1,IDXSPE(1))
16932 JDAHKK(2,IS) = JDAHKK(2,IDXSPE(1))
16933 ENDIF
16934 16 CONTINUE
16935
16936* check energy-momentum conservation
16937 IF (LEMCCK) THEN
16938 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,500,IREJ1)
16939 IF (IREJ1.NE.0) GOTO 9999
16940 ENDIF
16941
16942* update counter
16943 IF (LABSOR) THEN
16944 NINCCO(ICAS,1) = NINCCO(ICAS,1)+1
16945 ELSE
16946 IF (IPROC.EQ.1) NINCCO(ICAS,2) = NINCCO(ICAS,2)+1
16947 IF (IPROC.EQ.2) NINCCO(ICAS,3) = NINCCO(ICAS,3)+1
16948 ENDIF
16949
16950 RETURN
16951
16952 9997 CONTINUE
16953 9998 CONTINUE
16954* transport-step but no cascade step due to configuration (i.e. there
16955* is no nucleon for interaction etc.)
16956 IF (LCAS) THEN
16957 DO 100 K=1,4
16958C WHKK(K,IDXCAS) = VTXCAS(1,K)
16959C VHKK(K,IDXCAS) = VTXCAS(2,K)
16960 WHKK(K,IDXCAS) = VTXCA1(1,K)
16961 VHKK(K,IDXCAS) = VTXCA1(2,K)
16962 100 CONTINUE
16963 ENDIF
16964
16965C9998 CONTINUE
16966* no cascade-step because of configuration
16967* (i.e. hadron outside nucleus etc.)
16968 LCAS = .TRUE.
16969 RETURN
16970
16971 9999 CONTINUE
16972* rejection
16973 IREJ = 1
16974 RETURN
16975 END
16976
16977*$ CREATE DT_ABSORP.FOR
16978*COPY DT_ABSORP
16979*
16980*===absorp=============================================================*
16981*
16982 SUBROUTINE DT_ABSORP(IDCAS,PCAS,NCAS,NSPE,IDSPE,IDXSPE,MODE,IREJ)
16983
16984************************************************************************
16985* Two-nucleon absorption of antiprotons, pi-, and K-. *
16986* Antiproton absorption is handled by HADRIN. *
16987* The following channels for meson-absorption are considered: *
16988* pi- + p + p ---> n + p *
16989* pi- + p + n ---> n + n *
16990* K- + p + p ---> sigma+ + n / Lam + p / sigma0 + p *
16991* K- + p + n ---> sigma- + n / Lam + n / sigma0 + n *
16992* K- + p + p ---> sigma- + n *
16993* IDCAS, PCAS identity, momentum of particle to be absorbed *
16994* NCAS = 1 intranuclear cascade in projectile *
16995* = -1 intranuclear cascade in target *
16996* NSPE number of spectator nucleons involved *
16997* IDXSPE(2) DTEVT1-indices of spectator nucleons involved *
16998* Revised version of the original STOPIK written by HJM and J. Ranft. *
16999* This version dated 24.02.95 is written by S. Roesler *
17000************************************************************************
17001
17002 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17003 SAVE
17004 PARAMETER ( LINP = 10 ,
17005 & LOUT = 6 ,
17006 & LDAT = 9 )
17007 PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,ONE=1.0D0,
17008 & ONETHI=0.3333D0,TWOTHI=0.6666D0)
17009
17010* event history
17011 PARAMETER (NMXHKK=200000)
17012 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17013 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17014 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17015* extended event history
17016 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17017 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17018 & IHIST(2,NMXHKK)
17019* flags for input different options
17020 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17021 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17022 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17023* final state after inc step
17024 PARAMETER (MAXFSP=10)
17025 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17026* particle properties (BAMJET index convention)
17027 CHARACTER*8 ANAME
17028 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17029 & IICH(210),IIBAR(210),K1(210),K2(210)
17030
17031 DIMENSION PCAS(5),IDXSPE(2),IDSPE(2),PSPE(2,5),PSPE1(5),
17032 & PTOT3P(4),BG3P(4),
17033 & ECMF(2),PCMF(2),CODF(2),COFF(2),SIFF(2)
17034
17035 IREJ = 0
17036 NFSP = 0
17037
17038* skip particles others than ap, pi-, K- for mode=0
17039 IF ((MODE.EQ.0).AND.
17040 & (IDCAS.NE.2).AND.(IDCAS.NE.14).AND.(IDCAS.NE.16)) RETURN
17041* skip particles others than pions for mode=1
17042* (2-nucleon absorption in intranuclear cascade)
17043 IF ((MODE.EQ.1).AND.
17044 & (IDCAS.NE.13).AND.(IDCAS.NE.14).AND.(IDCAS.NE.23)) RETURN
17045
17046 NUCAS = NCAS
17047 IF (NUCAS.EQ.-1) NUCAS = 2
17048
17049 IF (MODE.EQ.0) THEN
17050* scan spectator nucleons for nucleons being able to "absorb"
17051 NSPE = 0
17052 IDXSPE(1) = 0
17053 IDXSPE(2) = 0
17054 DO 1 I=1,NHKK
17055 IF ((ISTHKK(I).EQ.12+NUCAS).OR.(ISTHKK(I).EQ.14+NUCAS)) THEN
17056 NSPE = NSPE+1
17057 IDXSPE(NSPE) = I
17058 IDSPE(NSPE) = IDBAM(I)
17059 IF ((NSPE.EQ.1).AND.(IDCAS.EQ.2)) GOTO 2
17060 IF (NSPE.EQ.2) THEN
17061 IF ((IDCAS.EQ.14).AND.(IDSPE(1).EQ.8).AND.
17062 & (IDSPE(2).EQ.8)) THEN
17063* there is no pi-+n+n channel
17064 NSPE = 1
17065 GOTO 1
17066 ELSE
17067 GOTO 2
17068 ENDIF
17069 ENDIF
17070 ENDIF
17071 1 CONTINUE
17072
17073 2 CONTINUE
17074 ENDIF
17075* transform excited projectile nucleons (status=15) into proj. rest s.
17076 DO 3 I=1,NSPE
17077 DO 4 K=1,5
17078 PSPE(I,K) = PHKK(K,IDXSPE(I))
17079 4 CONTINUE
17080 3 CONTINUE
17081
17082* antiproton absorption
17083 IF ((IDCAS.EQ.2).AND.(NSPE.GE.1)) THEN
17084 DO 5 K=1,5
17085 PSPE1(K) = PSPE(1,K)
17086 5 CONTINUE
17087 CALL DT_HADRIN(IDCAS,PCAS,IDSPE(1),PSPE1,1,IREJ1)
17088 IF (IREJ1.NE.0) GOTO 9999
17089
17090* meson absorption
17091 ELSEIF (((IDCAS.EQ.13).OR.(IDCAS.EQ.14).OR.(IDCAS.EQ.23)
17092 & .OR.(IDCAS.EQ.16)).AND.(NSPE.GE.2)) THEN
17093 IF (IDCAS.EQ.14) THEN
17094* pi- absorption
17095 IDFSP(1) = 8
17096 IDFSP(2) = 8
17097 IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) IDFSP(2) = 1
17098 ELSEIF (IDCAS.EQ.13) THEN
17099* pi+ absorption
17100 IDFSP(1) = 1
17101 IDFSP(2) = 1
17102 IF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) IDFSP(2) = 8
17103 ELSEIF (IDCAS.EQ.23) THEN
17104* pi0 absorption
17105 IDFSP(1) = IDSPE(1)
17106 IDFSP(2) = IDSPE(2)
17107 ELSEIF (IDCAS.EQ.16) THEN
17108* K- absorption
17109 R = DT_RNDM(PCAS)
17110 IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) THEN
17111 IF (R.LT.ONETHI) THEN
17112 IDFSP(1) = 21
17113 IDFSP(2) = 8
17114 ELSEIF (R.LT.TWOTHI) THEN
17115 IDFSP(1) = 17
17116 IDFSP(2) = 1
17117 ELSE
17118 IDFSP(1) = 22
17119 IDFSP(2) = 1
17120 ENDIF
17121 ELSEIF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) THEN
17122 IDFSP(1) = 20
17123 IDFSP(2) = 8
17124 ELSE
17125 IF (R.LT.ONETHI) THEN
17126 IDFSP(1) = 20
17127 IDFSP(2) = 1
17128 ELSEIF (R.LT.TWOTHI) THEN
17129 IDFSP(1) = 17
17130 IDFSP(2) = 8
17131 ELSE
17132 IDFSP(1) = 22
17133 IDFSP(2) = 8
17134 ENDIF
17135 ENDIF
17136 ENDIF
17137* dump initial particles for energy-momentum cons. check
17138 IF (LEMCCK) THEN
17139 CALL DT_EVTEMC(PCAS(1),PCAS(2),PCAS(3),PCAS(4),1,IDUM,IDUM)
17140 CALL DT_EVTEMC(PSPE(1,1),PSPE(1,2),PSPE(1,3),PSPE(1,4),2,
17141 & IDUM,IDUM)
17142 CALL DT_EVTEMC(PSPE(2,1),PSPE(2,2),PSPE(2,3),PSPE(2,4),2,
17143 & IDUM,IDUM)
17144 ENDIF
17145* get Lorentz-parameter of 3 particle initial state
17146 DO 6 K=1,4
17147 PTOT3P(K) = PCAS(K)+PSPE(1,K)+PSPE(2,K)
17148 6 CONTINUE
17149 P3P = SQRT(PTOT3P(1)**2+PTOT3P(2)**2+PTOT3P(3)**2)
17150 AM3P = SQRT( (PTOT3P(4)-P3P)*(PTOT3P(4)+P3P) )
17151 DO 7 K=1,4
17152 BG3P(K) = PTOT3P(K)/MAX(AM3P,TINY10)
17153 7 CONTINUE
17154* 2-particle decay of the 3-particle compound system
17155 CALL DT_DTWOPD(AM3P,ECMF(1),ECMF(2),PCMF(1),PCMF(2),
17156 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
17157 & AAM(IDFSP(1)),AAM(IDFSP(2)))
17158 DO 8 I=1,2
17159 SDF = SQRT((ONE-CODF(I))*(ONE+CODF(I)))
17160 PX = PCMF(I)*COFF(I)*SDF
17161 PY = PCMF(I)*SIFF(I)*SDF
17162 PZ = PCMF(I)*CODF(I)
17163 CALL DT_DALTRA(BG3P(4),BG3P(1),BG3P(2),BG3P(3),PX,PY,PZ,
17164 & ECMF(I),PTOFSP,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17165 & PFSP(4,I))
17166 PFSP(5,I) = SQRT( (PFSP(4,I)-PTOFSP)*(PFSP(4,I)+PTOFSP) )
17167* check consistency of kinematics
17168 IF (ABS(AAM(IDFSP(I))-PFSP(5,I)).GT.TINY5) THEN
17169 WRITE(LOUT,1001) IDFSP(I),AAM(IDFSP(I)),PFSP(5,I)
17170 1001 FORMAT(1X,'ABSORP: warning! inconsistent',
17171 & ' tree-particle kinematics',/,20X,'id: ',I3,
17172 & ' AAM = ',E10.4,' MFSP = ',E10.4)
17173 ENDIF
17174* dump final state particles for energy-momentum cons. check
17175 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
17176 & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
17177 8 CONTINUE
17178 NFSP = 2
17179 IF (LEMCCK) THEN
17180 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,100,IREJ1)
17181 IF (IREJ1.NE.0) THEN
17182 WRITE(LOUT,*)'ABSORB: EMC ',AAM(IDFSP(1)),AAM(IDFSP(2)),
17183 & AM3P
17184 GOTO 9999
17185 ENDIF
17186 ENDIF
17187 ELSE
17188 IF (IOULEV(3).GT.0) WRITE(LOUT,1000) IDCAS,NSPE
17189 1000 FORMAT(1X,'ABSORP: warning! absorption for particle ',I3,
17190 & ' impossible',/,20X,'too few spectators (',I2,')')
17191 NSPE = 0
17192 ENDIF
17193
17194 RETURN
17195
17196 9999 CONTINUE
17197 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in ABSORP'
17198 IREJ = 1
17199 RETURN
17200 END
17201
17202*$ CREATE DT_HADRIN.FOR
17203*COPY DT_HADRIN
17204*
17205*===hadrin=============================================================*
17206*
17207 SUBROUTINE DT_HADRIN(IDPR,PPR,IDTA,PTA,MODE,IREJ)
17208
17209************************************************************************
17210* Interface to the HADRIN-routines for inelastic and elastic *
17211* scattering. *
17212* IDPR,PPR(5) identity, momentum of projectile *
17213* IDTA,PTA(5) identity, momentum of target *
17214* MODE = 1 inelastic interaction *
17215* = 2 elastic interaction *
17216* Revised version of the original FHAD. *
17217* This version dated 27.10.95 is written by S. Roesler *
17218************************************************************************
17219
17220 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17221 SAVE
17222 PARAMETER ( LINP = 10 ,
17223 & LOUT = 6 ,
17224 & LDAT = 9 )
17225 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,
17226 & TINY2=1.0D-2,TINY1=1.0D-1,ONE=1.0D0)
17227
17228 LOGICAL LCORR,LMSSG
17229
17230* flags for input different options
17231 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17232 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17233 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17234* final state after inc step
17235 PARAMETER (MAXFSP=10)
17236 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17237* particle properties (BAMJET index convention)
17238 CHARACTER*8 ANAME
17239 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17240 & IICH(210),IIBAR(210),K1(210),K2(210)
17241* output-common for DHADRI/ELHAIN
17242* final state from HADRIN interaction
17243 PARAMETER (MAXFIN=10)
17244 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
17245 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
17246
17247 DIMENSION PPR(5),PPR1(5),PTA(5),BGTA(4),
17248 & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4),IMCORR(2)
17249
17250 DATA LMSSG /.TRUE./
17251
17252 IREJ = 0
17253 NFSP = 0
17254 KCORR = 0
17255 IMCORR(1) = 0
17256 IMCORR(2) = 0
17257 LCORR = .FALSE.
17258
17259* dump initial particles for energy-momentum cons. check
17260 IF (LEMCCK) THEN
17261 CALL DT_EVTEMC(PPR(1),PPR(2),PPR(3),PPR(4),1,IDUM,IDUM)
17262 CALL DT_EVTEMC(PTA(1),PTA(2),PTA(3),PTA(4),2,IDUM,IDUM)
17263 ENDIF
17264
17265 AMP2 = PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2
17266 AMT2 = PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2
17267 IF ((AMP2.LT.ZERO).OR.(AMT2.LT.ZERO).OR.
17268 & (ABS(AMP2-AAM(IDPR)**2).GT.TINY5).OR.
17269 & (ABS(AMT2-AAM(IDTA)**2).GT.TINY5)) THEN
17270 IF (LMSSG.AND.(IOULEV(3).GT.0))
17271 & WRITE(LOUT,1000) AMP2,AAM(IDPR)**2,AMT2,AAM(IDTA)**2
17272 1000 FORMAT(1X,'HADRIN: warning! inconsistent projectile/target',
17273 & ' mass',/,20X,'AMP2 = ',E12.4,', AAM(IDPR)**2 = ',
17274 & E12.4,/,20X,'AMT2 = ',E12.4,', AAM(IDTA)**2 = ',E12.4)
17275 LMSSG = .FALSE.
17276 LCORR = .TRUE.
17277 ENDIF
17278
17279* convert initial state particles into particles which can be
17280* handled by HADRIN
17281 IDHPR = IDPR
17282 IDHTA = IDTA
17283 IF ((IDHPR.LE.0).OR.(IDHPR.GE.111).OR.LCORR) THEN
17284 IF ((IDHPR.LE.0).OR.(IDHPR.GE.111)) IDHPR = 1
17285 DO 1 K=1,4
17286 P1IN(K) = PPR(K)
17287 P2IN(K) = PTA(K)
17288 1 CONTINUE
17289 XM1 = AAM(IDHPR)
17290 XM2 = AAM(IDHTA)
17291 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
17292 IF (IREJ1.GT.0) THEN
17293 WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.'
17294 GOTO 9999
17295 ENDIF
17296 DO 2 K=1,4
17297 PPR(K) = P1OUT(K)
17298 PTA(K) = P2OUT(K)
17299 2 CONTINUE
17300 PPR(5) = SQRT(PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2)
17301 PTA(5) = SQRT(PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2)
17302 ENDIF
17303
17304* Lorentz-parameter for trafo into rest-system of target
17305 DO 3 K=1,4
17306 BGTA(K) = PTA(K)/PTA(5)
17307 3 CONTINUE
17308* transformation of projectile into rest-system of target
17309 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),PPR(1),PPR(2),
17310 & PPR(3),PPR(4),PPRTO1,PPR1(1),PPR1(2),PPR1(3),
17311 & PPR1(4))
17312
17313* direction cosines of projectile in target rest system
17314 CX = PPR1(1)/PPRTO1
17315 CY = PPR1(2)/PPRTO1
17316 CZ = PPR1(3)/PPRTO1
17317
17318* sample inelastic interaction
17319 IF (MODE.EQ.1) THEN
17320 CALL DT_DHADRI(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA)
17321 IF (IRH.EQ.1) GOTO 9998
17322* sample elastic interaction
17323 ELSEIF (MODE.EQ.2) THEN
17324 CALL DT_ELHAIN(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA,IREJ1)
17325 IF (IREJ1.NE.0) THEN
17326 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in HADRIN'
17327 GOTO 9999
17328 ENDIF
17329 IF (IRH.EQ.1) GOTO 9998
17330 ELSE
17331 WRITE(LOUT,1001) MODE,INTHAD
17332 1001 FORMAT(1X,'HADRIN: warning! inconsistent interaction mode',
17333 & I4,' (INTHAD =',I4,')')
17334 GOTO 9999
17335 ENDIF
17336
17337* transform final state particles back into Lab.
17338 DO 4 I=1,IRH
17339 NFSP = NFSP+1
17340 PX = CXRH(I)*PLRH(I)
17341 PY = CYRH(I)*PLRH(I)
17342 PZ = CZRH(I)*PLRH(I)
17343 CALL DT_DALTRA(BGTA(4),BGTA(1),BGTA(2),BGTA(3),
17344 & PX,PY,PZ,ELRH(I),PTOFSP,PFSP(1,NFSP),
17345 & PFSP(2,NFSP),PFSP(3,NFSP),PFSP(4,NFSP))
17346 IDFSP(NFSP) = ITRH(I)
17347 AMFSP2 = PFSP(4,NFSP)**2-PFSP(1,NFSP)**2-PFSP(2,NFSP)**2-
17348 & PFSP(3,NFSP)**2
17349 IF (AMFSP2.LT.-TINY3) THEN
17350 WRITE(LOUT,1002) IDFSP(NFSP),PFSP(1,NFSP),PFSP(2,NFSP),
17351 & PFSP(3,NFSP),PFSP(4,NFSP),AMFSP2
17352 1002 FORMAT(1X,'HADRIN: warning! final state particle (id = ',
17353 & I2,') with negative mass^2',/,1X,5E12.4)
17354 GOTO 9999
17355 ELSE
17356 PFSP(5,NFSP) = SQRT(ABS(AMFSP2))
17357 IF (ABS(PFSP(5,NFSP)-AAM(IDFSP(NFSP))).GT.TINY1) THEN
17358 WRITE(LOUT,1003) IDFSP(NFSP),AAM(IDFSP(NFSP)),
17359 & PFSP(5,NFSP)
17360 1003 FORMAT(1X,'HADRIN: warning! final state particle',
17361 & ' (id = ',I2,') with inconsistent mass',/,1X,
17362 & 2E12.4)
17363 KCORR = KCORR+1
17364 IF (KCORR.GT.2) GOTO 9999
17365 IMCORR(KCORR) = NFSP
17366 ENDIF
17367 ENDIF
17368* dump final state particles for energy-momentum cons. check
17369 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
17370 & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
17371 4 CONTINUE
17372
17373* transform momenta on mass shell in case of inconsistencies in
17374* HADRIN
17375 IF (KCORR.GT.0) THEN
17376 IF (KCORR.EQ.2) THEN
17377 I1 = IMCORR(1)
17378 I2 = IMCORR(2)
17379 ELSE
17380 IF (IMCORR(1).EQ.1) THEN
17381 I1 = 1
17382 I2 = 2
17383 ELSE
17384 I1 = 1
17385 I2 = IMCORR(1)
17386 ENDIF
17387 ENDIF
17388 IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I1),PFSP(2,I1),
17389 & PFSP(3,I1),PFSP(4,I1),2,IDUM,IDUM)
17390 IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I2),PFSP(2,I2),
17391 & PFSP(3,I2),PFSP(4,I2),2,IDUM,IDUM)
17392 DO 5 K=1,4
17393 P1IN(K) = PFSP(K,I1)
17394 P2IN(K) = PFSP(K,I2)
17395 5 CONTINUE
17396 XM1 = AAM(IDFSP(I1))
17397 XM2 = AAM(IDFSP(I2))
17398 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
17399 IF (IREJ1.GT.0) THEN
17400 WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.'
17401C GOTO 9999
17402 ENDIF
17403 DO 6 K=1,4
17404 PFSP(K,I1) = P1OUT(K)
17405 PFSP(K,I2) = P2OUT(K)
17406 6 CONTINUE
17407 PFSP(5,I1) = SQRT(PFSP(4,I1)**2-PFSP(1,I1)**2
17408 & -PFSP(2,I1)**2-PFSP(3,I1)**2)
17409 PFSP(5,I2) = SQRT(PFSP(4,I2)**2-PFSP(1,I2)**2
17410 & -PFSP(2,I2)**2-PFSP(3,I2)**2)
17411* dump final state particles for energy-momentum cons. check
17412 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I1),-PFSP(2,I1),
17413 & -PFSP(3,I1),-PFSP(4,I1),2,IDUM,IDUM)
17414 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I2),-PFSP(2,I2),
17415 & -PFSP(3,I2),-PFSP(4,I2),2,IDUM,IDUM)
17416 ENDIF
17417
17418* check energy-momentum conservation
17419 IF (LEMCCK) THEN
17420 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,102,IREJ1)
17421 IF (IREJ1.NE.0) GOTO 9999
17422 ENDIF
17423
17424 RETURN
17425
17426 9998 CONTINUE
17427 IREJ = 2
17428 RETURN
17429
17430 9999 CONTINUE
17431 IREJ = 1
17432 RETURN
17433 END
17434
17435*$ CREATE DT_HADCOL.FOR
17436*COPY DT_HADCOL
17437*
17438*===hadcol=============================================================*
17439*
17440 SUBROUTINE DT_HADCOL(IDPROJ,PPN,IDXTAR,IREJ)
17441
17442************************************************************************
17443* Interface to the HADRIN-routines for inelastic and elastic *
17444* scattering. This subroutine samples hadron-nucleus interactions *
17445* below DPM-threshold. *
17446* IDPROJ BAMJET-index of projectile hadron *
17447* PPN projectile momentum in target rest frame *
17448* IDXTAR DTEVT1-index of target nucleon undergoing *
17449* interaction with projectile hadron *
17450* This subroutine replaces HADHAD. *
17451* This version dated 5.5.95 is written by S. Roesler *
17452************************************************************************
17453
17454 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17455 SAVE
17456 PARAMETER ( LINP = 10 ,
17457 & LOUT = 6 ,
17458 & LDAT = 9 )
17459 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0)
17460
17461 LOGICAL LSTART
17462
17463* event history
17464 PARAMETER (NMXHKK=200000)
17465 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17466 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17467 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17468* extended event history
17469 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17470 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17471 & IHIST(2,NMXHKK)
17472* nuclear potential
17473 LOGICAL LFERMI
17474 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17475 & EBINDP(2),EBINDN(2),EPOT(2,210),
17476 & ETACOU(2),ICOUL,LFERMI
17477* interface HADRIN-DPM
17478 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
17479* parameter for intranuclear cascade
17480 LOGICAL LPAULI
17481 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
17482* final state after inc step
17483 PARAMETER (MAXFSP=10)
17484 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17485* particle properties (BAMJET index convention)
17486 CHARACTER*8 ANAME
17487 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17488 & IICH(210),IIBAR(210),K1(210),K2(210)
17489
17490 DIMENSION PPROJ(5),PNUC(5)
17491
17492 DATA LSTART /.TRUE./
17493
17494 IREJ = 0
17495
17496 NPOINT(1) = NHKK+1
17497
17498 TAUSAV = TAUFOR
17499**sr 6/9/01 commented
17500C TAUFOR = TAUFOR/2.0D0
17501**
17502 IF (LSTART) THEN
17503 WRITE(LOUT,1000)
17504 1000 FORMAT(/,1X,'HADCOL: Scattering handled by HADRIN')
17505 WRITE(LOUT,1001) TAUFOR
17506 1001 FORMAT(/,1X,'HADCOL: Formation zone parameter set to ',
17507 & F5.1,' fm/c')
17508 LSTART = .FALSE.
17509 ENDIF
17510
17511 IDNUC = IDBAM(IDXTAR)
17512 IDNUC1 = IDT_MCHAD(IDNUC)
17513 IDPRO1 = IDT_MCHAD(IDPROJ)
17514
17515 IF ((INTHAD.EQ.1).OR.(INTHAD.EQ.2)) THEN
17516 IPROC = INTHAD
17517 ELSE
17518**
17519C CALL DT_SIHNIN(IDPRO1,IDNUC1,PPN,SIGIN)
17520C CALL DT_SIHNEL(IDPRO1,IDNUC1,PPN,SIGEL)
17521 DUMZER = ZERO
17522 CALL DT_XSHN(IDPRO1,IDNUC1,PPN,DUMZER,SIGTOT,SIGEL)
17523 SIGIN = SIGTOT-SIGEL
17524C SIGTOT = SIGIN+SIGEL
17525**
17526 IPROC = 1
17527 IF (DT_RNDM(SIGIN).LT.SIGEL/SIGTOT) IPROC = 2
17528 ENDIF
17529
17530 PPROJ(1) = ZERO
17531 PPROJ(2) = ZERO
17532 PPROJ(3) = PPN
17533 PPROJ(5) = AAM(IDPROJ)
17534 PPROJ(4) = SQRT(PPROJ(5)**2+PPROJ(3)**2)
17535 DO 1 K=1,5
17536 PNUC(K) = PHKK(K,IDXTAR)
17537 1 CONTINUE
17538
17539 ILOOP = 0
17540 2 CONTINUE
17541 ILOOP = ILOOP+1
17542 IF (ILOOP.GT.100) GOTO 9999
17543
17544 CALL DT_HADRIN(IDPROJ,PPROJ,IDNUC,PNUC,IPROC,IREJ1)
17545 IF (IREJ1.EQ.1) GOTO 9999
17546
17547 IF (IREJ1.GT.1) THEN
17548* no interaction possible
17549* require Pauli blocking
17550 IF ((IDPROJ.EQ.1).AND.(PPROJ(4).LE.PFERMP(2)+PPROJ(5))) GOTO 2
17551 IF ((IDPROJ.EQ.8).AND.(PPROJ(4).LE.PFERMN(2)+PPROJ(5))) GOTO 2
17552 IF ((IIBAR(IDPROJ).NE.1).AND.
17553 & (PPROJ(4).LE.EPOT(2,IDPROJ)+PPROJ(5))) GOTO 2
17554* store incoming particle as final state particle
17555 CALL DT_LTNUC(PPROJ(3),PPROJ(4),PCMS,ECMS,3)
17556 CALL DT_EVTPUT(1,IDPROJ,1,0,PPROJ(1),PPROJ(2),PCMS,ECMS,0,0,0)
17557 NPOINT(4) = NHKK
17558 ELSE
17559* require Pauli blocking for final state nucleons
17560 DO 4 I=1,NFSP
17561 IF ((IDFSP(I).EQ.1).AND.
17562 & (PFSP(4,I).LE.PFERMP(2)+AAM(IDFSP(I)))) GOTO 2
17563 IF ((IDFSP(I).EQ.8).AND.
17564 & (PFSP(4,I).LE.PFERMN(2)+AAM(IDFSP(I)))) GOTO 2
17565 IF ((IIBAR(IDFSP(I)).NE.1).AND.
17566 & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I))))GOTO 2
17567 4 CONTINUE
17568* store final state particles
17569 DO 5 I=1,NFSP
17570 IST = 1
17571 IF ((IIBAR(IDFSP(I)).EQ.1).AND.
17572 & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I)))) IST = 16
17573 IDHAD = IDT_IPDGHA(IDFSP(I))
17574 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PCMS,ECMS,3)
17575 CALL DT_EVTPUT(IST,IDHAD,1,IDXTAR,PFSP(1,I),PFSP(2,I),
17576 & PCMS,ECMS,0,0,0)
17577 IF (I.EQ.1) NPOINT(4) = NHKK
17578 VHKK(1,NHKK) = 0.5D0*(VHKK(1,1)+VHKK(1,IDXTAR))
17579 VHKK(2,NHKK) = 0.5D0*(VHKK(2,1)+VHKK(2,IDXTAR))
17580 VHKK(3,NHKK) = VHKK(3,IDXTAR)
17581 VHKK(4,NHKK) = VHKK(4,IDXTAR)
17582 WHKK(1,NHKK) = 0.5D0*(WHKK(1,1)+WHKK(1,IDXTAR))
17583 WHKK(2,NHKK) = 0.5D0*(WHKK(2,1)+WHKK(2,IDXTAR))
17584 WHKK(3,NHKK) = WHKK(3,1)
17585 WHKK(4,NHKK) = WHKK(4,1)
17586 5 CONTINUE
17587 ENDIF
17588 TAUFOR = TAUSAV
17589 RETURN
17590
17591 9999 CONTINUE
17592 IREJ = 1
17593 TAUFOR = TAUSAV
17594 RETURN
17595 END
17596
17597*$ CREATE DT_GETEMU.FOR
17598*COPY DT_GETEMU
17599*
17600*===getemu=============================================================*
17601*
17602 SUBROUTINE DT_GETEMU(IT,ITZ,KKMAT,MODE)
17603
17604************************************************************************
17605* Sampling of emulsion component to be considered as target-nucleus. *
17606* This version dated 6.5.95 is written by S. Roesler. *
17607************************************************************************
17608
17609 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17610 SAVE
17611 PARAMETER ( LINP = 10 ,
17612 & LOUT = 6 ,
17613 & LDAT = 9 )
17614 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
17615
17616 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
17617* emulsion treatment
17618 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
17619 & NCOMPO,IEMUL
17620* Glauber formalism: flags and parameters for statistics
17621 LOGICAL LPROD
17622 CHARACTER*8 CGLB
17623 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
17624
17625 IF (MODE.EQ.0) THEN
17626 SUMFRA = ZERO
17627 RR = DT_RNDM(SUMFRA)
17628 IT = 0
17629 ITZ = 0
17630 DO 1 ICOMP=1,NCOMPO
17631 SUMFRA = SUMFRA+EMUFRA(ICOMP)
17632 IF (SUMFRA.GT.RR) THEN
17633 IT = IEMUMA(ICOMP)
17634 ITZ = IEMUCH(ICOMP)
17635 KKMAT = ICOMP
17636 GOTO 2
17637 ENDIF
17638 1 CONTINUE
17639 2 CONTINUE
17640 IF (IT.LE.0) THEN
17641 WRITE(LOUT,'(1X,A,E12.3)')
17642 & 'Warning! norm. failure within emulsion fractions',
17643 & SUMFRA
17644 STOP
17645 ENDIF
17646 ELSEIF (MODE.EQ.1) THEN
17647 NDIFF = 10000
17648 DO 3 I=1,NCOMPO
17649 IDIFF = ABS(IT-IEMUMA(I))
17650 IF (IDIFF.LT.NDIFF) THEN
17651 KKMAT = I
17652 NDIFF = IDIFF
17653 ENDIF
17654 3 CONTINUE
17655 ELSE
17656 STOP 'DT_GETEMU'
17657 ENDIF
17658
17659* bypass for variable projectile/target/energy runs: the correct
17660* Glauber data will be always loaded on kkmat=1
17661 IF (IOGLB.EQ.100) THEN
17662 KKMAT = 1
17663 ENDIF
17664
17665 RETURN
17666 END
17667
17668*$ CREATE DT_NCLPOT.FOR
17669*COPY DT_NCLPOT
17670*
17671*===nclpot=============================================================*
17672*
17673 SUBROUTINE DT_NCLPOT(IPZ,IP,ITZ,IT,AFERP,AFERT,MODE)
17674
17675************************************************************************
17676* Calculation of Coulomb and nuclear potential for a given configurat. *
17677* IPZ, IP charge/mass number of proj. *
17678* ITZ, IT charge/mass number of targ. *
17679* AFERP,AFERT factors modifying proj./target pot. *
17680* if =0, FERMOD is used *
17681* MODE = 0 calculation of binding energy *
17682* = 1 pre-calculated binding energy is used *
17683* This version dated 16.11.95 is written by S. Roesler. *
17684* *
17685* Last change 28.12.2006 by S. Roesler. *
17686************************************************************************
17687
17688 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17689 SAVE
17690 PARAMETER ( LINP = 10 ,
17691 & LOUT = 6 ,
17692 & LDAT = 9 )
17693 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
17694 & TINY10=1.0D-10)
17695
17696 LOGICAL LSTART
17697
17698* particle properties (BAMJET index convention)
17699 CHARACTER*8 ANAME
17700 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17701 & IICH(210),IIBAR(210),K1(210),K2(210)
17702* nuclear potential
17703 LOGICAL LFERMI
17704 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17705 & EBINDP(2),EBINDN(2),EPOT(2,210),
17706 & ETACOU(2),ICOUL,LFERMI
17707
17708 DIMENSION IDXPOT(14)
17709* ap an lam alam sig- sig+ sig0 tet0 tet- asig-
17710 DATA IDXPOT / 2, 9, 17, 18, 20, 21, 22, 97, 98, 99,
17711* asig0 asig+ atet0 atet+
17712 & 100, 101, 102, 103/
17713
17714 DATA AN /0.4D0/
17715 DATA LSTART /.TRUE./
17716
17717 IF (MODE.EQ.0) THEN
17718 EBINDP(1) = ZERO
17719 EBINDN(1) = ZERO
17720 EBINDP(2) = ZERO
17721 EBINDN(2) = ZERO
17722 ENDIF
17723 AIP = DBLE(IP)
17724 AIPZ = DBLE(IPZ)
17725 AIT = DBLE(IT)
17726 AITZ = DBLE(ITZ)
17727
17728 FERMIP = AFERP
17729 IF (AFERP.LE.ZERO) FERMIP = FERMOD
17730 FERMIT = AFERT
17731 IF (AFERT.LE.ZERO) FERMIT = FERMOD
17732
17733* Fermi momenta and binding energy for projectile
17734 IF ((IP.GT.1).AND.LFERMI) THEN
17735 IF (MODE.EQ.0) THEN
17736C EBINDP(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ-1)
17737C EBINDN(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ)
17738 BIP = AIP -ONE
17739 BIPZ = AIPZ-ONE
17740 EBINDP(1) = 1.0D-3*(DT_ENERGY(ONE,ONE)+DT_ENERGY(BIP,BIPZ)
17741 & -DT_ENERGY(AIP,AIPZ))
17742 IF (AIP.LE.AIPZ) THEN
17743 EBINDN(1) = EBINDP(1)
17744 WRITE(LOUT,*) ' DT_NCLPOT: AIP.LE.AIPZ (',AIP,AIPZ,')'
17745 ELSE
17746 EBINDN(1) = 1.0D-3*(DT_ENERGY(ONE,ZERO)
17747 & +DT_ENERGY(BIP,AIPZ)-DT_ENERGY(AIP,AIPZ))
17748 ENDIF
17749 ENDIF
17750 PFERMP(1) = FERMIP*AN*(AIPZ/AIP)**0.333333D0
17751 PFERMN(1) = FERMIP*AN*((AIP-AIPZ)/AIP)**0.33333D0
17752 ELSE
17753 PFERMP(1) = ZERO
17754 PFERMN(1) = ZERO
17755 ENDIF
17756* effective nuclear potential for projectile
17757C EPOT(1,1) = PFERMP(1)**2/(2.0D0*AAM(1)) + EBINDP(1)
17758C EPOT(1,8) = PFERMN(1)**2/(2.0D0*AAM(8)) + EBINDN(1)
17759 EPOT(1,1) = SQRT(PFERMP(1)**2+AAM(1)**2) -AAM(1) + EBINDP(1)
17760 EPOT(1,8) = SQRT(PFERMN(1)**2+AAM(8)**2) -AAM(8) + EBINDN(1)
17761
17762* Fermi momenta and binding energy for target
17763 IF ((IT.GT.1).AND.LFERMI) THEN
17764 IF (MODE.EQ.0) THEN
17765C EBINDP(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ-1)
17766C EBINDN(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ)
17767 BIT = AIT -ONE
17768 BITZ = AITZ-ONE
17769
17770 EBINDP(2) = 1.0D-3*(DT_ENERGY(ONE,ONE)+DT_ENERGY(BIT,BITZ)
17771 & -DT_ENERGY(AIT,AITZ))
17772
17773 IF (AIT.LE.AITZ) THEN
17774 EBINDN(2) = EBINDP(2)
17775 WRITE(LOUT,*) ' DT_NCLPOT: AIT.LE.AIPT (',AIT,AIPT,')'
17776 ELSE
17777
17778 EBINDN(2) = 1.0D-3*(DT_ENERGY(ONE,ZERO)
17779 & +DT_ENERGY(BIT,AITZ)-DT_ENERGY(AIT,AITZ))
17780
17781 ENDIF
17782 ENDIF
17783 PFERMP(2) = FERMIT*AN*(AITZ/AIT)**0.333333D0
17784 PFERMN(2) = FERMIT*AN*((AIT-AITZ)/AIT)**0.33333D0
17785 ELSE
17786 PFERMP(2) = ZERO
17787 PFERMN(2) = ZERO
17788 ENDIF
17789* effective nuclear potential for target
17790C EPOT(2,1) = PFERMP(2)**2/(2.0D0*AAM(1)) + EBINDP(2)
17791C EPOT(2,8) = PFERMN(2)**2/(2.0D0*AAM(8)) + EBINDN(2)
17792 EPOT(2,1) = SQRT(PFERMP(2)**2+AAM(1)**2) -AAM(1) + EBINDP(2)
17793 EPOT(2,8) = SQRT(PFERMN(2)**2+AAM(8)**2) -AAM(8) + EBINDN(2)
17794
17795 DO 2 I=1,14
17796 EPOT(1,IDXPOT(I)) = EPOT(1,8)
17797 EPOT(2,IDXPOT(I)) = EPOT(2,8)
17798 2 CONTINUE
17799
17800* Coulomb energy
17801 ETACOU(1) = ZERO
17802 ETACOU(2) = ZERO
17803 IF (ICOUL.EQ.1) THEN
17804 IF (IP.GT.1)
17805 & ETACOU(1) = 0.001116D0*AIPZ/(1.0D0+AIP**0.333D0)
17806 IF (IT.GT.1)
17807 & ETACOU(2) = 0.001116D0*AITZ/(1.0D0+AIT**0.333D0)
17808 ENDIF
17809
17810 IF (LSTART) THEN
17811 WRITE(LOUT,1000) IP,IPZ,IT,ITZ,EBINDP,EBINDN,
17812 & EPOT(1,1)-EBINDP(1),EPOT(2,1)-EBINDP(2),
17813 & EPOT(1,8)-EBINDN(1),EPOT(2,8)-EBINDN(2),
17814 & FERMOD,ETACOU
17815 1000 FORMAT(/,/,1X,'NCLPOT: quantities for inclusion of nuclear'
17816 & ,' effects',/,12X,'---------------------------',
17817 & '----------------',/,/,38X,'projectile',
17818 & ' target',/,/,1X,'Mass number / charge',
17819 & 17X,I3,' /',I3,6X,I3,' /',I3,/,1X,'Binding energy -',
17820 & ' proton (GeV) ',2E14.4,/,17X,'- neutron (GeV)'
17821 & ,1X,2E14.4,/,1X,'Fermi-potential - proton (GeV)',
17822 & 1X,2E14.4,/,17X,'- neutron (GeV) ',2E14.4,/,/,
17823 & 1X,'Scale factor for Fermi-momentum ',F4.2,/,
17824 & /,1X,'Coulomb-energy ',2(E14.4,' GeV '),/,/)
17825 LSTART = .FALSE.
17826 ENDIF
17827
17828 RETURN
17829 END
17830
17831*$ CREATE DT_RESNCL.FOR
17832*COPY DT_RESNCL
17833*
17834*===resncl=============================================================*
17835*
17836 SUBROUTINE DT_RESNCL(EPN,NLOOP,MODE)
17837
17838************************************************************************
17839* Treatment of residual nuclei and nuclear effects. *
17840* MODE = 1 initializations *
17841* = 2 treatment of final state *
17842* This version dated 16.11.95 is written by S. Roesler. *
17843* *
17844* Last change 05.01.2007 by S. Roesler. *
17845************************************************************************
17846
17847 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17848 SAVE
17849 PARAMETER ( LINP = 10 ,
17850 & LOUT = 6 ,
17851 & LDAT = 9 )
17852 PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,THREE=3.D0,TINY3=1.0D-3,
17853 & TINY2=1.0D-2,TINY1=1.0D-1,TINY4=1.0D-4,TINY10=1.0D-10,
17854 & ONETHI=ONE/THREE)
17855 PARAMETER (AMUAMU = 0.93149432D0,
17856 & FM2MM = 1.0D-12,
17857 & RNUCLE = 1.12D0)
17858 PARAMETER ( EMVGEV = 1.0 D-03 )
17859 PARAMETER ( AMUGEV = 0.93149432 D+00 )
17860 PARAMETER ( AMPRTN = 0.93827231 D+00 )
17861 PARAMETER ( AMNTRN = 0.93956563 D+00 )
17862 PARAMETER ( AMELCT = 0.51099906 D-03 )
17863 PARAMETER ( HLFHLF = 0.5D+00 )
17864 PARAMETER ( FERTHO = 14.33 D-09 )
17865 PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
17866 PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
17867 PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
17868
17869* event history
17870 PARAMETER (NMXHKK=200000)
17871 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17872 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17873 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17874* extended event history
17875 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17876 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17877 & IHIST(2,NMXHKK)
17878* particle properties (BAMJET index convention)
17879 CHARACTER*8 ANAME
17880 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17881 & IICH(210),IIBAR(210),K1(210),K2(210)
17882* flags for input different options
17883 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17884 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17885 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17886* nuclear potential
17887 LOGICAL LFERMI
17888 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17889 & EBINDP(2),EBINDN(2),EPOT(2,210),
17890 & ETACOU(2),ICOUL,LFERMI
17891* properties of interacting particles
17892 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
17893* properties of photon/lepton projectiles
17894 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
17895* Lorentz-parameters of the current interaction
17896 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
17897 & UMO,PPCM,EPROJ,PPROJ
17898* treatment of residual nuclei: wounded nucleons
17899 COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
17900* treatment of residual nuclei: 4-momenta
17901 LOGICAL LRCLPR,LRCLTA
17902 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
17903 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
17904
17905 DIMENSION PFSP(4),PSEC(4),PSEC0(4)
17906 DIMENSION PMOMB(5000),IDXB(5000),PMOMM(10000),IDXM(10000),
17907 & IDXCOR(15000),IDXOTH(NMXHKK)
17908
17909 GOTO (1,2) MODE
17910
17911*------- initializations
17912 1 CONTINUE
17913
17914* initialize arrays for residual nuclei
17915 DO 10 K=1,5
17916 IF (K.LE.4) THEN
17917 PFSP(K) = ZERO
17918 ENDIF
17919 PINIPR(K) = ZERO
17920 PINITA(K) = ZERO
17921 PRCLPR(K) = ZERO
17922 PRCLTA(K) = ZERO
17923 TRCLPR(K) = ZERO
17924 TRCLTA(K) = ZERO
17925 10 CONTINUE
17926 SCPOT = ONE
17927 NLOOP = 0
17928
17929* correction of projectile 4-momentum for effective target pot.
17930* and Coulomb-energy (in case of hadron-nucleus interaction only)
9b65428d
AM		 17931* IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
17932* EPNI = EPN
9aaba0d6 17933* Coulomb-energy:
17934* positively charged hadron - check energy for Coloumb pot.
9b65428d
AM		 17935* IF (IICH(IJPROJ).EQ.1) THEN
17936* THRESH = ETACOU(2)+AAM(IJPROJ)
17937* IF (EPNI.LE.THRESH) THEN
17938* WRITE(LOUT,1000)
17939* 1000 FORMAT(/,1X,'KKINC: WARNING! projectile energy',
17940* & ' below Coulomb threshold - event rejected',/)
17941* ISTHKK(1) = 1
17942* RETURN
17943* ENDIF
9aaba0d6 17944* negatively charged hadron - increase energy by Coulomb energy
9b65428d
AM		 17945* ELSEIF (IICH(IJPROJ).EQ.-1) THEN
17946* EPNI = EPNI+ETACOU(2)
17947* ENDIF
17948* IF ((IJPROJ.EQ.1).OR.(IJPROJ.EQ.8)) THEN
9aaba0d6 17949* Effective target potential
17950*sr 6.6. binding energy only (to avoid negative exc. energies)
17951C EPNI = EPNI+EPOT(2,IJPROJ)
9b65428d
AM		 17952* EBIPOT = EBINDP(2)
17953* IF ((IJPROJ.NE.1).AND.(ABS(EPOT(2,IJPROJ)).GT.5.0D-3))
17954* & EBIPOT = EBINDN(2)
17955* EPNI = EPNI+ABS(EBIPOT)
9aaba0d6 17956* re-initialization of DTLTRA
9b65428d
AM		 17957* DUM1 = ZERO
17958* DUM2 = ZERO
17959*
17960* CALL DT_LTINI(IJPROJ,IJTARG,EPNI,DUM1,DUM2,0)
17961* ENDIF
17962* ENDIF
9aaba0d6 17963
17964* projectile in n-n cms
17965 IF ((IP.LE.1).AND.(IT.GT.1)) THEN
17966 PMASS1 = AAM(IJPROJ)
17967C* VDM assumption
17968C IF (IJPROJ.EQ.7) PMASS1 = AAM(33)
17969 IF (IJPROJ.EQ.7) PMASS1 = AAM(IJPROJ)-SQRT(VIRT)
17970 PMASS2 = AAM(1)
17971 PM1 = SIGN(PMASS1**2,PMASS1)
17972 PM2 = SIGN(PMASS2**2,PMASS2)
17973 PINIPR(4) = (UMO**2-PM2+PM1)/(TWO*UMO)
17974 PINIPR(5) = PMASS1
17975 IF (PMASS1.GT.ZERO) THEN
17976 PINIPR(3) = SQRT((PINIPR(4)-PINIPR(5))
17977 & *(PINIPR(4)+PINIPR(5)))
17978 ELSE
17979 PINIPR(3) = SQRT(PINIPR(4)**2-PM1)
17980 ENDIF
17981 AIT = DBLE(IT)
17982 AITZ = DBLE(ITZ)
17983 PINITA(5) = AIT*AMUAMU+1.0D-3*DT_ENERGY(AIT,AITZ)
17984 CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
17985 ELSEIF ((IP.GT.1).AND.(IT.LE.1)) THEN
17986 PMASS1 = AAM(1)
17987 PMASS2 = AAM(IJTARG)
17988 PM1 = SIGN(PMASS1**2,PMASS1)
17989 PM2 = SIGN(PMASS2**2,PMASS2)
17990 PINITA(4) = (UMO**2-PM1+PM2)/(TWO*UMO)
17991 PINITA(5) = PMASS2
17992 PINITA(3) = -SQRT((PINITA(4)-PINITA(5))
17993 & *(PINITA(4)+PINITA(5)))
17994 AIP = DBLE(IP)
17995 AIPZ = DBLE(IPZ)
17996 PINIPR(5) = AIP*AMUAMU+1.0D-3*DT_ENERGY(AIP,AIPZ)
17997 CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
17998 ELSEIF ((IP.GT.1).AND.(IT.GT.1)) THEN
17999 AIP = DBLE(IP)
18000 AIPZ = DBLE(IPZ)
18001 PINIPR(5) = AIP*AMUAMU+1.0D-3*DT_ENERGY(AIP,AIPZ)
18002 CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
18003 AIT = DBLE(IT)
18004 AITZ = DBLE(ITZ)
18005 PINITA(5) = AIT*AMUAMU+1.0D-3*DT_ENERGY(AIT,AITZ)
18006 CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
18007 ENDIF
18008
18009 RETURN
18010
18011*------- treatment of final state
18012 2 CONTINUE
18013
18014 NLOOP = NLOOP+1
18015 IF (NLOOP.GT.1) SCPOT = 0.10D0
18016C WRITE(LOUT,*) 'event ',NEVHKK,NLOOP,SCPOT
18017
18018 JPW = NPW
18019 JPCW = NPCW
18020 JTW = NTW
18021 JTCW = NTCW
18022 DO 40 K=1,4
18023 PFSP(K) = ZERO
18024 40 CONTINUE
18025
18026 NOB = 0
18027 NOM = 0
18028 DO 900 I=NPOINT(4),NHKK
18029 IDXOTH(I) = -1
18030 IF (ISTHKK(I).EQ.1) THEN
18031 IF (IDBAM(I).EQ.7) GOTO 900
18032 IPOT = 0
18033 IOTHER = 0
18034* particle moving into forward direction
18035 IF (PHKK(3,I).GE.ZERO) THEN
18036* most likely to be effected by projectile potential
18037 IPOT = 1
18038* there is no projectile nucleus, try target
18039 IF ((IP.LE.1).OR.((IP-NPW).LE.1)) THEN
18040 IPOT = 2
18041 IF (IP.GT.1) IOTHER = 1
18042* there is no target nucleus --> skip
18043 IF ((IT.LE.1).OR.((IT-NTW).LE.1)) GOTO 900
18044 ENDIF
18045* particle moving into backward direction
18046 ELSE
18047* most likely to be effected by target potential
18048 IPOT = 2
18049* there is no target nucleus, try projectile
18050 IF ((IT.LE.1).OR.((IT-NTW).LE.1)) THEN
18051 IPOT = 1
18052 IF (IT.GT.1) IOTHER = 1
18053* there is no projectile nucleus --> skip
18054 IF ((IP.LE.1).OR.((IP-NPW).LE.1)) GOTO 900
18055 ENDIF
18056 ENDIF
18057 IFLG = -IPOT
18058* nobam=3: particle is in overlap-region or neither inside proj. nor target
18059* =1: particle is not in overlap-region AND is inside target (2)
18060* =2: particle is not in overlap-region AND is inside projectile (1)
18061* flag particles which are inside the nucleus ipot but not in its
18062* overlap region
18063 IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) IFLG = IPOT
18064 IF (IDBAM(I).NE.0) THEN
18065* baryons: keep all nucleons and all others where flag is set
18066 IF (IIBAR(IDBAM(I)).NE.0) THEN
18067 IF ((IDBAM(I).EQ.1).OR.(IDBAM(I).EQ.8).OR.(IFLG.GT.0))
18068 & THEN
18069 NOB = NOB+1
18070 PMOMB(NOB) = PHKK(3,I)
18071 IDXB(NOB) = SIGN(10000000*IABS(IFLG)
18072 & +1000000*IOTHER+I,IFLG)
18073 ENDIF
18074* mesons: keep only those mesons where flag is set
18075 ELSE
18076 IF (IFLG.GT.0) THEN
18077 NOM = NOM+1
18078 PMOMM(NOM) = PHKK(3,I)
18079 IDXM(NOM) = 10000000*IFLG+1000000*IOTHER+I
18080 ENDIF
18081 ENDIF
18082 ENDIF
18083 ENDIF
18084 900 CONTINUE
18085*
18086* sort particles in the arrays according to increasing long. momentum
18087 CALL DT_SORT1(PMOMB,IDXB,NOB,1,NOB,1)
18088 CALL DT_SORT1(PMOMM,IDXM,NOM,1,NOM,1)
18089*
18090* shuffle indices into one and the same array according to the later
18091* sequence of correction
18092 NCOR = 0
18093 IF (IT.GT.1) THEN
18094 DO 910 I=1,NOB
18095 IF (PMOMB(I).GT.ZERO) GOTO 911
18096 NCOR = NCOR+1
18097 IDXCOR(NCOR) = IDXB(I)
18098 910 CONTINUE
18099 911 CONTINUE
18100 IF (IP.GT.1) THEN
18101 DO 912 J=1,NOB
18102 I = NOB+1-J
18103 IF (PMOMB(I).LT.ZERO) GOTO 913
18104 NCOR = NCOR+1
18105 IDXCOR(NCOR) = IDXB(I)
18106 912 CONTINUE
18107 913 CONTINUE
18108 ELSE
18109 DO 914 I=1,NOB
18110 IF (PMOMB(I).GT.ZERO) THEN
18111 NCOR = NCOR+1
18112 IDXCOR(NCOR) = IDXB(I)
18113 ENDIF
18114 914 CONTINUE
18115 ENDIF
18116 ELSE
18117 DO 915 J=1,NOB
18118 I = NOB+1-J
18119 NCOR = NCOR+1
18120 IDXCOR(NCOR) = IDXB(I)
18121 915 CONTINUE
18122 ENDIF
18123 DO 925 I=1,NOM
18124 IF (PMOMM(I).GT.ZERO) GOTO 926
18125 NCOR = NCOR+1
18126 IDXCOR(NCOR) = IDXM(I)
18127 925 CONTINUE
18128 926 CONTINUE
18129 DO 927 J=1,NOM
18130 I = NOM+1-J
18131 IF (PMOMM(I).LT.ZERO) GOTO 928
18132 NCOR = NCOR+1
18133 IDXCOR(NCOR) = IDXM(I)
18134 927 CONTINUE
18135 928 CONTINUE
18136*
18137C IF (NEVHKK.EQ.484) THEN
18138C WRITE(LOUT,9000) JPCW,JPW-JPCW,JTCW,JTW-JTCW
18139C 9000 FORMAT(1X,'wounded nucleons (proj.-p,n targ.-p,n)',/,4I10)
18140C WRITE(LOUT,9001) NOB,NOM,NCOR
18141C 9001 FORMAT(1X,'produced particles (baryons,mesons,all)',3I10)
18142C WRITE(LOUT,'(/,A)') ' baryons '
18143C DO 950 I=1,NOB
18144CC J = IABS(IDXB(I))
18145CC INDEX = J-IABS(J/10000000)*10000000
18146C IPOT = IABS(IDXB(I))/10000000
18147C IOTHER = IABS(IDXB(I))/1000000-IPOT*10
18148C INDEX = IABS(IDXB(I))-IPOT*10000000-IOTHER*1000000
18149C WRITE(LOUT,9002) I,INDEX,IDXB(I),IDBAM(INDEX),PMOMB(I)
18150C 950 CONTINUE
18151C WRITE(LOUT,'(/,A)') ' mesons '
18152C DO 951 I=1,NOM
18153CC INDEX = IDXM(I)-IABS(IDXM(I)/10000000)*10000000
18154C IPOT = IABS(IDXM(I))/10000000
18155C IOTHER = IABS(IDXM(I))/1000000-IPOT*10
18156C INDEX = IABS(IDXM(I))-IPOT*10000000-IOTHER*1000000
18157C WRITE(LOUT,9002) I,INDEX,IDXM(I),IDBAM(INDEX),PMOMM(I)
18158C 951 CONTINUE
18159C 9002 FORMAT(1X,4I14,E14.5)
18160C WRITE(LOUT,'(/,A)') ' all '
18161C DO 952 I=1,NCOR
18162CC J = IABS(IDXCOR(I))
18163CC INDEX = J-IABS(J/10000000)*10000000
18164CC IPOT = IABS(IDXCOR(I))/10000000
18165C IOTHER = IABS(IDXCOR(I))/1000000-IPOT*10
18166C INDEX = IABS(IDXCOR(I))-IPOT*10000000-IOTHER*1000000
18167C WRITE(LOUT,9003) I,INDEX,IDXCOR(I),IDBAM(INDEX)
18168C 952 CONTINUE
18169C 9003 FORMAT(1X,4I14)
18170C ENDIF
18171*
18172 DO 20 ICOR=1,NCOR
18173 IPOT = IABS(IDXCOR(ICOR))/10000000
18174 IOTHER = IABS(IDXCOR(ICOR))/1000000-IPOT*10
18175 I = IABS(IDXCOR(ICOR))-IPOT*10000000-IOTHER*1000000
18176 IDXOTH(I) = 1
18177
18178 IDSEC = IDBAM(I)
18179
18180* reduction of particle momentum by corresponding nuclear potential
18181* (this applies only if Fermi-momenta are requested)
18182
18183 IF (LFERMI) THEN
18184
18185* Lorentz-transformation into the rest system of the selected nucleus
18186 IMODE = -IPOT-1
18187 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
18188 & PSEC(1),PSEC(2),PSEC(3),PSEC(4),IDSEC,IMODE)
18189 PSECO = SQRT(PSEC(1)**2+PSEC(2)**2+PSEC(3)**2)
18190 AMSEC = SQRT(ABS((PSEC(4)-PSECO)*(PSEC(4)+PSECO)))
18191 JPMOD = 0
18192
18193 CHKLEV = TINY3
18194 IF ((EPROJ.GE.1.0D4).AND.(IDSEC.EQ.7)) CHKLEV = TINY1
18195 IF (EPROJ.GE.2.0D6) CHKLEV = 1.0D0
18196 IF (ABS(AMSEC-AAM(IDSEC)).GT.CHKLEV) THEN
18197 IF (IOULEV(3).GT.0)
18198 & WRITE(LOUT,2000) I,NEVHKK,IDSEC,AMSEC,AAM(IDSEC)
18199 2000 FORMAT(1X,'RESNCL: inconsistent mass of particle',
18200 & ' at entry ',I5,' (evt.',I8,')',/,' IDSEC: ',
18201 & I4,' AMSEC: ',E12.3,' AAM(IDSEC): ',E12.3,/)
18202 GOTO 23
18203 ENDIF
18204
18205 DO 21 K=1,4
18206 PSEC0(K) = PSEC(K)
18207 21 CONTINUE
18208
18209* the correction for nuclear potential effects is applied to as many
18210* p/n as many nucleons were wounded; the momenta of other final state
18211* particles are corrected only if they materialize inside the corresp.
18212* nucleus (here: NOBAM = 1 part. outside proj., = 2 part. outside targ
18213* = 3 part. outside proj. and targ., >=10 in overlapping region)
18214 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) THEN
18215 IF (IPOT.EQ.1) THEN
18216 IF ((JPW.GT.0).AND.(IOTHER.EQ.0)) THEN
18217* this is most likely a wounded nucleon
18218**test
18219C RDIST = SQRT((VHKK(1,IPW(JPW))/FM2MM)**2
18220C & +(VHKK(2,IPW(JPW))/FM2MM)**2
18221C & +(VHKK(3,IPW(JPW))/FM2MM)**2)
18222C RAD = RNUCLE*DBLE(IP)**ONETHI
18223C FDEN = 1.4D0*DT_DENSIT(IP,RDIST,RAD)
18224C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
18225**
18226 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18227 JPW = JPW-1
18228 JPMOD = 1
18229 ELSE
18230* correct only if part. was materialized inside nucleus
18231* and if it is ouside the overlapping region
18232 IF ((NOBAM(I).NE.1).AND.(NOBAM(I).LT.3)) THEN
18233 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18234 JPMOD = 1
18235 ENDIF
18236 ENDIF
18237 ELSEIF (IPOT.EQ.2) THEN
18238 IF ((JTW.GT.0).AND.(IOTHER.EQ.0)) THEN
18239* this is most likely a wounded nucleon
18240**test
18241C RDIST = SQRT((VHKK(1,ITW(JTW))/FM2MM)**2
18242C & +(VHKK(2,ITW(JTW))/FM2MM)**2
18243C & +(VHKK(3,ITW(JTW))/FM2MM)**2)
18244C RAD = RNUCLE*DBLE(IT)**ONETHI
18245C FDEN = 1.4D0*DT_DENSIT(IT,RDIST,RAD)
18246C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
18247**
18248 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18249 JTW = JTW-1
18250 JPMOD = 1
18251 ELSE
18252* correct only if part. was materialized inside nucleus
18253 IF ((NOBAM(I).NE.2).AND.(NOBAM(I).LT.3)) THEN
18254 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18255 JPMOD = 1
18256 ENDIF
18257 ENDIF
18258 ENDIF
18259 ELSE
18260 IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) THEN
18261 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18262 JPMOD = 1
18263 ENDIF
18264 ENDIF
18265
18266 IF (NLOOP.EQ.1) THEN
18267* Coulomb energy correction:
18268* the treatment of Coulomb potential correction is similar to the
18269* one for nuclear potential
18270 IF (IDSEC.EQ.1) THEN
18271 IF ((IPOT.EQ.1).AND.(JPCW.GT.0)) THEN
18272 JPCW = JPCW-1
18273 ELSEIF ((IPOT.EQ.2).AND.(JTCW.GT.0)) THEN
18274 JTCW = JTCW-1
18275 ELSE
18276 IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
18277 ENDIF
18278 ELSE
18279 IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
18280 ENDIF
18281 IF (IICH(IDSEC).EQ.1) THEN
18282* pos. particles: check if they are able to escape Coulomb potential
18283 IF (PSEC(4).LT.AMSEC+ETACOU(IPOT)) THEN
18284 ISTHKK(I) = 14+IPOT
18285 IF (ISTHKK(I).EQ.15) THEN
18286 DO 26 K=1,4
18287 PHKK(K,I) = PSEC0(K)
18288 TRCLPR(K) = TRCLPR(K)+PSEC0(K)
18289 26 CONTINUE
18290 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
18291 IF (IDSEC.EQ.1) NPCW = NPCW-1
18292 ELSEIF (ISTHKK(I).EQ.16) THEN
18293 DO 27 K=1,4
18294 PHKK(K,I) = PSEC0(K)
18295 TRCLTA(K) = TRCLTA(K)+PSEC0(K)
18296 27 CONTINUE
18297 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
18298 IF (IDSEC.EQ.1) NTCW = NTCW-1
18299 ENDIF
18300 GOTO 20
18301 ENDIF
18302 ELSEIF (IICH(IDSEC).EQ.-1) THEN
18303* neg. particles: decrease energy by Coulomb-potential
18304 PSEC(4) = PSEC(4)-ETACOU(IPOT)
18305 JPMOD = 1
18306 ENDIF
18307 ENDIF
18308
18309 25 CONTINUE
18310
18311 IF (PSEC(4).LT.AMSEC) THEN
18312 IF (IOULEV(6).GT.0)
18313 & WRITE(LOUT,2001) I,IDSEC,PSEC(4),AMSEC
18314 2001 FORMAT(1X,'KKINC: particle at DTEVT1-pos. ',I5,
18315 & ' is not allowed to escape nucleus',/,
18316 & 8X,'id : ',I3,' reduced energy: ',E15.4,
18317 & ' mass: ',E12.3)
18318 ISTHKK(I) = 14+IPOT
18319 IF (ISTHKK(I).EQ.15) THEN
18320 DO 28 K=1,4
18321 PHKK(K,I) = PSEC0(K)
18322 TRCLPR(K) = TRCLPR(K)+PSEC0(K)
18323 28 CONTINUE
18324 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
18325 IF (IDSEC.EQ.1) NPCW = NPCW-1
18326 ELSEIF (ISTHKK(I).EQ.16) THEN
18327 DO 29 K=1,4
18328 PHKK(K,I) = PSEC0(K)
18329 TRCLTA(K) = TRCLTA(K)+PSEC0(K)
18330 29 CONTINUE
18331 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
18332 IF (IDSEC.EQ.1) NTCW = NTCW-1
18333 ENDIF
18334 GOTO 20
18335 ENDIF
18336
18337 IF (JPMOD.EQ.1) THEN
18338 PSECN = SQRT( (PSEC(4)-AMSEC)*(PSEC(4)+AMSEC) )
18339* 4-momentum after correction for nuclear potential
18340 DO 22 K=1,3
18341 PSEC(K) = PSEC(K)*PSECN/PSECO
18342 22 CONTINUE
18343
18344* store recoil momentum from particles escaping the nuclear potentials
18345 DO 30 K=1,4
18346 IF (IPOT.EQ.1) THEN
18347 TRCLPR(K) = TRCLPR(K)+PSEC0(K)-PSEC(K)
18348 ELSEIF (IPOT.EQ.2) THEN
18349 TRCLTA(K) = TRCLTA(K)+PSEC0(K)-PSEC(K)
18350 ENDIF
18351 30 CONTINUE
18352
18353* transform momentum back into n-n cms
18354 IMODE = IPOT+1
18355 CALL DT_LTRANS(PSEC(1),PSEC(2),PSEC(3),PSEC(4),
18356 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
18357 & IDSEC,IMODE)
18358 ENDIF
18359
18360 ENDIF
18361
18362 23 CONTINUE
18363 DO 31 K=1,4
18364 PFSP(K) = PFSP(K)+PHKK(K,I)
18365 31 CONTINUE
18366
18367 20 CONTINUE
18368
18369 DO 33 I=NPOINT(4),NHKK
18370 IF ((ISTHKK(I).EQ.1).AND.(IDXOTH(I).LT.0)) THEN
18371 PFSP(1) = PFSP(1)+PHKK(1,I)
18372 PFSP(2) = PFSP(2)+PHKK(2,I)
18373 PFSP(3) = PFSP(3)+PHKK(3,I)
18374 PFSP(4) = PFSP(4)+PHKK(4,I)
18375 ENDIF
18376 33 CONTINUE
18377
18378 DO 34 K=1,5
18379 PRCLPR(K) = TRCLPR(K)
18380 PRCLTA(K) = TRCLTA(K)
18381 34 CONTINUE
18382
18383 IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
18384* hadron-nucleus interactions: get residual momentum from energy-
18385* momentum conservation
18386 DO 32 K=1,4
18387 PRCLPR(K) = ZERO
18388 PRCLTA(K) = PINIPR(K)+PINITA(K)-PFSP(K)
18389 32 CONTINUE
18390 ELSE
18391* nucleus-hadron, nucleus-nucleus: get residual momentum from
18392* accumulated recoil momenta of particles leaving the spectators
18393* transform accumulated recoil momenta of residual nuclei into
18394* n-n cms
18395 PZI = PRCLPR(3)
18396 PEI = PRCLPR(4)
18397 CALL DT_LTNUC(PZI,PEI,PRCLPR(3),PRCLPR(4),2)
18398 PZI = PRCLTA(3)
18399 PEI = PRCLTA(4)
18400 CALL DT_LTNUC(PZI,PEI,PRCLTA(3),PRCLTA(4),3)
18401C IF (IP.GT.1) THEN
18402 PRCLPR(3) = PRCLPR(3)+PINIPR(3)
18403 PRCLPR(4) = PRCLPR(4)+PINIPR(4)
18404C ENDIF
18405 IF (IT.GT.1) THEN
18406 PRCLTA(3) = PRCLTA(3)+PINITA(3)
18407 PRCLTA(4) = PRCLTA(4)+PINITA(4)
18408 ENDIF
18409 ENDIF
18410
18411* check momenta of residual nuclei
18412 IF (LEMCCK) THEN
18413 CALL DT_EVTEMC(-PINIPR(1),-PINIPR(2),-PINIPR(3),-PINIPR(4),
18414 & 1,IDUM,IDUM)
18415 CALL DT_EVTEMC(-PINITA(1),-PINITA(2),-PINITA(3),-PINITA(4),
18416 & 2,IDUM,IDUM)
18417 CALL DT_EVTEMC(PRCLPR(1),PRCLPR(2),PRCLPR(3),PRCLPR(4),
18418 & 2,IDUM,IDUM)
18419 CALL DT_EVTEMC(PRCLTA(1),PRCLTA(2),PRCLTA(3),PRCLTA(4),
18420 & 2,IDUM,IDUM)
18421 CALL DT_EVTEMC(PFSP(1),PFSP(2),PFSP(3),PFSP(4),2,IDUM,IDUM)
18422**sr 19.12. changed to avoid output when used with phojet
18423C CHKLEV = TINY3
18424 CHKLEV = TINY1
18425 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,501,IREJ1)
18426C IF ((NEVHKK.EQ.409).OR.(NEVHKK.EQ.460).OR.(NEVHKK.EQ.765))
18427C & CALL DT_EVTOUT(4)
18428 IF (IREJ1.GT.0) RETURN
18429 ENDIF
18430
18431 RETURN
18432 END
18433
18434*$ CREATE DT_SCN4BA.FOR
18435*COPY DT_SCN4BA
18436*
18437*===scn4ba=============================================================*
18438*
18439 SUBROUTINE DT_SCN4BA
18440
18441************************************************************************
18442* SCan /DTEVT1/ 4 BAryons which are not able to escape nuclear pot. *
18443* This version dated 12.12.95 is written by S. Roesler. *
18444************************************************************************
18445
18446 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18447 SAVE
18448 PARAMETER ( LINP = 10 ,
18449 & LOUT = 6 ,
18450 & LDAT = 9 )
18451 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
18452 & TINY10=1.0D-10)
18453
18454* event history
18455 PARAMETER (NMXHKK=200000)
18456 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18457 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18458 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18459* extended event history
18460 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18461 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18462 & IHIST(2,NMXHKK)
18463* particle properties (BAMJET index convention)
18464 CHARACTER*8 ANAME
18465 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18466 & IICH(210),IIBAR(210),K1(210),K2(210)
18467* properties of interacting particles
18468 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
18469* nuclear potential
18470 LOGICAL LFERMI
18471 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18472 & EBINDP(2),EBINDN(2),EPOT(2,210),
18473 & ETACOU(2),ICOUL,LFERMI
18474* treatment of residual nuclei: wounded nucleons
18475 COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
18476* treatment of residual nuclei: 4-momenta
18477 LOGICAL LRCLPR,LRCLTA
18478 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18479 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18480
18481 DIMENSION PLAB(2,5),PCMS(4)
18482
18483 IREJ = 0
18484
18485* get number of wounded nucleons
18486 NPW = 0
18487 NPW0 = 0
18488 NPCW = 0
18489 NPSTCK = 0
18490 NTW = 0
18491 NTW0 = 0
18492 NTCW = 0
18493 NTSTCK = 0
18494
18495 ISGLPR = 0
18496 ISGLTA = 0
18497 LRCLPR = .FALSE.
18498 LRCLTA = .FALSE.
18499
18500C DO 2 I=1,NHKK
18501 DO 2 I=1,NPOINT(1)
18502* projectile nucleons wounded in primary interaction and in fzc
18503 IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.17)) THEN
18504 NPW = NPW+1
18505 IPW(NPW) = I
18506 NPSTCK = NPSTCK+1
18507 IF (IDHKK(I).EQ.2212) NPCW = NPCW+1
18508 IF (ISTHKK(I).EQ.11) NPW0 = NPW0+1
18509C IF (IP.GT.1) THEN
18510 DO 5 K=1,4
18511 TRCLPR(K) = TRCLPR(K)-PHKK(K,I)
18512 5 CONTINUE
18513C ENDIF
18514* target nucleons wounded in primary interaction and in fzc
18515 ELSEIF ((ISTHKK(I).EQ.12).OR.(ISTHKK(I).EQ.18)) THEN
18516 NTW = NTW+1
18517 ITW(NTW) = I
18518 NTSTCK = NTSTCK+1
18519 IF (IDHKK(I).EQ.2212) NTCW = NTCW+1
18520 IF (ISTHKK(I).EQ.12) NTW0 = NTW0+1
18521 IF (IT.GT.1) THEN
18522 DO 6 K=1,4
18523 TRCLTA(K) = TRCLTA(K)-PHKK(K,I)
18524 6 CONTINUE
18525 ENDIF
18526 ELSEIF (ISTHKK(I).EQ.13) THEN
18527 ISGLPR = I
18528 ELSEIF (ISTHKK(I).EQ.14) THEN
18529 ISGLTA = I
18530 ENDIF
18531 2 CONTINUE
18532
18533 DO 11 I=NPOINT(4),NHKK
18534* baryons which are unable to escape the nuclear potential of proj.
18535 IF (ISTHKK(I).EQ.15) THEN
18536 ISGLPR = I
18537 NPSTCK = NPSTCK-1
18538 IF (IIBAR(IDBAM(I)).NE.0) THEN
18539 NPW = NPW-1
18540 IF (IICH(IDBAM(I)).GT.0) NPCW = NPCW-1
18541 ENDIF
18542 DO 7 K=1,4
18543 TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
18544 7 CONTINUE
18545* baryons which are unable to escape the nuclear potential of targ.
18546 ELSEIF (ISTHKK(I).EQ.16) THEN
18547 ISGLTA = I
18548 NTSTCK = NTSTCK-1
18549 IF (IIBAR(IDBAM(I)).NE.0) THEN
18550 NTW = NTW-1
18551 IF (IICH(IDBAM(I)).GT.0) NTCW = NTCW-1
18552 ENDIF
18553 DO 8 K=1,4
18554 TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
18555 8 CONTINUE
18556 ENDIF
18557 11 CONTINUE
18558
18559* residual nuclei so far
18560 IRESP = IP-NPSTCK
18561 IREST = IT-NTSTCK
18562
18563* ckeck for "residual nuclei" consisting of one nucleon only
18564* treat it as final state particle
18565 IF (IRESP.EQ.1) THEN
18566 ID = IDBAM(ISGLPR)
18567 IST = ISTHKK(ISGLPR)
18568 CALL DT_LTRANS(PHKK(1,ISGLPR),PHKK(2,ISGLPR),
18569 & PHKK(3,ISGLPR),PHKK(4,ISGLPR),
18570 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,2)
18571 IF (IST.EQ.13) THEN
18572 ISTHKK(ISGLPR) = 11
18573 ELSE
18574 ISTHKK(ISGLPR) = 2
18575 ENDIF
18576 CALL DT_EVTPUT(1,IDHKK(ISGLPR),ISGLPR,0,
18577 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),
18578 & IDRES(ISGLPR),IDXRES(ISGLPR),IDCH(ISGLPR))
18579 NOBAM(NHKK) = NOBAM(ISGLPR)
18580 JDAHKK(1,ISGLPR) = NHKK
18581 DO 21 K=1,4
18582 TRCLPR(K) = TRCLPR(K)-PHKK(K,ISGLPR)
18583 21 CONTINUE
18584 ENDIF
18585 IF (IREST.EQ.1) THEN
18586 ID = IDBAM(ISGLTA)
18587 IST = ISTHKK(ISGLTA)
18588 CALL DT_LTRANS(PHKK(1,ISGLTA),PHKK(2,ISGLTA),
18589 & PHKK(3,ISGLTA),PHKK(4,ISGLTA),
18590 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,3)
18591 IF (IST.EQ.14) THEN
18592 ISTHKK(ISGLTA) = 12
18593 ELSE
18594 ISTHKK(ISGLTA) = 2
18595 ENDIF
18596 CALL DT_EVTPUT(1,IDHKK(ISGLTA),ISGLTA,0,
18597 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),
18598 & IDRES(ISGLTA),IDXRES(ISGLTA),IDCH(ISGLTA))
18599 NOBAM(NHKK) = NOBAM(ISGLTA)
18600 JDAHKK(1,ISGLTA) = NHKK
18601 DO 22 K=1,4
18602 TRCLTA(K) = TRCLTA(K)-PHKK(K,ISGLTA)
18603 22 CONTINUE
18604 ENDIF
18605
18606* get nuclear potential corresp. to the residual nucleus
18607 IPRCL = IP -NPW
18608 IPZRCL = IPZ-NPCW
18609 ITRCL = IT -NTW
18610 ITZRCL = ITZ-NTCW
18611 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
18612
18613* baryons unable to escape the nuclear potential are treated as
18614* excited nucleons (ISTHKK=15,16)
18615 DO 3 I=NPOINT(4),NHKK
18616 IF (ISTHKK(I).EQ.1) THEN
18617 ID = IDBAM(I)
18618 IF ( ((ID.EQ.1).OR.(ID.EQ.8)).AND.(NOBAM(I).NE.3) ) THEN
18619* final state n and p not being outside of both nuclei are considered
18620 NPOTP = 1
18621 NPOTT = 1
18622 IF ( (IP.GT.1) .AND.(IRESP.GT.1).AND.
18623 & (NOBAM(I).NE.1).AND.(NPW.GT.0) ) THEN
18624* Lorentz-trsf. into proj. rest sys. for those being inside proj.
18625 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
18626 & PHKK(4,I),PLAB(1,1),PLAB(1,2),PLAB(1,3),
18627 & PLAB(1,4),ID,-2)
18628 PLABT = SQRT(PLAB(1,1)**2+PLAB(1,2)**2+PLAB(1,3)**2)
18629 PLAB(1,5) = SQRT(ABS( (PLAB(1,4)-PLABT)*
18630 & (PLAB(1,4)+PLABT) ))
18631 EKIN = PLAB(1,4)-PLAB(1,5)
18632 IF (EKIN.LE.EPOT(1,ID)) NPOTP = 15
18633 IF ((ID.EQ.1).AND.(NPCW.LE.0)) NPOTP = 1
18634 ENDIF
18635 IF ( (IT.GT.1) .AND.(IREST.GT.1).AND.
18636 & (NOBAM(I).NE.2).AND.(NTW.GT.0) ) THEN
18637* Lorentz-trsf. into targ. rest sys. for those being inside targ.
18638 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
18639 & PHKK(4,I),PLAB(2,1),PLAB(2,2),PLAB(2,3),
18640 & PLAB(2,4),ID,-3)
18641 PLABT = SQRT(PLAB(2,1)**2+PLAB(2,2)**2+PLAB(2,3)**2)
18642 PLAB(2,5) = SQRT(ABS( (PLAB(2,4)-PLABT)*
18643 & (PLAB(2,4)+PLABT) ))
18644 EKIN = PLAB(2,4)-PLAB(2,5)
18645 IF (EKIN.LE.EPOT(2,ID)) NPOTT = 16
18646 IF ((ID.EQ.1).AND.(NTCW.LE.0)) NPOTT = 1
18647 ENDIF
18648 IF (PHKK(3,I).GE.ZERO) THEN
18649 ISTHKK(I) = NPOTT
18650 IF (NPOTP.NE.1) ISTHKK(I) = NPOTP
18651 ELSE
18652 ISTHKK(I) = NPOTP
18653 IF (NPOTT.NE.1) ISTHKK(I) = NPOTT
18654 ENDIF
18655 IF (ISTHKK(I).NE.1) THEN
18656 J = ISTHKK(I)-14
18657 DO 4 K=1,5
18658 PHKK(K,I) = PLAB(J,K)
18659 4 CONTINUE
18660 IF (ISTHKK(I).EQ.15) THEN
18661 NPW = NPW-1
18662 IF (ID.EQ.1) NPCW = NPCW-1
18663 DO 9 K=1,4
18664 TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
18665 9 CONTINUE
18666 ELSEIF (ISTHKK(I).EQ.16) THEN
18667 NTW = NTW-1
18668 IF (ID.EQ.1) NTCW = NTCW-1
18669 DO 10 K=1,4
18670 TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
18671 10 CONTINUE
18672 ENDIF
18673 ENDIF
18674 ENDIF
18675 ENDIF
18676 3 CONTINUE
18677
18678* again: get nuclear potential corresp. to the residual nucleus
18679 IPRCL = IP -NPW
18680 IPZRCL = IPZ-NPCW
18681 ITRCL = IT -NTW
18682 ITZRCL = ITZ-NTCW
18683c AFERP = 1.2D0*FERMOD*(ONE+(DBLE(IP+10-NPW0)/DBLE(IP+10))**1.1D0)
18684cC AFERP = 1.21D0*FERMOD*(ONE+(DBLE(IP+40-NPW0)/DBLE(IP+40))**1.1D0)
18685c & *(0.94D0+0.3D0*EXP(-DBLE(NPW0)/5.0D0)) /2.0D0
18686C AFERP = 0.0D0
18687c AFERT = 1.2D0*FERMOD*(ONE+(DBLE(IT+10-NTW0)/DBLE(IT+10))**1.1D0)
18688cC AFERT = 1.21D0*FERMOD*(ONE+(DBLE(IT+40-NTW0)/DBLE(IT+40))**1.1D0)
18689c & *(0.94D0+0.3D0*EXP(-DBLE(NTW0)/5.0D0)) /2.0D0
18690C AFERT = 0.0D0
18691C IF (AFERP.LT.FERMOD) AFERP = FERMOD+0.1
18692C IF (AFERT.LT.FERMOD) AFERT = FERMOD+0.1
18693C IF (AFERP.GT.0.85D0) AFERP = 0.85D0
18694C IF (AFERT.GT.0.85D0) AFERT = 0.85D0
18695 AFERP = FERMOD+0.1D0
18696 AFERT = FERMOD+0.1D0
18697
18698 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,AFERP,AFERT,1)
18699
18700 RETURN
18701 END
18702
18703*$ CREATE DT_FICONF.FOR
18704*COPY DT_FICONF
18705*
18706*===ficonf=============================================================*
18707*
18708 SUBROUTINE DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ)
18709
18710************************************************************************
18711* Treatment of FInal CONFiguration including evaporation, fission and *
18712* Fermi-break-up (for light nuclei only). *
18713* Adopted from the original routine FINALE and extended to residual *
18714* projectile nuclei. *
18715* This version dated 12.12.95 is written by S. Roesler. *
18716* *
18717* Last change 27.12.2006 by S. Roesler. *
18718************************************************************************
18719
18720 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18721 SAVE
18722 PARAMETER ( LINP = 10 ,
18723 & LOUT = 6 ,
18724 & LDAT = 9 )
18725 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
18726 PARAMETER (ANGLGB=5.0D-16)
18727 PARAMETER (AMUAMU=0.93149432D0,AMELEC=0.51099906D-3)
18728
18729* event history
18730 PARAMETER (NMXHKK=200000)
18731 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18732 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18733 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18734* extended event history
18735 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18736 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18737 & IHIST(2,NMXHKK)
18738* rejection counter
18739 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
18740 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
18741 & IREXCI(3),IRDIFF(2),IRINC
18742* central particle production, impact parameter biasing
18743 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
18744* particle properties (BAMJET index convention)
18745 CHARACTER*8 ANAME
18746 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18747 & IICH(210),IIBAR(210),K1(210),K2(210)
18748* treatment of residual nuclei: 4-momenta
18749 LOGICAL LRCLPR,LRCLTA
18750 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18751 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18752* treatment of residual nuclei: properties of residual nuclei
18753 COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
18754 & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
18755 & NTOTFI(2),NPROFI(2)
18756* statistics: residual nuclei
18757 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
18758 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
18759 & NINCST(2,4),NINCEV(2),
18760 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
18761 & NRESPB(2),NRESCH(2),NRESEV(4),
18762 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
18763 & NEVAFI(2,2)
18764* flags for input different options
18765 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18766 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18767 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18768* (original name: FINUC)
18769 PARAMETER (MXP=999)
18770 COMMON /FKFINU/ CXR (MXP), CYR (MXP), CZR (MXP),
18771 & CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP),
18772 & TKI (MXP), PLR (MXP), WEI (MXP),
18773 & TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP,
18774 & KPART (MXP)
18775* (original name: RESNUC)
18776 LOGICAL LRNFSS, LFRAGM
18777 COMMON /FKRESN/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
18778 & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
18779 & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES,
18780 & PYRES, PZRES, PTRES2, KTARP, KTARN, IGREYP,
18781 & IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,
18782 & ICRES, IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU,
18783 & IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG,
18784 & IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS,
18785 & LFRAGM
18786 COMMON /FKNDAT/ AV0WEL, APFRMX, AEFRMX, AEFRMA,
18787 & RDSNUC, V0WELL (2), PFRMMX (2), EFRMMX (2),
18788 & EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2),
18789 & VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2),
18790 & PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2),
18791 & EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2),
18792 & ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV ,
18793 & AMRCSQ , ATO1O3 , ZTO1O3 , ELBNDE (0:100)
18794* (original name: PAREVT)
18795 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
18796 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
18797 PARAMETER ( NALLWP = 39 )
18798 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
18799 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
18800 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
18801 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
18802* event flag
18803 COMMON /DTEVNO/ NEVENT,ICASCA
18804
18805 DIMENSION INUC(2),IDXPAR(2),IDPAR(2),AIF(2),AIZF(2),AMRCL(2),
18806 & PRCL(2,4),MO1(2),MO2(2),VRCL(2,4),WRCL(2,4),
18807 & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4)
18808
18809 DIMENSION EXPNUC(2),EXC(2,260),NEXC(2,260)
18810 LOGICAL LLCPOT
18811 DATA EXC,NEXC /520*ZERO,520*0/
18812 DATA EXPNUC /4.0D-3,4.0D-3/
18813
18814 IREJ = 0
18815 LRCLPR = .FALSE.
18816 LRCLTA = .FALSE.
18817
18818* skip residual nucleus treatment if not requested or in case
18819* of central collisions
18820 IF ((.NOT.LEVPRT).OR.(ICENTR.GT.0).OR.(ICENTR.EQ.-1)) RETURN
18821
18822 DO 1 K=1,2
18823 IDPAR(K) = 0
18824 IDXPAR(K)= 0
18825 NTOT(K) = 0
18826 NTOTFI(K)= 0
18827 NPRO(K) = 0
18828 NPROFI(K)= 0
18829 NN(K) = 0
18830 NH(K) = 0
18831 NHPOS(K) = 0
18832 NQ(K) = 0
18833 EEXC(K) = ZERO
18834 MO1(K) = 0
18835 MO2(K) = 0
18836 DO 2 I=1,4
18837 VRCL(K,I) = ZERO
18838 WRCL(K,I) = ZERO
18839 2 CONTINUE
18840 1 CONTINUE
18841 NFSP = 0
18842 INUC(1) = IP
18843 INUC(2) = IT
18844
18845 DO 3 I=1,NHKK
18846
18847* number of final state particles
18848 IF (ABS(ISTHKK(I)).EQ.1) THEN
18849 NFSP = NFSP+1
18850 IDFSP = IDBAM(I)
18851 ENDIF
18852
18853* properties of remaining nucleon configurations
18854 KF = 0
18855 IF ((ISTHKK(I).EQ.13).OR.(ISTHKK(I).EQ.15)) KF = 1
18856 IF ((ISTHKK(I).EQ.14).OR.(ISTHKK(I).EQ.16)) KF = 2
18857 IF (KF.GT.0) THEN
18858 IF (MO1(KF).EQ.0) MO1(KF) = I
18859 MO2(KF) = I
18860* position of residual nucleus = average position of nucleons
18861 DO 4 K=1,4
18862 VRCL(KF,K) = VRCL(KF,K)+VHKK(K,I)
18863 WRCL(KF,K) = WRCL(KF,K)+WHKK(K,I)
18864 4 CONTINUE
18865* total number of particles contributing to each residual nucleus
18866 NTOT(KF) = NTOT(KF)+1
18867 IDTMP = IDBAM(I)
18868 IDXTMP = I
18869* total charge of residual nuclei
18870 NQ(KF) = NQ(KF)+IICH(IDTMP)
18871* number of protons
18872 IF (IDHKK(I).EQ.2212) THEN
18873 NPRO(KF) = NPRO(KF)+1
18874* number of neutrons
18875 ELSEIF (IDHKK(I).EQ.2112) THEN
18876 NN(KF) = NN(KF)+1
18877 ELSE
18878* number of baryons other than n, p
18879 IF (IIBAR(IDTMP).EQ.1) THEN
18880 NH(KF) = NH(KF)+1
18881 IF (IICH(IDTMP).EQ.1) NHPOS(KF) = NHPOS(KF)+1
18882 ELSE
18883* any other mesons (status set to 1)
18884C WRITE(LOUT,1002) KF,IDTMP
18885C1002 FORMAT(1X,'FICONF: residual nucleus ',I2,
18886C & ' containing meson ',I4,', status set to 1')
18887 ISTHKK(I) = 1
18888 IDTMP = IDPAR(KF)
18889 IDXTMP = IDXPAR(KF)
18890 NTOT(KF) = NTOT(KF)-1
18891 ENDIF
18892 ENDIF
18893 IDPAR(KF) = IDTMP
18894 IDXPAR(KF) = IDXTMP
18895 ENDIF
18896 3 CONTINUE
18897
18898* reject elastic events (def: one final state particle = projectile)
18899 IF ((IP.EQ.1).AND.(NFSP.EQ.1).AND.(IDFSP.EQ.IJPROJ)) THEN
18900 IREXCI(3) = IREXCI(3)+1
18901 GOTO 9999
18902C RETURN
18903 ENDIF
18904
18905* check if one nucleus disappeared..
18906C IF ((IP.GT.1).AND.(NTOT(1).EQ.0).AND.(NTOT(2).NE.0)) THEN
18907C DO 5 K=1,4
18908C PRCLTA(K) = PRCLTA(K)+PRCLPR(K)
18909C PRCLPR(K) = ZERO
18910C 5 CONTINUE
18911C ELSEIF ((IT.GT.1).AND.(NTOT(2).EQ.0).AND.(NTOT(1).NE.0)) THEN
18912C DO 6 K=1,4
18913C PRCLPR(K) = PRCLPR(K)+PRCLTA(K)
18914C PRCLTA(K) = ZERO
18915C 6 CONTINUE
18916C ENDIF
18917
18918 ICOR = 0
18919 INORCL = 0
18920 DO 7 I=1,2
18921 DO 8 K=1,4
18922* get the average of the nucleon positions
18923 VRCL(I,K) = VRCL(I,K)/MAX(NTOT(I),1)
18924 WRCL(I,K) = WRCL(I,K)/MAX(NTOT(I),1)
18925 IF (I.EQ.1) PRCL(1,K) = PRCLPR(K)
18926 IF (I.EQ.2) PRCL(2,K) = PRCLTA(K)
18927 8 CONTINUE
18928* mass number and charge of residual nuclei
18929 AIF(I) = DBLE(NTOT(I))
18930 AIZF(I) = DBLE(NPRO(I)+NHPOS(I))
18931 IF (NTOT(I).GT.1) THEN
18932* masses of residual nuclei in ground state
18933 AMRCL0(I) = AIF(I)*AMUAMU+1.0D-3*DT_ENERGY(AIF(I),AIZF(I))
18934* masses of residual nuclei
18935 PTORCL = SQRT(PRCL(I,1)**2+PRCL(I,2)**2+PRCL(I,3)**2)
18936 AMRCL(I) = (PRCL(I,4)-PTORCL)*(PRCL(I,4)+PTORCL)
18937 IF (AMRCL(I).GT.ZERO) AMRCL(I) = SQRT(AMRCL(I))
18938*
18939* M_res^2 < 0 : configuration not allowed
18940*
18941* a) re-calculate E_exc with scaled nuclear potential
18942* (conditional jump to label 9998)
18943* b) or reject event if N_loop(max) is exceeded
18944* (conditional jump to label 9999)
18945*
18946 IF (AMRCL(I).LE.ZERO) THEN
18947 IF (IOULEV(3).GT.0)
18948 & WRITE(LOUT,1000) I,PRCL(I,1),PRCL(I,2),PRCL(I,3),
18949 & PRCL(I,4),NTOT
18950 1000 FORMAT(1X,'warning! negative excitation energy',/,
18951 & I4,4E15.4,2I4)
18952 AMRCL(I) = ZERO
18953 EEXC(I) = ZERO
18954 IF (NLOOP.LE.500) THEN
18955 GOTO 9998
18956 ELSE
18957 IREXCI(2) = IREXCI(2)+1
18958 GOTO 9999
18959 ENDIF
18960*
18961* 0 < M_res < M_res0 : mass below ground-state mass
18962*
18963* a) we had residual nuclei with mass N_tot and reasonable E_exc
18964* before- assign average E_exc of those configurations to this
18965* one ( Nexc(i,N_tot) > 0 )
18966* b) or (and this applies always if run in transport codes) go up
18967* one mass number and
18968* i) if mass now larger than proj/targ mass or if run in
18969* transport codes assign average E_exc per wounded nucleon
18970* x number of wounded nucleons (Inuc-Ntot)
18971* ii) or assign average E_exc of those configurations to this
18972* one ( Nexc(i,m) > 0 )
18973*
18974 ELSEIF ((AMRCL(I).GT.ZERO).AND.(AMRCL(I).LT.AMRCL0(I)))
18975 & THEN
18976 M = MIN(NTOT(I),260)
18977 IF (NEXC(I,M).GT.0) THEN
18978 AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
18979 ELSE
18980 70 CONTINUE
18981 M = M+1
18982**sr corrected 27.12.06
18983* IF (M.GE.INUC(I)) THEN
18984* AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I))
18985 IF ((M.GE.INUC(I)).OR.(ICASCA.GT.0)) THEN
18986 IF ( INUC (I) .GT. NTOT (I) ) THEN
18987 AMRCL(I) = AMRCL0(I)
18988 & + EXPNUC(I)*DBLE(MAX(INUC(I)-NTOT(I),0))
18989 ELSE
18990 AMRCL(I) = AMRCL0(I) + 0.5D+00 * EXPNUC(I)
18991 END IF
18992**
18993 ELSE
18994 IF (NEXC(I,M).GT.0) THEN
18995 AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
18996 ELSE
18997 GOTO 70
18998 ENDIF
18999 ENDIF
19000 ENDIF
19001 EEXC(I) = AMRCL(I)-AMRCL0(I)
19002 ICOR = ICOR+I
19003*
19004* M_res > 2.5 x M_res0 : unreasonably(?) high E_exc
19005*
19006* a) re-calculate E_exc with scaled nuclear potential
19007* (conditional jump to label 9998)
19008* b) or reject event if N_loop(max) is exceeded
19009* (conditional jump to label 9999)
19010*
19011*
19012 ELSEIF (AMRCL(I).GE.2.5D0*AMRCL0(I)) THEN
19013 IF (IOULEV(3).GT.0)
19014 & WRITE(LOUT,1004) I,AMRCL(I),AMRCL0(I),NTOT,NEVHKK
19015 1004 FORMAT(1X,'warning! too high excitation energy',/,
19016 & I4,1P,2E15.4,3I5)
19017 AMRCL(I) = ZERO
19018 EEXC(I) = ZERO
19019 IF (NLOOP.LE.500) THEN
19020 GOTO 9998
19021 ELSE
19022 IREXCI(2) = IREXCI(2)+1
19023 GOTO 9999
19024 ENDIF
19025*
19026* Otherwise (reasonable E_exc) :
19027* E_exc = M_res - M_res0
19028* in addition: calculate and save E_exc per wounded nucleon as
19029* well as E_exc in <E_exc> counter
19030*
19031 ELSE
19032* excitation energies of residual nuclei
19033 EEXC(I) = AMRCL(I)-AMRCL0(I)
19034**sr 27.12.06 new excitation energy correction by A.F.
19035*
19036* all parts with Ilcopt<3 commented since not used
19037*
19038* still to be done/decided:
19039* Increase Icor and put back both residual nuclei on mass shell
19040* with the exciting correction further below.
19041* For the moment the modification in the excitation energy is simply
19042* corrected by scaling the energy of the residual nucleus.
19043*
19044 LLCPOT = .TRUE.
19045 ILCOPT = 3
19046 IF ( LLCPOT ) THEN
19047 NNCHIT = MAX ( INUC (I) - NTOT (I), 0 )
19048 IF ( ILCOPT .LE. 2 ) THEN
19049C* Patch for Fermi momentum reduction correlated with impact parameter:
19050C FRMRDC = MIN ( (PFRMAV(INUC(I))/APFRMX)**3, ONE )
19051C DLKPRH = 0.1D+00 + 0.5D+00 / SQRT(DBLE(INUC(I)))
19052C AKPRHO = ONE - DLKPRH
19053C* f x K rho_cen + (1-f) x 0.5 x K rho_cen = frmrdc x rho_cen
19054C FRCFLL = MAX ( 2.D+00 * FRMRDC / AKPRHO - ONE,
19055C & 0.05D+00 )
19056C* REDORI = 0.75D+00
19057C* REDORI = ONE
19058C REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
19059 ELSE
19060 DLKPRH = ZERO
19061 RDCORE = 1.14D+00 * DBLE(INUC(I))**(ONE/3.D+00)
19062* Take out roughly one/half of the skin:
19063 RDCORE = RDCORE - 0.5D+00
19064 FRCFLL = RDCORE**3
19065 PRSKIN = (RDCORE+2.4D+00)**3 - FRCFLL
19066 PRSKIN = 0.5D+00 * PRSKIN / ( PRSKIN + FRCFLL )
19067 FRCFLL = ONE - PRSKIN
19068 FRMRDC = FRCFLL + 0.5D+00 * PRSKIN
19069 REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
19070 END IF
19071 IF ( NNCHIT .GT. 0 ) THEN
19072C IF ( ILCOPT .EQ. 1 ) THEN
19073C SKINRH = ONE - FRCFLL / (DBLE(INUC(I))-ONE)
19074C DO 1220 NCH = 1, 10
19075C ETAETA = ( ONE - SKINRH**INUC(I)
19076C & - DBLE(INUC(I))* ( ONE - FRCFLL )
19077C & * ( ONE - SKINRH ) )
19078C & / ( SKINRH**INUC(I) - DBLE (INUC(I))
19079C & * ( ONE - FRCFLL) * SKINRH )
19080C SKINRH = SKINRH * ( ONE + ETAETA )
19081C 1220 CONTINUE
19082C PRSKIN = SKINRH**(NNCHIT-1)
19083C ELSE IF ( ILCOPT .EQ. 2 ) THEN
19084C PRSKIN = ONE - FRCFLL
19085C END IF
19086 REDCTN = ZERO
19087 DO 1230 NCH = 1, NNCHIT
19088 IF (DT_RNDM(PRFRMI) .LT. PRSKIN) THEN
19089 PRFRMI = (( ONE - 2.D+00 * DLKPRH )
19090 & * DT_RNDM(PRFRMI))**0.333333333333D+00
19091 ELSE
19092 PRFRMI = ( ONE - 2.D+00 * DLKPRH
19093 & * DT_RNDM(PRFRMI))**0.333333333333D+00
19094 END IF
19095 REDCTN = REDCTN + PRFRMI**2
19096 1230 CONTINUE
19097 REDCTN = REDCTN / DBLE (NNCHIT)
19098 ELSE
19099 REDCTN = 0.5D+00
19100 END IF
19101 EEXC (I) = EEXC (I) * REDCTN / REDORI
19102 AMRCL (I) = AMRCL0 (I) + EEXC (I)
19103 PRCL(I,4) = SQRT ( PTORCL**2 + AMRCL(I)**2 )
19104 END IF
19105**
19106 IF (ICASCA.EQ.0) THEN
19107 EXPNUC(I) = EEXC(I)/MAX(1,INUC(I)-NTOT(I))
19108 M = MIN(NTOT(I),260)
19109 EXC(I,M) = EXC(I,M)+EEXC(I)
19110 NEXC(I,M) = NEXC(I,M)+1
19111 ENDIF
19112 ENDIF
19113 ELSEIF (NTOT(I).EQ.1) THEN
19114 WRITE(LOUT,1003) I
19115 1003 FORMAT(1X,'FICONF: warning! NTOT(I)=1? (I=',I3,')')
19116 GOTO 9999
19117 ELSE
19118 AMRCL0(I) = ZERO
19119 AMRCL(I) = ZERO
19120 EEXC(I) = ZERO
19121 INORCL = INORCL+I
19122 ENDIF
19123 7 CONTINUE
19124
19125 PRCLPR(5) = AMRCL(1)
19126 PRCLTA(5) = AMRCL(2)
19127
19128 IF (ICOR.GT.0) THEN
19129 IF (INORCL.EQ.0) THEN
19130* one or both residual nuclei consist of one nucleon only, transform
19131* this nucleon on mass shell
19132 DO 9 K=1,4
19133 P1IN(K) = PRCL(1,K)
19134 P2IN(K) = PRCL(2,K)
19135 9 CONTINUE
19136 XM1 = AMRCL(1)
19137 XM2 = AMRCL(2)
19138 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
19139 IF (IREJ1.GT.0) THEN
19140 WRITE(LOUT,*) 'ficonf-mashel rejection'
19141 GOTO 9999
19142 ENDIF
19143 DO 10 K=1,4
19144 PRCL(1,K) = P1OUT(K)
19145 PRCL(2,K) = P2OUT(K)
19146 PRCLPR(K) = P1OUT(K)
19147 PRCLTA(K) = P2OUT(K)
19148 10 CONTINUE
19149 PRCLPR(5) = AMRCL(1)
19150 PRCLTA(5) = AMRCL(2)
19151 ELSE
19152 IF (IOULEV(3).GT.0)
19153 & WRITE(LOUT,1001) NEVHKK,INT(AIF(1)),INT(AIZF(1)),
19154 & INT(AIF(2)),INT(AIZF(2)),AMRCL0(1),
19155 & AMRCL(1),AMRCL(1)-AMRCL0(1),AMRCL0(2),
19156 & AMRCL(2),AMRCL(2)-AMRCL0(2)
19157 1001 FORMAT(1X,'FICONF: warning! no residual nucleus for',
19158 & ' correction',/,11X,'at event',I8,
19159 & ', nucleon config. 1:',2I4,' 2:',2I4,
19160 & 2(/,11X,3E12.3))
19161 IF (NLOOP.LE.500) THEN
19162 GOTO 9998
19163 ELSE
19164 IREXCI(1) = IREXCI(1)+1
19165 ENDIF
19166 ENDIF
19167 ENDIF
19168
19169* update counter
19170C IF (NRESEV(1).NE.NEVHKK) THEN
19171C NRESEV(1) = NEVHKK
19172C NRESEV(2) = NRESEV(2)+1
19173C ENDIF
19174 NRESEV(2) = NRESEV(2)+1
19175 DO 15 I=1,2
19176 EXCDPM(I) = EXCDPM(I)+EEXC(I)
19177 EXCDPM(I+2) = EXCDPM(I+2)+(EEXC(I)/MAX(NTOT(I),1))
19178 NRESTO(I) = NRESTO(I)+NTOT(I)
19179 NRESPR(I) = NRESPR(I)+NPRO(I)
19180 NRESNU(I) = NRESNU(I)+NN(I)
19181 NRESBA(I) = NRESBA(I)+NH(I)
19182 NRESPB(I) = NRESPB(I)+NHPOS(I)
19183 NRESCH(I) = NRESCH(I)+NQ(I)
19184 15 CONTINUE
19185
19186* evaporation
19187 IF (LEVPRT) THEN
19188 DO 13 I=1,2
19189* initialize evaporation counter
19190 EEXCFI(I) = ZERO
19191 IF ((INUC(I).GT.1).AND.(AIF(I).GT.ONE).AND.
19192 & (EEXC(I).GT.ZERO)) THEN
19193* put residual nuclei into DTEVT1
19194 IDRCL = 80000
19195 JMASS = INT( AIF(I))
19196 JCHAR = INT(AIZF(I))
19197* the following patch is required to transmit the correct excitation
19198* energy to Eventd
19199 IF (ITRSPT.EQ.1) THEN
19200 IF ((ABS(AMRCL(I)-AMRCL0(I)-EEXC(I)).GT.1.D-04).AND.
19201 & (IOULEV(3).GT.0))
19202 & WRITE(LOUT,*)
19203 & ' DT_FICONF:AMRCL(I),AMRCL0(I),EEXC(I)',
19204 & AMRCL(I),AMRCL0(I),EEXC(I)
19205 PRCL0 = PRCL(I,4)
19206 PRCL(I,4) =SQRT(AMRCL(I)**2+PRCL(I,1)**2+PRCL(I,2)**2
19207 & +PRCL(I,3)**2)
19208 IF (ABS(PRCL0-PRCL(I,4)).GT.0.1D0) THEN
19209 WRITE(LOUT,*)
19210 & ' PRCL(I,4) recalculated :',PRCL0,PRCL(I,4)
19211 ENDIF
19212 ENDIF
19213 CALL DT_EVTPUT(1000,IDRCL,MO1(I),MO2(I),PRCL(I,1),
19214 & PRCL(I,2),PRCL(I,3),PRCL(I,4),JMASS,JCHAR,0)
19215**sr 22.6.97
19216 NOBAM(NHKK) = I
19217**
19218 DO 14 J=1,4
19219 VHKK(J,NHKK) = VRCL(I,J)
19220 WHKK(J,NHKK) = WRCL(I,J)
19221 14 CONTINUE
19222* interface to evaporation module - fill final residual nucleus into
19223* common FKRESN
19224* fill resnuc only if code is not used as event generator in Fluka
19225 IF (ITRSPT.NE.1) THEN
19226 PXRES = PRCL(I,1)
19227 PYRES = PRCL(I,2)
19228 PZRES = PRCL(I,3)
19229 IBRES = NPRO(I)+NN(I)+NH(I)
19230 ICRES = NPRO(I)+NHPOS(I)
19231 ANOW = DBLE(IBRES)
19232 ZNOW = DBLE(ICRES)
19233 PTRES = SQRT(PXRES**2+PYRES**2+PZRES**2)
19234* ground state mass of the residual nucleus (should be equal to AM0T)
19235 AMMRES = AMRCL0(I)
19236 AMNRES = AMMRES-ZNOW*AMELEC+ELBNDE(ICRES)
19237* common FKFINU
19238 TV = ZERO
19239* kinetic energy of residual nucleus
19240 TVRECL = PRCL(I,4)-AMRCL(I)
19241* excitation energy of residual nucleus
19242 TVCMS = EEXC(I)
19243 PTOLD = PTRES
19244 PTRES = SQRT(ABS(TVRECL*(TVRECL+
19245 & 2.0D0*(AMMRES+TVCMS))))
19246 IF (PTOLD.LT.ANGLGB) THEN
19247 CALL DT_RACO(PXRES,PYRES,PZRES)
19248 PTOLD = ONE
19249 ENDIF
19250 PXRES = PXRES*PTRES/PTOLD
19251 PYRES = PYRES*PTRES/PTOLD
19252 PZRES = PZRES*PTRES/PTOLD
19253* zero counter of secondaries from evaporation
19254 NP = 0
19255* evaporation
19256 WE = ONE
19257 CALL DT_EVEVAP(WE)
19258* put evaporated particles and residual nuclei to DTEVT1
19259 MO = NHKK
19260 CALL DT_EVA2HE(MO,EXCITF,I,IREJ1)
19261 ENDIF
19262 EEXCFI(I) = EXCITF
19263 EXCEVA(I) = EXCEVA(I)+EXCITF
19264 ENDIF
19265 13 CONTINUE
19266 ENDIF
19267
19268 RETURN
19269
19270C9998 IREXCI(1) = IREXCI(1)+1
19271 9998 IREJ = IREJ+1
19272 9999 CONTINUE
19273 LRCLPR = .TRUE.
19274 LRCLTA = .TRUE.
19275 IREJ = IREJ+1
19276 RETURN
19277 END
19278
19279*$ CREATE DT_EVA2HE.FOR
19280*COPY DT_EVA2HE
19281* *
19282*====eva2he============================================================*
19283* *
19284 SUBROUTINE DT_EVA2HE(MO,EEXCF,IRCL,IREJ)
19285
19286************************************************************************
19287* Interface between common's of evaporation module (FKFINU,FKFHVY) *
19288* and DTEVT1. *
19289* MO DTEVT1-index of "mother" (residual) nucleus before evap. *
19290* EEXCF exitation energy of residual nucleus after evaporation *
19291* IRCL = 1 projectile residual nucleus *
19292* = 2 target residual nucleus *
19293* This version dated 19.04.95 is written by S. Roesler. *
19294* *
19295* Last change 27.12.2006 by S. Roesler. *
19296************************************************************************
19297
19298 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19299 SAVE
19300 PARAMETER ( LINP = 10 ,
19301 & LOUT = 6 ,
19302 & LDAT = 9 )
19303 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3)
19304
19305* event history
19306 PARAMETER (NMXHKK=200000)
19307 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
19308 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
19309 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
19310* Note: DTEVT2 - special use for heavy fragments !
19311* (IDRES(I) = mass number, IDXRES(I) = charge)
19312* extended event history
19313 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
19314 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
19315 & IHIST(2,NMXHKK)
19316* particle properties (BAMJET index convention)
19317 CHARACTER*8 ANAME
19318 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19319 & IICH(210),IIBAR(210),K1(210),K2(210)
19320* flags for input different options
19321 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
19322 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
19323 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
19324* statistics: residual nuclei
19325 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
19326 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
19327 & NINCST(2,4),NINCEV(2),
19328 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
19329 & NRESPB(2),NRESCH(2),NRESEV(4),
19330 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
19331 & NEVAFI(2,2)
19332* treatment of residual nuclei: properties of residual nuclei
19333 COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
19334 & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
19335 & NTOTFI(2),NPROFI(2)
19336* (original name: FINUC)
19337 PARAMETER (MXP=999)
19338 COMMON /FKFINU/ CXR (MXP), CYR (MXP), CZR (MXP),
19339 & CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP),
19340 & TKI (MXP), PLR (MXP), WEI (MXP),
19341 & TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP,
19342 & KPART (MXP)
19343* (original name: FHEAVY,FHEAVC)
19344 PARAMETER ( MXHEAV = 100 )
19345 CHARACTER*8 ANHEAV
19346 COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV),
19347 & CZHEAV (MXHEAV), TKHEAV (MXHEAV),
19348 & PHEAVY (MXHEAV), WHEAVY (MXHEAV),
19349 & AMHEAV ( 12 ) , AMNHEA ( 12 ) ,
19350 & KHEAVY (MXHEAV), ICHEAV ( 12 ) ,
19351 & IBHEAV ( 12 ) , NPHEAV
19352 COMMON /FKFHVC/ ANHEAV ( 12 )
19353* (original name: RESNUC)
19354 LOGICAL LRNFSS, LFRAGM
19355 COMMON /FKRESN/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
19356 & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
19357 & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES,
19358 & PYRES, PZRES, PTRES2, KTARP, KTARN, IGREYP,
19359 & IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,
19360 & ICRES, IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU,
19361 & IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG,
19362 & IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS,
19363 & LFRAGM
19364
19365 DIMENSION IPTOKP(39)
19366 DATA IPTOKP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
19367 & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 99,
19368 & 100, 101, 97, 102, 98, 103, 109, 115 /
19369
19370 IREJ = 0
19371
19372* skip if evaporation package is not included
19373 IF (.NOT.LEVAPO) RETURN
19374
19375* update counter
19376 IF (NRESEV(3).NE.NEVHKK) THEN
19377 NRESEV(3) = NEVHKK
19378 NRESEV(4) = NRESEV(4)+1
19379 ENDIF
19380
19381 IF (LEMCCK)
19382 & CALL DT_EVTEMC(PHKK(1,MO),PHKK(2,MO),PHKK(3,MO),PHKK(4,MO),1,
19383 & IDUM,IDUM)
19384* mass number/charge of residual nucleus before evaporation
19385 IBTOT = IDRES(MO)
19386 IZTOT = IDXRES(MO)
19387
19388* protons/neutrons/gammas
19389 DO 1 I=1,NP
19390 PX = CXR(I)*PLR(I)
19391 PY = CYR(I)*PLR(I)
19392 PZ = CZR(I)*PLR(I)
19393 ID = IPTOKP(KPART(I))
19394 IDPDG = IDT_IPDGHA(ID)
19395 AM = ((PLR(I)+TKI(I))*(PLR(I)-TKI(I)))/
19396 & (2.0D0*MAX(TKI(I),TINY10))
19397 IF (ABS(AM-AAM(ID)).GT.TINY3) THEN
19398 WRITE(LOUT,1000) ID,AM,AAM(ID)
19399 1000 FORMAT(1X,'EVA2HE: inconsistent mass of evap. ',
19400 & 'particle',I3,2E10.3)
19401 ENDIF
19402 PE = TKI(I)+AM
19403 CALL DT_EVTPUT(-1,IDPDG,MO,0,PX,PY,PZ,PE,0,0,0)
19404 NOBAM(NHKK) = IRCL
19405 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
19406 IBTOT = IBTOT-IIBAR(ID)
19407 IZTOT = IZTOT-IICH(ID)
19408 1 CONTINUE
19409
19410* heavy fragments
19411 DO 2 I=1,NPHEAV
19412 PX = CXHEAV(I)*PHEAVY(I)
19413 PY = CYHEAV(I)*PHEAVY(I)
19414 PZ = CZHEAV(I)*PHEAVY(I)
19415 IDHEAV = 80000
19416 AM = ((PHEAVY(I)+TKHEAV(I))*(PHEAVY(I)-TKHEAV(I)))/
19417 & (2.0D0*MAX(TKHEAV(I),TINY10))
19418 PE = TKHEAV(I)+AM
19419 CALL DT_EVTPUT(-1,IDHEAV,MO,0,PX,PY,PZ,PE,
19420 & IBHEAV(KHEAVY(I)),ICHEAV(KHEAVY(I)),0)
19421 NOBAM(NHKK) = IRCL
19422 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
19423 IBTOT = IBTOT-IBHEAV(KHEAVY(I))
19424 IZTOT = IZTOT-ICHEAV(KHEAVY(I))
19425 2 CONTINUE
19426
19427 IF (IBRES.GT.0) THEN
19428* residual nucleus after evaporation
19429 IDNUC = 80000
19430 CALL DT_EVTPUT(1001,IDNUC,MO,0,PXRES,PYRES,PZRES,ERES,
19431 & IBRES,ICRES,0)
19432 NOBAM(NHKK) = IRCL
19433 ENDIF
19434 EEXCF = TVCMS
19435 NTOTFI(IRCL) = IBRES
19436 NPROFI(IRCL) = ICRES
19437 IF (LEMCCK) CALL DT_EVTEMC(-PXRES,-PYRES,-PZRES,-ERES,2,IDUM,IDUM)
19438 IBTOT = IBTOT-IBRES
19439 IZTOT = IZTOT-ICRES
19440
19441* count events with fission
19442 NEVAFI(1,IRCL) = NEVAFI(1,IRCL)+1
19443 IF (LRNFSS) NEVAFI(2,IRCL) = NEVAFI(2,IRCL)+1
19444
19445* energy-momentum conservation check
19446 IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,40,IREJ)
19447C IF (IREJ.GT.0) THEN
19448C CALL DT_EVTOUT(4)
19449C WRITE(*,*) EEXC(2),EEXCFI(2),NP,NPHEAV
19450C ENDIF
19451* baryon-number/charge conservation check
19452 IF (IBTOT+IZTOT.NE.0) THEN
19453 WRITE(LOUT,1001) NEVHKK,IBTOT,IZTOT
19454 1001 FORMAT(1X,'EVA2HE: baryon-number/charge conservation ',
19455 & 'failure at event ',I8,' : IBTOT,IZTOT = ',2I3)
19456 ENDIF
19457
19458 RETURN
19459 END
19460
19461*$ CREATE DT_EBIND.FOR
19462*COPY DT_EBIND
19463*
19464*===ebind==============================================================*
19465*
19466 DOUBLE PRECISION FUNCTION DT_EBIND(IA,IZ)
19467
19468************************************************************************
19469* Binding energy for nuclei. *
19470* (Shirokov & Yudin, Yad. Fizika, Nauka, Moskva 1972) *
19471* IA mass number *
19472* IZ atomic number *
19473* This version dated 5.5.95 is updated by S. Roesler. *
19474************************************************************************
19475
19476 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19477 SAVE
19478 PARAMETER ( LINP = 10 ,
19479 & LOUT = 6 ,
19480 & LDAT = 9 )
19481 PARAMETER (ZERO=0.0D0)
19482
19483 DATA A1, A2, A3, A4, A5
19484 & / 0.01575D0, 0.0178D0, 0.000710D0, 0.0237D0, 0.034D0/
19485
19486 IF ((IA.LE.1).OR.(IZ.EQ.0)) THEN
19487 WRITE(LOUT,'(1X,A,2I5)') 'DT_EBIND IA,IZ set EBIND=0. ',IA,IZ
19488 DT_EBIND = ZERO
19489 RETURN
19490 ENDIF
19491 AA = IA
19492 DT_EBIND = A1*AA - A2*AA**0.666667D0-A3*IZ*IZ*AA**(-0.333333D0)
19493 & -A4*(IA-2*IZ)**2/AA
19494 IF (MOD(IA,2).EQ.1) THEN
19495 IA5 = 0
19496 ELSEIF (MOD(IZ,2).EQ.1) THEN
19497 IA5 = 1
19498 ELSE
19499 IA5 = -1
19500 ENDIF
19501 DT_EBIND = DT_EBIND - IA5*A5*AA**(-0.75D0)
19502
19503 RETURN
19504 END
19505
19506**sr 30.6. routine replaced completely
19507*$ CREATE DT_ENERGY.FOR
19508*COPY DT_ENERGY
19509* *
19510*=== energy ===========================================================*
19511* *
19512 DOUBLE PRECISION FUNCTION DT_ENERGY( A, Z )
19513
19514C INCLUDE '(DBLPRC)'
19515* DBLPRC.ADD
19516 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19517 SAVE
19518* (original name: GLOBAL)
19519 PARAMETER ( KALGNM = 2 )
19520 PARAMETER ( ANGLGB = 5.0D-16 )
19521 PARAMETER ( ANGLSQ = 2.5D-31 )
19522 PARAMETER ( AXCSSV = 0.2D+16 )
19523 PARAMETER ( ANDRFL = 1.0D-38 )
19524 PARAMETER ( AVRFLW = 1.0D+38 )
19525 PARAMETER ( AINFNT = 1.0D+30 )
19526 PARAMETER ( AZRZRZ = 1.0D-30 )
19527 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
19528 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
19529 PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
19530 PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
19531 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
19532 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
19533 PARAMETER ( CSNNRM = 2.0D-15 )
19534 PARAMETER ( DMXTRN = 1.0D+08 )
19535 PARAMETER ( ZERZER = 0.D+00 )
19536 PARAMETER ( ONEONE = 1.D+00 )
19537 PARAMETER ( TWOTWO = 2.D+00 )
19538 PARAMETER ( THRTHR = 3.D+00 )
19539 PARAMETER ( FOUFOU = 4.D+00 )
19540 PARAMETER ( FIVFIV = 5.D+00 )
19541 PARAMETER ( SIXSIX = 6.D+00 )
19542 PARAMETER ( SEVSEV = 7.D+00 )
19543 PARAMETER ( EIGEIG = 8.D+00 )
19544 PARAMETER ( ANINEN = 9.D+00 )
19545 PARAMETER ( TENTEN = 10.D+00 )
19546 PARAMETER ( HLFHLF = 0.5D+00 )
19547 PARAMETER ( ONETHI = ONEONE / THRTHR )
19548 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
19549 PARAMETER ( ONEFOU = ONEONE / FOUFOU )
19550 PARAMETER ( THRTWO = THRTHR / TWOTWO )
19551 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
19552 PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
19553 PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
19554 PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
19555 PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
19556 PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
19557 PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
19558 PARAMETER ( EULERO = 0.577215664901532860606512 D+00 )
19559 PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 )
19560 PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 )
19561 PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 )
19562 PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
19563 PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
19564 PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
19565 PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
19566 PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
19567 PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
19568 PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
19569 PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
19570 PARAMETER ( CLIGHT = 2.99792458 D+10 )
19571 PARAMETER ( AVOGAD = 6.0221367 D+23 )
19572 PARAMETER ( BOLTZM = 1.380658 D-23 )
19573 PARAMETER ( AMELGR = 9.1093897 D-28 )
19574 PARAMETER ( PLCKBR = 1.05457266 D-27 )
19575 PARAMETER ( ELCCGS = 4.8032068 D-10 )
19576 PARAMETER ( ELCMKS = 1.60217733 D-19 )
19577 PARAMETER ( AMUGRM = 1.6605402 D-24 )
19578 PARAMETER ( AMMUMU = 0.113428913 D+00 )
19579 PARAMETER ( AMPRMU = 1.007276470 D+00 )
19580 PARAMETER ( AMNEMU = 1.008664904 D+00 )
19581 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
19582 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
19583 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
19584 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
19585 PARAMETER ( PLABRC = 0.197327053 D+00 )
19586 PARAMETER ( AMELCT = 0.51099906 D-03 )
19587 PARAMETER ( AMUGEV = 0.93149432 D+00 )
19588 PARAMETER ( AMMUON = 0.105658389 D+00 )
19589 PARAMETER ( AMPRTN = 0.93827231 D+00 )
19590 PARAMETER ( AMNTRN = 0.93956563 D+00 )
19591 PARAMETER ( AMDEUT = 1.87561339 D+00 )
19592 PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
19593 & * 1.D-09 )
19594 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
19595 PARAMETER ( BLTZMN = 8.617385 D-14 )
19596 PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
19597 PARAMETER ( GFOHB3 = 1.16639 D-05 )
19598 PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
19599 PARAMETER ( SIN2TW = 0.2319 D+00 )
19600 PARAMETER ( GEVMEV = 1.0 D+03 )
19601 PARAMETER ( EMVGEV = 1.0 D-03 )
19602 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
19603 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
19604 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
19605 LOGICAL LGBIAS, LGBANA
19606 COMMON /FKGLOB/ LGBIAS, LGBANA
19607C INCLUDE '(DIMPAR)'
19608* DIMPAR.ADD
19609 PARAMETER ( MXXRGN = 5000 )
19610 PARAMETER ( MXXMDF = 82 )
19611 PARAMETER ( MXXMDE = 54 )
19612 PARAMETER ( MFSTCK = 1000 )
19613 PARAMETER ( MESTCK = 100 )
19614 PARAMETER ( NALLWP = 39 )
19615 PARAMETER ( NELEMX = 80 )
19616 PARAMETER ( MPDPDX = 8 )
19617 PARAMETER ( ICOMAX = 180 )
19618 PARAMETER ( NSTBIS = 304 )
19619 PARAMETER ( IDMAXP = 220 )
19620 PARAMETER ( IDMXDC = 640 )
19621 PARAMETER ( MKBMX1 = 1 )
19622 PARAMETER ( MKBMX2 = 1 )
19623C INCLUDE '(IOUNIT)'
19624* IOUNIT.ADD
19625 PARAMETER ( LUNIN = 5 )
19626 PARAMETER ( LUNOUT = 6 )
19627**sr 19.5. set error output-unit from 15 to 6
19628 PARAMETER ( LUNERR = 6 )
19629 PARAMETER ( LUNBER = 14 )
19630 PARAMETER ( LUNECH = 8 )
19631 PARAMETER ( LUNFLU = 13 )
19632 PARAMETER ( LUNGEO = 16 )
19633 PARAMETER ( LUNPMF = 12 )
19634 PARAMETER ( LUNRAN = 2 )
19635 PARAMETER ( LUNXSC = 9 )
19636 PARAMETER ( LUNDET = 17 )
19637 PARAMETER ( LUNRAY = 10 )
19638 PARAMETER ( LUNRDB = 1 )
19639 PARAMETER ( LUNPGO = 7 )
19640 PARAMETER ( LUNPGS = 4 )
19641 PARAMETER ( LUNSCR = 3 )
19642*
19643*----------------------------------------------------------------------*
19644* *
19645* Revised version of the original routine from EVAP: *
19646* *
19647* Created on 15 may 1990 by Alfredo Ferrari & Paola Sala *
19648* Infn - Milan *
19649* *
19650* Last change on 19-sep-95 by Alfredo Ferrari *
19651* *
19652* !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
19653* !!! It is supposed to be used with the updated atomic !!! *
19654* !!! mass data file !!! *
19655* !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
19656* *
19657*----------------------------------------------------------------------*
19658*
19659* Mass number below which "unknown" isotopes out of the Z-interval
19660* reported in the mass tabulations are completely unstable and made
19661* up by Z proton masses + N neutron masses:
19662 PARAMETER ( KAFREE = 4 )
19663* Mass number below which "unknown" isotopes out of the Z-interval
19664* reported in the mass tabulations are supposed to be particle unstable
19665 PARAMETER ( KAPUNS = 12 )
19666* Minimum energy required for particle unstable isotopes
19667 PARAMETER ( DEPUNS = 0.5D+00 )
19668*
19669* (original name: EVA0)
19670 COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
19671 * FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
19672 * CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
19673 * T (4,7), RMASS (297), ALPH (297), BET (297),
19674 * APRIME (250), IA (6), IZ (6)
19675* (original name: ISOTOP)
19676 PARAMETER ( NAMSMX = 270 )
19677 PARAMETER ( NZGVAX = 15 )
19678 PARAMETER ( NISMMX = 574 )
19679 COMMON /FKISOT/ WAPS (NAMSMX,NZGVAX), T12NUC (NAMSMX,NZGVAX),
19680 & WAPISM (NISMMX), T12ISM (NISMMX),
19681 & ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260),
19682 & AMSSST (100) , ISOMNM (NSTBIS), ISONDX (2,100),
19683 & JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX),
19684 & INWAPS (NAMSMX), JSPISM (NISMMX),
19685 & JPTISM (NISMMX), IZWISM (NISMMX),
19686 & INWISM (0:NAMSMX)
19687*
454792a9 19688CPH SAVE KA0, KZ0, IZ0
9aaba0d6 19689 DATA KA0, KZ0, IZ0 / -1, -1, -1 /
19690*
19691 IFLAG = 1
19692 GO TO 10
19693*======================================================================*
19694* *
19695* Entry ENergy - KNOWn *
19696* *
19697*======================================================================*
19698 ENTRY DT_ENKNOW ( A, Z, IZZ0 )
19699 IZZ0 =-1
19700 IFLAG = 2
19701 10 CONTINUE
19702*
19703 KA0 = NINT ( A )
19704 KZ0 = NINT ( Z )
19705 N = KA0 - KZ0
19706* +-------------------------------------------------------------------*
19707* | Null residual nucleus:
19708 IF ( KA0 .EQ. 0 .AND. KZ0 .LE. 0 ) THEN
19709 IF ( IFLAG .EQ. 1 ) THEN
19710 DT_ENERGY = ZERZER
19711 ELSE
19712 DT_ENKNOW = ZERZER
19713 IZZ0 = -1
19714 END IF
19715 RETURN
19716* |
19717* +-------------------------------------------------------------------*
19718* | Only protons:
19719 ELSE IF ( N .LE. 0 ) THEN
19720 IF ( N .LT. 0 ) THEN
19721 WRITE ( LUNOUT, * )
19722 & ' DPMJET stopped in energy: mass number =< atomic number !!',
19723 & KA0, KZ0
19724 WRITE ( LUNOUT, * )
19725 & ' DPMJET stopped in energy: mass number =< atomic number !!',
19726 & KA0, KZ0
19727 WRITE ( 77, * )
19728 & ' ^^^DPMJET stopped in energy: mass number =< atomic number !!',
19729 & KA0, KZ0
19730 STOP 'DT_ENERGY:KA0-KZ0'
19731 END IF
19732 IZ0 = -1
19733 IF ( IFLAG .EQ. 1 ) THEN
19734 DT_ENERGY = Z * WAPS ( 1, 2 )
19735 ELSE
19736 DT_ENKNOW = Z * WAPS ( 1, 2 )
19737 IZZ0 = -1
19738 END IF
19739 RETURN
19740* |
19741* +-------------------------------------------------------------------*
19742* | Only neutrons:
19743 ELSE IF ( KZ0 .LE. 0 ) THEN
19744 IF ( KZ0 .LT. 0 ) THEN
19745 WRITE ( LUNOUT, * )
19746 & ' DPMJET stopped in energy: negative atomic number !!',KA0,KZ0
19747 WRITE ( LUNOUT, * )
19748 & ' DPMJET stopped in energy: negative atomic number !!',KA0,KZ0
19749 WRITE ( 77, * )
19750 &' ^^^DPMJET stopped in energy: negative atomic number !!',KA0,KZ0
19751 STOP 'DT_ENERGY:KZ0<0'
19752 END IF
19753 IZ0 = -1
19754 IF ( IFLAG .EQ. 1 ) THEN
19755 DT_ENERGY = A * WAPS ( 1, 1 )
19756 ELSE
19757 DT_ENKNOW = A * WAPS ( 1, 1 )
19758 IZZ0 = -1
19759 END IF
19760 RETURN
19761 END IF
19762* |
19763* +-------------------------------------------------------------------*
19764* +-------------------------------------------------------------------*
19765* | No actual nucleus
19766* |
19767* +-------------------------------------------------------------------*
19768* +-------------------------------------------------------------------*
19769* | A larger than maximum allowed:
19770 IF ( KA0 .GT. NAMSMX ) THEN
19771 IZ0 = -1
19772 IF ( IFLAG .EQ. 1 ) THEN
19773 DT_ENERGY = DT_ENRG( A, Z )
19774 ELSE
19775 DT_ENKNOW = DT_ENRG( A, Z )
19776 IZZ0 = -1
19777 END IF
19778 RETURN
19779 END IF
19780* |
19781* +-------------------------------------------------------------------*
19782 IZZ = INWAPS ( KA0 )
19783* +-------------------------------------------------------------------*
19784* | Too much neutron rich with respect to the stability line:
19785 IF ( KZ0 .LT. IZZ ) THEN
19786* | +----------------------------------------------------------------*
19787* | | Up to A=Kafree all "bound" masses are known, set it unbound:
19788 IF ( KA0 .LE. KAFREE ) THEN
19789 DT_ENERGY = AINFNT
19790* | |
19791* | +----------------------------------------------------------------*
19792* | | Up to Kapuns: be sure it is particle unstable
19793 ELSE IF ( KA0 .LE. KAPUNS ) THEN
19794* | | Exp. excess mass for A,IZZ
19795 ENEEXP = WAPS ( KA0, 1 )
19796* | | Cameron excess mass for A, IZZ
19797 ENECA1 = DT_ENRG( A, DBLE (IZZ) )
19798* | | Cameron excess mass for A, Z
19799 DT_ENERGY = DT_ENRG( A, Z )
19800* | | Use just the difference according to Cameron!!!
19801 DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19802 JZZ = INWAPS ( KA0 - 1 )
19803 LZZ = INWAPS ( KA0 - 2 )
19804* | | +-------------------------------------------------------------*
19805* | | | Residual mass for n-decay known:
19806 IF ( KZ0 .GE. JZZ .AND. KZ0 .LE. JZZ + NZGVAX - 1 ) THEN
19807 IZ0 = KZ0 - JZZ + 1
19808 DT_ENERGY = MAX(DT_ENERGY,WAPS (KA0-1,IZ0) + WAPS (1,1)
19809 & + DEPUNS )
19810* | | |
19811* | | +-------------------------------------------------------------*
19812* | | | Residual mass for 2n-decay known:
19813 ELSE IF ( KZ0 .GE. LZZ .AND. KZ0 .LE. LZZ + NZGVAX - 1 )THEN
19814 IZ0 = KZ0 - LZZ + 1
19815 DT_ENERGY = MAX ( DT_ENERGY, WAPS (KA0-2,IZ0) + TWOTWO *
19816 & ( WAPS (1,1) + DEPUNS ) )
19817* | | |
19818* | | +-------------------------------------------------------------*
19819* | | | Set it unbound:
19820 ELSE
19821 DT_ENERGY = AINFNT
19822 END IF
19823* | | |
19824* | | +-------------------------------------------------------------*
19825* | |
19826* | +----------------------------------------------------------------*
19827* | | Proceed as usual:
19828 ELSE
19829* | | Exp. excess mass for A,IZZ
19830 ENEEXP = WAPS ( KA0, 1 )
19831* | | Cameron excess mass for A, IZZ
19832 ENECA1 = DT_ENRG( A, DBLE (IZZ) )
19833* | | Cameron excess mass for A, Z
19834 DT_ENERGY = DT_ENRG( A, Z )
19835* | | Use just the difference according to Cameron!!!
19836 DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19837 END IF
19838* | |
19839* | +----------------------------------------------------------------*
19840* | Be sure not to have a positive energy state:
19841 DT_ENERGY = MIN(DT_ENERGY,(A-Z) * WAPS (1,1) + Z * WAPS (1,2) )
19842 IZ0 = -1
19843 IF ( IFLAG .EQ. 2 ) THEN
19844 DT_ENKNOW = DT_ENERGY
19845 IZZ0 = -1
19846 END IF
19847 RETURN
19848* |
19849* +-------------------------------------------------------------------*
19850* | Too much proton rich with respect to the stability line:
19851 ELSE IF ( KZ0 .GT. IZZ + NZGVAX - 1 ) THEN
19852* | +----------------------------------------------------------------*
19853* | | Up to A=Kafree all "bound" masses are known, set it unbound:
19854 IF ( KA0 .LE. KAFREE ) THEN
19855 DT_ENERGY = AINFNT
19856* | |
19857* | +----------------------------------------------------------------*
19858* | | Up to Kapuns: be sure it is particle unstable
19859 ELSE IF ( KA0 .LE. KAPUNS ) THEN
19860* | | Exp. excess mass for A,IZZ+NZGVAX-1
19861 ENEEXP = WAPS ( KA0, NZGVAX )
19862* | | Cameron excess mass for A, IZZ+NZGVAX-1
19863 ENECA1 = DT_ENRG( A, DBLE (IZZ+NZGVAX-1) )
19864* | | Cameron excess mass for A, Z
19865 DT_ENERGY = DT_ENRG( A, Z )
19866* | | Use just the difference according to Cameron!!!
19867 DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19868 JZZ = INWAPS ( KA0 - 1 )
19869 LZZ = INWAPS ( KA0 - 2 )
19870* | | +-------------------------------------------------------------*
19871* | | | Residual mass for p-decay known:
19872 IF ( KZ0-1 .GE. JZZ .AND. KZ0-1 .LE. JZZ + NZGVAX - 1 ) THEN
19873 IZ0 = KZ0 - 1 - JZZ + 1
19874 DT_ENERGY = MAX (DT_ENERGY, WAPS (KA0-1,IZ0) + WAPS (1,2)
19875 & + DEPUNS )
19876* | | |
19877* | | +-------------------------------------------------------------*
19878* | | | Residual mass for 2p-decay known:
19879 ELSE IF ( KZ0-2 .GE. LZZ .AND. KZ0-2 .LE. LZZ + NZGVAX - 1 )
19880 & THEN
19881 IZ0 = KZ0 - 2 - LZZ + 1
19882 DT_ENERGY = MAX ( DT_ENERGY, WAPS (KA0-2,IZ0) + TWOTWO *
19883 & ( WAPS (1,2) + DEPUNS ) )
19884* | | |
19885* | | +-------------------------------------------------------------*
19886* | | | Set it unbound:
19887 ELSE
19888 DT_ENERGY = AINFNT
19889 END IF
19890* | | |
19891* | | +-------------------------------------------------------------*
19892* | |
19893* | +----------------------------------------------------------------*
19894* | | Proceed as usual:
19895 ELSE
19896* | | Exp. excess mass for A,IZZ+NZGVAX-1
19897 ENEEXP = WAPS ( KA0, NZGVAX )
19898* | | Cameron excess mass for A, IZZ+NZGVAX-1
19899 ENECA1 = DT_ENRG( A, DBLE (IZZ+NZGVAX-1) )
19900* | | Cameron excess mass for A, Z
19901 DT_ENERGY = DT_ENRG( A, Z )
19902* | | Use just the difference according to Cameron!!!
19903 DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19904 END IF
19905* | |
19906* | +----------------------------------------------------------------*
19907* | Be sure not to have a positive energy state:
19908 DT_ENERGY = MIN(DT_ENERGY,(A-Z) * WAPS (1,1) + Z * WAPS (1,2) )
19909 IZ0 = -1
19910 IF ( IFLAG .EQ. 2 ) THEN
19911 DT_ENKNOW = DT_ENERGY
19912 IZZ0 = -1
19913 END IF
19914 RETURN
19915* |
19916* +-------------------------------------------------------------------*
19917* | Known isotope or anyway isotope "inside" the stability zone
19918 ELSE
19919 IZ0 = KZ0 - IZZ + 1
19920 DT_ENERGY = WAPS ( KA0, IZ0 )
19921 IF ( IFLAG .EQ. 2 ) IZZ0 = IZ0
19922* | +----------------------------------------------------------------*
19923* | | Mass not known
19924 IF ( ABS (DT_ENERGY) .LT. ANGLGB .AND. (KA0 .NE. 12 .OR. KZ0
19925 & .NE. 6) ) THEN
19926 IF ( IFLAG .EQ. 2 ) IZZ0 = -1
19927* | | +-------------------------------------------------------------*
19928* | | | Set it unbound:
19929 IF ( KA0 .LE. KAFREE ) THEN
19930 DT_ENERGY = AINFNT
19931* | | |
19932* | | +-------------------------------------------------------------*
19933* | | | Try to get a reasonable excess mass:
19934 ELSE
19935 JZ0 = -100
19936* | | | +----------------------------------------------------------*
19937* | | | | Check the closest one known:
19938 DO 500 JZZ = 1, NZGVAX
19939 IF ( ABS ( WAPS (KA0,JZZ) ) .GT. ANGLGB .AND.
19940 & ABS (JZZ-IZ0) .LT. ABS (JZ0-IZ0) ) JZ0 = JZZ
19941 IF ( ABS (JZ0-IZ0) .EQ. 1 ) GO TO 550
19942 500 CONTINUE
19943* | | | |
19944* | | | +----------------------------------------------------------*
19945 550 CONTINUE
19946* | | | Exp. excess mass for A,IZZ+JZ0-1
19947 ENEEXP = WAPS ( KA0, JZ0 )
19948* | | | Cameron excess mass for A, IZZ+JZ0-1
19949 ENECA1 = DT_ENRG( A, DBLE (IZZ+JZ0-1) )
19950* | | | Cameron excess mass for A, Z
19951 DT_ENERGY = DT_ENRG( A, Z )
19952* | | | Use just the difference according to Cameron!!!
19953 DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19954 IZ0 = -1
19955 END IF
19956* | | |
19957* | | +-------------------------------------------------------------*
19958* | | Be sure not to have a positive energy state:
19959 DT_ENERGY = MIN(DT_ENERGY,(A-Z)*WAPS(1,1)+Z*WAPS (1,2) )
19960 END IF
19961* | |
19962* | +----------------------------------------------------------------*
19963 IF ( IFLAG .EQ. 2 ) DT_ENKNOW = DT_ENERGY
19964 RETURN
19965 END IF
19966* |
19967* +-------------------------------------------------------------------*
19968*=== End of Function Energy ===========================================*
19969* RETURN
19970 END
19971**
19972
19973*$ CREATE DT_ENRG.FOR
19974*COPY DT_ENRG
19975* *
19976*=== enrg =============================================================*
19977* *
19978 DOUBLE PRECISION FUNCTION DT_ENRG(A,Z)
19979
19980 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19981 SAVE
19982
19983 PARAMETER ( ZERZER = 0.D+00 )
19984 PARAMETER ( ONEONE = 1.D+00 )
19985 PARAMETER ( LUNIN = 5 )
19986 PARAMETER ( LUNOUT = 6 )
19987*
19988*----------------------------------------------------------------------*
19989* *
19990* Revised version of the original routine from EVAP: *
19991* *
19992* Created on 15 may 1990 by Alfredo Ferrari & Paola Sala *
19993* Infn - Milan *
19994* *
19995* Last change on 01-oct-94 by Alfredo Ferrari *
19996* *
19997* !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
19998* !!! It is supposed to be used with the updated atomic !!! *
19999* !!! mass data file !!! *
20000* !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
20001* *
20002*----------------------------------------------------------------------*
20003*
20004 PARAMETER ( O16OLD = 931.145 D+00 )
20005 PARAMETER ( O16NEW = 931.19826D+00 )
20006 PARAMETER ( O16RAT = O16NEW / O16OLD )
20007 PARAMETER ( C12NEW = 931.49432D+00 )
20008 PARAMETER ( ADJUST = -8.322737768178909D-02 )
20009 PARAMETER ( AINFNT = 1.0D+30 )
20010* (original name: EVA0)
20011 COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
20012 * FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
20013 * CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
20014 * T (4,7), RMASS (297), ALPH (297), BET (297),
20015 * APRIME (250), IA (6), IZ (6)
20016 LOGICAL LFIRST
454792a9 20017CPH SAVE LFIRST, EXHYDR, EXNEUT
9aaba0d6 20018 DATA LFIRST / .TRUE. /
20019*
20020 IF ( LFIRST ) THEN
20021 LFIRST = .FALSE.
20022**sr 30.6.
20023C EXHYDR = DT_ENERGY( ONEONE, ONEONE )
20024C EXNEUT = DT_ENERGY( ONEONE, ZERZER )
20025 EXHYDR = A
20026 EXNEUT = Z
20027 DT_ENRG = -AINFNT
20028 RETURN
20029**
20030 END IF
20031 IZ0 = NINT (Z)
20032 IF ( IZ0 .LE. 0 ) THEN
20033 DT_ENRG = A * EXNEUT
20034 RETURN
20035 END IF
20036 N = NINT (A-Z)
20037 IF ( N .LE. 0 ) THEN
20038 DT_ENRG = Z * EXHYDR
20039 RETURN
20040 END IF
20041 AM2ZOA= (A-Z-Z)/A
20042 AM2ZOA=AM2ZOA*AM2ZOA
20043 A13 = RMASS(NINT(A))
20044* A13 = A**.3333333333333333D+00
20045 AM13 = 1.D+00/A13
20046 EV=-17.0354D+00*(1.D+00 -1.84619 D+00*AM2ZOA)*A
20047 ES= 25.8357D+00*(1.D+00 -1.712185D+00*AM2ZOA)*
20048 & (1.D+00 -0.62025D+00*AM13*AM13)*
20049 & (A13*A13 -.62025D+00)
20050 EC= 0.799D+00*Z*(Z-1.D+00)*AM13*(((1.5772D+00*AM13 +1.2273D+00)*
20051 & AM13-1.5849D+00)*
20052 & AM13*AM13 +1.D+00)
20053 EEX= -0.4323D+00*AM13*Z**1.3333333D+00*
20054 & (((0.49597D+00*AM13 -0.14518D+00)*AM13 -0.57811D+00) * AM13
20055 & + 1.D+00)
20056 DT_ENRG=8.367D+00*A-0.783D+00*Z +EV +ES +EC +EEX+CAM2(IZ0)+CAM3(N)
20057 DT_ENRG=(DT_ENRG + A * O16OLD ) * O16RAT - A * ( C12NEW - ADJUST )
20058 DT_ENRG = MIN ( DT_ENRG, Z * EXHYDR + ( A - Z ) * EXNEUT )
20059 RETURN
20060*=== End of function Enrg =============================================*
20061 END
20062
20063*$ CREATE DT_INCINI.FOR
20064*COPY DT_INCINI
20065* *
20066*=== incini ===========================================================*
20067* *
20068 SUBROUTINE DT_INCINI
20069
20070 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20071 SAVE
20072
20073 PARAMETER ( ZERZER = 0.D+00 )
20074 PARAMETER ( ONEONE = 1.D+00 )
20075 PARAMETER ( TWOTWO = 2.D+00 )
20076 PARAMETER ( THRTHR = 3.D+00 )
20077 PARAMETER ( FOUFOU = 4.D+00 )
20078 PARAMETER ( EIGEIG = 8.D+00 )
20079 PARAMETER ( ANINEN = 9.D+00 )
20080 PARAMETER ( HLFHLF = 0.5D+00 )
20081 PARAMETER ( ONETHI = ONEONE / THRTHR )
20082 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
20083 PARAMETER ( PLABRC = 0.197327053 D+00 )
20084 PARAMETER ( AMELCT = 0.51099906 D-03 )
20085 PARAMETER ( AMUGEV = 0.93149432 D+00 )
20086 PARAMETER ( AMPRTN = 0.93827231 D+00 )
20087 PARAMETER ( AMNTRN = 0.93956563 D+00 )
20088 PARAMETER ( AMDEUT = 1.87561339 D+00 )
20089 PARAMETER ( EMVGEV = 1.0 D-03 )
20090
20091 PARAMETER ( LUNOUT = 6 )
20092*
20093*----------------------------------------------------------------------*
20094* *
20095* Created on 10 june 1990 by Alfredo Ferrari & Paola Sala *
20096* Infn - Milan *
20097* *
20098* Last change on 02-may-95 by Alfredo Ferrari *
20099* *
20100* *
20101*----------------------------------------------------------------------*
20102*
20103* (original name: FHEAVY,FHEAVC)
20104 PARAMETER ( MXHEAV = 100 )
20105 CHARACTER*8 ANHEAV
20106 COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV),
20107 & CZHEAV (MXHEAV), TKHEAV (MXHEAV),
20108 & PHEAVY (MXHEAV), WHEAVY (MXHEAV),
20109 & AMHEAV ( 12 ) , AMNHEA ( 12 ) ,
20110 & KHEAVY (MXHEAV), ICHEAV ( 12 ) ,
20111 & IBHEAV ( 12 ) , NPHEAV
20112 COMMON /FKFHVC/ ANHEAV ( 12 )
20113* (original name: INPFLG)
20114 COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
20115* (original name: FRBKCM)
20116 PARAMETER ( MXFFBK = 6 )
20117 PARAMETER ( MXZFBK = 9 )
20118 PARAMETER ( MXNFBK = 10 )
20119 PARAMETER ( MXAFBK = 16 )
20120 PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
20121 PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
20122 PARAMETER ( NXAFBK = MXAFBK + 1 )
20123 PARAMETER ( MXPSST = 300 )
20124 PARAMETER ( MXPSFB = 41000 )
20125 LOGICAL LFRMBK, LNCMSS
20126 COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
20127 & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
20128 & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
20129 & IFRBKN (MXPSST), IFRBKZ (MXPSST),
20130 & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
20131 & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
20132 & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
20133 & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
20134 & IFBFRB, NBUFBK, LFRMBK, LNCMSS
20135* (original name: NUCDAT)
20136 PARAMETER ( AMUAMU = AMUGEV )
20137 PARAMETER ( AMPROT = AMPRTN )
20138 PARAMETER ( AMNEUT = AMNTRN )
20139 PARAMETER ( AMELEC = AMELCT )
20140 PARAMETER ( R0NUCL = 1.12 D+00 )
20141 PARAMETER ( RCCOUL = 1.7 D+00 )
20142 PARAMETER ( FERTHO = 14.33 D-09 )
20143 PARAMETER ( EXPEBN = 2.39 D+00 )
20144 PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
20145 PARAMETER ( AMUC12 = AMUGEV - HLFHLF * AMELCT + BEXC12 / 12.D+00 )
20146 PARAMETER ( AMHYDR = AMPRTN + AMELCT )
20147 PARAMETER ( AMHTON = AMHYDR - AMNTRN )
20148 PARAMETER ( AMNTOU = AMNTRN - AMUC12 )
20149 PARAMETER ( AMUCSQ = AMUC12 * AMUC12 )
20150 PARAMETER ( EBNDAV = HLFHLF * (AMPRTN + AMNTRN) - AMUC12 )
20151 PARAMETER ( GAMMIN = 1.0D-06 )
20152 PARAMETER ( GAMNSQ = 2.0D+00 * GAMMIN * GAMMIN )
20153 PARAMETER ( TVEPSI = GAMMIN / 100.D+00 )
20154 COMMON /FKNDAT/ AV0WEL, APFRMX, AEFRMX, AEFRMA,
20155 & RDSNUC, V0WELL (2), PFRMMX (2), EFRMMX (2),
20156 & EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2),
20157 & VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2),
20158 & PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2),
20159 & EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2),
20160 & ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV ,
20161 & AMRCSQ , ATO1O3 , ZTO1O3 , ELBNDE (0:100)
20162* (original name: PAREVT)
20163 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
20164 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
20165 PARAMETER ( NALLWP = 39 )
20166 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
20167 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
20168 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
20169 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
20170* (original name: NUCOLD)
20171 COMMON /FKNOLD/ HELP (2), HHLP (2), FTVTH (2), FINCX (2),
20172 & EKPOLD (2), BBOLD, ZZOLD, SQROLD, ASEASQ,
20173 & FSPRED, FEX0RD
20174*
20175 BBOLD = - 1.D+10
20176 ZZOLD = - 1.D+10
20177 SQROLD = - 1.D+10
20178 APFRMX = PLABRC * ( ANINEN * PIPIPI / EIGEIG )**ONETHI / R0NUCL
20179 AMNUCL (1) = AMPROT
20180 AMNUCL (2) = AMNEUT
20181 AMNUSQ (1) = AMPROT * AMPROT
20182 AMNUSQ (2) = AMNEUT * AMNEUT
20183 AMNHLP = HLFHLF * ( AMNUCL (1) + AMNUCL (2) )
20184 ASQHLP = AMNHLP**2
20185* ASQHLP = HLFHLF * ( AMNUSQ (1) + AMNUSQ (2) )
20186 AEFRMX = SQRT ( ASQHLP + APFRMX**2 ) - AMNHLP
20187 AEFRMA = 0.3D+00 * APFRMX**2 / AMNHLP * ( ONEONE - APFRMX**2 /
20188 & ( 5.6D+00 * ASQHLP ) )
20189 AV0WEL = AEFRMX + EBNDAV
20190 EBNDNG (1) = EBNDAV
20191 EBNDNG (2) = EBNDAV
20192 AEXC12 = EMVGEV * DT_ENERGY( 12.D+00, 6.D+00 )
20193 CEXC12 = EMVGEV * DT_ENRG( 12.D+00, 6.D+00 )
20194 AMMC12 = 12.D+00 * AMUGEV + AEXC12
20195 AMNC12 = AMMC12 - 6.D+00 * AMELCT + FERTHO * 6.D+00**EXPEBN
20196 AEXO16 = EMVGEV * DT_ENERGY( 16.D+00, 8.D+00 )
20197 CEXO16 = EMVGEV * DT_ENRG( 16.D+00, 8.D+00 )
20198 AMMO16 = 16.D+00 * AMUGEV + AEXO16
20199 AMNO16 = AMMO16 - 8.D+00 * AMELCT + FERTHO * 8.D+00**EXPEBN
20200 AEXS28 = EMVGEV * DT_ENERGY( 28.D+00, 14.D+00 )
20201 CEXS28 = EMVGEV * DT_ENRG( 28.D+00, 14.D+00 )
20202 AMMS28 = 28.D+00 * AMUGEV + AEXS28
20203 AMNS28 = AMMS28 - 14.D+00 * AMELCT + FERTHO * 14.D+00**EXPEBN
20204 AEXC40 = EMVGEV * DT_ENERGY( 40.D+00, 20.D+00 )
20205 CEXC40 = EMVGEV * DT_ENRG( 40.D+00, 20.D+00 )
20206 AMMC40 = 40.D+00 * AMUGEV + AEXC40
20207 AMNC40 = AMMC40 - 20.D+00 * AMELCT + FERTHO * 20.D+00**EXPEBN
20208 AEXF56 = EMVGEV * DT_ENERGY( 56.D+00, 26.D+00 )
20209 CEXF56 = EMVGEV * DT_ENRG( 56.D+00, 26.D+00 )
20210 AMMF56 = 56.D+00 * AMUGEV + AEXF56
20211 AMNF56 = AMMF56 - 26.D+00 * AMELCT + FERTHO * 26.D+00**EXPEBN
20212 AEX107 = EMVGEV * DT_ENERGY( 107.D+00, 47.D+00 )
20213 CEX107 = EMVGEV * DT_ENRG( 107.D+00, 47.D+00 )
20214 AMM107 = 107.D+00 * AMUGEV + AEX107
20215 AMN107 = AMM107 - 47.D+00 * AMELCT + FERTHO * 47.D+00**EXPEBN
20216 AEX132 = EMVGEV * DT_ENERGY( 132.D+00, 54.D+00 )
20217 CEX132 = EMVGEV * DT_ENRG( 132.D+00, 54.D+00 )
20218 AMM132 = 132.D+00 * AMUGEV + AEX132
20219 AMN132 = AMM132 - 54.D+00 * AMELCT + FERTHO * 54.D+00**EXPEBN
20220 AEX181 = EMVGEV * DT_ENERGY( 181.D+00, 73.D+00 )
20221 CEX181 = EMVGEV * DT_ENRG( 181.D+00, 73.D+00 )
20222 AMM181 = 181.D+00 * AMUGEV + AEX181
20223 AMN181 = AMM181 - 73.D+00 * AMELCT + FERTHO * 73.D+00**EXPEBN
20224 AEX208 = EMVGEV * DT_ENERGY( 208.D+00, 82.D+00 )
20225 CEX208 = EMVGEV * DT_ENRG( 208.D+00, 82.D+00 )
20226 AMM208 = 208.D+00 * AMUGEV + AEX208
20227 AMN208 = AMM208 - 82.D+00 * AMELCT + FERTHO * 82.D+00**EXPEBN
20228 AEX238 = EMVGEV * DT_ENERGY( 238.D+00, 92.D+00 )
20229 CEX238 = EMVGEV * DT_ENRG( 238.D+00, 92.D+00 )
20230 AMM238 = 238.D+00 * AMUGEV + AEX238
20231 AMN238 = AMM238 - 92.D+00 * AMELCT + FERTHO * 92.D+00**EXPEBN
20232
20233 AMHEAV (1) = AMUGEV + EMVGEV * DT_ENERGY( ONEONE, ZERZER )
20234 AMHEAV (2) = AMUGEV + EMVGEV * DT_ENERGY( ONEONE, ONEONE )
20235 AMHEAV (3) = TWOTWO * AMUGEV
20236 & + EMVGEV * DT_ENERGY( TWOTWO, ONEONE )
20237 AMHEAV (4) = THRTHR * AMUGEV
20238 & + EMVGEV * DT_ENERGY( THRTHR, ONEONE )
20239 AMHEAV (5) = THRTHR * AMUGEV
20240 & + EMVGEV * DT_ENERGY( THRTHR, TWOTWO )
20241 AMHEAV (6) = FOUFOU * AMUGEV
20242 & + EMVGEV * DT_ENERGY( FOUFOU, TWOTWO )
20243 ELBNDE (0) = ZERZER
20244 ELBNDE (1) = 13.6D-09
20245 DO 2000 IZ = 2, 100
20246 ELBNDE ( IZ ) = FERTHO * DBLE ( IZ )**EXPEBN
202472000 CONTINUE
20248 AMNHEA (1) = AMHEAV (1) + ELBNDE (0)
20249 AMNHEA (2) = AMHEAV (2) - AMELCT + ELBNDE (1)
20250 AMNHEA (3) = AMHEAV (3) - AMELCT + ELBNDE (1)
20251 AMNHEA (4) = AMHEAV (4) - AMELCT + ELBNDE (1)
20252 AMNHEA (5) = AMHEAV (5) - TWOTWO * AMELCT + ELBNDE (2)
20253 AMNHEA (6) = AMHEAV (6) - TWOTWO * AMELCT + ELBNDE (2)
20254 IF ( LEVPRT ) THEN
20255 WRITE ( LUNOUT, * )' **** Evaporation from residual nucleus',
20256 & ' activated **** '
20257 IF ( LDEEXG ) WRITE ( LUNOUT, * )' **** Deexcitation gamma',
20258 & ' production activated **** '
20259**sr 18.5.95
20260* commented, since obsolete
20261C IF ( LHEAVY ) WRITE ( LUNOUT, * )' **** Evaporated "heavies"',
20262C & ' transport activated **** '
20263 IF ( IFISS .GT. 0 )
20264 & WRITE ( LUNOUT, * )' **** High Energy fission ',
20265 & ' requested & activated **** '
20266 IF ( LFRMBK )
20267 & WRITE ( LUNOUT, * )' **** Fermi Break Up ',
20268 & ' requested & activated **** '
20269 IF ( LFRMBK ) CALL DT_FRBKIN(.FALSE.,.FALSE.)
20270 ELSE
20271 LDEEXG = .FALSE.
20272 LHEAVY = .FALSE.
20273 LFRMBK = .FALSE.
20274 IFISS = 0
20275 END IF
20276 RETURN
20277*=== End of subroutine incini =========================================*
20278 END
20279
20280*$ CREATE DT_STALIN.FOR
20281*COPY DT_STALIN
20282* *
20283*=== stalin ===========================================================*
20284* *
20285 SUBROUTINE DT_STALIN
20286
20287 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20288 SAVE
20289 PARAMETER ( ANGLGB = 5.0D-16 )
20290 PARAMETER ( ZERZER = 0.D+00 )
20291 PARAMETER ( ONEONE = 1.D+00 )
20292 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
20293 PARAMETER ( AMUGEV = 0.93149432 D+00 )
20294 PARAMETER ( EMVGEV = 1.0 D-03 )
20295 PARAMETER ( NSTBIS = 304 )
20296 PARAMETER ( LUNIN = 5 )
20297 PARAMETER ( LUNOUT = 6 )
20298*
20299*----------------------------------------------------------------------*
20300* *
20301* STAbility LINe calculation: *
20302* *
20303* Created on 04 december 1992 by Alfredo Ferrari & Paola Sala *
20304* Infn - Milan *
20305* *
20306* Last change on 04-dec-92 by Alfredo Ferrari *
20307* *
20308* *
20309*----------------------------------------------------------------------*
20310*
20311* (original name: ISOTOP)
20312 PARAMETER ( NAMSMX = 270 )
20313 PARAMETER ( NZGVAX = 15 )
20314 PARAMETER ( NISMMX = 574 )
20315 COMMON /FKISOT/ WAPS (NAMSMX,NZGVAX), T12NUC (NAMSMX,NZGVAX),
20316 & WAPISM (NISMMX), T12ISM (NISMMX),
20317 & ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260),
20318 & AMSSST (100) , ISOMNM (NSTBIS), ISONDX (2,100),
20319 & JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX),
20320 & INWAPS (NAMSMX), JSPISM (NISMMX),
20321 & JPTISM (NISMMX), IZWISM (NISMMX),
20322 & INWISM (0:NAMSMX)
20323*
20324 DIMENSION ZNORM (260)
20325* +-------------------------------------------------------------------*
20326* |
20327 DO 1000 IZ=1,100
20328 DO 500 J=1,2
20329 ASTLIN (J,IZ) = ZERZER
20330 500 CONTINUE
20331 1000 CONTINUE
20332* |
20333* +-------------------------------------------------------------------*
20334* +-------------------------------------------------------------------*
20335* |
20336 DO 2000 IA=1,260
20337 ZNORM (IA) = ZERZER
20338 DO 1500 J=1,2
20339 ZSTLIN (J,IA) = ZERZER
20340 1500 CONTINUE
20341 2000 CONTINUE
20342* |
20343* +-------------------------------------------------------------------*
20344* +-------------------------------------------------------------------*
20345* | Loop on the Atomic Number
20346 DO 3000 IZ=1,100
20347 AMSSST (IZ) = ZERZER
20348 ANORM = ONEONE
20349 ZTAR = IZ
20350* | +----------------------------------------------------------------*
20351* | | Loop on the stable isotopes
20352 DO 2500 IS = ISONDX (1,IZ), ISONDX (2,IZ)
20353 IA = ISOMNM (IS)
20354 ASTLIN (1,IZ) = ASTLIN (1,IZ) + ABUISO (IS) * IA
20355 ASTLIN (2,IZ) = ASTLIN (2,IZ) + ABUISO (IS) * IA**2
20356 ZNORM (IA) = ZNORM (IA) + ABUISO (IS)
20357 ZSTLIN (1,IA) = ZSTLIN (1,IA) + ABUISO (IS) * IZ
20358 ZSTLIN (2,IA) = ZSTLIN (2,IA) + ABUISO (IS) * IZ**2
20359 AHELP = IA
20360 IF ( AHELP .LE. 1.00001D+00 ) THEN
20361 ANORM = ONEONE / ( ONEONE - ABUISO (IS) )
20362 GO TO 2500
20363 END IF
20364 AMSSST (IZ) = ABUISO (IS) * ( AHELP * AMUGEV
20365 & + EMVGEV * DT_ENERGY(AHELP,ZTAR) ) + AMSSST (IZ)
20366 2500 CONTINUE
20367* | |
20368* | +----------------------------------------------------------------*
20369 AMSSST (IZ) = ANORM * AMSSST (IZ) / AMUGEV
20370* | Normalize and print A_stab versus Z data:
20371 ASTLIN (2,IZ) = MAX ( SQRT (ASTLIN(2,IZ)-ASTLIN(1,IZ)**2),
20372 & 0.5D+00 )
20373* WRITE (LUNOUT,*)' Z:',IZ,' A_stab:',SNGL(ASTLIN(1,IZ)),
20374* & ' Sigma_st',SNGL(ASTLIN(2,IZ))
20375 3000 CONTINUE
20376* |
20377* +-------------------------------------------------------------------*
20378* +-------------------------------------------------------------------*
20379* | Normalize and print Z_stab versus A data:
20380 DO 4000 IA=1,260
20381 ZSTLIN (1,IA) = ZSTLIN (1,IA) / MAX ( ZNORM (IA), 1.D-10 )
20382 ZSTLIN (2,IA) = ZSTLIN (2,IA) / MAX ( ZNORM (IA), 1.D-10 )
20383 ZSTLIN (2,IA) = MAX ( ZSTLIN (2,IA), ZSTLIN (1,IA)**2 )
20384 IF ( ZNORM (IA) .GT. ANGLGB )
20385**sr 2.11. avoid underflows at Pentium
20386 & ZSTLIN (2,IA) =
20387 & MAX ( SQRT ( ABS(ZSTLIN(2,IA)-ZSTLIN(1,IA)**2) ),
20388C & ZSTLIN (2,IA) = MAX ( SQRT (ZSTLIN(2,IA)-ZSTLIN(1,IA)**2),
20389 & 0.3D+00 )
20390 4000 CONTINUE
20391* |
20392* +-------------------------------------------------------------------*
20393* +-------------------------------------------------------------------*
20394* | Normalize and print Z_stab versus A data:
20395 DO 5000 IA=1,260
20396 IF ( ZNORM (IA) .LE. ANGLGB ) THEN
20397 DO 4200 JA = IA-1,1,-1
20398 IF ( ZNORM (JA) .GT. ANGLGB ) THEN
20399 IA1 = JA
20400 GO TO 4300
20401 END IF
20402 4200 CONTINUE
20403 4300 CONTINUE
20404 DO 4400 JA = IA+1,260
20405 IF ( ZNORM (JA) .GT. ANGLGB ) THEN
20406 IA2 = JA
20407 GO TO 4500
20408 END IF
20409 4400 CONTINUE
20410 IA2 = IA1
20411 IA1 = IA1 - 1
20412 4500 CONTINUE
20413 ZSTLIN (1,IA) = DBLE (IA-IA1) / DBLE (IA2-IA1)
20414 & * ( ZSTLIN (1,IA2) - ZSTLIN (1,IA1) )
20415 & + ZSTLIN (1,IA1)
20416 ZSTLIN (2,IA) = DBLE (IA-IA1) / DBLE (IA2-IA1)
20417 & * ( ZSTLIN (2,IA2) - ZSTLIN (2,IA1) )
20418 & + ZSTLIN (2,IA1)
20419 END IF
20420 IZ = MIN ( 100, NINT (ZSTLIN(1,IA)) )
20421 ATOZ = IZ / ASTLIN (1,IZ)
20422 ZSTLIN (2,IA) = MAX ( ZSTLIN (2,IA), ATOZ * ASTLIN (2,IZ) )
20423* WRITE (LUNOUT,*)' A:',IA,' Z_stab:',SNGL(ZSTLIN(1,IA)),
20424* & ' Sigma_st',SNGL(ZSTLIN(2,IA))
20425 5000 CONTINUE
20426* |
20427* +-------------------------------------------------------------------*
20428 RETURN
20429 END
20430
20431*$ CREATE DT_BERTTP.FOR
20432*COPY DT_BERTTP
20433*
20434*=== berttp ===========================================================*
20435* *
20436 SUBROUTINE DT_BERTTP
20437
20438 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20439 SAVE
20440
20441 PARAMETER ( CSNNRM = 2.0D-15 )
20442 PARAMETER ( ZERZER = 0.D+00 )
20443 PARAMETER ( ONEONE = 1.D+00 )
20444 PARAMETER ( THRTHR = 3.D+00 )
20445 PARAMETER ( SIXSIX = 6.D+00 )
20446 PARAMETER ( ONETHI = ONEONE / THRTHR )
20447 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
20448 PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
20449 PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
20450 PARAMETER ( EMVGEV = 1.0 D-03 )
20451
20452 PARAMETER ( NSTBIS = 304 )
20453
20454 PARAMETER ( LUNIN = 5 )
20455 PARAMETER ( LUNOUT = 6 )
20456**sr 19.5. set error output-unit from 15 to 6
20457 PARAMETER ( LUNERR = 6 )
20458C---------------------------------------------------------------------
20459C SUBNAME = DT_BERTTP --- READ BERTINI DATA
20460C---------------------------------------------------------------------
20461C ---------------------------------- I-N-C DATA
20462C COMMON R8(2127),R4(64),CRSC(600,4),R8B(336),CS(29849)
20463C REAL*8 R8,R8B,CRSC,CS
20464C REAL*4 R4
20465C --------------------------------- EVAPORATION DATA
20466* (original name: COOKCM)
20467 PARAMETER ( ASMTOG = SIXSIX / PIPIPI**2 )
20468 LOGICAL LDEFOZ, LDEFON
20469 PARAMETER ( INCOOK = 150, IZCOOK = 98 )
20470 COMMON /FKCOOK/ ALPIGN, BETIGN, GAMIGN, POWIGN,
20471 & SZCOOK (IZCOOK), SNCOOK (INCOOK), PZCOOK (IZCOOK),
20472 & PNCOOK (INCOOK), LDEFOZ (IZCOOK), LDEFON (INCOOK)
20473* (original name: EVA0)
20474 COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
20475 * FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
20476 * CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
20477 * T (4,7), RMASS (297), ALPH (297), BET (297),
20478 * APRIME (250), IA (6), IZ (6)
20479* (original name: FRBKCM)
20480 PARAMETER ( MXFFBK = 6 )
20481 PARAMETER ( MXZFBK = 9 )
20482 PARAMETER ( MXNFBK = 10 )
20483 PARAMETER ( MXAFBK = 16 )
20484 PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
20485 PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
20486 PARAMETER ( NXAFBK = MXAFBK + 1 )
20487 PARAMETER ( MXPSST = 300 )
20488 PARAMETER ( MXPSFB = 41000 )
20489 LOGICAL LFRMBK, LNCMSS
20490 COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
20491 & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
20492 & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
20493 & IFRBKN (MXPSST), IFRBKZ (MXPSST),
20494 & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
20495 & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
20496 & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
20497 & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
20498 & IFBFRB, NBUFBK, LFRMBK, LNCMSS
20499* (original name: HETTP)
20500 COMMON /FKHETP/ NHSTP,NBERTP,IOSUB,INSRS
20501* (original name: INPFLG)
20502 COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
20503* (original name: ISOTOP)
20504 PARAMETER ( NAMSMX = 270 )
20505 PARAMETER ( NZGVAX = 15 )
20506 PARAMETER ( NISMMX = 574 )
20507 COMMON /FKISOT/ WAPS (NAMSMX,NZGVAX), T12NUC (NAMSMX,NZGVAX),
20508 & WAPISM (NISMMX), T12ISM (NISMMX),
20509 & ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260),
20510 & AMSSST (100) , ISOMNM (NSTBIS), ISONDX (2,100),
20511 & JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX),
20512 & INWAPS (NAMSMX), JSPISM (NISMMX),
20513 & JPTISM (NISMMX), IZWISM (NISMMX),
20514 & INWISM (0:NAMSMX)
20515* (original name: NUCGID,NUCGEO,NUCGE2,NUCPWI,NUCGII)
20516 PARAMETER ( PI = PIPIPI )
20517 PARAMETER ( PISQ = PIPISQ )
20518 PARAMETER ( SKTOHL = 0.5456645846610345D+00 )
20519 PARAMETER ( RZNUCL = 1.12 D+00 )
20520 PARAMETER ( RMSPRO = 0.8 D+00 )
20521 PARAMETER ( R0PROT = RMSPRO / SQRT12 )
20522 PARAMETER ( ARHPRO = 1.D+00 / 8.D+00 / PI / R0PROT / R0PROT
20523 & / R0PROT )
20524 PARAMETER ( RLLE04 = RZNUCL )
20525 PARAMETER ( RLLE16 = RZNUCL )
20526 PARAMETER ( RLGT16 = RZNUCL )
20527 PARAMETER ( RCLE04 = 0.75D+00 / PI / RLLE04 / RLLE04 / RLLE04 )
20528 PARAMETER ( RCLE16 = 0.75D+00 / PI / RLLE16 / RLLE16 / RLLE16 )
20529 PARAMETER ( RCGT16 = 0.75D+00 / PI / RLGT16 / RLGT16 / RLGT16 )
20530 PARAMETER ( SKLE04 = 1.4D+00 )
20531 PARAMETER ( SKLE16 = 1.9D+00 )
20532 PARAMETER ( SKGT16 = 2.4D+00 )
20533 PARAMETER ( HLLE04 = SKTOHL * SKLE04 )
20534 PARAMETER ( HLLE16 = SKTOHL * SKLE16 )
20535 PARAMETER ( HLGT16 = SKTOHL * SKGT16 )
20536 PARAMETER ( ALPHA0 = 0.1D+00 )
20537 PARAMETER ( OMALH0 = 1.D+00 - ALPHA0 )
20538 PARAMETER ( GAMSK0 = 0.9D+00 )
20539 PARAMETER ( OMGAS0 = 1.D+00 - GAMSK0 )
20540 PARAMETER ( POTME0 = 0.6666666666666667D+00 )
20541 PARAMETER ( POTBA0 = 1.D+00 )
20542 PARAMETER ( PNFRAT = 1.533D+00 )
20543 PARAMETER ( RADPIM = 0.035D+00 )
20544 PARAMETER ( RDPMHL = 14.D+00 )
20545 PARAMETER ( APMRST = 4.D+00 / 44.D+00 )
20546 PARAMETER ( APMPRO = 1.D+00 / 6.D+00 )
20547 PARAMETER ( APPPRO = 5.D+00 / 6.D+00 )
20548 PARAMETER ( AP0PFS = 0.5D+00 )
20549 PARAMETER ( AP0PFP = 1.D+00 / 3.D+00 )
20550 PARAMETER ( AP0NFP = 2.D+00 / 3.D+00 )
20551 PARAMETER ( XPAUCO = 1.88495407241652 D+00 )
20552 PARAMETER ( MXSCIN = 50 )
20553 LOGICAL LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH, LNCDCY,
20554 & LNUSCT, LPREEQ, LNPHTC, LNWRAD, LPNRHO, LFTCMP, LFTCAC
20555 COMMON /FKNGID/ RHOTAB (2:260), RHATAB (2:260), ALPTAB (2:260),
20556 & RADTAB (2:260), SKITAB (2:260), HALTAB (2:260),
20557 & SK3TAB (2:260), SK4TAB (2:260), HABTAB (2:260),
20558 & CWSTAB (2:260), EKATAB (2:260), PFATAB (2:260),
20559 & PFRTAB (2:260)
20560 COMMON /FKNGEO/ RADTOT, RADIU1, RADIU0, RAD1O2, SKINDP, HALODP,
20561 & ALPHAL, OMALHL, RADSKN, SKNEFF, CPARWS, RADPRO,
20562 & RADCOR, RADCO2, RADMAX, BIMPTR, RIMPTR, XIMPTR,
20563 & YIMPTR, ZIMPTR, RHOIMT, EKFPRO, PFRPRO, RHOCEN,
20564 & RHOCOR, RHOSKN, EKFCEN (2), PFRCEN (2), EKFBIM,
20565 & PFRBIM, RHOIMP, EKFIMP, PFRIMP, RHOIM2, EKFIM2,
20566 & PFRIM2, RHOIM3, EKFIM3, PFRIM3, VPRWLL, RIMPCT,
20567 & BIMPCT, XIMPCT, YIMPCT, ZIMPCT, RIMPC2, XIMPC2,
20568 & YIMPC2, ZIMPC2, RIMPC3, XIMPC3, YIMPC3, ZIMPC3,
20569 & XBIMPC, YBIMPC, ZBIMPC, CXIMPC, CYIMPC, CZIMPC,
20570 & SQRIMP, SIGMAP, SIGMAN, SIGMAA, RHORED, R0TRAJ,
20571 & R1TRAJ, SBUSED, SBTOT , SBRES , RHOAVE, EKFAVE,
20572 & PFRAVE, AVEBIN, ACOLL , ZCOLL , RADSIG, OPACTY,
20573 & EKECON, PNUCCO, EKEWLL, PPRWLL, PXPROJ, PYPROJ,
20574 & PZPROJ, EKFERM, PNFRMI, PXFERM, PYFERM, PZFERM,
20575 & EKFER2, PNFRM2, PXFER2, PYFER2, PZFER2, EKFER3,
20576 & PNFRM3, PXFER3, PYFER3, PZFER3, RHOMEM, EKFMEM,
20577 & BIMMEM, WLLRED, VPRBIM, POTINC, POTOUT, EEXMIN
20578 COMMON /FKNGE2/ RDTTNC (2), RHONCP (2), RHONC2 (2), RHONC3 (2),
20579 & RHONCT (2), AMOTHR, EKOTHR, AMCREA, EKNCLN,
20580 & EEXDEL, EEXANY, CLMBBR, RDCLMB, BFCLMB, BFCEFF,
20581 & BNPROJ, BNDNUC, DEBRLM, SK4PAR, UBIMPC, VBIMPC,
20582 & WBIMPC, BNDPOT, SIGMAT, SIGABP, SIGABN, WLLRES,
20583 & POTBAR, POTMES, AGEPRI, OPNOPA, ETHRND,
20584 & BNENRG (3), DEFNUC (2), SIGMPR (4), SIGMNU (4),
20585 & SIGPAB (3), SIGNAB (3), HHLP (2), FORTOT (2),
20586 & FPNBLC, DPNBLC, FFTFLG, IFTFLG,
20587 & IPWELL, ITNCMX, KPRIN , NTARGT, KNUCIM, KNUCI2,
20588 & KNUCI3, IEVPRE, ISFCOL, ISFTAR, ISFTA2, ISFTA3,
20589 & NPOTHR, ICOTHR, IBOTHR, NPUMFN, ISTNCL, ITAUCM,
20590 & IABCOU, IADFLG, IGSFLG, IALFLG, ICBFLG, LPREEQ,
20591 & LNPHTC, LPNRHO, LNWRAD, LFTCMP, LFTCAC
20592 COMMON /FKNPWI/ ALMBAR, BIMMAX, SIGGEO, LLLMAX, LLLACT
20593 COMMON /FKNGII/ HOLEXP (2*MXSCIN), XEXPIN (3,0:MXSCIN),
20594 & YEXPIN (3,0:MXSCIN), ZEXPIN (3,0:MXSCIN),
20595 & AGEXIN (0:MXSCIN), RHOEXP (2), EKFEXP, EHLFIX,
20596 & NHLEXP, NHLFIX, IPRTYP, NNCEXI (0:MXSCIN),
20597 & NCEXPI (3,0:MXSCIN), ISEXIN (3,0:MXSCIN),
20598 & ISCTYP (0:MXSCIN), NUSCIN, NEXPEM,
20599 & LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH,
20600 & LNCDCY, LNUSCT
20601 DIMENSION AWSTAB (2:260), SIGMAB (3)
20602 EQUIVALENCE ( DEFPRO, DEFNUC (1) )
20603 EQUIVALENCE ( DEFNEU, DEFNUC (2) )
20604 EQUIVALENCE ( RHOIPP, RHONCP (1) )
20605 EQUIVALENCE ( RHOINP, RHONCP (2) )
20606 EQUIVALENCE ( RHOIP2, RHONC2 (1) )
20607 EQUIVALENCE ( RHOIN2, RHONC2 (2) )
20608 EQUIVALENCE ( RHOIP3, RHONC3 (1) )
20609 EQUIVALENCE ( RHOIN3, RHONC3 (2) )
20610 EQUIVALENCE ( RHOIPT, RHONCT (1) )
20611 EQUIVALENCE ( RHOINT, RHONCT (2) )
20612 EQUIVALENCE ( OMALHL, SK3PAR )
20613 EQUIVALENCE ( ALPHAL, HABPAR )
20614 EQUIVALENCE ( ALPTAB (2), AWSTAB (2) )
20615 EQUIVALENCE ( SIGMPE, SIGMPR (1) )
20616 EQUIVALENCE ( SIGMPC, SIGMPR (2) )
20617 EQUIVALENCE ( SIGMPI, SIGMPR (3) )
20618 EQUIVALENCE ( SIGMPA, SIGMPR (4) )
20619 EQUIVALENCE ( SIGMNE, SIGMNU (1) )
20620 EQUIVALENCE ( SIGMNC, SIGMNU (2) )
20621 EQUIVALENCE ( SIGMNI, SIGMNU (3) )
20622 EQUIVALENCE ( SIGMNA, SIGMNU (4) )
20623 EQUIVALENCE ( SIGMA2, SIGPAB (1) )
20624 EQUIVALENCE ( SIGMA3, SIGPAB (2) )
20625 EQUIVALENCE ( SIGMAS, SIGPAB (3) )
20626 EQUIVALENCE ( SIGPAB (1), SIGMAB (1) )
20627* (original name: NUCLEV)
20628 LOGICAL LCLVSL, LFLVSL, LRLVSL, LEQSBL
20629 COMMON /FKNLEV/ PAENUC (200,2), SHENUC (200,2), DEFRMI (2),
20630 & DEFMAG (2), ENNCLV (160,2), RANCLV (160,2),
20631 & CUMRAD (0:160,2), RUSNUC (2),
20632 & ENPLVL (114), ENNLVL(164), JUSNUC (160,2),
20633 & NTANUC (2), NAVNUC (2), NLSNUC (2), NCONUC (2),
20634 & NSKNUC (2), NHANUC (2), NUSNUC (2), NACNUC (2),
20635 & JMXNUC (2), IPRNUC (3), JPRNUC (3), MAGNUM (8),
20636 & MAGNUC (2), MGSNUC (8,2), MGSSNC (25,2),
20637 & NSBSHL (2), NMNSBS (2), NPRNUC, INUCLV, LCLVSL,
20638 & LFLVSL, LRLVSL, LEQSBL
20639 DIMENSION JUSPRO (160), JUSNEU (160), MGSPRO (8), MGSNEU (8),
20640 & MGSSPR (19) , MGSSNE (25)
20641 EQUIVALENCE ( RUSNUC (1), RUSPRO )
20642 EQUIVALENCE ( RUSNUC (2), RUSNEU )
20643 EQUIVALENCE ( JUSNUC (1,1), JUSPRO (1) )
20644 EQUIVALENCE ( JUSNUC (1,2), JUSNEU (1) )
20645 EQUIVALENCE ( MGSNUC (1,1), MGSPRO (1) )
20646 EQUIVALENCE ( MGSNUC (1,2), MGSNEU (1) )
20647 EQUIVALENCE ( MGSSNC (1,1), MGSSPR (1) )
20648 EQUIVALENCE ( MGSSNC (1,2), MGSSNE (1) )
20649 EQUIVALENCE ( NTANUC (1), NTAPRO )
20650 EQUIVALENCE ( NTANUC (2), NTANEU )
20651 EQUIVALENCE ( NAVNUC (1), NAVPRO )
20652 EQUIVALENCE ( NAVNUC (2), NAVNEU )
20653 EQUIVALENCE ( NLSNUC (1), NLSPRO )
20654 EQUIVALENCE ( NLSNUC (2), NLSNEU )
20655 EQUIVALENCE ( NCONUC (1), NCOPRO )
20656 EQUIVALENCE ( NCONUC (2), NCONEU )
20657 EQUIVALENCE ( NSKNUC (1), NSKPRO )
20658 EQUIVALENCE ( NSKNUC (2), NSKNEU )
20659 EQUIVALENCE ( NHANUC (1), NHAPRO )
20660 EQUIVALENCE ( NHANUC (2), NHANEU )
20661 EQUIVALENCE ( NUSNUC (1), NUSPRO )
20662 EQUIVALENCE ( NUSNUC (2), NUSNEU )
20663 EQUIVALENCE ( NACNUC (1), NACPRO )
20664 EQUIVALENCE ( NACNUC (2), NACNEU )
20665 EQUIVALENCE ( JMXNUC (1), JMXPRO )
20666 EQUIVALENCE ( JMXNUC (2), JMXNEU )
20667 EQUIVALENCE ( MAGNUC (1), MAGPRO )
20668 EQUIVALENCE ( MAGNUC (2), MAGNEU )
20669* (original name: PAREVT)
20670 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
20671 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
20672 PARAMETER ( NALLWP = 39 )
20673 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
20674 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
20675 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
20676 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
20677* (original name: XSEPAR)
20678 COMMON /FKXSEP/ AANXSE (100), BBNXSE (100), CCNXSE (100),
20679 & DDNXSE (100), EENXSE (100), ZZNXSE (100),
20680 & EMNXSE (100), XMNXSE (100),
20681 & AAPXSE (100), BBPXSE (100), CCPXSE (100),
20682 & DDPXSE (100), EEPXSE (100), FFPXSE (100),
20683 & ZZPXSE (100), EMPXSE (100), XMPXSE (100)
20684
20685C---------------------------------------------------------------------
20686**sr 17.5.95
20687* modified for use in DPMJET
20688C WRITE( LUNOUT,'(A,I2)')
20689C & ' *** Reading evaporation and nuclear data from unit: ', NBERTP
20690C REWIND NBERTP
20691 IF (LEVPRT) WRITE(LUNOUT,1000)
20692 1000 FORMAT(/,1X,'BERTTP:',4X,'Initialization of evaporation module',
20693 & /,12X,'------------------------------------',/)
20694 NBERNW = 23
f87dab60 20695CPH OPEN (UNIT=NBERNW,FILE='dpmjet.dat',STATUS='UNKNOWN')
9aaba0d6 20696
20697**sr 17.5.
20698*!!!! changed to be able to read the ASCII !!!!
20699**
20700C A. Ferrari: first of all read isotopic data
20701 READ (NBERNW,*) ISONDX
20702 READ (NBERNW,*) ISOMNM
20703 READ (NBERNW,*) ABUISO
20704C READ (NBERTP) ISONDX
20705C READ (NBERTP) ISOMNM
20706C READ (NBERTP) ABUISO
20707 DO 1 I=1,4
20708C READ (NBERTP) (CRSC(J,I),J=1,600)
20709C A. Ferrari: commented also the dummy read to save disk space
20710C READ (NBERTP)
20711 1 CONTINUE
20712C READ (NBERTP) CS
20713C A. Ferrari: commented also the dummy read to save disk space
20714C READ (NBERTP)
20715C---------------------------------------------------------------------
20716 READ (NBERNW,*) (P0(I),P1(I),P2(I),I=1,1001)
20717 READ (NBERNW,*) IA,IZ
20718 DO 2 I=1,6
20719 FLA(I)=IA(I)
20720 FLZ(I)=IZ(I)
20721 2 CONTINUE
20722 READ (NBERNW,*) RHO,OMEGA
20723 READ (NBERNW,*) EXMASS
20724 READ (NBERNW,*) CAM2
20725 READ (NBERNW,*) CAM3
20726 READ (NBERNW,*) CAM4
20727 READ (NBERNW,*) CAM5
20728 READ (NBERNW,*) ((T(I,J),J=1,7),I=1,3)
20729 DO 3 I=1,7
20730 T(4,I) = ZERZER
20731 3 CONTINUE
20732 READ (NBERNW,*) RMASS
20733 READ (NBERNW,*) ALPH
20734 READ (NBERNW,*) BET
20735 READ (NBERNW,*) INWAPS
20736 READ (NBERNW,*) WAPS
20737 READ (NBERNW,*) T12NUC
20738 READ (NBERNW,*) JSPNUC
20739 READ (NBERNW,*) JPTNUC
20740 READ (NBERNW,*) INWISM
20741 READ (NBERNW,*) IZWISM
20742 READ (NBERNW,*) WAPISM
20743 READ (NBERNW,*) T12ISM
20744 READ (NBERNW,*) JSPISM
20745 READ (NBERNW,*) JPTISM
20746 READ (NBERNW,*) APRIME
20747 IF (LEVPRT)
20748 &WRITE( LUNOUT,'(A)' ) ' *** Evaporation: using 1977 Waps data ***'
20749 READ (NBERNW,*) AHELP , BHELP , LRMSCH, LRD1O2, LTRASP
20750 IF ( ABS (AHELP-ALPHA0) .GT. CSNNRM * ALPHA0 .OR.
20751 & ABS (BHELP-GAMSK0) .GT. CSNNRM * GAMSK0 ) THEN
20752 WRITE (LUNOUT,*)
20753 & ' *** Inconsistent Nuclear Geometry data on file ***'
20754 STOP
20755 END IF
20756 READ (NBERNW,*) RHOTAB, RHATAB, ALPTAB, RADTAB, SKITAB, HALTAB,
20757 & EKATAB, PFATAB, PFRTAB
20758 READ (NBERNW,*) AANXSE, BBNXSE, CCNXSE, DDNXSE, EENXSE, ZZNXSE,
20759 & EMNXSE, XMNXSE
20760 READ (NBERNW,*) AAPXSE, BBPXSE, CCPXSE, DDPXSE, EEPXSE, FFPXSE,
20761 & ZZPXSE, EMPXSE, XMPXSE
20762* Data about Fermi-breakup:
20763 READ (NBERNW,*) IPOSST, MXPDUM, MXADUM, MXNDUM, MXZDUM, IFBSTF
20764 IF ( MXADUM .NE. MXAFBK .OR. MXNDUM .NE. MXNFBK .OR. MXZDUM .NE.
20765 & MXZFBK .OR. MXPDUM .NE. MXPSST ) THEN
20766 WRITE (LUNOUT,*)' *** Inconsistent Fermi BreakUp data',
20767 & ' in the Nuclear Data file ***'
20768 STOP 'STOP:BERTTP-INCONS-FERMI-BREAKUP-DATA'
20769 END IF
20770 READ (NBERNW,*) IFRBKN
20771 READ (NBERNW,*) IFRBKZ
20772 READ (NBERNW,*) IFBKSP
20773 READ (NBERNW,*) IFBKST
20774 READ (NBERNW,*) EEXFBK
20775
20776 CLOSE (UNIT=NBERNW)
20777
20778C READ (NBERTP) (P0(I),P1(I),P2(I),I=1,1001)
20779C READ (NBERTP) IA,IZ
20780C DO 2 I=1,6
20781C FLA(I)=IA(I)
20782C FLZ(I)=IZ(I)
20783C 2 CONTINUE
20784C READ (NBERTP) RHO,OMEGA
20785C READ (NBERTP) EXMASS
20786C READ (NBERTP) CAM2
20787C READ (NBERTP) CAM3
20788C READ (NBERTP) CAM4
20789C READ (NBERTP) CAM5
20790C READ (NBERTP) ((T(I,J),J=1,7),I=1,3)
20791C DO 3 I=1,7
20792C T(4,I) = ZERZER
20793C 3 CONTINUE
20794C READ (NBERTP) RMASS
20795C READ (NBERTP) ALPH
20796C READ (NBERTP) BET
20797C READ (NBERTP) INWAPS
20798C READ (NBERTP) WAPS
20799C READ (NBERTP) T12NUC
20800C READ (NBERTP) JSPNUC
20801C READ (NBERTP) JPTNUC
20802C READ (NBERTP) INWISM
20803C READ (NBERTP) IZWISM
20804C READ (NBERTP) WAPISM
20805C READ (NBERTP) T12ISM
20806C READ (NBERTP) JSPISM
20807C READ (NBERTP) JPTISM
20808C READ (NBERTP) APRIME
20809C WRITE( LUNOUT,'(A)' ) ' *** Evaporation: using 1977 Waps data ***'
20810C READ (NBERTP) AHELP , BHELP , LRMSCH, LRD1O2, LTRASP
20811C IF ( ABS (AHELP-ALPHA0) .GT. CSNNRM * ALPHA0 .OR.
20812C & ABS (BHELP-GAMSK0) .GT. CSNNRM * GAMSK0 ) THEN
20813C WRITE (LUNOUT,*)
20814C & ' *** Inconsistent Nuclear Geometry data on file ***'
20815C STOP
20816C END IF
20817C READ (NBERTP) RHOTAB, RHATAB, ALPTAB, RADTAB, SKITAB, HALTAB,
20818C & EKATAB, PFATAB, PFRTAB
20819C READ (NBERTP) AANXSE, BBNXSE, CCNXSE, DDNXSE, EENXSE, ZZNXSE,
20820C & EMNXSE, XMNXSE
20821C READ (NBERTP) AAPXSE, BBPXSE, CCPXSE, DDPXSE, EEPXSE, FFPXSE,
20822C & ZZPXSE, EMPXSE, XMPXSE
20823* Data about Fermi-breakup:
20824C READ (NBERTP) IPOSST, MXPDUM, MXADUM, MXNDUM, MXZDUM, IFBSTF
20825C IF ( MXADUM .NE. MXAFBK .OR. MXNDUM .NE. MXNFBK .OR. MXZDUM .NE.
20826C & MXZFBK .OR. MXPDUM .NE. MXPSST ) THEN
20827C WRITE (LUNOUT,*)' *** Inconsistent Fermi BreakUp data',
20828C & ' in the Nuclear Data file ***'
20829C STOP 'STOP:BERTTP-INCONS-FERMI-BREAKUP-DATA'
20830C END IF
20831C READ (NBERTP) IFRBKN
20832C READ (NBERTP) IFRBKZ
20833C READ (NBERTP) IFBKSP
20834C READ (NBERTP) IFBKST
20835C READ (NBERTP) EEXFBK
20836C CLOSE (UNIT=NBERTP)
20837 DO 100 JZ = 1, 130
20838 SHENUC ( JZ, 1 ) = EMVGEV * ( CAM2 (JZ) + CAM4 (JZ) )
20839 100 CONTINUE
20840 DO 200 JA = 1, 200
20841 SHENUC ( JA, 2 ) = EMVGEV * ( CAM3 (JA) + CAM5 (JA) )
20842 200 CONTINUE
20843 CALL DT_STALIN
20844 IF ( ILVMOD .LE. 0 ) THEN
20845 ILVMOD = IB0
20846 ELSE
20847 IB0 = ILVMOD
20848 END IF
20849 IF ( LLVMOD ) THEN
20850 DO 300 JZ = 1, IZCOOK
20851 CAM4 (JZ) = PZCOOK (JZ)
20852 300 CONTINUE
20853 DO 400 JN = 1, INCOOK
20854 CAM5 (JN) = PNCOOK (JZ)
20855 400 CONTINUE
20856 END IF
20857**sr
20858 IF (LEVPRT) THEN
20859 WRITE (LUNOUT,*)
20860 IF ( ILVMOD .EQ. 1 ) THEN
20861 WRITE (LUNOUT,*)
20862 & ' **** Standard EVAP T=0 level density used ****'
20863 ELSE IF ( ILVMOD .EQ. 2 ) THEN
20864 WRITE (LUNOUT,*)
20865 & ' **** Gilbert & Cameron T=0 N,Z-dep. level density used ****'
20866 ELSE IF ( ILVMOD .EQ. 3 ) THEN
20867 WRITE (LUNOUT,*)
20868 & ' **** Julich A-dependent level density used ****'
20869 ELSE IF ( ILVMOD .EQ. 4 ) THEN
20870 WRITE (LUNOUT,*)
20871 & ' **** Brancazio & Cameron T=0 N,Z-dep. level density used',
20872 & ' ****'
20873 ELSE
20874 WRITE (LUNOUT,*)
20875 & ' **** Unknown T=0 level density option requested ****'
20876 STOP 'BERTTP-ILVMOD'
20877 END IF
20878 IF ( JLVMOD .LE. 0 ) THEN
20879 GAMIGN = ZERZER
20880 WRITE (LUNOUT,*)
20881 & ' **** No Excitation en. dependence for level densities ****'
20882 ELSE IF ( JLVMOD .EQ. 1 ) THEN
20883 WRITE (LUNOUT,*)
20884 & ' **** Ignyatuk (1975, 1st) level density en. dep. used ****'
20885 WRITE (LUNOUT,*)
20886 & ' **** with Ignyatuk (1975, 1st) set of parameters for T=oo',
20887 & ' ****'
20888 GAMIGN = 0.054D+00
20889 BETIGN = -6.3 D-05
20890 ALPIGN = 0.154D+00
20891 POWIGN = ZERZER
20892 ELSE IF ( JLVMOD .EQ. 2 ) THEN
20893 WRITE (LUNOUT,*)
20894 & ' **** Ignyatuk (1975, 1st) level density en. dep. used ****'
20895 WRITE (LUNOUT,*)
20896 & ' **** with UNKNOWN set of parameters for T=oo ****'
20897 STOP 'BERTTP-JLVMOD'
20898 ELSE IF ( JLVMOD .EQ. 3 ) THEN
20899 WRITE (LUNOUT,*)
20900 & ' **** Ignyatuk (1975, 1st) level density en. dep. used ****'
20901 WRITE (LUNOUT,*)
20902 & ' **** with UNKNOWN set of parameters for T=oo ****'
20903 STOP 'BERTTP-JLVMOD'
20904 ELSE IF ( JLVMOD .EQ. 4 ) THEN
20905 WRITE (LUNOUT,*)
20906 & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****'
20907 WRITE (LUNOUT,*)
20908 & ' **** with Ignyatuk (1975, 2nd) set of parameters for T=oo',
20909 & ' ****'
20910 GAMIGN = 0.054D+00
20911 BETIGN = 0.162D+00
20912 ALPIGN = 0.114D+00
20913 POWIGN = -ONETHI
20914 ELSE IF ( JLVMOD .EQ. 5 ) THEN
20915 WRITE (LUNOUT,*)
20916 & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****'
20917 WRITE (LUNOUT,*)
20918 & ' **** with Iljinov & Mebel 1st set of parameters for T=oo****'
20919 GAMIGN = 0.051D+00
20920 BETIGN = 0.098D+00
20921 ALPIGN = 0.114D+00
20922 POWIGN = -ONETHI
20923 ELSE IF ( JLVMOD .EQ. 6 ) THEN
20924 WRITE (LUNOUT,*)
20925 & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****'
20926 WRITE (LUNOUT,*)
20927 & ' **** with Iljinov & Mebel 2nd set of parameters for T=oo****'
20928 GAMIGN = -0.46D+00
20929 BETIGN = 0.107D+00
20930 ALPIGN = 0.111D+00
20931 POWIGN = -ONETHI
20932 ELSE IF ( JLVMOD .EQ. 7 ) THEN
20933 WRITE (LUNOUT,*)
20934 & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****'
20935 WRITE (LUNOUT,*)
20936 & ' **** with Iljinov & Mebel 3rd set of parameters for T=oo****'
20937 GAMIGN = 0.059D+00
20938 BETIGN = 0.257D+00
20939 ALPIGN = 0.072D+00
20940 POWIGN = -ONETHI
20941 ELSE IF ( JLVMOD .EQ. 8 ) THEN
20942 WRITE (LUNOUT,*)
20943 & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****'
20944 WRITE (LUNOUT,*)
20945 & ' **** with Iljinov & Mebel 4th set of parameters for T=oo****'
20946 GAMIGN = -0.37D+00
20947 BETIGN = 0.229D+00
20948 ALPIGN = 0.077D+00
20949 POWIGN = -ONETHI
20950 ELSE
20951 WRITE (LUNOUT,*)
20952 & ' **** Unknown T=oo level density option requested ****'
20953 STOP 'BERTTP-JLVMOD'
20954 END IF
20955 IF ( LLVMOD ) THEN
20956 WRITE (LUNOUT,*)
20957 & ' **** Cook''s modified pairing energy used ****'
20958 ELSE
20959 WRITE (LUNOUT,*)
20960 & ' **** Original Gilbert/Cameron pairing energy used ****'
20961 END IF
20962 ENDIF
20963**
20964
20965 ILVMOD = IB0
20966 DO 500 JZ = 1, 130
20967 PAENUC ( JZ, 1 ) = EMVGEV * CAM4 (JZ)
20968 500 CONTINUE
20969 DO 600 JA = 1, 200
20970 PAENUC ( JA, 2 ) = EMVGEV * CAM5 (JA)
20971 600 CONTINUE
20972 RETURN
20973 END
20974
20975*$ CREATE DT_EVEVAP.FOR
20976*COPY DT_EVEVAP
20977*
20978*====evevap============================================================*
20979*
20980 SUBROUTINE DT_EVEVAP(WE)
20981
20982 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20983 SAVE
20984 PARAMETER ( LINP = 10 ,
20985 & LOUT = 6 ,
20986 & LDAT = 9 )
20987
20988* flags for input different options
20989 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
20990 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
20991 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
20992
20993 LEVAPO = .FALSE.
20994
20995 RETURN
20996 END
20997
20998*$ CREATE DT_FRBKIN.FOR
20999*COPY DT_FRBKIN
21000*
21001*====frbkin============================================================*
21002*
21003 SUBROUTINE DT_FRBKIN(LDUM1,LDUM2)
21004
21005 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21006 SAVE
21007 PARAMETER ( LINP = 10 ,
21008 & LOUT = 6 ,
21009 & LDAT = 9 )
21010
21011 LOGICAL LDUM1,LDUM2
21012
21013 RETURN
21014 END
21015
21016*$ CREATE DT_EXPLOD.FOR
21017*COPY DT_EXPLOD
21018*
21019*=== explod ===========================================================*
21020*
21021 SUBROUTINE DT_EXPLOD( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
21022 & PYEXPL, PZEXPL )
21023
21024 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21025 SAVE
21026
21027 DIMENSION PXEXPL (NPEXPL), PYEXPL (NPEXPL), PZEXPL (NPEXPL),
21028 & ETEXPL (NPEXPL), AMEXPL (NPEXPL)
21029
21030 RETURN
21031 END
21032
21033************************************************************************
21034* *
21035* DPMJET 3.0: cross section routines *
21036* *
21037************************************************************************
21038*
21039*
21040* SUBROUTINE DT_SHNDIF
21041* diffractive cross sections (all energies)
21042* SUBROUTINE DT_PHOXS
21043* total and inel. cross sections from PHOJET interpol. tables
21044* SUBROUTINE DT_XSHN
21045* total and el. cross sections for all energies
21046* SUBROUTINE DT_SIHNAB
21047* pion 2-nucleon absorption cross sections
21048* SUBROUTINE DT_SIGEMU
21049* cross section for target "compounds"
21050* SUBROUTINE DT_SIGGA
21051* photon nucleus cross sections
21052* SUBROUTINE DT_SIGGAT
21053* photon nucleus cross sections from tables
21054* SUBROUTINE DT_SANO
21055* anomalous hard photon-nucleon cross sections from tables
21056* SUBROUTINE DT_SIGGP
21057* photon nucleon cross sections
21058* SUBROUTINE DT_SIGVEL
21059* quasi-elastic vector meson prod. cross sections
21060* DOUBLE PRECISION FUNCTION DT_SIGVP
21061* sigma_VN(tilde)
21062* DOUBLE PRECISION FUNCTION DT_RRM2
21063* DOUBLE PRECISION FUNCTION DT_RM2
21064* DOUBLE PRECISION FUNCTION DT_SAM2
21065* SUBROUTINE DT_CKMT
21066* SUBROUTINE DT_CKMTX
21067* SUBROUTINE DT_PDF0
21068* SUBROUTINE DT_CKMTQ0
21069* SUBROUTINE DT_CKMTDE
21070* SUBROUTINE DT_CKMTPR
21071* FUNCTION DT_CKMTFF
21072*
21073* SUBROUTINE DT_FLUINI
21074* total nucleon cross section fluctuation treatment
21075*
21076* SUBROUTINE DT_SIGTBL
21077* pre-tabulation of low-energy elastic x-sec. using SIHNEL
21078* SUBROUTINE DT_XSTABL
21079* service routines
21080*
21081*
21082*$ CREATE DT_SHNDIF.FOR
21083*COPY DT_SHNDIF
21084*
21085*===shndif===============================================================*
21086*
21087 SUBROUTINE DT_SHNDIF(ECM,KPROJ,KTARG,SIGDIF,SIGDIH)
21088
21089**********************************************************************
21090* Single diffractive hadron-nucleon cross sections *
21091* S.Roesler 14/1/93 *
21092* *
21093* The cross sections are calculated from extrapolated single *
21094* diffractive antiproton-proton cross sections (DTUJET92) using *
21095* scaling relations between total and single diffractive cross *
21096* sections. *
21097**********************************************************************
21098
21099 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21100 SAVE
21101 PARAMETER (ZERO=0.0D0)
21102
21103* particle properties (BAMJET index convention)
21104 CHARACTER*8 ANAME
21105 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21106 & IICH(210),IIBAR(210),K1(210),K2(210)
21107*
21108 CSD1 = 4.201483727D0
21109 CSD4 = -0.4763103556D-02
21110 CSD5 = 0.4324148297D0
21111*
21112 CHMSD1 = 0.8519297242D0
21113 CHMSD4 = -0.1443076599D-01
21114 CHMSD5 = 0.4014954567D0
21115*
21116 EPN = (ECM**2 -AAM(KPROJ)**2 -AAM(KTARG)**2)/(2.0D0*AAM(KTARG))
21117 PPN = SQRT((EPN-AAM(KPROJ))*(EPN+AAM(KPROJ)))
21118*
21119 SDIAPP = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
21120 SHMSD = CHMSD1+CHMSD4*LOG(PPN)**2+CHMSD5*LOG(PPN)
21121 FRAC = SHMSD/SDIAPP
21122*
21123 GOTO( 10, 20,999,999,999,999,999, 10, 20,999,
21124 & 999, 20, 20, 20, 20, 20, 10, 20, 20, 10,
21125 & 10, 10, 20, 20, 20) KPROJ
21126*
21127 10 CONTINUE
21128*---------------------------- p - p , n - p , sigma0+- - p ,
21129* Lambda - p
21130 CSD1 = 6.004476070D0
21131 CSD4 = -0.1257784606D-03
21132 CSD5 = 0.2447335720D0
21133 SIGDIF = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
21134 SIGDIH = FRAC*SIGDIF
21135 RETURN
21136*
21137 20 CONTINUE
21138*
21139 KPSCAL = 2
21140 KTSCAL = 1
21141C F = SDIAPP/DT_SHNTOT(KPSCAL,KTSCAL,ECM,ZERO)
21142 DUMZER = ZERO
21143 CALL DT_XSHN(KPSCAL,KTSCAL,DUMZER,ECM,SIGTO,SIGEL)
21144 F = SDIAPP/SIGTO
21145 KT = 1
21146C SIGDIF = DT_SHNTOT(KPROJ,KT,ECM,ZERO)*F
21147 CALL DT_XSHN(KPROJ,KT,DUMZER,ECM,SIGTO,SIGEL)
21148 SIGDIF = SIGTO*F
21149 SIGDIH = FRAC*SIGDIF
21150 RETURN
21151*
21152 999 CONTINUE
21153*-------------------------- leptons..
21154 SIGDIF = 1.D-10
21155 SIGDIH = 1.D-10
21156 RETURN
21157 END
21158
21159*$ CREATE DT_PHOXS.FOR
21160*COPY DT_PHOXS
21161*
21162*===phoxs================================================================*
21163*
21164 SUBROUTINE DT_PHOXS(KPROJ,KTARG,ECM,PLAB,STOT,SINE,SDIF1,BEL,MODE)
21165
21166************************************************************************
21167* Total/inelastic proton-nucleon cross sections taken from PHOJET- *
21168* interpolation tables. *
21169* This version dated 05.11.97 is written by S. Roesler *
21170************************************************************************
21171
21172 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21173 SAVE
21174
21175 PARAMETER ( LINP = 10 ,
21176 & LOUT = 6 ,
21177 & LDAT = 9 )
21178 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21179 PARAMETER (TWOPI = 6.283185307179586454D+00,
21180 & PI = TWOPI/TWO,
21181 & GEV2MB = 0.38938D0)
21182
21183 LOGICAL LFIRST
21184 DATA LFIRST /.TRUE./
21185
21186* nucleon-nucleon event-generator
21187 CHARACTER*8 CMODEL
21188 LOGICAL LPHOIN
21189 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21190* particle properties (BAMJET index convention)
21191 CHARACTER*8 ANAME
21192 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21193 & IICH(210),IIBAR(210),K1(210),K2(210)
21194
21195**PHOJET105a
21196C PARAMETER (IEETAB=10)
21197C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
21198**PHOJET110
21199C energy-interpolation table
21200 INTEGER IEETA2
21201 PARAMETER ( IEETA2 = 20 )
21202 INTEGER ISIMAX
21203 DOUBLE PRECISION SIGTAB,SIGECM
21204 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
21205**
21206
21207 IF ((MCGENE.NE.2).AND.(MODE.NE.1)) THEN
21208 WRITE(LOUT,*) MCGENE
21209 1000 FORMAT(1X,'PHOXS: warning! PHOJET not initialized (',I2,')')
21210 STOP
21211 ENDIF
21212
21213 IF (ECM.LE.ZERO) THEN
21214 EPN = SQRT(AAM(KPROJ)**2+PLAB**2)
21215 ECM = SQRT(AAM(KPROJ)**2+AAM(KTARG)**2+2.0D0*EPN*AAM(KTARG))
21216 ENDIF
21217
21218 IF (MODE.EQ.1) THEN
21219* DL
21220 DELDL = 0.0808D0
21221 EPSDL = -0.4525D0
21222 S = ECM*ECM
21223 STOT = 21.7D0*S**DELDL+56.08D0*S**EPSDL
21224 ALPHAP= 0.25D0
21225 BEL = 8.5D0+2.D0*ALPHAP*LOG(S)
21226 SIGEL = STOT**2/(16.D0*PI*BEL*GEV2MB)
21227 SINE = STOT-SIGEL
21228 SDIF1 = ZERO
21229 ELSE
21230* Phojet
21231 IP = 1
21232 IF(ECM.LE.SIGECM(IP,1)) THEN
21233 I1 = 1
21234 I2 = 1
21235 ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
21236 DO 1 I=2,ISIMAX
21237 IF (ECM.LE.SIGECM(IP,I)) GOTO 2
21238 1 CONTINUE
21239 2 CONTINUE
21240 I1 = I-1
21241 I2 = I
21242 ELSE
21243 IF (LFIRST) THEN
21244 WRITE(LOUT,'(/1X,A,2E12.3)')
21245 & 'PHOXS: warning! energy above initialization limit (',
21246 & ECM,SIGECM(IP,ISIMAX)
21247 LFIRST = .FALSE.
21248 ENDIF
21249 I1 = ISIMAX
21250 I2 = ISIMAX
21251 ENDIF
21252 FAC2 = ZERO
21253 IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
21254 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
21255 FAC1 = ONE-FAC2
21256 STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
21257 SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
21258 SDIF1 = FAC2*(SIGTAB(IP,30,I2)+SIGTAB(IP,32,I2))+
21259 & FAC1*(SIGTAB(IP,30,I1)+SIGTAB(IP,32,I1))
21260 BEL = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
21261 ENDIF
21262
21263 RETURN
21264 END
21265
21266*$ CREATE DT_XSHN.FOR
21267*COPY DT_XSHN
21268*
21269*===xshn===============================================================*
21270*
21271 SUBROUTINE DT_XSHN(IP,IT,PL,ECM,STOT,SELA)
21272
21273************************************************************************
21274* Total and elastic hadron-nucleon cross section. *
21275* Below 500GeV cross sections are based on the '98 data compilation *
21276* of the PDG. At higher energies PHOJET results are used (patched to *
21277* the low energy data at 500GeV). *
21278* IP projectile index (BAMJET numbering scheme) *
21279* (should be in the range 1..25) *
21280* IT target index (BAMJET numbering scheme) *
21281* (1 = proton, 8 = neutron) *
21282* PL laboratory momentum *
21283* ECM cm. energy (ignored if PL>0) *
21284* STOT total cross section *
21285* SELA elastic cross section *
21286* Last change: 24.4.99 by S. Roesler *
21287************************************************************************
21288
21289 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21290 SAVE
21291
21292 PARAMETER ( LINP = 10 ,
21293 & LOUT = 6 ,
21294 & LDAT = 9 )
21295 PARAMETER (ZERO=0.0D0,ONE=1.0D0)
21296
21297 PARAMETER (NPOIN1 = 54, NPOIN2 = 8,
21298 & PLABLO = 0.1D0, PTHRE = 5.0D0, PLABHI = 500.0D0)
21299 PARAMETER (NPOINT = NPOIN1+NPOIN2+1)
21300
21301 LOGICAL LFIRST
21302* particle properties (BAMJET index convention)
21303 CHARACTER*8 ANAME
21304 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21305 & IICH(210),IIBAR(210),K1(210),K2(210)
21306* nucleon-nucleon event-generator
21307 CHARACTER*8 CMODEL
21308 LOGICAL LPHOIN
21309 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21310**PHOJET105a
21311C PARAMETER (IEETAB=10)
21312C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
21313**PHOJET110
21314C energy-interpolation table
21315 INTEGER IEETA2
21316 PARAMETER ( IEETA2 = 20 )
21317 INTEGER ISIMAX
21318 DOUBLE PRECISION SIGTAB,SIGECM
21319 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
21320
21321 DIMENSION APL(NPOINT),ASIGTO(10,NPOINT),ASIGEL(10,NPOINT)
21322 DIMENSION IDXDAT(25,2)
21323*
21324 DATA APL /
21325 &-1.000,-0.969,-0.937,-0.906,-0.874,-0.843,-0.811,-0.780,-0.748,
21326 &-0.717,-0.685,-0.654,-0.622,-0.591,-0.560,-0.528,-0.497,-0.465,
21327 &-0.434,-0.402,-0.371,-0.339,-0.308,-0.276,-0.245,-0.213,-0.182,
21328 &-0.151,-0.119,-0.088,-0.056,-0.025, 0.007, 0.038, 0.070, 0.101,
21329 & 0.133, 0.164, 0.196, 0.227, 0.258, 0.290, 0.321, 0.353, 0.384,
21330 & 0.416, 0.447, 0.479, 0.510, 0.542, 0.573, 0.605, 0.636, 0.668,
21331 & 0.699, 0.949, 1.199, 1.449, 1.699, 1.949, 2.199, 2.449, 2.699/
21332*
21333* total cross sections:
21334* p p
21335 DATA (ASIGTO(1,K),K=1,NPOINT) /
21336 & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
21337 & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
21338 & 1.577, 1.518, 1.462, 1.420, 1.393, 1.375, 1.363, 1.356, 1.352,
21339 & 1.350, 1.351, 1.359, 1.381, 1.410, 1.444, 1.487, 1.544, 1.596,
21340 & 1.650, 1.672, 1.676, 1.677, 1.677, 1.675, 1.675, 1.669, 1.664,
21341 & 1.658, 1.653, 1.645, 1.640, 1.634, 1.630, 1.625, 1.620, 1.617,
21342 & 1.614, 1.602, 1.594, 1.589, 1.581, 1.583, 1.588, 1.596, 1.603/
21343* pbar p
21344 DATA (ASIGTO(2,K),K=1,NPOINT) /
21345 & 2.778, 2.759, 2.739, 2.718, 2.697, 2.675, 2.651, 2.626, 2.598,
21346 & 2.569, 2.537, 2.502, 2.471, 2.443, 2.420, 2.389, 2.361, 2.329,
21347 & 2.313, 2.304, 2.268, 2.244, 2.222, 2.212, 2.178, 2.162, 2.151,
21348 & 2.132, 2.109, 2.097, 2.089, 2.078, 2.063, 2.049, 2.035, 2.024,
21349 & 2.014, 2.004, 1.993, 1.981, 1.970, 1.958, 1.946, 1.933, 1.921,
21350 & 1.909, 1.894, 1.885, 1.871, 1.854, 1.836, 1.825, 1.816, 1.802,
21351 & 1.790, 1.744, 1.694, 1.663, 1.642, 1.614, 1.623, 1.623, 1.630/
21352* n p
21353 DATA (ASIGTO(3,K),K=1,NPOINT) /
21354 & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
21355 & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
21356 & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
21357 & 1.547, 1.534, 1.526, 1.522, 1.520, 1.525, 1.536, 1.550, 1.566,
21358 & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
21359 & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
21360 & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
21361* pi+ p
21362 DATA (ASIGTO(4,K),K=1,NPOINT) /
21363 & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
21364 & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
21365 & 2.001, 1.875, 1.801, 1.665, 1.609, 1.484, 1.412, 1.334, 1.195,
21366 & 1.160, 1.166, 1.208, 1.309, 1.356, 1.394, 1.406, 1.419, 1.473,
21367 & 1.540, 1.596, 1.570, 1.533, 1.516, 1.484, 1.471, 1.478, 1.492,
21368 & 1.497, 1.491, 1.479, 1.465, 1.453, 1.449, 1.450, 1.444, 1.428,
21369 & 1.422, 1.406, 1.384, 1.369, 1.364, 1.369, 1.374, 1.388, 1.395/
21370* pi- p
21371 DATA (ASIGTO(5,K),K=1,NPOINT) /
21372 & 0.458, 0.540, 0.626, 0.718, 0.819, 0.933, 1.063, 1.208, 1.226,
21373 & 1.436, 1.470, 1.594, 1.708, 1.786, 1.852, 1.836, 1.763, 1.679,
21374 & 1.590, 1.492, 1.445, 1.426, 1.423, 1.433, 1.473, 1.506, 1.547,
21375 & 1.660, 1.671, 1.545, 1.591, 1.687, 1.808, 1.656, 1.582, 1.543,
21376 & 1.562, 1.560, 1.537, 1.540, 1.549, 1.557, 1.557, 1.551, 1.535,
21377 & 1.527, 1.511, 1.510, 1.507, 1.500, 1.491, 1.483, 1.478, 1.468,
21378 & 1.463, 1.435, 1.408, 1.394, 1.384, 1.380, 1.383, 1.393, 1.411/
21379* K+ p
21380 DATA (ASIGTO(6,K),K=1,NPOINT) /
21381 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
21382 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
21383 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.096, 1.095,
21384 & 1.098, 1.105, 1.111, 1.139, 1.169, 1.209, 1.248, 1.259, 1.268,
21385 & 1.262, 1.257, 1.254, 1.252, 1.250, 1.249, 1.246, 1.244, 1.244,
21386 & 1.243, 1.240, 1.238, 1.237, 1.236, 1.235, 1.235, 1.236, 1.236,
21387 & 1.236, 1.233, 1.238, 1.248, 1.257, 1.272, 1.292, 1.311, 1.336/
21388* K- p
21389 DATA (ASIGTO(7,K),K=1,NPOINT) /
21390 & 2.003, 2.002, 2.001, 2.000, 1.999, 1.998, 1.998, 1.997, 1.997,
21391 & 1.996, 1.995, 1.993, 1.990, 1.992, 1.974, 1.912, 1.865, 1.847,
21392 & 1.896, 1.950, 1.827, 1.681, 1.637, 1.616, 1.589, 1.545, 1.543,
21393 & 1.532, 1.603, 1.604, 1.616, 1.658, 1.700, 1.658, 1.595, 1.508,
21394 & 1.493, 1.514, 1.531, 1.523, 1.501, 1.479, 1.474, 1.467, 1.463,
21395 & 1.450, 1.444, 1.435, 1.426, 1.424, 1.423, 1.415, 1.401, 1.396,
21396 & 1.384, 1.364, 1.330, 1.313, 1.310, 1.309, 1.317, 1.329, 1.338/
21397* K+ n
21398 DATA (ASIGTO(8,K),K=1,NPOINT) /
21399 & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21400 & 0.631, 0.675, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21401 & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.102, 1.125, 1.147,
21402 & 1.168, 1.187, 1.205, 1.224, 1.248, 1.279, 1.315, 1.324, 1.301,
21403 & 1.285, 1.279, 1.274, 1.273, 1.272, 1.271, 1.267, 1.263, 1.261,
21404 & 1.259, 1.256, 1.252, 1.247, 1.244, 1.241, 1.240, 1.240, 1.240,
21405 & 1.241, 1.243, 1.245, 1.253, 1.265, 1.275, 1.293, 1.314, 1.342/
21406* K- n
21407 DATA (ASIGTO(9,K),K=1,NPOINT) /
21408 & 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778,
21409 & 1.778, 1.778, 1.778, 1.778, 1.778, 1.779, 1.779, 1.778, 1.773,
21410 & 1.765, 1.746, 1.703, 1.646, 1.561, 1.488, 1.454, 1.437, 1.437,
21411 & 1.458, 1.505, 1.561, 1.588, 1.593, 1.581, 1.551, 1.500, 1.454,
21412 & 1.427, 1.408, 1.390, 1.372, 1.361, 1.356, 1.351, 1.347, 1.343,
21413 & 1.341, 1.340, 1.338, 1.337, 1.335, 1.334, 1.332, 1.331, 1.330,
21414 & 1.330, 1.313, 1.303, 1.288, 1.288, 1.297, 1.305, 1.320, 1.342/
21415* Lambda p
21416 DATA (ASIGTO(10,K),K=1,NPOINT) /
21417 & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21418 & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.629,
21419 & 1.599, 1.576, 1.558, 1.543, 1.530, 1.520, 1.512, 1.505, 1.499,
21420 & 1.495, 1.495, 1.497, 1.504, 1.514, 1.525, 1.536, 1.550, 1.567,
21421 & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
21422 & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
21423 & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
21424*
21425* elastic cross sections:
21426* p p
21427 DATA (ASIGEL(1,K),K=1,NPOINT) /
21428 & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
21429 & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
21430 & 1.577, 1.518, 1.462, 1.420, 1.393, 1.374, 1.360, 1.353, 1.350,
21431 & 1.351, 1.356, 1.362, 1.369, 1.376, 1.384, 1.385, 1.399, 1.397,
21432 & 1.389, 1.385, 1.379, 1.366, 1.358, 1.344, 1.320, 1.294, 1.275,
21433 & 1.260, 1.248, 1.235, 1.219, 1.199, 1.172, 1.144, 1.126, 1.115,
21434 & 1.104, 1.013, 0.962, 0.905, 0.869, 0.845, 0.846, 0.850, 0.868/
21435* pbar p
21436 DATA (ASIGEL(2,K),K=1,NPOINT) /
21437 & 1.987, 1.985, 1.983, 1.980, 1.978, 1.975, 1.971, 1.968, 1.963,
21438 & 1.958, 1.951, 1.944, 1.935, 1.925, 1.914, 1.902, 1.889, 1.875,
21439 & 1.859, 1.845, 1.834, 1.817, 1.792, 1.769, 1.754, 1.738, 1.720,
21440 & 1.702, 1.688, 1.676, 1.667, 1.659, 1.652, 1.645, 1.640, 1.636,
21441 & 1.620, 1.591, 1.562, 1.546, 1.540, 1.524, 1.496, 1.475, 1.457,
21442 & 1.429, 1.402, 1.373, 1.344, 1.330, 1.306, 1.294, 1.265, 1.228,
21443 & 1.204, 1.086, 0.977, 0.933, 0.914, 0.850, 0.862, 0.848, 0.845/
21444* n p
21445 DATA (ASIGEL(3,K),K=1,NPOINT) /
21446 & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
21447 & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
21448 & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
21449 & 1.544, 1.527, 1.514, 1.504, 1.495, 1.486, 1.476, 1.466, 1.454,
21450 & 1.440, 1.425, 1.409, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21451 & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21452 & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21453* pi+ p
21454 DATA (ASIGEL(4,K),K=1,NPOINT) /
21455 & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
21456 & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
21457 & 2.001, 1.875, 1.801, 1.664, 1.610, 1.479, 1.423, 1.299, 1.166,
21458 & 1.097, 1.020, 0.958, 0.914, 1.013, 1.088, 1.153, 1.167, 1.235,
21459 & 1.240, 1.237, 1.202, 1.135, 1.090, 1.026, 0.975, 0.941, 0.904,
21460 & 0.894, 0.884, 0.862, 0.850, 0.845, 0.827, 0.805, 0.789, 0.776,
21461 & 0.763, 0.686, 0.626, 0.562, 0.505, 0.518, 0.525, 0.528, 0.528/
21462* pi- p
21463 DATA (ASIGEL(5,K),K=1,NPOINT) /
21464 & 0.266, 0.278, 0.294, 0.320, 0.360, 0.419, 0.503, 0.608, 0.727,
21465 & 0.850, 0.968, 1.071, 1.167, 1.305, 1.369, 1.404, 1.446, 1.217,
21466 & 1.112, 1.071, 1.014, 1.002, 0.996, 1.008, 1.070, 1.126, 1.209,
21467 & 1.300, 1.281, 1.188, 1.156, 1.341, 1.423, 1.314, 1.171, 1.140,
21468 & 1.106, 1.071, 1.011, 1.037, 1.026, 1.024, 0.988, 0.953, 0.895,
21469 & 0.894, 0.880, 0.871, 0.864, 0.853, 0.837, 0.820, 0.809, 0.800,
21470 & 0.782, 0.674, 0.612, 0.530, 0.521, 0.528, 0.524, 0.542, 0.569/
21471* K+ p
21472 DATA (ASIGEL(6,K),K=1,NPOINT) /
21473 & 1.064, 1.065, 1.065, 1.066, 1.066, 1.066, 1.066, 1.066, 1.066,
21474 & 1.065, 1.064, 1.063, 1.062, 1.062, 1.062, 1.064, 1.066, 1.070,
21475 & 1.076, 1.082, 1.088, 1.096, 1.103, 1.104, 1.104, 1.102, 1.093,
21476 & 1.087, 1.084, 1.079, 1.075, 1.067, 1.058, 1.040, 1.029, 1.012,
21477 & 1.003, 0.985, 0.935, 0.909, 0.880, 0.846, 0.790, 0.771, 0.759,
21478 & 0.743, 0.718, 0.681, 0.666, 0.645, 0.622, 0.606, 0.594, 0.584,
21479 & 0.575, 0.513, 0.453, 0.403, 0.356, 0.365, 0.389, 0.430, 0.477/
21480* K- p
21481 DATA (ASIGEL(7,K),K=1,NPOINT) /
21482 & 1.941, 1.936, 1.931, 1.926, 1.919, 1.912, 1.903, 1.892, 1.878,
21483 & 1.863, 1.844, 1.821, 1.791, 1.755, 1.713, 1.666, 1.615, 1.561,
21484 & 1.533, 1.531, 1.518, 1.511, 1.452, 1.339, 1.265, 1.233, 1.188,
21485 & 1.184, 1.236, 1.316, 1.333, 1.336, 1.333, 1.277, 1.216, 1.077,
21486 & 1.018, 0.912, 0.926, 0.920, 0.910, 0.894, 0.830, 0.825, 0.800,
21487 & 0.788, 0.747, 0.703, 0.707, 0.689, 0.643, 0.633, 0.635, 0.618,
21488 & 0.584, 0.579, 0.461, 0.403, 0.405, 0.399, 0.408, 0.418, 0.413/
21489* K+ n
21490 DATA (ASIGEL(8,K),K=1,NPOINT) /
21491 & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21492 & 0.631, 0.676, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21493 & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.103, 1.126, 1.148,
21494 & 1.168, 1.187, 1.205, 1.223, 1.248, 1.282, 1.269, 1.185, 1.111,
21495 & 1.063, 1.031, 0.998, 0.964, 0.928, 0.889, 0.849, 0.814, 0.785,
21496 & 0.760, 0.738, 0.720, 0.703, 0.688, 0.674, 0.660, 0.648, 0.635,
21497 & 0.624, 0.536, 0.473, 0.442, 0.428, 0.428, 0.436, 0.453, 0.477/
21498* K- n
21499 DATA (ASIGEL(9,K),K=1,NPOINT) /
21500 & 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613,
21501 & 1.613, 1.613, 1.613, 1.612, 1.613, 1.614, 1.614, 1.612, 1.606,
21502 & 1.593, 1.564, 1.498, 1.402, 1.240, 1.071, 0.977, 0.922, 0.914,
21503 & 0.961, 1.077, 1.214, 1.271, 1.290, 1.281, 1.217, 1.096, 0.979,
21504 & 0.896, 0.822, 0.736, 0.655, 0.608, 0.591, 0.580, 0.569, 0.559,
21505 & 0.550, 0.540, 0.531, 0.522, 0.514, 0.507, 0.500, 0.494, 0.489,
21506 & 0.485, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477/
21507* Lambda p
21508 DATA (ASIGEL(10,K),K=1,NPOINT) /
21509 & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21510 & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.630,
21511 & 1.600, 1.577, 1.558, 1.542, 1.528, 1.518, 1.510, 1.505, 1.502,
21512 & 1.501, 1.500, 1.499, 1.496, 1.491, 1.485, 1.477, 1.466, 1.454,
21513 & 1.440, 1.425, 1.408, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21514 & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21515 & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21516
21517 DATA (IDXDAT(K,1),K=1,25) /
21518 & 1, 2, 0, 0, 0, 0, 0, 3, 2, 0, 0,67, 4, 5, 6, 7,10, 2,67, 3,
21519 & 1, 3,45, 8, 9/
21520 DATA (IDXDAT(K,2),K=1,25) /
21521 & 3, 2, 0, 0, 0, 0, 0, 1, 2, 0, 0,89, 5, 4, 8, 9, 1, 2,89, 1,
21522 & 3, 1,45, 6, 7/
21523
21524 DATA LFIRST /.TRUE./
21525
21526 IF (LFIRST) THEN
21527 APLABL = LOG10(PLABLO)
21528 APLABH = LOG10(PLABHI)
21529 APTHRE = LOG10(PTHRE)
21530 ADP1 = (APTHRE-APLABL)/DBLE(NPOIN1)
21531 ADP2 = (APLABH-APTHRE)/DBLE(NPOIN2)
21532 DUM0 = ZERO
21533 PHOPLA = PLABHI
21534 PHOELA = SQRT(AAM(1)**2+PHOPLA**2)
21535 ECMS = SQRT(2.0D0*AAM(1)**2+2.0D0*AAM(1)*PHOELA)
21536 IF (MCGENE.EQ.2) THEN
21537 IF (ECMS.LE.SIGECM(1,ISIMAX)) THEN
21538 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,0)
21539 ELSE
21540 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21541 ENDIF
21542 ELSE
21543 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21544 ENDIF
21545 PHOSEL = PHOSTO-PHOSIN
21546 APHOST = LOG10(PHOSTO)
21547 APHOSE = LOG10(PHOSEL)
21548 LFIRST = .FALSE.
21549 ENDIF
21550 STOT = ZERO
21551 SELA = ZERO
21552 PLAB = PL
21553 ECMS = ECM
21554 IF ( (IP.LT.1).OR.((IT.NE.1).AND.(IT.NE.8)) ) THEN
21555 WRITE(LOUT,1000) IP,IT
21556 1000 FORMAT(1X,'DT_XSHN: cross sections not implemented for ',
21557 & 'proj/target',2I4)
21558 STOP
21559 ENDIF
21560
21561 IF ((PLAB.LE.ZERO).AND.(ECMS.GT.ZERO)) THEN
21562 ELAB = (ECMS**2-AAM(IP)**2-AAM(IT)**2)/(2.0D0*AAM(IT))
21563 PLAB = SQRT((ELAB-AAM(IP))*(ELAB+AAM(IP)))
21564 ELSEIF ((PLAB.LE.ZERO).AND.(ECMS.LE.ZERO)) THEN
21565 WRITE(LOUT,1001) PLAB,ECMS
21566 1001 FORMAT(1X,'DT_XSHN: invalid momentum/cm-energy ',2E15.5)
21567 STOP
21568 ENDIF
21569
21570* index of spectrum
21571 IDXP = IP
21572 IF (IP.GT.25) THEN
21573 IF (AAM(IP).GT.ZERO) THEN
21574 IF (ABS(IIBAR(IP)).GT.0) THEN
21575 IDXP = 1
21576 ELSE
21577 IDXP = 13
21578 ENDIF
21579 ELSE
21580 IDXP = 7
21581 ENDIF
21582 ENDIF
21583 IDXT = 1
21584 IF (IT.EQ.8) IDXT = 2
21585 IDXS = IDXDAT(IDXP,IDXT)
21586 IF (IDXS.EQ.0) RETURN
21587
21588* compute momentum bin indices
21589 IF (PLAB.LT.PLABLO) THEN
21590 IDX0 = 1
21591 IDX1 = 1
21592 ELSEIF (PLAB.GE.PLABHI) THEN
21593 IDX0 = NPOINT
21594 IDX1 = NPOINT
21595 ELSE
21596 APLAB = LOG10(PLAB)
21597 IF ((PLAB.GE.PLABLO).AND.(PLAB.LT.PTHRE )) THEN
21598 IDX0 = INT((APLAB-APLABL)/ADP1)+1
21599 ELSEIF ((PLAB.GE.PTHRE ).AND.(PLAB.LT.PLABHI)) THEN
21600 IDX0 = INT((APLAB-APTHRE)/ADP2)+NPOIN1+1
21601 ENDIF
21602 IDX1 = IDX0+1
21603 ENDIF
21604
21605* interpolate cross section
21606 IF (IDXS.GT.10) THEN
21607 IDXS1 = IDXS/10
21608 IDXS2 = IDXS-10*IDXS1
21609 IF (IDX0.EQ.IDX1) THEN
21610 IF (IDX0.EQ.1) THEN
21611 ASTOT = 0.5D0*(ASIGTO(IDXS1,IDX0)+ASIGTO(IDXS2,IDX0))
21612 ASELA = 0.5D0*(ASIGEL(IDXS1,IDX0)+ASIGEL(IDXS2,IDX0))
21613 ELSE
21614 DUM0 = ZERO
21615 CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21616 PHOSEL = PHOSTO-PHOSIN
21617 ASTOT1 = ASIGTO(IDXS1,NPOINT)-APHOST+LOG10(PHOSTO)
21618 ASELA1 = ASIGEL(IDXS1,NPOINT)-APHOSE+LOG10(PHOSEL)
21619 ASTOT2 = ASIGTO(IDXS2,NPOINT)-APHOST+LOG10(PHOSTO)
21620 ASELA2 = ASIGEL(IDXS2,NPOINT)-APHOSE+LOG10(PHOSEL)
21621 ASTOT = 0.5D0*(ASTOT1+ASTOT2)
21622 ASELA = 0.5D0*(ASELA1+ASELA2)
21623 ENDIF
21624 ELSE
21625 FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21626 ASTOT1 = ASIGTO(IDXS1,IDX0)+
21627 & FAC*(ASIGTO(IDXS1,IDX1)-ASIGTO(IDXS1,IDX0))
21628 ASTOT2 = ASIGTO(IDXS2,IDX0)+
21629 & FAC*(ASIGTO(IDXS2,IDX1)-ASIGTO(IDXS2,IDX0))
21630 ASTOT = 0.5D0*(ASTOT1+ASTOT2)
21631 ASELA1 = ASIGEL(IDXS1,IDX0)+
21632 & FAC*(ASIGEL(IDXS1,IDX1)-ASIGEL(IDXS1,IDX0))
21633 ASELA2 = ASIGEL(IDXS2,IDX0)+
21634 & FAC*(ASIGEL(IDXS2,IDX1)-ASIGEL(IDXS2,IDX0))
21635 ASELA = 0.5D0*(ASELA1+ASELA2)
21636 ENDIF
21637 ELSE
21638 IF (IDX0.EQ.IDX1) THEN
21639 IF (IDX0.EQ.1) THEN
21640 ASTOT = ASIGTO(IDXS,IDX0)
21641 ASELA = ASIGEL(IDXS,IDX0)
21642 ELSE
21643 DUM0 = ZERO
21644 CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21645 PHOSEL = PHOSTO-PHOSIN
21646 ASTOT = ASIGTO(IDXS,NPOINT)-APHOST+LOG10(PHOSTO)
21647 ASELA = ASIGEL(IDXS,NPOINT)-APHOSE+LOG10(PHOSEL)
21648 ENDIF
21649 ELSE
21650 FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21651 ASTOT = ASIGTO(IDXS,IDX0)+
21652 & FAC*(ASIGTO(IDXS,IDX1)-ASIGTO(IDXS,IDX0))
21653 ASELA = ASIGEL(IDXS,IDX0)+
21654 & FAC*(ASIGEL(IDXS,IDX1)-ASIGEL(IDXS,IDX0))
21655 ENDIF
21656 ENDIF
21657 STOT = 10.0D0**ASTOT
21658 SELA = 10.0D0**ASELA
21659
21660 RETURN
21661 END
21662
21663*$ CREATE DT_SIHNAB.FOR
21664*COPY DT_SIHNAB
21665*
21666*===sihnab===============================================================*
21667*
21668 SUBROUTINE DT_SIHNAB(IDP,IDT,PLAB,SIGABS)
21669
21670**********************************************************************
21671* Pion 2-nucleon absorption cross sections. *
21672* (sigma_tot for pi+ d --> p p, pi- d --> n n *
21673* taken from Ritchie PRC 28 (1983) 926 ) *
21674* This version dated 18.05.96 is written by S. Roesler *
21675**********************************************************************
21676
21677 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21678 SAVE
21679 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY3=1.0D-3)
21680 PARAMETER (AMPR = 938.0D0,
21681 & AMPI = 140.0D0,
21682 & AMDE = TWO*AMPR,
21683 & A = -1.2D0,
21684 & B = 3.5D0,
21685 & C = 7.4D0,
21686 & D = 5600.0D0,
21687 & ER = 2136.0D0)
21688
21689 SIGABS = ZERO
21690 IF ( ((IDP.NE.13).AND.(IDP.NE.14).AND.(IDP.NE.23))
21691 & .OR.((IDT.NE.1).AND.(IDT.NE.8)) ) RETURN
21692 PTOT = PLAB*1.0D3
21693 EKIN = SQRT(AMPI**2+PTOT**2)-AMPI
21694 IF ((EKIN.LT.TINY3).OR.(EKIN.GT.400.0D0)) RETURN
21695 ECM = SQRT( (AMPI+AMDE)**2+TWO*EKIN*AMDE )
21696 SIGABS = A+B/SQRT(EKIN)+C*1.0D4/((ECM-ER)**2+D)
21697* approximate 3N-abs., I=1-abs. etc.
21698 SIGABS = SIGABS/0.40D0
21699* pi0-absorption (rough approximation!!)
21700 IF (IDP.EQ.23) SIGABS = 0.5D0*SIGABS
21701
21702 RETURN
21703 END
21704
21705*$ CREATE DT_SIGEMU.FOR
21706*COPY DT_SIGEMU
21707*
21708*===sigemu=============================================================*
21709*
21710 SUBROUTINE DT_SIGEMU
21711
21712************************************************************************
21713* Combined cross section for target compounds. *
21714* This version dated 6.4.98 is written by S. Roesler *
21715************************************************************************
21716
21717 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21718 SAVE
21719 PARAMETER ( LINP = 10 ,
21720 & LOUT = 6 ,
21721 & LDAT = 9 )
21722 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21723 & OHALF=0.5D0,ONE=1.0D0)
21724
21725 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21726* Glauber formalism: cross sections
21727 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21728 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21729 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21730 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21731 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21732 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21733 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21734 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21735 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21736 & BSLOPE,NEBINI,NQBINI
21737* emulsion treatment
21738 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
21739 & NCOMPO,IEMUL
21740* nucleon-nucleon event-generator
21741 CHARACTER*8 CMODEL
21742 LOGICAL LPHOIN
21743 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21744
21745 IF (MCGENE.NE.4) THEN
21746 WRITE(LOUT,'(A)') ' DT_SIGEMU: Combined cross sections'
21747 WRITE(LOUT,'(15X,A)') '-----------------------'
21748 ENDIF
21749 DO 1 IE=1,NEBINI
21750 DO 2 IQ=1,NQBINI
21751 SIGTOT = ZERO
21752 SIGELA = ZERO
21753 SIGQEP = ZERO
21754 SIGQET = ZERO
21755 SIGQE2 = ZERO
21756 SIGPRO = ZERO
21757 SIGDEL = ZERO
21758 SIGDQE = ZERO
21759 ERRTOT = ZERO
21760 ERRELA = ZERO
21761 ERRQEP = ZERO
21762 ERRQET = ZERO
21763 ERRQE2 = ZERO
21764 ERRPRO = ZERO
21765 ERRDEL = ZERO
21766 ERRDQE = ZERO
21767 IF (NCOMPO.GT.0) THEN
21768 DO 3 IC=1,NCOMPO
21769 SIGTOT = SIGTOT+EMUFRA(IC)*XSTOT(IE,IQ,IC)
21770 SIGELA = SIGELA+EMUFRA(IC)*XSELA(IE,IQ,IC)
21771 SIGQEP = SIGQEP+EMUFRA(IC)*XSQEP(IE,IQ,IC)
21772 SIGQET = SIGQET+EMUFRA(IC)*XSQET(IE,IQ,IC)
21773 SIGQE2 = SIGQE2+EMUFRA(IC)*XSQE2(IE,IQ,IC)
21774 SIGPRO = SIGPRO+EMUFRA(IC)*XSPRO(IE,IQ,IC)
21775 SIGDEL = SIGDEL+EMUFRA(IC)*XSDEL(IE,IQ,IC)
21776 SIGDQE = SIGDQE+EMUFRA(IC)*XSDQE(IE,IQ,IC)
21777 ERRTOT = ERRTOT+XETOT(IE,IQ,IC)**2
21778 ERRELA = ERRELA+XEELA(IE,IQ,IC)**2
21779 ERRQEP = ERRQEP+XEQEP(IE,IQ,IC)**2
21780 ERRQET = ERRQET+XEQET(IE,IQ,IC)**2
21781 ERRQE2 = ERRQE2+XEQE2(IE,IQ,IC)**2
21782 ERRPRO = ERRPRO+XEPRO(IE,IQ,IC)**2
21783 ERRDEL = ERRDEL+XEDEL(IE,IQ,IC)**2
21784 ERRDQE = ERRDQE+XEDQE(IE,IQ,IC)**2
21785 3 CONTINUE
21786 ERRTOT = SQRT(ERRTOT)
21787 ERRELA = SQRT(ERRELA)
21788 ERRQEP = SQRT(ERRQEP)
21789 ERRQET = SQRT(ERRQET)
21790 ERRQE2 = SQRT(ERRQE2)
21791 ERRPRO = SQRT(ERRPRO)
21792 ERRDEL = SQRT(ERRDEL)
21793 ERRDQE = SQRT(ERRDQE)
21794 ELSE
21795 SIGTOT = XSTOT(IE,IQ,1)
21796 SIGELA = XSELA(IE,IQ,1)
21797 SIGQEP = XSQEP(IE,IQ,1)
21798 SIGQET = XSQET(IE,IQ,1)
21799 SIGQE2 = XSQE2(IE,IQ,1)
21800 SIGPRO = XSPRO(IE,IQ,1)
21801 SIGDEL = XSDEL(IE,IQ,1)
21802 SIGDQE = XSDQE(IE,IQ,1)
21803 ERRTOT = XETOT(IE,IQ,1)
21804 ERRELA = XEELA(IE,IQ,1)
21805 ERRQEP = XEQEP(IE,IQ,1)
21806 ERRQET = XEQET(IE,IQ,1)
21807 ERRQE2 = XEQE2(IE,IQ,1)
21808 ERRPRO = XEPRO(IE,IQ,1)
21809 ERRDEL = XEDEL(IE,IQ,1)
21810 ERRDQE = XEDQE(IE,IQ,1)
21811 ENDIF
21812 IF (MCGENE.NE.4) THEN
21813 WRITE(LOUT,1000) ECMNN(IE),Q2G(IQ)
21814 1000 FORMAT(/,1X,'E_cm =',F9.1,' GeV Q^2 =',F6.1,' GeV^2 :',/)
21815 WRITE(LOUT,1001) SIGTOT,ERRTOT
21816 1001 FORMAT(1X,'total',32X,F10.4,' +-',F11.5,' mb')
21817 WRITE(LOUT,1002) SIGELA,ERRELA
21818 1002 FORMAT(1X,'elastic',30X,F10.4,' +-',F11.5,' mb')
21819 WRITE(LOUT,1003) SIGQEP,ERRQEP
21820 1003 FORMAT(1X,'quasi-elastic (A+B-->A+X)',12X,F10.4,' +-',
21821 & F11.5,' mb')
21822 WRITE(LOUT,1004) SIGQET,ERRQET
21823 1004 FORMAT(1X,'quasi-elastic (A+B-->X+B)',12X,F10.4,' +-',
21824 & F11.5,' mb')
21825 WRITE(LOUT,1005) SIGQE2,ERRQE2
21826 1005 FORMAT(1X,'quasi-elastic (A+B-->X, excl. 2-4)',3X,F10.4,
21827 & ' +-',F11.5,' mb')
21828 WRITE(LOUT,1006) SIGPRO,ERRPRO
21829 1006 FORMAT(1X,'production',27X,F10.4,' +-',F11.5,' mb')
21830 WRITE(LOUT,1007) SIGDEL,ERRDEL
21831 1007 FORMAT(1X,'diff-el ',27X,F10.4,' +-',F11.5,' mb')
21832 WRITE(LOUT,1008) SIGDQE,ERRDQE
21833 1008 FORMAT(1X,'diff-qel ',27X,F10.4,' +-',F11.5,' mb')
21834 ENDIF
21835
21836 2 CONTINUE
21837 1 CONTINUE
21838
21839 RETURN
21840 END
21841
21842*$ CREATE DT_SIGGA.FOR
21843*COPY DT_SIGGA
21844*
21845*===sigga==============================================================*
21846*
21847 SUBROUTINE DT_SIGGA(NTI,XI,Q2I,ECMI,XNUI,STOT,ETOT,SIN,EIN,STOT0)
21848
21849************************************************************************
21850* Total/inelastic photon-nucleus cross sections. *
21851* !!!! Overwrites SHMAKI-initialization. Do not use it during *
21852* production runs !!!! *
21853* This version dated 27.03.96 is written by S. Roesler *
21854************************************************************************
21855
21856 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21857 SAVE
21858 PARAMETER ( LINP = 10 ,
21859 & LOUT = 6 ,
21860 & LDAT = 9 )
21861 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21862 & OHALF=0.5D0,ONE=1.0D0)
21863 PARAMETER (AMPROT = 0.938D0)
21864
21865 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21866* Glauber formalism: cross sections
21867 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21868 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21869 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21870 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21871 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21872 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21873 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21874 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21875 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21876 & BSLOPE,NEBINI,NQBINI
21877
21878 NT = NTI
21879 X = XI
21880 Q2 = Q2I
21881 ECM = ECMI
21882 XNU = XNUI
21883 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21884 & ECM = SQRT(AMPROT**2-Q2+2.0D0*XNUI*AMPROT)
21885 CALL DT_XSGLAU(1,NT,7,X,Q2,ECM,1,1,-1)
21886 STOT = XSTOT(1,1,1)
21887 ETOT = XETOT(1,1,1)
21888 SIN = XSPRO(1,1,1)
21889 EIN = XEPRO(1,1,1)
21890
21891 RETURN
21892 END
21893
21894*$ CREATE DT_SIGGAT.FOR
21895*COPY DT_SIGGAT
21896*
21897*===siggat=============================================================*
21898*
21899 SUBROUTINE DT_SIGGAT(Q2I,ECMI,STOT,NT)
21900
21901************************************************************************
21902* Total/inelastic photon-nucleus cross sections. *
21903* Uses pre-tabulated cross section. *
21904* This version dated 29.07.96 is written by S. Roesler *
21905************************************************************************
21906
21907 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21908 SAVE
21909 PARAMETER ( LINP = 10 ,
21910 & LOUT = 6 ,
21911 & LDAT = 9 )
21912 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21913 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21914
21915 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21916* Glauber formalism: cross sections
21917 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21918 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21919 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21920 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21921 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21922 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21923 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21924 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21925 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21926 & BSLOPE,NEBINI,NQBINI
21927
21928 NTARG = ABS(NT)
21929 I1 = 1
21930 I2 = 1
21931 RATE = ONE
21932 IF (NEBINI.GT.1) THEN
21933 IF (ECMI.GE.ECMNN(NEBINI)) THEN
21934 I1 = NEBINI
21935 I2 = NEBINI
21936 RATE = ONE
21937 ELSEIF (ECMI.GT.ECMNN(1)) THEN
21938 DO 1 I=2,NEBINI
21939 IF (ECMI.LT.ECMNN(I)) THEN
21940 I1 = I-1
21941 I2 = I
21942 RATE = (ECMI-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
21943 GOTO 2
21944 ENDIF
21945 1 CONTINUE
21946 2 CONTINUE
21947 ENDIF
21948 ENDIF
21949 J1 = 1
21950 J2 = 1
21951 RATQ = ONE
21952 IF (NQBINI.GT.1) THEN
21953 IF (Q2I.GE.Q2G(NQBINI)) THEN
21954 J1 = NQBINI
21955 J2 = NQBINI
21956 RATQ = ONE
21957 ELSEIF (Q2I.GT.Q2G(1)) THEN
21958 DO 3 I=2,NQBINI
21959 IF (Q2I.LT.Q2G(I)) THEN
21960 J1 = I-1
21961 J2 = I
21962 RATQ = LOG10( Q2I/MAX(Q2G(J1),TINY14))/
21963 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
21964C RATQ = (Q2I-Q2G(J1))/(Q2G(J2)-Q2G(J1))
21965 GOTO 4
21966 ENDIF
21967 3 CONTINUE
21968 4 CONTINUE
21969 ENDIF
21970 ENDIF
21971
21972 STOT = XSTOT(I1,J1,NTARG)+
21973 & RATE*(XSTOT(I2,J1,NTARG)-XSTOT(I1,J1,NTARG))+
21974 & RATQ*(XSTOT(I1,J2,NTARG)-XSTOT(I1,J1,NTARG))+
21975 & RATE*RATQ*(XSTOT(I2,J2,NTARG)-XSTOT(I1,J2,NTARG)+
21976 & XSTOT(I1,J1,NTARG)-XSTOT(I2,J1,NTARG))
21977
21978 RETURN
21979 END
21980
21981*$ CREATE DT_SANO.FOR
21982*COPY DT_SANO
21983*
21984*===sigano=============================================================*
21985*
21986 DOUBLE PRECISION FUNCTION DT_SANO(ECM)
21987
21988************************************************************************
21989* This version dated 31.07.96 is written by S. Roesler *
21990************************************************************************
21991
21992 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21993 SAVE
21994 PARAMETER ( LINP = 10 ,
21995 & LOUT = 6 ,
21996 & LDAT = 9 )
21997 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21998 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21999 PARAMETER (NE = 8)
22000
22001* VDM parameter for photon-nucleus interactions
22002 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22003* properties of interacting particles
22004 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
22005
22006 DIMENSION ECMANO(NE),FRAANO(NE),SIGHRD(NE)
22007 DATA ECMANO /
22008 & 0.200D+02,0.500D+02,0.100D+03,0.200D+03,0.500D+03,
22009 & 0.100D+04,0.200D+04,0.500D+04
22010 & /
22011* fixed cut (3 GeV/c)
22012 DATA FRAANO /
22013 & 0.085D+00,0.114D+00,0.105D+00,0.091D+00,0.073D+00,
22014 & 0.062D+00,0.054D+00,0.042D+00
22015 & /
22016 DATA SIGHRD /
22017 & 4.0099D-04,3.3104D-03,1.1905D-02,3.6435D-02,1.3493D-01,
22018 & 3.3086D-01,7.6255D-01,2.1319D+00
22019 & /
22020* running cut (based on obsolete Phojet-caluclations, bugs..)
22021C DATA FRAANO /
22022C & 0.251E+00,0.313E+00,0.279E+00,0.239E+00,0.186E+00,
22023C & 0.167E+00,0.150E+00,0.131E+00
22024C & /
22025C DATA SIGHRD /
22026C & 6.6569E-04,4.4949E-03,1.4837E-02,4.1466E-02,1.5071E-01,
22027C & 2.5736E-01,4.5593E-01,8.2550E-01
22028C & /
22029
22030 DT_SANO = ZERO
22031 IF ((ISHAD(2).NE.1).OR.(IJPROJ.NE.7)) RETURN
22032 J1 = 0
22033 J2 = 0
22034 RATE = ONE
22035 IF (ECM.GE.ECMANO(NE)) THEN
22036 J1 = NE
22037 J2 = NE
22038 ELSEIF (ECM.GT.ECMANO(1)) THEN
22039 DO 1 IE=2,NE
22040 IF (ECM.LT.ECMANO(IE)) THEN
22041 J1 = IE-1
22042 J2 = IE
22043 RATE = LOG10(ECM/ECMANO(J1))/LOG10(ECMANO(J2)/ECMANO(J1))
22044 GOTO 2
22045 ENDIF
22046 1 CONTINUE
22047 2 CONTINUE
22048 ENDIF
22049 IF ((J1.GT.0).AND.(J2.GT.0)) THEN
22050 AFRA1 = LOG10(MAX(FRAANO(J1)*SIGHRD(J1),TINY14))
22051 AFRA2 = LOG10(MAX(FRAANO(J2)*SIGHRD(J2),TINY14))
22052 DT_SANO = 10.0D0**(AFRA1+RATE*(AFRA2-AFRA1))
22053 ENDIF
22054
22055 RETURN
22056 END
22057
22058*$ CREATE DT_SIGGP.FOR
22059*COPY DT_SIGGP
22060*
22061*===siggp==============================================================*
22062*
22063 SUBROUTINE DT_SIGGP(XI,Q2I,ECMI,XNUI,STOT,SINE,SDIR)
22064
22065************************************************************************
22066* Total/inelastic photon-nucleon cross sections. *
22067* This version dated 30.04.96 is written by S. Roesler *
22068************************************************************************
22069
22070 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22071 SAVE
22072 PARAMETER ( LINP = 10 ,
22073 & LOUT = 6 ,
22074 & LDAT = 9 )
22075 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22076 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22077 & PI = TWOPI/TWO,
22078 & GEV2MB = 0.38938D0,
22079 & ALPHEM = ONE/137.0D0)
22080
22081* particle properties (BAMJET index convention)
22082 CHARACTER*8 ANAME
22083 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22084 & IICH(210),IIBAR(210),K1(210),K2(210)
22085* VDM parameter for photon-nucleus interactions
22086 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22087
22088**PHOJET105a
22089C CHARACTER*8 MDLNA
22090C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
22091C PARAMETER (IEETAB=10)
22092C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
22093**PHOJET110
22094C model switches and parameters
22095 CHARACTER*8 MDLNA
22096 INTEGER ISWMDL,IPAMDL
22097 DOUBLE PRECISION PARMDL
22098 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
22099C energy-interpolation table
22100 INTEGER IEETA2
22101 PARAMETER ( IEETA2 = 20 )
22102 INTEGER ISIMAX
22103 DOUBLE PRECISION SIGTAB,SIGECM
22104 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
22105**
22106
22107C PARAMETER (NPOINT=80)
22108 PARAMETER (NPOINT=16)
22109 DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
22110
22111 STOT = ZERO
22112 SINE = ZERO
22113 SDIR = ZERO
22114
22115 W2 = ECMI**2
22116 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
22117 & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
22118 Q2 = Q2I
22119 X = XI
22120* photoprod.
22121 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22122 Q2 = 0.0001D0
22123 X = Q2/(W2+Q2-AAM(1)**2)
22124* DIS
22125 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
22126 X = Q2/(W2+Q2-AAM(1)**2)
22127 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22128 Q2 = (W2-AAM(1)**2)*X/(ONE-X)
22129 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
22130 W2 = Q2*(ONE-X)/X+AAM(1)**2
22131 ELSE
22132 WRITE(LOUT,*) 'SIGGP: inconsistent input ',W2,Q2,X
22133 STOP
22134 ENDIF
22135 ECM = SQRT(W2)
22136
22137 IF (MODEGA.EQ.1) THEN
22138 SCALE = SQRT(Q2)
22139 CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
22140 & IDPDF)
22141C W = SQRT(W2)
22142C ALLMF2 = PHO_ALLM97(Q2,W)
22143C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
22144 STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
22145 SINE = ZERO
22146 SDIR = ZERO
22147 ELSEIF (MODEGA.EQ.2) THEN
22148 IF (INTRGE(1).EQ.1) THEN
22149 AMLO2 = (3.0D0*AAM(13))**2
22150 ELSEIF (INTRGE(1).EQ.2) THEN
22151 AMLO2 = AAM(33)**2
22152 ELSE
22153 AMLO2 = AAM(96)**2
22154 ENDIF
22155 IF (INTRGE(2).EQ.1) THEN
22156 AMHI2 = W2/TWO
22157 ELSEIF (INTRGE(2).EQ.2) THEN
22158 AMHI2 = W2/4.0D0
22159 ELSE
22160 AMHI2 = W2
22161 ENDIF
22162 AMHI20 = (ECM-AAM(1))**2
22163 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22164 XAMLO = LOG( AMLO2+Q2 )
22165 XAMHI = LOG( AMHI2+Q2 )
22166**PHOJET105a
22167C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
22168**PHOJET112
22169 CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
22170**
22171 SUM = ZERO
22172 DO 1 J=1,NPOINT
22173 AM2 = EXP(ABSZX(J))-Q2
22174 IF (AM2.LT.16.0D0) THEN
22175 R = TWO
22176 ELSEIF ((AM2.GE.16.0D0).AND.(AM2.LT.121.0D0)) THEN
22177 R = 10.0D0/3.0D0
22178 ELSE
22179 R = 11.0D0/3.0D0
22180 ENDIF
22181C FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
22182 FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
22183 & * (ONE+EPSPOL*Q2/AM2)
22184 SUM = SUM+WEIGHT(J)*FAC
22185 1 CONTINUE
22186 SINE = SUM
22187 SDIR = DT_SIGVP(X,Q2)
22188 STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*SDIR
22189 SDIR = SDIR/(0.588D0+RL2+Q2)
22190C STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*DT_SIGVP(X,Q2)
22191 ELSEIF (MODEGA.EQ.3) THEN
22192 CALL DT_SIGGA(1,XI,Q2I,ECMI,ZERO,STOT,ETOT,SINE,EINE,DUM)
22193 ELSEIF (MODEGA.EQ.4) THEN
22194* load cross sections from PHOJET interpolation table
22195 IP = 1
22196 IF(ECM.LE.SIGECM(IP,1)) THEN
22197 I1 = 1
22198 I2 = 1
22199 ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
22200 DO 2 I=2,ISIMAX
22201 IF (ECM.LE.SIGECM(IP,I)) GOTO 3
22202 2 CONTINUE
22203 3 CONTINUE
22204 I1 = I-1
22205 I2 = I
22206 ELSE
22207 WRITE(LOUT,'(/1X,A,2E12.3)')
22208 & 'SIGGP:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
22209 I1 = ISIMAX
22210 I2 = ISIMAX
22211 ENDIF
22212 FAC2 = ZERO
22213 IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
22214 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
22215 FAC1 = ONE-FAC2
22216* cross section dependence on photon virtuality
22217 FSUP1 = ZERO
22218 DO 4 I=1,3
22219 FSUP1 = FSUP1+PARMDL(26+I)*(1.D0+Q2/(4.D0*PARMDL(30+I)))
22220 & /(1.D0+Q2/PARMDL(30+I))**2
22221 4 CONTINUE
22222 FSUP1 = FSUP1+PARMDL(30)/(1.D0+Q2/PARMDL(34))
22223 FAC1 = FAC1*FSUP1
22224 FAC2 = FAC2*FSUP1
22225 FSUP2 = 1.0D0
22226 STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
22227 SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
22228 SDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
22229**re:
22230 STOT = STOT-SDIR
22231**
22232 SDIR = SDIR/(FSUP1*FSUP2)
22233**re:
22234 STOT = STOT+SDIR
22235**
22236 ENDIF
22237
22238 RETURN
22239 END
22240
22241*$ CREATE DT_SIGVEL.FOR
22242*COPY DT_SIGVEL
22243*
22244*===sigvel=============================================================*
22245*
22246 SUBROUTINE DT_SIGVEL(XI,Q2I,ECMI,XNUI,IDXV,SVEL,SIG1,SIG2)
22247
22248************************************************************************
22249* Cross section for elastic vector meson production *
22250* This version dated 10.05.96 is written by S. Roesler *
22251************************************************************************
22252
22253 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22254 SAVE
22255 PARAMETER ( LINP = 10 ,
22256 & LOUT = 6 ,
22257 & LDAT = 9 )
22258 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22259 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22260 & PI = TWOPI/TWO,
22261 & GEV2MB = 0.38938D0,
22262 & ALPHEM = ONE/137.0D0)
22263
22264* particle properties (BAMJET index convention)
22265 CHARACTER*8 ANAME
22266 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22267 & IICH(210),IIBAR(210),K1(210),K2(210)
22268* VDM parameter for photon-nucleus interactions
22269 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22270
22271 W2 = ECMI**2
22272 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
22273 & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
22274 Q2 = Q2I
22275 X = XI
22276* photoprod.
22277 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22278 Q2 = 0.0001D0
22279 X = Q2/(W2+Q2-AAM(1)**2)
22280* DIS
22281 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
22282 X = Q2/(W2+Q2-AAM(1)**2)
22283 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22284 Q2 = (W2-AAM(1)**2)*X/(ONE-X)
22285 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
22286 W2 = Q2*(ONE-X)/X+AAM(1)**2
22287 ELSE
22288 WRITE(LOUT,*) 'SIGVEL: inconsistent input ',W2,Q2,X
22289 STOP
22290 ENDIF
22291 ECM = SQRT(W2)
22292
22293 AMV = AAM(IDXV)
22294 AMV2 = AMV**2
22295
22296 BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
22297 & +0.25D0*LOG(W2/(AMV2+Q2)))*GEV2MB
22298 ROSH = 0.1D0
22299 STOVP = DT_SIGVP(X,Q2)/(AMV2+Q2+RL2)
22300 SELVP = STOVP**2*(ONE+ROSH**2)/(8.0D0*TWOPI*BSLOPE)
22301
22302 IF (IDXV.EQ.33) THEN
22303 COUPL = 0.00365D0
22304 ELSE
22305 STOP
22306 ENDIF
22307 SIG1 = (AMV2/(AMV2+Q2))**2 * (ONE+EPSPOL*Q2/AMV2)
22308 SIG2 = SELVP
22309 SVEL = COUPL * (AMV2/(AMV2+Q2))**2
22310 & * (ONE+EPSPOL*Q2/AMV2) * SELVP
22311
22312 RETURN
22313 END
22314
22315*$ CREATE DT_SIGVP.FOR
22316*COPY DT_SIGVP
22317*
22318*===sigvp==============================================================*
22319*
22320 DOUBLE PRECISION FUNCTION DT_SIGVP(XI,Q2I)
22321
22322************************************************************************
22323* sigma_Vp *
22324************************************************************************
22325
22326 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22327 SAVE
22328
22329 PARAMETER ( LINP = 10 ,
22330 & LOUT = 6 ,
22331 & LDAT = 9 )
22332 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22333 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22334 & PI = TWOPI/TWO,
22335 & GEV2MB = 0.38938D0,
22336 & AMPROT = 0.938D0,
22337 & ALPHEM = ONE/137.0D0)
22338* VDM parameter for photon-nucleus interactions
22339 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22340
22341 X = XI
22342 Q2 = Q2I
22343 IF (XI.LE.ZERO) X = 0.0001D0
22344 IF (Q2I.LE.ZERO) Q2 = 0.0001D0
22345
22346 ECM = SQRT( Q2*(ONE-X)/X+AMPROT**2 )
22347
22348 SCALE = SQRT(Q2)
22349 IF (MODEGA.EQ.1) THEN
22350 CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
22351 & IDPDF)
22352C W = ECM
22353C ALLMF2 = PHO_ALLM97(Q2,W)
22354C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
22355C STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
22356C DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))
22357 DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))*GEV2MB
22358 ELSEIF (MODEGA.EQ.4) THEN
22359 CALL DT_SIGGP(X,Q2,ECM,DUM1,STOT,DUM2,DUM3)
22360C F2 = Q2*(ONE-X)/(TWOPI**2*ALPHEM*GEV2MB) * STOT
22361 DT_SIGVP = 3.0D0*PI/(ALPHEM*DT_RRM2(X,Q2)) * STOT
22362 ELSE
22363 STOP ' DT_SIGVP: F2 not defined for this MODEGA !'
22364 ENDIF
22365
22366 RETURN
22367
22368 END
22369
22370*$ CREATE DT_RRM2.FOR
22371*COPY DT_RRM2
22372*
22373*===RRM2===============================================================*
22374*
22375 DOUBLE PRECISION FUNCTION DT_RRM2(X,Q2)
22376
22377 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22378 SAVE
22379 PARAMETER ( LINP = 10 ,
22380 & LOUT = 6 ,
22381 & LDAT = 9 )
22382 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22383 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22384 & PI = TWOPI/TWO,
22385 & GEV2MB = 0.38938D0)
22386
22387* particle properties (BAMJET index convention)
22388 CHARACTER*8 ANAME
22389 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22390 & IICH(210),IIBAR(210),K1(210),K2(210)
22391* VDM parameter for photon-nucleus interactions
22392 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22393
22394 S = Q2*(ONE-X)/X+AAM(1)**2
22395 ECM = SQRT(S)
22396
22397 IF (INTRGE(1).EQ.1) THEN
22398 AMLO2 = (3.0D0*AAM(13))**2
22399 ELSEIF (INTRGE(1).EQ.2) THEN
22400 AMLO2 = AAM(33)**2
22401 ELSE
22402 AMLO2 = AAM(96)**2
22403 ENDIF
22404 IF (INTRGE(2).EQ.1) THEN
22405 AMHI2 = S/TWO
22406 ELSEIF (INTRGE(2).EQ.2) THEN
22407 AMHI2 = S/4.0D0
22408 ELSE
22409 AMHI2 = S
22410 ENDIF
22411 AMHI20 = (ECM-AAM(1))**2
22412 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22413
22414 AM1C2 = 16.0D0
22415 AM2C2 = 121.0D0
22416 IF (AMHI2.LE.AM1C2) THEN
22417 DT_RRM2 = TWO*DT_RM2(AMLO2,AMHI2,Q2)
22418 ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22419 DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22420 & 10.0D0/3.0D0*DT_RM2(AM1C2,AMHI2,Q2)
22421 ELSE
22422 DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22423 & 10.0D0/3.0D0*DT_RM2(AM1C2,AM2C2,Q2)+
22424 & 11.0D0/3.0D0*DT_RM2(AM2C2,AMHI2,Q2)
22425 ENDIF
22426
22427 RETURN
22428 END
22429
22430*$ CREATE DT_RM2.FOR
22431*COPY DT_RM2
22432*
22433*===RM2================================================================*
22434*
22435 DOUBLE PRECISION FUNCTION DT_RM2(AMLO2,AMHI2,Q2)
22436
22437 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22438 SAVE
22439 PARAMETER ( LINP = 10 ,
22440 & LOUT = 6 ,
22441 & LDAT = 9 )
22442 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22443 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22444 & PI = TWOPI/TWO,
22445 & GEV2MB = 0.38938D0)
22446* VDM parameter for photon-nucleus interactions
22447 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22448
22449 IF (RL2.LE.ZERO) THEN
22450 DT_RM2 = -ONE/(AMHI2+Q2)+Q2/(TWO*(AMHI2+Q2)**2) -
22451 & (-ONE/(AMLO2+Q2)+Q2/(TWO*(AMLO2+Q2)**2))
22452 & +EPSPOL*(-Q2/(TWO*(AMHI2+Q2)**2)+Q2/(TWO*(AMLO2+Q2)**2))
22453 ELSE
22454 TMPMLO = LOG(ONE+RL2/(AMLO2+Q2))
22455 TMPMHI = LOG(ONE+RL2/(AMHI2+Q2))
22456 DT_RM2 = Q2/(RL2*(AMHI2+Q2))-(Q2+RL2)/RL2**2*TMPMHI
22457 & -(Q2/(RL2*(AMLO2+Q2))-(Q2+RL2)/RL2**2*TMPMLO)
22458 & +EPSPOL*(
22459 & -Q2/(RL2*(AMHI2+Q2))+Q2/RL2**2*TMPMHI
22460 & -(-Q2/(RL2*(AMLO2+Q2))+Q2/RL2**2*TMPMLO))
22461 ENDIF
22462
22463 RETURN
22464 END
22465
22466*$ CREATE DT_SAM2.FOR
22467*COPY DT_SAM2
22468*
22469*===SAM2===============================================================*
22470*
22471 DOUBLE PRECISION FUNCTION DT_SAM2(Q2,ECM)
22472
22473 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22474 SAVE
22475 PARAMETER ( LINP = 10 ,
22476 & LOUT = 6 ,
22477 & LDAT = 9 )
22478 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
22479 & TENTRD=10.0D0/3.0D0,ELVTRD=11.0D0/3.0D0)
22480 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22481 & PI = TWOPI/TWO,
22482 & GEV2MB = 0.38938D0)
22483
22484* particle properties (BAMJET index convention)
22485 CHARACTER*8 ANAME
22486 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22487 & IICH(210),IIBAR(210),K1(210),K2(210)
22488* VDM parameter for photon-nucleus interactions
22489 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22490
22491 S = ECM**2
22492 IF (INTRGE(1).EQ.1) THEN
22493 AMLO2 = (3.0D0*AAM(13))**2
22494 ELSEIF (INTRGE(1).EQ.2) THEN
22495 AMLO2 = AAM(33)**2
22496 ELSE
22497 AMLO2 = AAM(96)**2
22498 ENDIF
22499 IF (INTRGE(2).EQ.1) THEN
22500 AMHI2 = S/TWO
22501 ELSEIF (INTRGE(2).EQ.2) THEN
22502 AMHI2 = S/4.0D0
22503 ELSE
22504 AMHI2 = S
22505 ENDIF
22506 AMHI20 = (ECM-AAM(1))**2
22507 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22508
22509 AM1C2 = 16.0D0
22510 AM2C2 = 121.0D0
22511 YLO = LOG(AMLO2+Q2)
22512 YC1 = LOG(AM1C2+Q2)
22513 YC2 = LOG(AM2C2+Q2)
22514 YHI = LOG(AMHI2+Q2)
22515 IF (AMHI2.LE.AM1C2) THEN
22516 FACHI = TWO
22517 ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22518 FACHI = TENTRD
22519 ELSE
22520 FACHI = ELVTRD
22521 ENDIF
22522
22523 1 CONTINUE
22524 YSAM2 = YLO+(YHI-YLO)*DT_RNDM(AM1C2)
22525 IF (YSAM2.LE.YC1) THEN
22526 FAC = TWO
22527 ELSEIF ((YSAM2.GT.YC1).AND.(YSAM2.LE.YC2)) THEN
22528 FAC = TENTRD
22529 ELSE
22530 FAC = ELVTRD
22531 ENDIF
22532 WEIGMX = FACHI*(ONE-Q2*EXP( -YHI))
22533 XSAM2 = FAC *(ONE-Q2*EXP(-YSAM2))
22534 IF (DT_RNDM(YSAM2)*WEIGMX.GT.XSAM2) GOTO 1
22535
22536 DT_SAM2 = EXP(YSAM2)-Q2
22537
22538 RETURN
22539 END
22540
22541*$ CREATE DT_CKMT.FOR
22542*COPY DT_CKMT
22543*
22544*===ckmt===============================================================*
22545*
22546 SUBROUTINE DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,
22547 & F2,IPAR)
22548
22549************************************************************************
22550* This version dated 31.01.96 is written by S. Roesler *
22551************************************************************************
22552
22553 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22554 SAVE
22555 PARAMETER ( LINP = 10 ,
22556 & LOUT = 6 ,
22557 & LDAT = 9 )
22558 PARAMETER (ZERO=0.0D0,TWO=2.0D0,TINY10=1.0D-10)
22559
22560 PARAMETER (Q02 = 2.0D0,
22561 & DQ2 = 10.05D0,
22562 & Q12 = Q02+DQ2)
22563
22564 DIMENSION PD(-6:6),SEA(3),VAL(2)
22565
22566 CALL DT_PDF0(Q02,X,F2Q0,VAL,SEA,GLU,IPAR)
22567 CALL DT_PDF0(Q12,X,F2Q1,VAL,SEA,GLU,IPAR)
22568 ADQ2 = LOG10(Q12)-LOG10(Q02)
22569 F2P = (F2Q1-F2Q0)/ADQ2
22570 CALL DT_CKMTX(IPAR,X,Q02,PD,F2PQ0)
22571 CALL DT_CKMTX(IPAR,X,Q12,PD,F2PQ1)
22572 F2PP = (F2PQ1-F2PQ0)/ADQ2
22573 FX = (F2P-F2PP)/(F2PP+LOG(DQ2)*F2PQ0+TINY10)*Q02
22574
22575 Q2 = MAX(SCALE**2.0D0,TINY10)
22576 SMOOTH = 1.0D0+FX*(Q2-Q02)/Q2**2
22577 IF (Q2.LT.Q02) THEN
22578 CALL DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22579 UPV = VAL(1)
22580 DNV = VAL(2)
22581 USEA = SEA(1)
22582 DSEA = SEA(2)
22583 STR = SEA(3)
22584 CHM = 0.0D0
22585 BOT = 0.0D0
22586 TOP = 0.0D0
22587 GL = GLU
22588 ELSE
22589 CALL DT_CKMTX(IPAR,X,Q2,PD,F2)
22590 F2 = F2*SMOOTH
22591 UPV = PD(2)-PD(3)
22592 DNV = PD(1)-PD(3)
22593 USEA = PD(3)
22594 DSEA = PD(3)
22595 STR = PD(3)
22596 CHM = PD(4)
22597 BOT = PD(5)
22598 TOP = PD(6)
22599 GL = PD(0)
22600C UPV = UPV*SMOOTH
22601C DNV = DNV*SMOOTH
22602C USEA = USEA*SMOOTH
22603C DSEA = DSEA*SMOOTH
22604C STR = STR*SMOOTH
22605C CHM = CHM*SMOOTH
22606C GL = GL*SMOOTH
22607 ENDIF
22608
22609 RETURN
22610 END
22611C
22612
22613*$ CREATE DT_CKMTX.FOR
22614*COPY DT_CKMTX
22615 SUBROUTINE DT_CKMTX(IPAR,X,SCALE2,PD,F2)
22616C**********************************************************************
22617C
22618C PDF based on Regge theory, evolved with .... by ....
22619C
22620C input: IPAR 2212 proton (not installed)
22621C 45 Pomeron
22622C 100 Deuteron
22623C
22624C output: PD(-6:6) x*f(x) parton distribution functions
22625C (PDFLIB convention: d = PD(1), u = PD(2) )
22626C
22627C**********************************************************************
22628
22629 SAVE
22630 DOUBLE PRECISION X,SCALE2,PD(-6:6),CDN,CUP,F2
22631 PARAMETER ( LINP = 10 ,
22632 & LOUT = 6 ,
22633 & LDAT = 9 )
22634 DIMENSION QQ(7)
22635C
22636 Q2=SNGL(SCALE2)
22637 Q1S=Q2
22638 XX=SNGL(X)
22639C QCD lambda for evolution
22640 OWLAM = 0.23D0
22641 OWLAM2=OWLAM**2
22642C Q0**2 for evolution
22643 Q02 = 2.D0
22644C
22645C
22646C the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
22647C q(6)=x*charm, q(7)=x*gluon
22648C
22649 SB=0.
22650 IF(Q2-Q02) 1,1,2
22651 2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
22652 1 CONTINUE
22653 IF(IPAR.EQ.2212) THEN
22654 CALL DT_CKMTPR(1,0,XX,SB,QQ(1))
22655 CALL DT_CKMTPR(2,0,XX,SB,QQ(2))
22656 CALL DT_CKMTPR(3,0,XX,SB,QQ(3))
22657 CALL DT_CKMTPR(4,0,XX,SB,QQ(4))
22658 CALL DT_CKMTPR(5,0,XX,SB,QQ(5))
22659 CALL DT_CKMTPR(8,0,XX,SB,QQ(6))
22660 CALL DT_CKMTPR(7,0,XX,SB,QQ(7))
22661C ELSEIF (IPAR.EQ.45) THEN
22662C CALL CKMTPO(1,0,XX,SB,QQ(1))
22663C CALL CKMTPO(2,0,XX,SB,QQ(2))
22664C CALL CKMTPO(3,0,XX,SB,QQ(3))
22665C CALL CKMTPO(4,0,XX,SB,QQ(4))
22666C CALL CKMTPO(5,0,XX,SB,QQ(5))
22667C CALL CKMTPO(8,0,XX,SB,QQ(6))
22668C CALL CKMTPO(7,0,XX,SB,QQ(7))
22669 ELSEIF (IPAR.EQ.100) THEN
22670 CALL DT_CKMTDE(1,0,XX,SB,QQ(1))
22671 CALL DT_CKMTDE(2,0,XX,SB,QQ(2))
22672 CALL DT_CKMTDE(3,0,XX,SB,QQ(3))
22673 CALL DT_CKMTDE(4,0,XX,SB,QQ(4))
22674 CALL DT_CKMTDE(5,0,XX,SB,QQ(5))
22675 CALL DT_CKMTDE(8,0,XX,SB,QQ(6))
22676 CALL DT_CKMTDE(7,0,XX,SB,QQ(7))
22677 ELSE
22678 WRITE(LOUT,'(1X,A,I4,A)')
22679 & 'CKMTX: IPAR =',IPAR,' not implemented!'
22680 STOP
22681 ENDIF
22682C
22683 PD(-6) = 0.D0
22684 PD(-5) = 0.D0
22685 PD(-4) = DBLE(QQ(6))
22686 PD(-3) = DBLE(QQ(3))
22687 PD(-2) = DBLE(QQ(4))
22688 PD(-1) = DBLE(QQ(5))
22689 PD(0) = DBLE(QQ(7))
22690 PD(1) = DBLE(QQ(2))
22691 PD(2) = DBLE(QQ(1))
22692 PD(3) = DBLE(QQ(3))
22693 PD(4) = DBLE(QQ(6))
22694 PD(5) = 0.D0
22695 PD(6) = 0.D0
22696 IF(IPAR.EQ.45) THEN
22697 CDN = (PD(1)-PD(-1))/2.D0
22698 CUP = (PD(2)-PD(-2))/2.D0
22699 PD(-1) = PD(-1) + CDN
22700 PD(-2) = PD(-2) + CUP
22701 PD(1) = PD(-1)
22702 PD(2) = PD(-2)
22703 ENDIF
22704 F2 = 4.0D0/9.0D0*(PD(2)-PD(3)+2.0D0*PD(3))+
22705 & 1.0D0/9.0D0*(PD(1)-PD(3)+2.0D0*PD(3))+
22706 & 1.0D0/9.0D0*(2.0D0*PD(3))+4.0D0/9.0D0*(2.0D0*PD(4))
22707 END
22708C
22709
22710*$ CREATE DT_PDF0.FOR
22711*COPY DT_PDF0
22712*
22713*===pdf0===============================================================*
22714*
22715 SUBROUTINE DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22716
22717************************************************************************
22718* This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 *
22719* an F_2-ansatz given in Capella et al. PLB 337(1994)358. *
22720* IPAR = 2212 proton *
22721* = 100 deuteron *
22722* This version dated 31.01.96 is written by S. Roesler *
22723************************************************************************
22724
22725 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22726 SAVE
22727 PARAMETER ( LINP = 10 ,
22728 & LOUT = 6 ,
22729 & LDAT = 9 )
22730 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22731
22732 PARAMETER (
22733 & AA = 0.1502D0,
22734 & BBDEU = 1.2D0,
22735 & BUD = 0.754D0,
22736 & BDD = 0.4495D0,
22737 & BUP = 1.2064D0,
22738 & BDP = 0.1798D0,
22739 & DELTA0 = 0.07684D0,
22740 & D = 1.117D0,
22741 & C = 3.5489D0,
22742 & A = 0.2631D0,
22743 & B = 0.6452D0,
22744 & ALPHAR = 0.415D0,
22745 & E = 0.1D0
22746 & )
22747
22748 PARAMETER (NPOINT=16)
22749C DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
22750 DIMENSION SEA(3),VAL(2)
22751
22752 DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22753 AN = 1.5D0*(1.0D0+Q2/(Q2+C))
22754* proton, deuteron
22755 IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22756 CALL DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22757 SEA(1) = 0.75D0*SEA0
22758 SEA(2) = SEA(1)
22759 SEA(3) = SEA(1)
22760 VAL(1) = 9.0D0/4.0D0*VALU0
22761 VAL(2) = 9.0D0*VALD0
22762 GLU0 = SEA(1)/(1.0D0-X)
22763 F2 = SEA0+VALU0+VALD0
22764 F2PDF = 4.0D0/9.0D0*(VAL(1)+2.0D0*SEA(1))+
22765 & 1.0D0/9.0D0*(VAL(2)+2.0D0*SEA(2))+
22766 & 1.0D0/9.0D0*(2.0D0*SEA(3))
22767 IF (ABS(F2-F2PDF).GT.TINY9) THEN
22768 WRITE(LOUT,'(1X,A,2E15.5)') 'inconsistent PDF! ',F2,F2PDF
22769 STOP
22770 ENDIF
22771**PHOJET105a
22772C CALL GSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22773**PHOJET112
22774C CALL PHO_GAUSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22775**
22776C SUMQ = ZERO
22777C SUMG = ZERO
22778C DO 1 J=1,NPOINT
22779C CALL DT_CKMTQ0(Q2,ABSZX(J),IPAR,VALU0,VALD0,SEA0)
22780C VALU0 = 9.0D0/4.0D0*VALU0
22781C VALD0 = 9.0D0*VALD0
22782C SEA0 = 0.75D0*SEA0
22783C SUMQ = SUMQ+ (VALU0+VALD0+6.0D0*SEA0) *WEIGHT(J)
22784C SUMG = SUMG+ (SEA0/(1.0D0-ABSZX(J))) *WEIGHT(J)
22785C 1 CONTINUE
22786C GLU = GLU0*(1.0D0-SUMQ)/SUMG
22787 ELSE
22788 WRITE(LOUT,'(1X,A,I4,A)')
22789 & 'PDF0: IPAR =',IPAR,' not implemented!'
22790 STOP
22791 ENDIF
22792
22793 RETURN
22794 END
22795
22796*$ CREATE DT_CKMTQ0.FOR
22797*COPY DT_CKMTQ0
22798*
22799*===ckmtq0=============================================================*
22800*
22801 SUBROUTINE DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22802
22803************************************************************************
22804* This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 *
22805* an F_2-ansatz given in Capella et al. PLB 337(1994)358. *
22806* IPAR = 2212 proton *
22807* = 100 deuteron *
22808* This version dated 31.01.96 is written by S. Roesler *
22809************************************************************************
22810
22811 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22812 SAVE
22813 PARAMETER ( LINP = 10 ,
22814 & LOUT = 6 ,
22815 & LDAT = 9 )
22816 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22817
22818 PARAMETER (
22819 & AA = 0.1502D0,
22820 & BBDEU = 1.2D0,
22821 & BUD = 0.754D0,
22822 & BDD = 0.4495D0,
22823 & BUP = 1.2064D0,
22824 & BDP = 0.1798D0,
22825 & DELTA0 = 0.07684D0,
22826 & D = 1.117D0,
22827 & C = 3.5489D0,
22828 & A = 0.2631D0,
22829 & B = 0.6452D0,
22830 & ALPHAR = 0.415D0,
22831 & E = 0.1D0
22832 & )
22833
22834 DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22835 AN = 1.5D0*(1.0D0+Q2/(Q2+C))
22836* proton, deuteron
22837 IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22838 IF (IPAR.EQ.2212) THEN
22839 BU = BUP
22840 BD = BDP
22841 ELSE
22842 BU = BUD
22843 BD = BDD
22844 ENDIF
22845 SEA0 = AA*X**(-DELTA)*(1.0D0-X)**(AN+4.0D0)*
22846 & (Q2/(Q2+A))**(1.0D0+DELTA)
22847 VALU0 = BU*X**(1.0D0-ALPHAR)*(1.0D0-X)**AN*
22848 & (Q2/(Q2+B))**(ALPHAR)
22849 VALD0 = BD*X**(1.0D0-ALPHAR)*(1.0D0-X)**(AN+1.0D0)*
22850 & (Q2/(Q2+B))**(ALPHAR)
22851 ELSE
22852 WRITE(LOUT,'(1X,A,I4,A)')
22853 & 'CKMTQ0: IPAR =',IPAR,' not implemented!'
22854 STOP
22855 ENDIF
22856 RETURN
22857 END
22858C
22859C
22860
22861*$ CREATE DT_CKMTDE.FOR
22862*COPY DT_CKMTDE
22863 SUBROUTINE DT_CKMTDE(I,NDRV,X,S,ANS)
22864C
22865C**********************************************************************
22866C Deuteron - PDFs
22867C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
22868C ANS = PDF(I)
22869C This version by S. Roesler, 30.01.96
22870C**********************************************************************
22871
22872 SAVE
22873 DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
22874 EQUIVALENCE (GF(1,1,1),DL(1))
22875 DATA DELTA/.13/
22876C
22877 DATA (DL(K),K= 1, 85) /
22878 &0.351858E+00,0.388489E+00,0.325356E+00,0.325356E+00,0.325356E+00,
22879 &0.325356E+00,0.445218E+01,0.000000E+00,0.419818E+00,0.459249E+00,
22880 &0.391167E+00,0.391143E+00,0.391125E+00,0.391167E+00,0.628186E+01,
22881 &0.703797E-01,0.498333E+00,0.540626E+00,0.467466E+00,0.467423E+00,
22882 &0.467393E+00,0.467466E+00,0.837368E+01,0.151191E+00,0.587839E+00,
22883 &0.633058E+00,0.554689E+00,0.554630E+00,0.554595E+00,0.554689E+00,
22884 &0.107170E+02,0.242877E+00,0.688652E+00,0.736861E+00,0.653150E+00,
22885 &0.653080E+00,0.653046E+00,0.653150E+00,0.132960E+02,0.345760E+00,
22886 &0.800961E+00,0.852226E+00,0.763038E+00,0.762961E+00,0.762933E+00,
22887 &0.763038E+00,0.160884E+02,0.460033E+00,0.924829E+00,0.979213E+00,
22888 &0.884414E+00,0.884335E+00,0.884319E+00,0.884414E+00,0.190679E+02,
22889 &0.585764E+00,0.106016E+01,0.111773E+01,0.101719E+01,0.101711E+01,
22890 &0.101711E+01,0.101719E+01,0.222033E+02,0.722864E+00,0.120670E+01,
22891 &0.126752E+01,0.116110E+01,0.116102E+01,0.116105E+01,0.116110E+01,
22892 &0.254603E+02,0.871079E+00,0.136402E+01,0.142815E+01,0.131571E+01,
22893 &0.131565E+01,0.131570E+01,0.131571E+01,0.288020E+02,0.102998E+01,
22894 &0.153151E+01,0.159900E+01,0.148043E+01,0.148038E+01,0.148046E+01/
22895 DATA (DL(K),K= 86, 170) /
22896 &0.148043E+01,0.321898E+02,0.119897E+01,0.170838E+01,0.177930E+01,
22897 &0.165447E+01,0.165444E+01,0.165455E+01,0.165447E+01,0.355845E+02,
22898 &0.137726E+01,0.189369E+01,0.196807E+01,0.183687E+01,0.183686E+01,
22899 &0.183701E+01,0.183687E+01,0.389473E+02,0.156390E+01,0.208631E+01,
22900 &0.216422E+01,0.202653E+01,0.202654E+01,0.202673E+01,0.202653E+01,
22901 &0.422402E+02,0.175779E+01,0.228501E+01,0.236648E+01,0.222220E+01,
22902 &0.222224E+01,0.222248E+01,0.222220E+01,0.454277E+02,0.195768E+01,
22903 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22904 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22905 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22906 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22907 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22908 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22909 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22910 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22911 &0.326035E+00,0.380777E+00,0.286363E+00,0.286363E+00,0.286363E+00,
22912 &0.286363E+00,0.392252E+01,-.138778E-16,0.380092E+00,0.438587E+00/
22913 DATA (DL(K),K= 171, 255) /
22914 &0.337452E+00,0.337430E+00,0.337424E+00,0.337452E+00,0.532193E+01,
22915 &0.553645E-01,0.440879E+00,0.503177E+00,0.395208E+00,0.395169E+00,
22916 &0.395165E+00,0.395208E+00,0.686454E+01,0.117354E+00,0.508415E+00,
22917 &0.574566E+00,0.459649E+00,0.459600E+00,0.459604E+00,0.459649E+00,
22918 &0.853316E+01,0.185994E+00,0.582647E+00,0.652699E+00,0.530722E+00,
22919 &0.530667E+00,0.530687E+00,0.530722E+00,0.103093E+02,0.261237E+00,
22920 &0.663404E+00,0.737405E+00,0.608254E+00,0.608199E+00,0.608241E+00,
22921 &0.608254E+00,0.121710E+02,0.342917E+00,0.750429E+00,0.828423E+00,
22922 &0.691990E+00,0.691941E+00,0.692009E+00,0.691990E+00,0.140946E+02,
22923 &0.430783E+00,0.843361E+00,0.925391E+00,0.781571E+00,0.781533E+00,
22924 &0.781632E+00,0.781571E+00,0.160553E+02,0.524479E+00,0.941741E+00,
22925 &0.102784E+01,0.876538E+00,0.876515E+00,0.876650E+00,0.876538E+00,
22926 &0.180277E+02,0.623549E+00,0.104501E+01,0.113521E+01,0.976335E+00,
22927 &0.976332E+00,0.976506E+00,0.976335E+00,0.199863E+02,0.727439E+00,
22928 &0.115251E+01,0.124685E+01,0.108031E+01,0.108034E+01,0.108055E+01,
22929 &0.108031E+01,0.219066E+02,0.835506E+00,0.126352E+01,0.136201E+01,
22930 &0.118775E+01,0.118780E+01,0.118806E+01,0.118775E+01,0.237652E+02/
22931 DATA (DL(K),K= 256, 340) /
22932 &0.947020E+00,0.137724E+01,0.147989E+01,0.129783E+01,0.129791E+01,
22933 &0.129822E+01,0.129783E+01,0.255406E+02,0.106119E+01,0.149279E+01,
22934 &0.159961E+01,0.140972E+01,0.140984E+01,0.141019E+01,0.140972E+01,
22935 &0.272135E+02,0.117715E+01,0.160929E+01,0.172028E+01,0.152252E+01,
22936 &0.152267E+01,0.152308E+01,0.152252E+01,0.287669E+02,0.129402E+01,
22937 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22938 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22939 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22940 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22941 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22942 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22943 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22944 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22945 &0.309785E+00,0.391282E+00,0.250518E+00,0.250518E+00,0.250518E+00,
22946 &0.250518E+00,0.343842E+01,-.138778E-16,0.352113E+00,0.438463E+00,
22947 &0.288877E+00,0.288863E+00,0.288878E+00,0.288877E+00,0.446765E+01,
22948 &0.424850E-01,0.398382E+00,0.489596E+00,0.331132E+00,0.331111E+00/
22949 DATA (DL(K),K= 341, 425) /
22950 &0.331148E+00,0.331132E+00,0.555902E+01,0.888369E-01,0.448375E+00,
22951 &0.544458E+00,0.377064E+00,0.377043E+00,0.377108E+00,0.377064E+00,
22952 &0.669490E+01,0.138845E+00,0.501854E+00,0.602811E+00,0.426440E+00,
22953 &0.426425E+00,0.426523E+00,0.426440E+00,0.785892E+01,0.192281E+00,
22954 &0.558506E+00,0.664331E+00,0.478946E+00,0.478944E+00,0.479079E+00,
22955 &0.478946E+00,0.903368E+01,0.248834E+00,0.617972E+00,0.728657E+00,
22956 &0.534229E+00,0.534244E+00,0.534421E+00,0.534229E+00,0.102022E+02,
22957 &0.308155E+00,0.679844E+00,0.795370E+00,0.591883E+00,0.591921E+00,
22958 &0.592141E+00,0.591883E+00,0.113479E+02,0.369841E+00,0.743667E+00,
22959 &0.864009E+00,0.651460E+00,0.651525E+00,0.651792E+00,0.651460E+00,
22960 &0.124553E+02,0.433447E+00,0.808951E+00,0.934073E+00,0.712474E+00,
22961 &0.712571E+00,0.712885E+00,0.712474E+00,0.135102E+02,0.498486E+00,
22962 &0.875171E+00,0.100503E+01,0.774408E+00,0.774541E+00,0.774902E+00,
22963 &0.774408E+00,0.144999E+02,0.564446E+00,0.941784E+00,0.107632E+01,
22964 &0.836726E+00,0.836897E+00,0.837307E+00,0.836726E+00,0.154136E+02,
22965 &0.630788E+00,0.100823E+01,0.114738E+01,0.898879E+00,0.899092E+00,
22966 &0.899551E+00,0.898879E+00,0.162423E+02,0.696967E+00,0.107396E+01/
22967 DATA (DL(K),K= 426, 510) /
22968 &0.121764E+01,0.960319E+00,0.960577E+00,0.961084E+00,0.960319E+00,
22969 &0.169791E+02,0.762433E+00,0.113843E+01,0.128655E+01,0.102051E+01,
22970 &0.102081E+01,0.102137E+01,0.102051E+01,0.176190E+02,0.826647E+00,
22971 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22972 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22973 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22974 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22975 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22976 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22977 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22978 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22979 &0.304680E+00,0.425088E+00,0.216504E+00,0.216504E+00,0.216504E+00,
22980 &0.216504E+00,0.298356E+01,0.000000E+00,0.337300E+00,0.463627E+00,
22981 &0.244023E+00,0.244024E+00,0.244063E+00,0.244023E+00,0.370271E+01,
22982 &0.316585E-01,0.371787E+00,0.503942E+00,0.273415E+00,0.273423E+00,
22983 &0.273505E+00,0.273415E+00,0.443039E+01,0.651685E-01,0.407853E+00,
22984 &0.545739E+00,0.304395E+00,0.304418E+00,0.304545E+00,0.304395E+00/
22985 DATA (DL(K),K= 511, 595) /
22986 &0.515321E+01,0.100252E+00,0.445229E+00,0.588741E+00,0.336700E+00,
22987 &0.336744E+00,0.336918E+00,0.336700E+00,0.586004E+01,0.136648E+00,
22988 &0.483606E+00,0.632629E+00,0.370026E+00,0.370095E+00,0.370318E+00,
22989 &0.370026E+00,0.654027E+01,0.174056E+00,0.522666E+00,0.677074E+00,
22990 &0.404062E+00,0.404162E+00,0.404433E+00,0.404062E+00,0.718442E+01,
22991 &0.212167E+00,0.562075E+00,0.721735E+00,0.438483E+00,0.438618E+00,
22992 &0.438938E+00,0.438483E+00,0.778423E+01,0.250658E+00,0.601494E+00,
22993 &0.766258E+00,0.472959E+00,0.473131E+00,0.473500E+00,0.472959E+00,
22994 &0.833276E+01,0.289199E+00,0.640580E+00,0.810290E+00,0.507156E+00,
22995 &0.507369E+00,0.507784E+00,0.507156E+00,0.882448E+01,0.327457E+00,
22996 &0.678993E+00,0.853479E+00,0.540747E+00,0.541003E+00,0.541463E+00,
22997 &0.540747E+00,0.925529E+01,0.365104E+00,0.716405E+00,0.895483E+00,
22998 &0.573411E+00,0.573714E+00,0.574216E+00,0.573411E+00,0.962250E+01,
22999 &0.401821E+00,0.752501E+00,0.935975E+00,0.604848E+00,0.605197E+00,
23000 &0.605740E+00,0.604848E+00,0.992478E+01,0.437304E+00,0.786987E+00,
23001 &0.974647E+00,0.634775E+00,0.635173E+00,0.635752E+00,0.634775E+00,
23002 &0.101620E+02,0.471269E+00,0.819594E+00,0.101122E+01,0.662936E+00/
23003 DATA (DL(K),K= 596, 680) /
23004 &0.663382E+00,0.663995E+00,0.662936E+00,0.103354E+02,0.503459E+00,
23005 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23006 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23007 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23008 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23009 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23010 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23011 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23012 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23013 &0.312661E+00,0.487836E+00,0.182562E+00,0.182562E+00,0.182562E+00,
23014 &0.182562E+00,0.253626E+01,0.000000E+00,0.336910E+00,0.518440E+00,
23015 &0.200702E+00,0.200721E+00,0.200779E+00,0.200702E+00,0.299460E+01,
23016 &0.224425E-01,0.361554E+00,0.549164E+00,0.219359E+00,0.219402E+00,
23017 &0.219517E+00,0.219359E+00,0.343183E+01,0.453742E-01,0.386348E+00,
23018 &0.579759E+00,0.238296E+00,0.238367E+00,0.238536E+00,0.238296E+00,
23019 &0.384076E+01,0.685610E-01,0.411080E+00,0.610003E+00,0.257305E+00,
23020 &0.257408E+00,0.257630E+00,0.257305E+00,0.421619E+01,0.917987E-01/
23021 DATA (DL(K),K= 681, 765) /
23022 &0.435528E+00,0.639668E+00,0.276174E+00,0.276313E+00,0.276583E+00,
23023 &0.276174E+00,0.455400E+01,0.114876E+00,0.459476E+00,0.668531E+00,
23024 &0.294698E+00,0.294875E+00,0.295191E+00,0.294698E+00,0.485107E+01,
23025 &0.137589E+00,0.482719E+00,0.696375E+00,0.312682E+00,0.312900E+00,
23026 &0.313258E+00,0.312682E+00,0.510539E+01,0.159742E+00,0.505060E+00,
23027 &0.722995E+00,0.329941E+00,0.330200E+00,0.330596E+00,0.329941E+00,
23028 &0.531589E+01,0.181149E+00,0.526315E+00,0.748199E+00,0.346303E+00,
23029 &0.346604E+00,0.347034E+00,0.346303E+00,0.548250E+01,0.201638E+00,
23030 &0.546317E+00,0.771808E+00,0.361613E+00,0.361957E+00,0.362418E+00,
23031 &0.361613E+00,0.560595E+01,0.221052E+00,0.564917E+00,0.793667E+00,
23032 &0.375735E+00,0.376122E+00,0.376609E+00,0.375735E+00,0.568772E+01,
23033 &0.239253E+00,0.581987E+00,0.813638E+00,0.388553E+00,0.388982E+00,
23034 &0.389491E+00,0.388553E+00,0.572992E+01,0.256122E+00,0.597419E+00,
23035 &0.831608E+00,0.399972E+00,0.400443E+00,0.400970E+00,0.399972E+00,
23036 &0.573516E+01,0.271562E+00,0.611129E+00,0.847487E+00,0.409919E+00,
23037 &0.410430E+00,0.410972E+00,0.409919E+00,0.570642E+01,0.285497E+00,
23038 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23039 DATA (DL(K),K= 766, 850) /
23040 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23041 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23042 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23043 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23044 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23045 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23046 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23047 &0.335149E+00,0.582072E+00,0.146415E+00,0.146415E+00,0.146415E+00,
23048 &0.146415E+00,0.206772E+01,0.000000E+00,0.351552E+00,0.603437E+00,
23049 &0.156515E+00,0.156542E+00,0.156595E+00,0.156515E+00,0.231143E+01,
23050 &0.146091E-01,0.367407E+00,0.623737E+00,0.166387E+00,0.166442E+00,
23051 &0.166542E+00,0.166387E+00,0.252488E+01,0.289315E-01,0.382571E+00,
23052 &0.642832E+00,0.175891E+00,0.175976E+00,0.176118E+00,0.175891E+00,
23053 &0.270658E+01,0.428312E-01,0.396926E+00,0.660609E+00,0.184917E+00,
23054 &0.185034E+00,0.185212E+00,0.184917E+00,0.285608E+01,0.561981E-01,
23055 &0.410365E+00,0.676962E+00,0.193365E+00,0.193513E+00,0.193722E+00,
23056 &0.193365E+00,0.297375E+01,0.689319E-01,0.422792E+00,0.691796E+00/
23057 DATA (DL(K),K= 851, 935) /
23058 &0.201144E+00,0.201324E+00,0.201560E+00,0.201144E+00,0.306050E+01,
23059 &0.809434E-01,0.434123E+00,0.705030E+00,0.208181E+00,0.208393E+00,
23060 &0.208650E+00,0.208181E+00,0.311775E+01,0.921567E-01,0.444287E+00,
23061 &0.716596E+00,0.214413E+00,0.214656E+00,0.214931E+00,0.214413E+00,
23062 &0.314738E+01,0.102508E+00,0.453228E+00,0.726441E+00,0.219792E+00,
23063 &0.220066E+00,0.220354E+00,0.219792E+00,0.315156E+01,0.111949E+00,
23064 &0.460906E+00,0.734527E+00,0.224285E+00,0.224589E+00,0.224886E+00,
23065 &0.224285E+00,0.313271E+01,0.120441E+00,0.467291E+00,0.740835E+00,
23066 &0.227870E+00,0.228203E+00,0.228506E+00,0.227870E+00,0.309338E+01,
23067 &0.127963E+00,0.472372E+00,0.745357E+00,0.230541E+00,0.230902E+00,
23068 &0.231208E+00,0.230541E+00,0.303621E+01,0.134506E+00,0.476148E+00,
23069 &0.748105E+00,0.232304E+00,0.232690E+00,0.232996E+00,0.232304E+00,
23070 &0.296381E+01,0.140070E+00,0.478635E+00,0.749103E+00,0.233176E+00,
23071 &0.233586E+00,0.233889E+00,0.233176E+00,0.287874E+01,0.144672E+00,
23072 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23073 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23074 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23075 DATA (DL(K),K= 936, 1020) /
23076 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23077 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23078 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23079 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23080 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23081 &0.370162E+00,0.695827E+00,0.105823E+00,0.105823E+00,0.105823E+00,
23082 &0.105823E+00,0.154556E+01,0.208167E-16,0.378214E+00,0.703794E+00,
23083 &0.109539E+00,0.109554E+00,0.109571E+00,0.109539E+00,0.162770E+01,
23084 &0.818783E-02,0.385258E+00,0.710067E+00,0.112818E+00,0.112847E+00,
23085 &0.112879E+00,0.112818E+00,0.168578E+01,0.158212E-01,0.391264E+00,
23086 &0.714648E+00,0.115620E+00,0.115666E+00,0.115709E+00,0.115620E+00,
23087 &0.172175E+01,0.228667E-01,0.396214E+00,0.717539E+00,0.117923E+00,
23088 &0.117985E+00,0.118037E+00,0.117923E+00,0.173756E+01,0.293009E-01,
23089 &0.400098E+00,0.718759E+00,0.119711E+00,0.119790E+00,0.119848E+00,
23090 &0.119711E+00,0.173541E+01,0.351123E-01,0.402915E+00,0.718332E+00,
23091 &0.120979E+00,0.121074E+00,0.121137E+00,0.120979E+00,0.171755E+01,
23092 &0.402951E-01,0.404672E+00,0.716292E+00,0.121728E+00,0.121840E+00/
23093 DATA (DL(K),K= 1021, 1105) /
23094 &0.121905E+00,0.121728E+00,0.168619E+01,0.448514E-01,0.405385E+00,
23095 &0.712681E+00,0.121967E+00,0.122095E+00,0.122161E+00,0.121967E+00,
23096 &0.164352E+01,0.487902E-01,0.405077E+00,0.707551E+00,0.121712E+00,
23097 &0.121855E+00,0.121920E+00,0.121712E+00,0.159162E+01,0.521265E-01,
23098 &0.403778E+00,0.700963E+00,0.120984E+00,0.121141E+00,0.121204E+00,
23099 &0.120984E+00,0.153245E+01,0.548814E-01,0.401525E+00,0.692984E+00,
23100 &0.119809E+00,0.119980E+00,0.120040E+00,0.119809E+00,0.146780E+01,
23101 &0.570807E-01,0.398361E+00,0.683691E+00,0.118218E+00,0.118402E+00,
23102 &0.118457E+00,0.118218E+00,0.139928E+01,0.587542E-01,0.394333E+00,
23103 &0.673166E+00,0.116244E+00,0.116440E+00,0.116490E+00,0.116244E+00,
23104 &0.132834E+01,0.599355E-01,0.389495E+00,0.661496E+00,0.113924E+00,
23105 &0.114131E+00,0.114175E+00,0.113924E+00,0.125620E+01,0.606602E-01,
23106 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23107 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23108 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23109 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23110 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23111 DATA (DL(K),K= 1106, 1190) /
23112 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23113 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23114 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23115 &0.394012E+00,0.757115E+00,0.772117E-01,0.772117E-01,0.772117E-01,
23116 &0.772117E-01,0.117279E+01,0.346945E-17,0.395841E+00,0.752988E+00,
23117 &0.780501E-01,0.780655E-01,0.780723E-01,0.780501E-01,0.118528E+01,
23118 &0.491697E-02,0.396627E+00,0.747223E+00,0.785386E-01,0.785692E-01,
23119 &0.785806E-01,0.785386E-01,0.118242E+01,0.932754E-02,0.396401E+00,
23120 &0.739901E+00,0.786820E-01,0.787273E-01,0.787413E-01,0.786820E-01,
23121 &0.116673E+01,0.132427E-01,0.395190E+00,0.731092E+00,0.784870E-01,
23122 &0.785464E-01,0.785613E-01,0.784870E-01,0.114033E+01,0.166738E-01,
23123 &0.393030E+00,0.720878E+00,0.779683E-01,0.780410E-01,0.780555E-01,
23124 &0.779683E-01,0.110528E+01,0.196392E-01,0.389962E+00,0.709342E+00,
23125 &0.771427E-01,0.772280E-01,0.772409E-01,0.771427E-01,0.106344E+01,
23126 &0.221591E-01,0.386027E+00,0.696571E+00,0.760304E-01,0.761276E-01,
23127 &0.761378E-01,0.760304E-01,0.101653E+01,0.242567E-01,0.381274E+00,
23128 &0.682657E+00,0.746543E-01,0.747623E-01,0.747692E-01,0.746543E-01/
23129 DATA (DL(K),K= 1191, 1275) /
23130 &0.966057E+00,0.259571E-01,0.375752E+00,0.667695E+00,0.730389E-01,
23131 &0.731569E-01,0.731598E-01,0.730389E-01,0.913345E+00,0.272876E-01,
23132 &0.369514E+00,0.651782E+00,0.712104E-01,0.713374E-01,0.713358E-01,
23133 &0.712104E-01,0.859530E+00,0.282763E-01,0.362616E+00,0.635021E+00,
23134 &0.691957E-01,0.693307E-01,0.693243E-01,0.691957E-01,0.805566E+00,
23135 &0.289524E-01,0.355116E+00,0.617511E+00,0.670220E-01,0.671640E-01,
23136 &0.671526E-01,0.670220E-01,0.752235E+00,0.293453E-01,0.347072E+00,
23137 &0.599357E+00,0.647162E-01,0.648642E-01,0.648478E-01,0.647162E-01,
23138 &0.700161E+00,0.294844E-01,0.338543E+00,0.580659E+00,0.623046E-01,
23139 &0.624578E-01,0.624363E-01,0.623046E-01,0.649828E+00,0.293983E-01,
23140 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23141 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23142 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23143 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23144 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23145 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23146 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23147 DATA (DL(K),K= 1276, 1360) /
23148 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23149 &0.408305E+00,0.775318E+00,0.509141E-01,0.509141E-01,0.509141E-01,
23150 &0.509141E-01,0.818839E+00,-.867362E-17,0.403619E+00,0.758058E+00,
23151 &0.502245E-01,0.502351E-01,0.502337E-01,0.502245E-01,0.795347E+00,
23152 &0.264045E-02,0.398068E+00,0.739709E+00,0.493454E-01,0.493661E-01,
23153 &0.493626E-01,0.493454E-01,0.764942E+00,0.491508E-02,0.391719E+00,
23154 &0.720394E+00,0.482952E-01,0.483253E-01,0.483192E-01,0.482952E-01,
23155 &0.729624E+00,0.685202E-02,0.384627E+00,0.700222E+00,0.470896E-01,
23156 &0.471285E-01,0.471194E-01,0.470896E-01,0.690906E+00,0.847433E-02,
23157 &0.376851E+00,0.679300E+00,0.457475E-01,0.457946E-01,0.457822E-01,
23158 &0.457475E-01,0.650078E+00,0.980774E-02,0.368452E+00,0.657739E+00,
23159 &0.442875E-01,0.443419E-01,0.443261E-01,0.442875E-01,0.608239E+00,
23160 &0.108769E-01,0.359490E+00,0.635646E+00,0.427281E-01,0.427892E-01,
23161 &0.427698E-01,0.427281E-01,0.566280E+00,0.117061E-01,0.350026E+00,
23162 &0.613128E+00,0.410878E-01,0.411549E-01,0.411320E-01,0.410878E-01,
23163 &0.524918E+00,0.123191E-01,0.340122E+00,0.590292E+00,0.393848E-01,
23164 &0.394571E-01,0.394308E-01,0.393848E-01,0.484713E+00,0.127393E-01/
23165 DATA (DL(K),K= 1361, 1445) /
23166 &0.329838E+00,0.567240E+00,0.376363E-01,0.377132E-01,0.376836E-01,
23167 &0.376363E-01,0.446084E+00,0.129888E-01,0.319236E+00,0.544074E+00,
23168 &0.358589E-01,0.359396E-01,0.359068E-01,0.358589E-01,0.409328E+00,
23169 &0.130888E-01,0.308374E+00,0.520890E+00,0.340678E-01,0.341517E-01,
23170 &0.341160E-01,0.340678E-01,0.374641E+00,0.130594E-01,0.297312E+00,
23171 &0.497781E+00,0.322772E-01,0.323636E-01,0.323253E-01,0.322772E-01,
23172 &0.342135E+00,0.129195E-01,0.286106E+00,0.474837E+00,0.304999E-01,
23173 &0.305882E-01,0.305474E-01,0.304999E-01,0.311854E+00,0.126863E-01,
23174 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23175 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23176 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23177 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23178 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23179 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23180 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23181 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23182 &0.407248E+00,0.746438E+00,0.335640E-01,0.335640E-01,0.335640E-01/
23183 DATA (DL(K),K= 1446, 1530) /
23184 &0.335640E-01,0.573540E+00,0.173472E-16,0.397516E+00,0.719825E+00,
23185 &0.324649E-01,0.324735E-01,0.324698E-01,0.324649E-01,0.540770E+00,
23186 &0.147177E-02,0.387197E+00,0.692869E+00,0.312911E-01,0.313075E-01,
23187 &0.313000E-01,0.312911E-01,0.505972E+00,0.269995E-02,0.376365E+00,
23188 &0.665689E+00,0.300576E-01,0.300811E-01,0.300699E-01,0.300576E-01,
23189 &0.470389E+00,0.371147E-02,0.365085E+00,0.638387E+00,0.287770E-01,
23190 &0.288070E-01,0.287922E-01,0.287770E-01,0.434885E+00,0.452768E-02,
23191 &0.353423E+00,0.611066E+00,0.274623E-01,0.274980E-01,0.274797E-01,
23192 &0.274623E-01,0.400103E+00,0.516996E-02,0.341442E+00,0.583823E+00,
23193 &0.261256E-01,0.261663E-01,0.261448E-01,0.261256E-01,0.366541E+00,
23194 &0.565807E-02,0.329207E+00,0.556753E+00,0.247782E-01,0.248234E-01,
23195 &0.247989E-01,0.247782E-01,0.334555E+00,0.601048E-02,0.316777E+00,
23196 &0.529946E+00,0.234308E-01,0.234798E-01,0.234525E-01,0.234308E-01,
23197 &0.304384E+00,0.624451E-02,0.304214E+00,0.503489E+00,0.220932E-01,
23198 &0.221452E-01,0.221155E-01,0.220932E-01,0.276170E+00,0.637618E-02,
23199 &0.291575E+00,0.477462E+00,0.207739E-01,0.208286E-01,0.207966E-01,
23200 &0.207739E-01,0.249976E+00,0.642028E-02,0.278917E+00,0.451941E+00/
23201 DATA (DL(K),K= 1531, 1615) /
23202 &0.194809E-01,0.195376E-01,0.195037E-01,0.194809E-01,0.225809E+00,
23203 &0.639038E-02,0.266293E+00,0.426995E+00,0.182209E-01,0.182791E-01,
23204 &0.182436E-01,0.182209E-01,0.203629E+00,0.629880E-02,0.253754E+00,
23205 &0.402686E+00,0.169996E-01,0.170587E-01,0.170219E-01,0.169996E-01,
23206 &0.183361E+00,0.615665E-02,0.241347E+00,0.379071E+00,0.158217E-01,
23207 &0.158814E-01,0.158436E-01,0.158217E-01,0.164907E+00,0.597385E-02,
23208 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23209 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23210 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23211 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23212 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23213 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23214 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23215 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23216 &0.395106E+00,0.689399E+00,0.218554E-01,0.218554E-01,0.218554E-01,
23217 &0.218554E-01,0.398362E+00,-.173472E-17,0.381441E+00,0.656777E+00,
23218 &0.207816E-01,0.207886E-01,0.207844E-01,0.207816E-01,0.366703E+00/
23219 DATA (DL(K),K= 1616, 1700) /
23220 &0.826643E-03,0.367505E+00,0.624578E+00,0.197001E-01,0.197133E-01,
23221 &0.197053E-01,0.197001E-01,0.335573E+00,0.149886E-02,0.353373E+00,
23222 &0.592889E+00,0.186195E-01,0.186383E-01,0.186266E-01,0.186195E-01,
23223 &0.305590E+00,0.203730E-02,0.339106E+00,0.561783E+00,0.175468E-01,
23224 &0.175705E-01,0.175555E-01,0.175468E-01,0.277136E+00,0.245817E-02,
23225 &0.324766E+00,0.531331E+00,0.164887E-01,0.165166E-01,0.164986E-01,
23226 &0.164887E-01,0.250424E+00,0.277666E-02,0.310411E+00,0.501599E+00,
23227 &0.154510E-01,0.154825E-01,0.154618E-01,0.154510E-01,0.225588E+00,
23228 &0.300658E-02,0.296100E+00,0.472648E+00,0.144390E-01,0.144735E-01,
23229 &0.144504E-01,0.144390E-01,0.202681E+00,0.316040E-02,0.281885E+00,
23230 &0.444535E+00,0.134570E-01,0.134940E-01,0.134689E-01,0.134570E-01,
23231 &0.181693E+00,0.324944E-02,0.267820E+00,0.417309E+00,0.125091E-01,
23232 &0.125481E-01,0.125212E-01,0.125091E-01,0.162572E+00,0.328396E-02,
23233 &0.253953E+00,0.391017E+00,0.115984E-01,0.116389E-01,0.116106E-01,
23234 &0.115984E-01,0.145235E+00,0.327313E-02,0.240328E+00,0.365695E+00,
23235 &0.107275E-01,0.107690E-01,0.107396E-01,0.107275E-01,0.129575E+00,
23236 &0.322510E-02,0.226989E+00,0.341375E+00,0.989805E-02,0.994030E-02/
23237 DATA (DL(K),K= 1701, 1785) /
23238 &0.990998E-02,0.989805E-02,0.115477E+00,0.314713E-02,0.213972E+00,
23239 &0.318081E+00,0.911149E-02,0.915408E-02,0.912316E-02,0.911149E-02,
23240 &0.102820E+00,0.304556E-02,0.201311E+00,0.295830E+00,0.836852E-02,
23241 &0.841111E-02,0.837984E-02,0.836852E-02,0.914804E-01,0.292596E-02,
23242 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23243 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23244 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23245 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23246 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23247 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23248 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23249 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23250 &0.374678E+00,0.616087E+00,0.139531E-01,0.139531E-01,0.139531E-01,
23251 &0.139531E-01,0.272491E+00,-.693889E-17,0.358052E+00,0.580345E+00,
23252 &0.130624E-01,0.130680E-01,0.130641E-01,0.130624E-01,0.245861E+00,
23253 &0.460255E-03,0.341487E+00,0.545719E+00,0.121971E-01,0.122076E-01,
23254 &0.122002E-01,0.121971E-01,0.220877E+00,0.826785E-03,0.325046E+00/
23255 DATA (DL(K),K= 1786, 1870) /
23256 &0.512244E+00,0.113599E-01,0.113748E-01,0.113641E-01,0.113599E-01,
23257 &0.197730E+00,0.111366E-02,0.308783E+00,0.479952E+00,0.105534E-01,
23258 &0.105720E-01,0.105585E-01,0.105534E-01,0.176497E+00,0.133192E-02,
23259 &0.292747E+00,0.448868E+00,0.977938E-02,0.980112E-02,0.978518E-02,
23260 &0.977938E-02,0.157150E+00,0.149139E-02,0.276986E+00,0.419015E+00,
23261 &0.903955E-02,0.906394E-02,0.904584E-02,0.903955E-02,0.139631E+00,
23262 &0.160093E-02,0.261546E+00,0.390412E+00,0.833509E-02,0.836165E-02,
23263 &0.834171E-02,0.833509E-02,0.123850E+00,0.166838E-02,0.246467E+00,
23264 &0.363074E+00,0.766687E-02,0.769516E-02,0.767369E-02,0.766687E-02,
23265 &0.109695E+00,0.170073E-02,0.231787E+00,0.337008E+00,0.703540E-02,
23266 &0.706500E-02,0.704230E-02,0.703540E-02,0.970428E-01,0.170416E-02,
23267 &0.217542E+00,0.312218E+00,0.644083E-02,0.647137E-02,0.644772E-02,
23268 &0.644083E-02,0.857658E-01,0.168409E-02,0.203759E+00,0.288701E+00,
23269 &0.588300E-02,0.591415E-02,0.588981E-02,0.588300E-02,0.757385E-01,
23270 &0.164528E-02,0.190467E+00,0.266449E+00,0.536147E-02,0.539292E-02,
23271 &0.536812E-02,0.536147E-02,0.668383E-01,0.159185E-02,0.177686E+00,
23272 &0.245447E+00,0.487551E-02,0.490698E-02,0.488195E-02,0.487551E-02/
23273 DATA (DL(K),K= 1871, 1955) /
23274 &0.589492E-01,0.152735E-02,0.165434E+00,0.225677E+00,0.442416E-02,
23275 &0.445543E-02,0.443037E-02,0.442416E-02,0.519652E-01,0.145483E-02,
23276 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23277 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23278 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23279 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23280 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23281 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23282 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23283 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23284 &0.348042E+00,0.534691E+00,0.867977E-02,0.867977E-02,0.867977E-02,
23285 &0.867977E-02,0.182547E+00,-.693889E-17,0.329349E+00,0.498248E+00,
23286 &0.800724E-02,0.801198E-02,0.800836E-02,0.800724E-02,0.161948E+00,
23287 &0.250949E-03,0.311047E+00,0.463485E+00,0.737155E-02,0.738040E-02,
23288 &0.737356E-02,0.737155E-02,0.143267E+00,0.447662E-03,0.293181E+00,
23289 &0.430377E+00,0.677169E-02,0.678409E-02,0.677441E-02,0.677169E-02,
23290 &0.126447E+00,0.598803E-03,0.275787E+00,0.398907E+00,0.620726E-02/
23291 DATA (DL(K),K= 1956, 2040) /
23292 &0.622265E-02,0.621051E-02,0.620726E-02,0.111401E+00,0.711280E-03,
23293 &0.258900E+00,0.369051E+00,0.567741E-02,0.569532E-02,0.568106E-02,
23294 &0.567741E-02,0.979944E-01,0.790986E-03,0.242550E+00,0.340785E+00,
23295 &0.518138E-02,0.520134E-02,0.518531E-02,0.518138E-02,0.860936E-01,
23296 &0.843227E-03,0.226765E+00,0.314083E+00,0.471828E-02,0.473987E-02,
23297 &0.472238E-02,0.471828E-02,0.755615E-01,0.872644E-03,0.211568E+00,
23298 &0.288916E+00,0.428714E-02,0.430998E-02,0.429133E-02,0.428714E-02,
23299 &0.662627E-01,0.883319E-03,0.196981E+00,0.265252E+00,0.388691E-02,
23300 &0.391065E-02,0.389112E-02,0.388691E-02,0.580684E-01,0.878818E-03,
23301 &0.183020E+00,0.243053E+00,0.351645E-02,0.354077E-02,0.352060E-02,
23302 &0.351645E-02,0.508578E-01,0.862228E-03,0.169696E+00,0.222280E+00,
23303 &0.317451E-02,0.319914E-02,0.317858E-02,0.317451E-02,0.445190E-01,
23304 &0.836224E-03,0.157017E+00,0.202888E+00,0.285982E-02,0.288450E-02,
23305 &0.286376E-02,0.285982E-02,0.389523E-01,0.803096E-03,0.144987E+00,
23306 &0.184832E+00,0.257101E-02,0.259553E-02,0.257480E-02,0.257101E-02,
23307 &0.340677E-01,0.764787E-03,0.133605E+00,0.168060E+00,0.230670E-02,
23308 &0.233087E-02,0.231031E-02,0.230670E-02,0.297820E-01,0.722929E-03/
23309 DATA (DL(K),K= 2041, 2125) /
23310 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23311 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23312 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23313 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23314 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23315 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23316 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23317 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23318 &0.316867E+00,0.451111E+00,0.522815E-02,0.522815E-02,0.522815E-02,
23319 &0.522815E-02,0.119118E+00,0.889046E-17,0.296950E+00,0.415915E+00,
23320 &0.475497E-02,0.475914E-02,0.475574E-02,0.475497E-02,0.104204E+00,
23321 &0.132513E-03,0.277735E+00,0.382805E+00,0.431809E-02,0.432582E-02,
23322 &0.431944E-02,0.431809E-02,0.910279E-01,0.235347E-03,0.259241E+00,
23323 &0.351694E+00,0.391455E-02,0.392531E-02,0.391637E-02,0.391455E-02,
23324 &0.794222E-01,0.313322E-03,0.241485E+00,0.322517E+00,0.354249E-02,
23325 &0.355575E-02,0.354464E-02,0.354249E-02,0.692354E-01,0.370408E-03,
23326 &0.224480E+00,0.295202E+00,0.319987E-02,0.321518E-02,0.320226E-02/
23327 DATA (DL(K),K= 2126, 2210) /
23328 &0.319987E-02,0.603106E-01,0.409866E-03,0.208235E+00,0.269681E+00,
23329 &0.288490E-02,0.290184E-02,0.288744E-02,0.288490E-02,0.525034E-01,
23330 &0.434663E-03,0.192759E+00,0.245887E+00,0.259589E-02,0.261407E-02,
23331 &0.259852E-02,0.259589E-02,0.456838E-01,0.447393E-03,0.178054E+00,
23332 &0.223752E+00,0.233123E-02,0.235033E-02,0.233390E-02,0.233123E-02,
23333 &0.397318E-01,0.450314E-03,0.164120E+00,0.203207E+00,0.208941E-02,
23334 &0.210910E-02,0.209206E-02,0.208941E-02,0.345396E-01,0.445394E-03,
23335 &0.150954E+00,0.184182E+00,0.186896E-02,0.188897E-02,0.187155E-02,
23336 &0.186896E-02,0.300131E-01,0.434333E-03,0.138548E+00,0.166608E+00,
23337 &0.166844E-02,0.168854E-02,0.167096E-02,0.166844E-02,0.260692E-01,
23338 &0.418584E-03,0.126892E+00,0.150412E+00,0.148650E-02,0.150648E-02,
23339 &0.148891E-02,0.148650E-02,0.226325E-01,0.399380E-03,0.115971E+00,
23340 &0.135523E+00,0.132180E-02,0.134148E-02,0.132409E-02,0.132180E-02,
23341 &0.196374E-01,0.377764E-03,0.105767E+00,0.121870E+00,0.117308E-02,
23342 &0.119231E-02,0.117524E-02,0.117308E-02,0.170312E-01,0.354610E-03,
23343 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23344 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23345 DATA (DL(K),K= 2211, 2295) /
23346 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23347 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23348 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23349 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23350 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23351 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23352 &0.282579E+00,0.369670E+00,0.302765E-02,0.302765E-02,0.302765E-02,
23353 &0.302765E-02,0.752529E-01,-.455365E-17,0.262229E+00,0.337209E+00,
23354 &0.271512E-02,0.271883E-02,0.271564E-02,0.271512E-02,0.651086E-01,
23355 &0.669321E-04,0.242857E+00,0.307069E+00,0.243269E-02,0.243953E-02,
23356 &0.243360E-02,0.243269E-02,0.563252E-01,0.118744E-03,0.224455E+00,
23357 &0.279111E+00,0.217687E-02,0.218631E-02,0.217808E-02,0.217687E-02,
23358 &0.487143E-01,0.157767E-03,0.207014E+00,0.253223E+00,0.194534E-02,
23359 &0.195689E-02,0.194675E-02,0.194534E-02,0.421227E-01,0.186063E-03,
23360 &0.190523E+00,0.229293E+00,0.173585E-02,0.174909E-02,0.173741E-02,
23361 &0.173585E-02,0.364156E-01,0.205286E-03,0.174969E+00,0.207218E+00,
23362 &0.154647E-02,0.156100E-02,0.154811E-02,0.154647E-02,0.314732E-01/
23363 DATA (DL(K),K= 2296, 2380) /
23364 &0.216964E-03,0.160335E+00,0.186895E+00,0.137545E-02,0.139092E-02,
23365 &0.137713E-02,0.137545E-02,0.271927E-01,0.222455E-03,0.146604E+00,
23366 &0.168227E+00,0.122121E-02,0.123733E-02,0.122290E-02,0.122121E-02,
23367 &0.234852E-01,0.222947E-03,0.133756E+00,0.151116E+00,0.108234E-02,
23368 &0.109881E-02,0.108400E-02,0.108234E-02,0.202747E-01,0.219474E-03,
23369 &0.121765E+00,0.135471E+00,0.957502E-03,0.974107E-03,0.959112E-03,
23370 &0.957502E-03,0.174932E-01,0.212928E-03,0.110606E+00,0.121198E+00,
23371 &0.845493E-03,0.862024E-03,0.847037E-03,0.845493E-03,0.150824E-01,
23372 &0.204075E-03,0.100250E+00,0.108210E+00,0.745196E-03,0.761482E-03,
23373 &0.746662E-03,0.745196E-03,0.129965E-01,0.193573E-03,0.906661E-01,
23374 &0.964191E-01,0.655569E-03,0.671466E-03,0.656948E-03,0.655569E-03,
23375 &0.111930E-01,0.181962E-03,0.818218E-01,0.857412E-01,0.575637E-03,
23376 &0.591030E-03,0.576925E-03,0.575637E-03,0.962922E-02,0.169687E-03,
23377 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23378 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23379 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23380 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23381 DATA (DL(K),K= 2381, 2465) /
23382 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23383 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23384 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23385 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23386 &0.246444E+00,0.293515E+00,0.167124E-02,0.167124E-02,0.167124E-02,
23387 &0.167124E-02,0.456929E-01,-.260209E-17,0.226393E+00,0.264836E+00,
23388 &0.147748E-02,0.148085E-02,0.147783E-02,0.147748E-02,0.392393E-01,
23389 &0.318190E-04,0.207552E+00,0.238550E+00,0.130596E-02,0.131212E-02,
23390 &0.130656E-02,0.130596E-02,0.337276E-01,0.566426E-04,0.189877E+00,
23391 &0.214470E+00,0.115347E-02,0.116190E-02,0.115427E-02,0.115347E-02,
23392 &0.290012E-01,0.753776E-04,0.173336E+00,0.192452E+00,0.101789E-02,
23393 &0.102811E-02,0.101881E-02,0.101789E-02,0.249381E-01,0.889466E-04,
23394 &0.157889E+00,0.172355E+00,0.897268E-03,0.908872E-03,0.898270E-03,
23395 &0.897268E-03,0.214419E-01,0.980950E-04,0.143501E+00,0.154046E+00,
23396 &0.789951E-03,0.802565E-03,0.790996E-03,0.789951E-03,0.184296E-01,
23397 &0.103536E-03,0.130132E+00,0.137402E+00,0.694510E-03,0.707811E-03,
23398 &0.695568E-03,0.694510E-03,0.158331E-01,0.105929E-03,0.117743E+00/
23399 DATA (DL(K),K= 2466, 2550) /
23400 &0.122303E+00,0.609684E-03,0.623394E-03,0.610733E-03,0.609684E-03,
23401 &0.135929E-01,0.105853E-03,0.106293E+00,0.108637E+00,0.534365E-03,
23402 &0.548244E-03,0.535386E-03,0.534365E-03,0.116583E-01,0.103825E-03,
23403 &0.957386E-01,0.962976E-01,0.467572E-03,0.481416E-03,0.468551E-03,
23404 &0.467572E-03,0.999103E-02,0.100301E-03,0.860376E-01,0.851820E-01,
23405 &0.408422E-03,0.422062E-03,0.409350E-03,0.408422E-03,0.855563E-02,
23406 &0.956675E-04,0.771455E-01,0.751930E-01,0.356117E-03,0.369416E-03,
23407 &0.356989E-03,0.356117E-03,0.731542E-02,0.902499E-04,0.690178E-01,
23408 &0.662386E-01,0.309950E-03,0.322797E-03,0.310761E-03,0.309950E-03,
23409 &0.624633E-02,0.843305E-04,0.616096E-01,0.582312E-01,0.269281E-03,
23410 &0.281590E-03,0.270030E-03,0.269281E-03,0.533230E-02,0.781441E-04,
23411 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23412 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23413 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23414 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23415 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23416 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23417 DATA (DL(K),K= 2551, 2635) /
23418 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23419 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23420 &0.209608E+00,0.224862E+00,0.869706E-03,0.869706E-03,0.869706E-03,
23421 &0.869706E-03,0.264204E-01,-.138236E-17,0.190523E+00,0.200603E+00,
23422 &0.757542E-03,0.760626E-03,0.757768E-03,0.757542E-03,0.226261E-01,
23423 &0.138827E-04,0.172819E+00,0.178656E+00,0.660281E-03,0.665837E-03,
23424 &0.660670E-03,0.660281E-03,0.194018E-01,0.249832E-04,0.156420E+00,
23425 &0.158805E+00,0.575414E-03,0.582918E-03,0.575917E-03,0.575414E-03,
23426 &0.166434E-01,0.334851E-04,0.141265E+00,0.140883E+00,0.501258E-03,
23427 &0.510252E-03,0.501836E-03,0.501258E-03,0.142710E-01,0.397017E-04,
23428 &0.127291E+00,0.124732E+00,0.436386E-03,0.446473E-03,0.437008E-03,
23429 &0.436386E-03,0.122297E-01,0.439154E-04,0.114437E+00,0.110205E+00,
23430 &0.379575E-03,0.390415E-03,0.380217E-03,0.379575E-03,0.104701E-01,
23431 &0.464110E-04,0.102644E+00,0.971655E-01,0.329805E-03,0.341109E-03,
23432 &0.330448E-03,0.329805E-03,0.895086E-02,0.474758E-04,0.918521E-01,
23433 &0.854876E-01,0.286206E-03,0.297729E-03,0.286836E-03,0.286206E-03,
23434 &0.764249E-02,0.473771E-04,0.820032E-01,0.750529E-01,0.248027E-03/
23435 DATA (DL(K),K= 2636, 2720) /
23436 &0.259564E-03,0.248633E-03,0.248027E-03,0.651744E-02,0.463561E-04,
23437 &0.730394E-01,0.657510E-01,0.214611E-03,0.225995E-03,0.215186E-03,
23438 &0.214611E-03,0.554573E-02,0.446239E-04,0.649040E-01,0.574789E-01,
23439 &0.185396E-03,0.196491E-03,0.185935E-03,0.185396E-03,0.470938E-02,
23440 &0.423722E-04,0.575411E-01,0.501405E-01,0.159891E-03,0.170590E-03,
23441 &0.160391E-03,0.159891E-03,0.399752E-02,0.397689E-04,0.508960E-01,
23442 &0.436466E-01,0.137650E-03,0.147874E-03,0.138111E-03,0.137650E-03,
23443 &0.338807E-02,0.369434E-04,0.449157E-01,0.379141E-01,0.118285E-03,
23444 &0.127973E-03,0.118705E-03,0.118285E-03,0.286125E-02,0.340035E-04,
23445 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23446 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23447 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23448 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23449 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23450 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23451 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23452 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23453 DATA (DL(K),K= 2721, 2805) /
23454 &0.173133E+00,0.165162E+00,0.420483E-03,0.420483E-03,0.420483E-03,
23455 &0.420483E-03,0.143704E-01,0.418773E-17,0.155600E+00,0.145586E+00,
23456 &0.360490E-03,0.363140E-03,0.360629E-03,0.360490E-03,0.123560E-01,
23457 &0.533279E-05,0.139551E+00,0.128113E+00,0.309555E-03,0.314310E-03,
23458 &0.309792E-03,0.309555E-03,0.106262E-01,0.982612E-05,0.124876E+00,
23459 &0.112516E+00,0.265952E-03,0.272344E-03,0.266256E-03,0.265952E-03,
23460 &0.913151E-02,0.133834E-04,0.111490E+00,0.986188E-01,0.228522E-03,
23461 &0.236138E-03,0.228869E-03,0.228522E-03,0.783135E-02,0.160429E-04,
23462 &0.993081E-01,0.862590E-01,0.196336E-03,0.204821E-03,0.196706E-03,
23463 &0.196336E-03,0.670031E-02,0.178799E-04,0.882484E-01,0.752883E-01,
23464 &0.168604E-03,0.177655E-03,0.168981E-03,0.168604E-03,0.572016E-02,
23465 &0.189837E-04,0.782334E-01,0.655714E-01,0.144684E-03,0.154047E-03,
23466 &0.145058E-03,0.144684E-03,0.487276E-02,0.194655E-04,0.691885E-01,
23467 &0.569841E-01,0.124035E-03,0.133497E-03,0.124397E-03,0.124035E-03,
23468 &0.413648E-02,0.194296E-04,0.610420E-01,0.494128E-01,0.106203E-03,
23469 &0.115592E-03,0.106548E-03,0.106203E-03,0.350042E-02,0.189800E-04,
23470 &0.537249E-01,0.427533E-01,0.908141E-04,0.999895E-04,0.911377E-04/
23471 DATA (DL(K),K= 2806, 2890) /
23472 &0.908141E-04,0.295961E-02,0.182192E-04,0.471713E-01,0.369100E-01,
23473 &0.775359E-04,0.863895E-04,0.778360E-04,0.775359E-04,0.249629E-02,
23474 &0.172287E-04,0.413182E-01,0.317957E-01,0.660857E-04,0.745356E-04,
23475 &0.663611E-04,0.660857E-04,0.209482E-02,0.160791E-04,0.361056E-01,
23476 &0.273306E-01,0.562298E-04,0.642173E-04,0.564804E-04,0.562298E-04,
23477 &0.175588E-02,0.148407E-04,0.314766E-01,0.234421E-01,0.477598E-04,
23478 &0.552457E-04,0.479859E-04,0.477598E-04,0.147398E-02,0.135653E-04,
23479 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23480 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23481 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23482 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23483 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23484 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23485 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23486 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23487 &0.138007E+00,0.115214E+00,0.185072E-03,0.185072E-03,0.185072E-03,
23488 &0.185072E-03,0.722856E-02,-.380826E-17,0.122517E+00,0.100251E+00/
23489 DATA (DL(K),K= 2891, 2975) /
23490 &0.155814E-03,0.158287E-03,0.155901E-03,0.155814E-03,0.630580E-02,
23491 &0.155371E-05,0.108535E+00,0.870870E-01,0.131535E-03,0.135909E-03,
23492 &0.131680E-03,0.131535E-03,0.547867E-02,0.304952E-05,0.959260E-01,
23493 &0.754985E-01,0.111183E-03,0.116980E-03,0.111366E-03,0.111183E-03,
23494 &0.473794E-02,0.433106E-05,0.845828E-01,0.653163E-01,0.940433E-04,
23495 &0.100851E-03,0.942493E-04,0.940433E-04,0.407647E-02,0.533613E-05,
23496 &0.744017E-01,0.563870E-01,0.795843E-04,0.870596E-04,0.798007E-04,
23497 &0.795843E-04,0.349165E-02,0.606691E-05,0.652864E-01,0.485720E-01,
23498 &0.673476E-04,0.752069E-04,0.675656E-04,0.673476E-04,0.297273E-02,
23499 &0.652898E-05,0.571466E-01,0.417472E-01,0.569700E-04,0.649812E-04,
23500 &0.571831E-04,0.569700E-04,0.251732E-02,0.675028E-05,0.498975E-01,
23501 &0.358008E-01,0.481618E-04,0.561391E-04,0.483654E-04,0.481618E-04,
23502 &0.212754E-02,0.677236E-05,0.434594E-01,0.306320E-01,0.406746E-04,
23503 &0.484724E-04,0.408657E-04,0.406746E-04,0.179059E-02,0.662814E-05,
23504 &0.377578E-01,0.261500E-01,0.343050E-04,0.418123E-04,0.344818E-04,
23505 &0.343050E-04,0.149563E-02,0.635273E-05,0.327229E-01,0.222734E-01,
23506 &0.288923E-04,0.360279E-04,0.290540E-04,0.288923E-04,0.124695E-02/
23507 DATA (DL(K),K= 2976, 3060) /
23508 &0.598767E-05,0.282894E-01,0.189287E-01,0.242960E-04,0.310036E-04,
23509 &0.244423E-04,0.242960E-04,0.104112E-02,0.556344E-05,0.243968E-01,
23510 &0.160504E-01,0.203920E-04,0.266363E-04,0.205232E-04,0.203920E-04,
23511 &0.863677E-03,0.510070E-05,0.209890E-01,0.135797E-01,0.170822E-04,
23512 &0.228449E-04,0.171989E-04,0.170822E-04,0.711641E-03,0.462338E-05,
23513 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23514 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23515 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23516 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23517 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23518 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23519 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23520 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23521 &0.105155E+00,0.752467E-01,0.719932E-04,0.719932E-04,0.719932E-04,
23522 &0.719932E-04,0.328057E-02,-.758942E-18,0.920856E-01,0.645455E-01,
23523 &0.592305E-04,0.615087E-04,0.592802E-04,0.592305E-04,0.295327E-02,
23524 &0.945234E-07,0.804695E-01,0.552770E-01,0.489125E-04,0.528632E-04/
23525 DATA (DL(K),K= 3061, 3145) /
23526 &0.489946E-04,0.489125E-04,0.261804E-02,0.365139E-06,0.701499E-01,
23527 &0.472409E-01,0.404786E-04,0.456186E-04,0.405807E-04,0.404786E-04,
23528 &0.229460E-02,0.686912E-06,0.610049E-01,0.402864E-01,0.335367E-04,
23529 &0.394631E-04,0.336495E-04,0.335367E-04,0.198445E-02,0.981070E-06,
23530 &0.529201E-01,0.342803E-01,0.278134E-04,0.342044E-04,0.279301E-04,
23531 &0.278134E-04,0.169772E-02,0.122521E-05,0.457907E-01,0.291037E-01,
23532 &0.230821E-04,0.296833E-04,0.231978E-04,0.230821E-04,0.144575E-02,
23533 &0.140819E-05,0.395205E-01,0.246522E-01,0.191553E-04,0.257661E-04,
23534 &0.192666E-04,0.191553E-04,0.122125E-02,0.152152E-05,0.340212E-01,
23535 &0.208330E-01,0.158874E-04,0.223546E-04,0.159921E-04,0.158874E-04,
23536 &0.101912E-02,0.156880E-05,0.292116E-01,0.175644E-01,0.131678E-04,
23537 &0.193783E-04,0.132645E-04,0.131678E-04,0.847586E-03,0.156432E-05,
23538 &0.250173E-01,0.147740E-01,0.109029E-04,0.167762E-04,0.109910E-04,
23539 &0.109029E-04,0.705515E-03,0.151845E-05,0.213702E-01,0.123979E-01,
23540 &0.901273E-05,0.144953E-04,0.909200E-05,0.901273E-05,0.581767E-03,
23541 &0.143817E-05,0.182083E-01,0.103797E-01,0.743733E-05,0.124978E-04,
23542 &0.750792E-05,0.743733E-05,0.475483E-03,0.133574E-05,0.154751E-01/
23543 DATA (DL(K),K= 3146, 3230) /
23544 &0.867011E-02,0.612722E-05,0.107517E-04,0.618950E-05,0.612722E-05,
23545 &0.390116E-03,0.122183E-05,0.131193E-01,0.722560E-02,0.503734E-05,
23546 &0.922584E-05,0.509185E-05,0.503734E-05,0.319980E-03,0.110130E-05,
23547 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23548 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23549 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23550 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23551 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23552 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23553 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23554 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23555 &0.754424E-01,0.449848E-01,0.236444E-04,0.236444E-04,0.236444E-04,
23556 &0.236444E-04,0.129291E-02,0.113079E-17,0.650429E-01,0.379660E-01,
23557 &0.187739E-04,0.207130E-04,0.187990E-04,0.187739E-04,0.124038E-02,
23558 &-.327995E-06,0.559588E-01,0.319936E-01,0.149625E-04,0.182671E-04,
23559 &0.150033E-04,0.149625E-04,0.113497E-02,-.464337E-06,0.480234E-01,
23560 &0.269030E-01,0.119484E-04,0.161746E-04,0.119982E-04,0.119484E-04/
23561 DATA (DL(K),K= 3231, 3315) /
23562 &0.100877E-02,-.490618E-06,0.411091E-01,0.225716E-01,0.954833E-05,
23563 &0.143391E-04,0.960250E-05,0.954833E-05,0.883852E-03,-.461770E-06,
23564 &0.350995E-01,0.188947E-01,0.763738E-05,0.127129E-04,0.769248E-05,
23565 &0.763738E-05,0.760077E-03,-.403363E-06,0.298897E-01,0.157798E-01,
23566 &0.611070E-05,0.112548E-04,0.616439E-05,0.611070E-05,0.639505E-03,
23567 &-.335607E-06,0.253856E-01,0.131470E-01,0.488993E-05,0.994021E-05,
23568 &0.494070E-05,0.488993E-05,0.534131E-03,-.267652E-06,0.215026E-01,
23569 &0.109271E-01,0.391276E-05,0.875190E-05,0.395967E-05,0.391276E-05,
23570 &0.445478E-03,-.205292E-06,0.181648E-01,0.906007E-02,0.312720E-05,
23571 &0.767418E-05,0.316978E-05,0.312720E-05,0.366232E-03,-.154024E-06,
23572 &0.153041E-01,0.749382E-02,0.249633E-05,0.670002E-05,0.253440E-05,
23573 &0.249633E-05,0.297435E-03,-.112673E-06,0.128596E-01,0.618334E-02,
23574 &0.199074E-05,0.582360E-05,0.202435E-05,0.199074E-05,0.242305E-03,
23575 &-.794410E-07,0.107770E-01,0.508977E-02,0.158457E-05,0.503733E-05,
23576 &0.161393E-05,0.158457E-05,0.196927E-03,-.546702E-07,0.900806E-02,
23577 &0.417964E-02,0.125888E-05,0.433619E-05,0.128428E-05,0.125888E-05,
23578 &0.158171E-03,-.364714E-07,0.751006E-02,0.342418E-02,0.998674E-06/
23579 DATA (DL(K),K= 3316, 3400) /
23580 &0.371518E-05,0.102046E-05,0.998674E-06,0.126865E-03,-.228706E-07,
23581 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23582 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23583 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23584 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23585 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23586 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23587 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23588 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23589 &0.496787E-01,0.236961E-01,0.607312E-05,0.607312E-05,0.607312E-05,
23590 &0.607312E-05,0.415108E-03,-.140523E-17,0.420445E-01,0.196196E-01,
23591 &0.443589E-05,0.603481E-05,0.444683E-05,0.443589E-05,0.444425E-03,
23592 &-.375397E-06,0.355108E-01,0.162223E-01,0.321766E-05,0.587645E-05,
23593 &0.323504E-05,0.321766E-05,0.432635E-03,-.593989E-06,0.299148E-01,
23594 &0.133836E-01,0.231504E-05,0.562250E-05,0.233581E-05,0.231504E-05,
23595 &0.395801E-03,-.699904E-06,0.251339E-01,0.110157E-01,0.164651E-05,
23596 &0.526880E-05,0.166853E-05,0.164651E-05,0.344925E-03,-.733095E-06/
23597 DATA (DL(K),K= 3401, 3485) /
23598 &0.210605E-01,0.904539E-02,0.115940E-05,0.485739E-05,0.118122E-05,
23599 &0.115940E-05,0.294439E-03,-.715193E-06,0.175989E-01,0.740944E-02,
23600 &0.808365E-06,0.441709E-05,0.829075E-06,0.808365E-06,0.249093E-03,
23601 &-.665420E-06,0.146656E-01,0.605433E-02,0.555563E-06,0.396078E-05,
23602 &0.574607E-06,0.555563E-06,0.205675E-03,-.600648E-06,0.121872E-01,
23603 &0.493466E-02,0.375914E-06,0.350822E-05,0.393011E-06,0.375914E-06,
23604 &0.166757E-03,-.529210E-06,0.100993E-01,0.401191E-02,0.250032E-06,
23605 &0.307359E-05,0.265094E-06,0.250032E-06,0.135196E-03,-.456996E-06,
23606 &0.834582E-02,0.325348E-02,0.162261E-06,0.266488E-05,0.175325E-06,
23607 &0.162261E-06,0.108862E-03,-.388821E-06,0.687767E-02,0.263179E-02,
23608 &0.102273E-06,0.228913E-05,0.113453E-06,0.102273E-06,0.865539E-04,
23609 &-.326325E-06,0.565221E-02,0.212357E-02,0.620694E-07,0.194975E-05,
23610 &0.715290E-07,0.620694E-07,0.687156E-04,-.270547E-06,0.463248E-02,
23611 &0.170926E-02,0.351992E-07,0.164711E-05,0.431226E-07,0.351992E-07,
23612 &0.543744E-04,-.222379E-06,0.378655E-02,0.137242E-02,0.178902E-07,
23613 &0.138124E-05,0.244675E-07,0.178902E-07,0.426626E-04,-.181158E-06,
23614 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23615 DATA (DL(K),K= 3486, 3570) /
23616 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23617 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23618 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23619 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23620 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23621 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23622 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23623 &0.286141E-01,0.102357E-01,0.105702E-05,0.105702E-05,0.105702E-05,
23624 &0.105702E-05,0.963318E-04,0.591070E-18,0.236608E-01,0.827483E-02,
23625 &0.548552E-06,0.163293E-05,0.551993E-06,0.548552E-06,0.133058E-03,
23626 &-.268677E-06,0.195282E-01,0.668247E-02,0.238780E-06,0.183459E-05,
23627 &0.243802E-06,0.238780E-06,0.135119E-03,-.393414E-06,0.160742E-01,
23628 &0.538444E-02,0.599864E-07,0.183277E-05,0.655085E-07,0.599864E-07,
23629 &0.124554E-03,-.428349E-06,0.131940E-01,0.432750E-02,-.392825E-07,
23630 &0.172071E-05,-.338391E-07,-.392825E-07,0.111121E-03,-.415550E-06,
23631 &0.107996E-01,0.346954E-02,-.875089E-07,0.154604E-05,-.824926E-07,
23632 &-.875089E-07,0.941854E-04,-.376855E-06,0.881435E-02,0.277463E-02/
23633 DATA (DL(K),K= 3571, 3655) /
23634 &-.103962E-06,0.135013E-05,-.995446E-07,-.103962E-06,0.772195E-04,
23635 &-.326008E-06,0.717317E-02,0.221313E-02,-.102844E-06,0.115335E-05,
23636 &-.990733E-07,-.102844E-06,0.626565E-04,-.272858E-06,0.582050E-02,
23637 &0.176061E-02,-.929503E-07,0.967229E-06,-.898064E-07,-.929503E-07,
23638 &0.499930E-04,-.222828E-06,0.470908E-02,0.139692E-02,-.791495E-07,
23639 &0.800414E-06,-.765797E-07,-.791495E-07,0.394181E-04,-.178141E-06,
23640 &0.379875E-02,0.110542E-02,-.647230E-07,0.655119E-06,-.626567E-07,
23641 &-.647230E-07,0.309999E-04,-.140000E-06,0.305549E-02,0.872447E-03,
23642 &-.515215E-07,0.530834E-06,-.498829E-07,-.515215E-07,0.240354E-04,
23643 &-.108633E-06,0.245058E-02,0.686769E-03,-.400234E-07,0.426835E-06,
23644 &-.387401E-07,-.400234E-07,0.184613E-04,-.832544E-07,0.195984E-02,
23645 &0.539209E-03,-.304312E-07,0.341169E-06,-.294373E-07,-.304312E-07,
23646 &0.143512E-04,-.630818E-07,0.156297E-02,0.422273E-03,-.228633E-07,
23647 &0.271199E-06,-.221014E-07,-.228633E-07,0.110898E-04,-.474683E-07,
23648 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23649 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23650 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23651 DATA (DL(K),K= 3656, 3740) /
23652 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23653 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23654 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23655 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23656 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23657 &0.129345E-01,0.308444E-02,0.903693E-07,0.903693E-07,0.903693E-07,
23658 &0.903693E-07,0.123538E-04,-.166230E-18,0.103598E-01,0.241354E-02,
23659 &0.155648E-06,-.205296E-06,0.154889E-06,0.155648E-06,0.267249E-04,
23660 &0.880707E-07,0.828507E-02,0.188764E-02,0.176333E-06,-.341498E-06,
23661 &0.175220E-06,0.176333E-06,0.306432E-04,0.125718E-06,0.660736E-02,
23662 &0.147304E-02,0.173444E-06,-.383695E-06,0.172215E-06,0.173444E-06,
23663 &0.280787E-04,0.135578E-06,0.525320E-02,0.114618E-02,0.158651E-06,
23664 &-.373371E-06,0.157437E-06,0.158651E-06,0.243526E-04,0.130412E-06,
23665 &0.416429E-02,0.889584E-03,0.137131E-06,-.333468E-06,0.136012E-06,
23666 &0.137131E-06,0.203463E-04,0.116115E-06,0.329102E-02,0.688580E-03,
23667 &0.113839E-06,-.280874E-06,0.112853E-06,0.113839E-06,0.161038E-04,
23668 &0.982305E-07,0.259282E-02,0.531508E-03,0.914374E-07,-.225427E-06/
23669 DATA (DL(K),K= 3741, 3825) /
23670 &0.905971E-07,0.914374E-07,0.125639E-04,0.798741E-07,0.203641E-02,
23671 &0.409120E-03,0.709595E-07,-.173123E-06,0.702607E-07,0.709595E-07,
23672 &0.979247E-05,0.624138E-07,0.159441E-02,0.314027E-03,0.532256E-07,
23673 &-.127272E-06,0.526566E-07,0.532256E-07,0.741899E-05,0.469253E-07,
23674 &0.124447E-02,0.240357E-03,0.385509E-07,-.888851E-07,0.380956E-07,
23675 &0.385509E-07,0.554070E-05,0.339174E-07,0.968328E-03,0.183454E-03,
23676 &0.267272E-07,-.580277E-07,0.263687E-07,0.267272E-07,0.420032E-05,
23677 &0.233280E-07,0.751159E-03,0.139632E-03,0.174605E-07,-.342016E-07,
23678 &0.171822E-07,0.174605E-07,0.315522E-05,0.149727E-07,0.580936E-03,
23679 &0.105986E-03,0.104515E-07,-.164567E-07,0.102383E-07,0.104515E-07,
23680 &0.230829E-05,0.863527E-08,0.447955E-03,0.802293E-04,0.531954E-08,
23681 &-.376312E-08,0.515829E-08,0.531954E-08,0.170771E-05,0.399662E-08,
23682 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23683 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23684 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23685 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23686 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23687 DATA (DL(K),K= 3826, 3910) /
23688 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23689 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23690 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23691 &0.324478E-02,0.386879E-03,0.135983E-08,0.135983E-08,0.135983E-08,
23692 &0.135983E-08,0.371787E-06,-.274599E-19,0.246219E-02,0.286505E-03,
23693 &-.106852E-06,0.327611E-06,-.106589E-06,-.106852E-06,0.231631E-05,
23694 &-.107814E-06,0.186777E-02,0.212413E-03,-.161566E-06,0.492001E-06,
23695 &-.161179E-06,-.161566E-06,0.311589E-05,-.162249E-06,0.141322E-02,
23696 &0.157212E-03,-.183398E-06,0.557106E-06,-.182972E-06,-.183398E-06,
23697 &0.267943E-05,-.183884E-06,0.106518E-02,0.115892E-03,-.185231E-06,
23698 &0.562185E-06,-.184809E-06,-.185231E-06,0.203027E-05,-.185573E-06,
23699 &0.800350E-03,0.851995E-04,-.174680E-06,0.530096E-06,-.174290E-06,
23700 &-.174680E-06,0.165870E-05,-.174922E-06,0.599444E-03,0.624676E-04,
23701 &-.157644E-06,0.478420E-06,-.157300E-06,-.157644E-06,0.130112E-05,
23702 &-.157815E-06,0.447433E-03,0.456556E-04,-.137838E-06,0.418429E-06,
23703 &-.137543E-06,-.137838E-06,0.903220E-06,-.137958E-06,0.332836E-03,
23704 &0.332643E-04,-.117616E-06,0.357179E-06,-.117368E-06,-.117616E-06/
23705 DATA (DL(K),K= 3911, 3995) /
23706 &0.636187E-06,-.117699E-06,0.246754E-03,0.241622E-04,-.984560E-07,
23707 &0.299077E-06,-.982529E-07,-.984560E-07,0.481221E-06,-.985144E-07,
23708 &0.182315E-03,0.174961E-04,-.811089E-07,0.246465E-06,-.809446E-07,
23709 &-.811089E-07,0.342859E-06,-.811495E-07,0.134250E-03,0.126299E-04,
23710 &-.659052E-07,0.200354E-06,-.657742E-07,-.659052E-07,0.227840E-06,
23711 &-.659334E-07,0.985288E-04,0.908931E-05,-.529252E-07,0.160947E-06,
23712 &-.528218E-07,-.529252E-07,0.161641E-06,-.529447E-07,0.720750E-04,
23713 &0.652153E-05,-.420621E-07,0.127943E-06,-.419814E-07,-.420621E-07,
23714 &0.119540E-06,-.420756E-07,0.525538E-04,0.466527E-05,-.331141E-07,
23715 &0.100758E-06,-.330516E-07,-.331141E-07,0.808991E-07,-.331233E-07,
23716 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23717 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23718 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23719 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23720 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23721 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23722 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23723 DATA (DL(K),K= 3996, 4000) /
23724 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23725C
23726 ANS = 0.
23727 IF (X.GT.0.9985) RETURN
23728 IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
23729C
23730 IS = S/DELTA+1
23731 IS1 = IS+1
23732 DO 1 L=1,25
23733 KL = L+NDRV*25
23734 F1(L) = GF(I,IS,KL)
23735 F2(L) = GF(I,IS1,KL)
23736 1 CONTINUE
23737 A1 = DT_CKMTFF(X,F1)
23738 A2 = DT_CKMTFF(X,F2)
23739C A1=ALOG(A1)
23740C A2=ALOG(A2)
23741 S1 = (IS-1)*DELTA
23742 S2 = S1+DELTA
23743 ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
23744C ANS=EXP(ANS)
23745 RETURN
23746 END
23747C
23748C
23749
23750*$ CREATE DT_CKMTPR.FOR
23751*COPY DT_CKMTPR
23752 SUBROUTINE DT_CKMTPR(I,NDRV,X,S,ANS)
23753C
23754C**********************************************************************
23755C Proton - PDFs
23756C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
23757C ANS = PDF(I)
23758C This version by S. Roesler, 31.01.96
23759C**********************************************************************
23760
23761 SAVE
23762 DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
23763 EQUIVALENCE (GF(1,1,1),DL(1))
23764 DATA DELTA/.10/
23765C
23766 DATA (DL(K),K= 1, 85) /
23767 &0.367759E+00,0.350609E+00,0.325356E+00,0.325356E+00,0.325356E+00,
23768 &0.325356E+00,0.533117E+01,0.138778E-16,0.427988E+00,0.409718E+00,
23769 &0.382948E+00,0.382920E+00,0.382933E+00,0.382948E+00,0.686279E+01,
23770 &0.611113E-01,0.494752E+00,0.475328E+00,0.447011E+00,0.446959E+00,
23771 &0.446984E+00,0.447011E+00,0.855688E+01,0.128659E+00,0.568248E+00,
23772 &0.547637E+00,0.517743E+00,0.517671E+00,0.517705E+00,0.517743E+00,
23773 &0.104074E+02,0.202846E+00,0.648622E+00,0.626792E+00,0.595289E+00,
23774 &0.595201E+00,0.595244E+00,0.595289E+00,0.124065E+02,0.283819E+00,
23775 &0.735974E+00,0.712890E+00,0.679748E+00,0.679648E+00,0.679696E+00,
23776 &0.679748E+00,0.145441E+02,0.371679E+00,0.830359E+00,0.805987E+00,
23777 &0.771173E+00,0.771066E+00,0.771119E+00,0.771173E+00,0.168081E+02,
23778 &0.466485E+00,0.931778E+00,0.906084E+00,0.869566E+00,0.869456E+00,
23779 &0.869511E+00,0.869566E+00,0.191850E+02,0.568240E+00,0.104018E+01,
23780 &0.101313E+01,0.974873E+00,0.974763E+00,0.974819E+00,0.974873E+00,
23781 &0.216593E+02,0.676890E+00,0.115544E+01,0.112700E+01,0.108698E+01,
23782 &0.108687E+01,0.108693E+01,0.108698E+01,0.242146E+02,0.792321E+00,
23783 &0.127738E+01,0.124751E+01,0.120570E+01,0.120560E+01,0.120565E+01/
23784 DATA (DL(K),K= 86, 170) /
23785 &0.120570E+01,0.268333E+02,0.914356E+00,0.140577E+01,0.137444E+01,
23786 &0.133079E+01,0.133070E+01,0.133075E+01,0.133079E+01,0.294970E+02,
23787 &0.104275E+01,0.154028E+01,0.150745E+01,0.146194E+01,0.146187E+01,
23788 &0.146192E+01,0.146194E+01,0.321867E+02,0.117720E+01,0.168054E+01,
23789 &0.164619E+01,0.159879E+01,0.159874E+01,0.159877E+01,0.159879E+01,
23790 &0.348836E+02,0.131732E+01,0.182613E+01,0.179020E+01,0.174088E+01,
23791 &0.174086E+01,0.174088E+01,0.174088E+01,0.375685E+02,0.146269E+01,
23792 &0.197653E+01,0.193901E+01,0.188774E+01,0.188774E+01,0.188775E+01,
23793 &0.188774E+01,0.402228E+02,0.161282E+01,0.213121E+01,0.209205E+01,
23794 &0.203880E+01,0.203884E+01,0.203884E+01,0.203880E+01,0.428285E+02,
23795 &0.176714E+01,0.228955E+01,0.224873E+01,0.219348E+01,0.219355E+01,
23796 &0.219353E+01,0.219348E+01,0.453682E+02,0.192507E+01,0.245093E+01,
23797 &0.240840E+01,0.235113E+01,0.235123E+01,0.235120E+01,0.235113E+01,
23798 &0.478258E+02,0.208597E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23799 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23800 &0.349839E+00,0.324128E+00,0.286363E+00,0.286363E+00,0.286363E+00,
23801 &0.286363E+00,0.469694E+01,0.000000E+00,0.398361E+00,0.371065E+00/
23802 DATA (DL(K),K= 171, 255) /
23803 &0.331239E+00,0.331213E+00,0.331227E+00,0.331239E+00,0.586152E+01,
23804 &0.481683E-01,0.451010E+00,0.422096E+00,0.380182E+00,0.380137E+00,
23805 &0.380161E+00,0.380182E+00,0.711349E+01,0.100378E+00,0.507782E+00,
23806 &0.477215E+00,0.433187E+00,0.433128E+00,0.433160E+00,0.433187E+00,
23807 &0.844371E+01,0.156627E+00,0.568644E+00,0.536390E+00,0.490220E+00,
23808 &0.490152E+00,0.490190E+00,0.490220E+00,0.984291E+01,0.216886E+00,
23809 &0.633517E+00,0.599543E+00,0.551204E+00,0.551133E+00,0.551174E+00,
23810 &0.551204E+00,0.113005E+02,0.281079E+00,0.702295E+00,0.666565E+00,
23811 &0.616031E+00,0.615963E+00,0.616004E+00,0.616031E+00,0.128050E+02,
23812 &0.349101E+00,0.774832E+00,0.737311E+00,0.684556E+00,0.684495E+00,
23813 &0.684535E+00,0.684556E+00,0.143447E+02,0.420809E+00,0.850945E+00,
23814 &0.811598E+00,0.756596E+00,0.756547E+00,0.756583E+00,0.756596E+00,
23815 &0.159073E+02,0.496022E+00,0.930413E+00,0.889207E+00,0.831933E+00,
23816 &0.831901E+00,0.831931E+00,0.831933E+00,0.174801E+02,0.574524E+00,
23817 &0.101298E+01,0.969882E+00,0.910312E+00,0.910301E+00,0.910324E+00,
23818 &0.910312E+00,0.190508E+02,0.656061E+00,0.109836E+01,0.105333E+01,
23819 &0.991445E+00,0.991459E+00,0.991471E+00,0.991445E+00,0.206070E+02/
23820 DATA (DL(K),K= 256, 340) /
23821 &0.740345E+00,0.118622E+01,0.113923E+01,0.107501E+01,0.107505E+01,
23822 &0.107505E+01,0.107501E+01,0.221368E+02,0.827056E+00,0.127622E+01,
23823 &0.122724E+01,0.116065E+01,0.116073E+01,0.116072E+01,0.116065E+01,
23824 &0.236287E+02,0.915845E+00,0.136797E+01,0.131696E+01,0.124800E+01,
23825 &0.124812E+01,0.124809E+01,0.124800E+01,0.250721E+02,0.100634E+01,
23826 &0.146107E+01,0.140801E+01,0.133666E+01,0.133681E+01,0.133677E+01,
23827 &0.133666E+01,0.264571E+02,0.109813E+01,0.155511E+01,0.149996E+01,
23828 &0.142621E+01,0.142641E+01,0.142634E+01,0.142621E+01,0.277747E+02,
23829 &0.119081E+01,0.164964E+01,0.159239E+01,0.151622E+01,0.151646E+01,
23830 &0.151638E+01,0.151622E+01,0.290168E+02,0.128396E+01,0.174424E+01,
23831 &0.168485E+01,0.160626E+01,0.160655E+01,0.160645E+01,0.160626E+01,
23832 &0.301765E+02,0.137713E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23833 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23834 &0.345345E+00,0.306823E+00,0.250518E+00,0.250518E+00,0.250518E+00,
23835 &0.250518E+00,0.411726E+01,-.138778E-16,0.384210E+00,0.343514E+00,
23836 &0.284500E+00,0.284487E+00,0.284496E+00,0.284500E+00,0.496835E+01,
23837 &0.371582E-01,0.425419E+00,0.382518E+00,0.320782E+00,0.320762E+00/
23838 DATA (DL(K),K= 341, 425) /
23839 &0.320777E+00,0.320782E+00,0.585504E+01,0.765988E-01,0.468853E+00,
23840 &0.423717E+00,0.359246E+00,0.359226E+00,0.359243E+00,0.359246E+00,
23841 &0.676824E+01,0.118207E+00,0.514392E+00,0.466990E+00,0.399771E+00,
23842 &0.399758E+00,0.399775E+00,0.399771E+00,0.769967E+01,0.161865E+00,
23843 &0.561883E+00,0.512186E+00,0.442209E+00,0.442208E+00,0.442222E+00,
23844 &0.442209E+00,0.864071E+01,0.207426E+00,0.611162E+00,0.559140E+00,
23845 &0.486395E+00,0.486411E+00,0.486420E+00,0.486395E+00,0.958280E+01,
23846 &0.254727E+00,0.662044E+00,0.607667E+00,0.532145E+00,0.532185E+00,
23847 &0.532185E+00,0.532145E+00,0.105176E+02,0.303587E+00,0.714325E+00,
23848 &0.657566E+00,0.579261E+00,0.579328E+00,0.579318E+00,0.579261E+00,
23849 &0.114370E+02,0.353808E+00,0.767786E+00,0.708618E+00,0.627526E+00,
23850 &0.627625E+00,0.627603E+00,0.627526E+00,0.123333E+02,0.405174E+00,
23851 &0.822195E+00,0.760591E+00,0.676711E+00,0.676846E+00,0.676810E+00,
23852 &0.676711E+00,0.131994E+02,0.457458E+00,0.877307E+00,0.813242E+00,
23853 &0.726575E+00,0.726750E+00,0.726697E+00,0.726575E+00,0.140286E+02,
23854 &0.510420E+00,0.932865E+00,0.866317E+00,0.776867E+00,0.777085E+00,
23855 &0.777015E+00,0.776867E+00,0.148150E+02,0.563809E+00,0.988608E+00/
23856 DATA (DL(K),K= 426, 510) /
23857 &0.919556E+00,0.827330E+00,0.827594E+00,0.827505E+00,0.827330E+00,
23858 &0.155533E+02,0.617368E+00,0.104427E+01,0.972694E+00,0.877703E+00,
23859 &0.878016E+00,0.877907E+00,0.877703E+00,0.162391E+02,0.670837E+00,
23860 &0.109958E+01,0.102547E+01,0.927723E+00,0.928088E+00,0.927957E+00,
23861 &0.927723E+00,0.168687E+02,0.723954E+00,0.115428E+01,0.107761E+01,
23862 &0.977132E+00,0.977550E+00,0.977397E+00,0.977132E+00,0.174391E+02,
23863 &0.776458E+00,0.120809E+01,0.112886E+01,0.102567E+01,0.102615E+01,
23864 &0.102597E+01,0.102567E+01,0.179481E+02,0.828097E+00,0.126078E+01,
23865 &0.117898E+01,0.107310E+01,0.107363E+01,0.107343E+01,0.107310E+01,
23866 &0.183942E+02,0.878621E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23867 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23868 &0.357586E+00,0.299938E+00,0.216504E+00,0.216504E+00,0.216504E+00,
23869 &0.216504E+00,0.357260E+01,-.277556E-16,0.388529E+00,0.327984E+00,
23870 &0.241161E+00,0.241168E+00,0.241168E+00,0.241161E+00,0.415893E+01,
23871 &0.278429E-01,0.420472E+00,0.357015E+00,0.266823E+00,0.266844E+00,
23872 &0.266842E+00,0.266823E+00,0.474689E+01,0.566783E-01,0.453271E+00,
23873 &0.386886E+00,0.293349E+00,0.293389E+00,0.293381E+00,0.293349E+00/
23874 DATA (DL(K),K= 511, 595) /
23875 &0.532982E+01,0.863668E-01,0.486793E+00,0.417464E+00,0.320608E+00,
23876 &0.320673E+00,0.320657E+00,0.320608E+00,0.590219E+01,0.116779E+00,
23877 &0.520887E+00,0.448601E+00,0.348454E+00,0.348549E+00,0.348523E+00,
23878 &0.348454E+00,0.645868E+01,0.147773E+00,0.555403E+00,0.480149E+00,
23879 &0.376740E+00,0.376870E+00,0.376831E+00,0.376740E+00,0.699440E+01,
23880 &0.179201E+00,0.590183E+00,0.511950E+00,0.405314E+00,0.405482E+00,
23881 &0.405429E+00,0.405314E+00,0.750493E+01,0.210912E+00,0.625064E+00,
23882 &0.543845E+00,0.434019E+00,0.434229E+00,0.434159E+00,0.434019E+00,
23883 &0.798636E+01,0.242750E+00,0.659882E+00,0.575673E+00,0.462696E+00,
23884 &0.462952E+00,0.462864E+00,0.462696E+00,0.843528E+01,0.274558E+00,
23885 &0.694472E+00,0.607271E+00,0.491188E+00,0.491492E+00,0.491385E+00,
23886 &0.491188E+00,0.884885E+01,0.306178E+00,0.728669E+00,0.638478E+00,
23887 &0.519337E+00,0.519690E+00,0.519563E+00,0.519337E+00,0.922480E+01,
23888 &0.337451E+00,0.762311E+00,0.669133E+00,0.546987E+00,0.547392E+00,
23889 &0.547244E+00,0.546987E+00,0.956139E+01,0.368224E+00,0.795240E+00,
23890 &0.699084E+00,0.573988E+00,0.574447E+00,0.574277E+00,0.573988E+00,
23891 &0.985744E+01,0.398346E+00,0.827302E+00,0.728181E+00,0.600196E+00/
23892 DATA (DL(K),K= 596, 680) /
23893 &0.600710E+00,0.600518E+00,0.600196E+00,0.101123E+02,0.427671E+00,
23894 &0.858354E+00,0.756282E+00,0.625475E+00,0.626044E+00,0.625829E+00,
23895 &0.625475E+00,0.103258E+02,0.456064E+00,0.888257E+00,0.783256E+00,
23896 &0.649696E+00,0.650321E+00,0.650083E+00,0.649696E+00,0.104982E+02,
23897 &0.483395E+00,0.916887E+00,0.808981E+00,0.672742E+00,0.673422E+00,
23898 &0.673161E+00,0.672742E+00,0.106303E+02,0.509546E+00,0.944126E+00,
23899 &0.833345E+00,0.694506E+00,0.695243E+00,0.694958E+00,0.694506E+00,
23900 &0.107231E+02,0.534410E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23901 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23902 &0.390721E+00,0.304671E+00,0.182562E+00,0.182562E+00,0.182562E+00,
23903 &0.182562E+00,0.303699E+01,0.693889E-17,0.414806E+00,0.325059E+00,
23904 &0.199103E+00,0.199133E+00,0.199124E+00,0.199103E+00,0.339971E+01,
23905 &0.198528E-01,0.438929E+00,0.345508E+00,0.215797E+00,0.215862E+00,
23906 &0.215842E+00,0.215797E+00,0.374624E+01,0.398420E-01,0.462973E+00,
23907 &0.365903E+00,0.232531E+00,0.232635E+00,0.232601E+00,0.232531E+00,
23908 &0.407322E+01,0.598565E-01,0.486835E+00,0.386142E+00,0.249208E+00,
23909 &0.249352E+00,0.249304E+00,0.249208E+00,0.437817E+01,0.797987E-01/
23910 DATA (DL(K),K= 681, 765) /
23911 &0.510407E+00,0.406123E+00,0.265725E+00,0.265913E+00,0.265849E+00,
23912 &0.265725E+00,0.465901E+01,0.995694E-01,0.533588E+00,0.425746E+00,
23913 &0.281986E+00,0.282220E+00,0.282139E+00,0.281986E+00,0.491410E+01,
23914 &0.119072E+00,0.556274E+00,0.444912E+00,0.297897E+00,0.298178E+00,
23915 &0.298079E+00,0.297897E+00,0.514220E+01,0.138212E+00,0.578369E+00,
23916 &0.463528E+00,0.313366E+00,0.313696E+00,0.313578E+00,0.313366E+00,
23917 &0.534249E+01,0.156900E+00,0.599777E+00,0.481503E+00,0.328308E+00,
23918 &0.328688E+00,0.328549E+00,0.328308E+00,0.551456E+01,0.175048E+00,
23919 &0.620409E+00,0.498752E+00,0.342642E+00,0.343071E+00,0.342913E+00,
23920 &0.342642E+00,0.565833E+01,0.192575E+00,0.640181E+00,0.515196E+00,
23921 &0.356292E+00,0.356770E+00,0.356592E+00,0.356292E+00,0.577410E+01,
23922 &0.209407E+00,0.659017E+00,0.530764E+00,0.369190E+00,0.369718E+00,
23923 &0.369519E+00,0.369190E+00,0.586243E+01,0.225474E+00,0.676845E+00,
23924 &0.545389E+00,0.381275E+00,0.381852E+00,0.381633E+00,0.381275E+00,
23925 &0.592421E+01,0.240714E+00,0.693604E+00,0.559015E+00,0.392493E+00,
23926 &0.393118E+00,0.392880E+00,0.392493E+00,0.596052E+01,0.255072E+00,
23927 &0.709239E+00,0.571593E+00,0.402799E+00,0.403472E+00,0.403213E+00/
23928 DATA (DL(K),K= 766, 850) /
23929 &0.402799E+00,0.597267E+01,0.268502E+00,0.723703E+00,0.583081E+00,
23930 &0.412157E+00,0.412875E+00,0.412597E+00,0.412157E+00,0.596211E+01,
23931 &0.280966E+00,0.736960E+00,0.593447E+00,0.420536E+00,0.421299E+00,
23932 &0.421002E+00,0.420536E+00,0.593045E+01,0.292434E+00,0.748980E+00,
23933 &0.602669E+00,0.427918E+00,0.428723E+00,0.428408E+00,0.427918E+00,
23934 &0.587934E+01,0.302884E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23935 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23936 &0.448390E+00,0.320678E+00,0.146415E+00,0.146415E+00,0.146415E+00,
23937 &0.146415E+00,0.247594E+01,0.000000E+00,0.465760E+00,0.333734E+00,
23938 &0.155974E+00,0.156013E+00,0.156000E+00,0.155974E+00,0.265633E+01,
23939 &0.130329E-01,0.482525E+00,0.346293E+00,0.165233E+00,0.165311E+00,
23940 &0.165285E+00,0.165233E+00,0.281612E+01,0.257304E-01,0.498626E+00,
23941 &0.358294E+00,0.174131E+00,0.174249E+00,0.174209E+00,0.174131E+00,
23942 &0.295484E+01,0.380345E-01,0.514008E+00,0.369688E+00,0.182622E+00,
23943 &0.182779E+00,0.182724E+00,0.182622E+00,0.307242E+01,0.498976E-01,
23944 &0.528624E+00,0.380432E+00,0.190660E+00,0.190856E+00,0.190786E+00,
23945 &0.190660E+00,0.316911E+01,0.612760E-01,0.542428E+00,0.390485E+00/
23946 DATA (DL(K),K= 851, 935) /
23947 &0.198205E+00,0.198441E+00,0.198356E+00,0.198205E+00,0.324538E+01,
23948 &0.721303E-01,0.555382E+00,0.399810E+00,0.205224E+00,0.205498E+00,
23949 &0.205398E+00,0.205224E+00,0.330192E+01,0.824256E-01,0.567448E+00,
23950 &0.408377E+00,0.211687E+00,0.211997E+00,0.211882E+00,0.211687E+00,
23951 &0.333960E+01,0.921319E-01,0.578597E+00,0.416159E+00,0.217568E+00,
23952 &0.217915E+00,0.217784E+00,0.217568E+00,0.335945E+01,0.101224E+00,
23953 &0.588802E+00,0.423136E+00,0.222847E+00,0.223229E+00,0.223084E+00,
23954 &0.222847E+00,0.336262E+01,0.109681E+00,0.598043E+00,0.429293E+00,
23955 &0.227512E+00,0.227928E+00,0.227768E+00,0.227512E+00,0.335036E+01,
23956 &0.117489E+00,0.606305E+00,0.434619E+00,0.231551E+00,0.232000E+00,
23957 &0.231826E+00,0.231551E+00,0.332398E+01,0.124636E+00,0.613579E+00,
23958 &0.439110E+00,0.234962E+00,0.235442E+00,0.235254E+00,0.234962E+00,
23959 &0.328483E+01,0.131119E+00,0.619860E+00,0.442766E+00,0.237745E+00,
23960 &0.238254E+00,0.238053E+00,0.237745E+00,0.323429E+01,0.136936E+00,
23961 &0.625150E+00,0.445594E+00,0.239905E+00,0.240441E+00,0.240228E+00,
23962 &0.239905E+00,0.317371E+01,0.142091E+00,0.629453E+00,0.447603E+00,
23963 &0.241452E+00,0.242014E+00,0.241788E+00,0.241452E+00,0.310443E+01/
23964 DATA (DL(K),K= 936, 1020) /
23965 &0.146594E+00,0.632782E+00,0.448808E+00,0.242400E+00,0.242987E+00,
23966 &0.242749E+00,0.242400E+00,0.302775E+01,0.150456E+00,0.635151E+00,
23967 &0.449228E+00,0.242767E+00,0.243376E+00,0.243127E+00,0.242767E+00,
23968 &0.294491E+01,0.153694E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23969 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23970 &0.528765E+00,0.341825E+00,0.105823E+00,0.105823E+00,0.105823E+00,
23971 &0.105823E+00,0.185069E+01,-.138778E-16,0.538124E+00,0.347118E+00,
23972 &0.109762E+00,0.109780E+00,0.109774E+00,0.109762E+00,0.189644E+01,
23973 &0.738880E-02,0.546541E+00,0.351712E+00,0.113300E+00,0.113336E+00,
23974 &0.113324E+00,0.113300E+00,0.192700E+01,0.143076E-01,0.554014E+00,
23975 &0.355607E+00,0.116431E+00,0.116485E+00,0.116466E+00,0.116431E+00,
23976 &0.194356E+01,0.207515E-01,0.560546E+00,0.358805E+00,0.119150E+00,
23977 &0.119222E+00,0.119196E+00,0.119150E+00,0.194722E+01,0.267179E-01,
23978 &0.566139E+00,0.361311E+00,0.121459E+00,0.121549E+00,0.121515E+00,
23979 &0.121459E+00,0.193921E+01,0.322084E-01,0.570802E+00,0.363134E+00,
23980 &0.123359E+00,0.123467E+00,0.123426E+00,0.123359E+00,0.192071E+01,
23981 &0.372262E-01,0.574542E+00,0.364286E+00,0.124858E+00,0.124983E+00/
23982 DATA (DL(K),K= 1021, 1105) /
23983 &0.124933E+00,0.124858E+00,0.189295E+01,0.417774E-01,0.577372E+00,
23984 &0.364779E+00,0.125961E+00,0.126103E+00,0.126046E+00,0.125961E+00,
23985 &0.185710E+01,0.458703E-01,0.579307E+00,0.364629E+00,0.126681E+00,
23986 &0.126839E+00,0.126774E+00,0.126681E+00,0.181432E+01,0.495154E-01,
23987 &0.580363E+00,0.363857E+00,0.127029E+00,0.127202E+00,0.127130E+00,
23988 &0.127029E+00,0.176571E+01,0.527252E-01,0.580561E+00,0.362483E+00,
23989 &0.127020E+00,0.127208E+00,0.127128E+00,0.127020E+00,0.171231E+01,
23990 &0.555142E-01,0.579923E+00,0.360529E+00,0.126670E+00,0.126872E+00,
23991 &0.126785E+00,0.126670E+00,0.165511E+01,0.578985E-01,0.578474E+00,
23992 &0.358021E+00,0.125998E+00,0.126213E+00,0.126119E+00,0.125998E+00,
23993 &0.159501E+01,0.598958E-01,0.576241E+00,0.354987E+00,0.125022E+00,
23994 &0.125249E+00,0.125148E+00,0.125022E+00,0.153284E+01,0.615248E-01,
23995 &0.573252E+00,0.351453E+00,0.123762E+00,0.124000E+00,0.123893E+00,
23996 &0.123762E+00,0.146934E+01,0.628056E-01,0.569539E+00,0.347450E+00,
23997 &0.122240E+00,0.122488E+00,0.122375E+00,0.122240E+00,0.140517E+01,
23998 &0.637587E-01,0.565134E+00,0.343008E+00,0.120476E+00,0.120733E+00,
23999 &0.120615E+00,0.120476E+00,0.134093E+01,0.644054E-01,0.560071E+00/
24000 DATA (DL(K),K= 1106, 1190) /
24001 &0.338158E+00,0.118493E+00,0.118758E+00,0.118635E+00,0.118493E+00,
24002 &0.127712E+01,0.647671E-01,0.000000E+00,0.000000E+00,0.000000E+00,
24003 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24004 &0.584093E+00,0.349173E+00,0.772117E-01,0.772117E-01,0.772117E-01,
24005 &0.772117E-01,0.140433E+01,0.346945E-17,0.586736E+00,0.349017E+00,
24006 &0.785355E-01,0.785519E-01,0.785448E-01,0.785355E-01,0.139434E+01,
24007 &0.447504E-02,0.588402E+00,0.348237E+00,0.795437E-01,0.795759E-01,
24008 &0.795617E-01,0.795437E-01,0.137550E+01,0.854114E-02,0.589124E+00,
24009 &0.346861E+00,0.802498E-01,0.802970E-01,0.802758E-01,0.802498E-01,
24010 &0.134918E+01,0.122148E-01,0.588930E+00,0.344912E+00,0.806656E-01,
24011 &0.807271E-01,0.806990E-01,0.806656E-01,0.131652E+01,0.155101E-01,
24012 &0.587849E+00,0.342417E+00,0.808055E-01,0.808805E-01,0.808457E-01,
24013 &0.808055E-01,0.127862E+01,0.184435E-01,0.585912E+00,0.339402E+00,
24014 &0.806843E-01,0.807718E-01,0.807306E-01,0.806843E-01,0.123648E+01,
24015 &0.210315E-01,0.583151E+00,0.335894E+00,0.803173E-01,0.804166E-01,
24016 &0.803692E-01,0.803173E-01,0.119104E+01,0.232909E-01,0.579599E+00,
24017 &0.331923E+00,0.797205E-01,0.798308E-01,0.797775E-01,0.797205E-01/
24018 DATA (DL(K),K= 1191, 1275) /
24019 &0.114317E+01,0.252394E-01,0.575288E+00,0.327516E+00,0.789107E-01,
24020 &0.790310E-01,0.789721E-01,0.789107E-01,0.109362E+01,0.268946E-01,
24021 &0.570253E+00,0.322704E+00,0.779045E-01,0.780341E-01,0.779698E-01,
24022 &0.779045E-01,0.104307E+01,0.282745E-01,0.564530E+00,0.317515E+00,
24023 &0.767190E-01,0.768570E-01,0.767878E-01,0.767190E-01,0.992143E+00,
24024 &0.293974E-01,0.558155E+00,0.311981E+00,0.753713E-01,0.755169E-01,
24025 &0.754432E-01,0.753713E-01,0.941341E+00,0.302812E-01,0.551166E+00,
24026 &0.306131E+00,0.738784E-01,0.740308E-01,0.739528E-01,0.738784E-01,
24027 &0.891113E+00,0.309441E-01,0.543599E+00,0.299995E+00,0.722571E-01,
24028 &0.724154E-01,0.723336E-01,0.722571E-01,0.841829E+00,0.314037E-01,
24029 &0.535494E+00,0.293603E+00,0.705237E-01,0.706871E-01,0.706019E-01,
24030 &0.705237E-01,0.793794E+00,0.316774E-01,0.526888E+00,0.286986E+00,
24031 &0.686941E-01,0.688619E-01,0.687736E-01,0.686941E-01,0.747249E+00,
24032 &0.317823E-01,0.517822E+00,0.280172E+00,0.667836E-01,0.669551E-01,
24033 &0.668640E-01,0.667836E-01,0.702381E+00,0.317346E-01,0.508333E+00,
24034 &0.273189E+00,0.648068E-01,0.649814E-01,0.648879E-01,0.648068E-01,
24035 &0.659330E+00,0.315501E-01,0.000000E+00,0.000000E+00,0.000000E+00/
24036 DATA (DL(K),K= 1276, 1360) /
24037 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24038 &0.622739E+00,0.340676E+00,0.509141E-01,0.509141E-01,0.509141E-01,
24039 &0.509141E-01,0.980502E+00,-.173472E-17,0.617764E+00,0.335457E+00,
24040 &0.507607E-01,0.507701E-01,0.507651E-01,0.507607E-01,0.944375E+00,
24041 &0.242386E-02,0.611957E+00,0.329837E+00,0.504236E-01,0.504417E-01,
24042 &0.504321E-01,0.504236E-01,0.905225E+00,0.455851E-02,0.605372E+00,
24043 &0.323853E+00,0.499207E-01,0.499471E-01,0.499328E-01,0.499207E-01,
24044 &0.864035E+00,0.642656E-02,0.598052E+00,0.317537E+00,0.492668E-01,
24045 &0.493008E-01,0.492822E-01,0.492668E-01,0.821557E+00,0.804638E-02,
24046 &0.590044E+00,0.310919E+00,0.484772E-01,0.485183E-01,0.484955E-01,
24047 &0.484772E-01,0.778444E+00,0.943663E-02,0.581391E+00,0.304033E+00,
24048 &0.475665E-01,0.476142E-01,0.475874E-01,0.475665E-01,0.735263E+00,
24049 &0.106150E-01,0.572137E+00,0.296908E+00,0.465487E-01,0.466024E-01,
24050 &0.465720E-01,0.465487E-01,0.692487E+00,0.115984E-01,0.562326E+00,
24051 &0.289573E+00,0.454376E-01,0.454968E-01,0.454629E-01,0.454376E-01,
24052 &0.650510E+00,0.124032E-01,0.552003E+00,0.282060E+00,0.442463E-01,
24053 &0.443103E-01,0.442733E-01,0.442463E-01,0.609652E+00,0.130451E-01/
24054 DATA (DL(K),K= 1361, 1445) /
24055 &0.541210E+00,0.274395E+00,0.429871E-01,0.430555E-01,0.430156E-01,
24056 &0.429871E-01,0.570164E+00,0.135389E-01,0.529991E+00,0.266608E+00,
24057 &0.416720E-01,0.417443E-01,0.417018E-01,0.416720E-01,0.532237E+00,
24058 &0.138989E-01,0.518389E+00,0.258725E+00,0.403123E-01,0.403879E-01,
24059 &0.403431E-01,0.403123E-01,0.496010E+00,0.141386E-01,0.506446E+00,
24060 &0.250772E+00,0.389186E-01,0.389971E-01,0.389501E-01,0.389186E-01,
24061 &0.461573E+00,0.142708E-01,0.494204E+00,0.242775E+00,0.375006E-01,
24062 &0.375815E-01,0.375327E-01,0.375006E-01,0.428979E+00,0.143074E-01,
24063 &0.481705E+00,0.234757E+00,0.360674E-01,0.361503E-01,0.361000E-01,
24064 &0.360674E-01,0.398246E+00,0.142598E-01,0.468990E+00,0.226741E+00,
24065 &0.346276E-01,0.347120E-01,0.346605E-01,0.346276E-01,0.369363E+00,
24066 &0.141385E-01,0.456098E+00,0.218750E+00,0.331887E-01,0.332743E-01,
24067 &0.332216E-01,0.331887E-01,0.342300E+00,0.139532E-01,0.443068E+00,
24068 &0.210804E+00,0.317576E-01,0.318440E-01,0.317905E-01,0.317576E-01,
24069 &0.317005E+00,0.137130E-01,0.000000E+00,0.000000E+00,0.000000E+00,
24070 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24071 &0.631458E+00,0.318714E+00,0.335640E-01,0.335640E-01,0.335640E-01/
24072 DATA (DL(K),K= 1446, 1530) /
24073 &0.335640E-01,0.686773E+00,0.346945E-17,0.620274E+00,0.310241E+00,
24074 &0.329311E-01,0.329377E-01,0.329337E-01,0.329311E-01,0.646559E+00,
24075 &0.135960E-02,0.608504E+00,0.301610E+00,0.322083E-01,0.322210E-01,
24076 &0.322133E-01,0.322083E-01,0.606503E+00,0.252820E-02,0.596205E+00,
24077 &0.292854E+00,0.314099E-01,0.314281E-01,0.314169E-01,0.314099E-01,
24078 &0.567134E+00,0.352543E-02,0.583429E+00,0.284002E+00,0.305470E-01,
24079 &0.305704E-01,0.305558E-01,0.305470E-01,0.528824E+00,0.436693E-02,
24080 &0.570223E+00,0.275080E+00,0.296307E-01,0.296586E-01,0.296411E-01,
24081 &0.296307E-01,0.491848E+00,0.506768E-02,0.556637E+00,0.266115E+00,
24082 &0.286709E-01,0.287030E-01,0.286827E-01,0.286709E-01,0.456422E+00,
24083 &0.564157E-02,0.542717E+00,0.257131E+00,0.276770E-01,0.277128E-01,
24084 &0.276900E-01,0.276770E-01,0.422697E+00,0.610148E-02,0.528511E+00,
24085 &0.248154E+00,0.266578E-01,0.266968E-01,0.266718E-01,0.266578E-01,
24086 &0.390771E+00,0.645942E-02,0.514062E+00,0.239205E+00,0.256210E-01,
24087 &0.256629E-01,0.256359E-01,0.256210E-01,0.360700E+00,0.672653E-02,
24088 &0.499417E+00,0.230307E+00,0.245741E-01,0.246185E-01,0.245896E-01,
24089 &0.245741E-01,0.332498E+00,0.691312E-02,0.484617E+00,0.221480E+00/
24090 DATA (DL(K),K= 1531, 1615) /
24091 &0.235237E-01,0.235701E-01,0.235397E-01,0.235237E-01,0.306153E+00,
24092 &0.702875E-02,0.469706E+00,0.212745E+00,0.224757E-01,0.225238E-01,
24093 &0.224921E-01,0.224757E-01,0.281624E+00,0.708222E-02,0.454725E+00,
24094 &0.204118E+00,0.214355E-01,0.214850E-01,0.214522E-01,0.214355E-01,
24095 &0.258855E+00,0.708159E-02,0.439713E+00,0.195618E+00,0.204079E-01,
24096 &0.204586E-01,0.204249E-01,0.204079E-01,0.237774E+00,0.703428E-02,
24097 &0.424709E+00,0.187259E+00,0.193972E-01,0.194486E-01,0.194142E-01,
24098 &0.193972E-01,0.218298E+00,0.694702E-02,0.409750E+00,0.179057E+00,
24099 &0.184069E-01,0.184588E-01,0.184239E-01,0.184069E-01,0.200339E+00,
24100 &0.682594E-02,0.394870E+00,0.171023E+00,0.174402E-01,0.174924E-01,
24101 &0.174571E-01,0.174402E-01,0.183804E+00,0.667657E-02,0.380104E+00,
24102 &0.163171E+00,0.164997E-01,0.165519E-01,0.165164E-01,0.164997E-01,
24103 &0.168600E+00,0.650389E-02,0.000000E+00,0.000000E+00,0.000000E+00,
24104 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24105 &0.619056E+00,0.288873E+00,0.218554E-01,0.218554E-01,0.218554E-01,
24106 &0.218554E-01,0.477010E+00,-.867362E-17,0.602890E+00,0.278444E+00,
24107 &0.211480E-01,0.211530E-01,0.211497E-01,0.211480E-01,0.440877E+00/
24108 DATA (DL(K),K= 1616, 1700) /
24109 &0.767466E-03,0.586431E+00,0.268081E+00,0.204081E-01,0.204175E-01,
24110 &0.204113E-01,0.204081E-01,0.406417E+00,0.141432E-02,0.569736E+00,
24111 &0.257807E+00,0.196446E-01,0.196581E-01,0.196491E-01,0.196446E-01,
24112 &0.373808E+00,0.195508E-02,0.552853E+00,0.247642E+00,0.188646E-01,
24113 &0.188816E-01,0.188701E-01,0.188646E-01,0.343145E+00,0.240123E-02,
24114 &0.535829E+00,0.237603E+00,0.180743E-01,0.180945E-01,0.180808E-01,
24115 &0.180743E-01,0.314460E+00,0.276332E-02,0.518710E+00,0.227710E+00,
24116 &0.172796E-01,0.173025E-01,0.172868E-01,0.172796E-01,0.287750E+00,
24117 &0.305100E-02,0.501539E+00,0.217977E+00,0.164854E-01,0.165108E-01,
24118 &0.164933E-01,0.164854E-01,0.262983E+00,0.327305E-02,0.484360E+00,
24119 &0.208420E+00,0.156964E-01,0.157239E-01,0.157049E-01,0.156964E-01,
24120 &0.240098E+00,0.343744E-02,0.467213E+00,0.199053E+00,0.149165E-01,
24121 &0.149457E-01,0.149254E-01,0.149165E-01,0.219021E+00,0.355144E-02,
24122 &0.450140E+00,0.189889E+00,0.141493E-01,0.141800E-01,0.141586E-01,
24123 &0.141493E-01,0.199660E+00,0.362164E-02,0.433177E+00,0.180939E+00,
24124 &0.133978E-01,0.134297E-01,0.134073E-01,0.133978E-01,0.181918E+00,
24125 &0.365401E-02,0.416362E+00,0.172214E+00,0.126646E-01,0.126974E-01/
24126 DATA (DL(K),K= 1701, 1785) /
24127 &0.126742E-01,0.126646E-01,0.165692E+00,0.365394E-02,0.399729E+00,
24128 &0.163725E+00,0.119518E-01,0.119853E-01,0.119615E-01,0.119518E-01,
24129 &0.150875E+00,0.362628E-02,0.383310E+00,0.155477E+00,0.112613E-01,
24130 &0.112952E-01,0.112711E-01,0.112613E-01,0.137364E+00,0.357539E-02,
24131 &0.367138E+00,0.147479E+00,0.105945E-01,0.106287E-01,0.106042E-01,
24132 &0.105945E-01,0.125056E+00,0.350515E-02,0.351239E+00,0.139737E+00,
24133 &0.995250E-02,0.998673E-02,0.996211E-02,0.995250E-02,0.113852E+00,
24134 &0.341903E-02,0.335641E+00,0.132253E+00,0.933610E-02,0.937024E-02,
24135 &0.934557E-02,0.933610E-02,0.103659E+00,0.332009E-02,0.320367E+00,
24136 &0.125033E+00,0.874584E-02,0.877973E-02,0.875514E-02,0.874584E-02,
24137 &0.943886E-01,0.321106E-02,0.000000E+00,0.000000E+00,0.000000E+00,
24138 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24139 &0.591114E+00,0.254807E+00,0.139531E-01,0.139531E-01,0.139531E-01,
24140 &0.139531E-01,0.326288E+00,0.000000E+00,0.571121E+00,0.243424E+00,
24141 &0.133325E-01,0.133362E-01,0.133336E-01,0.133325E-01,0.296956E+00,
24142 &0.429082E-03,0.551151E+00,0.232297E+00,0.127105E-01,0.127175E-01,
24143 &0.127126E-01,0.127105E-01,0.269811E+00,0.785137E-03,0.531253E+00/
24144 DATA (DL(K),K= 1786, 1870) /
24145 &0.221436E+00,0.120916E-01,0.121015E-01,0.120945E-01,0.120916E-01,
24146 &0.244803E+00,0.107790E-02,0.511467E+00,0.210850E+00,0.114794E-01,
24147 &0.114918E-01,0.114829E-01,0.114794E-01,0.221863E+00,0.131504E-02,
24148 &0.491833E+00,0.200545E+00,0.108767E-01,0.108913E-01,0.108808E-01,
24149 &0.108767E-01,0.200886E+00,0.150337E-02,0.472388E+00,0.190531E+00,
24150 &0.102861E-01,0.103027E-01,0.102907E-01,0.102861E-01,0.181762E+00,
24151 &0.164910E-02,0.453170E+00,0.180812E+00,0.970979E-02,0.972799E-02,
24152 &0.971477E-02,0.970979E-02,0.164371E+00,0.175777E-02,0.434213E+00,
24153 &0.171394E+00,0.914959E-02,0.916916E-02,0.915488E-02,0.914959E-02,
24154 &0.148589E+00,0.183434E-02,0.415548E+00,0.162282E+00,0.860700E-02,
24155 &0.862770E-02,0.861252E-02,0.860700E-02,0.134293E+00,0.188328E-02,
24156 &0.397208E+00,0.153479E+00,0.808323E-02,0.810484E-02,0.808891E-02,
24157 &0.808323E-02,0.121361E+00,0.190856E-02,0.379220E+00,0.144989E+00,
24158 &0.757922E-02,0.760152E-02,0.758501E-02,0.757922E-02,0.109676E+00,
24159 &0.191374E-02,0.361611E+00,0.136811E+00,0.709565E-02,0.711846E-02,
24160 &0.710150E-02,0.709565E-02,0.991261E-01,0.190199E-02,0.344406E+00,
24161 &0.128948E+00,0.663300E-02,0.665614E-02,0.663885E-02,0.663300E-02/
24162 DATA (DL(K),K= 1871, 1955) /
24163 &0.896059E-01,0.187610E-02,0.327627E+00,0.121398E+00,0.619152E-02,
24164 &0.621484E-02,0.619734E-02,0.619152E-02,0.810177E-01,0.183856E-02,
24165 &0.311292E+00,0.114161E+00,0.577130E-02,0.579466E-02,0.577706E-02,
24166 &0.577130E-02,0.732709E-01,0.179155E-02,0.295421E+00,0.107235E+00,
24167 &0.537228E-02,0.539554E-02,0.537794E-02,0.537228E-02,0.662824E-01,
24168 &0.173700E-02,0.280026E+00,0.100616E+00,0.499423E-02,0.501728E-02,
24169 &0.499977E-02,0.499423E-02,0.599766E-01,0.167658E-02,0.265121E+00,
24170 &0.943000E-01,0.463683E-02,0.465958E-02,0.464223E-02,0.463683E-02,
24171 &0.542848E-01,0.161174E-02,0.000000E+00,0.000000E+00,0.000000E+00,
24172 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24173 &0.551659E+00,0.219084E+00,0.867977E-02,0.867977E-02,0.867977E-02,
24174 &0.867977E-02,0.218587E+00,-.173472E-16,0.528947E+00,0.207536E+00,
24175 &0.819621E-02,0.819909E-02,0.819696E-02,0.819621E-02,0.196367E+00,
24176 &0.234843E-03,0.506575E+00,0.196391E+00,0.772540E-02,0.773082E-02,
24177 &0.772680E-02,0.772540E-02,0.176280E+00,0.427503E-03,0.484579E+00,
24178 &0.185646E+00,0.726876E-02,0.727639E-02,0.727069E-02,0.726876E-02,
24179 &0.158158E+00,0.583933E-03,0.462988E+00,0.175298E+00,0.682746E-02/
24180 DATA (DL(K),K= 1956, 2040) /
24181 &0.683702E-02,0.682985E-02,0.682746E-02,0.141851E+00,0.708874E-03,
24182 &0.441830E+00,0.165345E+00,0.640226E-02,0.641347E-02,0.640502E-02,
24183 &0.640226E-02,0.127203E+00,0.806409E-03,0.421129E+00,0.155783E+00,
24184 &0.599380E-02,0.600641E-02,0.599686E-02,0.599380E-02,0.114065E+00,
24185 &0.880249E-03,0.400912E+00,0.146609E+00,0.560252E-02,0.561629E-02,
24186 &0.560581E-02,0.560252E-02,0.102296E+00,0.933676E-03,0.381199E+00,
24187 &0.137819E+00,0.522870E-02,0.524342E-02,0.523217E-02,0.522870E-02,
24188 &0.917608E-01,0.969607E-03,0.362011E+00,0.129407E+00,0.487247E-02,
24189 &0.488796E-02,0.487607E-02,0.487247E-02,0.823356E-01,0.990632E-03,
24190 &0.343367E+00,0.121370E+00,0.453385E-02,0.454992E-02,0.453753E-02,
24191 &0.453385E-02,0.739054E-01,0.999042E-03,0.325282E+00,0.113700E+00,
24192 &0.421272E-02,0.422921E-02,0.421644E-02,0.421272E-02,0.663651E-01,
24193 &0.996863E-03,0.307770E+00,0.106393E+00,0.390887E-02,0.392563E-02,
24194 &0.391260E-02,0.390887E-02,0.596195E-01,0.985881E-03,0.290841E+00,
24195 &0.994399E-01,0.362199E-02,0.363889E-02,0.362570E-02,0.362199E-02,
24196 &0.535826E-01,0.967664E-03,0.274506E+00,0.928343E-01,0.335170E-02,
24197 &0.336862E-02,0.335536E-02,0.335170E-02,0.481769E-01,0.943587E-03/
24198 DATA (DL(K),K= 2041, 2125) /
24199 &0.258771E+00,0.865679E-01,0.309756E-02,0.311439E-02,0.310114E-02,
24200 &0.309756E-02,0.433336E-01,0.914850E-03,0.243639E+00,0.806321E-01,
24201 &0.285905E-02,0.287571E-02,0.286255E-02,0.285905E-02,0.389912E-01,
24202 &0.882497E-03,0.229113E+00,0.750177E-01,0.263565E-02,0.265205E-02,
24203 &0.263905E-02,0.263565E-02,0.350948E-01,0.847432E-03,0.215193E+00,
24204 &0.697152E-01,0.242677E-02,0.244285E-02,0.243005E-02,0.242677E-02,
24205 &0.315960E-01,0.810432E-03,0.000000E+00,0.000000E+00,0.000000E+00,
24206 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24207 &0.503850E+00,0.183581E+00,0.522815E-02,0.522815E-02,0.522815E-02,
24208 &0.522815E-02,0.142635E+00,0.123599E-16,0.479478E+00,0.172477E+00,
24209 &0.488093E-02,0.488328E-02,0.488147E-02,0.488093E-02,0.126767E+00,
24210 &0.124505E-03,0.455750E+00,0.161879E+00,0.455054E-02,0.455493E-02,
24211 &0.455153E-02,0.455054E-02,0.112695E+00,0.225968E-03,0.432681E+00,
24212 &0.151771E+00,0.423664E-02,0.424278E-02,0.423800E-02,0.423664E-02,
24213 &0.100212E+00,0.307702E-03,0.410286E+00,0.142140E+00,0.393907E-02,
24214 &0.394671E-02,0.394073E-02,0.393907E-02,0.891488E-01,0.372395E-03,
24215 &0.388577E+00,0.132974E+00,0.365743E-02,0.366634E-02,0.365934E-02/
24216 DATA (DL(K),K= 2126, 2210) /
24217 &0.365743E-02,0.793490E-01,0.422302E-03,0.367563E+00,0.124259E+00,
24218 &0.339138E-02,0.340133E-02,0.339347E-02,0.339138E-02,0.706688E-01,
24219 &0.459484E-03,0.347256E+00,0.115984E+00,0.314049E-02,0.315129E-02,
24220 &0.314273E-02,0.314049E-02,0.629792E-01,0.485762E-03,0.327660E+00,
24221 &0.108136E+00,0.290433E-02,0.291580E-02,0.290667E-02,0.290433E-02,
24222 &0.561642E-01,0.502744E-03,0.308782E+00,0.100701E+00,0.268243E-02,
24223 &0.269440E-02,0.268483E-02,0.268243E-02,0.501207E-01,0.511853E-03,
24224 &0.290625E+00,0.936693E-01,0.247429E-02,0.248663E-02,0.247672E-02,
24225 &0.247429E-02,0.447569E-01,0.514346E-03,0.273189E+00,0.870261E-01,
24226 &0.227939E-02,0.229197E-02,0.228184E-02,0.227939E-02,0.399920E-01,
24227 &0.511328E-03,0.256475E+00,0.807592E-01,0.209722E-02,0.210991E-02,
24228 &0.209965E-02,0.209722E-02,0.357547E-01,0.503769E-03,0.240478E+00,
24229 &0.748555E-01,0.192721E-02,0.193992E-02,0.192961E-02,0.192721E-02,
24230 &0.319825E-01,0.492518E-03,0.225194E+00,0.693019E-01,0.176883E-02,
24231 &0.178147E-02,0.177117E-02,0.176883E-02,0.286209E-01,0.478318E-03,
24232 &0.210615E+00,0.640851E-01,0.162151E-02,0.163400E-02,0.162379E-02,
24233 &0.162151E-02,0.256219E-01,0.461813E-03,0.196733E+00,0.591917E-01/
24234 DATA (DL(K),K= 2211, 2295) /
24235 &0.148471E-02,0.149698E-02,0.148691E-02,0.148471E-02,0.229436E-01,
24236 &0.443561E-03,0.183536E+00,0.546085E-01,0.135786E-02,0.136986E-02,
24237 &0.135998E-02,0.135786E-02,0.205496E-01,0.424043E-03,0.171011E+00,
24238 &0.503219E-01,0.124042E-02,0.125211E-02,0.124246E-02,0.124042E-02,
24239 &0.184079E-01,0.403672E-03,0.000000E+00,0.000000E+00,0.000000E+00,
24240 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24241 &0.450310E+00,0.149685E+00,0.302765E-02,0.302765E-02,0.302765E-02,
24242 &0.302765E-02,0.901099E-01,-.108420E-17,0.425282E+00,0.139479E+00,
24243 &0.279499E-02,0.279691E-02,0.279537E-02,0.279499E-02,0.794239E-01,
24244 &0.632140E-04,0.401169E+00,0.129837E+00,0.257801E-02,0.258157E-02,
24245 &0.257870E-02,0.257801E-02,0.700941E-01,0.114711E-03,0.377966E+00,
24246 &0.120733E+00,0.237556E-02,0.238052E-02,0.237650E-02,0.237556E-02,
24247 &0.619270E-01,0.156107E-03,0.355668E+00,0.112145E+00,0.218688E-02,
24248 &0.219301E-02,0.218802E-02,0.218688E-02,0.547717E-01,0.188777E-03,
24249 &0.334269E+00,0.104052E+00,0.201113E-02,0.201823E-02,0.201243E-02,
24250 &0.201113E-02,0.484974E-01,0.213848E-03,0.313762E+00,0.964335E-01,
24251 &0.184758E-02,0.185546E-02,0.184900E-02,0.184758E-02,0.429879E-01/
24252 DATA (DL(K),K= 2296, 2380) /
24253 &0.232367E-03,0.294139E+00,0.892696E-01,0.169553E-02,0.170402E-02,
24254 &0.169703E-02,0.169553E-02,0.381432E-01,0.245270E-03,0.275389E+00,
24255 &0.825414E-01,0.155431E-02,0.156326E-02,0.155586E-02,0.155431E-02,
24256 &0.338762E-01,0.253383E-03,0.257502E+00,0.762303E-01,0.142329E-02,
24257 &0.143258E-02,0.142487E-02,0.142329E-02,0.301119E-01,0.257441E-03,
24258 &0.240464E+00,0.703180E-01,0.130188E-02,0.131138E-02,0.130347E-02,
24259 &0.130188E-02,0.267853E-01,0.258098E-03,0.224262E+00,0.647867E-01,
24260 &0.118950E-02,0.119912E-02,0.119108E-02,0.118950E-02,0.238409E-01,
24261 &0.255929E-03,0.208879E+00,0.596190E-01,0.108562E-02,0.109526E-02,
24262 &0.108717E-02,0.108562E-02,0.212308E-01,0.251442E-03,0.194298E+00,
24263 &0.547975E-01,0.989698E-03,0.999283E-03,0.991221E-03,0.989698E-03,
24264 &0.189136E-01,0.245082E-03,0.180499E+00,0.503054E-01,0.901248E-03,
24265 &0.910711E-03,0.902726E-03,0.901248E-03,0.168537E-01,0.237238E-03,
24266 &0.167463E+00,0.461263E-01,0.819789E-03,0.829074E-03,0.821215E-03,
24267 &0.819789E-03,0.150206E-01,0.228250E-03,0.155167E+00,0.422438E-01,
24268 &0.744866E-03,0.753925E-03,0.746234E-03,0.744866E-03,0.133878E-01,
24269 &0.218412E-03,0.143590E+00,0.386421E-01,0.676043E-03,0.684836E-03/
24270 DATA (DL(K),K= 2381, 2465) /
24271 &0.677349E-03,0.676043E-03,0.119320E-01,0.207976E-03,0.132706E+00,
24272 &0.353058E-01,0.612907E-03,0.621403E-03,0.614147E-03,0.612907E-03,
24273 &0.106334E-01,0.197159E-03,0.000000E+00,0.000000E+00,0.000000E+00,
24274 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24275 &0.393307E+00,0.118409E+00,0.167124E-02,0.167124E-02,0.167124E-02,
24276 &0.167124E-02,0.547140E-01,0.433681E-17,0.368555E+00,0.109414E+00,
24277 &0.152547E-02,0.152705E-02,0.152573E-02,0.152547E-02,0.479708E-01,
24278 &0.303147E-04,0.344946E+00,0.101001E+00,0.139202E-02,0.139494E-02,
24279 &0.139249E-02,0.139202E-02,0.421517E-01,0.552185E-04,0.322450E+00,
24280 &0.931345E-01,0.126960E-02,0.127363E-02,0.127024E-02,0.126960E-02,
24281 &0.371043E-01,0.753524E-04,0.301043E+00,0.857854E-01,0.115731E-02,
24282 &0.116225E-02,0.115808E-02,0.115731E-02,0.327131E-01,0.913172E-04,
24283 &0.280698E+00,0.789267E-01,0.105427E-02,0.105995E-02,0.105514E-02,
24284 &0.105427E-02,0.288844E-01,0.103605E-03,0.261390E+00,0.725323E-01,
24285 &0.959726E-03,0.965979E-03,0.960659E-03,0.959726E-03,0.255366E-01,
24286 &0.112688E-03,0.243091E+00,0.665774E-01,0.872987E-03,0.879676E-03,
24287 &0.873966E-03,0.872987E-03,0.226017E-01,0.119000E-03,0.225775E+00/
24288 DATA (DL(K),K= 2466, 2550) /
24289 &0.610385E-01,0.793435E-03,0.800438E-03,0.794441E-03,0.793435E-03,
24290 &0.200219E-01,0.122931E-03,0.209414E+00,0.558928E-01,0.720508E-03,
24291 &0.727716E-03,0.721524E-03,0.720508E-03,0.177490E-01,0.124835E-03,
24292 &0.193979E+00,0.511187E-01,0.653691E-03,0.661011E-03,0.654703E-03,
24293 &0.653691E-03,0.157425E-01,0.125031E-03,0.179441E+00,0.466950E-01,
24294 &0.592513E-03,0.599863E-03,0.593511E-03,0.592513E-03,0.139674E-01,
24295 &0.123805E-03,0.165770E+00,0.426018E-01,0.536539E-03,0.543850E-03,
24296 &0.537513E-03,0.536539E-03,0.123945E-01,0.121411E-03,0.152935E+00,
24297 &0.388195E-01,0.485370E-03,0.492584E-03,0.486314E-03,0.485370E-03,
24298 &0.109993E-01,0.118076E-03,0.140905E+00,0.353295E-01,0.438636E-03,
24299 &0.445702E-03,0.439543E-03,0.438636E-03,0.976027E-02,0.113999E-03,
24300 &0.129648E+00,0.321137E-01,0.395992E-03,0.402871E-03,0.396859E-03,
24301 &0.395992E-03,0.865895E-02,0.109353E-03,0.119131E+00,0.291550E-01,
24302 &0.357120E-03,0.363779E-03,0.357945E-03,0.357120E-03,0.767960E-02,
24303 &0.104292E-03,0.109323E+00,0.264366E-01,0.321725E-03,0.328139E-03,
24304 &0.322505E-03,0.321725E-03,0.680866E-02,0.989468E-04,0.100191E+00,
24305 &0.239428E-01,0.289531E-03,0.295679E-03,0.290266E-03,0.289531E-03/
24306 DATA (DL(K),K= 2551, 2635) /
24307 &0.603390E-02,0.934295E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24308 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24309 &0.334851E+00,0.904666E-01,0.869706E-03,0.869706E-03,0.869706E-03,
24310 &0.869706E-03,0.316365E-01,-.311708E-17,0.311223E+00,0.828706E-01,
24311 &0.784673E-03,0.785968E-03,0.784847E-03,0.784673E-03,0.277037E-01,
24312 &0.134749E-04,0.288910E+00,0.758361E-01,0.708234E-03,0.710597E-03,
24313 &0.708543E-03,0.708234E-03,0.243298E-01,0.247881E-04,0.267855E+00,
24314 &0.693222E-01,0.639256E-03,0.642491E-03,0.639671E-03,0.639256E-03,
24315 &0.214125E-01,0.340882E-04,0.248015E+00,0.632964E-01,0.576953E-03,
24316 &0.580887E-03,0.577448E-03,0.576953E-03,0.188764E-01,0.415701E-04,
24317 &0.229343E+00,0.577274E-01,0.520615E-03,0.525096E-03,0.521167E-03,
24318 &0.520615E-03,0.166642E-01,0.474027E-04,0.211794E+00,0.525860E-01,
24319 &0.469624E-03,0.474520E-03,0.470215E-03,0.469624E-03,0.147265E-01,
24320 &0.517615E-04,0.195325E+00,0.478447E-01,0.423445E-03,0.428640E-03,
24321 &0.424060E-03,0.423445E-03,0.130234E-01,0.548213E-04,0.179891E+00,
24322 &0.434776E-01,0.381606E-03,0.387001E-03,0.382232E-03,0.381606E-03,
24323 &0.115226E-01,0.567474E-04,0.165449E+00,0.394601E-01,0.343691E-03/
24324 DATA (DL(K),K= 2636, 2720) /
24325 &0.349200E-03,0.344317E-03,0.343691E-03,0.101965E-01,0.576952E-04,
24326 &0.151958E+00,0.357691E-01,0.309329E-03,0.314879E-03,0.309948E-03,
24327 &0.309329E-03,0.902217E-02,0.578101E-04,0.139374E+00,0.323826E-01,
24328 &0.278192E-03,0.283721E-03,0.278796E-03,0.278192E-03,0.798131E-02,
24329 &0.572266E-04,0.127655E+00,0.292797E-01,0.249984E-03,0.255440E-03,
24330 &0.250569E-03,0.249984E-03,0.705796E-02,0.560672E-04,0.116760E+00,
24331 &0.264406E-01,0.224440E-03,0.229782E-03,0.225002E-03,0.224440E-03,
24332 &0.623793E-02,0.544420E-04,0.106647E+00,0.238467E-01,0.201321E-03,
24333 &0.206513E-03,0.201856E-03,0.201321E-03,0.550962E-02,0.524504E-04,
24334 &0.972762E-01,0.214802E-01,0.180411E-03,0.185425E-03,0.180918E-03,
24335 &0.180411E-03,0.486321E-02,0.501804E-04,0.886073E-01,0.193242E-01,
24336 &0.161512E-03,0.166328E-03,0.161990E-03,0.161512E-03,0.428946E-02,
24337 &0.477087E-04,0.806013E-01,0.173629E-01,0.144446E-03,0.149048E-03,
24338 &0.144894E-03,0.144446E-03,0.378030E-02,0.451020E-04,0.732197E-01,
24339 &0.155814E-01,0.129049E-03,0.133425E-03,0.129467E-03,0.129049E-03,
24340 &0.332897E-02,0.424179E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24341 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24342 DATA (DL(K),K= 2721, 2805) /
24343 &0.276761E+00,0.663170E-01,0.420483E-03,0.420483E-03,0.420483E-03,
24344 &0.420483E-03,0.172075E-01,0.418773E-17,0.255003E+00,0.601925E-01,
24345 &0.374768E-03,0.375776E-03,0.374876E-03,0.374768E-03,0.151410E-01,
24346 &0.540038E-05,0.234664E+00,0.545789E-01,0.334420E-03,0.336252E-03,
24347 &0.334612E-03,0.334420E-03,0.133594E-01,0.101360E-04,0.215665E+00,
24348 &0.494328E-01,0.298611E-03,0.301108E-03,0.298867E-03,0.298611E-03,
24349 &0.118079E-01,0.141555E-04,0.197941E+00,0.447203E-01,0.266766E-03,
24350 &0.269787E-03,0.267068E-03,0.266766E-03,0.104461E-01,0.174750E-04,
24351 &0.181428E+00,0.404089E-01,0.238391E-03,0.241815E-03,0.238726E-03,
24352 &0.238391E-03,0.924609E-02,0.201244E-04,0.166064E+00,0.364687E-01,
24353 &0.213061E-03,0.216782E-03,0.213417E-03,0.213061E-03,0.818507E-02,
24354 &0.221467E-04,0.151790E+00,0.328719E-01,0.190418E-03,0.194343E-03,
24355 &0.190785E-03,0.190418E-03,0.724366E-02,0.235974E-04,0.138548E+00,
24356 &0.295925E-01,0.170150E-03,0.174202E-03,0.170521E-03,0.170150E-03,
24357 &0.640614E-02,0.245354E-04,0.126282E+00,0.266063E-01,0.151991E-03,
24358 &0.156104E-03,0.152359E-03,0.151991E-03,0.566089E-02,0.250221E-04,
24359 &0.114939E+00,0.238907E-01,0.135710E-03,0.139827E-03,0.136071E-03/
24360 DATA (DL(K),K= 2806, 2890) /
24361 &0.135710E-03,0.499773E-02,0.251191E-04,0.104465E+00,0.214245E-01,
24362 &0.121106E-03,0.125180E-03,0.121455E-03,0.121106E-03,0.440691E-02,
24363 &0.248850E-04,0.948101E-01,0.191879E-01,0.108002E-03,0.111994E-03,
24364 &0.108337E-03,0.108002E-03,0.388094E-02,0.243760E-04,0.859247E-01,
24365 &0.171625E-01,0.962435E-04,0.100124E-03,0.965624E-04,0.962435E-04,
24366 &0.341379E-02,0.236445E-04,0.777613E-01,0.153309E-01,0.856948E-04,
24367 &0.894394E-04,0.859960E-04,0.856948E-04,0.299910E-02,0.227378E-04,
24368 &0.702736E-01,0.136770E-01,0.762337E-04,0.798235E-04,0.765166E-04,
24369 &0.762337E-04,0.263116E-02,0.216984E-04,0.634174E-01,0.121859E-01,
24370 &0.677528E-04,0.711742E-04,0.680169E-04,0.677528E-04,0.230551E-02,
24371 &0.205642E-04,0.571500E-01,0.108434E-01,0.601554E-04,0.633990E-04,
24372 &0.604008E-04,0.601554E-04,0.201791E-02,0.193681E-04,0.514305E-01,
24373 &0.963651E-02,0.533545E-04,0.564148E-04,0.535814E-04,0.533545E-04,
24374 &0.176404E-02,0.181381E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24375 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24376 &0.220700E+00,0.461964E-01,0.185072E-03,0.185072E-03,0.185072E-03,
24377 &0.185072E-03,0.865568E-02,-.294090E-17,0.201438E+00,0.415162E-01/
24378 DATA (DL(K),K= 2891, 2975) /
24379 &0.162774E-03,0.163610E-03,0.162842E-03,0.162774E-03,0.772611E-02,
24380 &0.184134E-05,0.183625E+00,0.372730E-01,0.143469E-03,0.144974E-03,
24381 &0.143588E-03,0.143469E-03,0.690038E-02,0.359959E-05,0.167162E+00,
24382 &0.334245E-01,0.126634E-03,0.128666E-03,0.126791E-03,0.126634E-03,
24383 &0.616000E-02,0.518075E-05,0.151966E+00,0.299378E-01,0.111904E-03,
24384 &0.114340E-03,0.112088E-03,0.111904E-03,0.549219E-02,0.654232E-05,
24385 &0.137959E+00,0.267821E-01,0.989836E-04,0.101716E-03,0.991845E-04,
24386 &0.989836E-04,0.488896E-02,0.767008E-05,0.125065E+00,0.239289E-01,
24387 &0.876157E-04,0.905559E-04,0.878269E-04,0.876157E-04,0.434253E-02,
24388 &0.855860E-05,0.113213E+00,0.213524E-01,0.775899E-04,0.806611E-04,
24389 &0.778055E-04,0.775899E-04,0.384886E-02,0.921640E-05,0.102335E+00,
24390 &0.190285E-01,0.687292E-04,0.718676E-04,0.689446E-04,0.687292E-04,
24391 &0.340422E-02,0.965961E-05,0.923671E-01,0.169353E-01,0.608829E-04,
24392 &0.640353E-04,0.610944E-04,0.608829E-04,0.300332E-02,0.990752E-05,
24393 &0.832476E-01,0.150523E-01,0.539242E-04,0.570473E-04,0.541291E-04,
24394 &0.539242E-04,0.264288E-02,0.998320E-05,0.749179E-01,0.133608E-01,
24395 &0.477459E-04,0.508046E-04,0.479422E-04,0.477459E-04,0.232088E-02/
24396 DATA (DL(K),K= 2976, 3060) /
24397 &0.991147E-05,0.673221E-01,0.118435E-01,0.422554E-04,0.452220E-04,
24398 &0.424417E-04,0.422554E-04,0.203376E-02,0.971603E-05,0.604073E-01,
24399 &0.104845E-01,0.373730E-04,0.402263E-04,0.375483E-04,0.373730E-04,
24400 &0.177791E-02,0.941959E-05,0.541231E-01,0.926900E-02,0.330304E-04,
24401 &0.357544E-04,0.331943E-04,0.330304E-04,0.155117E-02,0.904408E-05,
24402 &0.484216E-01,0.818347E-02,0.291681E-04,0.317517E-04,0.293202E-04,
24403 &0.291681E-04,0.135108E-02,0.860921E-05,0.432578E-01,0.721549E-02,
24404 &0.257333E-04,0.281694E-04,0.258738E-04,0.257333E-04,0.117463E-02,
24405 &0.813214E-05,0.385889E-01,0.635362E-02,0.226802E-04,0.249648E-04,
24406 &0.228093E-04,0.226802E-04,0.101941E-02,0.762814E-05,0.343746E-01,
24407 &0.558739E-02,0.199682E-04,0.221003E-04,0.200863E-04,0.199682E-04,
24408 &0.883469E-03,0.711035E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24409 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24410 &0.168205E+00,0.301419E-01,0.719932E-04,0.719932E-04,0.719932E-04,
24411 &0.719932E-04,0.392825E-02,-.205998E-17,0.151922E+00,0.267932E-01,
24412 &0.623634E-04,0.630456E-04,0.624028E-04,0.623634E-04,0.361412E-02,
24413 &0.457084E-06,0.137042E+00,0.237932E-01,0.541981E-04,0.554098E-04/
24414 DATA (DL(K),K= 3061, 3145) /
24415 &0.542663E-04,0.541981E-04,0.330342E-02,0.989813E-06,0.123446E+00,
24416 &0.211038E-01,0.472163E-04,0.488314E-04,0.473050E-04,0.472163E-04,
24417 &0.300140E-02,0.152631E-05,0.111042E+00,0.186954E-01,0.412159E-04,
24418 &0.431273E-04,0.413184E-04,0.412159E-04,0.270826E-02,0.202092E-05,
24419 &0.997395E-01,0.165410E-01,0.360433E-04,0.381615E-04,0.361542E-04,
24420 &0.360433E-04,0.242968E-02,0.245400E-05,0.894558E-01,0.146159E-01,
24421 &0.315670E-04,0.338178E-04,0.316822E-04,0.315670E-04,0.216928E-02,
24422 &0.281218E-05,0.801130E-01,0.128978E-01,0.276779E-04,0.300002E-04,
24423 &0.277940E-04,0.276779E-04,0.192603E-02,0.308878E-05,0.716379E-01,
24424 &0.113663E-01,0.242878E-04,0.266317E-04,0.244024E-04,0.242878E-04,
24425 &0.170100E-02,0.328451E-05,0.639623E-01,0.100031E-01,0.213246E-04,
24426 &0.236502E-04,0.214357E-04,0.213246E-04,0.149649E-02,0.340483E-05,
24427 &0.570222E-01,0.879131E-02,0.187277E-04,0.210033E-04,0.188341E-04,
24428 &0.187277E-04,0.131163E-02,0.345656E-05,0.507574E-01,0.771565E-02,
24429 &0.164465E-04,0.186476E-04,0.165471E-04,0.164465E-04,0.114469E-02,
24430 &0.344782E-05,0.451118E-01,0.676223E-02,0.144396E-04,0.165480E-04,
24431 &0.145339E-04,0.144396E-04,0.995649E-03,0.338831E-05,0.400330E-01/
24432 DATA (DL(K),K= 3146, 3230) /
24433 &0.591841E-02,0.126720E-04,0.146744E-04,0.127597E-04,0.126720E-04,
24434 &0.863829E-03,0.328754E-05,0.354720E-01,0.517273E-02,0.111137E-04,
24435 &0.130013E-04,0.111946E-04,0.111137E-04,0.747293E-03,0.315403E-05,
24436 &0.313830E-01,0.451477E-02,0.973915E-05,0.115067E-04,0.981339E-05,
24437 &0.973915E-05,0.644664E-03,0.299600E-05,0.277237E-01,0.393511E-02,
24438 &0.852687E-05,0.101721E-04,0.859457E-05,0.852687E-05,0.555034E-03,
24439 &0.282099E-05,0.244545E-01,0.342521E-02,0.745784E-05,0.898076E-05,
24440 &0.751926E-05,0.745784E-05,0.476998E-03,0.263530E-05,0.215390E-01,
24441 &0.297737E-02,0.651555E-05,0.791817E-05,0.657100E-05,0.651555E-05,
24442 &0.409096E-03,0.244427E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24443 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24444 &0.120694E+00,0.180081E-01,0.236444E-04,0.236444E-04,0.236444E-04,
24445 &0.236444E-04,0.154817E-02,0.416656E-17,0.107713E+00,0.158098E-01,
24446 &0.200945E-04,0.206098E-04,0.201146E-04,0.200945E-04,0.151249E-02,
24447 &0.192118E-07,0.960063E-01,0.138667E-01,0.171552E-04,0.180593E-04,
24448 &0.171894E-04,0.171552E-04,0.143574E-02,0.116516E-06,0.854477E-01,
24449 &0.121473E-01,0.146986E-04,0.158894E-04,0.147425E-04,0.146986E-04/
24450 DATA (DL(K),K= 3231, 3315) /
24451 &0.133744E-02,0.251060E-06,0.759386E-01,0.106275E-01,0.126329E-04,
24452 &0.140252E-04,0.126830E-04,0.126329E-04,0.122900E-02,0.395272E-06,
24453 &0.673865E-01,0.928577E-02,0.108901E-04,0.124142E-04,0.109436E-04,
24454 &0.108901E-04,0.111367E-02,0.535145E-06,0.597062E-01,0.810254E-02,
24455 &0.941160E-05,0.110108E-04,0.946648E-05,0.941160E-05,0.996785E-03,
24456 &0.659421E-06,0.528194E-01,0.706039E-02,0.815165E-05,0.978016E-05,
24457 &0.820627E-05,0.815165E-05,0.885152E-03,0.762600E-06,0.466540E-01,
24458 &0.614371E-02,0.707299E-05,0.869464E-05,0.712616E-05,0.707299E-05,
24459 &0.780484E-03,0.842072E-06,0.411433E-01,0.533850E-02,0.614470E-05,
24460 &0.773135E-05,0.619559E-05,0.614470E-05,0.682563E-03,0.896683E-06,
24461 &0.362261E-01,0.463223E-02,0.534297E-05,0.687330E-05,0.539102E-05,
24462 &0.534297E-05,0.593317E-03,0.928176E-06,0.318459E-01,0.401364E-02,
24463 &0.464848E-05,0.610690E-05,0.469333E-05,0.464848E-05,0.513720E-03,
24464 &0.939174E-06,0.279510E-01,0.347266E-02,0.404483E-05,0.542054E-05,
24465 &0.408628E-05,0.404483E-05,0.442713E-03,0.932117E-06,0.244935E-01,
24466 &0.300029E-02,0.351893E-05,0.480507E-05,0.355692E-05,0.351893E-05,
24467 &0.379744E-03,0.910085E-06,0.214299E-01,0.258845E-02,0.306021E-05/
24468 DATA (DL(K),K= 3316, 3400) /
24469 &0.425313E-05,0.309476E-05,0.306021E-05,0.324785E-03,0.876365E-06,
24470 &0.187200E-01,0.222996E-02,0.265958E-05,0.375823E-05,0.269081E-05,
24471 &0.265958E-05,0.277080E-03,0.833755E-06,0.163273E-01,0.191840E-02,
24472 &0.230942E-05,0.331477E-05,0.233747E-05,0.230942E-05,0.235661E-03,
24473 &0.784780E-06,0.142185E-01,0.164805E-02,0.200337E-05,0.291797E-05,
24474 &0.202844E-05,0.200337E-05,0.199949E-03,0.731774E-06,0.123631E-01,
24475 &0.141382E-02,0.173596E-05,0.256351E-05,0.175824E-05,0.173596E-05,
24476 &0.169376E-03,0.676674E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24477 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24478 &0.794823E-01,0.948208E-02,0.607312E-05,0.607312E-05,0.607312E-05,
24479 &0.607312E-05,0.497062E-03,-.140523E-17,0.699344E-01,0.820355E-02,
24480 &0.500852E-05,0.538347E-05,0.501731E-05,0.500852E-05,0.542262E-03,
24481 &-.714686E-07,0.614560E-01,0.709106E-02,0.415227E-05,0.479898E-05,
24482 &0.416702E-05,0.415227E-05,0.549985E-03,-.960102E-07,0.539240E-01,
24483 &0.612155E-02,0.345977E-05,0.429563E-05,0.347839E-05,0.345977E-05,
24484 &0.531288E-03,-.894946E-07,0.472426E-01,0.527757E-02,0.289508E-05,
24485 &0.385164E-05,0.291595E-05,0.289508E-05,0.495120E-03,-.668594E-07/
24486 DATA (DL(K),K= 3401, 3485) /
24487 &0.413245E-01,0.454380E-02,0.243524E-05,0.345851E-05,0.245713E-05,
24488 &0.243524E-05,0.452156E-03,-.338861E-07,0.360903E-01,0.390658E-02,
24489 &0.205923E-05,0.310726E-05,0.208123E-05,0.205923E-05,0.406686E-03,
24490 &0.329349E-08,0.314681E-01,0.335393E-02,0.174861E-05,0.278918E-05,
24491 &0.177007E-05,0.174861E-05,0.359402E-03,0.387747E-07,0.273932E-01,
24492 &0.287528E-02,0.149082E-05,0.250013E-05,0.151127E-05,0.149082E-05,
24493 &0.313779E-03,0.705560E-07,0.238068E-01,0.246132E-02,0.127582E-05,
24494 &0.223699E-05,0.129498E-05,0.127582E-05,0.272195E-03,0.975744E-07,
24495 &0.206558E-01,0.210383E-02,0.109488E-05,0.199657E-05,0.111257E-05,
24496 &0.109488E-05,0.234227E-03,0.118651E-06,0.178921E-01,0.179558E-02,
24497 &0.941584E-06,0.177694E-05,0.957733E-06,0.941584E-06,0.199907E-03,
24498 &0.133780E-06,0.154726E-01,0.153020E-02,0.811157E-06,0.157680E-05,
24499 &0.825743E-06,0.811157E-06,0.169849E-03,0.143581E-06,0.133582E-01,
24500 &0.130209E-02,0.699567E-06,0.139481E-05,0.712624E-06,0.699567E-06,
24501 &0.143794E-03,0.148591E-06,0.115137E-01,0.110634E-02,0.603631E-06,
24502 &0.122977E-05,0.615228E-06,0.603631E-06,0.121163E-03,0.149477E-06,
24503 &0.990774E-02,0.938615E-03,0.520920E-06,0.108072E-05,0.531148E-06/
24504 DATA (DL(K),K= 3486, 3570) /
24505 &0.520920E-06,0.101725E-03,0.147055E-06,0.851194E-02,0.795146E-03,
24506 &0.449441E-06,0.946634E-06,0.458405E-06,0.449441E-06,0.852238E-04,
24507 &0.142064E-06,0.730103E-02,0.672622E-03,0.387542E-06,0.826497E-06,
24508 &0.395353E-06,0.387542E-06,0.712290E-04,0.135149E-06,0.625244E-02,
24509 &0.568155E-03,0.333888E-06,0.719316E-06,0.340658E-06,0.333888E-06,
24510 &0.593824E-04,0.126902E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24511 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24512 &0.457819E-01,0.409492E-02,0.105702E-05,0.105702E-05,0.105702E-05,
24513 &0.105702E-05,0.115350E-03,0.265810E-18,0.395724E-01,0.347873E-02,
24514 &0.812397E-06,0.103880E-05,0.815187E-06,0.812397E-06,0.160406E-03,
24515 &-.555147E-07,0.341639E-01,0.295295E-02,0.627904E-06,0.987449E-06,
24516 &0.632305E-06,0.627904E-06,0.174490E-03,-.847266E-07,0.294481E-01,
24517 &0.250329E-02,0.490075E-06,0.920197E-06,0.495305E-06,0.490075E-06,
24518 &0.174490E-03,-.944763E-07,0.253423E-01,0.211912E-02,0.387225E-06,
24519 &0.845257E-06,0.392760E-06,0.387225E-06,0.167111E-03,-.916775E-07,
24520 &0.217735E-01,0.179138E-02,0.309989E-06,0.766697E-06,0.315473E-06,
24521 &0.309989E-06,0.152540E-03,-.819158E-07,0.186760E-01,0.151211E-02/
24522 DATA (DL(K),K= 3571, 3655) /
24523 &0.252109E-06,0.688927E-06,0.257316E-06,0.252109E-06,0.135295E-03,
24524 &-.682145E-07,0.159921E-01,0.127447E-02,0.208612E-06,0.614302E-06,
24525 &0.213410E-06,0.208612E-06,0.118648E-03,-.528734E-07,0.136704E-01,
24526 &0.107254E-02,0.175203E-06,0.543807E-06,0.179526E-06,0.175203E-06,
24527 &0.102484E-03,-.379748E-07,0.116656E-01,0.901214E-03,0.149064E-06,
24528 &0.478363E-06,0.152890E-06,0.149064E-06,0.871530E-04,-.245007E-07,
24529 &0.993760E-02,0.756074E-03,0.128274E-06,0.418496E-06,0.131610E-06,
24530 &0.128274E-06,0.735682E-04,-.128491E-07,0.845081E-02,0.633315E-03,
24531 &0.111313E-06,0.364260E-06,0.114187E-06,0.111313E-06,0.617706E-04,
24532 &-.327698E-08,0.717398E-02,0.529654E-03,0.971373E-07,0.315568E-06,
24533 &0.995871E-07,0.971373E-07,0.514764E-04,0.421954E-08,0.607950E-02,
24534 &0.442265E-03,0.850687E-07,0.272228E-06,0.871375E-07,0.850687E-07,
24535 &0.426580E-04,0.982709E-08,0.514311E-02,0.368716E-03,0.746164E-07,
24536 &0.233927E-06,0.763489E-07,0.746164E-07,0.352463E-04,0.137715E-07,
24537 &0.434349E-02,0.306920E-03,0.654439E-07,0.200291E-06,0.668838E-07,
24538 &0.654439E-07,0.290260E-04,0.163078E-07,0.366196E-02,0.255085E-03,
24539 &0.573307E-07,0.170932E-06,0.585192E-07,0.573307E-07,0.238196E-04/
24540 DATA (DL(K),K= 3656, 3740) /
24541 &0.177037E-07,0.308217E-02,0.211681E-03,0.501185E-07,0.145441E-06,
24542 &0.510931E-07,0.501185E-07,0.195033E-04,0.182028E-07,0.258987E-02,
24543 &0.175396E-03,0.436915E-07,0.123415E-06,0.444860E-07,0.436915E-07,
24544 &0.159423E-04,0.180204E-07,0.000000E+00,0.000000E+00,0.000000E+00,
24545 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24546 &0.206951E-01,0.123383E-02,0.903693E-07,0.903693E-07,0.903693E-07,
24547 &0.903693E-07,0.147928E-04,0.131925E-18,0.174566E-01,0.102241E-02,
24548 &0.892028E-07,0.129792E-07,0.885875E-07,0.892028E-07,0.328931E-04,
24549 &0.168541E-07,0.147092E-01,0.846741E-03,0.841992E-07,-.346085E-07,
24550 &0.832249E-07,0.841992E-07,0.410825E-04,0.262547E-07,0.123736E-01,
24551 &0.700287E-03,0.769173E-07,-.620958E-07,0.757563E-07,0.769173E-07,
24552 &0.418512E-04,0.305542E-07,0.103910E-01,0.578275E-03,0.688622E-07,
24553 &-.753692E-07,0.676306E-07,0.688622E-07,0.392599E-04,0.318183E-07,
24554 &0.871109E-02,0.476815E-03,0.611778E-07,-.782788E-07,0.599557E-07,
24555 &0.611778E-07,0.356221E-04,0.316149E-07,0.728984E-02,0.392546E-03,
24556 &0.537256E-07,-.749101E-07,0.525642E-07,0.537256E-07,0.312295E-04,
24557 &0.301630E-07,0.608951E-02,0.322656E-03,0.466227E-07,-.678673E-07/
24558 DATA (DL(K),K= 3741, 3825) /
24559 &0.455521E-07,0.466227E-07,0.265816E-04,0.278681E-07,0.507758E-02,
24560 &0.264779E-03,0.400790E-07,-.588670E-07,0.391148E-07,0.400790E-07,
24561 &0.223044E-04,0.251720E-07,0.422604E-02,0.216927E-03,0.341205E-07,
24562 &-.492124E-07,0.332680E-07,0.341205E-07,0.185283E-04,0.222885E-07,
24563 &0.351082E-02,0.177427E-03,0.287480E-07,-.397442E-07,0.280058E-07,
24564 &0.287480E-07,0.152122E-04,0.193702E-07,0.291126E-02,0.144878E-03,
24565 &0.239699E-07,-.309608E-07,0.233320E-07,0.239699E-07,0.123840E-04,
24566 &0.165481E-07,0.240962E-02,0.118102E-03,0.197695E-07,-.231453E-07,
24567 &0.192276E-07,0.197695E-07,0.100316E-04,0.139043E-07,0.199075E-02,
24568 &0.961132E-04,0.161186E-07,-.164194E-07,0.156628E-07,0.161186E-07,
24569 &0.808648E-05,0.114903E-07,0.164168E-02,0.780880E-04,0.129826E-07,
24570 &-.107955E-07,0.126029E-07,0.129826E-07,0.648861E-05,0.933575E-08,
24571 &0.135135E-02,0.633381E-04,0.103192E-07,-.622051E-08,0.100055E-07,
24572 &0.103192E-07,0.519042E-05,0.744979E-08,0.111036E-02,0.512898E-04,
24573 &0.808255E-08,-.260101E-08,0.782557E-08,0.808255E-08,0.414192E-05,
24574 &0.582811E-08,0.910718E-03,0.414657E-04,0.622640E-08,0.177583E-09,
24575 &0.601750E-08,0.622640E-08,0.329729E-05,0.445766E-08,0.745657E-03/
24576 DATA (DL(K),K= 3826, 3910) /
24577 &0.334694E-04,0.470431E-08,0.223586E-08,0.453577E-08,0.470431E-08,
24578 &0.261981E-05,0.331859E-08,0.000000E+00,0.000000E+00,0.000000E+00,
24579 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24580 &0.519165E-02,0.154752E-03,0.135983E-08,0.135983E-08,0.135983E-08,
24581 &0.135983E-08,0.445189E-06,0.165858E-19,0.420352E-02,0.123002E-03,
24582 &-.202651E-07,0.730203E-07,-.200511E-07,-.202651E-07,0.358557E-05,
24583 &-.213089E-07,0.340143E-02,0.977718E-04,-.356451E-07,0.114908E-06,
24584 &-.353066E-07,-.356451E-07,0.384652E-05,-.364475E-07,0.274771E-02,
24585 &0.776124E-04,-.435588E-07,0.139200E-06,-.431556E-07,-.435588E-07,
24586 &0.404834E-05,-.441752E-07,0.221524E-02,0.614950E-04,-.471629E-07,
24587 &0.150069E-06,-.467352E-07,-.471629E-07,0.391615E-05,-.476355E-07,
24588 &0.178268E-02,0.486476E-04,-.477545E-07,0.151420E-06,-.473296E-07,
24589 &-.477545E-07,0.334100E-05,-.481163E-07,0.143185E-02,0.384202E-04,
24590 &-.462359E-07,0.146515E-06,-.458316E-07,-.462359E-07,0.275426E-05,
24591 &-.465126E-07,0.114781E-02,0.302894E-04,-.434031E-07,0.137587E-06,
24592 &-.430295E-07,-.434031E-07,0.226010E-05,-.436143E-07,0.918288E-03,
24593 &0.238367E-04,-.398089E-07,0.126321E-06,-.394715E-07,-.398089E-07/
24594 DATA (DL(K),K= 3911, 3995) /
24595 &0.180947E-05,-.399700E-07,0.733193E-03,0.187249E-04,-.358525E-07,
24596 &0.113940E-06,-.355529E-07,-.358525E-07,0.142045E-05,-.359751E-07,
24597 &0.584227E-03,0.146823E-04,-.318183E-07,0.101291E-06,-.315563E-07,
24598 &-.318183E-07,0.110919E-05,-.319115E-07,0.464586E-03,0.114914E-04,
24599 &-.278936E-07,0.889550E-07,-.276671E-07,-.278936E-07,0.860964E-06,
24600 &-.279643E-07,0.368700E-03,0.897731E-05,-.241972E-07,0.773096E-07,
24601 &-.240033E-07,-.241972E-07,0.662825E-06,-.242508E-07,0.292013E-03,
24602 &0.700034E-05,-.208001E-07,0.665779E-07,-.206356E-07,-.208001E-07,
24603 &0.508061E-06,-.208406E-07,0.230814E-03,0.544870E-05,-.177366E-07,
24604 &0.568734E-07,-.175982E-07,-.177366E-07,0.388493E-06,-.177672E-07,
24605 &0.182078E-03,0.423324E-05,-.150157E-07,0.482316E-07,-.149000E-07,
24606 &-.150157E-07,0.296111E-06,-.150387E-07,0.143349E-03,0.328297E-05,
24607 &-.126295E-07,0.406343E-07,-.125335E-07,-.126295E-07,0.225104E-06,
24608 &-.126468E-07,0.112639E-03,0.254145E-05,-.105595E-07,0.340280E-07,
24609 &-.104803E-07,-.105595E-07,0.170871E-06,-.105726E-07,0.883377E-04,
24610 &0.196395E-05,-.878062E-08,0.283380E-07,-.871555E-08,-.878062E-08,
24611 &0.129517E-06,-.879039E-08,0.000000E+00,0.000000E+00,0.000000E+00/
24612 DATA (DL(K),K= 3996, 4000) /
24613 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24614C
24615 ANS = 0.
24616 IF (X.GT.0.9985) RETURN
24617 IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
24618C
24619 IS = S/DELTA+1
24620 IS1 = IS+1
24621 DO 1 L=1,25
24622 KL = L+NDRV*25
24623 F1(L) = GF(I,IS,KL)
24624 F2(L) = GF(I,IS1,KL)
24625 1 CONTINUE
24626 A1 = DT_CKMTFF(X,F1)
24627 A2 = DT_CKMTFF(X,F2)
24628C A1=ALOG(A1)
24629C A2=ALOG(A2)
24630 S1 = (IS-1)*DELTA
24631 S2 = S1+DELTA
24632 ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
24633C ANS=EXP(ANS)
24634 RETURN
24635 END
24636C
24637
24638*$ CREATE DT_CKMTFF.FOR
24639*COPY DT_CKMTFF
24640 FUNCTION DT_CKMTFF(X,FVL)
24641C**********************************************************************
24642C
24643C LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
24644C FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
24645C NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
24646C IN MAIN ROUTINE.
24647C
24648C**********************************************************************
24649
24650 SAVE
24651 DIMENSION FVL(25),XGRID(25)
24652 DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
24653 *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
24654C
24655 DT_CKMTFF=0.
24656 DO 1 I=1,NX
24657 IF(X.LT.XGRID(I)) GO TO 2
24658 1 CONTINUE
24659 2 I=I-1
24660 IF(I.EQ.0) THEN
24661 I=I+1
24662 ELSE IF(I.GT.23) THEN
24663 I=23
24664 ENDIF
24665 J=I+1
24666 K=J+1
24667 AXI=LOG(XGRID(I))
24668 BXI=LOG(1.-XGRID(I))
24669 AXJ=LOG(XGRID(J))
24670 BXJ=LOG(1.-XGRID(J))
24671 AXK=LOG(XGRID(K))
24672 BXK=LOG(1.-XGRID(K))
24673 FI=LOG(ABS(FVL(I)) +1.E-15)
24674 FJ=LOG(ABS(FVL(J)) +1.E-16)
24675 FK=LOG(ABS(FVL(K)) +1.E-17)
24676 DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
24677 ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
24678 $ BXI))/DET
24679 ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
24680 BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
24681 IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
24682 1RETURN
24683C IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
24684C WRITE(6,2001) X,FVL
24685C 2001 FORMAT(8E12.4)
24686C WRITE(6,2001) ALPHA,BETA,ALOGA,DET
24687C ENDIF
24688 DT_CKMTFF=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
24689 RETURN
24690 END
24691
24692*$ CREATE DT_FLUINI.FOR
24693*COPY DT_FLUINI
24694*
24695*===fluini=============================================================*
24696*
24697 SUBROUTINE DT_FLUINI
24698
24699************************************************************************
24700* Initialisation of the nucleon-nucleon cross section fluctuation *
24701* treatment. The original version by J. Ranft. *
24702* This version dated 21.04.95 is revised by S. Roesler. *
24703************************************************************************
24704
24705 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24706 SAVE
24707 PARAMETER ( LINP = 10 ,
24708 & LOUT = 6 ,
24709 & LDAT = 9 )
24710 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
24711
24712 PARAMETER ( A = 0.1D0,
24713 & B = 0.893D0,
24714 & OM = 1.1D0,
24715 & N = 6,
24716 & DX = 0.003D0)
24717
24718* n-n cross section fluctuations
24719 PARAMETER (NBINS = 1000)
24720 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
24721 DIMENSION FLUSI(NBINS),FLUIX(NBINS)
24722
24723 WRITE(LOUT,1000)
24724 1000 FORMAT(/,1X,'FLUINI: hadronic cross section fluctuations ',
24725 & 'treated')
24726
24727 FLUSU = ZERO
24728 FLUSUU = ZERO
24729
24730 DO 1 I=1,NBINS
24731 X = DBLE(I)*DX
24732 FLUIX(I) = X
24733 FLUS = ((X-B)/(OM*B))**N
24734 IF (FLUS.LE.20.0D0) THEN
24735 FLUSI(I) = (X/B)*EXP(-FLUS)/(X/B+A)
24736 ELSE
24737 FLUSI(I) = ZERO
24738 ENDIF
24739 FLUSU = FLUSU+FLUSI(I)
24740 1 CONTINUE
24741 DO 2 I=1,NBINS
24742 FLUSUU = FLUSUU+FLUSI(I)/FLUSU
24743 FLUSI(I) = FLUSUU
24744 2 CONTINUE
24745
24746C WRITE(LOUT,1001)
24747C1001 FORMAT(1X,'FLUCTUATIONS')
24748C CALL PLOT(FLUIX,FLUSI,1000,1,1000,0.0D0,0.06D0,0.0D0,0.01D0)
24749
24750 DO 3 I=1,NBINS
24751 AF = DBLE(I)*0.001D0
24752 DO 4 J=1,NBINS
24753 IF (AF.LE.FLUSI(J)) THEN
24754 FLUIXX(I) = FLUIX(J)
24755 GOTO 5
24756 ENDIF
24757 4 CONTINUE
24758 5 CONTINUE
24759 3 CONTINUE
24760 FLUIXX(1) = FLUIX(1)
24761 FLUIXX(NBINS) = FLUIX(NBINS)
24762
24763 RETURN
24764 END
24765
24766*$ CREATE DT_SIGTBL.FOR
24767*COPY DT_SIGTBL
24768*
24769*===sigtab=============================================================*
24770*
24771 SUBROUTINE DT_SIGTBL(JP,JT,PTOT,SIGE,MODE)
24772
24773************************************************************************
24774* This version dated 18.11.95 is written by S. Roesler *
24775************************************************************************
24776
24777 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24778 SAVE
24779 PARAMETER ( LINP = 10 ,
24780 & LOUT = 6 ,
24781 & LDAT = 9 )
24782
24783 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24784 & OHALF=0.5D0,ONE=1.0D0)
24785 PARAMETER (PLO=0.01D0,PHI=20.0D0,NBINS=150)
24786
24787 LOGICAL LINIT
24788
24789* particle properties (BAMJET index convention)
24790 CHARACTER*8 ANAME
24791 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24792 & IICH(210),IIBAR(210),K1(210),K2(210)
24793
24794 DIMENSION SIGEP(5,NBINS+1),SIGEN(5,NBINS+1),IDSIG(23)
24795 DATA IDSIG / 1, 0, 0, 0, 0, 0, 0, 2, 0, 0,
24796 & 0, 0, 3, 4, 0, 0, 0, 0, 0, 0,
24797 & 0, 0, 5/
24798 DATA LINIT /.FALSE./
24799
24800* precalculation and tabulation of elastic cross sections
24801 IF (ABS(MODE).EQ.1) THEN
24802 IF (MODE.EQ.1)
24803 & OPEN(LDAT,FILE='outdata0/sigtab.out',STATUS='UNKNOWN')
24804 PLABLX = LOG10(PLO)
24805 PLABHX = LOG10(PHI)
24806 DPLAB = (PLABHX-PLABLX)/DBLE(NBINS)
24807 DO 1 I=1,NBINS+1
24808 PLAB = PLABLX+DBLE(I-1)*DPLAB
24809 PLAB = 10**PLAB
24810 DO 2 IPROJ=1,23
24811 IDX = IDSIG(IPROJ)
24812 IF (IDX.GT.0) THEN
24813C CALL DT_SIHNEL(IPROJ,1,PLAB,SIGEP(IDX,I))
24814C CALL DT_SIHNEL(IPROJ,8,PLAB,SIGEN(IDX,I))
24815 DUMZER = ZERO
24816 CALL DT_XSHN(IPROJ,1,PLAB,DUMZER,SIGTOT,SIGEP(IDX,I))
24817 CALL DT_XSHN(IPROJ,8,PLAB,DUMZER,SIGTOT,SIGEN(IDX,I))
24818 ENDIF
24819 2 CONTINUE
24820 IF (MODE.EQ.1) THEN
24821 WRITE(LDAT,1000) PLAB,(SIGEP(IDX,I),IDX=1,5),
24822 & (SIGEN(IDX,I),IDX=1,5)
24823 1000 FORMAT(F5.1,10F7.2)
24824 ENDIF
24825 1 CONTINUE
24826 IF (MODE.EQ.1) CLOSE(LDAT)
24827 LINIT = .TRUE.
24828 ELSE
24829 SIGE = -ONE
24830 IF (LINIT.AND.(JP.LE.23).AND.(PTOT.GE.PLO)
24831 & .AND.(PTOT.LE.PHI) ) THEN
24832 IDX = IDSIG(JP)
24833 IF ( (IDX.GT.0).AND.((JT.EQ.1).OR.(JT.EQ.8)) ) THEN
24834 PLABX = LOG10(PTOT)
24835 IF (PLABX.LE.PLABLX) THEN
24836 I1 = 1
24837 I2 = 1
24838 ELSEIF (PLABX.GE.PLABHX) THEN
24839 I1 = NBINS+1
24840 I2 = NBINS+1
24841 ELSE
24842 I1 = INT((PLABX-PLABLX)/DPLAB)+1
24843 I2 = I1+1
24844 ENDIF
24845 PLAB1X = PLABLX+DBLE(I1-1)*DPLAB
24846 PLAB2X = PLABLX+DBLE(I2-1)*DPLAB
24847 PBIN = PLAB2X-PLAB1X
24848 IF (PBIN.GT.TINY10) THEN
24849 RATX = (PLABX-PLAB1X)/(PLAB2X-PLAB1X)
24850 ELSE
24851 RATX = ZERO
24852 ENDIF
24853 IF (JT.EQ.1) THEN
24854 SIG1 = SIGEP(IDX,I1)
24855 SIG2 = SIGEP(IDX,I2)
24856 ELSE
24857 SIG1 = SIGEN(IDX,I1)
24858 SIG2 = SIGEN(IDX,I2)
24859 ENDIF
24860 SIGE = SIG1+RATX*(SIG2-SIG1)
24861 ENDIF
24862 ENDIF
24863 ENDIF
24864
24865 RETURN
24866 END
24867
24868*$ CREATE DT_XSTABL.FOR
24869*COPY DT_XSTABL
24870*
24871*===xstabl=============================================================*
24872*
24873 SUBROUTINE DT_XSTABL(WHAT,IXSQEL,IRATIO)
24874
24875 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24876 SAVE
24877 PARAMETER ( LINP = 10 ,
24878 & LOUT = 6 ,
24879 & LDAT = 9 )
24880 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24881 & OHALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
24882 LOGICAL LLAB,LELOG,LQLOG
24883
24884* particle properties (BAMJET index convention)
24885 CHARACTER*8 ANAME
24886 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24887 & IICH(210),IIBAR(210),K1(210),K2(210)
24888* properties of interacting particles
24889 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
24890 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
24891* Glauber formalism: cross sections
24892 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
24893 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
24894 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
24895 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
24896 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
24897 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
24898 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
24899 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
24900 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
24901 & BSLOPE,NEBINI,NQBINI
24902* emulsion treatment
24903 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
24904 & NCOMPO,IEMUL
24905
24906 DIMENSION WHAT(6)
24907
24908 LLAB = (WHAT(1).GT.ZERO).OR.(WHAT(2).GT.ZERO)
24909 ELO = ABS(WHAT(1))
24910 EHI = ABS(WHAT(2))
24911 IF (ELO.GT.EHI) ELO = EHI
24912 LELOG = WHAT(3).LT.ZERO
24913 NEBINS = MAX(INT(ABS(WHAT(3))),1)
24914 DEBINS = (EHI-ELO)/DBLE(NEBINS)
24915 IF (LELOG) THEN
24916 AELO = LOG10(ELO)
24917 AEHI = LOG10(EHI)
24918 ADEBIN = (AEHI-AELO)/DBLE(NEBINS)
24919 ENDIF
24920 Q2LO = WHAT(4)
24921 Q2HI = WHAT(5)
24922 IF (Q2LO.GT.Q2HI) Q2LO = Q2HI
24923 LQLOG = WHAT(6).LT.ZERO
24924 NQBINS = MAX(INT(ABS(WHAT(6))),1)
24925 DQBINS = (Q2HI-Q2LO)/DBLE(NQBINS)
24926 IF (LQLOG) THEN
24927 AQ2LO = LOG10(Q2LO)
24928 AQ2HI = LOG10(Q2HI)
24929 ADQBIN = (AQ2HI-AQ2LO)/DBLE(NQBINS)
24930 ENDIF
24931
24932 IF ( ELO.EQ. EHI) NEBINS = 0
24933 IF (Q2LO.EQ.Q2HI) NQBINS = 0
24934
24935 WRITE(LOUT,1000) ELO,EHI,LLAB,IXSQEL,Q2LO,Q2HI,IJPROJ,IP,IT
24936 1000 FORMAT(/,1X,'XSTABL: E_lo =',E10.3,' GeV E_hi =',E10.3,
24937 & ' GeV Lab = ',L1,' qel: ',I2,/,10X,'Q2_lo =',F10.5,
24938 & ' GeV^2 Q2_hi =',F10.5,' GeV^2',/,10X,'id_p = ',I2,
24939 & ' A_p = ',I3,' A_t = ',I3,/)
24940
24941C IF (IJPROJ.NE.7) THEN
24942 WRITE(LOUT,'(1X,A,/)')'(E,STOT,SELA,SQEP,SQET,SQE2,SINE,SPROD)'
24943* normalize fractions of emulsion components
24944 IF (NCOMPO.GT.0) THEN
24945 SUMFRA = ZERO
24946 DO 10 I=1,NCOMPO
24947 SUMFRA = SUMFRA+EMUFRA(I)
24948 10 CONTINUE
24949 IF (SUMFRA.GT.ZERO) THEN
24950 DO 11 I=1,NCOMPO
24951 EMUFRA(I) = EMUFRA(I)/SUMFRA
24952 11 CONTINUE
24953 ENDIF
24954 ENDIF
24955C ELSE
24956C WRITE(LOUT,'(1X,A,/)') '(Q2,E,STOT,ETOT,SIN,EIN,STOT0)'
24957C ENDIF
24958 DO 1 I=1,NEBINS+1
24959 IF (LELOG) THEN
24960 E = 10**(AELO+DBLE(I-1)*ADEBIN)
24961 ELSE
24962 E = ELO+DBLE(I-1)*DEBINS
24963 ENDIF
24964 DO 2 J=1,NQBINS+1
24965 IF (LQLOG) THEN
24966 Q2 = 10**(AQ2LO+DBLE(J-1)*ADQBIN)
24967 ELSE
24968 Q2 = Q2LO+DBLE(J-1)*DQBINS
24969 ENDIF
24970c IF (IJPROJ.NE.7) THEN
24971 IF (LLAB) THEN
24972 PLAB = ZERO
24973 ECM = ZERO
24974 CALL DT_LTINI(IJPROJ,1,E,PPN0,ECM,0)
24975 ELSE
24976 ECM = E
24977 ENDIF
24978 XI = ZERO
24979 Q2I = ZERO
24980 IF (IJPROJ.EQ.7) Q2I = Q2
24981 IF (NCOMPO.GT.0) THEN
24982 DO 20 IC=1,NCOMPO
24983 IIT = IEMUMA(IC)
24984 CALL DT_XSGLAU(IP,IIT,IJPROJ,XI,Q2I,ECM,1,1,-IC)
24985 20 CONTINUE
24986 ELSE
24987 CALL DT_XSGLAU(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,-1)
24988C CALL AMPLIT(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,1)
24989 ENDIF
24990 IF (NCOMPO.GT.0) THEN
24991 XTOT = ZERO
24992 ETOT = ZERO
24993 XELA = ZERO
24994 EELA = ZERO
24995 XQEP = ZERO
24996 EQEP = ZERO
24997 XQET = ZERO
24998 EQET = ZERO
24999 XQE2 = ZERO
25000 EQE2 = ZERO
25001 XPRO = ZERO
25002 EPRO = ZERO
25003 XPRO1= ZERO
25004 XDEL = ZERO
25005 EDEL = ZERO
25006 XDQE = ZERO
25007 EDQE = ZERO
25008 DO 21 IC=1,NCOMPO
25009 XTOT = XTOT+EMUFRA(IC)*XSTOT(1,1,IC)
25010 ETOT = ETOT+EMUFRA(IC)*XETOT(1,1,IC)**2
25011 XELA = XELA+EMUFRA(IC)*XSELA(1,1,IC)
25012 EELA = EELA+EMUFRA(IC)*XEELA(1,1,IC)**2
25013 XQEP = XQEP+EMUFRA(IC)*XSQEP(1,1,IC)
25014 EQEP = EQEP+EMUFRA(IC)*XEQEP(1,1,IC)**2
25015 XQET = XQET+EMUFRA(IC)*XSQET(1,1,IC)
25016 EQET = EQET+EMUFRA(IC)*XEQET(1,1,IC)**2
25017 XQE2 = XQE2+EMUFRA(IC)*XSQE2(1,1,IC)
25018 EQE2 = EQE2+EMUFRA(IC)*XEQE2(1,1,IC)**2
25019 XPRO = XPRO+EMUFRA(IC)*XSPRO(1,1,IC)
25020 EPRO = EPRO+EMUFRA(IC)*XEPRO(1,1,IC)**2
25021 XDEL = XDEL+EMUFRA(IC)*XSDEL(1,1,IC)
25022 EDEL = EDEL+EMUFRA(IC)*XEDEL(1,1,IC)**2
25023 XDQE = XDQE+EMUFRA(IC)*XSDQE(1,1,IC)
25024 EDQE = EDQE+EMUFRA(IC)*XEDQE(1,1,IC)**2
25025 YPRO = XSTOT(1,1,IC)-XSELA(1,1,IC)
25026 & -XSQEP(1,1,IC)-XSQET(1,1,IC)
25027 & -XSQE2(1,1,IC)
25028 XPRO1= XPRO1+EMUFRA(IC)*YPRO
25029 21 CONTINUE
25030 ETOT = SQRT(ETOT)
25031 EELA = SQRT(EELA)
25032 EQEP = SQRT(EQEP)
25033 EQET = SQRT(EQET)
25034 EQE2 = SQRT(EQE2)
25035 EPRO = SQRT(EPRO)
25036 EDEL = SQRT(EDEL)
25037 EDQE = SQRT(EDQE)
25038 WRITE(LOUT,'(8E9.3)')
25039 & E,XTOT,XELA,XQEP,XQET,XQE2,XPRO,XPRO1
25040C WRITE(LOUT,'(4E9.3)')
25041C & E,XDEL,XDQE,XDEL+XDQE
25042 ELSE
25043 WRITE(LOUT,'(11E10.3)')
25044 & E,
25045 & XSTOT(1,1,1),XSELA(1,1,1),XSQEP(1,1,1),XSQET(1,1,1),
25046 & XSQE2(1,1,1),XSPRO(1,1,1),
25047 & XSTOT(1,1,1)-XSELA(1,1,1)-XSQEP(1,1,1)-XSQET(1,1,1)
25048 & -XSQE2(1,1,1),XSDEL(1,1,1),XSDQE(1,1,1),
25049 & XSDEL(1,1,1)+XSDQE(1,1,1)
25050C WRITE(LOUT,'(4E9.3)') E,XSDEL(1,1,1),XSDQE(1,1,1),
25051C & XSDEL(1,1,1)+XSDQE(1,1,1)
25052 ENDIF
25053c ELSE
25054c IF (LLAB) THEN
25055c IF (IT.GT.1) THEN
25056c IF (IXSQEL.EQ.0) THEN
25057cC CALL DT_SIGGA(IT, Q2, E,ZERO,ZERO,
25058cC CALL DT_SIGGA(IT, E,Q2,ZERO,ZERO,
25059c CALL DT_SIGGA(IT,ZERO,Q2,ZERO,E,
25060c & STOT,ETOT,SIN,EIN,STOT0)
25061c IF (IRATIO.EQ.1) THEN
25062c CALL DT_SIGGP( Q2, E,ZERO,ZERO,STGP,SIGP,SDGP)
25063cC CALL DT_SIGGP( E,Q2,ZERO,ZERO,STGP,SIGP,SDGP)
25064cC CALL DT_SIGGP(ZERO,Q2,ZERO,E,STGP,SIGP,SDGP)
25065c*!! save cross sections
25066c STOTA = STOT
25067c ETOTA = ETOT
25068c STOTP = STGP
25069c*!!
25070c STOT = STOT/(DBLE(IT)*STGP)
25071c SIN = SIN/(DBLE(IT)*SIGP)
25072c STOT0 = STGP
25073c ETOT = ZERO
25074c EIN = ZERO
25075c ENDIF
25076c ELSE
25077c WRITE(LOUT,*)
25078c & ' XSTABL: qel. xs. not implemented for nuclei'
25079c STOP
25080c ENDIF
25081c ELSE
25082c ETOT = ZERO
25083c EIN = ZERO
25084c STOT0= ZERO
25085c IF (IXSQEL.EQ.0) THEN
25086c CALL DT_SIGGP(ZERO,Q2,ZERO,E,STOT,SIN,SDIR)
25087c ELSE
25088c SIN = ZERO
25089c CALL DT_SIGVEL(ZERO,Q2,ZERO,E,IXSQEL,STOT,SIN,STOT0)
25090c ENDIF
25091c ENDIF
25092c ELSE
25093c IF (IT.GT.1) THEN
25094c IF (IXSQEL.EQ.0) THEN
25095c CALL DT_SIGGA(IT,ZERO,Q2,E,ZERO,
25096c & STOT,ETOT,SIN,EIN,STOT0)
25097c IF (IRATIO.EQ.1) THEN
25098c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STGP,SIGP,SDGP)
25099c*!! save cross sections
25100c STOTA = STOT
25101c ETOTA = ETOT
25102c STOTP = STGP
25103c*!!
25104c STOT = STOT/(DBLE(IT)*STGP)
25105c SIN = SIN/(DBLE(IT)*SIGP)
25106c STOT0 = STGP
25107c ETOT = ZERO
25108c EIN = ZERO
25109c ENDIF
25110c ELSE
25111c WRITE(LOUT,*)
25112c & ' XSTABL: qel. xs. not implemented for nuclei'
25113c STOP
25114c ENDIF
25115c ELSE
25116c ETOT = ZERO
25117c EIN = ZERO
25118c STOT0= ZERO
25119c IF (IXSQEL.EQ.0) THEN
25120c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STOT,SIN,SDIR)
25121c ELSE
25122c SIN = ZERO
25123c CALL DT_SIGVEL(ZERO,Q2,E,ZERO,IXSQEL,STOT,SIN,STOT0)
25124c ENDIF
25125c ENDIF
25126c ENDIF
25127cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,STOTA,ETOTA,STOTP,ZERO
25128cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,SDIR
25129cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,STOT0
25130c WRITE(LOUT,'(1X,6E10.3)')Q2,E,STOT,ETOT,SIN,EIN
25131c ENDIF
25132 2 CONTINUE
25133 1 CONTINUE
25134
25135 RETURN
25136 END
25137
25138*$ CREATE DT_TESTXS.FOR
25139*COPY DT_TESTXS
25140*
25141*===testxs=============================================================*
25142*
25143 SUBROUTINE DT_TESTXS
25144
25145 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25146 SAVE
25147
25148 DIMENSION XSTOT(26,2),XSELA(26,2)
25149
25150 OPEN(10,FILE='testxs_ptot.out',STATUS='UNKNOWN')
25151 OPEN(11,FILE='testxs_pela.out',STATUS='UNKNOWN')
25152 OPEN(12,FILE='testxs_ntot.out',STATUS='UNKNOWN')
25153 OPEN(13,FILE='testxs_nela.out',STATUS='UNKNOWN')
25154 DUMECM = 0.0D0
25155 PLABL = 0.01D0
25156 PLABH = 10000.0D0
25157 NBINS = 120
25158 APLABL = LOG10(PLABL)
25159 APLABH = LOG10(PLABH)
25160 ADPLAB = (APLABH-APLABL)/DBLE(NBINS)
25161 DO 1 I=1,NBINS+1
25162 ADP = APLABL+DBLE(I-1)*ADPLAB
25163 P = 10.0D0**ADP
25164 DO 2 J=1,26
25165 CALL DT_XSHN(J,1,P,DUMECM,XSTOT(J,1),XSELA(J,1))
25166 CALL DT_XSHN(J,8,P,DUMECM,XSTOT(J,2),XSELA(J,2))
25167 2 CONTINUE
25168 WRITE(10,1000) P,(XSTOT(K,1),K=1,26)
25169 WRITE(11,1000) P,(XSELA(K,1),K=1,26)
25170 WRITE(12,1000) P,(XSTOT(K,2),K=1,26)
25171 WRITE(13,1000) P,(XSELA(K,2),K=1,26)
25172 1 CONTINUE
25173 1000 FORMAT(F8.3,26F9.3)
25174
25175 RETURN
25176 END
25177
25178************************************************************************
25179* *
25180* DTUNUC 2.0: library routines *
25181* processed by S. Roesler, 6.5.95 *
25182* *
25183************************************************************************
25184*
25185* 1) Handling of parton momenta
25186* SUBROUTINE MASHEL
25187* SUBROUTINE DFERMI
25188*
25189* 2) Handling of parton flavors and particle indices
25190* INTEGER FUNCTION IPDG2B
25191* INTEGER FUNCTION IB2PDG
25192* INTEGER FUNCTION IQUARK
25193* INTEGER FUNCTION IBJQUA
25194* INTEGER FUNCTION ICIHAD
25195* INTEGER FUNCTION IPDGHA
25196* INTEGER FUNCTION MCHAD
25197* SUBROUTINE FLAHAD
25198*
25199* 3) Energy-momentum and quantum number conservation check routines
25200* SUBROUTINE EMC1
25201* SUBROUTINE EMC2
25202* SUBROUTINE EVTEMC
25203* SUBROUTINE EVTFLC
25204* SUBROUTINE EVTCHG
25205*
25206* 4) Transformations
25207* SUBROUTINE LTINI
25208* SUBROUTINE LTRANS
25209* SUBROUTINE LTNUC
25210* SUBROUTINE DALTRA
25211* SUBROUTINE DTRAFO
25212* SUBROUTINE STTRAN
25213* SUBROUTINE MYTRAN
25214* SUBROUTINE LT2LAO
25215* SUBROUTINE LT2LAB
25216*
25217* 5) Sampling from distributions
25218* INTEGER FUNCTION NPOISS
25219* DOUBLE PRECISION FUNCTION SAMPXB
25220* DOUBLE PRECISION FUNCTION SAMPEX
25221* DOUBLE PRECISION FUNCTION SAMSQX
25222* DOUBLE PRECISION FUNCTION BETREJ
25223* DOUBLE PRECISION FUNCTION DGAMRN
25224* DOUBLE PRECISION FUNCTION DBETAR
25225* SUBROUTINE RANNOR
25226* SUBROUTINE DPOLI
25227* SUBROUTINE DSFECF
25228* SUBROUTINE RACO
25229*
25230* 6) Special functions, algorithms and service routines
25231* DOUBLE PRECISION FUNCTION YLAMB
25232* SUBROUTINE SORT
25233* SUBROUTINE SORT1
25234* SUBROUTINE DT_XTIME
25235*
25236* 7) Random number generator package
25237* DOUBLE PRECISION FUNCTION DT_RNDM
25238* SUBROUTINE DT_RNDMST
25239* SUBROUTINE DT_RNDMIN
25240* SUBROUTINE DT_RNDMOU
25241* SUBROUTINE DT_RNDMTE
25242*
25243************************************************************************
25244* *
25245* 1) Handling of parton momenta *
25246* *
25247************************************************************************
25248*$ CREATE DT_MASHEL.FOR
25249*COPY DT_MASHEL
25250*
25251*===mashel=============================================================*
25252*
25253 SUBROUTINE DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
25254
25255************************************************************************
25256* *
25257* rescaling of momenta of two partons to put both *
25258* on mass shell *
25259* *
25260* input: PA1,PA2 input momentum vectors *
25261* XM1,2 desired masses of particles afterwards *
25262* P1,P2 changed momentum vectors *
25263* *
25264* The original version is written by R. Engel. *
25265* This version dated 12.12.94 is modified by S. Roesler. *
25266************************************************************************
25267
25268 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25269 SAVE
25270 PARAMETER ( LINP = 10 ,
25271 & LOUT = 6 ,
25272 & LDAT = 9 )
25273 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
25274
25275 DIMENSION PA1(4),PA2(4),P1(4),P2(4)
25276
25277 IREJ = 0
25278
25279* Lorentz transformation into system CMS
25280 PX = PA1(1)+PA2(1)
25281 PY = PA1(2)+PA2(2)
25282 PZ = PA1(3)+PA2(3)
25283 EE = PA1(4)+PA2(4)
25284 XPTOT = SQRT(PX**2+PY**2+PZ**2)
25285 XMS = (EE-XPTOT)*(EE+XPTOT)
25286 IF(XMS.LT.(XM1+XM2)**2) THEN
25287C WRITE(LOUT,'(3E12.4)')XMS,XM1,XM2
25288 GOTO 9999
25289 ENDIF
25290 XMS = SQRT(XMS)
25291 BGX = PX/XMS
25292 BGY = PY/XMS
25293 BGZ = PZ/XMS
25294 GAM = EE/XMS
25295 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
25296 & PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
25297* rotation angles
25298 COD = P1(3)/PTOT1
25299C SID = SQRT((ONE-COD)*(ONE+COD))
25300 PPT = SQRT(P1(1)**2+P1(2)**2)
25301 SID = PPT/PTOT1
25302 COF = ONE
25303 SIF = ZERO
25304 IF(PTOT1*SID.GT.TINY10) THEN
25305 COF = P1(1)/(SID*PTOT1)
25306 SIF = P1(2)/(SID*PTOT1)
25307 ANORF = SQRT(COF*COF+SIF*SIF)
25308 COF = COF/ANORF
25309 SIF = SIF/ANORF
25310 ENDIF
25311* new CM momentum and energies (for masses XM1,XM2)
25312 XM12 = SIGN(XM1**2,XM1)
25313 XM22 = SIGN(XM2**2,XM2)
25314 SS = XMS**2
25315 PCMP = DT_YLAMB(SS,XM12,XM22)/(2.D0*XMS)
25316 EE1 = SQRT(XM12+PCMP**2)
25317 EE2 = XMS-EE1
25318* back rotation
25319 MODE = 1
25320 CALL DT_MYTRAN(MODE,ZERO,ZERO,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
25321 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
25322 & PTOT1,P1(1),P1(2),P1(3),P1(4))
25323 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
25324 & PTOT2,P2(1),P2(2),P2(3),P2(4))
25325* check consistency
25326 DEL = XMS*0.0001D0
25327 IF (ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
25328 IDEV = 1
25329 ELSEIF (ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
25330 IDEV = 2
25331 ELSEIF (ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
25332 IDEV = 3
25333 ELSEIF (ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
25334 IDEV = 4
25335 ELSE
25336 IDEV = 0
25337 ENDIF
25338 IF (IDEV.NE.0) THEN
25339 WRITE(LOUT,'(/1X,A,I3)')
25340 & 'MASHEL: inconsistent transformation',IDEV
25341 WRITE(LOUT,'(1X,A)') 'MASHEL: input momenta/masses:'
25342 WRITE(LOUT,'(1X,5E12.5)') (PA1(K),K=1,4),XM1
25343 WRITE(LOUT,'(1X,5E12.5)') (PA2(K),K=1,4),XM2
25344 WRITE(LOUT,'(1X,A)') 'MASHEL: output momenta:'
25345 WRITE(LOUT,'(5X,4E12.5)') (P1(K),K=1,4)
25346 WRITE(LOUT,'(5X,4E12.5)') (P2(K),K=1,4)
25347 ENDIF
25348 RETURN
25349
25350 9999 CONTINUE
25351 IREJ = 1
25352 RETURN
25353 END
25354
25355*$ CREATE DT_DFERMI.FOR
25356*COPY DT_DFERMI
25357*
25358*===dfermi=============================================================*
25359*
25360 SUBROUTINE DT_DFERMI(GPART)
25361
25362************************************************************************
25363* Find largest of three random numbers. *
25364************************************************************************
25365
25366 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25367 SAVE
25368
25369 DIMENSION G(3)
25370
25371 DO 10 I=1,3
25372 G(I)=DT_RNDM(GPART)
25373 10 CONTINUE
25374 IF (G(3).LT.G(2)) GOTO 40
25375 IF (G(3).LT.G(1)) GOTO 30
25376 GPART = G(3)
25377 20 RETURN
25378 30 GPART = G(1)
25379 GOTO 20
25380 40 IF (G(2).LT.G(1)) GOTO 30
25381 GPART = G(2)
25382 GOTO 20
25383
25384 END
25385
25386************************************************************************
25387* *
25388* 2) Handling of parton flavors and particle indices *
25389* *
25390************************************************************************
25391*$ CREATE IDT_IPDG2B.FOR
25392*COPY IDT_IPDG2B
25393*
25394*===ipdg2b=============================================================*
25395*
25396 INTEGER FUNCTION IDT_IPDG2B(ID,NN,MODE)
25397
25398************************************************************************
25399* *
25400* conversion of quark numbering scheme *
25401* *
25402* input: PDG parton numbering *
25403* for diquarks: NN number of the constituent quark *
25404* (e.g. ID=2301,NN=1 -> ICONV2=1) *
25405* *
25406* output: BAMJET particle codes *
25407* 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) *
25408* 2 d 8 a-d -2 a-d *
25409* 3 s 9 a-s -3 a-s *
25410* 4 c 10 a-c -4 a-c *
25411* *
25412* This is a modified version of ICONV2 written by R. Engel. *
25413* This version dated 13.12.94 is written by S. Roesler. *
25414************************************************************************
25415
25416 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25417 SAVE
25418 PARAMETER ( LINP = 10 ,
25419 & LOUT = 6 ,
25420 & LDAT = 9 )
25421
25422 IDA = ABS(ID)
25423* diquarks
25424 IF (IDA.GT.6) THEN
25425 KF = 3
25426 IF (IDA.GE.1000) KF = 4
25427 IDA = IDA/(10**(KF-NN))
25428 IDA = MOD(IDA,10)
25429 ENDIF
25430* exchange up and dn quarks
25431 IF (IDA.EQ.1) THEN
25432 IDA = 2
25433 ELSEIF (IDA.EQ.2) THEN
25434 IDA = 1
25435 ENDIF
25436* antiquarks
25437 IF (ID.LT.0) THEN
25438 IF (MODE.EQ.1) THEN
25439 IDA = IDA+6
25440 ELSE
25441 IDA = -IDA
25442 ENDIF
25443 ENDIF
25444 IDT_IPDG2B = IDA
25445
25446 RETURN
25447 END
25448
25449*$ CREATE IDT_IB2PDG.FOR
25450*COPY IDT_IB2PDG
25451*
25452*===ib2pdg=============================================================*
25453*
25454 INTEGER FUNCTION IDT_IB2PDG(ID1,ID2,MODE)
25455
25456************************************************************************
25457* *
25458* conversion of quark numbering scheme *
25459* *
25460* input: BAMJET particle codes *
25461* 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) *
25462* 2 d 8 a-d -2 a-d *
25463* 3 s 9 a-s -3 a-s *
25464* 4 c 10 a-c -4 a-c *
25465* *
25466* output: PDG parton numbering *
25467* *
25468* This version dated 13.12.94 is written by S. Roesler. *
25469************************************************************************
25470
25471 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25472 SAVE
25473 PARAMETER ( LINP = 10 ,
25474 & LOUT = 6 ,
25475 & LDAT = 9 )
25476
25477 DIMENSION IHKKQ(-6:6),IHKKQQ(-3:3,-3:3)
25478 DATA IHKKQ/-6,-5,-4,-3,-1,-2,0,2,1,3,4,5,6/
25479 DATA IHKKQQ/-3303,-3103,-3203,0,0,0,0, -3103,-1103,-2103,0,0,0,0,
25480 &-3203,-2103,-2203,0,0,0,0, 0,0,0,0,0,0,0, 0,0,0,0,2203,2103,3203,
25481 &0,0,0,0,2103,1103,3103, 0,0,0,0,3203,3103,3303/
25482
25483 IDA = ID1
25484 IDB = ID2
25485 IF (MODE.EQ.1) THEN
25486 IF (ID1.GT.6) IDA = -(ID1-6)
25487 IF (ID2.GT.6) IDB = -(ID2-6)
25488 ENDIF
25489 IF (ID2.EQ.0) THEN
25490 IDT_IB2PDG = IHKKQ(IDA)
25491 ELSE
25492 IDT_IB2PDG = IHKKQQ(IDA,IDB)
25493 ENDIF
25494
25495 RETURN
25496 END
25497
25498*$ CREATE IDT_IQUARK.FOR
25499*COPY IDT_IQUARK
25500*
25501*===ipdgqu=============================================================*
25502*
25503 INTEGER FUNCTION IDT_IQUARK(K,IDBAMJ)
25504
25505************************************************************************
25506* *
25507* quark contents according to PDG conventions *
25508* (random selection in case of quark mixing) *
25509* *
25510* input: IDBAMJ BAMJET particle code *
25511* K 1..3 quark number *
25512* *
25513* output: 1 d (anti --> neg.) *
25514* 2 u *
25515* 3 s *
25516* 4 c *
25517* *
25518* This version written by R. Engel. *
25519************************************************************************
25520
25521 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25522 SAVE
25523
25524 IQ = IDT_IBJQUA(K,IDBAMJ)
25525* quark-antiquark
25526 IF (IQ.GT.6) THEN
25527 IQ = 6-IQ
25528 ENDIF
25529* exchange of up and down
25530 IF (ABS(IQ).EQ.1) THEN
25531 IQ = SIGN(2,IQ)
25532 ELSEIF (ABS(IQ).EQ.2) THEN
25533 IQ = SIGN(1,IQ)
25534 ENDIF
25535 IDT_IQUARK = IQ
25536
25537 RETURN
25538 END
25539
25540*$ CREATE IDT_IBJQUA.FOR
25541*COPY IDT_IBJQUA
25542*
25543*===ibamq==============================================================*
25544*
25545 INTEGER FUNCTION IDT_IBJQUA(K,IDBAMJ)
25546
25547************************************************************************
25548* *
25549* quark contents according to BAMJET conventions *
25550* (random selection in case of quark mixing) *
25551* *
25552* input: IDBAMJ BAMJET particle code *
25553* K 1..3 quark number *
25554* *
25555* output: 1 u 7 u bar *
25556* 2 d 8 d bar *
25557* 3 s 9 s bar *
25558* 4 c 10 c bar *
25559* *
25560* This version written by R. Engel. *
25561************************************************************************
25562
25563 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25564 SAVE
25565
25566 DIMENSION ITAB(3,210)
25567 DATA ((ITAB(I,K),I=1,3),K=1,30) /
25568 & 1, 1, 2, 7, 7, 8, 0, 0, 0,
25569 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25570 & 0, 0, 0, 1, 2, 2, 7, 8, 8,
25571*sr 10.1.94
25572C & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25573 & 0, 0, 0, 0, 0, 0, 3, 8, 0,
25574*
25575 & 1, 8, 0, 2, 7, 0, 1, 9, 0,
25576*sr 10.1.94
25577C & 3, 7, 0, 0, 0, 0, 0, 0, 0,
25578 & 3, 7, 0, 3, 1, 2, 9, 7, 8,
25579*sr 10.1.94
25580C & 0, 0, 0, 2, 2, 3, 1, 1, 3,
25581 & 2, 9, 0, 2, 2, 3, 1, 1, 3,
25582*
25583 & 1, 2, 3, 201,202, 0, 2, 9, 0,
25584 & 3, 8, 0, 0, 0, 0, 0, 0, 0,
25585 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25586 DATA ((ITAB(I,K),I=1,3),K=31,60) /
25587 & 3, 9, 0, 1, 8, 0, 203,204, 0,
25588 & 2, 7, 0, 0, 0, 0, 1, 9, 0,
25589 & 2, 9, 0, 3, 7, 0, 3, 8, 0,
25590 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25591 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25592 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25593 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25594 & 0, 0, 0, 1, 1, 1, 1, 1, 2,
25595 & 1, 2, 2, 2, 2, 2, 0, 0, 0,
25596 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25597 DATA ((ITAB(I,K),I=1,3),K=61,90) /
25598 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25599 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25600 & 7, 7, 7, 7, 7, 8, 7, 8, 8,
25601 & 8, 8, 8, 0, 0, 0, 0, 0, 0,
25602 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25603 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25604 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25605 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25606 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25607 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25608 DATA ((ITAB(I,K),I=1,3),K=91,120) /
25609 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25610 & 0, 0, 0, 0, 0, 0, 3, 9, 0,
25611 & 1, 3, 3, 2, 3, 3, 7, 7, 9,
25612 & 7, 8, 9, 8, 8, 9, 7, 9, 9,
25613 & 8, 9, 9, 1, 1, 3, 1, 2, 3,
25614 & 2, 2, 3, 1, 3, 3, 2, 3, 3,
25615 & 3, 3, 3, 7, 7, 9, 7, 8, 9,
25616 & 8, 8, 9, 7, 9, 9, 8, 9, 9,
25617 & 9, 9, 9, 4, 7, 0, 4, 8, 0,
25618 & 2, 10, 0, 1, 10, 0, 4, 9, 0 /
25619 DATA ((ITAB(I,K),I=1,3),K=121,150) /
25620 & 3, 10, 0, 4, 10, 0, 4, 7, 0,
25621 & 4, 8, 0, 2, 10, 0, 1, 10, 0,
25622 & 4, 9, 0, 3, 10, 0, 4, 10, 0,
25623 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25624 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25625 & 0, 0, 0, 1, 2, 4, 1, 3, 4,
25626 & 2, 3, 4, 1, 1, 4, 0, 0, 0,
25627 & 2, 2, 4, 0, 0, 0, 0, 0, 0,
25628 & 3, 3, 4, 1, 4, 4, 2, 4, 4,
25629 & 3, 4, 4, 7, 8, 10, 7, 9, 10 /
25630 DATA ((ITAB(I,K),I=1,3),K=151,180) /
25631 & 8, 9, 10, 7, 7, 10, 0, 0, 0,
25632 & 8, 8, 10, 0, 0, 0, 0, 0, 0,
25633 & 9, 9, 10, 7, 10, 10, 8, 10, 10,
25634 & 9, 10, 10, 1, 1, 4, 1, 2, 4,
25635 & 2, 2, 4, 1, 3, 4, 2, 3, 4,
25636 & 3, 3, 4, 1, 4, 4, 2, 4, 4,
25637 & 3, 4, 4, 4, 4, 4, 7, 7, 10,
25638 & 7, 8, 10, 8, 8, 10, 7, 9, 10,
25639 & 8, 9, 10, 9, 9, 10, 7, 10, 10,
25640 & 8, 10, 10, 9, 10, 10, 10, 10, 10 /
25641 DATA ((ITAB(I,K),I=1,3),K=181,210) /
25642 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25643 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25644 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25645 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25646 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25647 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25648 & 0, 0, 0, 0, 0, 0, 1, 7, 0,
25649 & 2, 8, 0, 1, 7, 0, 2, 8, 0,
25650 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25651 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25652 DATA IDOLD /0/
25653
25654 ONE = 1.0D0
25655 IF (ITAB(1,IDBAMJ).LE.200) THEN
25656 ID = ITAB(K,IDBAMJ)
25657 ELSE
25658 IF(IDOLD.NE.IDBAMJ) THEN
25659 IT = AINT((ITAB(2,IDBAMJ)-ITAB(1,IDBAMJ)+0.999999D0)*
25660 & DT_RNDM(ONE)+ITAB(1,IDBAMJ))
25661 ELSE
25662 IDOLD = 0
25663 ENDIF
25664 ID = ITAB(K,IT)
25665 ENDIF
25666 IDOLD = IDBAMJ
25667 IDT_IBJQUA = ID
25668
25669 RETURN
25670 END
25671
25672*$ CREATE IDT_ICIHAD.FOR
25673*COPY IDT_ICIHAD
25674*
25675*===icihad=============================================================*
25676*
25677 INTEGER FUNCTION IDT_ICIHAD(MCIND)
25678
25679************************************************************************
25680* Conversion of particle index PDG proposal --> BAMJET-index scheme *
25681* This is a completely new version dated 25.10.95. *
25682* Renamed to be not in conflict with the modified PHOJET-version *
25683************************************************************************
25684
25685 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25686 SAVE
25687
25688* hadron index conversion (BAMJET <--> PDG)
25689 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25690 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25691 & IAMCIN(210)
25692
25693 IDT_ICIHAD = 0
25694 KPDG = ABS(MCIND)
25695 IF ((KPDG.EQ.0).OR.(KPDG.GT.70000)) RETURN
25696 IF (MCIND.LT.0) THEN
25697 JSIGN = 1
25698 ELSE
25699 JSIGN = 2
25700 ENDIF
25701 IF (KPDG.GE.10000) THEN
25702 DO 1 I=1,19
25703 IDT_ICIHAD = IBAM5(JSIGN,I)
25704 IF (IPDG5(JSIGN,I).EQ.MCIND) GOTO 5
25705 IDT_ICIHAD = 0
25706 1 CONTINUE
25707 ELSEIF (KPDG.GE.1000) THEN
25708 DO 2 I=1,29
25709 IDT_ICIHAD = IBAM4(JSIGN,I)
25710 IF (IPDG4(JSIGN,I).EQ.MCIND) GOTO 5
25711 IDT_ICIHAD = 0
25712 2 CONTINUE
25713 ELSEIF (KPDG.GE.100) THEN
25714 DO 3 I=1,22
25715 IDT_ICIHAD = IBAM3(JSIGN,I)
25716 IF (IPDG3(JSIGN,I).EQ.MCIND) GOTO 5
25717 IDT_ICIHAD = 0
25718 3 CONTINUE
25719 ELSEIF (KPDG.GE.10) THEN
25720 DO 4 I=1,7
25721 IDT_ICIHAD = IBAM2(JSIGN,I)
25722 IF (IPDG2(JSIGN,I).EQ.MCIND) GOTO 5
25723 IDT_ICIHAD = 0
25724 4 CONTINUE
25725 ENDIF
25726 5 CONTINUE
25727
25728 RETURN
25729 END
25730
25731*$ CREATE IDT_IPDGHA.FOR
25732*COPY IDT_IPDGHA
25733*
25734*===ipdgha=============================================================*
25735*
25736 INTEGER FUNCTION IDT_IPDGHA(MCIND)
25737
25738************************************************************************
25739* Conversion of particle index BAMJET-index scheme --> PDG proposal *
25740* Adopted from the original by S. Roesler. This version dated 12.5.95 *
25741* Renamed to be not in conflict with the modified PHOJET-version *
25742************************************************************************
25743
25744 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25745 SAVE
25746
25747* hadron index conversion (BAMJET <--> PDG)
25748 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25749 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25750 & IAMCIN(210)
25751
25752 IDT_IPDGHA = IAMCIN(MCIND)
25753
25754 RETURN
25755 END
25756
25757*$ CREATE DT_FLAHAD.FOR
25758*COPY DT_FLAHAD
25759*
25760*===flahad=============================================================*
25761*
25762 SUBROUTINE DT_FLAHAD(ID,IF1,IF2,IF3)
25763
25764************************************************************************
25765* sampling of FLAvor composition for HADrons/photons *
25766* ID BAMJET-id of hadron *
25767* IF1,2,3 flavor content *
25768* (u,d,s: 1,2,3; au,ad,as: -1,-1,-3) *
25769* Note: - u,d numbering as in BAMJET *
25770* - ID .le. 30 !! *
25771* This version dated 12.03.96 is written by S. Roesler *
25772************************************************************************
25773
25774 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25775 SAVE
25776
25777* auxiliary common for reggeon exchange (DTUNUC 1.x)
25778 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
25779 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
25780 & IQTCHR(-6:6),MQUARK(3,39)
25781
25782 DIMENSION JSEL(3,6)
25783 DATA JSEL/ 1,2,3, 2,3,1, 3,1,2, 1,3,2, 2,1,3, 3,2,1/
25784
25785 ONE = 1.0D0
25786 IF (ID.EQ.7) THEN
25787* photon (charge dependent flavour sampling)
25788 K = INT(DT_RNDM(ONE)*6.D0+1.D0)
25789 IF (K.LE.4) THEN
25790 IF1 = 2
25791 IF2 = -2
25792 ELSE IF(K.EQ.5) THEN
25793 IF1 = 1
25794 IF2 = -1
25795 ELSE
25796 IF1 = 3
25797 IF2 = -3
25798 ENDIF
25799 IF(DT_RNDM(ONE).LT.0.5D0) THEN
25800 K = IF1
25801 IF1 = IF2
25802 IF2 = K
25803 ENDIF
25804 IF3 = 0
25805 ELSE
25806* hadron
25807 IX = INT(1.0D0+5.99999D0*DT_RNDM(ONE))
25808 IF1 = MQUARK(JSEL(1,IX),ID)
25809 IF2 = MQUARK(JSEL(2,IX),ID)
25810 IF3 = MQUARK(JSEL(3,IX),ID)
25811 IF ((IF1.EQ.0).AND.(IF3.NE.0)) THEN
25812 IF1 = IF3
25813 IF3 = 0
25814 ELSEIF ((IF2.EQ.0).AND.(IF3.NE.0)) THEN
25815 IF2 = IF3
25816 IF3 = 0
25817 ENDIF
25818 ENDIF
25819
25820 RETURN
25821 END
25822
25823*$ CREATE IDT_MCHAD.FOR
25824*COPY IDT_MCHAD
25825*
25826*===mchad==============================================================*
25827*
25828 INTEGER FUNCTION IDT_MCHAD(ITDTU)
25829
25830************************************************************************
25831* Conversion of particle index BAMJET-index scheme --> HADRIN index s. *
25832* Adopted from the original by S. Roesler. This version dated 6.5.95 *
25833* *
25834* Last change 28.12.2006 by S. Roesler. *
25835************************************************************************
25836
25837 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25838 SAVE
25839
25840 DIMENSION ITRANS(210)
25841 DATA ITRANS / 1, 2, -1, -1, -1, -1, -1, 8, 9, -1, -1, 24, 13, 14,
25842 &15, 16, 8, 9, 25, 8, 1, 8, 23, 24, 25, -1, -1, -1, -1, -1, 23, 13,
25843 &23, 14, 23, 15, 24, 16, 25, 15, 24, 16, 25, 15, 24, 16, 25, 1, 8,
25844 &8, 8, 1, 1, 1, 8, 8, 1, 1, 8, 8, 1, 8, 1, 8, 1, 8, 2, 2, 9, 9, 2,
25845 &2, 9, 9, 2, 9, 1, 13, 23, 14, 1, 1, 8, 8, 1, 1, 23, 14, 1, 8, 1,
25846 &8, 1, 8, 23, 23, 8, 8, 2, 9, 9, 9, 9, 1, 8, 8, 8, 8, 8, 2, 9, 9,
25847 &9, 9, 9, 85*- 1,7*-1,1,8,-1/
25848
25849 IF ( ITDTU .GT. 0 ) THEN
25850 IDT_MCHAD = ITRANS(ITDTU)
25851 ELSE
25852 IDT_MCHAD = -1
25853 END IF
25854
25855 RETURN
25856 END
25857
25858************************************************************************
25859* *
25860* 3) Energy-momentum and quantum number conservation check routines *
25861* *
25862************************************************************************
25863*$ CREATE DT_EMC1.FOR
25864*COPY DT_EMC1
25865*
25866*===emc1===============================================================*
25867*
25868 SUBROUTINE DT_EMC1(PP1,PP2,PT1,PT2,MODE,IPOS,IREJ)
25869
25870************************************************************************
25871* This version dated 15.12.94 is written by S. Roesler *
25872************************************************************************
25873
25874 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25875 SAVE
25876 PARAMETER ( LINP = 10 ,
25877 & LOUT = 6 ,
25878 & LDAT = 9 )
25879 PARAMETER (TINY10=1.0D-10)
25880
25881 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
25882
25883 IREJ = 0
25884
25885 IF ((MODE.EQ.0).OR.(ABS(MODE).GT.3))
25886 & WRITE(LOUT,'(1X,A,I6)')'EMC1: not supported MODE ',MODE
25887
25888 IF ((MODE.GT.0).AND.(MODE.LT.3)) THEN
25889 IF (MODE.EQ.1) THEN
25890 CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),1,IDUM,IDUM)
25891 ELSEIF (MODE.EQ.2) THEN
25892 CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),2,IDUM,IDUM)
25893 ENDIF
25894 CALL DT_EVTEMC(PP2(1),PP2(2),PP2(3),PP2(4),2,IDUM,IDUM)
25895 CALL DT_EVTEMC(PT1(1),PT1(2),PT1(3),PT1(4),2,IDUM,IDUM)
25896 CALL DT_EVTEMC(PT2(1),PT2(2),PT2(3),PT2(4),2,IDUM,IDUM)
25897 ELSEIF (MODE.LT.0) THEN
25898 IF (MODE.EQ.-1) THEN
25899 CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),1,IDUM,IDUM)
25900 ELSEIF (MODE.EQ.-2) THEN
25901 CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),2,IDUM,IDUM)
25902 ENDIF
25903 CALL DT_EVTEMC(-PP2(1),-PP2(2),-PP2(3),-PP2(4),2,IDUM,IDUM)
25904 CALL DT_EVTEMC(-PT1(1),-PT1(2),-PT1(3),-PT1(4),2,IDUM,IDUM)
25905 CALL DT_EVTEMC(-PT2(1),-PT2(2),-PT2(3),-PT2(4),2,IDUM,IDUM)
25906 ENDIF
25907
25908 IF (ABS(MODE).EQ.3) THEN
25909 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,IPOS,IREJ1)
25910 IF (IREJ1.NE.0) GOTO 9999
25911 ENDIF
25912 RETURN
25913
25914 9999 CONTINUE
25915 IREJ = 1
25916 RETURN
25917 END
25918
25919*$ CREATE DT_EMC2.FOR
25920*COPY DT_EMC2
25921*
25922*===emc2===============================================================*
25923*
25924 SUBROUTINE DT_EMC2(IP1,IP2,IP3,IP4,IP5,MP,IN1,IN2,IN3,IN4,IN5,MN,
25925 & MODE,IPOS,IREJ)
25926
25927************************************************************************
25928* MODE = 1 energy-momentum cons. check *
25929* = 2 flavor-cons. check *
25930* = 3 energy-momentum & flavor cons. check *
25931* = 4 energy-momentum & charge cons. check *
25932* = 5 energy-momentum & flavor & charge cons. check *
25933* This version dated 16.01.95 is written by S. Roesler *
25934************************************************************************
25935
25936 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25937 SAVE
25938 PARAMETER ( LINP = 10 ,
25939 & LOUT = 6 ,
25940 & LDAT = 9 )
25941 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
25942
25943* event history
25944 PARAMETER (NMXHKK=200000)
25945 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25946 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25947 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25948* extended event history
25949 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
25950 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
25951 & IHIST(2,NMXHKK)
25952
25953 IREJ = 0
25954 IREJ1 = 0
25955 IREJ2 = 0
25956 IREJ3 = 0
25957
25958 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25959 & CALL DT_EVTEMC(ZERO,ZERO,ZERO,ZERO,1,IDUM,IDUM)
25960 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25961 & CALL DT_EVTFLC(0,IDUM,1,IDUM,IDUM)
25962 IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,1,IDUM,IDUM)
25963 DO 1 I=1,NHKK
25964 IF ((ISTHKK(I).EQ.IP1).OR.(ISTHKK(I).EQ.IP2).OR.
25965 & (ISTHKK(I).EQ.IP3).OR.(ISTHKK(I).EQ.IP4).OR.
25966 & (ISTHKK(I).EQ.IP5)) THEN
25967 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25968 & .OR.(MODE.EQ.5))
25969 & CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
25970 & 2,IDUM,IDUM)
25971 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25972 & CALL DT_EVTFLC(IDHKK(I),MP,2,IDUM,IDUM)
25973 IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25974 & CALL DT_EVTCHG(IDHKK(I),2,IDUM,IDUM)
25975 ENDIF
25976 IF ((ISTHKK(I).EQ.IN1).OR.(ISTHKK(I).EQ.IN2).OR.
25977 & (ISTHKK(I).EQ.IN3).OR.(ISTHKK(I).EQ.IN4).OR.
25978 & (ISTHKK(I).EQ.IN5)) THEN
25979 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25980 & .OR.(MODE.EQ.5))
25981 & CALL DT_EVTEMC(-PHKK(1,I),-PHKK(2,I),-PHKK(3,I),-PHKK(4,I),
25982 & 2,IDUM,IDUM)
25983 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25984 & CALL DT_EVTFLC(IDHKK(I),MN,-2,IDUM,IDUM)
25985 IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25986 & CALL DT_EVTCHG(IDHKK(I),-2,IDUM,IDUM)
25987 ENDIF
25988 1 CONTINUE
25989 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25990 & CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,IPOS,IREJ1)
25991 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25992 & CALL DT_EVTFLC(0,IDUM,3,IPOS,IREJ2)
25993 IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,3,IPOS,IREJ3)
25994 IF ((IREJ1.NE.0).OR.(IREJ2.NE.0).OR.(IREJ3.NE.0)) GOTO 9999
25995
25996 RETURN
25997
25998 9999 CONTINUE
25999 IREJ = 1
26000 RETURN
26001 END
26002
26003*$ CREATE DT_EVTEMC.FOR
26004*COPY DT_EVTEMC
26005*
26006*===evtemc=============================================================*
26007*
26008 SUBROUTINE DT_EVTEMC(PXIO,PYIO,PZIO,EIO,IMODE,IPOS,IREJ)
26009
26010************************************************************************
26011* This version dated 13.12.94 is written by S. Roesler *
26012************************************************************************
26013
26014 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26015 SAVE
26016 PARAMETER ( LINP = 10 ,
26017 & LOUT = 6 ,
26018 & LDAT = 9 )
26019 PARAMETER (TINY1=1.0D-1,TINY2=1.0D-2,TINY4=1.0D-4,TINY10=1.0D-10,
26020 & ZERO=0.0D0)
26021
26022* event history
26023 PARAMETER (NMXHKK=200000)
26024 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26025 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26026 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26027* flags for input different options
26028 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
26029 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
26030 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
26031
26032 IREJ = 0
26033
26034 MODE = IMODE
26035 CHKLEV = TINY10
26036 IF (MODE.EQ.4) THEN
26037 CHKLEV = TINY2
26038 MODE = 3
26039 ELSEIF (MODE.EQ.5) THEN
26040 CHKLEV = TINY1
26041 MODE = 3
26042 ELSEIF (MODE.EQ.-1) THEN
26043 CHKLEV = EIO
26044 MODE = 3
26045 ENDIF
26046
26047 IF (ABS(MODE).EQ.3) THEN
26048 PXDEV = PX
26049 PYDEV = PY
26050 PZDEV = PZ
26051 EDEV = E
26052 IF ((IFRAG(1).EQ.2).AND.(CHKLEV.LT.TINY4)) CHKLEV = TINY4
26053 IF ((ABS(PXDEV).GT.CHKLEV).OR.(ABS(PYDEV).GT.CHKLEV).OR.
26054 & (ABS(PZDEV).GT.CHKLEV).OR.(ABS(EDEV).GT.CHKLEV)) THEN
26055 IF (IOULEV(2).GT.0) WRITE(LOUT,'(1X,A,I4,A,I8,A,/,4G10.3)')
26056 & 'EVTEMC: energy-momentum cons. failure at pos. ',IPOS,
26057 & ' event ',NEVHKK,
26058 & ' ! ',PXDEV,PYDEV,PZDEV,EDEV
26059 PX = 0.0D0
26060 PY = 0.0D0
26061 PZ = 0.0D0
26062 E = 0.0D0
26063 GOTO 9999
26064 ENDIF
26065 PX = 0.0D0
26066 PY = 0.0D0
26067 PZ = 0.0D0
26068 E = 0.0D0
26069 RETURN
26070 ENDIF
26071
26072 IF (MODE.EQ.1) THEN
26073 PX = 0.0D0
26074 PY = 0.0D0
26075 PZ = 0.0D0
26076 E = 0.0D0
26077 ENDIF
26078
26079 PX = PX+PXIO
26080 PY = PY+PYIO
26081 PZ = PZ+PZIO
26082 E = E+EIO
26083
26084 RETURN
26085
26086 9999 CONTINUE
26087 IREJ = 1
26088 RETURN
26089 END
26090
26091*$ CREATE DT_EVTFLC.FOR
26092*COPY DT_EVTFLC
26093*
26094*===evtflc=============================================================*
26095*
26096 SUBROUTINE DT_EVTFLC(ID,ID1,MODE,IPOS,IREJ)
26097
26098************************************************************************
26099* Flavor conservation check. *
26100* ID identity of particle *
26101* ID1 = 1 ID for q,aq,qq,aqaq in PDG-numbering scheme *
26102* = 2 ID for particle/resonance in BAMJET numbering scheme *
26103* = 3 ID for particle/resonance in PDG numbering scheme *
26104* MODE = 1 initialization and add ID *
26105* =-1 initialization and subtract ID *
26106* = 2 add ID *
26107* =-2 subtract ID *
26108* = 3 check flavor cons. *
26109* IPOS flag to give position of call of EVTFLC to output *
26110* unit in case of violation *
26111* This version dated 10.01.95 is written by S. Roesler *
26112************************************************************************
26113
26114 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26115 SAVE
26116 PARAMETER ( LINP = 10 ,
26117 & LOUT = 6 ,
26118 & LDAT = 9 )
26119 PARAMETER (TINY10=1.0D-10)
26120
26121 IREJ = 0
26122
26123 IF (MODE.EQ.3) THEN
26124 IF (IFL.NE.0) THEN
26125 WRITE(LOUT,'(1X,A,I3,A,I3)')
26126 & 'EVTFLC: flavor-conservation failure at pos. ',IPOS,
26127 & ' ! IFL = ',IFL
26128 IFL = 0
26129 GOTO 9999
26130 ENDIF
26131 IFL = 0
26132 RETURN
26133 ENDIF
26134
26135 IF (MODE.EQ.1) IFL = 0
26136 IF (ID.EQ.0) RETURN
26137
26138 IF (ID1.EQ.1) THEN
26139 IDD = ABS(ID)
26140 NQ = 1
26141 IF ((IDD.GE.100).AND.(IDD.LT.1000)) NQ = 2
26142 IF (IDD.GE.1000) NQ = 3
26143 DO 1 I=1,NQ
26144 IFBAM = IDT_IPDG2B(ID,I,2)
26145 IF (ABS(IFBAM).EQ.1) THEN
26146 IFBAM = SIGN(2,IFBAM)
26147 ELSEIF (ABS(IFBAM).EQ.2) THEN
26148 IFBAM = SIGN(1,IFBAM)
26149 ENDIF
26150 IF (MODE.GT.0) THEN
26151 IFL = IFL+IFBAM
26152 ELSE
26153 IFL = IFL-IFBAM
26154 ENDIF
26155 1 CONTINUE
26156 RETURN
26157 ENDIF
26158
26159 IDD = ID
26160 IF (ID1.EQ.3) IDD = IDT_ICIHAD(ID)
26161 IF ((ID1.EQ.2).OR.(ID1.EQ.3)) THEN
26162 DO 2 I=1,3
26163 IF (MODE.GT.0) THEN
26164 IFL = IFL+IDT_IQUARK(I,IDD)
26165 ELSE
26166 IFL = IFL-IDT_IQUARK(I,IDD)
26167 ENDIF
26168 2 CONTINUE
26169 ENDIF
26170 RETURN
26171
26172 9999 CONTINUE
26173 IREJ = 1
26174 RETURN
26175 END
26176
26177*$ CREATE DT_EVTCHG.FOR
26178*COPY DT_EVTCHG
26179*
26180*===evtchg=============================================================*
26181*
26182 SUBROUTINE DT_EVTCHG(ID,MODE,IPOS,IREJ)
26183
26184************************************************************************
26185* Charge conservation check. *
26186* ID identity of particle (PDG-numbering scheme) *
26187* MODE = 1 initialization *
26188* =-2 subtract ID-charge *
26189* = 2 add ID-charge *
26190* = 3 check charge cons. *
26191* IPOS flag to give position of call of EVTCHG to output *
26192* unit in case of violation *
26193* This version dated 10.01.95 is written by S. Roesler *
26194* Last change: s.r. 21.01.01 *
26195************************************************************************
26196
26197 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26198 SAVE
26199 PARAMETER ( LINP = 10 ,
26200 & LOUT = 6 ,
26201 & LDAT = 9 )
26202
26203* event history
26204 PARAMETER (NMXHKK=200000)
26205 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26206 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26207 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26208* particle properties (BAMJET index convention)
26209 CHARACTER*8 ANAME
26210 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26211 & IICH(210),IIBAR(210),K1(210),K2(210)
26212
26213 IREJ = 0
26214
26215 IF (MODE.EQ.1) THEN
26216 ICH = 0
26217 IBAR = 0
26218 RETURN
26219 ENDIF
26220
26221 IF (MODE.EQ.3) THEN
26222 IF ((ICH.NE.0).OR.(IBAR.NE.0)) THEN
26223 WRITE(LOUT,'(1X,A,I3,A,2I3,A,I8)')
26224 & 'EVTCHG: charge/baryo.-cons. failure at pos. ',IPOS,
26225 & '! ICH/IBAR= ',ICH,IBAR,' event ',NEVHKK
26226 ICH = 0
26227 IBAR = 0
26228 GOTO 9999
26229 ENDIF
26230 ICH = 0
26231 IBAR = 0
26232 RETURN
26233 ENDIF
26234
26235 IF (ID.EQ.0) RETURN
26236
26237 IDD = IDT_ICIHAD(ID)
26238* modification 21.1.01: use intrinsic phojet-functions to determine charge
26239* and baryon number
26240C IF (IDD.GT.0) THEN
26241C IF (MODE.EQ.2) THEN
26242C ICH = ICH+IICH(IDD)
26243C IBAR = IBAR+IIBAR(IDD)
26244C ELSEIF (MODE.EQ.-2) THEN
26245C ICH = ICH-IICH(IDD)
26246C IBAR = IBAR-IIBAR(IDD)
26247C ENDIF
26248C ELSE
26249C WRITE(LOUT,'(1X,A,3I6)') 'EVTCHG: (IDD = 0 !), IDD,ID=',IDD,ID
26250C CALL DT_EVTOUT(4)
26251C STOP
26252C ENDIF
26253 IF (MODE.EQ.2) THEN
26254 ICH = ICH+IPHO_CHR3(ID,1)/3
26255 IBAR = IBAR+IPHO_BAR3(ID,1)/3
26256 ELSEIF (MODE.EQ.-2) THEN
26257 ICH = ICH-IPHO_CHR3(ID,1)/3
26258 IBAR = IBAR-IPHO_BAR3(ID,1)/3
26259 ENDIF
26260
26261 RETURN
26262
26263 9999 CONTINUE
26264 IREJ = 1
26265 RETURN
26266 END
26267
26268************************************************************************
26269* *
26270* 4) Transformations *
26271* *
26272************************************************************************
26273*$ CREATE DT_LTINI.FOR
26274*COPY DT_LTINI
26275*
26276*===ltini==============================================================*
26277*
26278 SUBROUTINE DT_LTINI(IDPR,IDTA,EPN0,PPN0,ECM0,MODE)
26279
26280************************************************************************
26281* Initializations of Lorentz-transformations, calculation of Lorentz- *
26282* parameters. *
26283* This version dated 13.11.95 is written by S. Roesler. *
26284************************************************************************
26285
26286 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26287 SAVE
26288 PARAMETER ( LINP = 10 ,
26289 & LOUT = 6 ,
26290 & LDAT = 9 )
26291 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,
26292 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
26293
26294* Lorentz-parameters of the current interaction
26295 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26296 & UMO,PPCM,EPROJ,PPROJ
26297* properties of photon/lepton projectiles
26298 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
26299* particle properties (BAMJET index convention)
26300 CHARACTER*8 ANAME
26301 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26302 & IICH(210),IIBAR(210),K1(210),K2(210)
26303* nucleon-nucleon event-generator
26304 CHARACTER*8 CMODEL
26305 LOGICAL LPHOIN
26306 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
26307
26308 Q2 = VIRT
26309 IDP = IDPR
26310 IF (MCGENE.NE.3) THEN
26311* lepton-projectiles and PHOJET: initialize real photon instead
26312 IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26313 & (IDPR.EQ.10).OR.(IDPR.EQ.11).OR.
26314 & (IDPR.EQ. 5).OR.(IDPR.EQ. 6)) THEN
26315 IDP = 7
26316 Q2 = ZERO
26317 ENDIF
26318 ENDIF
26319 IDT = IDTA
26320 EPN = EPN0
26321 PPN = PPN0
26322 ECM = ECM0
26323 AMP = AAM(IDP)-SQRT(ABS(Q2))
26324 AMT = AAM(IDT)
26325 AMP2 = SIGN(AMP**2,AMP)
26326 AMT2 = AMT**2
26327 IF (ECM0.GT.ZERO) THEN
26328 EPN = (ECM**2-AMP2-AMT2)/(TWO*AMT)
26329 IF (AMP2.GT.ZERO) THEN
26330 PPN = SQRT((EPN+AMP)*(EPN-AMP))
26331 ELSE
26332 PPN = SQRT(EPN**2-AMP2)
26333 ENDIF
26334 ELSE
26335 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26336 IF (IDP.EQ.7) EPN = ABS(EPN)
26337 IF (EPN.LT.ZERO) EPN = ABS(EPN)+AMP
26338 IF (AMP2.GT.ZERO) THEN
26339 PPN = SQRT((EPN+AMP)*(EPN-AMP))
26340 ELSE
26341 PPN = SQRT(EPN**2-AMP2)
26342 ENDIF
26343 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26344 IF (AMP2.GT.ZERO) THEN
26345 EPN = PPN*SQRT(ONE+(AMP/PPN)**2)
26346 ELSE
26347 EPN = SQRT(PPN**2+AMP2)
26348 ENDIF
26349 ENDIF
26350 ECM = SQRT(AMP2+AMT2+TWO*AMT*EPN)
26351 ENDIF
26352 UMO = ECM
26353 EPROJ = EPN
26354 PPROJ = PPN
26355 IF (AMP2.GT.ZERO) THEN
26356 ETARG = (ECM**2-AMP2-AMT2)/(TWO*AMP)
26357 PTARG = -SQRT((ETARG+AMT)*(ETARG-AMT))
26358 ELSE
26359 ETARG = TINY10
26360 PTARG = TINY10
26361 ENDIF
26362* photon-projectiles (get momentum in cm-frame for virtuality Q^2)
26363 IF (IDP.EQ.7) THEN
26364 PGAMM(1) = ZERO
26365 PGAMM(2) = ZERO
26366 AMGAM = AMP
26367 AMGAM2 = AMP2
26368 IF (ECM0.GT.ZERO) THEN
26369 S = ECM0**2
26370 ELSE
26371 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26372 S = AMGAM2+AMT2+TWO*AMT*ABS(EPN0)
26373 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26374 S = AMGAM2+AMT2+TWO*AMT*SQRT(PPN0**2+AMGAM2)
26375 ENDIF
26376 ENDIF
26377 PGAMM(3) = SQRT( (S**2-TWO*AMGAM2*S-TWO*AMT2*S-TWO*AMGAM2*AMT2
26378 & +AMGAM2**2+AMT2**2)/(4.0D0*S) )
26379 PGAMM(4) = SQRT(AMGAM2+PGAMM(3)**2)
26380 IF (MODE.EQ.1) THEN
26381 PNUCL(1) = ZERO
26382 PNUCL(2) = ZERO
26383 PNUCL(3) = -PGAMM(3)
26384 PNUCL(4) = SQRT(S)-PGAMM(4)
26385 ENDIF
26386 ENDIF
26387 IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26388 & (IDPR.EQ.10).OR.(IDPR.EQ.11)) THEN
26389 PLEPT0(1) = ZERO
26390 PLEPT0(2) = ZERO
26391* neglect lepton masses
26392C AMLPT2 = AAM(IDPR)**2
26393 AMLPT2 = ZERO
26394*
26395 IF (ECM0.GT.ZERO) THEN
26396 S = ECM0**2
26397 ELSE
26398 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26399 S = AMLPT2+AMT2+TWO*AMT*ABS(EPN0)
26400 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26401 S = AMLPT2+AMT2+TWO*AMT*SQRT(PPN0**2+AMLPT2)
26402 ENDIF
26403 ENDIF
26404 PLEPT0(3) = SQRT( (S**2-TWO*AMLPT2*S-TWO*AMT2*S-TWO*AMLPT2*AMT2
26405 & +AMLPT2**2+AMT2**2)/(4.0D0*S) )
26406 PLEPT0(4) = SQRT(AMLPT2+PLEPT0(3)**2)
26407 PNUCL(1) = ZERO
26408 PNUCL(2) = ZERO
26409 PNUCL(3) = -PLEPT0(3)
26410 PNUCL(4) = SQRT(S)-PLEPT0(4)
26411 ENDIF
26412* Lorentz-parameter for transformation Lab. - projectile rest system
26413 IF ((IDP.EQ.7).OR.(AMP.LT.TINY10)) THEN
26414 GALAB = TINY10
26415 BGLAB = TINY10
26416 BLAB = TINY10
26417 ELSE
26418 GALAB = EPROJ/AMP
26419 BGLAB = PPROJ/AMP
26420 BLAB = BGLAB/GALAB
26421 ENDIF
26422* Lorentz-parameter for transf. proj. rest sys. - nucl.-nucl. cms.
26423 IF (IDP.EQ.7) THEN
26424 GACMS(1) = TINY10
26425 BGCMS(1) = TINY10
26426 ELSE
26427 GACMS(1) = (ETARG+AMP)/UMO
26428 BGCMS(1) = PTARG/UMO
26429 ENDIF
26430* Lorentz-parameter for transformation Lab. - nucl.-nucl. cms.
26431 GACMS(2) = (EPROJ+AMT)/UMO
26432 BGCMS(2) = PPROJ/UMO
26433 PPCM = GACMS(2)*PPROJ-BGCMS(2)*EPROJ
26434
26435 EPN0 = EPN
26436 PPN0 = PPN
26437 ECM0 = ECM
26438
26439 RETURN
26440 END
26441
26442*$ CREATE DT_LTRANS.FOR
26443*COPY DT_LTRANS
26444*
26445*===ltrans=============================================================*
26446*
26447 SUBROUTINE DT_LTRANS(PXI,PYI,PZI,PEI,PXO,PYO,PZO,PEO,ID,MODE)
26448
26449************************************************************************
26450* Lorentz-transformations. *
26451* MODE = 1(-1) projectile rest syst. --> Lab (back) *
26452* = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) *
26453* = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) *
26454* This version dated 01.11.95 is written by S. Roesler. *
26455************************************************************************
26456
26457 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26458 SAVE
26459 PARAMETER ( LINP = 10 ,
26460 & LOUT = 6 ,
26461 & LDAT = 9 )
26462 PARAMETER (TINY3=1.0D-3,ZERO=0.0D0,TWO=2.0D0)
26463
26464 PARAMETER (SQTINF=1.0D+15)
26465
26466* particle properties (BAMJET index convention)
26467 CHARACTER*8 ANAME
26468 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26469 & IICH(210),IIBAR(210),K1(210),K2(210)
26470
26471 PXO = PXI
26472 PYO = PYI
26473 CALL DT_LTNUC(PZI,PEI,PZO,PEO,MODE)
26474
26475* check particle mass for consistency (numerical rounding errors)
26476 PO = SQRT(PXO*PXO+PYO*PYO+PZO*PZO)
26477 AMO2 = (PEO-PO)*(PEO+PO)
26478 AMORQ2 = AAM(ID)**2
26479 AMDIF2 = ABS(AMO2-AMORQ2)
26480 IF ((AMDIF2.GT.TINY3).AND.(PEO.LT.SQTINF).AND.(PO.GT.ZERO)) THEN
26481 DELTA = (AMORQ2-AMO2)/(TWO*(PEO+PO))
26482 PEO = PEO+DELTA
26483 PO1 = PO -DELTA
26484 PXO = PXO*PO1/PO
26485 PYO = PYO*PO1/PO
26486 PZO = PZO*PO1/PO
26487C WRITE(6,*) 'LTRANS corrected', AMDIF2,PZI,PEI,PZO,PEO,MODE,ID
26488 ENDIF
26489
26490 RETURN
26491 END
26492
26493*$ CREATE DT_LTNUC.FOR
26494*COPY DT_LTNUC
26495*
26496*===ltnuc==============================================================*
26497*
26498 SUBROUTINE DT_LTNUC(PIN,EIN,POUT,EOUT,MODE)
26499
26500************************************************************************
26501* Lorentz-transformations. *
26502* PIN longitudnal momentum (input) *
26503* EIN energy (input) *
26504* POUT transformed long. momentum (output) *
26505* EOUT transformed energy (output) *
26506* MODE = 1(-1) projectile rest syst. --> Lab (back) *
26507* = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) *
26508* = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) *
26509* This version dated 01.11.95 is written by S. Roesler. *
26510************************************************************************
26511
26512 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26513 SAVE
26514 PARAMETER ( LINP = 10 ,
26515 & LOUT = 6 ,
26516 & LDAT = 9 )
26517 PARAMETER (ZERO=0.0D0)
26518
26519* Lorentz-parameters of the current interaction
26520 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26521 & UMO,PPCM,EPROJ,PPROJ
26522
26523 BDUM1 = ZERO
26524 BDUM2 = ZERO
26525 PDUM1 = ZERO
26526 PDUM2 = ZERO
26527 IF (ABS(MODE).EQ.1) THEN
26528 BG = -SIGN(BGLAB,DBLE(MODE))
26529 CALL DT_DALTRA(GALAB,BDUM1,BDUM2,-BG,PDUM1,PDUM2,PIN,EIN,
26530 & DUM1,DUM2,DUM3,POUT,EOUT)
26531 ELSEIF (ABS(MODE).EQ.2) THEN
26532 BG = SIGN(BGCMS(1),DBLE(MODE))
26533 CALL DT_DALTRA(GACMS(1),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26534 & DUM1,DUM2,DUM3,POUT,EOUT)
26535 ELSEIF (ABS(MODE).EQ.3) THEN
26536 BG = -SIGN(BGCMS(2),DBLE(MODE))
26537 CALL DT_DALTRA(GACMS(2),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26538 & DUM1,DUM2,DUM3,POUT,EOUT)
26539 ELSE
26540 WRITE(LOUT,1000) MODE
26541 1000 FORMAT(1X,'LTNUC: not supported mode (MODE = ',I3,')')
26542 EOUT = EIN
26543 POUT = PIN
26544 ENDIF
26545
26546 RETURN
26547 END
26548
26549*$ CREATE DT_DALTRA.FOR
26550*COPY DT_DALTRA
26551*
26552*===daltra=============================================================*
26553*
26554 SUBROUTINE DT_DALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
26555
26556************************************************************************
26557* Arbitrary Lorentz-transformation. *
26558* Adopted from the original by S. Roesler. This version dated 15.01.95 *
26559************************************************************************
26560
26561 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26562 SAVE
26563 PARAMETER (ONE=1.0D0)
26564
26565 EP = PCX*BGX+PCY*BGY+PCZ*BGZ
26566 PE = EP/(GA+ONE)+EC
26567 PX = PCX+BGX*PE
26568 PY = PCY+BGY*PE
26569 PZ = PCZ+BGZ*PE
26570 P = SQRT(PX*PX+PY*PY+PZ*PZ)
26571 E = GA*EC+EP
26572
26573 RETURN
26574 END
26575
26576*$ CREATE DT_DTRAFO.FOR
26577*COPY DT_DTRAFO
26578*
26579*====dtrafo============================================================*
26580*
26581 SUBROUTINE DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
26582 & PL,CXL,CYL,CZL,EL)
26583
26584C LORENTZ TRANSFORMATION INTO THE LAB - SYSTEM
26585
26586 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26587 SAVE
26588
26589 IF (ABS(COD).GT.1.0D0) COD = SIGN(1.0D0,COD)
26590 SID = SQRT(1.D0-COD*COD)
26591 PLX = P*SID*COF
26592 PLY = P*SID*SIF
26593 PCMZ = P*COD
26594 PLZ = GAM*PCMZ+BGAM*ECM
26595 PL = SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
26596 EL = GAM*ECM+BGAM*PCMZ
26597C ROTATION INTO THE ORIGINAL DIRECTION
26598 COZ = PLZ/PL
26599 SIZ = SQRT(1.D0-COZ**2)
26600 CALL DT_STTRAN(CX,CY,CZ,COZ,SIZ,SIF,COF,CXL,CYL,CZL)
26601
26602 RETURN
26603 END
26604
26605*$ CREATE DT_STTRAN.FOR
26606*COPY DT_STTRAN
26607*
26608*====sttran============================================================*
26609*
26610 SUBROUTINE DT_STTRAN(XO,YO,ZO,CDE,SDE,SFE,CFE,X,Y,Z)
26611
26612 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26613 SAVE
26614 DATA ANGLSQ/1.D-30/
26615************************************************************************
26616* VERSION BY J. RANFT *
26617* LEIPZIG *
26618* *
26619* THIS IS A SUBROUTINE OF FLUKA TO GIVE NEW DIRECTION COSINES *
26620* *
26621* INPUT VARIABLES: *
26622* XO,YO,ZO = ORIGINAL DIRECTION COSINES *
26623* CDE,SDE = COSINE AND SINE OF THE POLAR (THETA) *
26624* ANGLE OF "SCATTERING" *
26625* SDE = SINE OF THE POLAR (THETA) ANGLE OF "SCATTERING" *
26626* SFE,CFE = SINE AND COSINE OF THE AZIMUTHAL (PHI) ANGLE *
26627* OF "SCATTERING" *
26628* *
26629* OUTPUT VARIABLES: *
26630* X,Y,Z = NEW DIRECTION COSINES *
26631* *
26632* ROTATION OF COORDINATE SYSTEM (SEE CERN 64-47 ) *
26633************************************************************************
26634*
26635*
26636* Changed by A. Ferrari
26637*
26638* IF (ABS(XO)-0.0001D0) 1,1,2
26639* 1 IF (ABS(YO)-0.0001D0) 3,3,2
26640* 3 CONTINUE
26641 A = XO**2 + YO**2
26642 IF ( A .LT. ANGLSQ ) THEN
26643 X=SDE*CFE
26644 Y=SDE*SFE
26645 Z=CDE*ZO
26646 ELSE
26647 XI=SDE*CFE
26648 YI=SDE*SFE
26649 ZI=CDE
26650 A=SQRT(A)
26651 X=-YO*XI/A-ZO*XO*YI/A+XO*ZI
26652 Y=XO*XI/A-ZO*YO*YI/A+YO*ZI
26653 Z=A*YI+ZO*ZI
26654 ENDIF
26655
26656 RETURN
26657 END
26658
26659*$ CREATE DT_MYTRAN.FOR
26660*COPY DT_MYTRAN
26661*
26662*===mytran=============================================================*
26663*
26664 SUBROUTINE DT_MYTRAN(IMODE,XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
26665
26666************************************************************************
26667* This subroutine rotates the coordinate frame *
26668* a) theta around y *
26669* b) phi around z if IMODE = 1 *
26670* *
26671* x' cos(ph) -sin(ph) 0 cos(th) 0 sin(th) x *
26672* y' = A B = sin(ph) cos(ph) 0 . 0 1 0 y *
26673* z' 0 0 1 -sin(th) 0 cos(th) z *
26674* *
26675* and vice versa if IMODE = 0. *
26676* This version dated 5.4.94 is based on the original version DTRAN *
26677* by J. Ranft and is written by S. Roesler. *
26678************************************************************************
26679
26680 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26681 SAVE
26682 PARAMETER ( LINP = 10 ,
26683 & LOUT = 6 ,
26684 & LDAT = 9 )
26685
26686 IF (IMODE.EQ.1) THEN
26687 X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
26688 Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
26689 Z=-SDE *XO +CDE *ZO
26690 ELSE
26691 X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
26692 Y= -SFE*XO+CFE*YO
26693 Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
26694 ENDIF
26695 RETURN
26696 END
26697
26698*$ CREATE DT_LT2LAO.FOR
26699*COPY DT_LT2LAO
26700*
26701*===lt2lab=============================================================*
26702*
26703 SUBROUTINE DT_LT2LAO
26704
26705************************************************************************
26706* Lorentz-transformation to lab-system. This subroutine scans DTEVT1 *
26707* for final state particles/fragments defined in nucleon-nucleon-cms *
26708* and transforms them back to the lab. *
26709* This version dated 16.11.95 is written by S. Roesler *
26710************************************************************************
26711
26712 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26713 SAVE
26714 PARAMETER ( LINP = 10 ,
26715 & LOUT = 6 ,
26716 & LDAT = 9 )
26717
26718* event history
26719 PARAMETER (NMXHKK=200000)
26720 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26721 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26722 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26723* extended event history
26724 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26725 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26726 & IHIST(2,NMXHKK)
26727
26728 NEND = NHKK
26729 NPOINT(5) = NHKK+1
26730 IF ( (NPOINT(4).EQ.0).OR.(NEND.LT.NPOINT(4)) ) RETURN
26731 DO 1 I=NPOINT(4),NEND
26732C DO 1 I=1,NEND
26733 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26734 & (ISTHKK(I).EQ.1001)) THEN
26735 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26736 NOB = NOBAM(I)
26737 CALL DT_EVTPUT(ISTHKK(I),IDHKK(I),I,0,PHKK(1,I),PHKK(2,I),
26738 & PZ,PE,IDRES(I),IDXRES(I),IDCH(I))
26739 IF ((ISTHKK(I).EQ.1000).OR.(ISTHKK(I).EQ.1001)) THEN
26740 ISTHKK(I) = 3*ISTHKK(I)
26741 NOBAM(NHKK) = NOB
26742 ELSE
26743 IF (ISTHKK(I).EQ.-1) NOBAM(NHKK) = NOB
26744 ISTHKK(I) = SIGN(3,ISTHKK(I))
26745 ENDIF
26746 JDAHKK(1,I) = NHKK
26747 ENDIF
26748 1 CONTINUE
26749
26750 RETURN
26751 END
26752
26753*$ CREATE DT_LT2LAB.FOR
26754*COPY DT_LT2LAB
26755*
26756*===lt2lab=============================================================*
26757*
26758 SUBROUTINE DT_LT2LAB
26759
26760************************************************************************
26761* Lorentz-transformation to lab-system. This subroutine scans DTEVT1 *
26762* for final state particles/fragments defined in nucleon-nucleon-cms *
26763* and transforms them to the lab. *
26764* This version dated 07.01.96 is written by S. Roesler *
26765************************************************************************
26766
26767 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26768 SAVE
26769 PARAMETER ( LINP = 10 ,
26770 & LOUT = 6 ,
26771 & LDAT = 9 )
26772
26773* event history
26774 PARAMETER (NMXHKK=200000)
26775 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26776 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26777 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26778* extended event history
26779 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26780 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26781 & IHIST(2,NMXHKK)
26782
26783 IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
26784 DO 1 I=NPOINT(4),NHKK
26785 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26786 & (ISTHKK(I).EQ.1001)) THEN
430525dd 26787
9aaba0d6 26788 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26789 PHKK(3,I) = PZ
26790 PHKK(4,I) = PE
26791 ENDIF
26792 1 CONTINUE
26793
26794 RETURN
26795 END
26796
26797************************************************************************
26798* *
26799* 5) Sampling from distributions *
26800* *
26801************************************************************************
26802*$ CREATE IDT_NPOISS.FOR
26803*COPY IDT_NPOISS
26804*
26805*===npoiss=============================================================*
26806*
26807 INTEGER FUNCTION IDT_NPOISS(AVN)
26808
26809************************************************************************
26810* Sample according to Poisson distribution with Poisson parameter AVN. *
26811* The original version written by J. Ranft. *
26812* This version dated 11.1.95 is written by S. Roesler. *
26813************************************************************************
26814
26815 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26816 SAVE
26817 PARAMETER ( LINP = 10 ,
26818 & LOUT = 6 ,
26819 & LDAT = 9 )
26820
26821 EXPAVN = EXP(-AVN)
26822 K = 1
26823 A = 1.0D0
26824
26825 10 CONTINUE
26826 A = DT_RNDM(A)*A
26827 IF (A.GE.EXPAVN) THEN
26828 K = K+1
26829 GOTO 10
26830 ENDIF
26831 IDT_NPOISS = K-1
26832
26833 RETURN
26834 END
26835
26836*$ CREATE DT_SAMPXB.FOR
26837*COPY DT_SAMPXB
26838*
26839*===sampxb=============================================================*
26840*
26841 DOUBLE PRECISION FUNCTION DT_SAMPXB(X1,X2,B)
26842
26843************************************************************************
26844* Sampling from f(x)=1./SQRT(X**2+B**2) between x1 and x2. *
26845* Processed by S. Roesler, 6.5.95 *
26846************************************************************************
26847
26848 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26849 SAVE
26850 PARAMETER (TWO=2.0D0)
26851
26852 A1 = LOG(X1+SQRT(X1**2+B**2))
26853 A2 = LOG(X2+SQRT(X2**2+B**2))
26854 AN = A2-A1
26855 A = AN*DT_RNDM(A1)+A1
26856 BB = EXP(A)
26857 DT_SAMPXB = (BB**2-B**2)/(TWO*BB)
26858
26859 RETURN
26860 END
26861
26862*$ CREATE DT_SAMPEX.FOR
26863*COPY DT_SAMPEX
26864*
26865*===sampex=============================================================*
26866*
26867 DOUBLE PRECISION FUNCTION DT_SAMPEX(X1,X2)
26868
26869************************************************************************
26870* Sampling from f(x)=1./x between x1 and x2. *
26871* Processed by S. Roesler, 6.5.95 *
26872************************************************************************
26873
26874 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26875 SAVE
26876 PARAMETER (ONE=1.0D0)
26877
26878 R = DT_RNDM(X1)
26879 AL1 = LOG(X1)
26880 AL2 = LOG(X2)
26881 DT_SAMPEX = EXP((ONE-R)*AL1+R*AL2)
26882
26883 RETURN
26884 END
26885
26886*$ CREATE DT_SAMSQX.FOR
26887*COPY DT_SAMSQX
26888*
26889*===samsqx=============================================================*
26890*
26891 DOUBLE PRECISION FUNCTION DT_SAMSQX(X1,X2)
26892
26893************************************************************************
26894* Sampling from f(x)=1./x^0.5 between x1 and x2. *
26895* Processed by S. Roesler, 6.5.95 *
26896************************************************************************
26897
26898 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26899 SAVE
26900 PARAMETER (ONE=1.0D0)
26901
26902 R = DT_RNDM(X1)
26903 DT_SAMSQX = (R*SQRT(X2)+(ONE-R)*SQRT(X1))**2
26904
26905 RETURN
26906 END
26907
26908*$ CREATE DT_SAMPLW.FOR
26909*COPY DT_SAMPLW
26910*
26911*===samplw=============================================================*
26912*
26913 DOUBLE PRECISION FUNCTION DT_SAMPLW(XMIN,XMAX,B)
26914
26915************************************************************************
26916* Sampling from f(x)=1/x^b between x_min and x_max. *
26917* S. Roesler, 18.4.98 *
26918************************************************************************
26919
26920 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26921 SAVE
26922 PARAMETER (ONE=1.0D0)
26923
26924 R = DT_RNDM(B)
26925 IF (B.EQ.ONE) THEN
26926 DT_SAMPLW = EXP(R*LOG(XMAX)+(ONE-R)*LOG(XMIN))
26927 ELSE
26928 ONEMB = ONE-B
26929 DT_SAMPLW = (R*XMAX**ONEMB+(ONE-R)*XMIN**ONEMB)**(ONE/ONEMB)
26930 ENDIF
26931
26932 RETURN
26933 END
26934
26935*$ CREATE DT_BETREJ.FOR
26936*COPY DT_BETREJ
26937*
26938*===betrej=============================================================*
26939*
26940 DOUBLE PRECISION FUNCTION DT_BETREJ(GAM,ETA,XMIN,XMAX)
26941
26942 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26943 SAVE
26944
26945 PARAMETER ( LINP = 10 ,
26946 & LOUT = 6 ,
26947 & LDAT = 9 )
26948 PARAMETER (ONE=1.0D0)
26949
26950 IF (XMIN.GE.XMAX)THEN
26951 WRITE (LOUT,500) XMIN,XMAX
26952 500 FORMAT(1X,'DT_BETREJ: XMIN<XMAX execution stopped ',2F10.5)
26953 STOP
26954 ENDIF
26955
26956 10 CONTINUE
26957 XX = XMIN+(XMAX-XMIN)*DT_RNDM(ETA)
26958 BETMAX = XMIN**(GAM-ONE)*(ONE-XMIN)**(ETA-ONE)
26959 YY = BETMAX*DT_RNDM(XX)
26960 BETXX = XX**(GAM-ONE)*(ONE-XX)**(ETA-ONE)
26961 IF (YY.GT.BETXX) GOTO 10
26962 DT_BETREJ = XX
26963
26964 RETURN
26965 END
26966
26967*$ CREATE DT_DGAMRN.FOR
26968*COPY DT_DGAMRN
26969*
26970*===dgamrn=============================================================*
26971*
26972 DOUBLE PRECISION FUNCTION DT_DGAMRN(ALAM,ETA)
26973
26974************************************************************************
26975* Sampling from Gamma-distribution. *
26976* F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA) *
26977* Processed by S. Roesler, 6.5.95 *
26978************************************************************************
26979
26980 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26981 SAVE
26982 PARAMETER (ZERO=0.0D0,TINY9=1.0D-9,ONE=1.0D0)
26983
26984 NCOU = 0
26985 N = INT(ETA)
26986 F = ETA-DBLE(N)
26987 IF (F.EQ.ZERO) GOTO 20
26988 10 R = DT_RNDM(F)
26989 NCOU = NCOU+1
26990 IF (NCOU.GE.11) GOTO 20
26991 IF (R.LT.F/(F+2.71828D0)) GOTO 30
26992 YYY = LOG(DT_RNDM(R)+TINY9)/F
26993 IF (ABS(YYY).GT.50.0D0) GOTO 20
26994 Y = EXP(YYY)
26995 IF (LOG(DT_RNDM(Y)+TINY9).GT.-Y) GOTO 10
26996 GOTO 40
26997 20 Y = 0.0D0
26998 GOTO 50
26999 30 Y = ONE-LOG(DT_RNDM(Y)+TINY9)
27000 IF (DT_RNDM(R).GT.Y**(F-ONE)) GOTO 10
27001 40 IF (N.EQ.0) GOTO 70
27002 50 Z = 1.0D0
27003 DO 60 I = 1,N
27004 60 Z = Z*DT_RNDM(Z)
27005 Y = Y-LOG(Z+TINY9)
27006 70 DT_DGAMRN = Y/ALAM
27007
27008 RETURN
27009 END
27010
27011*$ CREATE DT_DBETAR.FOR
27012*COPY DT_DBETAR
27013*
27014*===dbetar=============================================================*
27015*
27016 DOUBLE PRECISION FUNCTION DT_DBETAR(GAM,ETA)
27017
27018************************************************************************
27019* Sampling from Beta -distribution between 0.0 and 1.0 *
27020* F(X)=X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM)/(GAMM(GAM)*GAMM(ETA))*
27021* Processed by S. Roesler, 6.5.95 *
27022************************************************************************
27023
27024 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27025 SAVE
27026
27027 Y = DT_DGAMRN(1.0D0,GAM)
27028 Z = DT_DGAMRN(1.0D0,ETA)
27029 DT_DBETAR = Y/(Y+Z)
27030
27031 RETURN
27032 END
27033
27034*$ CREATE DT_RANNOR.FOR
27035*COPY DT_RANNOR
27036*
27037*===rannor=============================================================*
27038*
27039 SUBROUTINE DT_RANNOR(X,Y)
27040
27041************************************************************************
27042* Sampling from Gaussian distribution. *
27043* Processed by S. Roesler, 6.5.95 *
27044************************************************************************
27045
27046 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27047 SAVE
27048 PARAMETER (TINY10=1.0D-10)
27049
27050 CALL DT_DSFECF(SFE,CFE)
27051 V = MAX(TINY10,DT_RNDM(X))
27052 A = SQRT(-2.D0*LOG(V))
27053 X = A*SFE
27054 Y = A*CFE
27055
27056 RETURN
27057 END
27058
27059*$ CREATE DT_DPOLI.FOR
27060*COPY DT_DPOLI
27061*
27062*===dpoli==============================================================*
27063*
27064 SUBROUTINE DT_DPOLI(CS,SI)
27065
27066 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27067 SAVE
27068
27069 U = DT_RNDM(CS)
27070 CS = DT_RNDM(U)
27071 IF (U.LT.0.5D0) CS=-CS
27072 SI = SQRT(1.0D0-CS*CS+1.0D-10)
27073
27074 RETURN
27075 END
27076
27077*$ CREATE DT_DSFECF.FOR
27078*COPY DT_DSFECF
27079*
27080*===dsfecf=============================================================*
27081*
27082 SUBROUTINE DT_DSFECF(SFE,CFE)
27083
27084 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27085 SAVE
27086 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
27087
27088 1 CONTINUE
27089 X = DT_RNDM(SFE)
27090 Y = DT_RNDM(X)
27091 XX = X*X
27092 YY = Y*Y
27093 XY = XX+YY
27094 IF (XY.GT.ONE) GOTO 1
27095 CFE = (XX-YY)/XY
27096 SFE = TWO*X*Y/XY
27097 IF (DT_RNDM(X).LT.OHALF) SFE = -SFE
27098 RETURN
27099 END
27100
27101*$ CREATE DT_RACO.FOR
27102*COPY DT_RACO
27103*
27104*===raco===============================================================*
27105*
27106 SUBROUTINE DT_RACO(WX,WY,WZ)
27107
27108************************************************************************
27109* Direction cosines of random uniform (isotropic) direction in three *
27110* dimensional space *
27111* Processed by S. Roesler, 20.11.95 *
27112************************************************************************
27113
27114 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27115 SAVE
27116 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
27117
27118 10 CONTINUE
27119 X = TWO*DT_RNDM(WX)-ONE
27120 Y = DT_RNDM(X)
27121 X2 = X*X
27122 Y2 = Y*Y
27123 IF (X2+Y2.GT.ONE) GOTO 10
27124
27125 CFE = (X2-Y2)/(X2+Y2)
27126 SFE = TWO*X*Y/(X2+Y2)
27127* z = 1/2 [ 1 + cos (theta) ]
27128 Z = DT_RNDM(X)
27129* 1/2 sin (theta)
27130 WZ = SQRT(Z*(ONE-Z))
27131 WX = TWO*WZ*CFE
27132 WY = TWO*WZ*SFE
27133 WZ = TWO*Z-ONE
27134
27135 RETURN
27136 END
27137
27138************************************************************************
27139* *
27140* 6) Special functions, algorithms and service routines *
27141* *
27142************************************************************************
27143*$ CREATE DT_YLAMB.FOR
27144*COPY DT_YLAMB
27145*
27146*===ylamb==============================================================*
27147*
27148 DOUBLE PRECISION FUNCTION DT_YLAMB(X,Y,Z)
27149
27150************************************************************************
27151* *
27152* auxiliary function for three particle decay mode *
27153* (standard LAMBDA**(1/2) function) *
27154* *
27155* Adopted from an original version written by R. Engel. *
27156* This version dated 12.12.94 is written by S. Roesler. *
27157************************************************************************
27158
27159 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27160 SAVE
27161
27162 YZ = Y-Z
27163 XLAM = X*X-2.D0*X*(Y+Z)+YZ*YZ
27164 IF (XLAM.LE.0.D0) XLAM = ABS(XLAM)
27165 DT_YLAMB = SQRT(XLAM)
27166
27167 RETURN
27168 END
27169
27170*$ CREATE DT_SORT.FOR
27171*COPY DT_SORT
27172*
27173*===sort1==============================================================*
27174*
27175 SUBROUTINE DT_SORT(A,N,I0,I1,MODE)
27176
27177************************************************************************
27178* This subroutine sorts entries in A in increasing/decreasing order *
27179* of A(3,i). *
27180* MODE = 1 increasing in A(3,i=1..N) *
27181* = 2 decreasing in A(3,i=1..N) *
27182* This version dated 21.04.95 is revised by S. Roesler *
27183************************************************************************
27184
27185 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27186 SAVE
27187
27188 DIMENSION A(3,N)
27189
27190 M = I1
27191 10 CONTINUE
27192 M = I1-1
27193 IF (M.LE.0) RETURN
27194 L = 0
27195 DO 20 I=I0,M
27196 J = I+1
27197 IF (MODE.EQ.1) THEN
27198 IF (A(3,I).LE.A(3,J)) GOTO 20
27199 ELSE
27200 IF (A(3,I).GE.A(3,J)) GOTO 20
27201 ENDIF
27202 B = A(3,I)
27203 C = A(1,I)
27204 D = A(2,I)
27205 A(3,I) = A(3,J)
27206 A(2,I) = A(2,J)
27207 A(1,I) = A(1,J)
27208 A(3,J) = B
27209 A(1,J) = C
27210 A(2,J) = D
27211 L = 1
27212 20 CONTINUE
27213 IF (L.EQ.1) GOTO 10
27214
27215 RETURN
27216 END
27217
27218*$ CREATE DT_SORT1.FOR
27219*COPY DT_SORT1
27220*
27221*===sort1==============================================================*
27222*
27223 SUBROUTINE DT_SORT1(A,IDX,N,I0,I1,MODE)
27224
27225************************************************************************
27226* This subroutine sorts entries in A in increasing/decreasing order *
27227* of A(i). *
27228* MODE = 1 increasing in A(i=1..N) *
27229* = 2 decreasing in A(i=1..N) *
27230* This version dated 21.04.95 is revised by S. Roesler *
27231************************************************************************
27232
27233 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27234 SAVE
27235
27236 DIMENSION A(N),IDX(N)
27237
27238 M = I1
27239 10 CONTINUE
27240 M = I1-1
27241 IF (M.LE.0) RETURN
27242 L = 0
27243 DO 20 I=I0,M
27244 J = I+1
27245 IF (MODE.EQ.1) THEN
27246 IF (A(I).LE.A(J)) GOTO 20
27247 ELSE
27248 IF (A(I).GE.A(J)) GOTO 20
27249 ENDIF
27250 B = A(I)
27251 A(I) = A(J)
27252 A(J) = B
27253 IX = IDX(I)
27254 IDX(I) = IDX(J)
27255 IDX(J) = IX
27256 L = 1
27257 20 CONTINUE
27258 IF (L.EQ.1) GOTO 10
27259
27260 RETURN
27261 END
27262
27263*$ CREATE DT_XTIME.FOR
27264*COPY DT_XTIME
27265*
27266*===xtime==============================================================*
27267*
27268 SUBROUTINE DT_XTIME
27269
27270 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27271 SAVE
27272 PARAMETER ( LINP = 10 ,
27273 & LOUT = 6 ,
27274 & LDAT = 9 )
27275
27276 CHARACTER DAT*9,TIM*11
27277
27278 DAT = ' '
27279 TIM = ' '
27280C CALL GETDAT(IYEAR,IMONTH,IDAY)
27281C CALL GETTIM(IHOUR,IMINUT,ISECND,IHSCND)
27282
27283C CALL DATE(DAT)
27284C CALL TIME(TIM)
27285C WRITE(LOUT,1000) DAT,TIM
27286 1000 FORMAT(/,2X,'Date: ',A9,3X,'Time: ',A11,/)
27287
27288 RETURN
27289 END
27290
27291************************************************************************
27292* *
27293* 7) Random number generator package *
27294* *
27295* THIS IS A PACKAGE CONTAINING A RANDOM NUMBER GENERATOR AND *
27296* SERVICE ROUTINES. *
27297* THE ALGORITHM IS FROM *
27298* 'TOWARD A UNVERSAL RANDOM NUMBER GENERATOR' *
27299* G.MARSAGLIA, A.ZAMAN ; FSU-SCRI-87-50 *
27300* IMPLEMENTATION BY K. HAHN DEC. 88, *
27301* THIS GENERATOR SHOULD NOT DEPEND ON THE HARD WARE ( IF A REAL HAS *
27302* AT LEAST 24 SIGNIFICANT BITS IN INTERNAL REPRESENTATION ), *
27303* THE PERIOD IS ABOUT 2**144, *
27304* TIME FOR ONE CALL AT IBM-XT IS ABOUT 0.7 MILLISECONDS, *
27305* THE PACKAGE CONTAINS *
27306* FUNCTION DT_RNDM(I) : GENERATOR *
27307* SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB4): INITIALIZATION *
27308* SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) : PUT SEED TO GENERATOR *
27309* SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) : TAKE SEED FROM GENERATOR *
27310* SUBROUTINE DT_RNDMTE(IO) : TEST OF GENERATOR *
27311*--- *
27312* FUNCTION DT_RNDM(I) *
27313* GIVES UNIFORMLY DISTRIBUTED RANDOM NUMBERS IN (0..1) *
27314* I - DUMMY VARIABLE, NOT USED *
27315* SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1) *
27316* INITIALIZES THE GENERATOR, MUST BE CALLED BEFORE USING DT_RNDM *
27317* NA1,NA2,NA3,NB1 - VALUES FOR INITIALIZING THE GENERATOR *
27318* NA? MUST BE IN 1..178 AND NOT ALL 1 *
27319* 12,34,56 ARE THE STANDARD VALUES *
27320* NB1 MUST BE IN 1..168 *
27321* 78 IS THE STANDARD VALUE *
27322* SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) *
27323* PUTS SEED TO GENERATOR ( BRINGS GENERATOR IN THE SAME STATUS *
27324* AS AFTER THE LAST DT_RNDMOU CALL ) *
27325* U(97),C,CD,CM,I,J - SEED VALUES AS TAKEN FROM DT_RNDMOU *
27326* SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) *
27327* TAKES SEED FROM GENERATOR *
27328* U(97),C,CD,CM,I,J - SEED VALUES *
27329* SUBROUTINE DT_RNDMTE(IO) *
27330* TEST OF THE GENERATOR *
27331* IO - DEFINES OUTPUT *
27332* = 0 OUTPUT ONLY IF AN ERROR IS DETECTED *
27333* = 1 OUTPUT INDEPENDEND ON AN ERROR *
27334* DT_RNDMTE USES DT_RNDMIN AND DT_RNDMOU TO BRING GENERATOR TO *
27335* SAME STATUS *
27336* AS BEFORE CALL OF DT_RNDMTE *
27337************************************************************************
27338*$ CREATE DT_RNDM.FOR
27339*COPY DT_RNDM
27340*
839efe5b 27341c$$$*===rndm===============================================================*
27342c$$$*
27343c$$$ DOUBLE PRECISION FUNCTION DT_RNDM(VDUMMY)
27344c$$$
27345c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27346c$$$ SAVE
27347c$$$
27348c$$$* random number generator
27349c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27350c$$$
27351c$$$* counter of calls to random number generator
27352c$$$* uncomment if needed
27353c$$$C COMMON /DTRNCT/ IRNCT0,IRNCT1
27354c$$$C LOGICAL LFIRST
27355c$$$C DATA LFIRST /.TRUE./
27356c$$$
27357c$$$* counter of calls to random number generator
27358c$$$* uncomment if needed
27359c$$$C IF (LFIRST) THEN
27360c$$$C IRNCT0 = 0
27361c$$$C IRNCT1 = 0
27362c$$$C LFIRST = .FALSE.
27363c$$$C ENDIF
27364c$$$ 100 CONTINUE
27365c$$$ DT_RNDM = U(I)-U(J)
27366c$$$ IF ( DT_RNDM.LT.0.0D0 ) DT_RNDM = DT_RNDM+1.0D0
27367c$$$ U(I) = DT_RNDM
27368c$$$ I = I-1
27369c$$$ IF ( I.EQ.0 ) I = 97
27370c$$$ J = J-1
27371c$$$ IF ( J.EQ.0 ) J = 97
27372c$$$ C = C-CD
27373c$$$ IF ( C.LT.0.0D0 ) C = C+CM
27374c$$$ DT_RNDM = DT_RNDM-C
27375c$$$ IF ( DT_RNDM.LT.0.0D0 ) DT_RNDM = DT_RNDM+1.0D0
27376c$$$
27377c$$$ IF ((DT_RNDM.EQ.0.D0).OR.(DT_RNDM.EQ.1.D0)) GOTO 100
27378c$$$
27379c$$$* counter of calls to random number generator
27380c$$$* uncomment if needed
27381c$$$C IRNCT0 = IRNCT0+1
27382c$$$
27383c$$$ RETURN
27384c$$$ END
27385c$$$
27386c$$$*$ CREATE DT_RNDMST.FOR
27387c$$$*COPY DT_RNDMST
27388c$$$*
27389c$$$*===rndmst=============================================================*
27390c$$$*
27391c$$$ SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)
27392c$$$
27393c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27394c$$$ SAVE
27395c$$$
27396c$$$* random number generator
27397c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27398c$$$
27399c$$$ MA1 = NA1
27400c$$$ MA2 = NA2
27401c$$$ MA3 = NA3
27402c$$$ MB1 = NB1
27403c$$$ I = 97
27404c$$$ J = 33
27405c$$$ DO 20 II2 = 1,97
27406c$$$ S = 0
27407c$$$ T = 0.5D0
27408c$$$ DO 10 II1 = 1,24
27409c$$$ MAT = MOD(MOD(MA1*MA2,179)*MA3,179)
27410c$$$ MA1 = MA2
27411c$$$ MA2 = MA3
27412c$$$ MA3 = MAT
27413c$$$ MB1 = MOD(53*MB1+1,169)
27414c$$$ IF ( MOD(MB1*MAT,64).GE.32 ) S = S+T
27415c$$$ 10 T = 0.5D0*T
27416c$$$ 20 U(II2) = S
27417c$$$ C = 362436.0D0/16777216.0D0
27418c$$$ CD = 7654321.0D0/16777216.0D0
27419c$$$ CM = 16777213.0D0/16777216.0D0
27420c$$$ RETURN
27421c$$$ END
27422c$$$
27423c$$$*$ CREATE DT_RNDMIN.FOR
27424c$$$*COPY DT_RNDMIN
27425c$$$*
27426c$$$*===rndmin=============================================================*
27427c$$$*
27428c$$$ SUBROUTINE DT_RNDMIN(UIN,CIN,CDIN,CMIN,IIN,JIN)
27429c$$$
27430c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27431c$$$ SAVE
27432c$$$
27433c$$$* random number generator
27434c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27435c$$$
27436c$$$ DIMENSION UIN(97)
27437c$$$
27438c$$$ DO 10 KKK = 1,97
27439c$$$ 10 U(KKK) = UIN(KKK)
27440c$$$ C = CIN
27441c$$$ CD = CDIN
27442c$$$ CM = CMIN
27443c$$$ I = IIN
27444c$$$ J = JIN
27445c$$$
27446c$$$ RETURN
27447c$$$ END
27448c$$$
27449c$$$*$ CREATE DT_RNDMOU.FOR
27450c$$$*COPY DT_RNDMOU
27451c$$$*
27452c$$$*===rndmou=============================================================*
27453c$$$*
27454c$$$ SUBROUTINE DT_RNDMOU(UOUT,COUT,CDOUT,CMOUT,IOUT,JOUT)
27455c$$$
27456c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27457c$$$ SAVE
27458c$$$
27459c$$$* random number generator
27460c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27461c$$$
27462c$$$ DIMENSION UOUT(97)
27463c$$$
27464c$$$ DO 10 KKK = 1,97
27465c$$$ 10 UOUT(KKK) = U(KKK)
27466c$$$ COUT = C
27467c$$$ CDOUT = CD
27468c$$$ CMOUT = CM
27469c$$$ IOUT = I
27470c$$$ JOUT = J
27471c$$$
27472c$$$ RETURN
27473c$$$ END
27474c$$$
27475c$$$*$ CREATE DT_RNDMTE.FOR
27476c$$$*COPY DT_RNDMTE
27477c$$$*
27478c$$$*===rndmte=============================================================*
27479c$$$*
27480c$$$ SUBROUTINE DT_RNDMTE(IO)
27481c$$$
27482c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27483c$$$ SAVE
27484c$$$
27485c$$$ DIMENSION UU(97),U(6),X(6),D(6)
27486c$$$ DATA U / 6533892.D0, 14220222.D0, 7275067.D0, 6172232.D0,
27487c$$$ +8354498.D0, 10633180.D0/
27488c$$$
27489c$$$ CALL DT_RNDMOU(UU,CC,CCD,CCM,II,JJ)
27490c$$$ CALL DT_RNDMST(12,34,56,78)
27491c$$$ DO 10 II1 = 1,20000
27492c$$$ 10 XX = DT_RNDM(XX)
27493c$$$ SD = 0.0D0
27494c$$$ DO 20 II2 = 1,6
27495c$$$ X(II2) = 4096.D0*(4096.D0*DT_RNDM(SD))
27496c$$$ D(II2) = X(II2)-U(II2)
27497c$$$ 20 SD = SD+D(II2)
27498c$$$ CALL DT_RNDMIN(UU,CC,CCD,CCM,II,JJ)
27499c$$$**sr 24.01.95
27500c$$$C IF ( IO.EQ. 1.OR. SD.NE.0. 0) WRITE(6,500) (U(I),X(I),D(I),I=1,6)
27501c$$$ IF ((IO.EQ.1).OR.(SD.NE.0.0)) THEN
27502c$$$C WRITE(6,1000)
27503c$$$ 1000 FORMAT(/,/,1X,'DT_RNDMTE: Test of random-number generator...',
27504c$$$ & ' passed')
27505c$$$ ENDIF
27506c$$$**
27507c$$$ RETURN
27508c$$$ 500 FORMAT(' === TEST OF THE RANDOM-GENERATOR ===',/,
27509c$$$ &' EXPECTED VALUE CALCULATED VALUE DIFFERENCE',/, 6(F17.
27510c$$$ &1,F20.1,F15.3,/), ' === END OF TEST ;',
27511c$$$ &' GENERATOR HAS THE SAME STATUS AS BEFORE CALLING DT_RNDMTE')
27512c$$$ END
9aaba0d6 27513*
27514*$ CREATE PHO_RNDM.FOR
27515*COPY PHO_RNDM
27516*
27517*===pho_rndm===========================================================*
27518*
27519 DOUBLE PRECISION FUNCTION PHO_RNDM(DUMMY)
27520
27521 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27522 SAVE
27523
27524 PHO_RNDM = DT_RNDM(DUMMY)
27525
27526 RETURN
27527 END
27528
27529*$ CREATE PYR.FOR
27530*COPY PYR
27531*
27532*===pyr================================================================*
27533*
27534 DOUBLE PRECISION FUNCTION PYR(IDUMMY)
27535
27536 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27537 SAVE
27538
27539 DUMMY = DBLE(IDUMMY)
27540 PYR = DT_RNDM(DUMMY)
27541
27542 RETURN
27543 END
27544
27545*$ CREATE DT_TITLE.FOR
27546*COPY DT_TITLE
27547*
27548*===title==============================================================*
27549*
27550 SUBROUTINE DT_TITLE
27551
27552 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27553 SAVE
27554 PARAMETER ( LINP = 10 ,
27555 & LOUT = 6 ,
27556 & LDAT = 9 )
27557
27558 CHARACTER*6 CVERSI
27559 CHARACTER*11 CCHANG
27560 DATA CVERSI,CCHANG /'3.0-5 ','08 Jan 2007'/
27561
27562 CALL DT_XTIME
27563 WRITE(LOUT,1000) CVERSI,CCHANG
27564 1000 FORMAT(1X,'+-------------------------------------------------',
27565 & '----------------------+',/,
27566 & 1X,'|',71X,'|',/,
27567 & 1X,'|',26X,'DPMJET version ',A6,24X,'|',/,
27568 & 1X,'|',71X,'|',/,
27569 & 1X,'|',22X,'(Last change: ',A11,')',23X,'|',/,
27570 & 1X,'|',71X,'|',/,
27571 & 1X,'|',12X,'Authors: Stefan Roesler (CERN)',27X,'|',/,
27572 & 1X,'|',21X,'Ralph Engel (FZ Karlsruhe)',19X,'|',/,
27573 & 1X,'|',21X,'Johannes Ranft (Siegen Univ.)',19X,'|',/,
27574 & 1X,'|',71X,'|',/,
27575 & 1X,'|',12X,'http://home.cern.ch/~sroesler/dpmjet3.html',
27576 & 17X,'|',/,
27577 & 1X,'|',71X,'|',/,
27578 & 1X,'+-------------------------------------------------',
27579 & '----------------------+',/,
27580 & 1X,'| Please send suggestions, bug reports, etc. to: ',
27581 & 'Stefan.Roesler@cern.ch |',/,
27582 & 1X,'+-------------------------------------------------',
27583 & '----------------------+',/)
27584
27585 RETURN
27586 END
27587
27588*$ CREATE DT_EVTINI.FOR
27589*COPY DT_EVTINI
27590*
27591*===evtini=============================================================*
27592*
27593 SUBROUTINE DT_EVTINI
27594
27595************************************************************************
27596* Initialization of DTEVT1. *
27597* This version dated 15.01.94 is written by S. Roesler *
27598************************************************************************
27599
27600 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27601 SAVE
27602 PARAMETER ( LINP = 10 ,
27603 & LOUT = 6 ,
27604 & LDAT = 9 )
27605
27606* event history
27607 PARAMETER (NMXHKK=200000)
27608 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27609 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27610 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27611* extended event history
27612 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27613 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27614 & IHIST(2,NMXHKK)
27615* event flag
27616 COMMON /DTEVNO/ NEVENT,ICASCA
27617 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
27618* emulsion treatment
27619 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
27620 & NCOMPO,IEMUL
27621
27622* initialization of DTEVT1/DTEVT2
27623 NEND = NHKK
27624 IF (NEVENT.EQ.1) NEND = NMXHKK
27625 NHKK = 0
27626 NEVHKK = NEVENT
27627 DO 1 I=1,NEND
27628 ISTHKK(I) = 0
27629 IDHKK(I) = 0
27630 JMOHKK(1,I) = 0
27631 JMOHKK(2,I) = 0
27632 JDAHKK(1,I) = 0
27633 JDAHKK(2,I) = 0
27634 IDRES(I) = 0
27635 IDXRES(I) = 0
27636 NOBAM(I) = 0
27637 IDCH(I) = 0
27638 IHIST(1,I) = 0
27639 IHIST(2,I) = 0
27640 DO 2 J=1,4
27641 PHKK(J,I) = 0.0D0
27642 VHKK(J,I) = 0.0D0
27643 WHKK(J,I) = 0.0D0
27644 2 CONTINUE
27645 PHKK(5,I) = 0.0D0
27646 1 CONTINUE
27647 DO 3 I=1,10
27648 NPOINT(I) = 0
27649 3 CONTINUE
27650 CALL DT_CHASTA(-1)
27651
27652C* initialization of DTLTRA
27653C IF (NCOMPO.GT.0) CALL DT_LTINI(ID,EPN,PPN,ECM)
27654
27655 RETURN
27656 END
27657
27658*$ CREATE DT_STATIS.FOR
27659*COPY DT_STATIS
27660*
27661*===statis=============================================================*
27662*
27663 SUBROUTINE DT_STATIS(MODE)
27664
27665************************************************************************
27666* Initialization and output of run-statistics. *
27667* MODE = 1 initialization *
27668* = 2 output *
27669* This version dated 23.01.94 is written by S. Roesler *
27670************************************************************************
27671
27672 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27673 SAVE
27674 PARAMETER ( LINP = 10 ,
27675 & LOUT = 6 ,
27676 & LDAT = 9 )
27677 PARAMETER (TINY3=1.0D-3)
27678
27679* statistics
27680 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
27681 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
27682 & ICEVTG(8,0:30)
27683* rejection counter
27684 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27685 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27686 & IREXCI(3),IRDIFF(2),IRINC
27687* central particle production, impact parameter biasing
27688 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
27689* various options for treatment of partons (DTUNUC 1.x)
27690* (chain recombination, Cronin,..)
27691 LOGICAL LCO2CR,LINTPT
27692 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
27693 & LCO2CR,LINTPT
27694* nucleon-nucleon event-generator
27695 CHARACTER*8 CMODEL
27696 LOGICAL LPHOIN
27697 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
27698* flags for particle decays
27699 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
27700 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
27701 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
27702* diquark-breaking mechanism
27703 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
27704
27705 DIMENSION PP(4),PT(4)
27706
27707 GOTO (1,2) MODE
27708
27709* initialization
27710 1 CONTINUE
27711
27712* initialize statistics counter
27713 ICREQU = 0
27714 ICSAMP = 0
27715 ICCPRO = 0
27716 ICDPR = 0
27717 ICDTA = 0
27718 ICRJSS = 0
27719 ICVV2S = 0
27720 DO 10 I=1,9
27721 ICRES(I) = 0
27722 ICCHAI(1,I) = 0
27723 ICCHAI(2,I) = 0
27724 10 CONTINUE
27725* initialize rejection counter
27726 IRPT = 0
27727 IRHHA = 0
27728 LOMRES = 0
27729 LOBRES = 0
27730 IRFRAG = 0
27731 IREVT = 0
27732 IRRES(1) = 0
27733 IRRES(2) = 0
27734 IRCHKI(1) = 0
27735 IRCHKI(2) = 0
27736 IRCRON(1) = 0
27737 IRCRON(2) = 0
27738 IRCRON(3) = 0
27739 IRDIFF(1) = 0
27740 IRDIFF(2) = 0
27741 IRINC = 0
27742 DO 11 I=1,5
27743 ICDIFF(I) = 0
27744 11 CONTINUE
27745 DO 12 I=1,8
27746 DO 13 J=0,30
27747 ICEVTG(I,J) = 0
27748 13 CONTINUE
27749 12 CONTINUE
27750
27751 RETURN
27752
27753* output
27754 2 CONTINUE
27755
27756* statistics counter
27757 WRITE(LOUT,1000)
27758 1000 FORMAT(/,/,1X,'STATIS:',20X,'statistics of the run',/,
27759 & 28X,'---------------------')
be6523b4 27760 IF (ICREQU.GT.0) THEN
9aaba0d6 27761 WRITE(LOUT,1001) ICREQU,ICSAMP,DBLE(ICSAMP)/DBLE(ICREQU)
27762 1001 FORMAT(/,1X,'number of events requested / sampled',13X,
27763 & I8,' / ',I8,/,1X,'number of samp. evts per requested ',
27764 & 'event',11X,F9.1)
be6523b4 27765 ENDIF
9aaba0d6 27766 IF (ICDIFF(1).NE.0) THEN
27767 WRITE(LOUT,1009) ICDIFF
27768 1009 FORMAT(/,1X,'diffractive events: total ',I8,/,49X,
27769 & 'low mass high mass',/,24X,'single diffraction',
27770 & 7X,I8,4X,I8,/,24X,'double diffraction',7X,I8,4X,I8)
27771 ENDIF
be6523b4 27772 IF (ICENTR.GT.0.AND.ICSAMP.GT.0.AND.ICCPRO.GT.0) THEN
9aaba0d6 27773 WRITE(LOUT,1002) DBLE(ICCPRO)/DBLE(ICSAMP),
27774 & DBLE(ICSAMP)/DBLE(ICCPRO)
27775 1002 FORMAT(/,1X,'central production:',/,2X,'mean number',
27776 & ' of sampled Glauber-events per event',9X,F9.1,/,
27777 & 2X,'fraction of production cross section',21X,F10.6)
27778 ENDIF
be6523b4 27779 IF (ICSAMP.GT.0) THEN
9aaba0d6 27780 WRITE(LOUT,1003) DBLE(ICDPR)/DBLE(ICSAMP),
27781 & DBLE(ICDTA)/DBLE(ICSAMP)
27782 1003 FORMAT(/,54X,'proj. targ.',/,1X,'average number of wounded',
27783 & ' nucleons after x-sampling',2(4X,F6.2))
be6523b4 27784 ENDIF
9aaba0d6 27785
27786 IF (MCGENE.EQ.1) THEN
be6523b4 27787 IF (ICSAMP.GT.0) THEN
9aaba0d6 27788 WRITE(LOUT,1004) DBLE(ICRJSS)/DBLE(ICSAMP)
27789 1004 FORMAT(/,1X,'mean number of sea-sea chain rejections per',
27790 & ' event',3X,F9.1)
27791 IF (ISICHA.EQ.1) THEN
27792 WRITE(LOUT,1005) DBLE(ICVV2S)/DBLE(ICSAMP)
27793 1005 FORMAT(/,1X,'Reggeon contribution:',/,1X,'mean number ',
27794 & 'of single chains per event',13X,F9.1)
27795 ENDIF
be6523b4 27796 ENDIF
27797 IF (ICSAMP.GT.0.AND.ICREQU.GT.0) THEN
9aaba0d6 27798 WRITE(LOUT,1006)
27799 1006 FORMAT(/,1X,'chain system statistics: (per event)',/,
27800 & 23X,'mean number of chains mean number of chains',/,
27801 & 23X,'sampled hadronized having mass of a reso.')
27802 WRITE(LOUT,1007) (DBLE(ICCHAI(1,J))/(2.0D0*DBLE(ICSAMP)),
27803 & DBLE(ICCHAI(2,J))/(2.0D0*DBLE(ICREQU)),
27804 & DBLE(ICRES(J))/(2.0D0*DBLE(ICREQU)),J=1,8),
27805 & DBLE(ICCHAI(2,9))/MAX(DBLE(ICCHAI(1,9)),TINY3)
27806 1007 FORMAT(1X,'sea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27807 & 1X,'disea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27808 & 1X,'sea - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27809 & 1X,'sea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27810 & 1X,'disea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27811 & 1X,'valence - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27812 & 1X,'valence - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27813 & 1X,'valence - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27814 & 1X,'fused chains ',18X,F4.1,17X,F4.1,/)
27815 WRITE(LOUT,1008)
27816 & (DBLE(IRCRON(I))/MAX(DBLE(IRCRON(1)),TINY3),I=2,3),
27817 & DBLE(IRPT)/DBLE(ICREQU),(DBLE(IRRES(I))/DBLE(ICREQU),I=1,2),
27818 & DBLE(LOMRES)/DBLE(ICREQU),DBLE(LOBRES)/DBLE(ICREQU),
27819 & (DBLE(IRCHKI(I))/DBLE(ICREQU),I=1,2),
27820 & (DBLE(IRDIFF(I))/DBLE(ICREQU),I=1,2),
27821 & DBLE(IRHHA)/DBLE(ICREQU),
27822 & DBLE(IRFRAG)/DBLE(ICREQU),DBLE(IREVT)/DBLE(ICREQU),
27823 & (DBLE(IREXCI(I))/DBLE(ICREQU),I=1,2),IREXCI(3)
27824 1008 FORMAT(/,1X,'Rejection counter: (NEVT = no. of events)',/,/,
27825 & 1X,'Cronin-effect (CRONIN)',15X,'IRCRON(2)/IRCRON(1) = ',
27826 & F7.2,/,38X,'IRCRON(3)/IRCRON(1) = ',F7.2,/,1X,
27827 & 'Intrins. p_t (GETSPT)',21X,'IRPT /NEVT = ',F7.2,/,
27828 & 1X,'Chain mass corr. for resonances (EVTRES)',2X,
27829 & 'IRRES(1) /NEVT = ',F7.2,/,33X,'(CH2RES) IRRES(2) /',
27830 & 'NEVT = ',F7.2,/,43X,'LOMRES /NEVT = ',F7.2,/,
27831 & 43X,'LOBRES /NEVT = ',F7.2,/,1X,'Kinem. corr. of',
27832 & ' 2-chain systems (CHKINE) IRCHKI(1)/NEVT = ',F7.2,/,
27833 & 43X,'IRCHKI(2)/NEVT = ',F7.2,/,1X,'Diffraction',31X,
27834 & 'IRDIFF(1)/NEVT = ',F7.2,/,43X,'IRDIFF(2)/NEVT = ',
27835 & F7.2,/,1X,'Total no. of rej.',
27836 & ' in chain-systems treatment (GETCSY)',/,43X,
27837 & 'IRHHA /NEVT = ',F7.2,/,1X,'Fragmentation (EVTFRA)',
27838 & ' (not yet used!)',4X,'IRFRAG /NEVT = ',F7.2,/,
27839 & 1X,'Total no. of rej. in DPM-treatment of one event',
27840 & ' (EVENTA)',/,43X,'IREVT /NEVT = ',F7.2,/,1X,
27841 & 'Treatment of final nucleon conf.',10X,'IREXCI(1)/NEVT = '
27842 & ,F7.2,/,43X,'IREXCI(2)/NEVT = ',F7.2,/,48X,
27843 & 'IREXCI(3) = ',I5,/)
be6523b4 27844 ENDIF
9aaba0d6 27845 ELSEIF (MCGENE.EQ.2) THEN
27846 WRITE(LOUT,1010) ELOJET
27847 1010 FORMAT(/,/,1X,'PHOJET-treatment of chain systems above ',
27848 & F4.1,' GeV')
27849 WRITE(LOUT,1011)
27850 1011 FORMAT(/,1X,'1. chain system statistics - total numbers:',/,
27851 & 30X,'--------------',/,/,12X,'s-s',5X,'d-s',5X,'s-d',
27852 & 5X,'s-v',5X,'d-v',5X,'v-s',5X,'v-d',5X,'v-v')
27853 WRITE(LOUT,1012) ((ICEVTG(I,J),I=1,8),J=0,1),
27854 & (INT(ICCHAI(2,I)/2.0D0),I=1,8),
27855 & (ICEVTG(I,2),I=1,8),(ICEVTG(I,29),I=1,8),
27856 & ((ICEVTG(I,J),I=1,8),J=3,7),
27857 & ((ICEVTG(I,J),I=1,8),J=19,21),
27858 & (ICEVTG(I,8),I=1,8),
27859 & ((ICEVTG(I,J),I=1,8),J=22,24),
27860 & (ICEVTG(I,9),I=1,8),
27861 & ((ICEVTG(I,J),I=1,8),J=25,28),
27862 & ((ICEVTG(I,J),I=1,8),J=10,18)
27863 1012 FORMAT(/,1X,'req.to.',8I8,/,/,1X,'low rq.',8I8,/,1X,'low ac.',
27864 & 8I8,/,/,1X,'PHOJET ',8I8,/,' sngl ',8I8,/,/,
27865 & ' no-dif.',8I8,/,
27866 & ' el-sca.',8I8,/,' qel-sc.',8I8,/,' dbl-Po.',8I8,/,
27867 & ' diff-1 ',8I8,/,' low ',8I8,/,' high ',8I8,/,
27868 & ' h-diff',8I8,/,' diff-2 ',8I8,/,' low ',8I8,/,
27869 & ' high ',8I8,/,' h-diff',8I8,/,' dbl-di.',8I8,/,
27870 & ' lo-lo ',8I8,/,' hi-hi ',8I8,/,' lo-hi ',8I8,/,
27871 & ' hi-lo ',8I8,/,
27872 & ' dir-ga.',8I8,/,/,' dir-1 ',8I8,/,' dir-2 ',8I8,/,
27873 & ' dbl-dir',8I8,/,' s-Pom. ',8I8,/,' h-Pom. ',8I8,/,
27874 & ' s-Reg. ',8I8,/,' enh-trg',8I8,/,' enh-log',8I8)
27875 WRITE(LOUT,1013)
27876 1013 FORMAT(/,1X,'2. chain system statistics -',
27877 & ' mean numbers per evt:',/,30X,'---------------------',
27878 & /,/,16X,'s-s',7X,'d-s',7X,'s-d')
be6523b4 27879 IF (ICSAMP.GT.0) THEN
9aaba0d6 27880 WRITE(LOUT,1014)
27881 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=0,1),
27882 & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=1,3),
27883 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=2,18)
27884 1014 FORMAT(/,1X,'req.to. ',3E10.2,/,/,1X,'low rq. ',3E10.2,/,
27885 & 1X,'low ac. ',3E10.2,/,/,1X,'PHOJET ',3E10.2,/,/,
27886 & ' no-dif. ',3E10.2,/,' el-sca. ',3E10.2,/,
27887 & ' qel-sc. ',3E10.2,/,' dbl-Po. ',3E10.2,/,
27888 & ' diff-1 ',3E10.2,/,' diff-2 ',3E10.2,/,
27889 & ' dbl-di. ',3E10.2,/,' dir-ga. ',3E10.2,/,/,
27890 & ' dir-1 ',3E10.2,/,' dir-2 ',3E10.2,/,
27891 & ' dbl-dir ',3E10.2,/,' s-Pom. ',3E10.2,/,
27892 & ' h-Pom. ',3E10.2,/,' s-Reg. ',3E10.2,/,
27893 & ' enh-trg ',3E10.2,/,' enh-log ',3E10.2)
be6523b4 27894 ENDIF
9aaba0d6 27895 WRITE(LOUT,1015)
27896 1015 FORMAT(/,16X,'s-v',7X,'d-v',7X,'v-s',7X,'v-d',7X,'v-v')
be6523b4 27897 IF (ICSAMP.GT.0) THEN
9aaba0d6 27898 WRITE(LOUT,1016)
27899 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=0,1),
27900 & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=4,8),
27901 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=2,18)
27902 1016 FORMAT(/,1X,'req.to. ',5E10.2,/,/,1X,'low rq. ',5E10.2,/,
27903 & 1X,'low ac. ',5E10.2,/,/,1X,'PHOJET ',5E10.2,/,/,
27904 & ' no-dif. ',5E10.2,/,' el-sca. ',5E10.2,/,
27905 & ' qel-sc. ',5E10.2,/,' dbl-Po. ',5E10.2,/,
27906 & ' diff-1 ',5E10.2,/,' diff-2 ',5E10.2,/,
27907 & ' dbl-di. ',5E10.2,/,' dir-ga. ',5E10.2,/,/,
27908 & ' dir-1 ',5E10.2,/,' dir-2 ',5E10.2,/,
27909 & ' dbl-dir ',5E10.2,/,' s-Pom. ',5E10.2,/,
27910 & ' h-Pom. ',5E10.2,/,' s-Reg. ',5E10.2,/,
27911 & ' enh-trg ',5E10.2,/,' enh-log ',5E10.2)
be6523b4 27912 ENDIF
9aaba0d6 27913
27914 ENDIF
27915 CALL DT_CHASTA(1)
27916
27917 IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
27918 & .OR.(PDBSEA(3).GT.0.0D0)) THEN
27919 WRITE(LOUT,*)'YGS1S,YGS2S,YUS1S,YUS2S',
27920 & DBRKA(1,1)+DBRKA(2,1),DBRKA(1,2)+DBRKA(2,2),
27921 & DBRKA(1,3)+DBRKA(2,3),DBRKA(1,4)+DBRKA(2,4)
27922 WRITE(LOUT,*)'YGS1R,YGS2R,YUS1R,YUS2R',
27923 & DBRKR(1,1)+DBRKR(2,1),DBRKR(1,2)+DBRKR(2,2),
27924 & DBRKR(1,3)+DBRKR(2,3),DBRKR(1,4)+DBRKR(2,4)
27925 WRITE(LOUT,*)'YGSA1S,YGSA2S,YUSA1S,YUSA2S',
27926 & DBRKA(1,5)+DBRKA(2,5),DBRKA(1,6)+DBRKA(2,6),
27927 & DBRKA(1,7)+DBRKA(2,7),DBRKA(1,8)+DBRKA(2,8)
27928 WRITE(LOUT,*)'YGSA1R,YGSA2R,YUSA1R,YUSA2R',
27929 & DBRKR(1,5)+DBRKR(2,5),DBRKR(1,6)+DBRKR(2,6),
27930 & DBRKR(1,7)+DBRKR(2,7),DBRKR(1,8)+DBRKR(2,8)
27931 WRITE(LOUT,*)'YG31S,YG32S,YU31S,YU32S',
27932 & DBRKA(3,1),DBRKA(3,2),
27933 & DBRKA(3,3),DBRKA(3,4)
27934 WRITE(LOUT,*)'YG31R,YG32R,YU31R,YU32R',
27935 & DBRKR(3,1),DBRKR(3,2),
27936 & DBRKR(3,3),DBRKR(3,4)
27937 WRITE(LOUT,*)'YG3A1S,YG3A2S,YU3A1S,YU3A2S',
27938 & DBRKA(3,5),DBRKA(3,6),
27939 & DBRKA(3,7),DBRKA(3,8)
27940 WRITE(LOUT,*)'YG3A1R,YG3A2R,YU3A1R,YU3A2R',
27941 & DBRKR(3,5),DBRKR(3,6),
27942 & DBRKR(3,7),DBRKR(3,8)
27943 ENDIF
27944
27945 FAC = 1.0D0
27946 IF (MCGENE.EQ.2) THEN
27947C CALL PHO_PHIST(-2,SIGMAX)
27948 CALL PHO_EVENT(-2,PP,PT,FAC,IREJ1)
27949 ENDIF
27950
27951 CALL DT_XTIME
27952
27953 RETURN
27954 END
27955
27956*$ CREATE DT_EVTOUT.FOR
27957*COPY DT_EVTOUT
27958*
27959*===evtout=============================================================*
27960*
27961 SUBROUTINE DT_EVTOUT(MODE)
27962
27963************************************************************************
27964* MODE = 1 plot content of complete DTEVT1 to out. unit *
27965* 3 plot entries of extended DTEVT1 (DTEVT2) *
27966* 4 plot entries of DTEVT1 and DTEVT2 *
27967* This version dated 11.12.94 is written by S. Roesler *
27968************************************************************************
27969
27970 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27971 SAVE
27972 PARAMETER ( LINP = 10 ,
27973 & LOUT = 6 ,
27974 & LDAT = 9 )
27975* event history
27976 PARAMETER (NMXHKK=200000)
27977 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27978 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27979 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27980
27981 DIMENSION IRANGE(NMXHKK)
27982
27983 IF (MODE.EQ.2) RETURN
27984
27985 CALL DT_EVTPLO(IRANGE,MODE)
27986
27987 RETURN
27988 END
27989
27990*$ CREATE DT_EVTPLO.FOR
27991*COPY DT_EVTPLO
27992*
27993*===evtplo=============================================================*
27994*
27995 SUBROUTINE DT_EVTPLO(IRANGE,MODE)
27996
27997************************************************************************
27998* MODE = 1 plot content of complete DTEVT1 to out. unit *
27999* 2 plot entries of DTEVT1 given by IRANGE *
28000* 3 plot entries of extended DTEVT1 (DTEVT2) *
28001* 4 plot entries of DTEVT1 and DTEVT2 *
28002* 5 plot rejection counter *
28003* This version dated 11.12.94 is written by S. Roesler *
28004************************************************************************
28005
28006 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28007 SAVE
28008 PARAMETER ( LINP = 10 ,
28009 & LOUT = 6 ,
28010 & LDAT = 9 )
28011
28012 CHARACTER*16 CHAU
28013
28014* event history
28015 PARAMETER (NMXHKK=200000)
28016 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28017 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28018 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28019* extended event history
28020 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28021 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28022 & IHIST(2,NMXHKK)
28023* rejection counter
28024 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
28025 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
28026 & IREXCI(3),IRDIFF(2),IRINC
28027
28028 DIMENSION IRANGE(NMXHKK)
28029
28030 IF ((MODE.EQ.1).OR.(MODE.EQ.4)) THEN
28031 WRITE(LOUT,1000)
28032 1000 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTEVT1/',/,
28033 & 15X,' --------------------------',/,/,
28034 & ' ST ID M1 M2 D1 D2 PX PY',
28035 & ' PZ E M',/)
28036 DO 1 I=1,NHKK
28037 WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28038 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28039 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
28040 & PHKK(5,I)
28041C WRITE(LOUT,1011) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28042C & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28043C & PHKK(3,I),PHKK(4,I)
28044C WRITE(LOUT,'(4E15.4)')
28045C & VHKK(1,I),VHKK(2,I),VHKK(3,I),VHKK(4,I)
28046 1001 FORMAT(I5,I5,I6,4I5,3F7.3,F8.3,F8.4)
28047 1011 FORMAT(I5,I5,I6,4I5,2E15.5)
28048 1 CONTINUE
28049 WRITE(LOUT,*)
28050C DO 4 I=1,NHKK
28051C WRITE(LOUT,1006) I,ISTHKK(I),
28052C & VHKK(1,I),VHKK(2,I),VHKK(3,I),WHKK(1,I),
28053C & WHKK(2,I),WHKK(3,I)
28054C1006 FORMAT(1X,I4,I6,6E10.3)
28055C 4 CONTINUE
28056 ENDIF
28057
28058 IF (MODE.EQ.2) THEN
28059 WRITE(LOUT,1000)
28060 NC = 0
28061 2 CONTINUE
28062 NC = NC+1
28063 IF (IRANGE(NC).EQ.-100) GOTO 9999
28064 I = IRANGE(NC)
28065 WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28066 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28067 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
28068 & PHKK(5,I)
28069 GOTO 2
28070 ENDIF
28071
28072 IF ((MODE.EQ.3).OR.(MODE.EQ.4)) THEN
28073 WRITE(LOUT,1002)
28074 1002 FORMAT(/,1X,'EVTPLO:',14X,
28075 & ' content of COMMON /DTEVT1/,/DTEVT2/',/,
28076 & 15X,' -----------------------------------',/,/,
28077 & ' ST ID M1 M2 D1 D2 IDR IDXR',
28078 & ' NOBAM IDCH M',/)
28079 DO 3 I=1,NHKK
28080C IF ((ISTHKK(I).GT.10).OR.(ISTHKK(I).EQ.1)) THEN
28081 KF = IDHKK(I)
28082 IDCHK = KF/10000
28083 IF ((((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
28084 & (KF.NE.80000)).OR.(IDHKK(I).EQ.99999)) KF = 92
28085 CALL PYNAME(KF,CHAU)
28086 WRITE(LOUT,1003) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28087 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28088 & IDRES(I),IDXRES(I),NOBAM(I),IDCH(I),
28089 & PHKK(5,I),CHAU
28090 1003 FORMAT(I5,I5,I6,4I5,4I4,F8.4,2X,A)
28091C ENDIF
28092 3 CONTINUE
28093 ENDIF
28094
28095 IF (MODE.EQ.5) THEN
28096 WRITE(LOUT,1004)
28097 1004 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTREJC/',/,
28098 & 15X,' --------------------------',/)
28099 WRITE(LOUT,1005) IRPT,IRHHA,IRRES,LOMRES,LOBRES,IREMC,IRFRAG,
28100 & IRSEA,IRCRON
28101 1005 FORMAT(1X,'IRPT = ',I5,' IRHHA = ',I5,/,
28102 & 1X,'IRRES = ',2I5,' LOMRES = ',I5,' LOBRES = ',I5,/,
28103 & 1X,'IREMC = ',10I5,/,
28104 & 1X,'IRFRAG = ',I5,' IRSEA = ',I5,' IRCRON = ',I5,/)
28105 ENDIF
28106
28107 9999 RETURN
28108 END
28109
28110*$ CREATE DT_EVTPUT.FOR
28111*COPY DT_EVTPUT
28112*
28113*===evtput=============================================================*
28114*
28115 SUBROUTINE DT_EVTPUT(IST,ID,M1,M2,PX,PY,PZ,E,IDR,IDXR,IDC)
28116
28117 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28118 SAVE
28119 PARAMETER ( LINP = 10 ,
28120 & LOUT = 6 ,
28121 & LDAT = 9 )
28122 PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,TINY3=1.0D-3,
28123 & TINY2=1.0D-2,SQTINF=1.0D+15,ZERO=0.0D0)
28124
28125* event history
28126 PARAMETER (NMXHKK=200000)
28127 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28128 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28129 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28130* extended event history
28131 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28132 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28133 & IHIST(2,NMXHKK)
28134* Lorentz-parameters of the current interaction
28135 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28136 & UMO,PPCM,EPROJ,PPROJ
28137* particle properties (BAMJET index convention)
28138 CHARACTER*8 ANAME
28139 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28140 & IICH(210),IIBAR(210),K1(210),K2(210)
28141
28142C IF (MODE.GT.100) THEN
28143C WRITE(LOUT,'(1X,A,I5,A,I5)')
28144C & 'EVTPUT: reset NHKK = ',NHKK,' to NHKK =',NHKK-MODE+100
28145C NHKK = NHKK-MODE+100
28146C RETURN
28147C ENDIF
28148 MO1 = M1
28149 MO2 = M2
28150 NHKK = NHKK+1
28151
28152 IF (NHKK.GT.NMXHKK) THEN
28153 WRITE(LOUT,1000) NHKK
28154 1000 FORMAT(1X,'EVTPUT: NHKK exeeds NMXHKK = ',I7,
28155 & '! program execution stopped..')
28156 STOP
28157 ENDIF
28158 IF (M1.LT.0) MO1 = NHKK+M1
28159 IF (M2.LT.0) MO2 = NHKK+M2
28160 ISTHKK(NHKK) = IST
28161 IDHKK(NHKK) = ID
28162 JMOHKK(1,NHKK) = MO1
28163 JMOHKK(2,NHKK) = MO2
28164 JDAHKK(1,NHKK) = 0
28165 JDAHKK(2,NHKK) = 0
28166 IDRES(NHKK) = IDR
28167 IDXRES(NHKK) = IDXR
28168 IDCH(NHKK) = IDC
28169** here we need to do something..
28170 IF (ID.EQ.88888) THEN
28171 IDMO1 = ABS(IDHKK(MO1))
28172 IDMO2 = ABS(IDHKK(MO2))
28173 IF ((IDMO1.LT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 3
28174 IF ((IDMO1.LT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 4
28175 IF ((IDMO1.GT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 5
28176 IF ((IDMO1.GT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 6
28177 ELSE
28178 NOBAM(NHKK) = 0
28179 ENDIF
28180 IDBAM(NHKK) = IDT_ICIHAD(ID)
28181 IF (MO1.GT.0) THEN
28182 IF (JDAHKK(1,MO1).NE.0) THEN
28183 JDAHKK(2,MO1) = NHKK
28184 ELSE
28185 JDAHKK(1,MO1) = NHKK
28186 ENDIF
28187 ENDIF
28188 IF (MO2.GT.0) THEN
28189 IF (JDAHKK(1,MO2).NE.0) THEN
28190 JDAHKK(2,MO2) = NHKK
28191 ELSE
28192 JDAHKK(1,MO2) = NHKK
28193 ENDIF
28194 ENDIF
28195C IF ((IDBAM(NHKK).GT.0).AND.(IDBAM(NHKK).NE.7)) THEN
28196C PTOT = SQRT(PX**2+PY**2+PZ**2)
28197C AM0 = SQRT(ABS( (E-PTOT)*(E+PTOT) ))
28198C AMRQ = AAM(IDBAM(NHKK))
28199C AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
28200C IF ((ABS(AMDIF2).GT.TINY3).AND.(E.LT.SQTINF).AND.
28201C & (PTOT.GT.ZERO)) THEN
28202C DELTA = -AMDIF2/(2.0D0*(E+PTOT))
28203CC DELTA = (AMRQ2-AM2)/(2.0D0*(E+PTOT))
28204C E = E+DELTA
28205C PTOT1 = PTOT-DELTA
28206C PX = PX*PTOT1/PTOT
28207C PY = PY*PTOT1/PTOT
28208C PZ = PZ*PTOT1/PTOT
28209C ENDIF
28210C ENDIF
28211 PHKK(1,NHKK) = PX
28212 PHKK(2,NHKK) = PY
28213 PHKK(3,NHKK) = PZ
28214 PHKK(4,NHKK) = E
28215 PTOT = SQRT( PX**2+PY**2+PZ**2 )
28216 IF ((IDHKK(NHKK).GE.22).AND.(IDHKK(NHKK).LE.24)) THEN
28217 PHKK(5,NHKK) = PHKK(4,NHKK)**2-PTOT**2
28218 PHKK(5,NHKK) = SIGN(SQRT(ABS(PHKK(5,NHKK))),PHKK(5,NHKK))
28219 ELSE
28220 PHKK(5,NHKK) = (PHKK(4,NHKK)-PTOT)*(PHKK(4,NHKK)+PTOT)
28221C IF ((PHKK(5,NHKK).LT.0.0D0).AND.(ABS(PHKK(5,NHKK)).GT.TINY4))
28222C & WRITE(LOUT,'(1X,A,G10.3)')
28223C & 'EVTPUT: negative mass**2 ',PHKK(5,NHKK)
28224 PHKK(5,NHKK) = SQRT(ABS(PHKK(5,NHKK)))
28225 ENDIF
28226 IDCHK = ID/10000
28227 IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.(ID.NE.80000)) THEN
28228* special treatment for chains:
28229* z coordinate of chain in Lab = pos. of target nucleon
28230* time of chain-creation in Lab = time of passage of projectile
28231* nucleus at pos. of taget nucleus
28232C VHKK(1,NHKK) = 0.5D0*(VHKK(1,MO1)+VHKK(1,MO2))
28233C VHKK(2,NHKK) = 0.5D0*(VHKK(2,MO1)+VHKK(2,MO2))
28234 VHKK(1,NHKK) = VHKK(1,MO2)
28235 VHKK(2,NHKK) = VHKK(2,MO2)
28236 VHKK(3,NHKK) = VHKK(3,MO2)
28237 VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
28238C WHKK(1,NHKK) = 0.5D0*(WHKK(1,MO1)+WHKK(1,MO2))
28239C WHKK(2,NHKK) = 0.5D0*(WHKK(2,MO1)+WHKK(2,MO2))
28240 WHKK(1,NHKK) = WHKK(1,MO1)
28241 WHKK(2,NHKK) = WHKK(2,MO1)
28242 WHKK(3,NHKK) = WHKK(3,MO1)
28243 WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
28244 ELSE
28245 IF (MO1.GT.0) THEN
28246 DO 1 I=1,4
28247 VHKK(I,NHKK) = VHKK(I,MO1)
28248 WHKK(I,NHKK) = WHKK(I,MO1)
28249 1 CONTINUE
28250 ELSE
28251 DO 2 I=1,4
28252 VHKK(I,NHKK) = ZERO
28253 WHKK(I,NHKK) = ZERO
28254 2 CONTINUE
28255 ENDIF
28256 ENDIF
28257
28258 RETURN
28259 END
28260
28261*$ CREATE DT_CHASTA.FOR
28262*COPY DT_CHASTA
28263*
28264*===chasta=============================================================*
28265*
28266 SUBROUTINE DT_CHASTA(MODE)
28267
28268************************************************************************
28269* This subroutine performs CHAin STAtistics and checks sequence of *
28270* partons in dtevt1 and sorts them with projectile partons coming *
28271* first if necessary. *
28272* *
28273* This version dated 8.5.00 is written by S. Roesler. *
28274************************************************************************
28275
28276 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28277 SAVE
28278 PARAMETER ( LINP = 10 ,
28279 & LOUT = 6 ,
28280 & LDAT = 9 )
28281
28282 CHARACTER*5 CCHTYP
28283
28284* event history
28285 PARAMETER (NMXHKK=200000)
28286 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28287 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28288 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28289* extended event history
28290 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28291 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28292 & IHIST(2,NMXHKK)
28293* pointer to chains in hkkevt common (used by qq-breaking mechanisms)
28294 PARAMETER (MAXCHN=10000)
28295 COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
28296
28297 DIMENSION ICHCFG(10,10,9,2),ICHTYP(5,5),
28298 & CCHTYP(9),ICHSTA(10),ITOT(10)
28299 DATA ICHCFG /1800*0/
28300 DATA (ICHTYP(1,K),K=1,5) / 0, 1, 3, 0, 0/
28301 DATA (ICHTYP(2,K),K=1,5) / 2, 0, 0, 5, 0/
28302 DATA (ICHTYP(3,K),K=1,5) / 4, 0, 0, 7, 0/
28303 DATA (ICHTYP(4,K),K=1,5) / 0, 6, 8, 0, 0/
28304 DATA (ICHTYP(5,K),K=1,5) / 0, 0, 0, 0, 9/
28305 DATA ICHSTA / 21, 22, 31, 32, 41, 42, 51, 52, 61, 62/
28306 DATA CCHTYP / ' q aq','aq q ',' q d ',' d q ','aq ad',
28307 & 'ad aq',' d ad','ad d ',' g g '/
28308*
28309* initialization
28310*
28311 IF (MODE.EQ.-1) THEN
28312 NCHAIN = 0
28313*
28314* loop over DTEVT1 and analyse chain configurations
28315*
28316 ELSEIF (MODE.EQ.0) THEN
28317 DO 21 IDX=NPOINT(3),NHKK
28318 IDCHK = IDHKK(IDX)/10000
28319 IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
28320 & (IDHKK(IDX).NE.80000).AND.
28321 & (ISTHKK(IDX).NE.2).AND.(IDRES(IDX).EQ.0)) THEN
28322 IF (JMOHKK(1,IDX).GT.JMOHKK(2,IDX)) THEN
28323 WRITE(LOUT,*) ' CHASTA: JMOHKK(1,x) > JMOHKK(2,x) ',
28324 & ' at entry ',IDX
28325 GOTO 21
28326 ENDIF
28327*
28328 IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28329 IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28330 IMO1 = IST1/10
28331 IMO1 = IST1-10*IMO1
28332 IMO2 = IST2/10
28333 IMO2 = IST2-10*IMO2
28334* swop parton entries if necessary since we need projectile partons
28335* to come first in the common
28336 IF (IMO1.GT.IMO2) THEN
28337 NPTN = JMOHKK(2,IDX)-JMOHKK(1,IDX)+1
28338 DO 22 K=1,NPTN/2
28339 I0 = JMOHKK(1,IDX)-1+K
28340 I1 = JMOHKK(2,IDX)+1-K
28341 ITMP = ISTHKK(I0)
28342 ISTHKK(I0) = ISTHKK(I1)
28343 ISTHKK(I1) = ITMP
28344 ITMP = IDHKK(I0)
28345 IDHKK(I0) = IDHKK(I1)
28346 IDHKK(I1) = ITMP
28347 IF (JDAHKK(1,JMOHKK(1,I0)).EQ.I0)
28348 & JDAHKK(1,JMOHKK(1,I0)) = I1
28349 IF (JDAHKK(2,JMOHKK(1,I0)).EQ.I0)
28350 & JDAHKK(2,JMOHKK(1,I0)) = I1
28351 IF (JDAHKK(1,JMOHKK(2,I0)).EQ.I0)
28352 & JDAHKK(1,JMOHKK(2,I0)) = I1
28353 IF (JDAHKK(2,JMOHKK(2,I0)).EQ.I0)
28354 & JDAHKK(2,JMOHKK(2,I0)) = I1
28355 IF (JDAHKK(1,JMOHKK(1,I1)).EQ.I1)
28356 & JDAHKK(1,JMOHKK(1,I1)) = I0
28357 IF (JDAHKK(2,JMOHKK(1,I1)).EQ.I1)
28358 & JDAHKK(2,JMOHKK(1,I1)) = I0
28359 IF (JDAHKK(1,JMOHKK(2,I1)).EQ.I1)
28360 & JDAHKK(1,JMOHKK(2,I1)) = I0
28361 IF (JDAHKK(2,JMOHKK(2,I1)).EQ.I1)
28362 & JDAHKK(2,JMOHKK(2,I1)) = I0
28363 ITMP = JMOHKK(1,I0)
28364 JMOHKK(1,I0) = JMOHKK(1,I1)
28365 JMOHKK(1,I1) = ITMP
28366 ITMP = JMOHKK(2,I0)
28367 JMOHKK(2,I0) = JMOHKK(2,I1)
28368 JMOHKK(2,I1) = ITMP
28369 ITMP = JDAHKK(1,I0)
28370 JDAHKK(1,I0) = JDAHKK(1,I1)
28371 JDAHKK(1,I1) = ITMP
28372 ITMP = JDAHKK(2,I0)
28373 JDAHKK(2,I0) = JDAHKK(2,I1)
28374 JDAHKK(2,I1) = ITMP
28375 DO 23 J=1,4
28376 RTMP1 = PHKK(J,I0)
28377 RTMP2 = VHKK(J,I0)
28378 RTMP3 = WHKK(J,I0)
28379 PHKK(J,I0) = PHKK(J,I1)
28380 VHKK(J,I0) = VHKK(J,I1)
28381 WHKK(J,I0) = WHKK(J,I1)
28382 PHKK(J,I1) = RTMP1
28383 VHKK(J,I1) = RTMP2
28384 WHKK(J,I1) = RTMP3
28385 23 CONTINUE
28386 RTMP1 = PHKK(5,I0)
28387 PHKK(5,I0) = PHKK(5,I1)
28388 PHKK(5,I1) = RTMP1
28389 ITMP = IDRES(I0)
28390 IDRES(I0) = IDRES(I1)
28391 IDRES(I1) = ITMP
28392 ITMP = IDXRES(I0)
28393 IDXRES(I0) = IDXRES(I1)
28394 IDXRES(I1) = ITMP
28395 ITMP = NOBAM(I0)
28396 NOBAM(I0) = NOBAM(I1)
28397 NOBAM(I1) = ITMP
28398 ITMP = IDBAM(I0)
28399 IDBAM(I0) = IDBAM(I1)
28400 IDBAM(I1) = ITMP
28401 ITMP = IDCH(I0)
28402 IDCH(I0) = IDCH(I1)
28403 IDCH(I1) = ITMP
28404 ITMP = IHIST(1,I0)
28405 IHIST(1,I0) = IHIST(1,I1)
28406 IHIST(1,I1) = ITMP
28407 ITMP = IHIST(2,I0)
28408 IHIST(2,I0) = IHIST(2,I1)
28409 IHIST(2,I1) = ITMP
28410 22 CONTINUE
28411 ENDIF
28412 IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28413 IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28414*
28415* parton 1 (projectile side)
28416 IF (IST1.EQ.21) THEN
28417 IDX1 = 1
28418 ELSEIF (IST1.EQ.22) THEN
28419 IDX1 = 2
28420 ELSEIF (IST1.EQ.31) THEN
28421 IDX1 = 3
28422 ELSEIF (IST1.EQ.32) THEN
28423 IDX1 = 4
28424 ELSEIF (IST1.EQ.41) THEN
28425 IDX1 = 5
28426 ELSEIF (IST1.EQ.42) THEN
28427 IDX1 = 6
28428 ELSEIF (IST1.EQ.51) THEN
28429 IDX1 = 7
28430 ELSEIF (IST1.EQ.52) THEN
28431 IDX1 = 8
28432 ELSEIF (IST1.EQ.61) THEN
28433 IDX1 = 9
28434 ELSEIF (IST1.EQ.62) THEN
28435 IDX1 = 10
28436 ELSE
28437c WRITE(LOUT,*)
28438c & ' CHASTA: unknown parton status flag (',
28439c & IST1,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28440 GOTO 21
28441 ENDIF
28442 ID = IDHKK(JMOHKK(1,IDX))
28443 IF (ABS(ID).LE.4) THEN
28444 IF (ID.GT.0) THEN
28445 ITYP1 = 1
28446 ELSE
28447 ITYP1 = 2
28448 ENDIF
28449 ELSEIF (ABS(ID).GE.1000) THEN
28450 IF (ID.GT.0) THEN
28451 ITYP1 = 3
28452 ELSE
28453 ITYP1 = 4
28454 ENDIF
28455 ELSEIF (ID.EQ.21) THEN
28456 ITYP1 = 5
28457 ELSE
28458 WRITE(LOUT,*)
28459 & ' CHASTA: inconsistent parton identity (',
28460 & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28461 GOTO 21
28462 ENDIF
28463*
28464* parton 2 (target side)
28465 IF (IST2.EQ.21) THEN
28466 IDX2 = 1
28467 ELSEIF (IST2.EQ.22) THEN
28468 IDX2 = 2
28469 ELSEIF (IST2.EQ.31) THEN
28470 IDX2 = 3
28471 ELSEIF (IST2.EQ.32) THEN
28472 IDX2 = 4
28473 ELSEIF (IST2.EQ.41) THEN
28474 IDX2 = 5
28475 ELSEIF (IST2.EQ.42) THEN
28476 IDX2 = 6
28477 ELSEIF (IST2.EQ.51) THEN
28478 IDX2 = 7
28479 ELSEIF (IST2.EQ.52) THEN
28480 IDX2 = 8
28481 ELSEIF (IST2.EQ.61) THEN
28482 IDX2 = 9
28483 ELSEIF (IST2.EQ.62) THEN
28484 IDX2 = 10
28485 ELSE
28486c WRITE(LOUT,*)
28487c & ' CHASTA: unknown parton status flag (',
28488c & IST2,') at entry ',JMOHKK(2,IDX),'(',IDX,')'
28489 GOTO 21
28490 ENDIF
28491 ID = IDHKK(JMOHKK(2,IDX))
28492 IF (ABS(ID).LE.4) THEN
28493 IF (ID.GT.0) THEN
28494 ITYP2 = 1
28495 ELSE
28496 ITYP2 = 2
28497 ENDIF
28498 ELSEIF (ABS(ID).GE.1000) THEN
28499 IF (ID.GT.0) THEN
28500 ITYP2 = 3
28501 ELSE
28502 ITYP2 = 4
28503 ENDIF
28504 ELSEIF (ID.EQ.21) THEN
28505 ITYP2 = 5
28506 ELSE
28507 WRITE(LOUT,*)
28508 & ' CHASTA: inconsistent parton identity (',
28509 & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28510 GOTO 21
28511 ENDIF
28512*
28513* fill counter
28514 ITYPE = ICHTYP(ITYP1,ITYP2)
28515 IF (ITYPE.NE.0) THEN
28516 ICHCFG(IDX1,IDX2,ITYPE,1) =ICHCFG(IDX1,IDX2,ITYPE,1)+1
28517 NGLUON = JMOHKK(2,IDX)-JMOHKK(1,IDX)-1
28518 ICHCFG(IDX1,IDX2,ITYPE,2) =
28519 & ICHCFG(IDX1,IDX2,ITYPE,2)+NGLUON
28520
28521 NCHAIN = NCHAIN+1
28522 IF (NCHAIN.GT.MAXCHN) THEN
28523 WRITE(LOUT,*) ' CHASTA: NCHAIN > MAXCHN ! ',
28524 & NCHAIN,MAXCHN
28525 STOP
28526 ENDIF
28527 IDXCHN(1,NCHAIN) = IDX
28528 IDXCHN(2,NCHAIN) = ITYPE
28529 ELSE
28530 WRITE(LOUT,*)
28531 & ' CHASTA: inconsistent chain at entry ',IDX
28532 GOTO 21
28533 ENDIF
28534 ENDIF
28535 21 CONTINUE
28536*
28537* write statistics to output unit
28538*
28539 ELSEIF (MODE.EQ.1) THEN
28540 WRITE(LOUT,'(/,A)') ' CHASTA: generated chain configurations'
28541 DO 31 I=1,10
28542 WRITE(LOUT,'(/,2A)')
28543 & ' -----------------------------------------',
28544 & '------------------------------------'
28545 WRITE(LOUT,'(2A)')
28546 & ' p\\t 21 22 31 32 41',
28547 & ' 42 51 52 61 62'
28548 WRITE(LOUT,'(2A)')
28549 & ' -----------------------------------------',
28550 & '------------------------------------'
28551 DO 32 J=1,10
28552 ITOT(J) = 0
28553 DO 33 K=1,9
28554 ITOT(J) = ITOT(J)+ICHCFG(I,J,K,1)
28555 33 CONTINUE
28556 32 CONTINUE
28557 WRITE(LOUT,'(1X,I2,5X,10I7,/)') ICHSTA(I),(ITOT(J),J=1,10)
28558 DO 34 K=1,9
28559 ISUM = 0
28560 DO 35 J=1,10
28561 ISUM = ISUM+ICHCFG(I,J,K,1)
28562 35 CONTINUE
28563 IF (ISUM.GT.0)
28564 & WRITE(LOUT,'(1X,A5,2X,10I7)')
28565 & CCHTYP(K),(ICHCFG(I,J,K,1),J=1,10)
28566 34 CONTINUE
28567C WRITE(LOUT,'(2A)')
28568C & ' -----------------------------------------',
28569C & '-------------------------------'
28570 31 CONTINUE
28571*
28572 ELSE
28573 WRITE(LOUT,*) ' CHASTA: MODE ',MODE,' not supported !'
28574 STOP
28575 ENDIF
28576
28577 RETURN
28578 END
28579*$ CREATE PHO_PHIST.FOR
28580*COPY PHO_PHIST
28581*
28582*===pohist=============================================================*
28583*
28584 SUBROUTINE PHO_PHIST(IMODE,WEIGHT)
28585
28586 IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28587 SAVE
28588
28589 PARAMETER ( LINP = 10 ,
28590 & LOUT = 6 ,
28591 & LDAT = 9 )
28592 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
28593* Glauber formalism: cross sections
28594 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
28595 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
28596 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
28597 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
28598 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
28599 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
28600 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
28601 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
28602 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
28603 & BSLOPE,NEBINI,NQBINI
28604
28605 ILAB = 0
28606 IF (IMODE.EQ.10) THEN
28607 IMODE = 1
28608 ILAB = 1
28609 ENDIF
28610 IF (ABS(IMODE).LT.1000) THEN
28611* PHOJET-statistics
28612C CALL POHISX(IMODE,WEIGHT)
28613 IF (IMODE.EQ.-1) THEN
28614 MODE = 1
28615 XSTOT(1,1,1) = WEIGHT
28616 ENDIF
28617 IF (IMODE.EQ. 1) MODE = 2
28618 IF (IMODE.EQ.-2) MODE = 3
28619 IF (MODE.EQ.2) CALL DT_SWPPHO(ILAB)
28620C IF (MODE.EQ.3) WRITE(LOUT,*)
28621C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization'
28622 CALL DT_HISTOG(MODE)
28623 CALL DT_USRHIS(MODE)
28624 ELSE
28625* DTUNUC-statistics
28626 MODE = IMODE/1000
28627C IF (MODE.EQ.3) WRITE(LOUT,*)
28628C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization'
28629 CALL DT_HISTOG(MODE)
28630 CALL DT_USRHIS(MODE)
28631 ENDIF
28632
28633 RETURN
28634 END
28635
28636*$ CREATE DT_SWPPHO.FOR
28637*COPY DT_SWPPHO
28638*
28639*===swppho=============================================================*
28640*
28641 SUBROUTINE DT_SWPPHO(ILAB)
28642
28643 IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28644 SAVE
28645 PARAMETER ( LINP = 10 ,
28646 & LOUT = 6 ,
28647 & LDAT = 9 )
28648 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28649
28650 LOGICAL LSTART
28651
28652* event history
28653 PARAMETER (NMXHKK=200000)
28654 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28655 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28656 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28657* extended event history
28658 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28659 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28660 & IHIST(2,NMXHKK)
28661* flags for input different options
28662 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28663 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28664 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28665* properties of photon/lepton projectiles
28666 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
28667
28668**PHOJET105a
28669C PARAMETER (NMXHEP=2000)
28670C COMMON/HEPEVS/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28671C &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
28672C COMMON /GLOCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28673C COMMON /PLASAV/ PLAB
28674**PHOJET110
28675C standard particle data interface
28676 INTEGER NMXHEP
28677 PARAMETER (NMXHEP=4000)
28678 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28679 DOUBLE PRECISION PHEP,VHEP
28680 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28681 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
09b429a4 28682 & VHEP(4,NMXHEP),NSD1, NSD2, NDD
9aaba0d6 28683C extension to standard particle data interface (PHOJET specific)
28684 INTEGER IMPART,IPHIST,ICOLOR
28685 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28686C global event kinematics and particle IDs
28687 INTEGER IFPAP,IFPAB
28688 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
28689 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28690**
28691 DATA ICOUNT/0/
28692
28693 DATA LSTART /.TRUE./
28694
28695C IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0).AND.LSTART) THEN
28696 IF ((IFRAME.EQ.1).AND.LSTART) THEN
28697 UMO = ECM
28698 ELA = ZERO
28699 PLA = ZERO
28700 IDP = IDT_ICIHAD(IFPAP(1))
28701 IDT = IDT_ICIHAD(IFPAP(2))
28702 VIRT = PVIRT(1)
28703 CALL DT_LTINI(IDP,IDT,ELA,PLA,UMO,0)
28704 PLAB = PLA
28705 LSTART = .FALSE.
28706 ENDIF
28707
28708 NHKK = 0
28709 ICOUNT = ICOUNT+1
28710C NEVHKK = NEVHEP
28711 NEVHKK = ICOUNT
28712 IF (MOD(ICOUNT,500).EQ.0) WRITE(LOUT,*)' SWPPHO: event # ',ICOUNT
28713 DO 1 I=3,NHEP
28714 IF (ISTHEP(I).EQ.1) THEN
28715 NHKK = NHKK+1
28716 ISTHKK(NHKK) = 1
28717 IDHKK(NHKK) = IDHEP(I)
28718 JMOHKK(1,NHKK) = 0
28719 JMOHKK(2,NHKK) = 0
28720 JDAHKK(1,NHKK) = 0
28721 JDAHKK(2,NHKK) = 0
28722 DO 2 K=1,4
28723 PHKK(K,NHKK) = PHEP(K,I)
28724 VHKK(K,NHKK) = ZERO
28725 WHKK(K,NHKK) = ZERO
28726 2 CONTINUE
28727 IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0))
28728 & CALL DT_LTNUC(PHEP(3,I),PHEP(4,I),
28729 & PHKK(3,NHKK),PHKK(4,NHKK),-3)
28730 PHKK(5,NHKK) = PHEP(5,I)
28731 IDRES(NHKK) = 0
28732 IDXRES(NHKK) = 0
28733 NOBAM(NHKK) = 0
28734 IDBAM(NHKK) = IDT_ICIHAD(IDHEP(I))
28735 IDCH(NHKK) = 0
28736 ENDIF
28737 1 CONTINUE
28738
28739 RETURN
28740 END
28741
28742*$ CREATE DT_HISTOG.FOR
28743*COPY DT_HISTOG
28744*
28745*===histog=============================================================*
28746*
28747 SUBROUTINE DT_HISTOG(MODE)
28748
28749************************************************************************
28750* This version dated 25.03.96 is written by S. Roesler *
28751************************************************************************
28752
28753 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28754 SAVE
28755 PARAMETER ( LINP = 10 ,
28756 & LOUT = 6 ,
28757 & LDAT = 9 )
28758
28759 LOGICAL LFSP,LRNL
28760
28761* event history
28762 PARAMETER (NMXHKK=200000)
28763 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28764 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28765 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28766* extended event history
28767 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28768 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28769 & IHIST(2,NMXHKK)
28770* event flag used for histograms
28771 COMMON /DTNORM/ ICEVT,IEVHKK
28772* flags for activated histograms
28773 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
28774
28775 IEVHKK = NEVHKK
28776 GOTO (1,2,3) MODE
28777
28778*------------------------------------------------------------------
28779* initialization
28780 1 CONTINUE
28781 ICEVT = 0
28782 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,1)
28783 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(1)
28784
28785 RETURN
28786*------------------------------------------------------------------
28787* filling of histogram with event-record
28788 2 CONTINUE
28789 ICEVT = ICEVT+1
28790
28791 DO 20 I=1,NHKK
28792 CALL DT_SWPFSP(I,LFSP,LRNL)
28793 IF (LFSP) THEN
28794 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,2)
28795 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(2)
28796 ENDIF
28797 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,5)
28798 20 CONTINUE
28799 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,4)
28800
28801 RETURN
28802*------------------------------------------------------------------
28803* output
28804 3 CONTINUE
28805 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,3)
28806 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(3)
28807
28808 RETURN
28809 END
28810
28811*$ CREATE DT_SWPFSP.FOR
28812*COPY DT_SWPFSP
28813*
28814*===swpfsp=============================================================*
28815*
28816 SUBROUTINE DT_SWPFSP(IDX,LFSP,LRNL)
28817
28818 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28819 SAVE
28820 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28821 PARAMETER (TWOPI=6.283185307179586476925286766559D+00,
28822 & PI =TWOPI/TWO,
28823 & BOG =TWOPI/360.0D0)
28824
28825* event history
28826 PARAMETER (NMXHKK=200000)
28827 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28828 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28829 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28830* extended event history
28831 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28832 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28833 & IHIST(2,NMXHKK)
28834* particle properties (BAMJET index convention)
28835 CHARACTER*8 ANAME
28836 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28837 & IICH(210),IIBAR(210),K1(210),K2(210)
28838* Lorentz-parameters of the current interaction
28839 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28840 & UMO,PPCM,EPROJ,PPROJ
28841* flags for input different options
28842 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28843 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28844 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28845* (original name: PAREVT)
28846 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
28847 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
28848 PARAMETER ( NALLWP = 39 )
28849 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
28850 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
28851 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
28852 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
28853* temporary storage for one final state particle
28854 LOGICAL LFRAG,LGREY,LBLACK
28855 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
28856 & SINTHE,COSTHE,THETA,THECMS,
28857 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
28858 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
28859 & LFRAG,LGREY,LBLACK
28860
28861 LOGICAL LFSP,LRNL
28862
28863 LFSP = .FALSE.
28864 LRNL = .FALSE.
28865 ISTRNL = 1000
28866 MULDEF = 1
28867 IF (LEVPRT) ISTRNL = 1001
28868
28869 IF (ABS(ISTHKK(IDX)).EQ.1) THEN
28870 IST = ISTHKK(IDX)
28871 IDPDG = IDHKK(IDX)
28872 LFRAG = .FALSE.
28873 IF (IDHKK(IDX).LT.80000) THEN
28874 IDBJT = IDBAM(IDX)
28875 IBARY = IIBAR(IDBJT)
28876 ICHAR = IICH(IDBJT)
28877 AMASS = AAM(IDBJT)
28878 ELSEIF (IDHKK(IDX).EQ.80000) THEN
28879 IDBJT = 0
28880 IBARY = IDRES(IDX)
28881 ICHAR = IDXRES(IDX)
28882 AMASS = PHKK(5,IDX)
28883 INUT = IBARY-ICHAR
28884 IF ((ICHAR.EQ.1).AND.(INUT.EQ.1)) IDBJT = 116
28885 IF ((ICHAR.EQ.1).AND.(INUT.EQ.2)) IDBJT = 117
28886 IF ((ICHAR.EQ.2).AND.(INUT.EQ.1)) IDBJT = 118
28887 IF ((ICHAR.EQ.2).AND.(INUT.EQ.2)) IDBJT = 119
28888 IF (IDBJT.EQ.0) LFRAG = .TRUE.
28889 ELSE
28890 GOTO 9999
28891 ENDIF
28892 PE = PHKK(4,IDX)
28893 PX = PHKK(1,IDX)
28894 PY = PHKK(2,IDX)
28895 PZ = PHKK(3,IDX)
28896 PT2 = PX**2+PY**2
28897 PT = SQRT(PT2)
28898 PTOT = SQRT(PT2+PZ**2)
28899 SINTHE = PT/MAX(PTOT,TINY14)
28900 COSTHE = PZ/MAX(PTOT,TINY14)
28901 IF (COSTHE.GT.ONE) THEN
28902 THETA = ZERO
28903 ELSEIF (COSTHE.LT.-ONE) THEN
28904 THETA = TWOPI/2.0D0
28905 ELSE
28906 THETA = ACOS(COSTHE)
28907 ENDIF
28908 EKIN = PE-AMASS
28909**sr 15.4.96 new E_t-definition
28910 IF (IBARY.GT.0) THEN
28911 ET = EKIN*SINTHE
28912 ELSEIF (IBARY.LT.0) THEN
28913 ET = (EKIN+TWO*AMASS)*SINTHE
28914 ELSE
28915 ET = PE*SINTHE
28916 ENDIF
28917**
28918 XLAB = PZ/MAX(PPROJ,TINY14)
28919C XLAB = PE/MAX(EPROJ,TINY14)
28920 BETA = SQRT(ABS( (ONE-AMASS/MAX(PE,TINY14))
28921 & *(ONE+AMASS/MAX(PE,TINY14)) ))
28922 PPLUS = PE+PZ
28923 PMINUS = PE-PZ
28924 IF (PMINUS.GT.TINY14) THEN
28925 YY = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28926 ELSE
28927 YY = 100.0D0
28928 ENDIF
28929 IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
28930 ETA = -LOG(TAN(THETA/TWO))
28931 ELSE
28932 ETA = 100.0D0
28933 ENDIF
28934 IF (IFRAME.EQ.1) THEN
28935 CALL DT_LTNUC(PZ,PE,PZCMS,EECMS,3)
28936 PPLUS = EECMS+PZCMS
28937 PMINUS = EECMS-PZCMS
28938 IF ((PPLUS*PMINUS).GT.TINY14) THEN
28939 YYCMS = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28940 ELSE
28941 YYCMS = 100.0D0
28942 ENDIF
28943 PTOTCM = SQRT(PT2+PZCMS**2)
28944 COSTH = PZCMS/MAX(PTOTCM,TINY14)
28945 IF (COSTH.GT.ONE) THEN
28946 THECMS = ZERO
28947 ELSEIF (COSTH.LT.-ONE) THEN
28948 THECMS = TWOPI/2.0D0
28949 ELSE
28950 THECMS = ACOS(COSTH)
28951 ENDIF
28952 IF ((THECMS.GT.TINY14).AND.((PI-THECMS).GT.TINY14)) THEN
28953 ETACMS = -LOG(TAN(THECMS/TWO))
28954 ELSE
28955 ETACMS = 100.0D0
28956 ENDIF
28957 XF = PZCMS/MAX(PPCM,TINY14)
28958 THECMS = THECMS/BOG
28959 ELSE
28960 PZCMS = PZ
28961 EECMS = PE
28962 YYCMS = YY
28963 ETACMS = ETA
28964 XF = XLAB
28965 THECMS = THETA/BOG
28966 ENDIF
28967 THETA = THETA/BOG
28968
28969* set flag for "grey/black"
28970 LGREY = .FALSE.
28971 LBLACK = .FALSE.
28972 EK = EKIN
28973 IF (IDHKK(IDX).EQ.80000) EK = EKIN/DBLE(IBARY)
28974 IF (MULDEF.EQ.1) THEN
28975* EMU01-Def.
28976 IF ( ( (IDBJT.EQ. 1).AND.(EK.GT. 26.0D-3).AND.
28977 & (EK.LE.375.0D-3) ).OR.
28978 & ( (IDBJT.EQ.13).AND.(EK.GT. 12.0D-3).AND.
28979 & (EK.LE. 56.0D-3) ).OR.
28980 & ( (IDBJT.EQ.14).AND.(EK.GT. 12.0D-3).AND.
28981 & (EK.LE. 56.0D-3) ).OR.
28982 & ( (IDBJT.EQ.15).AND.(EK.GT. 20.0D-3).AND.
28983 & (EK.LE.198.0D-3) ).OR.
28984 & ( (IDBJT.EQ.16).AND.(EK.GT. 20.0D-3).AND.
28985 & (EK.LE.198.0D-3) ).OR.
28986 & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28987 & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28988 & (IDBJT.NE.16).AND.
28989 & (BETA.GT.0.23D0).AND.(BETA.LE.0.70D0) ) )
28990 & LGREY = .TRUE.
28991 IF ( ( (IDBJT.EQ. 1).AND.(EK.LE. 26.0D-3) ).OR.
28992 & ( (IDBJT.EQ.13).AND.(EK.LE. 12.0D-3) ).OR.
28993 & ( (IDBJT.EQ.14).AND.(EK.LE. 12.0D-3) ).OR.
28994 & ( (IDBJT.EQ.15).AND.(EK.LE. 20.0D-3) ).OR.
28995 & ( (IDBJT.EQ.16).AND.(EK.LE. 20.0D-3) ).OR.
28996 & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28997 & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28998 & (IDBJT.NE.16).AND.(BETA.LE.0.23D0) ) )
28999 & LBLACK = .TRUE.
29000 ELSE
29001* common Def.
29002 IF ((BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)) LGREY=.TRUE.
29003 IF (BETA.LE.0.23D0) LBLACK=.TRUE.
29004 ENDIF
29005 LFSP = .TRUE.
29006 ELSEIF (ABS(ISTHKK(IDX)).EQ.ISTRNL) THEN
29007 IST = ISTHKK(IDX)
29008 IDPDG = IDHKK(IDX)
29009 LFRAG = .TRUE.
29010 IDBJT = 0
29011 IBARY = IDRES(IDX)
29012 ICHAR = IDXRES(IDX)
29013 AMASS = PHKK(5,IDX)
29014 PE = PHKK(4,IDX)
29015 PX = PHKK(1,IDX)
29016 PY = PHKK(2,IDX)
29017 PZ = PHKK(3,IDX)
29018 PT2 = PX**2+PY**2
29019 PT = SQRT(PT2)
29020 PTOT = SQRT(PT2+PZ**2)
29021 SINTHE = PT/MAX(PTOT,TINY14)
29022 COSTHE = PZ/MAX(PTOT,TINY14)
29023 IF (COSTHE.GT.ONE) THEN
29024 THETA = ZERO
29025 ELSEIF (COSTHE.LT.-ONE) THEN
29026 THETA = TWOPI/2.0D0
29027 ELSE
29028 THETA = ACOS(COSTHE)
29029 ENDIF
29030 EKIN = PE-AMASS
29031**sr 15.4.96 new E_t-definition
29032C ET = PE*SINTHE
29033 ET = EKIN*SINTHE
29034**
29035 IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
29036 ETA = -LOG(TAN(THETA/TWO))
29037 ELSE
29038 ETA = 100.0D0
29039 ENDIF
29040 THETA = THETA/BOG
29041 LRNL = .TRUE.
29042 ENDIF
29043
29044 9999 CONTINUE
29045 RETURN
29046 END
29047
29048*$ CREATE DT_HIMULT.FOR
29049*COPY DT_HIMULT
29050*
29051*===himult=============================================================*
29052*
29053 SUBROUTINE DT_HIMULT(MODE)
29054
29055************************************************************************
29056* Tables of average energies/multiplicities. *
29057* This version dated 30.08.2000 is written by S. Roesler *
29058************************************************************************
29059
29060 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29061 SAVE
29062 PARAMETER ( LINP = 10 ,
29063 & LOUT = 6 ,
29064 & LDAT = 9 )
29065 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
29066
29067 PARAMETER (SWMEXP=1.7D0)
29068
29069 CHARACTER*8 ANAMEH(4)
29070
29071* particle properties (BAMJET index convention)
29072 CHARACTER*8 ANAME
29073 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29074 & IICH(210),IIBAR(210),K1(210),K2(210)
29075* temporary storage for one final state particle
29076 LOGICAL LFRAG,LGREY,LBLACK
29077 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
29078 & SINTHE,COSTHE,THETA,THECMS,
29079 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
29080 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
29081 & LFRAG,LGREY,LBLACK
29082* event flag used for histograms
29083 COMMON /DTNORM/ ICEVT,IEVHKK
29084* Lorentz-parameters of the current interaction
29085 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
29086 & UMO,PPCM,EPROJ,PPROJ
29087
29088 PARAMETER (NOPART=210)
29089 DIMENSION AVMULT(4,NOPART),AVE(4,NOPART),AVSWM(4,NOPART),
29090 & AVPT(4,NOPART),IAVPT(4,NOPART)
29091 DATA ANAMEH /'DEUTERON','3-H ','3-HE ','4-HE '/
29092
29093 GOTO (1,2,3) MODE
29094
29095*------------------------------------------------------------------
29096* initialization
29097 1 CONTINUE
29098 DO 10 I=1,NOPART
29099 DO 11 J=1,4
29100 AVMULT(J,I) = ZERO
29101 AVE(J,I) = ZERO
29102 AVSWM(J,I) = ZERO
29103 AVPT(J,I) = ZERO
29104 IAVPT(J,I) = 0
29105 11 CONTINUE
29106 10 CONTINUE
29107
29108 RETURN
29109
29110*------------------------------------------------------------------
29111* filling of histogram with event-record
29112 2 CONTINUE
29113 IF (PE.LT.0.0D0) THEN
29114 WRITE(LOUT,*) ' HIMULT: PE < 0 ! ',PE
29115 RETURN
29116 ENDIF
29117 IF (.NOT.LFRAG) THEN
29118 IVEL = 2
29119 IF (LGREY) IVEL = 3
29120 IF (LBLACK) IVEL = 4
29121 AVE(1,IDBJT) = AVE(1,IDBJT) +PE
29122 AVE(IVEL,IDBJT) = AVE(IVEL,IDBJT)+PE
29123 AVPT(1,IDBJT) = AVPT(1,IDBJT) +PT
29124 AVPT(IVEL,IDBJT) = AVPT(IVEL,IDBJT)+PT
29125 IAVPT(1,IDBJT) = IAVPT(1,IDBJT) +1
29126 IAVPT(IVEL,IDBJT) = IAVPT(IVEL,IDBJT)+1
29127 AVSWM(1,IDBJT) = AVSWM(1,IDBJT) +PE**SWMEXP
29128 AVSWM(IVEL,IDBJT) = AVSWM(IVEL,IDBJT)+PE**SWMEXP
29129 AVMULT(1,IDBJT) = AVMULT(1,IDBJT) +ONE
29130 AVMULT(IVEL,IDBJT) = AVMULT(IVEL,IDBJT)+ONE
29131 IF (IDBJT.LT.116) THEN
29132* total energy, multiplicity
29133 AVE(1,30) = AVE(1,30) +PE
29134 AVE(IVEL,30) = AVE(IVEL,30)+PE
29135 AVPT(1,30) = AVPT(1,30) +PT
29136 AVPT(IVEL,30) = AVPT(IVEL,30)+PT
29137 IAVPT(1,30) = IAVPT(1,30) +1
29138 IAVPT(IVEL,30) = IAVPT(IVEL,30)+1
29139 AVSWM(1,30) = AVSWM(1,30)+PE**SWMEXP
29140 AVSWM(IVEL,30) = AVSWM(IVEL,30)+PE**SWMEXP
29141 AVMULT(1,30) = AVMULT(1,30) +ONE
29142 AVMULT(IVEL,30) = AVMULT(IVEL,30)+ONE
29143* charged energy, multiplicity
29144 IF (ICHAR.LT.0) THEN
29145 AVE(1,26) = AVE(1,26) +PE
29146 AVE(IVEL,26) = AVE(IVEL,26)+PE
29147 AVPT(1,26) = AVPT(1,26) +PT
29148 AVPT(IVEL,26) = AVPT(IVEL,26)+PT
29149 IAVPT(1,26) = IAVPT(1,26) +1
29150 IAVPT(IVEL,26) = IAVPT(IVEL,26)+1
29151 AVSWM(1,26) = AVSWM(1,26) +PE**SWMEXP
29152 AVSWM(IVEL,26) = AVSWM(IVEL,26)+PE**SWMEXP
29153 AVMULT(1,26) = AVMULT(1,26) +ONE
29154 AVMULT(IVEL,26) = AVMULT(IVEL,26)+ONE
29155 ENDIF
29156 IF (ICHAR.NE.0) THEN
29157 AVE(1,27) = AVE(1,27) +PE
29158 AVE(IVEL,27) = AVE(IVEL,27)+PE
29159 AVPT(1,27) = AVPT(1,27) +PT
29160 AVPT(IVEL,27) = AVPT(IVEL,27)+PT
29161 IAVPT(1,27) = IAVPT(1,27) +1
29162 IAVPT(IVEL,27) = IAVPT(IVEL,27)+1
29163 AVSWM(1,27) = AVSWM(1,27) +PE**SWMEXP
29164 AVSWM(IVEL,27) = AVSWM(IVEL,27)+PE**SWMEXP
29165 AVMULT(1,27) = AVMULT(1,27) +ONE
29166 AVMULT(IVEL,27) = AVMULT(IVEL,27)+ONE
29167 ENDIF
29168 ENDIF
29169 ENDIF
29170
29171 RETURN
29172
29173*------------------------------------------------------------------
29174* output
29175 3 CONTINUE
29176 WRITE(LOUT,3000)
29177 3000 FORMAT(/,1X,'HIMULT:',21X,'particle - statistics',/,
29178 & 29X,'---------------------',/)
29179 IF (MULDEF.EQ.1) THEN
29180 WRITE(LOUT,'(1X,A,/)') 'fast/grey/black: EMU-def.'
29181 ELSE
29182 BETGRE = 0.7D0
29183 BETBLC = 0.23D0
29184 WRITE(LOUT,3002) BETGRE,BETGRE,BETBLC,BETBLC
29185 3002 FORMAT(1X,'fast: beta > ',F4.2,' grey: ',F4.2,' > beta > '
29186 & ,F4.2,' black: beta < ',F4.2,/)
29187 ENDIF
29188 WRITE(LOUT,3003) SWMEXP
29189 3003 FORMAT(1X,'particle |',12X,'average multiplicity',/,
29190 & 13X,'| total fast',
29191C & ' grey black K f(',F3.1,')',/,1X,
29192 & ' grey black <pt> f(',F3.1,')',/,1X,
29193 & '------------+--------------',
29194 & '-------------------------------------------------')
29195 DO 30 I=1,NOPART
29196 DO 31 J=1,4
29197 AVMULT(J,I) = AVMULT(J,I)/DBLE(MAX(ICEVT,1))
29198 AVE(J,I) = AVE(J,I)/DBLE(MAX(ICEVT,1))/EPROJ
29199 AVPT(J,I) = AVPT(J,I)/DBLE(MAX(IAVPT(J,I),1))
29200 AVSWM(J,I) = AVSWM(J,I)/DBLE(MAX(ICEVT,1))/EPROJ**SWMEXP
29201 31 CONTINUE
29202 IF (I.LE.115) THEN
29203 WRITE(LOUT,3004) ANAME(I),I,
29204 & AVMULT(1,I),AVMULT(2,I),
29205 & AVMULT(3,I),AVMULT(4,I),
29206C & AVE(1,I),AVSWM(1,I)
29207 & AVPT(1,I),AVSWM(1,I)
29208 ELSEIF (I.LE.119) THEN
29209 WRITE(LOUT,3004) ANAMEH(I-115),I,
29210 & AVMULT(1,I),AVMULT(2,I),
29211 & AVMULT(3,I),AVMULT(4,I),
29212C & AVE(1,I),AVSWM(1,I)
29213 & AVPT(1,I),AVSWM(1,I)
29214 ENDIF
29215 3004 FORMAT(1X,A8,I4,'| ',2F13.6,2F9.5,2F9.5)
29216 30 CONTINUE
29217**temporary
29218C WRITE(LOUT,'(A,F7.3)') ' number of charged heavy particles: ',
29219C & AVMULT(3,27)+AVMULT(4,27)
29220**
29221
29222 RETURN
29223 END
29224
29225*$ CREATE DT_HISTAT.FOR
29226*COPY DT_HISTAT
29227*
29228*===histat=============================================================*
29229*
29230 SUBROUTINE DT_HISTAT(IDX,MODE)
29231
29232************************************************************************
29233* This version dated 26.02.96 is written by S. Roesler *
29234* *
29235* Last change 27.12.2006 by S. Roesler. *
29236************************************************************************
29237
29238 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29239 SAVE
29240 PARAMETER ( LINP = 10 ,
29241 & LOUT = 6 ,
29242 & LDAT = 9 )
29243 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
29244 PARAMETER (NDIM=199)
29245
29246* event history
29247 PARAMETER (NMXHKK=200000)
29248 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
29249 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
29250 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
29251* extended event history
29252 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
29253 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
29254 & IHIST(2,NMXHKK)
29255* particle properties (BAMJET index convention)
29256 CHARACTER*8 ANAME
29257 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29258 & IICH(210),IIBAR(210),K1(210),K2(210)
29259 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
29260* Glauber formalism: cross sections
29261 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
29262 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
29263 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
29264 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
29265 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
29266 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
29267 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
29268 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
29269 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
29270 & BSLOPE,NEBINI,NQBINI
29271* emulsion treatment
29272 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
29273 & NCOMPO,IEMUL
29274* properties of interacting particles
29275 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
29276* rejection counter
29277 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
29278 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
29279 & IREXCI(3),IRDIFF(2),IRINC
29280* statistics: residual nuclei
29281 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
29282 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
29283 & NINCST(2,4),NINCEV(2),
29284 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
29285 & NRESPB(2),NRESCH(2),NRESEV(4),
29286 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
29287 & NEVAFI(2,2)
29288* parameter for intranuclear cascade
29289 LOGICAL LPAULI
29290 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
29291* (original name: PAREVT)
29292 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
29293 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
29294 PARAMETER ( NALLWP = 39 )
29295 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
29296 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
29297 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
29298 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
29299* (original name: FRBKCM)
29300 PARAMETER ( MXFFBK = 6 )
29301 PARAMETER ( MXZFBK = 9 )
29302 PARAMETER ( MXNFBK = 10 )
29303 PARAMETER ( MXAFBK = 16 )
29304 PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
29305 PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
29306 PARAMETER ( NXAFBK = MXAFBK + 1 )
29307 PARAMETER ( MXPSST = 300 )
29308 PARAMETER ( MXPSFB = 41000 )
29309 LOGICAL LFRMBK, LNCMSS
29310 COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
29311 & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
29312 & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
29313 & IFRBKN (MXPSST), IFRBKZ (MXPSST),
29314 & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
29315 & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
29316 & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
29317 & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
29318 & IFBFRB, NBUFBK, LFRMBK, LNCMSS
29319* (original name: INPFLG)
29320 COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
29321* temporary storage for one final state particle
29322 LOGICAL LFRAG,LGREY,LBLACK
29323 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
29324 & SINTHE,COSTHE,THETA,THECMS,
29325 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
29326 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
29327 & LFRAG,LGREY,LBLACK
29328* event flag used for histograms
29329 COMMON /DTNORM/ ICEVT,IEVHKK
29330* statistics: double-Pomeron exchange
29331 COMMON /DTFLG2/ INTFLG,IPOPO
29332
29333 DIMENSION EMUSAM(NCOMPX)
29334
29335 CHARACTER*13 CMSG(3)
29336 DATA CMSG /'not requested','not requested','not requested'/
29337
29338 GOTO (1,2,3,4,5) MODE
29339
29340*------------------------------------------------------------------
29341* initialization
29342 1 CONTINUE
29343* emulsion treatment
29344 IF (NCOMPO.GT.0) THEN
29345 DO 10 I=1,NCOMPX
29346 EMUSAM(I) = ZERO
29347 10 CONTINUE
29348 ENDIF
29349* common /DTSTA2/, statistics on i.n.c., residual nuclei, evap.
29350 NINCGE = 0
29351 DO 11 I=1,2
29352 EXCDPM(I) = ZERO
29353 EXCDPM(I+2) = ZERO
29354 EXCEVA(I) = ZERO
29355 NINCWO(I) = 0
29356 NINCEV(I) = 0
29357 NRESTO(I) = 0
29358 NRESPR(I) = 0
29359 NRESNU(I) = 0
29360 NRESBA(I) = 0
29361 NRESPB(I) = 0
29362 NRESCH(I) = 0
29363 NRESEV(I) = 0
29364 NRESEV(I+2) = 0
29365 NEVAGA(I) = 0
29366 NEVAHT(I) = 0
29367 NEVAFI(1,I) = 0
29368 NEVAFI(2,I) = 0
29369 DO 12 J=1,6
29370 IF (J.LE.2) NINCHR(I,J) = 0
29371 IF (J.LE.3) NINCCO(I,J) = 0
29372 IF (J.LE.4) NINCST(I,J) = 0
29373 NEVA(I,J) = 0
29374 12 CONTINUE
29375 DO 13 J=1,210
29376 NEVAHY(1,I,J) = 0
29377 NEVAHY(2,I,J) = 0
29378 13 CONTINUE
29379 11 CONTINUE
29380 MAXGEN = 0
29381**dble Po statistics.
29382 KPOPO = 0
29383
29384 RETURN
29385*------------------------------------------------------------------
29386* filling of histogram with event-record
29387 2 CONTINUE
29388 IF (IST.EQ.-1) THEN
29389 IF (.NOT.LFRAG) THEN
29390 IF (IDPDG.EQ.2212) THEN
29391 NEVA(NOBAM(IDX),1) = NEVA(NOBAM(IDX),1)+1
29392 ELSEIF (IDPDG.EQ.2112) THEN
29393 NEVA(NOBAM(IDX),2) = NEVA(NOBAM(IDX),2)+1
29394 ELSEIF (IDPDG.EQ.22) THEN
29395 NEVAGA(NOBAM(IDX)) = NEVAGA(NOBAM(IDX))+1
29396 ELSEIF (IDPDG.EQ.80000) THEN
29397 IF (IDBJT.EQ.116) THEN
29398 NEVA(NOBAM(IDX),3) = NEVA(NOBAM(IDX),3)+1
29399 ELSEIF (IDBJT.EQ.117) THEN
29400 NEVA(NOBAM(IDX),4) = NEVA(NOBAM(IDX),4)+1
29401 ELSEIF (IDBJT.EQ.118) THEN
29402 NEVA(NOBAM(IDX),5) = NEVA(NOBAM(IDX),5)+1
29403 ELSEIF (IDBJT.EQ.119) THEN
29404 NEVA(NOBAM(IDX),6) = NEVA(NOBAM(IDX),6)+1
29405 ENDIF
29406 ENDIF
29407 ELSE
29408* heavy fragments (here: fission products only)
29409 NEVAHY(NOBAM(IDX),1,IBARY) = NEVAHY(NOBAM(IDX),1,IBARY)+1
29410 NEVAHY(NOBAM(IDX),2,ICHAR) = NEVAHY(NOBAM(IDX),2,ICHAR)+1
29411 NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29412 ENDIF
29413 ELSEIF ((IST.EQ.1).AND.(.NOT.LFRAG)) THEN
29414 IF (IDCH(IDX).GT.MAXGEN) MAXGEN = IDCH(IDX)
29415 ENDIF
29416
29417 RETURN
29418*------------------------------------------------------------------
29419* output
29420 3 CONTINUE
29421
29422**dble Po statistics.
29423C WRITE(LOUT,'(1X,A,2I7,2E12.4)')
29424C & '# evts. / # dble-Po. evts / s_in / s_popo :',
29425C & ICEVT,KPOPO,XSPRO(1,1,1),XSPRO(1,1,1)*DBLE(KPOPO)/DBLE(ICEVT)
29426
29427* emulsion treatment
29428 IF (NCOMPO.GT.0) THEN
29429 WRITE(LOUT,3000)
29430 3000 FORMAT(/,1X,'HISTAT:',14X,'statistics - target emulsion',/,
29431 & 22X,'----------------------------',/,/,19X,
29432 & 'mass charge fraction',/,39X,
29433 & 'input treated',/)
29434 DO 30 I=1,NCOMPO
29435 WRITE(LOUT,3013) I,IEMUMA(I),IEMUCH(I),EMUFRA(I),
29436 & EMUSAM(I)/DBLE(ICEVT)
29437 3013 FORMAT(12X,I2,1X,2I8,6X,F7.3,5X,F7.3)
29438 30 CONTINUE
29439 ENDIF
29440
29441* i.n.c. statistics: output
29442 WRITE(LOUT,3001) ICEVT,NRESEV(2),IRINC
29443 3001 FORMAT(/,1X,'HISTAT:',14X,'statistics - intranuclear cascade',/,
29444 & 22X,'---------------------------------',/,/,1X,
29445 & 'no. of events for normalization: (accepted final events,',
29446 & ' evt)',4X,I6,/,34X,'(events before evap.-step, evt1)',I6,
29447 & /,1X,'no. of rejected events due to intranuclear',
29448 & ' cascade',15X,I6,/)
29449 ICEV = MAX(ICEVT,1)
29450 ICEV1 = ICEV
29451 IF (LEVPRT) ICEV1 = MAX(NRESEV(2),1)
29452 WRITE(LOUT,3002)
29453 & (DBLE(NINCWO(I))/DBLE(ICEV),I=1,2),
29454 & ((DBLE(NINCST(I,J))/DBLE(ICEV),I=1,2),J=1,4),
29455 & KTAUGE,DBLE(NINCGE)/DBLE(ICEV),
29456 & (DBLE(NINCCO(I,1)+NINCCO(I,2)+NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29457 & (DBLE(NINCCO(I,2))/DBLE(ICEV1),I=1,2),
29458 & (DBLE(NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29459 & (DBLE(NINCCO(I,1))/DBLE(ICEV1),I=1,2)
29460 3002 FORMAT(1X,'no. of wounded nucl. in proj./ target (mean per evt)',
29461 & 5X,F6.2,' /',F6.2,/,1X,'no. of particles unable to escape',
29462 & ' proj./ target (mean per evt)',/,8X,'baryons: pos. ',
29463 & F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3,/,8X,
29464 & 'mesons: pos. ',F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3,
29465 & /,1X,'maximum no. of generations treated (maximum allowed:'
29466 & ,I4,')',/,43X,'(mean per evt)',5X,F6.2,/,1X,'no. of sec.',
29467 & ' interactions in proj./ target (mean per evt1)',
29468 & F7.3,' /',F7.3,/,8X,'out of which by inelastic',
29469 & ' interactions',12X,F7.3,' /',F7.3,/,21X,'by elastic ',
29470 & 'interactions',14X,F7.3,' /',F7.3,/,21X,'by absorption ',
29471 & '(ap, K-, pi- only) ',F7.3,' /',F7.3,/)
29472 WRITE(LOUT,3003) NRESEV(2),NRESEV(4),IREXCI,
29473 & IREXCI(1)+IREXCI(2)+IREXCI(3)
29474 3003 FORMAT(/,1X,'HISTAT:',14X,'statistics - residual nuclei, ',
29475 & 'evaporation',/,22X,'-----------------------------',
29476 & '------------',/,/,1X,'no. of events for normal.: ',
29477 & '(events handled by FICONF, evt)',7X,I6,/,28X,'(events',
29478 & ' passing the evap.-step, evt1) ',I6,/,1X,'no. of',
29479 & ' rejected events (',I4,',',I4,',',I4,')',22X,I6,/)
29480
29481 WRITE(LOUT,3004)
29482 3004 FORMAT(/,22X,'1) before evaporation-step:',/)
29483 ICEV = MAX(NRESEV(2),1)
29484 WRITE(LOUT,3005)
29485 & (DBLE(NRESTO(I))/DBLE(ICEV),I=1,2),
29486 & (DBLE(NRESPR(I))/DBLE(ICEV),I=1,2),
29487 & (DBLE(NRESNU(I))/DBLE(ICEV),I=1,2),
29488 & (DBLE(NRESBA(I))/DBLE(ICEV),I=1,2),
29489 & (DBLE(NRESPB(I))/DBLE(ICEV),I=1,2),
29490 & (DBLE(NRESCH(I))/DBLE(ICEV),I=1,2),
29491 & (EXCDPM(I)/DBLE(ICEV),I=1,2),
29492 & (EXCDPM(I+2)/DBLE(ICEV),I=1,2)
29493 3005 FORMAT(1X,'residual nuclei: (mean values per evt)',12X,
29494 & 'proj. / target',/,/,8X,'total number of particles',15X,
29495 & 2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29496 & 'neutrons',18X,2F9.3,/,22X,'baryons',19X,2F9.3,/,22X,
29497 & 'pos. baryons',14X,2F9.3,/,8X,'total charge',28X,2F9.3,/,
29498 & /,8X,'excitation energy (bef. evap.-step) ',2E11.3,/,
29499 & 8X,'excitation energy per nucleon ',2E11.3,/,/)
29500
29501* evaporation / fission / fragmentation statistics: output
29502 ICEV = MAX(NRESEV(2),1)
29503 ICEV1 = MAX(NRESEV(4),1)
29504 NTEVA1 =
29505 & NEVA(1,1)+NEVA(1,2)+NEVA(1,3)+NEVA(1,4)+NEVA(1,5)+NEVA(1,6)
29506 NTEVA2 =
29507 & NEVA(2,1)+NEVA(2,2)+NEVA(2,3)+NEVA(2,4)+NEVA(2,5)+NEVA(2,6)
29508 IF (LEVPRT) THEN
29509 IF (IFISS.EQ.1) CMSG(1) = 'requested '
29510 IF (LFRMBK) CMSG(2) = 'requested '
29511 IF (LDEEXG) CMSG(3) = 'requested '
29512 WRITE(LOUT,3006)
29513 & CMSG,
29514 & DBLE(NTEVA1)/DBLE(ICEV1),DBLE(NTEVA2)/DBLE(ICEV1),
29515 & (DBLE(NEVA(I,1))/DBLE(ICEV1),I=1,2),
29516 & (DBLE(NEVA(I,2))/DBLE(ICEV1),I=1,2),
29517 & (DBLE(NEVA(I,3))/DBLE(ICEV1),I=1,2),
29518 & (DBLE(NEVA(I,4))/DBLE(ICEV1),I=1,2),
29519 & (DBLE(NEVA(I,5))/DBLE(ICEV1),I=1,2),
29520 & (DBLE(NEVA(I,6))/DBLE(ICEV1),I=1,2),
29521 & (DBLE(NEVAGA(I))/DBLE(ICEV1),I=1,2),
29522 & (DBLE(NEVAHT(I))/DBLE(ICEV1),I=1,2)
29523 3006 FORMAT(22X,'2) after evaporation-step:',/,/,1X,'Fission:',
29524 & 13X,A13,/,1X,'Fermi-Break-up:',6X,A13,/,1X,'Gamma-',
29525 & 'deexcitation:',2X,A13,/,/,
29526 & 1X,'evaporation/deexcitation: (mean values per evt1) ',
29527 & 'proj. / target',/,/,8X,'total number of evap. particles',
29528 & 9X,2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29529 & 'neutrons',18X,2F9.3,/,22X,'deuterons',17X,2F9.3,/,22X,
29530 & '3-H',23X,2F9.3,/,22X,'3-He',22X,2F9.3,/,22X,'4-He',22X,
29531 & 2F9.3,/,8X,'nucl. deexcit. gammas',19X,2F9.3,/,8X,
29532 & 'heavy fragments',25X,2F9.3,/)
29533 IF (IFISS.EQ.1) THEN
29534 WRITE(LOUT,3007) NEVAFI(1,1),NEVAFI(1,2),
29535 & NEVAFI(2,1),NEVAFI(2,2),
29536 & DBLE(NEVAFI(2,1))/DBLE(MAX(NEVAFI(1,1),1))*100.0D0,
29537 & DBLE(NEVAFI(2,2))/DBLE(MAX(NEVAFI(1,2),1))*100.0D0
29538 3007 FORMAT(1X,'Fission: total number of events',14X,2I9,/
29539 & 12X,'out of which fission occured',8X,2I9,/,
29540 & 50X,'(',F5.2,'%) (',F5.2,'%)',/)
29541 ENDIF
29542C IF ((LFRMBK).OR.(IFISS.EQ.1)) THEN
29543C WRITE(LOUT,3008)
29544C3008 FORMAT(1X,'heavy fragments - statistics:',7X,'charge',
29545C & ' proj. / target',/)
29546C DO 31 I=1,210
29547C IF ((NEVAHY(1,2,I).NE.0).OR.(NEVAHY(2,2,I).NE.0)) THEN
29548C WRITE(LOUT,3009) I,
29549C & (DBLE(NEVAHY(K,2,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29550C3009 FORMAT(38X,I3,3X,2E12.3)
29551C ENDIF
29552C 31 CONTINUE
29553C WRITE(LOUT,3010)
29554C3010 FORMAT(1X,'heavy fragments - statistics:',7X,'mass ',
29555C & ' proj. / target',/)
29556C DO 32 I=1,210
29557C IF ((NEVAHY(1,1,I).NE.0).OR.(NEVAHY(2,1,I).NE.0)) THEN
29558C WRITE(LOUT,3011) I,
29559C & (DBLE(NEVAHY(K,1,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29560C3011 FORMAT(38X,I3,3X,2E12.3)
29561C ENDIF
29562C 32 CONTINUE
29563C WRITE(LOUT,*)
29564C ENDIF
29565 ELSE
29566 WRITE(LOUT,3012)
29567 3012 FORMAT(22X,'2) after evaporation-step:',/,/,1X,
29568 & 'Evaporation: not requested',/)
29569 ENDIF
29570
29571 RETURN
29572*------------------------------------------------------------------
29573* filling of histogram with event-record
29574 4 CONTINUE
29575* emulsion treatment
29576 IF (NCOMPO.GT.0) THEN
29577 DO 40 I=1,NCOMPO
29578 IF (IT.EQ.IEMUMA(I)) THEN
29579 EMUSAM(I) = EMUSAM(I)+ONE
29580 ENDIF
29581 40 CONTINUE
29582 ENDIF
29583 NINCGE = NINCGE+MAXGEN
29584 MAXGEN = 0
29585**dble Po statistics.
29586 IF (IPOPO.EQ.1) KPOPO = KPOPO+1
29587
29588 RETURN
29589*------------------------------------------------------------------
29590* filling of histogram with event-record
29591 5 CONTINUE
29592 IF ((ISTHKK(IDX).EQ.15).OR.(ISTHKK(IDX).EQ.16)) THEN
29593 IB = IIBAR(IDBAM(IDX))
29594 IC = IICH(IDBAM(IDX))
29595 J = ISTHKK(IDX)-14
29596 IF ( ((ABS(IB).EQ.1).AND.(IC.EQ.1)).OR.(IC.EQ.0) ) THEN
29597 NINCST(J,1) = NINCST(J,1)+1
29598 ELSEIF ((ABS(IB).EQ.1).AND.(IC.EQ.-1)) THEN
29599 NINCST(J,2) = NINCST(J,2)+1
29600 ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ. 1)) THEN
29601 NINCST(J,3) = NINCST(J,3)+1
29602 ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ.-1)) THEN
29603 NINCST(J,4) = NINCST(J,4)+1
29604 ENDIF
29605 ELSEIF (ISTHKK(IDX).EQ.17) THEN
29606 NINCWO(1) = NINCWO(1)+1
29607 ELSEIF (ISTHKK(IDX).EQ.18) THEN
29608 NINCWO(2) = NINCWO(2)+1
29609 ELSEIF (ISTHKK(IDX).EQ.1001) THEN
29610 IB = IDRES(IDX)
29611 IC = IDXRES(IDX)
29612 IF (IC.GT.0) THEN
29613 NEVAHY(NOBAM(IDX),1,IB) = NEVAHY(NOBAM(IDX),1,IB)+1
29614 NEVAHY(NOBAM(IDX),2,IC) = NEVAHY(NOBAM(IDX),2,IC)+1
29615 ENDIF
29616 NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29617 ENDIF
29618
29619 RETURN
29620 END
29621
29622*$ CREATE DT_NEWHGR.FOR
29623*COPY DT_NEWHGR
29624*
29625*===newhgr=============================================================*
29626*
29627 SUBROUTINE DT_NEWHGR(XLIM1,XLIM2,XLIM3,XLIMB,IBIN,IREFN)
29628
29629************************************************************************
29630* *
29631* Histogram initialization. *
29632* *
29633* input: XLIM1/XLIM2 lower/upper edge of histogram-window *
29634* XLIM3 bin size *
29635* IBIN > 0 number of bins in equidistant lin. binning *
29636* = -1 reset histograms *
29637* < -1 |IBIN| number of bins in equidistant log. *
29638* binning or log. binning in user def. struc. *
29639* XLIMB(*) user defined bin structure *
29640* *
29641* The bin structure is sensitive to *
29642* XLIM1, XLIM3, IBIN if XLIM3 > 0 (lin.) *
29643* XLIM1, XLIM2, IBIN if XLIM3 = 0 (lin. & log.) *
29644* XLIMB, IBIN if XLIM3 < 0 *
29645* *
29646* *
29647* output: IREFN histogram index *
29648* (= -1 for inconsistent histogr. request) *
29649* *
29650* This subroutine is based on a original version by R. Engel. *
29651* This version dated 22.4.95 is written by S. Roesler. *
29652************************************************************************
29653
29654 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29655 SAVE
29656 PARAMETER ( LINP = 10 ,
29657 & LOUT = 6 ,
29658 & LDAT = 9 )
29659
29660 LOGICAL LSTART
29661
29662 PARAMETER (ZERO = 0.0D0,
29663 & TINY = 1.0D-10)
29664
29665 DIMENSION XLIMB(*)
29666
29667* histograms
29668 PARAMETER (NHIS=150, NDIM=250)
29669 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29670 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29671* auxiliary common for histograms
29672 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29673
29674 DATA LSTART /.TRUE./
29675
29676* reset histogram counter
29677 IF (LSTART.OR.(IBIN.EQ.-1)) THEN
29678 IHISL = 0
29679 IF (IBIN.EQ.-1) RETURN
29680 LSTART = .FALSE.
29681 ENDIF
29682
29683 IHIS = IHISL+1
29684* check for maximum number of allowed histograms
29685 IF (IHIS.GT.NHIS) THEN
29686 WRITE(LOUT,1003) IHIS,NHIS,IHIS
29687 1003 FORMAT(1X,'NEWHGR: warning! number of histograms (',
29688 & I4,') exceeds array size (',I4,')',/,21X,
29689 & 'histogram',I3,' skipped!')
29690 GOTO 9999
29691 ENDIF
29692
29693 IREFN = IHIS
29694 IBINS(IHIS) = ABS(IBIN)
29695* check requested number of bins
29696 IF (IBINS(IHIS).GE.NDIM) THEN
29697 WRITE(LOUT,1000) IBIN,NDIM,NDIM
29698 1000 FORMAT(1X,'NEWHGR: warning! number of bins (',
29699 & I3,') exceeds array size (',I3,')',/,21X,
29700 & 'and will be reset to ',I3)
29701 IBINS(IHIS) = NDIM
29702 ENDIF
29703 IF (IBINS(IHIS).EQ.0) THEN
29704 WRITE(LOUT,1001) IBIN,IHIS
29705 1001 FORMAT(1X,'NEWHGR: warning! inconsistent number of',
29706 & ' bins (',I3,')',/,21X,'histogram',I3,' skipped!')
29707 GOTO 9999
29708 ENDIF
29709
29710* initialize arrays
29711 DO 1 I=1,NDIM
29712 DO 2 K=1,3
29713 HIST(K,IHIS,I) = ZERO
29714 HIST(K+3,IHIS,I) = ZERO
29715 TMPHIS(K,IHIS,I) = ZERO
29716 2 CONTINUE
29717 HIST(7,IHIS,I) = ZERO
29718 1 CONTINUE
29719 DENTRY(1,IHIS)= ZERO
29720 DENTRY(2,IHIS)= ZERO
29721 OVERF(IHIS) = ZERO
29722 UNDERF(IHIS) = ZERO
29723 TMPUFL(IHIS) = ZERO
29724 TMPOFL(IHIS) = ZERO
29725
29726* bin str. sensitive to lower edge, bin size, and numb. of bins
29727 IF (XLIM3.GT.ZERO) THEN
29728 DO 3 K=1,IBINS(IHIS)+1
29729 HIST(1,IHIS,K) = XLIM1+DBLE(K-1)*XLIM3
29730 3 CONTINUE
29731 ISWI(IHIS) = 1
29732* bin str. sensitive to lower/upper edge and numb. of bins
29733 ELSEIF (XLIM3.EQ.ZERO) THEN
29734* linear binning
29735 IF (IBIN.GT.0) THEN
29736 XLOW = XLIM1
29737 XHI = XLIM2
29738 IF (XLIM2.LE.XLIM1) THEN
29739 WRITE(LOUT,1002) XLIM1,XLIM2
29740 1002 FORMAT(1X,'NEWHGR: warning! inconsistent x-range',
29741 & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29742 GOTO 9999
29743 ENDIF
29744 ISWI(IHIS) = 1
29745 ELSEIF (IBIN.LT.-1) THEN
29746* logarithmic binning
29747 IF ((XLIM1.LE.ZERO).OR.(XLIM2.LE.ZERO)) THEN
29748 WRITE(LOUT,1004) XLIM1,XLIM2
29749 1004 FORMAT(1X,'NEWHGR: warning! inconsistent log. ',
29750 & 'binning',/,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29751 GOTO 9999
29752 ENDIF
29753 IF (XLIM2.LE.XLIM1) THEN
29754 WRITE(LOUT,1005) XLIM1,XLIM2
29755 1005 FORMAT(1X,'NEWHGR: warning! inconsistent x-range',
29756 & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29757 GOTO 9999
29758 ENDIF
29759 XLOW = LOG10(XLIM1)
29760 XHI = LOG10(XLIM2)
29761 ISWI(IHIS) = 3
29762 ENDIF
29763 DX = ABS(XHI-XLOW)/DBLE(MAX(IBINS(IHIS),1))
29764 DO 4 K=1,IBINS(IHIS)+1
29765 HIST(1,IHIS,K) = XLOW+DBLE(K-1)*DX
29766 4 CONTINUE
29767 ELSE
29768* user defined bin structure
29769 DO 5 K=1,IBINS(IHIS)+1
29770 IF (IBIN.GT.0) THEN
29771 HIST(1,IHIS,K) = XLIMB(K)
29772 ISWI(IHIS) = 2
29773 ELSEIF (IBIN.LT.-1) THEN
29774 HIST(1,IHIS,K) = LOG10(XLIMB(K))
29775 ISWI(IHIS) = 4
29776 ENDIF
29777 5 CONTINUE
29778 ENDIF
29779
29780* histogram accepted
29781 IHISL = IHIS
29782
29783 RETURN
29784
29785 9999 CONTINUE
29786 IREFN = -1
29787 RETURN
29788 END
29789
29790*$ CREATE DT_FILHGR.FOR
29791*COPY DT_FILHGR
29792*
29793*===filhgr=============================================================*
29794*
29795 SUBROUTINE DT_FILHGR(XI,YI,IHIS,NEVT)
29796
29797************************************************************************
29798* *
29799* Scoring for histogram IHIS. *
29800* *
29801* This subroutine is based on a original version by R. Engel. *
29802* This version dated 23.4.95 is written by S. Roesler. *
29803************************************************************************
29804
29805 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29806 SAVE
29807 PARAMETER ( LINP = 10 ,
29808 & LOUT = 6 ,
29809 & LDAT = 9 )
29810
29811 PARAMETER (ZERO = 0.0D0,
29812 & ONE = 1.0D0,
29813 & TINY = 1.0D-10)
29814
29815* histograms
29816 PARAMETER (NHIS=150, NDIM=250)
29817 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29818 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29819* auxiliary common for histograms
29820 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29821
29822 DATA NCEVT /1/
29823
29824 X = XI
29825 Y = YI
29826
29827* dump content of temorary arrays into histograms
29828 IF ((NEVT.NE.NCEVT).OR.(NEVT.LT.0)) THEN
29829 CALL DT_EVTHIS(IDUM)
29830 NCEVT = NEVT
29831 ENDIF
29832
29833* check histogram index
29834 IF (IHIS.EQ.-1) RETURN
29835 IF ((IHIS.LT.1).OR.(IHIS.GT.IHISL)) THEN
29836C WRITE(LOUT,1000) IHIS,IHISL
29837 1000 FORMAT(1X,'FILHGR: warning! histogram index',I4,
29838 & ' out of range (1..',I3,')')
29839 RETURN
29840 ENDIF
29841
29842 IF ((ISWI(IHIS).EQ.1).OR.(ISWI(IHIS).EQ.3)) THEN
29843* bin structure not explicitly given
29844 IF ((ISWI(IHIS).EQ.3).AND.(X.GT.ZERO)) X = LOG10(X)
29845 DX = ABS(HIST(1,IHIS,2)-HIST(1,IHIS,1))
29846 IF (X.LT.HIST(1,IHIS,1)) THEN
29847 I1 = 0
29848 ELSE
29849 I1 = INT( (X-HIST(1,IHIS,1))/MAX(DX,TINY) )+1
29850 ENDIF
29851
29852 ELSEIF ((ISWI(IHIS).EQ.2).OR.(ISWI(IHIS).EQ.4)) THEN
29853* user defined bin structure
29854 IF ((ISWI(IHIS).EQ.4).AND.(X.GT.ZERO)) X = LOG10(X)
29855 IF (X.LT.HIST(1,IHIS,1)) THEN
29856 I1 = 0
29857 ELSE IF (X.GT.HIST(1,IHIS,IBINS(IHIS)+1)) THEN
29858 I1 = IBINS(IHIS)+1
29859 ELSE
29860* binary sort algorithm
29861 KMIN = 0
29862 KMAX = IBINS(IHIS)+1
29863 1 CONTINUE
29864 IF ((KMAX-KMIN).EQ.1) GOTO 2
29865 KK = (KMAX+KMIN)/2
29866 IF (X.LE.HIST(1,IHIS,KK)) THEN
29867 KMAX=KK
29868 ELSE
29869 KMIN=KK
29870 ENDIF
29871 GOTO 1
29872 2 CONTINUE
29873 I1 = KMIN
29874 ENDIF
29875
29876 ELSE
29877 WRITE(LOUT,1001)
29878 1001 FORMAT(1X,'FILHGR: warning! histogram not initialized')
29879 RETURN
29880 ENDIF
29881
29882* scoring
29883 IF (I1.LE.0) THEN
29884 TMPUFL(IHIS) = TMPUFL(IHIS)+ONE
29885 ELSEIF (I1.LE.IBINS(IHIS)) THEN
29886 TMPHIS(1,IHIS,I1) = TMPHIS(1,IHIS,I1)+ONE
29887 IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
29888 TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+10**X
29889 ELSE
29890 TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+X
29891 ENDIF
29892 TMPHIS(3,IHIS,I1) = TMPHIS(3,IHIS,I1)+Y
29893 ELSE
29894 TMPOFL(IHIS) = TMPOFL(IHIS)+ONE
29895 ENDIF
29896
29897 RETURN
29898 END
29899
29900*$ CREATE DT_EVTHIS.FOR
29901*COPY DT_EVTHIS
29902*
29903*===evthis=============================================================*
29904*
29905 SUBROUTINE DT_EVTHIS(NEVT)
29906
29907************************************************************************
29908* Dump content of temorary histograms into /DTHIS1/. This subroutine *
29909* is called after each event and for the last event before any call *
29910* to OUTHGR. *
29911* NEVT number of events dumped, this is only needed to *
29912* get the normalization after the last event *
29913* This version dated 23.4.95 is written by S. Roesler. *
29914************************************************************************
29915
29916 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29917 SAVE
29918 PARAMETER ( LINP = 10 ,
29919 & LOUT = 6 ,
29920 & LDAT = 9 )
29921
29922 LOGICAL LNOETY
29923
29924 PARAMETER (ZERO = 0.0D0,
29925 & ONE = 1.0D0,
29926 & TINY = 1.0D-10)
29927
29928* histograms
29929 PARAMETER (NHIS=150, NDIM=250)
29930 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29931 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29932* auxiliary common for histograms
29933 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29934
29935 DATA NCEVT /0/
29936
29937 NCEVT = NCEVT+1
29938 NEVT = NCEVT
29939
29940 DO 1 I=1,IHISL
29941 LNOETY = .TRUE.
29942 DO 2 J=1,IBINS(I)
29943 IF (TMPHIS(1,I,J).GT.ZERO) THEN
29944 LNOETY = .FALSE.
29945 HIST(2,I,J) = HIST(2,I,J)+ONE
29946 HIST(7,I,J) = HIST(7,I,J)+TMPHIS(1,I,J)
29947 DENTRY(2,I) = DENTRY(2,I)+TMPHIS(1,I,J)
29948 AVX = TMPHIS(2,I,J)/TMPHIS(1,I,J)
29949 HIST(3,I,J) = HIST(3,I,J)+TMPHIS(3,I,J)*AVX
29950 HIST(4,I,J) = HIST(4,I,J)+TMPHIS(3,I,J)*AVX**2
29951 HIST(5,I,J) = HIST(5,I,J)+TMPHIS(3,I,J)
29952 HIST(6,I,J) = HIST(6,I,J)+TMPHIS(3,I,J)**2
29953 TMPHIS(1,I,J) = ZERO
29954 TMPHIS(2,I,J) = ZERO
29955 TMPHIS(3,I,J) = ZERO
29956 ENDIF
29957 2 CONTINUE
29958 IF (LNOETY) THEN
29959 IF (TMPUFL(I).GT.ZERO) THEN
29960 UNDERF(I) = UNDERF(I)+ONE
29961 TMPUFL(I) = ZERO
29962 ELSEIF (TMPOFL(I).GT.ZERO) THEN
29963 OVERF(I) = OVERF(I)+ONE
29964 TMPOFL(I) = ZERO
29965 ENDIF
29966 ELSE
29967 DENTRY(1,I) = DENTRY(1,I)+ONE
29968 ENDIF
29969 1 CONTINUE
29970
29971 RETURN
29972 END
29973
29974*$ CREATE DT_OUTHGR.FOR
29975*COPY DT_OUTHGR
29976*
29977*===outhgr=============================================================*
29978*
29979 SUBROUTINE DT_OUTHGR(I1,I2,I3,I4,I5,I6,CHEAD,IHEAD,NEVTS,FAC,
29980 & ILOGY,INORM,NMODE)
29981
29982************************************************************************
29983* *
29984* Plot histogram(s) to standard output unit *
29985* *
29986* I1..6 indices of histograms to be plotted *
29987* CHEAD,IHEAD header string,integer *
29988* NEVTS number of events *
29989* FAC scaling factor *
29990* ILOGY = 1 logarithmic y-axis *
29991* INORM normalization *
29992* = 0 no further normalization (FAC is obsolete) *
29993* = 1 per event and bin width *
29994* = 2 per entry and bin width *
29995* = 3 per bin entry *
29996* = 4 per event and "bin width" x1^2...x2^2 *
29997* = 5 per event and "log. bin width" ln x1..ln x2 *
29998* = 6 per event *
29999* MODE = 0 no output but normalization applied *
30000* = 1 all valid histograms separately (small frame) *
30001* all valid histograms separately (small frame) *
30002* = -1 and tables as histograms *
30003* = 2 all valid histograms (one plot, wide frame) *
30004* all valid histograms (one plot, wide frame) *
30005* = -2 and tables as histograms *
30006* *
30007* *
30008* Note: All histograms to be plotted with one call to this *
30009* subroutine and |MODE|=2 must have the same bin structure! *
30010* There is no test included ensuring this fact. *
30011* *
30012* This version dated 23.4.95 is written by S. Roesler. *
30013************************************************************************
30014
30015 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30016 SAVE
30017 PARAMETER ( LINP = 10 ,
30018 & LOUT = 6 ,
30019 & LDAT = 9 )
30020
30021 CHARACTER*72 CHEAD
30022
30023 PARAMETER (ZERO = 0.0D0,
30024 & IZERO = 0,
30025 & ONE = 1.0D0,
30026 & TWO = 2.0D0,
30027 & OHALF = 0.5D0,
30028 & EPS = 1.0D-5,
30029 & TINY = 1.0D-8,
30030 & SMALL = -1.0D8,
30031 & RLARGE = 1.0D8 )
30032
30033* histograms
30034 PARAMETER (NHIS=150, NDIM=250)
30035 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30036 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30037
30038 PARAMETER (NDIM2 = 2*NDIM)
30039 DIMENSION XX(NDIM2),YY(NDIM2)
30040
30041 PARAMETER (NHISTO = 6)
30042 DIMENSION YY1(NDIM,NHISTO),XX1(NDIM,NHISTO),IDX1(NHISTO),
30043 & IDX(NHISTO)
30044
30045 CHARACTER*43 CNORM(0:8)
30046 DATA CNORM /'no further normalization ',
30047 & 'per event and bin width ',
30048 & 'per entry1 and bin width ',
30049 & 'per bin entry ',
30050 & 'per event and "bin width" x1^2...x2^2 ',
30051 & 'per event and "log. bin width" ln x1..ln x2',
30052 & 'per event ',
30053 & 'per bin entry1 ',
30054 & 'per entry2 and bin width '/
30055
30056 IDX1(1) = I1
30057 IDX1(2) = I2
30058 IDX1(3) = I3
30059 IDX1(4) = I4
30060 IDX1(5) = I5
30061 IDX1(6) = I6
30062
30063 MODE = NMODE
30064
30065* initialization if "wide frame" is requested
30066 IF (ABS(MODE).EQ.2) THEN
30067 DO 1 I=1,NHISTO
30068 DO 2 J=1,NDIM
30069 XX1(J,I) = ZERO
30070 YY1(J,I) = ZERO
30071 2 CONTINUE
30072 1 CONTINUE
30073 ENDIF
30074
30075* plot header
30076 WRITE(LOUT,'(/1X,A,I3,/,1X,70A1)') CHEAD,IHEAD,('=',II=1,70)
30077
30078* check histogram indices
30079 NHI = 0
30080 DO 3 I=1,NHISTO
30081 IF ((IDX1(I).GE.1).AND.(IDX1(I).LE.IHISL)) THEN
30082 IF (ISWI(IDX1(I)).NE.0) THEN
30083 IF (DENTRY(1,IDX1(I)).LT.ONE) THEN
30084 WRITE(LOUT,1000)
30085 & IDX1(I),UNDERF(IDX1(I)),OVERF(IDX1(I))
30086 1000 FORMAT(/,1X,'OUTHGR: warning! no entries in',
30087 & ' histogram ',I3,/,21X,'underflows:',F10.0,
30088 & ' overflows: ',F10.0)
30089 ELSE
30090 NHI = NHI+1
30091 IDX(NHI) = IDX1(I)
30092 ENDIF
30093 ENDIF
30094 ENDIF
30095 3 CONTINUE
30096 IF (NHI.EQ.0) THEN
30097 WRITE(LOUT,1001)
30098 1001 FORMAT(/,1X,'OUTHGR: warning! histogram indices not valid')
30099 RETURN
30100 ENDIF
30101
30102* check normalization request
30103 IF ( ((FAC.EQ.ZERO).AND.(INORM.NE.0)).OR.
30104 & ((NEVTS.LT.1).AND.((INORM.EQ.1).OR.(INORM.EQ.4).OR.
30105 & (INORM.EQ.5).OR.(INORM.EQ.6))).OR.
30106 & (INORM.LT.0).OR.(INORM.GT.8) ) THEN
30107 WRITE(LOUT,1002) NEVTS,INORM,FAC
30108 1002 FORMAT(/,1X,'OUTHGR: warning! normalization request not ',
30109 & 'valid',/,21X,'NEVTS = ',I7,4X,'INORM = ',I2,4X,
30110 & 'FAC = ',E11.4)
30111 RETURN
30112 ENDIF
30113
30114 WRITE(LOUT,'(/,1X,A,I8)') 'number of events:',NEVTS
30115
30116* apply normalization
30117 DO 4 N=1,NHI
30118
30119 I = IDX(N)
30120
30121 IF (ISWI(I).EQ.1) THEN
30122 WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30123 1003 FORMAT(/,1X,'histo.',I4,', linear binning from',2X,E10.4,
30124 & ' to',2X,E10.4,',',2X,I3,' bins')
30125 ELSEIF (ISWI(I).EQ.2) THEN
30126 WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30127 WRITE(LOUT,1007)
30128 1007 FORMAT(1X,'user defined bin structure')
30129 ELSEIF (ISWI(I).EQ.3) THEN
30130 WRITE(LOUT,1004)
30131 & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30132 1004 FORMAT(/,1X,'histo.',I4,', logar. binning from',2X,E10.4,
30133 & ' to',2X,E10.4,',',2X,I3,' bins')
30134 ELSEIF (ISWI(I).EQ.4) THEN
30135 WRITE(LOUT,1004)
30136 & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30137 WRITE(LOUT,1007)
30138 ELSE
30139 WRITE(LOUT,1008) ISWI(I)
30140 1008 FORMAT(/,1X,'warning! inconsistent bin structure flag ',I4)
30141 ENDIF
30142 WRITE(LOUT,1005) DENTRY(1,I),DENTRY(2,I),UNDERF(I),OVERF(I)
30143 1005 FORMAT(13X,'entries:',2F9.0,' underfl.:',F8.0,
30144 & ' overfl.:',F8.0)
30145 WRITE(LOUT,1009) CNORM(INORM)
30146 1009 FORMAT(1X,'normalization: ',A,/)
30147
30148 DO 5 K=1,IBINS(I)
30149 CALL DT_GETBIN(I,K,NEVTS,INORM,XLOW,XHI,XMEAN,YMEAN,YERR)
30150 YMEAN = FAC*YMEAN
30151 YERR = FAC*YERR
30152 WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,YERR,HIST(2,I,K)
30153 WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,YERR,HIST(2,I,K)
30154 1006 FORMAT(1X,5E11.3)
30155* small frame
30156 II = 2*K
30157 XX(II-1) = HIST(1,I,K)
30158 XX(II) = HIST(1,I,K+1)
30159 YY(II-1) = YMEAN
30160 YY(II) = YMEAN
30161* wide frame
30162 XX1(K,N) = XMEAN
30163 IF ((ISWI(I).EQ.3).OR.(ISWI(I).EQ.4))
30164 & XX1(K,N) = LOG10(XMEAN)
30165 YY1(K,N) = YMEAN
30166 5 CONTINUE
30167
30168* plot small frame
30169 IF (ABS(MODE).EQ.1) THEN
30170 IBIN2 = 2*IBINS(I)
30171 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30172 IF(ILOGY.EQ.1) THEN
30173 CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30174 ELSE
30175 CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30176 ENDIF
30177 ENDIF
30178
30179 4 CONTINUE
30180
30181* plot wide frame
30182 IF (ABS(MODE).EQ.2) THEN
30183 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30184 NSIZE = NDIM*NHISTO
30185 DXLOW = HIST(1,IDX(1),1)
30186 DDX = ABS(HIST(1,IDX(1),2)-HIST(1,IDX(1),1))
30187 YLOW = RLARGE
30188 YHI = SMALL
30189 DO 6 I=1,NHISTO
30190 DO 7 J=1,NDIM
30191 IF (YY1(J,I).LT.YLOW) THEN
30192 IF (ILOGY.EQ.1) THEN
30193 IF (YY1(J,I).GT.ZERO) YLOW = YY1(J,I)
30194 ELSE
30195 YLOW = YY1(J,I)
30196 ENDIF
30197 ENDIF
30198 IF (YY1(J,I).GT.YHI) YHI = YY1(J,I)
30199 7 CONTINUE
30200 6 CONTINUE
30201 DY = (YHI-YLOW)/DBLE(NDIM)
30202 IF (DY.LE.ZERO) THEN
30203 WRITE(LOUT,'(1X,A,6I4,A,2E12.4)')
30204 & 'OUTHGR: warning! zero bin width for histograms ',
30205 & IDX,': ',YLOW,YHI
30206 RETURN
30207 ENDIF
30208 IF (ILOGY.EQ.1) THEN
30209 YLOW = LOG10(YLOW)
30210 DY = (LOG10(YHI)-YLOW)/100.0D0
30211 DO 8 I=1,NHISTO
30212 DO 9 J=1,NDIM
30213 IF (YY1(J,I).LE.ZERO) THEN
30214 YY1(J,I) = YLOW
30215 ELSE
30216 YY1(J,I) = LOG10(YY1(J,I))
30217 ENDIF
30218 9 CONTINUE
30219 8 CONTINUE
30220 ENDIF
30221 CALL DT_SRPLOT(XX1,YY1,NSIZE,NHISTO,NDIM,DXLOW,DDX,YLOW,DY)
30222 ENDIF
30223
30224 RETURN
30225 END
30226
30227*$ CREATE DT_GETBIN.FOR
30228*COPY DT_GETBIN
30229*
30230*===getbin=============================================================*
30231*
30232 SUBROUTINE DT_GETBIN(IHIS,IBIN,KEVT,NORM,XLOW,XHI,
30233 & XMEAN,YMEAN,YERR)
30234
30235************************************************************************
30236* This version dated 23.4.95 is written by S. Roesler. *
30237************************************************************************
30238
30239 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30240 SAVE
30241 PARAMETER ( LINP = 10 ,
30242 & LOUT = 6 ,
30243 & LDAT = 9 )
30244
30245 PARAMETER (ZERO = 0.0D0,
30246 & ONE = 1.0D0,
30247 & TINY35 = 1.0D-35)
30248
30249* histograms
30250 PARAMETER (NHIS=150, NDIM=250)
30251 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30252 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30253
30254 XLOW = HIST(1,IHIS,IBIN)
30255 XHI = HIST(1,IHIS,IBIN+1)
30256 IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
30257 XLOW = 10**XLOW
30258 XHI = 10**XHI
30259 ENDIF
30260 IF (NORM.EQ.2) THEN
30261 DX = XHI-XLOW
30262 NEVT = INT(DENTRY(1,IHIS))
30263 ELSEIF (NORM.EQ.3) THEN
30264 DX = ONE
30265 NEVT = INT(HIST(2,IHIS,IBIN))
30266 ELSEIF (NORM.EQ.4) THEN
30267 DX = XHI**2-XLOW**2
30268 NEVT = KEVT
30269 ELSEIF (NORM.EQ.5) THEN
30270 DX = LOG(ABS(XHI))-LOG(ABS(XLOW))
30271 NEVT = KEVT
30272 ELSEIF (NORM.EQ.6) THEN
30273 DX = ONE
30274 NEVT = KEVT
30275 ELSEIF (NORM.EQ.7) THEN
30276 DX = ONE
30277 NEVT = INT(HIST(7,IHIS,IBIN))
30278 ELSEIF (NORM.EQ.8) THEN
30279 DX = XHI-XLOW
30280 NEVT = INT(DENTRY(2,IHIS))
30281 ELSE
30282 DX = ABS(XHI-XLOW)
30283 NEVT = KEVT
30284 ENDIF
30285 IF (ABS(DX).LT.TINY35) DX = ONE
30286 NEVT = MAX(NEVT,1)
30287 YMEAN = HIST(5,IHIS,IBIN)/DX/DBLE(NEVT)
30288 YMEAN2 = HIST(6,IHIS,IBIN)/DX**2/DBLE(NEVT)
30289 YERR = SQRT(ABS(YMEAN2-YMEAN**2))/SQRT(DBLE(NEVT))
30290 YSUM = HIST(5,IHIS,IBIN)
30291 IF (ABS(YSUM).LT.TINY35) YSUM = ONE
30292C XMEAN = HIST(3,IHIS,IBIN)/YSUM/MAX(HIST(2,IHIS,IBIN),ONE)
30293 XMEAN = HIST(3,IHIS,IBIN)/YSUM
30294 IF (XMEAN.EQ.ZERO) XMEAN = XLOW
30295
30296 RETURN
30297 END
30298
30299*$ CREATE DT_JOIHIS.FOR
30300*COPY DT_JOIHIS
30301*
30302*===joihis=============================================================*
30303*
30304 SUBROUTINE DT_JOIHIS(IH1,IH2,COPER,FAC1,FAC2,KEVT,NORM,ILOGY,MODE)
30305
30306************************************************************************
30307* *
30308* Operation on histograms. *
30309* *
30310* input: IH1,IH2 histogram indices to be joined *
30311* COPER character defining the requested operation, *
30312* i.e. '+', '-', '*', '/' *
30313* FAC1,FAC2 factors for joining, i.e. *
30314* FAC1*histo1 COPER FAC2*histo2 *
30315* *
30316* This version dated 23.4.95 is written by S. Roesler. *
30317************************************************************************
30318
30319 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30320 SAVE
30321 PARAMETER ( LINP = 10 ,
30322 & LOUT = 6 ,
30323 & LDAT = 9 )
30324
30325 CHARACTER COPER*1
30326
30327 PARAMETER (ZERO = 0.0D0,
30328 & ONE = 1.0D0,
30329 & OHALF = 0.5D0,
30330 & TINY8 = 1.0D-8,
30331 & SMALL = -1.0D8,
30332 & RLARGE = 1.0D8 )
30333
30334* histograms
30335 PARAMETER (NHIS=150, NDIM=250)
30336 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30337 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30338
30339 PARAMETER (NDIM2 = 2*NDIM)
30340 DIMENSION XX(NDIM2),YY(NDIM2),YY1(NDIM),XX1(NDIM)
30341
30342 CHARACTER*43 CNORM(0:6)
30343 DATA CNORM /'no further normalization ',
30344 & 'per event and bin width ',
30345 & 'per entry and bin width ',
30346 & 'per bin entry ',
30347 & 'per event and "bin width" x1^2...x2^2 ',
30348 & 'per event and "log. bin width" ln x1..ln x2',
30349 & 'per event '/
30350
30351* check histogram indices
30352 IF ((IH1.LT. 1).OR.(IH2.LT. 1).OR.
30353 & (IH1.GT.IHISL).OR.(IH2.GT.IHISL)) THEN
30354 WRITE(LOUT,1000) IH1,IH2,IHISL
30355 1000 FORMAT(1X,'JOIHIS: warning! inconsistent histogram ',
30356 & 'indices (',I3,',',I3,'),',/,21X,'valid range: 1,',I3)
30357 GOTO 9999
30358 ENDIF
30359
30360* check bin structure of histograms to be joined
30361 IF (IBINS(IH1).NE.IBINS(IH2)) THEN
30362 WRITE(LOUT,1001) IH1,IH2,IBINS(IH1),IBINS(IH2)
30363 1001 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3,
30364 & ' and ',I3,' failed',/,21X,
30365 & 'due to different numbers of bins (',I3,',',I3,')')
30366 GOTO 9999
30367 ENDIF
30368 DO 1 K=1,IBINS(IH1)+1
30369 IF (ABS(HIST(1,IH1,K)-HIST(1,IH2,K)).GT.TINY8) THEN
30370 WRITE(LOUT,1002) IH1,IH2,K,HIST(1,IH1,K),HIST(1,IH2,K)
30371 1002 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3,
30372 & ' and ',I3,' failed at bin edge ',I3,/,21X,
30373 & 'X1,X2 = ',2E11.4)
30374 GOTO 9999
30375 ENDIF
30376 1 CONTINUE
30377
30378 WRITE(LOUT,1003) IH1,IH2,COPER,FAC1,FAC2
30379 1003 FORMAT(1X,'JOIHIS: joining histograms ',I3,',',I3,' with ',
30380 & 'operation ',A,/,11X,'and factors ',2E11.4)
30381 WRITE(LOUT,1004) CNORM(NORM)
30382 1004 FORMAT(1X,'normalization: ',A,/)
30383
30384 DO 2 K=1,IBINS(IH1)
30385 CALL DT_GETBIN(IH1,K,KEVT,NORM,XLOW1,XHI1,XMEAN1,YMEAN1,YERR1)
30386 CALL DT_GETBIN(IH2,K,KEVT,NORM,XLOW2,XHI2,XMEAN2,YMEAN2,YERR2)
30387 XLOW = XLOW1
30388 XHI = XHI1
30389 XMEAN = OHALF*(XMEAN1+XMEAN2)
30390 IF (COPER.EQ.'+') THEN
30391 YMEAN = FAC1*YMEAN1+FAC2*YMEAN2
30392 ELSEIF (COPER.EQ.'*') THEN
30393 YMEAN = FAC1*YMEAN1*FAC2*YMEAN2
30394 ELSEIF (COPER.EQ.'/') THEN
30395 IF (YMEAN2.EQ.ZERO) THEN
30396 YMEAN = ZERO
30397 ELSE
30398 IF (FAC2.EQ.ZERO) FAC2 = ONE
30399 YMEAN = FAC1*YMEAN1/(FAC2*YMEAN2)
30400 ENDIF
30401 ELSE
30402 GOTO 9998
30403 ENDIF
30404 WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30405 WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30406 1006 FORMAT(1X,5E11.3)
30407* small frame
30408 II = 2*K
30409 XX(II-1) = HIST(1,IH1,K)
30410 XX(II) = HIST(1,IH1,K+1)
30411 YY(II-1) = YMEAN
30412 YY(II) = YMEAN
30413* wide frame
30414 XX1(K) = XMEAN
30415 IF ((ISWI(IH1).EQ.3).OR.(ISWI(IH1).EQ.4)) XX1(K) = LOG10(XMEAN)
30416 YY1(K) = YMEAN
30417 2 CONTINUE
30418
30419* plot small frame
30420 IF (ABS(MODE).EQ.1) THEN
30421 IBIN2 = 2*IBINS(IH1)
30422 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30423 IF(ILOGY.EQ.1) THEN
30424 CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30425 ELSE
30426 CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30427 ENDIF
30428 ENDIF
30429
30430* plot wide frame
30431 IF (ABS(MODE).EQ.2) THEN
30432 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30433 NSIZE = NDIM
30434 DXLOW = HIST(1,IH1,1)
30435 DDX = ABS(HIST(1,IH1,2)-HIST(1,IH1,1))
30436 YLOW = RLARGE
30437 YHI = SMALL
30438 DO 3 I=1,NDIM
30439 IF (YY1(I).LT.YLOW) THEN
30440 IF (ILOGY.EQ.1) THEN
30441 IF (YY1(I).GT.ZERO) YLOW = YY1(I)
30442 ELSE
30443 YLOW = YY1(I)
30444 ENDIF
30445 ENDIF
30446 IF (YY1(I).GT.YHI) YHI = YY1(I)
30447 3 CONTINUE
30448 DY = (YHI-YLOW)/DBLE(NDIM)
30449 IF (DY.LE.ZERO) THEN
30450 WRITE(LOUT,'(1X,A,2I4,A,2E12.4)')
30451 & 'JOIHIS: warning! zero bin width for histograms ',
30452 & IH1,IH2,': ',YLOW,YHI
30453 RETURN
30454 ENDIF
30455 IF (ILOGY.EQ.1) THEN
30456 YLOW = LOG10(YLOW)
30457 DY = (LOG10(YHI)-YLOW)/100.0D0
30458 DO 4 I=1,NDIM
30459 IF (YY1(I).LE.ZERO) THEN
30460 YY1(I) = YLOW
30461 ELSE
30462 YY1(I) = LOG10(YY1(I))
30463 ENDIF
30464 4 CONTINUE
30465 ENDIF
30466 CALL DT_SRPLOT(XX1,YY1,NSIZE,1,NDIM,DXLOW,DDX,YLOW,DY)
30467 ENDIF
30468
30469 RETURN
30470
30471 9998 CONTINUE
30472 WRITE(LOUT,1005) COPER
30473 1005 FORMAT(1X,'JOIHIS: unknown operation ',A)
30474
30475 9999 CONTINUE
30476 RETURN
30477 END
30478
30479*$ CREATE DT_XGRAPH.FOR
30480*COPY DT_XGRAPH
30481*
30482*===qgraph=============================================================*
30483*
30484 SUBROUTINE DT_XGRAPH(N,IARG,X,Y1,Y2)
30485C***********************************************************************
30486C
30487C calculate quasi graphic picture with 25 lines and 79 columns
30488C ranges will be chosen automatically
30489C
30490C input N dimension of input fields
30491C IARG number of curves (fields) to plot
30492C X field of X
30493C Y1 field of Y1
30494C Y2 field of Y2
30495C
30496C This subroutine is written by R. Engel.
30497C***********************************************************************
30498 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30499 SAVE
30500
30501 PARAMETER ( LINP = 10 ,
30502 & LOUT = 6 ,
30503 & LDAT = 9 )
30504C
30505 DIMENSION X(N),Y1(N),Y2(N)
30506 PARAMETER (EPS=1.D-30)
30507 PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30508 CHARACTER SYMB(5)
30509 CHARACTER COL(0:149,0:49)
30510C
30511 DATA SYMB /'0','e','z','#','x'/
30512C
30513 ISPALT=IBREIT-10
30514C
30515C*** automatic range fitting
30516C
30517 XMAX=X(1)
30518 XMIN=X(1)
30519 DO 600 I=1,N
30520 XMAX=MAX(X(I),XMAX)
30521 XMIN=MIN(X(I),XMIN)
30522 600 CONTINUE
30523 XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30524C
30525 ITEST=0
30526 DO 1100 K=0,IZEIL-1
30527 ITEST=ITEST+1
30528 IF (ITEST.EQ.IYRAST) THEN
30529 DO 1010 L=1,ISPALT-1
30530 COL(L,K)='-'
305311010 CONTINUE
30532 COL(ISPALT,K)='+'
30533 ITEST=0
30534 DO 1020 L=0,ISPALT-1,IXRAST
30535 COL(L,K)='+'
305361020 CONTINUE
30537 ELSE
30538 DO 1030 L=1,ISPALT-1
30539 COL(L,K)=' '
305401030 CONTINUE
30541 DO 1040 L=0,ISPALT-1,IXRAST
30542 COL(L,K)='|'
305431040 CONTINUE
30544 COL(ISPALT,K)='|'
30545 ENDIF
305461100 CONTINUE
30547C
30548C*** plot curve Y1
30549C
30550 YMAX=Y1(1)
30551 YMIN=Y1(1)
30552 DO 500 I=1,N
30553 YMAX=MAX(Y1(I),YMAX)
30554 YMIN=MIN(Y1(I),YMIN)
30555500 CONTINUE
30556 IF(IARG.GT.1) THEN
30557 DO 550 I=1,N
30558 YMAX=MAX(Y2(I),YMAX)
30559 YMIN=MIN(Y2(I),YMIN)
30560550 CONTINUE
30561 ENDIF
30562 YMAX=(YMAX-YMIN)/40.0D0+YMAX
30563 YMIN=YMIN-(YMAX-YMIN)/40.0D0
30564 YZOOM=(YMAX-YMIN)/DBLE(IZEIL)
30565 IF(YZOOM.LT.EPS) THEN
30566 WRITE(LOUT,'(1X,A)')
30567 & 'XGRAPH:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30568 RETURN
30569 ENDIF
30570C
30571C*** plot curve Y1
30572C
30573 ILAST=-1
30574 LLAST=-1
30575 DO 1200 K=1,N
30576 L=NINT((X(K)-XMIN)/XZOOM)
30577 I=NINT((YMAX-Y1(K))/YZOOM)
30578 IF(ILAST.GE.0) THEN
30579 LD = L-LLAST
30580 ID = I-ILAST
30581 DO 55 II=0,LD,SIGN(1,LD)
30582 DO 66 KK=0,ID,SIGN(1,ID)
30583 COL(II+LLAST,KK+ILAST)=SYMB(1)
30584 66 CONTINUE
30585 55 CONTINUE
30586 ELSE
30587 COL(L,I)=SYMB(1)
30588 ENDIF
30589 ILAST = I
30590 LLAST = L
305911200 CONTINUE
30592C
30593 IF(IARG.GT.1) THEN
30594C
30595C*** plot curve Y2
30596C
30597 DO 1250 K=1,N
30598 L=NINT((X(K)-XMIN)/XZOOM)
30599 I=NINT((YMAX-Y2(K))/YZOOM)
30600 COL(L,I)=SYMB(2)
306011250 CONTINUE
30602 ENDIF
30603C
30604C*** write it
30605C
30606 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30607C
30608C*** write range of X
30609C
30610 XZOOM = (XMAX-XMIN)/DBLE(7)
30611 WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30612C
30613 DO 1300 K=0,IZEIL-1
30614 YPOS=YMAX-((DBLE(K)+0.5D0)*YZOOM)
30615 WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30616 110 FORMAT(1X,1PE9.2,70A1)
306171300 CONTINUE
30618C
30619C*** write range of X
30620C
30621 XZOOM = (XMAX-XMIN)/DBLE(7)
30622 WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30623 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30624 120 FORMAT(6X,7(1PE10.3))
30625 END
30626
30627*$ CREATE DT_XGLOGY.FOR
30628*COPY DT_XGLOGY
30629*
30630*===qglogy=============================================================*
30631*
30632 SUBROUTINE DT_XGLOGY(N,IARG,X,Y1,Y2)
30633C***********************************************************************
30634C
30635C calculate quasi graphic picture with 25 lines and 79 columns
30636C logarithmic y axis
30637C ranges will be chosen automatically
30638C
30639C input N dimension of input fields
30640C IARG number of curves (fields) to plot
30641C X field of X
30642C Y1 field of Y1
30643C Y2 field of Y2
30644C
30645C This subroutine is written by R. Engel.
30646C***********************************************************************
30647C
30648 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30649 SAVE
30650
30651 PARAMETER ( LINP = 10 ,
30652 & LOUT = 6 ,
30653 & LDAT = 9 )
30654 DIMENSION X(N),Y1(N),Y2(N)
30655 PARAMETER (EPS=1.D-30)
30656 PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30657 CHARACTER SYMB(5)
30658 CHARACTER COL(0:149,0:49)
30659 PARAMETER (DEPS = 1.D-10)
30660C
30661 DATA SYMB /'0','e','z','#','x'/
30662C
30663 ISPALT=IBREIT-10
30664C
30665C*** automatic range fitting
30666C
30667 XMAX=X(1)
30668 XMIN=X(1)
30669 DO 600 I=1,N
30670 XMAX=MAX(X(I),XMAX)
30671 XMIN=MIN(X(I),XMIN)
30672 600 CONTINUE
30673 XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30674C
30675 ITEST=0
30676 DO 1100 K=0,IZEIL-1
30677 ITEST=ITEST+1
30678 IF (ITEST.EQ.IYRAST) THEN
30679 DO 1010 L=1,ISPALT-1
30680 COL(L,K)='-'
306811010 CONTINUE
30682 COL(ISPALT,K)='+'
30683 ITEST=0
30684 DO 1020 L=0,ISPALT-1,IXRAST
30685 COL(L,K)='+'
306861020 CONTINUE
30687 ELSE
30688 DO 1030 L=1,ISPALT-1
30689 COL(L,K)=' '
306901030 CONTINUE
30691 DO 1040 L=0,ISPALT-1,IXRAST
30692 COL(L,K)='|'
306931040 CONTINUE
30694 COL(ISPALT,K)='|'
30695 ENDIF
306961100 CONTINUE
30697C
30698C*** plot curve Y1
30699C
30700 YMAX=Y1(1)
30701 YMIN=MAX(Y1(1),EPS)
30702 DO 500 I=1,N
30703 YMAX =MAX(Y1(I),YMAX)
30704 IF(Y1(I).GT.EPS) THEN
30705 IF(YMIN.EQ.EPS) THEN
30706 YMIN = Y1(I)/10.D0
30707 ELSE
30708 YMIN = MIN(Y1(I),YMIN)
30709 ENDIF
30710 ENDIF
30711500 CONTINUE
30712 IF(IARG.GT.1) THEN
30713 DO 550 I=1,N
30714 YMAX=MAX(Y2(I),YMAX)
30715 IF(Y2(I).GT.EPS) THEN
30716 IF(YMIN.EQ.EPS) THEN
30717 YMIN = Y2(I)
30718 ELSE
30719 YMIN = MIN(Y2(I),YMIN)
30720 ENDIF
30721 ENDIF
30722550 CONTINUE
30723 ENDIF
30724C
30725 DO 560 I=1,N
30726 Y1(I) = MAX(Y1(I),YMIN)
30727 560 CONTINUE
30728 IF(IARG.GT.1) THEN
30729 DO 570 I=1,N
30730 Y2(I) = MAX(Y2(I),YMIN)
30731 570 CONTINUE
30732 ENDIF
30733C
30734 IF(YMAX.LE.YMIN) THEN
30735 WRITE(LOUT,'(/1X,A,2E12.3,/)')
30736 & 'XGLOGY:ERROR:YMIN,YMAX ',YMIN,YMAX
30737 WRITE(LOUT,'(1X,A)') 'MIN = MAX, OUTPUT SUPPRESSED'
30738 RETURN
30739 ENDIF
30740C
30741 YMA=(LOG10(YMAX)-LOG10(YMIN))/20.0D0+LOG10(YMAX)
30742 YMI=LOG10(YMIN)-(LOG10(YMAX)-LOG10(YMIN))/20.0D0
30743 YZOOM=(YMA-YMI)/DBLE(IZEIL)
30744 IF(YZOOM.LT.EPS) THEN
30745 WRITE(LOUT,'(1X,A)')
30746 & 'XGLOGY:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30747 RETURN
30748 ENDIF
30749C
30750C*** plot curve Y1
30751C
30752 ILAST=-1
30753 LLAST=-1
30754 DO 1200 K=1,N
30755 L=NINT((X(K)-XMIN)/XZOOM)
30756 I=NINT((YMA-LOG10(Y1(K)))/YZOOM)
30757 IF(ILAST.GE.0) THEN
30758 LD = L-LLAST
30759 ID = I-ILAST
30760 DO 55 II=0,LD,SIGN(1,LD)
30761 DO 66 KK=0,ID,SIGN(1,ID)
30762 COL(II+LLAST,KK+ILAST)=SYMB(1)
30763 66 CONTINUE
30764 55 CONTINUE
30765 ELSE
30766 COL(L,I)=SYMB(1)
30767 ENDIF
30768 ILAST = I
30769 LLAST = L
307701200 CONTINUE
30771C
30772 IF(IARG.GT.1) THEN
30773C
30774C*** plot curve Y2
30775C
30776 DO 1250 K=1,N
30777 L=NINT((X(K)-XMIN)/XZOOM)
30778 I=NINT((YMA-LOG10(Y2(K)))/YZOOM)
30779 COL(L,I)=SYMB(2)
307801250 CONTINUE
30781 ENDIF
30782C
30783C*** write it
30784C
30785 WRITE(LOUT,'(2X,A)') '(LOGARITHMIC Y AXIS)'
30786 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30787C
30788C*** write range of X
30789C
30790 XZOOM1 = (XMAX-XMIN)/DBLE(7)
30791 WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30792C
30793 DO 1300 K=0,IZEIL-1
30794 YPOS=10.D0**(YMA-((DBLE(K)+0.5D0)*YZOOM))
30795 WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30796 110 FORMAT(1X,1PE9.2,70A1)
307971300 CONTINUE
30798C
30799C*** write range of X
30800C
30801 WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30802 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30803 120 FORMAT(6X,7(1PE10.3))
30804C
30805 END
30806
30807*$ CREATE DT_SRPLOT.FOR
30808*COPY DT_SRPLOT
30809*
30810*===plot===============================================================*
30811*
30812 SUBROUTINE DT_SRPLOT(X,Y,N,M,MM,XO,DX,YO,DY)
30813
30814 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30815 SAVE
30816
30817 PARAMETER ( LINP = 10 ,
30818 & LOUT = 6 ,
30819 & LDAT = 9 )
30820*
30821* initial version
30822* J. Ranft, (FORTRAN-Programmierung,J.R.,Teubner, Leipzig, 72)
30823* This is a subroutine of fluka to plot Y across the page
30824* as a function of X down the page. Up to 37 curves can be
30825* plotted in the same picture with different plotting characters.
30826* Output of first 10 overprinted characters addad by FB 88
30827* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
30828*
30829* Input Variables:
30830* X = array containing the values of X
30831* Y = array containing the values of Y
30832* N = number of values in X and in Y
30833* can exceed the fixed number of lines
30834* M = number of different curves X,Y are containing
30835* MM = number of points in each curve i.e. N=M*MM
30836* XO = smallest value of X to be plotted
30837* DX = increment of X between subsequent lines
30838* YO = smallest value of Y to be plotted
30839* DY = increment of Y between subsequent character spaces
30840*
30841* other variables used inside:
30842* XX = numbers along the X-coordinate axis
30843* YY = numbers along the Y-coordinate axis
30844* LL = ten lines temporary storage for the plot
30845* L = character set used to plot different curves
30846* LOV = memorizes overprinted symbols
30847* the first 10 overprinted symbols are printed on
30848* the end of the line to avoid ambiguities
30849* (added by FB as considered quite helpful)
30850*
30851*********************************************************************
30852*
30853 DIMENSION XX(61),YY(61),LL(101,10)
30854 DIMENSION X(N),Y(N),L(40),LOV(40,10)
333481d6 30855 INTEGER*4 LL, L, LOV
9aaba0d6 30856 DATA L/
30857 11H*,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HZ,
30858 21H+,1HA,1HO,1HB,1HC,1HD,1HE,1HF,1HG,1HH,
30859 31HI,1HJ,1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,
30860 41HS,1HT,1HU,1HV,1HW,1HX,1HY,1H1,1H-,1H /
30861*
30862*
30863 MN=51
30864 DO 10 I=1,MN
30865 AI=I-1
30866 10 XX(I)=XO+AI*DX
30867 DO 20 I=1,11
30868 AI=I-1
30869 20 YY(I)=YO+10.0D0*AI*DY
30870 WRITE(LOUT, 500) (YY(I),I=1,11)
30871 MMN=MN-1
30872*
30873*
30874 DO 90 JJ=1,MMN,10
30875 JJJ=JJ-1
30876 DO 30 I=1,101
30877 DO 30 J=1,10
30878 30 LL(I,J)=L(40)
30879 DO 40 I=1,101
30880 40 LL(I,1)=L(39)
30881 DO 50 I=1,101,10
30882 DO 50 J=1,10
30883 50 LL(I,J)=L(38)
30884 DO 60 I=1,40
30885 DO 60 J=1,10
30886 60 LOV(I,J)=L(40)
30887*
30888*
30889 DO 70 I=1,M
30890 DO 70 J=1,MM
30891 II=J+(I-1)*MM
30892 AIX=(X(II)-(XO-DX/2.0D0))/DX+1.0D0
30893 AIY=(Y(II)-(YO-DY/2.0D0))/DY+1.0D0
30894 AIX=AIX-DBLE(JJJ)
30895* changed Sept.88 by FB to avoid INTEGER OVERFLOW
30896 IF( AIX .GT. 1.D0.AND. AIX .LT. 11.D0.AND. AIY .GT. 1.D0.AND
30897 + . AIY .LT. 102.D0) THEN
30898 IX=INT(AIX)
30899 IY=INT(AIY)
30900 IF( IX.GT. 0.AND. IX.LE. 10.AND. IY.GT. 0.AND. IY.LE. 101)
30901 + THEN
30902 IF(LL(IY,IX).NE.L(38).AND.LL(IY,IX).NE.L(39)) LOV(I,IX)
30903 + =LL(IY,IX)
30904 LL(IY,IX)=L(I)
30905 ENDIF
30906 ENDIF
30907 70 CONTINUE
30908*
30909*
30910 DO 80 I=1,10
30911 II=I+JJJ
30912 III=II+1
30913 WRITE(LOUT,510) XX(II),XX(III) , (LL(J,I),J=1,101) ,
30914 & (LOV(J,I),J=1,10)
30915 80 CONTINUE
30916 90 CONTINUE
30917*
30918*
30919 WRITE(LOUT, 520)
30920 WRITE(LOUT, 500) (YY(I),I=1,11)
30921 RETURN
30922*
30923 500 FORMAT(11X,11(1PE10.2),11HOVERPRINTED)
30924 510 FORMAT(1X,2(1PE10.2),101A1,1H ,10A1)
30925 520 FORMAT(20X,10('1---------'),'1')
30926 END
30927
30928*$ CREATE DT_DEFSET.FOR
30929*COPY DT_DEFSET
30930*
30931*===defset=============================================================*
30932*
30933 BLOCK DATA DT_DEFSET
30934
30935 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30936 SAVE
30937
30938* flags for input different options
30939 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
30940 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
30941 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
30942 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
30943* emulsion treatment
30944 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
30945 & NCOMPO,IEMUL
30946
30947* / DTFLG1 /
30948 DATA IFRAG / 2, 1 /
30949 DATA IRESCO / 1 /
30950 DATA IMSHL / 1 /
30951 DATA IRESRJ / 0 /
30952 DATA IOULEV / -1, -1, -1, -1, -1, -1 /
30953 DATA LEMCCK / .FALSE. /
30954 DATA LHADRO / .FALSE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,
30955 & .TRUE.,.TRUE.,.TRUE./
30956 DATA LSEADI / .TRUE. /
30957 DATA LEVAPO / .TRUE. /
30958 DATA IFRAME / 1 /
30959 DATA ITRSPT / 0 /
30960
30961* / DTCOMP /
30962 DATA EMUFRA / NCOMPX*0.0D0 /
30963 DATA IEMUMA / NCOMPX*1 /
30964 DATA IEMUCH / NCOMPX*1 /
30965 DATA NCOMPO / 0 /
30966 DATA IEMUL / 0 /
30967
30968 END
30969
30970*$ CREATE DT_HADPRP.FOR
30971*COPY DT_HADPRP
30972*
30973*===hadprp=============================================================*
30974*
30975 BLOCK DATA DT_HADPRP
30976
30977 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30978 SAVE
30979
30980* auxiliary common for reggeon exchange (DTUNUC 1.x)
30981 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
30982 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
30983 & IQTCHR(-6:6),MQUARK(3,39)
30984* hadron index conversion (BAMJET <--> PDG)
30985 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
30986 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
30987 & IAMCIN(210)
30988* names of hadrons used in input-cards
30989 CHARACTER*8 BTYPE
30990 COMMON /DTPAIN/ BTYPE(30)
30991
30992* / DTQUAR /
30993*----------------------------------------------------------------------*
30994* *
30995* Quark content of particles: *
30996* index quark el. charge bar. charge isospin isospin3 *
30997* 1 = u 2/3 1/3 1/2 1/2 *
30998* -1 = ubar -2/3 -1/3 1/2 -1/2 *
30999* 2 = d -1/3 1/3 1/2 -1/2 *
31000* -2 = dbar 1/3 -1/3 1/2 1/2 *
31001* 3 = s -1/3 1/3 0 0 *
31002* -3 = sbar 1/3 -1/3 0 0 *
31003* 4 = c 2/3 1/3 0 0 *
31004* -4 = cbar -2/3 -1/3 0 0 *
31005* 5 = b -1/3 1/3 0 0 *
31006* -5 = bbar 1/3 -1/3 0 0 *
31007* 6 = t 2/3 1/3 0 0 *
31008* -6 = tbar -2/3 -1/3 0 0 *
31009* *
31010* Mquark = particle quark composition (Paprop numbering) *
31011* Iqechr = electric charge ( in 1/3 unit ) *
31012* Iqbchr = baryonic charge ( in 1/3 unit ) *
31013* Iqichr = isospin ( in 1/2 unit ), z component *
31014* Iqschr = strangeness *
31015* Iqcchr = charm *
31016* Iquchr = beauty *
31017* Iqtchr = ...... *
31018* *
31019*----------------------------------------------------------------------*
31020 DATA IQECHR / -2, 1, -2, 1, 1, -2, 0, 2, -1, -1, 2, -1, 2 /
31021 DATA IQBCHR / 6*-1, 0, 6*1 /
31022 DATA IQICHR / 4*0, 1, -1, 0, 1, -1, 4*0 /
31023 DATA IQSCHR / 3*0, 1, 5*0, -1, 3*0 /
31024 DATA IQCCHR / 2*0, -1, 7*0, 1, 2*0 /
31025 DATA IQUCHR / 0, 1, 9*0, -1, 0 /
31026 DATA IQTCHR / -1, 11*0, 1 /
31027 DATA MQUARK /
31028 & 2, 1, 1, -2,-1,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31029 & 0, 0, 0, 0, 0, 0, 2, 2, 1, -2,-2,-1, 0, 0, 0,
31030 & 0, 0, 0, 0, 0, 0, 1,-2, 0, 2,-1, 0, 1,-3, 0,
31031 & 3,-1, 0, 1, 2, 3, -1,-2,-3, 0, 0, 0, 2, 2, 3,
31032 & 1, 1, 3, 1, 2, 3, 1,-1, 0, 2,-3, 0, 3,-2, 0,
31033 & 2,-2, 0, 3,-3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31034 & -1,-1,-3, -1,-2,-3, -2,-2,-3, 1, 3, 3, -1,-3,-3,
31035 & 2, 3, 3, -2,-3,-3, 3, 3, 3, -3,-3,-3 /
31036
31037* / DTHAIC /
31038* (renamed) (HAdron InDex COnversion)
31039* translation table version filled up by r.e. 25.01.94 *
31040 DATA IAMCIN /
31041 &2212,-2212,11,-11,12, -12,22,2112,-2112,-13,
31042 &13,130,211,-211,321, -321,3122,-3122,310,3112,
31043 &3222,3212,111,311,-311, 0,0,0,0,0,
31044 &221,213,113,-213,223, 323,313,-323,-313,10323,
31045 &10313,-10323,-10313,30323,30313, -30323,-30313,3224,3214,3114,
31046 &3216,3218,2224,2214,2114, 1114,12224,12214,12114,11114,
31047 &99999,99999,22212,22112,32124, 31214,-2224,-2214,-2114,-1114,
31048 &-12224,-12214,-12114,-11114,-2124, -1214,4*99999,
31049 &5*99999, 5*99999,
31050 &4*99999,331, 333,3322,3312,-3222,-3212,
31051 &-3112,-3322,-3312,3224,3214, 3114,3324,3314,3334,-3224,
31052 &-3214,-3114,-3324,-3314,-3334, 421,411,-411,-421,431,
31053 &-431,441,423,413,-413, -423,433,-433,20443,443,
31054 &-15,15,16,-16,14, -14,4122,4232,4132,4222,
31055 &4212,4112,3*99999, 3*99999,-4122,-4232,
31056 &-4132,-4222,-4212,-4112,99999, 5*99999,
31057 &5*99999, 5*99999,
31058 &10*99999,
31059 &5*99999 , 20211,20111,-20211,99999,20321,
31060 &-20321,20311,-20311,7*99999 ,
31061 &7*99999,12212,12112,99999/
31062
31063* / DTHAIC /
31064* (HAdron InDex COnversion)
31065 DATA (IPDG2(1,K),K=1,7)
31066 & / -11, -12, -13, -15, -16, -14, 0/
31067 DATA (IBAM2(1,K),K=1,7)
31068 & / 4, 6, 10, 131, 134, 136, 0/
31069 DATA (IPDG2(2,K),K=1,7)
31070 & / 11, 12, 22, 13, 15, 16, 14/
31071 DATA (IBAM2(2,K),K=1,7)
31072 & / 3, 5, 7, 11, 132, 133, 135/
31073 DATA (IPDG3(1,K),K=1,22)
31074 & / -211, -321, -311, -213, -323, -313, -411, -421,
31075 & -431, -413, -423, -433, 0, 0, 0, 0,
31076 & 0, 0, 0, 0, 0, 0/
31077 DATA (IBAM3(1,K),K=1,22)
31078 & / 14, 16, 25, 34, 38, 39, 118, 119,
31079 & 121, 125, 126, 128, 0, 0, 0, 0,
31080 & 0, 0, 0, 0, 0, 0/
31081 DATA (IPDG3(2,K),K=1,22)
31082 & / 130, 211, 321, 310, 111, 311, 221, 213,
31083 & 113, 223, 323, 313, 331, 333, 421, 411,
31084 & 431, 441, 423, 413, 433, 443/
31085 DATA (IBAM3(2,K),K=1,22)
31086 & / 12, 13, 15, 19, 23, 24, 31, 32,
31087 & 33, 35, 36, 37, 95, 96, 116, 117,
31088 & 120, 122, 123, 124, 127, 130/
31089 DATA (IPDG4(1,K),K=1,29)
31090 & / -2212, -2112, -3122, -2224, -2214, -2114, -1114, -2124,
31091 & -1214, -3222, -3212, -3112, -3322, -3312, -3224, -3214,
31092 & -3114, -3324, -3314, -3334, -4122, -4232, -4132, -4222,
31093 & -4212, -4112, 0, 0, 0/
31094 DATA (IBAM4(1,K),K=1,29)
31095 & / 2, 9, 18, 67, 68, 69, 70, 75,
31096 & 76, 99, 100, 101, 102, 103, 110, 111,
31097 & 112, 113, 114, 115, 149, 150, 151, 152,
31098 & 153, 154, 0, 0, 0/
31099 DATA (IPDG4(2,K),K=1,29)
31100 & / 2212, 2112, 3122, 3112, 3222, 3212, 3224, 3214,
31101 & 3114, 3216, 3218, 2224, 2214, 2114, 1114, 3322,
31102 & 3312, 3224, 3214, 3114, 3324, 3314, 3334, 4122,
31103 & 4232, 4132, 4222, 4212, 4112/
31104 DATA (IBAM4(2,K),K=1,29)
31105 & / 1, 8, 17, 20, 21, 22, 48, 49,
31106 & 50, 51, 52, 53, 54, 55, 56, 97,
31107 & 98, 104, 105, 106, 107, 108, 109, 137,
31108 & 138, 139, 140, 141, 142/
31109 DATA (IPDG5(1,K),K=1,19)
31110 & /-10323,-10313,-30323,-30313,-12224,-12214,-12114,-11114,
31111 & -20211,-20321,-20311, 0, 0, 0, 0, 0,
31112 & 0, 0, 0/
31113 DATA (IBAM5(1,K),K=1,19)
31114 & / 42, 43, 46, 47, 71, 72, 73, 74,
31115 & 188, 191, 193, 0, 0, 0, 0, 0,
31116 & 0, 0, 0/
31117 DATA (IPDG5(2,K),K=1,19)
31118 & / 10323, 10313, 30323, 30313, 12224, 12214, 12114, 11114,
31119 & 22212, 22112, 32124, 31214, 20443, 20211, 20111, 20321,
31120 & 20311, 12212, 12112/
31121 DATA (IBAM5(2,K),K=1,19)
31122 & / 40, 41, 44, 45, 57, 58, 59, 60,
31123 & 63, 64, 65, 66, 129, 186, 187, 190,
31124 & 192, 208, 209/
31125
31126* / DTPAIN /
31127* internal particle names
31128 DATA BTYPE / 'PROTON ' , 'APROTON ' , 'ELECTRON' , 'POSITRON' ,
31129 &'NEUTRIE ' , 'ANEUTRIE' , 'PHOTON ' , 'NEUTRON ' , 'ANEUTRON' ,
31130 &'MUON+ ' , 'MUON- ' , 'KAONLONG' , 'PION+ ' , 'PION- ' ,
31131 &'KAON+ ' , 'KAON- ' , 'LAMBDA ' , 'ALAMBDA ' , 'KAONSHRT' ,
31132 &'SIGMA- ' , 'SIGMA+ ' , 'SIGMAZER' , 'PIZERO ' , 'KAONZERO' ,
31133 &'AKAONZER' , 'NEUTRIM ' , 'ANEUTRIM' , 'NEUTRIT ' , 'ANEUTRIT' ,
31134 &'BLANK ' /
31135
31136 END
31137
31138*$ CREATE DT_BLKD46.FOR
31139*COPY DT_BLKD46
31140*
31141*===blkd46=============================================================*
31142*
31143 BLOCK DATA DT_BLKD46
31144
31145 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31146 SAVE
31147
31148 PARAMETER ( AMELCT = 0.51099906 D-03 )
31149 PARAMETER ( AMMUON = 0.105658389 D+00 )
31150
31151* particle properties (BAMJET index convention)
31152 CHARACTER*8 ANAME
31153 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
31154 & IICH(210),IIBAR(210),K1(210),K2(210)
31155
31156* / DTPART /
31157* Particle masses Engel version JETSET compatible
31158C DATA (AAM(K),K=1,85) /
31159C & .9383D+00, .9383D+00, AMELCT , AMELCT , .0000D+00,
31160C & .0000D+00, .0000D+00, .9396D+00, .9396D+00, AMMUON ,
31161C & AMMUON , .4977D+00, .1396D+00, .1396D+00, .4936D+00,
31162C & .4936D+00, .1116D+01, .1116D+01, .4977D+00, .1197D+01,
31163C & .1189D+01, .1193D+01, .1350D+00, .4977D+00, .4977D+00,
31164C & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31165C & .5488D+00, .7669D+00, .7700D+00, .7669D+00, .7820D+00,
31166C & .8921D+00, .8962D+00, .8921D+00, .8962D+00, .1300D+01,
31167C & .1300D+01, .1300D+01, .1300D+01, .1421D+01, .1421D+01,
31168C & .1421D+01, .1421D+01, .1383D+01, .1384D+01, .1387D+01,
31169C & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
31170C & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
31171C & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
31172C & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
31173C & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
31174C & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
31175C & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 /
31176C DATA (AAM(K),K=86,183) /
31177C & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
31178C & .1700D+01, .1700D+01, .1820D+01, .2030D+01, .9575D+00,
31179C & .1019D+01, .1315D+01, .1321D+01, .1189D+01, .1193D+01,
31180C & .1197D+01, .1315D+01, .1321D+01, .1383D+01, .1384D+01,
31181C & .1387D+01, .1532D+01, .1535D+01, .1672D+01, .1383D+01,
31182C & .1384D+01, .1387D+01, .1532D+01, .1535D+01, .1672D+01,
31183C & .1865D+01, .1869D+01, .1869D+01, .1865D+01, .1969D+01,
31184C & .1969D+01, .2980D+01, .2007D+01, .2010D+01, .2010D+01,
31185C & .2007D+01, .2113D+01, .2113D+01, .3686D+01, .3097D+01,
31186C & .1784D+01, .1784D+01, .0000D+00, .0000D+00, .0000D+00,
31187C & .0000D+00, .2285D+01, .2460D+01, .2460D+01, .2452D+01,
31188C & .2453D+01, .2454D+01, .2560D+01, .2560D+01, .2730D+01,
31189C & .3610D+01, .3610D+01, .3790D+01, .2285D+01, .2460D+01,
31190C & .2460D+01, .2452D+01, .2453D+01, .2454D+01, .2560D+01,
31191C & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
31192C & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31193C & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31194C & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31195C & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31196C & .1250D+01, .1250D+01, .1250D+01 /
31197C DATA (AAM ( I ), I = 184,210 ) /
31198C & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31199C & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31200C & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31201C & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31202C & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31203C & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31204C & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31205C & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31206C & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31207* sr 25.1.06: particle masses adjusted to Pythia
31208 DATA (AAM(K),K=1,85) /
31209 & .938270E+00,.938270E+00, AMELCT , AMELCT ,.000000E+00,
31210 & .000000E+00,.000000E+00,.939570E+00,.939570E+00, AMMUON ,
31211 & AMMUON ,.497670E+00,.139570E+00,.139570E+00,.493600E+00,
31212 & .493600E+00,.111568E+01,.111568E+01,.497670E+00,.119744E+01,
31213 & .118937E+01,.119255E+01,.134980E+00,.497670E+00,.497670E+00,
31214 & .0000D+00, .0000D+00, .0000D+00 , .0000D+00, .0000D+00,
31215 & .547450E+00,.766900E+00,.768500E+00,.766900E+00,.781940E+00,
31216 & .891600E+00,.896100E+00,.891600E+00,.896100E+00,.129000E+01,
31217 & .129000E+01,.129000E+01,.129000E+01, .1421D+01, .1421D+01,
31218 & .1421D+01, .1421D+01,.138280E+01,.138370E+01,.138720E+01,
31219 & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
31220 & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
31221 & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
31222 & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
31223 & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
31224 & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
31225 & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 /
31226 DATA (AAM(K),K=86,183) /
31227 & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
31228 & .1700D+01, .1700D+01, .1820D+01, .2030D+01,.957770E+00,
31229 & .101940E+01,.131490E+01,.132130E+01,.118937E+01,.119255E+01,
31230 & .119744E+01,.131490E+01,.132130E+01,.138280E+01,.138370E+01,
31231 & .138720E+01,.153180E+01, .1535D+01,.167245E+01,.138280E+01,
31232 & .138370E+01,.138720E+01,.153180E+01, .1535D+01,.167245E+01,
31233 & .186450E+01,.186930E+01,.186930E+01,.186450E+01,.196850E+01,
31234 & .196850E+01,.297980E+01,.200670E+01, .2010D+01, .2010D+01,
31235 & .200670E+01,.211240E+01,.211240E+01, .3686D+01,.309688E+01,
31236 & .177700E+01,.177700E+01, .0000D+00, .0000D+00, .0000D+00,
31237 & .0000D+00,.228490E+01,.246560E+01,.247030E+01,.245290E+01,
31238 & .245350E+01,.245210E+01, .2560D+01, .2560D+01, .2730D+01,
31239 & .3610D+01, .3610D+01, .3790D+01,.228490E+01,.246560E+01,
31240 & .2460D+01,.245290E+01,.245350E+01,.245210E+01, .2560D+01,
31241 & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
31242 & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31243 & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31244 & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31245 & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31246 & .1250D+01, .1250D+01, .1250D+01 /
31247 DATA (AAM ( I ), I = 184,210 ) /
31248 & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31249 & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31250 & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31251 & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31252 & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31253 & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31254 & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31255 & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31256 & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31257* Particle mean lives
31258 DATA (TAU(K),K=1,183) /
31259 & .1000D+19, .1000D+19, .1000D+19, .1000D+19, .1000D+19,
31260 & .1000D+19, .1000D+19, .9180D+03, .9180D+03, .2200D-05,
31261 & .2200D-05, .5200D-07, .2600D-07, .2600D-07, .1200D-07,
31262 & .1200D-07, .2600D-09, .2600D-09, .9000D-10, .1500D-09,
31263 & .8000D-10, .5000D-14, .8000D-16, .0000D+00, .0000D+00,
31264 & 70*.0000D+00,
31265 & .0000D+00, .3000D-09, .1700D-09, .8000D-10, .1000D-13,
31266 & .1500D-09, .3000D-09, .1700D-09, .0000D+00, .0000D+00,
31267 & .0000D+00, .0000D+00, .0000D+00, .1000D-09, .0000D+00,
31268 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .1000D-09,
31269 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31270 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31271 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31272 & .9000D-11, .9000D-11, .9000D-11, .9000D-11, .1000D+19,
31273 & .1000D+19, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31274 & 40*.0000D+00,
31275 & .0000D+00, .0000D+00, .0000D+00 /
31276 DATA ( TAU ( I ), I = 184,210 ) /
31277 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31278 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31279 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31280 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31281 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31282 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31283 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31284 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31285 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00/
31286* Resonance width Gamma in GeV
31287 DATA (GA(K),K= 1,85) /
31288 & 30*.0000D+00,
31289 & .8500D-06, .1520D+00, .1520D+00, .1520D+00, .1000D-01,
31290 & .7900D-01, .7900D-01, .7900D-01, .7900D-01, .4500D+00,
31291 & .4500D+00, .4500D+00, .4500D+00, .1080D+00, .1080D+00,
31292 & .1080D+00, .1080D+00, .5000D-01, .5000D-01, .5000D-01,
31293 & .8500D-01, .1800D+00, .1150D+00, .1150D+00, .1150D+00,
31294 & .1150D+00, .2000D+00, .2000D+00, .2000D+00, .2000D+00,
31295 & .2000D+00, .2000D+00, .1000D+00, .1000D+00, .2000D+00,
31296 & .2000D+00, .1150D+00, .1150D+00, .1150D+00, .1150D+00,
31297 & .2000D+00, .2000D+00, .2000D+00, .2000D+00, .1000D+00,
31298 & .1000D+00, .2000D+00, .1000D+00, .1000D+00, .1000D+00,
31299 & .1000D+00, .1000D+00, .1000D+00, .1000D+00, .2000D+00 /
31300 DATA (GA(K),K= 86,183) /
31301 & .2000D+00, .2000D+00, .2000D+00, .1500D+00, .1500D+00,
31302 & .1500D+00, .1500D+00, .8500D-01, .1800D+00, .2000D-02,
31303 & .4000D-02, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31304 & .0000D+00, .0000D+00, .0000D+00, .3400D-01, .3400D-01,
31305 & .3600D-01, .9000D-02, .9000D-02, .0000D+00, .3400D-01,
31306 & .3400D-01, .3600D-01, .9000D-02, .9000D-02, .0000D+00,
31307 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31308 & .0000D+00, .0000D+00, .5000D-02, .2000D-02, .2000D-02,
31309 & .5000D-02, .2000D-02, .2000D-02, .2000D-03, .7000D-03,
31310 & 50*.0000D+00,
31311 & .3000D+00, .3000D+00, .3000D+00 /
31312 DATA ( GA ( I ), I = 184,210 ) /
31313 & 2.00000000000000D-01, 2.00000000000000D-01, 3.00000000000000D-01,
31314 & 3.00000000000000D-01, 3.00000000000000D-01, 2.70000000000000D-01,
31315 & 2.50000000000000D-01, 2.50000000000000D-01, 2.50000000000000D-01,
31316 & 2.50000000000000D-01, 1.50000000000000D-01, 1.50000000000000D-01,
31317 & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31318 & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31319 & 6.00000000000000D-02, 6.00000000000000D-02, 6.00000000000000D-02,
31320 & 6.00000000000000D-02, 5.50000000000000D-02, 5.50000000000000D-02,
31321 & 2.00000000000000D-01, 2.00000000000000D-01, 0.00000000000000D+00/
31322* Particle names
31323* S+1385+Sigma+(1385) L02030+Lambda0(2030)
31324* Rho77=Rho(770) Om783=Omega(783) K*14=K*(1420) and so on
31325* designation N*@@ means N*@1(@2)
31326 DATA (ANAME(K),K=1,85) /
31327 & 'P ','AP ','E- ','E+ ','NUE ',
31328 & 'ANUE ','GAM ','NEU ','ANEU ','MUE+ ',
31329 & 'MUE- ','K0L ','PI+ ','PI- ','K+ ',
31330 & 'K- ','LAM ','ALAM ','K0S ','SIGM- ',
31331 & 'SIGM+ ','SIGM0 ','PI0 ','K0 ','AK0 ',
31332 & 'BLANK ','BLANK ','BLANK ','BLANK ','BLANK ',
31333 & 'ETA550 ','RHO+77 ','RHO077 ','RHO-77 ','OM0783 ',
31334 & 'K*+892 ','K*0892 ','K*-892 ','AK*089 ','KA+125 ',
31335 & 'KA0125 ','KA-125 ','AKA012 ','K*+142 ','K*0142 ',
31336 & 'K*-142 ','AK*014 ','S+1385 ','S01385 ','S-1385 ',
31337 & 'L01820 ','L02030 ','N*++12 ','N*+ 12 ','N*012 ',
31338 & 'N*-12 ','N*++16 ','N*+16 ','N*016 ','N*-16 ',
31339 & 'N*+14 ','N*014 ','N*+15 ','N*015 ','N*+18 ',
31340 & 'N*018 ','AN--12 ','AN*-12 ','AN*012 ','AN*+12 ',
31341 & 'AN--16 ','AN*-16 ','AN*016 ','AN*+16 ','AN*-15 ',
31342 & 'AN*015 ','DE*=24 ','RPI+49 ','RPI049 ','RPI-49 ',
31343 & 'PIN++ ','PIN+0 ','PIN+- ','PIN-0 ','PPPI ' /
31344 DATA (ANAME(K),K=86,183) /
31345 & 'PNPI ','APPPI ','APNPI ','K+PPI ','K-PPI ',
31346 & 'K+NPI ','K-NPI ','S+1820 ','S-2030 ','ETA* ',
31347 & 'PHI ','TETA0 ','TETA- ','ASIG- ','ASIG0 ',
31348 & 'ASIG+ ','ATETA0 ','ATETA+ ','SIG*+ ','SIG*0 ',
31349 & 'SIG*- ','TETA*0 ','TETA* ','OMEGA- ','ASIG*- ',
31350 & 'ASIG*0 ','ASIG*+ ','ATET*0 ','ATET*+ ','OMEGA+ ',
31351 & 'D0 ','D+ ','D- ','AD0 ','F+ ',
31352 & 'F- ','ETAC ','D*0 ','D*+ ','D*- ',
31353 & 'AD*0 ','F*+ ','F*- ','PSI ','JPSI ',
31354 & 'TAU+ ','TAU- ','NUET ','ANUET ','NUEM ',
31355 & 'ANUEM ','C0+ ','A+ ','A0 ','C1++ ',
31356 & 'C1+ ','C10 ','S+ ','S0 ','T0 ',
31357 & 'XU++ ','XD+ ','XS+ ','AC0- ','AA- ',
31358 & 'AA0 ','AC1-- ','AC1- ','AC10 ','AS- ',
31359 & 'AS0 ','AT0 ','AXU-- ','AXD- ','AXS ',
31360 & 'C1*++ ','C1*+ ','C1*0 ','S*+ ','S*0 ',
31361 & 'T*0 ','XU*++ ','XD*+ ','XS*+ ','TETA++ ',
31362 & 'AC1*-- ','AC1*- ','AC1*0 ','AS*- ','AS*0 ',
31363 & 'AT*0 ','AXU*-- ','AXD*- ','AXS*- ','ATET-- ',
31364 & 'RO ','R+ ','R- ' /
31365 DATA ( ANAME ( I ), I = 184,210 ) /
31366 &'AN*-14 ','AN*014 ','PI+130 ','PI0130 ','PI-130 ','F01400 ',
31367 &'K*+146 ','K*-146 ','K*0146 ','AK0146 ','L01600 ','AL0160 ',
31368 &'S+1660 ','S01660 ','S-1660 ','AS-166 ','AS0166 ','AS+166 ',
31369 &'X01950 ','X-1950 ','AX0195 ','AX+195 ','OM-225 ','AOM+22 ',
31370 &'N*+14 ','N*014 ','BLANK '/
31371* Charge of particles and resonances
31372 DATA (IICH ( I ), I = 1,210 ) /
31373 & 1, -1, -1, 1, 0, 0, 0, 0, 0, 1, -1, 0, 1, -1, 1,
31374 & -1, 0, 0, 0, -1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31375 & 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0,
31376 & -1, 0, 1, 0, -1, 0, 0, 2, 1, 0, -1, 2, 1, 0, -1,
31377 & 1, 0, 1, 0, 1, 0, -2, -1, 0, 1, -2, -1, 0, 1, -1,
31378 & 0, 1, 1, 0, -1, 2, 1, 0, -1, 2, 1, 0, -1, 2, 0,
31379 & 1, -1, 1, -1, 0, 0, 0, -1, -1, 0, 1, 0, 1, 1, 0,
31380 & -1, 0, -1, -1, -1, 0, 1, 0, 1, 1, 0, 1, -1, 0, 1,
31381 & -1, 0, 0, 1, -1, 0, 1, -1, 0, 0, 1, -1, 0, 0, 0,
31382 & 0, 1, 1, 0, 2, 1, 0, 1, 0, 0, 2, 1, 1, -1, -1,
31383 & 0, -2, -1, 0, -1, 0, 0, -2, -1, -1, 2, 1, 0, 1, 0,
31384 & 0, 2, 1, 1, 2, -2, -1, 0, -1, 0, 0, -2, -1, -1, -2,
31385 & 0, 1, -1, -1, 0, 1, 0, -1, 0, 1, -1, 0, 0, 0, 0,
31386 & 1, 0, -1, -1, 0, 1, 0, -1, 0, 1, -1, 1, 1, 0, 0/
31387* Particle baryonic charges
31388 DATA (IIBAR ( I ), I = 1,210 ) /
31389 & 1, -1, 0, 0, 0, 0, 0, 1, -1, 0, 0, 0, 0, 0, 0,
31390 & 0, 1, -1, 0, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0,
31391 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31392 & 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
31393 & 1, 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31394 & -1, 2, 0, 0, 0, 1, 1, 1, 1, 2, 2, 0, 0, 1, 1,
31395 & 1, 1, 1, 1, 0, 0, 1, 1, -1, -1, -1, -1, -1, 1, 1,
31396 & 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, 0, 0, 0, 0, 0,
31397 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31398 & 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, -1, -1,
31399 & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 1, 1, 1, 1, 1,
31400 & 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31401 & 0, 0, 0, -1, -1, 0, 0, 0, 0, 0, 0, 0, 0, 1, -1,
31402 & 1, 1, 1, -1, -1, -1, 1, 1, -1, -1, 1, -1, 1, 1, 0/
31403* First number of decay channels used for resonances
31404* and decaying particles
31405 DATA K1/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 16, 17,
31406 & 18, 24, 30, 34, 38, 40, 41, 43, 44, 136, 138, 330, 327, 328,
31407 & 2*330, 46, 51, 52, 54, 55, 58,
31408* 50
31409 & 60, 62, 64, 66, 68, 70, 72, 74, 82, 90, 98, 106, 109, 112, 114,
31410 & 123, 140, 141, 143, 145, 146, 150, 157, 164, 168, 174, 180, 187,
31411 & 194, 202, 210, 211, 213, 215, 216, 220, 227, 234, 238, 245, 252,
31412* 85
31413 & 254, 255, 256, 257, 259, 262, 265, 267, 269, 272, 276, 279, 282,
31414 & 286, 290, 293, 299, 331, 335, 339, 340, 341, 343, 344, 345, 346,
31415 & 347, 350, 353, 356, 358, 360, 363, 366, 369, 372, 374, 376, 379,
31416 & 383, 385, 387, 391, 394, 397, 400, 402, 405, 408, 410, 412, 414,
31417 & 417, 420, 425, 430, 431, 432, 433, 434, 448, 452, 457, 458, 459,
31418 & 460, 461, 462, 466, 468, 470, 472, 486, 490, 495, 496, 497, 498,
31419 & 499, 500, 504, 506, 508, 510, 511, 512, 513, 514, 515, 516, 517,
31420 & 518, 519, 522, 523, 524, 525, 526, 527, 528, 529, 530, 531, 534,
31421 & 537, 539, 541, 547, 553, 558, 563, 568, 572, 573, 574, 575, 576,
31422 & 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, 589,
31423 & 590, 596, 602 /
31424* Last number of decay channels used for resonances
31425* and decaying particles
31426 DATA K2/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 15, 16, 17,
31427 & 23, 29, 31, 35, 39, 40, 42, 43, 45, 137, 139, 330, 327, 328,
31428 & 2* 330, 50, 51, 53, 54, 57,
31429* 50
31430 & 59, 61, 63, 65, 67, 69, 71, 73, 81, 89, 97, 105, 108, 111, 113,
31431 & 122, 135, 140, 142, 144, 145, 149, 156, 163, 167, 173, 179, 186,
31432 & 193, 201, 209, 210, 212, 214, 215, 219, 226, 233, 237, 244, 251,
31433* 85
31434 & 253, 254, 255, 256, 258, 261, 264, 266, 268, 271, 275, 278, 281,
31435 & 285, 289, 292, 298, 307, 334, 338, 339, 340, 342, 343, 344, 345,
31436 & 346, 349, 352, 355, 357, 359, 362, 365, 368, 371, 373, 375, 378,
31437 & 382, 384, 386, 390, 393, 396, 399, 401, 404, 407, 409, 411, 413,
31438 & 416, 419, 424, 429, 430, 431, 432, 433, 447, 451, 456, 457, 458,
31439 & 459, 460, 461, 465, 467, 469, 471, 485, 489, 494, 495, 496, 497,
31440 & 498, 499, 503, 505, 507, 509, 510, 511, 512, 513, 514, 515, 516,
31441 & 517, 518, 521, 522, 523, 524, 525, 526, 527, 528, 529, 530, 533,
31442 & 536, 538, 540, 546, 552, 557, 562, 567, 571, 572, 573, 574, 575,
31443 & 576, 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588,
31444 & 589, 595, 601, 602 /
31445
31446 END
31447
31448*$ CREATE DT_BLKD47.FOR
31449*COPY DT_BLKD47
31450*
31451*===blkd47=============================================================*
31452*
31453 BLOCK DATA DT_BLKD47
31454
31455 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31456 SAVE
31457
31458* HADRIN: decay channel information
31459 PARAMETER (IDMAX9=602)
31460 CHARACTER*8 ZKNAME
31461 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
31462
31463* Name of decay channel
31464* Designation N*@ means N*@1(1236)
31465* @1=# means ++, @1 = = means --
31466* Designation P+/0/- means Pi+/Pi0/Pi- , respectively
31467 DATA (ZKNAME(K),K= 1, 85) /
31468 & 'P ','AP ','E- ','E+ ','NUE ',
31469 & 'ANUE ','GAM ','PE-NUE ','APEANU ','EANUNU ',
31470 & 'E-NUAN ','3PI0 ','PI+-0 ','PIMUNU ','PIE-NU ',
31471 & 'MU+NUE ','MU-NUE ','MU+NUE ','PI+PI0 ','PI++- ',
31472 & 'PI+00 ','M+P0NU ','E+P0NU ','MU-NU ','PI-0 ',
31473 & 'PI+-- ','PI-00 ','M-P0NU ','E-P0NU ','PPI- ',
31474 & 'NPI0 ','PD-NUE ','PM-NUE ','APPI+ ','ANPI0 ',
31475 & 'APE+NU ','APM+NU ','PI+PI- ','PI0PI0 ','NPI- ',
31476 & 'PPI0 ','NPI+ ','LAGA ','GAGA ','GAE+E- ',
31477 & 'GAGA ','GAGAP0 ','PI000 ','PI+-0 ','PI+-GA ',
31478 & 'PI+0 ','PI+- ','PI00 ','PI-0 ','PI+-0 ',
31479 & 'PI+- ','PI0GA ','K+PI0 ','K0PI+ ','KOPI0 ',
31480 & 'K+PI- ','K-PI0 ','AK0PI- ','AK0PI0 ','K-PI+ ',
31481 & 'K+PI0 ','K0PI+ ','K0PI0 ','K+PI- ','K-PI0 ',
31482 & 'K0PI- ','AK0PI0 ','K-PI+ ','K+PI0 ','K0PI+ ',
31483 & 'K+89P0 ','K08PI+ ','K+RO77 ','K0RO+7 ','K+OM07 ',
31484 & 'K+E055 ','K0PI0 ','K+PI+ ','K089P0 ','K+8PI- ' /
31485 DATA (ZKNAME(K),K= 86,170) /
31486 & 'K0R077 ','K+R-77 ','K+R-77 ','K0OM07 ','K0E055 ',
31487 & 'K-PI0 ','K0PI- ','K-89P0 ','AK08P- ','K-R077 ',
31488 & 'AK0R-7 ','K-OM07 ','K-E055 ','AK0PI0 ','K-PI+ ',
31489 & 'AK08P0 ','K-8PI+ ','AK0R07 ','AK0OM7 ','AK0E05 ',
31490 & 'LA0PI+ ','SI0PI+ ','SI+PI0 ','LA0PI0 ','SI+PI- ',
31491 & 'SI-PI+ ','LA0PI- ','SI0PI- ','NEUAK0 ','PK- ',
31492 & 'SI+PI- ','SI0PI0 ','SI-PI+ ','LA0ET0 ','S+1PI- ',
31493 & 'S-1PI+ ','SO1PI0 ','NEUAK0 ','PK- ','LA0PI0 ',
31494 & 'LA0OM0 ','LA0RO0 ','SI+RO- ','SI-RO+ ','SI0RO0 ',
31495 & 'LA0ET0 ','SI0ET0 ','SI+PI- ','SI-PI+ ','SI0PI0 ',
31496 & 'K0S ','K0L ','K0S ','K0L ','P PI+ ',
31497 & 'P PI0 ','N PI+ ','P PI- ','N PI0 ','N PI- ',
31498 & 'P PI+ ','N*#PI0 ','N*+PI+ ','PRHO+ ','P PI0 ',
31499 & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ',
31500 & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ',
31501 & 'N*-PI+ ','PRHO- ','NRHO0 ','N PI- ','N*0PI- ',
31502 & 'N*-PI0 ','NRHO- ','PETA0 ','N*#PI- ','N*+PI0 ' /
31503 DATA (ZKNAME(K),K=171,255) /
31504 & 'N*0PI+ ','PRHO0 ','NRHO+ ','NETA0 ','N*+PI- ',
31505 & 'N*0PI0 ','N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ',
31506 & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ',
31507 & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ',
31508 & 'N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ','N PI+ ',
31509 & 'PRHO0 ','NRHO+ ','LAMK+ ','S+ K0 ','S0 K+ ',
31510 & 'PETA0 ','P PI- ','N PI0 ','PRHO- ','NRHO0 ',
31511 & 'LAMK0 ','S0 K0 ','S- K+ ','NETA/ ','APPI- ',
31512 & 'APPI0 ','ANPI- ','APPI+ ','ANPI0 ','ANPI+ ',
31513 & 'APPI- ','AN*=P0 ','AN*-P- ','APRHO- ','APPI0 ',
31514 & 'ANPI- ','AN*=P+ ','AN*-P0 ','AN*0P- ','APRHO0 ',
31515 & 'ANRHO- ','APPI+ ','ANPI0 ','AN*-P+ ','AN*0P0 ',
31516 & 'AN*+P- ','APRHO+ ','ANRHO0 ','ANPI+ ','AN*0P+ ',
31517 & 'AN*+P0 ','ANRHO+ ','APPI0 ','ANPI- ','AN*=P+ ',
31518 & 'AN*-P0 ','AN*0P- ','APRHO0 ','ANRHO- ','APPI+, ',
31519 & 'ANPI0 ','AN*-P+ ','AN*0P0 ','AN*+P- ','APRHO+ ',
31520 & 'ANRHO0 ','PN*014 ','NN*=14 ','PI+0 ','PI+- ' /
31521 DATA (ZKNAME(K),K=256,340) /
31522 & 'PI-0 ','P+0 ','N++ ','P+- ','P00 ',
31523 & 'N+0 ','N+- ','N00 ','P-0 ','N-0 ',
31524 & 'P-- ','PPPI0 ','PNPI+ ','PNPI0 ','PPPI- ',
31525 & 'NNPI+ ','APPPI0 ','APNPI+ ','ANNPI0 ','ANPPI- ',
31526 & 'APNPI0 ','APPPI- ','ANNPI- ','K+PPI0 ','K+NPI+ ',
31527 & 'K0PPI0 ','K-PPI0 ','K-NPI+ ','AKPPI- ','AKNPI0 ',
31528 & 'K+NPI0 ','K+PPI- ','K0PPI0 ','K0NPI+ ','K-NPI0 ',
31529 & 'K-PPI- ','AKNPI- ','PAK0 ','SI+PI0 ','SI0PI+ ',
31530 & 'SI+ETA ','S+1PI0 ','S01PI+ ','NEUK- ','LA0PI- ',
31531 & 'SI-OM0 ','LA0RO- ','SI0RO- ','SI-RO0 ','SI-ET0 ',
31532 & 'SI0PI- ','SI-0 ','BLANC ','BLANC ','BLANC ',
31533 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31534 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31535 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31536 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31537 & 'EPI+- ','EPI00 ','GAPI+- ','GAGA* ','K+- ',
31538 & 'KLKS ','PI+-0 ','EGA ','LPI0 ','LPI ' /
31539 DATA (ZKNAME(K),K=341,425) /
31540 & 'APPI0 ','ANPI- ','ALAGA ','ANPI ','ALPI0 ',
31541 & 'ALPI+ ','LAPI+ ','SI+PI0 ','SI0PI+ ','LAPI0 ',
31542 & 'SI+PI- ','SI-PI+ ','LAPI- ','SI-PI0 ','SI0PI- ',
31543 & 'TE0PI0 ','TE-PI+ ','TE0PI- ','TE-PI0 ','TE0PI ',
31544 & 'TE-PI ','LAK- ','ALPI- ','AS-PI0 ','AS0PI- ',
31545 & 'ALPI0 ','AS+PI- ','AS-PI+ ','ALPI+ ','AS+PI0 ',
31546 & 'AS0PI+ ','AT0PI0 ','AT+PI- ','AT0PI+ ','AT+PI0 ',
31547 & 'AT0PI ','AT+PI ','ALK+ ','K-PI+ ','K-PI+0 ',
31548 & 'K0PI+- ','K0PI0 ','K-PI++ ','AK0PI+ ','K+PI-- ',
31549 & 'K0PI- ','K+PI- ','K+PI-0 ','AKPI-+ ','AK0PI0 ',
31550 & 'ETAPIF ','K++- ','K+AK0 ','ETAPI- ','K--+ ',
31551 & 'K-K0 ','PI00 ','PI+- ','GAGA ','D0PI0 ',
31552 & 'D0GA ','D0PI+ ','D+PI0 ','DFGA ','AD0PI- ',
31553 & 'D-PI0 ','D-GA ','AD0PI0 ','AD0GA ','F+GA ',
31554 & 'F+GA ','F-GA ','F-GA ','PSPI+- ','PSPI00 ',
31555 & 'PSETA ','E+E- ','MUE+- ','PI+-0 ','M+NN ',
31556 & 'E+NN ','RHO+NT ','PI+ANT ','K*+ANT ','M-NN ' /
31557 DATA (ZKNAME(K),K=426,510) /
31558 & 'E-NN ','RHO-NT ','PI-NT ','K*-NT ','NUET ',
31559 & 'ANUET ','NUEM ','ANUEM ','SI+ETA ','SI+ET* ',
31560 & 'PAK0 ','TET0K+ ','SI*+ET ','N*+AK0 ','N*++K- ',
31561 & 'LAMRO+ ','SI0RO+ ','SI+RO0 ','SI+OME ','PAK*0 ',
31562 & 'N*+AK* ','N*++K* ','SI+AK0 ','TET0PI ','SI+AK* ',
31563 & 'TET0RO ','SI0AK* ','SI+K*- ','TET0OM ','TET-RO ',
31564 & 'SI*0AK ','C0+PI+ ','C0+PI0 ','C0+PI- ','A+GAM ',
31565 & 'A0GAM ','TET0AK ','TET0K* ','OM-RO+ ','OM-PI+ ',
31566 & 'C1++AK ','A+PI+ ','C0+AK0 ','A0PI+ ','A+AK0 ',
31567 & 'T0PI+ ','ASI-ET ','ASI-E* ','APK0 ','ATET0K ',
31568 & 'ASI*-E ','AN*-K0 ','AN*--K ','ALAMRO ','ASI0RO ',
31569 & 'ASI-RO ','ASI-OM ','APK*0 ','AN*-K* ','AN*--K ',
31570 & 'ASI-K0 ','ATETPI ','ASI-K* ','ATETRO ','ASI0K* ',
31571 & 'ASI-K* ','ATE0OM ','ATE+RO ','ASI*0K ','AC-PI- ',
31572 & 'AC-PI0 ','AC-PI+ ','AA-GAM ','AA0GAM ','ATET0K ',
31573 & 'ATE0K* ','AOM+RO ','AOM+PI ','AC1--K ','AA-PI- ',
31574 & 'AC0-K0 ','AA0PI- ','AA-K0 ','AT0PI- ','C1++GA ' /
31575 DATA (ZKNAME(K),K=511,540) /
31576 & 'C1++GA ','C10GAM ','S+GAM ','S0GAM ','T0GAM ',
31577 & 'XU++GA ','XD+GAM ','XS+GAM ','A+AKPI ','T02PI+ ',
31578 & 'C1++2K ','AC1--G ','AC1-GA ','AC10GA ','AS-GAM ',
31579 & 'AS0GAM ','AT0GAM ','AXU--G ','AXD-GA ','AXS-GA ',
31580 & 'AA-KPI ','AT02PI ','AC1--K ','RH-PI+ ','RH+PI- ',
31581 & 'RH3PI0 ','RH0PI+ ','RH+PI0 ','RH0PI- ','RH-PI0 ' /
31582 DATA (ZKNAME(I),I=541,602)/
31583 & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHO0','ANRHO-','ANETA ',
31584 & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0','RH0PI+','RH+PI0',
31585 & '3PI+00','3PI-++','F0PI+ ','RH+PI-','RH0PI0','3PI000','3PI0+-',
31586 & 'F0PI0 ','RH0PI-','RH-PI0','3PI-00','3PI--+','F0PI- ','PI0PI0',
31587 & 'PI+PI-','K+K- ','K0AK0 ','L01600','AL0160','K*+146','K*-146',
31588 & 'K*0146','AK0146','S+1660','S01660','S-1660','AS-166','AS0166',
31589 & 'AS+166','X01690','X-1690','AX0169','AX+169','OM-225','AOM+22',
31590 & 'N*PPI0','N*NPI+','N*P2P0','N*PP+-','N*D+P0','N*D0P+','N*NPI0',
31591 & 'N*PPI-','N*N2P0','N*NP+-','N*D+P-','N*D0P0','BLANK '/
31592* Weight of decay channel
31593 DATA (WT(K),K= 1, 85) /
31594 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31595 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31596 & .1000D+01, .2100D+00, .1200D+00, .2700D+00, .4000D+00,
31597 & .1000D+01, .1000D+01, .6400D+00, .2100D+00, .6000D-01,
31598 & .2000D-01, .3000D-01, .4000D-01, .6400D+00, .2100D+00,
31599 & .6000D-01, .2000D-01, .3000D-01, .4000D-01, .6400D+00,
31600 & .3600D+00, .0000D+00, .0000D+00, .6400D+00, .3600D+00,
31601 & .0000D+00, .0000D+00, .6900D+00, .3100D+00, .1000D+01,
31602 & .5200D+00, .4800D+00, .1000D+01, .9900D+00, .1000D-01,
31603 & .3800D+00, .3000D-01, .3000D+00, .2400D+00, .5000D-01,
31604 & .1000D+01, .1000D+01, .0000D+00, .1000D+01, .9000D+00,
31605 & .1000D-01, .9000D-01, .3300D+00, .6700D+00, .3300D+00,
31606 & .6700D+00, .3300D+00, .6700D+00, .3300D+00, .6700D+00,
31607 & .3300D+00, .6700D+00, .3300D+00, .6700D+00, .3300D+00,
31608 & .6700D+00, .3300D+00, .6700D+00, .1900D+00, .3800D+00,
31609 & .9000D-01, .2000D+00, .3000D-01, .4000D-01, .5000D-01,
31610 & .2000D-01, .1900D+00, .3800D+00, .9000D-01, .2000D+00 /
31611 DATA (WT(K),K= 86,170) /
31612 & .3000D-01, .4000D-01, .5000D-01, .2000D-01, .1900D+00,
31613 & .3800D+00, .9000D-01, .2000D+00, .3000D-01, .4000D-01,
31614 & .5000D-01, .2000D-01, .1900D+00, .3800D+00, .9000D-01,
31615 & .2000D+00, .3000D-01, .4000D-01, .5000D-01, .2000D-01,
31616 & .8800D+00, .6000D-01, .6000D-01, .8800D+00, .6000D-01,
31617 & .6000D-01, .8800D+00, .1200D+00, .1900D+00, .1900D+00,
31618 & .1600D+00, .1600D+00, .1700D+00, .3000D-01, .3000D-01,
31619 & .3000D-01, .4000D-01, .1000D+00, .1000D+00, .2000D+00,
31620 & .1200D+00, .1000D+00, .4000D-01, .4000D-01, .5000D-01,
31621 & .7500D-01, .7500D-01, .3000D-01, .3000D-01, .4000D-01,
31622 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01,
31623 & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31624 & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31625 & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31626 & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31627 & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31628 & .2700D+00, .3000D+00, .4000D+00, .2000D+00, .1250D+00 /
31629 DATA (WT(K),K=171,255) /
31630 & .7500D-01, .7500D-01, .1250D+00, .4000D+00, .7500D-01,
31631 & .1250D+00, .2000D+00, .1250D+00, .7500D-01, .1800D+00,
31632 & .3700D+00, .1300D+00, .8000D-01, .4000D-01, .7000D-01,
31633 & .1300D+00, .3700D+00, .1800D+00, .4000D-01, .8000D-01,
31634 & .1300D+00, .1300D+00, .7000D-01, .7000D-01, .1300D+00,
31635 & .2300D+00, .4700D+00, .5000D-01, .2000D-01, .1000D-01,
31636 & .2000D-01, .1300D+00, .7000D-01, .4700D+00, .2300D+00,
31637 & .5000D-01, .1000D-01, .2000D-01, .2000D-01, .1000D+01,
31638 & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31639 & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31640 & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31641 & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31642 & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31643 & .2700D+00, .3000D+00, .1800D+00, .3700D+00, .1300D+00,
31644 & .8000D-01, .4000D-01, .7000D-01, .1300D+00, .3700D+00,
31645 & .1800D+00, .4000D-01, .8000D-01, .1300D+00, .1300D+00,
31646 & .7000D-01, .5000D+00, .5000D+00, .1000D+01, .1000D+01 /
31647 DATA (WT(K),K=256,340) /
31648 & .1000D+01, .8000D+00, .2000D+00, .6000D+00, .3000D+00,
31649 & .1000D+00, .6000D+00, .3000D+00, .1000D+00, .8000D+00,
31650 & .2000D+00, .3300D+00, .6700D+00, .6600D+00, .1700D+00,
31651 & .1700D+00, .3200D+00, .1700D+00, .3200D+00, .1900D+00,
31652 & .3300D+00, .3300D+00, .3400D+00, .3000D+00, .5000D-01,
31653 & .6500D+00, .3800D+00, .1200D+00, .3800D+00, .1200D+00,
31654 & .3800D+00, .1200D+00, .3800D+00, .1200D+00, .3000D+00,
31655 & .5000D-01, .6500D+00, .3800D+00, .2500D+00, .2500D+00,
31656 & .2000D-01, .5000D-01, .5000D-01, .2000D+00, .2000D+00,
31657 & .1200D+00, .1000D+00, .7000D-01, .7000D-01, .1400D+00,
31658 & .5000D-01, .5000D-01, .1000D+01, .1000D+01, .1000D+01,
31659 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31660 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31661 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31662 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31663 & .4800D+00, .2400D+00, .2600D+00, .2000D-01, .4700D+00,
31664 & .3500D+00, .1500D+00, .3000D-01, .1000D+01, .1000D+01 /
31665 DATA (WT(K),K=341,425) /
31666 & .5200D+00, .4800D+00, .1000D+01, .1000D+01, .1000D+01,
31667 & .1000D+01, .9000D+00, .5000D-01, .5000D-01, .9000D+00,
31668 & .5000D-01, .5000D-01, .9000D+00, .5000D-01, .5000D-01,
31669 & .3300D+00, .6700D+00, .6700D+00, .3300D+00, .2500D+00,
31670 & .2500D+00, .5000D+00, .9000D+00, .5000D-01, .5000D-01,
31671 & .9000D+00, .5000D-01, .5000D-01, .9000D+00, .5000D-01,
31672 & .5000D-01, .3300D+00, .6700D+00, .6700D+00, .3300D+00,
31673 & .2500D+00, .2500D+00, .5000D+00, .1000D+00, .5000D+00,
31674 & .1600D+00, .2400D+00, .7000D+00, .3000D+00, .7000D+00,
31675 & .3000D+00, .1000D+00, .5000D+00, .1600D+00, .2400D+00,
31676 & .3000D+00, .4000D+00, .3000D+00, .3000D+00, .4000D+00,
31677 & .3000D+00, .4900D+00, .4900D+00, .2000D-01, .5500D+00,
31678 & .4500D+00, .6800D+00, .3000D+00, .2000D-01, .6800D+00,
31679 & .3000D+00, .2000D-01, .5500D+00, .4500D+00, .9000D+00,
31680 & .1000D+00, .9000D+00, .1000D+00, .6000D+00, .3000D+00,
31681 & .1000D+00, .1000D+00, .1000D+00, .8000D+00, .2800D+00,
31682 & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .2800D+00 /
31683 DATA (WT(K),K=426,510) /
31684 & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .1000D+01,
31685 & .1000D+01, .1000D+01, .1000D+01, .2000D-01, .3000D-01,
31686 & .7000D-01, .2000D-01, .2000D-01, .4000D-01, .1300D+00,
31687 & .7000D-01, .6000D-01, .6000D-01, .2000D+00, .1400D+00,
31688 & .4000D-01, .1000D+00, .2500D+00, .3000D-01, .3000D+00,
31689 & .4200D+00, .2200D+00, .3500D+00, .1900D+00, .1600D+00,
31690 & .8000D-01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31691 & .1000D+01, .3700D+00, .2000D+00, .3600D+00, .7000D-01,
31692 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00,
31693 & .5000D+00, .2000D-01, .3000D-01, .7000D-01, .2000D-01,
31694 & .2000D-01, .4000D-01, .1300D+00, .7000D-01, .6000D-01,
31695 & .6000D-01, .2000D+00, .1400D+00, .4000D-01, .1000D+00,
31696 & .2500D+00, .3000D-01, .3000D+00, .4200D+00, .2200D+00,
31697 & .3500D+00, .1900D+00, .1600D+00, .8000D-01, .1000D+01,
31698 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .3700D+00,
31699 & .2000D+00, .3600D+00, .7000D-01, .5000D+00, .5000D+00,
31700 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01 /
31701 DATA (WT(K),K=511,540) /
31702 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31703 & .1000D+01, .1000D+01, .1000D+01, .3000D+00, .3000D+00,
31704 & .4000D+00, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31705 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31706 & .3000D+00, .3000D+00, .4000D+00, .3300D+00, .3300D+00,
31707 & .3400D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00 /
31708C
31709 DATA (WT(I),I=541,602) / .0D+00, .3334D+00, .2083D+00, 2*.125D+00,
31710 & .2083D+00, .0D+00, .125D+00, .2083D+00, .3334D+00, .2083D+00,
31711 & .125D+00, 0.2D+00, 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00,
31712 & 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, 0.2D+00, 0.3D+00,
31713 & 0.3D+00, 0.0D+00, 0.31D+00, 0.62D+00, 0.035D+00, 0.035D+00,
31714 & 18*1.D+00, 0.5D+00, 0.16D+00, 2*0.12D+00, 2*0.05D+00, 0.5D+00,
31715 & 0.16D+00, 2*0.12D+00, 2*0.05D+00, 1.D+00 /
31716* Particle numbers in decay channel
31717 DATA (NZK(K,1),K= 1,170) /
31718 & 1, 2, 3, 4, 5, 6, 7, 1, 2, 4,
31719 & 3, 23, 13, 13, 13, 10, 11, 10, 13, 13,
31720 & 13, 10, 4, 11, 14, 14, 14, 11, 3, 1,
31721 & 8, 1, 1, 2, 9, 2, 2, 13, 23, 8,
31722 & 1, 8, 17, 7, 7, 7, 23, 23, 13, 13,
31723 & 13, 13, 23, 14, 13, 13, 23, 15, 24, 24,
31724 & 15, 16, 25, 25, 16, 15, 24, 24, 15, 16,
31725 & 24, 25, 16, 15, 24, 36, 37, 15, 24, 15,
31726 & 15, 24, 15, 37, 36, 24, 15, 24, 24, 16,
31727 & 24, 38, 39, 16, 25, 16, 16, 25, 16, 39,
31728 & 38, 25, 16, 25, 25, 17, 22, 21, 17, 21,
31729 & 20, 17, 22, 8, 1, 21, 22, 20, 17, 48,
31730 & 50, 49, 8, 1, 17, 17, 17, 21, 20, 22,
31731 & 17, 22, 21, 20, 22, 19, 12, 19, 12, 1,
31732 & 1, 8, 1, 8, 8, 1, 53, 54, 1, 1,
31733 & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55,
31734 & 56, 1, 8, 8, 55, 56, 8, 1, 53, 54 /
31735 DATA (NZK(K,1),K=171,340) /
31736 & 55, 1, 8, 8, 54, 55, 56, 1, 8, 1,
31737 & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55,
31738 & 56, 1, 8, 1, 8, 1, 8, 17, 21, 22,
31739 & 1, 1, 8, 1, 8, 17, 22, 20, 8, 2,
31740 & 2, 9, 2, 9, 9, 2, 67, 68, 2, 2,
31741 & 9, 67, 68, 69, 2, 9, 2, 9, 68, 69,
31742 & 70, 2, 9, 9, 69, 70, 9, 2, 9, 67,
31743 & 68, 69, 2, 9, 2, 9, 68, 69, 70, 2,
31744 & 9, 1, 8, 13, 13, 14, 1, 8, 1, 1,
31745 & 8, 8, 8, 1, 8, 1, 1, 1, 1, 1,
31746 & 8, 2, 2, 9, 9, 2, 2, 9, 15, 15,
31747 & 24, 16, 16, 25, 25, 15, 15, 24, 24, 16,
31748 & 16, 25, 1, 21, 22, 21, 48, 49, 8, 17,
31749 & 20, 17, 22, 20, 20, 22, 20, 0, 0, 0,
31750 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31751 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31752 & 31, 31, 13, 7, 15, 12, 13, 31, 17, 17 /
31753 DATA (NZK(K,1),K=341,510) /
31754 & 2, 9, 18, 9, 18, 18, 17, 21, 22, 17,
31755 & 21, 20, 17, 20, 22, 97, 98, 97, 98, 97,
31756 & 98, 17, 18, 99, 100, 18, 101, 99, 18, 101,
31757 & 100, 102, 103, 102, 103, 102, 103, 18, 16, 16,
31758 & 24, 24, 16, 25, 15, 24, 15, 15, 25, 25,
31759 & 31, 15, 15, 31, 16, 16, 23, 13, 7, 116,
31760 & 116, 116, 117, 117, 119, 118, 118, 119, 119, 120,
31761 & 120, 121, 121, 130, 130, 130, 4, 10, 13, 10,
31762 & 4, 32, 13, 36, 11, 3, 34, 14, 38, 133,
31763 & 134, 135, 136, 21, 21, 1, 97, 104, 54, 53,
31764 & 17, 22, 21, 21, 1, 54, 53, 21, 97, 21,
31765 & 97, 22, 21, 97, 98, 105, 137, 137, 137, 138,
31766 & 139, 97, 97, 109, 109, 140, 138, 137, 139, 138,
31767 & 145, 99, 99, 2, 102, 110, 68, 67, 18, 100,
31768 & 99, 99, 2, 68, 67, 99, 102, 99, 102, 100,
31769 & 99, 102, 103, 111, 149, 149, 149, 150, 151, 113,
31770 & 113, 115, 115, 152, 150, 149, 151, 150, 157, 140 /
31771 DATA (NZK(K,1),K=511,540) /
31772 & 141, 142, 143, 144, 145, 146, 147, 148, 138, 145,
31773 & 140, 152, 153, 154, 155, 156, 157, 158, 159, 160,
31774 & 150, 157, 152, 34, 32, 33, 33, 32, 33, 34 /
31775 DATA (NZK(I,1),I=541,602) / 2, 67, 68, 69, 2, 9, 9, 68, 69,
31776 & 70, 2, 9, 33, 32, 13, 14, 189, 32, 34, 23, 23, 189, 33, 34, 14,
31777 & 14, 189, 23, 13, 15, 24, 36, 38, 37, 39, 194, 195, 196, 197,
31778 & 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 1, 8, 1, 1, 54,
31779 & 55, 8, 1, 8, 8, 54, 55, 210/
31780 DATA (NZK(K,2),K= 1,170) /
31781 & 0, 0, 0, 0, 0, 0, 0, 3, 4, 6,
31782 & 5, 23, 14, 11, 3, 5, 5, 5, 23, 13,
31783 & 23, 23, 23, 5, 23, 13, 23, 23, 23, 14,
31784 & 23, 3, 11, 13, 23, 4, 10, 14, 23, 14,
31785 & 23, 13, 7, 7, 4, 7, 7, 23, 14, 14,
31786 & 23, 14, 23, 23, 14, 14, 7, 23, 13, 23,
31787 & 14, 23, 14, 23, 13, 23, 13, 23, 14, 23,
31788 & 14, 23, 13, 23, 13, 23, 13, 33, 32, 35,
31789 & 31, 23, 14, 23, 14, 33, 34, 35, 31, 23,
31790 & 14, 23, 14, 33, 34, 35, 31, 23, 13, 23,
31791 & 13, 33, 32, 35, 31, 13, 13, 23, 23, 14,
31792 & 13, 14, 14, 25, 16, 14, 23, 13, 31, 14,
31793 & 13, 23, 25, 16, 23, 35, 33, 34, 32, 33,
31794 & 31, 31, 14, 13, 23, 0, 0, 0, 0, 13,
31795 & 23, 13, 14, 23, 14, 13, 23, 13, 78, 23,
31796 & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23,
31797 & 13, 80, 79, 14, 14, 23, 80, 31, 14, 23 /
31798 DATA (NZK(K,2),K=171,340) /
31799 & 13, 79, 78, 31, 14, 23, 13, 80, 79, 23,
31800 & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23,
31801 & 13, 80, 79, 23, 13, 33, 32, 15, 24, 15,
31802 & 31, 14, 23, 34, 33, 24, 24, 15, 31, 14,
31803 & 23, 14, 13, 23, 13, 14, 23, 14, 80, 23,
31804 & 14, 13, 23, 14, 79, 80, 13, 23, 13, 23,
31805 & 14, 78, 79, 13, 13, 23, 78, 23, 14, 13,
31806 & 23, 14, 79, 80, 13, 23, 13, 23, 14, 78,
31807 & 79, 62, 61, 23, 14, 23, 13, 13, 13, 23,
31808 & 13, 13, 23, 14, 14, 14, 1, 8, 8, 1,
31809 & 8, 1, 8, 8, 1, 8, 1, 8, 1, 8,
31810 & 1, 1, 8, 1, 8, 8, 1, 1, 8, 8,
31811 & 1, 8, 25, 23, 13, 31, 23, 13, 16, 14,
31812 & 35, 34, 34, 33, 31, 14, 23, 0, 0, 0,
31813 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31814 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31815 & 13, 23, 14, 7, 16, 19, 14, 7, 23, 14 /
31816 DATA (NZK(K,2),K=341,510) /
31817 & 23, 14, 7, 13, 23, 13, 13, 23, 13, 23,
31818 & 14, 13, 14, 23, 14, 23, 13, 14, 23, 14,
31819 & 23, 16, 14, 23, 14, 23, 14, 13, 13, 23,
31820 & 13, 23, 14, 13, 23, 13, 23, 15, 13, 13,
31821 & 13, 23, 13, 13, 14, 14, 14, 14, 14, 23,
31822 & 13, 16, 25, 14, 15, 24, 23, 14, 7, 23,
31823 & 7, 13, 23, 7, 14, 23, 7, 23, 7, 7,
31824 & 7, 7, 7, 13, 23, 31, 3, 11, 14, 135,
31825 & 5, 134, 134, 134, 136, 6, 133, 133, 133, 0,
31826 & 0, 0, 0, 31, 95, 25, 15, 31, 95, 16,
31827 & 32, 32, 33, 35, 39, 39, 38, 25, 13, 39,
31828 & 32, 39, 38, 35, 32, 39, 13, 23, 14, 7,
31829 & 7, 25, 37, 32, 13, 25, 13, 25, 13, 25,
31830 & 13, 31, 95, 24, 16, 31, 24, 15, 34, 34,
31831 & 33, 35, 37, 37, 36, 24, 14, 37, 34, 37,
31832 & 36, 35, 34, 37, 14, 23, 13, 7, 7, 24,
31833 & 39, 34, 14, 24, 14, 24, 14, 24, 14, 7 /
31834 DATA (NZK(K,2),K=511,540) /
31835 & 7, 7, 7, 7, 7, 7, 7, 7, 25, 13,
31836 & 25, 7, 7, 7, 7, 7, 7, 7, 7, 7,
31837 & 24, 14, 24, 13, 14, 23, 13, 23, 14, 23 /
31838 DATA (NZK(I,2),I=541,602) / 31, 13, 23, 14, 79, 80, 31, 13, 23,
31839 & 14, 78, 79, 13, 23, 23, 13, 13, 14, 13, 23, 13, 23, 14, 23, 23,
31840 & 14, 14, 23, 14, 16, 25,
31841 & 4*23, 14*0, 23, 13, 23, 13, 23, 13, 23, 14,
31842 & 23, 13, 14, 23, 0 /
31843 DATA (NZK(K,3),K= 1,170) /
31844 & 0, 0, 0, 0, 0, 0, 0, 5, 6, 5,
31845 & 6, 23, 23, 5, 5, 0, 0, 0, 0, 14,
31846 & 23, 5, 5, 0, 0, 14, 23, 5, 5, 0,
31847 & 0, 5, 5, 0, 0, 5, 5, 0, 0, 0,
31848 & 0, 0, 0, 0, 3, 0, 7, 23, 23, 7,
31849 & 0, 0, 0, 0, 23, 0, 0, 0, 0, 0,
31850 & 110*0 /
31851 DATA (NZK(K,3),K=171,340) /
31852 & 80*0,
31853 & 0, 0, 0, 0, 0, 0, 23, 13, 14, 23,
31854 & 23, 14, 23, 23, 23, 14, 23, 13, 23, 14,
31855 & 13, 23, 13, 23, 14, 23, 14, 14, 23, 13,
31856 & 13, 23, 13, 14, 23, 23, 14, 23, 13, 23,
31857 & 14, 14, 0, 0, 0, 0, 0, 0, 0, 0,
31858 & 30*0,
31859 & 14, 23, 7, 0, 0, 0, 23, 0, 0, 0 /
31860 DATA (NZK(K,3),K=341,510) /
31861 & 30*0,
31862 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 23,
31863 & 14, 0, 13, 0, 14, 0, 0, 23, 13, 0,
31864 & 0, 15, 0, 0, 16, 0, 0, 0, 0, 0,
31865 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31866 & 0, 0, 0, 14, 23, 0, 0, 0, 23, 134,
31867 & 134, 0, 0, 0, 133, 133, 0, 0, 0, 0,
31868 & 80*0 /
31869 DATA (NZK(K,3),K=511,540) /
31870 & 0, 0, 0, 0, 0, 0, 0, 0, 13, 13,
31871 & 25, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31872 & 14, 14, 24, 0, 0, 0, 0, 0, 0, 0 /
31873 DATA (NZK(I,3),I=541,602) / 12*0, 2*0, 23, 13, 0, 2*0, 23, 14, 0,
31874 & 2*0, 23, 13, 0, 4*0, 18*0, 2*0, 23, 14, 2*0, 2*0, 23, 14, 2*0, 0/
31875
31876 END
31877
31878*$ CREATE DT_BDEVAP.FOR
31879*COPY DT_BDEVAP
31880*
31881*=== bdevap ===========================================================*
31882*
31883 BLOCK DATA DT_BDEVAP
31884
31885C INCLUDE '(DBLPRC)'
31886* DBLPRC.ADD
31887 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31888 SAVE
31889* (original name: GLOBAL)
31890 PARAMETER ( KALGNM = 2 )
31891 PARAMETER ( ANGLGB = 5.0D-16 )
31892 PARAMETER ( ANGLSQ = 2.5D-31 )
31893 PARAMETER ( AXCSSV = 0.2D+16 )
31894 PARAMETER ( ANDRFL = 1.0D-38 )
31895 PARAMETER ( AVRFLW = 1.0D+38 )
31896 PARAMETER ( AINFNT = 1.0D+30 )
31897 PARAMETER ( AZRZRZ = 1.0D-30 )
31898 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
31899 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
31900 PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
31901 PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
31902 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
31903 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
31904 PARAMETER ( CSNNRM = 2.0D-15 )
31905 PARAMETER ( DMXTRN = 1.0D+08 )
31906 PARAMETER ( ZERZER = 0.D+00 )
31907 PARAMETER ( ONEONE = 1.D+00 )
31908 PARAMETER ( TWOTWO = 2.D+00 )
31909 PARAMETER ( THRTHR = 3.D+00 )
31910 PARAMETER ( FOUFOU = 4.D+00 )
31911 PARAMETER ( FIVFIV = 5.D+00 )
31912 PARAMETER ( SIXSIX = 6.D+00 )
31913 PARAMETER ( SEVSEV = 7.D+00 )
31914 PARAMETER ( EIGEIG = 8.D+00 )
31915 PARAMETER ( ANINEN = 9.D+00 )
31916 PARAMETER ( TENTEN = 10.D+00 )
31917 PARAMETER ( HLFHLF = 0.5D+00 )
31918 PARAMETER ( ONETHI = ONEONE / THRTHR )
31919 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
31920 PARAMETER ( ONEFOU = ONEONE / FOUFOU )
31921 PARAMETER ( THRTWO = THRTHR / TWOTWO )
31922 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
31923 PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
31924 PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
31925 PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
31926 PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
31927 PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
31928 PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
31929 PARAMETER ( EULERO = 0.577215664901532860606512 D+00 )
31930 PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 )
31931 PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 )
31932 PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 )
31933 PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
31934 PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
31935 PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
31936 PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
31937 PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
31938 PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
31939 PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
31940 PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
31941 PARAMETER ( CLIGHT = 2.99792458 D+10 )
31942 PARAMETER ( AVOGAD = 6.0221367 D+23 )
31943 PARAMETER ( BOLTZM = 1.380658 D-23 )
31944 PARAMETER ( AMELGR = 9.1093897 D-28 )
31945 PARAMETER ( PLCKBR = 1.05457266 D-27 )
31946 PARAMETER ( ELCCGS = 4.8032068 D-10 )
31947 PARAMETER ( ELCMKS = 1.60217733 D-19 )
31948 PARAMETER ( AMUGRM = 1.6605402 D-24 )
31949 PARAMETER ( AMMUMU = 0.113428913 D+00 )
31950 PARAMETER ( AMPRMU = 1.007276470 D+00 )
31951 PARAMETER ( AMNEMU = 1.008664904 D+00 )
31952 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
31953 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
31954 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
31955 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
31956 PARAMETER ( PLABRC = 0.197327053 D+00 )
31957 PARAMETER ( AMELCT = 0.51099906 D-03 )
31958 PARAMETER ( AMUGEV = 0.93149432 D+00 )
31959 PARAMETER ( AMMUON = 0.105658389 D+00 )
31960 PARAMETER ( AMPRTN = 0.93827231 D+00 )
31961 PARAMETER ( AMNTRN = 0.93956563 D+00 )
31962 PARAMETER ( AMDEUT = 1.87561339 D+00 )
31963 PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
31964 & * 1.D-09 )
31965 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
31966 PARAMETER ( BLTZMN = 8.617385 D-14 )
31967 PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
31968 PARAMETER ( GFOHB3 = 1.16639 D-05 )
31969 PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
31970 PARAMETER ( SIN2TW = 0.2319 D+00 )
31971 PARAMETER ( GEVMEV = 1.0 D+03 )
31972 PARAMETER ( EMVGEV = 1.0 D-03 )
31973 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
31974 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
31975 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
31976 LOGICAL LGBIAS, LGBANA
31977 COMMON /FKGLOB/ LGBIAS, LGBANA
31978C INCLUDE '(DIMPAR)'
31979* DIMPAR.ADD
31980 PARAMETER ( MXXRGN = 5000 )
31981 PARAMETER ( MXXMDF = 82 )
31982 PARAMETER ( MXXMDE = 54 )
31983 PARAMETER ( MFSTCK = 1000 )
31984 PARAMETER ( MESTCK = 100 )
31985 PARAMETER ( NELEMX = 80 )
31986 PARAMETER ( MPDPDX = 8 )
31987 PARAMETER ( ICOMAX = 180 )
31988 PARAMETER ( NSTBIS = 304 )
31989 PARAMETER ( IDMAXP = 220 )
31990 PARAMETER ( IDMXDC = 640 )
31991 PARAMETER ( MKBMX1 = 1 )
31992 PARAMETER ( MKBMX2 = 1 )
31993C INCLUDE '(IOUNIT)'
31994* IOUNIT.ADD
31995 PARAMETER ( LUNIN = 5 )
31996 PARAMETER ( LUNOUT = 6 )
31997**sr 19.5. set error output-unit from 15 to 6
31998 PARAMETER ( LUNERR = 6 )
31999 PARAMETER ( LUNBER = 14 )
32000 PARAMETER ( LUNECH = 8 )
32001 PARAMETER ( LUNFLU = 13 )
32002 PARAMETER ( LUNGEO = 16 )
32003 PARAMETER ( LUNPMF = 12 )
32004 PARAMETER ( LUNRAN = 2 )
32005 PARAMETER ( LUNXSC = 9 )
32006 PARAMETER ( LUNDET = 17 )
32007 PARAMETER ( LUNRAY = 10 )
32008 PARAMETER ( LUNRDB = 1 )
32009 PARAMETER ( LUNPGO = 7 )
32010 PARAMETER ( LUNPGS = 4 )
32011 PARAMETER ( LUNSCR = 3 )
32012*
32013*----------------------------------------------------------------------*
32014* *
32015* Block Data for the EVAPoration routines: *
32016* *
32017* Created on 20 may 1990 by Alfredo Ferrari & Paola Sala *
32018* Infn - Milan *
32019* *
32020* Modified from the original version of J.M.Zazula *
32021* and, for cookcm, from a LAHET block data kindly provided by *
32022* R.E.Prael-LANL *
32023* *
32024* Last change on 20-feb-95 by Alfredo Ferrari *
32025* *
32026* *
32027*----------------------------------------------------------------------*
32028*
32029* (original name: COOKCM)
32030 PARAMETER ( ASMTOG = SIXSIX / PIPIPI**2 )
32031 LOGICAL LDEFOZ, LDEFON
32032 PARAMETER ( INCOOK = 150, IZCOOK = 98 )
32033 COMMON /FKCOOK/ ALPIGN, BETIGN, GAMIGN, POWIGN,
32034 & SZCOOK (IZCOOK), SNCOOK (INCOOK), PZCOOK (IZCOOK),
32035 & PNCOOK (INCOOK), LDEFOZ (IZCOOK), LDEFON (INCOOK)
32036* (original name: EVA0)
32037 COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
32038 * FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
32039 * CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
32040 * T (4,7), RMASS (297), ALPH (297), BET (297),
32041 * APRIME (250), IA (6), IZ (6)
32042* (original name: HETTP)
32043 COMMON /FKHETP/ NHSTP,NBERTP,IOSUB,INSRS
32044* (original name: HETC7)
32045 COMMON /FKHET7/ COSKS,SINKS, COSTH,SINTH, COSPHI,SINPHI
32046* (original name: INPFLG)
32047 COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
32048*
32049 DATA B0 / 8.D+00 /, Y0 / 1.5D+00 /
32050 DATA IANG / 1 /, IFISS / 1 /, IB0 / 2 /, IGEOM / 0 /
32051 DATA ISTRAG /0/, KEYDK /0/
32052 DATA NBERTP /LUNBER/
32053 DATA COSTH /ONEONE/, SINTH /ZERZER/, COSPHI /ONEONE/,
32054 & SINPHI/ZERZER/
32055* /cookcm/
32056 DATA ( PZCOOK(I),I = 1, IZCOOK ) /
32057 & 0.000D+00, 5.440D+00, 0.000D+00, 2.760D+00, 0.000D+00, 3.340D+00,
32058 & 0.000D+00, 2.700D+00, 0.000D+00, 2.500D+00, 0.000D+00, 2.460D+00,
32059 & 0.000D+00, 2.090D+00, 0.000D+00, 1.620D+00, 0.000D+00, 1.620D+00,
32060 & 0.000D+00, 1.830D+00, 0.000D+00, 1.730D+00, 0.000D+00, 1.350D+00,
32061 & 0.000D+00, 1.540D+00, 0.000D+00, 1.280D+00, 2.600D-01, 8.800D-01,
32062 & 1.900D-01, 1.350D+00,-5.000D-02, 1.520D+00,-9.000D-02, 1.170D+00,
32063 & 4.000D-02, 1.240D+00, 2.900D-01, 1.090D+00, 2.600D-01, 1.170D+00,
32064 & 2.300D-01, 1.150D+00,-8.000D-02, 1.350D+00, 3.400D-01, 1.050D+00,
32065 & 2.800D-01, 1.270D+00, 0.000D+00, 1.050D+00, 0.000D+00, 1.000D+00,
32066 & 9.000D-02, 1.200D+00, 2.000D-01, 1.400D+00, 9.300D-01, 1.000D+00,
32067 &-2.000D-01, 1.190D+00, 9.000D-02, 9.700D-01, 0.000D+00, 9.200D-01,
32068 & 1.100D-01, 6.800D-01, 5.000D-02, 6.800D-01,-2.200D-01, 7.900D-01,
32069 & 9.000D-02, 6.900D-01, 1.000D-02, 7.200D-01, 0.000D+00, 4.000D-01,
32070 & 1.600D-01, 7.300D-01, 0.000D+00, 4.600D-01, 1.700D-01, 8.900D-01,
32071 & 0.000D+00, 7.900D-01, 0.000D+00, 8.900D-01, 0.000D+00, 8.100D-01,
32072 &-6.000D-02, 6.900D-01,-2.000D-01, 7.100D-01,-1.200D-01, 7.200D-01,
32073 & 0.000D+00, 7.700D-01/
32074 DATA ( PNCOOK(I),I = 1, 90 ) /
32075 & 0.000D+00, 5.980D+00, 0.000D+00, 2.770D+00, 0.000D+00, 3.160D+00,
32076 & 0.000D+00, 3.010D+00, 0.000D+00, 2.500D+00, 0.000D+00, 2.670D+00,
32077 & 0.000D+00, 1.800D+00, 0.000D+00, 1.670D+00, 0.000D+00, 1.860D+00,
32078 & 0.000D+00, 2.040D+00, 0.000D+00, 1.640D+00, 0.000D+00, 1.440D+00,
32079 & 0.000D+00, 1.540D+00, 0.000D+00, 1.300D+00, 0.000D+00, 1.270D+00,
32080 & 0.000D+00, 1.290D+00, 8.000D-02, 1.410D+00,-8.000D-02, 1.500D+00,
32081 &-5.000D-02, 2.240D+00,-4.700D-01, 1.430D+00,-1.500D-01, 1.440D+00,
32082 & 6.000D-02, 1.560D+00, 2.500D-01, 1.570D+00,-1.600D-01, 1.460D+00,
32083 & 0.000D+00, 9.300D-01, 1.000D-02, 6.200D-01,-5.000D-01, 1.420D+00,
32084 & 1.300D-01, 1.520D+00,-6.500D-01, 8.000D-01,-8.000D-02, 1.290D+00,
32085 &-4.700D-01, 1.250D+00,-4.400D-01, 9.700D-01, 8.000D-02, 1.650D+00,
32086 &-1.100D-01, 1.260D+00,-4.600D-01, 1.060D+00, 2.200D-01, 1.550D+00,
32087 &-7.000D-02, 1.370D+00, 1.000D-01, 1.200D+00,-2.700D-01, 9.200D-01,
32088 &-3.500D-01, 1.190D+00, 0.000D+00, 1.050D+00,-2.500D-01, 1.610D+00,
32089 &-2.100D-01, 9.000D-01,-2.100D-01, 7.400D-01,-3.800D-01, 7.200D-01/
32090 DATA ( PNCOOK(I),I = 91, INCOOK ) /
32091 &-3.400D-01, 9.200D-01,-2.600D-01, 9.400D-01, 1.000D-02, 6.500D-01,
32092 &-3.600D-01, 8.300D-01, 1.100D-01, 6.700D-01, 5.000D-02, 1.000D+00,
32093 & 5.100D-01, 1.040D+00, 3.300D-01, 6.800D-01,-2.700D-01, 8.100D-01,
32094 & 9.000D-02, 7.500D-01, 1.700D-01, 8.600D-01, 1.400D-01, 1.100D+00,
32095 &-2.200D-01, 8.400D-01,-4.700D-01, 4.800D-01, 2.000D-02, 8.800D-01,
32096 & 2.400D-01, 5.200D-01, 2.700D-01, 4.100D-01,-5.000D-02, 3.800D-01,
32097 & 1.500D-01, 6.700D-01, 0.000D+00, 6.100D-01, 0.000D+00, 7.800D-01,
32098 & 0.000D+00, 6.700D-01, 0.000D+00, 6.700D-01, 0.000D+00, 7.900D-01,
32099 & 0.000D+00, 6.000D-01, 4.000D-02, 6.400D-01,-6.000D-02, 4.500D-01,
32100 & 5.000D-02, 2.600D-01,-2.200D-01, 3.900D-01, 0.000D+00, 3.900D-01/
32101 DATA ( SZCOOK(I),I = 1, 98) /
32102 & 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
32103 & 0.000D+00, 0.000D+00,-1.100D-01,-8.100D-01,-2.910D+00,-4.170D+00,
32104 &-5.720D+00,-7.800D+00,-8.970D+00,-9.700D+00,-1.010D+01,-1.070D+01,
32105 &-1.138D+01,-1.207D+01,-1.255D+01,-1.324D+01,-1.393D+01,-1.471D+01,
32106 &-1.553D+01,-1.637D+01,-1.736D+01,-1.860D+01,-1.870D+01,-1.801D+01,
32107 &-1.787D+01,-1.708D+01,-1.660D+01,-1.675D+01,-1.650D+01,-1.635D+01,
32108 &-1.622D+01,-1.641D+01,-1.689D+01,-1.643D+01,-1.668D+01,-1.673D+01,
32109 &-1.745D+01,-1.729D+01,-1.744D+01,-1.782D+01,-1.862D+01,-1.827D+01,
32110 &-1.939D+01,-1.991D+01,-1.914D+01,-1.826D+01,-1.740D+01,-1.642D+01,
32111 &-1.577D+01,-1.437D+01,-1.391D+01,-1.310D+01,-1.311D+01,-1.143D+01,
32112 &-1.089D+01,-1.075D+01,-1.062D+01,-1.041D+01,-1.021D+01,-9.850D+00,
32113 &-9.470D+00,-9.030D+00,-8.610D+00,-8.130D+00,-7.460D+00,-7.480D+00,
32114 &-7.200D+00,-7.130D+00,-7.060D+00,-6.780D+00,-6.640D+00,-6.640D+00,
32115 &-7.680D+00,-7.890D+00,-8.410D+00,-8.490D+00,-7.880D+00,-6.300D+00,
32116 &-5.470D+00,-4.780D+00,-4.370D+00,-4.170D+00,-4.130D+00,-4.320D+00,
32117 &-4.550D+00,-5.040D+00,-5.280D+00,-6.060D+00,-6.280D+00,-6.870D+00,
32118 &-7.200D+00,-7.740D+00/
32119 DATA ( SNCOOK(I),I = 1, 90 ) /
32120 & 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
32121 & 0.000D+00, 0.000D+00, 1.030D+01, 5.660D+00, 6.800D+00, 7.530D+00,
32122 & 7.550D+00, 7.210D+00, 7.440D+00, 8.070D+00, 8.940D+00, 9.810D+00,
32123 & 1.060D+01, 1.139D+01, 1.254D+01, 1.368D+01, 1.434D+01, 1.419D+01,
32124 & 1.383D+01, 1.350D+01, 1.300D+01, 1.213D+01, 1.260D+01, 1.326D+01,
32125 & 1.413D+01, 1.492D+01, 1.552D+01, 1.638D+01, 1.716D+01, 1.755D+01,
32126 & 1.803D+01, 1.759D+01, 1.903D+01, 1.871D+01, 1.880D+01, 1.899D+01,
32127 & 1.846D+01, 1.825D+01, 1.776D+01, 1.738D+01, 1.672D+01, 1.562D+01,
32128 & 1.438D+01, 1.288D+01, 1.323D+01, 1.381D+01, 1.490D+01, 1.486D+01,
32129 & 1.576D+01, 1.620D+01, 1.762D+01, 1.773D+01, 1.816D+01, 1.867D+01,
32130 & 1.969D+01, 1.951D+01, 2.017D+01, 1.948D+01, 1.998D+01, 1.983D+01,
32131 & 2.020D+01, 1.972D+01, 1.987D+01, 1.924D+01, 1.844D+01, 1.761D+01,
32132 & 1.710D+01, 1.616D+01, 1.590D+01, 1.533D+01, 1.476D+01, 1.354D+01,
32133 & 1.263D+01, 1.065D+01, 1.010D+01, 8.890D+00, 1.025D+01, 9.790D+00,
32134 & 1.139D+01, 1.172D+01, 1.243D+01, 1.296D+01, 1.343D+01, 1.337D+01/
32135 DATA ( SNCOOK(I),I = 91, INCOOK ) /
32136 & 1.296D+01, 1.211D+01, 1.192D+01, 1.100D+01, 1.080D+01, 1.042D+01,
32137 & 1.039D+01, 9.690D+00, 9.270D+00, 8.930D+00, 8.570D+00, 8.020D+00,
32138 & 7.590D+00, 7.330D+00, 7.230D+00, 7.050D+00, 7.420D+00, 6.750D+00,
32139 & 6.600D+00, 6.380D+00, 6.360D+00, 6.490D+00, 6.250D+00, 5.850D+00,
32140 & 5.480D+00, 4.530D+00, 4.300D+00, 3.390D+00, 2.350D+00, 1.660D+00,
32141 & 8.100D-01, 4.600D-01,-9.600D-01,-1.690D+00,-2.530D+00,-3.160D+00,
32142 &-1.870D+00,-4.100D-01, 7.100D-01, 1.660D+00, 2.620D+00, 3.220D+00,
32143 & 3.760D+00, 4.100D+00, 4.460D+00, 4.830D+00, 5.090D+00, 5.180D+00,
32144 & 5.170D+00, 5.100D+00, 5.010D+00, 4.970D+00, 5.090D+00, 5.030D+00,
32145 & 4.930D+00, 5.280D+00, 5.490D+00, 5.500D+00, 5.370D+00, 5.300D+00/
32146 DATA LDEFOZ / 53*.FALSE.,25*.TRUE.,7*.FALSE.,13*.TRUE. /
32147 DATA LDEFON / 85*.FALSE.,37*.TRUE.,7*.FALSE.,21*.TRUE. /
32148*=== End of Block Data Bdevap =========================================*
32149 END
32150
32151*$ CREATE DT_BDNOPT.FOR
32152*COPY DT_BDNOPT
32153*
32154*=== bdnopt ===========================================================*
32155*== *
32156 BLOCK DATA DT_BDNOPT
32157
32158C INCLUDE '(DBLPRC)'
32159* DBLPRC.ADD
32160 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32161 SAVE
32162* (original name: GLOBAL)
32163 PARAMETER ( KALGNM = 2 )
32164 PARAMETER ( ANGLGB = 5.0D-16 )
32165 PARAMETER ( ANGLSQ = 2.5D-31 )
32166 PARAMETER ( AXCSSV = 0.2D+16 )
32167 PARAMETER ( ANDRFL = 1.0D-38 )
32168 PARAMETER ( AVRFLW = 1.0D+38 )
32169 PARAMETER ( AINFNT = 1.0D+30 )
32170 PARAMETER ( AZRZRZ = 1.0D-30 )
32171 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
32172 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
32173 PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
32174 PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
32175 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
32176 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
32177 PARAMETER ( CSNNRM = 2.0D-15 )
32178 PARAMETER ( DMXTRN = 1.0D+08 )
32179 PARAMETER ( ZERZER = 0.D+00 )
32180 PARAMETER ( ONEONE = 1.D+00 )
32181 PARAMETER ( TWOTWO = 2.D+00 )
32182 PARAMETER ( THRTHR = 3.D+00 )
32183 PARAMETER ( FOUFOU = 4.D+00 )
32184 PARAMETER ( FIVFIV = 5.D+00 )
32185 PARAMETER ( SIXSIX = 6.D+00 )
32186 PARAMETER ( SEVSEV = 7.D+00 )
32187 PARAMETER ( EIGEIG = 8.D+00 )
32188 PARAMETER ( ANINEN = 9.D+00 )
32189 PARAMETER ( TENTEN = 10.D+00 )
32190 PARAMETER ( HLFHLF = 0.5D+00 )
32191 PARAMETER ( ONETHI = ONEONE / THRTHR )
32192 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
32193 PARAMETER ( ONEFOU = ONEONE / FOUFOU )
32194 PARAMETER ( THRTWO = THRTHR / TWOTWO )
32195 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
32196 PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
32197 PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
32198 PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
32199 PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
32200 PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
32201 PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
32202 PARAMETER ( EULERO = 0.577215664901532860606512 D+00 )
32203 PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 )
32204 PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 )
32205 PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 )
32206 PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
32207 PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
32208 PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
32209 PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
32210 PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
32211 PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
32212 PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
32213 PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
32214 PARAMETER ( CLIGHT = 2.99792458 D+10 )
32215 PARAMETER ( AVOGAD = 6.0221367 D+23 )
32216 PARAMETER ( BOLTZM = 1.380658 D-23 )
32217 PARAMETER ( AMELGR = 9.1093897 D-28 )
32218 PARAMETER ( PLCKBR = 1.05457266 D-27 )
32219 PARAMETER ( ELCCGS = 4.8032068 D-10 )
32220 PARAMETER ( ELCMKS = 1.60217733 D-19 )
32221 PARAMETER ( AMUGRM = 1.6605402 D-24 )
32222 PARAMETER ( AMMUMU = 0.113428913 D+00 )
32223 PARAMETER ( AMPRMU = 1.007276470 D+00 )
32224 PARAMETER ( AMNEMU = 1.008664904 D+00 )
32225 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
32226 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
32227 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
32228 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
32229 PARAMETER ( PLABRC = 0.197327053 D+00 )
32230 PARAMETER ( AMELCT = 0.51099906 D-03 )
32231 PARAMETER ( AMUGEV = 0.93149432 D+00 )
32232 PARAMETER ( AMMUON = 0.105658389 D+00 )
32233 PARAMETER ( AMPRTN = 0.93827231 D+00 )
32234 PARAMETER ( AMNTRN = 0.93956563 D+00 )
32235 PARAMETER ( AMDEUT = 1.87561339 D+00 )
32236 PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
32237 & * 1.D-09 )
32238 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
32239 PARAMETER ( BLTZMN = 8.617385 D-14 )
32240 PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
32241 PARAMETER ( GFOHB3 = 1.16639 D-05 )
32242 PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
32243 PARAMETER ( SIN2TW = 0.2319 D+00 )
32244 PARAMETER ( GEVMEV = 1.0 D+03 )
32245 PARAMETER ( EMVGEV = 1.0 D-03 )
32246 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
32247 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
32248 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
32249 LOGICAL LGBIAS, LGBANA
32250 COMMON /FKGLOB/ LGBIAS, LGBANA
32251C INCLUDE '(DIMPAR)'
32252* DIMPAR.ADD
32253 PARAMETER ( MXXRGN = 5000 )
32254 PARAMETER ( MXXMDF = 82 )
32255 PARAMETER ( MXXMDE = 54 )
32256 PARAMETER ( MFSTCK = 1000 )
32257 PARAMETER ( MESTCK = 100 )
32258 PARAMETER ( NELEMX = 80 )
32259 PARAMETER ( MPDPDX = 8 )
32260 PARAMETER ( ICOMAX = 180 )
32261 PARAMETER ( NSTBIS = 304 )
32262 PARAMETER ( IDMAXP = 220 )
32263 PARAMETER ( IDMXDC = 640 )
32264 PARAMETER ( MKBMX1 = 1 )
32265 PARAMETER ( MKBMX2 = 1 )
32266C INCLUDE '(IOUNIT)'
32267* IOUNIT.ADD
32268 PARAMETER ( LUNIN = 5 )
32269 PARAMETER ( LUNOUT = 6 )
32270**sr 19.5. set error output-unit from 15 to 6
32271 PARAMETER ( LUNERR = 6 )
32272 PARAMETER ( LUNBER = 14 )
32273 PARAMETER ( LUNECH = 8 )
32274 PARAMETER ( LUNFLU = 13 )
32275 PARAMETER ( LUNGEO = 16 )
32276 PARAMETER ( LUNPMF = 12 )
32277 PARAMETER ( LUNRAN = 2 )
32278 PARAMETER ( LUNXSC = 9 )
32279 PARAMETER ( LUNDET = 17 )
32280 PARAMETER ( LUNRAY = 10 )
32281 PARAMETER ( LUNRDB = 1 )
32282 PARAMETER ( LUNPGO = 7 )
32283 PARAMETER ( LUNPGS = 4 )
32284 PARAMETER ( LUNSCR = 3 )
32285*
32286*----------------------------------------------------------------------*
32287* *
32288* Created on 20 september 1989 by Alfredo Ferrari - Infn Milan *
32289* *
32290* Last change on 20-apr-95 by Alfredo Ferrari *
32291* *
32292*----------------------------------------------------------------------*
32293*
32294C INCLUDE '(BLNKCM)'
32295* BLNKCM.ADD
32296**sr 17.5. commented since not used here
32297C PARAMETER ( NBLNMX = 1100000 )
32298C DIMENSION GMSTOR ( NBLNMX ), BRMBRR ( NBLNMX ), BRMEXP ( NBLNMX ),
32299C & BRMSIG ( NBLNMX ), SIGGTT ( KALGNM*NBLNMX ),
32300C & COMSCO ( NBLNMX ), LBSTOR ( KALGNM*NBLNMX )
32301C REAL SIGGTT
32302C LOGICAL LBSTOR
32303C COMMON NSTOR ( KALGNM*NBLNMX )
32304**
32305**sr 18.5. commented since not used for evap.
32306C COMMON / ADDRCM / MBLNMX, KBLNKL, KGMBGN, KGMLST, KCMBGN, KCMLST,
32307C & KISBGN, KISLST, KDTBGN, KDTLST, KUBBGN, KUBLST,
32308C & KUXBGN, KUXLST, KTCBGN, KTCLST, KRNBGN, KRNLST,
32309C & KYLBGN, KYLLST, KXSBGN, KXSLST, KIHBGN, KIHLST,
32310C & KINBGN, KINLST, KIEBGN, KIELST, KETBGN, KETLST,
32311C & KRRBGN, KRRLST, KGLBGN, KGLLST, KNABGN, KNALST,
32312C & KGDBGN, KGDLST, KDWBGN, KDWLST, KGCBGN, KGCLST,
32313C & KWLBGN, KWLLST, KWHBGN, KWHLST, KWMBGN, KWMLST,
32314C & KWSBGN, KWSLST, KNDBGN, KNDLST, KDPBGN, KDPLST,
32315C & KRGBGN, KRGLST, KSGBGN, KSGLST, KBRBGN, KBRLST,
32316C & KTMBGN
32317**
32318
32319C EQUIVALENCE ( NSTOR (1), GMSTOR (1) )
32320C EQUIVALENCE ( NSTOR (1), BRMBRR (1) )
32321C EQUIVALENCE ( NSTOR (1), BRMEXP (1) )
32322C EQUIVALENCE ( NSTOR (1), BRMSIG (1) )
32323C EQUIVALENCE ( NSTOR (1), COMSCO (1) )
32324C EQUIVALENCE ( NSTOR (1), SIGGTT (1) )
32325C EQUIVALENCE ( NSTOR (1), LBSTOR (1) )
32326C INCLUDE '(BLNTMP)'
32327* BLNTMP.ADD
32328**sr 18.5. commented since not used for evap.
32329C COMMON / BLNTMP / KIHBTM, KINBTM, KIEBTM, KRRBTM, KGLBTM, KNABTM,
32330C & KGCBTM, KGDWTM, KBDWTM, KWLOTM, KWHITM, KWMUTM,
32331C & KWSHTM, KEXTTM, KSTXTM, KSTNTM, KECTTM, KPCTTM,
32332C & KLPBTM, NXXRGN
32333**
32334C INCLUDE '(CMMDNR)'
32335* CMMDNR.ADD
32336**sr 18.5. commented since not used for evap.
32337C LOGICAL LFLDNR
32338C COMMON / CMMDNR / DDNEAR, LFLDNR
32339**
32340C INCLUDE '(CTITLE)'
32341* CTITLE.ADD
32342**sr 18.5. commented since not used for evap.
32343C CHARACTER RUNTIT*80, RUNTIM*32, RUNKEY*10
32344C COMMON / CTITLE / RUNTIT, RUNTIM, RUNKEY
32345C COMMON / CEXPCK / ITEXPI, ITEXMX
32346**
32347C INCLUDE '(DETECT)'
32348* DETECT.ADD
32349**sr 18.5. commented since not used for evap.
32350C PARAMETER (NRGNMX = 10)
32351C PARAMETER (NDTCMX = 10)
32352C PARAMETER (NSCRMX = 10)
32353C PARAMETER (NDTBIN = 1024)
32354C CHARACTER*10 TITDET,TITSCO
32355C LOGICAL LDTCTR
32356C COMMON /DETCT/ EDTMIN(NDTCMX), EDTBIN(NDTCMX), EDTCUT(NDTCMX),
32357C & KDTREG(NRGNMX,NDTCMX), KDTDET(NDTCMX,NSCRMX),
32358C & NDTSCO, NDTDET, LDTCTR, IDTREG(MXXRGN),
32359C & KDTSCD(NSCRMX)
32360C COMMON /DETCH/ TITDET(NDTCMX), TITSCO(NSCRMX)
32361**
32362C INCLUDE '(DETLOC)'
32363* DETLOC.ADD
32364**sr 18.5. commented since not used for evap.
32365C PARAMETER (NDTCM2 = 10)
32366C COMMON /DETLOC/ ACCUMP (NDTCM2), ACCUMN (NDTCM2),
32367C & ICOINC(NDTCM2), NCLAS
32368**
32369C INCLUDE '(EMGTRN)'
32370* EMGTRN.ADD
32371**sr 18.5. commented since not used for evap.
32372C LOGICAL LMCSMG
32373C COMMON / EMGTRN / UMCSMG, VMCSMG, WMCSMG, LMCSMG
32374**
32375C INCLUDE '(EMSHO)'
32376* EMSHO.ADD
32377**sr 18.5. commented since not used for evap.
32378C LOGICAL EMFLO, EMFHLO, EMFELO, LIMPRE, LEXPTE
32379C COMMON /EMSHO/ EMFETH, EMFPTH, EMFHET, EMFHPT, EMFBIA, EMFLO,
32380C & EMFHLO, EMFELO, LIMPRE, LEXPTE
32381**
32382C INCLUDE '(EPISOR)'
32383* EPISOR.ADD
32384**sr 18.5. commented since not used for evap.
32385C LOGICAL LUSSRC
32386C COMMON/EPISOR/TKESUM,LUSSRC
32387**
32388* (original name: FHEAVY,FHEAVC)
32389 PARAMETER ( MXHEAV = 100 )
32390 CHARACTER*8 ANHEAV
32391 COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV),
32392 & CZHEAV (MXHEAV), TKHEAV (MXHEAV),
32393 & PHEAVY (MXHEAV), WHEAVY (MXHEAV),
32394 & AMHEAV ( 12 ) , AMNHEA ( 12 ) ,
32395 & KHEAVY (MXHEAV), ICHEAV ( 12 ) ,
32396 & IBHEAV ( 12 ) , NPHEAV
32397 COMMON /FKFHVC/ ANHEAV ( 12 )
32398* (original name: FINUC)
32399 PARAMETER (MXP=999)
32400 COMMON /FKFINU/ CXR (MXP), CYR (MXP), CZR (MXP),
32401 & CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP),
32402 & TKI (MXP), PLR (MXP), WEI (MXP),
32403 & TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP,
32404 & KPART (MXP)
32405C INCLUDE '(GENTHR)'
32406* GENTHR.ADD
32407**sr 18.5. commented since not used for evap.
32408C COMMON / GENTHR / PEANCT, PEAPIT, PLDNCT, PTHRSH (NALLWP),
32409C & PTHDFF (NALLWP), IJNUCR (NALLWP)
32410**
32411C INCLUDE '(LOWNEU)'
32412* LOWNEU.ADD
32413**sr 18.5. commented since not used for evap.
32414C PARAMETER ( MXGTHN = 15 )
32415C PARAMETER ( MXGLWN = 200 )
32416C PARAMETER ( MXSHPP = 5 )
32417C LOGICAL LCOMPN, LIMPRN, LBIASN, LDOWNN, LRECPR, LLOWWW, LLOWET
32418C CHARACTER*10 TITLOW
32419C COMMON / LOWNEU / ATOLOW (MXXMDF), WSHPLN (MXGLWN,MXSHPP), EXTWWL,
32420C & SHPIMP (MXGLWN), EXTETL (MXGLWN), WWAMFL,
32421C & VLLNTH (MXGTHN,MXXMDF), ABLNTH (MXGTHN,MXXMDF),
32422C & STLNTH (MXGTHN,MXXMDF), TMRTLN (MXXMDF),
32423C & TMNMLN (MXXMDF), ICHCPT (MXXMDF),
32424C & IGTMRT (MXXMDF), NEUMED (MXXMDF),
32425C & ID1MED (MXXMDF), ID2MED (MXXMDF),
32426C & ID3MED (MXXMDF), MGTMED (MXXMDF),
32427C & LCOMPN (MXXMDF), LRECPR (MXXMDF), KPRLOW, NMGP,
32428C & NMTG , IGRTHN, LIMPRN, LBIASN, LDOWNN, LLOWWW,
32429C & LLOWET, ICLMED, IKRBGN, INABGN, IDWBGN, IETBGN,
32430C & I0XSEC, IDXSEC, ISENAV, ISVELN, ISPNAV, IWWLWB,
32431C & IWWLWT, IPXBGN, NPXSEC
32432C COMMON / CHLWNT / TITLOW (MXXMDF)
32433**
32434C INCLUDE '(LTCLCM)'
32435* LTCLCM.ADD
32436**sr 18.5. commented since not used for evap.
32437C COMMON / LTCLCM / MLATTC, NEWLAT, MLATLD, MLATM1, MLTSEN, MLTSM1
32438**
32439C INCLUDE '(MULBOU)'
32440* MULBOU.ADD
32441**sr 18.5. commented since not used for evap.
32442C LOGICAL LLDA , LAGAIN, LSTNEW, LARTEF, LNORML, LSENSE, LMGNOR
32443C COMMON / MULBOU / UOLD , VOLD , WOLD , UMAG , VMAG , WMAG ,
32444C & UNORML, VNORML, WNORML, USENSE, VSENSE, WSENSE,
32445C & TSENSE, DDSENS, DSMALL, NSSENS, LLDA , LAGAIN,
32446C & LSTNEW, LARTEF, LNORML, LSENSE, LMGNOR
32447**
32448C INCLUDE '(MULHD)'
32449* MULHD.ADD
32450**sr 18.5. commented since not used for evap.
32451C PARAMETER ( MXXPT1 = 1 )
32452C PARAMETER ( TIMESS = 2.00D+00 )
32453C PARAMETER ( TMSRLX = 1.50D+00 )
32454C PARAMETER ( EPSINS = 0.15D+00 )
32455C PARAMETER ( EPSRLX = 0.50D+00 )
32456C PARAMETER ( SQEPSN = 0.3872983346207417 D+00 )
32457C PARAMETER ( SQEPSR = 0.7071067811865475 D+00 )
32458C PARAMETER ( PARNSI = 1.732050807568877 D+00 * SQEPSN )
32459C PARAMETER ( PRNSR0 = 1.732050807568877 D+00 * SQEPSR )
32460C PARAMETER ( R0NCMS = 1.20 D+00 )
32461C LOGICAL LTOPT, LSRCRH, LNSCRH
32462C COMMON / MULHD / BLCC ( MXXMDF ), BLCCRA ( MXXMDF ),
32463C & XCC ( MXXMDF ), ZTILDE ( MXXMDF, 0:MXXPT1 ),
32464C & ALPZTL ( MXXMDF, 0:MXXPT1 ), RLDU ( MXXMDF ),
32465C & ALPZT2 ( MXXMDF, 0:MXXPT1 ), TEFF0 ( MXXMDF ),
32466C & XR0 ( MXXMDF ), ECUTM ( MXXMDF, 39, 2 ),
32467C & ESTEPF ( MXXMDF ), HTHNSZ ( MXXMDF, 39 ),
32468C & AE1O3 ( MXXMDF ), PARNSR ( MXXMDF ),
32469C & HEESLI ( MXXMDF ), THMSPR, THMSSC, HMSAMP,
32470C & HMREJE, LSRCRH ( MXXMDF ), LNSCRH ( MXXMDF ),
32471C & LTOPT ( MXXMDF ), NFSCAT
32472**
32473* (original name: PAREVT)
32474 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
32475 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
32476 PARAMETER ( NALLWP = 39 )
32477 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
32478 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
32479 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
32480 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
32481* (original name: RESNUC)
32482 LOGICAL LRNFSS, LFRAGM
32483 COMMON /FKRESN/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
32484 & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
32485 & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES,
32486 & PYRES, PZRES, PTRES2, KTARP, KTARN, IGREYP,
32487 & IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,
32488 & ICRES, IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU,
32489 & IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG,
32490 & IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS,
32491 & LFRAGM
32492C INCLUDE '(SCOHLP)'
32493* SCOHLP.ADD
32494**sr 18.5. commented since not used for evap.
32495C LOGICAL LSCZER
32496C COMMON / SCOHLP / ISCRNG, JSCRNG, LSCZER
32497**
32498C INCLUDE '(TRACKR)'
32499* TRACKR.ADD
32500**sr 18.5. commented since not used for evap.
32501C PARAMETER ( MXTRCK = 2500 )
32502C LOGICAL LFSSSC
32503C COMMON / TRACKR / XTRACK ( 0:MXTRCK ), YTRACK ( 0:MXTRCK ),
32504C & ZTRACK ( 0:MXTRCK ), TTRACK ( MXTRCK ),
32505C & DTRACK ( MXTRCK ), ETRACK, PTRACK, WTRACK,
32506C & ATRACK, CTRACK, AKSHRT, AKLONG, WSCRNG,
32507C & NTRACK, MTRACK, JTRACK, KTRACK, MMTRCK,
32508C & LT1TRK, LT2TRK, LTRACK, LLOUSE, LFSSSC
32509**
32510C INCLUDE '(USRBDX)'
32511* USRBDX.ADD
32512**sr 18.5. commented since not used for evap.
32513C PARAMETER ( MXUSBX = 600 )
32514C LOGICAL LUSBDX, LFUSBX, LWUSBX, LLNUSX
32515C CHARACTER*10 TITUSX
32516C COMMON /USRBX/ EBXLOW(MXUSBX), EBXHGH(MXUSBX), ABXLOW(MXUSBX),
32517C & ABXHGH(MXUSBX), DEBXBN(MXUSBX), DABXBN(MXUSBX),
32518C & AUSBDX(MXUSBX),
32519C & NEBXBN(MXUSBX), NABXBN(MXUSBX), NR1USX(MXUSBX),
32520C & NR2USX(MXUSBX), ITUSBX(MXUSBX), IDUSBX(MXUSBX),
32521C & KBUSBX(MXUSBX), IPUSBX(MXUSBX), IGMUSX(MXUSBX),
32522C & LFUSBX(MXUSBX), LWUSBX(MXUSBX), LLNUSX(MXUSBX),
32523C & NUSRBX, LUSBDX
32524C COMMON /USXCH/ TITUSX(MXUSBX)
32525**
32526C INCLUDE '(USRBIN)'
32527* USRBIN.ADD
32528**sr 18.5. commented since not used for evap.
32529C PARAMETER ( MXUSBN = 100 )
32530C LOGICAL LUSBIN, LEVTBN, LNTZER, LUSEVT, LUSTKB, LTRKBN
32531C CHARACTER*10 TITUSB
32532C COMMON /USRBN/ XLOW (MXUSBN), XHIGH (MXUSBN), YLOW (MXUSBN),
32533C & YHIGH (MXUSBN), ZLOW (MXUSBN), ZHIGH (MXUSBN),
32534C & DXUSBN(MXUSBN), DYUSBN(MXUSBN), DZUSBN(MXUSBN),
32535C & TCUSBN(MXUSBN), BKUSBN(MXUSBN), B2USBN(MXUSBN),
32536C & NXBIN (MXUSBN), NYBIN (MXUSBN), NZBIN (MXUSBN),
32537C & ITUSBN(MXUSBN), IDUSBN(MXUSBN), KBUSBN(MXUSBN),
32538C & IPUSBN(MXUSBN), LEVTBN(MXUSBN), LNTZER(MXUSBN),
32539C & LTRKBN(MXUSBN), NUSRBN, LUSBIN, LUSEVT, LUSTKB
32540C COMMON /USRCH/ TITUSB(MXUSBN)
32541**
32542C INCLUDE '(USRSNC)'
32543* USRSNC.ADD
32544**sr 18.5. commented since not used for evap.
32545C PARAMETER ( MXRSNC = 400 )
32546C PARAMETER ( NMZMIN = -5 )
32547C LOGICAL LURSNC
32548C CHARACTER*10 TIURSN
32549C COMMON /USRSNC/ VURSNC(MXRSNC), IZRHGH(MXRSNC), IMRHGH(MXRSNC),
32550C & NRURSN(MXRSNC), ITURSN(MXRSNC), KBURSN(MXRSNC),
32551C & IPURSN(MXRSNC), NURSNC, LURSNC
32552C COMMON /USRSCH/ TIURSN(MXRSNC)
32553C INCLUDE '(USRTRC)'
32554* USRTRC.ADD
32555**sr 18.5. commented since not used for evap.
32556C PARAMETER ( MXUSTC = 400 )
32557C LOGICAL LUSRTC, LUSTRK, LUSCLL, LLNUTC
32558C CHARACTER*10 TITUTC
32559C COMMON /USRTC/ ETCLOW(MXUSTC), ETCHGH(MXUSTC), DETCBN(MXUSTC),
32560C & VUSRTC(MXUSTC),
32561C & IUSTRK(MXUSTC), IUSCLL(MXUSTC), NETCBN(MXUSTC),
32562C & NRUSTC(MXUSTC), ITUSTC(MXUSTC), IDUSTC(MXUSTC),
32563C & KBUSTC(MXUSTC), IPUSTC(MXUSTC), IGMUTC(MXUSTC),
32564C & LLNUTC(MXUSTC), NUSRTC, NUSTRK, NUSCLL, LUSRTC,
32565C & LUSTRK, LUSCLL
32566C COMMON /USTCH/ TITUTC(MXUSTC)
32567**
32568C INCLUDE '(USRYLD)'
32569* USRYLD.ADD
32570**sr 18.5. commented since not used for evap.
32571C PARAMETER ( MXUSYL = 500 )
32572C LOGICAL LUSRYL, LLNUYL, LSCUYL
32573C CHARACTER*10 TITUYL
32574C COMMON /USRYL/ EYLLOW(MXUSYL), EYLHGH(MXUSYL), DEYLBN(MXUSYL),
32575C & USNRYL(MXUSYL), SGUSYL(MXUSYL), AYLLOW(MXUSYL),
32576C & AYLHGH(MXUSYL), PUSRYL, UUSRYL, VUSRYL, WUSRYL,
32577C & ETXUYL, ETYUYL, ETZUYL, GAMUYL, SQSUYL, UCMUYL,
32578C & VCMUYL, WCMUYL, IJUSYL, JTUSYL,
32579C & NEYLBN(MXUSYL), NR1UYL(MXUSYL), NR2UYL(MXUSYL),
32580C & IXUSYL(MXUSYL), ITUSYL(MXUSYL), IDUSYL(MXUSYL),
32581C & KBUSYL(MXUSYL), IPUSYL(MXUSYL), IGMUYL(MXUSYL),
32582C & IEUSYL(MXUSYL), IAUSYL(MXUSYL), LLNUYL(MXUSYL),
32583C & NUSRYL, LUSRYL, LSCUYL
32584C COMMON /USYCH/ TITUYL(MXUSYL)
32585**
32586C INCLUDE '(WWINDW)'
32587* WWINDW.ADD
32588**sr 18.5. commented since not used for evap.
32589C PARAMETER ( MXWWSP = 3 )
32590C PARAMETER ( WWSPMX = 50.D+00 )
32591C LOGICAL LWWNDW, LWWPRM
32592C COMMON / WWINDW / ETHWW1 (NALLWP), ETHWW2 (NALLWP),
32593C & WWEXWD (NALLWP), EXTWWN (NALLWP),
32594C & IWLBGN, IWHBGN, IWMBGN, LWWNDW, LWWPRM
32595**
32596
32597* /blnkcm/
32598* *** If blank common dimension has to be superseded substitute in the
32599* *** following two lines the new dimension in real*8 units to Nblnmx
32600**sr 18.5. commented since not used for evap.
32601C PARAMETER (MXDUMM = KALGNM * NBLNMX)
32602C DATA KTMBGN / NBLNMX /
32603C DATA MBLNMX / MXDUMM /
32604C DATA KBLNKL, KGMBGN, KGMLST, KCMBGN, KCMLST, KISBGN, KISLST,
32605C & KDTBGN, KDTLST, KUBBGN, KUBLST, KUXBGN, KUXLST, KTCBGN,
32606C & KTCLST, KRNBGN, KRNLST, KYLBGN, KYLLST, KXSBGN, KXSLST,
32607C & KIHBGN, KIHLST, KINBGN, KINLST, KIEBGN, KIELST, KETBGN,
32608C & KETLST, KRRBGN, KRRLST, KGLBGN, KGLLST, KNABGN, KNALST,
32609C & KGDBGN, KGDLST, KDWBGN, KDWLST, KGCBGN, KGCLST, KWLBGN,
32610C & KWLLST, KWHBGN, KWHLST, KWMBGN, KWMLST, KWSBGN, KWSLST,
32611C & KDPBGN, KDPLST, KRGBGN, KRGLST, KSGBGN, KSGLST, KBRBGN,
32612C & KBRLST / 57*0 /
32613
32614* /blntmp/
32615**sr 18.5. commented since not used for evap.
32616C DATA KIHBTM, KINBTM, KIEBTM, KRRBTM, KGLBTM, KNABTM, KGDWTM,
32617C & KBDWTM, KGCBTM, KWLOTM, KWHITM, KWMUTM, KWSHTM, KEXTTM,
32618C & KSTXTM, KSTNTM, KECTTM, KPCTTM, KLPBTM / 19*0 /
32619
32620* /cmmdnr/
32621**sr 18.5. commented since not used for evap.
32622C DATA DDNEAR / 0.D+00 /, LFLDNR / .FALSE. /
32623
32624* /ctitle/
32625**sr 18.5. commented since not used for evap.
32626C DATA RUNTIT (1:40) / '****************************************' /
32627C DATA RUNTIT(41:80) / '****************************************' /
32628C DATA ITEXPI, ITEXMX / 100000000, 150 /
32629* /detect/
32630**sr 18.5. commented since not used for evap.
32631C PARAMETER (NNN1 = NRGNMX*NDTCMX)
32632C PARAMETER (NNN2 = NSCRMX*NDTCMX)
32633C DATA LDTCTR /.FALSE./, NDTSCO /0/, NDTDET /0/
32634C DATA EDTMIN/NDTCMX*0.D0/, EDTBIN/NDTCMX*0.D0/, EDTCUT/NDTCMX*0.D0/
32635C DATA KDTREG/NNN1*0/, KDTDET/NNN2*0/, KDTSCD/NSCRMX*0/
32636C DATA TITDET/NDTCMX*' '/, TITSCO/NSCRMX*' '/
32637
32638* /detloc/
32639**sr 18.5. commented since not used for evap.
32640C DATA ACCUMP /NDTCM2*0.D0/, ACCUMN /NDTCM2*0.D0/, ICOINC /NDTCM2*0/
32641C DATA NCLAS /0/
32642
32643* /emgtrn/
32644**sr 18.5. commented since not used for evap.
32645C DATA LMCSMG / .FALSE. /
32646
32647* /emsho/
32648**sr 18.5. commented since not used for evap.
32649C DATA LIMPRE, LEXPTE / 2 * .FALSE. /
32650
32651* /episor/
32652**sr 18.5. commented since not used for evap.
32653C DATA TKESUM / 0.D+00 /, LUSSRC / .FALSE. /
32654
32655* /fheavy/
32656 DATA AMHEAV / 12 * 0.D+00 /
32657 DATA ANHEAV / 'NEUTRON ', 'PROTON ', 'DEUTERON', '3-H ',
32658 & '3-He ', '4-He ', 'H-FRAG-1', 'H-FRAG-2',
32659 & 'H-FRAG-3', 'H-FRAG-4', 'H-FRAG-5', 'H-FRAG-6'/
32660 DATA ICHEAV / 0, 1, 1, 1, 2, 2, 6*0 /,
32661 & IBHEAV / 1, 1, 2, 3, 3, 4, 6*0 /
32662 DATA NPHEAV / 0 /
32663
32664* /finuc/
32665 DATA NP / 0 /, TV / 0.D+00 /, TVCMS / 0.D+00 /, TVRECL / 0.D+00/,
32666 & TVHEAV / 0.D+00 /, TVBIND / 0.D+00 /
32667
32668* /genthr/
32669* Up to 20-apr-'95
32670* DATA PEANCT, PEAPIT / 2*1.D+00 /
32671* DATA PTHRSH / 16*5.D+00,2*2.5D+00,5.D+00,3*2.5D+00,8*5.D+00,
32672* & 9*2.5D+00 /
32673* DATA PTHDFF / 39*5.D+00 /
32674* & 9*2.5D+00 /
32675* New values:
32676**sr 18.5. commented since not used for evap.
32677C DATA PEANCT, PEAPIT / 1.3D+00, 1.1D+00 /
32678C DATA PTHRSH / 12*5.D+00, 2*3.5D+00, 2*5.D+00, 2*2.5D+00, 5.D+00,
32679C & 3*2.5D+00, 3.5D+00, 2*5.D+00, 3.5D+00, 4*5.D+00,
32680C & 9*2.5D+00 /
32681C DATA PTHDFF / 12*5.D+00, 2*3.5D+00, 8*5.D+00, 3.5D+00, 2*5.D+00,
32682C & 3.5D+00, 13*5.D+00 /
32683C DATA PLDNCT / 0.26D+00 /
32684C DATA IJNUCR / 16*1, 2*0, 1, 3*0, 8*1, 9*0 /
32685
32686* /lowneu/
32687**sr 18.5. commented since not used for evap.
32688C DATA WWAMFL / 10.D+00 /, EXTWWL / 1.D+00 /
32689C DATA IWWLWB, IWWLWT / 2 * 100000000 /
32690C DATA ICLMED, INABGN, IDWBGN, IETBGN / 4*0 /
32691C DATA IGRTHN / 1 /
32692C DATA LIMPRN / .FALSE. /, LBIASN / .FALSE. /, LDOWNN / .FALSE. /,
32693C & LLOWWW / .FALSE. /, LLOWET / .FALSE. /
32694
32695* /ltclcm/
32696**sr 18.5. commented since not used for evap.
32697C DATA MLATTC, NEWLAT, MLATLD, MLATM1, MLTSEN, MLTSM1 / 6*0 /
32698
32699* /mulbou/
32700**sr 18.5. commented since not used for evap.
32701C DATA LLDA, LAGAIN, LSTNEW, LARTEF, LSENSE, LNORML, LMGNOR
32702C & / 7 * .FALSE. /
32703C DATA TSENSE / AINFNT /, NSSENS / -1 /
32704C DATA DSMALL / ANGLGB /
32705
32706* /mulhd/
32707**sr 18.5. commented since not used for evap.
32708C DATA LTOPT / MXXMDF * .FALSE. /, NFSCAT / 0 /
32709C DATA ESTEPF / MXXMDF * 0.1D+00 /
32710C DATA LSRCRH / MXXMDF * .FALSE. /, LNSCRH / MXXMDF * .FALSE. /
32711C DATA THMSPR / 0.02D+00 /, THMSSC / 1.D+00 /
32712
32713* /parevt/
32714 DATA DPOWER /-13.D+00 /, FSPRD0 / 0.6D+00 /, FSHPFN / 0.0D+00 /,
32715 & RN1GSC /-1.0D+00 /, RN2GSC /-1.0D+00 /
32716 DATA LDIFFR / .TRUE., .TRUE., 6 * .TRUE., .TRUE., 8 * .TRUE.,
32717 & .TRUE., 4 * .TRUE., .TRUE., 3 * .TRUE.,
32718 & 4 * .FALSE., 9 * .TRUE./
32719**sr 17.5.95
32720* default value for LEVPRT changed (reset sr 25.7.97)
32721* default value for LHEAVY changed 25.7.97
32722C DATA LPOWER / .TRUE. /, LINCTV / .TRUE. /, LEVPRT / .TRUE. /,
32723C & LHEAVY / .FALSE. /, LDEEXG / .TRUE. /, LGDHPR / .TRUE. /,
32724C & LPREEX / .TRUE. /, LHLFIX / .FALSE. /, LPRFIX / .FALSE. /,
32725C & LPARWV / .TRUE. /, LSNGCH / .TRUE. /, LSCHDF / .TRUE. /
32726 DATA LPOWER / .TRUE. /, LINCTV / .TRUE. /, LEVPRT / .TRUE. /,
32727 & LHEAVY / .TRUE. /, LDEEXG / .TRUE. /, LGDHPR / .TRUE. /,
32728 & LPREEX / .TRUE. /, LHLFIX / .FALSE. /, LPRFIX / .FALSE. /,
32729 & LPARWV / .TRUE. /, LSNGCH / .TRUE. /, LSCHDF / .TRUE. /
32730**
32731**sr 27.5.97
32732* default value for ILVMOD changed
32733C DATA ILVMOD / 0 /, JLVMOD / 1 /, LLVMOD / .TRUE. /
32734 DATA ILVMOD / 1 /, JLVMOD / 1 /, LLVMOD / .TRUE. /
32735**
32736
32737* /resnuc/
32738 DATA IPREEH / 0 /, IPRTRI / 0 /, IPRDEU / 0 /, IPR3HE / 0 /,
32739 & IPR4HE / 0 /
32740 DATA IEVAPL / 0 /, IEVAPH / 0 /, IEVNEU / 0 /, IEVPRO / 0 /,
32741 & IEVTRI / 0 /, IEVDEU / 0 /, IEV3HE / 0 /, IEV4HE / 0 /,
32742 & IDEEXG / 0 /
32743 DATA LRNFSS / .FALSE. /
32744
32745* /scohlp/
32746**sr 18.5. commented since not used for evap.
32747C DATA ISCRNG, JSCRNG / 2*0 /, LSCZER / .FALSE. /
32748
32749* /trackr/
32750**sr 18.5. commented since not used for evap.
32751C DATA ETRACK /0.D+00/, WTRACK /0.D+00/, ATRACK /0.D+00/,
32752C & CTRACK /0.D+00/, NTRACK /0/, MTRACK /0/, JTRACK /0/
32753
32754* /usrbin/
32755**sr 18.5. commented since not used for evap.
32756C DATA LUSBIN, LUSEVT, LUSTKB /3*.FALSE./, NUSRBN /0/
32757
32758* /usrbdx/
32759**sr 18.5. commented since not used for evap.
32760C DATA LUSBDX /.FALSE./, NUSRBX /0/
32761
32762* /usrsnc/
32763**sr 18.5. commented since not used for evap.
32764C DATA LURSNC /.FALSE./, NURSNC /0/
32765
32766* /usrtrc/
32767**sr 18.5. commented since not used for evap.
32768C DATA LUSRTC, LUSTRK, LUSCLL / 3*.FALSE. /
32769C DATA NUSRTC, NUSTRK, NUSCLL / 3*0 /
32770
32771* /usryld/
32772**sr 18.5. commented since not used for evap.
32773C DATA LUSRYL / .FALSE./, LSCUYL / .FALSE. /, NUSRYL /0/,
32774C & IJUSYL /0/, JTUSYL /0/
32775C DATA PUSRYL, UUSRYL, VUSRYL, WUSRYL / 4*ZERZER /
32776
32777* /wwindw/
32778**sr 18.5. commented since not used for evap.
32779C DATA IWLBGN, IWHBGN, IWMBGN / 3*0 /
32780C DATA LWWPRM / .TRUE. /
32781
32782*= end*block.bdnopt *
32783 END
32784
32785*$ CREATE DT_BDPREE.FOR
32786*COPY DT_BDPREE
32787*
32788*=== bdpree ===========================================================*
32789*
32790 BLOCK DATA DT_BDPREE
32791
32792C INCLUDE '(DBLPRC)'
32793* DBLPRC.ADD
32794 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32795 SAVE
32796* (original name: GLOBAL)
32797 PARAMETER ( KALGNM = 2 )
32798 PARAMETER ( ANGLGB = 5.0D-16 )
32799 PARAMETER ( ANGLSQ = 2.5D-31 )
32800 PARAMETER ( AXCSSV = 0.2D+16 )
32801 PARAMETER ( ANDRFL = 1.0D-38 )
32802 PARAMETER ( AVRFLW = 1.0D+38 )
32803 PARAMETER ( AINFNT = 1.0D+30 )
32804 PARAMETER ( AZRZRZ = 1.0D-30 )
32805 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
32806 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
32807 PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
32808 PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
32809 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
32810 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
32811 PARAMETER ( CSNNRM = 2.0D-15 )
32812 PARAMETER ( DMXTRN = 1.0D+08 )
32813 PARAMETER ( ZERZER = 0.D+00 )
32814 PARAMETER ( ONEONE = 1.D+00 )
32815 PARAMETER ( TWOTWO = 2.D+00 )
32816 PARAMETER ( THRTHR = 3.D+00 )
32817 PARAMETER ( FOUFOU = 4.D+00 )
32818 PARAMETER ( FIVFIV = 5.D+00 )
32819 PARAMETER ( SIXSIX = 6.D+00 )
32820 PARAMETER ( SEVSEV = 7.D+00 )
32821 PARAMETER ( EIGEIG = 8.D+00 )
32822 PARAMETER ( ANINEN = 9.D+00 )
32823 PARAMETER ( TENTEN = 10.D+00 )
32824 PARAMETER ( HLFHLF = 0.5D+00 )
32825 PARAMETER ( ONETHI = ONEONE / THRTHR )
32826 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
32827 PARAMETER ( ONEFOU = ONEONE / FOUFOU )
32828 PARAMETER ( THRTWO = THRTHR / TWOTWO )
32829 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
32830 PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
32831 PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
32832 PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
32833 PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
32834 PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
32835 PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
32836 PARAMETER ( EULERO = 0.577215664901532860606512 D+00 )
32837 PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 )
32838 PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 )
32839 PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 )
32840 PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
32841 PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
32842 PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
32843 PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
32844 PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
32845 PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
32846 PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
32847 PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
32848 PARAMETER ( CLIGHT = 2.99792458 D+10 )
32849 PARAMETER ( AVOGAD = 6.0221367 D+23 )
32850 PARAMETER ( BOLTZM = 1.380658 D-23 )
32851 PARAMETER ( AMELGR = 9.1093897 D-28 )
32852 PARAMETER ( PLCKBR = 1.05457266 D-27 )
32853 PARAMETER ( ELCCGS = 4.8032068 D-10 )
32854 PARAMETER ( ELCMKS = 1.60217733 D-19 )
32855 PARAMETER ( AMUGRM = 1.6605402 D-24 )
32856 PARAMETER ( AMMUMU = 0.113428913 D+00 )
32857 PARAMETER ( AMPRMU = 1.007276470 D+00 )
32858 PARAMETER ( AMNEMU = 1.008664904 D+00 )
32859 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
32860 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
32861 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
32862 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
32863 PARAMETER ( PLABRC = 0.197327053 D+00 )
32864 PARAMETER ( AMELCT = 0.51099906 D-03 )
32865 PARAMETER ( AMUGEV = 0.93149432 D+00 )
32866 PARAMETER ( AMMUON = 0.105658389 D+00 )
32867 PARAMETER ( AMPRTN = 0.93827231 D+00 )
32868 PARAMETER ( AMNTRN = 0.93956563 D+00 )
32869 PARAMETER ( AMDEUT = 1.87561339 D+00 )
32870 PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
32871 & * 1.D-09 )
32872 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
32873 PARAMETER ( BLTZMN = 8.617385 D-14 )
32874 PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
32875 PARAMETER ( GFOHB3 = 1.16639 D-05 )
32876 PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
32877 PARAMETER ( SIN2TW = 0.2319 D+00 )
32878 PARAMETER ( GEVMEV = 1.0 D+03 )
32879 PARAMETER ( EMVGEV = 1.0 D-03 )
32880 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
32881 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
32882 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
32883 LOGICAL LGBIAS, LGBANA
32884 COMMON /FKGLOB/ LGBIAS, LGBANA
32885C INCLUDE '(DIMPAR)'
32886* DIMPAR.ADD
32887 PARAMETER ( MXXRGN = 5000 )
32888 PARAMETER ( MXXMDF = 82 )
32889 PARAMETER ( MXXMDE = 54 )
32890 PARAMETER ( MFSTCK = 1000 )
32891 PARAMETER ( MESTCK = 100 )
32892 PARAMETER ( NALLWP = 39 )
32893 PARAMETER ( NELEMX = 80 )
32894 PARAMETER ( MPDPDX = 8 )
32895 PARAMETER ( ICOMAX = 180 )
32896 PARAMETER ( NSTBIS = 304 )
32897 PARAMETER ( IDMAXP = 220 )
32898 PARAMETER ( IDMXDC = 640 )
32899 PARAMETER ( MKBMX1 = 1 )
32900 PARAMETER ( MKBMX2 = 1 )
32901C INCLUDE '(IOUNIT)'
32902* IOUNIT.ADD
32903 PARAMETER ( LUNIN = 5 )
32904 PARAMETER ( LUNOUT = 6 )
32905**sr 19.5. set error output-unit from 15 to 6
32906 PARAMETER ( LUNERR = 6 )
32907 PARAMETER ( LUNBER = 14 )
32908 PARAMETER ( LUNECH = 8 )
32909 PARAMETER ( LUNFLU = 13 )
32910 PARAMETER ( LUNGEO = 16 )
32911 PARAMETER ( LUNPMF = 12 )
32912 PARAMETER ( LUNRAN = 2 )
32913 PARAMETER ( LUNXSC = 9 )
32914 PARAMETER ( LUNDET = 17 )
32915 PARAMETER ( LUNRAY = 10 )
32916 PARAMETER ( LUNRDB = 1 )
32917 PARAMETER ( LUNPGO = 7 )
32918 PARAMETER ( LUNPGS = 4 )
32919 PARAMETER ( LUNSCR = 3 )
32920*
32921*----------------------------------------------------------------------*
32922* *
32923* Created on 16 september 1991 by Alfredo Ferrari & Paola Sala *
32924* Infn - Milan *
32925* *
32926* Last change on 03-feb-94 by Alfredo Ferrari *
32927* *
32928* *
32929*----------------------------------------------------------------------*
32930*
32931* (original name: CMPISG,CHPISG)
32932 PARAMETER ( TPPPI0 = 0.279656044337515D+00 )
32933 PARAMETER ( TNNPI0 = 0.279642680857450D+00 )
32934 PARAMETER ( TPPPIP = 0.292295207182790D+00 )
32935 PARAMETER ( TPPDEP = 0.287514778898469D+00 )
32936 PARAMETER ( TNNPIM = 0.286723140900975D+00 )
32937 PARAMETER ( TNNDEM = 0.281949292916434D+00 )
32938 PARAMETER ( TPNPI0 = 0.279456888147740D+00 )
32939 PARAMETER ( TPNDE0 = 0.274693916135245D+00 )
32940 PARAMETER ( TPNPIP = 0.292086756473890D+00 )
32941 PARAMETER ( TNPPI0 = 0.279842093144975D+00 )
32942 PARAMETER ( TNPDE0 = 0.275072555824202D+00 )
32943 PARAMETER ( TNPPIP = 0.292489370554958D+00 )
32944 PARAMETER ( PIRSMX = 1.2D+00 )
32945 PARAMETER ( NPIREA = 10 )
32946 PARAMETER ( NPIRTA = 68 )
32947 PARAMETER ( NPIRLN = 21 )
32948 PARAMETER ( NPIRLG = NPIRTA - NPIRLN )
32949 PARAMETER ( NPISIS = NPIRLN + 20 )
32950 PARAMETER ( NPISEX = NPIRLN + 21 )
32951 PARAMETER ( NPIIMN = 14 )
32952 PARAMETER ( NPIIRC = 6 )
32953 PARAMETER ( DELWLL = 0.035D+00 )
32954 CHARACTER CHPIRE*8
32955 LOGICAL LDLRES
32956 COMMON /FKCMPI/ PMNPIS, PMMPIS, PISPIS, PEXPIS, PMXPIS, DPPISG,
32957 & RTPISG, AMNPIS, AMMPIS, AISPIS, AEXPIS, AMXPIS,
32958 & ARPISG, BPISLO (NPIRLN:NPIRTA,NPIREA),
32959 & CPISLO (NPIRLN:NPIRTA,NPIREA), PPITHR (NPIREA),
32960 & SPISLO (NPIRLN:NPIRTA,NPIREA), APITHR (NPIREA),
32961 & SGPIIN (NPIIMN:NPIRTA,NPIIRC), RHPICR (1:5) ,
32962 & SGPICU (0:20,NPIRTA,NPIREA) , SGRTRS (NPIREA),
32963 & SGPIDF (0:20,NPIRTA,NPIREA) , BRREIN (NPIREA),
32964 & SGPIIS (NPIRTA,NPIREA) , BRREOU (NPIREA),
32965 & BRD3OU (2,2,-1:2), BRDEOU (2,-1:2),
32966 & SGABSR (2,2,4) , PRRSDL,
32967 & IPIREA (2,2,3:5) , IPIINE (2,3:5) , NPIRVR ,
32968 & KPIIRE (2,NPIREA), KPIORE (2,NPIREA) ,
32969 & JSTOKP (5), KPTOJS (23), ITTRRS (3:5), LDLRES
32970 COMMON /FKCHPI/ CHPIRE (NPIREA)
32971 DIMENSION SG2BRS (2,2), SGABSW (2,2), SG3BRS (2,2,2)
32972 EQUIVALENCE ( SG2BRS (1,1), SGABSR (1,1,1) )
32973 EQUIVALENCE ( SGABSW (1,1), SGABSR (1,1,2) )
32974 EQUIVALENCE ( SG3BRS (1,1,1), SGABSR (1,1,3) )
32975* (original name: FRBKCM)
32976 PARAMETER ( MXFFBK = 6 )
32977 PARAMETER ( MXZFBK = 9 )
32978 PARAMETER ( MXNFBK = 10 )
32979 PARAMETER ( MXAFBK = 16 )
32980 PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
32981 PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
32982 PARAMETER ( NXAFBK = MXAFBK + 1 )
32983 PARAMETER ( MXPSST = 300 )
32984 PARAMETER ( MXPSFB = 41000 )
32985 LOGICAL LFRMBK, LNCMSS
32986 COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
32987 & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
32988 & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
32989 & IFRBKN (MXPSST), IFRBKZ (MXPSST),
32990 & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
32991 & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
32992 & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
32993 & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
32994 & IFBFRB, NBUFBK, LFRMBK, LNCMSS
32995* (original name: NUCGID,NUCGEO,NUCGE2,NUCPWI,NUCGII)
32996 PARAMETER ( PI = PIPIPI )
32997 PARAMETER ( PISQ = PIPISQ )
32998 PARAMETER ( SKTOHL = 0.5456645846610345D+00 )
32999 PARAMETER ( RZNUCL = 1.12 D+00 )
33000 PARAMETER ( RMSPRO = 0.8 D+00 )
33001 PARAMETER ( R0PROT = RMSPRO / SQRT12 )
33002 PARAMETER ( ARHPRO = 1.D+00 / 8.D+00 / PI / R0PROT / R0PROT
33003 & / R0PROT )
33004 PARAMETER ( RLLE04 = RZNUCL )
33005 PARAMETER ( RLLE16 = RZNUCL )
33006 PARAMETER ( RLGT16 = RZNUCL )
33007 PARAMETER ( RCLE04 = 0.75D+00 / PI / RLLE04 / RLLE04 / RLLE04 )
33008 PARAMETER ( RCLE16 = 0.75D+00 / PI / RLLE16 / RLLE16 / RLLE16 )
33009 PARAMETER ( RCGT16 = 0.75D+00 / PI / RLGT16 / RLGT16 / RLGT16 )
33010 PARAMETER ( SKLE04 = 1.4D+00 )
33011 PARAMETER ( SKLE16 = 1.9D+00 )
33012 PARAMETER ( SKGT16 = 2.4D+00 )
33013 PARAMETER ( HLLE04 = SKTOHL * SKLE04 )
33014 PARAMETER ( HLLE16 = SKTOHL * SKLE16 )
33015 PARAMETER ( HLGT16 = SKTOHL * SKGT16 )
33016 PARAMETER ( ALPHA0 = 0.1D+00 )
33017 PARAMETER ( OMALH0 = 1.D+00 - ALPHA0 )
33018 PARAMETER ( GAMSK0 = 0.9D+00 )
33019 PARAMETER ( OMGAS0 = 1.D+00 - GAMSK0 )
33020 PARAMETER ( POTME0 = 0.6666666666666667D+00 )
33021 PARAMETER ( POTBA0 = 1.D+00 )
33022 PARAMETER ( PNFRAT = 1.533D+00 )
33023 PARAMETER ( RADPIM = 0.035D+00 )
33024 PARAMETER ( RDPMHL = 14.D+00 )
33025 PARAMETER ( APMRST = 4.D+00 / 44.D+00 )
33026 PARAMETER ( APMPRO = 1.D+00 / 6.D+00 )
33027 PARAMETER ( APPPRO = 5.D+00 / 6.D+00 )
33028 PARAMETER ( AP0PFS = 0.5D+00 )
33029 PARAMETER ( AP0PFP = 1.D+00 / 3.D+00 )
33030 PARAMETER ( AP0NFP = 2.D+00 / 3.D+00 )
33031 PARAMETER ( XPAUCO = 1.88495407241652 D+00 )
33032 PARAMETER ( MXSCIN = 50 )
33033 LOGICAL LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH, LNCDCY,
33034 & LNUSCT, LPREEQ, LNPHTC, LNWRAD, LPNRHO, LFTCMP, LFTCAC
33035 COMMON /FKNGID/ RHOTAB (2:260), RHATAB (2:260), ALPTAB (2:260),
33036 & RADTAB (2:260), SKITAB (2:260), HALTAB (2:260),
33037 & SK3TAB (2:260), SK4TAB (2:260), HABTAB (2:260),
33038 & CWSTAB (2:260), EKATAB (2:260), PFATAB (2:260),
33039 & PFRTAB (2:260)
33040 COMMON /FKNGEO/ RADTOT, RADIU1, RADIU0, RAD1O2, SKINDP, HALODP,
33041 & ALPHAL, OMALHL, RADSKN, SKNEFF, CPARWS, RADPRO,
33042 & RADCOR, RADCO2, RADMAX, BIMPTR, RIMPTR, XIMPTR,
33043 & YIMPTR, ZIMPTR, RHOIMT, EKFPRO, PFRPRO, RHOCEN,
33044 & RHOCOR, RHOSKN, EKFCEN (2), PFRCEN (2), EKFBIM,
33045 & PFRBIM, RHOIMP, EKFIMP, PFRIMP, RHOIM2, EKFIM2,
33046 & PFRIM2, RHOIM3, EKFIM3, PFRIM3, VPRWLL, RIMPCT,
33047 & BIMPCT, XIMPCT, YIMPCT, ZIMPCT, RIMPC2, XIMPC2,
33048 & YIMPC2, ZIMPC2, RIMPC3, XIMPC3, YIMPC3, ZIMPC3,
33049 & XBIMPC, YBIMPC, ZBIMPC, CXIMPC, CYIMPC, CZIMPC,
33050 & SQRIMP, SIGMAP, SIGMAN, SIGMAA, RHORED, R0TRAJ,
33051 & R1TRAJ, SBUSED, SBTOT , SBRES , RHOAVE, EKFAVE,
33052 & PFRAVE, AVEBIN, ACOLL , ZCOLL , RADSIG, OPACTY,
33053 & EKECON, PNUCCO, EKEWLL, PPRWLL, PXPROJ, PYPROJ,
33054 & PZPROJ, EKFERM, PNFRMI, PXFERM, PYFERM, PZFERM,
33055 & EKFER2, PNFRM2, PXFER2, PYFER2, PZFER2, EKFER3,
33056 & PNFRM3, PXFER3, PYFER3, PZFER3, RHOMEM, EKFMEM,
33057 & BIMMEM, WLLRED, VPRBIM, POTINC, POTOUT, EEXMIN
33058 COMMON /FKNGE2/ RDTTNC (2), RHONCP (2), RHONC2 (2), RHONC3 (2),
33059 & RHONCT (2), AMOTHR, EKOTHR, AMCREA, EKNCLN,
33060 & EEXDEL, EEXANY, CLMBBR, RDCLMB, BFCLMB, BFCEFF,
33061 & BNPROJ, BNDNUC, DEBRLM, SK4PAR, UBIMPC, VBIMPC,
33062 & WBIMPC, BNDPOT, SIGMAT, SIGABP, SIGABN, WLLRES,
33063 & POTBAR, POTMES, AGEPRI, OPNOPA, ETHRND,
33064 & BNENRG (3), DEFNUC (2), SIGMPR (4), SIGMNU (4),
33065 & SIGPAB (3), SIGNAB (3), HHLP (2), FORTOT (2),
33066 & FPNBLC, DPNBLC, FFTFLG, IFTFLG,
33067 & IPWELL, ITNCMX, KPRIN , NTARGT, KNUCIM, KNUCI2,
33068 & KNUCI3, IEVPRE, ISFCOL, ISFTAR, ISFTA2, ISFTA3,
33069 & NPOTHR, ICOTHR, IBOTHR, NPUMFN, ISTNCL, ITAUCM,
33070 & IABCOU, IADFLG, IGSFLG, IALFLG, ICBFLG, LPREEQ,
33071 & LNPHTC, LPNRHO, LNWRAD, LFTCMP, LFTCAC
33072 COMMON /FKNPWI/ ALMBAR, BIMMAX, SIGGEO, LLLMAX, LLLACT
33073 COMMON /FKNGII/ HOLEXP (2*MXSCIN), XEXPIN (3,0:MXSCIN),
33074 & YEXPIN (3,0:MXSCIN), ZEXPIN (3,0:MXSCIN),
33075 & AGEXIN (0:MXSCIN), RHOEXP (2), EKFEXP, EHLFIX,
33076 & NHLEXP, NHLFIX, IPRTYP, NNCEXI (0:MXSCIN),
33077 & NCEXPI (3,0:MXSCIN), ISEXIN (3,0:MXSCIN),
33078 & ISCTYP (0:MXSCIN), NUSCIN, NEXPEM,
33079 & LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH,
33080 & LNCDCY, LNUSCT
33081 DIMENSION AWSTAB (2:260), SIGMAB (3)
33082 EQUIVALENCE ( DEFPRO, DEFNUC (1) )
33083 EQUIVALENCE ( DEFNEU, DEFNUC (2) )
33084 EQUIVALENCE ( RHOIPP, RHONCP (1) )
33085 EQUIVALENCE ( RHOINP, RHONCP (2) )
33086 EQUIVALENCE ( RHOIP2, RHONC2 (1) )
33087 EQUIVALENCE ( RHOIN2, RHONC2 (2) )
33088 EQUIVALENCE ( RHOIP3, RHONC3 (1) )
33089 EQUIVALENCE ( RHOIN3, RHONC3 (2) )
33090 EQUIVALENCE ( RHOIPT, RHONCT (1) )
33091 EQUIVALENCE ( RHOINT, RHONCT (2) )
33092 EQUIVALENCE ( OMALHL, SK3PAR )
33093 EQUIVALENCE ( ALPHAL, HABPAR )
33094 EQUIVALENCE ( ALPTAB (2), AWSTAB (2) )
33095 EQUIVALENCE ( SIGMPE, SIGMPR (1) )
33096 EQUIVALENCE ( SIGMPC, SIGMPR (2) )
33097 EQUIVALENCE ( SIGMPI, SIGMPR (3) )
33098 EQUIVALENCE ( SIGMPA, SIGMPR (4) )
33099 EQUIVALENCE ( SIGMNE, SIGMNU (1) )
33100 EQUIVALENCE ( SIGMNC, SIGMNU (2) )
33101 EQUIVALENCE ( SIGMNI, SIGMNU (3) )
33102 EQUIVALENCE ( SIGMNA, SIGMNU (4) )
33103 EQUIVALENCE ( SIGMA2, SIGPAB (1) )
33104 EQUIVALENCE ( SIGMA3, SIGPAB (2) )
33105 EQUIVALENCE ( SIGMAS, SIGPAB (3) )
33106 EQUIVALENCE ( SIGPAB (1), SIGMAB (1) )
33107* (original name: NUCLEV)
33108 LOGICAL LCLVSL, LFLVSL, LRLVSL, LEQSBL
33109 COMMON /FKNLEV/ PAENUC (200,2), SHENUC (200,2), DEFRMI (2),
33110 & DEFMAG (2), ENNCLV (160,2), RANCLV (160,2),
33111 & CUMRAD (0:160,2), RUSNUC (2),
33112 & ENPLVL (114), ENNLVL(164), JUSNUC (160,2),
33113 & NTANUC (2), NAVNUC (2), NLSNUC (2), NCONUC (2),
33114 & NSKNUC (2), NHANUC (2), NUSNUC (2), NACNUC (2),
33115 & JMXNUC (2), IPRNUC (3), JPRNUC (3), MAGNUM (8),
33116 & MAGNUC (2), MGSNUC (8,2), MGSSNC (25,2),
33117 & NSBSHL (2), NMNSBS (2), NPRNUC, INUCLV, LCLVSL,
33118 & LFLVSL, LRLVSL, LEQSBL
33119 DIMENSION JUSPRO (160), JUSNEU (160), MGSPRO (8), MGSNEU (8),
33120 & MGSSPR (19) , MGSSNE (25)
33121 EQUIVALENCE ( RUSNUC (1), RUSPRO )
33122 EQUIVALENCE ( RUSNUC (2), RUSNEU )
33123 EQUIVALENCE ( JUSNUC (1,1), JUSPRO (1) )
33124 EQUIVALENCE ( JUSNUC (1,2), JUSNEU (1) )
33125 EQUIVALENCE ( MGSNUC (1,1), MGSPRO (1) )
33126 EQUIVALENCE ( MGSNUC (1,2), MGSNEU (1) )
33127 EQUIVALENCE ( MGSSNC (1,1), MGSSPR (1) )
33128 EQUIVALENCE ( MGSSNC (1,2), MGSSNE (1) )
33129 EQUIVALENCE ( NTANUC (1), NTAPRO )
33130 EQUIVALENCE ( NTANUC (2), NTANEU )
33131 EQUIVALENCE ( NAVNUC (1), NAVPRO )
33132 EQUIVALENCE ( NAVNUC (2), NAVNEU )
33133 EQUIVALENCE ( NLSNUC (1), NLSPRO )
33134 EQUIVALENCE ( NLSNUC (2), NLSNEU )
33135 EQUIVALENCE ( NCONUC (1), NCOPRO )
33136 EQUIVALENCE ( NCONUC (2), NCONEU )
33137 EQUIVALENCE ( NSKNUC (1), NSKPRO )
33138 EQUIVALENCE ( NSKNUC (2), NSKNEU )
33139 EQUIVALENCE ( NHANUC (1), NHAPRO )
33140 EQUIVALENCE ( NHANUC (2), NHANEU )
33141 EQUIVALENCE ( NUSNUC (1), NUSPRO )
33142 EQUIVALENCE ( NUSNUC (2), NUSNEU )
33143 EQUIVALENCE ( NACNUC (1), NACPRO )
33144 EQUIVALENCE ( NACNUC (2), NACNEU )
33145 EQUIVALENCE ( JMXNUC (1), JMXPRO )
33146 EQUIVALENCE ( JMXNUC (2), JMXNEU )
33147 EQUIVALENCE ( MAGNUC (1), MAGPRO )
33148 EQUIVALENCE ( MAGNUC (2), MAGNEU )
33149* (original name: PARNUC)
33150 PARAMETER ( PIGRK = PIPIPI )
33151 PARAMETER ( ALEVEL = 8.D-03 )
33152 PARAMETER ( RCNUCL = 1.12D+00 )
33153 PARAMETER ( R0SIG = 1.3D+00 )
33154 PARAMETER ( R0SIGK = 1.5D+00 )
33155 PARAMETER ( RCOULB = 1.5D+00 )
33156 PARAMETER ( COULBH = 0.88235D-03 )
33157 PARAMETER ( RHONU0 = 0.75D+00 / PIGRK / RCNUCL / RCNUCL / RCNUCL )
33158 PARAMETER ( TAUFO0 = 10.0D+00 )
33159 PARAMETER ( EKEEXP = 0.03D+00 )
33160 PARAMETER ( EKREXP = 0.05D+00 )
33161 PARAMETER ( EKEMNM = 0.01D+00 )
33162 PARAMETER ( NCPMX = 120 )
33163 COMMON /FKPARN/ EKORI , PXORI , PYORI , PZORI , PTORI , TAUFOR,
33164 & ENNUC (NCPMX), PNUCL (NCPMX), EKFNUC (NCPMX),
33165 & XSTNUC (NCPMX), YSTNUC (NCPMX), ZSTNUC (NCPMX),
33166 & PXNUCL (NCPMX), PYNUCL (NCPMX), PZNUCL (NCPMX),
33167 & RSTNUC (NCPMX), FREEPA (NCPMX), CRRPAN (NCPMX),
33168 & CRRPAP (NCPMX), BSTNUC (NCPMX), AGENUC (NCPMX),
33169 & TAUFPA (NCPMX), RHNUCL(NCPMX,2), BNDGAV, DEFMIN,
33170 & KPNUCL (NCPMX), KRFNUC (NCPMX), ILINUC (NCPMX),
33171 & INUCTS (NCPMX), ISFNUC (NCPMX), KPORI , IBORI ,
33172 & IBNUCL, NPNUC , NNUCTS
33173*
33174 DATA LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH / 6*.FALSE. /
33175 DATA POTBAR / POTBA0 /, POTMES / POTME0 /, WLLRES / 0.D+00 /
33176 DATA JUSNUC / 320 * 0 /, INUCLV / 1 /, IEVPRE / 0 /
33177 DATA MAGNUM / 2, 8, 20, 28, 50, 82, 126, 160 /
33178 DATA LPREEQ / .FALSE. /
33179* /cmpisg/
33180 DATA JSTOKP / 1, 8, 13, 14, 23 /
33181 DATA KPTOJS / 1, 6*0, 2, 4*0, 3, 4, 8*0, 5 /
33182 DATA CHPIRE / 'PI+PPI+P','PI-PPI-P','PI-PPI0N','PI0PPI0P',
33183 & 'PI0PPI+N','PI-NPI-N','PI+NPI+N','PI+NPI0P',
33184 & 'PI0NPI0N','PI0NPI-P' /
33185 DATA KPIIRE / 13, 1, 14, 1, 14, 1, 23, 1, 23, 1, 14, 8,
33186 & 13, 8, 13, 8, 23, 8, 23, 8 /
33187 DATA KPIORE / 13, 1, 14, 1, 23, 8, 23, 1, 13, 8, 14, 8,
33188 & 13, 8, 23, 1, 23, 8, 14, 1 /
33189 DATA IPIREA / 1, 0, 7, 8, 2, 3, 6, 0, 4, 5, 9, 10 /
33190 DATA IPIINE / 1, 2, 3, 4, 5, 6 /
33191* /frbkcm/
33192 DATA LFRMBK / .FALSE. /
33193 DATA NBUFBK / 500 /
33194 DATA EXMXFB / 80.0 D+00 /
33195 DATA R0FRBK / 1.18 D+00 /
33196 DATA R0CFBK / 2.173D+00 /
33197 DATA C1CFBK / 6.103D-03 /
33198 DATA C2CFBK / 9.443D-03 /
33199* /parnuc/
33200 DATA TAUFOR / TAUFO0 /
33201*=== End of Block Data Bdpree =========================================*
33202 END
33203
33204*$ CREATE DT_XHOINI.FOR
33205*COPY DT_XHOINI
33206*
33207*====phoini============================================================*
33208*
33209 SUBROUTINE DT_XHOINI
33210C SUBROUTINE DT_PHOINI
33211
33212 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33213 SAVE
33214 PARAMETER ( LINP = 10 ,
33215 & LOUT = 6 ,
33216 & LDAT = 9 )
33217
33218 RETURN
33219 END
33220
33221*$ CREATE DT_XVENTB.FOR
33222*COPY DT_XVENTB
33223*
33224*====eventb============================================================*
33225*
33226 SUBROUTINE DT_XVENTB(NCSY,IREJ)
33227C SUBROUTINE DT_EVENTB(NCSY,IREJ)
33228
33229 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33230 SAVE
33231 PARAMETER ( LINP = 10 ,
33232 & LOUT = 6 ,
33233 & LDAT = 9 )
33234
33235 WRITE(LOUT,1000)
33236 1000 FORMAT(1X,'EVENTB: PHOJET-package requested but not linked!')
33237 STOP
33238
33239 END
33240
33241*$ CREATE DT_XVENT.FOR
33242*COPY DT_XVENT
33243*
33244*===event==============================================================*
33245*
33246 SUBROUTINE DT_XVENT(IDUM,PP,PT,DUM,IREJ)
33247C SUBROUTINE EVENT(IDUM,PP,PT,DUM,IREJ)
33248
33249 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33250 SAVE
33251
33252 DIMENSION PP(4),PT(4)
33253
33254 RETURN
33255 END
33256
33257*$ CREATE DT_XOHISX.FOR
33258*COPY DT_XOHISX
33259*
33260*===pohisx=============================================================*
33261*
33262 SUBROUTINE DT_XOHISX(I,X)
33263C SUBROUTINE POHISX(I,X)
33264
33265 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33266 SAVE
33267
33268 RETURN
33269 END
33270
33271*$ CREATE PHO_LHIST.FOR
33272*COPY PHO_LHIST
33273*
33274*===poluhi=============================================================*
33275*
33276 SUBROUTINE PHO_LHIST(I,X)
33277**
33278
33279 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33280 SAVE
33281
33282 RETURN
33283 END
33284
33285*$ CREATE PDFSET.FOR
33286*COPY PDFSET
33287*
33288C**********************************************************************
33289C
33290C dummy subroutines, remove to link PDFLIB
33291C
33292C**********************************************************************
33293 SUBROUTINE PDFSET(PARAM,VALUE)
33294 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33295 DIMENSION PARAM(20),VALUE(20)
33296 CHARACTER*20 PARAM
33297 END
33298
33299*$ CREATE STRUCTM.FOR
33300*COPY STRUCTM
33301*
33302 SUBROUTINE STRUCTM(XI,SCALE2,UV,DV,US,DS,SS,CS,BS,TS,GL)
33303 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33304 END
33305
33306*$ CREATE STRUCTP.FOR
33307*COPY STRUCTP
33308*
33309 SUBROUTINE STRUCTP(XI,SCALE2,P2,IP2,UV,DV,US,DS,SS,CS,BS,TS,GL)
33310 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33311 END
33312
33313*$ CREATE DT_DIQBRK.FOR
33314*COPY DT_DIQBRK
33315*
33316*===diqbrk=============================================================*
33317*
33318 SUBROUTINE DT_XIQBRK
33319C SUBROUTINE DT_DIQBRK
33320
33321 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33322 SAVE
33323
33324 STOP 'diquark-breaking not implemeted !'
33325
33326 RETURN
33327 END
33328
33329*$ CREATE DT_ELHAIN.FOR
33330*COPY DT_ELHAIN
33331*
33332*===elhain=============================================================*
33333*
33334 SUBROUTINE DT_ELHAIN(IP,PLA,ELAB,CX,CY,CZ,IT,IREJ)
33335
33336************************************************************************
33337* Elastic hadron-hadron scattering. *
33338* This is a revised version of the original. *
33339* This version dated 03.04.98 is written by S. Roesler *
33340************************************************************************
33341
33342 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33343 SAVE
33344 PARAMETER ( LINP = 10 ,
33345 & LOUT = 6 ,
33346 & LDAT = 9 )
33347 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
33348 & TINY10=1.0D-10)
33349
33350 PARAMETER (ENNTHR = 3.5D0)
33351 PARAMETER (PLOWH=0.01D0,PHIH=9.0D0,
33352 & BLOWB=0.05D0,BHIB=0.2D0,
33353 & BLOWM=0.1D0, BHIM=2.0D0)
33354
33355* particle properties (BAMJET index convention)
33356 CHARACTER*8 ANAME
33357 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
33358 & IICH(210),IIBAR(210),K1(210),K2(210)
33359* final state from HADRIN interaction
33360 PARAMETER (MAXFIN=10)
33361 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
33362 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
33363
33364C DATA TSLOPE /10.0D0/
33365
33366 IREJ = 0
33367
33368 1 CONTINUE
33369
33370 PLAB = SQRT( (ELAB-AAM(IP))*(ELAB+AAM(IP)) )
33371 EKIN = ELAB-AAM(IP)
33372* kinematical quantities in cms of the hadrons
33373 AMP2 = AAM(IP)**2
33374 AMT2 = AAM(IT)**2
33375 S = AMP2+AMT2+TWO*ELAB*AAM(IT)
33376 ECM = SQRT(S)
33377 ECMP = OHALF*ECM+(AMP2-AMT2)/(TWO*ECM)
33378 PCM = SQRT( (ECMP-AAM(IP))*(ECMP+AAM(IP)) )
33379
33380* nucleon-nucleon scattering at E_kin<3.5: use DT_TSAMCS(HETC-KFA)
33381 IF ( ((IP.EQ.1).OR.(IP.EQ.8)).AND.
33382 & ((IT.EQ.1).OR.(IT.EQ.8)).AND.(EKIN.LT.ENNTHR) ) THEN
33383* TSAMCS treats pp and np only, therefore change pn into np and
33384* nn into pp
33385 IF (IT.EQ.1) THEN
33386 KPROJ = IP
33387 ELSE
33388 KPROJ = 8
33389 IF (IP.EQ.8) KPROJ = 1
33390 ENDIF
33391 CALL DT_TSAMCS(KPROJ,EKIN,CTCMS)
33392 T = TWO*PCM**2*(CTCMS-ONE)
33393
33394* very crude treatment otherwise: sample t from exponential dist.
33395 ELSE
33396* momentum transfer t
33397 TMAX = TWO*TWO*PCM**2
33398 RR = (PLAB-PLOWH)/(PHIH-PLOWH)
33399 IF (IIBAR(IP).NE.0) THEN
33400 TSLOPE = BLOWB+RR*(BHIB-BLOWB)
33401 ELSE
33402 TSLOPE = BLOWM+RR*(BHIM-BLOWM)
33403 ENDIF
33404 FMAX = EXP(-TSLOPE*TMAX)-ONE
33405 R = DT_RNDM(RR)
33406 T = LOG(ONE+R*FMAX+TINY10)/TSLOPE
33407 IF (T.GT.ZERO) T = LOG(ONE+R*FMAX)/TSLOPE
33408 ENDIF
33409
33410* target hadron in Lab after scattering
33411 ELRH(2) = (TWO*AMT2-T)/(TWO*AAM(IT))
33412 PLRH(2) = SQRT( ABS(ELRH(2)-AAM(IT))*(ELRH(2)+AAM(IT)) )
33413 IF (PLRH(2).LE.TINY10) THEN
33414C WRITE(*,*)'ELHAIN: T,PLRH(2) ',T,PLRH(2)
33415 GOTO 1
33416 ENDIF
33417* projectile hadron in Lab after scattering
33418 ELRH(1) = ELAB+AAM(IT)-ELRH(2)
33419 PLRH(1) = SQRT( ABS(ELRH(1)-AAM(IP))*(ELRH(1)+AAM(IP)) )
33420* scattering angle of projectile in Lab
33421 CTLABP = (T-TWO*AMP2+TWO*ELAB*ELRH(1))/(TWO*PLAB*PLRH(1))
33422 STLABP = SQRT( (ONE-CTLABP)*(ONE+CTLABP) )
33423 CALL DT_DSFECF(SPLABP,CPLABP)
33424* direction cosines of projectile in Lab
33425 CALL DT_STTRAN(CX,CY,CZ,CTLABP,STLABP,SPLABP,CPLABP,
33426 & CXRH(1),CYRH(1),CZRH(1))
33427* scattering angle of target in Lab
33428 PLLABT = PLAB-CTLABP*PLRH(1)
33429 CTLABT = PLLABT/PLRH(2)
33430 STLABT = SQRT( (ONE-CTLABT)*(ONE+CTLABT) )
33431* direction cosines of target in Lab
33432 CALL DT_STTRAN(CX,CY,CZ,CTLABT,STLABT,-SPLABP,-CPLABP,
33433 & CXRH(2),CYRH(2),CZRH(2))
33434* fill /HNFSPA/
33435 IRH = 2
33436 ITRH(1) = IP
33437 ITRH(2) = IT
33438
33439 RETURN
33440 END
33441
33442*$ CREATE DT_TSAMCS.FOR
33443*COPY DT_TSAMCS
33444*
33445*===tsamcs=============================================================*
33446*
33447 SUBROUTINE DT_TSAMCS(KPROJ,EKIN,CST)
33448
33449************************************************************************
33450* Sampling of cos(theta) for nucleon-proton scattering according to *
33451* hetkfa2/bertini parametrization. *
33452* This is a revised version of the original (HJM 24/10/88) *
33453* This version dated 28.10.95 is written by S. Roesler *
33454************************************************************************
33455
33456 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33457 SAVE
33458 PARAMETER ( LINP = 10 ,
33459 & LOUT = 6 ,
33460 & LDAT = 9 )
33461 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
33462 & TINY10=1.0D-10)
33463
33464 DIMENSION DCLIN(195),DCHN(143),DCHNA(36),DCHNB(60)
33465 DIMENSION PDCI(60),PDCH(55)
33466
33467 DATA (DCLIN(I),I=1,80) /
33468 & 5.000D-01, 1.000D+00, 0.000D+00, 1.000D+00, 0.000D+00,
33469 & 4.993D-01, 9.881D-01, 5.963D-02, 9.851D-01, 5.945D-02,
33470 & 4.936D-01, 8.955D-01, 5.224D-01, 8.727D-01, 5.091D-01,
33471 & 4.889D-01, 8.228D-01, 8.859D-01, 7.871D-01, 8.518D-01,
33472 & 4.874D-01, 7.580D-01, 1.210D+00, 7.207D-01, 1.117D+00,
33473 & 4.912D-01, 6.969D-01, 1.516D+00, 6.728D-01, 1.309D+00,
33474 & 5.075D-01, 6.471D-01, 1.765D+00, 6.667D-01, 1.333D+00,
33475 & 5.383D-01, 6.054D-01, 1.973D+00, 7.059D-01, 1.176D+00,
33476 & 5.397D-01, 5.990D-01, 2.005D+00, 7.023D-01, 1.191D+00,
33477 & 5.336D-01, 6.083D-01, 1.958D+00, 6.959D-01, 1.216D+00,
33478 & 5.317D-01, 6.075D-01, 1.962D+00, 6.897D-01, 1.241D+00,
33479 & 5.300D-01, 6.016D-01, 1.992D+00, 6.786D-01, 1.286D+00,
33480 & 5.281D-01, 6.063D-01, 1.969D+00, 6.786D-01, 1.286D+00,
33481 & 5.280D-01, 5.960D-01, 2.020D+00, 6.667D-01, 1.333D+00,
33482 & 5.273D-01, 5.920D-01, 2.040D+00, 6.604D-01, 1.358D+00,
33483 & 5.273D-01, 5.862D-01, 2.069D+00, 6.538D-01, 1.385D+00/
33484 DATA (DCLIN(I),I=81,160) /
33485 & 5.223D-01, 5.980D-01, 2.814D+00, 6.538D-01, 1.385D+00,
33486 & 5.202D-01, 5.969D-01, 2.822D+00, 6.471D-01, 1.412D+00,
33487 & 5.183D-01, 5.881D-01, 2.883D+00, 6.327D-01, 1.469D+00,
33488 & 5.159D-01, 5.866D-01, 2.894D+00, 6.250D-01, 1.500D+00,
33489 & 5.133D-01, 5.850D-01, 2.905D+00, 6.170D-01, 1.532D+00,
33490 & 5.106D-01, 5.833D-01, 2.917D+00, 6.087D-01, 1.565D+00,
33491 & 5.084D-01, 5.801D-01, 2.939D+00, 6.000D-01, 1.600D+00,
33492 & 5.063D-01, 5.763D-01, 2.966D+00, 5.909D-01, 1.636D+00,
33493 & 5.036D-01, 5.730D-01, 2.989D+00, 5.814D-01, 1.674D+00,
33494 & 5.014D-01, 5.683D-01, 3.022D+00, 5.714D-01, 1.714D+00,
33495 & 4.986D-01, 5.641D-01, 3.051D+00, 5.610D-01, 1.756D+00,
33496 & 4.964D-01, 5.580D-01, 3.094D+00, 5.500D-01, 1.800D+00,
33497 & 4.936D-01, 5.573D-01, 3.099D+00, 5.431D-01, 1.827D+00,
33498 & 4.909D-01, 5.509D-01, 3.144D+00, 5.313D-01, 1.875D+00,
33499 & 4.885D-01, 5.512D-01, 3.142D+00, 5.263D-01, 1.895D+00,
33500 & 4.857D-01, 5.437D-01, 3.194D+00, 5.135D-01, 1.946D+00/
33501 DATA (DCLIN(I),I=161,195) /
33502 & 4.830D-01, 5.353D-01, 3.253D+00, 5.000D-01, 2.000D+00,
33503 & 4.801D-01, 5.323D-01, 3.274D+00, 4.915D-01, 2.034D+00,
33504 & 4.770D-01, 5.228D-01, 3.341D+00, 4.767D-01, 2.093D+00,
33505 & 4.738D-01, 5.156D-01, 3.391D+00, 4.643D-01, 2.143D+00,
33506 & 4.701D-01, 5.010D-01, 3.493D+00, 4.444D-01, 2.222D+00,
33507 & 4.672D-01, 4.990D-01, 3.507D+00, 4.375D-01, 2.250D+00,
33508 & 4.634D-01, 4.856D-01, 3.601D+00, 4.194D-01, 2.323D+00/
33509
33510 DATA PDCI /
33511 & 4.400D+02, 1.896D-01, 1.931D-01, 1.982D-01, 1.015D-01,
33512 & 1.029D-01, 4.180D-02, 4.228D-02, 4.282D-02, 4.350D-02,
33513 & 2.204D-02, 2.236D-02, 5.900D+02, 1.433D-01, 1.555D-01,
33514 & 1.774D-01, 1.000D-01, 1.128D-01, 5.132D-02, 5.600D-02,
33515 & 6.158D-02, 6.796D-02, 3.660D-02, 3.820D-02, 6.500D+02,
33516 & 1.192D-01, 1.334D-01, 1.620D-01, 9.527D-02, 1.141D-01,
33517 & 5.283D-02, 5.952D-02, 6.765D-02, 7.878D-02, 4.796D-02,
33518 & 6.957D-02, 8.000D+02, 4.872D-02, 6.694D-02, 1.152D-01,
33519 & 9.348D-02, 1.368D-01, 6.912D-02, 7.953D-02, 9.577D-02,
33520 & 1.222D-01, 7.755D-02, 9.525D-02, 1.000D+03, 3.997D-02,
33521 & 5.456D-02, 9.804D-02, 8.084D-02, 1.208D-01, 6.520D-02,
33522 & 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02, 1.093D-01/
33523
33524 DATA PDCH /
33525 & 1.000D+03, 9.453D-02, 9.804D-02, 8.084D-02, 1.208D-01,
33526 & 6.520D-02, 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02,
33527 & 1.093D-01, 1.400D+03, 1.072D-01, 7.450D-02, 6.645D-02,
33528 & 1.136D-01, 6.750D-02, 8.580D-02, 1.110D-01, 1.530D-01,
33529 & 1.010D-01, 1.350D-01, 2.170D+03, 4.004D-02, 3.013D-02,
33530 & 2.664D-02, 5.511D-02, 4.240D-02, 7.660D-02, 1.364D-01,
33531 & 2.300D-01, 1.670D-01, 2.010D-01, 2.900D+03, 1.870D-02,
33532 & 1.804D-02, 1.320D-02, 2.970D-02, 2.860D-02, 5.160D-02,
33533 & 1.020D-01, 2.400D-01, 2.250D-01, 3.370D-01, 4.400D+03,
33534 & 1.196D-03, 8.784D-03, 1.517D-02, 2.874D-02, 2.488D-02,
33535 & 4.464D-02, 8.330D-02, 2.008D-01, 2.360D-01, 3.567D-01/
33536
33537 DATA (DCHN(I),I=1,90) /
33538 & 4.770D-01, 4.750D-01, 4.715D-01, 4.685D-01, 4.650D-01,
33539 & 4.610D-01, 4.570D-01, 4.550D-01, 4.500D-01, 4.450D-01,
33540 & 4.405D-01, 4.350D-01, 4.300D-01, 4.250D-01, 4.200D-01,
33541 & 4.130D-01, 4.060D-01, 4.000D-01, 3.915D-01, 3.840D-01,
33542 & 3.760D-01, 3.675D-01, 3.580D-01, 3.500D-01, 3.400D-01,
33543 & 3.300D-01, 3.200D-01, 3.100D-01, 3.000D-01, 2.900D-01,
33544 & 2.800D-01, 2.700D-01, 2.600D-01, 2.500D-01, 2.400D-01,
33545 & 2.315D-01, 2.240D-01, 2.150D-01, 2.060D-01, 2.000D-01,
33546 & 1.915D-01, 1.850D-01, 1.780D-01, 1.720D-01, 1.660D-01,
33547 & 1.600D-01, 1.550D-01, 1.500D-01, 1.450D-01, 1.400D-01,
33548 & 1.360D-01, 1.320D-01, 1.280D-01, 1.250D-01, 1.210D-01,
33549 & 1.180D-01, 1.150D-01, 1.120D-01, 1.100D-01, 1.070D-01,
33550 & 1.050D-01, 1.030D-01, 1.010D-01, 9.900D-02, 9.700D-02,
33551 & 9.550D-02, 9.480D-02, 9.400D-02, 9.200D-02, 9.150D-02,
33552 & 9.100D-02, 9.000D-02, 8.990D-02, 8.900D-02, 8.850D-02,
33553 & 8.750D-02, 8.700D-02, 8.650D-02, 8.550D-02, 8.500D-02,
33554 & 8.499D-02, 8.450D-02, 8.350D-02, 8.300D-02, 8.250D-02,
33555 & 8.150D-02, 8.100D-02, 8.030D-02, 8.000D-02, 7.990D-02/
33556 DATA (DCHN(I),I=91,143) /
33557 & 7.980D-02, 7.950D-02, 7.900D-02, 7.860D-02, 7.800D-02,
33558 & 7.750D-02, 7.650D-02, 7.620D-02, 7.600D-02, 7.550D-02,
33559 & 7.530D-02, 7.500D-02, 7.499D-02, 7.498D-02, 7.480D-02,
33560 & 7.450D-02, 7.400D-02, 7.350D-02, 7.300D-02, 7.250D-02,
33561 & 7.230D-02, 7.200D-02, 7.100D-02, 7.050D-02, 7.020D-02,
33562 & 7.000D-02, 6.999D-02, 6.995D-02, 6.993D-02, 6.991D-02,
33563 & 6.990D-02, 6.870D-02, 6.850D-02, 6.800D-02, 6.780D-02,
33564 & 6.750D-02, 6.700D-02, 6.650D-02, 6.630D-02, 6.600D-02,
33565 & 6.550D-02, 6.525D-02, 6.510D-02, 6.500D-02, 6.499D-02,
33566 & 6.498D-02, 6.496D-02, 6.494D-02, 6.493D-02, 6.490D-02,
33567 & 6.488D-02, 6.485D-02, 6.480D-02/
33568
33569 DATA DCHNA /
33570 & 6.300D+02, 7.810D-02, 1.421D-01, 1.979D-01, 2.479D-01,
33571 & 3.360D-01, 5.400D-01, 7.236D-01, 1.000D+00, 1.540D+03,
33572 & 2.225D-01, 3.950D-01, 5.279D-01, 6.298D-01, 7.718D-01,
33573 & 9.405D-01, 9.835D-01, 1.000D+00, 2.560D+03, 2.625D-01,
33574 & 4.550D-01, 5.963D-01, 7.020D-01, 8.380D-01, 9.603D-01,
33575 & 9.903D-01, 1.000D+00, 3.520D+03, 4.250D-01, 6.875D-01,
33576 & 8.363D-01, 9.163D-01, 9.828D-01, 1.000D+00, 1.000D+00,
33577 & 1.000D+00/
33578
33579 DATA DCHNB /
33580 & 6.300D+02, 3.800D-02, 7.164D-02, 1.275D-01, 2.171D-01,
33581 & 3.227D-01, 4.091D-01, 5.051D-01, 6.061D-01, 7.074D-01,
33582 & 8.434D-01, 1.000D+00, 2.040D+03, 1.200D-01, 2.115D-01,
33583 & 3.395D-01, 5.295D-01, 7.251D-01, 8.511D-01, 9.487D-01,
33584 & 9.987D-01, 1.000D+00, 1.000D+00, 1.000D+00, 2.200D+03,
33585 & 1.344D-01, 2.324D-01, 3.754D-01, 5.674D-01, 7.624D-01,
33586 & 8.896D-01, 9.808D-01, 1.000D+00, 1.000D+00, 1.000D+00,
33587 & 1.000D+00, 2.850D+03, 2.330D-01, 4.130D-01, 6.610D-01,
33588 & 9.010D-01, 9.970D-01, 1.000D+00, 1.000D+00, 1.000D+00,
33589 & 1.000D+00, 1.000D+00, 1.000D+00, 3.500D+03, 3.300D-01,
33590 & 5.450D-01, 7.950D-01, 1.000D+00, 1.000D+00, 1.000D+00,
33591 & 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00/
33592
33593 CST = ONE
33594 IF (EKIN.GT.3.5D0) RETURN
33595C
33596 IF(KPROJ.EQ.8) GOTO 101
33597 IF(KPROJ.EQ.1) GOTO 102
33598C* INVALID REACTION
33599 WRITE(LOUT,'(A,I5/A)')
33600 & ' INVALID PARTICLE TYPE IN DNUPRE - KPROJ=',KPROJ,
33601 & ' COS(THETA) = 1D0 RETURNED'
33602 RETURN
33603C-------------------------------- NP ELASTIC SCATTERING----------
33604101 CONTINUE
33605 IF (EKIN.GT.0.740D0)GOTO 1000
33606 IF (EKIN.LT.0.300D0)THEN
33607C EKIN .LT. 300 MEV
33608 IDAT=1
33609 ELSE
33610C 300 MEV < EKIN < 740 MEV
33611 IDAT=6
33612 END IF
33613C
33614 ENER=EKIN
33615 IE=INT(ABS(ENER/0.020D0))
33616 UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
33617C FORWARD/BACKWARD DECISION
33618 K=IDAT+5*IE
33619 BWFW=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
33620 IF (DT_RNDM(CST).LT.BWFW)THEN
33621 VALUE2=-1D0
33622 K=K+1
33623 ELSE
33624 VALUE2=1D0
33625 K=K+3
33626 END IF
33627C
33628 COEF=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
33629 RND=DT_RNDM(COEF)
33630C
33631 IF(RND.LT.COEF)THEN
33632 CST=DT_RNDM(RND)
33633 CST=CST*VALUE2
33634 ELSE
33635 R1=DT_RNDM(CST)
33636 R2=DT_RNDM(R1)
33637 R3=DT_RNDM(R2)
33638 R4=DT_RNDM(R3)
33639C
33640 IF(VALUE2.GT.0.0)THEN
33641 CST=MAX(R1,R2,R3,R4)
33642 GOTO 1500
33643 ELSE
33644 R5=DT_RNDM(R4)
33645C
33646 IF (IDAT.EQ.1)THEN
33647 CST=-MAX(R1,R2,R3,R4,R5)
33648 ELSE
33649 R6=DT_RNDM(R5)
33650 R7=DT_RNDM(R6)
33651 CST=-MAX(R1,R2,R3,R4,R5,R6,R7)
33652 END IF
33653C
33654 END IF
33655C
33656 END IF
33657C
33658 GOTO 1500
33659C
33660C******** EKIN .GT. 0.74 GEV
33661C
336621000 ENER=EKIN - 0.66D0
33663C IE=ABS(ENER/0.02)
33664 IE=INT(ENER/0.02D0)
33665 EMEV=EKIN*1D3
33666C
33667 UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
33668 K=IE
33669 BWFW=(DCHN(K+1)-DCHN(K))*UNIV + DCHN(K)
33670 RND=DT_RNDM(BWFW)
33671C FORWARD NEUTRON
33672 IF (RND.GE.BWFW)THEN
33673 DO 1200 K=10,36,9
33674 IF (DCHNA(K).GT.EMEV) THEN
33675 UNIVE=(EMEV-DCHNA(K-9))/(DCHNA(K)-DCHNA(K-9))
33676 UNIV=DT_RNDM(UNIVE)
33677 DO 1100 I=1,8
33678 II=K+I
33679 P=(DCHNA(II)-DCHNA(II-9))*UNIVE + DCHNA(II-9)
33680C
33681 IF (P.GT.UNIV)THEN
33682 UNIV=DT_RNDM(UNIVE)
33683 FLTI=DBLE(I)-UNIV
33684 GOTO(290,290,290,290,330,340,350,360) I
33685 END IF
33686 1100 CONTINUE
33687 END IF
33688 1200 CONTINUE
33689C
33690 ELSE
33691C BACKWARD NEUTRON
33692 DO 1400 K=13,60,12
33693 IF (DCHNB(K).GT.EMEV) THEN
33694 UNIVE=(EMEV-DCHNB(K-12))/(DCHNB(K)-DCHNB(K-12))
33695 UNIV=DT_RNDM(UNIVE)
33696 DO 1300 I=1,11
33697 II=K+I
33698 P=(DCHNB(II)-DCHNB(II-12))*UNIVE + DCHNB(II-12)
33699C
33700 IF (P.GT.UNIV)THEN
33701 UNIV=DT_RNDM(P)
33702 FLTI=DBLE(I)-UNIV
33703 GOTO(120,120,140,150,160,160,180,190,200,210,220) I
33704 END IF
33705 1300 CONTINUE
33706 END IF
33707 1400 CONTINUE
33708 END IF
33709C
33710120 CST=1.0D-2*FLTI-1.0D0
33711 GOTO 1500
33712140 CST=2.0D-2*UNIV-0.98D0
33713 GOTO 1500
33714150 CST=4.0D-2*UNIV-0.96D0
33715 GOTO 1500
33716160 CST=6.0D-2*FLTI-1.16D0
33717 GOTO 1500
33718180 CST=8.0D-2*UNIV-0.80D0
33719 GOTO 1500
33720190 CST=1.0D-1*UNIV-0.72D0
33721 GOTO 1500
33722200 CST=1.2D-1*UNIV-0.62D0
33723 GOTO 1500
33724210 CST=2.0D-1*UNIV-0.50D0
33725 GOTO 1500
33726220 CST=3.0D-1*(UNIV-1.0D0)
33727 GOTO 1500
33728C
33729290 CST=1.0D0-2.5d-2*FLTI
33730 GOTO 1500
33731330 CST=0.85D0+0.5D-1*UNIV
33732 GOTO 1500
33733340 CST=0.70D0+1.5D-1*UNIV
33734 GOTO 1500
33735350 CST=0.50D0+2.0D-1*UNIV
33736 GOTO 1500
33737360 CST=0.50D0*UNIV
33738C
337391500 RETURN
33740C
33741C----------------------------------- PP ELASTIC SCATTERING -------
33742C
33743 102 CONTINUE
33744 EMEV=EKIN*1D3
33745C
33746 IF (EKIN.LE.0.500D0) THEN
33747 RND=DT_RNDM(EMEV)
33748 CST=2.0D0*RND-1.0D0
33749 RETURN
33750C
33751 ELSEIF (EKIN.LT.1.0D0) THEN
33752 DO 2200 K=13,60,12
33753 IF (PDCI(K).GT.EMEV) THEN
33754 UNIVE=(EMEV-PDCI(K-12))/(PDCI(K)-PDCI(K-12))
33755 UNIV=DT_RNDM(UNIVE)
33756 SUM=0
33757 DO 2100 I=1,11
33758 II=K+I
33759 SUM=SUM + (PDCI(II)-PDCI(II-12))*UNIVE + PDCI(II-12)
33760C
33761 IF (UNIV.LT.SUM)THEN
33762 UNIV=DT_RNDM(SUM)
33763 FLTI=DBLE(I)-UNIV
33764 GOTO(55,55,55,60,60,65,65,65,65,70,70) I
33765 END IF
33766 2100 CONTINUE
33767 END IF
33768 2200 CONTINUE
33769 ELSE
33770 DO 2400 K=12,55,11
33771 IF (PDCH(K).GT.EMEV) THEN
33772 UNIVE=(EMEV-PDCH(K-11))/(PDCH(K)-PDCH(K-11))
33773 UNIV=DT_RNDM(UNIVE)
33774 SUM=0.0D0
33775 DO 2300 I=1,10
33776 II=K+I
33777 SUM=SUM + (PDCH(II)-PDCH(II-11))*UNIVE + PDCH(II-11)
33778C
33779 IF (UNIV.LT.SUM)THEN
33780 UNIV=DT_RNDM(SUM)
33781 FLTI=UNIV+DBLE(I)
33782 GOTO(50,55,60,60,65,65,65,65,70,70) I
33783 END IF
33784 2300 CONTINUE
33785 END IF
33786 2400 CONTINUE
33787 END IF
33788C
3378950 CST=0.4D0*UNIV
33790 GOTO 2500
3379155 CST=0.2D0*FLTI
33792 GOTO 2500
3379360 CST=0.3D0+0.1D0*FLTI
33794 GOTO 2500
3379565 CST=0.6D0+0.04D0*FLTI
33796 GOTO 2500
3379770 CST=0.78D0+0.02D0*FLTI
33798C
337992500 CONTINUE
33800 IF (DT_RNDM(CST).GT.0.5D0) CST=-CST
33801C
33802 RETURN
33803 END
33804
33805*$ CREATE DT_DHADRI.FOR
33806*COPY DT_DHADRI
33807*
33808*===dhadri=============================================================*
33809*
33810 SUBROUTINE DT_DHADRI(N,PLAB,ELAB,CX,CY,CZ,ITTA)
33811
33812 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33813 SAVE
33814
33815 PARAMETER ( LINP = 10 ,
33816 & LOUT = 6 ,
33817 & LDAT = 9 )
33818C
33819C-----------------------------
33820C*** INPUT VARIABLES LIST:
33821C*** SAMPLING OF HADRON NUCLEON INTERACTION FOR (ABOUT) 0.1 LE PLAB LE 6
33822C*** GEV/C LABORATORY MOMENTUM REGION
33823C*** N - PROJECTILE HADRON INDEX
33824C*** PLAB - LABORATORY MOMENTUM OF N (GEV/C)
33825C*** ELAB - LABORATORY ENERGY OF N (GEV)
33826C*** CX,CY,CZ - DIRECTION COSINES OF N IN THE LABORATORY SYSTEM
33827C*** ITTA - TARGET NUCLEON INDEX
33828C*** OUTPUT VARIABLES LIST OF PARTICLE CHARACTERISTICS IN /FINLSP/
33829C IR COUNTS THE NUMBER OF PRODUCED PARTICLES
33830C*** ITR - PARTICLE INDEX, CXR,CYR,CZR - DIRECTION COSINES (LAB. SYST.)
33831C*** ELR,PLR LAB. ENERGY AND LAB. MOMENTUM OF THE SAMPLED PARTICLE
33832C*** RESPECT., UNITS (GEV/C AND GEV)
33833C----------------------------
33834
33835 COMMON /HNGAMR/ REDU,AMO,AMM(15)
33836 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33837 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33838 & NRK(2,268),NURE(30,2)
33839* particle properties (BAMJET index convention),
33840* (dublicate of DTPART for HADRIN)
33841 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33842 & K1H(110),K2H(110)
33843 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
33844 COMMON /HNMETL/ CXS(149),CYS(149),CZS(149),ELS(149),PLS(149),
33845 & ITS(149),IS
33846 COMMON /HNDRUN/ RUNTES,EFTES
33847* particle properties (BAMJET index convention)
33848 CHARACTER*8 ANAME
33849 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
33850 & IICH(210),IIBAR(210),K1(210),K2(210)
33851* final state from HADRIN interaction
33852 PARAMETER (MAXFIN=10)
33853 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
33854 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
33855
33856 DIMENSION ITPRF(110)
33857 DATA NNN/0/
33858 DATA UMODA/0./
33859 DATA ITPRF/-1,-1,5*1,-1,-1,1,1,1,-1,-1,-1,-1,6*1,-1,-1,-1,85*1/
33860 LOWP=0
33861 IF (N.LE.0.OR.N.GE.111)N=1
33862 IF (ITPRF( N ).GT.0 .OR. ITTA.GT.8) THEN
33863 GOTO 280
33864* WRITE (6,1000)
33865* + ' FALSE USE OF THE PARTICLE TYPE INDEX: N, ITTA', N, ITTA
33866* STOP
33867*1000 FORMAT (3(5H ****/),A,2I4,3(5H ****/))
33868* + 45H FALSE USE OF THE PARTICLE TYPE INDEX, N,LUE ,I4,3(5H ****/))
33869 ENDIF
33870 IATMPT=0
33871 IF (ABS(PLAB-5.0D0).LT.4.99999D0) GO TO 20
33872C IF(IPRI.GE.1) WRITE (6,1010) PLAB
33873C STOP
33874 1010 FORMAT ( ' PROJECTILE HADRON MOMENTUM OUTSIDE OF THE
33875 + ALLOWED REGION, PLAB=',1E15.5)
33876
33877 20 CONTINUE
33878 UMODAT=N*1.11111D0+ITTA*2.19291D0
33879 IF(UMODAT.NE.UMODA) CALL DT_DCALUM(N,ITTA)
33880 UMODA=UMODAT
33881 30 IATMPT=0
33882 LOWP=LOWP+1
33883 40 CONTINUE
33884 IMACH=0
33885 REDU=2.0D0
33886 IF (LOWP.GT.20) THEN
33887C WRITE(LOUT,*) ' jump 1'
33888 GO TO 280
33889 ENDIF
33890 NNN=N
33891 IF (NNN.EQ.N) GO TO 50
33892 RUNTES=0.0D0
33893 EFTES=0.0D0
33894 50 CONTINUE
33895 IS=1
33896 IRH=0
33897 IST=1
33898 NSTAB=23
33899 IRE=NURE(N,1)
33900 IF(ITTA.GT.1) IRE=NURE(N,2)
33901C
33902C-----------------------------
33903C*** IE,AMT,ECM,SI DETERMINATION
33904C----------------------------
33905 CALL DT_DSIGIN(IRE,PLAB,N,IE,AMT ,AMN,ECM,SI,ITTA)
33906 IANTH=-1
33907**sr
33908C IF (AMH(1).NE.0.93828D0) IANTH=1
33909 IF (AMH(1).NE.0.9383D0) IANTH=1
33910**
33911 IF (IANTH.GE.0) SI=1.0D0
33912 ECMMH=ECM
33913C
33914C-----------------------------
33915C ENERGY INDEX
33916C IRE CHARACTERIZES THE REACTION
33917C IE IS THE ENERGY INDEX
33918C----------------------------
33919 IF (SI.LT.1.D-6) THEN
33920C WRITE(LOUT,*) ' jump 2'
33921 GO TO 280
33922 ENDIF
33923 IF (N.LE.NSTAB) GO TO 60
33924 RUNTES=RUNTES+1.0D0
33925 IF (RUNTES.LT.20.D0) WRITE(LOUT,1020)N
33926 1020 FORMAT(3H N=,I10,30H THE PROEKTILE IS A RESONANCE )
33927 IF(IBARH(N).EQ.1) N=8
33928 IF(IBARH(N).EQ.-1) N=9
33929 60 CONTINUE
33930 IMACH=IMACH+1
33931**sr 19.2.97: loop for direct channel suppression
33932C IF (IMACH.GT.10) THEN
33933 IF (IMACH.GT.1000) THEN
33934**
33935C WRITE(LOUT,*) ' jump 3'
33936 GO TO 280
33937 ENDIF
33938 ECM =ECMMH
33939 AMN2=AMN**2
33940 AMT2=AMT**2
33941 ECMN=(ECM**2+AMN2-AMT2)/(2.0D0*ECM )
33942 IF(ECMN.LE.AMN) ECMN=AMN
33943 PCMN=SQRT(ECMN**2-AMN2)
33944 GAM=(ELAB+AMT)/ECM
33945 BGAM=PLAB/ECM
33946 IF (IANTH.GE.0) ECM=2.1D0
33947C
33948C-----------------------------
33949C*** RANDOM CHOICE OF REACTION CHANNEL
33950C----------------------------
33951 IST=0
33952 VV=DT_RNDM(AMN2)
33953 VV=VV-1.D-17
33954C
33955C-----------------------------
33956C*** PLACE REDUCED VERSION
33957C----------------------------
33958 IIEI=IEII(IRE)
33959 IDWK=IEII(IRE+1)-IIEI
33960 IIWK=IRII(IRE)
33961 IIKI=IKII(IRE)
33962C
33963C-----------------------------
33964C*** SHRINKAGE TO THE CONSIDERED ENERGY REGION FOR THE USE OF WEIGHTS
33965C----------------------------
33966 HECM=ECM
33967 HUMO=2.0D0*UMO(IIEI+IDWK)-UMO(IIEI+IDWK-1)
33968 IF (HUMO.LT.ECM) ECM=HUMO
33969C
33970C-----------------------------
33971C*** INTERPOLATION PREPARATION
33972C----------------------------
33973 ECMO=UMO(IE)
33974 ECM1=UMO(IE-1)
33975 DECM=ECMO-ECM1
33976 DEC=ECMO-ECM
33977C
33978C-----------------------------
33979C*** RANDOM LOOP
33980C----------------------------
33981 IK=0
33982 WKK=0.0D0
33983 WICOR=0.0D0
33984 70 IK=IK+1
33985 IWK=IIWK+(IK-1)*IDWK+IE-IIEI
33986 WOK=WK(IWK)
33987 WDK=WOK-WK(IWK-1)
33988C
33989C-----------------------------
33990C*** TESTVARIABLE WICO/WICOR: IF CHANNEL IK HAS THE SAME WEIGHTS LIKE IK
33991C GO TO NEXT CHANNEL, BECAUSE WKK((IK))-WKK((IK-1))=0, IK CAN NOT
33992C CONTRIBUTE
33993C----------------------------
33994 IF (PLAB.LT.PLABF(IIEI+2)) WDK=0.0D0
33995 WICO=WOK*1.23459876D0+WDK*1.735218469D0
33996 IF (WICO.EQ.WICOR) GO TO 70
33997 IF (UMO(IIEI+IDWK).LT.HECM) WDK=0.0D0
33998 WICOR=WICO
33999C
34000C-----------------------------
34001C*** INTERPOLATION IN CHANNEL WEIGHTS
34002C----------------------------
34003 EKLIM=-THRESH(IIKI+IK)
34004 IELIM=IDT_IEFUND(EKLIM,IRE)
34005 DELIM=UMO(IELIM)+EKLIM
34006 *+1.D-16
34007 DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
34008 IF (DELIM*DELIM-DETE*DETE) 90,90,80
34009 80 DECC=DELIM
34010 GO TO 100
34011 90 DECC=DECM
34012 100 CONTINUE
34013 WKK=WOK-WDK*DEC/(DECC+1.D-9)
34014C
34015C-----------------------------
34016C*** RANDOM CHOICE
34017C----------------------------
34018C
34019 IF (VV.GT.WKK) GO TO 70
34020C
34021C***IK IS THE REACTION CHANNEL
34022C----------------------------
34023 INRK=IKII(IRE)+IK
34024 ECM=HECM
34025 I1001 =0
34026C
34027 110 CONTINUE
34028 IT1=NRK(1,INRK)
34029 AM1=DT_DAMG(IT1)
34030 IT2=NRK(2,INRK)
34031 AM2=DT_DAMG(IT2)
34032 AMS=AM1+AM2
34033 I1001=I1001+1
34034 IF (I1001.GT.50) GO TO 60
34035C
34036 IF (IT2*AMS.GT.IT2*ECM) GO TO 110
34037 IT11=IT1
34038 IT22=IT2
34039 IF (IANTH.GE.0) ECM=ELAB+AMT+0.00001D0
34040 AM11=AM1
34041 AM22=AM2
34042 IF (IT2.GT.0) GO TO 120
34043**sr 19.2.97: supress direct channel for pp-collisions
34044 IF ((N.EQ.1).AND.(ITTA.EQ.1).AND.(IT2.LE.0)) THEN
34045 RR = DT_RNDM(AM11)
34046 IF (RR.LE.0.75D0) GOTO 60
34047 ENDIF
34048**
34049C
34050C-----------------------------
34051C INCLUSION OF DIRECT RESONANCES
34052C RANDOM CHOICE OF DECAY CHANNELS OF THE DIRECT RESONANCE IT1
34053C------------------------
34054 KZ1=K1H(IT1)
34055 IST=IST+1
34056 IECO=0
34057 ECO=ECM
34058 GAM=(ELAB+AMT)/ECO
34059 BGAM=PLAB/ECO
34060 CXS(1)=CX
34061 CYS(1)=CY
34062 CZS(1)=CZ
34063 GO TO 170
34064 120 CONTINUE
34065 WW=DT_RNDM(ECO)
34066 IF(WW.LT. 0.5D0) GO TO 130
34067 IT1=IT22
34068 IT2=IT11
34069 AM1=AM22
34070 AM2=AM11
34071 130 CONTINUE
34072C
34073C-----------------------------
34074C THE FIRST PARTICLE IS DEFINED TO BE THE FORWARD GOING ONE AT SMALL T
34075 IBN=IBARH(N)
34076 IB1=IBARH(IT1)
34077 IT11=IT1
34078 IT22=IT2
34079 AM11=AM1
34080 AM22=AM2
34081 IF(IB1.EQ.IBN) GO TO 140
34082 IT1=IT22
34083 IT2=IT11
34084 AM1=AM22
34085 AM2=AM11
34086 140 CONTINUE
34087C-----------------------------
34088C***IT1,IT2 ARE THE CREATED PARTICLES
34089C***MOMENTA AND DIRECTION COSINA IN THE CM - SYSTEM
34090C------------------------
34091 CALL DT_DTWOPA(ECM1,ECM2,PCM1,PCM2,COD1,COD2,COF1,COF2,SIF1,SIF2,
34092 *IT1,IT2,ECM,ECMN,PCMN,N,AM1,AM2)
34093 IST=IST+1
34094 ITS(IST)=IT1
34095 AMM(IST)=AM1
34096C
34097C-----------------------------
34098C***TRANSFORMATION INTO LAB SYSTEM AND ROTATION
34099C----------------------------
34100 CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD1,COF1,SIF1,
34101 &PCM1,ECM1,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34102 IST=IST+1
34103 ITS(IST)=IT2
34104 AMM(IST)=AM2
34105 CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD2,COF2,SIF2,
34106 *PCM2,ECM2,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34107 150 CONTINUE
34108C
34109C-----------------------------
34110C***TEST STABLE OR UNSTABLE
34111C----------------------------
34112 IF(ITS(IST).GT.NSTAB) GO TO 160
34113 IRH=IRH+1
34114C
34115C-----------------------------
34116C***IRH IS THE NUMBER OF THE FINAL STABLE PARTICLE
34117C----------------------------
34118C* IF (REDU.LT.0.D0) GO TO 1009
34119 ITRH(IRH)=ITS(IST)
34120 PLRH(IRH)=PLS(IST)
34121 CXRH(IRH)=CXS(IST)
34122 CYRH(IRH)=CYS(IST)
34123 CZRH(IRH)=CZS(IST)
34124 ELRH(IRH)=ELS(IST)
34125 IST=IST-1
34126 IF(IST.GE.1) GO TO 150
34127 GO TO 260
34128 160 CONTINUE
34129C
34130C RANDOM CHOICE OF DECAY CHANNELS
34131C----------------------------
34132C
34133 IT=ITS(IST)
34134 ECO=AMM(IST)
34135 GAM=ELS(IST)/ECO
34136 BGAM=PLS(IST)/ECO
34137 IECO=0
34138 KZ1=K1H(IT)
34139 170 CONTINUE
34140 IECO=IECO+1
34141 VV=DT_RNDM(GAM)
34142 VV=VV-1.D-17
34143 IIK=KZ1-1
34144 180 IIK=IIK+1
34145 IF (VV.GT.WTI(IIK)) GO TO 180
34146C
34147C IIK IS THE DECAY CHANNEL
34148C----------------------------
34149 IT1=NZKI(IIK,1)
34150 I310=0
34151 190 CONTINUE
34152 I310=I310+1
34153 AM1=DT_DAMG(IT1)
34154 IT2=NZKI(IIK,2)
34155 AM2=DT_DAMG(IT2)
34156 IF (IT2-1.LT.0) GO TO 240
34157 IT3=NZKI(IIK,3)
34158 AM3=DT_DAMG(IT3)
34159 AMS=AM1+AM2+AM3
34160C
34161C IF IIK-KIN.LIM.GT.ACTUAL TOTAL CM-ENERGY, DO AGAIN RANDOM IIK-CHOICE
34162C----------------------------
34163 IF (IECO.LE.10) GO TO 200
34164 IATMPT=IATMPT+1
34165 IF(IATMPT.GT.3) THEN
34166C WRITE(LOUT,*) ' jump 4'
34167 GO TO 280
34168 ENDIF
34169 GO TO 40
34170 200 CONTINUE
34171 IF (I310.GT.50) GO TO 170
34172 IF (AMS.GT.ECO) GO TO 190
34173C
34174C FOR THE DECAY CHANNEL
34175C IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM IT
34176C----------------------------
34177 IF (REDU.LT.0.D0) GO TO 30
34178 ITWTHC=0
34179 REDU=2.0D0
34180 IF(IT3.EQ.0) GO TO 220
34181 210 CONTINUE
34182 ITWTH=1
34183 CALL DT_DTHREP(ECO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,SIF1,
34184 *COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
34185 GO TO 230
34186 220 CALL DT_DTWOPD(ECO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,
34187 &COD2,COF2,SIF2,AM1,AM2)
34188 ITWTH=-1
34189 IT3=0
34190 230 CONTINUE
34191 ITWTHC=ITWTHC+1
34192 IF (REDU.GT.0.D0) GO TO 240
34193 REDU=2.0D0
34194 IF (ITWTHC.GT.100) GO TO 30
34195 IF (ITWTH) 220,220,210
34196 240 CONTINUE
34197 ITS(IST )=IT1
34198 IF (IT2-1.LT.0) GO TO 250
34199 ITS(IST+1) =IT2
34200 ITS(IST+2)=IT3
34201 RX=CXS(IST)
34202 RY=CYS(IST)
34203 RZ=CZS(IST)
34204 AMM(IST)=AM1
34205 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD1,COF1,SIF1,PCM1,ECM1,
34206 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34207 IST=IST+1
34208 AMM(IST)=AM2
34209 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD2,COF2,SIF2,PCM2,ECM2,
34210 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34211 IF (IT3.LE.0) GO TO 250
34212 IST=IST+1
34213 AMM(IST)=AM3
34214 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD3,COF3,SIF3,PCM3,ECM3,
34215 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34216 250 CONTINUE
34217 GO TO 150
34218 260 CONTINUE
34219 270 CONTINUE
34220 RETURN
34221 280 CONTINUE
34222C
34223C----------------------------
34224C
34225C ZERO CROSS SECTION CASE
34226C----------------------------
34227C
34228 IRH=1
34229 ITRH(1)=N
34230 CXRH(1)=CX
34231 CYRH(1)=CY
34232 CZRH(1)=CZ
34233 ELRH(1)=ELAB
34234 PLRH(1)=PLAB
34235 RETURN
34236 END
34237
34238*$ CREATE DT_RUNTT.FOR
34239*COPY DT_RUNTT
34240*
34241*===runtt==============================================================*
34242*
34243 BLOCK DATA DT_RUNTT
34244
34245 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34246 SAVE
34247
34248 COMMON /HNDRUN/ RUNTES,EFTES
34249
34250 DATA RUNTES,EFTES /100.D0,100.D0/
34251
34252 END
34253
34254*$ CREATE DT_NONAME.FOR
34255*COPY DT_NONAME
34256*
34257*===noname=============================================================*
34258*
34259 BLOCK DATA DT_NONAME
34260
34261 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34262 SAVE
34263
34264* slope parameters for HADRIN interactions
34265 COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
34266 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34267
34268C DATAS DATAS DATAS DATAS DATAS
34269C****** *********
34270 DATA IKII/ 0, 15, 41, 67, 82, 93, 110, 133, 148, 159, 172, 183,
34271 & 207, 224, 241, 252, 268 /
34272 DATA IEII/ 0, 21, 46, 71, 92, 109, 126, 143, 160, 173, 186, 199,
34273 & 220, 241, 262, 279, 296 /
34274 DATA IRII/ 0, 315, 965, 1615, 1930, 2117, 2406, 2797, 3052, 3195,
34275 & 3364, 3507, 4011, 4368, 4725, 4912, 5184/
34276
34277C
34278C MASSES FOR THE SLOPE B(M) IN GEV
34279C SLOPE B(M) FOR AN MESONIC SYSTEM
34280C SLOPE B(M) FOR A BARYONIC SYSTEM
34281
34282*
34283 DATA SM,BBM,BBB/ 0.8D0, 0.85D0, 0.9D0, 0.95D0, 1.D0,
34284 & 1.05D0, 1.1D0, 1.15D0, 1.2D0, 1.25D0,
34285 & 1.3D0, 1.35D0, 1.4D0, 1.45D0, 1.5D0,
34286 & 1.55D0, 1.6D0, 1.65D0, 1.7D0, 1.75D0,
34287 & 1.8D0, 1.85D0, 1.9D0, 1.95D0, 2.D0,
34288 & 15.6D0, 14.95D0, 14.3D0, 13.65D0, 13.D0,
34289 & 12.35D0, 11.7D0, 10.85D0, 10.D0, 9.15D0,
34290 & 8.3D0, 7.8D0, 7.3D0, 7.25D0, 7.2D0,
34291 & 6.95D0, 6.7D0, 6.6D0, 6.5D0, 6.3D0,
34292 & 6.1D0, 5.85D0, 5.6D0, 5.35D0, 5.1D0,
34293 & 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0,
34294 & 14.2D0, 13.4D0, 12.6D0,
34295 & 11.8D0, 11.2D0, 10.6D0, 9.8D0, 9.D0,
34296 & 8.25D0, 7.5D0, 6.25D0, 5.D0, 4.5D0, 5*4.D0 /
34297*
34298 END
34299
34300*$ CREATE DT_DAMG.FOR
34301*COPY DT_DAMG
34302*
34303*===damg===============================================================*
34304*
34305 DOUBLE PRECISION FUNCTION DT_DAMG(IT)
34306
34307 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34308 SAVE
34309
34310* particle properties (BAMJET index convention),
34311* (dublicate of DTPART for HADRIN)
34312 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34313 & K1H(110),K2H(110)
34314
34315 DIMENSION GASUNI(14)
34316 DATA GASUNI/
34317 *-1.D0,-.98D0,-.95D0,-.87D0,-.72D0,-.48D0,
34318 *-.17D0,.17D0,.48D0,.72D0,.87D0,.95D0,.98D0,1.D0/
34319 DATA GAUNO/2.352D0/
34320 DATA GAUNON/2.4D0/
34321 DATA IO/14/
34322 DATA NSTAB/23/
34323
34324 I=1
34325 IF (IT.LE.0) GO TO 30
34326 IF (IT.LE.NSTAB) GO TO 20
34327 DGAUNI=GAUNO*GAUNON/DBLE(IO-1)
34328 VV=DT_RNDM(DGAUNI)
34329 VV=VV*2.0D0-1.0D0+1.D-16
34330 10 CONTINUE
34331 VO=GASUNI(I)
34332 I=I+1
34333 V1=GASUNI(I)
34334 IF (VV.GT.V1) GO TO 10
34335 UNIGA=DGAUNI*(DBLE(I)-2.0D0+(VV-VO+1.D-16)/
34336 & (V1-VO)-(DBLE(IO)-1.0D0)*0.5D0)
34337 DAM=GAH(IT)*UNIGA/GAUNO
34338 AAM=AMH(IT)+DAM
34339 DT_DAMG=AAM
34340 RETURN
34341 20 CONTINUE
34342 DT_DAMG=AMH(IT)
34343 RETURN
34344 30 CONTINUE
34345 DT_DAMG=0.0D0
34346 RETURN
34347 END
34348
34349*$ CREATE DT_DCALUM.FOR
34350*COPY DT_DCALUM
34351*
34352*===dcalum=============================================================*
34353*
34354 SUBROUTINE DT_DCALUM(N,ITTA)
34355
34356 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34357 SAVE
34358
34359C*** C.M.S.-ENERGY AND REACTION CHANNEL THRESHOLD CALCULATION
34360
34361* particle properties (BAMJET index convention),
34362* (dublicate of DTPART for HADRIN)
34363 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34364 & K1H(110),K2H(110)
34365 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34366 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
34367 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34368 & NRK(2,268),NURE(30,2)
34369
34370 IRE=NURE(N,ITTA/8+1)
34371 IEO=IEII(IRE)+1
34372 IEE=IEII(IRE +1)
34373 AM1=AMH(N )
34374 AM12=AM1**2
34375 AM2=AMH(ITTA)
34376 AM22=AM2**2
34377 DO 10 IE=IEO,IEE
34378 PLAB2=PLABF(IE)**2
34379 ELAB=SQRT(AM12+AM22+2.0D0*SQRT(PLAB2+AM12)*AM2)
34380 UMO(IE)=ELAB
34381 10 CONTINUE
34382 IKO=IKII(IRE)+1
34383 IKE=IKII(IRE +1)
34384 UMOO=UMO(IEO)
34385 DO 30 IK=IKO,IKE
34386 IF(NRK(2,IK).GT.0) GO TO 30
34387 IKI=NRK(1,IK)
34388 AMSS=5.0D0
34389 K11=K1H(IKI)
34390 K22=K2H(IKI)
34391 DO 20 IK1=K11,K22
34392 IN=NZKI(IK1,1)
34393 AMS=AMH(IN)
34394 IN=NZKI(IK1,2)
34395 IF(IN.GT.0)AMS=AMS+AMH(IN)
34396 IN=NZKI(IK1,3)
34397 IF(IN.GT.0) AMS=AMS+AMH(IN)
34398 IF (AMS.LT.AMSS) AMSS=AMS
34399 20 CONTINUE
34400 IF(UMOO.LT.AMSS) UMOO=AMSS
34401 THRESH(IK)=UMOO
34402 30 CONTINUE
34403 RETURN
34404 END
34405
34406*$ CREATE DT_DCHANH.FOR
34407*COPY DT_DCHANH
34408*
34409*===dchanh=============================================================*
34410*
34411 SUBROUTINE DT_DCHANH
34412
34413 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34414 SAVE
34415
34416 PARAMETER ( LINP = 10 ,
34417 & LOUT = 6 ,
34418 & LDAT = 9 )
34419* particle properties (BAMJET index convention),
34420* (dublicate of DTPART for HADRIN)
34421 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34422 & K1H(110),K2H(110)
34423 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
34424 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34425 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34426 & NRK(2,268),NURE(30,2)
34427
34428 DIMENSION HWT(460),HWK(40),SI(5184)
34429 EQUIVALENCE (WK(1),SI(1))
34430C--------------------
34431C*** USE ONLY FOR DATAPREPARATION OF PURE HADRIN
34432C*** CALCULATION OF REACTION- AND DECAY-CHANNEL-WEIGHTS,
34433C*** THRESHOLD ENERGIES+MOMENTA OF REACTION CHNLS.
34434C*** CHANGE OF WT- AND WK-INPUTDATA INTO WEIGHTS FOR THE M.-C.-PROCEDURE
34435C*** (ADDED ONE TO EACH OTHER FOR CORRESPONDING CHANNELS)
34436C--------------------------
34437 IREG=16
34438 DO 90 IRE=1,IREG
34439 IWKO=IRII(IRE)
34440 IEE=IEII(IRE+1)-IEII(IRE)
34441 IKE=IKII(IRE+1)-IKII(IRE)
34442 IEO=IEII(IRE)+1
34443 IIKA=IKII(IRE)
34444* modifications to suppress elestic scattering 24/07/91
34445 DO 80 IE=1,IEE
34446 SIS=1.D-14
34447 SINORC=0.0D0
34448 DO 10 IK=1,IKE
34449 IWK=IWKO+IEE*(IK-1)+IE
34450 IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
34451 SIS=SIS+SI(IWK)*SINORC
34452 10 CONTINUE
34453 SIIN(IEO+IE-1)=SIS
34454 SIO=0.D0
34455 IF (SIS.GE.1.D-12) GO TO 20
34456 SIS=1.D0
34457 SIO=1.D0
34458 20 CONTINUE
34459 SINORC=0.0D0
34460 DO 30 IK=1,IKE
34461 IWK=IWKO+IEE*(IK-1)+IE
34462 IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
34463 SIO=SIO+SI(IWK)*SINORC/SIS
34464 HWK(IK)=SIO
34465 30 CONTINUE
34466 DO 40 IK=1,IKE
34467 IWK=IWKO+IEE*(IK-1)+IE
34468 40 WK(IWK)=HWK(IK)
34469 IIKI=IKII(IRE)
34470 DO 70 IK=1,IKE
34471 AM111=0.D0
34472 INRK1=NRK(1,IIKI+IK)
34473 IF (INRK1.GT.0) AM111=AMH(INRK1)
34474 AM222=0.D0
34475 INRK2=NRK(2,IIKI+IK)
34476 IF (INRK2.GT.0) AM222=AMH(INRK2)
34477 THRESH(IIKI+IK)=AM111 +AM222
34478 IF (INRK2-1.GE.0) GO TO 60
34479 INRKK=K1H(INRK1)
34480 AMSS=5.D0
34481 INRKO=K2H(INRK1)
34482 DO 50 INRK1=INRKK,INRKO
34483 INZK1=NZKI(INRK1,1)
34484 INZK2=NZKI(INRK1,2)
34485 INZK3=NZKI(INRK1,3)
34486 IF (INZK1.LE.0.OR.INZK1.GT.110) GO TO 50
34487 IF (INZK2.LE.0.OR.INZK2.GT.110) GO TO 50
34488 IF (INZK3.LE.0.OR.INZK3.GT.110) GO TO 50
34489C WRITE (6,310)INRK1,INZK1,INZK2,INZK3
34490 1000 FORMAT (4I10)
34491 AMS=AMH(INZK1)+AMH(INZK2)
34492 IF (INZK3-1.GE.0) AMS=AMS+AMH(INZK3)
34493 IF (AMSS.GT.AMS) AMSS=AMS
34494 50 CONTINUE
34495 AMS=AMSS
34496 IF (AMS.LT.UMO(IEO)) AMS=UMO(IEO)
34497 THRESH(IIKI+IK)=AMS
34498 60 CONTINUE
34499 70 CONTINUE
34500 80 CONTINUE
34501 90 CONTINUE
34502 DO 100 J=1,460
34503 100 HWT(J)=0.D0
34504 DO 120 I=1,110
34505 IK1=K1H(I)
34506 IK2=K2H(I)
34507 HV=0.D0
34508 IF (IK2.GT.460)IK2=460
34509 IF (IK1.LE.0)IK1=1
34510 DO 110 J=IK1,IK2
34511 HV=HV+WTI(J)
34512 HWT(J)=HV
34513 JI=J
34514 110 CONTINUE
34515 IF (ABS(HV-1.0D0).GT.1.D-4) WRITE(LOUT,1010)I,JI,HV
34516 1010 FORMAT (35H ERROR IN HWT, FALSE USE OF CHANWH ,2I6,F10.2)
34517 120 CONTINUE
34518 DO 130 J=1,460
34519 130 WTI(J)=HWT(J)
34520 RETURN
34521 END
34522
34523*$ CREATE DT_DHADDE.FOR
34524*COPY DT_DHADDE
34525*
34526*===dhadde=============================================================*
34527*
34528 SUBROUTINE DT_DHADDE
34529
34530 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34531 SAVE
34532
34533* particle properties (BAMJET index convention)
34534 CHARACTER*8 ANAME
34535 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
34536 & IICH(210),IIBAR(210),K1(210),K2(210)
34537* HADRIN: decay channel information
34538 PARAMETER (IDMAX9=602)
34539 CHARACTER*8 ZKNAME
34540 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
34541* particle properties (BAMJET index convention),
34542* (dublicate of DTPART for HADRIN)
34543 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34544 & K1H(110),K2H(110)
34545 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
34546* decay channel information for HADRIN
34547 COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
34548 & K1Z(16),K2Z(16),WTZ(153),II22,
34549 & NZK1(153),NZK2(153),NZK3(153)
34550
34551 DATA IRETUR/0/
34552
34553 IRETUR=IRETUR+1
34554 AMH(31)=0.48D0
34555 IF (IRETUR.GT.1) RETURN
34556 DO 10 I=1,94
34557 AMH(I) = AAM(I)
34558 GAH(I) = GA(I)
34559 TAUH(I) = TAU(I)
34560 ICHH(I) = IICH(I)
34561 IBARH(I) = IIBAR(I)
34562 K1H(I) = K1(I)
34563 K2H(I) = K2(I)
34564 10 CONTINUE
34565**sr
34566C AMH(1)=0.93828D0
34567 AMH(1)=0.9383D0
34568**
34569 AMH(2)=AMH(1)
34570 DO 20 I=26,30
34571 K1H(I)=452
34572 K2H(I)=452
34573 20 CONTINUE
34574 DO 30 I=1,307
34575 WTI(I) = WT(I)
34576 NZKI(I,1) = NZK(I,1)
34577 NZKI(I,2) = NZK(I,2)
34578 NZKI(I,3) = NZK(I,3)
34579 30 CONTINUE
34580 DO 40 I=1,16
34581 L=I+94
34582 AMH(L)=AMZ(I)
34583 GAH( L)=GAZ(I)
34584 TAUH( L)=TAUZ(I)
34585 ICHH( L)=ICHZ(I)
34586 IBARH( L)=IBARZ(I)
34587 K1H( L)=K1Z(I)
34588 K2H( L)=K2Z(I)
34589 40 CONTINUE
34590 DO 50 I=1,153
34591 L=I+307
34592 WTI(L) = WTZ(I)
34593 NZKI(L,3) = NZK3(I)
34594 NZKI(L,2) = NZK2(I)
34595 NZKI(L,1) = NZK1(I)
34596 50 CONTINUE
34597 RETURN
34598 END
34599
34600*$ CREATE IDT_IEFUND.FOR
34601*COPY IDT_IEFUND
34602*
34603*===iefund=============================================================*
34604*
34605 INTEGER FUNCTION IDT_IEFUND(PL,IRE)
34606
34607 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34608 SAVE
34609
34610C*****IEFUN CALCULATES A MOMENTUM INDEX
34611
34612 PARAMETER ( LINP = 10 ,
34613 & LOUT = 6 ,
34614 & LDAT = 9 )
34615 COMMON /HNDRUN/ RUNTES,EFTES
34616 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34617 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34618 & NRK(2,268),NURE(30,2)
34619
34620 IPLA=IEII(IRE)+1
34621 *+1
34622 IPLE=IEII(IRE+1)
34623 IF (PL.LT.0.) GO TO 30
34624 DO 10 I=IPLA,IPLE
34625 J=I-IPLA+1
34626 IF (PL.LE.PLABF(I)) GO TO 60
34627 10 CONTINUE
34628 I=IPLE
34629 IF ( EFTES.GT.40.D0) GO TO 20
34630 EFTES=EFTES+1.0D0
34631 WRITE(LOUT,1000)PL,J
34632 20 CONTINUE
34633 GO TO 70
34634 30 CONTINUE
34635 DO 40 I=IPLA,IPLE
34636 J=I-IPLA+1
34637 IF (-PL.LE.UMO(I)) GO TO 60
34638 40 CONTINUE
34639 I=IPLE
34640 IF ( EFTES.GT.40.D0) GO TO 50
34641 EFTES=EFTES+1.0D0
34642 WRITE(LOUT,1000)PL,I
34643 50 CONTINUE
34644 60 CONTINUE
34645 70 CONTINUE
34646 IDT_IEFUND=I
34647 RETURN
34648 1000 FORMAT(14H PLAB OR -ECM=,E12.4,27H IS OUT OF CONSIDERED RANGE ,
34649 +7H IEFUN=,I5)
34650 END
34651
34652*$ CREATE DT_DSIGIN.FOR
34653*COPY DT_DSIGIN
34654*
34655*===dsigin=============================================================*
34656*
34657 SUBROUTINE DT_DSIGIN(IRE ,PLAB,N,IE ,AMT ,AMN,ECM ,SI ,ITAR)
34658
34659 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34660 SAVE
34661
34662* particle properties (BAMJET index convention),
34663* (dublicate of DTPART for HADRIN)
34664 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34665 & K1H(110),K2H(110)
34666 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34667 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34668 & NRK(2,268),NURE(30,2)
34669
34670 IE=IDT_IEFUND(PLAB,IRE)
34671 IF (IE.LE.IEII(IRE)) IE=IE+1
34672 AMT=AMH(ITAR)
34673 AMN=AMH(N)
34674 AMN2=AMN*AMN
34675 AMT2=AMT*AMT
34676 ECM=SQRT(AMN2+AMT2+2.0D0*AMT*SQRT(AMN2+PLAB**2))
34677C*** INTERPOLATION PREPARATION
34678 ECMO=UMO(IE)
34679 ECM1=UMO(IE-1)
34680 DECM=ECMO-ECM1
34681 DEC=ECMO-ECM
34682 IIKI=IKII(IRE)+1
34683 EKLIM=-THRESH(IIKI)
34684 WOK=SIIN(IE)
34685 WDK=WOK-SIIN(IE-1)
34686 IF (ECM.GT.ECMO) WDK=0.0D0
34687C*** INTERPOLATION IN CHANNEL WEIGHTS
34688 IELIM=IDT_IEFUND(EKLIM,IRE)
34689 DELIM=UMO(IELIM)+EKLIM
34690 *+1.D-16
34691 DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
34692 IF (DELIM*DELIM-DETE*DETE) 20,20,10
34693 10 DECC=DELIM
34694 GO TO 30
34695 20 DECC=DECM
34696 30 CONTINUE
34697 WKK=WOK-WDK*DEC/(DECC+1.D-9)
34698 IF (WKK.LT.0.0D0) WKK=0.0D0
34699 SI=WKK+1.D-12
34700 IF (-EKLIM.GT.ECM) SI=1.D-14
34701 RETURN
34702 END
34703
34704*$ CREATE DT_DTCHOI.FOR
34705*COPY DT_DTCHOI
34706*
34707*===dtchoi=============================================================*
34708*
34709 SUBROUTINE DT_DTCHOI(T,P,PP,E,EE,I,II,N,AM1,AM2)
34710
34711 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34712 SAVE
34713
34714C ****************************
34715C TCHOIC CALCULATES A RANDOM VALUE
34716C FOR THE FOUR-MOMENTUM-TRANSFER T
34717C ****************************
34718
34719* particle properties (BAMJET index convention),
34720* (dublicate of DTPART for HADRIN)
34721 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34722 & K1H(110),K2H(110)
34723* slope parameters for HADRIN interactions
34724 COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
34725
34726 AMA=AM1
34727 AMB=AM2
34728 IF (I.GT.30.AND.II.GT.30) GO TO 20
34729 III=II
34730 AM3=AM2
34731 IF (I.LE.30) GO TO 10
34732 III=I
34733 AM3=AM1
34734 10 CONTINUE
34735 GO TO 30
34736 20 CONTINUE
34737 III=II
34738 AM3=AM2
34739 IF (AMA.LE.AMB) GO TO 30
34740 III=I
34741 AM3=AM1
34742 30 CONTINUE
34743 IB=IBARH(III)
34744 AMA=AM3
34745 K=INT((AMA-0.75D0)/0.05D0)
34746 IF (K-2.LT.0) K=1
34747 IF (K-26.GE.0) K=25
34748 IF (IB)50,40,50
34749 40 BM=BBM(K)
34750 GO TO 60
34751 50 BM=BBB(K)
34752 60 CONTINUE
34753C NORMALIZATION
34754 TMIN=-2.0D0*(E*EE-P*PP)+AMH(N)**2+AM1 **2
34755 TMAX=-2.0D0*(E*EE+P*PP)+AMH(N)**2+AM1 **2
34756 VB=DT_RNDM(TMIN)
34757**sr test
34758C IF (VB.LT.0.2D0) BM=BM*0.1
34759C **0.5
34760 BM = BM*5.05D0
34761**
34762 TMI=BM*TMIN
34763 TMA=BM*TMAX
34764 ETMA=0.D0
34765 IF (ABS(TMA).GT.120.D0) GO TO 70
34766 ETMA=EXP(TMA)
34767 70 CONTINUE
34768 AN=(1.0D0/BM)*(EXP(TMI)-ETMA)
34769C*** RANDOM CHOICE OF THE T - VALUE
34770 R=DT_RNDM(TMI)
34771 T=(1.0D0/BM)*LOG(ETMA+R*AN*BM)
34772 RETURN
34773 END
34774
34775*$ CREATE DT_DTWOPA.FOR
34776*COPY DT_DTWOPA
34777*
34778*===dtwopa=============================================================*
34779*
34780 SUBROUTINE DT_DTWOPA(E1,E2,P1,P2,COD1,COD2,COF1,COF2,SIF1,SIF2,
34781 &IT1,IT2,UMOO,ECM,P,N,AM1,AM2)
34782
34783 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34784 SAVE
34785
34786C ******************************************************
34787C QUASI TWO PARTICLE PRODUCTION
34788C TWOPAR CALCULATES THE ENERGYS AND THE MOMENTA
34789C FOR THE CREATED PARTICLES OR RESONANCES IT1 AND IT2
34790C IN THE CM - SYSTEM
34791C COD1,COD2,COF1,COF2,SIF1,SIF2 ARE THE ANGLES FOR
34792C SPHERICAL COORDINATES
34793C ******************************************************
34794
34795* particle properties (BAMJET index convention),
34796* (dublicate of DTPART for HADRIN)
34797 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34798 & K1H(110),K2H(110)
34799
34800 AMA=AM1
34801 AMB=AM2
34802 AMA2=AMA*AMA
34803 E1=((UMOO-AMB)*(UMOO+AMB) + AMA2)/(2.0D0*UMOO)
34804 E2=UMOO - E1
34805 IF (E1.LT.AMA*1.00001D0) E1=AMA*1.00001D0
34806 AMTE=(E1-AMA)*(E1+AMA)
34807 AMTE=AMTE+1.D-18
34808 P1=SQRT(AMTE)
34809 P2=P1
34810C / P2 / = / P1 / BUT OPPOSITE DIRECTIONS
34811C DETERMINATION OF THE ANGLES
34812C COS(THETA1)=COD1 COS(THETA2)=COD2
34813C SIN(PHI1)=SIF1 SIN(PHI2)=SIF2
34814C COS(PHI1)=COF1 COS(PHI2)=COF2
34815C PHI IS UNIFORMLY DISTRIBUTED IN ( 0,2*PI )
34816 CALL DT_DSFECF(COF1,SIF1)
34817 COF2=-COF1
34818 SIF2=-SIF1
34819C CALCULATION OF THETA1
34820 CALL DT_DTCHOI(TR,P,P1,ECM,E1,IT1,IT2,N,AM1,AM2)
34821 COD1=(TR-AMA2-AMH(N)*AMH(N)+2.0D0*ECM*E1)/(2.0D0*P*P1+1.D-18)
34822 IF (COD1.GT.0.9999999D0) COD1=0.9999999D0
34823 COD2=-COD1
34824 RETURN
34825 END
34826
34827*$ CREATE DT_ZK.FOR
34828*COPY DT_ZK
34829*
34830*===zk=================================================================*
34831*
34832 BLOCK DATA DT_ZK
34833
34834 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34835 SAVE
34836
34837* decay channel information for HADRIN
34838 COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
34839 & K1Z(16),K2Z(16),WTZ(153),II22,
34840 & NZK1(153),NZK2(153),NZK3(153)
34841* decay channel information for HADRIN
34842 CHARACTER*8 ANAMZ,ZKNAM4,ZKNAM5,ZKNAM6
34843 COMMON /HNADDN/ ANAMZ(16),ZKNAM4(9),ZKNAM5(90),ZKNAM6(54)
34844
34845* Particle masses in GeV *
34846 DATA AMZ/ 3*2.2D0, 0.9576D0, 3*1.887D0, 2.4D0, 2.03D0, 2*1.44D0,
34847 & 2*1.7D0, 3*0.D0/
34848* Resonance width Gamma in GeV *
34849 DATA GAZ/ 3*.2D0, .1D0, 4*.2D0, .18D0, 2*.2D0, 2*.15D0, 3*0.D0 /
34850* Mean life time in seconds *
34851 DATA TAUZ / 16*0.D0 /
34852* Charge of particles and resonances *
34853 DATA ICHZ/ 0, 1, 3*0, 1, -1, 0, 1, -1, 0, 0, 1 , 3*0 /
34854* Baryonic charge *
34855 DATA IBARZ/ 2, 7*0, 1, -1, -1, 1, 1, 3*0 /
34856* First number of decay channels used for resonances *
34857* and decaying particles *
34858 DATA K1Z/ 308,310,313,317,322,365,393,421,425,434,440,446,449,
34859 & 3*460/
34860* Last number of decay channels used for resonances *
34861* and decaying particles *
34862 DATA K2Z/ 309,312,316,321,364,392,420,424,433,439,445,448,451,
34863 & 3*460/
34864* Weight of decay channel *
34865 DATA WTZ/ .17D0, .83D0, 2*.33D0, .34D0, .17D0, 2*.33D0, .17D0,
34866 & .01D0, .13D0, .36D0, .27D0, .23D0, .0014D0, .0029D0, .0014D0,
34867 & .0029D0, 4*.0007D0, .0517D0, .0718D0, .0144D0, .0431D0, .0359D0,
34868 & .0718D0, .0014D0, .0273D0, .0014D0, .0431D0, 2*.0129D0, .0259D0,
34869 & .0517D0, .0359D0, .0014D0, 2*.0144D0, .0129D0, .0014D0, .0259D0,
34870 & .0359D0, .0072D0, .0474D0, .0948D0, .0259D0, .0072D0, .0144D0,
34871 & .0287D0, .0431D0, .0144D0, .0287D0, .0474D0, .0144D0, .0075D0,
34872 & .0057D0, .0019D0, .0038D0, .0095D0, 2*.0014D0, .0191D0, .0572D0,
34873 & .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0, .0686D0,.0172D0,
34874 & .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, .0190D0,
34875 & .0057D0, .0019D0, .0038D0, .0095D0, .0014D0, .0014D0, .0191D0,
34876 & .0572D0, .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0,.0686D0,
34877 & .0172D0, .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0,
34878 & .0190D0, 4*.25D0, 2*.2D0, .12D0, .1D0, .07D0, .07D0, .14D0,
34879 & 2*.05D0, .0D0, .3334D0, .2083D0, 2*.125D0, .2083D0, .0D0, .125D0,
34880 & .2083D0, .3334D0, .2083D0, .125D0, .3D0, .05D0, .65D0, .3D0,
34881 & .05D0, .65D0, 9*1.D0 /
34882* Particle numbers in decay channel *
34883 DATA NZK1/ 8, 1, 2, 9, 1, 2, 9, 2, 9, 7, 13, 31, 15, 24, 23, 13,
34884 & 23, 13, 2*23, 14, 13, 23, 31, 98, 2*33, 32, 23, 14, 13, 35, 2*23,
34885 & 14, 13, 33, 23, 98, 31, 23, 14, 13, 35, 2*33, 32, 23, 35, 33, 32,
34886 & 98, 5*35, 4*13, 23, 13, 98, 32, 33, 23, 13, 23, 13, 14, 13, 32,
34887 & 13, 98, 23, 13, 2*32, 13, 33, 32, 98, 2*35, 4*14, 23, 14, 98,
34888 & 2*34, 23, 14, 23, 2*14, 13, 34, 14, 98, 23, 14, 2*34, 14, 33, 32,
34889 & 98, 2*35, 104, 61, 105, 62, 1, 17, 21, 17, 22, 2*21, 22, 21, 2,
34890 & 67, 68, 69, 2, 2*9, 68, 69, 70, 2, 9, 2*24, 15, 2*25, 16, 9*0/
34891 DATA NZK2/ 2*8, 1, 8, 9, 2*8, 2*1, 7, 14, 13, 16, 25, 23, 14, 23,
34892 & 14, 31, 33, 32, 34, 35, 31, 23, 31, 33, 34, 31, 32, 34, 31, 33,
34893 & 32, 2*33, 35, 31, 33, 31, 33, 32, 34, 35, 31, 33, 34, 35, 31,
34894 & 4*33, 32, 3*35, 2*23, 13, 31, 32, 33, 13, 31, 32, 2*31, 32, 33,
34895 & 32, 32, 35, 31, 2*32, 33, 31, 33, 35, 33, 3*32, 35, 2*23, 14,
34896 & 31, 34, 33, 14, 31, 33, 2*31, 34, 32, 33, 34, 35, 31, 2*34, 33,
34897 & 31, 33, 35, 33, 2*34, 33, 35, 1, 2, 8, 9, 25, 13, 35, 2*32, 33,
34898 & 31, 13, 23, 31, 13, 23, 14, 79, 80, 31, 13, 23, 14, 78, 79, 8,
34899 & 1, 8, 1, 8, 1, 9*0 /
34900 DATA NZK3/ 23, 14, 2*13, 23, 13, 2*23, 14, 0, 7, 14, 4*0, 2*23,
34901 & 10*0, 33, 2*31, 0, 33, 34, 32, 34, 0, 35, 0, 31, 3*35, 0, 3*31,
34902 & 35, 31, 33, 34, 31, 33, 34, 31, 33, 35, 0, 23, 14, 6*0, 32, 3*33,
34903 & 32, 34, 0, 35, 0, 2*35, 2*31, 35, 32, 34, 31, 33, 32, 0, 23, 13,
34904 & 6*0, 34, 2*33, 34, 33, 34, 0, 35, 0,2*35, 2*31, 35, 2*34, 31,
34905 & 2*34, 25*0, 23, 2*14, 23, 2*13, 9*0 /
34906* Particle names *
34907 DATA ANAMZ / 'NNPI', 'ANPPI', 'ANNPI', ' ETS ',' PAP ',' PAN ',
34908 & 'APN', 'DEO ', 'S+2030', 'AN*-14', 'AN*014','KONPI ','AKOPPI',
34909 & 3*'BLANK' /
34910* Name of decay channel *
34911 DATA ZKNAM4/'NNPI0','PNPI-','APPPI+','ANNPI+','ANPPI0','APNPI+',
34912 & 'ANNPI0','APPPI0','ANPPI-'/
34913 DATA ZKNAM5/' GAGA ','P+P-GA','ETP+P-','K+K- ','K0AK0 ',
34914 & ' POPO ',' P+P- ','POPOPO','P+P0P-','P0ET ','&0R0 ','P-R+ ',
34915 & 'P+R- ','POOM ',' ETET ','ETSP0 ','R0ET ',' R0R0 ','R+R- ',
34916 & 'P0ETR0','P-ETR+','P+ETR-',' OMET ','P0R0R0','P0R+R-','P-R+R0',
34917 & 'P+R-R0','R0OM ','P0ETOM','ETSR0 ','ETETET','P0R0OM','P-R+OM',
34918 & 'P+R-OM','OMOM ','R0ETET','R0R0ET','R+R-ET','P0OMOM','OMETET',
34919 & 'R0R0R0','R+R0R-','ETSRET','OMR0R0','OMR+R-','OMOMET','OMOMR0',
34920 & 'OMOMOM',
34921 & ' P+PO ','P+POPO','P+P+P-','P+ET ','P0R+ ','P+R0 ','ETSP+ ',
34922 & 'R+ET ',' R0R+ ','POETR+','P+ETR0','POR+R-','P+R0R0','P-R+R+',
34923 & 'P+R-R+','R+OM ','P+ETOM','ETSR+ ','POR+OM','P+R0OM','R+ETET',
34924 & 'R+R0ET','P+OMOM','R0R0R+','R+R+R-','ETSR+E','OMR+R0','OMOMR+',
34925 & 'P-PO ','P-POPO','P-P-P+','P-ET ','POR- ','P-R0 ','ETSP- ',
34926 & 'R-ET ','R-R0 ','POETR-','P-ETR0','POR-R0','P-R+R-','P-R0R0'/
34927 DATA ZKNAM6/'P+R-R-','R-OM ','P-ETOM','ETSR- ','POR-OM','P-R0OM',
34928 & 'R-ETET','R-R0ET','P-OMOM','R0R0R-','R+R-R-','ETSR-E','OMR0R-',
34929 & 'OMOMR-', 'PAN-14','APN+14','NAN014','ANN014','PAKO ','LPI+ ',
34930 & 'SI+OM','LAMRO+','SI0RO+','SI+RO0','SI+ETA','SI0PI+','SI+PI0',
34931 & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHOO','ANRHO-','ANETA ',
34932 & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0',
34933 & 'KONPIO','KOPPI-','K+NPI-','AKOPPO','AKONP+','K-PPI+',
34934 & 9*'BLANK'/
34935*= end*block.zk *
34936 END
34937
34938*$ CREATE DT_BLKD43.FOR
34939*COPY DT_BLKD43
34940*
34941*===blkd43=============================================================*
34942*
34943 BLOCK DATA DT_BLKD43
34944
34945 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34946 SAVE
34947
34948*
34949*=== reac =============================================================*
34950*
34951*----------------------------------------------------------------------*
34952* *
34953* Created on 10 december 1991 by Alfredo Ferrari & Paola Sala *
34954* Infn - Milan *
34955* *
34956* Last change on 10-dec-91 by Alfredo Ferrari *
34957* *
34958* This is the original common reac of Hadrin *
34959* *
34960*----------------------------------------------------------------------*
34961*
34962 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34963 & NRK(2,268),NURE(30,2)
34964
34965 DIMENSION
34966 & UMOPI(92), UMOKC(68), UMOP(39), UMON(63), UMOK0(34),
34967 & PLAPI(92), PLAKC(68), PLAP(39), PLAN(63), PLAK0(34),
34968 & SPIKP1(315), SPIKPU(278), SPIKPV(372),
34969 & SPIKPW(278), SPIKPX(372), SPIKP4(315),
34970 & SPIKP5(187), SPIKP6(289),
34971 & SKMPEL(102), SPIKP7(289), SKMNEL(68), SPIKP8(187),
34972 & SPIKP9(143), SPIKP0(169), SPKPV(143),
34973 & SAPPEL(105), SPIKPE(399), SAPNEL(84), SPIKPZ(273),
34974 & SANPEL(84) , SPIKPF(273),
34975 & SPKP15(187), SPKP16(272),
34976 & NRKPI(164), NRKKC(132), NRKP(70), NRKN(116), NRKK0(54),
34977 & NURELN(60)
34978*
34979 DIMENSION NRKLIN(532)
34980 EQUIVALENCE (NRK(1,1), NRKLIN(1))
34981 EQUIVALENCE ( UMO( 1), UMOPI(1)), ( UMO( 93), UMOKC(1))
34982 EQUIVALENCE ( UMO(161), UMOP(1)), ( UMO(200), UMON(1))
34983 EQUIVALENCE ( UMO(263), UMOK0(1))
34984 EQUIVALENCE ( PLABF( 1), PLAPI(1)), ( PLABF( 93), PLAKC(1))
34985 EQUIVALENCE ( PLABF(161), PLAP(1)), ( PLABF(200), PLAN(1))
34986 EQUIVALENCE ( PLABF(263), PLAK0(1))
34987 EQUIVALENCE ( WK( 1), SPIKP1(1)), ( WK( 316), SPIKPU(1))
34988 EQUIVALENCE ( WK( 594), SPIKPV(1)), ( WK( 966), SPIKPW(1))
34989 EQUIVALENCE ( WK(1244), SPIKPX(1)), ( WK(1616), SPIKP4(1))
34990 EQUIVALENCE ( WK(1931), SPIKP5(1)), ( WK(2118), SPIKP6(1))
34991 EQUIVALENCE ( WK(2407), SKMPEL(1)), ( WK(2509), SPIKP7(1))
34992 EQUIVALENCE ( WK(2798), SKMNEL(1)), ( WK(2866), SPIKP8(1))
34993 EQUIVALENCE ( WK(3053), SPIKP9(1)), ( WK(3196), SPIKP0(1))
34994 EQUIVALENCE ( WK(3365), SPKPV(1)), ( WK(3508), SAPPEL(1))
34995 EQUIVALENCE ( WK(3613), SPIKPE(1)), ( WK(4012), SAPNEL(1))
34996 EQUIVALENCE ( WK(4096), SPIKPZ(1)), ( WK(4369), SANPEL(1))
34997 EQUIVALENCE ( WK(4453), SPIKPF(1)), ( WK(4726), SPKP15(1))
34998 EQUIVALENCE ( WK(4913), SPKP16(1))
34999 EQUIVALENCE (NRK(1,1), NRKLIN(1))
35000 EQUIVALENCE (NRKLIN( 1), NRKPI(1)), (NRKLIN( 165), NRKKC(1))
35001 EQUIVALENCE (NRKLIN( 297), NRKP(1)), (NRKLIN( 367), NRKN(1))
35002 EQUIVALENCE (NRKLIN( 483), NRKK0(1))
35003 EQUIVALENCE (NURE(1,1), NURELN(1))
35004*
35005**** pi- p data *
35006**** pi+ n data *
35007 DATA PLAPI / 0.D0, .3D0, .5D0, .6D0, .7D0, .8D0, .9D0, .95D0,1.D0,
35008 & 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0,
35009 & 3.D0, 3.5D0, 4.D0, 0.D0, .285D0, .4D0, .45D0, .5D0, .6D0, .7D0,
35010 & .75D0, .8D0, .85D0, .9D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0,
35011 & 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0,
35012 & .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, .75D0, .8D0, .85D0, .9D0,
35013 & 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0,
35014 & 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, .3D0, .5D0, .6D0, .7D0,
35015 & .8D0, .9D0, .95D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0,
35016 & 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0 /
35017 DATA PLAKC /
35018 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35019 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35020 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
35021 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35022 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35023 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
35024 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35025 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35026 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
35027 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35028 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35029 & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
35030 DATA PLAK0 /
35031 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35032 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35033 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
35034 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35035 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35036 & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
35037* pp pn np nn *
35038 DATA PLAP /
35039 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35040 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35041 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35042 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35043 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35044 & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
35045* app apn anp ann *
35046 DATA PLAN /
35047 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
35048 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35049 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35050 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
35051 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35052 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35053 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
35054 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35055 & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
35056 DATA SIIN / 296*0.D0 /
35057 DATA UMOPI/ 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
35058 & 1.557D0,1.615D0,1.6435D0,
35059 & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
35060 & 2.286D0,2.366D0,2.482D0,2.56D0,
35061 & 2.735D0,2.90D0,
35062 & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
35063 & 1.496D0,1.527D0,1.557D0,
35064 & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
35065 & 2.071D0,2.159D0,2.286D0,2.366D0,
35066 & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
35067 & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
35068 & 1.496D0,1.527D0,1.557D0,
35069 & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
35070 & 2.071D0,2.159D0,2.286D0,2.366D0,
35071 & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
35072 & 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
35073 & 1.557D0,1.615D0,1.6435D0,
35074 & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
35075 & 2.286D0,2.366D0,2.482D0,2.56D0,
35076 & 2.735D0, 2.90D0/
35077 DATA UMOKC/ 1.44D0,
35078 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35079 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35080 & 3.1D0,1.44D0,
35081 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35082 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35083 & 3.1D0,1.44D0,
35084 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35085 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35086 & 3.1D0,1.44D0,
35087 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35088 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35089 & 3.1D0/
35090 DATA UMOK0/ 1.44D0,
35091 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35092 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35093 & 3.1D0,1.44D0,
35094 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35095 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35096 & 3.1D0/
35097* pp pn np nn *
35098 DATA UMOP/
35099 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35100 & 3.D0,3.1D0,3.2D0,
35101 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35102 & 3.D0,3.1D0,3.2D0,
35103 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35104 & 3.D0,3.1D0,3.2D0/
35105* app apn anp ann *
35106 DATA UMON /
35107 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
35108 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35109 & 3.D0,3.1D0,3.2D0,
35110 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
35111 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35112 & 3.D0,3.1D0,3.2D0,
35113 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
35114 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35115 & 3.D0,3.1D0,3.2D0/
35116**** reaction channel state particles *
35117 DATA NRKPI / 13, 1, 15, 21, 81, 0, 13, 54, 23, 53, 13, 63, 13, 58,
35118 & 23, 57, 13, 65, 1, 32, 53, 31, 54, 32, 53, 33, 53, 35, 63, 32,
35119 & 13, 8, 23, 1, 17, 15, 21, 24, 22, 15, 82, 0, 61, 0, 13, 55, 23,
35120 & 54, 14, 53, 13, 64, 23, 63, 13, 59, 23, 58, 14, 57, 13, 66, 23,
35121 & 65, 1, 31, 8, 32, 1, 33, 1, 35, 54, 31, 55, 32, 54, 33, 53, 34,
35122 & 54, 35, 14, 1, 23, 8, 17, 24, 20, 15, 22, 24, 83, 0, 62, 0, 14,
35123 & 54, 23, 55, 13, 56, 14, 63, 23, 64, 14, 58, 23, 59, 13, 60, 14,
35124 & 65, 23, 66, 8, 31, 1, 34, 8, 33, 8, 35, 55, 31, 54, 34, 55, 33,
35125 & 56, 32, 55, 35, 14, 8, 24, 20, 84, 0, 14, 55, 23, 56, 14, 64, 14,
35126 & 59, 23, 60, 14, 66, 8, 34, 56, 31, 55, 34, 56, 33, 56, 35, 64,34/
35127 DATA NRKKC/ 15, 1, 89, 0, 24, 53, 15, 54, 1, 36, 1, 40, 1, 44, 36,
35128 & 63, 15, 63, 45, 53, 44, 54, 15, 8, 24, 1, 91, 0, 24, 54, 15, 55,
35129 & 8, 36, 1, 37, 8, 40, 1, 41, 8, 44, 1, 45, 36, 64, 37, 63, 15, 64,
35130 & 24, 63, 45, 54, 44, 55, 16, 1, 25, 8, 17, 23, 21, 14, 20,
35131 & 13, 22, 23, 90, 0, 38, 1, 39, 8, 16, 54, 25, 55, 1, 42, 8, 43,
35132 & 16, 63, 25, 64, 39, 64, 38, 63, 46, 54, 47, 55, 8, 47, 1, 46, 52,
35133 & 0, 51, 0, 16, 8, 17, 14, 20, 23, 22, 14, 92, 0, 8, 38, 16, 55,
35134 & 25, 56, 8, 42, 16, 64, 38, 64, 46, 55, 47, 56, 8, 46, 94, 0 /
35135* *
35136* k0 p k0 n ak0 p ak/ n *
35137* *
35138 DATA NRKK0 / 24, 8, 106, 0, 15, 56, 24, 55, 37, 8, 41, 8, 45, 8,
35139 & 37, 64, 24, 64, 44, 56, 45, 55, 25, 1, 17, 13, 22, 13, 21, 23,
35140 & 107, 0, 39, 1, 25, 54, 16, 53, 43, 1, 25, 63, 39, 63, 47, 54, 46,
35141 & 53, 47, 1, 103, 0, 93, 0/
35142* pp pn np nn *
35143 DATA NRKP / 1, 1, 85, 0, 8, 53, 1, 54, 1, 63, 8, 57, 1, 58, 2*54,
35144 & 53, 55, 63, 54, 64, 53, 1, 8, 86, 0, 8, 54, 1, 55, 8, 63, 1, 64,
35145 & 8, 58, 1, 59, 64, 54, 63, 55, 54, 55, 53, 56, 77, 0, 2*8, 95, 0,
35146 & 8, 55, 1, 56, 8, 64, 8, 59, 1, 60, 2*55, 54, 56, 64, 55, 63, 56 /
35147* app apn anp ann *
35148 DATA NRKN/ 1, 2, 17, 18, 15, 16, 8, 9, 13, 14, 99, 0, 87, 0, 1,
35149 & 68, 8, 69, 2, 54, 9, 55, 102, 0, 2, 63, 9, 64, 1, 75, 8, 76, 53,
35150 & 67, 54, 68, 55, 69, 56, 70, 63, 68, 64, 69, 75, 54, 76, 55, 2, 8,
35151 & 18, 20, 16, 24, 14, 23, 101, 0, 88, 0, 2, 55, 9, 56, 1, 67, 8,
35152 & 68, 2, 64, 8, 75, 2, 59, 8, 72, 68, 55, 67, 54, 69, 56, 1, 9, 18,
35153 & 21, 15, 25, 13, 23, 100, 0, 96, 0, 2, 53, 9, 54, 1, 69, 8, 70, 1,
35154 & 76, 9, 63, 1, 73, 9, 58, 55, 70, 53, 68, 54, 69 /
35155**** channel cross section *
35156 DATA SPIKP1/ 0.D0, 300.D0, 40.D0, 20.D0, 13.D0,8.5D0,8.D0, 9.5D0,
35157 & 12.D0,14.D0,15.5D0,20.D0,17.D0,13.D0,10.D0,9.D0,8.5D0,8.D0,7.8D0,
35158 & 7.3D0, 6.7D0, 9*0.D0,.23D0,.35D0,.7D0,.52D0,.4D0,.3D0,.2D0,.15D0,
35159 & .13D0, .11D0, .09D0, .07D0, 0.D0, .033D0,.8D0,1.35D0,1.35D0,.5D0,
35160 & 15*0.D0, 3*0.D0,.00D0,0.80D0,2.2D0,3.6D0,4.6D0,4.7D0,3.5D0,2.4D0,
35161 &1.8D0,1.4D0,.75D0,.47D0,.25D0,.13D0,.08D0,6*0.D0,0.D0,1.2D0,3.3D0,
35162 & 5.4D0,6.9D0,7.3D0,5.3D0,3.6D0,2.7D0,2.2D0,1.1D0,.73D0,.4D0,.22D0,
35163 & .12D0,9*0.D0,.0D0,0.D0,2.0D0,4.4D0,6.8D0,9.9D0,7.9D0,6.0D0,3.8D0,
35164 &2.5D0,2.D0,1.4D0,1.D0,.6D0,.35D0,10*0.D0,.25D0,.55D0,.75D0,1.25D0,
35165 & 1.9D0,2.D0,1.8D0,1.5D0,1.25D0,1.D0,.8D0,6*0.D0,4*0.D0,.4D0,.85D0,
35166 & 1.1D0, 1.85D0, 2.8D0, 3.D0,2.7D0,2.2D0,1.85D0,1.5D0,1.2D0,6*0.D0,
35167 & 6*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, 5.6D0,
35168 & 5.2D0, 6*0.D0, 2*0.D0, .0D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0,
35169 & 2.75D0, 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 6*0.D0, 3*0.D0,
35170 & .0D0, .45D0, 1.4D0, 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0,
35171 & 8*0.D0, 5*0.D0, .0D0, .0D0, .6D0, .8D0, .95D0, .8D0, .7D0, .6D0,
35172 & .5D0, .4D0, 6*0.D0, 5*0.D0, .0D0, .00D0, .85D0, 1.2D0, 1.4D0,
35173 & 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 6*0.D0, 5*0.D0, .0D0, .00D0,
35174 & 1.D0, 1.5D0, 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 6*0.D0,
35175 & 10*0.D0, .5D0, 2.0D0, 3.3D0, 5.4D0, 7.D0 /
35176**** pi+ n data *
35177 DATA SPIKPU/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 20.D0,
35178 & 20.D0, 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
35179 & 10.D0, 10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
35180 & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
35181 & 4.2D0, 7.5D0, 3.4D0, 2.5D0, 2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0,
35182 & .6D0, .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0,
35183 & .48D0, .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0,
35184 & .065D0, .05D0, .04D0, 12*0.D0, .2D0, .25D0, .25D0, .2D0, .1D0,
35185 & .08D0, .06D0, .045D0, .03D0, .02D0, .01D0, .005D0, .003D0,
35186 & 12*0.D0, .3D0, .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0,
35187 & .09D0, .08D0, .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0,
35188 & 3.1D0, 4.5D0, 2.D0, 18*0.D0, 3*.0D0, 0.D0, 0.D0, 4.0D0, 11.D0,
35189 & 11.4D0, 10.3D0, 7.5D0, 6.8D0, 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0,
35190 & .35D0, 13*0.D0, .1D0, .34D0, .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0,
35191 & 2.3D0, 1.6D0, .95D0, .45D0, .28D0, .15D0, 10*0.D0, 2*0.D0, .17D0,
35192 & .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0, 6.2D0, 4.4D0, 3.D0, 1.8D0,
35193 & .9D0, .53D0, .28D0, 10*0.D0, 2*0.D0, .25D0, .82D0,
35194 & 1.3D0, 1.9D0, 2.8D0, 5.5D0 , 8.D0, 5.7D0, 3.9D0, 2.35D0, 1.15D0,
35195 & .69D0, .37D0, 10*0.D0, 7*0.D0, .0D0, .34D0, 1.5D0, 3.47D0,
35196 & 5.87D0, 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
35197*
35198 DATA SPIKPV/ 7*0.D0, .00D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
35199 & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 6*0.D0, 10*0.D0, .2D0,
35200 & .6D0, .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0,
35201 & 1.D0, .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0,
35202 & 3.5D0, 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0,
35203 & .31D0, .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0,
35204 & .23D0, 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0,
35205 & 5.D0, 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0,
35206 & 2.5D0, 3*0.D0, 3*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0,
35207 & 1.5D0, 1.1D0, .8D0, .7D0, .55D0, .3D0, 10*0.D0, 9*0.D0, .1D0,
35208 & .4D0, 1.D0, 1.4D0, 2.2D0, 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0,
35209 & .8D0, .6D0, .4D0, 12*0.D0, .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0,
35210 & 3.8D0, 3.3D0, 2.45D0, 2.05D0, 1.65D0, 1.2D0, .9D0, .6D0, 3*0.D0,
35211 & 9*0.D0, .10D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0,
35212 & 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, 13*0.D0, .2D0, .5D0, .7D0,
35213 & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
35214 & 17*0.D0, .2D0, .5D0, .85D0, 2.D0, 2.15D0, 2.05D0, 1.75D0, 1.D0,
35215 & 17*0.D0, .13D0, .33D0, .57D0, 1.33D0, 1.43D0, 1.36D0, 1.17D0,
35216 & .67D0, 17*0.D0, .07D0, .17D0, .28D0, .67D0, .72D0, .69D0, .58D0,
35217 & .33D0,17*0.D0,.4D0, .7D0, 1.D0, 1.6D0, 1.8D0, 2.3D0,1.9D0,1.7D0 /
35218**** pi- p data *
35219 DATA SPIKPW/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 2*20.D0,
35220 & 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
35221 & 2*10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
35222 & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
35223 & 4.2D0, 7.5D0, 3.4D0, 2*2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, .6D0,
35224 & .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, .48D0,
35225 & .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, .065D0,
35226 & .05D0, .04D0, 12*0.D0, .2D0, 2*.25D0, .2D0, .1D0, .08D0, .06D0,
35227 & .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, 12*0.D0, .3D0,
35228 & .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, .09D0, .08D0,
35229 & .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, 3.1D0, 4.5D0,
35230 & 2.D0, 23*0.D0, 4.0D0, 11.D0, 11.4D0, 10.3D0, 7.5D0, 6.8D0,
35231 & 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, .35D0, 13*0.D0, .1D0, .34D0,
35232 & .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, 2.3D0, 1.6D0, .95D0, .45D0,
35233 & .28D0, .15D0, 12*0.D0, .17D0, .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0,
35234 & 6.2D0, 4.4D0, 3.D0, 1.8D0, .9D0, .53D0, .28D0, 12*0.D0, .25D0,
35235 & .82D0, 1.3D0, 1.9D0, 2.8D0, 5.5D0, 8.D0, 5.7D0, 3.9D0, 2.35D0,
35236 & 1.15D0, .69D0, .37D0, 18*0.D0, .34D0, 1.5D0, 3.47D0, 5.87D0,
35237 & 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
35238*
35239 DATA SPIKPX/ 8*0.D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
35240 & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 16*0.D0, .2D0, .6D0,
35241 & .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, 1.D0,
35242 & .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, 3.5D0,
35243 & 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, .31D0,
35244 & .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, .23D0,
35245 & 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, 5.D0,
35246 & 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, 2.5D0,
35247 & 6*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, 1.5D0, 1.1D0,
35248 & .8D0, .7D0, .55D0, .3D0, 19*0.D0, .1D0, .4D0, 1.D0, 1.4D0, 2.2D0,
35249 & 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, .8D0, .6D0, .4D0, 12*0.D0,
35250 & .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, 3.8D0, 3.3D0, 2.45D0, 2.05D0,
35251 & 1.65D0, 1.2D0, .9D0, .6D0, 12*0.D0, .10D0, .2D0, .5D0, .7D0,
35252 & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
35253 & 13*0.D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0,
35254 & 1.35D0, 1.15D0, .95D0, .7D0, 17*0.D0, .2D0, .5D0, .85D0, 2.D0,
35255 & 2.15D0, 2.05D0, 1.75D0, 1.D0, 17*0.D0, .13D0, .33D0, .57D0,
35256 & 1.33D0, 1.43D0, 1.36D0, 1.17D0, .67D0, 17*0.D0, .07D0, .17D0,
35257 & .28D0, .67D0, .72D0, .69D0, .58D0, .33D0, 17*0.D0, .4D0, .7D0,
35258 & 1.D0, 1.6D0, 1.8D0, 2.3D0, 1.9D0, 1.7D0 /
35259**** pi- n data *
35260 DATA SPIKP4 / 0.D0, 300.D0, 40.D0, 20.D0, 13.D0, 8.5D0, 8.D0,
35261 & 9.5D0, 12.D0, 14.D0, 15.5D0, 20.D0, 17.D0, 13.D0, 10.D0, 9.D0,
35262 & 8.5D0, 8.D0, 7.8D0, 7.3D0, 6.7D0, 9*0.D0, .23D0, .35D0, .7D0,
35263 & .52D0, .4D0, .3D0, .2D0, .15D0, .13D0, .11D0, .09D0, .07D0, 0.D0,
35264 & .033D0, .8D0, 2*1.35D0, .5D0, 19*0.D0, 0.8D0, 2.2D0, 3.6D0,
35265 & 4.6D0, 4.7D0, 3.5D0, 2.4D0, 1.8D0, 1.4D0, .75D0, .47D0, .25D0,
35266 & .13D0, .08D0, 7*0.D0, 1.2D0, 3.3D0, 5.4D0, 6.9D0, 7.3D0, 5.3D0,
35267 & 3.6D0, 2.7D0, 2.2D0, 1.1D0, .73D0, .4D0, .22D0, .12D0, 11*0.D0,
35268 & 2.0D0, 4.4D0, 6.8D0, 9.9D0, 7.9D0, 6.0D0, 3.8D0, 2.5D0, 2.D0,
35269 & 1.4D0, 1.D0, .6D0, .35D0, 10*0.D0, .25D0, .55D0, .75D0, 1.25D0,
35270 & 1.9D0, 2.D0, 1.8D0, 1.5D0, 1.25D0, 1.D0, .8D0, 10*0.D0, .4D0,
35271 & .85D0, 1.1D0, 1.85D0, 2.8D0, 3.D0, 2.7D0, 2.2D0, 1.85D0, 1.5D0,
35272 & 1.2D0, 12*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0,
35273 & 5.6D0, 5.2D0, 9*0.D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, 2.75D0,
35274 & 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 10*0.D0, .45D0, 1.4D0,
35275 & 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, 15*0.D0, .6D0,
35276 & .8D0, .95D0, .8D0, .7D0, .6D0, .5D0, .4D0, 13*0.D0, .85D0, 1.2D0,
35277 & 1.4D0, 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 13*0.D0, 1.D0, 1.5D0,
35278 & 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 16*0.D0, .5D0, 2.0D0,
35279 & 3.3D0, 5.4D0, 7.D0 /
35280**** k+ p data *
35281 DATA SPIKP5/ 0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0,
35282 & 7.D0, 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
35283 & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 13*0.D0, 0.9D0,
35284 & 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0,
35285 & .45D0, .21D0, .2D0, 3*0.D0, .9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
35286 & 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
35287 & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, 1.4D0,
35288 & 1.2D0, 1.05D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, 2*1.D0, .9D0,
35289 & .7D0, .4D0, .3D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.2D0,
35290 & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
35291 & 1.71D0, 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0,
35292 & 3.5D0, 2.85D0, 2.35D0, 2.01D0, 1.8D0, 12*0.D0, .1D0, .8D0,2.05D0,
35293 & 3.31D0, 3.5D0, 12*0.D0, .034D0, .2D0, .75D0, 1.04D0, 1.24D0 /
35294**** k+ n data *
35295 DATA SPIKP6/ 0.D0, 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0,
35296 & 1.5D0, 1.2D0, 1.D0, .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0,
35297 & 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, 1.5D0, 1.2D0, 1.D0,
35298 & .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, .5D0, 1.3D0, 2.8D0,
35299 & 2.3D0, 1.6D0, .9D0, 13*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
35300 & 2.D0, 1.7D0, 1.5D0,1.2D0,.9D0,.6D0,.45D0,.21D0,.2D0,3*0.D0,0.9D0,
35301 & 2.5D0, 3.D0, 2.5D0, 2.3D0,2.D0,1.7D0,1.5D0,1.2D0,.9D0,.6D0,.45D0,
35302 & .21D0, .2D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.D0,1.8D0,1.7D0,1.4D0,
35303 & 1.2D0,1.15D0,.9D0,.66D0,.5D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.1D0,
35304 & 1.8D0,1.7D0,1.4D0,1.2D0, 1.15D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0,
35305 & 2*1.D0, .9D0, .7D0, .4D0, .35D0, .2D0, 9*0.D0, .3D0, 2*1.D0,.9D0,
35306 & .7D0, .4D0, .35D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.4D0,3.5D0,4.25D0,
35307 & 4.55D0, 4.85D0, 4.9D0, 9*0.D0, .1D0, 1.D0, 2.4D0, 3.5D0, 4.25D0,
35308 & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
35309 & 1.71D0, 1.6D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0,
35310 & 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0,4.4D0,4.D0,3.5D0,2.85D0,
35311 & 2.35D0, 2.01D0, 1.8D0, 6*0.D0, 1.4D0,3.8D0,5.D0,4.7D0,4.4D0,4.D0,
35312 & 3.5D0,2.85D0,2.35D0,2.01D0,1.8D0,12*0.D0,.1D0,.8D0,2.05D0,3.31D0,
35313 & 3.5D0, 12*0.D0, .034D0,.2D0,.75D0,1.04D0,1.24D0 /
35314**** k- p data *
35315 DATA SKMPEL/ 0.D0, 35.D0, 22.D0, 25.D0, 17.D0, 9.D0, 9.5D0, 8.D0,
35316 & 7.D0, 6.5D0, 6.1D0, 5.D0, 4.8D0, 4.6D0, 4.45D0, 4.3D0, 4.2D0,
35317 & 0.D0, 8.D0, 3.5D0, 8.D0, 3.D0, 1.9D0, 1.7D0, 1.D0, .9D0, .8D0,
35318 & .75D0, .5D0, .42D0, .38D0, .34D0, .25D0, .2D0,
35319 & 0.D0, 3.D0, 3.2D0, 3.5D0, 1.5D0, 1.4D0, 1.1D0, .6D0, .5D0,
35320 & .35D0, .28D0, .25D0, .18D0, .12D0, .1D0, .08D0, .04D0,
35321 & 0.D0, 8.5D0, 2.4D0, 1.7D0, 1.3D0, 1.3D0, 1.1D0, .5D0,
35322 & .4D0, .4D0, .35D0, .3D0, .28D0, .2D0, .16D0, .13D0, .11D0,
35323 & 0.D0, 7.D0, 4.8D0, 1.4D0, 1.9D0, .9D0, .4D0, .2D0, .13D0,
35324 & .1D0, .08D0, .06D0, .04D0, .02D0, .015D0, .01D0, .01D0,
35325 & 0.D0, 5.5D0, 1.D0, .8D0, .75D0, .32D0, .2D0, .1D0, .09D0,
35326 & .08D0, .065D0, .05D0, .04D0, .022D0, .017D0, 2*.01D0/
35327 DATA SPIKP7 / 0.D0, .56D0, 1.46D0, 3.16D0, 2.01D0, 1.28D0, .74D0,
35328 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
35329 & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 4*0.D0,
35330 & 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, 1.57D0,
35331 & 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0, 3.03D0,
35332 & 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0,
35333 & .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, 2.8D0,
35334 & 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0,
35335 & .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
35336 & .45D0, .39D0, .22D0, .07D0, 0.D0, 7*0.D0, .34D0, 1.12D0, 1.12D0,
35337 & 1.01D0, .78D0, .45D0, .39D0, .22D0, .07D0, 0.D0, 6*0.D0, 1.71D0,
35338 & 4.26D0, 5.6D0, 5.57D0, 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0,
35339 & 2.25D0, 2.D0, 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
35340 & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, .22D0,
35341 & .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 10*0.D0, .22D0, .8D0,
35342 & .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, .3D0, .7D0,1.D0,
35343 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, 1.72D0, 2.69D0,
35344 & 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 9*0.D0, .11D0, 1.72D0,
35345 & 2.69D0, 3.92D0, 4.76D0, 5.1D0, 5.44D0, 5.3D0, 5*0.D0,9.2D0,4.7D0,
35346 & 1.9D0, 10*0.D0, 2.5D0, 15.D0, 21.5D0, 15.3D0, 3.D0, 1.5D0,
35347 & 10*0.D0/
35348***** k- n data *
35349 DATA SKMNEL/0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
35350 & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0,
35351 & 0.D0, 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0,
35352 & 1.9D0, .9D0, .5D0, .3D0, .24D0, .2D0, .18D0, .1D0, .09D0,
35353 & 0.D0, 1.8D0, 2.D0, 1.1D0, .9D0, .5D0, .5D0, .4D0, .4D0,
35354 & .2D0, .1D0, .06D0, .05D0, .04D0, .03D0, .02D0, .02D0,
35355 & 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, .7D0, .65D0,
35356 & .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, .03D0/
35357 DATA SPIKP8/0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
35358 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
35359 & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,
35360 & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
35361 & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
35362 & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
35363 & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
35364 & 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, .45D0,
35365 & .39D0, .22D0, .07D0, 0.D0,
35366 & 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
35367 & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0,
35368 & 10*0.D0, .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0,
35369 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0,
35370 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0,
35371 & 9*0.D0, .11D0, 1.72D0, 2.69D0, 3.92D0, 4.76D0,
35372 & 5.10D0, 5.44D0, 5.3D0,
35373 & 4*0.D0, 0.00D0, 9.2D0, 4.7D0, 1.9D0, 9*0.D0/
35374***** p p data *
35375 DATA SPIKP9/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
35376 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
35377 & 0.D0, 3.6D0, 1.7D0, 10*0.D0,
35378 & .0D0, 0.D0, 8.7D0, 17.7D0, 18.8D0, 15.9D0,
35379 & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
35380 & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
35381 & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
35382 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
35383 & 16.9D0, 16.5D0, 11.D0, 5.5D0, 3.5D0,
35384 & 10*0.D0, 4.3D0, 7.6D0, 9.D0,
35385 & 10*0.D0, 1.7D0, 2.6D0, 3.D0,
35386 & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
35387 & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
35388 & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
35389 & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/
35390***** p n data *
35391 DATA SPIKP0/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
35392 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
35393 & 0.D0, 1.8D0, .2D0, 12*0.D0,
35394 & 3.2D0, 6.05D0, 9.9D0, 5.1D0,
35395 & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
35396 & 2*.0D0, 3.2D0, 6.05D0, 9.9D0, 5.1D0,
35397 & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
35398 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
35399 & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
35400 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
35401 & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
35402 & 10*0.D0, .7D0, 5.1D0, 8.D0,
35403 & 10*0.D0, .7D0, 5.1D0, 8.D0,
35404 & 10*.0D0, .3D0, 2.8D0, 4.7D0,
35405 & 10*.0D0, .3D0, 2.8D0, 4.7D0,
35406 & 7*0.D0, 1.2D0, 2.5D0, 3.5D0, 6.D0, 5.3D0, 2.9D0,
35407 & 7*0.D0, 1.7D0, 3.6D0, 5.4D0, 9.D0, 7.6D0, 4.2D0,
35408 & 5*0.D0, 7.7D0, 6.1D0, 2.9D0, 5*0.D0/
35409* nn - data *
35410* *
35411 DATA SPKPV/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
35412 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
35413 & 0.D0, 3.6D0, 1.7D0, 12*0.D0,
35414 & 8.7D0, 17.7D0, 18.8D0, 15.9D0,
35415 & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
35416 & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
35417 & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
35418 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0, 16.9D0, 16.5D0,
35419 & 11.D0, 5.5D0, 3.5D0,
35420 & 10*0.D0, 4.3D0, 7.6D0, 9.D0,
35421 & 10*0.D0, 1.7D0, 2.6D0, 3.D0,
35422 & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
35423 & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
35424 & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
35425 & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/
35426**************** ap - p - data *
35427 DATA SAPPEL/ 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
35428 & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
35429 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0,
35430 & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
35431 & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
35432 & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
35433 & 0.D0, 55.D0, 50.D0, 25.D0, 15.D0, 15.D0, 14.D0, 12.D0,
35434 & 10.D0, 7.D0, 6.D0, 4.D0, 3.3D0, 2.8D0, 2.4D0, 2.D0, 1.8D0,
35435 & 1.55D0, 1.3D0, .95D0, .75D0,
35436 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
35437 & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
35438 & .01D0, .008D0, .006D0, .005D0/
35439 DATA SPIKPE/0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
35440 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
35441 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0,
35442 & 9*0.D0, 2.D0, 2.5D0, .2D0, 19*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0,
35443 & 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, .3D0, 1.4D0,
35444 & 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0,
35445 & .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0,
35446 & .3D0, 10*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0,
35447 & .6D0, .5D0, .4D0, .3D0, 9*0.D0, .6D0, 2.5D0, 5.D0, 5.2D0, 5.1D0,
35448 & 5.4D0, 5.8D0, 2.8D0, 2.1D0, 1.8D0, 1.6D0, 1.2D0, 13*0.D0, 1.3D0,
35449 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
35450 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
35451 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
35452 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 14*0.D0, .2D0,
35453 & .5D0, 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0,
35454 & 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0,
35455 & 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, 1.6D0,
35456 & 1.4D0, 1.1D0, .9D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0,
35457 & .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0,
35458 & 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0 /
35459**************** ap - n - data *
35460 DATA SAPNEL/
35461 & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
35462 & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
35463 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0,
35464 & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0,
35465 & .85D0, 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0,
35466 & .14D0, .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
35467 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
35468 & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
35469 & .01D0, .008D0, .006D0, .005D0 /
35470 DATA SPIKPZ/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
35471 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
35472 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
35473 & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35474 & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
35475 & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
35476 & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
35477 & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35478 & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35479 & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35480 & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
35481 & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
35482 & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
35483 & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
35484* *
35485* *
35486**************** an - p - data *
35487* *
35488 DATA SANPEL/
35489 & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, 50.D0,
35490 & 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
35491 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0, .05D0,
35492 & .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
35493 & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
35494 & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
35495 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, .25D0,
35496 & .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
35497 & .01D0, .008D0, .006D0, .005D0 /
35498 DATA SPIKPF/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
35499 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
35500 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
35501 & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35502 & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
35503 & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
35504 & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
35505 & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35506 & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35507 & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35508 & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
35509 & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
35510 & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
35511 & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
35512**** ko - n - data *
35513 DATA SPKP15/0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, 7.D0,
35514 & 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
35515 & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 10*0.D0,
35516 & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
35517 & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
35518 & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
35519 & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
35520 & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0,
35521 & 1.4D0, 1.2D0, 1.05D0, .9D0, .66D0, .5D0,
35522 & 7*0.D0, .3D0, 1.D0, 1.D0, .9D0, .7D0, .4D0, .30D0, .2D0,
35523 & 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.20D0, 4.55D0,
35524 & 4.85D0, 4.9D0,
35525 & 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, 1.6D0,
35526 & 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, 3.5D0,
35527 & 2.85D0, 2.35D0, 2.01D0, 1.8D0,
35528 & 12*0.D0, .1D0, .8D0, 2.05D0, 3.31D0, 3.5D0,
35529 & 12*0.D0, .034D0, .20D0, .75D0, 1.04D0, 1.24D0 /
35530**** ako - p - data *
35531 DATA SPKP16/ 0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
35532 & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, 0.D0,
35533 & 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, 1.9D0, .9D0, .5D0,
35534 & .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, 0.D0, 1.8D0, 2.D0, 1.1D0,
35535 & .9D0, .5D0, .5D0, .4D0, .4D0, .2D0, .1D0, .06D0, .05D0, .04D0,
35536 & .03D0, .02D0, .02D0, 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0,
35537 & .7D0, .65D0, .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0,
35538 & .03D0, 0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
35539 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0,
35540 & 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0,
35541 & 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0,
35542 & 1.01D0, .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0,
35543 & 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0,
35544 & .5D0, .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
35545 & .45D0, .39D0, .22D0, .07D0, 7*0.D0, 1.71D0, 4.26D0, 5.6D0,5.57D0,
35546 & 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0,
35547 & .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0,
35548 & .3D0, .7D0, 1.D0, 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0,
35549 & 1.72D0, 2.69D0, 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 5*0.D0,
35550 & 9.2D0, 4.7D0, 1.9D0, 9*0.D0, .0D0,2.5D0,15.D0,
35551 & 21.5D0, 15.3D0, 3.D0, 1.5D0, 10*0.D0 /
35552 DATA NURELN/9, 12, 5*0, 10, 14, 3*0, 1, 3, 5, 7, 6*0, 2, 6, 16,
35553 & 5*0, 10, 13, 5*0, 11, 12, 3*0, 2, 4, 6, 8, 6*0, 3, 15, 7, 5*0 /
35554*= end*block.blkdt3 *
35555 END
35556
35557*$ CREATE DT_QEL_POL.FOR
35558*COPY DT_QEL_POL
35559*
35560*===qel_pol============================================================*
35561*
35562 SUBROUTINE DT_QEL_POL(ENU,LTYP,P21,P22,P23,P24,P25)
35563
35564 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35565 SAVE
35566
35567 CALL DT_MASS_INI
35568 CALL DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
35569
35570 RETURN
35571 END
35572
35573*$ CREATE DT_GEN_QEL.FOR
35574*COPY DT_GEN_QEL
35575C==================================================================
35576C Generation of a Quasi-Elastic neutrino scattering
35577C==================================================================
35578*
35579*===gen_qel============================================================*
35580*
35581 SUBROUTINE DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
35582
35583C...Generate a quasi-elastic neutrino/antineutrino
35584C. Interaction on a nuclear target
35585C. INPUT : LTYP = neutrino type (1,...,6)
35586C. ENU (GeV) = neutrino energy
35587C----------------------------------------------------
35588
35589 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35590 SAVE
35591
35592 PARAMETER ( LINP = 10 ,
35593 & LOUT = 6 ,
35594 & LDAT = 9 )
35595 PARAMETER (MAXLND=4000)
35596 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
35597* nuclear potential
35598 LOGICAL LFERMI
35599 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
35600 & EBINDP(2),EBINDN(2),EPOT(2,210),
35601 & ETACOU(2),ICOUL,LFERMI
35602* steering flags for qel neutrino scattering modules
35603 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
35604**sr - removed (not needed)
35605C COMMON /CBAD/ LBAD, NBAD
35606C COMMON /CNUC/ XMN,XMN2,PFERMI,EFERMI,EBIND,EB2,C0
35607**
35608
35609 DIMENSION PI(3),PO(3)
35610CJR+
35611 DATA ININU/0/
35612CJR-
35613C REAL*8 DBETA(3)
35614C REAL*8 MN(2), ML0(6), ML, ML2, MI, MI2, MF, MF2
35615 DIMENSION DBETA(3),DBETB(3),AMN(2),AML0(6)
35616 DATA AMN /0.93827231D0, 0.93956563D0/
35617 DATA AML0 /2*0.51100D-03,2*0.105659D0, 2*1.777D0/
35618 DATA INIPRI/0/
35619
35620C DATA PFERMI/0.22D0/
35621CGB+...Binding Energy
35622 DATA EBIND/0.008D0/
35623CGB-...
35624
35625 ININU=ININU+1
35626 IF(ININU.EQ.1)NDSIG=0
35627 LBAD = 0
35628 enu0=enu
35629c write(*,*) enu0
35630C...Lepton mass
35631 AML = AML0(LTYP) ! massa leptoni
35632 AML2 = AML**2 ! massa leptoni **2
35633C...Particle labels (LUND)
35634 N = 5
35635 K(1,1) = 21
35636 K(2,1) = 21
35637 K(3,1) = 21
35638 K(3,3) = 1
35639 K(4,1) = 1
35640 K(4,3) = 1
35641 K(5,1) = 1
35642 K(5,3) = 2
35643 K0 = (LTYP-1)/2 ! 2
35644 K1 = LTYP/2 ! 2
35645 KA = 12 + 2*K0 ! 16
35646 IS = -1 + 2*LTYP - 4*K1 ! -1 +10 -8 = 1
35647 K(1,2) = IS*KA
35648 K(4,2) = IS*(KA-1)
35649 K(3,2) = IS*24
35650 LNU = 2 - LTYP + 2*K1 ! 2 - 5 + 2 = - 1
35651 IF (LNU .EQ. 2) THEN
35652 K(2,2) = 2212
35653 K(5,2) = 2112
35654 AMI = AMN(1)
35655 AMF = AMN(2)
35656CJR+
35657 PFERMI=PFERMN(2)
35658CJR-
35659 ELSE
35660 K(2,2) = 2112
35661 K(5,2) = 2212
35662 AMI = AMN(2)
35663 AMF = AMN(1)
35664CJR+
35665 PFERMI=PFERMP(2)
35666CJR-
35667 ENDIF
35668 AMI2 = AMI**2
35669 AMF2 = AMF**2
35670
35671 DO IGB=1,5
35672 P(3,IGB) = 0.
35673 P(4,IGB) = 0.
35674 P(5,IGB) = 0.
35675 END DO
35676
35677 NTRY = 0
35678CGB+...
35679 EFMAX = SQRT(PFERMI**2 + AMI2) -AMI ! max. Fermi Energy
35680 ENWELL = EFMAX + EBIND ! depth of nuclear potential well
35681CGB-...
35682
35683 100 CONTINUE
35684
35685C...4-momentum initial lepton
35686 P(1,5) = 0. ! massa
35687 P(1,4) = ENU0 ! energia
35688 P(1,1) = 0. ! px
35689 P(1,2) = 0. ! py
35690 P(1,3) = ENU0 ! pz
35691
35692C PF = PFERMI*PYR(0)**(1./3.)
35693c write(23,*) PYR(0)
35694c write(*,*) 'Pfermi=',PF
35695c PF = 0.
35696 NTRY=NTRY+1
35697C IF(ntry.GT.2) WRITE(*,*) ntry,enu0,k2
35698 IF (NTRY .GT. 500) THEN
35699 LBAD = 1
35700 WRITE (LOUT,1001) NBAD, ENU
35701 RETURN
35702 ENDIF
35703C CT = -1. + 2.*PYR(0)
35704c CT = -1.
35705C ST = SQRT(1.-CT*CT)
35706C F = 2.*3.1415926*PYR(0)
35707c F = 0.
35708
35709C P(2,4) = SQRT(PF*PF + MI2) - EBIND ! energia
35710C P(2,1) = PF*ST*COS(F) ! px
35711C P(2,2) = PF*ST*SIN(F) ! py
35712C P(2,3) = PF*CT ! pz
35713C P(2,5) = SQRT(P(2,4)**2-PF*PF) ! massa
35714 P(2,1) = P21
35715 P(2,2) = P22
35716 P(2,3) = P23
35717 P(2,4) = P24
35718 P(2,5) = P25
35719 beta1=-p(2,1)/p(2,4)
35720 beta2=-p(2,2)/p(2,4)
35721 beta3=-p(2,3)/p(2,4)
35722 N=2
35723C WRITE(6,*)' before transforming into target rest frame'
35724 CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
35725C print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
35726 N=5
35727
35728 phi11=atan(p(1,2)/p(1,3))
35729 pi(1)=p(1,1)
35730 pi(2)=p(1,2)
35731 pi(3)=p(1,3)
35732
35733 CALL DT_TESTROT(PI,Po,PHI11,1)
35734 DO ll=1,3
35735 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35736 END DO
35737c WRITE(*,*) po
35738 p(1,1)=po(1)
35739 p(1,2)=po(2)
35740 p(1,3)=po(3)
35741 phi12=atan(p(1,1)/p(1,3))
35742
35743 pi(1)=p(1,1)
35744 pi(2)=p(1,2)
35745 pi(3)=p(1,3)
35746 CALL DT_TESTROT(Pi,Po,PHI12,2)
35747 DO ll=1,3
35748 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35749 END DO
35750c WRITE(*,*) po
35751 p(1,1)=po(1)
35752 p(1,2)=po(2)
35753 p(1,3)=po(3)
35754
35755 enu=p(1,4)
35756
35757C...Kinematical limits in Q**2
35758c S = P(2,5)**2 + 2.*ENU*(P(2,4)-P(2,3)) ! ????
35759 S = P(2,5)**2 + 2.*ENU*P(2,5)
35760 SQS = SQRT(S) ! E centro massa
35761 IF (SQS .LT. (AML + AMF + 3.E-03)) GOTO 100
35762 ELF = (S-AMF2+AML2)/(2.*SQS) ! energia leptone finale p
35763 PSTAR = (S-P(2,5)**2)/(2.*SQS) ! p* neutrino nel c.m.
35764 PLF = SQRT(ELF**2-AML2) ! 3-momento leptone finale
35765 Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF) ! + o -
35766 Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF) ! according con cos(theta)
35767 IF (Q2MIN .LT. 0.) Q2MIN = 0. ! ??? non fisico
35768
35769C...Generate Q**2
35770 DSIGMAX = DT_DSQEL_Q2 (LTYP,ENU, Q2MIN)
35771 200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
35772 DSIG = DT_DSQEL_Q2 (LTYP,ENU, Q2)
35773 IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200
35774 CALL DT_QGAUS(Q2MIN,Q2MAX,DSIGEV,ENU,LTYP)
35775 NDSIG=NDSIG+1
35776C WRITE(6,*)' Q2,Q2min,Q2MAX,DSIGEV',
35777C &Q2,Q2min,Q2MAX,DSIGEV
35778
35779C...c.m. frame. Neutrino along z axis
35780 DETOT = (P(1,4)) + (P(2,4)) ! e totale
35781 DBETA(1) = ((P(1,1)) + (P(2,1)))/DETOT ! px1+px2/etot = beta_x
35782 DBETA(2) = ((P(1,2)) + (P(2,2)))/DETOT !
35783 DBETA(3) = ((P(1,3)) + (P(2,3)))/DETOT !
35784c WRITE(*,*)
35785c WRITE(*,*)
35786C WRITE(*,*) 'Input values laboratory frame'
35787 N=2
35788
35789 CALL PYROBO(0,0,0.0D0,0.0D0,-DBETA(1),-DBETA(2),-DBETA(3))
35790
35791 N=5
35792c STHETA = ULANGL(P(1,3),P(1,1))
35793c write(*,*) 'stheta' ,stheta
35794c stheta=0.
35795c CALL PYROBO (0,0,-STHETA,0.,0.D0,0.D0,0.D0)
35796c WRITE(*,*)
35797c WRITE(*,*)
35798C WRITE(*,*) 'Output values cm frame'
35799C...Kinematic in c.m. frame
35800 CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) ! cos(theta) cm
35801 STSTAR = SQRT(1.-CTSTAR**2)
35802 PHI = 6.28319*PYR(0) ! random phi tra 0 e 2*pi
35803 P(4,5) = AML ! massa leptone
35804 P(4,4) = ELF ! e leptone
35805 P(4,3) = PLF*CTSTAR ! px
35806 P(4,1) = PLF*STSTAR*COS(PHI) ! py
35807 P(4,2) = PLF*STSTAR*SIN(PHI) ! pz
35808
35809 P(5,5) = AMF ! barione
35810 P(5,4) = (S+AMF2-AML2)/(2.*SQS)! e barione
35811 P(5,3) = -P(4,3) ! px
35812 P(5,1) = -P(4,1) ! py
35813 P(5,2) = -P(4,2) ! pz
35814
35815 P(3,5) = -Q2
35816 P(3,1) = P(1,1)-P(4,1)
35817 P(3,2) = P(1,2)-P(4,2)
35818 P(3,3) = P(1,3)-P(4,3)
35819 P(3,4) = P(1,4)-P(4,4)
35820
35821C...Transform back to laboratory frame
35822C WRITE(*,*) 'before going back to nucl rest frame'
35823c CALL PYROBO (0,0,STHETA,0.,0.D0,0.D0,0.D0)
35824 N=5
35825
35826 CALL PYROBO(0,0,0.0D0,0.0D0,DBETA(1),DBETA(2),DBETA(3))
35827
35828C WRITE(*,*) 'Now back in nucl rest frame'
35829 IF(LTYP.GE.3) CALL DT_PREPOLA(Q2,LTYP,ENU)
35830
35831c********************************************
35832
35833 DO kw=1,5
35834 pi(1)=p(kw,1)
35835 pi(2)=p(kw,2)
35836 pi(3)=p(kw,3)
35837 CALL DT_TESTROT(Pi,Po,PHI12,3)
35838 DO ll=1,3
35839 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35840 END DO
35841 p(kw,1)=po(1)
35842 p(kw,2)=po(2)
35843 p(kw,3)=po(3)
35844 END DO
35845c********************************************
35846
35847 DO kw=1,5
35848 pi(1)=p(kw,1)
35849 pi(2)=p(kw,2)
35850 pi(3)=p(kw,3)
35851 CALL DT_TESTROT(Pi,Po,PHI11,4)
35852 DO ll=1,3
35853 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35854 END DO
35855 p(kw,1)=po(1)
35856 p(kw,2)=po(2)
35857 p(kw,3)=po(3)
35858 END DO
35859
35860c********************************************
35861
35862C WRITE(*,*) 'Now back in lab frame'
35863
35864 CALL PYROBO(1,5,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
35865
35866CGB+...
35867C...test (on final momentum of nucleon) if Fermi-blocking
35868C...is operating
35869 ENUCL = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2 + P(5,5)**2)
35870 & - P(5,5)
35871 IF (ENUCL.LT. EFMAX) THEN
35872 IF(INIPRI.LT.10)THEN
35873 INIPRI=INIPRI+1
35874C WRITE(6,*)' qel: Pauli ENUCL.LT.EFMAX ', ENUCL,EFMAX
35875C...the interaction is not possible due to Pauli-Blocking and
35876C...it must be resampled
35877 ENDIF
35878 GOTO 100
35879 ELSE IF (ENUCL.LT.ENWELL.and.ENUCL.GE.EFMAX) THEN
35880 IF(INIPRI.LT.10)THEN
35881 INIPRI=INIPRI+1
35882C WRITE(6,*)' qel: inside ENUCL.LT.ENWELL ', ENUCL,ENWELL
35883 ENDIF
35884C Reject (J:R) here all these events
35885C are otherwise rejected in dpmjet
35886 GOTO 100
35887C...the interaction is possible, but the nucleon remains inside
35888C...the nucleus. The nucleus is therefore left excited.
35889C...We treat this case as a nucleon with 0 kinetic energy.
35890C P(5,5) = AMF
35891C P(5,4) = AMF
35892C P(5,1) = 0.
35893C P(5,2) = 0.
35894C P(5,3) = 0.
35895 ELSE IF (ENUCL.GE.ENWELL) THEN
35896C WRITE(6,*)' qel ENUCL.GE.ENWELL ',ENUCL,ENWELL
35897C...the interaction is possible, the nucleon can exit the nucleus
35898C...but the nuclear well depth must be subtracted. The nucleus could be
35899C...left in an excited state.
35900 Pstart = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2)
35901C P(5,4) = ENUCL-ENWELL + AMF
35902 Pnucl = SQRT(P(5,4)**2-AMF**2)
35903C...The 3-momentum is scaled assuming that the direction remains
35904C...unaffected
35905 P(5,1) = P(5,1) * Pnucl/Pstart
35906 P(5,2) = P(5,2) * Pnucl/Pstart
35907 P(5,3) = P(5,3) * Pnucl/Pstart
35908C WRITE(6,*)' qel new P(5,4) ',P(5,4)
35909 ENDIF
35910CGB-...
35911 DSIGSU=DSIGSU+DSIGEV
35912
35913 GA=P(4,4)/P(4,5)
35914 BGX=P(4,1)/P(4,5)
35915 BGY=P(4,2)/P(4,5)
35916 BGZ=P(4,3)/P(4,5)
35917*
35918 DBETB(1)=BGX/GA
35919 DBETB(2)=BGY/GA
35920 DBETB(3)=BGZ/GA
35921 IF(NEUDEC.EQ.1.OR.NEUDEC.EQ.2) THEN
35922
35923 CALL PYROBO(6,8,0.0D0,0.0D0,DBETB(1),DBETB(2),DBETB(3))
35924
35925 ENDIF
35926c
35927C PRINT*,' FINE EVENTO '
35928 enu=enu0
35929 RETURN
35930
35931 1001 FORMAT(2X, 'DT_GEN_QEL : event rejected ', I5, G10.3)
35932 END
35933
35934*$ CREATE DT_MASS_INI.FOR
35935*COPY DT_MASS_INI
35936C====================================================================
35937C. Masses
35938C====================================================================
35939*
35940*===mass_ini===========================================================*
35941*
35942 SUBROUTINE DT_MASS_INI
35943C...Initialize the kinematics for the quasi-elastic cross section
35944
35945 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35946 SAVE
35947
35948* particle masses used in qel neutrino scattering modules
35949 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
35950 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
35951 & EMPROTSQ,EMNEUTSQ,EMNSQ
35952
35953 EML(1) = 0.51100D-03 ! e-
35954 EML(2) = EML(1) ! e+
35955 EML(3) = 0.105659D0 ! mu-
35956 EML(4) = EML(3) ! mu+
35957 EML(5) = 1.7777D0 ! tau-
35958 EML(6) = EML(5) ! tau+
35959 EMPROT = 0.93827231D0 ! p
35960 EMNEUT = 0.93956563D0 ! n
35961 EMPROTSQ = EMPROT**2
35962 EMNEUTSQ = EMNEUT**2
35963 EMN = (EMPROT + EMNEUT)/2.
35964 EMNSQ = EMN**2
35965 DO J=1,3
35966 J0 = 2*(J-1)
35967 EMN1(J0+1) = EMNEUT
35968 EMN1(J0+2) = EMPROT
35969 EMN2(J0+1) = EMPROT
35970 EMN2(J0+2) = EMNEUT
35971 ENDDO
35972 DO J=1,6
35973 EMLSQ(J) = EML(J)**2
35974 ETQE(J) = ((EMN2(J)+ EML(J))**2-EMN1(J)**2)/(2.*EMN1(J))
35975 ENDDO
35976 RETURN
35977 END
35978
35979*$ CREATE DT_DSQEL_Q2.FOR
35980*COPY DT_DSQEL_Q2
35981*
35982*===dsqel_q2===========================================================*
35983*
35984 DOUBLE PRECISION FUNCTION DT_DSQEL_Q2 (JTYP,ENU, Q2)
35985
35986C...differential cross section for Quasi-Elastic scattering
35987C. nu + N -> l + N'
35988C. From Llewellin Smith Phys.Rep. 3C, 261, (1971).
35989C.
35990C. INPUT : JTYP = 1,...,6 nu_e, ...., nubar_tau
35991C. ENU (GeV) = Neutrino energy
35992C. Q2 (GeV**2) = (Transfer momentum)**2
35993C.
35994C. OUTPUT : DSQEL_Q2 = differential cross section :
35995C. dsigma/dq**2 (10**-38 cm+2/GeV**2)
35996C------------------------------------------------------------------
35997
35998 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35999 SAVE
36000
36001* particle masses used in qel neutrino scattering modules
36002 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
36003 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
36004 & EMPROTSQ,EMNEUTSQ,EMNSQ
36005**sr - removed (not needed)
36006C COMMON /CAXIAL/ FA0, AXIAL2
36007**
36008
36009 DIMENSION SS(6)
36010 DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
36011 DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
36012 DATA AXIAL2 /1.03D0/ ! to be checked
36013
36014 FA0=-1.253D0
36015 CSI = 3.71D0 ! ???
36016 GVE = 1.D0/ (1.D0 + Q2/0.84D0**2)**2 ! G_e(q**2)
36017 GVM = (1.D0+CSI)*GVE ! G_m (q**2)
36018 X = Q2/(EMN*EMN) ! emn=massa barione
36019 XA = X/4.D0
36020 FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
36021 FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
36022 FA = FA0/(1.D0 + Q2/AXIAL2)**2
36023 FFA = FA*FA
36024 FFV1 = FV1*FV1
36025 FFV2 = FV2*FV2
36026 RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp)
36027 A1 = (4.D0+X)*FFA - (4.D0-X)*FFV1 + X*FFV2*(1.D0-XA)+4*X*FV1*FV2
36028 A2 = -RM * ((FV1 + FV2)**2 + FFA)
36029 AA = (XA+0.25D0*RM)*(A1 + A2)
36030 BB = -X*FA*(FV1 + FV2)
36031 CC = 0.25D0*(FFA + FFV1 + XA*FFV2)
36032 SU = (4.D0*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
36033 DT_DSQEL_Q2 = C0*(AA + SS(JTYP)*BB*SU + CC*SU*SU) / (ENU*ENU) !
36034 IF(DT_DSQEL_Q2 .LT. 0.D0) DT_DSQEL_Q2 = 0.D0
36035
36036 RETURN
36037 END
36038
36039*$ CREATE DT_PREPOLA.FOR
36040*COPY DT_PREPOLA
36041*
36042*===prepola============================================================*
36043*
36044 SUBROUTINE DT_PREPOLA(Q2,JTYP,ENU)
36045
36046 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36047 SAVE
36048c
36049c By G. Battistoni and E. Scapparone (sept. 1997)
36050c According to:
36051c Albright & Jarlskog, Nucl Phys B84 (1975) 467
36052c
36053c
36054 PARAMETER (MAXLND=4000)
36055 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
36056 COMMON /QNPOL/ POLARX(4),PMODUL
36057* particle masses used in qel neutrino scattering modules
36058 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
36059 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
36060 & EMPROTSQ,EMNEUTSQ,EMNSQ
36061* steering flags for qel neutrino scattering modules
36062 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
36063**sr - removed (not needed)
36064C COMMON /CAXIAL/ FA0, AXIAL2
36065C COMMON /TAUTAU/Q(4,5),ETL,PXL,PYL,PZL,
36066C & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN
36067**
36068 REAL*8 POL(4,4),BB2(3)
36069 DIMENSION SS(6)
36070C DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
36071 DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
36072**sr uncommented since common block CAXIAL is now commented
36073 DATA AXIAL2 /1.03D0/ ! to be checked
36074**
36075
36076 RML=P(4,5)
36077 RMM=0.93960D+00
36078 FM2 = RMM**2
36079 MPI = 0.135D+00
36080 OLDQ2=Q2
36081 FA0=-1.253D+00
36082 CSI = 3.71D+00 !
36083 GVE = 1.D0/ (1.D0 + Q2/(0.84D+00)**2)**2 ! G_e(q**2)
36084 GVM = (1.D0+CSI)*GVE ! G_m (q**2)
36085 X = Q2/(EMN*EMN) ! emn=massa barione
36086 XA = X/4.D0
36087 FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
36088 FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
36089 FA = FA0/(1.D0 + Q2/AXIAL2**2)**2
36090 FFA = FA*FA
36091 FFV1 = FV1*FV1
36092 FFV2 = FV2*FV2
36093 FP=2.D0*FA*RMM/(MPI**2 + Q2)
36094 RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp)
36095 A1 = (4.D0+X)*FFA-(4.D0-X)*FFV1+X*FFV2*(1.D0-XA)+4.D0*X*FV1*FV2
36096 A2 = -RM * ((FV1 + FV2)**2 + FFA)
36097 AA = (XA+0.25D+00*RM)*(A1 + A2)
36098 BB = -X*FA*(FV1 + FV2)
36099 CC = 0.25D+00*(FFA + FFV1 + XA*FFV2)
36100 SU = (4.D+00*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
36101
36102 OMEGA1=FFA+XA*(FFA+(FV1+FV2)**2 ) ! articolo di ll...-smith
36103 OMEGA2=4.D+00*CC
36104 OMEGA3=2.D+00*FA*(FV1+FV2)
36105 OMEGA4P=(-(FV1+FV2)**2-(FA+2*FP)**2+(4.0D+00+
36106 1 (Q2/FM2))*FP**2)
36107 OMEGA5=OMEGA2
36108 OMEGA4=(OMEGA4P-OMEGA2+2*OMEGA5)/4.D+00
36109 WW1=2.D+00*OMEGA1*EMN**2
36110 WW2=2.D+00*OMEGA2*EMN**2
36111 WW3=2.D+00*OMEGA3*EMN**2
36112 WW4=2.D+00*OMEGA4*EMN**2
36113 WW5=2.D+00*OMEGA5*EMN**2
36114
36115 DO I=1,3
36116 BB2(I)=-P(4,I)/P(4,4)
36117 END DO
36118c WRITE(*,*)
36119c WRITE(*,*)
36120c WRITE(*,*) 'Prepola: ready to transform to lepton rest frame'
36121 N=5
36122 CALL PYROBO(0,0,0.0D0,0.0D0,BB2(1),BB2(2),BB2(3))
36123* NOW PARTICLES ARE IN THE SCATTERED LEPTON REST FRAME
36124c WRITE(*,*)
36125c WRITE(*,*)
36126c WRITE(*,*) 'Prepola: now in lepton rest frame'
36127 EE=ENU
36128 QM2=Q2+RML**2
36129 U=Q2/(2.*RMM)
36130 FRAC=QM2*WW1 + (2.D+00*EE*(EE-U) - 0.5D+00*QM2)*WW2 - SS(JTYP)*
36131 + (0.5D+00/(RMM**2))*(2.D+00*RMM*EE*Q2 - U*QM2)*WW3 +
36132 + ((RML**2)/(2.D+00*FM2))*(QM2*WW4-2.D+00*RMM*EE*WW5) !<=FM2 inv di RMM!!
36133
36134 FACTK=2.D+00*WW1 -WW2 -SS(JTYP)*(EE/RMM)*WW3 +((EE-U)/RMM)*WW5
36135 + - ((RML**2)/FM2)*WW4 !<=FM2 inv di RMM!!
36136
36137 FACTP=2.D+00*EE/RMM*WW2 - (QM2/(2.D+00*RMM**2))*(SS(JTYP)*WW3+WW5)
36138
36139 DO I=1,3
36140 POL(4,I)=RML*SS(JTYP)*(FACTK*P(1,I)+FACTP*P(2,I))/FRAC
36141 POLARX(I)=POL(4,I)
36142 END DO
36143
36144 PMODUL=0.D0
36145 DO I=1,3
36146 PMODUL=PMODUL+POL(4,I)**2
36147 END DO
36148
36149 IF(JTYP.GT.4.AND.NEUDEC.GT.0) THEN
36150 IF(NEUDEC.EQ.1) THEN
36151 CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-2),POLARX(3),
36152 + ETL,PXL,PYL,PZL,
36153 + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
36154c
36155c Tau has decayed in muon
36156c
36157 ENDIF
36158 IF(NEUDEC.EQ.2) THEN
36159 CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-4),POLARX(3),
36160 + ETL,PXL,PYL,PZL,
36161 + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
36162c
36163c Tau has decayed in electron
36164c
36165 ENDIF
36166 K(4,1)=15
36167 K(4,4) = 6
36168 K(4,5) = 8
36169 N=N+3
36170c
36171c fill common for muon(electron)
36172c
36173 P(6,1)=PXL
36174 P(6,2)=PYL
36175 P(6,3)=PZL
36176 P(6,4)=ETL
36177 K(6,1)=1
36178 IF(JTYP.EQ.5) THEN
36179 IF(NEUDEC.EQ.1) THEN
36180 P(6,5)=EML(JTYP-2)
36181 K(6,2)=13
36182 ELSEIF(NEUDEC.EQ.2) THEN
36183 P(6,5)=EML(JTYP-4)
36184 K(6,2)=11
36185 ENDIF
36186 ELSEIF(JTYP.EQ.6) THEN
36187 IF(NEUDEC.EQ.1) THEN
36188 K(6,2)=-13
36189 ELSEIF(NEUDEC.EQ.2) THEN
36190 K(6,2)=-11
36191 ENDIF
36192 END IF
36193 K(6,3)=4
36194 K(6,4)=0
36195 K(6,5)=0
36196c
36197c fill common for tau_(anti)neutrino
36198c
36199 P(7,1)=PXB
36200 P(7,2)=PYB
36201 P(7,3)=PZB
36202 P(7,4)=ETB
36203 P(7,5)=0.
36204 K(7,1)=1
36205 IF(JTYP.EQ.5) THEN
36206 K(7,2)=16
36207 ELSEIF(JTYP.EQ.6) THEN
36208 K(7,2)=-16
36209 END IF
36210 K(7,3)=4
36211 K(7,4)=0
36212 K(7,5)=0
36213c
36214c Fill common for muon(electron)_(anti)neutrino
36215c
36216 P(8,1)=PXN
36217 P(8,2)=PYN
36218 P(8,3)=PZN
36219 P(8,4)=ETN
36220 P(8,5)=0.
36221 K(8,1)=1
36222 IF(JTYP.EQ.5) THEN
36223 IF(NEUDEC.EQ.1) THEN
36224 K(8,2)=-14
36225 ELSEIF(NEUDEC.EQ.2) THEN
36226 K(8,2)=-12
36227 ENDIF
36228 ELSEIF(JTYP.EQ.6) THEN
36229 IF(NEUDEC.EQ.1) THEN
36230 K(8,2)=14
36231 ELSEIF(NEUDEC.EQ.2) THEN
36232 K(8,2)=12
36233 ENDIF
36234 END IF
36235 K(8,3)=4
36236 K(8,4)=0
36237 K(8,5)=0
36238 ENDIF
36239c WRITE(*,*)
36240c WRITE(*,*)
36241
36242c IF(PMODUL.GE.1.D+00) THEN
36243c WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
36244c write(*,*) pmodul
36245c DO I=1,3
36246c POL(4,I)=POL(4,I)/PMODUL
36247c POLARX(I)=POL(4,I)
36248c END DO
36249c PMODUL=0.
36250c DO I=1,3
36251c PMODUL=PMODUL+POL(4,I)**2
36252c END DO
36253c WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
36254c
36255c ENDIF
36256
36257c WRITE(*,*) 'PMODUL = ',PMODUL
36258
36259c WRITE(*,*)
36260c WRITE(*,*)
36261c WRITE(*,*) 'prepola: Now back to nucl rest frame'
36262 CALL PYROBO(1,5,0.0D0,0.0D0,-BB2(1),-BB2(2),-BB2(3))
36263
36264 XDC = V(4,1)+V(4,5)*P(4,1)/P(4,5)
36265 YDC = V(4,2)+V(4,5)*P(4,2)/P(4,5)
36266 ZDC = V(4,3)+V(4,5)*P(4,3)/P(4,5)
36267 DO NDC =6,8
36268 V(NDC,1) = XDC
36269 V(NDC,2) = YDC
36270 V(NDC,3) = ZDC
36271 END DO
36272
36273 RETURN
36274 END
36275
36276*$ CREATE DT_TESTROT.FOR
36277*COPY DT_TESTROT
36278*
36279*===testrot============================================================*
36280*
36281 SUBROUTINE DT_TESTROT(PI,PO,PHI,MODE)
36282
36283 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36284 SAVE
36285
36286 DIMENSION ROT(3,3),PI(3),PO(3)
36287
36288 IF (MODE.EQ.1) THEN
36289 ROT(1,1) = 1.D0
36290 ROT(1,2) = 0.D0
36291 ROT(1,3) = 0.D0
36292 ROT(2,1) = 0.D0
36293 ROT(2,2) = COS(PHI)
36294 ROT(2,3) = -SIN(PHI)
36295 ROT(3,1) = 0.D0
36296 ROT(3,2) = SIN(PHI)
36297 ROT(3,3) = COS(PHI)
36298 ELSEIF (MODE.EQ.2) THEN
36299 ROT(1,1) = 0.D0
36300 ROT(1,2) = 1.D0
36301 ROT(1,3) = 0.D0
36302 ROT(2,1) = COS(PHI)
36303 ROT(2,2) = 0.D0
36304 ROT(2,3) = -SIN(PHI)
36305 ROT(3,1) = SIN(PHI)
36306 ROT(3,2) = 0.D0
36307 ROT(3,3) = COS(PHI)
36308 ELSEIF (MODE.EQ.3) THEN
36309 ROT(1,1) = 0.D0
36310 ROT(2,1) = 1.D0
36311 ROT(3,1) = 0.D0
36312 ROT(1,2) = COS(PHI)
36313 ROT(2,2) = 0.D0
36314 ROT(3,2) = -SIN(PHI)
36315 ROT(1,3) = SIN(PHI)
36316 ROT(2,3) = 0.D0
36317 ROT(3,3) = COS(PHI)
36318 ELSEIF (MODE.EQ.4) THEN
36319 ROT(1,1) = 1.D0
36320 ROT(2,1) = 0.D0
36321 ROT(3,1) = 0.D0
36322 ROT(1,2) = 0.D0
36323 ROT(2,2) = COS(PHI)
36324 ROT(3,2) = -SIN(PHI)
36325 ROT(1,3) = 0.D0
36326 ROT(2,3) = SIN(PHI)
36327 ROT(3,3) = COS(PHI)
36328 ELSE
36329 STOP ' TESTROT: mode not supported!'
36330 ENDIF
36331 DO 1 J=1,3
36332 PO(J) = ROT(J,1)*PI(1)+ROT(J,2)*PI(2)+ROT(J,3)*PI(3)
36333 1 CONTINUE
36334
36335 RETURN
36336 END
36337
36338*$ CREATE DT_LEPDCYP.FOR
36339*COPY DT_LEPDCYP
36340*
36341*===lepdcyp============================================================*
36342*
36343 SUBROUTINE DT_LEPDCYP(AMA,AML,POL,ETL,PXL,PYL,PZL,
36344 & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
36345C
36346C-----------------------------------------------------------------
36347C
36348C Author :- G. Battistoni 10-NOV-1995
36349C
36350C=================================================================
36351C
36352C Purpose : performs decay of polarized lepton in
36353C its rest frame: a => b + l + anti-nu
36354C (Example: mu- => nu-mu + e- + anti-nu-e)
36355C Polarization is assumed along Z-axis
36356C WARNING:
36357C 1) b AND anti-nu ARE ASSUMED TO BE NEUTRINOS
36358C OF NEGLIGIBLE MASS
36359C 2) RADIATIVE CORRECTIONS ARE NOT CONSIDERED
36360C IN THIS VERSION
36361C
36362C Method : modifies phase space distribution obtained
36363C by routine EXPLOD using a rejection against the
36364C matrix element for unpolarized lepton decay
36365C
36366C Inputs : Mass of a : AMA
36367C Mass of l : AML
36368C Polar. of a: POL
36369C (Example: fully polar. mu- decay: AMA=AMMUON, AML=AMELCT,
36370C POL = -1)
36371C
36372C Outputs : kinematic variables in the rest frame of decaying lepton
36373C ETL,PXL,PYL,PZL 4-moment of l
36374C ETB,PXB,PYB,PZB 4-moment of b
36375C ETN,PXN,PYN,PZN 4-moment of anti-nu
36376C
36377C============================================================
36378C +
36379C Declarations.
36380C -
36381 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36382 SAVE
36383
36384 PARAMETER ( LINP = 10 ,
36385 & LOUT = 6 ,
36386 & LDAT = 9 )
36387 PARAMETER ( KALGNM = 2 )
36388 PARAMETER ( ANGLGB = 5.0D-16 )
36389 PARAMETER ( ANGLSQ = 2.5D-31 )
36390 PARAMETER ( AXCSSV = 0.2D+16 )
36391 PARAMETER ( ANDRFL = 1.0D-38 )
36392 PARAMETER ( AVRFLW = 1.0D+38 )
36393 PARAMETER ( AINFNT = 1.0D+30 )
36394 PARAMETER ( AZRZRZ = 1.0D-30 )
36395 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
36396 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
36397 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
36398 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
36399 PARAMETER ( CSNNRM = 2.0D-15 )
36400 PARAMETER ( DMXTRN = 1.0D+08 )
36401 PARAMETER ( ZERZER = 0.D+00 )
36402 PARAMETER ( ONEONE = 1.D+00 )
36403 PARAMETER ( TWOTWO = 2.D+00 )
36404 PARAMETER ( THRTHR = 3.D+00 )
36405 PARAMETER ( FOUFOU = 4.D+00 )
36406 PARAMETER ( FIVFIV = 5.D+00 )
36407 PARAMETER ( SIXSIX = 6.D+00 )
36408 PARAMETER ( SEVSEV = 7.D+00 )
36409 PARAMETER ( EIGEIG = 8.D+00 )
36410 PARAMETER ( ANINEN = 9.D+00 )
36411 PARAMETER ( TENTEN = 10.D+00 )
36412 PARAMETER ( HLFHLF = 0.5D+00 )
36413 PARAMETER ( ONETHI = ONEONE / THRTHR )
36414 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
36415 PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
36416 PARAMETER ( ENEPER = 2.7182818284590452354 D+00 )
36417 PARAMETER ( SQRENT = 1.6487212707001281468 D+00 )
36418 PARAMETER ( CLIGHT = 2.99792458 D+10 )
36419 PARAMETER ( AVOGAD = 6.0221367 D+23 )
36420 PARAMETER ( AMELGR = 9.1093897 D-28 )
36421 PARAMETER ( PLCKBR = 1.05457266 D-27 )
36422 PARAMETER ( ELCCGS = 4.8032068 D-10 )
36423 PARAMETER ( ELCMKS = 1.60217733 D-19 )
36424 PARAMETER ( AMUGRM = 1.6605402 D-24 )
36425 PARAMETER ( AMMUMU = 0.113428913 D+00 )
36426 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
36427 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
36428 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
36429 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
36430 PARAMETER ( PLABRC = 0.197327053 D+00 )
36431 PARAMETER ( AMELCT = 0.51099906 D-03 )
36432 PARAMETER ( AMUGEV = 0.93149432 D+00 )
36433 PARAMETER ( AMMUON = 0.105658389 D+00 )
36434 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
36435 PARAMETER ( GEVMEV = 1.0 D+03 )
36436 PARAMETER ( EMVGEV = 1.0 D-03 )
36437 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
36438 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
36439 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
36440C +
36441C variables for EXPLOD
36442C -
36443 PARAMETER ( KPMX = 10 )
36444 DIMENSION AMEXPL (KPMX), PXEXPL (KPMX), PYEXPL (KPMX),
36445 & PZEXPL (KPMX), ETEXPL (KPMX)
36446C +
36447C test variables
36448C -
36449**sr - removed (not needed)
36450C COMMON /GBATNU/ ELERAT,NTRY
36451**
36452C +
36453C Initializes test variables
36454C -
36455 NTRY = 0
36456 ELERAT = 0.D+00
36457C +
36458C Maximum value for matrix element
36459C -
36460 ELEMAX = ( AMA**2 + AML**2 )**2 / AMA**2 * ( AMA**2 - AML**2 +
36461 & SQRT( AMA**4 + AML**4 - 3.D+00 * AMA**2 * AML**2 ) )
36462C + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
36463C Inputs for EXPLOD
36464C part. no. 1 is l (e- in mu- decay)
36465C part. no. 2 is b (nu-mu in mu- decay)
36466C part. no. 3 is anti-nu (anti-nu-e in mu- decay)
36467C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
36468 NPEXPL = 3
36469 ETOTEX = AMA
36470 AMEXPL(1) = AML
36471 AMEXPL(2) = 0.D+00
36472 AMEXPL(3) = 0.D+00
36473C +
36474C phase space distribution
36475C -
36476 100 CONTINUE
36477 NTRY = NTRY + 1
36478
36479 CALL DT_EXPLOD ( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
36480 & PYEXPL, PZEXPL )
36481
36482C +
36483C Calculates matrix element:
36484C 64*GF**2{[P(a)-ama*S(a)]*P(anti-nu)}{P(l)*P(b)}
36485C Here CTH is the cosine of the angle between anti-nu and Z axis
36486C -
36487 CTH = PZEXPL(3) / SQRT ( PXEXPL(3)**2 + PYEXPL(3)**2 +
36488 & PZEXPL(3)**2 )
36489 PROD1 = ETEXPL(3) * AMA * (1.D+00 - POL * CTH)
36490 PROD2 = ETEXPL(1) * ETEXPL(2) - PXEXPL(1)*PXEXPL(2) -
36491 & PYEXPL(1)*PYEXPL(2) - PZEXPL(1)*PZEXPL(2)
36492 ELEMAT = 16.D+00 * PROD1 * PROD2
36493 IF(ELEMAT.GT.ELEMAX) THEN
36494 WRITE(LOUT,*) 'Problems in LEPDCY',ELEMAX,ELEMAT
36495 STOP
36496 ENDIF
36497C +
36498C Here performs the rejection
36499C -
36500 TEST = DT_RNDM(ETOTEX) * ELEMAX
36501 IF ( TEST .GT. ELEMAT ) GO TO 100
36502C +
36503C final assignment of variables
36504C -
36505 ELERAT = ELEMAT/ELEMAX
36506 ETL = ETEXPL(1)
36507 PXL = PXEXPL(1)
36508 PYL = PYEXPL(1)
36509 PZL = PZEXPL(1)
36510 ETB = ETEXPL(2)
36511 PXB = PXEXPL(2)
36512 PYB = PYEXPL(2)
36513 PZB = PZEXPL(2)
36514 ETN = ETEXPL(3)
36515 PXN = PXEXPL(3)
36516 PYN = PYEXPL(3)
36517 PZN = PZEXPL(3)
36518 999 RETURN
36519 END
36520
36521*$ CREATE DT_GEN_DELTA.FOR
36522*COPY DT_GEN_DELTA
36523C==================================================================
36524C. Generation of Delta resonance events
36525C==================================================================
36526*
36527*===gen_delta==========================================================*
36528*
36529 SUBROUTINE DT_GEN_DELTA(ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25)
36530
36531 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36532 SAVE
36533
36534 PARAMETER ( LINP = 10 ,
36535 & LOUT = 6 ,
36536 & LDAT = 9 )
36537C...Generate a Delta-production neutrino/antineutrino
36538C. CC-interaction on a nucleon
36539C
36540C. INPUT ENU (GeV) = Neutrino Energy
36541C. LLEP = neutrino type
36542C. LTARG = nucleon target type 1=p, 2=n.
36543C. JINT = 1:CC, 2::NC
36544C.
36545C. OUTPUT PPL(4) 4-monentum of final lepton
36546C----------------------------------------------------
36547 PARAMETER (MAXLND=4000)
36548 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
36549**sr - removed (not needed)
36550C COMMON /CBAD/ LBAD, NBAD
36551**
36552
36553 DIMENSION PI(3),PO(3)
36554C REAL*4 AMD0, AMD, AMN(2), AML0(6), AML, AML2, AMDMIN
36555 DIMENSION AML0(6),AMN(2)
36556 DATA AMD0 /1.231/, GAMD /0.12/, DELD/0.169/, AMDMIN/1.084/
36557 DATA AMN /0.93827231, 0.93956563/
36558 DATA AML0 /2*0.51100E-03,2*0.105659, 2*1.777/
36559
36560c WRITE(6,*)' GEN_DEL',ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25
36561 LBAD = 0
36562C...Final lepton mass
36563 IF (JINT.EQ.1) THEN
36564 AML = AML0(LLEP)
36565 ELSE
36566 AML = 0.
36567 ENDIF
36568 AML2 = AML**2
36569
36570C...Particle labels (LUND)
36571 N = 5
36572 K(1,1) = 21
36573 K(2,1) = 21
36574 K(3,1) = 21
36575 K(4,1) = 1
36576 K(3,3) = 1
36577 K(4,3) = 1
36578 IF (LTARG .EQ. 1) THEN
36579 K(2,2) = 2212
36580 ELSE
36581 K(2,2) = 2112
36582 ENDIF
36583 K0 = (LLEP-1)/2
36584 K1 = LLEP/2
36585 KA = 12 + 2*K0
36586 IS = -1 + 2*LLEP - 4*K1
36587 LNU = 2 - LLEP + 2*K1
36588 K(1,2) = IS*KA
36589 K(5,1) = 1
36590 K(5,3) = 2
36591 IF (JINT .EQ. 1) THEN ! CC interactions
36592 K(3,2) = IS*24
36593 K(4,2) = IS*(KA-1)
36594 IF(LNU.EQ.1) THEN
36595 IF (LTARG .EQ. 1) THEN
36596 K(5,2) = 2224
36597 ELSE
36598 K(5,2) = 2214
36599 ENDIF
36600 ELSE
36601 IF (LTARG .EQ. 1) THEN
36602 K(5,2) = 2114
36603 ELSE
36604 K(5,2) = 1114
36605 ENDIF
36606 ENDIF
36607 ELSE
36608 K(3,2) = 23 ! NC (Z0) interactions
36609 K(4,2) = K(1,2)
36610**sr 7.5.00: swop Delta's (bug), Delta+ for proton (LTARG=1),
36611* Delta0 for neutron (LTARG=2)
36612C IF (LTARG .EQ. 1) THEN
36613C K(5,2) = 2114
36614C ELSE
36615C K(5,2) = 2214
36616C ENDIF
36617 IF (LTARG .EQ. 1) THEN
36618 K(5,2) = 2214
36619 ELSE
36620 K(5,2) = 2114
36621 ENDIF
36622**
36623 ENDIF
36624
36625C...4-momentum initial lepton
36626 P(1,5) = 0.
36627 P(1,4) = ENU
36628 P(1,1) = 0.
36629 P(1,2) = 0.
36630 P(1,3) = ENU
36631C...4-momentum initial nucleon
36632 P(2,5) = AMN(LTARG)
36633C P(2,4) = P(2,5)
36634C P(2,1) = 0.
36635C P(2,2) = 0.
36636C P(2,3) = 0.
36637 P(2,1) = P21
36638 P(2,2) = P22
36639 P(2,3) = P23
36640 P(2,4) = P24
36641 P(2,5) = P25
36642 N=2
36643 beta1=-p(2,1)/p(2,4)
36644 beta2=-p(2,2)/p(2,4)
36645 beta3=-p(2,3)/p(2,4)
36646 N=2
36647
36648 CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
36649
36650C print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
36651
36652 phi11=atan(p(1,2)/p(1,3))
36653 pi(1)=p(1,1)
36654 pi(2)=p(1,2)
36655 pi(3)=p(1,3)
36656
36657 CALL DT_TESTROT(PI,Po,PHI11,1)
36658 DO ll=1,3
36659 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36660 END DO
36661 p(1,1)=po(1)
36662 p(1,2)=po(2)
36663 p(1,3)=po(3)
36664 phi12=atan(p(1,1)/p(1,3))
36665
36666 pi(1)=p(1,1)
36667 pi(2)=p(1,2)
36668 pi(3)=p(1,3)
36669 CALL DT_TESTROT(Pi,Po,PHI12,2)
36670 DO ll=1,3
36671 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36672 END DO
36673 p(1,1)=po(1)
36674 p(1,2)=po(2)
36675 p(1,3)=po(3)
36676
36677 ENUU=P(1,4)
36678
36679C...Generate the Mass of the Delta
36680 NTRY = 0
36681100 R = PYR(0)
36682 AMD=AMD0+0.5*GAMD*TAN((2.*R-1.)*ATAN(2.*DELD/GAMD))
36683 NTRY = NTRY + 1
36684 IF (NTRY .GT. 1000) THEN
36685 LBAD = 1
36686 WRITE (LOUT,1001) NBAD, ENUU,AMD,AMDMIN,AMD0,GAMD,ET
36687 RETURN
36688 ENDIF
36689 IF (AMD .LT. AMDMIN) GOTO 100
36690 ET = ((AMD+AML)**2 - AMN(LTARG)**2)/(2.*AMN(LTARG))
36691 IF (ENUU .LT. ET) GOTO 100
36692
36693C...Kinematical limits in Q**2
36694 S = AMN(LTARG)**2 + 2.*AMN(LTARG)*ENUU
36695 SQS = SQRT(S)
36696 PSTAR = (S - AMN(LTARG)**2)/(2.*SQS)
36697 ELF = (S - AMD**2 + AML2)/(2.*SQS)
36698 PLF = SQRT(ELF**2 - AML2)
36699 Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)
36700 Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)
36701 IF (Q2MIN .LT. 0.) Q2MIN = 0.
36702
36703 DSIGMAX = DT_DSIGMA_DELTA(LNU,-Q2MIN, S, AML, AMD)
36704200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
36705 DSIG = DT_DSIGMA_DELTA(LNU,-Q2, S, AML, AMD)
36706 IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200
36707
36708C...Generate the kinematics of the final particles
36709 EISTAR = (S + AMN(LTARG)**2)/(2.*SQS)
36710 GAM = EISTAR/AMN(LTARG)
36711 BET = PSTAR/EISTAR
36712 CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF)
36713 EL = GAM*(ELF + BET*PLF*CTSTAR)
36714 PLZ = GAM*(PLF*CTSTAR + BET*ELF)
36715 PL = SQRT(EL**2 - AML2)
36716 PLT = SQRT(MAX(1.D-06,(PL*PL - PLZ*PLZ)))
36717 PHI = 6.28319*PYR(0)
36718 P(4,1) = PLT*COS(PHI)
36719 P(4,2) = PLT*SIN(PHI)
36720 P(4,3) = PLZ
36721 P(4,4) = EL
36722 P(4,5) = AML
36723
36724C...4-momentum of Delta
36725 P(5,1) = -P(4,1)
36726 P(5,2) = -P(4,2)
36727 P(5,3) = ENUU-P(4,3)
36728 P(5,4) = ENUU+AMN(LTARG)-P(4,4)
36729 P(5,5) = AMD
36730
36731C...4-momentum of intermediate boson
36732 P(3,5) = -Q2
36733 P(3,4) = P(1,4)-P(4,4)
36734 P(3,1) = P(1,1)-P(4,1)
36735 P(3,2) = P(1,2)-P(4,2)
36736 P(3,3) = P(1,3)-P(4,3)
36737 N=5
36738
36739 DO kw=1,5
36740 pi(1)=p(kw,1)
36741 pi(2)=p(kw,2)
36742 pi(3)=p(kw,3)
36743 CALL DT_TESTROT(Pi,Po,PHI12,3)
36744 DO ll=1,3
36745 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36746 END DO
36747 p(kw,1)=po(1)
36748 p(kw,2)=po(2)
36749 p(kw,3)=po(3)
36750 END DO
36751
36752c********************************************
36753
36754 DO kw=1,5
36755 pi(1)=p(kw,1)
36756 pi(2)=p(kw,2)
36757 pi(3)=p(kw,3)
36758 CALL DT_TESTROT(Pi,Po,PHI11,4)
36759 DO ll=1,3
36760 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36761 END DO
36762 p(kw,1)=po(1)
36763 p(kw,2)=po(2)
36764 p(kw,3)=po(3)
36765 END DO
36766c********************************************
36767C transform back into Lab.
36768
36769 CALL PYROBO(0,0,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
36770
36771C WRITE(6,*)' Lab fram ( fermi incl.) '
36772 N=5
36773 CALL PYEXEC
36774
36775 RETURN
367761001 FORMAT(2X, 'DT_GEN_DELTA : event rejected ', I5, 6G10.3)
36777 END
36778
36779*$ CREATE DT_DSIGMA_DELTA.FOR
36780*COPY DT_DSIGMA_DELTA
36781*
36782*===dsigma_delta=======================================================*
36783*
36784 DOUBLE PRECISION FUNCTION DT_DSIGMA_DELTA (LNU, QQ, S, AML, MD)
36785
36786 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36787 SAVE
36788
36789C...Reaction nu + N -> lepton + Delta
36790C. returns the cross section
36791C. dsigma/dt
36792C. INPUT LNU = 1, 2 (neutrino-antineutrino)
36793C. QQ = t (always negative) GeV**2
36794C. S = (c.m energy)**2 GeV**2
36795C. OUTPUT = 10**-38 cm+2/GeV**2
36796C-----------------------------------------------------
36797 REAL*8 MN, MN2, MN4, MD,MD2, MD4
36798 DATA MN /0.938/
36799 DATA PI /3.1415926/
36800
36801 GF = (1.1664 * 1.97)
36802 GF2 = GF*GF
36803 MN2 = MN*MN
36804 MN4 = MN2*MN2
36805 MD2 = MD*MD
36806 MD4 = MD2*MD2
36807 AML2 = AML*AML
36808 AML4 = AML2*AML2
36809 VQ = (MN2 - MD2 - QQ)/2.
36810 VPI = (MN2 + MD2 - QQ)/2.
36811 VK = (S + QQ - MN2 - AML2)/2.
36812 PIK = (S - MN2)/2.
36813 QK = (AML2 - QQ)/2.
36814 PIQ = (QQ + MN2 - MD2)/2.
36815 Q = SQRT(-QQ)
36816 C3V = 2.07*SQRT(EXP(-6.3*Q)*(1.+9*Q))
36817 C3 = SQRT(3.)*C3V/MN
36818 C4 = -C3/MD ! attenzione al segno
36819 C5A = 1.18/(1.-QQ/0.4225)**2
36820 C32 = C3**2
36821 C42 = C4**2
36822 C5A2 = C5A**2
36823
36824 IF (LNU .EQ. 1) THEN
36825 ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
36826 . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
36827 . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
36828 . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
36829 ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
36830 . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
36831 . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
36832 . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
36833 . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
36834 . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ-
36835 . 4.*MN*C3*C5A*MD2*VK*QQ+4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
36836 . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
36837 . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
36838 . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
36839 . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK-MD*
36840 . C3*C5A*MD2*PIK*QQ+MD*C3*C5A*MD2*QK*PIQ-3.*MD*C3*C5A
36841 . *VK*VPI*QQ+MD*C3*C5A*VK*VQ*PIQ+3.*MD*C3*C5A*VPI*VQ*
36842 . QK-MD*C3*C5A*VQ**2*PIK+C4*C5A*MD2*VK*VPI*QQ+C4*C5A*
36843 . MD2*VK*VQ*PIQ-C4*C5A*MD2*VPI*VQ*QK-C4*C5A*MD2*VQ**2
36844 . *PIK-C4*C5A*MD4*PIK*QQ+C4*C5A*MD4*QK*PIQ-2.*MD2*VK
36845 . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
36846 . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
36847 . *C42-2.*MD2*VPI*QK**2*C32+ANS3
36848 ELSE
36849 ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
36850 . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
36851 . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
36852 . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
36853 ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
36854 . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
36855 . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
36856 . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
36857 . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
36858 . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ+
36859 . 4.*MN*C3*C5A*MD2*VK*QQ-4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
36860 . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
36861 . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
36862 . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
36863 . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK+MD*
36864 . C3*C5A*MD2*PIK*QQ-MD*C3*C5A*MD2*QK*PIQ+3.*MD*C3*C5A
36865 . *VK*VPI*QQ-MD*C3*C5A*VK*VQ*PIQ-3.*MD*C3*C5A*VPI*VQ*
36866 . QK+MD*C3*C5A*VQ**2*PIK-C4*C5A*MD2*VK*VPI*QQ-C4*C5A*
36867 . MD2*VK*VQ*PIQ+C4*C5A*MD2*VPI*VQ*QK+C4*C5A*MD2*VQ**2
36868 . *PIK+C4*C5A*MD4*PIK*QQ-C4*C5A*MD4*QK*PIQ-2.*MD2*VK
36869 . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
36870 . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
36871 . *C42-2.*MD2*VPI*QK**2*C32+ANS3
36872 ENDIF
36873 ANS1=32.*ANS2
36874 ANS=ANS1/(3.*MD2)
36875 P1CM = (S-MN2)/(2.*SQRT(S))
36876 DT_DSIGMA_DELTA = GF2/2. * ANS/(64.*PI*S*P1CM**2)
36877
36878 RETURN
36879 END
36880
36881*$ CREATE DT_QGAUS.FOR
36882*COPY DT_QGAUS
36883*
36884*===qgaus==============================================================*
36885*
36886 SUBROUTINE DT_QGAUS(A,B,SS,ENU,LTYP)
36887
36888 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36889 SAVE
36890
36891 DIMENSION X(5),W(5)
36892 DATA X/.1488743389D0,.4333953941D0,
36893 & .6794095682D0,.8650633666D0,.9739065285D0
36894 */
36895 DATA W/.2955242247D0,.2692667193D0,
36896 & .2190863625D0,.1494513491D0,.0666713443D0
36897 */
36898 XM=0.5D0*(B+A)
36899 XR=0.5D0*(B-A)
36900 SS=0
36901 DO 11 J=1,5
36902 DX=XR*X(J)
36903 SS=SS+W(J)*(DT_DSQEL_Q2(LTYP,ENU,XM+DX)+
36904 * DT_DSQEL_Q2(LTYP,ENU,XM-DX))
3690511 CONTINUE
36906 SS=XR*SS
36907
36908 RETURN
36909 END
36910
36911*$ CREATE DT_DIQBRK.FOR
36912*COPY DT_DIQBRK
36913*
36914*===diqbrk=============================================================*
36915*
36916 SUBROUTINE DT_DIQBRK
36917
36918 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36919 SAVE
36920
36921* event history
36922 PARAMETER (NMXHKK=200000)
36923 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36924 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36925 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36926* extended event history
36927 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36928 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36929 & IHIST(2,NMXHKK)
36930* event flag
36931 COMMON /DTEVNO/ NEVENT,ICASCA
36932
36933C IF(DT_RNDM(VV).LE.0.5D0)THEN
36934C CALL GSQBS1(NHKK)
36935C CALL GSQBS2(NHKK)
36936C CALL USQBS1(NHKK)
36937C CALL USQBS2(NHKK)
36938C CALL GSABS1(NHKK)
36939C CALL GSABS2(NHKK)
36940C CALL USABS1(NHKK)
36941C CALL USABS2(NHKK)
36942C ELSE
36943C CALL GSQBS2(NHKK)
36944C CALL GSQBS1(NHKK)
36945C CALL USQBS2(NHKK)
36946C CALL USQBS1(NHKK)
36947C CALL GSABS2(NHKK)
36948C CALL GSABS1(NHKK)
36949C CALL USABS2(NHKK)
36950C CALL USABS1(NHKK)
36951C ENDIF
36952
36953 IF(DT_RNDM(VV).LE.0.5D0) THEN
36954 CALL DT_DBREAK(1)
36955 CALL DT_DBREAK(2)
36956 CALL DT_DBREAK(3)
36957 CALL DT_DBREAK(4)
36958 CALL DT_DBREAK(5)
36959 CALL DT_DBREAK(6)
36960 CALL DT_DBREAK(7)
36961 CALL DT_DBREAK(8)
36962 ELSE
36963 CALL DT_DBREAK(2)
36964 CALL DT_DBREAK(1)
36965 CALL DT_DBREAK(4)
36966 CALL DT_DBREAK(3)
36967 CALL DT_DBREAK(6)
36968 CALL DT_DBREAK(5)
36969 CALL DT_DBREAK(8)
36970 CALL DT_DBREAK(7)
36971 ENDIF
36972
36973 RETURN
36974 END
36975
36976*$ CREATE MUSQBS2.FOR
36977*COPY MUSQBS2
36978C
36979C
36980C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
36981 SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36982 * IP1,IP21,IP22,IPP1,IPP2,IPIP,ISQ,IGCOUN)
36983C
36984C USQBS-2 diagram (split target diquark)
36985C
36986 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36987 SAVE
36988
36989 PARAMETER ( LINP = 10 ,
36990 & LOUT = 6 ,
36991 & LDAT = 9 )
36992* event history
36993 PARAMETER (NMXHKK=200000)
36994 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36995 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36996 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36997* extended event history
36998 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36999 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37000 & IHIST(2,NMXHKK)
37001* Lorentz-parameters of the current interaction
37002 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37003 & UMO,PPCM,EPROJ,PPROJ
37004* diquark-breaking mechanism
37005 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37006
37007C
37008 PARAMETER (NTMHKK= 300)
37009 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37010 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37011 +(4,NTMHKK)
37012*KEEP,XSEADI.
37013 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37014 +SSMIMQ,VVMTHR
37015*KEEP,DPRIN.
37016 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37017 COMMON /EVFLAG/ NUMEV
37018C
37019C USQBS-2 diagram (split target diquark)
37020C
37021C
37022C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
37023C Input chain 2(NC2) sea-antiquark(NC2P)-sea-quark(NC2T)
37024C
37025C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
37026C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37027C
37028C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
37029C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37030C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37031C
37032C
37033C Put new chains into COMMON /HKKTMP/
37034C
37035 IIGLU1=NC1T-NC1P-1
37036 IIGLU2=NC2T-NC2P-1
37037 IGCOUN=0
37038C WRITE(LOUT,*)'MUSQBS2: IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
37039 CVQ=1.D0
37040 IREJ=0
37041 IF(IPIP.EQ.2)THEN
37042C IF(NUMEV.EQ.-324)THEN
37043C WRITE(LOUT,*)' MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37044C * 'IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN)',
37045C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37046C * IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN
37047 ENDIF
37048C
37049C
37050C
37051C determine x-values of NC1T diquark
37052 XDIQT=PHKK(4,NC1T)*2.D0/UMO
37053 XVQP=PHKK(4,NC1P)*2.D0/UMO
37054C
37055C determine x-values of sea quark pair
37056C
37057 IPCO=1
37058 ICOU=0
37059 2234 CONTINUE
37060 ICOU=ICOU+1
37061 IF(ICOU.GE.500)THEN
37062 IREJ=1
37063 IF(ISQ.EQ.3)IREJ=3
37064 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 2234 ICOU. GT.500'
37065 IPCO=0
37066 RETURN
37067 ENDIF
37068 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS2 call XSEAPA: UMO,XDIQT,XVQP ',
37069 * UMO, XDIQT,XVQP
37070 XSQ=0.D0
37071 XSAQ=0.D0
37072**NEW
37073C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37074 IF (IPIP.EQ.1) THEN
37075 XQMAX = XDIQT/2.0D0
37076 XAQMAX = 2.D0*XVQP/3.0D0
37077 ELSE
37078 XQMAX = 2.D0*XVQP/3.0D0
37079 XAQMAX = XDIQT/2.0D0
37080 ENDIF
37081 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37082 ISAQ = 6+ISQ
37083C write(*,*) 'MUSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
37084**
37085 IF(IPCO.GE.3)
37086 & WRITE(LOUT,*)'MUSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37087 IF(IREJ.GE.1)THEN
37088 IF(IPCO.GE.3)
37089 & WRITE(LOUT,*)'MUSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37090 IPCO=0
37091 RETURN
37092 ENDIF
37093 IF(IPIP.EQ.1)THEN
37094 IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37095 ELSEIF(IPIP.EQ.2)THEN
37096 IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37097 ENDIF
37098 IF(IPCO.GE.3)THEN
37099 WRITE(LOUT,'(A,4E12.4)')' MUSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
37100 * XDIQT,XVQP,XSQ,XSAQ
37101 ENDIF
37102C
37103C subtract xsq,xsaq from NC1T diquark and NC1P quark
37104C
37105C XSQ=0.D0
37106 IF(IPIP.EQ.1)THEN
37107 XDIQT=XDIQT-XSQ
37108 XVQP =XVQP -XSAQ
37109 ELSEIF(IPIP.EQ.2)THEN
37110 XDIQT=XDIQT-XSAQ
37111 XVQP =XVQP -XSQ
37112 ENDIF
37113 IF(IPCO.GE.3)
37114 & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
37115C
37116C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37117C
37118 XVTHRO=CVQ/UMO
37119 IVTHR=0
37120 3466 CONTINUE
37121 IF(IVTHR.EQ.10)THEN
37122 IREJ=1
37123 IF(ISQ.EQ.3)IREJ=3
37124 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 3466 reject IVTHR 10'
37125 IPCO=0
37126 RETURN
37127 ENDIF
37128 IVTHR=IVTHR+1
37129 XVTHR=XVTHRO/(201-IVTHR)
37130 UNOPRV=UNON
37131 380 CONTINUE
37132 IF(XVTHR.GT.0.66D0*XDIQT)THEN
37133 IREJ=1
37134 IF(ISQ.EQ.3)IREJ=3
37135 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 380 XVTHR large ',
37136 * XVTHR
37137 IPCO=0
37138 RETURN
37139 ENDIF
37140 IF(DT_RNDM(V).LT.0.5D0)THEN
37141 XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37142 XVTQII=XDIQT-XVTQI
37143 ELSE
37144 XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37145 XVTQI=XDIQT-XVTQII
37146 ENDIF
37147 IF(IPCO.GE.3)THEN
37148 WRITE(LOUT,'(A,2E12.4)')' MUSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
37149 ENDIF
37150C
37151C Prepare 4 momenta of new chains and chain ends
37152C
37153C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37154C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37155C +(4,NTMHKK)
37156C
37157C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
37158C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37159C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37160C
37161C SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37162C * IP1,IP21,IP22,IPP1,IPP2)
37163C
37164 IF(IPIP.EQ.1)THEN
37165 XSQ1=XSQ
37166 XSAQ1=XSAQ
37167 ISQ1=ISQ
37168 ISAQ1=ISAQ
37169 ELSEIF(IPIP.EQ.2)THEN
37170 XSQ1=XSAQ
37171 XSAQ1=XSQ
37172 ISQ1=ISAQ
37173 ISAQ1=ISQ
37174 ENDIF
37175 IDHKT(1) =IPP1
37176 ISTHKT(1) =951
37177 JMOHKT(1,1)=NC2P
37178 JMOHKT(2,1)=0
37179 JDAHKT(1,1)=3+IIGLU1
37180 JDAHKT(2,1)=0
37181C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
37182 PHKT(1,1) =PHKK(1,NC2P)
37183 PHKT(2,1) =PHKK(2,NC2P)
37184 PHKT(3,1) =PHKK(3,NC2P)
37185 PHKT(4,1) =PHKK(4,NC2P)
37186C PHKT(5,1) =PHKK(5,NC2P)
37187 XMIST =(PHKT(4,1)**2-
37188 * PHKT(3,1)**2-PHKT(2,1)**2-
37189 *PHKT(1,1)**2)
37190 IF(XMIST.GT.0.D0)THEN
37191 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
37192 *PHKT(1,1)**2)
37193 ELSE
37194C WRITE(LOUT,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
37195 PHKT(5,1)=0.D0
37196 ENDIF
37197 VHKT(1,1) =VHKK(1,NC2P)
37198 VHKT(2,1) =VHKK(2,NC2P)
37199 VHKT(3,1) =VHKK(3,NC2P)
37200 VHKT(4,1) =VHKK(4,NC2P)
37201 WHKT(1,1) =WHKK(1,NC2P)
37202 WHKT(2,1) =WHKK(2,NC2P)
37203 WHKT(3,1) =WHKK(3,NC2P)
37204 WHKT(4,1) =WHKK(4,NC2P)
37205C Add here IIGLU1 gluons to this chaina
37206 PG1=0.D0
37207 PG2=0.D0
37208 PG3=0.D0
37209 PG4=0.D0
37210 IF(IIGLU1.GE.1)THEN
37211 JJG=NC1P
37212 DO 61 IIG=2,2+IIGLU1-1
37213 KKG=JJG+IIG-1
37214 IDHKT(IIG) =IDHKK(KKG)
37215 ISTHKT(IIG) =921
37216 JMOHKT(1,IIG)=KKG
37217 JMOHKT(2,IIG)=0
37218 JDAHKT(1,IIG)=3+IIGLU1
37219 JDAHKT(2,IIG)=0
37220 PHKT(1,IIG)=PHKK(1,KKG)
37221 PG1=PG1+ PHKT(1,IIG)
37222 PHKT(2,IIG)=PHKK(2,KKG)
37223 PG2=PG2+ PHKT(2,IIG)
37224 PHKT(3,IIG)=PHKK(3,KKG)
37225 PG3=PG3+ PHKT(3,IIG)
37226 PHKT(4,IIG)=PHKK(4,KKG)
37227 PG4=PG4+ PHKT(4,IIG)
37228 PHKT(5,IIG)=PHKK(5,KKG)
37229 VHKT(1,IIG) =VHKK(1,KKG)
37230 VHKT(2,IIG) =VHKK(2,KKG)
37231 VHKT(3,IIG) =VHKK(3,KKG)
37232 VHKT(4,IIG) =VHKK(4,KKG)
37233 WHKT(1,IIG) =WHKK(1,KKG)
37234 WHKT(2,IIG) =WHKK(2,KKG)
37235 WHKT(3,IIG) =WHKK(3,KKG)
37236 WHKT(4,IIG) =WHKK(4,KKG)
37237 61 CONTINUE
37238 ENDIF
37239 IDHKT(2+IIGLU1) =IP21
37240 ISTHKT(2+IIGLU1) =952
37241 JMOHKT(1,2+IIGLU1)=NC1T
37242 JMOHKT(2,2+IIGLU1)=0
37243 JDAHKT(1,2+IIGLU1)=3+IIGLU1
37244 JDAHKT(2,2+IIGLU1)=0
37245 PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
37246 PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
37247 PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
37248 PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
37249C PHKT(5,2) =PHKK(5,NC1T)
37250 XMIST =(PHKT(4,2+IIGLU1)**2-
37251 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37252 *PHKT(1,2+IIGLU1)**2)
37253 IF(XMIST.GT.0.D0)THEN
37254 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
37255 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37256 *PHKT(1,2+IIGLU1)**2)
37257 ELSE
37258C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
37259 PHKT(5,5+IIGLU1)=0.D0
37260 ENDIF
37261 VHKT(1,2+IIGLU1) =VHKK(1,NC1T)
37262 VHKT(2,2+IIGLU1) =VHKK(2,NC1T)
37263 VHKT(3,2+IIGLU1) =VHKK(3,NC1T)
37264 VHKT(4,2+IIGLU1) =VHKK(4,NC1T)
37265 WHKT(1,2+IIGLU1) =WHKK(1,NC1T)
37266 WHKT(2,2+IIGLU1) =WHKK(2,NC1T)
37267 WHKT(3,2+IIGLU1) =WHKK(3,NC1T)
37268 WHKT(4,2+IIGLU1) =WHKK(4,NC1T)
37269 IDHKT(3+IIGLU1) =88888
37270 ISTHKT(3+IIGLU1) =95
37271 JMOHKT(1,3+IIGLU1)=1
37272 JMOHKT(2,3+IIGLU1)=2+IIGLU1
37273 JDAHKT(1,3+IIGLU1)=0
37274 JDAHKT(2,3+IIGLU1)=0
37275 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
37276 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
37277 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
37278 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
37279 XMIST
37280 * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37281 * -PHKT(3,3+IIGLU1)**2)
37282 IF(XMIST.GT.0.D0)THEN
37283 PHKT(5,3+IIGLU1)
37284 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37285 * -PHKT(3,3+IIGLU1)**2)
37286 ELSE
37287C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
37288 PHKT(5,5+IIGLU1)=0.D0
37289 ENDIF
37290 IF(IPIP.GE.2)THEN
37291C IF(NUMEV.EQ.-324)THEN
37292C WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
37293C * JDAHKT(1,1),
37294C *JDAHKT(2,1),(PHKT(III,1),III=1,5)
37295 DO 71 IIG=2,2+IIGLU1-1
37296C WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
37297C & JMOHKT(1,IIG),JMOHKT(2,IIG),
37298C * JDAHKT(1,IIG),
37299C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37300 71 CONTINUE
37301C WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
37302C * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
37303C *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
37304C WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
37305C * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
37306C *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
37307 ENDIF
37308 CHAMAL=CHAM1
37309 IF(IPIP.EQ.1)THEN
37310 IF(IPP1.LE.-3.OR.IP21.GE.3)CHAMAL=CHAM3
37311 ELSEIF(IPIP.EQ.2)THEN
37312 IF(IPP1.GE.3.OR.IP21.LE.-3)CHAMAL=CHAM3
37313 ENDIF
37314 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
37315C IREJ=1
37316 IPCO=0
37317C RETURN
37318C WRITE(LOUT,*)' MUSQBS1 jump back from chain 3'
37319 GO TO 3466
37320 ENDIF
37321 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
37322 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
37323 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
37324 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
37325 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
37326 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
37327 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
37328 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
37329 IF(IPIP.EQ.1)THEN
37330 IDHKT(4+IIGLU1) =-(ISAQ1-6)
37331 ELSEIF(IPIP.EQ.2)THEN
37332 IDHKT(4+IIGLU1) =ISAQ1
37333 ENDIF
37334 ISTHKT(4+IIGLU1) =951
37335 JMOHKT(1,4+IIGLU1)=NC1P
37336 JMOHKT(2,4+IIGLU1)=0
37337 JDAHKT(1,4+IIGLU1)=6+IIGLU1
37338 JDAHKT(2,4+IIGLU1)=0
37339C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37340 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
37341 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
37342 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
37343 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
37344C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
37345 XMIST =(PHKT(4,4+IIGLU1)**2-
37346 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37347 *PHKT(1,4+IIGLU1)**2)
37348 IF(XMIST.GT.0.D0)THEN
37349 PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2-
37350 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37351 *PHKT(1,4+IIGLU1)**2)
37352 ELSE
37353C WRITE(LOUT,*)'MUSQBS2 parton 4 mass square LT.0 ',XMIST
37354 PHKT(5,4+IIGLU1)=0.D0
37355 ENDIF
37356 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
37357 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
37358 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
37359 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
37360 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
37361 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
37362 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
37363 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
37364 IDHKT(5+IIGLU1) =IP22
37365 ISTHKT(5+IIGLU1) =952
37366 JMOHKT(1,5+IIGLU1)=NC1T
37367 JMOHKT(2,5+IIGLU1)=0
37368 JDAHKT(1,5+IIGLU1)=6+IIGLU1
37369 JDAHKT(2,5+IIGLU1)=0
37370 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
37371 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
37372 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
37373 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
37374C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
37375 XMIST =(PHKT(4,5+IIGLU1)**2-
37376 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37377 *PHKT(1,5+IIGLU1)**2)
37378 IF(XMIST.GT.0.D0)THEN
37379 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
37380 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37381 *PHKT(1,5+IIGLU1)**2)
37382 ELSE
37383C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37384 PHKT(5,5+IIGLU1)=0.D0
37385 ENDIF
37386 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
37387 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
37388 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
37389 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
37390 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
37391 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
37392 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
37393 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
37394 IDHKT(6+IIGLU1) =88888
37395 ISTHKT(6+IIGLU1) =95
37396 JMOHKT(1,6+IIGLU1)=4+IIGLU1
37397 JMOHKT(2,6+IIGLU1)=5+IIGLU1
37398 JDAHKT(1,6+IIGLU1)=0
37399 JDAHKT(2,6+IIGLU1)=0
37400 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37401 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37402 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37403 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37404 XMIST
37405 * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37406 * -PHKT(3,6+IIGLU1)**2)
37407 IF(XMIST.GT.0.D0)THEN
37408 PHKT(5,6+IIGLU1)
37409 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37410 * -PHKT(3,6+IIGLU1)**2)
37411 ELSE
37412C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37413 PHKT(5,5+IIGLU1)=0.D0
37414 ENDIF
37415C IF(IPIP.GE.2)THEN
37416C IF(NUMEV.EQ.-324)THEN
37417C WRITE(6,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
37418C * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
37419C *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
37420C WRITE(6,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
37421C * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
37422C *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
37423C WRITE(6,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
37424C * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
37425C *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
37426C ENDIF
37427 CHAMAL=CHAM1
37428 IF(IPIP.EQ.1)THEN
37429 IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
37430 ELSEIF(IPIP.EQ.2)THEN
37431 IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
37432 ENDIF
37433 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37434C IREJ=1
37435 IPCO=0
37436C RETURN
37437C WRITE(6,*)' MUSQBS1 jump back from chain 6',
37438C * CHAMAL,PHKT(5,6+IIGLU1)
37439 GO TO 3466
37440 ENDIF
37441 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
37442 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
37443 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
37444 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
37445 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
37446 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
37447 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
37448 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
37449C IDHKT(7) =1000*IPP1+100*ISQ+1
37450 IDHKT(7+IIGLU1) =IP1
37451 ISTHKT(7+IIGLU1) =951
37452 JMOHKT(1,7+IIGLU1)=NC1P
37453 JMOHKT(2,7+IIGLU1)=0
37454**NEW
37455C JDAHKT(1,7+IIGLU1)=9+IIGLU1
37456 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
37457**
37458 JDAHKT(2,7+IIGLU1)=0
37459 PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
37460 PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
37461 PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
37462 PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
37463C PHKT(5,7+IIGLU1) =PHKK(5,NC1P)
37464 XMIST =(PHKT(4,7+IIGLU1)**2-
37465 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
37466 *PHKT(1,7+IIGLU1)**2)
37467 IF(XMIST.GT.0.D0)THEN
37468 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
37469 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
37470 *PHKT(1,7+IIGLU1)**2)
37471 ELSE
37472C WRITE(6,*)'MUSQBS2 parton 7 mass square LT.0 ',XMIST
37473 PHKT(5,7+IIGLU1)=0.D0
37474 ENDIF
37475 VHKT(1,7+IIGLU1) =VHKK(1,NC1P)
37476 VHKT(2,7+IIGLU1) =VHKK(2,NC1P)
37477 VHKT(3,7+IIGLU1) =VHKK(3,NC1P)
37478 VHKT(4,7+IIGLU1) =VHKK(4,NC1P)
37479 WHKT(1,7+IIGLU1) =WHKK(1,NC1P)
37480 WHKT(2,7+IIGLU1) =WHKK(2,NC1P)
37481 WHKT(3,7+IIGLU1) =WHKK(3,NC1P)
37482 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
37483C Insert here the IIGLU2 gluons
37484 PG1=0.D0
37485 PG2=0.D0
37486 PG3=0.D0
37487 PG4=0.D0
37488 IF(IIGLU2.GE.1)THEN
37489 JJG=NC2P
37490 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37491 KKG=JJG+IIG-7-IIGLU1
37492 IDHKT(IIG) =IDHKK(KKG)
37493 ISTHKT(IIG) =921
37494 JMOHKT(1,IIG)=KKG
37495 JMOHKT(2,IIG)=0
37496 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
37497 JDAHKT(2,IIG)=0
37498 PHKT(1,IIG)=PHKK(1,KKG)
37499 PG1=PG1+ PHKT(1,IIG)
37500 PHKT(2,IIG)=PHKK(2,KKG)
37501 PG2=PG2+ PHKT(2,IIG)
37502 PHKT(3,IIG)=PHKK(3,KKG)
37503 PG3=PG3+ PHKT(3,IIG)
37504 PHKT(4,IIG)=PHKK(4,KKG)
37505 PG4=PG4+ PHKT(4,IIG)
37506 PHKT(5,IIG)=PHKK(5,KKG)
37507 VHKT(1,IIG) =VHKK(1,KKG)
37508 VHKT(2,IIG) =VHKK(2,KKG)
37509 VHKT(3,IIG) =VHKK(3,KKG)
37510 VHKT(4,IIG) =VHKK(4,KKG)
37511 WHKT(1,IIG) =WHKK(1,KKG)
37512 WHKT(2,IIG) =WHKK(2,KKG)
37513 WHKT(3,IIG) =WHKK(3,KKG)
37514 WHKT(4,IIG) =WHKK(4,KKG)
37515 81 CONTINUE
37516 ENDIF
37517 IF(IPIP.EQ.1)THEN
37518 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3
37519 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
37520 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
37521 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
37522 ELSEIF(IPIP.EQ.2)THEN
37523 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3
37524 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
37525 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
37526 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
37527 ENDIF
37528 ISTHKT(8+IIGLU1+IIGLU2) =952
37529 JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
37530 JMOHKT(2,8+IIGLU1+IIGLU2)=0
37531 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
37532 JDAHKT(2,8+IIGLU1+IIGLU2)=0
37533 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC2T)+
37534 * PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
37535 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC2T)+
37536 * PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
37537 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC2T)+
37538 * PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
37539 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC2T)+
37540 * PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
37541C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
37542C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
37543 IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
37544C IREJ=1
37545C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
37546C * ,PHKT(4,8+IIGLU1+IIGLU2), PHKK(4,NC2T),NC2T
37547 IPCO=0
37548C RETURN
37549 GO TO 3466
37550 ENDIF
37551C PHKT(5,8) =PHKK(5,NC2T)
37552 XMIST =(PHKT(4,8+IIGLU1+IIGLU2)**2-
37553 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37554 *PHKT(1,8+IIGLU1+IIGLU2)**2)
37555 IF(XMIST.GT.0.D0)THEN
37556 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
37557 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37558 *PHKT(1,8+IIGLU1+IIGLU2)**2)
37559 ELSE
37560C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37561 PHKT(5,5+IIGLU1)=0.D0
37562 ENDIF
37563 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T)
37564 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T)
37565 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T)
37566 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T)
37567 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T)
37568 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T)
37569 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T)
37570 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T)
37571 IDHKT(9+IIGLU1+IIGLU2) =88888
37572 ISTHKT(9+IIGLU1+IIGLU2) =95
37573 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
37574 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
37575 JDAHKT(1,9+IIGLU1+IIGLU2)=0
37576 JDAHKT(2,9+IIGLU1+IIGLU2)=0
37577**NEW
37578C PHKT(1,9+IIGLU1+IIGLU2)
37579C * =PHKT(1,7+IIGLU1+IIGLU2)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
37580C PHKT(2,9+IIGLU1+IIGLU2)
37581C * =PHKT(2,7+IIGLU1+IIGLU2)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
37582C PHKT(3,9+IIGLU1+IIGLU2)
37583C * =PHKT(3,7+IIGLU1+IIGLU2)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
37584C PHKT(4,9+IIGLU1+IIGLU2)
37585C * =PHKT(4,7+IIGLU1+IIGLU2)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
37586 PHKT(1,9+IIGLU1+IIGLU2)
37587 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
37588 PHKT(2,9+IIGLU1+IIGLU2)
37589 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
37590 PHKT(3,9+IIGLU1+IIGLU2)
37591 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
37592 PHKT(4,9+IIGLU1+IIGLU2)
37593 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
37594**
37595 XMIST
37596 * =(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37597 * -PHKT(2,9+IIGLU1+IIGLU2)**2
37598 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
37599 IF(XMIST.GT.0.D0)THEN
37600 PHKT(5,9+IIGLU1+IIGLU2)
37601 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37602 * -PHKT(2,9+IIGLU1+IIGLU2)**2
37603 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
37604 ELSE
37605C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37606 PHKT(5,5+IIGLU1)=0.D0
37607 ENDIF
37608 IF(IPIP.GE.2)THEN
37609C IF(NUMEV.EQ.-324)THEN
37610C WRITE(6,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
37611C * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
37612C *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
37613C DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37614C WRITE(6,*)IIG,ISTHKT(IIG),IDHKT(IIG),JMOHKT(1,IIG),JMOHKT(2,IIG),
37615C * JDAHKT(1,IIG),
37616C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37617C 91 CONTINUE
37618C WRITE(6,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
37619C * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
37620C *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
37621C *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
37622C WRITE(6,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
37623C * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
37624C *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
37625C *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
37626 ENDIF
37627 CHAMAL=CHAB1
37628 IF(IPIP.EQ.1)THEN
37629 IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
37630 ELSEIF(IPIP.EQ.2)THEN
37631 IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
37632 ENDIF
37633 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
37634C IREJ=1
37635 IPCO=0
37636C RETURN
37637C WRITE(6,*)' MUSQBS1 jump back from chain 9',
37638C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
37639 GO TO 3466
37640 ENDIF
37641 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
37642 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
37643 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
37644 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
37645 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
37646 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
37647 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
37648 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
37649C
37650 IPCO=0
37651 IGCOUN=9+IIGLU1+IIGLU2
37652 RETURN
37653 END
37654
37655*$ CREATE MGSQBS2.FOR
37656*COPY MGSQBS2
37657C
37658C
37659C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
37660 SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37661 * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,ISQ,IGCOUN)
37662C
37663C GSQBS-2 diagram (split target diquark)
37664C
37665 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37666 SAVE
37667
37668 PARAMETER ( LINP = 10 ,
37669 & LOUT = 6 ,
37670 & LDAT = 9 )
37671* event history
37672 PARAMETER (NMXHKK=200000)
37673 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
37674 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
37675 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
37676* extended event history
37677 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
37678 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37679 & IHIST(2,NMXHKK)
37680* Lorentz-parameters of the current interaction
37681 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37682 & UMO,PPCM,EPROJ,PPROJ
37683* diquark-breaking mechanism
37684 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37685
37686C
37687 PARAMETER (NTMHKK= 300)
37688 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37689 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37690 +(4,NTMHKK)
37691
37692*KEEP,XSEADI.
37693 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37694 +SSMIMQ,VVMTHR
37695*KEEP,DPRIN.
37696 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37697C
37698C GSQBS-2 diagram (split target diquark)
37699C
37700C
37701C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
37702C Input chain 2(NC2) valence-diquark(NC2P)-sea-quark(NC2T)
37703C
37704C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
37705C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37706C
37707C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
37708C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37709C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37710C
37711C
37712C
37713C Put new chains into COMMON /HKKTMP/
37714C
37715 IIGLU1=NC1T-NC1P-1
37716 IIGLU2=NC2T-NC2P-1
37717 IGCOUN=0
37718C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
37719 CVQ=1.D0
37720 IREJ=0
37721C IF(IPIP.EQ.2)THEN
37722C WRITE(6,*)' MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37723C * 'IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN)',
37724C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37725C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN
37726C ENDIF
37727C
37728C
37729C
37730C determine x-values of NC1T diquark
37731 XDIQT=PHKK(4,NC1T)*2.D0/UMO
37732 XVQP=PHKK(4,NC1P)*2.D0/UMO
37733C
37734C determine x-values of sea quark pair
37735C
37736 IPCO=1
37737 ICOU=0
37738 2234 CONTINUE
37739 ICOU=ICOU+1
37740 IF(ICOU.GE.500)THEN
37741 IREJ=1
37742 IF(ISQ.EQ.3)IREJ=3
37743 IF(IPCO.GE.3)
37744 & WRITE(LOUT,*)' MGSQBS2 Rejection 2234 ICOU. GT.500'
37745 IPCO=0
37746 RETURN
37747 ENDIF
37748 IF(IPCO.GE.3)
37749 & WRITE(LOUT,*)'MGSQBS2 call XSEAPA: UMO,XDIQT,XVQP ',
37750 * UMO, XDIQT,XVQP
37751 XSQ=0.D0
37752 XSAQ=0.D0
37753**NEW
37754C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37755 IF (IPIP.EQ.1) THEN
37756 XQMAX = XDIQT/2.0D0
37757 XAQMAX = 2.D0*XVQP/3.0D0
37758 ELSE
37759 XQMAX = 2.D0*XVQP/3.0D0
37760 XAQMAX = XDIQT/2.0D0
37761 ENDIF
37762 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37763 ISAQ = 6+ISQ
37764C write(*,*) 'MGSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
37765**
37766 IF(IPCO.GE.3)
37767 & WRITE(LOUT,*)'MGSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37768 IF(IREJ.GE.1)THEN
37769 IF(IPCO.GE.3)
37770 & WRITE(LOUT,*)'MGSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37771 IPCO=0
37772 RETURN
37773 ENDIF
37774 IF(IPIP.EQ.1)THEN
37775 IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37776 ELSEIF(IPIP.EQ.2)THEN
37777 IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37778 ENDIF
37779 IF(IPCO.GE.3)THEN
37780 WRITE(LOUT,'(A,4E12.4)')' MGSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
37781 * XDIQT,XVQP,XSQ,XSAQ
37782 ENDIF
37783C
37784C subtract xsq,xsaq from NC1T diquark and NC1P quark
37785C
37786C XSQ=0.D0
37787 IF(IPIP.EQ.1)THEN
37788 XDIQT=XDIQT-XSQ
37789 XVQP =XVQP -XSAQ
37790 ELSEIF(IPIP.EQ.2)THEN
37791 XDIQT=XDIQT-XSAQ
37792 XVQP =XVQP -XSQ
37793 ENDIF
37794 IF(IPCO.GE.3)
37795 & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
37796C
37797C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37798C
37799 XVTHRO=CVQ/UMO
37800 IVTHR=0
37801 3466 CONTINUE
37802 IF(IVTHR.EQ.10)THEN
37803 IREJ=1
37804 IF(ISQ.EQ.3)IREJ=3
37805 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 3466 reject IVTHR 10'
37806 IPCO=0
37807 RETURN
37808 ENDIF
37809 IVTHR=IVTHR+1
37810 XVTHR=XVTHRO/(201-IVTHR)
37811 UNOPRV=UNON
37812 380 CONTINUE
37813 IF(XVTHR.GT.0.66D0*XDIQT)THEN
37814 IREJ=1
37815 IF(ISQ.EQ.3)IREJ=3
37816 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 Rejection 380 XVTHR large ',
37817 * XVTHR
37818 IPCO=0
37819 RETURN
37820 ENDIF
37821 IF(DT_RNDM(V).LT.0.5D0)THEN
37822 XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37823 XVTQII=XDIQT-XVTQI
37824 ELSE
37825 XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37826 XVTQI=XDIQT-XVTQII
37827 ENDIF
37828 IF(IPCO.GE.3)THEN
37829 WRITE(LOUT,'(A,2E12.4)')' MGSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
37830 ENDIF
37831C
37832C Prepare 4 momenta of new chains and chain ends
37833C
37834C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37835C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37836C +(4,NTMHKK)
37837C
37838C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
37839C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37840C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37841C
37842C SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37843C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IGCOUN)
37844C
37845 IF(IPIP.EQ.1)THEN
37846 XSQ1=XSQ
37847 XSAQ1=XSAQ
37848 ISQ1=ISQ
37849 ISAQ1=ISAQ
37850 ELSEIF(IPIP.EQ.2)THEN
37851 XSQ1=XSAQ
37852 XSAQ1=XSQ
37853 ISQ1=ISAQ
37854 ISAQ1=ISQ
37855 ENDIF
37856 KK11=IP21
37857C IDHKT(1) =1000*IPP11+100*IPP12+1
37858 KK21=IPP11
37859 KK22=IPP12
37860 XGIVE=0.D0
37861 IF(IPIP.EQ.1)THEN
37862 IDHKT(4+IIGLU1) =-(ISAQ1-6)
37863 ELSEIF(IPIP.EQ.2)THEN
37864 IDHKT(4+IIGLU1) =ISAQ1
37865 ENDIF
37866 ISTHKT(4+IIGLU1) =961
37867 JMOHKT(1,4+IIGLU1)=NC1P
37868 JMOHKT(2,4+IIGLU1)=0
37869 JDAHKT(1,4+IIGLU1)=6+IIGLU1
37870 JDAHKT(2,4+IIGLU1)=0
37871C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37872 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
37873 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
37874 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
37875 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
37876C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
37877 XXMIST=(PHKT(4,4+IIGLU1)**2-
37878 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37879 *PHKT(1,4+IIGLU1)**2)
37880 IF(XXMIST.GT.0.D0)THEN
37881 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
37882 ELSE
37883 WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
37884 XXMIST=ABS(XXMIST)
37885 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
37886 ENDIF
37887 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
37888 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
37889 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
37890 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
37891 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
37892 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
37893 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
37894 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
37895 IDHKT(5+IIGLU1) =IP22
37896 ISTHKT(5+IIGLU1) =962
37897 JMOHKT(1,5+IIGLU1)=NC1T
37898 JMOHKT(2,5+IIGLU1)=0
37899 JDAHKT(1,5+IIGLU1)=6+IIGLU1
37900 JDAHKT(2,5+IIGLU1)=0
37901 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
37902 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
37903 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
37904 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
37905C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
37906 XXMIST=(PHKT(4,5+IIGLU1)**2-
37907 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37908 *PHKT(1,5+IIGLU1)**2)
37909 IF(XXMIST.GT.0.D0)THEN
37910 PHKT(5,5+IIGLU1) =SQRT(XXMIST)
37911 ELSE
37912 WRITE(LOUT,*)' MGSQBS2 XXMIST', XXMIST
37913 XXMIST=ABS(XXMIST)
37914 PHKT(5,5+IIGLU1) =SQRT(XXMIST)
37915 ENDIF
37916 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
37917 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
37918 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
37919 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
37920 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
37921 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
37922 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
37923 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
37924 IDHKT(6+IIGLU1) =88888
37925 ISTHKT(6+IIGLU1) =96
37926 JMOHKT(1,6+IIGLU1)=4+IIGLU1
37927 JMOHKT(2,6+IIGLU1)=5+IIGLU1
37928 JDAHKT(1,6+IIGLU1)=0
37929 JDAHKT(2,6+IIGLU1)=0
37930 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37931 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37932 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37933 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37934 PHKT(5,6+IIGLU1)
37935 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37936 * -PHKT(3,6+IIGLU1)**2)
37937 CHAMAL=CHAM1
37938 IF(IPIP.EQ.1)THEN
37939 IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
37940 ELSEIF(IPIP.EQ.2)THEN
37941 IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
37942 ENDIF
37943C---------------------------------------------------
37944 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37945 IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
37946C we drop chain 6 and give the energy to chain 3
37947 IDHKT(6+IIGLU1)=22888
37948 XGIVE=1.D0
37949C WRITE(6,*)' drop chain 6 xgive=1'
37950 GO TO 7788
37951 ELSEIF(IDHKT(4+IIGLU1).EQ.-IP21)THEN
37952C we drop chain 6 and give the energy to chain 3
37953C and change KK11 to IDHKT(5)
37954 IDHKT(6+IIGLU1)=22888
37955 XGIVE=1.D0
37956C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(5)'
37957 KK11=IDHKT(5+IIGLU1)
37958 GO TO 7788
37959 ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP11)THEN
37960C we drop chain 6 and give the energy to chain 3
37961C and change KK21 to IDHKT(5+IIGLU1)
37962C IDHKT(1) =1000*IPP11+100*IPP12+1
37963 IDHKT(6+IIGLU1)=22888
37964 XGIVE=1.D0
37965C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(5+IIGLU1)'
37966 KK21=IDHKT(5+IIGLU1)
37967 GO TO 7788
37968 ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP12)THEN
37969C we drop chain 6 and give the energy to chain 3
37970C and change KK22 to IDHKT(5)
37971C IDHKT(1) =1000*IPP11+100*IPP12+1
37972 IDHKT(6+IIGLU1)=22888
37973 XGIVE=1.D0
37974C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(5+IIGLU1)'
37975 KK22=IDHKT(5+IIGLU1)
37976 GO TO 7788
37977 ENDIF
37978C IREJ=1
37979 IPCO=0
37980C RETURN
37981 GO TO 3466
37982 ENDIF
37983 7788 CONTINUE
37984C---------------------------------------------------
37985 IF(IPIP.GE.3)THEN
37986 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
37987 * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
37988 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
37989 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
37990 * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
37991 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
37992 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
37993 * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
37994 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
37995 ENDIF
37996 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
37997 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
37998 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
37999 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
38000 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
38001 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
38002 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
38003 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
38004C IDHKT(1) =1000*IPP11+100*IPP12+1
38005 IF(IPIP.EQ.1)THEN
38006 IDHKT(1) =1000*KK21+100*KK22+3
38007 IF(IDHKT(1).EQ.1203)IDHKT(1)=2103
38008 IF(IDHKT(1).EQ.1303)IDHKT(1)=3103
38009 IF(IDHKT(1).EQ.2303)IDHKT(1)=3203
38010 ELSEIF(IPIP.EQ.2)THEN
38011 IDHKT(1) =1000*KK21+100*KK22-3
38012 IF(IDHKT(1).EQ.-1203)IDHKT(1)=-2103
38013 IF(IDHKT(1).EQ.-1303)IDHKT(1)=-3103
38014 IF(IDHKT(1).EQ.-2303)IDHKT(1)=-3203
38015 ENDIF
38016 ISTHKT(1) =961
38017 JMOHKT(1,1)=NC2P
38018 JMOHKT(2,1)=0
38019 JDAHKT(1,1)=3+IIGLU1
38020 JDAHKT(2,1)=0
38021C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
38022 PHKT(1,1) =PHKK(1,NC2P)
38023 *+XGIVE*PHKT(1,4+IIGLU1)
38024 PHKT(2,1) =PHKK(2,NC2P)
38025 *+XGIVE*PHKT(2,4+IIGLU1)
38026 PHKT(3,1) =PHKK(3,NC2P)
38027 *+XGIVE*PHKT(3,4+IIGLU1)
38028 PHKT(4,1) =PHKK(4,NC2P)
38029 *+XGIVE*PHKT(4,4+IIGLU1)
38030C PHKT(5,1) =PHKK(5,NC2P)
38031 XXMIST=PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38032 *PHKT(1,1)**2
38033 IF(XXMIST.GT.0.D0)THEN
38034 PHKT(5,1) =SQRT(XXMIST)
38035 ELSE
38036 WRITE(LOUT,*)'MGSQBS2',XXMIST
38037 XXMIST=ABS(XXMIST)
38038 PHKT(5,1) =SQRT(XXMIST)
38039 ENDIF
38040 VHKT(1,1) =VHKK(1,NC2P)
38041 VHKT(2,1) =VHKK(2,NC2P)
38042 VHKT(3,1) =VHKK(3,NC2P)
38043 VHKT(4,1) =VHKK(4,NC2P)
38044 WHKT(1,1) =WHKK(1,NC2P)
38045 WHKT(2,1) =WHKK(2,NC2P)
38046 WHKT(3,1) =WHKK(3,NC2P)
38047 WHKT(4,1) =WHKK(4,NC2P)
38048C Add here IIGLU1 gluons to this chaina
38049 PG1=0.D0
38050 PG2=0.D0
38051 PG3=0.D0
38052 PG4=0.D0
38053 IF(IIGLU1.GE.1)THEN
38054 JJG=NC1P
38055 DO 61 IIG=2,2+IIGLU1-1
38056 KKG=JJG+IIG-1
38057 IDHKT(IIG) =IDHKK(KKG)
38058 ISTHKT(IIG) =921
38059 JMOHKT(1,IIG)=KKG
38060 JMOHKT(2,IIG)=0
38061 JDAHKT(1,IIG)=3+IIGLU1
38062 JDAHKT(2,IIG)=0
38063 PHKT(1,IIG)=PHKK(1,KKG)
38064 PG1=PG1+ PHKT(1,IIG)
38065 PHKT(2,IIG)=PHKK(2,KKG)
38066 PG2=PG2+ PHKT(2,IIG)
38067 PHKT(3,IIG)=PHKK(3,KKG)
38068 PG3=PG3+ PHKT(3,IIG)
38069 PHKT(4,IIG)=PHKK(4,KKG)
38070 PG4=PG4+ PHKT(4,IIG)
38071 PHKT(5,IIG)=PHKK(5,KKG)
38072 VHKT(1,IIG) =VHKK(1,KKG)
38073 VHKT(2,IIG) =VHKK(2,KKG)
38074 VHKT(3,IIG) =VHKK(3,KKG)
38075 VHKT(4,IIG) =VHKK(4,KKG)
38076 WHKT(1,IIG) =WHKK(1,KKG)
38077 WHKT(2,IIG) =WHKK(2,KKG)
38078 WHKT(3,IIG) =WHKK(3,KKG)
38079 WHKT(4,IIG) =WHKK(4,KKG)
38080 61 CONTINUE
38081 ENDIF
38082C IDHKT(2) =IP21
38083 IDHKT(2+IIGLU1) =KK11
38084 ISTHKT(2+IIGLU1) =962
38085 JMOHKT(1,2+IIGLU1)=NC1T
38086 JMOHKT(2,2+IIGLU1)=0
38087 JDAHKT(1,2+IIGLU1)=3+IIGLU1
38088 JDAHKT(2,2+IIGLU1)=0
38089 PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
38090C * +0.5D0*PHKK(1,NC2T)
38091 *+XGIVE*PHKT(1,5+IIGLU1)
38092 PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
38093C *+0.5D0*PHKK(2,NC2T)
38094 *+XGIVE*PHKT(2,5+IIGLU1)
38095 PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
38096C *+0.5D0*PHKK(3,NC2T)
38097 *+XGIVE*PHKT(3,5+IIGLU1)
38098 PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
38099C *+0.5D0*PHKK(4,NC2T)
38100 *+XGIVE*PHKT(4,5+IIGLU1)
38101C PHKT(5,2) =PHKK(5,NC1T)
38102 XXMIST=(PHKT(4,2+IIGLU1)**2-
38103 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38104 *PHKT(1,2+IIGLU1)**2)
38105 IF(XXMIST.GT.0.D0)THEN
38106 PHKT(5,2+IIGLU1) =SQRT(XXMIST)
38107 ELSE
38108 WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
38109 XXMIST=ABS(XXMIST)
38110 PHKT(5,2+IIGLU1) =SQRT(XXMIST)
38111 ENDIF
38112 VHKT(1,2+IIGLU1) =VHKK(1,NC1T)
38113 VHKT(2,2+IIGLU1) =VHKK(2,NC1T)
38114 VHKT(3,2+IIGLU1) =VHKK(3,NC1T)
38115 VHKT(4,2+IIGLU1) =VHKK(4,NC1T)
38116 WHKT(1,2+IIGLU1) =WHKK(1,NC1T)
38117 WHKT(2,2+IIGLU1) =WHKK(2,NC1T)
38118 WHKT(3,2+IIGLU1) =WHKK(3,NC1T)
38119 WHKT(4,2+IIGLU1) =WHKK(4,NC1T)
38120 IDHKT(3+IIGLU1) =88888
38121 ISTHKT(3+IIGLU1) =96
38122 JMOHKT(1,3+IIGLU1)=1
38123 JMOHKT(2,3+IIGLU1)=2+IIGLU1
38124 JDAHKT(1,3+IIGLU1)=0
38125 JDAHKT(2,3+IIGLU1)=0
38126 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
38127 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
38128 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
38129 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
38130 PHKT(5,3+IIGLU1)
38131 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38132 * -PHKT(3,3+IIGLU1)**2)
38133 IF(IPIP.EQ.3)THEN
38134 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
38135 * JDAHKT(1,1),
38136 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
38137 DO 71 IIG=2,2+IIGLU1-1
38138 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38139 & JMOHKT(1,IIG),JMOHKT(2,IIG),
38140 * JDAHKT(1,IIG),
38141 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38142 71 CONTINUE
38143 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
38144 * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
38145 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
38146 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
38147 * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
38148 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
38149 ENDIF
38150 CHAMAL=CHAB1
38151 IF(IPIP.EQ.1)THEN
38152 IF(IPP11.GE.3.OR.IPP12.GE.3.OR.IP21.GE.3)CHAMAL=CHAB3
38153 ELSEIF(IPIP.EQ.2)THEN
38154 IF(IPP11.LE.-3.OR.IPP12.LE.-3.OR.IP21.LE.-3)CHAMAL=CHAB3
38155 ENDIF
38156 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
38157C IREJ=1
38158 IPCO=0
38159C RETURN
38160 GO TO 3466
38161 ENDIF
38162 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
38163 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
38164 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
38165 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
38166 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
38167 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
38168 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
38169 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
38170C IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+1
38171 IDHKT(7+IIGLU1) =IP1
38172 ISTHKT(7+IIGLU1) =961
38173 JMOHKT(1,7+IIGLU1)=NC1P
38174 JMOHKT(2,7+IIGLU1)=0
38175 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
38176 JDAHKT(2,7+IIGLU1)=0
38177 PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
38178 PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
38179 PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
38180 PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
38181C PHKT(5,7+IIGLU1) =PHKK(5,NC1P)
38182 XXMIST=(PHKT(4,7+IIGLU1)**2-
38183 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
38184 *PHKT(1,7+IIGLU1)**2)
38185 IF(XXMIST.GT.0.D0)THEN
38186 PHKT(5,7+IIGLU1) =SQRT(XXMIST)
38187 ELSE
38188 WRITE(LOUT,*)' MGSQBS2, XXMIST',XXMIST
38189 XXMIST=ABS(XXMIST)
38190 PHKT(5,7+IIGLU1) =SQRT(XXMIST)
38191 ENDIF
38192 VHKT(1,7+IIGLU1) =VHKK(1,NC1P)
38193 VHKT(2,7+IIGLU1) =VHKK(2,NC1P)
38194 VHKT(3,7+IIGLU1) =VHKK(3,NC1P)
38195 VHKT(4,7+IIGLU1) =VHKK(4,NC1P)
38196 WHKT(1,7+IIGLU1) =WHKK(1,NC1P)
38197 WHKT(2,7+IIGLU1) =WHKK(2,NC1P)
38198 WHKT(3,7+IIGLU1) =WHKK(3,NC1P)
38199 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
38200C IDHKT(7) =1000*IPP1+100*ISQ+1
38201C Insert here the IIGLU2 gluons
38202 PG1=0.D0
38203 PG2=0.D0
38204 PG3=0.D0
38205 PG4=0.D0
38206 IF(IIGLU2.GE.1)THEN
38207 JJG=NC2P
38208 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38209 KKG=JJG+IIG-7-IIGLU1
38210 IDHKT(IIG) =IDHKK(KKG)
38211 ISTHKT(IIG) =921
38212 JMOHKT(1,IIG)=KKG
38213 JMOHKT(2,IIG)=0
38214 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
38215 JDAHKT(2,IIG)=0
38216 PHKT(1,IIG)=PHKK(1,KKG)
38217 PG1=PG1+ PHKT(1,IIG)
38218 PHKT(2,IIG)=PHKK(2,KKG)
38219 PG2=PG2+ PHKT(2,IIG)
38220 PHKT(3,IIG)=PHKK(3,KKG)
38221 PG3=PG3+ PHKT(3,IIG)
38222 PHKT(4,IIG)=PHKK(4,KKG)
38223 PG4=PG4+ PHKT(4,IIG)
38224 PHKT(5,IIG)=PHKK(5,KKG)
38225 VHKT(1,IIG) =VHKK(1,KKG)
38226 VHKT(2,IIG) =VHKK(2,KKG)
38227 VHKT(3,IIG) =VHKK(3,KKG)
38228 VHKT(4,IIG) =VHKK(4,KKG)
38229 WHKT(1,IIG) =WHKK(1,KKG)
38230 WHKT(2,IIG) =WHKK(2,KKG)
38231 WHKT(3,IIG) =WHKK(3,KKG)
38232 WHKT(4,IIG) =WHKK(4,KKG)
38233 81 CONTINUE
38234 ENDIF
38235 IF(IPIP.EQ.1)THEN
38236 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3
38237 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
38238 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
38239 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
38240 ELSEIF(IPIP.EQ.2)THEN
38241**NEW
38242C IDHKT(8) =1000*IPP2+100*(-ISQ1+6)-3
38243 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3
38244**
38245 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
38246 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
38247 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
38248 ENDIF
38249 ISTHKT(8+IIGLU1+IIGLU2) =962
38250 JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
38251 JMOHKT(2,8+IIGLU1+IIGLU2)=0
38252 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
38253 JDAHKT(2,8+IIGLU1+IIGLU2)=0
38254C PHKT(1,8) =0.5D0*PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ/(XDIQT+XSQ)
38255C PHKT(2,8) =0.5D0*PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ/(XDIQT+XSQ)
38256C PHKT(3,8) =0.5D0*PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ/(XDIQT+XSQ)
38257C PHKT(4,8) =0.5D0*PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ/(XDIQT+XSQ)
38258 PHKT(1,8+IIGLU1+IIGLU2) =
38259 * PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
38260 PHKT(2,8+IIGLU1+IIGLU2) =
38261 * PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
38262 PHKT(3,8+IIGLU1+IIGLU2) =
38263 * PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
38264 PHKT(4,8+IIGLU1+IIGLU2) =
38265 * PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
38266C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
38267C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
38268 IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
38269C IREJ=1
38270C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
38271 IPCO=0
38272C RETURN
38273 GO TO 3466
38274 ENDIF
38275C PHKT(5,8) =PHKK(5,NC2T)
38276 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
38277 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38278 *PHKT(1,8+IIGLU1+IIGLU2)**2)
38279 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T)
38280 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T)
38281 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T)
38282 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T)
38283 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T)
38284 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T)
38285 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T)
38286 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T)
38287 IDHKT(9+IIGLU1+IIGLU2) =88888
38288 ISTHKT(9+IIGLU1+IIGLU2) =96
38289 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
38290 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
38291 JDAHKT(1,9+IIGLU1+IIGLU2)=0
38292 JDAHKT(2,9+IIGLU1+IIGLU2)=0
38293 PHKT(1,9+IIGLU1+IIGLU2)
38294 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
38295 PHKT(2,9+IIGLU1+IIGLU2)
38296 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
38297 PHKT(3,9+IIGLU1+IIGLU2)
38298 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
38299 PHKT(4,9+IIGLU1+IIGLU2)
38300 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
38301 PHKT(5,9+IIGLU1+IIGLU2)
38302 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
38303 * PHKT(2,9+IIGLU1+IIGLU2)**2
38304 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
38305 IF(IPIP.GE.3)THEN
38306 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
38307 * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
38308 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
38309 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38310 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38311 & JMOHKT(1,IIG),JMOHKT(2,IIG),
38312 * JDAHKT(1,IIG),
38313 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38314 91 CONTINUE
38315 WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
38316 * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
38317 *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
38318 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
38319 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
38320 * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
38321 *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
38322 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
38323 ENDIF
38324 CHAMAL=CHAB1
38325 IF(IPIP.EQ.1)THEN
38326 IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
38327 ELSEIF(IPIP.EQ.2)THEN
38328 IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
38329 ENDIF
38330 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
38331C IREJ=1
38332 IPCO=0
38333C RETURN
38334 GO TO 3466
38335 ENDIF
38336 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
38337 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
38338 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
38339 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
38340 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
38341 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
38342 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
38343 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
38344C
38345 IPCO=0
38346 IGCOUN=9+IIGLU1+IIGLU2
38347 RETURN
38348 END
38349
38350*$ CREATE MUSQBS1.FOR
38351*COPY MUSQBS1
38352C
38353C
38354C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
38355 SUBROUTINE MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
38356 * IP11,IP12,IP2,IPP1,IPP2,IPIP,ISQ,IGCOUN)
38357C
38358C USQBS-1 diagram (split projectile diquark)
38359C
38360 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38361 SAVE
38362
38363 PARAMETER ( LINP = 10 ,
38364 & LOUT = 6 ,
38365 & LDAT = 9 )
38366* event history
38367 PARAMETER (NMXHKK=200000)
38368 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38369 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38370 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38371* extended event history
38372 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38373 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38374 & IHIST(2,NMXHKK)
38375* Lorentz-parameters of the current interaction
38376 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
38377 & UMO,PPCM,EPROJ,PPROJ
38378* diquark-breaking mechanism
38379 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
38380
38381C
38382 PARAMETER (NTMHKK= 300)
38383 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38384 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38385 +(4,NTMHKK)
38386*KEEP,XSEADI.
38387 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
38388 +SSMIMQ,VVMTHR
38389*KEEP,DPRIN.
38390 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
38391 COMMON /EVFLAG/ NUMEV
38392C
38393C USQBS-1 diagram (split projectile diquark)
38394C
38395C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
38396C Input chain 2(NC2) sea-quark(NC2P)-sea-antiquark(NC2T)
38397C
38398C Create quark(qsP)-antiquark(aqsT) pair, energy from NC1P and NC1T
38399C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
38400C
38401C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
38402C 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
38403C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
38404C
38405C Put new chains into COMMON /HKKTMP/
38406C
38407 IIGLU1=NC1T-NC1P-1
38408 IIGLU2=NC2T-NC2P-1
38409 IGCOUN=0
38410C WRITE(6,*)'MUSQBS1: IIGLU1,IIGLU2,IPIP ',IIGLU1,IIGLU2,IPIP
38411 CVQ=1.D0
38412 IREJ=0
38413 IF(IPIP.EQ.3)THEN
38414C IF(NUMEV.EQ.-324)THEN
38415 WRITE(LOUT,*)' MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
38416 * ' IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN)',
38417 *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
38418 * IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN
38419 ENDIF
38420C
38421C
38422C
38423C determine x-values of NC1P diquark
38424 XDIQP=PHKK(4,NC1P)*2.D0/UMO
38425 XVQT=PHKK(4,NC1T)*2.D0/UMO
38426C
38427C determine x-values of sea quark pair
38428C
38429 IPCO=1
38430 ICOU=0
38431 2234 CONTINUE
38432 ICOU=ICOU+1
38433 IF(ICOU.GE.500)THEN
38434 IREJ=1
38435 IF(ISQ.EQ.3)IREJ=3
38436 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 2234 ICOU. GT.100'
38437 IPCO=0
38438 RETURN
38439 ENDIF
38440 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 call XSEAPA: UMO,XDIQP,XVQT ',
38441 * UMO, XDIQP,XVQT
38442 XSQ=0.D0
38443 XSAQ=0.D0
38444**NEW
38445C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
38446 IF (IPIP.EQ.1) THEN
38447 XQMAX = XDIQP/2.0D0
38448 XAQMAX = 2.D0*XVQT/3.0D0
38449 ELSE
38450 XQMAX = 2.D0*XVQT/3.0D0
38451 XAQMAX = XDIQP/2.0D0
38452 ENDIF
38453 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
38454 ISAQ = 6+ISQ
38455C write(*,*) 'MUSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
38456**
38457 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
38458 IF(IREJ.GE.1)THEN
38459 IF(IPCO.GE.3)
38460 & WRITE(LOUT,*)'MUSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
38461 IPCO=0
38462 RETURN
38463 ENDIF
38464 IF(IPIP.EQ.1)THEN
38465 IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
38466 ELSEIF(IPIP.EQ.2)THEN
38467 IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
38468 ENDIF
38469 IF(IPCO.GE.3)THEN
38470 WRITE(LOUT,'(A,4E12.4)')' MUSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
38471 * XDIQP,XVQT,XSQ,XSAQ
38472 ENDIF
38473C
38474C subtract xsq,xsaq from NC1P diquark and NC1T quark
38475C
38476C XSQ=0.D0
38477 IF(IPIP.EQ.1)THEN
38478 XDIQP=XDIQP-XSQ
38479 XVQT =XVQT -XSAQ
38480 ELSEIF(IPIP.EQ.2)THEN
38481 XDIQP=XDIQP-XSAQ
38482 XVQT =XVQT -XSQ
38483 ENDIF
38484 IF(IPCO.GE.3)
38485 & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
38486C
38487C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
38488C
38489 XVTHRO=CVQ/UMO
38490 IVTHR=0
38491 3466 CONTINUE
38492 IF(IVTHR.EQ.10)THEN
38493 IREJ=1
38494 IF(ISQ.EQ.3)IREJ=3
38495 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 3466 reject IVTHR 10'
38496 IPCO=0
38497 RETURN
38498 ENDIF
38499 IVTHR=IVTHR+1
38500 XVTHR=XVTHRO/(201-IVTHR)
38501 UNOPRV=UNON
38502 380 CONTINUE
38503 IF(XVTHR.GT.0.66D0*XDIQP)THEN
38504 IREJ=1
38505 IF(ISQ.EQ.3)IREJ=3
38506 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 380 XVTHR large ',
38507 * XVTHR
38508 IPCO=0
38509 RETURN
38510 ENDIF
38511 IF(DT_RNDM(V).LT.0.5D0)THEN
38512 XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
38513 XVPQII=XDIQP-XVPQI
38514 ELSE
38515 XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
38516 XVPQI=XDIQP-XVPQII
38517 ENDIF
38518 IF(IPCO.GE.3)THEN
38519 WRITE(LOUT,'(A,2E12.4)')' MUSQBS1:XVPQI,XVPQII ',XVPQI,XVPQII
38520 ENDIF
38521C
38522C Prepare 4 momenta of new chains and chain ends
38523C
38524C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38525C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38526C +(4,NTMHKK)
38527C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
38528C 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
38529C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
38530 IF(IPIP.EQ.1)THEN
38531 XSQ1=XSQ
38532 XSAQ1=XSAQ
38533 ISQ1=ISQ
38534 ISAQ1=ISAQ
38535 ELSEIF(IPIP.EQ.2)THEN
38536 XSQ1=XSAQ
38537 XSAQ1=XSQ
38538 ISQ1=ISAQ
38539 ISAQ1=ISQ
38540 ENDIF
38541 IDHKT(1) =IP11
38542 ISTHKT(1) =931
38543 JMOHKT(1,1)=NC1P
38544 JMOHKT(2,1)=0
38545 JDAHKT(1,1)=3+IIGLU1
38546 JDAHKT(2,1)=0
38547C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
38548 PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
38549 PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
38550 PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
38551 PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
38552C PHKT(5,1) =PHKK(5,NC1P)
38553 XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38554 *PHKT(1,1)**2)
38555 IF(XMIST.GE.0.D0)THEN
38556 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38557 *PHKT(1,1)**2)
38558 ELSE
38559C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38560 PHKT(5,1)=0.D0
38561 ENDIF
38562 VHKT(1,1) =VHKK(1,NC1P)
38563 VHKT(2,1) =VHKK(2,NC1P)
38564 VHKT(3,1) =VHKK(3,NC1P)
38565 VHKT(4,1) =VHKK(4,NC1P)
38566 WHKT(1,1) =WHKK(1,NC1P)
38567 WHKT(2,1) =WHKK(2,NC1P)
38568 WHKT(3,1) =WHKK(3,NC1P)
38569 WHKT(4,1) =WHKK(4,NC1P)
38570C Add here IIGLU1 gluons to this chaina
38571 PG1=0.D0
38572 PG2=0.D0
38573 PG3=0.D0
38574 PG4=0.D0
38575 IF(IIGLU1.GE.1)THEN
38576 JJG=NC1P
38577 DO 61 IIG=2,2+IIGLU1-1
38578 KKG=JJG+IIG-1
38579 IDHKT(IIG) =IDHKK(KKG)
38580 ISTHKT(IIG) =921
38581 JMOHKT(1,IIG)=KKG
38582 JMOHKT(2,IIG)=0
38583 JDAHKT(1,IIG)=3+IIGLU1
38584 JDAHKT(2,IIG)=0
38585 PHKT(1,IIG)=PHKK(1,KKG)
38586 PG1=PG1+ PHKT(1,IIG)
38587 PHKT(2,IIG)=PHKK(2,KKG)
38588 PG2=PG2+ PHKT(2,IIG)
38589 PHKT(3,IIG)=PHKK(3,KKG)
38590 PG3=PG3+ PHKT(3,IIG)
38591 PHKT(4,IIG)=PHKK(4,KKG)
38592 PG4=PG4+ PHKT(4,IIG)
38593 PHKT(5,IIG)=PHKK(5,KKG)
38594 VHKT(1,IIG) =VHKK(1,KKG)
38595 VHKT(2,IIG) =VHKK(2,KKG)
38596 VHKT(3,IIG) =VHKK(3,KKG)
38597 VHKT(4,IIG) =VHKK(4,KKG)
38598 WHKT(1,IIG) =WHKK(1,KKG)
38599 WHKT(2,IIG) =WHKK(2,KKG)
38600 WHKT(3,IIG) =WHKK(3,KKG)
38601 WHKT(4,IIG) =WHKK(4,KKG)
38602 61 CONTINUE
38603 ENDIF
38604 IDHKT(2+IIGLU1) =IPP2
38605 ISTHKT(2+IIGLU1) =932
38606 JMOHKT(1,2+IIGLU1)=NC2T
38607 JMOHKT(2,2+IIGLU1)=0
38608 JDAHKT(1,2+IIGLU1)=3+IIGLU1
38609 JDAHKT(2,2+IIGLU1)=0
38610 PHKT(1,2+IIGLU1) =PHKK(1,NC2T)
38611 PHKT(2,2+IIGLU1) =PHKK(2,NC2T)
38612 PHKT(3,2+IIGLU1) =PHKK(3,NC2T)
38613 PHKT(4,2+IIGLU1) =PHKK(4,NC2T)
38614C PHKT(5,2+IIGLU1) =PHKK(5,NC2T)
38615 XMIST=(PHKT(4,2+IIGLU1)**2-
38616 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38617 *PHKT(1,2+IIGLU1)**2)
38618 IF(XMIST.GT.0.D0)THEN
38619 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
38620 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38621 *PHKT(1,2+IIGLU1)**2)
38622 ELSE
38623C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38624 PHKT(5,2+IIGLU1)=0.D0
38625 ENDIF
38626 VHKT(1,2+IIGLU1) =VHKK(1,NC2T)
38627 VHKT(2,2+IIGLU1) =VHKK(2,NC2T)
38628 VHKT(3,2+IIGLU1) =VHKK(3,NC2T)
38629 VHKT(4,2+IIGLU1) =VHKK(4,NC2T)
38630 WHKT(1,2+IIGLU1) =WHKK(1,NC2T)
38631 WHKT(2,2+IIGLU1) =WHKK(2,NC2T)
38632 WHKT(3,2+IIGLU1) =WHKK(3,NC2T)
38633 WHKT(4,2+IIGLU1) =WHKK(4,NC2T)
38634 IDHKT(3+IIGLU1) =88888
38635 ISTHKT(3+IIGLU1) =94
38636 JMOHKT(1,3+IIGLU1)=1
38637 JMOHKT(2,3+IIGLU1)=2+IIGLU1
38638 JDAHKT(1,3+IIGLU1)=0
38639 JDAHKT(2,3+IIGLU1)=0
38640 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
38641 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
38642 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
38643 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
38644 XMIST
38645 * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38646 * -PHKT(3,3+IIGLU1)**2)
38647 IF(XMIST.GE.0.D0)THEN
38648 PHKT(5,3+IIGLU1)
38649 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38650 * -PHKT(3,3+IIGLU1)**2)
38651 ELSE
38652C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38653 PHKT(5,1)=0.D0
38654 ENDIF
38655 IF(IPIP.GE.3)THEN
38656C IF(NUMEV.EQ.-324)THEN
38657 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),
38658 * JMOHKT(2,1),JDAHKT(1,1),
38659 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
38660 DO 71 IIG=2,2+IIGLU1-1
38661 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38662 & JMOHKT(1,IIG),JMOHKT(2,IIG),
38663 * JDAHKT(1,IIG),
38664 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38665 71 CONTINUE
38666 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
38667 * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
38668 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
38669 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
38670 * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
38671 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
38672 ENDIF
38673 CHAMAL=CHAM1
38674 IF(IPIP.EQ.1)THEN
38675 IF(IP11.GE.3.OR.IPP2.GE.3)CHAMAL=CHAM3
38676 ELSEIF(IPIP.EQ.2)THEN
38677 IF(IP11.LE.-3.OR.IPP2.LE.-3)CHAMAL=CHAM3
38678 ENDIF
38679 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
38680C IREJ=1
38681 IPCO=0
38682C RETURN
38683C WRITE(6,*)' MUSQBS1 jump back from chain 3'
38684 GO TO 3466
38685 ENDIF
38686 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
38687 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
38688 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
38689 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
38690 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
38691 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
38692 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
38693 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
38694 IDHKT(4+IIGLU1) =IP12
38695 ISTHKT(4+IIGLU1) =931
38696 JMOHKT(1,4+IIGLU1)=NC1P
38697 JMOHKT(2,4+IIGLU1)=0
38698 JDAHKT(1,4+IIGLU1)=6+IIGLU1
38699 JDAHKT(2,4+IIGLU1)=0
38700C create chain 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
38701 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
38702 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
38703 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
38704 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
38705C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
38706 XMIST =(PHKT(4,4+IIGLU1)**2-
38707 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
38708 *PHKT(1,4+IIGLU1)**2)
38709 IF(XMIST.GT.0.D0)THEN
38710 PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2-
38711 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
38712 *PHKT(1,4+IIGLU1)**2)
38713 ELSE
38714C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38715 PHKT(5,4+IIGLU1)=0.D0
38716 ENDIF
38717 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
38718 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
38719 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
38720 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
38721 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
38722 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
38723 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
38724 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
38725 IF(IPIP.EQ.1)THEN
38726 IDHKT(5+IIGLU1) =-(ISAQ1-6)
38727 ELSEIF(IPIP.EQ.2)THEN
38728 IDHKT(5+IIGLU1) =ISAQ1
38729 ENDIF
38730 ISTHKT(5+IIGLU1) =932
38731 JMOHKT(1,5+IIGLU1)=NC1T
38732 JMOHKT(2,5+IIGLU1)=0
38733 JDAHKT(1,5+IIGLU1)=6+IIGLU1
38734 JDAHKT(2,5+IIGLU1)=0
38735 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
38736 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
38737 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
38738 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
38739C IF( PHKT(4,5).EQ.0.D0)THEN
38740C IREJ=1
38741CIPCO=0
38742CRETURN
38743C ENDIF
38744C PHKT(5,5) =PHKK(5,NC1T)
38745 XMIST=(PHKT(4,5+IIGLU1)**2-
38746 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
38747 *PHKT(1,5+IIGLU1)**2)
38748 IF(XMIST.GT.0.D0)THEN
38749 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
38750 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
38751 *PHKT(1,5+IIGLU1)**2)
38752 ELSE
38753C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38754 PHKT(5,5+IIGLU1)=0.D0
38755 ENDIF
38756 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
38757 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
38758 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
38759 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
38760 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
38761 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
38762 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
38763 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
38764 IDHKT(6+IIGLU1) =88888
38765 ISTHKT(6+IIGLU1) =94
38766 JMOHKT(1,6+IIGLU1)=4+IIGLU1
38767 JMOHKT(2,6+IIGLU1)=5+IIGLU1
38768 JDAHKT(1,6+IIGLU1)=0
38769 JDAHKT(2,6+IIGLU1)=0
38770 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
38771 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
38772 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
38773 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
38774 XMIST
38775 * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
38776 * -PHKT(3,6+IIGLU1)**2)
38777 IF(XMIST.GE.0.D0)THEN
38778 PHKT(5,6+IIGLU1)
38779 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
38780 * -PHKT(3,6+IIGLU1)**2)
38781 ELSE
38782C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38783 PHKT(5,1)=0.D0
38784 ENDIF
38785C IF(IPIP.EQ.3)THEN
38786 CHAMAL=CHAM1
38787 IF(IPIP.EQ.1)THEN
38788 IF(IP12.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
38789 ELSEIF(IPIP.EQ.2)THEN
38790 IF(IP12.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
38791 ENDIF
38792 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
38793C IREJ=1
38794 IPCO=0
38795C RETURN
38796C WRITE(6,*)' MGSQBS1 jump back from chain 6',
38797C * CHAMAL,PHKT(5,6+IIGLU1)
38798 GO TO 3466
38799 ENDIF
38800 IF(IPIP.GE.3)THEN
38801C IF(NUMEV.EQ.-324)THEN
38802 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
38803 * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
38804 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
38805 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
38806 * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
38807 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
38808 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
38809 * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
38810 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
38811 ENDIF
38812 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
38813 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
38814 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
38815 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
38816 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
38817 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
38818 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
38819 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
38820 IF(IPIP.EQ.1)THEN
38821 IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+3
38822 IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
38823 IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
38824 IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
38825 ELSEIF(IPIP.EQ.2)THEN
38826 IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3
38827 IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
38828 IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
38829 IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
38830C WRITE(6,*)'IDHKT(7+IIGLU1),IPP1,ISQ1',IDHKT(7+IIGLU1),IPP1,ISQ1
38831 ENDIF
38832 ISTHKT(7+IIGLU1) =931
38833 JMOHKT(1,7+IIGLU1)=NC2P
38834 JMOHKT(2,7+IIGLU1)=0
38835 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
38836 JDAHKT(2,7+IIGLU1)=0
38837C create chain 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
38838 PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
38839 PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
38840 PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
38841 PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
38842C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
38843C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
38844 IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
38845C IREJ=1
38846C WRITE(6,*)'reject PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P)'
38847 IPCO=0
38848C RETURN
38849 GO TO 3466
38850 ENDIF
38851C PHKT(5,7) =PHKK(5,NC2P)
38852 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
38853 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
38854 *PHKT(1,7+IIGLU1)**2)
38855 VHKT(1,7+IIGLU1) =VHKK(1,NC2P)
38856 VHKT(2,7+IIGLU1) =VHKK(2,NC2P)
38857 VHKT(3,7+IIGLU1) =VHKK(3,NC2P)
38858 VHKT(4,7+IIGLU1) =VHKK(4,NC2P)
38859 WHKT(1,7+IIGLU1) =WHKK(1,NC2P)
38860 WHKT(2,7+IIGLU1) =WHKK(2,NC2P)
38861 WHKT(3,7+IIGLU1) =WHKK(3,NC2P)
38862 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
38863C Insert here the IIGLU2 gluons
38864 PG1=0.D0
38865 PG2=0.D0
38866 PG3=0.D0
38867 PG4=0.D0
38868 IF(IIGLU2.GE.1)THEN
38869 JJG=NC2P
38870 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38871 KKG=JJG+IIG-7-IIGLU1
38872 IDHKT(IIG) =IDHKK(KKG)
38873 ISTHKT(IIG) =921
38874 JMOHKT(1,IIG)=KKG
38875 JMOHKT(2,IIG)=0
38876 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
38877 JDAHKT(2,IIG)=0
38878 PHKT(1,IIG)=PHKK(1,KKG)
38879 PG1=PG1+ PHKT(1,IIG)
38880 PHKT(2,IIG)=PHKK(2,KKG)
38881 PG2=PG2+ PHKT(2,IIG)
38882 PHKT(3,IIG)=PHKK(3,KKG)
38883 PG3=PG3+ PHKT(3,IIG)
38884 PHKT(4,IIG)=PHKK(4,KKG)
38885 PG4=PG4+ PHKT(4,IIG)
38886 PHKT(5,IIG)=PHKK(5,KKG)
38887 VHKT(1,IIG) =VHKK(1,KKG)
38888 VHKT(2,IIG) =VHKK(2,KKG)
38889 VHKT(3,IIG) =VHKK(3,KKG)
38890 VHKT(4,IIG) =VHKK(4,KKG)
38891 WHKT(1,IIG) =WHKK(1,KKG)
38892 WHKT(2,IIG) =WHKK(2,KKG)
38893 WHKT(3,IIG) =WHKK(3,KKG)
38894 WHKT(4,IIG) =WHKK(4,KKG)
38895 81 CONTINUE
38896 ENDIF
38897 IDHKT(8+IIGLU1+IIGLU2) =IP2
38898 ISTHKT(8+IIGLU1+IIGLU2) =932
38899 JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
38900 JMOHKT(2,8+IIGLU1+IIGLU2)=0
38901 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
38902 JDAHKT(2,8+IIGLU1+IIGLU2)=0
38903 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
38904 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
38905 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
38906 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
38907C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T)
38908 XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
38909 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38910 *PHKT(1,8+IIGLU1+IIGLU2)**2)
38911 IF(XMIST.GT.0.D0)THEN
38912 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
38913 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38914 *PHKT(1,8+IIGLU1+IIGLU2)**2)
38915 ELSE
38916C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38917 PHKT(5,8+IIGLU1+IIGLU2)=0.D0
38918 ENDIF
38919 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T)
38920 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T)
38921 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T)
38922 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T)
38923 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T)
38924 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T)
38925 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T)
38926 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T)
38927 IDHKT(9+IIGLU1+IIGLU2) =88888
38928 ISTHKT(9+IIGLU1+IIGLU2) =94
38929 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
38930 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
38931 JDAHKT(1,9+IIGLU1+IIGLU2)=0
38932 JDAHKT(2,9+IIGLU1+IIGLU2)=0
38933 PHKT(1,9+IIGLU1+IIGLU2)
38934 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
38935 PHKT(2,9+IIGLU1+IIGLU2)
38936 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
38937 PHKT(3,9+IIGLU1+IIGLU2)
38938 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
38939 PHKT(4,9+IIGLU1+IIGLU2)
38940 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
38941 XMIST
38942 *=(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
38943 * -PHKT(2,9+IIGLU1+IIGLU2)**2
38944 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
38945 IF(XMIST.GE.0.D0)THEN
38946 PHKT(5,9+IIGLU1+IIGLU2)
38947 *=SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
38948 * -PHKT(2,9+IIGLU1+IIGLU2)**2
38949 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
38950 ELSE
38951C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38952 PHKT(5,1)=0.D0
38953 ENDIF
38954 IF(IPIP.GE.3)THEN
38955C IF(NUMEV.EQ.-324)THEN
38956 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
38957 * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
38958 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
38959 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38960 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38961 & JMOHKT(1,IIG),JMOHKT(2,IIG),
38962 * JDAHKT(1,IIG),
38963 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38964 91 CONTINUE
38965 WRITE(LOUT,*)8+IIGLU1+IIGLU2,
38966 * ISTHKT(8+IIGLU1+IIGLU2),IDHKT(8+IIGLU1+IIGLU2),
38967 * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
38968 *JDAHKT(1,8+IIGLU1+IIGLU2),
38969 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
38970 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
38971 * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
38972 *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
38973 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
38974 ENDIF
38975 CHAMAL=CHAB1
38976 IF(IPIP.EQ.1)THEN
38977 IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
38978 ELSEIF(IPIP.EQ.2)THEN
38979 IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
38980 ENDIF
38981 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
38982C IREJ=1
38983 IPCO=0
38984C RETURN
38985C WRITE(6,*)' MGSQBS1 jump back from chain 9',
38986C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
38987 GO TO 3466
38988 ENDIF
38989 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
38990 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
38991 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
38992 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
38993 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
38994 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
38995 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
38996 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
38997C
38998 IPCO=0
38999 IGCOUN=9+IIGLU1+IIGLU2
39000 RETURN
39001 END
39002
39003*$ CREATE MGSQBS1.FOR
39004*COPY MGSQBS1
39005C
39006C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
39007 SUBROUTINE MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
39008 * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,ISQ,IGCOUN)
39009C
39010C GSQBS-1 diagram (split projectile diquark)
39011C
39012 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39013 SAVE
39014
39015 PARAMETER ( LINP = 10 ,
39016 & LOUT = 6 ,
39017 & LDAT = 9 )
39018* event history
39019 PARAMETER (NMXHKK=200000)
39020 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
39021 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
39022 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
39023* extended event history
39024 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
39025 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
39026 & IHIST(2,NMXHKK)
39027* Lorentz-parameters of the current interaction
39028 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
39029 & UMO,PPCM,EPROJ,PPROJ
39030* diquark-breaking mechanism
39031 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
39032
39033C
39034 PARAMETER (NTMHKK= 300)
39035 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
39036 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
39037 +(4,NTMHKK)
39038*KEEP,XSEADI.
39039 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
39040 +SSMIMQ,VVMTHR
39041*KEEP,DPRIN.
39042 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
39043C
39044C GSQBS-1 diagram (split projectile diquark)
39045C
39046C
39047C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
39048C Input chain 2(NC2) sea-quark(NC2P)-valence-diquark(NC2T)
39049C
39050C Create quark(qs)-antiquark(aqs) pair energy from NC1P and NC1T
39051C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
39052C
39053C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
39054C 6 valence quark(vq2P 4)-sea-quark(aqsP 5)
39055C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
39056C
39057C Put new chains into COMMON /HKKTMP/
39058C
39059 IIGLU1=NC1T-NC1P-1
39060 IIGLU2=NC2T-NC2P-1
39061 IGCOUN=0
39062C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
39063 CVQ=1.D0
39064 NNNC1=IDHKK(NC1)/1000
39065 MMMC1=IDHKK(NC1)-NNNC1*1000
39066 KKKC1=ISTHKK(NC1)
39067 NNNC2=IDHKK(NC2)/1000
39068 MMMC2=IDHKK(NC2)-NNNC2*1000
39069 KKKC2=ISTHKK(NC2)
39070 IREJ=0
39071 IF(IPIP.EQ.3)THEN
39072 WRITE(LOUT,*)' MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
39073 * ' IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN)',
39074 *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
39075 * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN
39076 ENDIF
39077C
39078C
39079C
39080C determine x-values of NC1P diquark
39081 XDIQP=PHKK(4,NC1P)*2.D0/UMO
39082 XVQT=PHKK(4,NC1T)*2.D0/UMO
39083C
39084C determine x-values of sea quark pair
39085C
39086 IPCO=1
39087 ICOU=0
39088 2234 CONTINUE
39089 ICOU=ICOU+1
39090 IF(ICOU.GE.500)THEN
39091 IREJ=1
39092 IF(ISQ.EQ.3)IREJ=3
39093 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 Rejection 2234 ICOU. GT.100'
39094 IPCO=0
39095 RETURN
39096 ENDIF
39097 IF(IPCO.GE.3)WRITE(LOUT,*)'MGSQBS1 call XSEAPA: UMO,XDIQP,XVQT ',
39098 * UMO, XDIQP,XVQT
39099 XSQ=0.D0
39100 XSAQ=0.D0
39101**NEW
39102C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
39103 IF (IPIP.EQ.1) THEN
39104 XQMAX = XDIQP/2.0D0
39105 XAQMAX = 2.D0*XVQT/3.0D0
39106 ELSE
39107 XQMAX = 2.D0*XVQT/3.0D0
39108 XAQMAX = XDIQP/2.0D0
39109 ENDIF
39110 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
39111 ISAQ = 6+ISQ
39112C write(*,*) 'MGSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
39113**
39114 IF(IPCO.GE.3)
39115 & WRITE(LOUT,*)'MGSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
39116 IF(IREJ.GE.1)THEN
39117 IF(IPCO.GE.3)
39118 & WRITE(LOUT,*)'MGSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
39119 IPCO=0
39120 RETURN
39121 ENDIF
39122 IF(IPIP.EQ.1)THEN
39123 IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
39124 ELSEIF(IPIP.EQ.2)THEN
39125 IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
39126 ENDIF
39127 IF(IPCO.GE.3)THEN
39128 WRITE(LOUT,'(A,4E12.4)')' MGSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
39129 * XDIQP,XVQT,XSQ,XSAQ
39130 ENDIF
39131C
39132C subtract xsq,xsaq from NC1P diquark and NC1T quark
39133C
39134C XSQ=0.D0
39135 IF(IPIP.EQ.1)THEN
39136 XDIQP=XDIQP-XSQ
39137**NEW
39138C IF (XDIQP.LT.0.0D0) WRITE(*,*) ' mgsqbs1: XDIQP<0!!',XDIQP
39139**
39140 XVQT =XVQT -XSAQ
39141 ELSEIF(IPIP.EQ.2)THEN
39142 XDIQP=XDIQP-XSAQ
39143 XVQT =XVQT -XSQ
39144 ENDIF
39145 IF(IPCO.GE.3)
39146 & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
39147C
39148C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
39149C
39150 XVTHRO=CVQ/UMO
39151 IVTHR=0
39152 3466 CONTINUE
39153 IF(IVTHR.EQ.10)THEN
39154 IREJ=1
39155 IF(ISQ.EQ.3)IREJ=3
39156 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 3466 reject IVTHR 10'
39157 IPCO=0
39158 RETURN
39159 ENDIF
39160 IVTHR=IVTHR+1
39161 XVTHR=XVTHRO/(201-IVTHR)
39162 UNOPRV=UNON
39163 380 CONTINUE
39164 IF(XVTHR.GT.0.66D0*XDIQP)THEN
39165 IREJ=1
39166 IF(ISQ.EQ.3)IREJ=3
39167 IF(IPCO.GE.3)
39168 & WRITE(LOUT,*)' MGSQBS1 Rejection 380 XVTHR large ',
39169 * XVTHR
39170 IPCO=0
39171 RETURN
39172 ENDIF
39173 IF(DT_RNDM(V).LT.0.5D0)THEN
39174 XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
39175 XVPQII=XDIQP-XVPQI
39176 ELSE
39177 XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
39178 XVPQI=XDIQP-XVPQII
39179 ENDIF
39180 IF(IPCO.GE.3)THEN
39181 WRITE(LOUT,'(A,4E12.4)')' MGSQBS1:XVTHR,XDIQP,XVPQI,XVPQII ',
39182 * XVTHR,XDIQP,XVPQI,XVPQII
39183 ENDIF
39184C
39185C Prepare 4 momenta of new chains and chain ends
39186C
39187C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
39188C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
39189C +(4,NTMHKK)
39190C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
39191C 6 valence quark(vq2P 4)-sea-quark(aqsP 5)
39192C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
39193 IF(IPIP.EQ.1)THEN
39194 XSQ1=XSQ
39195 XSAQ1=XSAQ
39196 ISQ1=ISQ
39197 ISAQ1=ISAQ
39198 ELSEIF(IPIP.EQ.2)THEN
39199 XSQ1=XSAQ
39200 XSAQ1=XSQ
39201 ISQ1=ISAQ
39202 ISAQ1=ISQ
39203 ENDIF
39204 KK11=IP11
39205C IDHKT(2) =1000*IPP21+100*IPP22+1
39206 KK21= IPP21
39207 KK22= IPP22
39208 XGIVE=0.D0
39209 IDHKT(4+IIGLU1) =IP12
39210 ISTHKT(4+IIGLU1) =921
39211 JMOHKT(1,4+IIGLU1)=NC1P
39212 JMOHKT(2,4+IIGLU1)=0
39213 JDAHKT(1,4+IIGLU1)=6+IIGLU1
39214 JDAHKT(2,4+IIGLU1)=0
39215**NEW
39216 IF ((XDIQP.LT.0.0D0).OR.(XVPQII.LT.0.0D0).OR.
39217 & (XSQ1.LT.0.0D0)) WRITE(LOUT,*) ' mgsqbs1: ',XDIQP,XVPQII,XSQ1
39218**
39219 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
39220 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
39221 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
39222 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
39223C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
39224 XXMIST=(PHKT(4,4+IIGLU1)**2-
39225 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
39226 * PHKT(1,4+IIGLU1)**2)
39227 IF(XXMIST.GT.0.D0)THEN
39228 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
39229 ELSE
39230 WRITE(LOUT,*)'MGSQBS1 XXMIST',XXMIST
39231 XXMIST=ABS(XXMIST)
39232 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
39233 ENDIF
39234 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
39235 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
39236 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
39237 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
39238 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
39239 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
39240 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
39241 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
39242 IF(IPIP.EQ.1)THEN
39243 IDHKT(5+IIGLU1) =-(ISAQ1-6)
39244 ELSEIF(IPIP.EQ.2)THEN
39245 IDHKT(5+IIGLU1) =ISAQ1
39246 ENDIF
39247 ISTHKT(5+IIGLU1) =922
39248 JMOHKT(1,5+IIGLU1)=NC1T
39249 JMOHKT(2,5+IIGLU1)=0
39250 JDAHKT(1,5+IIGLU1)=6+IIGLU1
39251 JDAHKT(2,5+IIGLU1)=0
39252**NEW
39253 IF ((XSAQ1.LT.0.0D0).OR.(XVQT .LT.0.0D0))
39254 & WRITE(LOUT,*) ' mgsqbs2: ',XSAQ1,XVQT
39255**
39256 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
39257 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
39258 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
39259 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
39260C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
39261 XMIST=(PHKT(4,5+IIGLU1)**2-
39262 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
39263 *PHKT(1,5+IIGLU1)**2)
39264 IF(XMIST.GT.0.D0)THEN
39265 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
39266 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
39267 *PHKT(1,5+IIGLU1)**2)
39268 ELSE
39269C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
39270 PHKT(5,5+IIGLU1)=0.D0
39271 ENDIF
39272 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
39273 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
39274 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
39275 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
39276 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
39277 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
39278 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
39279 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
39280 IDHKT(6+IIGLU1) =88888
39281C IDHKT(6) =1000*NNNC1+MMMC1
39282 ISTHKT(6+IIGLU1) =93
39283C ISTHKT(6) =KKKC1
39284 JMOHKT(1,6+IIGLU1)=4+IIGLU1
39285 JMOHKT(2,6+IIGLU1)=5+IIGLU1
39286 JDAHKT(1,6+IIGLU1)=0
39287 JDAHKT(2,6+IIGLU1)=0
39288 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
39289 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
39290 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
39291 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
39292 PHKT(5,6+IIGLU1)
39293 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
39294 * -PHKT(3,6+IIGLU1)**2)
39295 CHAMAL=CHAM1
39296 IF(IPIP.EQ.1)THEN
39297 IF(IP12.GE.3.OR.ISAQ.GE.9)CHAMAL=CHAM3
39298 ELSEIF(IPIP.EQ.2)THEN
39299 IF(IP12.LE.-3.OR.ISAQ.GE.3)CHAMAL=CHAM3
39300 ENDIF
39301 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
39302 IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
39303C we drop chain 6 and give the energy to chain 3
39304 IDHKT(6+IIGLU1)=33888
39305 XGIVE=1.D0
39306C WRITE(6,*)' drop chain 6 xgive=1'
39307 GO TO 7788
39308 ELSEIF(IDHKT(5+IIGLU1).EQ.-IP11)THEN
39309C we drop chain 6 and give the energy to chain 3
39310C and change KK11 to IDHKT(4)
39311 IDHKT(6+IIGLU1)=33888
39312 XGIVE=1.D0
39313C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(4+IIGLU1)'
39314 KK11=IDHKT(4+IIGLU1)
39315 GO TO 7788
39316 ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP21)THEN
39317C we drop chain 6 and give the energy to chain 3
39318C and change KK21 to IDHKT(4)
39319C IDHKT(2) =1000*IPP21+100*IPP22+1
39320 IDHKT(6+IIGLU1)=33888
39321 XGIVE=1.D0
39322C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(4+IIGLU1)'
39323 KK21=IDHKT(4+IIGLU1)
39324 GO TO 7788
39325 ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP22)THEN
39326C we drop chain 6 and give the energy to chain 3
39327C and change KK22 to IDHKT(4)
39328C IDHKT(2) =1000*IPP21+100*IPP22+1
39329 IDHKT(6+IIGLU1)=33888
39330 XGIVE=1.D0
39331C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(4+IIGLU1)'
39332 KK22=IDHKT(4+IIGLU1)
39333 GO TO 7788
39334 ENDIF
39335C IREJ=1
39336 IPCO=0
39337C RETURN
39338C WRITE(6,*)' MGSQBS1 jump back from chain 6'
39339 GO TO 3466
39340 ENDIF
39341 7788 CONTINUE
39342 IF(IPIP.GE.3)THEN
39343 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
39344 * JMOHKT(1,4+IIGLU1),
39345 * JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
39346 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
39347 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
39348 * JMOHKT(1,5+IIGLU1),
39349 * JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
39350 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
39351 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
39352 * JMOHKT(1,6+IIGLU1),
39353 * JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
39354 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
39355 ENDIF
39356 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
39357 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
39358 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
39359 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
39360 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
39361 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
39362 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
39363 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
39364C IDHKT(1) =IP11
39365 IDHKT(1) =KK11
39366 ISTHKT(1) =921
39367 JMOHKT(1,1)=NC1P
39368 JMOHKT(2,1)=0
39369 JDAHKT(1,1)=3+IIGLU1
39370 JDAHKT(2,1)=0
39371 PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
39372C * +0.5D0*PHKK(1,NC2P)
39373 *+XGIVE*PHKT(1,4+IIGLU1)
39374 PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
39375C * +0.5D0*PHKK(2,NC2P)
39376 *+XGIVE*PHKT(2,4+IIGLU1)
39377 PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
39378C * +0.5D0*PHKK(3,NC2P)
39379 *+XGIVE*PHKT(3,4+IIGLU1)
39380 PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
39381C * +0.5D0*PHKK(4,NC2P)
39382 *+XGIVE*PHKT(4,4+IIGLU1)
39383C PHKT(5,1) =PHKK(5,NC1P)
39384 XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
39385 *PHKT(1,1)**2)
39386 IF(XMIST.GE.0.D0)THEN
39387 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
39388 *PHKT(1,1)**2)
39389 ELSE
39390C WRITE(6,*)'MGSQBS1 parton 1 mass square LT.0 ',XMIST
39391 PHKT(5,1)=0.D0
39392 ENDIF
39393 VHKT(1,1) =VHKK(1,NC1P)
39394 VHKT(2,1) =VHKK(2,NC1P)
39395 VHKT(3,1) =VHKK(3,NC1P)
39396 VHKT(4,1) =VHKK(4,NC1P)
39397 WHKT(1,1) =WHKK(1,NC1P)
39398 WHKT(2,1) =WHKK(2,NC1P)
39399 WHKT(3,1) =WHKK(3,NC1P)
39400 WHKT(4,1) =WHKK(4,NC1P)
39401C Add here IIGLU1 gluons to this chaina
39402 PG1=0.D0
39403 PG2=0.D0
39404 PG3=0.D0
39405 PG4=0.D0
39406 IF(IIGLU1.GE.1)THEN
39407 JJG=NC1P
39408 DO 61 IIG=2,2+IIGLU1-1
39409 KKG=JJG+IIG-1
39410 IDHKT(IIG) =IDHKK(KKG)
39411 ISTHKT(IIG) =921
39412 JMOHKT(1,IIG)=KKG
39413 JMOHKT(2,IIG)=0
39414 JDAHKT(1,IIG)=3+IIGLU1
39415 JDAHKT(2,IIG)=0
39416 PHKT(1,IIG)=PHKK(1,KKG)
39417 PG1=PG1+ PHKT(1,IIG)
39418 PHKT(2,IIG)=PHKK(2,KKG)
39419 PG2=PG2+ PHKT(2,IIG)
39420 PHKT(3,IIG)=PHKK(3,KKG)
39421 PG3=PG3+ PHKT(3,IIG)
39422 PHKT(4,IIG)=PHKK(4,KKG)
39423 PG4=PG4+ PHKT(4,IIG)
39424 PHKT(5,IIG)=PHKK(5,KKG)
39425 VHKT(1,IIG) =VHKK(1,KKG)
39426 VHKT(2,IIG) =VHKK(2,KKG)
39427 VHKT(3,IIG) =VHKK(3,KKG)
39428 VHKT(4,IIG) =VHKK(4,KKG)
39429 WHKT(1,IIG) =WHKK(1,KKG)
39430 WHKT(2,IIG) =WHKK(2,KKG)
39431 WHKT(3,IIG) =WHKK(3,KKG)
39432 WHKT(4,IIG) =WHKK(4,KKG)
39433 61 CONTINUE
39434 ENDIF
39435C IDHKT(2) =1000*IPP21+100*IPP22+1
39436 IF(IPIP.EQ.1)THEN
39437 IDHKT(2+IIGLU1) =1000*KK21+100*KK22+3
39438 IF(IDHKT(2+IIGLU1).EQ.1203)IDHKT(2+IIGLU1)=2103
39439 IF(IDHKT(2+IIGLU1).EQ.1303)IDHKT(2+IIGLU1)=3103
39440 IF(IDHKT(2+IIGLU1).EQ.2303)IDHKT(2+IIGLU1)=3203
39441 ELSEIF(IPIP.EQ.2)THEN
39442 IDHKT(2+IIGLU1) =1000*KK21+100*KK22-3
39443 IF(IDHKT(2+IIGLU1).EQ.-1203)IDHKT(2+IIGLU1)=-2103
39444 IF(IDHKT(2+IIGLU1).EQ.-1303)IDHKT(2+IIGLU1)=-3103
39445 IF(IDHKT(2+IIGLU1).EQ.-2303)IDHKT(2+IIGLU1)=-3203
39446 ENDIF
39447 ISTHKT(2+IIGLU1) =922
39448 JMOHKT(1,2+IIGLU1)=NC2T
39449 JMOHKT(2,2+IIGLU1)=0
39450 JDAHKT(1,2+IIGLU1)=3+IIGLU1
39451 JDAHKT(2,2+IIGLU1)=0
39452 PHKT(1,2+IIGLU1) =PHKK(1,NC2T)
39453 *+XGIVE*PHKT(1,5+IIGLU1)
39454 PHKT(2,2+IIGLU1) =PHKK(2,NC2T)
39455 *+XGIVE*PHKT(2,5+IIGLU1)
39456 PHKT(3,2+IIGLU1) =PHKK(3,NC2T)
39457 *+XGIVE*PHKT(3,5+IIGLU1)
39458 PHKT(4,2+IIGLU1) =PHKK(4,NC2T)
39459 *+XGIVE*PHKT(4,5+IIGLU1)
39460C PHKT(5,2) =PHKK(5,NC2T)
39461 XMIST=(PHKT(4,2+IIGLU1)**2-
39462 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
39463 *PHKT(1,2+IIGLU1)**2)
39464 IF(XMIST.GT.0.D0)THEN
39465 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
39466 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
39467 *PHKT(1,2+IIGLU1)**2)
39468 ELSE
39469C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
39470 PHKT(5,2+IIGLU1)=0.D0
39471 ENDIF
39472 VHKT(1,2+IIGLU1) =VHKK(1,NC2T)
39473 VHKT(2,2+IIGLU1) =VHKK(2,NC2T)
39474 VHKT(3,2+IIGLU1) =VHKK(3,NC2T)
39475 VHKT(4,2+IIGLU1) =VHKK(4,NC2T)
39476 WHKT(1,2+IIGLU1) =WHKK(1,NC2T)
39477 WHKT(2,2+IIGLU1) =WHKK(2,NC2T)
39478 WHKT(3,2+IIGLU1) =WHKK(3,NC2T)
39479 WHKT(4,2+IIGLU1) =WHKK(4,NC2T)
39480 IDHKT(3+IIGLU1) =88888
39481C IDHKT(3) =1000*NNNC1+MMMC1+10
39482 ISTHKT(3+IIGLU1) =93
39483C ISTHKT(3) =KKKC1
39484 JMOHKT(1,3+IIGLU1)=1
39485 JMOHKT(2,3+IIGLU1)=2+IIGLU1
39486 JDAHKT(1,3+IIGLU1)=0
39487 JDAHKT(2,3+IIGLU1)=0
39488 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
39489 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
39490 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
39491 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
39492 PHKT(5,3+IIGLU1)
39493 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
39494 * -PHKT(3,3+IIGLU1)**2)
39495 IF(IPIP.GE.3)THEN
39496 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
39497 * JDAHKT(1,1),
39498 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
39499 DO 71 IIG=2,2+IIGLU1-1
39500 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
39501 & JMOHKT(1,IIG),JMOHKT(2,IIG),
39502 * JDAHKT(1,IIG),
39503 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
39504 71 CONTINUE
39505 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),
39506 & IDHKT(2),JMOHKT(1,2+IIGLU1),
39507 * JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
39508 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
39509 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
39510 * JMOHKT(1,3+IIGLU1),
39511 * JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
39512 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
39513 ENDIF
39514 CHAMAL=CHAB1
39515**NEW
39516C IF(IPIP.EQ.1)THEN
39517C IF(IPP21.GE.3.OR.IPP22.GE.3.OR.IP11.GE.3)CHAMAL=CHAB3
39518C ELSEIF(IPIP.EQ.2)THEN
39519C IF(IPP21.LE.-3.OR.IPP22.LE.-3.OR.IP11.LE.-3)CHAMAL=CHAB3
39520C ENDIF
39521 IF(IPIP.EQ.1)THEN
39522 IF(KK21.GE.3.OR.KK22.GE.3.OR.KK11.GE.3)CHAMAL=CHAB3
39523 ELSEIF(IPIP.EQ.2)THEN
39524 IF(KK21.LE.-3.OR.KK22.LE.-3.OR.KK11.LE.-3)CHAMAL=CHAB3
39525 ENDIF
39526**
39527 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
39528C IREJ=1
39529 IPCO=0
39530C RETURN
39531C WRITE(6,*)' MGSQBS1 jump back from chain 3'
39532 GO TO 3466
39533 ENDIF
39534 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
39535 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
39536 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
39537 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
39538 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
39539 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
39540 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
39541 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
39542 IF(IPIP.EQ.1)THEN
39543 IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ1+3
39544 IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
39545 IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
39546 IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
39547 ELSEIF(IPIP.EQ.2)THEN
39548 IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3
39549 IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
39550 IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
39551 IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
39552C WRITE(6,*)'IDHKT(7),IPP1,ISQ1',IDHKT(7),IPP1,ISQ1
39553 ENDIF
39554 ISTHKT(7+IIGLU1) =921
39555 JMOHKT(1,7+IIGLU1)=NC2P
39556 JMOHKT(2,7+IIGLU1)=0
39557 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
39558 JDAHKT(2,7+IIGLU1)=0
39559C PHKT(1,7) =0.5D0*PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ/(XDIQP+XSQ)
39560C PHKT(2,7) =0.5D0*PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ/(XDIQP+XSQ)
39561C PHKT(3,7) =0.5D0*PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ/(XDIQP+XSQ)
39562C PHKT(4,7+IIGLU1) =0.5D0*PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ/(XDIQP+XSQ)
39563**NEW
39564 IF ((XSQ1 .LT.0.0D0).OR.(XDIQP .LT.0.0D0))
39565 & WRITE(LOUT,*) ' mgsqbs3: ',XSQ1,XDIQP
39566**
39567 PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
39568 PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
39569 PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
39570 PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
39571C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
39572C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
39573 IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
39574C IREJ=1
39575C WRITE(6,*)'reject PHKT(4,7).GE. PHKK(4,NC1P)'
39576 IPCO=0
39577C RETURN
39578 GO TO 3466
39579 ENDIF
39580C PHKT(5,7) =PHKK(5,NC2P)
39581 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
39582 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
39583 *PHKT(1,7+IIGLU1)**2)
39584 VHKT(1,7+IIGLU1) =VHKK(1,NC2P)
39585 VHKT(2,7+IIGLU1) =VHKK(2,NC2P)
39586 VHKT(3,7+IIGLU1) =VHKK(3,NC2P)
39587 VHKT(4,7+IIGLU1) =VHKK(4,NC2P)
39588 WHKT(1,7+IIGLU1) =WHKK(1,NC2P)
39589 WHKT(2,7+IIGLU1) =WHKK(2,NC2P)
39590 WHKT(3,7+IIGLU1) =WHKK(3,NC2P)
39591 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
39592C Insert here the IIGLU2 gluons
39593 PG1=0.D0
39594 PG2=0.D0
39595 PG3=0.D0
39596 PG4=0.D0
39597 IF(IIGLU2.GE.1)THEN
39598 JJG=NC2P
39599 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
39600 KKG=JJG+IIG-7-IIGLU1
39601 IDHKT(IIG) =IDHKK(KKG)
39602 ISTHKT(IIG) =921
39603 JMOHKT(1,IIG)=KKG
39604 JMOHKT(2,IIG)=0
39605 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
39606 JDAHKT(2,IIG)=0
39607 PHKT(1,IIG)=PHKK(1,KKG)
39608 PG1=PG1+ PHKT(1,IIG)
39609 PHKT(2,IIG)=PHKK(2,KKG)
39610 PG2=PG2+ PHKT(2,IIG)
39611 PHKT(3,IIG)=PHKK(3,KKG)
39612 PG3=PG3+ PHKT(3,IIG)
39613 PHKT(4,IIG)=PHKK(4,KKG)
39614 PG4=PG4+ PHKT(4,IIG)
39615 PHKT(5,IIG)=PHKK(5,KKG)
39616 VHKT(1,IIG) =VHKK(1,KKG)
39617 VHKT(2,IIG) =VHKK(2,KKG)
39618 VHKT(3,IIG) =VHKK(3,KKG)
39619 VHKT(4,IIG) =VHKK(4,KKG)
39620 WHKT(1,IIG) =WHKK(1,KKG)
39621 WHKT(2,IIG) =WHKK(2,KKG)
39622 WHKT(3,IIG) =WHKK(3,KKG)
39623 WHKT(4,IIG) =WHKK(4,KKG)
39624 81 CONTINUE
39625 ENDIF
39626 IDHKT(8+IIGLU1+IIGLU2) =IP2
39627 ISTHKT(8+IIGLU1+IIGLU2) =922
39628 JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
39629 JMOHKT(2,8+IIGLU1+IIGLU2)=0
39630 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
39631 JDAHKT(2,8+IIGLU1+IIGLU2)=0
39632**NEW
39633 IF ((XVQT.LT.0.0D0).OR.(XSAQ1 .LT.0.0D0))
39634 & WRITE(LOUT,*) ' mgsqbs4: ',XVQT,XSAQ1
39635**
39636 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
39637 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
39638 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
39639 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
39640C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T)
39641 XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
39642 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
39643 *PHKT(1,8+IIGLU1+IIGLU2)**2)
39644 IF(XMIST.GT.0.D0)THEN
39645 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
39646 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
39647 *PHKT(1,8+IIGLU1+IIGLU2)**2)
39648 ELSE
39649C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
39650 PHKT(5,8+IIGLU1+IIGLU2)=0.D0
39651 ENDIF
39652 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T)
39653 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T)
39654 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T)
39655 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T)
39656 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T)
39657 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T)
39658 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T)
39659 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T)
39660 IDHKT(9+IIGLU1+IIGLU2) =88888
39661C IDHKT(9) =1000*NNNC2+MMMC2+10
39662 ISTHKT(9+IIGLU1+IIGLU2) =93
39663C ISTHKT(9) =KKKC2
39664 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
39665 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
39666 JDAHKT(1,9+IIGLU1+IIGLU2)=0
39667 JDAHKT(2,9+IIGLU1+IIGLU2)=0
39668 PHKT(1,9+IIGLU1+IIGLU2) =PHKT(1,7+IIGLU1)
39669 * +PHKT(1,8+IIGLU1+IIGLU2)+PG1
39670 PHKT(2,9+IIGLU1+IIGLU2) =PHKT(2,7+IIGLU1)
39671 * +PHKT(2,8+IIGLU1+IIGLU2)+PG2
39672 PHKT(3,9+IIGLU1+IIGLU2) =PHKT(3,7+IIGLU1)
39673 * +PHKT(3,8+IIGLU1+IIGLU2)+PG3
39674 PHKT(4,9+IIGLU1+IIGLU2) =PHKT(4,7+IIGLU1)
39675 * +PHKT(4,8+IIGLU1+IIGLU2)+PG4
39676 PHKT(5,9+IIGLU1+IIGLU2)
39677 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
39678 * PHKT(2,9+IIGLU1+IIGLU2)**2
39679 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
39680 IF(IPIP.GE.3)THEN
39681 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
39682 * JMOHKT(1,7+IIGLU1),
39683 * JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
39684 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
39685 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
39686 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
39687 & JMOHKT(1,IIG),JMOHKT(2,IIG),
39688 * JDAHKT(1,IIG),
39689 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
39690 91 CONTINUE
39691 WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
39692 * IDHKT(8+IIGLU1+IIGLU2),
39693 * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
39694 * JDAHKT(1,8+IIGLU1+IIGLU2),
39695 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
39696 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
39697 * IDHKT(9+IIGLU1+IIGLU2),
39698 * JMOHKT(1,9+IIGLU1+IIGLU2),JMOHKT(2,9+IIGLU1+IIGLU2),
39699 * JDAHKT(1,9+IIGLU1+IIGLU2),
39700 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
39701 ENDIF
39702 CHAMAL=CHAB1
39703 IF(IPIP.EQ.1)THEN
39704 IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
39705 ELSEIF(IPIP.EQ.2)THEN
39706 IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
39707 ENDIF
39708 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
39709C IREJ=1
39710 IPCO=0
39711C RETURN
39712C WRITE(6,*)' MGSQBS1 jump back from chain 9',
39713C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
39714 GO TO 3466
39715 ENDIF
39716 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
39717 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
39718 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
39719 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
39720 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
39721 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
39722 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
39723 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
39724C
39725 IGCOUN=9+IIGLU1+IIGLU2
39726 IPCO=0
39727 RETURN
39728 END
39729
39730*$ CREATE HKKHKT.FOR
39731*COPY HKKHKT
39732C
39733C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
39734C
39735 SUBROUTINE HKKHKT(I,J)
39736 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39737 SAVE
39738
39739* event history
39740 PARAMETER (NMXHKK=200000)
39741 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
39742 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
39743 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
39744* extended event history
39745 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
39746 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
39747 & IHIST(2,NMXHKK)
39748
39749 PARAMETER (NTMHKK= 300)
39750 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
39751 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
39752 +(4,NTMHKK)
39753C
39754 ISTHKK(I) =ISTHKT(J)
39755 IDHKK(I) =IDHKT(J)
39756C IF(J.EQ.3.OR.J.EQ.6.OR.J.EQ.9)THEN
39757 IF(IDHKK(I).EQ.88888)THEN
39758C JMOHKK(1,I)=I-2
39759C JMOHKK(2,I)=I-1
39760 JMOHKK(1,I)=I-(J-JMOHKT(1,J))
39761 JMOHKK(2,I)=I-(J-JMOHKT(2,J))
39762 ELSE
39763 JMOHKK(1,I)=JMOHKT(1,J)
39764 JMOHKK(2,I)=JMOHKT(2,J)
39765 ENDIF
39766 JDAHKK(1,I)=JDAHKT(1,J)
39767 JDAHKK(2,I)=JDAHKT(2,J)
39768C IF(J.EQ.1.OR.J.EQ.4.OR.J.EQ.7)THEN
39769C JDAHKK(1,I)=I+2
39770C ELSEIF(J.EQ.2.OR.J.EQ.5.OR.J.EQ.8)THEN
39771C JDAHKK(1,I)=I+1
39772C ENDIF
39773 IF(JDAHKT(1,J).GT.0)THEN
39774 JDAHKK(1,I)=I+(JDAHKT(1,J)-J)
39775 ENDIF
39776 PHKK(1,I) =PHKT(1,J)
39777 PHKK(2,I) =PHKT(2,J)
39778 PHKK(3,I) =PHKT(3,J)
39779 PHKK(4,I) =PHKT(4,J)
39780 PHKK(5,I) =PHKT(5,J)
39781 VHKK(1,I) =VHKT(1,J)
39782 VHKK(2,I) =VHKT(2,J)
39783 VHKK(3,I) =VHKT(3,J)
39784 VHKK(4,I) =VHKT(4,J)
39785 WHKK(1,I) =WHKT(1,J)
39786 WHKK(2,I) =WHKT(2,J)
39787 WHKK(3,I) =WHKT(3,J)
39788 WHKK(4,I) =WHKT(4,J)
39789 RETURN
39790 END
39791
39792*$ CREATE DT_DBREAK.FOR
39793*COPY DT_DBREAK
39794*
39795*===dbreak=============================================================*
39796*
39797 SUBROUTINE DT_DBREAK(MODE)
39798
39799************************************************************************
39800* This is the steering subroutine for the different diquark breaking *
39801* mechanisms. *
39802* *
39803* MODE = 1 breaking of projectile diquark in qq-q chain using *
39804* a sea quark (q-qq chain) of the same projectile *
39805* = 2 breaking of target diquark in q-qq chain using *
39806* a sea quark (qq-q chain) of the same target *
39807* = 3 breaking of projectile diquark in qq-q chain using *
39808* a sea quark (q-aq chain) of the same projectile *
39809* = 4 breaking of target diquark in q-qq chain using *
39810* a sea quark (aq-q chain) of the same target *
39811* = 5 breaking of projectile anti-diquark in aqaq-aq chain using *
39812* a sea anti-quark (aq-aqaq chain) of the same projectile *
39813* = 6 breaking of target anti-diquark in aq-aqaq chain using *
39814* a sea anti-quark (aqaq-aq chain) of the same target *
39815* = 7 breaking of projectile anti-diquark in aqaq-aq chain using *
39816* a sea anti-quark (aq-q chain) of the same projectile *
39817* = 8 breaking of target anti-diquark in aq-aqaq chain using *
39818* a sea anti-quark (q-aq chain) of the same target *
39819* *
39820* Original version by J. Ranft. *
39821* This version dated 17.5.00 is written by S. Roesler. *
39822************************************************************************
39823
39824 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39825 SAVE
39826 PARAMETER ( LINP = 10 ,
39827 & LOUT = 6 ,
39828 & LDAT = 9 )
39829
39830* event history
39831 PARAMETER (NMXHKK=200000)
39832 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
39833 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
39834 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
39835* extended event history
39836 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
39837 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
39838 & IHIST(2,NMXHKK)
39839* flags for input different options
39840 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
39841 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
39842 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
39843* pointer to chains in hkkevt common (used by qq-breaking mechanisms)
39844 PARAMETER (MAXCHN=10000)
39845 COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
39846* diquark-breaking mechanism
39847 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
39848* flags for particle decays
39849 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
39850 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
39851 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
39852
39853*
39854* chain identifiers
39855* ( 1 = q-aq, 2 = aq-q, 3 = q-qq, 4 = qq-q,
39856* 5 = aq-adq, 6 = adq-aq, 7 = dq-adq, 8 = adq-dq )
39857 DIMENSION IDCHN1(8),IDCHN2(8)
39858 DATA IDCHN1 / 4, 3, 4, 3, 6, 5, 6, 5/
39859 DATA IDCHN2 / 3, 4, 1, 2, 5, 6, 2, 1/
39860*
39861* parton identifiers
39862* ( +-21/22 = valence, +-31/32 = Glauber-sea, +-41/42 = Pomeron (diff),
39863* +-51/52 = unitarity-sea, +-61/62 = gluons )
39864 DIMENSION ISP1P(8,3),ISP1T(8,3),ISP2P(8,3),ISP2T(8,3)
39865 DATA ISP1P / 21, 21, 21, 21, 21, 21, 21, 21,
39866 & 31, 31, 31, 31, 31, 31, 31, 31,
39867 & 41, 41, 41, 41, 51, 51, 51, 51/
39868 DATA ISP1T / 22, 22, 22, 22, 22, 22, 22, 22,
39869 & 32, 32, 32, 32, 32, 32, 32, 32,
39870 & 42, 42, 42, 42, 52, 52, 52, 52/
39871 DATA ISP2P / 31, 21, 31, 31, 21, 21, 21, 21,
39872 & 51, 31, 41, 41, 31, 31, 31, 31,
39873 & 0, 41, 51, 51, 51, 51, 51, 51/
39874 DATA ISP2T / 22, 32, 32, 32, 22, 22, 22, 22,
39875 & 32, 52, 42, 42, 32, 32, 32, 32,
39876 & 42, 0, 52, 52, 52, 52, 52, 52/
39877
39878 IF (NCHAIN.LE.0) RETURN
39879 DO 1 I=1,NCHAIN
39880 IDX1 = IDXCHN(1,I)
39881 IS1P = ABS(ISTHKK(JMOHKK(1,IDX1)))
39882 IS1T = ABS(ISTHKK(JMOHKK(2,IDX1)))
39883 IF ( (IDXCHN(2,I).EQ.IDCHN1(MODE))
39884 & .AND.
39885 & ((IS1P.EQ.ISP1P(MODE,1)).OR.(IS1P.EQ.ISP1P(MODE,2)).OR.
39886 & (IS1P.EQ.ISP1P(MODE,3)))
39887 & .AND.
39888 & ((IS1T.EQ.ISP1T(MODE,1)).OR.(IS1T.EQ.ISP1T(MODE,2)).OR.
39889 & (IS1T.EQ.ISP1T(MODE,3)))
39890 & ) THEN
39891 DO 2 J=1,NCHAIN
39892 IDX2 = IDXCHN(1,J)
39893 IS2P = ABS(ISTHKK(JMOHKK(1,IDX2)))
39894 IS2T = ABS(ISTHKK(JMOHKK(2,IDX2)))
39895 IF ( (IDXCHN(2,J).EQ.IDCHN2(MODE))
39896 & .AND.
39897 & ((IS2P.EQ.ISP2P(MODE,1)).OR.(IS2P.EQ.ISP2P(MODE,2))
39898 & .OR.(IS2P.EQ.ISP2P(MODE,3)))
39899 & .AND.
39900 & ((IS2T.EQ.ISP2T(MODE,1)).OR.(IS2T.EQ.ISP2T(MODE,2))
39901 & .OR.(IS2T.EQ.ISP2T(MODE,3)))
39902 & ) THEN
39903* find mother nucleons of the diquark to be splitted and of the
39904* sea-quark and reject this combination if it is not the same
39905 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.
39906 & (MODE.EQ.5).OR.(MODE.EQ.7)) THEN
39907 IANCES = 1
39908 ELSE
39909 IANCES = 2
39910 ENDIF
39911 IDXMO1 = JMOHKK(IANCES,IDX1)
39912 4 CONTINUE
39913 IF ((JMOHKK(1,IDXMO1).NE.0).AND.
39914 & (JMOHKK(2,IDXMO1).NE.0)) THEN
39915 IANC = IANCES
39916 ELSE
39917 IANC = 1
39918 ENDIF
39919 IF (JMOHKK(IANC,IDXMO1).NE.0) THEN
39920 IDXMO1 = JMOHKK(IANC,IDXMO1)
39921 GOTO 4
39922 ENDIF
39923 IDXMO2 = JMOHKK(IANCES,IDX2)
39924 5 CONTINUE
39925 IF ((JMOHKK(1,IDXMO2).NE.0).AND.
39926 & (JMOHKK(2,IDXMO2).NE.0)) THEN
39927 IANC = IANCES
39928 ELSE
39929 IANC = 1
39930 ENDIF
39931 IF (JMOHKK(IANC,IDXMO2).NE.0) THEN
39932 IDXMO2 = JMOHKK(IANC,IDXMO2)
39933 GOTO 5
39934 ENDIF
39935 IF (IDXMO1.NE.IDXMO2) GOTO 2
39936* quark content of projectile parton
39937 IP1 = IDHKK(JMOHKK(1,IDX1))
39938 IP11 = IP1/1000
39939 IP12 = (IP1-1000*IP11)/100
39940 IP2 = IDHKK(JMOHKK(2,IDX1))
39941 IP21 = IP2/1000
39942 IP22 = (IP2-1000*IP21)/100
39943* quark content of target parton
39944 IT1 = IDHKK(JMOHKK(1,IDX2))
39945 IT11 = IT1/1000
39946 IT12 = (IT1-1000*IT11)/100
39947 IT2 = IDHKK(JMOHKK(2,IDX2))
39948 IT21 = IT2/1000
39949 IT22 = (IT2-1000*IT21)/100
39950* split diquark and form new chains
39951 IF (MODE.EQ.1) THEN
39952 IF (IT1.EQ.4) GOTO 2
39953 CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39954 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39955 & IP11,IP12,IP2,IT1,IT21,IT22,1,IPQ,IGCOUN)
39956 ELSEIF (MODE.EQ.2) THEN
39957 IF (IT2.EQ.4) GOTO 2
39958 CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39959 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39960 & IP1,IP21,IP22,IT11,IT12,IT2,1,IPQ,IGCOUN)
39961 ELSEIF (MODE.EQ.3) THEN
39962 IF (IT1.EQ.4) GOTO 2
39963 CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39964 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39965 & IP11,IP12,IP2,IT1,IT2,1,IPQ,IGCOUN)
39966 ELSEIF (MODE.EQ.4) THEN
39967 IF (IT2.EQ.4) GOTO 2
39968 CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39969 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39970 & IP1,IP21,IP22,IT1,IT2,1,IPQ,IGCOUN)
39971 ELSEIF (MODE.EQ.5) THEN
39972 CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39973 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39974 & IP11,IP12,IP2,IT1,IT21,IT22,2,IPQ,IGCOUN)
39975 ELSEIF (MODE.EQ.6) THEN
39976 CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39977 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39978 & IP1,IP21,IP22,IT11,IT12,IT2,2,IPQ,IGCOUN)
39979 ELSEIF (MODE.EQ.7) THEN
39980 CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39981 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39982 & IP11,IP12,IP2,IT1,IT2,2,IPQ,IGCOUN)
39983 ELSEIF (MODE.EQ.8) THEN
39984 CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39985 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39986 & IP1,IP21,IP22,IT1,IT2,2,IPQ,IGCOUN)
39987 ENDIF
39988 IF (IREJ.GE.1) THEN
39989 if ((ipq.lt.0).or.(ipq.ge.4))
39990 & write(LOUT,*) 'ipq !!!',ipq,mode
39991 DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
39992* accept or reject new chains corresponding to PDBSEA
39993 ELSE
39994 IF ((IPQ.EQ.1).OR.(IPQ.EQ.2)) THEN
39995 ACC = DBRKA(1,MODE)+DBRKA(2,MODE)
39996 REJ = DBRKR(1,MODE)+DBRKR(2,MODE)
39997 ELSEIF (IPQ.EQ.3) THEN
39998 ACC = DBRKA(3,MODE)
39999 REJ = DBRKR(3,MODE)
40000 ELSE
40001 WRITE(LOUT,*) ' inconsistent IPQ ! ',IPQ
40002 STOP
40003 ENDIF
40004 IF (ACC/(ACC+REJ).LE.PDBSEA(IPQ)) THEN
40005 DBRKA(IPQ,MODE) = DBRKA(IPQ,MODE)+1.0D0
40006 IACC = 1
40007 ELSE
40008 DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
40009 IACC = 0
40010 ENDIF
40011* new chains have been accepted and are now copied into HKKEVT
40012 IF (IACC.EQ.1) THEN
40013 IF (LEMCCK) THEN
40014 CALL DT_EVTEMC(PHKK(1,IDX1),PHKK(2,IDX1),
40015 & PHKK(3,IDX1),PHKK(4,IDX1),
40016 & 1,IDUM1,IDUM2)
40017 CALL DT_EVTEMC(PHKK(1,IDX2),PHKK(2,IDX2),
40018 & PHKK(3,IDX2),PHKK(4,IDX2),
40019 & 2,IDUM1,IDUM2)
40020 ENDIF
40021 IDHKK(IDX1) = 99888
40022 IDHKK(IDX2) = 99888
40023 IDXCHN(2,I) = -1
40024 IDXCHN(2,J) = -1
40025 DO 3 K=1,IGCOUN
40026 NHKK = NHKK+1
40027 CALL HKKHKT(NHKK,K)
40028 IF ((LEMCCK).AND.(IDHKK(NHKK).EQ.88888))THEN
40029 PX = -PHKK(1,NHKK)
40030 PY = -PHKK(2,NHKK)
40031 PZ = -PHKK(3,NHKK)
40032 PE = -PHKK(4,NHKK)
40033 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
40034 ENDIF
40035 3 CONTINUE
40036 IF (LEMCCK) THEN
40037 CHKLEV = 0.1D0
40038 CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,9000,
40039 & IREJ)
40040 IF (IREJ.NE.0) CALL DT_EVTOUT(4)
40041 ENDIF
40042 GOTO 1
40043 ENDIF
40044 ENDIF
40045 ENDIF
40046 2 CONTINUE
40047 ENDIF
40048 1 CONTINUE
40049 RETURN
40050 END
40051
40052*$ CREATE DT_CQPAIR.FOR
40053*COPY DT_CQPAIR
40054*
40055*===cqpair=============================================================*
40056*
40057 SUBROUTINE DT_CQPAIR(XQMAX,XAQMAX,XQ,XAQ,IFLV,IREJ)
40058
40059************************************************************************
40060* This subroutine Creates a Quark-antiquark PAIR from the sea. *
40061* *
40062* XQMAX maxium energy fraction of quark (input) *
40063* XAQMAX maxium energy fraction of antiquark (input) *
40064* XQ energy fraction of quark (output) *
40065* XAQ energy fraction of antiquark (output) *
40066* IFLV quark flavour (- antiquark flavor) (output) *
40067* *
40068* This version dated 14.5.00 is written by S. Roesler. *
40069************************************************************************
40070
40071 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
40072 SAVE
40073 PARAMETER ( LINP = 10 ,
40074 & LOUT = 6 ,
40075 & LDAT = 9 )
40076
40077* Lorentz-parameters of the current interaction
40078 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
40079 & UMO,PPCM,EPROJ,PPROJ
40080
40081*
40082 IREJ = 0
40083 XQ = 0.0D0
40084 XAQ = 0.0D0
40085*
40086* sample quark flavour
40087*
40088* set seasq here (the one from DTCHAI should be used in the future)
40089 SEASQ = 0.5D0
40090 IFLV = INT(1.0D0+DT_RNDM(XQMAX)*(2.0D0+SEASQ))
40091*
40092* sample energy fractions of sea pair
40093* we first sample the energy fraction of a gluon and then split the gluon
40094*
40095* maximum energy fraction of the gluon forced via input
40096 XGMAXI = XQMAX+XAQMAX
40097* minimum energy fraction of the gluon
40098 XTHR1 = 4.0D0 /UMO**2
40099 XTHR2 = 0.54D0/UMO**1.5D0
40100 XGMIN = MAX(XTHR1,XTHR2)
40101* maximum energy fraction of the gluon
40102 XGMAX = 0.3D0
40103 XGMAX = MIN(XGMAXI,XGMAX)
40104 IF (XGMIN.GE.XGMAX) THEN
40105 IREJ = 1
40106 RETURN
40107 ENDIF
40108*
40109* sample energy fraction of the gluon
40110 NLOOP = 0
40111 1 CONTINUE
40112 NLOOP = NLOOP+1
40113 IF (NLOOP.GE.50) THEN
40114 IREJ = 1
40115 RETURN
40116 ENDIF
40117 XGLUON = DT_SAMSQX(XGMIN,XGMAX)
40118 EGLUON = XGLUON*UMO/2.0D0
40119*
40120* split gluon into q-aq pair (we follow PHOJET's subroutine PHO_GLU2QU)
40121 ZMIN = MIN(0.1D0,0.5D0/EGLUON)
40122 ZMAX = 1.0D0-ZMIN
40123 RZ = DT_RNDM(ZMAX)
40124 XHLP = ((1.0D0-RZ)*ZMIN**3+RZ*ZMAX**3)**0.33333
40125 RQ = DT_RNDM(ZMAX)
40126 IF (RQ.LT.0.5D0) THEN
40127 XQ = XGLUON*XHLP
40128 XAQ = XGLUON-XQ
40129 ELSE
40130 XAQ = XGLUON*XHLP
40131 XQ = XGLUON-XAQ
40132 ENDIF
40133 IF ((XQ.GT.XQMAX).OR.(XAQ.GT.XAQMAX)) GOTO 1
40134
40135 RETURN
40136 END