]> 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
Extra header added to the list
[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
e3f546f5 2206 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
2207 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
2208 & NCP,NCT
9aaba0d6 2209
2210 DIMENSION WHAT(6)
2211
2212 IREJ = 0
2213 ILOOP = 0
09b429a4 2214 NSD1 = 0
2215 NSD2 = 0
2216 NDD = 0
9aaba0d6 2217 100 CONTINUE
2218 IF (ILOOP.EQ.4) THEN
2219 WRITE(LOUT,1000) NEVHKK
2220 1000 FORMAT(1X,'KKINC: event ',I8,' rejected!')
2221 GOTO 9999
2222 ENDIF
2223 ILOOP = ILOOP+1
2224
2225* variable energy-runs, recalculate parameters for LT's
2226 IF ((ABS(VAREHI).GT.ZERO).OR.(IOGLB.EQ.100)) THEN
2227 PDUM = ZERO
2228 CDUM = ZERO
2229 CALL DT_LTINI(IDP,1,EPN,PDUM,CDUM,1)
2230 ENDIF
2231 IF (EPN.GT.EPROJ) THEN
2232 WRITE(LOUT,'(A,E9.3,2A,E9.3,A)')
2233 & ' Requested energy (',EPN,'GeV) exceeds',
2234 & ' initialization energy (',EPROJ,'GeV) !'
2235 STOP
2236 ENDIF
2237
2238* re-initialize /DTPRTA/
2239 IP = NPMASS
2240 IPZ = NPCHAR
2241 IT = NTMASS
2242 ITZ = NTCHAR
2243 IJPROJ = IDP
2244 IBPROJ = IIBAR(IJPROJ)
2245
2246* calculate nuclear potentials (common /DTNPOT/)
2247 CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
2248
2249* initialize treatment for residual nuclei
2250 CALL DT_RESNCL(EPN,NLOOP,1)
2251
2252* sample hadron/nucleus-nucleus interaction
2253 CALL DT_KKEVNT(KKMAT,IREJ1)
2254 IF (IREJ1.GT.0) THEN
2255 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKINC'
2256 GOTO 9999
2257 ENDIF
2258
2259 IF ((NPMASS.GT.1).OR.(NTMASS.GT.1)) THEN
2260
2261* intranuclear cascade of final state particles for KTAUGE generations
2262* of secondaries
2263 CALL DT_FOZOCA(LFZC,IREJ1)
2264 IF (IREJ1.GT.0) THEN
2265 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKINC'
2266 GOTO 9999
2267 ENDIF
2268
2269* baryons unable to escape the nuclear potential are treated as
2270* excited nucleons (ISTHKK=15,16)
2271 CALL DT_SCN4BA
2272
2273* decay of resonances produced in intranuclear cascade processes
2274**sr 15-11-95 should be obsolete
2275C IF (LFZC) CALL DT_DECAY1
2276
2277 101 CONTINUE
2278* treatment of residual nuclei
2279 CALL DT_RESNCL(EPN,NLOOP,2)
2280
2281* evaporation / fission / fragmentation
2282* (if intranuclear cascade was sampled only)
2283 IF (LFZC) THEN
2284 CALL DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ1)
2285 IF (IREJ1.GT.1) GOTO 101
2286 IF (IREJ1.EQ.1) GOTO 100
2287 ENDIF
2288
2289 ENDIF
2290
2291* rejection of unphysical configurations
2292 CALL DT_REJUCO(1,IREJ1)
2293 IF (IREJ1.GT.0) THEN
2294 IF (IOULEV(1).GT.0)
2295 & WRITE(LOUT,*) 'rejected 3 in KKINC: too large x'
2296 GOTO 100
2297 ENDIF
2298
2299* transform finale state into Lab.
2300 IFLAG = 2
2301 CALL DT_BEAMPR(WHAT,DUM,IFLAG)
2302 IF ((IFRAME.EQ.1).AND.(IFLAG.EQ.-1)) CALL DT_LT2LAB
2303
2304 IF (IPI0.EQ.1) CALL DT_DECPI0
2305
2306C IF (NEVHKK.EQ.5) CALL DT_EVTOUT(4)
9aaba0d6 2307 RETURN
e3f546f5 2308
9aaba0d6 2309 9999 CONTINUE
2310 IREJ = 1
09b429a4 2311
9aaba0d6 2312 RETURN
2313 END
2314
2315*$ CREATE DT_DEFAUL.FOR
2316*COPY DT_DEFAUL
2317*
2318*===defaul=============================================================*
2319*
2320 SUBROUTINE DT_DEFAUL(EPN,PPN)
2321
2322************************************************************************
2323* Variables are set to default values. *
2324* This version dated 8.5.95 is written by S. Roesler. *
2325************************************************************************
2326
2327 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2328 SAVE
2329 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
2330 PARAMETER (TWOPI = 6.283185307179586454D+00)
2331
2332* particle properties (BAMJET index convention)
2333 CHARACTER*8 ANAME
2334 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2335 & IICH(210),IIBAR(210),K1(210),K2(210)
2336* nuclear potential
2337 LOGICAL LFERMI
2338 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
2339 & EBINDP(2),EBINDN(2),EPOT(2,210),
2340 & ETACOU(2),ICOUL,LFERMI
2341* interface HADRIN-DPM
2342 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
2343* central particle production, impact parameter biasing
2344 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
2345* properties of interacting particles
2346 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2347* properties of photon/lepton projectiles
2348 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
2349 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2350* emulsion treatment
2351 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2352 & NCOMPO,IEMUL
2353* parameter for intranuclear cascade
2354 LOGICAL LPAULI
2355 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
2356* various options for treatment of partons (DTUNUC 1.x)
2357* (chain recombination, Cronin,..)
2358 LOGICAL LCO2CR,LINTPT
2359 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
2360 & LCO2CR,LINTPT
2361* threshold values for x-sampling (DTUNUC 1.x)
2362 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
2363 & SSMIMQ,VVMTHR
2364* flags for input different options
2365 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2366 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2367 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2368* n-n cross section fluctuations
2369 PARAMETER (NBINS = 1000)
2370 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
2371* flags for particle decays
2372 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
2373 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
2374 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
2375* diquark-breaking mechanism
2376 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
2377* nucleon-nucleon event-generator
2378 CHARACTER*8 CMODEL
2379 LOGICAL LPHOIN
2380 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
2381* flags for diffractive interactions (DTUNUC 1.x)
2382 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
2383* VDM parameter for photon-nucleus interactions
2384 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
2385* Glauber formalism: flags and parameters for statistics
2386 LOGICAL LPROD
2387 CHARACTER*8 CGLB
2388 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
2389* kinematical cuts for lepton-nucleus interactions
2390 COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
2391 & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
2392* flags for activated histograms
2393 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
2394* cuts for variable energy runs
2395 COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
2396* parameters for hA-diffraction
2397 COMMON /DTDIHA/ DIBETA,DIALPH
2398* LEPTO
2399 REAL RPPN
2400 COMMON /LEPTOI/ RPPN,LEPIN,INTER
2401* steering flags for qel neutrino scattering modules
2402 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
2403* event flag
2404 COMMON /DTEVNO/ NEVENT,ICASCA
2405
2406 DATA POTMES /0.002D0/
2407
2408* common /DTNPOT/
2409 DO 10 I=1,2
2410 PFERMP(I) = ZERO
2411 PFERMN(I) = ZERO
2412 EBINDP(I) = ZERO
2413 EBINDN(I) = ZERO
2414 DO 11 J=1,210
2415 EPOT(I,J) = ZERO
2416 11 CONTINUE
2417* nucleus independent meson potential
2418 EPOT(I,13) = POTMES
2419 EPOT(I,14) = POTMES
2420 EPOT(I,15) = POTMES
2421 EPOT(I,16) = POTMES
2422 EPOT(I,23) = POTMES
2423 EPOT(I,24) = POTMES
2424 EPOT(I,25) = POTMES
2425 10 CONTINUE
2426 FERMOD = 0.55D0
2427 ETACOU(1) = ZERO
2428 ETACOU(2) = ZERO
2429 ICOUL = 1
2430 LFERMI = .TRUE.
2431
2432* common /HNTHRE/
2433 EHADTH = -99.0D0
2434 EHADLO = 4.06D0
2435 EHADHI = 6.0D0
2436 INTHAD = 1
2437 IDXTA = 2
2438
2439* common /DTIMPA/
2440 ICENTR = 0
2441 BIMIN = ZERO
2442 BIMAX = 1.0D10
2443 XSFRAC = 1.0D0
2444
2445* common /DTPRTA/
2446 IP = 1
2447 IPZ = 1
2448 IT = 1
2449 ITZ = 1
2450 IJPROJ = 1
2451 IBPROJ = 1
2452 IJTARG = 1
2453 IBTARG = 1
2454* common /DTGPRO/
2455 VIRT = ZERO
2456 DO 14 I=1,4
2457 PGAMM(I) = ZERO
2458 PLEPT0(I) = ZERO
2459 PLEPT1(I) = ZERO
2460 PNUCL(I) = ZERO
2461 14 CONTINUE
2462 IDIREC = 0
2463
2464* common /DTFOTI/
2465**sr 7.4.98: changed after corrected B-sampling
2466C TAUFOR = 4.4D0
2467 TAUFOR = 3.5D0
2468 KTAUGE = 25
2469 ITAUVE = 1
2470 INCMOD = 1
2471 LPAULI = .TRUE.
2472
2473* common /DTCHAI/
2474 SEASQ = ONE
2475 MKCRON = 1
2476 CRONCO = 0.64D0
2477 ISICHA = 0
2478 CUTOF = 100.0D0
2479 LCO2CR = .FALSE.
2480 IRECOM = 1
2481 LINTPT = .TRUE.
2482
2483* common /DTXCUT/
2484* definition of soft quark distributions
2485 XSEACU = 0.05D0
2486 UNON = 2.0D0
2487 UNOM = 1.5D0
2488 UNOSEA = 5.0D0
2489* cutoff parameters for x-sampling
2490 CVQ = 1.0D0
2491 CDQ = 2.0D0
2492C CSEA = 0.3D0
2493 CSEA = 0.1D0
2494 SSMIMA = 1.2D0
2495 SSMIMQ = SSMIMA**2
2496 VVMTHR = 2.0D0
2497
2498* common /DTXSFL/
2499 IFLUCT = 0
2500
2501* common /DTFRPA/
2502 PDB = 0.15D0
2503 PDBSEA(1) = 0.0D0
2504 PDBSEA(2) = 0.0D0
2505 PDBSEA(3) = 0.0D0
2506 ISIG0 = 0
2507 IPI0 = 0
2508 NMSTU = 0
2509 NPARU = 0
2510 NMSTJ = 0
2511 NPARJ = 0
2512
2513* common /DTDIQB/
2514 DO 15 I=1,8
2515 DBRKR(1,I) = 5.0D0
2516 DBRKR(2,I) = 5.0D0
2517 DBRKR(3,I) = 10.0D0
2518 DBRKA(1,I) = ZERO
2519 DBRKA(2,I) = ZERO
2520 DBRKA(3,I) = ZERO
2521 15 CONTINUE
2522 CHAM1 = 0.2D0
2523 CHAM3 = 0.5D0
2524 CHAB1 = 0.7D0
2525 CHAB3 = 1.0D0
2526
2527* common /DTFLG3/
2528 ISINGD = 0
2529 IDOUBD = 0
2530 IFLAGD = 0
2531 IDIFF = 0
2532
2533* common /DTMODL/
2534 MCGENE = 2
2535 CMODEL(1) = 'DTUNUC '
2536 CMODEL(2) = 'PHOJET '
2537 CMODEL(3) = 'LEPTO '
2538 CMODEL(4) = 'QNEUTRIN'
2539 LPHOIN = .TRUE.
2540 ELOJET = 5.0D0
2541
2542* common /DTLCUT/
2543 ECMIN = 3.5D0
2544 ECMAX = 1.0D10
2545 XBJMIN = ZERO
2546 ELMIN = ZERO
2547 EGMIN = ZERO
2548 EGMAX = 1.0D10
2549 YMIN = TINY10
2550 YMAX = 0.999D0
2551 Q2MIN = TINY10
2552 Q2MAX = 10.0D0
2553 THMIN = ZERO
2554 THMAX = TWOPI
2555 Q2LI = ZERO
2556 Q2HI = 1.0D10
2557 ECMLI = ZERO
2558 ECMHI = 1.0D10
2559
2560* common /DTVDMP/
2561 RL2 = 2.0D0
2562 INTRGE(1) = 1
2563 INTRGE(2) = 3
2564 IDPDF = 2212
2565 MODEGA = 4
2566 ISHAD(1) = 1
2567 ISHAD(2) = 1
2568 ISHAD(3) = 1
2569 EPSPOL = ZERO
2570
2571* common /DTGLGP/
2572 JSTATB = 1000
2573 JBINSB = 49
2574 CGLB = ' '
2575 IF (ITRSPT.EQ.1) THEN
2576 IOGLB = 100
2577 ELSE
2578 IOGLB = 0
2579 ENDIF
2580 LPROD = .TRUE.
2581
2582* common /DTHIS3/
2583 DO 16 I=1,50
2584 IHISPP(I) = 0
2585 IHISXS(I) = 0
2586 16 CONTINUE
2587 IXSTBL = 0
2588
2589* common /DTVARE/
2590 VARELO = ZERO
2591 VAREHI = ZERO
2592 VARCLO = ZERO
2593 VARCHI = ZERO
2594
2595* common /DTDIHA/
2596 DIBETA = -1.0D0
2597 DIALPH = ZERO
2598
2599* common /LEPTOI/
2600 RPPN = 0.0
2601 LEPIN = 0
2602 INTER = 0
2603
2604* common /QNEUTO/
2605 NEUTYP = 1
2606 NEUDEC = 0
2607
2608* common /DTEVNO/
2609 NEVENT = 1
2610 IF (ITRSPT.EQ.1) THEN
2611 ICASCA = 1
2612 ELSE
2613 ICASCA = 0
2614 ENDIF
2615
2616* default Lab.-energy
2617 EPN = 200.0D0
2618 PPN = SQRT((EPN-AAM(IJPROJ))*(EPN+AAM(IJPROJ)))
2619
2620 RETURN
2621 END
2622
2623*$ CREATE DT_AAEVT.FOR
2624*COPY DT_AAEVT
2625*
2626*===aaevt==============================================================*
2627*
2628 SUBROUTINE DT_AAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
2629 & IDP,IGLAU)
2630
2631************************************************************************
2632* This version dated 22.03.96 is written by S. Roesler. *
2633************************************************************************
2634
2635 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2636 SAVE
2637 PARAMETER ( LINP = 10 ,
2638 & LOUT = 6 ,
2639 & LDAT = 9 )
2640
2641 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2642* emulsion treatment
2643 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2644 & NCOMPO,IEMUL
2645* event flag
2646 COMMON /DTEVNO/ NEVENT,ICASCA
9aaba0d6 2647 CHARACTER*8 DATE,HHMMSS
2648 DIMENSION IDMNYR(3)
09b429a4 2649 NSD1 = 0
2650 NSD2 = 0
2651 NDD = 0
9aaba0d6 2652 KKMAT = 1
2653 NMSG = MAX(NEVTS/100,1)
2654
2655* initialization of run-statistics and histograms
2656 CALL DT_STATIS(1)
2657 CALL PHO_PHIST(1000,DUM)
2658
2659* initialization of Glauber-formalism
2660 IF (NCOMPO.LE.0) THEN
2661 CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
2662 ELSE
2663 DO 1 I=1,NCOMPO
2664 CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
2665 1 CONTINUE
2666 ENDIF
2667 CALL DT_SIGEMU
2668
2669 CALL IDATE(IDMNYR)
2670 WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2671 & IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
2672 CALL ITIME(IDMNYR)
2673 WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)')
2674 & IDMNYR(1),IDMNYR(2),IDMNYR(3)
2675 WRITE(LOUT,1001) DATE,HHMMSS
2676 1001 FORMAT(/,' DT_AAEVT: Initialisation finished. ( Date: ',A8,
2677 & ' Time: ',A8,' )')
2678
2679* generate NEVTS events
2680 DO 2 IEVT=1,NEVTS
2681
2682* print run-status message
2683 IF (MOD(IEVT,NMSG).EQ.0) THEN
2684 CALL IDATE(IDMNYR)
2685 WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2686 & IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
2687 CALL ITIME(IDMNYR)
2688 WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)')
2689 & IDMNYR(1),IDMNYR(2),IDMNYR(3)
2690 WRITE(LOUT,1000) IEVT-1,NEVTS,DATE,HHMMSS
2691 1000 FORMAT(/,1X,I8,' out of ',I8,' events sampled ( Date: ',A,
2692 & ' Time: ',A,' )',/)
2693C WRITE(LOUT,1000) IEVT-1
2694C1000 FORMAT(1X,I8,' events sampled')
2695 ENDIF
2696 NEVENT = IEVT
2697* treat nuclear emulsions
2698 IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
2699* composite targets only
2700 KKMAT = -KKMAT
2701* sample this event
2702 CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,IREJ)
2703
2704 CALL PHO_PHIST(2000,DUM)
09b429a4 2705
2706 write(6,*) "Diffractive collisions", NSD1, NSD2, NDD
9aaba0d6 2707
2708 2 CONTINUE
2709
2710* print run-statistics and histograms to output-unit 6
2711 CALL PHO_PHIST(3000,DUM)
2712 CALL DT_STATIS(2)
9aaba0d6 2713 RETURN
2714 END
2715
2716*$ CREATE DT_LAEVT.FOR
2717*COPY DT_LAEVT
2718*
2719*===laevt==============================================================*
2720*
2721 SUBROUTINE DT_LAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
2722 & IDP,IGLAU)
2723
2724************************************************************************
2725* Interface to run DPMJET for lepton-nucleus interactions. *
2726* Kinematics is sampled using the equivalent photon approximation *
2727* Based on GPHERA-routine by R. Engel. *
2728* This version dated 23.03.96 is written by S. Roesler. *
2729************************************************************************
2730
2731 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2732 SAVE
2733 PARAMETER ( LINP = 10 ,
2734 & LOUT = 6 ,
2735 & LDAT = 9 )
2736 PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,
2737 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
2738 PARAMETER (TWOPI = 6.283185307179586454D+00,
2739 & PI = TWOPI/TWO,
2740 & ALPHEM = ONE/137.0D0)
2741
2742C CHARACTER*72 HEADER
2743
2744* particle properties (BAMJET index convention)
2745 CHARACTER*8 ANAME
2746 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2747 & IICH(210),IIBAR(210),K1(210),K2(210)
2748* event history
2749 PARAMETER (NMXHKK=200000)
2750 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
2751 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
2752 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
2753* extended event history
2754 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
2755 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
2756 & IHIST(2,NMXHKK)
2757* kinematical cuts for lepton-nucleus interactions
2758 COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
2759 & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
2760* properties of interacting particles
2761 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2762* properties of photon/lepton projectiles
2763 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
2764* kinematics at lepton-gamma vertex
2765 COMMON /DTLGVX/ PPL0(4),PPL1(4),PPG(4),PPA(4)
2766* flags for activated histograms
2767 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
2768 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2769* emulsion treatment
2770 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2771 & NCOMPO,IEMUL
2772* Glauber formalism: cross sections
2773 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
2774 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
2775 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
2776 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
2777 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
2778 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
2779 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
2780 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
2781 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
2782 & BSLOPE,NEBINI,NQBINI
2783* nucleon-nucleon event-generator
2784 CHARACTER*8 CMODEL
2785 LOGICAL LPHOIN
2786 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
2787* flags for input different options
2788 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2789 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2790 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2791* event flag
2792 COMMON /DTEVNO/ NEVENT,ICASCA
2793
2794 DIMENSION XDUMB(40),BGTA(4)
2795
2796* LEPTO
2797 IF (MCGENE.EQ.3) THEN
2798 STOP ' This version does not contain LEPTO !'
2799 ENDIF
2800
2801 KKMAT = 1
2802 NMSG = MAX(NEVTS/10,1)
2803
2804* mass of incident lepton
2805 AMLPT = AAM(IDP)
2806 AMLPT2 = AMLPT**2
2807 IDPPDG = IDT_IPDGHA(IDP)
2808
2809* consistency of kinematical limits
2810 Q2MIN = MAX(Q2MIN,TINY10)
2811 Q2MAX = MAX(Q2MAX,TINY10)
2812 YMIN = MIN(MAX(YMIN,TINY10),0.999D0)
2813 YMAX = MIN(MAX(YMAX,TINY10),0.999D0)
2814
2815* total energy of the lepton-nucleon system
2816 PTOTLN = SQRT( (PLEPT0(1)+PNUCL(1))**2+(PLEPT0(2)+PNUCL(2))**2
2817 & +(PLEPT0(3)+PNUCL(3))**2 )
2818 ETOTLN = PLEPT0(4)+PNUCL(4)
2819 ECMLN = SQRT((ETOTLN-PTOTLN)*(ETOTLN+PTOTLN))
2820 ECMAX = MIN(ECMAX,ECMLN)
2821 WRITE(LOUT,1003) ECMIN,ECMAX,YMIN,YMAX,Q2MIN,Q2MAX,EGMIN,
2822 & THMIN,THMAX,ELMIN
2823 1003 FORMAT(1X,'LAEVT:',16X,'kinematical cuts',/,22X,
2824 & '------------------',/,9X,'W (min) =',
2825 & F7.1,' GeV (max) =',F7.1,' GeV',/,9X,'y (min) =',
2826 & F7.3,8X,'(max) =',F7.3,/,9X,'Q^2 (min) =',F7.1,
2827 & ' GeV^2 (max) =',F7.1,' GeV^2',/,' (Lab) E_g (min) ='
2828 & ,F7.1,' GeV',/,' (Lab) theta (min) =',F7.4,8X,'(max) =',
2829 & F7.4,' for E_lpt >',F7.1,' GeV',/)
2830
2831* Lorentz-parameter for transf. into Lab
2832 BGTA(1) = PNUCL(1)/AAM(1)
2833 BGTA(2) = PNUCL(2)/AAM(1)
2834 BGTA(3) = PNUCL(3)/AAM(1)
2835 BGTA(4) = PNUCL(4)/AAM(1)
2836* LT of incident lepton into Lab and dump it in DTEVT1
2837 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
2838 & PLEPT0(1),PLEPT0(2),PLEPT0(3),PLEPT0(4),
2839 & PLTOT,PPL0(1),PPL0(2),PPL0(3),PPL0(4))
2840 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
2841 & PNUCL(1),PNUCL(2),PNUCL(3),PNUCL(4),
2842 & PLTOT,PPA(1),PPA(2),PPA(3),PPA(4))
2843* maximum energy of photon nucleon system
2844 PTOTGN = SQRT((YMAX*PPL0(1)+PPA(1))**2+(YMAX*PPL0(2)+PPA(2))**2
2845 & +(YMAX*PPL0(3)+PPA(3))**2)
2846 ETOTGN = YMAX*PPL0(4)+PPA(4)
2847 EGNMAX = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN))
2848 EGNMAX = MIN(EGNMAX,ECMAX)
2849* minimum energy of photon nucleon system
2850 PTOTGN = SQRT((YMIN*PPL0(1)+PPA(1))**2+(YMIN*PPL0(2)+PPA(2))**2
2851 & +(YMIN*PPL0(3)+PPA(3))**2)
2852 ETOTGN = YMIN*PPL0(4)+PPA(4)
2853 EGNMIN = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN))
2854 EGNMIN = MAX(EGNMIN,ECMIN)
2855
2856* limits for Glauber-initialization
2857 Q2LI = Q2MIN
2858 Q2HI = MAX(Q2LI,MIN(Q2HI,Q2MAX))
2859 ECMLI = MAX(EGNMIN,THREE)
2860 ECMHI = EGNMAX
2861 WRITE(LOUT,1004) EGNMIN,EGNMAX,ECMLI,ECMHI,Q2LI,Q2HI
2862 1004 FORMAT(1X,'resulting limits:',/,9X,'W (min) =',F7.1,
2863 & ' GeV (max) =',F7.1,' GeV',/,/,' limits for ',
2864 & 'Glauber-initialization:',/,9X,'W (min) =',F7.1,
2865 & ' GeV (max) =',F7.1,' GeV',/,9X,'Q^2 (min) =',F7.1,
2866 & ' GeV^2 (max) =',F7.1,' GeV^2',/)
2867* initialization of Glauber-formalism
2868 IF (NCOMPO.LE.0) THEN
2869 CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
2870 ELSE
2871 DO 9 I=1,NCOMPO
2872 CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
2873 9 CONTINUE
2874 ENDIF
2875 CALL DT_SIGEMU
2876
2877* initialization of run-statistics and histograms
2878 CALL DT_STATIS(1)
2879 CALL PHO_PHIST(1000,DUM)
2880
2881* maximum photon-nucleus cross section
2882 I1 = 1
2883 I2 = 1
2884 RAT = ONE
2885 IF (EGNMAX.GE.ECMNN(NEBINI)) THEN
2886 I1 = NEBINI
2887 I2 = NEBINI
2888 RAT = ONE
2889 ELSEIF (EGNMAX.GT.ECMNN(1)) THEN
2890 DO 5 I=2,NEBINI
2891 IF (EGNMAX.LT.ECMNN(I)) THEN
2892 I1 = I-1
2893 I2 = I
2894 RAT = (EGNMAX-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
2895 GOTO 6
2896 ENDIF
2897 5 CONTINUE
2898 6 CONTINUE
2899 ENDIF
2900 SIGMAX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
2901 EGNXX = EGNMAX
2902 I1 = 1
2903 I2 = 1
2904 RAT = ONE
2905 IF (EGNMIN.GE.ECMNN(NEBINI)) THEN
2906 I1 = NEBINI
2907 I2 = NEBINI
2908 RAT = ONE
2909 ELSEIF (EGNMIN.GT.ECMNN(1)) THEN
2910 DO 7 I=2,NEBINI
2911 IF (EGNMIN.LT.ECMNN(I)) THEN
2912 I1 = I-1
2913 I2 = I
2914 RAT = (EGNMIN-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
2915 GOTO 8
2916 ENDIF
2917 7 CONTINUE
2918 8 CONTINUE
2919 ENDIF
2920 SIGXX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
2921 IF (SIGXX.GT.SIGMAX) EGNXX = EGNMIN
2922 SIGMAX = MAX(SIGMAX,SIGXX)
2923 WRITE(LOUT,'(9X,A,F8.3,A)') 'Sigma_tot (max) =',SIGMAX,' mb'
2924
2925* plot photon flux table
2926 AYMIN = LOG(YMIN)
2927 AYMAX = LOG(YMAX)
2928 AYRGE = AYMAX-AYMIN
2929 MAXTAB = 50
2930 ADY = LOG(YMAX/YMIN)/DBLE(MAXTAB-1)
2931C WRITE(LOUT,'(/,1X,A)') 'LAEVT: photon flux '
2932 DO 1 I=1,MAXTAB
2933 Y = EXP(AYMIN+ADY*DBLE(I-1))
2934 Q2LOW = MAX(Q2MIN,AMLPT2*Y**2/(ONE-Y))
2935 FF1 = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
2936 & -TWO*AMLPT2*Y*(ONE/Q2LOW-ONE/Q2MAX))
2937 FF2 = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
2938 & -TWO*(ONE-Y)/Y*(ONE-Q2LOW/Q2MAX))
2939C WRITE(LOUT,'(5X,3E15.4)') Y,FF1,FF2
2940 1 CONTINUE
2941
2942* maximum residual weight for flux sampling (dy/y)
2943 YY = YMIN
2944 Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY))
2945 WGHMAX = (ONE+(ONE-YY)**2)*LOG(Q2MAX/Q2LOW)
2946 & -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY
2947
2948 CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY0)
2949 CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY1)
2950 CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY2)
2951 CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ0)
2952 CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ1)
2953 CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ2)
2954 CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE0)
2955 CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE1)
2956 CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE2)
2957 CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU0)
2958 CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU1)
2959 CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU2)
2960 XBLOW = 0.001D0
2961 CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX0)
2962 CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX1)
2963 CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX2)
2964
2965 ITRY = 0
2966 ITRW = 0
2967 NC0 = 0
2968 NC1 = 0
2969
2970* generate events
2971 DO 2 IEVT=1,NEVTS
2972 IF (MOD(IEVT,NMSG).EQ.0) THEN
2973C OPEN(LDAT,FILE='/scrtch3/hr/sroesler/statusd5.out',
2974C & STATUS='UNKNOWN')
2975 WRITE(LOUT,'(1X,I8,A)') IEVT-1,' events sampled'
2976C CLOSE(LDAT)
2977 ENDIF
2978 NEVENT = IEVT
2979
2980 100 CONTINUE
2981 ITRY = ITRY+1
2982
2983* sample y
2984 101 CONTINUE
2985 ITRW = ITRW+1
2986 YY = EXP(AYRGE*DT_RNDM(RAT)+AYMIN)
2987 Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY))
2988 Q2LOG = LOG(Q2MAX/Q2LOW)
2989 WGH = (ONE+(ONE-YY)**2)*Q2LOG
2990 & -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY
2991 IF (WGHMAX.LT.WGH) WRITE(LOUT,1000) YY,WGHMAX,WGH
2992 1000 FORMAT(1X,'LAEVT: weight error!',3E12.5)
2993 IF (DT_RNDM(YY)*WGHMAX.GT.WGH) GOTO 101
2994
2995* sample Q2
2996 YEFF = ONE+(ONE-YY)**2
2997 102 CONTINUE
2998 Q2 = Q2LOW*EXP(Q2LOG*DT_RNDM(YY))
2999 WGH = (YEFF-TWO*(ONE-YY)*Q2LOW/Q2)/YEFF
3000 IF (WGH.LT.DT_RNDM(Q2)) GOTO 102
3001
3002c NC0 = NC0+1
3003c CALL DT_FILHGR(YY,ONE,IHFLY0,NC0)
3004c CALL DT_FILHGR(Q2,ONE,IHFLQ0,NC0)
3005
3006* kinematics at lepton-photon vertex
3007* scattered electron
3008 YQ2 = SQRT((ONE-YY)*Q2)
3009 Q2E = Q2/(4.0D0*PLEPT0(4))
3010 E1Y = (ONE-YY)*PLEPT0(4)
3011 CALL DT_DSFECF(SIF,COF)
3012 PLEPT1(1) = YQ2*COF
3013 PLEPT1(2) = YQ2*SIF
3014 PLEPT1(3) = E1Y-Q2E
3015 PLEPT1(4) = E1Y+Q2E
3016C THETA = ACOS( (E1Y-Q2E)/(E1Y+Q2E) )
3017* radiated photon
3018 PGAMM(1) = -PLEPT1(1)
3019 PGAMM(2) = -PLEPT1(2)
3020 PGAMM(3) = PLEPT0(3)-PLEPT1(3)
3021 PGAMM(4) = PLEPT0(4)-PLEPT1(4)
3022* E_cm cut
3023 PTOTGN = SQRT( (PGAMM(1)+PNUCL(1))**2+(PGAMM(2)+PNUCL(2))**2
3024 & +(PGAMM(3)+PNUCL(3))**2 )
3025 ETOTGN = PGAMM(4)+PNUCL(4)
3026 ECMGN = (ETOTGN-PTOTGN)*(ETOTGN+PTOTGN)
3027 IF (ECMGN.LT.0.1D0) GOTO 101
3028 ECMGN = SQRT(ECMGN)
3029 IF ((ECMGN.LT.ECMIN).OR.(ECMGN.GT.ECMAX)) GOTO 101
3030
3031* Lorentz-transformation into nucleon-rest system
3032 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3033 & PGAMM(1),PGAMM(2),PGAMM(3),PGAMM(4),
3034 & PGTOT,PPG(1),PPG(2),PPG(3),PPG(4))
3035 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3036 & PLEPT1(1),PLEPT1(2),PLEPT1(3),PLEPT1(4),
3037 & PLTOT,PPL1(1),PPL1(2),PPL1(3),PPL1(4))
3038* temporary checks..
3039 Q2TMP = ABS(PPG(4)**2-PGTOT**2)
3040 IF (ABS(Q2-Q2TMP).GT.0.01D0) WRITE(LOUT,1001) Q2,Q2TMP
3041 1001 FORMAT(1X,'LAEVT: inconsistent kinematics (Q2,Q2TMP) ',
3042 & 2F10.4)
3043 ECMTMP = SQRT((PPG(4)+AAM(1)-PGTOT)*(PPG(4)+AAM(1)+PGTOT))
3044 IF (ABS(ECMGN-ECMTMP).GT.TINY10) WRITE(LOUT,1002) ECMGN,ECMTMP
3045 1002 FORMAT(1X,'LAEVT: inconsistent kinematics (ECMGN,ECMTMP) ',
3046 & 2F10.2)
3047 YYTMP = PPG(4)/PPL0(4)
3048 IF (ABS(YY-YYTMP).GT.0.01D0) WRITE(LOUT,1005) YY,YYTMP
3049 1005 FORMAT(1X,'LAEVT: inconsistent kinematics (YY,YYTMP) ',
3050 & 2F10.4)
3051
3052* lepton tagger (Lab)
3053 THETA = ACOS( PPL1(3)/PLTOT )
3054 IF (PPL1(4).GT.ELMIN) THEN
3055 IF ((THETA.LT.THMIN).OR.(THETA.GT.THMAX)) GOTO 101
3056 ENDIF
3057* photon energy-cut (Lab)
3058 IF (PPG(4).LT.EGMIN) GOTO 101
3059 IF (PPG(4).GT.EGMAX) GOTO 101
3060* x_Bj cut
3061 XBJ = ABS(Q2/(1.876D0*PPG(4)))
3062 IF (XBJ.LT.XBJMIN) GOTO 101
3063
3064 NC0 = NC0+1
3065 CALL DT_FILHGR( Q2,ONE,IHFLQ0,NC0)
3066 CALL DT_FILHGR( YY,ONE,IHFLY0,NC0)
3067 CALL DT_FILHGR( XBJ,ONE,IHFLX0,NC0)
3068 CALL DT_FILHGR(PPG(4),ONE,IHFLU0,NC0)
3069 CALL DT_FILHGR( ECMGN,ONE,IHFLE0,NC0)
3070
3071* rotation angles against z-axis
3072 COD = PPG(3)/PGTOT
3073C SID = SQRT((ONE-COD)*(ONE+COD))
3074 PPT = SQRT(PPG(1)**2+PPG(2)**2)
3075 SID = PPT/PGTOT
3076 COF = ONE
3077 SIF = ZERO
3078 IF (PGTOT*SID.GT.TINY10) THEN
3079 COF = PPG(1)/(SID*PGTOT)
3080 SIF = PPG(2)/(SID*PGTOT)
3081 ANORF = SQRT(COF*COF+SIF*SIF)
3082 COF = COF/ANORF
3083 SIF = SIF/ANORF
3084 ENDIF
3085
3086 IF (IXSTBL.EQ.0) THEN
3087* change to photon projectile
3088 IJPROJ = 7
3089* set virtuality
3090 VIRT = Q2
3091* re-initialize LTs with new kinematics
3092* !!PGAMM ist set in cms (ECMGN) along z
3093 EPN = ZERO
3094 PPN = ZERO
3095 CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,ECMGN,0)
3096* force Lab-system
3097 IFRAME = 1
3098* get emulsion component if requested
3099 IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
3100* convolute with cross section
3101 CALL DT_SIGGAT(Q2LOW,EGNXX,STOTX,KKMAT)
3102 CALL DT_SIGGAT(Q2,ECMGN,STOT,KKMAT)
3103 IF (STOTX.LT.STOT) WRITE(LOUT,'(1X,A,/,6E12.3)')
3104 & 'LAEVT: warning STOTX<STOT ! ',Q2LOW,EGNMAX,STOTX,
3105 & Q2,ECMGN,STOT
3106 IF (DT_RNDM(Q2)*STOTX.GT.STOT) GOTO 100
3107 NC1 = NC1+1
3108 CALL DT_FILHGR( Q2,ONE,IHFLQ1,NC1)
3109 CALL DT_FILHGR( YY,ONE,IHFLY1,NC1)
3110 CALL DT_FILHGR( XBJ,ONE,IHFLX1,NC1)
3111 CALL DT_FILHGR(PPG(4),ONE,IHFLU1,NC1)
3112 CALL DT_FILHGR( ECMGN,ONE,IHFLE1,NC1)
3113* composite targets only
3114 KKMAT = -KKMAT
3115* sample this event
3116 CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IJPROJ,EPN,KKMAT,
3117 & IREJ)
3118* rotate momenta of final state particles back in photon-nucleon syst.
3119 DO 4 I=NPOINT(4),NHKK
3120 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
3121 & (ISTHKK(I).EQ.1001)) THEN
3122 PX = PHKK(1,I)
3123 PY = PHKK(2,I)
3124 PZ = PHKK(3,I)
3125 CALL DT_MYTRAN(1,PX,PY,PZ,COD,SID,COF,SIF,
3126 & PHKK(1,I),PHKK(2,I),PHKK(3,I))
3127 ENDIF
3128 4 CONTINUE
3129 ENDIF
3130
3131 CALL DT_FILHGR( Q2,ONE,IHFLQ2,NC1)
3132 CALL DT_FILHGR( YY,ONE,IHFLY2,NC1)
3133 CALL DT_FILHGR( XBJ,ONE,IHFLX2,NC1)
3134 CALL DT_FILHGR(PPG(4),ONE,IHFLU2,NC1)
3135 CALL DT_FILHGR( ECMGN,ONE,IHFLE2,NC1)
3136
3137* dump this event to histograms
3138 CALL PHO_PHIST(2000,DUM)
3139
3140 2 CONTINUE
3141
3142 WGY = ALPHEM/TWOPI*WGHMAX*DBLE(ITRY)/DBLE(ITRW)
3143 WGY = WGY*LOG(YMAX/YMIN)
3144 WEIGHT = WGY*SIGMAX*DBLE(NEVTS)/DBLE(ITRY)
3145
3146C HEADER = ' LAEVT: Q^2 distribution 0'
3147C CALL DT_OUTHGR(IHFLQ0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3148C HEADER = ' LAEVT: Q^2 distribution 1'
3149C CALL DT_OUTHGR(IHFLQ1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3150C HEADER = ' LAEVT: Q^2 distribution 2'
3151C CALL DT_OUTHGR(IHFLQ2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3152C HEADER = ' LAEVT: y distribution 0'
3153C CALL DT_OUTHGR(IHFLY0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3154C HEADER = ' LAEVT: y distribution 1'
3155C CALL DT_OUTHGR(IHFLY1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3156C HEADER = ' LAEVT: y distribution 2'
3157C CALL DT_OUTHGR(IHFLY2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3158C HEADER = ' LAEVT: x distribution 0'
3159C CALL DT_OUTHGR(IHFLX0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3160C HEADER = ' LAEVT: x distribution 1'
3161C CALL DT_OUTHGR(IHFLX1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3162C HEADER = ' LAEVT: x distribution 2'
3163C CALL DT_OUTHGR(IHFLX2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3164C HEADER = ' LAEVT: E_g distribution 0'
3165C CALL DT_OUTHGR(IHFLU0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3166C HEADER = ' LAEVT: E_g distribution 1'
3167C CALL DT_OUTHGR(IHFLU1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3168C HEADER = ' LAEVT: E_g distribution 2'
3169C CALL DT_OUTHGR(IHFLU2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3170C HEADER = ' LAEVT: E_c distribution 0'
3171C CALL DT_OUTHGR(IHFLE0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3172C HEADER = ' LAEVT: E_c distribution 1'
3173C CALL DT_OUTHGR(IHFLE1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3174C HEADER = ' LAEVT: E_c distribution 2'
3175C CALL DT_OUTHGR(IHFLE2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3176
3177* print run-statistics and histograms to output-unit 6
3178 CALL PHO_PHIST(3000,DUM)
3179 IF (IXSTBL.EQ.0) CALL DT_STATIS(2)
3180
3181 RETURN
3182 END
3183
3184*$ CREATE DT_DTUINI.FOR
3185*COPY DT_DTUINI
3186*
3187*===dtuini=============================================================*
3188*
3189 SUBROUTINE DT_DTUINI(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
3190 & IDP,IEMU)
3191
3192 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3193 SAVE
3194
3195 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
3196* emulsion treatment
3197 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
3198 & NCOMPO,IEMUL
3199* Glauber formalism: flags and parameters for statistics
3200 LOGICAL LPROD
3201 CHARACTER*8 CGLB
3202 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
3203
3204 CALL DT_INIT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,IGLAU)
3205 CALL DT_STATIS(1)
3206 CALL PHO_PHIST(1000,DUM)
3207 IF (NCOMPO.LE.0) THEN
3208 CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
3209 ELSE
3210 DO 1 I=1,NCOMPO
3211 CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
3212 1 CONTINUE
3213 ENDIF
3214 IF (IOGLB.NE.100) CALL DT_SIGEMU
3215 IEMU = IEMUL
3216
3217 RETURN
3218 END
3219
3220*$ CREATE DT_DTUOUT.FOR
3221*COPY DT_DTUOUT
3222*
3223*===dtuout=============================================================*
3224*
3225 SUBROUTINE DT_DTUOUT
3226
3227 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3228 SAVE
3229
3230 CALL PHO_PHIST(3000,DUM)
3231 CALL DT_STATIS(2)
3232
3233 RETURN
3234 END
3235
3236*$ CREATE DT_BEAMPR.FOR
3237*COPY DT_BEAMPR
3238*
3239*===beampr=============================================================*
3240*
3241 SUBROUTINE DT_BEAMPR(WHAT,PLAB,MODE)
3242
3243************************************************************************
3244* Initialization of event generation *
3245* This version dated 7.4.98 is written by S. Roesler. *
3246************************************************************************
3247
3248 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3249 SAVE
3250
3251 PARAMETER ( LINP = 10 ,
3252 & LOUT = 6 ,
3253 & LDAT = 9 )
3254 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
3255 PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
3256
3257 LOGICAL LBEAM
3258
3259* event history
3260 PARAMETER (NMXHKK=200000)
3261 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3262 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3263 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3264* extended event history
3265 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3266 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3267 & IHIST(2,NMXHKK)
3268* properties of interacting particles
3269 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
3270* particle properties (BAMJET index convention)
3271 CHARACTER*8 ANAME
3272 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
3273 & IICH(210),IIBAR(210),K1(210),K2(210)
3274* beam momenta
3275 COMMON /DTBEAM/ P1(4),P2(4)
3276
3277C DIMENSION WHAT(6),P1(4),P2(4),P1CMS(4),P2CMS(4)
3278 DIMENSION WHAT(6),P1CMS(4),P2CMS(4)
3279
3280 DATA LBEAM /.FALSE./
3281
3282 GOTO (1,2) MODE
3283
3284 1 CONTINUE
3285
3286 E1 = WHAT(1)
3287 IF (E1.LT.ZERO) E1 = DBLE(IPZ)/DBLE(IP)*ABS(WHAT(1))
3288 E2 = WHAT(2)
3289 IF (E2.LT.ZERO) E2 = DBLE(ITZ)/DBLE(IT)*ABS(WHAT(2))
3290 PP1 = SQRT( (E1+AAM(IJPROJ))*(E1-AAM(IJPROJ)) )
3291 PP2 = SQRT( (E2+AAM(IJTARG))*(E2-AAM(IJTARG)) )
3292 TH = 1.D-6*WHAT(3)/2.D0
3293 PH = WHAT(4)*BOG
3294 P1(1) = PP1*SIN(TH)*COS(PH)
3295 P1(2) = PP1*SIN(TH)*SIN(PH)
3296 P1(3) = PP1*COS(TH)
3297 P1(4) = E1
3298 P2(1) = PP2*SIN(TH)*COS(PH)
3299 P2(2) = PP2*SIN(TH)*SIN(PH)
3300 P2(3) = -PP2*COS(TH)
3301 P2(4) = E2
3302 ECM = SQRT( (P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))**2
3303 & -(P1(3)+P2(3))**2 )
3304 ELAB = (ECM**2-AAM(IJPROJ)**2-AAM(IJTARG)**2)/(2.0D0*AAM(IJTARG))
3305 PLAB = SQRT( (ELAB+AAM(IJPROJ))*(ELAB-AAM(IJPROJ)) )
3306 BGX = (P1(1)+P2(1))/ECM
3307 BGY = (P1(2)+P2(2))/ECM
3308 BGZ = (P1(3)+P2(3))/ECM
3309 BGE = (P1(4)+P2(4))/ECM
3310 CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P1(1),P1(2),P1(3),P1(4),
3311 & P1TOT,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4))
3312 CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P2(1),P2(2),P2(3),P2(4),
3313 & P2TOT,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4))
3314 COD = P1CMS(3)/P1TOT
3315C SID = SQRT((ONE-COD)*(ONE+COD))
3316 PPT = SQRT(P1CMS(1)**2+P1CMS(2)**2)
3317 SID = PPT/P1TOT
3318 COF = ONE
3319 SIF = ZERO
3320 IF (P1TOT*SID.GT.TINY10) THEN
3321 COF = P1CMS(1)/(SID*P1TOT)
3322 SIF = P1CMS(2)/(SID*P1TOT)
3323 ANORF = SQRT(COF*COF+SIF*SIF)
3324 COF = COF/ANORF
3325 SIF = SIF/ANORF
3326 ENDIF
3327**check
3328C WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
3329C WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
3330C WRITE(LOUT,'(5E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),P1TOT
3331C WRITE(LOUT,'(5E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),P2TOT
3332C PAX = ZERO
3333C PAY = ZERO
3334C PAZ = P1TOT
3335C PAE = SQRT(AAM(IJPROJ)**2+PAZ**2)
3336C PBX = ZERO
3337C PBY = ZERO
3338C PBZ = -P2TOT
3339C PBE = SQRT(AAM(IJTARG)**2+PBZ**2)
3340C WRITE(LOUT,'(4E15.4)') PAX,PAY,PAZ,PAE
3341C WRITE(LOUT,'(4E15.4)') PBX,PBY,PBZ,PBE
3342C CALL DT_MYTRAN(1,PAX,PAY,PAZ,COD,SID,COF,SIF,
3343C & P1CMS(1),P1CMS(2),P1CMS(3))
3344C CALL DT_MYTRAN(1,PBX,PBY,PBZ,COD,SID,COF,SIF,
3345C & P2CMS(1),P2CMS(2),P2CMS(3))
3346C WRITE(LOUT,'(4E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4)
3347C WRITE(LOUT,'(4E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4)
3348C CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),
3349C & P1TOT,P1(1),P1(2),P1(3),P1(4))
3350C CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),
3351C & P2TOT,P2(1),P2(2),P2(3),P2(4))
3352C WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
3353C WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
3354C STOP
3355**
3356
3357 LBEAM = .TRUE.
3358
3359 RETURN
3360
3361 2 CONTINUE
3362
3363 IF (LBEAM) THEN
3364 IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
3365 DO 20 I=NPOINT(4),NHKK
430525dd 3366 IF ((ABS(ISTHKK(I)).EQ.1) .OR.
3367 & (ABS(ISTHKK(I)).EQ.2) .OR.
3368 & (ISTHKK(I).EQ.1000) .OR.
3369 & (ISTHKK(I).EQ.1001)) THEN
3370
9aaba0d6 3371 CALL DT_MYTRAN(1,PHKK(1,I),PHKK(2,I),PHKK(3,I),
3372 & COD,SID,COF,SIF,PXCMS,PYCMS,PZCMS)
3373 PECMS = PHKK(4,I)
3374 CALL DT_DALTRA(BGE,BGX,BGY,BGZ,PXCMS,PYCMS,PZCMS,PECMS,
3375 & PTOT,PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I))
3376 ENDIF
3377 20 CONTINUE
3378 ELSE
3379 MODE = -1
3380 ENDIF
3381
3382 RETURN
3383 END
3384
3385*$ CREATE DT_REJUCO.FOR
3386*COPY DT_REJUCO
3387*
3388*===rejuco=============================================================*
3389*
3390 SUBROUTINE DT_REJUCO(MODE,IREJ)
3391
3392************************************************************************
3393* REJection of Unphysical COnfigurations *
3394* MODE = 1 rejection of particles with unphysically large energy *
3395* *
3396* This version dated 27.12.2006 is written by S. Roesler. *
3397************************************************************************
3398
3399 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3400 SAVE
3401
3402 PARAMETER ( LINP = 10 ,
3403 & LOUT = 6 ,
3404 & LDAT = 9 )
3405 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
3406 PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
3407
3408* maximum x_cms of final state particle
3409 PARAMETER (XCMSMX = 1.4D0)
3410
3411* event history
3412 PARAMETER (NMXHKK=200000)
3413 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3414 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3415 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3416* extended event history
3417 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3418 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3419 & IHIST(2,NMXHKK)
3420* Lorentz-parameters of the current interaction
3421 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
3422 & UMO,PPCM,EPROJ,PPROJ
3423
3424 IREJ = 0
3425
3426 IF (MODE.EQ.1) THEN
3427 IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
3428 ECMHLF = UMO/2.0D0
3429 DO 10 I=NPOINT(4),NHKK
3430 IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDHKK(I).NE.80000)) THEN
3431 XCMS = ABS(PHKK(4,I))/ECMHLF
3432 IF (XCMS.GT.XCMSMX) GOTO 9999
3433 ENDIF
3434 10 CONTINUE
3435 ENDIF
3436
3437 RETURN
3438 9999 CONTINUE
3439 IREJ = 1
3440 RETURN
3441 END
3442
3443*$ CREATE DT_EVENTB.FOR
3444*COPY DT_EVENTB
3445*
3446*===eventb=============================================================*
3447*
3448 SUBROUTINE DT_EVENTB(NCSY,IREJ)
3449
3450************************************************************************
3451* Treatment of nucleon-nucleon interactions with full two-component *
3452* Dual Parton Model. *
3453* NCSY number of nucleon-nucleon interactions *
3454* IREJ rejection flag *
3455* This version dated 14.01.2000 is written by S. Roesler *
3456************************************************************************
3457
3458 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3459 SAVE
3460 PARAMETER ( LINP = 10 ,
3461 & LOUT = 6 ,
3462 & LDAT = 9 )
3463 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
3464
3465* event history
3466 PARAMETER (NMXHKK=200000)
3467 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3468 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3469 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3470* extended event history
3471 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3472 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3473 & IHIST(2,NMXHKK)
3474*! uncomment this line for internal phojet-fragmentation
3475C #include "dtu_dtevtp.inc"
3476* particle properties (BAMJET index convention)
3477 CHARACTER*8 ANAME
3478 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
3479 & IICH(210),IIBAR(210),K1(210),K2(210)
3480* flags for input different options
3481 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
3482 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
3483 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
3484* rejection counter
3485 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
3486 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
3487 & IREXCI(3),IRDIFF(2),IRINC
3488* properties of interacting particles
3489 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
3490* properties of photon/lepton projectiles
3491 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
3492* various options for treatment of partons (DTUNUC 1.x)
3493* (chain recombination, Cronin,..)
3494 LOGICAL LCO2CR,LINTPT
3495 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
3496 & LCO2CR,LINTPT
3497* statistics
3498 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
3499 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
3500 & ICEVTG(8,0:30)
3501* DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
3502 COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
3503* Glauber formalism: collision properties
3504 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
e3f546f5 3505 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
3506 & NCP,NCT
9aaba0d6 3507* flags for diffractive interactions (DTUNUC 1.x)
3508 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
3509* statistics: double-Pomeron exchange
3510 COMMON /DTFLG2/ INTFLG,IPOPO
3511* flags for particle decays
3512 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
3513 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
3514 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
3515* nucleon-nucleon event-generator
3516 CHARACTER*8 CMODEL
3517 LOGICAL LPHOIN
3518 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
3519C nucleon-nucleus / nucleus-nucleus interface to DPMJET
3520 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
3521 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
3522 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
3523 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
3524C model switches and parameters
3525 CHARACTER*8 MDLNA
3526 INTEGER ISWMDL,IPAMDL
3527 DOUBLE PRECISION PARMDL
3528 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
3529C initial state parton radiation (internal part)
3530 INTEGER MXISR3,MXISR4
3531 PARAMETER ( MXISR3 = 50, MXISR4 = 100 )
3532 INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC
3533 DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT
3534 COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3),
3535 & ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3),
3536 & IFL1(2,MXISR3),IFL2(2,MXISR3),
3537 & IBRA(2,MXISR4),IFANO(2),ISH(2),NACC
3538C event debugging information
3539 INTEGER NMAXD
3540 PARAMETER (NMAXD=100)
3541 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
3542 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3543 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
3544 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3545C general process information
3546 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
3547 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
3548
3549 DIMENSION PP(4),PT(4),PTOT(4),PP1(4),PP2(4),PT1(4),PT2(4),
3550 & PPNN(4),PTNN(4),PTOTNN(4),PPSUB(4),PTSUB(4),
3551 & PPTCMS(4),PTTCMS(4),PPTMP(4),PTTMP(4),
3552 & KPRON(15),ISINGL(2000)
3553
3554* initial values for max. number of phojet scatterings and dtunuc chains
3555* to be fragmented with one pyexec call
3556 DATA MXPHFR,MXDTFR /10,100/
3557
3558 IREJ = 0
3559* pointer to first parton of the first chain in dtevt common
3560 NPOINT(3) = NHKK+1
3561* special flag for double-Pomeron statistics
3562 IPOPO = 1
3563* counter for low-mass (DTUNUC) interactions
3564 NDTUSC = 0
3565* counter for interactions treated by PHOJET
3566 NPHOSC = 0
3567
3568* scan interactions for single nucleon-nucleon interactions
3569* (this has to be checked here because Cronin modifies parton momenta)
3570 NC = NPOINT(2)
3571 IF (NCSY.GT.2000) STOP ' DT_EVENTB: NCSY > 2000 ! '
3572 DO 8 I=1,NCSY
3573 ISINGL(I) = 0
3574 MOP = JMOHKK(1,NC)
3575 MOT = JMOHKK(1,NC+1)
3576 DIFF1 = ABS(PHKK(4,MOP)-PHKK(4, NC)-PHKK(4,NC+2))
3577 DIFF2 = ABS(PHKK(4,MOT)-PHKK(4,NC+1)-PHKK(4,NC+3))
3578 IF ((DIFF1.LT.TINY10).AND.(DIFF2.LT.TINY10)) ISINGL(I) = 1
3579 NC = NC+4
3580 8 CONTINUE
3581
3582* multiple scattering of chain ends
3583 IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
3584 IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
3585
3586* switch to PHOJET-settings for JETSET parameter
3587 CALL DT_INITJS(1)
3588
3589* loop over nucleon-nucleon interaction
3590 NC = NPOINT(2)
3591 DO 2 I=1,NCSY
3592*
3593* pick up one nucleon-nucleon interaction from DTEVT1
3594* ppnn / ptnn - momenta of the interacting nucleons (cms)
3595* ptotnn - total momentum of the interacting nucleons (cms)
3596* pp1,2 / pt1,2 - momenta of the four partons
3597* pp / pt - total momenta of the proj / targ partons
3598* ptot - total momentum of the four partons
3599 MOP = JMOHKK(1,NC)
3600 MOT = JMOHKK(1,NC+1)
3601 DO 3 K=1,4
3602 PPNN(K) = PHKK(K,MOP)
3603 PTNN(K) = PHKK(K,MOT)
3604 PTOTNN(K) = PPNN(K)+PTNN(K)
3605 PP1(K) = PHKK(K,NC)
3606 PT1(K) = PHKK(K,NC+1)
3607 PP2(K) = PHKK(K,NC+2)
3608 PT2(K) = PHKK(K,NC+3)
3609 PP(K) = PP1(K)+PP2(K)
3610 PT(K) = PT1(K)+PT2(K)
3611 PTOT(K) = PP(K)+PT(K)
3612 3 CONTINUE
3613*
3614*-----------------------------------------------------------------------
3615* this is a complete nucleon-nucleon interaction
3616*
3617 IF (ISINGL(I).EQ.1) THEN
3618*
3619* initialize PHOJET-variables for remnant/valence-partons
3620 IHFLD(1,1) = 0
3621 IHFLD(1,2) = 0
3622 IHFLD(2,1) = 0
3623 IHFLD(2,2) = 0
3624 IHFLS(1) = 1
3625 IHFLS(2) = 1
3626* save current settings of PHOJET process and min. bias flags
3627 DO 9 K=1,11
3628 KPRON(K) = IPRON(K,1)
3629 9 CONTINUE
3630 ISWSAV = ISWMDL(2)
3631*
3632* check if forced sampling of diffractive interaction requested
3633 IF (ISINGD.LT.-1) THEN
3634 DO 90 K=1,11
3635 IPRON(K,1) = 0
3636 90 CONTINUE
3637 IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-3)) IPRON(5,1) = 1
3638 IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-4)) IPRON(6,1) = 1
3639 IF (ISINGD.EQ.-5) IPRON(4,1) = 1
3640 ENDIF
3641*
3642* for photons: a direct/anomalous interaction is not sampled
3643* in PHOJET but already in Glauber-formalism. Here we check if such
3644* an interaction is requested
3645 IF (IJPROJ.EQ.7) THEN
3646* first switch off direct interactions
3647 IPRON(8,1) = 0
3648* this is a direct interactions
3649 IF (IDIREC.EQ.1) THEN
3650 DO 12 K=1,11
3651 IPRON(K,1) = 0
3652 12 CONTINUE
3653 IPRON(8,1) = 1
3654* this is an anomalous interactions
3655* (iswmdl(2) = 0 only hard int. generated ( = 1 min. bias) )
3656 ELSEIF (IDIREC.EQ.2) THEN
3657 ISWMDL(2) = 0
3658 ENDIF
3659 ELSE
3660 IF (IDIREC.NE.0) STOP ' DT_EVENTB: IDIREC > 0 ! '
3661 ENDIF
3662*
3663* make sure that total momenta of partons, pp and pt, are on mass
3664* shell (Cronin may have srewed this up..)
3665 CALL DT_MASHEL(PP,PT,PHKK(5,MOP),PHKK(5,MOT),PPNN,PTNN,IR1)
3666 IF (IR1.NE.0) THEN
3667 IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A)')
3668 & 'EVENTB: mass shell correction rejected'
3669 GOTO 9999
3670 ENDIF
3671*
3672* initialize the incoming particles in PHOJET
3673 IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
3674 CALL PHO_SETPAR(1,22,0,VIRT)
3675 ELSE
3676 CALL PHO_SETPAR(1,IDHKK(MOP),0,ZERO)
3677 ENDIF
3678 CALL PHO_SETPAR(2,IDHKK(MOT),0,ZERO)
3679*
3680* initialize rejection loop counter for anomalous processes
3681 IRJANO = 0
3682 800 CONTINUE
3683 IRJANO = IRJANO+1
3684*
3685* temporary fix for ifano problem
3686 IFANO(1) = 0
3687 IFANO(2) = 0
3688*
3689* generate complete hadron/nucleon/photon-nucleon event with PHOJET
3690 CALL PHO_EVENT(2,PPNN,PTNN,DUM,IREJ1)
3691*
3692* for photons: special consistency check for anomalous interactions
3693 IF (IJPROJ.EQ.7) THEN
3694 IF (IRJANO.LT.30) THEN
3695 IF (IFANO(1).NE.0) THEN
3696* here, an anomalous interaction was generated. Check if it
3697* was also requested. Otherwise reject this event.
3698 IF (IDIREC.EQ.0) GOTO 800
3699 ELSE
3700* here, an anomalous interaction was not generated. Check if it
3701* was requested in which case we need to reject this event.
3702 IF (IDIREC.EQ.2) GOTO 800
3703 ENDIF
3704 ELSE
3705 WRITE(LOUT,*) ' DT_EVENTB: Warning! IRJANO > 30 ',
3706 & IRJANO,IDIREC,NEVHKK
3707 ENDIF
3708 ENDIF
3709*
3710* copy back original settings of PHOJET process and min. bias flags
3711 DO 10 K=1,11
3712 IPRON(K,1) = KPRON(K)
3713 10 CONTINUE
3714 ISWMDL(2) = ISWSAV
3715*
3716* check if PHOJET has rejected this event
3717 IF (IREJ1.NE.0) THEN
3718C IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
3719 WRITE(LOUT,'(1X,A,I4)')
3720 & 'EVENTB: chain system rejected',IDIREC
3721 CALL PHO_PREVNT(0)
3722 GOTO 9999
3723 ENDIF
3724*
3725* copy partons and strings from PHOJET common back into DTEVT for
3726* external fragmentation
3727 MO1 = NC
3728 MO2 = NC+3
3729*! uncomment this line for internal phojet-fragmentation
3730C CALL DT_GETFSP(MO1,MO2,PPNN,PTNN,-1)
3731 NPHOSC = NPHOSC+1
3732 CALL DT_GETPJE(MO1,MO2,PPNN,PTNN,-1,NPHOSC,IREJ1)
3733 IF (IREJ1.NE.0) THEN
3734 IF (IOULEV(1).GT.0)
3735 & WRITE(LOUT,'(1X,A,I4)') 'EVENTB: chain system rejected 1'
3736 GOTO 9999
3737 ENDIF
3738*
3739* update statistics counter
3740 ICEVTG(IDCH(NC),29) = ICEVTG(IDCH(NC),29)+1
3741*
3742*-----------------------------------------------------------------------
3743* this interaction involves "remnants"
3744*
3745 ELSE
3746*
3747* total mass of this system
3748 PPTOT = SQRT(PTOT(1)**2+PTOT(2)**2+PTOT(3)**2)
3749 AMTOT2 = (PTOT(4)-PPTOT)*(PTOT(4)+PPTOT)
3750 IF (AMTOT2.LT.ZERO) THEN
3751 AMTOT = ZERO
3752 ELSE
3753 AMTOT = SQRT(AMTOT2)
3754 ENDIF
3755*
3756* systems with masses larger than elojet are treated with PHOJET
3757 IF (AMTOT.GT.ELOJET) THEN
3758*
3759* initialize PHOJET-variables for remnant/valence-partons
3760* projectile parton flavors and valence flag
3761 IHFLD(1,1) = IDHKK(NC)
3762 IHFLD(1,2) = IDHKK(NC+2)
3763 IHFLS(1) = 0
3764 IF ((IDCH(NC).EQ.6).OR.(IDCH(NC).EQ.7)
3765 & .OR.(IDCH(NC).EQ.8)) IHFLS(1) = 1
3766* target parton flavors and valence flag
3767 IHFLD(2,1) = IDHKK(NC+1)
3768 IHFLD(2,2) = IDHKK(NC+3)
3769 IHFLS(2) = 0
3770 IF ((IDCH(NC).EQ.4).OR.(IDCH(NC).EQ.5)
3771 & .OR.(IDCH(NC).EQ.8)) IHFLS(2) = 1
3772* flag signalizing PHOJET how to treat the remnant:
3773* iremn = -1 sea-quark remnant: PHOJET takes flavors from ihfld
3774* iremn > -1 valence remnant: PHOJET assumes flavors according
3775* to mother particle
3776 IREMN1 = IHFLS(1)-1
3777 IREMN2 = IHFLS(2)-1
3778*
3779* initialize the incoming particles in PHOJET
3780 IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
3781 CALL PHO_SETPAR(1,22,IREMN1,VIRT)
3782 ELSE
3783 CALL PHO_SETPAR(1,IDHKK(MOP),IREMN1,ZERO)
3784 ENDIF
3785 CALL PHO_SETPAR(2,IDHKK(MOT),IREMN2,ZERO)
3786*
3787* calculate Lorentz parameter of the nucleon-nucleon cm-system
3788 PPTOTN = SQRT(PTOTNN(1)**2+PTOTNN(2)**2+PTOTNN(3)**2)
3789 AMNN = SQRT( (PTOTNN(4)-PPTOTN)*(PTOTNN(4)+PPTOTN) )
3790 BGX = PTOTNN(1)/AMNN
3791 BGY = PTOTNN(2)/AMNN
3792 BGZ = PTOTNN(3)/AMNN
3793 GAM = PTOTNN(4)/AMNN
3794* transform interacting nucleons into nucleon-nucleon cm-system
3795 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3796 & PPNN(1),PPNN(2),PPNN(3),PPNN(4),PPCMS,
3797 & PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4))
3798 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3799 & PTNN(1),PTNN(2),PTNN(3),PTNN(4),PTCMS,
3800 & PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4))
3801* transform (total) momenta of the proj and targ partons into
3802* nucleon-nucleon cm-system
3803 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3804 & PP(1),PP(2),PP(3),PP(4),
3805 & PPTSUB,PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4))
3806 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3807 & PT(1),PT(2),PT(3),PT(4),
3808 & PTTSUB,PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4))
3809* energy fractions of the proj and targ partons
3810 XPSUB = MIN(PPSUB(4)/PPTCMS(4),ONE)
3811 XTSUB = MIN(PTSUB(4)/PTTCMS(4),ONE)
3812***
3813* testprint
3814c PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
3815c & (PPTCMS(2)+PTTCMS(2))**2 +
3816c & (PPTCMS(3)+PTTCMS(3))**2 )
3817c EOLDCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
3818c & (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
3819c PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
3820c & (PPSUB(2)+PTSUB(2))**2 +
3821c & (PPSUB(3)+PTSUB(3))**2 )
3822c EOLDSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
3823c & (PPSUB(4)+PTSUB(4)+PTOTSU) )
3824***
3825*
3826* save current settings of PHOJET process and min. bias flags
3827 DO 7 K=1,11
3828 KPRON(K) = IPRON(K,1)
3829 7 CONTINUE
3830* disallow direct photon int. (does not make sense here anyway)
3831 IPRON(8,1) = 0
3832* disallow double pomeron processes (due to technical problems
3833* in PHOJET, needs to be solved sometime)
3834 IPRON(4,1) = 0
3835* disallow diffraction for sea-diquarks
3836 IF ((IABS(IHFLD(1,1)).GT.1100).AND.
3837 & (IABS(IHFLD(1,2)).GT.1100)) THEN
3838 IPRON(3,1) = 0
3839 IPRON(6,1) = 0
3840 ENDIF
3841 IF ((IABS(IHFLD(2,1)).GT.1100).AND.
3842 & (IABS(IHFLD(2,2)).GT.1100)) THEN
3843 IPRON(3,1) = 0
3844 IPRON(5,1) = 0
3845 ENDIF
3846*
3847* we need massless partons: transform them on mass shell
3848 XMP = ZERO
3849 XMT = ZERO
3850 DO 6 K=1,4
3851 PPTMP(K) = PPSUB(K)
3852 PTTMP(K) = PTSUB(K)
3853 6 CONTINUE
3854 CALL DT_MASHEL(PPTMP,PTTMP,XMP,XMT,PPSUB,PTSUB,IREJ1)
3855 PPSUTO = SQRT(PPSUB(1)**2+PPSUB(2)**2+PPSUB(3)**2)
3856 PTSUTO = SQRT(PTSUB(1)**2+PTSUB(2)**2+PTSUB(3)**2)
3857 PSUTOT = SQRT((PPSUB(1)+PTSUB(1))**2+
3858 & (PPSUB(2)+PTSUB(2))**2+(PPSUB(3)+PTSUB(3))**2)
3859* total energy of the subsysten after mass transformation
3860* (should be the same as before..)
3861 SECM = SQRT( (PPSUB(4)+PTSUB(4)-PSUTOT)*
3862 & (PPSUB(4)+PTSUB(4)+PSUTOT) )
3863*
3864* after mass shell transformation the x_sub - relation has to be
3865* corrected. We therefore create "pseudo-momenta" of mother-nucleons.
3866*
3867* The old version was to scale based on the original x_sub and the
3868* 4-momenta of the subsystem. At very high energy this could lead to
3869* "pseudo-cm energies" of the parent system considerably exceeding
3870* the true cm energy. Now we keep the true cm energy and calculate
3871* new x_sub instead.
3872C old version PPTCMS(4) = PPSUB(4)/XPSUB
3873 PPTCMS(4) = MAX(PPTCMS(4),PPSUB(4))
3874 XPSUB = PPSUB(4)/PPTCMS(4)
3875 IF (IJPROJ.EQ.7) THEN
3876 AMP2 = PHKK(5,MOT)**2
3877 PTOT1 = SQRT(PPTCMS(4)**2-AMP2)
3878 ELSE
3879*???????
3880 PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOP))
3881 & *(PPTCMS(4)+PHKK(5,MOP)))
3882C PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOT))
3883C & *(PPTCMS(4)+PHKK(5,MOT)))
3884 ENDIF
3885C old version PTTCMS(4) = PTSUB(4)/XTSUB
3886 PTTCMS(4) = MAX(PTTCMS(4),PTSUB(4))
3887 XTSUB = PTSUB(4)/PTTCMS(4)
3888 PTOT2 = SQRT((PTTCMS(4)-PHKK(5,MOT))
3889 & *(PTTCMS(4)+PHKK(5,MOT)))
3890 DO 4 K=1,3
3891 PPTCMS(K) = PTOT1*PPSUB(K)/PPSUTO
3892 PTTCMS(K) = PTOT2*PTSUB(K)/PTSUTO
3893 4 CONTINUE
3894***
3895* testprint
3896*
3897* ppnn / ptnn - momenta of the int. nucleons (cms, negl. Fermi)
3898* ptotnn - total momentum of the int. nucleons (cms, negl. Fermi)
3899* pptcms/ pttcms - momenta of the interacting nucleons (cms)
3900* pp1,2 / pt1,2 - momenta of the four partons
3901*
3902* pp / pt - total momenta of the pr/ta partons (cms, negl. Fermi)
3903* ptot - total momentum of the four partons (cms, negl. Fermi)
3904* ppsub / ptsub - total momenta of the proj / targ partons (cms)
3905*
3906c PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
3907c & (PPTCMS(2)+PTTCMS(2))**2 +
3908c & (PPTCMS(3)+PTTCMS(3))**2 )
3909c ENEWCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
3910c & (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
3911c PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
3912c & (PPSUB(2)+PTSUB(2))**2 +
3913c & (PPSUB(3)+PTSUB(3))**2 )
3914c ENEWSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
3915c & (PPSUB(4)+PTSUB(4)+PTOTSU) )
3916c IF (ENEWCM/EOLDCM.GT.1.1D0) THEN
3917c WRITE(*,*) ' EOLDCM, ENEWCM : ',EOLDCM,ENEWCM
3918c WRITE(*,*) ' EOLDSU, ENEWSU : ',EOLDSU,ENEWSU
3919c WRITE(*,*) ' XPSUB, XTSUB : ',XPSUB,XTSUB
3920c ENDIF
3921c BBGX = (PPTCMS(1)+PTTCMS(1))/ENEWCM
3922c BBGY = (PPTCMS(2)+PTTCMS(2))/ENEWCM
3923c BBGZ = (PPTCMS(3)+PTTCMS(3))/ENEWCM
3924c BGAM = (PPTCMS(4)+PTTCMS(4))/ENEWCM
3925* transform interacting nucleons into nucleon-nucleon cm-system
3926c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3927c & PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4),PPTOT,
3928c & PPNEW1,PPNEW2,PPNEW3,PPNEW4)
3929c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3930c & PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4),PTTOT,
3931c & PTNEW1,PTNEW2,PTNEW3,PTNEW4)
3932c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3933c & PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4),PPTOT,
3934c & PPSUB1,PPSUB2,PPSUB3,PPSUB4)
3935c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3936c & PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4),PTTOT,
3937c & PTSUB1,PTSUB2,PTSUB3,PTSUB4)
3938c PTSTCM = SQRT( (PPNEW1+PTNEW1)**2 +
3939c & (PPNEW2+PTNEW2)**2 +
3940c & (PPNEW3+PTNEW3)**2 )
3941c ETSTCM = SQRT( (PPNEW4+PTNEW4-PTSTCM) *
3942c & (PPNEW4+PTNEW4+PTSTCM) )
3943c PTSTSU = SQRT( (PPSUB1+PTSUB1)**2 +
3944c & (PPSUB2+PTSUB2)**2 +
3945c & (PPSUB3+PTSUB3)**2 )
3946c ETSTSU = SQRT( (PPSUB4+PTSUB4-PTSTSU) *
3947c & (PPSUB4+PTSUB4+PTSTSU) )
3948C WRITE(*,*) ' mother cmE :'
3949C WRITE(*,*) ETSTCM,ENEWCM
3950C WRITE(*,*) ' subsystem cmE :'
3951C WRITE(*,*) ETSTSU,ENEWSU
3952C WRITE(*,*) ' projectile mother :'
3953C WRITE(*,*) PPNEW1,PPNEW2,PPNEW3,PPNEW4
3954C WRITE(*,*) ' target mother :'
3955C WRITE(*,*) PTNEW1,PTNEW2,PTNEW3,PTNEW4
3956C WRITE(*,*) ' projectile subsystem:'
3957C WRITE(*,*) PPSUB1,PPSUB2,PPSUB3,PPSUB4
3958C WRITE(*,*) ' target subsystem:'
3959C WRITE(*,*) PTSUB1,PTSUB2,PTSUB3,PTSUB4
3960C WRITE(*,*) ' projectile subsystem should be:'
3961C WRITE(*,*) ZERO,ZERO,XPSUB*ETSTCM/2.0D0,
3962C & XPSUB*ETSTCM/2.0D0
3963C WRITE(*,*) ' target subsystem should be:'
3964C WRITE(*,*) ZERO,ZERO,-XTSUB*ETSTCM/2.0D0,
3965C & XTSUB*ETSTCM/2.0D0
3966C WRITE(*,*) ' subsystem cmE should be: '
3967C WRITE(*,*) SQRT(XPSUB*XTSUB)*ETSTCM,XPSUB,XTSUB
3968***
3969*
3970* generate complete remnant - nucleon/remnant event with PHOJET
3971 CALL PHO_EVENT(3,PPTCMS,PTTCMS,DUM,IREJ1)
3972*
3973* copy back original settings of PHOJET process flags
3974 DO 11 K=1,11
3975 IPRON(K,1) = KPRON(K)
3976 11 CONTINUE
3977*
3978* check if PHOJET has rejected this event
3979 IF (IREJ1.NE.0) THEN
3980 IF (IOULEV(1).GT.0)
3981 & WRITE(LOUT,'(1X,A)') 'EVENTB: chain system rejected'
3982 WRITE(LOUT,*)
3983 & 'XPSUB,XTSUB,SECM ',XPSUB,XTSUB,SECM,AMTOT
3984 CALL PHO_PREVNT(0)
3985 GOTO 9999
3986 ENDIF
3987*
3988* copy partons and strings from PHOJET common back into DTEVT for
3989* external fragmentation
3990 MO1 = NC
3991 MO2 = NC+3
3992*! uncomment this line for internal phojet-fragmentation
3993C CALL DT_GETFSP(MO1,MO2,PP,PT,1)
3994 NPHOSC = NPHOSC+1
3995 CALL DT_GETPJE(MO1,MO2,PP,PT,1,NPHOSC,IREJ1)
3996 IF (IREJ1.NE.0) THEN
3997 IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
3998 & 'EVENTB: chain system rejected 2'
3999 GOTO 9999
4000 ENDIF
4001*
4002* update statistics counter
4003 ICEVTG(IDCH(NC),2) = ICEVTG(IDCH(NC),2)+1
4004*
4005*-----------------------------------------------------------------------
4006* two-chain approx. for smaller systems
4007*
4008 ELSE
4009*
4010 NDTUSC = NDTUSC+1
4011* special flag for double-Pomeron statistics
4012 IPOPO = 0
4013*
4014* pick up flavors at the ends of the two chains
4015 IFP1 = IDHKK(NC)
4016 IFT1 = IDHKK(NC+1)
4017 IFP2 = IDHKK(NC+2)
4018 IFT2 = IDHKK(NC+3)
4019* ..and the indices of the mothers
4020 MOP1 = NC
4021 MOT1 = NC+1
4022 MOP2 = NC+2
4023 MOT2 = NC+3
4024 CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
4025 & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
4026*
4027* check if this chain system was rejected
4028 IF (IREJ1.GT.0) THEN
4029 IF (IOULEV(1).GT.0) THEN
4030 WRITE(LOUT,*) 'rejected 1 in EVENTB'
4031 WRITE(LOUT,'(1X,4(I6,4E12.3,/),E12.3)')
4032 & IFP1,PP1,IFT1,PT1,IFP2,PP2,IFT2,PT2,AMTOT
4033 ENDIF
4034 IRHHA = IRHHA+1
4035 GOTO 9999
4036 ENDIF
4037* the following lines are for sea-sea chains rejected in GETCSY
4038 IF (IREJ1.EQ.-1) NDTUSC = NDTUSC-1
4039 ICEVTG(IDCH(NC),1) = ICEVTG(IDCH(NC),1)+1
4040 ENDIF
4041*
4042 ENDIF
4043*
4044* update statistics counter
4045 ICEVTG(IDCH(NC),0) = ICEVTG(IDCH(NC),0)+1
4046*
4047 NC = NC+4
4048*
4049 2 CONTINUE
4050*
4051*-----------------------------------------------------------------------
4052* treatment of low-mass chains (if there are any)
4053*
4054 IF (NDTUSC.GT.0) THEN
4055*
4056* correct chains of very low masses for possible resonances
4057 IF (IRESCO.EQ.1) THEN
4058 CALL DT_EVTRES(IREJ1)
4059 IF (IREJ1.GT.0) THEN
4060 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2a in EVENTB'
4061 IRRES(1) = IRRES(1)+1
4062 GOTO 9999
4063 ENDIF
4064 ENDIF
4065* fragmentation of low-mass chains
4066*! uncomment this line for internal phojet-fragmentation
4067* (of course it will still be fragmented by DPMJET-routines but it
4068* has to be done here instead of further below)
4069C CALL DT_EVTFRA(IREJ1)
4070C IF (IREJ1.GT.0) THEN
4071C IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2b in EVENTB'
4072C IRFRAG = IRFRAG+1
4073C GOTO 9999
4074C ENDIF
4075 ELSE
4076*! uncomment this line for internal phojet-fragmentation
4077C NPOINT(4) = NHKK+1
4078 IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
4079 ENDIF
4080*
4081*-----------------------------------------------------------------------
4082* new di-quark breaking mechanisms
4083*
4084 MXLEFT = 2
4085 CALL DT_CHASTA(0)
4086 IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
4087 & .OR.(PDBSEA(3).GT.0.0D0)) THEN
4088 CALL DT_DIQBRK
4089 MXLEFT = 4
4090 ENDIF
4091*
4092*-----------------------------------------------------------------------
4093* hadronize this event
4094*
4095* hadronize PHOJET chain systems
4096 NPYMAX = 0
4097 NPJE = NPHOSC/MXPHFR
4098 IF (MXPHFR.LT.MXLEFT) MXLEFT = 2
4099 IF (NPJE.GT.1) THEN
4100 NLEFT = NPHOSC-NPJE*MXPHFR
4101 DO 20 JFRG=1,NPJE
4102 NFRG = JFRG*MXPHFR
4103 IF ((JFRG.EQ.NPJE).AND.(NLEFT.LE.MXLEFT)) THEN
4104 CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4105 IF (IREJ1.GT.0) GOTO 22
4106 NLEFT = 0
4107 ELSE
4108 CALL DT_EVTFRG(1,NFRG,NPYMEM,IREJ1)
4109 IF (IREJ1.GT.0) GOTO 22
4110 ENDIF
4111 IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4112 20 CONTINUE
4113 IF (NLEFT.GT.0) THEN
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 ELSE
4119 CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4120 IF (IREJ1.GT.0) GOTO 22
4121 IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4122 ENDIF
4123*
4124* check max. filling level of jetset common and
4125* reduce mxphfr if necessary
4126 IF (NPYMAX.GT.3000) THEN
4127 IF (NPYMAX.GT.3500) THEN
4128 MXPHFR = MAX(1,MXPHFR-2)
4129 ELSE
4130 MXPHFR = MAX(1,MXPHFR-1)
4131 ENDIF
4132C WRITE(LOUT,*) ' EVENTB: Mxphfr reduced to ',MXPHFR
4133 ENDIF
4134*
4135* hadronize DTUNUC chain systems
4136 23 CONTINUE
4137 IBACK = MXDTFR
4138 CALL DT_EVTFRG(2,IBACK,NPYMEM,IREJ2)
4139 IF (IREJ2.GT.0) GOTO 22
4140*
4141* check max. filling level of jetset common and
4142* reduce mxdtfr if necessary
4143 IF (NPYMEM.GT.3000) THEN
4144 IF (NPYMEM.GT.3500) THEN
4145 MXDTFR = MAX(1,MXDTFR-20)
4146 ELSE
4147 MXDTFR = MAX(1,MXDTFR-10)
4148 ENDIF
4149C WRITE(LOUT,*) ' EVENTB: Mxdtfr reduced to ',MXDTFR
4150 ENDIF
4151*
4152 IF (IBACK.EQ.-1) GOTO 23
4153*
4154 22 CONTINUE
4155C CALL DT_EVTFRG(1,IREJ1)
4156C CALL DT_EVTFRG(2,IREJ2)
4157 IF ((IREJ1.GT.0).OR.(IREJ2.GT.0)) THEN
4158 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTB'
4159 IRFRAG = IRFRAG+1
4160 GOTO 9999
4161 ENDIF
4162*
4163* get final state particles from /DTEVTP/
4164*! uncomment this line for internal phojet-fragmentation
4165C CALL DT_GETFSP(IDUM,IDUM,PP,PT,2)
4166
4167 IF (IJPROJ.NE.7)
4168 & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,88,IREJ3)
4169C IF (IREJ3.NE.0) GOTO 9999
4170
4171 RETURN
4172
4173 9999 CONTINUE
4174 IREVT = IREVT+1
4175 IREJ = 1
4176 RETURN
4177 END
4178
4179*$ CREATE DT_GETPJE.FOR
4180*COPY DT_GETPJE
4181*
4182*===getpje=============================================================*
4183*
4184 SUBROUTINE DT_GETPJE(MO1,MO2,PP,PT,MODE,IPJE,IREJ)
4185
4186************************************************************************
4187* This subroutine copies PHOJET partons and strings from POEVT1 into *
4188* DTEVT1. *
4189* MO1,MO2 indices of first and last mother-parton in DTEVT1 *
4190* PP,PT 4-momenta of projectile/target being handled by *
4191* PHOJET *
4192* This version dated 11.12.99 is written by S. Roesler *
4193************************************************************************
4194
4195 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4196 SAVE
4197 PARAMETER ( LINP = 10 ,
4198 & LOUT = 6 ,
4199 & LDAT = 9 )
4200 PARAMETER (TINY10=1.0D-10,TINY1=1.0D-1,
4201 & ZERO=0.0D0,ONE=1.0D0,OHALF=0.5D0)
4202
4203 LOGICAL LFLIP
4204
4205* event history
4206 PARAMETER (NMXHKK=200000)
4207 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
4208 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
4209 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
4210* extended event history
4211 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
4212 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
4213 & IHIST(2,NMXHKK)
4214* Lorentz-parameters of the current interaction
4215 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4216 & UMO,PPCM,EPROJ,PPROJ
4217* DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
4218 COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
4219* flags for input different options
4220 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
4221 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
4222 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
4223* statistics: double-Pomeron exchange
4224 COMMON /DTFLG2/ INTFLG,IPOPO
4225* statistics
4226 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
4227 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
4228 & ICEVTG(8,0:30)
4229* rejection counter
4230 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
4231 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
4232 & IREXCI(3),IRDIFF(2),IRINC
4233C standard particle data interface
4234 INTEGER NMXHEP
4235 PARAMETER (NMXHEP=4000)
4236 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
4237 DOUBLE PRECISION PHEP,VHEP
4238 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
4239 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
09b429a4 4240 & VHEP(4,NMXHEP), NSD1, NSD2, NDD
9aaba0d6 4241C extension to standard particle data interface (PHOJET specific)
4242 INTEGER IMPART,IPHIST,ICOLOR
4243 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
4244C color string configurations including collapsed strings and hadrons
4245 INTEGER MSTR
4246 PARAMETER (MSTR=500)
4247 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
4248 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
4249 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
4250 & NNCH(MSTR),IBHAD(MSTR),ISTR
4251C general process information
4252 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
4253 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
4254C model switches and parameters
4255 CHARACTER*8 MDLNA
4256 INTEGER ISWMDL,IPAMDL
4257 DOUBLE PRECISION PARMDL
4258 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4259C event debugging information
4260 INTEGER NMAXD
4261 PARAMETER (NMAXD=100)
4262 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4263 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4264 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4265 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4266
4267 DIMENSION PP(4),PT(4)
4268 DATA MAXLOP /10000/
4269
4270 INHKK = NHKK
4271 LFLIP = .TRUE.
4272 1 CONTINUE
4273 NPVAL = 0
4274 NTVAL = 0
4275 IREJ = 0
4276
4277* store initial momenta for energy-momentum conservation check
4278 IF (LEMCCK) THEN
4279 CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM1,IDUM2)
4280 CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM1,IDUM2)
4281 ENDIF
4282* copy partons and strings from POEVT1 into DTEVT1
4283 DO 11 I=1,ISTR
4284C IF ((NCODE(I).EQ.-99).AND.(IPAMDL(17).EQ.0)) THEN
4285 IF (NCODE(I).EQ.-99) THEN
4286 IDXSTG = NPOS(1,I)
4287 IDSTG = IDHEP(IDXSTG)
4288 PX = PHEP(1,IDXSTG)
4289 PY = PHEP(2,IDXSTG)
4290 PZ = PHEP(3,IDXSTG)
4291 PE = PHEP(4,IDXSTG)
4292 IF (MODE.LT.0) THEN
4293 ISTAT = 70000+IPJE
4294 CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PX,PY,PZ,PE,
4295 & 11,IDSTG,0)
4296 IF (LEMCCK) THEN
4297 PX = -PX
4298 PY = -PY
4299 PZ = -PZ
4300 PE = -PE
4301 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4302 ENDIF
4303 ELSE
4304 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4305 & PPX,PPY,PPZ,PPE)
4306 ISTAT = 70000+IPJE
4307 CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PPX,PPY,PPZ,PPE,
4308 & 11,IDSTG,0)
4309 IF (LEMCCK) THEN
4310 PX = -PPX
4311 PY = -PPY
4312 PZ = -PPZ
4313 PE = -PPE
4314 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4315 ENDIF
4316 ENDIF
4317 NOBAM(NHKK) = 0
4318 IHIST(1,NHKK) = IPHIST(1,IDXSTG)
4319 IHIST(2,NHKK) = 0
4320 ELSEIF (NCODE(I).GE.0) THEN
4321* indices of partons and string in POEVT1
4322 IDX1 = ABS(JMOHEP(1,NPOS(1,I)))
4323 IDX2 = ABS(JMOHEP(2,NPOS(1,I)))
4324 IF ((IDX1.GT.IDX2).OR.(JMOHEP(2,NPOS(1,I)).GT.0)) THEN
4325 WRITE(LOUT,*) ' GETPJE: IDX1.GT.IDX2 ',IDX1,IDX2,
4326 & ' or JMOHEP(2,NPOS(1,I)).GT.0 ',JMOHEP(2,NPOS(1,I)),' ! '
4327 STOP ' GETPJE 1'
4328 ENDIF
4329 IDXSTG = NPOS(1,I)
4330* find "mother" string of the string
4331 IDXMS1 = ABS(JMOHEP(1,IDX1))
4332 IDXMS2 = ABS(JMOHEP(1,IDX2))
4333 IF (IDXMS1.NE.IDXMS2) THEN
4334 IDXMS1 = IDXSTG
4335 IDXMS2 = IDXSTG
4336C STOP ' GETPJE: IDXMS1.NE.IDXMS2 !'
4337 ENDIF
4338* search POEVT1 for the original hadron of the parton
4339 ILOOP = 0
4340 IPOM1 = 0
4341 14 CONTINUE
4342 ILOOP = ILOOP+1
4343 IF (IDHEP(IDXMS1).EQ.990) IPOM1 = 1
4344 IDXMS1 = ABS(JMOHEP(1,IDXMS1))
4345 IF ((IDXMS1.NE.1).AND.(IDXMS1.NE.2).AND.
4346 & (ILOOP.LT.MAXLOP)) GOTO 14
4347 IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 1 ! '
4348 IPOM2 = 0
4349 ILOOP = 0
4350 15 CONTINUE
4351 ILOOP = ILOOP+1
4352 IF (IDHEP(IDXMS2).EQ.990) IPOM2 = 1
4353 IF ((ILOOP.EQ.1).OR.(IDHEP(IDXMS2).GE.7777)) THEN
4354 IDXMS2 = ABS(JMOHEP(2,IDXMS2))
4355 ELSE
4356 IDXMS2 = ABS(JMOHEP(1,IDXMS2))
4357 ENDIF
4358 IF ((IDXMS2.NE.1).AND.(IDXMS2.NE.2).AND.
4359 & (ILOOP.LT.MAXLOP)) GOTO 15
4360 IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 5 ! '
4361* parton 1
4362 IF (IDXMS1.EQ.1) THEN
4363 ISPTN1 = ISTHKK(MO1)
4364 M1PTN1 = MO1
4365 M2PTN1 = MO1+2
4366 ELSE
4367 ISPTN1 = ISTHKK(MO2)
4368 M1PTN1 = MO2-2
4369 M2PTN1 = MO2
4370 ENDIF
4371* parton 2
4372 IF (IDXMS2.EQ.1) THEN
4373 ISPTN2 = ISTHKK(MO1)
4374 M1PTN2 = MO1
4375 M2PTN2 = MO1+2
4376 ELSE
4377 ISPTN2 = ISTHKK(MO2)
4378 M1PTN2 = MO2-2
4379 M2PTN2 = MO2
4380 ENDIF
4381* check for mis-identified mothers and switch mother indices if necessary
4382 IF ((IDXMS1.EQ.IDXMS2).AND.(IPROCE.NE.5).AND.(IPROCE.NE.6)
4383 & .AND.((IDHEP(IDX1).NE.21).OR.(IDHEP(IDX2).NE.21)).AND.
4384 & (LFLIP)) THEN
4385 IF (PHEP(3,IDX1).GT.PHEP(3,IDX2)) THEN
4386 ISPTN1 = ISTHKK(MO1)
4387 M1PTN1 = MO1
4388 M2PTN1 = MO1+2
4389 ISPTN2 = ISTHKK(MO2)
4390 M1PTN2 = MO2-2
4391 M2PTN2 = MO2
4392 ELSE
4393 ISPTN1 = ISTHKK(MO2)
4394 M1PTN1 = MO2-2
4395 M2PTN1 = MO2
4396 ISPTN2 = ISTHKK(MO1)
4397 M1PTN2 = MO1
4398 M2PTN2 = MO1+2
4399 ENDIF
4400 ENDIF
4401* register partons in temporary common
4402* parton at chain end
4403 PX = PHEP(1,IDX1)
4404 PY = PHEP(2,IDX1)
4405 PZ = PHEP(3,IDX1)
4406 PE = PHEP(4,IDX1)
4407* flag only partons coming from Pomeron with 41/42
4408C IF ((IPOM1.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4409 IF (IPOM1.NE.0) THEN
4410 ISTX = ABS(ISPTN1)/10
4411 IMO = ABS(ISPTN1)-10*ISTX
4412 ISPTN1 = -(40+IMO)
4413 ELSE
4414 IF ((ICOLOR(2,IDX1).EQ.0).OR.(IDHEP(IDX1).EQ.21)) THEN
4415 ISTX = ABS(ISPTN1)/10
4416 IMO = ABS(ISPTN1)-10*ISTX
4417 IF ((IDHEP(IDX1).EQ.21).OR.
4418 & (ABS(IPHIST(1,IDX1)).GE.100)) THEN
4419 ISPTN1 = -(60+IMO)
4420 ELSE
4421 ISPTN1 = -(50+IMO)
4422 ENDIF
4423 ENDIF
4424 ENDIF
4425 IF (ISPTN1.EQ.-21) NPVAL = NPVAL+1
4426 IF (ISPTN1.EQ.-22) NTVAL = NTVAL+1
4427 IF (MODE.LT.0) THEN
4428 CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PX,PY,
4429 & PZ,PE,0,0,0)
4430 ELSE
4431 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4432 & PPX,PPY,PPZ,PPE)
4433 CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PPX,PPY,
4434 & PPZ,PPE,0,0,0)
4435 ENDIF
4436 IHIST(1,NHKK) = IPHIST(1,IDX1)
4437 IHIST(2,NHKK) = 0
4438 DO 19 KK=1,4
4439 VHKK(KK,NHKK) = VHKK(KK,M2PTN1)
4440 WHKK(KK,NHKK) = WHKK(KK,M1PTN1)
4441 19 CONTINUE
4442 VHKK(4,NHKK) = VHKK(3,M2PTN1)/BLAB-VHKK(3,M1PTN1)/BGLAB
4443 WHKK(4,NHKK) = -WHKK(3,M1PTN1)/BLAB+WHKK(3,M2PTN1)/BGLAB
4444 M1STRG = NHKK
4445* gluon kinks
4446 NGLUON = IDX2-IDX1-1
4447 IF (NGLUON.GT.0) THEN
4448 DO 17 IGLUON=1,NGLUON
4449 IDX = IDX1+IGLUON
4450 IDXMS = ABS(JMOHEP(1,IDX))
4451 IF ((IDXMS.NE.1).AND.(IDXMS.NE.2)) THEN
4452 ILOOP = 0
4453 16 CONTINUE
4454 ILOOP = ILOOP+1
4455 IDXMS = ABS(JMOHEP(1,IDXMS))
4456 IF ((IDXMS.NE.1).AND.(IDXMS.NE.2).AND.
4457 & (ILOOP.LT.MAXLOP)) GOTO 16
4458 IF (ILOOP.EQ.MAXLOP)
4459 & WRITE(LOUT,*) ' GETPJE: MAXLOP in 3 ! '
4460 ENDIF
4461 IF (IDXMS.EQ.1) THEN
4462 ISPTN = ISTHKK(MO1)
4463 M1PTN = MO1
4464 M2PTN = MO1+2
4465 ELSE
4466 ISPTN = ISTHKK(MO2)
4467 M1PTN = MO2-2
4468 M2PTN = MO2
4469 ENDIF
4470 PX = PHEP(1,IDX)
4471 PY = PHEP(2,IDX)
4472 PZ = PHEP(3,IDX)
4473 PE = PHEP(4,IDX)
4474 IF ((ICOLOR(2,IDX).EQ.0).OR.(IDHEP(IDX).EQ.21)) THEN
4475 ISTX = ABS(ISPTN)/10
4476 IMO = ABS(ISPTN)-10*ISTX
4477 IF ((IDHEP(IDX).EQ.21).OR.
4478 & (ABS(IPHIST(1,IDX)).GE.100)) THEN
4479 ISPTN = -(60+IMO)
4480 ELSE
4481 ISPTN = -(50+IMO)
4482 ENDIF
4483 ENDIF
4484 IF (ISPTN.EQ.-21) NPVAL = NPVAL+1
4485 IF (ISPTN.EQ.-22) NTVAL = NTVAL+1
4486 IF (MODE.LT.0) THEN
4487 CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4488 & PX,PY,PZ,PE,0,0,0)
4489 ELSE
4490 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4491 & PPX,PPY,PPZ,PPE)
4492 CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4493 & PPX,PPY,PPZ,PPE,0,0,0)
4494 ENDIF
4495 IHIST(1,NHKK) = IPHIST(1,IDX)
4496 IHIST(2,NHKK) = 0
4497 DO 20 KK=1,4
4498 VHKK(KK,NHKK) = VHKK(KK,M2PTN)
4499 WHKK(KK,NHKK) = WHKK(KK,M1PTN)
4500 20 CONTINUE
4501 VHKK(4,NHKK)= VHKK(3,M2PTN)/BLAB-VHKK(3,M1PTN)/BGLAB
4502 WHKK(4,NHKK)= -WHKK(3,M1PTN)/BLAB+WHKK(3,M2PTN)/BGLAB
4503 17 CONTINUE
4504 ENDIF
4505* parton at chain end
4506 PX = PHEP(1,IDX2)
4507 PY = PHEP(2,IDX2)
4508 PZ = PHEP(3,IDX2)
4509 PE = PHEP(4,IDX2)
4510* flag only partons coming from Pomeron with 41/42
4511C IF ((IPOM2.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4512 IF (IPOM2.NE.0) THEN
4513 ISTX = ABS(ISPTN2)/10
4514 IMO = ABS(ISPTN2)-10*ISTX
4515 ISPTN2 = -(40+IMO)
4516 ELSE
4517 IF ((ICOLOR(2,IDX2).EQ.0).OR.(IDHEP(IDX2).EQ.21)) THEN
4518 ISTX = ABS(ISPTN2)/10
4519 IMO = ABS(ISPTN2)-10*ISTX
4520 IF ((IDHEP(IDX2).EQ.21).OR.
4521 & (ABS(IPHIST(1,IDX2)).GE.100)) THEN
4522 ISPTN2 = -(60+IMO)
4523 ELSE
4524 ISPTN2 = -(50+IMO)
4525 ENDIF
4526 ENDIF
4527 ENDIF
4528 IF (ISPTN2.EQ.-21) NPVAL = NPVAL+1
4529 IF (ISPTN2.EQ.-22) NTVAL = NTVAL+1
4530 IF (MODE.LT.0) THEN
4531 CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4532 & PX,PY,PZ,PE,0,0,0)
4533 ELSE
4534 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4535 & PPX,PPY,PPZ,PPE)
4536 CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4537 & PPX,PPY,PPZ,PPE,0,0,0)
4538 ENDIF
4539 IHIST(1,NHKK) = IPHIST(1,IDX2)
4540 IHIST(2,NHKK) = 0
4541 DO 21 KK=1,4
4542 VHKK(KK,NHKK) = VHKK(KK,M2PTN2)
4543 WHKK(KK,NHKK) = WHKK(KK,M1PTN2)
4544 21 CONTINUE
4545 VHKK(4,NHKK) = VHKK(3,M2PTN2)/BLAB-VHKK(3,M1PTN2)/BGLAB
4546 WHKK(4,NHKK) = -WHKK(3,M1PTN2)/BLAB+WHKK(3,M2PTN2)/BGLAB
4547 M2STRG = NHKK
4548* register string
4549 JSTRG = 100*IPROCE+NCODE(I)
4550 PX = PHEP(1,IDXSTG)
4551 PY = PHEP(2,IDXSTG)
4552 PZ = PHEP(3,IDXSTG)
4553 PE = PHEP(4,IDXSTG)
4554 IF (MODE.LT.0) THEN
4555 ISTAT = 70000+IPJE
4556 CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4557 & PX,PY,PZ,PE,0,0,0)
4558 IF (LEMCCK) THEN
4559 PX = -PX
4560 PY = -PY
4561 PZ = -PZ
4562 PE = -PE
4563 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4564 ENDIF
4565 ELSE
4566 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4567 & PPX,PPY,PPZ,PPE)
4568 ISTAT = 70000+IPJE
4569 CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4570 & PPX,PPY,PPZ,PPE,0,0,0)
4571 IF (LEMCCK) THEN
4572 PX = -PPX
4573 PY = -PPY
4574 PZ = -PPZ
4575 PE = -PPE
4576 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4577 ENDIF
4578 ENDIF
4579 NOBAM(NHKK) = 0
4580 IHIST(1,NHKK) = 0
4581 IHIST(2,NHKK) = 0
4582 DO 18 KK=1,4
4583 VHKK(KK,NHKK) = VHKK(KK,MO2)
4584 WHKK(KK,NHKK) = WHKK(KK,MO1)
4585 18 CONTINUE
4586 VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
4587 WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
4588 ENDIF
4589 11 CONTINUE
4590
4591 IF ( ((NPVAL.GT.2).OR.(NTVAL.GT.2)).AND.(LFLIP) ) THEN
4592 NHKK = INHKK
4593 LFLIP = .FALSE.
4594 GOTO 1
4595 ENDIF
4596
4597 IF (LEMCCK) THEN
4598 IF (UMO.GT.1.0D5) THEN
4599 CHKLEV = 1.0D0
4600 ELSE
4601 CHKLEV = TINY1
4602 ENDIF
4603 CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,1000,IREJ2)
4604 IF (IREJ2.GT.ZERO) CALL PHO_PREVNT(0)
4605 ENDIF
4606
4607* internal statistics
4608* dble-Po statistics.
4609 IF (IPROCE.NE.4) IPOPO = 0
4610
4611 INTFLG = IPROCE
4612 IDCHSY = IDCH(MO1)
4613 IF ((IPROCE.GE.1).AND.(IPROCE.LE.8)) THEN
4614 ICEVTG(IDCHSY,IPROCE+2) = ICEVTG(IDCHSY,IPROCE+2)+1
4615 ELSE
4616 WRITE(LOUT,1000) IPROCE,NEVHKK,MO1
4617 1000 FORMAT(1X,'GETFSP: warning! incons. process id. (',I2,
4618 & ') at evt(chain) ',I6,'(',I2,')')
4619 ENDIF
4620 IF (IPROCE.EQ.5) THEN
4621 IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3)) THEN
4622 ICEVTG(IDCHSY,18+IDIFR1) = ICEVTG(IDCHSY,18+IDIFR1)+1
4623 ELSE
4624C WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4625 1001 FORMAT(1X,'GETFSP: warning! incons. diffrac. id. ',
4626 & '(IPROCE,IDIFR1,IDIFR2=',3I3,')')
4627 ENDIF
4628 ELSEIF (IPROCE.EQ.6) THEN
4629 IF ((IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4630 ICEVTG(IDCHSY,21+IDIFR2) = ICEVTG(IDCHSY,21+IDIFR2)+1
4631 ELSE
4632C WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4633 ENDIF
4634 ELSEIF (IPROCE.EQ.7) THEN
4635 IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3).AND.
4636 & (IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4637 IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.1))
4638 & ICEVTG(IDCHSY,25) = ICEVTG(IDCHSY,25)+1
4639 IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.2))
4640 & ICEVTG(IDCHSY,26) = ICEVTG(IDCHSY,26)+1
4641 IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.2))
4642 & ICEVTG(IDCHSY,27) = ICEVTG(IDCHSY,27)+1
4643 IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.1))
4644 & ICEVTG(IDCHSY,28) = ICEVTG(IDCHSY,28)+1
4645 ELSE
4646 WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4647 ENDIF
4648 ENDIF
4649 IF ((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GE.1).AND.(KHDIR.LE.3))
4650 & THEN
4651 ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4652 ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4653 ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4654 ENDIF
4655 ICEVTG(IDCHSY,14) = ICEVTG(IDCHSY,14)+KSPOM
4656 ICEVTG(IDCHSY,15) = ICEVTG(IDCHSY,15)+KHPOM
4657 ICEVTG(IDCHSY,16) = ICEVTG(IDCHSY,16)+KSREG
4658 ICEVTG(IDCHSY,17) = ICEVTG(IDCHSY,17)+(KSTRG+KHTRG)
4659 ICEVTG(IDCHSY,18) = ICEVTG(IDCHSY,18)+(KSLOO+KHLOO)
4660
4661 RETURN
4662
4663 9999 CONTINUE
4664 IREJ = 1
4665 RETURN
4666 END
4667
4668*$ CREATE DT_PHOINI.FOR
4669*COPY DT_PHOINI
4670*
4671*===phoini=============================================================*
4672*
4673 SUBROUTINE DT_PHOINI
4674
4675************************************************************************
4676* Initialization PHOJET-event generator for nucleon-nucleon interact. *
4677* This version dated 16.11.95 is written by S. Roesler *
4678* *
4679* Last change 27.12.2006 by S. Roesler. *
4680************************************************************************
4681
4682 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4683 SAVE
4684 PARAMETER ( LINP = 10 ,
4685 & LOUT = 6 ,
4686 & LDAT = 9 )
4687 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
4688
4689* nucleon-nucleon event-generator
4690 CHARACTER*8 CMODEL
4691 LOGICAL LPHOIN
4692 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
4693* particle properties (BAMJET index convention)
4694 CHARACTER*8 ANAME
4695 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
4696 & IICH(210),IIBAR(210),K1(210),K2(210)
4697* Lorentz-parameters of the current interaction
4698 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4699 & UMO,PPCM,EPROJ,PPROJ
4700* properties of interacting particles
4701 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
4702* properties of photon/lepton projectiles
4703 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
4704 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
4705* emulsion treatment
4706 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
4707 & NCOMPO,IEMUL
4708* VDM parameter for photon-nucleus interactions
4709 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
4710* nuclear potential
4711 LOGICAL LFERMI
4712 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
4713 & EBINDP(2),EBINDN(2),EPOT(2,210),
4714 & ETACOU(2),ICOUL,LFERMI
4715* Glauber formalism: flags and parameters for statistics
4716 LOGICAL LPROD
4717 CHARACTER*8 CGLB
4718 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
4719*
4720* parameters for cascade calculations:
4721* maximum mumber of PDF's which can be defined in phojet (limited
4722* by the dimension of ipdfs in pho_setpdf)
4723 PARAMETER (MAXPDF = 20)
4724* PDF parametrization and number of set for the first 30 hadrons in
4725* the bamjet-code list
4726* negative numbers mean that the PDF is set in phojet,
4727* zero stands for "not a hadron"
4728 DIMENSION IPARPD(30),ISETPD(30)
4729* PDF parametrization
4730 DATA IPARPD /
4731 & -5,-5, 0, 0, 0, 0,-5,-5,-5, 0, 0, 5,-5,-5, 5, 5, 5, 5, 5, 5,
4732 & 5, 5,-5, 5, 5, 0, 0, 0, 0, 0/
4733* number of set
4734 DATA ISETPD /
4735 & -6,-6, 0, 0, 0, 0,-3,-6,-6, 0, 0, 2,-2,-2, 2, 2, 6, 6, 2, 6,
4736 & 6, 6,-2, 2, 2, 0, 0, 0, 0, 0/
4737
4738**PHOJET105a
4739C COMMON /GLOCMS/ XECM,XPCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
4740C PARAMETER ( MAXPRO = 16 )
4741C PARAMETER ( MAXTAB = 20 )
4742C COMMON /HAXSEC/ XSECTA(4,-1:MAXPRO,4,MAXTAB),XSECT(6,-1:MAXPRO),
4743C & MXSECT(0:4,-1:MAXPRO,4),ECMSH(4,MAXTAB),ISTTAB
4744C CHARACTER*8 MDLNA
4745C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
4746C COMMON /PROCES/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15)
4747**PHOJET110
4748C global event kinematics and particle IDs
4749 INTEGER IFPAP,IFPAB
4750 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
4751 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
4752C hard cross sections and MC selection weights
4753 INTEGER Max_pro_2
4754 PARAMETER ( Max_pro_2 = 16 )
4755 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
4756 & MH_acc_1,MH_acc_2
4757 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
4758 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
4759 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
4760 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
4761 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
4762 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
4763C model switches and parameters
4764 CHARACTER*8 MDLNA
4765 INTEGER ISWMDL,IPAMDL
4766 DOUBLE PRECISION PARMDL
4767 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4768C general process information
4769 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
4770 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
4771**
4772 DIMENSION PP(4),PT(4)
4773
4774 LOGICAL LSTART
4775 DATA LSTART /.TRUE./
4776
4777 IJP = IJPROJ
4778 IJT = IJTARG
4779 Q2 = VIRT
4780* lepton-projectiles: initialize real photon instead
4781 IF ((IJP.EQ.3).OR.(IJP.EQ.4).OR.(IJP.EQ.10).OR.(IJP.EQ.11)) THEN
4782 IJP = 7
4783 Q2 = ZERO
4784 ENDIF
4785 IF (LPHOIN) CALL PHO_INIT(-1,LOUT,IDUM)
4786* switch Reggeon off
4787C IPAMDL(3)= 0
4788 IF (IP.EQ.1) THEN
4789 IFPAP(1) = IDT_IPDGHA(IJP)
4790 IFPAB(1) = IJP
4791 ELSE
4792 IFPAP(1) = 2212
4793 IFPAB(1) = IDT_ICIHAD(IFPAP(1))
4794 ENDIF
4795 PMASS(1) = AAM(IFPAB(1))-SQRT(Q2)
4796 PVIRT(1) = PMASS(1)**2
4797 IF (IT.EQ.1) THEN
4798 IFPAP(2) = IDT_IPDGHA(IJT)
4799 IFPAB(2) = IJT
4800 ELSE
4801 IFPAP(2) = 2212
4802 IFPAB(2) = IDT_ICIHAD(IFPAP(2))
4803 ENDIF
4804 PMASS(2) = AAM(IFPAB(2))
4805 PVIRT(2) = ZERO
4806 DO 1 K=1,4
4807 PP(K) = ZERO
4808 PT(K) = ZERO
4809 1 CONTINUE
4810* get max. possible momenta of incoming particles to be used for PHOJET ini.
4811 PPF = ZERO
4812 PTF = ZERO
4813 SCPF= 1.5D0
4814 IF (UMO.GE.1.E5) THEN
4815 SCPF= 5.0D0
4816 ENDIF
4817 IF (NCOMPO.GT.0) THEN
4818 DO 2 I=1,NCOMPO
4819 IF (IT.GT.1) THEN
4820 CALL DT_NCLPOT(IEMUCH(I),IEMUMA(I),ITZ,IT,ZERO,ZERO,0)
4821 ELSE
4822 CALL DT_NCLPOT(IPZ,IP,IEMUCH(I),IEMUMA(I),ZERO,ZERO,0)
4823 ENDIF
4824 PPFTMP = MAX(PFERMP(1),PFERMN(1))
4825 PTFTMP = MAX(PFERMP(2),PFERMN(2))
4826 IF (PPFTMP.GT.PPF) PPF = PPFTMP
4827 IF (PTFTMP.GT.PTF) PTF = PTFTMP
4828 2 CONTINUE
4829 ELSE
4830 CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
4831 PPF = MAX(PFERMP(1),PFERMN(1))
4832 PTF = MAX(PFERMP(2),PFERMN(2))
4833 ENDIF
4834 PTF = -PTF
4835 PPF = SCPF*PPF
4836 PTF = SCPF*PTF
4837 IF (IJP.EQ.7) THEN
4838 AMP2 = SIGN(PMASS(1)**2,PMASS(1))
4839 PP(3) = PPCM
4840 PP(4) = SQRT(AMP2+PP(3)**2)
4841 ELSE
4842 EPF = SQRT(PPF**2+PMASS(1)**2)
4843 CALL DT_LTNUC(PPF,EPF,PP(3),PP(4),2)
4844 ENDIF
4845 ETF = SQRT(PTF**2+PMASS(2)**2)
4846 CALL DT_LTNUC(PTF,ETF,PT(3),PT(4),3)
4847 ECMINI = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
4848 & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
4849 IF (LSTART) THEN
4850 WRITE(LOUT,1001) IP,IPZ,SCPF,PPF,PP
4851 1001 FORMAT(
4852 & ' DT_PHOINI: PHOJET initialized for projectile A,Z = ',
4853 & I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
4854 IF (NCOMPO.GT.0) THEN
4855 WRITE(LOUT,1002) SCPF,PTF,PT
4856 ELSE
4857 WRITE(LOUT,1003) IT,ITZ,SCPF,PTF,PT
4858 ENDIF
4859 1002 FORMAT(
4860 & ' DT_PHOINI: PHOJET initialized for target emulsion ',
4861 & /,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
4862 1003 FORMAT(
4863 & ' DT_PHOINI: PHOJET initialized for target A,Z = ',
4864 & I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
4865 WRITE(LOUT,1004) ECMINI
4866 1004 FORMAT(' E_cm = ',E10.3)
4867 IF (IJP.EQ.8) WRITE(LOUT,1005)
4868 1005 FORMAT(
4869 & ' DT_PHOINI: warning! proton parameters used for neutron',
4870 & ' projectile')
4871 LSTART = .FALSE.
4872 ENDIF
4873* switch off new diffractive cross sections at low energies for nuclei
4874* (temporary solution)
4875 IF ((ISWMDL(30).NE.0).AND.((IP.GT.1).OR.(IT.GT.1))) THEN
4876 WRITE(LOUT,'(1X,A)')
4877 & ' DT_PHOINI: model-switch 30 for nuclei re-set !'
4878 CALL PHO_SETMDL(30,0,1)
4879 ENDIF
4880*
4881C IF (IJP.EQ.7) THEN
4882C AMP2 = SIGN(PMASS(1)**2,PMASS(1))
4883C PP(3) = PPCM
4884C PP(4) = SQRT(AMP2+PP(3)**2)
4885C ELSE
4886C PFERMX = ZERO
4887C IF (IP.GT.1) PFERMX = 0.5D0
4888C EFERMX = SQRT(PFERMX**2+PMASS(1)**2)
4889C CALL DT_LTNUC(PFERMX,EFERMX,PP(3),PP(4),2)
4890C ENDIF
4891C PFERMX = ZERO
4892C IF ((IT.GT.1).OR.(NCOMPO.GT.0)) PFERMX = -0.5D0
4893C EFERMX = SQRT(PFERMX**2+PMASS(2)**2)
4894C CALL DT_LTNUC(PFERMX,EFERMX,PT(3),PT(4),3)
4895**sr 26.10.96
4896 ISAV = IPAMDL(13)
4897 IF ((ISHAD(2).EQ.1).AND.
4898 & ((IJPROJ.EQ. 7).OR.(IJPROJ.EQ.3).OR.(IJPROJ.EQ.4).OR.
4899 & (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11))) IPAMDL(13) = 1
4900**
4901 CALL PHO_EVENT(-1,PP,PT,SIGMAX,IREJ1)
4902**sr 26.10.96
4903 IPAMDL(13) = ISAV
4904**
4905*
4906* patch for cascade calculations:
4907* define parton distribution functions for other hadrons, i.e. other
4908* then defined already in phojet
4909 IF (IOGLB.EQ.100) THEN
4910 WRITE(LOUT,1006)
4911 1006 FORMAT(/,1X,'PHOINI: additional parton distribution functions',
4912 & ' assiged (ID,IPAR,ISET)',/)
4913 NPDF = 0
4914 DO 3 I=1,30
4915 IF (IPARPD(I).NE.0) THEN
4916 NPDF = NPDF+1
4917 IF (NPDF.GT.MAXPDF) STOP ' PHOINI: npdf > maxpdf !'
4918 IF ((IPARPD(I).GT.0).AND.(ISETPD(I).GT.0)) THEN
4919 IDPDG = IDT_IPDGHA(I)
4920 IPAR = IPARPD(I)
4921 ISET = ISETPD(I)
4922 WRITE(LOUT,'(13X,A8,3I6)') ANAME(I),IDPDG,IPAR,ISET
4923 CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,0,0,-1)
4924 ENDIF
4925 ENDIF
4926 3 CONTINUE
4927 ENDIF
4928
4929C CALL PHO_PHIST(-1,SIGMAX)
4930 IF (IREJ1.NE.0) THEN
4931 WRITE(LOUT,1000)
4932 1000 FORMAT(1X,'PHOINI: PHOJET event-initialization failed!')
4933 STOP
4934 ENDIF
4935
4936 RETURN
4937 END
4938
4939*$ CREATE DT_EVENTD.FOR
4940*COPY DT_EVENTD
4941*
4942*===eventd=============================================================*
4943*
4944 SUBROUTINE DT_EVENTD(IREJ)
4945
4946************************************************************************
4947* Quasi-elastic neutrino nucleus scattering. *
4948* This version dated 29.04.00 is written by S. Roesler. *
4949************************************************************************
4950
4951 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4952 SAVE
4953 PARAMETER ( LINP = 10 ,
4954 & LOUT = 6 ,
4955 & LDAT = 9 )
4956 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY5=1.0D-5)
4957 PARAMETER (SQTINF=1.0D+15)
4958
4959 LOGICAL LFIRST
4960
4961* event history
4962 PARAMETER (NMXHKK=200000)
4963 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
4964 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
4965 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
4966* extended event history
4967 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
4968 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
4969 & IHIST(2,NMXHKK)
4970* flags for input different options
4971 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
4972 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
4973 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
4974 PARAMETER (MAXLND=4000)
4975 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
4976* properties of interacting particles
4977 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
4978* Lorentz-parameters of the current interaction
4979 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4980 & UMO,PPCM,EPROJ,PPROJ
4981* nuclear potential
4982 LOGICAL LFERMI
4983 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
4984 & EBINDP(2),EBINDN(2),EPOT(2,210),
4985 & ETACOU(2),ICOUL,LFERMI
4986* steering flags for qel neutrino scattering modules
4987 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
4988 COMMON /QNPOL/ POLARX(4),PMODUL
4989 INTEGER PYK
4990
4991 DATA LFIRST /.TRUE./
4992
4993 IREJ = 0
4994
4995 IF (LFIRST) THEN
4996 LFIRST = .FALSE.
4997 CALL DT_MASS_INI
4998 ENDIF
4999
5000* JETSET parameter
5001 CALL DT_INITJS(0)
5002
5003* interacting target nucleon
5004 LTYP = NEUTYP
5005 IF (NEUDEC.LE.9) THEN
5006 IF ((LTYP.EQ.1).OR.(LTYP.EQ.3).OR.(LTYP.EQ.5)) THEN
5007 NUCTYP = 2112
5008 NUCTOP = 2
5009 ELSE
5010 NUCTYP = 2212
5011 NUCTOP = 1
5012 ENDIF
5013 ELSE
5014 RTYP = DT_RNDM(RTYP)
5015 ZFRAC = DBLE(ITZ)/DBLE(IT)
5016 IF (RTYP.LE.ZFRAC) THEN
5017 NUCTYP = 2212
5018 NUCTOP = 1
5019 ELSE
5020 NUCTYP = 2112
5021 NUCTOP = 2
5022 ENDIF
5023 ENDIF
5024
5025* select first nucleon in list with matching id and reset all other
5026* nucleons which have been marked as "wounded" by ININUC
5027 IFOUND = 0
5028 DO 1 I=1,NHKK
5029 IF ((IDHKK(I).EQ.NUCTYP).AND.(IFOUND.EQ.0)) THEN
5030 ISTHKK(I) = 12
5031 IFOUND = 1
5032 IDX = I
5033 ELSE
5034 IF (ISTHKK(I).EQ.12) ISTHKK(I) = 14
5035 ENDIF
5036 1 CONTINUE
5037 IF (IFOUND.EQ.0)
5038 & STOP ' EVENTD: interacting target nucleon not found! '
5039
5040* correct position of proj. lepton: assume position of target nucleon
5041 DO 3 I=1,4
5042 VHKK(I,1) = VHKK(I,IDX)
5043 WHKK(I,1) = WHKK(I,IDX)
5044 3 CONTINUE
5045
5046* load initial momenta for conservation check
5047 IF (LEMCCK) THEN
5048 CALL DT_EVTEMC(ZERO,ZERO,PPROJ,EPROJ,1,IDUM,IDUM)
5049 CALL DT_EVTEMC(PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),PHKK(4,IDX),
5050 & 2,IDUM,IDUM)
5051 ENDIF
5052
5053* quasi-elastic scattering
5054 IF (NEUDEC.LT.9) THEN
5055 CALL DT_QEL_POL(EPROJ,LTYP,PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),
5056 & PHKK(4,IDX),PHKK(5,IDX))
5057* CC event on p or n
5058 ELSEIF (NEUDEC.EQ.10) THEN
5059 CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,1,PHKK(1,IDX),PHKK(2,IDX),
5060 & PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5061* NC event on p or n
5062 ELSEIF (NEUDEC.EQ.11) THEN
5063 CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,2,PHKK(1,IDX),PHKK(2,IDX),
5064 & PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5065 ENDIF
5066
5067* get final state particles from Lund-common and write them into HKKEVT
5068 NPOINT(1) = NHKK+1
5069 NPOINT(4) = NHKK+1
5070 NLINES = PYK(0,1)
5071 NHKK0 = NHKK+1
5072 DO 4 I=4,NLINES
5073 IF (K(I,1).EQ.1) THEN
5074 ID = K(I,2)
5075 PX = P(I,1)
5076 PY = P(I,2)
5077 PZ = P(I,3)
5078 PE = P(I,4)
5079 CALL DT_EVTPUT(1,ID,1,IDX,PX,PY,PZ,PE,0,0,0)
5080 IDBJ = IDT_ICIHAD(ID)
5081 EKIN = PHKK(4,NHKK)-PHKK(5,NHKK)
5082 IF ((IDBJ.EQ.1).OR.(IDBJ.EQ.8)) THEN
5083 IF (EKIN.LE.EPOT(2,IDBJ)) ISTHKK(NHKK) = 16
5084 ENDIF
5085 VHKK(1,NHKK) = VHKK(1,IDX)
5086 VHKK(2,NHKK) = VHKK(2,IDX)
5087 VHKK(3,NHKK) = VHKK(3,IDX)
5088 VHKK(4,NHKK) = VHKK(4,IDX)
5089C IF (I.EQ.4) THEN
5090C WHKK(1,NHKK) = POLARX(1)
5091C WHKK(2,NHKK) = POLARX(2)
5092C WHKK(3,NHKK) = POLARX(3)
5093C WHKK(4,NHKK) = POLARX(4)
5094C ELSE
5095 WHKK(1,NHKK) = WHKK(1,IDX)
5096 WHKK(2,NHKK) = WHKK(2,IDX)
5097 WHKK(3,NHKK) = WHKK(3,IDX)
5098 WHKK(4,NHKK) = WHKK(4,IDX)
5099C ENDIF
5100 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
5101 ENDIF
5102 4 CONTINUE
5103
5104 IF (LEMCCK) THEN
5105 CHKLEV = TINY5
5106 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,778,IREJ1)
5107 IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
5108 ENDIF
5109
5110* transform momenta into cms (as required for inc etc.)
5111 DO 5 I=NHKK0,NHKK
5112 IF (ISTHKK(I).EQ.1) THEN
5113 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,3)
5114 PHKK(3,I) = PZ
5115 PHKK(4,I) = PE
5116 ENDIF
5117 5 CONTINUE
5118
5119 RETURN
5120 END
5121
5122*$ CREATE DT_KKEVNT.FOR
5123*COPY DT_KKEVNT
5124*
5125*===kkevnt=============================================================*
5126*
5127 SUBROUTINE DT_KKEVNT(KKMAT,IREJ)
5128
5129************************************************************************
5130* Treatment of complete nucleus-nucleus or hadron-nucleus scattering *
5131* without nuclear effects (one event). *
5132* This subroutine is an update of the previous version (KKEVT) written *
5133* by J. Ranft/ H.-J. Moehring. *
5134* This version dated 20.04.95 is written by S. Roesler *
5135************************************************************************
5136
5137 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5138 SAVE
5139 PARAMETER ( LINP = 10 ,
5140 & LOUT = 6 ,
5141 & LDAT = 9 )
5142 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10)
5143
5144 PARAMETER ( MAXNCL = 260,
5145 & MAXVQU = MAXNCL,
5146 & MAXSQU = 20*MAXVQU,
5147 & MAXINT = MAXVQU+MAXSQU)
5148* event history
5149 PARAMETER (NMXHKK=200000)
5150 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5151 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5152 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5153* extended event history
5154 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5155 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5156 & IHIST(2,NMXHKK)
5157* flags for input different options
5158 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5159 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5160 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5161* rejection counter
5162 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
5163 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
5164 & IREXCI(3),IRDIFF(2),IRINC
5165* statistics
5166 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5167 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5168 & ICEVTG(8,0:30)
5169* properties of interacting particles
5170 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5171* Lorentz-parameters of the current interaction
5172 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5173 & UMO,PPCM,EPROJ,PPROJ
5174* flags for diffractive interactions (DTUNUC 1.x)
5175 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
5176* interface HADRIN-DPM
5177 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5178* nucleon-nucleon event-generator
5179 CHARACTER*8 CMODEL
5180 LOGICAL LPHOIN
5181 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
5182* coordinates of nucleons
5183 COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
5184* interface between Glauber formalism and DPM
5185 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
5186 & INTER1(MAXINT),INTER2(MAXINT)
5187* Glauber formalism: collision properties
5188 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
7cbda79e 5189 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
5190 & NCP,NCT
9aaba0d6 5191* central particle production, impact parameter biasing
5192 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5193**temporary
5194* statistics: Glauber-formalism
5195 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
5196**
5197
5198 DATA NEVOLD,IPOLD,ITOLD,JJPOLD,EPROLD /4*0,0.0D0/
5199
5200 IREJ = 0
5201 ICREQU = ICREQU+1
5202 NC = 0
e3f546f5 5203
9aaba0d6 5204 1 CONTINUE
5205 ICSAMP = ICSAMP+1
5206 NC = NC+1
5207 IF (MOD(NC,10).EQ.0) THEN
5208 WRITE(LOUT,1000) NEVHKK
5209 1000 FORMAT(1X,'KKEVNT: event ',I8,' rejected!')
5210 GOTO 9999
5211 ENDIF
5212
5213* initialize DTEVT1/DTEVT2
5214 CALL DT_EVTINI
5215
5216* We need the following only in order to sample nucleon coordinates.
5217* However we don't have parameters (cross sections, slope etc.)
5218* for neutrinos available. Therefore switch projectile to proton
5219* in this case.
5220 IF (MCGENE.EQ.4) THEN
5221 JJPROJ = 1
5222 ELSE
5223 JJPROJ = IJPROJ
5224 ENDIF
5225
5226 10 CONTINUE
5227 IF ( (NEVHKK.NE.NEVOLD).OR.(ICENTR.GT.0).OR.
5228* make sure that Glauber-formalism is called each time the interaction
5229* configuration changed
5230 & (IP.NE.IPOLD).OR.(IT.NE.ITOLD).OR.(JJPROJ.NE.JJPOLD).OR.
5231 & (ABS(EPROJ-EPROLD).GT.TINY10) ) THEN
5232* sample number of nucleon-nucleon coll. according to Glauber-form.
5233 CALL DT_GLAUBE(IP,IT,JJPROJ,BIMPAC,NN,NP,NT,JSSH,JTSH,KKMAT)
5234 NWTSAM = NN
5235 NWASAM = NP
5236 NWBSAM = NT
5237 NEVOLD = NEVHKK
5238 IPOLD = IP
5239 ITOLD = IT
5240 JJPOLD = JJPROJ
5241 EPROLD = EPROJ
e3f546f5 5242 NCP = 0
5243 NCT = 0
5244
7cbda79e 5245 DO 8 I=1, IP
5246 NCP = NCP+JSSH(I)
5247* WRITE(6,*)' PROJ.NUCL. ',I,' NCOLL = ',NCP
5248 8 CONTINUE
e3f546f5 5249 write(6,*) "why this (1)", NCP, NCT
7cbda79e 5250 DO 9 I=1, IT
e3f546f5 5251 NCT = NCT +JTSH(I)
5252* WRITE(6,*)' TAR.NUCL. ',I,' NCOLL = ',NCT
7cbda79e 5253 9 CONTINUE
e3f546f5 5254 ENDIF
9aaba0d6 5255
5256* force diffractive particle production in h-K interactions
5257 IF (((ABS(ISINGD).GT.1).OR.(ABS(IDOUBD).GT.1)).AND.
5258 & (IP.EQ.1).AND.(NN.NE.1)) THEN
5259 NEVOLD = 0
5260 GOTO 10
5261 ENDIF
5262
5263* check number of involved proj. nucl. (NP) if central prod.is requested
5264 IF (ICENTR.GT.0) THEN
5265 CALL DT_CHKCEN(IP,IT,NP,NT,IBACK)
5266 IF (IBACK.GT.0) GOTO 10
5267 ENDIF
5268
5269* get initial nucleon-configuration in projectile and target
5270* rest-system (including Fermi-momenta if requested)
5271 CALL DT_ININUC(IJPROJ,IP,IPZ,PKOO,JSSH,1)
5272 MODE = 2
5273 IF (EPROJ.LE.EHADTH) MODE = 3
5274 CALL DT_ININUC(IJTARG,IT,ITZ,TKOO,JTSH,MODE)
5275
5276 IF ((MCGENE.NE.3).AND.(MCGENE.NE.4)) THEN
5277
5278* activate HADRIN at low energies (implemented for h-N scattering only)
5279 IF (EPROJ.LE.EHADHI) THEN
5280 IF (EHADTH.LT.ZERO) THEN
5281* smooth transition btwn. DPM and HADRIN
5282 FRAC = (EPROJ-EHADLO)/(EHADHI-EHADLO)
5283 RR = DT_RNDM(FRAC)
5284 IF (RR.GT.FRAC) THEN
5285 IF (IP.EQ.1) THEN
5286 CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5287 IF (IREJ1.GT.0) GOTO 1
5288 RETURN
5289 ELSE
5290 WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5291 ENDIF
5292 ENDIF
5293 ELSE
5294* fixed threshold for onset of production via HADRIN
5295 IF (EPROJ.LE.EHADTH) THEN
5296 IF (IP.EQ.1) THEN
5297 CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5298 IF (IREJ1.GT.0) GOTO 1
5299 RETURN
5300 ELSE
5301 WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5302 ENDIF
5303 ENDIF
5304 ENDIF
5305 ENDIF
5306 1001 FORMAT(1X,'KKEVNT: warning! interaction of proj. (m=',
5307 & I3,') with target (m=',I3,')',/,11X,
5308 & 'at E_lab=',F5.1,'GeV (threshold-energy: ',F3.1,
5309 & 'GeV) cannot be handled')
5310
5311* sampling of momentum-x fractions & flavors of chain ends
5312 CALL DT_SPLPTN(NN)
5313
5314* Lorentz-transformation of wounded nucleons into nucl.-nucl. cms
5315 CALL DT_NUC2CM
5316
5317* collect momenta of chain ends and put them into DTEVT1
5318 CALL DT_GETPTN(IP,NN,NCSY,IREJ1)
5319 IF (IREJ1.NE.0) GOTO 1
5320
5321 ENDIF
5322
5323* handle chains including fragmentation (two-chain approximation)
5324 IF (MCGENE.EQ.1) THEN
5325* two-chain approximation
5326 CALL DT_EVENTA(IJPROJ,IP,IT,NCSY,IREJ1)
5327 IF (IREJ1.NE.0) THEN
5328 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKEVNT'
5329 GOTO 1
5330 ENDIF
5331 ELSEIF (MCGENE.EQ.2) THEN
5332* multiple-Po exchange including minijets
5333 CALL DT_EVENTB(NCSY,IREJ1)
5334 IF (IREJ1.NE.0) THEN
5335 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKEVNT'
5336 GOTO 1
5337 ENDIF
5338 ELSEIF (MCGENE.EQ.3) THEN
5339 STOP ' This version does not contain LEPTO !'
5340 ELSEIF (MCGENE.EQ.4) THEN
5341* quasi-elastic neutrino scattering
5342 CALL DT_EVENTD(IREJ1)
5343 IF (IREJ1.NE.0) THEN
5344 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 4 in KKEVNT'
5345 GOTO 1
5346 ENDIF
5347 ELSE
5348 WRITE(LOUT,1002) MCGENE
5349 1002 FORMAT(1X,'KKEVNT: warning! event-generator',I4,
5350 & ' not available - program stopped')
5351 STOP
5352 ENDIF
5353
5354 RETURN
5355
5356 9999 CONTINUE
5357 IREJ = 1
5358 RETURN
5359 END
5360
5361*$ CREATE DT_CHKCEN.FOR
5362*COPY DT_CHKCEN
5363*
5364*===chkcen=============================================================*
5365*
5366 SUBROUTINE DT_CHKCEN(IP,IT,NP,NT,IBACK)
5367
5368************************************************************************
5369* Check of number of involved projectile nucleons if central production*
5370* is requested. *
5371* Adopted from a part of the old KKEVT routine which was written by *
5372* J. Ranft/H.-J.Moehring. *
5373* This version dated 13.01.95 is written by S. Roesler *
5374************************************************************************
5375
5376 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5377 SAVE
5378 PARAMETER ( LINP = 10 ,
5379 & LOUT = 6 ,
5380 & LDAT = 9 )
5381
5382* statistics
5383 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5384 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5385 & ICEVTG(8,0:30)
5386* central particle production, impact parameter biasing
5387 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5388
5389 IBACK = 0
5390
5391* old version
5392 IF (ICENTR.EQ.2) THEN
5393 IF (IP.LT.IT) THEN
5394 IF (IP.LE.8) THEN
5395 IF (NP.LT.IP-1) IBACK = 1
5396 ELSEIF (IP.LE.16) THEN
5397 IF (NP.LT.IP-2) IBACK = 1
5398 ELSEIF (IP.LE.32) THEN
5399 IF (NP.LT.IP-3) IBACK = 1
5400 ELSEIF (IP.GE.33) THEN
5401 IF (NP.LT.IP-5) IBACK = 1
5402 ENDIF
5403 ELSEIF (IP.EQ.IT) THEN
5404 IF (IP.EQ.32) THEN
5405 IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5406 ELSE
5407 IF (NP.LT.IP-IP/8) IBACK = 1
5408 ENDIF
5409 ELSEIF (ABS(IP-IT).LT.3) THEN
5410 IF (NP.LT.IP-IP/8) IBACK = 1
5411 ENDIF
5412 ELSE
5413* new version (DPMJET, 5.6.99)
5414 IF (IP.LT.IT) THEN
5415 IF (IP.LE.8) THEN
5416 IF (NP.LT.IP-1) IBACK = 1
5417 ELSEIF (IP.LE.16) THEN
5418 IF (NP.LT.IP-2) IBACK = 1
5419 ELSEIF (IP.LT.32) THEN
5420 IF (NP.LT.IP-3) IBACK = 1
5421 ELSEIF (IP.GE.32) THEN
5422 IF (IT.LE.150) THEN
5423* Example: S-Ag
5424 IF (NP.LT.IP-1) IBACK = 1
5425 ELSE
5426* Example: S-Au
5427 IF (NP.LT.IP) IBACK = 1
5428 ENDIF
5429 ENDIF
5430 ELSEIF (IP.EQ.IT) THEN
5431* Example: S-S
5432 IF (IP.EQ.32) THEN
5433 IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5434* Example: Pb-Pb
5435 ELSE
5436 IF (NP.LT.IP-IP/4) IBACK = 1
5437 ENDIF
5438 ELSEIF (ABS(IP-IT).LT.3) THEN
5439 IF (NP.LT.IP-IP/8) IBACK = 1
5440 ENDIF
5441 ENDIF
5442
5443 ICCPRO = ICCPRO+1
5444
5445 RETURN
5446 END
5447
5448*$ CREATE DT_ININUC.FOR
5449*COPY DT_ININUC
5450*
5451*===ininuc=============================================================*
5452*
5453 SUBROUTINE DT_ININUC(ID,NMASS,NCH,COORD,JS,IMODE)
5454
5455************************************************************************
5456* Samples initial configuration of nucleons in nucleus with mass NMASS *
5457* including Fermi-momenta (if reqested). *
5458* ID BAMJET-code for hadrons (instead of nuclei) *
5459* NMASS mass number of nucleus (number of nucleons) *
5460* NCH charge of nucleus *
5461* COORD(3,NMASS) coordinates of nucleons inside nucleus in fm *
5462* JS(NMASS) > 0 nucleon undergoes nucleon-nucleon interact. *
5463* IMODE = 1 projectile nucleus *
5464* = 2 target nucleus *
5465* = 3 target nucleus (E_lab<E_thr for HADRIN) *
5466* Adopted from a part of the old KKEVT routine which was written by *
5467* J. Ranft/H.-J.Moehring. *
5468* This version dated 13.01.95 is written by S. Roesler *
5469************************************************************************
5470
5471 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5472 SAVE
5473 PARAMETER ( LINP = 10 ,
5474 & LOUT = 6 ,
5475 & LDAT = 9 )
5476 PARAMETER (FM2MM=1.0D-12)
5477
5478 PARAMETER ( MAXNCL = 260,
5479 & MAXVQU = MAXNCL,
5480 & MAXSQU = 20*MAXVQU,
5481 & MAXINT = MAXVQU+MAXSQU)
5482* event history
5483 PARAMETER (NMXHKK=200000)
5484 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5485 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5486 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5487* extended event history
5488 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5489 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5490 & IHIST(2,NMXHKK)
5491* flags for input different options
5492 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5493 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5494 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5495* auxiliary common for chain system storage (DTUNUC 1.x)
5496 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
5497* nuclear potential
5498 LOGICAL LFERMI
5499 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5500 & EBINDP(2),EBINDN(2),EPOT(2,210),
5501 & ETACOU(2),ICOUL,LFERMI
5502* properties of photon/lepton projectiles
5503 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5504* particle properties (BAMJET index convention)
5505 CHARACTER*8 ANAME
5506 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5507 & IICH(210),IIBAR(210),K1(210),K2(210)
5508* Glauber formalism: collision properties
5509 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
e3f546f5 5510 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
5511 & NCP,NCT
9aaba0d6 5512* flavors of partons (DTUNUC 1.x)
5513 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5514 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5515 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
5516 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5517 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
5518 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5519 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
5520* interface HADRIN-DPM
5521 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5522
5523 DIMENSION PF(4),PFTOT(4),COORD(3,MAXNCL),JS(MAXNCL)
5524
5525* number of neutrons
5526 NNEU = NMASS-NCH
5527* initializations
5528 NP = 0
5529 NN = 0
5530 DO 1 K=1,4
5531 PFTOT(K) = 0.0D0
5532 1 CONTINUE
5533 MODE = IMODE
5534 IF (IMODE.GT.2) MODE = 2
5535**sr 29.5. new NPOINT(1)-definition
5536C IF (IMODE.GE.2) NPOINT(1) = NHKK+1
5537**
5538 NHADRI = 0
5539 NC = NHKK
5540
5541* get initial configuration
5542 DO 2 I=1,NMASS
5543 NHKK = NHKK+1
5544 IF (JS(I).GT.0) THEN
5545 ISTHKK(NHKK) = 10+MODE
5546 IF (IMODE.EQ.3) THEN
5547* additional treatment if HADRIN-generator is requested
5548 NHADRI = NHADRI+1
5549 IF (NHADRI.EQ.1) IDXTA = NHKK
5550 IF (NHADRI.GT.1) ISTHKK(NHKK) = 14
5551 ENDIF
5552 ELSE
5553 ISTHKK(NHKK) = 12+MODE
5554 ENDIF
5555 IF (NMASS.GE.2) THEN
5556* treatment for nuclei
5557 FRAC = 1.0D0-DBLE(NCH)/DBLE(NMASS)
5558 RR = DT_RNDM(FRAC)
5559 IF ((RR.LT.FRAC).AND.(NN.LT.NNEU)) THEN
5560 IDX = 8
5561 NN = NN+1
5562 ELSEIF ((RR.GE.FRAC).AND.(NP.LT.NCH)) THEN
5563 IDX = 1
5564 NP = NP+1
5565 ELSEIF (NN.LT.NNEU) THEN
5566 IDX = 8
5567 NN = NN+1
5568 ELSEIF (NP.LT.NCH) THEN
5569 IDX = 1
5570 NP = NP+1
5571 ENDIF
5572 IDHKK(NHKK) = IDT_IPDGHA(IDX)
5573 IDBAM(NHKK) = IDX
5574 IF (MODE.EQ.1) THEN
5575 IPOSP(I) = NHKK
5576 KKPROJ(I) = IDX
5577 ELSE
5578 IPOST(I) = NHKK
5579 KKTARG(I) = IDX
5580 ENDIF
5581 IF (IDX.EQ.1) THEN
5582 PFER = PFERMP(MODE)
5583 PBIN = SQRT(2.0D0*EBINDP(MODE)*AAM(1))
5584 ELSE
5585 PFER = PFERMN(MODE)
5586 PBIN = SQRT(2.0D0*EBINDN(MODE)*AAM(8))
5587 ENDIF
5588 CALL DT_FER4M(PFER,PBIN,PF(1),PF(2),PF(3),PF(4),IDX)
5589 DO 3 K=1,4
5590 PFTOT(K) = PFTOT(K)+PF(K)
5591 PHKK(K,NHKK) = PF(K)
5592 3 CONTINUE
5593 PHKK(5,NHKK) = AAM(IDX)
5594 ELSE
5595* treatment for hadrons
5596 IDHKK(NHKK) = IDT_IPDGHA(ID)
5597 IDBAM(NHKK) = ID
5598 PHKK(4,NHKK) = AAM(ID)
5599 PHKK(5,NHKK) = AAM(ID)
5600C* VDM assumption
5601C IF (IDHKK(NHKK).EQ.22) THEN
5602C PHKK(4,NHKK) = AAM(33)
5603C PHKK(5,NHKK) = AAM(33)
5604C ENDIF
5605 IF (MODE.EQ.1) THEN
5606 IPOSP(I) = NHKK
5607 KKPROJ(I) = ID
5608 PHKK(5,NHKK) = PHKK(5,NHKK)-SQRT(VIRT)
5609 ELSE
5610 IPOST(I) = NHKK
5611 KKTARG(I) = ID
5612 ENDIF
5613 ENDIF
5614 DO 4 K=1,3
5615 VHKK(K,NHKK) = COORD(K,I)*FM2MM
5616 WHKK(K,NHKK) = COORD(K,I)*FM2MM
5617 4 CONTINUE
5618 IF (MODE.EQ.2) VHKK(1,NHKK) = VHKK(1,NHKK)+BIMPAC*FM2MM
5619 IF (MODE.EQ.2) WHKK(1,NHKK) = WHKK(1,NHKK)+BIMPAC*FM2MM
5620 VHKK(4,NHKK) = 0.0D0
5621 WHKK(4,NHKK) = 0.0D0
5622 2 CONTINUE
5623
5624* balance Fermi-momenta
5625 IF (NMASS.GE.2) THEN
5626 DO 5 I=1,NMASS
5627 NC = NC+1
5628 DO 6 K=1,3
5629 PHKK(K,NC) = PHKK(K,NC)-PFTOT(K)/DBLE(NMASS)
5630 6 CONTINUE
5631 PHKK(4,NC) = SQRT(PHKK(5,NC)**2+PHKK(1,NC)**2+
5632 & PHKK(2,NC)**2+PHKK(3,NC)**2)
5633 5 CONTINUE
5634 ENDIF
5635
5636 RETURN
5637 END
5638
5639*$ CREATE DT_FER4M.FOR
5640*COPY DT_FER4M
5641*
5642*===fer4m==============================================================*
5643*
5644 SUBROUTINE DT_FER4M(PFERM,PBIND,PXT,PYT,PZT,ET,KT)
5645
5646************************************************************************
5647* Sampling of nucleon Fermi-momenta from distributions at T=0. *
5648* processed by S. Roesler, 17.10.95 *
5649************************************************************************
5650
5651 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5652 SAVE
5653 PARAMETER ( LINP = 10 ,
5654 & LOUT = 6 ,
5655 & LDAT = 9 )
5656
5657 LOGICAL LSTART
5658
5659* particle properties (BAMJET index convention)
5660 CHARACTER*8 ANAME
5661 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5662 & IICH(210),IIBAR(210),K1(210),K2(210)
5663* nuclear potential
5664 LOGICAL LFERMI
5665 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5666 & EBINDP(2),EBINDN(2),EPOT(2,210),
5667 & ETACOU(2),ICOUL,LFERMI
5668
5669 DATA LSTART /.TRUE./
5670
5671 ILOOP = 0
5672 IF (LFERMI) THEN
5673 IF (LSTART) THEN
5674 WRITE(LOUT,1000)
5675 1000 FORMAT(/,1X,'FER4M: sampling of Fermi-momenta activated')
5676 LSTART = .FALSE.
5677 ENDIF
5678 1 CONTINUE
5679 CALL DT_DFERMI(PABS)
5680 PABS = PFERM*PABS
5681C IF (PABS.GE.PBIND) THEN
5682C ILOOP = ILOOP+1
5683C IF (MOD(ILOOP,500).EQ.0) THEN
5684C WRITE(LOUT,1001) PABS,PBIND,ILOOP
5685C1001 FORMAT(1X,'FER4M: Fermi-mom. corr. for binding',
5686C & ' energy ',2E12.3,I6)
5687C ENDIF
5688C GOTO 1
5689C ENDIF
5690 CALL DT_DPOLI(POLC,POLS)
5691 CALL DT_DSFECF(SFE,CFE)
5692 CXTA = POLS*CFE
5693 CYTA = POLS*SFE
5694 CZTA = POLC
5695 ET = SQRT(PABS*PABS+AAM(KT)**2)
5696 PXT = CXTA*PABS
5697 PYT = CYTA*PABS
5698 PZT = CZTA*PABS
5699 ELSE
5700 ET = AAM(KT)
5701 PXT = 0.0D0
5702 PYT = 0.0D0
5703 PZT = 0.0D0
5704 ENDIF
5705
5706 RETURN
5707 END
5708
5709*$ CREATE DT_NUC2CM.FOR
5710*COPY DT_NUC2CM
5711*
5712*===nuc2cm=============================================================*
5713*
5714 SUBROUTINE DT_NUC2CM
5715
5716************************************************************************
5717* Lorentz-transformation of all wounded nucleons from Lab. to nucl.- *
5718* nucl. cms. (This subroutine replaces NUCMOM.) *
5719* This version dated 15.01.95 is written by S. Roesler *
5720************************************************************************
5721
5722 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5723 SAVE
5724 PARAMETER ( LINP = 10 ,
5725 & LOUT = 6 ,
5726 & LDAT = 9 )
5727 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
5728
5729* event history
5730 PARAMETER (NMXHKK=200000)
5731 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5732 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5733 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5734* extended event history
5735 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5736 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5737 & IHIST(2,NMXHKK)
5738* statistics
5739 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5740 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5741 & ICEVTG(8,0:30)
5742* properties of photon/lepton projectiles
5743 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5744* particle properties (BAMJET index convention)
5745 CHARACTER*8 ANAME
5746 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5747 & IICH(210),IIBAR(210),K1(210),K2(210)
5748* Glauber formalism: collision properties
5749 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
e3f546f5 5750 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
5751 & NCP,NCT
9aaba0d6 5752**temporary
5753* statistics: Glauber-formalism
5754 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
5755**
5756
5757 ICWP = 0
5758 ICWT = 0
5759 NWTACC = 0
5760 NWAACC = 0
5761 NWBACC = 0
5762
5763 NPOINT(1) = NHKK+1
5764 NEND = NHKK
5765 DO 1 I=1,NEND
5766 IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.12)) THEN
5767 IF (ISTHKK(I).EQ.11) NWAACC = NWAACC+1
5768 IF (ISTHKK(I).EQ.12) NWBACC = NWBACC+1
5769 MODE = ISTHKK(I)-9
5770C IF (IDHKK(I).EQ.22) THEN
5771C* VDM assumption
5772C PEIN = AAM(33)
5773C IDB = 33
5774C ELSE
5775C PEIN = PHKK(4,I)
5776C IDB = IDBAM(I)
5777C ENDIF
5778C CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PEIN,
5779C & PX,PY,PZ,PE,IDB,MODE)
5780 IF (PHKK(5,I).GT.ZERO) THEN
5781 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
5782 & PX,PY,PZ,PE,IDBAM(I),MODE)
5783 ELSE
5784 PX = PGAMM(1)
5785 PY = PGAMM(2)
5786 PZ = PGAMM(3)
5787 PE = PGAMM(4)
5788 ENDIF
5789 IST = ISTHKK(I)-2
5790 ID = IDHKK(I)
5791C* VDM assumption
5792C IF (ID.EQ.22) ID = 113
5793 CALL DT_EVTPUT(IST,ID,I,0,PX,PY,PZ,PE,0,0,0)
5794 IF (ISTHKK(I).EQ.11) ICWP = ICWP+1
5795 IF (ISTHKK(I).EQ.12) ICWT = ICWT+1
5796 ENDIF
5797 1 CONTINUE
5798
5799 NWTACC = MAX(NWAACC,NWBACC)
5800 ICDPR = ICDPR+ICWP
5801 ICDTA = ICDTA+ICWT
5802**temporary
5803 IF ((ICWP.EQ.0).OR.(ICWT.EQ.0)) THEN
5804 CALL DT_EVTOUT(4)
5805 STOP
5806 ENDIF
5807
5808 RETURN
5809 END
5810
5811*$ CREATE DT_SPLPTN.FOR
5812*COPY DT_SPLPTN
5813*
5814*===splptn=============================================================*
5815*
5816 SUBROUTINE DT_SPLPTN(NN)
5817
5818************************************************************************
5819* SamPLing of ParToN momenta and flavors. *
5820* This version dated 15.01.95 is written by S. Roesler *
5821************************************************************************
5822
5823 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5824 SAVE
5825 PARAMETER ( LINP = 10 ,
5826 & LOUT = 6 ,
5827 & LDAT = 9 )
5828
5829* Lorentz-parameters of the current interaction
5830 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5831 & UMO,PPCM,EPROJ,PPROJ
5832
5833* sample flavors of sea-quarks
5834 CALL DT_SPLFLA(NN,1)
5835
5836* sample x-values of partons at chain ends
5837 ECM = UMO
5838 CALL DT_XKSAMP(NN,ECM)
5839
5840* samle flavors
5841 CALL DT_SPLFLA(NN,2)
5842
5843 RETURN
5844 END
5845
5846*$ CREATE DT_SPLFLA.FOR
5847*COPY DT_SPLFLA
5848*
5849*===splfla=============================================================*
5850*
5851 SUBROUTINE DT_SPLFLA(NN,MODE)
5852
5853************************************************************************
5854* SamPLing of FLAvors of partons at chain ends. *
5855* This subroutine replaces FLKSAA/FLKSAM. *
5856* NN number of nucleon-nucleon interactions *
5857* MODE = 1 sea-flavors *
5858* = 2 valence-flavors *
5859* Based on the original version written by J. Ranft/H.-J. Moehring. *
5860* This version dated 16.01.95 is written by S. Roesler *
5861************************************************************************
5862
5863 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5864 SAVE
5865 PARAMETER ( LINP = 10 ,
5866 & LOUT = 6 ,
5867 & LDAT = 9 )
5868
5869 PARAMETER ( MAXNCL = 260,
5870 & MAXVQU = MAXNCL,
5871 & MAXSQU = 20*MAXVQU,
5872 & MAXINT = MAXVQU+MAXSQU)
5873* flavors of partons (DTUNUC 1.x)
5874 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5875 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5876 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
5877 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5878 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
5879 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5880 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
5881* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5882 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
5883 & IXPV,IXPS,IXTV,IXTS,
5884 & INTVV1(MAXVQU),INTVV2(MAXVQU),
5885 & INTSV1(MAXVQU),INTSV2(MAXVQU),
5886 & INTVS1(MAXVQU),INTVS2(MAXVQU),
5887 & INTSS1(MAXSQU),INTSS2(MAXSQU),
5888 & INTDV1(MAXVQU),INTDV2(MAXVQU),
5889 & INTVD1(MAXVQU),INTVD2(MAXVQU),
5890 & INTDS1(MAXSQU),INTDS2(MAXSQU),
5891 & INTSD1(MAXSQU),INTSD2(MAXSQU)
5892* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5893 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
5894 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
5895* particle properties (BAMJET index convention)
5896 CHARACTER*8 ANAME
5897 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5898 & IICH(210),IIBAR(210),K1(210),K2(210)
5899* various options for treatment of partons (DTUNUC 1.x)
5900* (chain recombination, Cronin,..)
5901 LOGICAL LCO2CR,LINTPT
5902 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
5903 & LCO2CR,LINTPT
5904
5905 IF (MODE.EQ.1) THEN
5906* sea-flavors
5907 DO 1 I=1,NN
5908 IPSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
5909 IPSAQ(I) = -IPSQ(I)
5910 1 CONTINUE
5911 DO 2 I=1,NN
5912 ITSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
5913 ITSAQ(I)= -ITSQ(I)
5914 2 CONTINUE
5915 ELSEIF (MODE.EQ.2) THEN
5916* valence flavors
5917 DO 3 I=1,IXPV
5918 CALL DT_FLAHAD(KKPROJ(IFROVP(I)),IPVQ(I),IPPV1(I),IPPV2(I))
5919 3 CONTINUE
5920 DO 4 I=1,IXTV
5921 CALL DT_FLAHAD(KKTARG(IFROVT(I)),ITVQ(I),ITTV1(I),ITTV2(I))
5922 4 CONTINUE
5923 ENDIF
5924
5925 RETURN
5926 END
5927
5928*$ CREATE DT_GETPTN.FOR
5929*COPY DT_GETPTN
5930*
5931*===getptn=============================================================*
5932*
5933 SUBROUTINE DT_GETPTN(IP,NN,NCSY,IREJ)
5934
5935************************************************************************
5936* This subroutine collects partons at chain ends from temporary *
5937* commons and puts them into DTEVT1. *
5938* This version dated 15.01.95 is written by S. Roesler *
5939************************************************************************
5940
5941 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5942 SAVE
5943 PARAMETER ( LINP = 10 ,
5944 & LOUT = 6 ,
5945 & LDAT = 9 )
5946 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0)
5947
5948 LOGICAL LCHK
5949
5950 PARAMETER ( MAXNCL = 260,
5951 & MAXVQU = MAXNCL,
5952 & MAXSQU = 20*MAXVQU,
5953 & MAXINT = MAXVQU+MAXSQU)
5954* event history
5955 PARAMETER (NMXHKK=200000)
5956 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5957 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5958 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5959* extended event history
5960 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5961 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5962 & IHIST(2,NMXHKK)
5963* flags for input different options
5964 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5965 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5966 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5967* auxiliary common for chain system storage (DTUNUC 1.x)
5968 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
5969* statistics
5970 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5971 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5972 & ICEVTG(8,0:30)
5973* flags for diffractive interactions (DTUNUC 1.x)
5974 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
5975* x-values of partons (DTUNUC 1.x)
5976 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
5977 & XTVQ(MAXVQU),XTVD(MAXVQU),
5978 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
5979 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
5980* flavors of partons (DTUNUC 1.x)
5981 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5982 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5983 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
5984 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5985 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
5986 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5987 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
5988* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5989 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
5990 & IXPV,IXPS,IXTV,IXTS,
5991 & INTVV1(MAXVQU),INTVV2(MAXVQU),
5992 & INTSV1(MAXVQU),INTSV2(MAXVQU),
5993 & INTVS1(MAXVQU),INTVS2(MAXVQU),
5994 & INTSS1(MAXSQU),INTSS2(MAXSQU),
5995 & INTDV1(MAXVQU),INTDV2(MAXVQU),
5996 & INTVD1(MAXVQU),INTVD2(MAXVQU),
5997 & INTDS1(MAXSQU),INTDS2(MAXSQU),
5998 & INTSD1(MAXSQU),INTSD2(MAXSQU)
5999* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6000 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
6001 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
6002
6003 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PP(4),PT(4)
6004
6005 DATA AMSS,AMVS,AMDS,AMVD,AMVV/0.4D0,2.0D0,2.0D0,2.5D0,2.0D0/
6006
6007 IREJ = 0
6008 NCSY = 0
6009 NPOINT(2) = NHKK+1
6010
6011* sea-sea chains
6012 DO 10 I=1,NSS
6013 IF (ISKPCH(1,I).EQ.99) GOTO 10
6014 ICCHAI(1,1) = ICCHAI(1,1)+2
6015 IDXP = INTSS1(I)
6016 IDXT = INTSS2(I)
6017 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6018 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6019 DO 11 K=1,4
6020 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6021 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6022 PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6023 PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6024 11 CONTINUE
6025 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6026 & +(PP1(3)+PT1(3))**2)
6027 ECH = PP1(4)+PT1(4)
6028 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6029 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6030 & +(PP2(3)+PT2(3))**2)
6031 ECH = PP2(4)+PT2(4)
6032 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6033 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6034 AM1 = SQRT(AM1)
6035 AM2 = SQRT(AM2)
6036 IF ((AM1.LT.AMSS).OR.(AM2.LT.AMSS)) THEN
6037C WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6038 5000 FORMAT(1X,'incon. chain mass SS: ',2I5,2E10.3)
6039 ENDIF
6040 ELSE
6041 WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6042 ENDIF
6043 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6044 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6045 IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6046 IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6047 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6048 & 0,0,1)
6049 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6050 & 0,0,1)
6051 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6052 & 0,0,1)
6053 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6054 & 0,0,1)
6055 NCSY = NCSY+1
6056 10 CONTINUE
6057
6058* disea-sea chains
6059 DO 20 I=1,NDS
6060 IF (ISKPCH(2,I).EQ.99) GOTO 20
6061 ICCHAI(1,2) = ICCHAI(1,2)+2
6062 IDXP = INTDS1(I)
6063 IDXT = INTDS2(I)
6064 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6065 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6066 DO 21 K=1,4
6067 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6068 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6069 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6070 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6071 21 CONTINUE
6072 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6073 & +(PP1(3)+PT1(3))**2)
6074 ECH = PP1(4)+PT1(4)
6075 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6076 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6077 & +(PP2(3)+PT2(3))**2)
6078 ECH = PP2(4)+PT2(4)
6079 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6080 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6081 AM1 = SQRT(AM1)
6082 AM2 = SQRT(AM2)
6083 IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6084C WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6085 5001 FORMAT(1X,'incon. chain mass DS: ',2I5,2E10.3)
6086 ENDIF
6087 ELSE
6088 WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6089 ENDIF
6090 IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6091 IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6092 IFT1 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6093 IFT2 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6094 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6095 & 0,0,2)
6096 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6097 & 0,0,2)
6098 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6099 & 0,0,2)
6100 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6101 & 0,0,2)
6102 NCSY = NCSY+1
6103 20 CONTINUE
6104
6105* sea-disea chains
6106 DO 30 I=1,NSD
6107 IF (ISKPCH(3,I).EQ.99) GOTO 30
6108 ICCHAI(1,3) = ICCHAI(1,3)+2
6109 IDXP = INTSD1(I)
6110 IDXT = INTSD2(I)
6111 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6112 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6113 DO 31 K=1,4
6114 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6115 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6116 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6117 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6118 31 CONTINUE
6119 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6120 & +(PP1(3)+PT1(3))**2)
6121 ECH = PP1(4)+PT1(4)
6122 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6123 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6124 & +(PP2(3)+PT2(3))**2)
6125 ECH = PP2(4)+PT2(4)
6126 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6127 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6128 AM1 = SQRT(AM1)
6129 AM2 = SQRT(AM2)
6130 IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6131C WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6132 5002 FORMAT(1X,'incon. chain mass SD: ',2I5,2E10.3)
6133 ENDIF
6134 ELSE
6135 WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6136 ENDIF
6137 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6138 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6139 IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6140 IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6141 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6142 & 0,0,3)
6143 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6144 & 0,0,3)
6145 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6146 & 0,0,3)
6147 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6148 & 0,0,3)
6149 NCSY = NCSY+1
6150 30 CONTINUE
6151
6152* disea-valence chains
6153 DO 50 I=1,NDV
6154 IF (ISKPCH(5,I).EQ.99) GOTO 50
6155 ICCHAI(1,5) = ICCHAI(1,5)+2
6156 IDXP = INTDV1(I)
6157 IDXT = INTDV2(I)
6158 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6159 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6160 DO 51 K=1,4
6161 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6162 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6163 PT1(K) = XTVQ(IDXT) *PHKK(K,MOT)
6164 PT2(K) = XTVD(IDXT) *PHKK(K,MOT)
6165 51 CONTINUE
6166 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6167 & +(PP1(3)+PT1(3))**2)
6168 ECH = PP1(4)+PT1(4)
6169 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6170 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6171 & +(PP2(3)+PT2(3))**2)
6172 ECH = PP2(4)+PT2(4)
6173 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6174 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6175 AM1 = SQRT(AM1)
6176 AM2 = SQRT(AM2)
6177 IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6178C WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6179 5003 FORMAT(1X,'incon. chain mass DV: ',2I5,2E10.3)
6180 ENDIF
6181 ELSE
6182 WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6183 ENDIF
6184 IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6185 IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6186 IFT1 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6187 IFT2 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6188 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6189 & 0,0,5)
6190 CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6191 & 0,0,5)
6192 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6193 & 0,0,5)
6194 CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6195 & 0,0,5)
6196 NCSY = NCSY+1
6197 50 CONTINUE
6198
6199* valence-sea chains
6200 DO 60 I=1,NVS
6201 IF (ISKPCH(6,I).EQ.99) GOTO 60
6202 ICCHAI(1,6) = ICCHAI(1,6)+2
6203 IDXP = INTVS1(I)
6204 IDXT = INTVS2(I)
6205 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6206 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6207 DO 61 K=1,4
6208 PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6209 PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6210 PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6211 PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6212 61 CONTINUE
6213 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6214 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6215 IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6216 IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6217 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6218 IF (LCHK) THEN
6219 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6220 & 0,0,6)
6221 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6222 & 0,0,6)
6223 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6224 & 0,0,6)
6225 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6226 & 0,0,6)
6227 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6228 & +(PP1(3)+PT1(3))**2)
6229 ECH = PP1(4)+PT1(4)
6230 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6231 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6232 & +(PP2(3)+PT2(3))**2)
6233 ECH = PP2(4)+PT2(4)
6234 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6235 ELSE
6236 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6237 & 0,0,6)
6238 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6239 & 0,0,6)
6240 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6241 & 0,0,6)
6242 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6243 & 0,0,6)
6244 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6245 & +(PP1(3)+PT2(3))**2)
6246 ECH = PP1(4)+PT2(4)
6247 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6248 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6249 & +(PP2(3)+PT1(3))**2)
6250 ECH = PP2(4)+PT1(4)
6251 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6252 ENDIF
6253 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6254 AM1 = SQRT(AM1)
6255 AM2 = SQRT(AM2)
6256 IF ((AM1.LT.AMSS).OR.(AM2.LT.AMVS)) THEN
6257C WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6258 5004 FORMAT(1X,'incon. chain mass VS: ',2I5,2E10.3)
6259 ENDIF
6260 ELSE
6261 WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6262 ENDIF
6263 NCSY = NCSY+1
6264 60 CONTINUE
6265
6266* sea-valence chains
6267 DO 40 I=1,NSV
6268 IF (ISKPCH(4,I).EQ.99) GOTO 40
6269 ICCHAI(1,4) = ICCHAI(1,4)+2
6270 IDXP = INTSV1(I)
6271 IDXT = INTSV2(I)
6272 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6273 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6274 DO 41 K=1,4
6275 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6276 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6277 PT1(K) = XTVD(IDXT) *PHKK(K,MOT)
6278 PT2(K) = XTVQ(IDXT) *PHKK(K,MOT)
6279 41 CONTINUE
6280 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6281 & +(PP1(3)+PT1(3))**2)
6282 ECH = PP1(4)+PT1(4)
6283 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6284 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6285 & +(PP2(3)+PT2(3))**2)
6286 ECH = PP2(4)+PT2(4)
6287 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6288 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6289 AM1 = SQRT(AM1)
6290 AM2 = SQRT(AM2)
6291 IF ((AM1.LT.AMVS).OR.(AM2.LT.AMSS)) THEN
6292C WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6293 5005 FORMAT(1X,'incon. chain mass SV: ',2I5,2E10.3)
6294 ENDIF
6295 ELSE
6296 WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6297 ENDIF
6298 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6299 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6300 IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6301 IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6302 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6303 & 0,0,4)
6304 CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6305 & 0,0,4)
6306 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6307 & 0,0,4)
6308 CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6309 & 0,0,4)
6310 NCSY = NCSY+1
6311 40 CONTINUE
6312
6313* valence-disea chains
6314 DO 70 I=1,NVD
6315 IF (ISKPCH(7,I).EQ.99) GOTO 70
6316 ICCHAI(1,7) = ICCHAI(1,7)+2
6317 IDXP = INTVD1(I)
6318 IDXT = INTVD2(I)
6319 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6320 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6321 DO 71 K=1,4
6322 PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6323 PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6324 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6325 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6326 71 CONTINUE
6327 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6328 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6329 IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6330 IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6331 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6332 IF (LCHK) THEN
6333 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6334 & 0,0,7)
6335 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6336 & 0,0,7)
6337 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6338 & 0,0,7)
6339 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6340 & 0,0,7)
6341 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6342 & +(PP1(3)+PT1(3))**2)
6343 ECH = PP1(4)+PT1(4)
6344 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6345 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6346 & +(PP2(3)+PT2(3))**2)
6347 ECH = PP2(4)+PT2(4)
6348 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6349 ELSE
6350 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6351 & 0,0,7)
6352 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6353 & 0,0,7)
6354 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6355 & 0,0,7)
6356 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6357 & 0,0,7)
6358 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6359 & +(PP1(3)+PT2(3))**2)
6360 ECH = PP1(4)+PT2(4)
6361 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6362 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6363 & +(PP2(3)+PT1(3))**2)
6364 ECH = PP2(4)+PT1(4)
6365 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6366 ENDIF
6367 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6368 AM1 = SQRT(AM1)
6369 AM2 = SQRT(AM2)
6370 IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6371C WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6372 5006 FORMAT(1X,'incon. chain mass VD: ',2I5,2E10.3)
6373 ENDIF
6374 ELSE
6375 WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6376 ENDIF
6377 NCSY = NCSY+1
6378 70 CONTINUE
6379
6380* valence-valence chains
6381 DO 80 I=1,NVV
6382 IF (ISKPCH(8,I).EQ.99) GOTO 80
6383 ICCHAI(1,8) = ICCHAI(1,8)+2
6384 IDXP = INTVV1(I)
6385 IDXT = INTVV2(I)
6386 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6387 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6388 DO 81 K=1,4
6389 PP1(K) = XPVQ(IDXP)*PHKK(K,MOP)
6390 PP2(K) = XPVD(IDXP)*PHKK(K,MOP)
6391 PT1(K) = XTVD(IDXT)*PHKK(K,MOT)
6392 PT2(K) = XTVQ(IDXT)*PHKK(K,MOT)
6393 81 CONTINUE
6394 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6395 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6396 IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6397 IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6398
6399* check for diffractive event
6400 IDIFF = 0
6401 IF (((ISINGD.GT.0).OR.(IDOUBD.GT.0)).AND.
6402 & (IP.EQ.1).AND.(NN.EQ.1)) THEN
6403 DO 800 K=1,4
6404 PP(K) = PP1(K)+PP2(K)
6405 PT(K) = PT1(K)+PT2(K)
6406 800 CONTINUE
6407 ISTCK = NHKK
6408 CALL DT_DIFEVT(IFP1,IFP2,PP,MOP,
6409 & IFT1,IFT2,PT,MOT,IDIFF,NCSY,IREJ1)
6410C IF (IREJ1.NE.0) GOTO 9999
6411 IF (IREJ1.NE.0) THEN
6412 IDIFF = 0
6413 NHKK = ISTCK
6414 ENDIF
6415 ELSE
6416 IDIFF = 0
6417 ENDIF
6418
6419 IF (IDIFF.EQ.0) THEN
6420* valence-valence chain system
6421 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6422 IF (LCHK) THEN
6423* baryon-baryon
6424 CALL DT_EVTPUT(-21,IFP1,MOP,0,
6425 & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6426 CALL DT_EVTPUT(-22,IFT1,MOT,0,
6427 & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6428 CALL DT_EVTPUT(-21,IFP2,MOP,0,
6429 & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6430 CALL DT_EVTPUT(-22,IFT2,MOT,0,
6431 & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6432 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6433 & +(PP1(3)+PT1(3))**2)
6434 ECH = PP1(4)+PT1(4)
6435 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6436 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6437 & +(PP2(3)+PT2(3))**2)
6438 ECH = PP2(4)+PT2(4)
6439 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6440 ELSE
6441* antibaryon-baryon
6442 CALL DT_EVTPUT(-21,IFP1,MOP,0,
6443 & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6444 CALL DT_EVTPUT(-22,IFT2,MOT,0,
6445 & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6446 CALL DT_EVTPUT(-21,IFP2,MOP,0,
6447 & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6448 CALL DT_EVTPUT(-22,IFT1,MOT,0,
6449 & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6450 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6451 & +(PP1(3)+PT2(3))**2)
6452 ECH = PP1(4)+PT2(4)
6453 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6454 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6455 & +(PP2(3)+PT1(3))**2)
6456 ECH = PP2(4)+PT1(4)
6457 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6458 ENDIF
6459 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6460 AM1 = SQRT(AM1)
6461 AM2 = SQRT(AM2)
6462 IF ((AM1.LT.AMVV).OR.(AM2.LT.AMVV)) THEN
6463C WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6464 5007 FORMAT(1X,'incon. chain mass VV: ',2I5,2E10.3)
6465 ENDIF
6466 ELSE
6467 WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6468 ENDIF
6469 NCSY = NCSY+1
6470 ENDIF
6471 80 CONTINUE
6472 IF (ISTHKK(NPOINT(2)).EQ.1) NPOINT(2) = NPOINT(2)+1
6473
6474* energy-momentum & flavor conservation check
6475 IF (ABS(IDIFF).NE.1) THEN
6476 IF (IDIFF.NE.0) THEN
6477 IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-41,1,0,
6478 & 1,3,10,IREJ)
6479 ELSE
6480 IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-31,-32,0,
6481 & 1,3,10,IREJ)
6482 ENDIF
6483 IF (IREJ.NE.0) THEN
6484 CALL DT_EVTOUT(4)
6485 STOP
6486 ENDIF
6487 ENDIF
6488
6489 RETURN
6490
6491 9999 CONTINUE
6492 IREJ = 1
6493 RETURN
6494 END
6495
6496*$ CREATE DT_CHKCSY.FOR
6497*COPY DT_CHKCSY
6498*
6499*===chkcsy=============================================================*
6500*
6501 SUBROUTINE DT_CHKCSY(ID1,ID2,LCHK)
6502
6503************************************************************************
6504* CHeCk Chain SYstem for consistency of partons at chain ends. *
6505* ID1,ID2 PDG-numbers of partons at chain ends *
6506* LCHK = .true. consistent chain *
6507* = .false. inconsistent chain *
6508* This version dated 18.01.95 is written by S. Roesler *
6509************************************************************************
6510
6511 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6512 SAVE
6513 PARAMETER ( LINP = 10 ,
6514 & LOUT = 6 ,
6515 & LDAT = 9 )
6516
6517 LOGICAL LCHK
6518
6519 LCHK = .TRUE.
6520
6521* q-aq chain
6522 IF ((ABS(ID1).LE.6).AND.(ABS(ID2).LE.6)) THEN
6523 IF (ID1*ID2.GT.0) LCHK = .FALSE.
6524* q-qq, aq-aqaq chain
6525 ELSEIF (((ABS(ID1).LE.6).AND.(ABS(ID2).GT.6)).OR.
6526 & ((ABS(ID1).GT.6).AND.(ABS(ID2).LE.6))) THEN
6527 IF (ID1*ID2.LT.0) LCHK = .FALSE.
6528* qq-aqaq chain
6529 ELSEIF ((ABS(ID1).GT.6).AND.(ABS(ID2).GT.6)) THEN
6530 IF (ID1*ID2.GT.0) LCHK = .FALSE.
6531 ENDIF
6532
6533 RETURN
6534 END
6535
6536*$ CREATE DT_EVENTA.FOR
6537*COPY DT_EVENTA
6538*
6539*===eventa=============================================================*
6540*
6541 SUBROUTINE DT_EVENTA(ID,IP,IT,NCSY,IREJ)
6542
6543************************************************************************
6544* Treatment of nucleon-nucleon interactions in a two-chain *
6545* approximation. *
6546* (input) ID BAMJET-index of projectile hadron (in case of *
6547* h-K scattering) *
6548* IP/IT mass number of projectile/target nucleus *
6549* NCSY number of two chain systems *
6550* IREJ rejection flag *
6551* This version dated 15.01.95 is written by S. Roesler *
6552************************************************************************
6553
6554 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6555 SAVE
6556 PARAMETER ( LINP = 10 ,
6557 & LOUT = 6 ,
6558 & LDAT = 9 )
6559 PARAMETER (TINY10=1.0D-10)
6560
6561* event history
6562 PARAMETER (NMXHKK=200000)
6563 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6564 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6565 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6566* extended event history
6567 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6568 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6569 & IHIST(2,NMXHKK)
6570* rejection counter
6571 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6572 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6573 & IREXCI(3),IRDIFF(2),IRINC
6574* flags for diffractive interactions (DTUNUC 1.x)
6575 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6576* particle properties (BAMJET index convention)
6577 CHARACTER*8 ANAME
6578 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6579 & IICH(210),IIBAR(210),K1(210),K2(210)
6580* flags for input different options
6581 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6582 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6583 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6584* various options for treatment of partons (DTUNUC 1.x)
6585* (chain recombination, Cronin,..)
6586 LOGICAL LCO2CR,LINTPT
6587 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
6588 & LCO2CR,LINTPT
6589
6590 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
6591
6592 IREJ = 0
6593 NPOINT(3) = NHKK+1
6594
6595* skip following treatment for low-mass diffraction
6596 IF (ABS(IFLAGD).EQ.1) THEN
6597 NPOINT(3) = NPOINT(2)
6598 GOTO 5
6599 ENDIF
6600
6601* multiple scattering of chain ends
6602 IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
6603 IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
6604
6605 NC = NPOINT(2)
6606* get a two-chain system from DTEVT1
6607 DO 3 I=1,NCSY
6608 IFP1 = IDHKK(NC)
6609 IFT1 = IDHKK(NC+1)
6610 IFP2 = IDHKK(NC+2)
6611 IFT2 = IDHKK(NC+3)
6612 DO 4 K=1,4
6613 PP1(K) = PHKK(K,NC)
6614 PT1(K) = PHKK(K,NC+1)
6615 PP2(K) = PHKK(K,NC+2)
6616 PT2(K) = PHKK(K,NC+3)
6617 4 CONTINUE
6618 MOP1 = NC
6619 MOT1 = NC+1
6620 MOP2 = NC+2
6621 MOT2 = NC+3
6622 CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
6623 & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
6624 IF (IREJ1.GT.0) THEN
6625 IRHHA = IRHHA+1
6626 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTA'
6627 GOTO 9999
6628 ENDIF
6629 NC = NC+4
6630 3 CONTINUE
6631
6632* meson/antibaryon projectile:
6633* sample single-chain valence-valence systems (Reggeon contrib.)
6634 IF ((IP.EQ.1).AND.(ISICHA.EQ.1)) THEN
6635 IF (IIBAR(ID).LE.0) CALL DT_VV2SCH
6636 ENDIF
6637
6638 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6639* check DTEVT1 for remaining resonance mass corrections
6640 CALL DT_EVTRES(IREJ1)
6641 IF (IREJ1.GT.0) THEN
6642 IRRES(1) = IRRES(1)+1
6643 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in EVENTA'
6644 GOTO 9999
6645 ENDIF
6646 ENDIF
6647
6648* assign p_t to two-"chain" systems consisting of two resonances only
6649* since only entries for chains will be affected, this is obsolete
6650* in case of JETSET-fragmetation
6651 CALL DT_RESPT
6652
6653* combine q-aq chains to color ropes (qq-aqaq) (chain fusion)
6654 IF (LCO2CR) CALL DT_COM2CR
6655
6656 5 CONTINUE
6657
6658* fragmentation of the complete event
6659**uncomment for internal phojet-fragmentation
6660C CALL DT_EVTFRA(IREJ1)
6661 CALL DT_EVTFRG(2,IDUM,NPYMEM,IREJ1)
6662 IF (IREJ1.GT.0) THEN
6663 IRFRAG = IRFRAG+1
6664 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 3 in EVENTA'
6665 GOTO 9999
6666 ENDIF
6667
6668* decay of possible resonances (should be obsolete)
6669 CALL DT_DECAY1
6670
6671 RETURN
6672
6673 9999 CONTINUE
6674 IREVT = IREVT+1
6675 IREJ = 1
6676 RETURN
6677 END
6678
6679*$ CREATE DT_GETCSY.FOR
6680*COPY DT_GETCSY
6681*
6682*===getcsy=============================================================*
6683*
6684 SUBROUTINE DT_GETCSY(IFPR1,PP1,MOP1,IFPR2,PP2,MOP2,
6685 & IFTA1,PT1,MOT1,IFTA2,PT2,MOT2,IREJ)
6686
6687************************************************************************
6688* This version dated 15.01.95 is written by S. Roesler *
6689************************************************************************
6690
6691 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6692 SAVE
6693 PARAMETER ( LINP = 10 ,
6694 & LOUT = 6 ,
6695 & LDAT = 9 )
6696 PARAMETER (TINY10=1.0D-10)
6697
6698* event history
6699 PARAMETER (NMXHKK=200000)
6700 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6701 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6702 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6703* extended event history
6704 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6705 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6706 & IHIST(2,NMXHKK)
6707* rejection counter
6708 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6709 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6710 & IREXCI(3),IRDIFF(2),IRINC
6711* flags for input different options
6712 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6713 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6714 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6715* flags for diffractive interactions (DTUNUC 1.x)
6716 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6717
6718 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),
6719 & IFP1(2),IFP2(2),IFT1(2),IFT2(2),PCH1(4),PCH2(4)
6720
6721 IREJ = 0
6722
6723* get quark content of partons
6724 DO 1 I=1,2
6725 IFP1(I) = 0
6726 IFP2(I) = 0
6727 IFT1(I) = 0
6728 IFT2(I) = 0
6729 1 CONTINUE
6730 IFP1(1) = IDT_IPDG2B(IFPR1,1,2)
6731 IF (ABS(IFPR1).GE.1000) IFP1(2) = IDT_IPDG2B(IFPR1,2,2)
6732 IFP2(1) = IDT_IPDG2B(IFPR2,1,2)
6733 IF (ABS(IFPR2).GE.1000) IFP2(2) = IDT_IPDG2B(IFPR2,2,2)
6734 IFT1(1) = IDT_IPDG2B(IFTA1,1,2)
6735 IF (ABS(IFTA1).GE.1000) IFT1(2) = IDT_IPDG2B(IFTA1,2,2)
6736 IFT2(1) = IDT_IPDG2B(IFTA2,1,2)
6737 IF (ABS(IFTA2).GE.1000) IFT2(2) = IDT_IPDG2B(IFTA2,2,2)
6738
6739* get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq, 3 - qq-aqaq)
6740 IDCH1 = 2
6741 IF ((IFP1(2).EQ.0).AND.(IFT1(2).EQ.0)) IDCH1 = 1
6742 IF ((IFP1(2).NE.0).AND.(IFT1(2).NE.0)) IDCH1 = 3
6743 IDCH2 = 2
6744 IF ((IFP2(2).EQ.0).AND.(IFT2(2).EQ.0)) IDCH2 = 1
6745 IF ((IFP2(2).NE.0).AND.(IFT2(2).NE.0)) IDCH2 = 3
6746
6747* store initial configuration for energy-momentum cons. check
6748 IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IDUM)
6749
6750* sample intrinsic p_t at chain-ends
6751 CALL DT_GETSPT(PP1,IFPR1,IFP1,PP2,IFPR2,IFP2,
6752 & PT1,IFTA1,IFT1,PT2,IFTA2,IFT2,
6753 & AMCH1,IDCH1,AMCH2,IDCH2,IDCH(MOP1),IREJ1)
6754 IF (IREJ1.NE.0) THEN
6755 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in GETCSY'
6756 IRPT = IRPT+1
6757 GOTO 9999
6758 ENDIF
6759
6760C IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6761C IF ((IDCH1.EQ.3).OR.((IDCH1.GT.1).AND.(IDCH2.EQ.1))) THEN
6762C* check second chain for resonance
6763C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6764C & AMCH2,AMCH2N,IDCH2,IREJ1)
6765C IF (IREJ1.NE.0) GOTO 9999
6766C IF (IDR2.NE.0) THEN
6767C CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6768C & AMCH2,AMCH2N,AMCH1,IREJ1)
6769C IF (IREJ1.NE.0) GOTO 9999
6770C ENDIF
6771C* check first chain for resonance
6772C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6773C & AMCH1,AMCH1N,IDCH1,IREJ1)
6774C IF (IREJ1.NE.0) GOTO 9999
6775C IF (IDR1.NE.0) IDR1 = 100*IDR1
6776C ELSE
6777C* check first chain for resonance
6778C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6779C & AMCH1,AMCH1N,IDCH1,IREJ1)
6780C IF (IREJ1.NE.0) GOTO 9999
6781C IF (IDR1.NE.0) THEN
6782C CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6783C & AMCH1,AMCH1N,AMCH2,IREJ1)
6784C IF (IREJ1.NE.0) GOTO 9999
6785C ENDIF
6786C* check second chain for resonance
6787C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6788C & AMCH2,AMCH2N,IDCH2,IREJ1)
6789C IF (IREJ1.NE.0) GOTO 9999
6790C IF (IDR2.NE.0) IDR2 = 100*IDR2
6791C ENDIF
6792C ENDIF
6793
6794 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6795* check chains for resonances
6796 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6797 & AMCH1,AMCH1N,IDCH1,IREJ1)
6798 IF (IREJ1.NE.0) GOTO 9999
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* change kinematics corresponding to resonance-masses
6803 IF ( (IDR1.NE.0).AND.(IDR2.EQ.0) ) THEN
6804 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6805 & AMCH1,AMCH1N,AMCH2,IREJ1)
6806 IF (IREJ1.GT.0) GOTO 9999
6807 IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
6808 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6809 & AMCH2,AMCH2N,IDCH2,IREJ1)
6810 IF (IREJ1.NE.0) GOTO 9999
6811 IF (IDR2.NE.0) IDR2 = 100*IDR2
6812 ELSEIF ( (IDR1.EQ.0).AND.(IDR2.NE.0) ) THEN
6813 CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6814 & AMCH2,AMCH2N,AMCH1,IREJ1)
6815 IF (IREJ1.GT.0) GOTO 9999
6816 IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
6817 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6818 & AMCH1,AMCH1N,IDCH1,IREJ1)
6819 IF (IREJ1.NE.0) GOTO 9999
6820 IF (IDR1.NE.0) IDR1 = 100*IDR1
6821 ELSEIF ( (IDR1.NE.0).AND.(IDR2.NE.0) ) THEN
6822 AMDIF1 = ABS(AMCH1-AMCH1N)
6823 AMDIF2 = ABS(AMCH2-AMCH2N)
6824 IF (AMDIF2.LT.AMDIF1) THEN
6825 CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6826 & AMCH2,AMCH2N,AMCH1,IREJ1)
6827 IF (IREJ1.GT.0) GOTO 9999
6828 IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
6829 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),
6830 & IDR1,IDXR1,AMCH1,AMCH1N,IDCH1,IREJ1)
6831 IF (IREJ1.NE.0) GOTO 9999
6832 IF (IDR1.NE.0) IDR1 = 100*IDR1
6833 ELSE
6834 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6835 & AMCH1,AMCH1N,AMCH2,IREJ1)
6836 IF (IREJ1.GT.0) GOTO 9999
6837 IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
6838 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),
6839 & IDR2,IDXR2,AMCH2,AMCH2N,IDCH2,IREJ1)
6840 IF (IREJ1.NE.0) GOTO 9999
6841 IF (IDR2.NE.0) IDR2 = 100*IDR2
6842 ENDIF
6843 ENDIF
6844 ENDIF
6845
6846* store final configuration for energy-momentum cons. check
6847 IF (LEMCCK) THEN
6848 CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IDUM)
6849 CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
6850 IF (IREJ1.NE.0) GOTO 9999
6851 ENDIF
6852
6853* put partons and chains into DTEVT1
6854 DO 10 I=1,4
6855 PCH1(I) = PP1(I)+PT1(I)
6856 PCH2(I) = PP2(I)+PT2(I)
6857 10 CONTINUE
6858 CALL DT_EVTPUT(-ISTHKK(MOP1),IFPR1,MOP1,0,PP1(1),PP1(2),
6859 & PP1(3),PP1(4),0,0,0)
6860 CALL DT_EVTPUT(-ISTHKK(MOT1),IFTA1,MOT1,0,PT1(1),PT1(2),
6861 & PT1(3),PT1(4),0,0,0)
6862 KCH = 100+IDCH(MOP1)*10+1
6863 CALL DT_EVTPUT(KCH,88888,-2,-1,
6864 & PCH1(1),PCH1(2),PCH1(3),PCH1(4),IDR1,IDXR1,IDCH(MOP1))
6865 CALL DT_EVTPUT(-ISTHKK(MOP2),IFPR2,MOP2,0,PP2(1),PP2(2),
6866 & PP2(3),PP2(4),0,0,0)
6867 CALL DT_EVTPUT(-ISTHKK(MOT2),IFTA2,MOT2,0,PT2(1),PT2(2),
6868 & PT2(3),PT2(4),0,0,0)
6869 KCH = KCH+1
6870 CALL DT_EVTPUT(KCH,88888,-2,-1,
6871 & PCH2(1),PCH2(2),PCH2(3),PCH2(4),IDR2,IDXR2,IDCH(MOP2))
6872
6873 RETURN
6874
6875 9999 CONTINUE
6876 IF ((IDCH(MOP1).LE.3).AND.(IDCH(MOP2).LE.3)) THEN
6877* "cancel" sea-sea chains
6878 CALL DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ1)
6879 IF (IREJ1.NE.0) GOTO 9998
6880**sr 16.5. flag for EVENTB
6881 IREJ = -1
6882 RETURN
6883 ENDIF
6884 9998 CONTINUE
6885 IREJ = 1
6886 RETURN
6887 END
6888
6889*$ CREATE DT_CHKINE.FOR
6890*COPY DT_CHKINE
6891*
6892*===chkine=============================================================*
6893*
6894 SUBROUTINE DT_CHKINE(PP1I,IFP1,PP2I,IFP2,PT1I,IFT1,PT2I,IFT2,
6895 & AMCH1,AMCH1N,AMCH2,IREJ)
6896
6897************************************************************************
6898* This subroutine replaces CORMOM. *
6899* This version dated 05.01.95 is written by S. Roesler *
6900************************************************************************
6901
6902 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6903 SAVE
6904 PARAMETER ( LINP = 10 ,
6905 & LOUT = 6 ,
6906 & LDAT = 9 )
6907 PARAMETER (TINY10=1.0D-10)
6908
6909* flags for input different options
6910 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6911 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6912 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6913* rejection counter
6914 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6915 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6916 & IREXCI(3),IRDIFF(2),IRINC
6917
6918 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),P1(4),P2(4),
6919 & PP1I(4),PP2I(4),PT1I(4),PT2I(4)
6920
6921 IREJ = 0
6922 JMSHL = IMSHL
6923
6924 SCALE = AMCH1N/MAX(AMCH1,TINY10)
6925 DO 10 I=1,4
6926 PP1(I) = PP1I(I)
6927 PP2(I) = PP2I(I)
6928 PT1(I) = PT1I(I)
6929 PT2(I) = PT2I(I)
6930 PP2(I) = PP2(I)+(1.0D0-SCALE)*PP1(I)
6931 PT2(I) = PT2(I)+(1.0D0-SCALE)*PT1(I)
6932 PP1(I) = SCALE*PP1(I)
6933 PT1(I) = SCALE*PT1(I)
6934 10 CONTINUE
6935 IF ((PP1(4).LT.0.0D0).OR.(PP2(4).LT.0.0D0).OR.
6936 & (PT1(4).LT.0.0D0).OR.(PT2(4).LT.0.0D0)) GOTO 9997
6937
6938 ECH = PP2(4)+PT2(4)
6939 PCH = SQRT( (PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2+
6940 & (PP2(3)+PT2(3))**2 )
6941 AMCH22 = (ECH-PCH)*(ECH+PCH)
6942 IF (AMCH22.LT.0.0D0) THEN
6943 IF (IOULEV(1).GT.0)
6944 & WRITE(LOUT,'(1X,A)') 'CHKINE: inconsistent treatment!'
6945 GOTO 9997
6946 ENDIF
6947
6948 AMCH1 = AMCH1N
6949 AMCH2 = SQRT(AMCH22)
6950
6951* put partons again on mass shell
6952 13 CONTINUE
6953 XM1 = 0.0D0
6954 XM2 = 0.0D0
6955 IF (JMSHL.EQ.1) THEN
6956 XM1 = PYMASS(IFP1)
6957 XM2 = PYMASS(IFT1)
6958 ENDIF
6959 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
6960 IF (IREJ1.NE.0) THEN
6961 IF (JMSHL.EQ.0) GOTO 9998
6962 JMSHL = 0
6963 GOTO 13
6964 ENDIF
6965 JMSHL = IMSHL
6966 DO 11 I=1,4
6967 PP1(I) = P1(I)
6968 PT1(I) = P2(I)
6969 11 CONTINUE
6970 14 CONTINUE
6971 XM1 = 0.0D0
6972 XM2 = 0.0D0
6973 IF (JMSHL.EQ.1) THEN
6974 XM1 = PYMASS(IFP2)
6975 XM2 = PYMASS(IFT2)
6976 ENDIF
6977 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P1,P2,IREJ1)
6978 IF (IREJ1.NE.0) THEN
6979 IF (JMSHL.EQ.0) GOTO 9998
6980 JMSHL = 0
6981 GOTO 14
6982 ENDIF
6983 DO 12 I=1,4
6984 PP2(I) = P1(I)
6985 PT2(I) = P2(I)
6986 12 CONTINUE
6987 DO 15 I=1,4
6988 PP1I(I) = PP1(I)
6989 PP2I(I) = PP2(I)
6990 PT1I(I) = PT1(I)
6991 PT2I(I) = PT2(I)
6992 15 CONTINUE
6993 RETURN
6994
6995 9997 IRCHKI(1) = IRCHKI(1)+1
6996**sr
6997C GOTO 9999
6998 IREJ = -1
6999 RETURN
7000**
7001 9998 IRCHKI(2) = IRCHKI(2)+1
7002
7003 9999 CONTINUE
7004 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in CHKINE'
7005 IREJ = 1
7006 RETURN
7007 END
7008
7009*$ CREATE DT_CH2RES.FOR
7010*COPY DT_CH2RES
7011*
7012*===ch2res=============================================================*
7013*
7014 SUBROUTINE DT_CH2RES(IF1,IF2,IF3,IF4,IDR,IDXR,
7015 & AM,AMN,IMODE,IREJ)
7016
7017************************************************************************
7018* Check chains for resonance production. *
7019* This subroutine replaces COMCMA/COBCMA/COMCM2 *
7020* input: *
7021* IF1,2,3,4 input flavors (q,aq in any order) *
7022* AM chain mass *
7023* MODE = 1 check q-aq chain for meson-resonance *
7024* = 2 check q-qq, aq-aqaq chain for baryon-resonance *
7025* = 3 check qq-aqaq chain for lower mass cut *
7026* output: *
7027* IDR = 0 no resonances found *
7028* = -1 pseudoscalar meson/octet baryon *
7029* = 1 vector-meson/decuplet baryon *
7030* IDXR BAMJET-index of corresponding resonance *
7031* AMN mass of corresponding resonance *
7032* *
7033* IREJ rejection flag *
7034* This version dated 06.01.95 is written by S. Roesler *
7035************************************************************************
7036
7037 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7038 SAVE
7039 PARAMETER ( LINP = 10 ,
7040 & LOUT = 6 ,
7041 & LDAT = 9 )
7042
7043* particle properties (BAMJET index convention)
7044 CHARACTER*8 ANAME
7045 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7046 & IICH(210),IIBAR(210),K1(210),K2(210)
7047* quark-content to particle index conversion (DTUNUC 1.x)
7048 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
7049 & IA08(6,21),IA10(6,21)
7050* rejection counter
7051 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7052 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7053 & IREXCI(3),IRDIFF(2),IRINC
7054* flags for input different options
7055 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7056 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7057 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7058
7059 DIMENSION IF(4),JF(4)
7060
7061**sr 4.7. test
7062C DATA AMLOM,AMLOB /0.08D0,0.2D0/
7063 DATA AMLOM,AMLOB /0.1D0,0.7D0/
7064**
7065C DATA AMLOM,AMLOB /0.001D0,0.001D0/
7066
7067 MODE = ABS(IMODE)
7068
7069 IF ((MODE.LT.1).OR.(MODE.GT.3)) THEN
7070 WRITE(LOUT,1000) MODE
7071 1000 FORMAT(1X,'CH2RES: MODE ',I4,' not supported!',/,
7072 & 1X,' program stopped')
7073 STOP
7074 ENDIF
7075
7076 AMX = AM
7077 IREJ = 0
7078 IDR = 0
7079 IDXR = 0
7080 AMN = AMX
7081 IF ((AM.LE.0.0D0).AND.(MODE.EQ.1)) AMX = AMLOM
7082 IF ((AM.LE.0.0D0).AND.(MODE.EQ.2)) AMX = AMLOB
7083
7084 IF(1) = IF1
7085 IF(2) = IF2
7086 IF(3) = IF3
7087 IF(4) = IF4
7088 NF = 0
7089 DO 100 I=1,4
7090 IF (IF(I).NE.0) THEN
7091 NF = NF+1
7092 JF(NF) = IF(I)
7093 ENDIF
7094 100 CONTINUE
7095 IF (NF.LE.MODE) THEN
7096 WRITE(LOUT,1001) MODE,IF
7097 1001 FORMAT(1X,'CH2RES: inconsistent input flavors in MODE ',
7098 & I4,' IF1 = ',I4,' IF2 = ',I4,' IF3 = ',I4,' IF4 = ',I4)
7099 GOTO 9999
7100 ENDIF
7101
7102 GOTO (1,2,3) MODE
7103
7104* check for meson resonance
7105 1 CONTINUE
7106 IFQ = JF(1)
7107 IFAQ = ABS(JF(2))
7108 IF (JF(2).GT.0) THEN
7109 IFQ = JF(2)
7110 IFAQ = ABS(JF(1))
7111 ENDIF
7112 IFPS = IMPS(IFAQ,IFQ)
7113 IFV = IMVE(IFAQ,IFQ)
7114 AMPS = AAM(IFPS)
7115 AMV = AAM(IFV)
7116 AMHI = AMV+0.3D0
7117 IF (AMX.LT.AMV) THEN
7118 IF (AMX.LT.AMPS) THEN
7119 IF (IMODE.GT.0) THEN
7120 IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOM)) GOTO 9999
7121 ELSE
7122 IF (AMX.LT.0.8D0*AMPS) GOTO 9999
7123 ENDIF
7124 LOMRES = LOMRES+1
7125 ENDIF
7126* replace chain by pseudoscalar meson
7127 IDR = -1
7128 IDXR = IFPS
7129 AMN = AMPS
7130 ELSEIF (AMX.LT.AMHI) THEN
7131* replace chain by vector-meson
7132 IDR = 1
7133 IDXR = IFV
7134 AMN = AMV
7135 ENDIF
7136 RETURN
7137
7138* check for baryon resonance
7139 2 CONTINUE
7140 CALL DT_DBKLAS(JF(1),JF(2),JF(3),JB8,JB10)
7141 AM8 = AAM(JB8)
7142 AM10 = AAM(JB10)
7143 AMHI = AM10+0.3D0
7144 IF (AMX.LT.AM10) THEN
7145 IF (AMX.LT.AM8) THEN
7146 IF (IMODE.GT.0) THEN
7147 IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOB)) GOTO 9999
7148 ELSE
7149 IF (AMX.LT.0.8D0*AM8) GOTO 9999
7150 ENDIF
7151 LOBRES = LOBRES+1
7152 ENDIF
7153* replace chain by oktet baryon
7154 IDR = -1
7155 IDXR = JB8
7156 AMN = AM8
7157 ELSEIF (AMX.LT.AMHI) THEN
7158 IDR = 1
7159 IDXR = JB10
7160 AMN = AM10
7161 ENDIF
7162 RETURN
7163
7164* check qq-aqaq for lower mass cut
7165 3 CONTINUE
7166* empirical definition of AMHI to allow for (b-antib)-pair prod.
7167 AMHI = 2.5D0
7168 IF (AMX.LT.AMHI) GOTO 9999
7169 RETURN
7170
7171 9999 CONTINUE
7172 IF ((IOULEV(1).GT.0).AND.(IMODE.GT.0))
7173 & WRITE(LOUT,*) 'rejected 1 in CH2RES',IMODE
7174 IREJ = 1
7175 IRRES(2) = IRRES(2)+1
7176 RETURN
7177 END
7178
7179*$ CREATE DT_RJSEAC.FOR
7180*COPY DT_RJSEAC
7181*
7182*===rjseac=============================================================*
7183*
7184 SUBROUTINE DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ)
7185
7186************************************************************************
7187* ReJection of SEA-sea Chains. *
7188* MOP1/2 entries of projectile sea-partons in DTEVT1 *
7189* MOT1/2 entries of projectile sea-partons in DTEVT1 *
7190* This version dated 16.01.95 is written by S. Roesler *
7191************************************************************************
7192
7193 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7194 SAVE
7195 PARAMETER ( LINP = 10 ,
7196 & LOUT = 6 ,
7197 & LDAT = 9 )
7198 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
7199
7200* event history
7201 PARAMETER (NMXHKK=200000)
7202 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7203 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7204 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7205* extended event history
7206 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7207 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7208 & IHIST(2,NMXHKK)
7209* statistics
7210 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7211 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7212 & ICEVTG(8,0:30)
7213
7214 DIMENSION IDXSEA(2,2),IDXNUC(2),ISTVAL(2)
7215
7216 IREJ = 0
7217
7218* projectile sea q-aq-pair
7219* indices of sea-pair
7220 IDXSEA(1,1) = MOP1
7221 IDXSEA(1,2) = MOP2
7222* index of mother-nucleon
7223 IDXNUC(1) = JMOHKK(1,MOP1)
7224* status of valence quarks to be corrected
7225 ISTVAL(1) = -21
7226
7227* target sea q-aq-pair
7228* indices of sea-pair
7229 IDXSEA(2,1) = MOT1
7230 IDXSEA(2,2) = MOT2
7231* index of mother-nucleon
7232 IDXNUC(2) = JMOHKK(1,MOT1)
7233* status of valence quarks to be corrected
7234 ISTVAL(2) = -22
7235
7236 DO 1 N=1,2
7237 IDONE = 0
7238 DO 2 I=NPOINT(2),NHKK
7239 IF ((ISTHKK(I).EQ.ISTVAL(N)).AND.
7240 & (JMOHKK(1,I).EQ.IDXNUC(N))) THEN
7241* valence parton found
7242* inrease 4-momentum by sea 4-momentum
7243 DO 3 K=1,4
7244 PHKK(K,I) = PHKK(K,I)+PHKK(K,IDXSEA(N,1))+
7245 & PHKK(K,IDXSEA(N,2))
7246 3 CONTINUE
7247 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
7248 & PHKK(2,I)**2-PHKK(3,I)**2))
7249* "cancel" sea-pair
7250 DO 4 J=1,2
7251 ISTHKK(IDXSEA(N,J)) = 100
7252 IDHKK(IDXSEA(N,J)) = 0
7253 JMOHKK(1,IDXSEA(N,J)) = 0
7254 JMOHKK(2,IDXSEA(N,J)) = 0
7255 JDAHKK(1,IDXSEA(N,J)) = 0
7256 JDAHKK(2,IDXSEA(N,J)) = 0
7257 DO 5 K=1,4
7258 PHKK(K,IDXSEA(N,J)) = ZERO
7259 VHKK(K,IDXSEA(N,J)) = ZERO
7260 WHKK(K,IDXSEA(N,J)) = ZERO
7261 5 CONTINUE
7262 PHKK(5,IDXSEA(N,J)) = ZERO
7263 4 CONTINUE
7264 IDONE = 1
7265 ENDIF
7266 2 CONTINUE
7267 IF (IDONE.NE.1) THEN
7268 WRITE(LOUT,1000) NEVHKK,MOP1,MOP2,MOT1,MOT2
7269 1000 FORMAT(1X,'RJSEAC: event ',I8,': inconsistent event',
7270 & '-record!',/,1X,' sea-quark pairs ',
7271 & 2I5,4X,2I5,' could not be canceled!')
7272 GOTO 9999
7273 ENDIF
7274 1 CONTINUE
7275 ICRJSS = ICRJSS+1
7276 RETURN
7277
7278 9999 CONTINUE
7279 IREJ = 1
7280 RETURN
7281 END
7282
7283*$ CREATE DT_VV2SCH.FOR
7284*COPY DT_VV2SCH
7285*
7286*===vv2sch=============================================================*
7287*
7288 SUBROUTINE DT_VV2SCH
7289
7290************************************************************************
7291* Change Valence-Valence chain systems to Single CHain systems for *
7292* hadron-nucleus collisions with meson or antibaryon projectile. *
7293* (Reggeon contribution) *
7294* The single chain system is approximately treated as one chain and a *
7295* meson at rest. *
7296* This version dated 18.01.95 is written by S. Roesler *
7297************************************************************************
7298
7299 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7300 SAVE
7301 PARAMETER ( LINP = 10 ,
7302 & LOUT = 6 ,
7303 & LDAT = 9 )
7304 PARAMETER (ZERO=0.0D0,TINY7=1.0D-7,TINY3=1.0D-3)
7305
7306 LOGICAL LSTART
7307
7308* event history
7309 PARAMETER (NMXHKK=200000)
7310 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7311 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7312 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7313* extended event history
7314 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7315 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7316 & IHIST(2,NMXHKK)
7317* flags for input different options
7318 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7319 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7320 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7321* statistics
7322 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7323 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7324 & ICEVTG(8,0:30)
7325
7326 DIMENSION IF(4,2),MO(4),PP1(4),PP2(4),PT1(4),PT2(4),PCH1(4),
7327 & PCH2(4)
7328
7329 DATA LSTART /.TRUE./
7330
7331 IFSC = 0
7332 IF (LSTART) THEN
7333 WRITE(LOUT,1000)
7334 1000 FORMAT(/,1X,'VV2SCH: Reggeon contribution to valance-',
7335 & 'valence chains treated')
7336 LSTART = .FALSE.
7337 ENDIF
7338
7339 NSTOP = NHKK
7340
7341* get index of first chain
7342 DO 1 I=NPOINT(3),NHKK
7343 IF (IDHKK(I).EQ.88888) THEN
7344 NC = I
7345 GOTO 2
7346 ENDIF
7347 1 CONTINUE
7348
7349 2 CONTINUE
7350 IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)
7351 & .AND.(NC.LT.NSTOP)) THEN
7352* get valence-valence chains
7353 IF ((IDCH(NC).EQ.8).AND.(IDCH(NC+3).EQ.8)) THEN
7354* get "mother"-hadron indices
7355 MO1 = JMOHKK(1,JMOHKK(1,JMOHKK(1,NC)))
7356 MO2 = JMOHKK(1,JMOHKK(1,JMOHKK(2,NC)))
7357 KPROJ = IDT_ICIHAD(IDHKK(MO1))
7358 KTARG = IDT_ICIHAD(IDHKK(MO2))
7359* Lab momentum of projectile hadron
7360 CALL DT_LTNUC(PHKK(3,MO1),PHKK(4,MO1),PPZ,PPE,-3)
7361 PTOT = SQRT(PHKK(1,MO1)**2+PHKK(2,MO1)**2+
7362 & PHKK(3,MO1)**2)
7363
7364 SICHAP = DT_PHNSCH(KPROJ,KTARG,PTOT)
7365 IF (DT_RNDM(PTOT).LE.SICHAP) THEN
7366 ICVV2S = ICVV2S+1
7367* single chain requested
7368* get flavors of chain-end partons
7369 MO(1) = JMOHKK(1,NC)
7370 MO(2) = JMOHKK(2,NC)
7371 MO(3) = JMOHKK(1,NC+3)
7372 MO(4) = JMOHKK(2,NC+3)
7373 DO 3 I=1,4
7374 IF(I,1) = IDT_IPDG2B(IDHKK(MO(I)),1,2)
7375 IF(I,2) = 0
7376 IF (ABS(IDHKK(MO(I))).GE.1000)
7377 & IF(I,2) = IDT_IPDG2B(IDHKK(MO(I)),2,2)
7378 3 CONTINUE
7379* which one is the q-aq chain?
7380* N1,N1+1 - DTEVT1-entries for q-aq system
7381* N2,N2+1 - DTEVT1-entries for the other chain
7382 IF ((IF(1,2).EQ.0).AND.(IF(2,2).EQ.0)) THEN
7383 K1 = 1
7384 K2 = 3
7385 N1 = NC-2
7386 N2 = NC+1
7387 ELSEIF ((IF(3,2).EQ.0).AND.(IF(4,2).EQ.0)) THEN
7388 K1 = 3
7389 K2 = 1
7390 N1 = NC+1
7391 N2 = NC-2
7392 ELSE
7393 GOTO 10
7394 ENDIF
7395 DO 4 K=1,4
7396 PP1(K) = PHKK(K,N1)
7397 PT1(K) = PHKK(K,N1+1)
7398 PP2(K) = PHKK(K,N2)
7399 PT2(K) = PHKK(K,N2+1)
7400 4 CONTINUE
7401 AMCH1 = PHKK(5,N1+2)
7402 AMCH2 = PHKK(5,N2+2)
7403* get meson-identity corresponding to flavors of q-aq chain
7404 ITMP = IRESRJ
7405 IRESRJ = 0
7406 CALL DT_CH2RES(IF(K1,1),IF(K1+1,1),0,0,IDR1,IDXR1,
7407 & ZERO,AMCH1N,1,IDUM)
7408 IRESRJ = ITMP
7409* change kinematics of chains
7410 CALL DT_CHKINE(PP1,IDHKK(N1), PP2,IDHKK(N2),
7411 & PT1,IDHKK(N1+1),PT2,IDHKK(N2+1),
7412 & AMCH1,AMCH1N,AMCH2,IREJ1)
7413 IF (IREJ1.NE.0) GOTO 10
7414* check second chain for resonance
7415 IDCHAI = 2
7416 IF ((IF(K2,2).NE.0).AND.(IF(K2+1,2).NE.0)) IDCHAI = 3
7417 CALL DT_CH2RES(IF(K2,1),IF(K2,2),IF(K2+1,1),IF(K2+1,2),
7418 & IDR2,IDXR2,AMCH2,AMCH2N,IDCHAI,IREJ1)
7419 IF (IREJ1.NE.0) GOTO 10
7420 IF (IDR2.NE.0) IDR2 = 100*IDR2
7421* add partons and chains to DTEVT1
7422 DO 5 K=1,4
7423 PCH1(K) = PP1(K)+PT1(K)
7424 PCH2(K) = PP2(K)+PT2(K)
7425 5 CONTINUE
7426 CALL DT_EVTPUT(ISTHKK(N1),IDHKK(N1),N1,0,PP1(1),PP1(2),
7427 & PP1(3),PP1(4),0,0,0)
7428 CALL DT_EVTPUT(ISTHKK(N1+1),IDHKK(N1+1),N1+1,0,PT1(1),
7429 & PT1(2),PT1(3),PT1(4),0,0,0)
7430 KCH = ISTHKK(N1+2)+100
7431 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH1(1),PCH1(2),PCH1(3),
7432 & PCH1(4),IDR1,IDXR1,IDCH(N1+2))
7433 IDHKK(N1+2) = 22222
7434 CALL DT_EVTPUT(ISTHKK(N2),IDHKK(N2),N2,0,PP2(1),PP2(2),
7435 & PP2(3),PP2(4),0,0,0)
7436 CALL DT_EVTPUT(ISTHKK(N2+1),IDHKK(N2+1),N2+1,0,PT2(1),
7437 & PT2(2),PT2(3),PT2(4),0,0,0)
7438 KCH = ISTHKK(N2+2)+100
7439 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH2(1),PCH2(2),PCH2(3),
7440 & PCH2(4),IDR2,IDXR2,IDCH(N2+2))
7441 IDHKK(N2+2) = 22222
7442 ENDIF
7443 ENDIF
7444 ELSE
7445 GOTO 11
7446 ENDIF
7447 10 CONTINUE
7448 NC = NC+6
7449 GOTO 2
7450
7451 11 CONTINUE
7452
7453 RETURN
7454 END
7455
7456*$ CREATE DT_PHNSCH.FOR
7457*COPY DT_PHNSCH
7458*
7459*=== phnsch ===========================================================*
7460*
7461 DOUBLE PRECISION FUNCTION DT_PHNSCH( KP, KTARG, PLAB )
7462
7463*----------------------------------------------------------------------*
7464* *
7465* Probability for Hadron Nucleon Single CHain interactions: *
7466* *
7467* Created on 30 december 1993 by Alfredo Ferrari & Paola Sala *
7468* Infn - Milan *
7469* *
7470* Last change on 04-jan-94 by Alfredo Ferrari *
7471* *
7472* modified by J.R.for use in DTUNUC 6.1.94 *
7473* *
7474* Input variables: *
7475* Kp = hadron projectile index (Part numbering *
7476* scheme) *
7477* Ktarg = target nucleon index (1=proton, 8=neutron) *
7478* Plab = projectile laboratory momentum (GeV/c) *
7479* Output variable: *
7480* Phnsch = probability per single chain (particle *
7481* exchange) interactions *
7482* *
7483*----------------------------------------------------------------------*
7484
7485 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7486 SAVE
7487
7488 PARAMETER ( LUNOUT = 6 )
7489 PARAMETER ( LUNERR = 6 )
7490 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
7491 PARAMETER ( ZERZER = 0.D+00 )
7492 PARAMETER ( ONEONE = 1.D+00 )
7493 PARAMETER ( TWOTWO = 2.D+00 )
7494 PARAMETER ( FIVFIV = 5.D+00 )
7495 PARAMETER ( HLFHLF = 0.5D+00 )
7496
7497 PARAMETER ( NALLWP = 39 )
7498 PARAMETER ( IDMAXP = 210 )
7499
7500 DIMENSION ICHRGE(39),AM(39)
7501
7502* particle properties (BAMJET index convention)
7503 CHARACTER*8 ANAME
7504 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7505 & IICH(210),IIBAR(210),K1(210),K2(210)
7506
7507 DIMENSION KPTOIP(210)
7508* auxiliary common for reggeon exchange (DTUNUC 1.x)
7509 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
7510 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
7511 & IQTCHR(-6:6),MQUARK(3,39)
7512
7513 DIMENSION SGTCOE (5,33), IHLP (NALLWP)
7514 DIMENSION SGTCO1(5,10),SGTCO2(5,8),SGTCO3(5,15)
454792a9 7515CPH SAVE SGTCOE, IHLP
7516CPH SAVE IQFSC1, IQFSC2, IQBSC1, IQBSC2
9aaba0d6 7517 EQUIVALENCE (SGTCO1(1,1),SGTCOE(1,1))
7518 EQUIVALENCE (SGTCO2(1,1),SGTCOE(1,11))
7519 EQUIVALENCE (SGTCO3(1,1),SGTCOE(1,19))
7520
7521* Conversion from part to paprop numbering
7522 DATA KPTOIP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
7523 & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 66*0,
7524 & 34, 36, 31, 32, 33, 35, 37, 5*0, 38, 5*0, 39, 19*0, 27, 28, 74*0/
7525
7526* 1=baryon, 2=pion, 3=kaon, 4=antibaryon:
7527 DATA IHLP/1,4,5*0,1,4,2*0,3,2*2,2*3,1,4,3,3*1,2,
7528 & 2*3, 2, 4*0, 3*4, 1, 4, 1, 4, 1, 4 /
7529C DATA ( ( SGTCOE (J,I), J=1,5 ), I=1,10 ) /
7530 DATA SGTCO1 /
7531* 1st reaction: gamma p total
7532 &0.147 D+00, ZERZER , ZERZER , 0.0022D+00, -0.0170D+00,
7533* 2nd reaction: gamma d total
7534 &0.300 D+00, ZERZER , ZERZER , 0.0095D+00, -0.057 D+00,
7535* 3rd reaction: pi+ p total
7536 &16.4 D+00, 19.3D+00, -0.42D+00, 0.19 D+00, ZERZER ,
7537* 4th reaction: pi- p total
7538 &33.0 D+00, 14.0D+00, -1.36D+00, 0.456 D+00, -4.03 D+00,
7539* 5th reaction: pi+/- d total
7540 &56.8 D+00, 42.2D+00, -1.45D+00, 0.65 D+00, -5.39 D+00,
7541* 6th reaction: K+ p total
7542 &18.1 D+00, ZERZER , ZERZER , 0.26 D+00, -1.0 D+00,
7543* 7th reaction: K+ n total
7544 &18.7 D+00, ZERZER , ZERZER , 0.21 D+00, -0.89 D+00,
7545* 8th reaction: K+ d total
7546 &34.2 D+00, 7.9 D+00, -2.1 D+00, 0.346 D+00, -0.99 D+00,
7547* 9th reaction: K- p total
7548 &32.1 D+00, ZERZER , ZERZER , 0.66 D+00, -5.6 D+00,
7549* 10th reaction: K- n total
7550 &25.2 D+00, ZERZER , ZERZER , 0.38 D+00, -2.9 D+00/
7551C DATA ( ( SGTCOE (J,I), J=1,5 ), I=11,18 ) /
7552 DATA SGTCO2 /
7553* 11th reaction: K- d total
7554 &57.6 D+00, ZERZER , ZERZER , 1.17 D+00, -9.5 D+00,
7555* 12th reaction: p p total
7556 &48.0 D+00, ZERZER , ZERZER , 0.522 D+00, -4.51 D+00,
7557* 13th reaction: p n total
7558 &47.30 D+00, ZERZER , ZERZER , 0.513 D+00, -4.27 D+00,
7559* 14th reaction: p d total
7560 &91.3 D+00, ZERZER , ZERZER , 1.05 D+00, -8.8 D+00,
7561* 15th reaction: pbar p total
7562 &38.4 D+00, 77.6D+00, -0.64D+00, 0.26 D+00, -1.2 D+00,
7563* 16th reaction: pbar n total
7564 &ZERZER ,133.6D+00, -0.70D+00, -1.22 D+00, 13.7 D+00,
7565* 17th reaction: pbar d total
7566 &112. D+00, 125.D+00, -1.08D+00, 1.14 D+00, -12.4 D+00,
7567* 18th reaction: Lamda p total
7568 &30.4 D+00, ZERZER , ZERZER , ZERZER , 1.6 D+00/
7569C DATA ( ( SGTCOE (J,I), J=1,5 ), I=19,33 ) /
7570 DATA SGTCO3 /
7571* 19th reaction: pi+ p elastic
7572 &ZERZER , 11.4D+00, -0.4 D+00, 0.079 D+00, ZERZER ,
7573* 20th reaction: pi- p elastic
7574 &1.76 D+00, 11.2D+00, -0.64D+00, 0.043 D+00, ZERZER ,
7575* 21st reaction: K+ p elastic
7576 &5.0 D+00, 8.1 D+00, -1.8 D+00, 0.16 D+00, -1.3 D+00,
7577* 22nd reaction: K- p elastic
7578 &7.3 D+00, ZERZER , ZERZER , 0.29 D+00, -2.40 D+00,
7579* 23rd reaction: p p elastic
7580 &11.9 D+00, 26.9D+00, -1.21D+00, 0.169 D+00, -1.85 D+00,
7581* 24th reaction: p d elastic
7582 &16.1 D+00, ZERZER , ZERZER , 0.32 D+00, -3.4 D+00,
7583* 25th reaction: pbar p elastic
7584 &10.2 D+00, 52.7D+00, -1.16D+00, 0.125 D+00, -1.28 D+00,
7585* 26th reaction: pbar p elastic bis
7586 &10.6 D+00, 53.1D+00, -1.19D+00, 0.136 D+00, -1.41 D+00,
7587* 27th reaction: pbar n elastic
7588 &36.5 D+00, ZERZER , ZERZER , ZERZER , -11.9 D+00,
7589* 28th reaction: Lamda p elastic
7590 &12.3 D+00, ZERZER , ZERZER , ZERZER , -2.4 D+00,
7591* 29th reaction: K- p ela bis
7592 &7.24 D+00, 46.0D+00, -4.71D+00, 0.279 D+00, -2.35 D+00,
7593* 30th reaction: pi- p cx
7594 &ZERZER ,0.912D+00, -1.22D+00, ZERZER , ZERZER ,
7595* 31st reaction: K- p cx
7596 &ZERZER , 3.39D+00, -1.75D+00, ZERZER , ZERZER ,
7597* 32nd reaction: K+ n cx
7598 &ZERZER , 7.18D+00, -2.01D+00, ZERZER , ZERZER ,
7599* 33rd reaction: pbar p cx
7600 &ZERZER , 18.8D+00, -2.01D+00, ZERZER , ZERZER /
7601*
7602* +-------------------------------------------------------------------*
7603 ICHRGE(KTARG)=IICH(KTARG)
7604 AM (KTARG)=AAM (KTARG)
7605* | Check for pi0 (d-dbar)
7606 IF ( KP .NE. 26 ) THEN
7607 IP = KPTOIP (KP)
7608 IF(IP.EQ.0)IP=1
7609 ICHRGE(IP)=IICH(KP)
7610 AM (IP)=AAM (KP)
7611* |
7612* +-------------------------------------------------------------------*
7613* |
7614 ELSE
7615 IP = 23
7616 ICHRGE(IP)=0
7617 END IF
7618* |
7619* +-------------------------------------------------------------------*
7620* +-------------------------------------------------------------------*
7621* | No such interactions for baryon-baryon
7622 IF ( IIBAR (KP) .GT. 0 ) THEN
7623 DT_PHNSCH = ZERZER
7624 RETURN
7625* |
7626* +-------------------------------------------------------------------*
7627* | No "annihilation" diagram possible for K+ p/n
7628 ELSE IF ( IP .EQ. 15 ) THEN
7629 DT_PHNSCH = ZERZER
7630 RETURN
7631* |
7632* +-------------------------------------------------------------------*
7633* | No "annihilation" diagram possible for K0 p/n
7634 ELSE IF ( IP .EQ. 24 ) THEN
7635 DT_PHNSCH = ZERZER
7636 RETURN
7637* |
7638* +-------------------------------------------------------------------*
7639* | No "annihilation" diagram possible for Omebar p/n
7640 ELSE IF ( IP .GE. 38 ) THEN
7641 DT_PHNSCH = ZERZER
7642 RETURN
7643 END IF
7644* |
7645* +-------------------------------------------------------------------*
7646* +-------------------------------------------------------------------*
7647* | If the momentum is larger than 50 GeV/c, compute the single
7648* | chain probability at 50 GeV/c and extrapolate to the present
7649* | momentum according to 1/sqrt(s)
7650* | sigma = sigma_sch (50) * sqrt (s(50)/s) + sigma_dch
7651* | P_sch (50) = sigma_sch (50) / ( sigma_dch + sigma_sch (50) )
7652* | sigma_dch / sigma_sch (50) = 1 / P_sch (50) - 1
7653* | sigma_dch / sigma_sch = 1 / P_sch - 1 = ( 1 / P_sch (50) - 1 )
7654* | x sqrt(s/s(50))
7655* | P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
7656 IF ( PLAB .GT. 50.D+00 ) THEN
7657 PLA = 50.D+00
7658 AMPSQ = AM (IP)**2
7659 AMTSQ = AM (KTARG)**2
7660 EPROJ = SQRT ( PLAB**2 + AMPSQ )
7661 UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7662 EPROJ = SQRT ( PLA**2 + AMPSQ )
7663 UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7664 UMORAT = SQRT ( UMOSQ / UMO50 )
7665* |
7666* +-------------------------------------------------------------------*
7667* | P < 3 GeV/c
7668 ELSE IF ( PLAB .LT. 3.D+00 ) THEN
7669 PLA = 3.D+00
7670 AMPSQ = AM (IP)**2
7671 AMTSQ = AM (KTARG)**2
7672 EPROJ = SQRT ( PLAB**2 + AMPSQ )
7673 UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7674 EPROJ = SQRT ( PLA**2 + AMPSQ )
7675 UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7676 UMORAT = SQRT ( UMOSQ / UMO50 )
7677* |
7678* +-------------------------------------------------------------------*
7679* | P < 50 GeV/c
7680 ELSE
7681 PLA = PLAB
7682 UMORAT = ONEONE
7683 END IF
7684* |
7685* +-------------------------------------------------------------------*
7686 ALGPLA = LOG (PLA)
7687* +-------------------------------------------------------------------*
7688* | Pions:
7689 IF ( IHLP (IP) .EQ. 2 ) THEN
7690 ACOF = SGTCOE (1,3)
7691 BCOF = SGTCOE (2,3)
7692 ENNE = SGTCOE (3,3)
7693 CCOF = SGTCOE (4,3)
7694 DCOF = SGTCOE (5,3)
7695* | Compute the pi+ p total cross section:
7696 SPPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7697 & + DCOF * ALGPLA
7698 ACOF = SGTCOE (1,19)
7699 BCOF = SGTCOE (2,19)
7700 ENNE = SGTCOE (3,19)
7701 CCOF = SGTCOE (4,19)
7702 DCOF = SGTCOE (5,19)
7703* | Compute the pi+ p elastic cross section:
7704 SPPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7705 & + DCOF * ALGPLA
7706* | Compute the pi+ p inelastic cross section:
7707 SPPPIN = SPPPTT - SPPPEL
7708 ACOF = SGTCOE (1,4)
7709 BCOF = SGTCOE (2,4)
7710 ENNE = SGTCOE (3,4)
7711 CCOF = SGTCOE (4,4)
7712 DCOF = SGTCOE (5,4)
7713* | Compute the pi- p total cross section:
7714 SPMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7715 & + DCOF * ALGPLA
7716 ACOF = SGTCOE (1,20)
7717 BCOF = SGTCOE (2,20)
7718 ENNE = SGTCOE (3,20)
7719 CCOF = SGTCOE (4,20)
7720 DCOF = SGTCOE (5,20)
7721* | Compute the pi- p elastic cross section:
7722 SPMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7723 & + DCOF * ALGPLA
7724* | Compute the pi- p inelastic cross section:
7725 SPMPIN = SPMPTT - SPMPEL
7726 SIGDIA = SPMPIN - SPPPIN
7727* | +----------------------------------------------------------------*
7728* | | Charged pions: besides isospin consideration it is supposed
7729* | | that (pi+ n)el is almost equal to (pi- p)el
7730* | | and (pi+ p)el " " " " (pi- n)el
7731* | | and all are almost equal among each others
7732* | | (reasonable above 5 GeV/c)
7733 IF ( ICHRGE (IP) .NE. 0 ) THEN
7734 KHELP = KTARG / 8
7735 JREAC = 3 + 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 total cross section:
7742 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7743 & + DCOF * ALGPLA
7744 JREAC = 19 + IP - 13 + ICHRGE (IP) * KHELP
7745 ACOF = SGTCOE (1,JREAC)
7746 BCOF = SGTCOE (2,JREAC)
7747 ENNE = SGTCOE (3,JREAC)
7748 CCOF = SGTCOE (4,JREAC)
7749 DCOF = SGTCOE (5,JREAC)
7750* | | Compute the elastic cross section:
7751 SHNCEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7752 & + DCOF * ALGPLA
7753* | | Compute the inelastic cross section:
7754 SHNCIN = SHNCTT - SHNCEL
7755* | | Number of diagrams:
7756 NDIAGR = 1 + IP - 13 + ICHRGE (IP) * KHELP
7757* | | Now compute the chain end (anti)quark-(anti)diquark
7758 IQFSC1 = 1 + IP - 13
7759 IQFSC2 = 0
7760 IQBSC1 = 1 + KHELP
7761 IQBSC2 = 1 + IP - 13
7762* | |
7763* | +----------------------------------------------------------------*
7764* | | pi0: besides isospin consideration it is supposed that the
7765* | | elastic cross section is not very different from
7766* | | pi+ p and/or pi- p (reasonable above 5 GeV/c)
7767 ELSE
7768 KHELP = KTARG / 8
7769 K2HLP = ( KP - 23 ) / 3
7770* | | Number of diagrams:
7771* | | For u ubar (k2hlp=0):
7772* NDIAGR = 2 - KHELP
7773* | | For d dbar (k2hlp=1):
7774* NDIAGR = 2 + KHELP - K2HLP
7775 NDIAGR = 2 + KHELP * ( 2 * K2HLP - 1 ) - K2HLP
7776 SHNCIN = HLFHLF * ( SPPPIN + SPMPIN )
7777* | | Now compute the chain end (anti)quark-(anti)diquark
7778 IQFSC1 = 1 + K2HLP
7779 IQFSC2 = 0
7780 IQBSC1 = 1 + KHELP
7781 IQBSC2 = 2 - K2HLP
7782 END IF
7783* | |
7784* | +----------------------------------------------------------------*
7785* | end pi's
7786* +-------------------------------------------------------------------*
7787* | Kaons:
7788 ELSE IF ( IHLP (IP) .EQ. 3 ) THEN
7789 ACOF = SGTCOE (1,6)
7790 BCOF = SGTCOE (2,6)
7791 ENNE = SGTCOE (3,6)
7792 CCOF = SGTCOE (4,6)
7793 DCOF = SGTCOE (5,6)
7794* | Compute the K+ p total cross section:
7795 SKPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7796 & + DCOF * ALGPLA
7797 ACOF = SGTCOE (1,21)
7798 BCOF = SGTCOE (2,21)
7799 ENNE = SGTCOE (3,21)
7800 CCOF = SGTCOE (4,21)
7801 DCOF = SGTCOE (5,21)
7802* | Compute the K+ p elastic cross section:
7803 SKPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7804 & + DCOF * ALGPLA
7805* | Compute the K+ p inelastic cross section:
7806 SKPPIN = SKPPTT - SKPPEL
7807 ACOF = SGTCOE (1,9)
7808 BCOF = SGTCOE (2,9)
7809 ENNE = SGTCOE (3,9)
7810 CCOF = SGTCOE (4,9)
7811 DCOF = SGTCOE (5,9)
7812* | Compute the K- p total cross section:
7813 SKMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7814 & + DCOF * ALGPLA
7815 ACOF = SGTCOE (1,22)
7816 BCOF = SGTCOE (2,22)
7817 ENNE = SGTCOE (3,22)
7818 CCOF = SGTCOE (4,22)
7819 DCOF = SGTCOE (5,22)
7820* | Compute the K- p elastic cross section:
7821 SKMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7822 & + DCOF * ALGPLA
7823* | Compute the K- p inelastic cross section:
7824 SKMPIN = SKMPTT - SKMPEL
7825 SIGDIA = HLFHLF * ( SKMPIN - SKPPIN )
7826* | +----------------------------------------------------------------*
7827* | | Charged Kaons: actually only K-
7828 IF ( ICHRGE (IP) .NE. 0 ) THEN
7829 KHELP = KTARG / 8
7830* | | +-------------------------------------------------------------*
7831* | | | Proton target:
7832 IF ( KHELP .EQ. 0 ) THEN
7833 SHNCIN = SKMPIN
7834* | | | Number of diagrams:
7835 NDIAGR = 2
7836* | | |
7837* | | +-------------------------------------------------------------*
7838* | | | Neutron target: besides isospin consideration it is supposed
7839* | | | that (K- n)el is almost equal to (K- p)el
7840* | | | (reasonable above 5 GeV/c)
7841 ELSE
7842 ACOF = SGTCOE (1,10)
7843 BCOF = SGTCOE (2,10)
7844 ENNE = SGTCOE (3,10)
7845 CCOF = SGTCOE (4,10)
7846 DCOF = SGTCOE (5,10)
7847* | | | Compute the total cross section:
7848 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7849 & + DCOF * ALGPLA
7850* | | | Compute the elastic cross section:
7851 SHNCEL = SKMPEL
7852* | | | Compute the inelastic cross section:
7853 SHNCIN = SHNCTT - SHNCEL
7854* | | | Number of diagrams:
7855 NDIAGR = 1
7856 END IF
7857* | | |
7858* | | +-------------------------------------------------------------*
7859* | | Now compute the chain end (anti)quark-(anti)diquark
7860 IQFSC1 = 3
7861 IQFSC2 = 0
7862 IQBSC1 = 1 + KHELP
7863 IQBSC2 = 2
7864* | |
7865* | +----------------------------------------------------------------*
7866* | | K0's: (actually only K0bar)
7867 ELSE
7868 KHELP = KTARG / 8
7869* | | +-------------------------------------------------------------*
7870* | | | Proton target: (K0bar p)in supposed to be given by
7871* | | | (K- p)in - Sig_diagr
7872 IF ( KHELP .EQ. 0 ) THEN
7873 SHNCIN = SKMPIN - SIGDIA
7874* | | | Number of diagrams:
7875 NDIAGR = 1
7876* | | |
7877* | | +-------------------------------------------------------------*
7878* | | | Neutron target: (K0bar n)in supposed to be given by
7879* | | | (K- n)in + Sig_diagr
7880* | | | besides isospin consideration it is supposed
7881* | | | that (K- n)el is almost equal to (K- p)el
7882* | | | (reasonable above 5 GeV/c)
7883 ELSE
7884 ACOF = SGTCOE (1,10)
7885 BCOF = SGTCOE (2,10)
7886 ENNE = SGTCOE (3,10)
7887 CCOF = SGTCOE (4,10)
7888 DCOF = SGTCOE (5,10)
7889* | | | Compute the total cross section:
7890 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7891 & + DCOF * ALGPLA
7892* | | | Compute the elastic cross section:
7893 SHNCEL = SKMPEL
7894* | | | Compute the inelastic cross section:
7895 SHNCIN = SHNCTT - SHNCEL + SIGDIA
7896* | | | Number of diagrams:
7897 NDIAGR = 2
7898 END IF
7899* | | |
7900* | | +-------------------------------------------------------------*
7901* | | Now compute the chain end (anti)quark-(anti)diquark
7902 IQFSC1 = 3
7903 IQFSC2 = 0
7904 IQBSC1 = 1
7905 IQBSC2 = 1 + KHELP
7906 END IF
7907* | |
7908* | +----------------------------------------------------------------*
7909* | end Kaon's
7910* +-------------------------------------------------------------------*
7911* | Antinucleons:
7912 ELSE IF ( IHLP (IP) .EQ. 4 .AND. IP .LE. 9 ) THEN
7913* | For momenta between 3 and 5 GeV/c the use of tabulated data
7914* | should be implemented!
7915 ACOF = SGTCOE (1,15)
7916 BCOF = SGTCOE (2,15)
7917 ENNE = SGTCOE (3,15)
7918 CCOF = SGTCOE (4,15)
7919 DCOF = SGTCOE (5,15)
7920* | Compute the pbar p total cross section:
7921 SAPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7922 & + DCOF * ALGPLA
7923 IF ( PLA .LT. FIVFIV ) THEN
7924 JREAC = 26
7925 ELSE
7926 JREAC = 25
7927 END IF
7928 ACOF = SGTCOE (1,JREAC)
7929 BCOF = SGTCOE (2,JREAC)
7930 ENNE = SGTCOE (3,JREAC)
7931 CCOF = SGTCOE (4,JREAC)
7932 DCOF = SGTCOE (5,JREAC)
7933* | Compute the pbar p elastic cross section:
7934 SAPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7935 & + DCOF * ALGPLA
7936* | Compute the pbar p inelastic cross section:
7937 SAPPIN = SAPPTT - SAPPEL
7938 ACOF = SGTCOE (1,12)
7939 BCOF = SGTCOE (2,12)
7940 ENNE = SGTCOE (3,12)
7941 CCOF = SGTCOE (4,12)
7942 DCOF = SGTCOE (5,12)
7943* | Compute the p p total cross section:
7944 SPPTOT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7945 & + DCOF * ALGPLA
7946 ACOF = SGTCOE (1,23)
7947 BCOF = SGTCOE (2,23)
7948 ENNE = SGTCOE (3,23)
7949 CCOF = SGTCOE (4,23)
7950 DCOF = SGTCOE (5,23)
7951* | Compute the p p elastic cross section:
7952 SPPELA = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7953 & + DCOF * ALGPLA
7954* | Compute the K- p inelastic cross section:
7955 SPPINE = SPPTOT - SPPELA
7956 SIGDIA = ( SAPPIN - SPPINE ) / FIVFIV
7957 KHELP = KTARG / 8
7958* | +----------------------------------------------------------------*
7959* | | Pbar:
7960 IF ( ICHRGE (IP) .NE. 0 ) THEN
7961 NDIAGR = 5 - KHELP
7962* | | +-------------------------------------------------------------*
7963* | | | Proton target:
7964 IF ( KHELP .EQ. 0 ) THEN
7965* | | | Number of diagrams:
7966 SHNCIN = SAPPIN
7967 PUUBAR = 0.8D+00
7968* | | |
7969* | | +-------------------------------------------------------------*
7970* | | | Neutron target: it is supposed that (ap n)el is almost equal
7971* | | | to (ap p)el (reasonable above 5 GeV/c)
7972 ELSE
7973 ACOF = SGTCOE (1,16)
7974 BCOF = SGTCOE (2,16)
7975 ENNE = SGTCOE (3,16)
7976 CCOF = SGTCOE (4,16)
7977 DCOF = SGTCOE (5,16)
7978* | | | Compute the total cross section:
7979 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7980 & + DCOF * ALGPLA
7981* | | | Compute the elastic cross section:
7982 SHNCEL = SAPPEL
7983* | | | Compute the inelastic cross section:
7984 SHNCIN = SHNCTT - SHNCEL
7985 PUUBAR = HLFHLF
7986 END IF
7987* | | |
7988* | | +-------------------------------------------------------------*
7989* | | Now compute the chain end (anti)quark-(anti)diquark
7990* | | there are different possibilities, make a random choiche:
7991 IQFSC1 = -1
7992 RNCHEN = DT_RNDM(PUUBAR)
7993 IF ( RNCHEN .LT. PUUBAR ) THEN
7994 IQFSC2 = -2
7995 ELSE
7996 IQFSC2 = -1
7997 END IF
7998 IQBSC1 = -IQFSC1 + KHELP
7999 IQBSC2 = -IQFSC2
8000* | |
8001* | +----------------------------------------------------------------*
8002* | | nbar:
8003 ELSE
8004 NDIAGR = 4 + KHELP
8005* | | +-------------------------------------------------------------*
8006* | | | Proton target: (nbar p)in supposed to be given by
8007* | | | (pbar p)in - Sig_diagr
8008 IF ( KHELP .EQ. 0 ) THEN
8009 SHNCIN = SAPPIN - SIGDIA
8010 PDDBAR = HLFHLF
8011* | | |
8012* | | +-------------------------------------------------------------*
8013* | | | Neutron target: (nbar n)el is supposed to be equal to
8014* | | | (pbar p)el (reasonable above 5 GeV/c)
8015 ELSE
8016* | | | Compute the total cross section:
8017 SHNCTT = SAPPTT
8018* | | | Compute the elastic cross section:
8019 SHNCEL = SAPPEL
8020* | | | Compute the inelastic cross section:
8021 SHNCIN = SHNCTT - SHNCEL
8022 PDDBAR = 0.8D+00
8023 END IF
8024* | | |
8025* | | +-------------------------------------------------------------*
8026* | | Now compute the chain end (anti)quark-(anti)diquark
8027* | | there are different possibilities, make a random choiche:
8028 IQFSC1 = -2
8029 RNCHEN = DT_RNDM(RNCHEN)
8030 IF ( RNCHEN .LT. PDDBAR ) THEN
8031 IQFSC2 = -1
8032 ELSE
8033 IQFSC2 = -2
8034 END IF
8035 IQBSC1 = -IQFSC1 + KHELP - 1
8036 IQBSC2 = -IQFSC2
8037 END IF
8038* | |
8039* | +----------------------------------------------------------------*
8040* |
8041* +-------------------------------------------------------------------*
8042* | Others: not yet implemented
8043 ELSE
8044 SIGDIA = ZERZER
8045 SHNCIN = ONEONE
8046 NDIAGR = 0
8047 DT_PHNSCH = ZERZER
8048 RETURN
8049 END IF
8050* | end others
8051* +-------------------------------------------------------------------*
8052 DT_PHNSCH = NDIAGR * SIGDIA / SHNCIN
8053 IQECHC = IQECHR (IQFSC1) + IQECHR (IQFSC2) + IQECHR (IQBSC1)
8054 & + IQECHR (IQBSC2)
8055 IQBCHC = IQBCHR (IQFSC1) + IQBCHR (IQFSC2) + IQBCHR (IQBSC1)
8056 & + IQBCHR (IQBSC2)
8057 IQECHC = IQECHC / 3
8058 IQBCHC = IQBCHC / 3
8059 IQSCHC = IQSCHR (IQFSC1) + IQSCHR (IQFSC2) + IQSCHR (IQBSC1)
8060 & + IQSCHR (IQBSC2)
8061 IQSPRO = IQSCHR (MQUARK(1,IP)) + IQSCHR (MQUARK(2,IP))
8062 & + IQSCHR (MQUARK(3,IP))
8063* +-------------------------------------------------------------------*
8064* | Consistency check:
8065 IF ( DT_PHNSCH .LE. ZERZER .OR. DT_PHNSCH .GT. ONEONE ) THEN
8066 WRITE (LUNOUT,*)' *** Phnsch,kp,ktarg,pla',
8067 & DT_PHNSCH,KP,KTARG,PLA,' ****'
8068 WRITE (LUNERR,*)' *** Phnsch,kp,ktarg,pla',
8069 & DT_PHNSCH,KP,KTARG,PLA,' ****'
8070 DT_PHNSCH = MAX ( DT_PHNSCH, ZERZER )
8071 DT_PHNSCH = MIN ( DT_PHNSCH, ONEONE )
8072 END IF
8073* |
8074* +-------------------------------------------------------------------*
8075* +-------------------------------------------------------------------*
8076* | Consistency check:
8077 IF ( IQSPRO .NE. IQSCHC .OR. ICHRGE (IP) + ICHRGE (KTARG)
8078 & .NE. IQECHC .OR. IIBAR (KP) + IIBAR (KTARG) .NE. IQBCHC) THEN
8079 WRITE (LUNOUT,*)
8080 &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8081 & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8082 WRITE (LUNERR,*)
8083 &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8084 & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8085 END IF
8086* |
8087* +-------------------------------------------------------------------*
8088* P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
8089 IF ( UMORAT .GT. ONEPLS )
8090 & DT_PHNSCH = ONEONE / ( ( ONEONE / DT_PHNSCH
8091 & - ONEONE ) * UMORAT + ONEONE )
8092 RETURN
8093*
8094 ENTRY DT_SCHQUA ( JQFSC1, JQFSC2, JQBSC1, JQBSC2 )
8095 DT_SCHQUA = ONEONE
8096 JQFSC1 = IQFSC1
8097 JQFSC2 = IQFSC2
8098 JQBSC1 = IQBSC1
8099 JQBSC2 = IQBSC2
8100*=== End of function Phnsch ===========================================*
8101 RETURN
8102 END
8103
8104*$ CREATE DT_RESPT.FOR
8105*COPY DT_RESPT
8106*
8107*===respt==============================================================*
8108*
8109 SUBROUTINE DT_RESPT
8110
8111************************************************************************
8112* Check DTEVT1 for two-resonance systems and sample intrinsic p_t. *
8113* This version dated 18.01.95 is written by S. Roesler *
8114************************************************************************
8115
8116 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8117 SAVE
8118 PARAMETER ( LINP = 10 ,
8119 & LOUT = 6 ,
8120 & LDAT = 9 )
8121 PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8122
8123* event history
8124 PARAMETER (NMXHKK=200000)
8125 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8126 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8127 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8128* extended event history
8129 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8130 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8131 & IHIST(2,NMXHKK)
8132
8133* get index of first chain
8134 DO 1 I=NPOINT(3),NHKK
8135 IF (IDHKK(I).EQ.88888) THEN
8136 NC = I
8137 GOTO 2
8138 ENDIF
8139 1 CONTINUE
8140
8141 2 CONTINUE
8142 IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)) THEN
8143C WRITE(LOUT,*)NC,NC+3,IDRES(NC),IDRES(NC+3)
8144* skip VV-,SS- systems
8145 IF ((IDCH(NC ).NE.1).AND.(IDCH(NC ).NE.8).AND.
8146 & (IDCH(NC+3).NE.1).AND.(IDCH(NC+3).NE.8)) THEN
8147* check if both "chains" are resonances
8148 IF ((IDRES(NC).NE.0).AND.(IDRES(NC+3).NE.0)) THEN
8149 CALL DT_SAPTRE(NC,NC+3)
8150 ENDIF
8151 ENDIF
8152 ELSE
8153 GOTO 3
8154 ENDIF
8155 NC = NC+6
8156 GOTO 2
8157
8158 3 CONTINUE
8159
8160 RETURN
8161 END
8162
8163*$ CREATE DT_EVTRES.FOR
8164*COPY DT_EVTRES
8165*
8166*===evtres=============================================================*
8167*
8168 SUBROUTINE DT_EVTRES(IREJ)
8169
8170************************************************************************
8171* This version dated 14.12.94 is written by S. Roesler *
8172************************************************************************
8173
8174 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8175 SAVE
8176 PARAMETER ( LINP = 10 ,
8177 & LOUT = 6 ,
8178 & LDAT = 9 )
8179 PARAMETER (TINY5=1.0D-5,TINY10=1.0D-10)
8180
8181* event history
8182 PARAMETER (NMXHKK=200000)
8183 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8184 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8185 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8186* extended event history
8187 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8188 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8189 & IHIST(2,NMXHKK)
8190* flags for input different options
8191 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8192 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8193 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8194* particle properties (BAMJET index convention)
8195 CHARACTER*8 ANAME
8196 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
8197 & IICH(210),IIBAR(210),K1(210),K2(210)
8198
8199 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),IFP(2),IFT(2)
8200
8201 IREJ = 0
8202
8203 DO 1 I=NPOINT(3),NHKK
8204 IF (ABS(IDRES(I)).GE.100) THEN
8205 AMMX = 0.0D0
8206 DO 2 J=NPOINT(3),NHKK
8207 IF (IDHKK(J).EQ.88888) THEN
8208 IF (PHKK(5,J).GT.AMMX) THEN
8209 AMMX = PHKK(5,J)
8210 IMMX = J
8211 ENDIF
8212 ENDIF
8213 2 CONTINUE
8214 IF (IDRES(IMMX).NE.0) THEN
8215 IF (IOULEV(3).GT.0) THEN
8216 WRITE(LOUT,'(1X,A)')
8217 & 'EVTRES: no chain for correc. found'
8218C GOTO 6
8219 GOTO 9999
8220 ELSE
8221 GOTO 9999
8222 ENDIF
8223 ENDIF
8224 IMO11 = JMOHKK(1,I)
8225 IMO12 = JMOHKK(2,I)
8226 IF (PHKK(3,IMO11).LT.0.0D0) THEN
8227 IMO11 = JMOHKK(2,I)
8228 IMO12 = JMOHKK(1,I)
8229 ENDIF
8230 IMO21 = JMOHKK(1,IMMX)
8231 IMO22 = JMOHKK(2,IMMX)
8232 IF (PHKK(3,IMO21).LT.0.0D0) THEN
8233 IMO21 = JMOHKK(2,IMMX)
8234 IMO22 = JMOHKK(1,IMMX)
8235 ENDIF
8236 AMCH1 = PHKK(5,I)
8237 AMCH1N = AAM(IDXRES(I))
8238
8239 IFPR1 = IDHKK(IMO11)
8240 IFPR2 = IDHKK(IMO21)
8241 IFTA1 = IDHKK(IMO12)
8242 IFTA2 = IDHKK(IMO22)
8243 DO 4 J=1,4
8244 PP1(J) = PHKK(J,IMO11)
8245 PP2(J) = PHKK(J,IMO21)
8246 PT1(J) = PHKK(J,IMO12)
8247 PT2(J) = PHKK(J,IMO22)
8248 4 CONTINUE
8249* store initial configuration for energy-momentum cons. check
8250 IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IREJ1)
8251* correct kinematics of second chain
8252 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
8253 & AMCH1,AMCH1N,AMCH2,IREJ1)
8254 IF (IREJ1.NE.0) GOTO 9999
8255* check now this chain for resonance mass
8256 IFP(1) = IDT_IPDG2B(IFPR2,1,2)
8257 IFP(2) = 0
8258 IF (ABS(IFPR2).GE.1000) IFP(2) = IDT_IPDG2B(IFPR2,2,2)
8259 IFT(1) = IDT_IPDG2B(IFTA2,1,2)
8260 IFT(2) = 0
8261 IF (ABS(IFTA2).GE.1000) IFT(2) = IDT_IPDG2B(IFTA2,2,2)
8262 IDCH2 = 2
8263 IF ((IFP(2).EQ.0).AND.(IFT(2).EQ.0)) IDCH2 = 1
8264 IF ((IFP(2).NE.0).AND.(IFT(2).NE.0)) IDCH2 = 3
8265 CALL DT_CH2RES(IFP(1),IFP(2),IFT(1),IFT(2),IDR2,IDXR2,
8266 & AMCH2,AMCH2N,IDCH2,IREJ1)
8267 IF ((IREJ1.NE.0).OR.(IDR2.NE.0)) THEN
8268 IF (IOULEV(1).GT.0)
8269 & WRITE(LOUT,*) ' correction for resonance not poss.'
8270**sr test
8271C GOTO 1
8272C GOTO 9999
8273**
8274 ENDIF
8275* store final configuration for energy-momentum cons. check
8276 IF (LEMCCK) THEN
8277 CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IREJ1)
8278 CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
8279 IF (IREJ1.NE.0) GOTO 9999
8280 ENDIF
8281 DO 5 J=1,4
8282 PHKK(J,IMO11) = PP1(J)
8283 PHKK(J,IMO21) = PP2(J)
8284 PHKK(J,IMO12) = PT1(J)
8285 PHKK(J,IMO22) = PT2(J)
8286 5 CONTINUE
8287* correct entries of chains
8288 DO 3 K=1,4
8289 PHKK(K,I) = PHKK(K,IMO11)+PHKK(K,IMO12)
8290 PHKK(K,IMMX) = PHKK(K,IMO21)+PHKK(K,IMO22)
8291 3 CONTINUE
8292 AM1 = PHKK(4,I)**2-PHKK(1,I)**2-PHKK(2,I)**2-PHKK(3,I)**2
8293 AM2 = PHKK(4,IMMX)**2-PHKK(1,IMMX)**2-PHKK(2,IMMX)**2-
8294 & PHKK(3,IMMX)**2
8295* ?? the following should now be obsolete
8296**sr test
8297C IF ((AM1.LT.0.0D0).OR.(AM2.LT.1.0D0)) THEN
8298 IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8299**
8300 WRITE(LOUT,'(1X,A,4G10.3)')
8301 & 'EVTRES: inonsistent mass-corr.',AM1,AM2
8302C GOTO 9999
8303 GOTO 1
8304 ENDIF
8305 PHKK(5,I) = SQRT(AM1)
8306 PHKK(5,IMMX) = SQRT(AM2)
8307 IDRES(I) = IDRES(I)/100
8308 IF ((ABS(PHKK(5,I)-AMCH1N).GT.TINY5).OR.
8309 & (ABS(PHKK(5,IMMX)-AMCH2).GT.TINY5)) THEN
8310 WRITE(LOUT,'(1X,A,4G10.3)')
8311 & 'EVTRES: inconsistent chain-masses',
8312 & PHKK(5,I),AMCH1N,PHKK(5,IMMX),AMCH2
8313 GOTO 9999
8314 ENDIF
8315 ENDIF
8316 1 CONTINUE
8317 6 CONTINUE
8318 RETURN
8319
8320 9999 CONTINUE
8321 IREJ = 1
8322 RETURN
8323 END
8324
8325*$ CREATE DT_GETSPT.FOR
8326*COPY DT_GETSPT
8327*
8328*===getspt=============================================================*
8329*
8330 SUBROUTINE DT_GETSPT(PP1I,IFPR1,IFP1,PP2I,IFPR2,IFP2,
8331 & PT1I,IFTA1,IFT1,PT2I,IFTA2,IFT2,
8332 & AM1,IDCH1,AM2,IDCH2,IDCHAI,IREJ)
8333
8334************************************************************************
8335* This version dated 12.12.94 is written by S. Roesler *
8336************************************************************************
8337
8338 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8339 SAVE
8340 PARAMETER ( LINP = 10 ,
8341 & LOUT = 6 ,
8342 & LDAT = 9 )
8343 PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,ZERO=0.0D0)
8344
8345* various options for treatment of partons (DTUNUC 1.x)
8346* (chain recombination, Cronin,..)
8347 LOGICAL LCO2CR,LINTPT
8348 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8349 & LCO2CR,LINTPT
8350* flags for input different options
8351 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8352 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8353 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8354* flags for diffractive interactions (DTUNUC 1.x)
8355 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
8356
8357 DIMENSION PP1(4),PP1I(4),PP2(4),PP2I(4),PT1(4),PT1I(4),
8358 & PT2(4),PT2I(4),P1(4),P2(4),
8359 & IFP1(2),IFP2(2),IFT1(2),IFT2(2),
8360 & PTOTI(4),PTOTF(4),DIFF(4)
8361
8362 IC = 0
8363 IREJ = 0
8364C B33P = 4.0D0
8365C B33T = 4.0D0
8366C IF ((IDCHAI.EQ.6).OR.(IDCHAI.EQ.7).OR.(IDCHAI.EQ.8)) B33P = 2.0D0
8367C IF ((IDCHAI.EQ.4).OR.(IDCHAI.EQ.5).OR.(IDCHAI.EQ.8)) B33T = 2.0D0
8368 REDU = 1.0D0
8369C B33P = 3.5D0
8370C B33T = 3.5D0
8371 B33P = 4.0D0
8372 B33T = 4.0D0
8373 IF (IDIFF.NE.0) THEN
8374 B33P = 16.0D0
8375 B33T = 16.0D0
8376 ENDIF
8377
8378 DO 1 I=1,4
8379 PTOTI(I) = PP1I(I)+PP2I(I)+PT1I(I)+PT2I(I)
8380 PP1(I) = PP1I(I)
8381 PP2(I) = PP2I(I)
8382 PT1(I) = PT1I(I)
8383 PT2(I) = PT2I(I)
8384 1 CONTINUE
8385* get initial chain masses
8386 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8387 & +(PP1(3)+PT1(3))**2)
8388 ECH = PP1(4)+PT1(4)
8389 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
8390 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8391 & +(PP2(3)+PT2(3))**2)
8392 ECH = PP2(4)+PT2(4)
8393 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
8394 IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8395 IF (IOULEV(1).GT.0)
8396 & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 1',
8397 & AM1,AM2
8398 GOTO 9999
8399 ENDIF
8400 AM1 = SQRT(AM1)
8401 AM2 = SQRT(AM2)
8402 AM1N = ZERO
8403 AM2N = ZERO
8404
8405 MODE = 0
8406C IF ((AM1.GE.3.0D0).AND.(AM2.GE.3.0D0)) THEN
8407C MODE = 0
8408C ELSE
8409C MODE = 1
8410C IF (AM1.LT.0.6) THEN
8411C B33P = 10.0D0
8412C ELSEIF ((AM1.GE.1.2).AND.(AM1.LT.3.0D0)) THEN
8413CC B33P = 4.0D0
8414C ENDIF
8415C IF (AM2.LT.0.6) THEN
8416C B33T = 10.0D0
8417C ELSEIF ((AM2.GE.1.2).AND.(AM2.LT.3.0D0)) THEN
8418CC B33T = 4.0D0
8419C ENDIF
8420C ENDIF
8421
8422* check chain masses for very low mass chains
8423C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8424C & AM1,DUM,-IDCH1,IREJ1)
8425C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8426C & AM2,DUM,-IDCH2,IREJ2)
8427C IF ((IREJ1.NE.0).OR.(IREJ2.NE.0)) THEN
8428C B33P = 20.0D0
8429C B33T = 20.0D0
8430C ENDIF
8431
8432 JMSHL = IMSHL
8433
8434 2 CONTINUE
8435 IC = IC+1
8436 IF (MOD(IC,15).EQ.0) B33P = 2.0D0*B33P
8437 IF (MOD(IC,15).EQ.0) B33T = 2.0D0*B33T
8438 IF (MOD(IC,18).EQ.0) REDU = 0.0D0
8439C IF (MOD(IC,19).EQ.0) JMSHL = 0
8440 IF (MOD(IC,20).EQ.0) GOTO 7
8441C WRITE(LOUT,'(1X,A)') 'GETSPT: rejection '
8442C RETURN
8443C GOTO 9999
8444C ENDIF
8445
8446* get transverse momentum
8447 IF (LINTPT) THEN
8448 ES = -2.0D0/(B33P**2)
8449 & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8450 HPSP = SQRT(ES*ES+2.0D0*ES*0.94D0)
8451 HPSP = HPSP*REDU
8452 ES = -2.0D0/(B33T**2)
8453 & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8454 HPST = SQRT(ES*ES+2.0D0*ES*0.94D0)
8455 HPST = HPST*REDU
8456 ELSE
8457 HPSP = ZERO
8458 HPST = ZERO
8459 ENDIF
8460 CALL DT_DSFECF(SFE1,CFE1)
8461 CALL DT_DSFECF(SFE2,CFE2)
8462 IF (MODE.EQ.0) THEN
8463 PP1(1) = PP1I(1)+HPSP*CFE1
8464 PP1(2) = PP1I(2)+HPSP*SFE1
8465 PP2(1) = PP2I(1)-HPSP*CFE1
8466 PP2(2) = PP2I(2)-HPSP*SFE1
8467 PT1(1) = PT1I(1)+HPST*CFE2
8468 PT1(2) = PT1I(2)+HPST*SFE2
8469 PT2(1) = PT2I(1)-HPST*CFE2
8470 PT2(2) = PT2I(2)-HPST*SFE2
8471 ELSE
8472 PP1(1) = PP1I(1)+HPSP*CFE1
8473 PP1(2) = PP1I(2)+HPSP*SFE1
8474 PT1(1) = PT1I(1)-HPSP*CFE1
8475 PT1(2) = PT1I(2)-HPSP*SFE1
8476 PP2(1) = PP2I(1)+HPST*CFE2
8477 PP2(2) = PP2I(2)+HPST*SFE2
8478 PT2(1) = PT2I(1)-HPST*CFE2
8479 PT2(2) = PT2I(2)-HPST*SFE2
8480 ENDIF
8481
8482* put partons on mass shell
8483 XMP1 = 0.0D0
8484 XMT1 = 0.0D0
8485 IF (JMSHL.EQ.1) THEN
8486 XMP1 = PYMASS(IFPR1)
8487 XMT1 = PYMASS(IFTA1)
8488 ENDIF
8489 CALL DT_MASHEL(PP1,PT1,XMP1,XMT1,P1,P2,IREJ1)
8490 IF (IREJ1.NE.0) GOTO 2
8491 DO 3 I=1,4
8492 PTOTF(I) = P1(I)+P2(I)
8493 PP1(I) = P1(I)
8494 PT1(I) = P2(I)
8495 3 CONTINUE
8496 XMP2 = 0.0D0
8497 XMT2 = 0.0D0
8498 IF (JMSHL.EQ.1) THEN
8499 XMP2 = PYMASS(IFPR2)
8500 XMT2 = PYMASS(IFTA2)
8501 ENDIF
8502 CALL DT_MASHEL(PP2,PT2,XMP2,XMT2,P1,P2,IREJ1)
8503 IF (IREJ1.NE.0) GOTO 2
8504 DO 4 I=1,4
8505 PTOTF(I) = PTOTF(I)+P1(I)+P2(I)
8506 PP2(I) = P1(I)
8507 PT2(I) = P2(I)
8508 4 CONTINUE
8509
8510* check consistency
8511 DO 5 I=1,4
8512 DIFF(I) = PTOTI(I)-PTOTF(I)
8513 5 CONTINUE
8514 IF ((ABS(DIFF(1)).GT.TINY5).OR.(ABS(DIFF(2)).GT.TINY5).OR.
8515 & (ABS(DIFF(3)).GT.TINY5).OR.(ABS(DIFF(4)).GT.TINY5)) THEN
8516 WRITE(LOUT,'(1X,A,4G10.3)') 'GETSPT: inconsistencies ',DIFF
8517 GOTO 9999
8518 ENDIF
8519 PTOTP1 = SQRT(PP1(1)**2+PP1(2)**2+PP1(3)**2)
8520 AMP1 = SQRT(ABS( (PP1(4)-PTOTP1)*(PP1(4)+PTOTP1) ))
8521 PTOTP2 = SQRT(PP2(1)**2+PP2(2)**2+PP2(3)**2)
8522 AMP2 = SQRT(ABS( (PP2(4)-PTOTP2)*(PP2(4)+PTOTP2) ))
8523 PTOTT1 = SQRT(PT1(1)**2+PT1(2)**2+PT1(3)**2)
8524 AMT1 = SQRT(ABS( (PT1(4)-PTOTT1)*(PT1(4)+PTOTT1) ))
8525 PTOTT2 = SQRT(PT2(1)**2+PT2(2)**2+PT2(3)**2)
8526 AMT2 = SQRT(ABS( (PT2(4)-PTOTT2)*(PT2(4)+PTOTT2) ))
8527 IF ((ABS(AMP1-XMP1).GT.TINY3).OR.(ABS(AMP2-XMP2).GT.TINY3).OR.
8528 & (ABS(AMT1-XMT1).GT.TINY3).OR.(ABS(AMT2-XMT2).GT.TINY3))
8529 & THEN
8530 WRITE(LOUT,'(1X,A,2(4G10.3,/))')
8531 & 'GETSPT: inconsistent masses',
8532 & AMP1,XMP1,AMP2,XMP2,AMT1,XMT1,AMT2,XMT2
8533* sr 22.11.00: commented. It should only have inconsistent masses for
8534* ultrahigh energies due to rounding problems
8535C GOTO 9999
8536 ENDIF
8537
8538* get chain masses
8539 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8540 & +(PP1(3)+PT1(3))**2)
8541 ECH = PP1(4)+PT1(4)
8542 AM1N = (ECH+PTOCH)*(ECH-PTOCH)
8543 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8544 & +(PP2(3)+PT2(3))**2)
8545 ECH = PP2(4)+PT2(4)
8546 AM2N = (ECH+PTOCH)*(ECH-PTOCH)
8547 IF ((AM1N.LT.0.0D0).OR.(AM2N.LT.0.0D0)) THEN
8548 IF (IOULEV(1).GT.0)
8549 & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 2',
8550 & AM1N,AM2N
8551 GOTO 2
8552 ENDIF
8553 AM1N = SQRT(AM1N)
8554 AM2N = SQRT(AM2N)
8555
8556* check chain masses for very low mass chains
8557 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8558 & AM1N,DUM,-IDCH1,IREJ1)
8559 IF (IREJ1.NE.0) GOTO 2
8560 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8561 & AM2N,DUM,-IDCH2,IREJ2)
8562 IF (IREJ2.NE.0) GOTO 2
8563
8564 7 CONTINUE
8565 IF (AM1N.GT.ZERO) THEN
8566 AM1 = AM1N
8567 AM2 = AM2N
8568 ENDIF
8569 DO 6 I=1,4
8570 PP1I(I) = PP1(I)
8571 PP2I(I) = PP2(I)
8572 PT1I(I) = PT1(I)
8573 PT2I(I) = PT2(I)
8574 6 CONTINUE
8575
8576 RETURN
8577
8578 9999 CONTINUE
8579 IREJ = 1
8580 RETURN
8581 END
8582
8583*$ CREATE DT_SAPTRE.FOR
8584*COPY DT_SAPTRE
8585*
8586*===saptre=============================================================*
8587*
8588 SUBROUTINE DT_SAPTRE(IDX1,IDX2)
8589
8590************************************************************************
8591* p-t sampling for two-resonance systems. ("BAMJET-like" method) *
8592* IDX1,IDX2 indices of resonances ("chains") in DTEVT1 *
8593* Adopted from the original SAPTRE written by J. Ranft. *
8594* This version dated 18.01.95 is written by S. Roesler *
8595************************************************************************
8596
8597 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8598 SAVE
8599 PARAMETER ( LINP = 10 ,
8600 & LOUT = 6 ,
8601 & LDAT = 9 )
8602 PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8603
8604* event history
8605 PARAMETER (NMXHKK=200000)
8606 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8607 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8608 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8609* extended event history
8610 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8611 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8612 & IHIST(2,NMXHKK)
8613* flags for input different options
8614 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8615 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8616 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8617
8618 DIMENSION PA1(4),PA2(4),P1(4),P2(4)
8619
8620 DATA B3 /4.0D0/
8621
8622 ESMAX1 = PHKK(4,IDX1)-PHKK(5,IDX1)
8623 ESMAX2 = PHKK(4,IDX2)-PHKK(5,IDX2)
8624 ESMAX = MIN(ESMAX1,ESMAX2)
8625 IF (ESMAX.LE.0.05D0) RETURN
8626
8627 HMA = PHKK(5,IDX1)
8628 DO 1 K=1,4
8629 PA1(K) = PHKK(K,IDX1)
8630 PA2(K) = PHKK(K,IDX2)
8631 1 CONTINUE
8632
8633 IF (LEMCCK) THEN
8634 CALL DT_EVTEMC(PA1(1),PA1(2),PA1(3),PA1(4),1,IDUM,IDUM)
8635 CALL DT_EVTEMC(PA2(1),PA2(2),PA2(3),PA2(4),2,IDUM,IDUM)
8636 ENDIF
8637
8638 EXEB = 0.0D0
8639 IF (B3*ESMAX.LE.60.0D0) EXEB = EXP(-B3*ESMAX)
8640 BEXP = HMA*(1.0D0-EXEB)/B3
8641 AXEXP = (1.0D0-(B3*ESMAX-1.0D0)*EXEB)/B3**2
8642 WA = AXEXP/(BEXP+AXEXP)
8643 XAB = DT_RNDM(WA)
8644 10 CONTINUE
8645* ES is the transverse kinetic energy
8646 IF (XAB.LT.WA)THEN
8647 X = DT_RNDM(WA)
8648 Y = DT_RNDM(WA)
8649 ES = -2.0D0/(B3**2)*LOG(X*Y+TINY7)
8650 ELSE
8651 X = DT_RNDM(Y)
8652 ES = ABS(-LOG(X+TINY7)/B3)
8653 ENDIF
8654 IF (ES.GT.ESMAX) GOTO 10
8655 ES = ES+HMA
8656* transverse momentum
8657 HPS = SQRT((ES-HMA)*(ES+HMA))
8658
8659 CALL DT_DSFECF(SFE,CFE)
8660 HPX = HPS*CFE
8661 HPY = HPS*SFE
8662 PZ1NSQ = PA1(3)**2-HPS**2-2.0D0*PA1(1)*HPX-2.0D0*PA1(2)*HPY
8663 PZ2NSQ = PA2(3)**2-HPS**2+2.0D0*PA2(1)*HPX+2.0D0*PA2(2)*HPY
8664 IF ((PZ1NSQ.LT.TINY3).OR.(PZ2NSQ.LT.TINY3)) RETURN
8665
8666C PA1(3) = SIGN(SQRT(PZ1NSQ),PA1(3))
8667C PA2(3) = SIGN(SQRT(PZ2NSQ),PA2(3))
8668 PA1(1) = PA1(1)+HPX
8669 PA1(2) = PA1(2)+HPY
8670 PA2(1) = PA2(1)-HPX
8671 PA2(2) = PA2(2)-HPY
8672
8673* put resonances on mass-shell again
8674 XM1 = PHKK(5,IDX1)
8675 XM2 = PHKK(5,IDX2)
8676 CALL DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ1)
8677 IF (IREJ1.NE.0) RETURN
8678
8679 IF (LEMCCK) THEN
8680 CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,IDUM,IDUM)
8681 CALL DT_EVTEMC(-P2(1),-P2(2),-P2(3),-P2(4),2,IDUM,IDUM)
8682 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,12,IREJ1)
8683 IF (IREJ1.NE.0) RETURN
8684 ENDIF
8685
8686 DO 2 K=1,4
8687 PHKK(K,IDX1) = P1(K)
8688 PHKK(K,IDX2) = P2(K)
8689 2 CONTINUE
8690
8691 RETURN
8692 END
8693
8694*$ CREATE DT_CRONIN.FOR
8695*COPY DT_CRONIN
8696*
8697*===cronin=============================================================*
8698*
8699 SUBROUTINE DT_CRONIN(INCL)
8700
8701************************************************************************
8702* Cronin-Effect. Multiple scattering of partons at chain ends. *
8703* INCL = 1 multiple sc. in projectile *
8704* = 2 multiple sc. in target *
8705* This version dated 05.01.96 is written by S. Roesler. *
8706************************************************************************
8707
8708 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8709 SAVE
8710 PARAMETER ( LINP = 10 ,
8711 & LOUT = 6 ,
8712 & LDAT = 9 )
8713 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
8714
8715* event history
8716 PARAMETER (NMXHKK=200000)
8717 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8718 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8719 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8720* extended event history
8721 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8722 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8723 & IHIST(2,NMXHKK)
8724* rejection counter
8725 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
8726 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
8727 & IREXCI(3),IRDIFF(2),IRINC
8728* Glauber formalism: collision properties
8729 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
e3f546f5 8730 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
8731 & NCP,NCT
9aaba0d6 8732 DIMENSION R(3),PIN(4),POUT(4),DEV(4)
8733
8734 DO 1 K=1,4
8735 DEV(K) = ZERO
8736 1 CONTINUE
8737
8738 DO 2 I=NPOINT(2),NHKK
8739 IF (ISTHKK(I).LT.0) THEN
8740* get z-position of the chain
8741 R(1) = VHKK(1,I)*1.0D12
8742 IF (INCL.EQ.2) R(1) = VHKK(1,I)*1.0D12-BIMPAC
8743 R(2) = VHKK(2,I)*1.0D12
8744 IDXNU = JMOHKK(1,I)
8745 IF ( (INCL.EQ.1).AND.(ISTHKK(IDXNU).EQ.10) )
8746 & IDXNU = JMOHKK(1,I-1)
8747 IF ( (INCL.EQ.2).AND.(ISTHKK(IDXNU).EQ. 9) )
8748 & IDXNU = JMOHKK(1,I+1)
8749 R(3) = VHKK(3,IDXNU)*1.0D12
8750* position of target parton the chain is connected to
8751 DO 3 K=1,4
8752 PIN(K) = PHKK(K,I)
8753 3 CONTINUE
8754* multiple scattering of parton with DTEVT1-index I
8755 CALL DT_CROMSC(PIN,R,POUT,INCL)
8756**testprint
8757C IF (NEVHKK.EQ.5) THEN
8758C AMIN = PIN(4)**2-PIN(1)**2-PIN(2)**2-PIN(3)**2
8759C AMOU = POUT(4)**2-POUT(1)**2-POUT(2)**2-POUT(3)**2
8760C AMIN = SIGN(SQRT(ABS(AMIN)),AMIN)
8761C AMOU = SIGN(SQRT(ABS(AMOU)),AMOU)
8762C WRITE(6,'(A,I4,2E15.5)')'I,AMIN,AMOU: ',I,AMIN,AMOU
8763C WRITE(6,'(A,4E15.5)')'PIN: ',PIN
8764C WRITE(6,'(A,4E15.5)')'POUT: ',POUT
8765C ENDIF
8766**
8767* increase accumulator by energy-momentum difference
8768 DO 4 K=1,4
8769 DEV(K) = DEV(K)+POUT(K)-PIN(K)
8770 PHKK(K,I) = POUT(K)
8771 4 CONTINUE
8772 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
8773 & PHKK(2,I)**2-PHKK(3,I)**2))
8774 ENDIF
8775 2 CONTINUE
8776
8777* dump accumulator to momenta of valence partons
8778 NVAL = 0
8779 ETOT = 0.0D0
8780 DO 5 I=NPOINT(2),NHKK
8781 IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
8782 NVAL = NVAL+1
8783 ETOT = ETOT+PHKK(4,I)
8784 ENDIF
8785 5 CONTINUE
8786C WRITE(LOUT,1000) NVAL,(DEV(K)/DBLE(NVAL),K=1,4)
8787 1000 FORMAT(1X,'CRONIN : number of val. partons ',I4,/,
8788 & 9X,4E12.4)
8789 DO 6 I=NPOINT(2),NHKK
8790 IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
8791 E = PHKK(4,I)
8792 DO 7 K=1,4
8793C PHKK(K,I) = PHKK(K,I)-DEV(K)/DBLE(NVAL)
8794 PHKK(K,I) = PHKK(K,I)-DEV(K)*E/ETOT
8795 7 CONTINUE
8796 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
8797 & PHKK(2,I)**2-PHKK(3,I)**2))
8798 ENDIF
8799 6 CONTINUE
8800
8801 RETURN
8802 END
8803
8804*$ CREATE DT_CROMSC.FOR
8805*COPY DT_CROMSC
8806*
8807*===cromsc=============================================================*
8808*
8809 SUBROUTINE DT_CROMSC(PIN,R,POUT,INCL)
8810
8811************************************************************************
8812* Cronin-Effect. Multiple scattering of one parton passing through *
8813* nuclear matter. *
8814* PIN(4) input 4-momentum of parton *
8815* POUT(4) 4-momentum of parton after mult. scatt. *
8816* R(3) spatial position of parton in target nucleus *
8817* INCL = 1 multiple sc. in projectile *
8818* = 2 multiple sc. in target *
8819* This is a revised version of the original version written by J. Ranft*
8820* This version dated 17.01.95 is written by S. Roesler. *
8821************************************************************************
8822
8823 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8824 SAVE
8825 PARAMETER ( LINP = 10 ,
8826 & LOUT = 6 ,
8827 & LDAT = 9 )
8828 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
8829
8830 LOGICAL LSTART
8831
8832* rejection counter
8833 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
8834 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
8835 & IREXCI(3),IRDIFF(2),IRINC
8836* Glauber formalism: collision properties
8837 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
e3f546f5 8838 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
8839 & NCP,NCT
9aaba0d6 8840* various options for treatment of partons (DTUNUC 1.x)
8841* (chain recombination, Cronin,..)
8842 LOGICAL LCO2CR,LINTPT
8843 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8844 & LCO2CR,LINTPT
8845
8846 DIMENSION PIN(4),POUT(4),R(3)
8847
8848 DATA LSTART /.TRUE./
8849
8850 IRCRON(1) = IRCRON(1)+1
8851
8852 IF (LSTART) THEN
8853 WRITE(LOUT,1000) CRONCO
8854 1000 FORMAT(/,1X,'CROMSC: multiple scattering of chain ends',
8855 & ' treated',/,10X,'with parameter CRONCO = ',F5.2)
8856 LSTART = .FALSE.
8857 ENDIF
8858
8859 NCBACK = 0
8860 RNCL = RPROJ
8861 IF (INCL.EQ.2) RNCL = RTARG
8862
8863* Lorentz-transformation into Lab.
8864 MODE = -(INCL+1)
8865 CALL DT_LTNUC(PIN(3),PIN(4),PZ,PE,MODE)
8866
8867 PTOT = SQRT(PIN(1)**2+PIN(2)**2+PZ**2)
8868 IF (PTOT.LE.8.0D0) GOTO 9997
8869
8870* direction cosines of parton before mult. scattering
8871 COSX = PIN(1)/PTOT
8872 COSY = PIN(2)/PTOT
8873 COSZ = PZ/PTOT
8874
8875 RTESQ = R(1)**2+R(2)**2+R(3)**2-RNCL**2
8876 IF (RTESQ.GE.-TINY3) GOTO 9999
8877
8878* calculate distance (DIST) from R to surface of nucleus (radius RNCL)
8879* in the direction of particle motion
8880
8881 A = COSX*R(1)+COSY*R(2)+COSZ*R(3)
8882 TMP = A**2-RTESQ
8883 IF (TMP.LT.ZERO) GOTO 9998
8884 DIST = -A+SQRT(TMP)
8885
8886* multiple scattering angle
8887 THETO = CRONCO*SQRT(DIST)/PTOT
8888 IF (THETO.GT.0.1D0) THETO=0.1D0
8889
8890 1 CONTINUE
8891* Gaussian sampling of spatial angle
8892 CALL DT_RANNOR(R1,R2)
8893 THETA = ABS(R1*THETO)
8894 IF (THETA.GT.0.3D0) GOTO 9997
8895 CALL DT_DSFECF(SFE,CFE)
8896 COSTH = COS(THETA)
8897 SINTH = SIN(THETA)
8898
8899* new direction cosines
8900 CALL DT_MYTRAN(1,COSX,COSY,COSZ,COSTH,SINTH,SFE,CFE,
8901 & COSXN,COSYN,COSZN)
8902
8903 POUT(1) = COSXN*PTOT
8904 POUT(2) = COSYN*PTOT
8905 PZ = COSZN*PTOT
8906* Lorentz-transformation into nucl.-nucl. cms
8907 MODE = INCL+1
8908 CALL DT_LTNUC(PZ,PE,POUT(3),POUT(4),MODE)
8909
8910C IF (ABS(PIN(4)-POUT(4)).GT.0.2D0) THEN
8911C IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.1D0 ) THEN
8912 IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.05D0 ) THEN
8913 THETO = THETO/2.0D0
8914 NCBACK = NCBACK+1
8915 IF (MOD(NCBACK,200).EQ.0) THEN
8916 WRITE(LOUT,1001) THETO,PIN,POUT
8917 1001 FORMAT(1X,'CROMSC: inconsistent scattering angle ',
8918 & E12.4,/,1X,' PIN :',4E12.4,/,
8919 & 1X,' POUT:',4E12.4)
8920 GOTO 9997
8921 ENDIF
8922 GOTO 1
8923 ENDIF
8924
8925 RETURN
8926
8927 9997 IRCRON(2) = IRCRON(2)+1
8928 GOTO 9999
8929 9998 IRCRON(3) = IRCRON(3)+1
8930
8931 9999 CONTINUE
8932 DO 100 K=1,4
8933 POUT(K) = PIN(K)
8934 100 CONTINUE
8935 RETURN
8936 END
8937
8938*$ CREATE DT_COM2CR.FOR
8939*COPY DT_COM2CR
8940*
8941*===com2sr=============================================================*
8942*
8943 SUBROUTINE DT_COM2CR
8944
8945************************************************************************
8946* COMbine q-aq chains to Color Ropes (qq-aqaq). *
8947* CUTOF parameter determining minimum number of not *
8948* combined q-aq chains *
8949* This subroutine replaces KKEVCC etc. *
8950* This version dated 11.01.95 is written by S. Roesler. *
8951************************************************************************
8952
8953 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8954 SAVE
8955 PARAMETER ( LINP = 10 ,
8956 & LOUT = 6 ,
8957 & LDAT = 9 )
8958
8959* event history
8960 PARAMETER (NMXHKK=200000)
8961 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8962 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8963 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8964* extended event history
8965 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8966 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8967 & IHIST(2,NMXHKK)
8968* statistics
8969 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
8970 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
8971 & ICEVTG(8,0:30)
8972* various options for treatment of partons (DTUNUC 1.x)
8973* (chain recombination, Cronin,..)
8974 LOGICAL LCO2CR,LINTPT
8975 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8976 & LCO2CR,LINTPT
8977
8978 DIMENSION IDXQA(248),IDXAQ(248)
8979
8980 ICCHAI(1,9) = ICCHAI(1,9)+1
8981 NQA = 0
8982 NAQ = 0
8983* scan DTEVT1 for q-aq, aq-q chains
8984 DO 10 I=NPOINT(3),NHKK
8985* skip "chains" which are resonances
8986 IF ((IDHKK(I).EQ.88888).AND.(IDRES(I).EQ.0)) THEN
8987 MO1 = JMOHKK(1,I)
8988 MO2 = JMOHKK(2,I)
8989 IF ((ABS(IDHKK(MO1)).LE.6).AND.(ABS(IDHKK(MO2)).LE.6)) THEN
8990* q-aq, aq-q chain found, keep index
8991 IF (IDHKK(MO1).GT.0) THEN
8992 NQA = NQA+1
8993 IDXQA(NQA) = I
8994 ELSE
8995 NAQ = NAQ+1
8996 IDXAQ(NAQ) = I
8997 ENDIF
8998 ENDIF
8999 ENDIF
9000 10 CONTINUE
9001
9002* minimum number of q-aq chains requested for the same projectile/
9003* target
9004 NCHMIN = IDT_NPOISS(CUTOF)
9005
9006* combine q-aq chains of the same projectile
9007 CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,1)
9008* combine q-aq chains of the same target
9009 CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,2)
9010* combine aq-q chains of the same projectile
9011 CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,1)
9012* combine aq-q chains of the same target
9013 CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,2)
9014
9015 RETURN
9016 END
9017
9018*$ CREATE DT_SCN4CR.FOR
9019*COPY DT_SCN4CR
9020*
9021*===scn4cr=============================================================*
9022*
9023 SUBROUTINE DT_SCN4CR(NCH,IDXCH,NCHMIN,MODE)
9024
9025************************************************************************
9026* SCan q-aq chains for Color Ropes. *
9027* This version dated 11.01.95 is written by S. Roesler. *
9028************************************************************************
9029
9030 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9031 SAVE
9032 PARAMETER ( LINP = 10 ,
9033 & LOUT = 6 ,
9034 & LDAT = 9 )
9035
9036* event history
9037 PARAMETER (NMXHKK=200000)
9038 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9039 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9040 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9041* extended event history
9042 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9043 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9044 & IHIST(2,NMXHKK)
9045
9046 DIMENSION IDXCH(248),IDXJN(248)
9047
9048 DO 1 I=1,NCH
9049 IF (IDXCH(I).GT.0) THEN
9050 NJOIN = 1
9051 IDXMO = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(I))))
9052 IDXJN(NJOIN) = I
9053 IF (I.LT.NCH) THEN
9054 DO 2 J=I+1,NCH
9055 IF (IDXCH(J).GT.0) THEN
9056 IDXMO1 = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(J))))
9057 IF (IDXMO.EQ.IDXMO1) THEN
9058 NJOIN = NJOIN+1
9059 IDXJN(NJOIN) = J
9060 ENDIF
9061 ENDIF
9062 2 CONTINUE
9063 ENDIF
9064 IF (NJOIN.GE.NCHMIN+2) THEN
9065 NJ = INT(DBLE(NJOIN-NCHMIN)/2.0D0)
9066 DO 3 J=1,2*NJ,2
9067 CALL DT_JOIN(IDXCH(IDXJN(J)),IDXCH(IDXJN(J+1)),IREJ1)
9068 IF (IREJ1.NE.0) GOTO 3
9069 IDXCH(IDXJN(J)) = 0
9070 IDXCH(IDXJN(J+1)) = 0
9071 3 CONTINUE
9072 ENDIF
9073 ENDIF
9074 1 CONTINUE
9075
9076 RETURN
9077 END
9078
9079*$ CREATE DT_JOIN.FOR
9080*COPY DT_JOIN
9081*
9082*===join===============================================================*
9083*
9084 SUBROUTINE DT_JOIN(IDX1,IDX2,IREJ)
9085
9086************************************************************************
9087* This subroutine joins two q-aq chains to one qq-aqaq chain. *
9088* IDX1, IDX2 DTEVT1 indices of chains to be joined *
9089* This version dated 11.01.95 is written by S. Roesler. *
9090************************************************************************
9091
9092 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9093 SAVE
9094 PARAMETER ( LINP = 10 ,
9095 & LOUT = 6 ,
9096 & LDAT = 9 )
9097
9098* event history
9099 PARAMETER (NMXHKK=200000)
9100 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9101 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9102 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9103* extended event history
9104 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9105 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9106 & IHIST(2,NMXHKK)
9107* flags for input different options
9108 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
9109 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
9110 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
9111* statistics
9112 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9113 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9114 & ICEVTG(8,0:30)
9115
9116 DIMENSION MO(2,2),ID(2,2),IDX(2),PCH(4),PP(4),PT(4),P1(4),P2(4)
9117
9118 IREJ = 0
9119
9120 IDX(1) = IDX1
9121 IDX(2) = IDX2
9122 DO 1 I=1,2
9123 DO 2 J=1,2
9124 MO(I,J) = JMOHKK(J,IDX(I))
9125 ID(I,J) = IDT_IPDG2B(IDHKK(MO(I,J)),1,2)
9126 2 CONTINUE
9127 1 CONTINUE
9128
9129* check consistency
9130 IF ((ABS(ID(1,1)).GT.6).OR.(ABS(ID(1,2)).GT.6).OR.
9131 & (ABS(ID(2,1)).GT.6).OR.(ABS(ID(2,2)).GT.6).OR.
9132 & ((ID(1,1)*ID(2,1)).LT.0).OR.
9133 & ((ID(1,2)*ID(2,2)).LT.0)) THEN
9134 WRITE(LOUT,1000) IDX(1),MO(1,1),MO(1,2),IDX(2),MO(2,1),
9135 & MO(2,2)
9136 1000 FORMAT(1X,'JOIN: incons. chain system! chain ',I4,':',
9137 & 2I5,' chain ',I4,':',2I5)
9138 ENDIF
9139
9140* join chains
9141 DO 3 K=1,4
9142 PP(K) = PHKK(K,MO(1,1))+PHKK(K,MO(2,1))
9143 PT(K) = PHKK(K,MO(1,2))+PHKK(K,MO(2,2))
9144 3 CONTINUE
9145 IF1 = IDT_IB2PDG(ID(1,1),ID(2,1),2)
9146 IF2 = IDT_IB2PDG(ID(1,2),ID(2,2),2)
9147 IST1 = ISTHKK(MO(1,1))
9148 IST2 = ISTHKK(MO(1,2))
9149
9150* put partons again on mass shell
9151 XM1 = 0.0D0
9152 XM2 = 0.0D0
9153 IF (IMSHL.EQ.1) THEN
9154 XM1 = PYMASS(IF1)
9155 XM2 = PYMASS(IF2)
9156 ENDIF
9157 CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1)
9158 IF (IREJ1.NE.0) GOTO 9999
9159 DO 4 I=1,4
9160 PP(I) = P1(I)
9161 PT(I) = P2(I)
9162 4 CONTINUE
9163
9164* store new partons in DTEVT1
9165 CALL DT_EVTPUT(IST1,IF1,MO(1,1),MO(2,1),PP(1),PP(2),PP(3),PP(4),
9166 & 0,0,0)
9167 CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4),
9168 & 0,0,0)
9169 DO 5 K=1,4
9170 PCH(K) = PP(K)+PT(K)
9171 5 CONTINUE
9172
9173* check new chain for lower mass limit
9174 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
9175 AMCH = SQRT(ABS(PCH(4)**2-PCH(1)**2-PCH(2)**2-PCH(3)**2))
9176 CALL DT_CH2RES(ID(1,1),ID(2,1),ID(1,2),ID(2,2),IDUM,IDUM,
9177 & AMCH,AMCHN,3,IREJ1)
9178 IF (IREJ1.NE.0) THEN
9179 NHKK = NHKK-2
9180 GOTO 9999
9181 ENDIF
9182 ENDIF
9183
9184 ICCHAI(2,9) = ICCHAI(2,9)+1
9185* store new chain in DTEVT1
9186 KCH = 191
9187 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),0,0,9)
9188 IDHKK(IDX(1)) = 22222
9189 IDHKK(IDX(2)) = 22222
9190* special treatment for space-time coordinates
9191 DO 6 K=1,4
9192 VHKK(K,NHKK) = (VHKK(K,IDX(1))+VHKK(K,IDX(2)))/2.0D0
9193 WHKK(K,NHKK) = (WHKK(K,IDX(1))+WHKK(K,IDX(2)))/2.0D0
9194 6 CONTINUE
9195 RETURN
9196
9197 9999 CONTINUE
9198 IREJ = 1
9199 RETURN
9200 END
9201
9202*$ CREATE DT_XSGLAU.FOR
9203*COPY DT_XSGLAU
9204*
9205*===xsglau=============================================================*
9206*
9207 SUBROUTINE DT_XSGLAU(NA,NB,JJPROJ,XI,Q2I,ECMI,IE,IQ,NIDX)
9208
9209************************************************************************
9210* Total, elastic, quasi-elastic, inelastic cross sections according to *
9211* Glauber's approach. *
9212* NA / NB mass numbers of proj./target nuclei *
9213* JJPROJ bamjet-index of projectile (=1 in case of proj.nucleus) *
9214* XI,Q2I,ECMI kinematical variables x, Q^2, E_cm *
9215* IE,IQ indices of energy and virtuality (the latter for gamma *
9216* projectiles only) *
9217* NIDX index of projectile/target nucleus *
9218* This version dated 17.3.98 is written by S. Roesler *
9219************************************************************************
9220
9221 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9222 SAVE
9223 PARAMETER ( LINP = 10 ,
9224 & LOUT = 6 ,
9225 & LDAT = 9 )
9226
9227 COMPLEX*16 CZERO,CONE,CTWO
9228 CHARACTER*12 CFILE
9229 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
9230 & ONETHI=ONE/THREE,TINY25=1.0D-25)
9231 PARAMETER (TWOPI = 6.283185307179586454D+00,
9232 & PI = TWOPI/TWO,
9233 & GEV2MB = 0.38938D0,
9234 & GEV2FM = 0.1972D0,
9235 & ALPHEM = ONE/137.0D0,
9236* proton mass
9237 & AMP = 0.938D0,
9238 & AMP2 = AMP**2,
9239* approx. nucleon radius
9240 & RNUCLE = 1.12D0)
9241
9242* particle properties (BAMJET index convention)
9243 CHARACTER*8 ANAME
9244 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
9245 & IICH(210),IIBAR(210),K1(210),K2(210)
9246 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
9247 PARAMETER ( MAXNCL = 260,
9248 & MAXVQU = MAXNCL,
9249 & MAXSQU = 20*MAXVQU,
9250 & MAXINT = MAXVQU+MAXSQU)
9251* Glauber formalism: parameters
9252 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
9253 & BMAX(NCOMPX),BSTEP(NCOMPX),
9254 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
9255 & NSITEB,NSTATB
9256* Glauber formalism: cross sections
9257 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
9258 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
9259 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
9260 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
9261 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
9262 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
9263 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
9264 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
9265 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
9266 & BSLOPE,NEBINI,NQBINI
9267* Glauber formalism: flags and parameters for statistics
9268 LOGICAL LPROD
9269 CHARACTER*8 CGLB
9270 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
9271* nucleon-nucleon event-generator
9272 CHARACTER*8 CMODEL
9273 LOGICAL LPHOIN
9274 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
9275* VDM parameter for photon-nucleus interactions
9276 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
9277* parameters for hA-diffraction
9278 COMMON /DTDIHA/ DIBETA,DIALPH
9279
9280 COMPLEX*16 PP11(MAXNCL),PP12(MAXNCL),PP21(MAXNCL),PP22(MAXNCL),
9281 & OMPP11,OMPP12,OMPP21,OMPP22,
9282 & DIPP11,DIPP12,DIPP21,DIPP22,AVDIPP,
9283 & PPTMP1,PPTMP2
9284 COMPLEX*16 C,CA,CI
9285 DIMENSION COOP1(3,MAXNCL),COOT1(3,MAXNCL),
9286 & COOP2(3,MAXNCL),COOT2(3,MAXNCL),
9287 & BPROD(KSITEB)
9288
9289 PARAMETER (NPOINT=16)
9290 DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
9291
9292 LOGICAL LFIRST,LOPEN
9293 DATA LFIRST,LOPEN /.TRUE.,.FALSE./
9294
9295 NTARG = ABS(NIDX)
9296* for quasi-elastic neutrino scattering set projectile to proton
9297* it should not have an effect since the whole Glauber-formalism is
9298* not needed for these interactions..
9299 IF (MCGENE.EQ.4) THEN
9300 IJPROJ = 1
9301 ELSE
9302 IJPROJ = JJPROJ
9303 ENDIF
9304
9305 IF ((ABS(IOGLB).EQ.1).AND.(.NOT.LOPEN)) THEN
9306 I = INDEX(CGLB,' ')
9307 IF (I.EQ.0) THEN
9308 CFILE = CGLB//'.glb'
9309 OPEN(LDAT,FILE=CGLB//'.glb',STATUS='UNKNOWN')
9310 ELSEIF (I.GT.1) THEN
9311 CFILE = CGLB(1:I-1)//'.glb'
9312 OPEN(LDAT,FILE=CGLB(1:I-1)//'.glb',STATUS='UNKNOWN')
9313 ELSE
9314 STOP 'XSGLAU 1'
9315 ENDIF
9316 LOPEN = .TRUE.
9317 ENDIF
9318
9319 CZERO = DCMPLX(ZERO,ZERO)
9320 CONE = DCMPLX(ONE,ZERO)
9321 CTWO = DCMPLX(TWO,ZERO)
9322 NEBINI = IE
9323 NQBINI = IQ
9324
9325* re-define kinematics
9326 S = ECMI**2
9327 Q2 = Q2I
9328 X = XI
9329* g(Q2=0)-A, h-A, A-A scattering
9330 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9331 Q2 = 0.0001D0
9332 X = Q2/(S+Q2-AMP2)
9333* g(Q2>0)-A scattering
9334 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(S.GT.ZERO)) THEN
9335 X = Q2/(S+Q2-AMP2)
9336 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9337 Q2 = (S-AMP2)*X/(ONE-X)
9338 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
9339 S = Q2*(ONE-X)/X+AMP2
9340 ELSE
9341 WRITE(LOUT,*) 'XSGLAU: inconsistent input ',S,Q2,X
9342 STOP
9343 ENDIF
9344 ECMNN(IE) = SQRT(S)
9345 Q2G(IQ) = Q2
9346 XNU = (S+Q2-AMP2)/(TWO*AMP)
9347
9348* parameters determining statistics in evaluating Glauber-xsection
9349 NSTATB = JSTATB
9350 NSITEB = JBINSB
9351 IF (NSITEB.GT.KSITEB) NSITEB = KSITEB
9352
9353* set up interaction geometry (common /DTGLAM/)
9354* projectile/target radii
9355 RPRNCL = DT_RNCLUS(NA)
9356 RTANCL = DT_RNCLUS(NB)
9357 IF (IJPROJ.EQ.7) THEN
9358 RASH(1) = ZERO
9359 RBSH(NTARG) = RTANCL
9360 BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9361 ELSE
9362 IF (NIDX.LE.-1) THEN
9363 RASH(1) = RPRNCL
9364 RBSH(NTARG) = RTANCL
9365 BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9366 ELSE
9367 RASH(NTARG) = RPRNCL
9368 RBSH(1) = RTANCL
9369 BMAX(NTARG) = 2.0D0*(RASH(NTARG)+RBSH(1))
9370 ENDIF
9371 ENDIF
9372* maximum impact-parameter
9373 BSTEP(NTARG)= BMAX(NTARG)/DBLE(NSITEB-1)
9374
9375* slope, rho ( Re(f(0))/Im(f(0)) )
9376 IF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
9377 IF (MCGENE.EQ.2) THEN
9378 ZERO1 = ZERO
9379 CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,SDUM1,SDUM2,SDUM3,
9380 & BSLOPE,0)
9381 ELSE
9382 BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
9383 ENDIF
9384 IF (ECMNN(IE).LE.3.0D0) THEN
9385 ROSH = -0.43D0
9386 ELSEIF ((ECMNN(IE).GT.3.0D0).AND.(ECMNN(IE).LE.50.D0)) THEN
9387 ROSH = -0.63D0+0.175D0*LOG(ECMNN(IE))
9388 ELSEIF (ECMNN(IE).GT.50.0D0) THEN
9389 ROSH = 0.1D0
9390 ENDIF
9391 ELSEIF (IJPROJ.EQ.7) THEN
9392 ROSH = 0.1D0
9393 ELSE
9394 BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
9395 ROSH = 0.01D0
9396 ENDIF
9397
9398* projectile-nucleon xsection (in fm)
9399 IF (IJPROJ.EQ.7) THEN
9400 SIGSH = DT_SIGVP(X,Q2)/10.0D0
9401 ELSE
9402 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
9403 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
9404C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
9405 DUMZER = ZERO
9406 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
9407 SIGSH = SIGSH/10.0D0
9408 ENDIF
9409
9410* parameters for projectile diffraction (hA scattering only)
9411 IF ((MCGENE.EQ.2).AND.(NA.EQ.1).AND.(NB.GT.1).AND.(IJPROJ.NE.7)
9412 & .AND.(DIBETA.GE.ZERO)) THEN
9413 ZERO1 = ZERO
9414 CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,STOT,SDUM2,SDIF1,BDUM,0)
9415C DIBETA = SDIF1/STOT
9416 DIBETA = 0.2D0
9417 DIGAMM = SQRT(DIALPH**2+DIBETA**2)
9418 IF (DIBETA.LE.ZERO) THEN
9419 ALPGAM = ONE
9420 ELSE
9421 ALPGAM = DIALPH/DIGAMM
9422 ENDIF
9423 FACDI1 = ONE-ALPGAM
9424 FACDI2 = ONE+ALPGAM
9425 FACDI = SQRT(FACDI1*FACDI2)
9426 WRITE(LOUT,*)'DIBETA,DIALPH,DIGAMM: ',DIBETA,DIALPH,DIGAMM
9427 ELSE
9428 DIBETA = -1.0D0
9429 DIALPH = ZERO
9430 DIGAMM = ZERO
9431 FACDI1 = ZERO
9432 FACDI2 = 2.0D0
9433 FACDI = ZERO
9434 ENDIF
9435
9436* initializations
9437 DO 10 I=1,NSITEB
9438 BSITE( 0,IQ,NTARG,I) = ZERO
9439 BSITE(IE,IQ,NTARG,I) = ZERO
9440 BPROD(I) = ZERO
9441 10 CONTINUE
9442 STOT = ZERO
9443 STOT2 = ZERO
9444 SELA = ZERO
9445 SELA2 = ZERO
9446 SQEP = ZERO
9447 SQEP2 = ZERO
9448 SQET = ZERO
9449 SQET2 = ZERO
9450 SQE2 = ZERO
9451 SQE22 = ZERO
9452 SPRO = ZERO
9453 SPRO2 = ZERO
9454 SDEL = ZERO
9455 SDEL2 = ZERO
9456 SDQE = ZERO
9457 SDQE2 = ZERO
9458 FACN = ONE/DBLE(NSTATB)
9459
9460 IPNT = 0
9461 RPNT = ZERO
9462
9463* initialize Gauss-integration for photon-proj.
9464 JPOINT = 1
9465 IF (IJPROJ.EQ.7) THEN
9466 IF (INTRGE(1).EQ.1) THEN
9467 AMLO2 = (3.0D0*AAM(13))**2
9468 ELSEIF (INTRGE(1).EQ.2) THEN
9469 AMLO2 = AAM(33)**2
9470 ELSE
9471 AMLO2 = AAM(96)**2
9472 ENDIF
9473 IF (INTRGE(2).EQ.1) THEN
9474 AMHI2 = S/TWO
9475 ELSEIF (INTRGE(2).EQ.2) THEN
9476 AMHI2 = S/4.0D0
9477 ELSE
9478 AMHI2 = S
9479 ENDIF
9480 AMHI20 = (ECMNN(IE)-AMP)**2
9481 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
9482 XAMLO = LOG( AMLO2+Q2 )
9483 XAMHI = LOG( AMHI2+Q2 )
9484**PHOJET105a
9485C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9486**PHOJET112
9487 CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9488**
9489 JPOINT = NPOINT
9490* ratio direct/total photon-nucleon xsection
9491 CALL DT_POILIK(NB,NTARG,ECMNN(IE),Q2,IPNT,RPNT,1)
9492 ENDIF
9493
9494* read pre-initialized profile-function from file
9495 IF (IOGLB.EQ.1) THEN
9496 READ(LDAT,'(5I10,E15.5)') KJPROJ,IA,IB,ISTATB,ISITEB,DUM
9497 IF ((IA.NE.NA).OR.(IB.NE.NB)) THEN
9498 WRITE(LOUT,1000) CFILE,IA,IB,ISTATB,ISITEB,
9499 & NA,NB,NSTATB,NSITEB
9500 1000 FORMAT(' XSGLAU: inconsistent input data in file ',A12,/,
9501 & ' (IA,IB,ISTATB,ISITEB) ',4I10,/,
9502 & ' (NA,NB,NSTATB,NSITEB) ',4I10)
9503 STOP
9504 ENDIF
9505 IF (LFIRST) WRITE(LOUT,1001) CFILE
9506 1001 FORMAT(/,' XSGLAU: impact parameter distribution read from ',
9507 & 'file ',A12,/)
9508 READ(LDAT,'(6E12.5)') XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),
9509 & XSQEP(IE,IQ,NTARG),XSQET(IE,IQ,NTARG),
9510 & XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
9511 READ(LDAT,'(6E12.5)') XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),
9512 & XEQEP(IE,IQ,NTARG),XEQET(IE,IQ,NTARG),
9513 & XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
9514 NLINES = INT(DBLE(NSITEB)/7.0D0)
9515 IF (NLINES.GT.0) THEN
9516 DO 21 I=1,NLINES
9517 ISTART = 7*I-6
9518 READ(LDAT,'(7E11.4)')
9519 & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
9520 21 CONTINUE
9521 ENDIF
9522 ISTART = 7*NLINES+1
9523 IF (ISTART.LE.NSITEB) THEN
9524 READ(LDAT,'(7E11.4)')
9525 & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
9526 ENDIF
9527 LFIRST = .FALSE.
9528 GOTO 100
9529* variable projectile/target/energy runs:
9530* read pre-initialized profile-functions from file
9531 ELSEIF (IOGLB.EQ.100) THEN
9532 CALL DT_GLBSET(IJPROJ,IINA,IINB,RRELAB,0)
9533 GOTO 100
9534 ENDIF
9535
9536* cross sections averaged over NSTATB nucleon configurations
9537 DO 11 IS=1,NSTATB
9538C IF ((NA.EQ.207).AND.(NB.EQ.207)) WRITE(LOUT,*) 'conf. ',IS
9539 STOTN = ZERO
9540 SELAN = ZERO
9541 SQEPN = ZERO
9542 SQETN = ZERO
9543 SQE2N = ZERO
9544 SPRON = ZERO
9545 SDELN = ZERO
9546 SDQEN = ZERO
9547
9548 IF (NIDX.LE.-1) THEN
9549 CALL DT_CONUCL(COOP1,NA,RASH(1),0)
9550 CALL DT_CONUCL(COOT1,NB,RBSH(NTARG),1)
9551 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9552 CALL DT_CONUCL(COOP2,NA,RASH(1),0)
9553 CALL DT_CONUCL(COOT2,NB,RBSH(NTARG),1)
9554 ENDIF
9555 ELSE
9556 CALL DT_CONUCL(COOP1,NA,RASH(NTARG),0)
9557 CALL DT_CONUCL(COOT1,NB,RBSH(1),1)
9558 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9559 CALL DT_CONUCL(COOP2,NA,RASH(NTARG),0)
9560 CALL DT_CONUCL(COOT2,NB,RBSH(1),1)
9561 ENDIF
9562 ENDIF
9563
9564* integration over impact parameter B
9565 DO 12 IB=1,NSITEB-1
9566 STOTB = ZERO
9567 SELAB = ZERO
9568 SQEPB = ZERO
9569 SQETB = ZERO
9570 SQE2B = ZERO
9571 SPROB = ZERO
9572 SDIR = ZERO
9573 SDELB = ZERO
9574 SDQEB = ZERO
9575 B = DBLE(IB)*BSTEP(NTARG)
9576 FACB = 10.0D0*TWOPI*B*BSTEP(NTARG)
9577
9578* integration over M_V^2 for photon-proj.
9579 DO 14 IM=1,JPOINT
9580 PP11(1) = CONE
9581 PP12(1) = CONE
9582 PP21(1) = CONE
9583 PP22(1) = CONE
9584 IF (IJPROJ.EQ.7) THEN
9585 DO 13 K=2,NB
9586 PP11(K) = CONE
9587 PP12(K) = CONE
9588 PP21(K) = CONE
9589 PP22(K) = CONE
9590 13 CONTINUE
9591 ENDIF
9592 SHI = ZERO
9593 FACM = ONE
9594 DCOH = 1.0D10
9595
9596 IF (IJPROJ.EQ.7) THEN
9597 AMV2 = EXP(ABSZX(IM))-Q2
9598 AMV = SQRT(AMV2)
9599 IF (AMV2.LT.16.0D0) THEN
9600 R = TWO
9601 ELSEIF ((AMV2.GE.16.0D0).AND.(AMV2.LT.121.0D0)) THEN
9602 R = 10.0D0/3.0D0
9603 ELSE
9604 R = 11.0D0/3.0D0
9605 ENDIF
9606* define M_V dependent properties of nucleon scattering amplitude
9607* V_M-nucleon xsection
9608 SIGMVD = RPNT*SIGSH/(AMV2+Q2+RL2)*10.0D0
9609 SIGMV = (ONE-RPNT)*SIGSH/(AMV2+Q2+RL2)
9610* slope-parametrisation a la Kaidalov
9611 BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
9612 & +0.25D0*LOG(S/(AMV2+Q2)))
9613* coherence length
9614 IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+Q2)*GEV2FM
9615* integration weight factor
9616 FACM = ALPHEM/(3.0D0*PI*(ONE-X))*
9617 & R*AMV2/(AMV2+Q2)*(ONE+EPSPOL*Q2/AMV2)*WEIGHT(IM)
9618 ENDIF
9619 GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
9620 GAM = GSH
9621 IF (IJPROJ.EQ.7) THEN
9622 RCA = GAM*SIGMV/TWOPI
9623 ELSE
9624 RCA = GAM*SIGSH/TWOPI
9625 ENDIF
9626 FCA = -ROSH*RCA
9627 CA = DCMPLX(RCA,FCA)
9628 CI = CONE
9629
9630 DO 15 INA=1,NA
9631 KK1 = 1
9632 INT1 = 1
9633 KK2 = 1
9634 INT2 = 1
9635 DO 16 INB=1,NB
9636* photon-projectile: check for supression by coherence length
9637 IF (IJPROJ.EQ.7) THEN
9638 IF (ABS(COOT1(3,INB)-COOT1(3,KK1)).GT.DCOH)THEN
9639 KK1 = INB
9640 INT1 = INT1+1
9641 ENDIF
9642 IF (ABS(COOT2(3,INB)-COOT2(3,KK2)).GT.DCOH)THEN
9643 KK2 = INB
9644 INT2 = INT2+1
9645 ENDIF
9646 ENDIF
9647
9648 X11 = B+COOT1(1,INB)-COOP1(1,INA)
9649 Y11 = COOT1(2,INB)-COOP1(2,INA)
9650 XY11 = GAM*(X11*X11+Y11*Y11)
9651 IF (XY11.LE.15.0D0) THEN
9652 C = CONE-CA*EXP(-XY11)
9653 AR = DBLE(PP11(INT1))
9654 AI = DIMAG(PP11(INT1))
9655 IF (ABS(AR).LT.TINY25) AR = ZERO
9656 IF (ABS(AI).LT.TINY25) AI = ZERO
9657 PP11(INT1) = DCMPLX(AR,AI)
9658 PP11(INT1) = PP11(INT1)*C
9659 AR = DBLE(C)
9660 AI = DIMAG(C)
9661 SHI = SHI+LOG(AR*AR+AI*AI)
9662 ENDIF
9663 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9664 X12 = B+COOT2(1,INB)-COOP1(1,INA)
9665 Y12 = COOT2(2,INB)-COOP1(2,INA)
9666 XY12 = GAM*(X12*X12+Y12*Y12)
9667 IF (XY12.LE.15.0D0) THEN
9668 C = CONE-CA*EXP(-XY12)
9669 AR = DBLE(PP12(INT2))
9670 AI = DIMAG(PP12(INT2))
9671 IF (ABS(AR).LT.TINY25) AR = ZERO
9672 IF (ABS(AI).LT.TINY25) AI = ZERO
9673 PP12(INT2) = DCMPLX(AR,AI)
9674 PP12(INT2) = PP12(INT2)*C
9675 ENDIF
9676 X21 = B+COOT1(1,INB)-COOP2(1,INA)
9677 Y21 = COOT1(2,INB)-COOP2(2,INA)
9678 XY21 = GAM*(X21*X21+Y21*Y21)
9679 IF (XY21.LE.15.0D0) THEN
9680 C = CONE-CA*EXP(-XY21)
9681 AR = DBLE(PP21(INT1))
9682 AI = DIMAG(PP21(INT1))
9683 IF (ABS(AR).LT.TINY25) AR = ZERO
9684 IF (ABS(AI).LT.TINY25) AI = ZERO
9685 PP21(INT1) = DCMPLX(AR,AI)
9686 PP21(INT1) = PP21(INT1)*C
9687 ENDIF
9688 X22 = B+COOT2(1,INB)-COOP2(1,INA)
9689 Y22 = COOT2(2,INB)-COOP2(2,INA)
9690 XY22 = GAM*(X22*X22+Y22*Y22)
9691 IF (XY22.LE.15.0D0) THEN
9692 C = CONE-CA*EXP(-XY22)
9693 AR = DBLE(PP22(INT2))
9694 AI = DIMAG(PP22(INT2))
9695 IF (ABS(AR).LT.TINY25) AR = ZERO
9696 IF (ABS(AI).LT.TINY25) AI = ZERO
9697 PP22(INT2) = DCMPLX(AR,AI)
9698 PP22(INT2) = PP22(INT2)*C
9699 ENDIF
9700 ENDIF
9701 16 CONTINUE
9702 15 CONTINUE
9703
9704 OMPP11 = CZERO
9705 OMPP21 = CZERO
9706 DIPP11 = CZERO
9707 DIPP21 = CZERO
9708 DO 17 K=1,INT1
9709 IF (PP11(K).EQ.CZERO) THEN
9710 PPTMP1 = CZERO
9711 PPTMP2 = CZERO
9712 ELSE
9713 PPTMP1 = PP11(K)**(ONE-DIALPH-DIGAMM)
9714 PPTMP2 = PP11(K)**(ONE-DIALPH+DIGAMM)
9715 ENDIF
9716 AVDIPP = 0.5D0*
9717 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9718 OMPP11 = OMPP11+AVDIPP
9719C OMPP11 = OMPP11+(CONE-PP11(K))
9720 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9721 DIPP11 = DIPP11+AVDIPP
9722 IF (PP21(K).EQ.CZERO) THEN
9723 PPTMP1 = CZERO
9724 PPTMP2 = CZERO
9725 ELSE
9726 PPTMP1 = PP21(K)**(ONE-DIALPH-DIGAMM)
9727 PPTMP2 = PP21(K)**(ONE-DIALPH+DIGAMM)
9728 ENDIF
9729 AVDIPP = 0.5D0*
9730 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9731 OMPP21 = OMPP21+AVDIPP
9732C OMPP21 = OMPP21+(CONE-PP21(K))
9733 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9734 DIPP21 = DIPP21+AVDIPP
9735 17 CONTINUE
9736 OMPP12 = CZERO
9737 OMPP22 = CZERO
9738 DIPP12 = CZERO
9739 DIPP22 = CZERO
9740 DO 18 K=1,INT2
9741 IF (PP12(K).EQ.CZERO) THEN
9742 PPTMP1 = CZERO
9743 PPTMP2 = CZERO
9744 ELSE
9745 PPTMP1 = PP12(K)**(ONE-DIALPH-DIGAMM)
9746 PPTMP2 = PP12(K)**(ONE-DIALPH+DIGAMM)
9747 ENDIF
9748 AVDIPP = 0.5D0*
9749 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9750 OMPP12 = OMPP12+AVDIPP
9751C OMPP12 = OMPP12+(CONE-PP12(K))
9752 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9753 DIPP12 = DIPP12+AVDIPP
9754 IF (PP22(K).EQ.CZERO) THEN
9755 PPTMP1 = CZERO
9756 PPTMP2 = CZERO
9757 ELSE
9758 PPTMP1 = PP22(K)**(ONE-DIALPH-DIGAMM)
9759 PPTMP2 = PP22(K)**(ONE-DIALPH+DIGAMM)
9760 ENDIF
9761 AVDIPP = 0.5D0*
9762 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9763 OMPP22 = OMPP22+AVDIPP
9764C OMPP22 = OMPP22+(CONE-PP22(K))
9765 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9766 DIPP22 = DIPP22+AVDIPP
9767 18 CONTINUE
9768
9769 SPROM = ONE-EXP(SHI)
9770 SPROB = SPROB+FACM*SPROM
9771 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9772 STOTM = DBLE(OMPP11+OMPP22)
9773 SELAM = DBLE(OMPP11*DCONJG(OMPP22))
9774 SQEPM = DBLE(OMPP11*DCONJG(OMPP21))-SELAM
9775 SQETM = DBLE(OMPP11*DCONJG(OMPP12))-SELAM
9776 SQE2M = DBLE(OMPP11*DCONJG(OMPP11))-SELAM-SQEPM-SQETM
9777 SDELM = DBLE(DIPP11*DCONJG(DIPP22))
9778 SDQEM = DBLE(DIPP11*DCONJG(DIPP21))-SDELM
9779 STOTB = STOTB+FACM*STOTM
9780 SELAB = SELAB+FACM*SELAM
9781 SDELB = SDELB+FACM*SDELM
9782 IF (NB.GT.1) THEN
9783 SQEPB = SQEPB+FACM*SQEPM
9784 SDQEB = SDQEB+FACM*SDQEM
9785 ENDIF
9786 IF (NA.GT.1) SQETB = SQETB+FACM*SQETM
9787 IF ((NA.GT.1).AND.(NB.GT.1)) SQE2B = SQE2B+FACM*SQE2M
9788 IF (IJPROJ.EQ.7) SDIR = SDIR+FACM*SIGMVD
9789 ENDIF
9790
9791 14 CONTINUE
9792
9793 STOTN = STOTN+FACB*STOTB
9794 SELAN = SELAN+FACB*SELAB
9795 SQEPN = SQEPN+FACB*SQEPB
9796 SQETN = SQETN+FACB*SQETB
9797 SQE2N = SQE2N+FACB*SQE2B
9798 SPRON = SPRON+FACB*SPROB
9799 SDELN = SDELN+FACB*SDELB
9800 SDQEN = SDQEN+FACB*SDQEB
9801
9802 IF (IJPROJ.EQ.7) THEN
9803 BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*(STOTB-SELAB-SQEPB)
9804 ELSE
9805 IF (DIBETA.GT.ZERO) THEN
9806 BPROD(IB+1)= BPROD(IB+1)
9807 & +FACN*FACB*(STOTB-SELAB-SQEPB-SQETB-SQE2B)
9808 ELSE
9809 BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*SPROB
9810 ENDIF
9811 ENDIF
9812
9813 12 CONTINUE
9814
9815 STOT = STOT +FACN*STOTN
9816 STOT2 = STOT2+FACN*STOTN**2
9817 SELA = SELA +FACN*SELAN
9818 SELA2 = SELA2+FACN*SELAN**2
9819 SQEP = SQEP +FACN*SQEPN
9820 SQEP2 = SQEP2+FACN*SQEPN**2
9821 SQET = SQET +FACN*SQETN
9822 SQET2 = SQET2+FACN*SQETN**2
9823 SQE2 = SQE2 +FACN*SQE2N
9824 SQE22 = SQE22+FACN*SQE2N**2
9825 SPRO = SPRO +FACN*SPRON
9826 SPRO2 = SPRO2+FACN*SPRON**2
9827 SDEL = SDEL +FACN*SDELN
9828 SDEL2 = SDEL2+FACN*SDELN**2
9829 SDQE = SDQE +FACN*SDQEN
9830 SDQE2 = SDQE2+FACN*SDQEN**2
9831
9832 11 CONTINUE
9833
9834* final cross sections
9835* 1) total
9836 XSTOT(IE,IQ,NTARG) = STOT
9837 IF (IJPROJ.EQ.7)
9838 & XSTOT(IE,IQ,NTARG) = XSTOT(IE,IQ,NTARG)+DBLE(NB)*SDIR
9839* 2) elastic
9840 XSELA(IE,IQ,NTARG) = SELA
9841* 3) quasi-el.: A+B-->A+X (excluding 2)
9842 XSQEP(IE,IQ,NTARG) = SQEP
9843* 4) quasi-el.: A+B-->X+B (excluding 2)
9844 XSQET(IE,IQ,NTARG) = SQET
9845* 5) quasi-el.: A+B-->X (excluding 2-4)
9846 XSQE2(IE,IQ,NTARG) = SQE2
9847* 6) production (= STOT-SELA-SQEP-SQET-SQE2!)
9848 IF (SDEL.GT.ZERO) THEN
9849 XSPRO(IE,IQ,NTARG) = STOT-SELA-SQEP-SQET-SQE2
9850 ELSE
9851 XSPRO(IE,IQ,NTARG) = SPRO
9852 ENDIF
9853* 7) projectile diffraction (el. scatt. off target)
9854 XSDEL(IE,IQ,NTARG) = SDEL
9855* 8) projectile diffraction (quasi-el. scatt. off target)
9856 XSDQE(IE,IQ,NTARG) = SDQE
9857* stat. errors
9858 XETOT(IE,IQ,NTARG) = SQRT(ABS(STOT2-STOT**2)/DBLE(NSTATB-1))
9859 XEELA(IE,IQ,NTARG) = SQRT(ABS(SELA2-SELA**2)/DBLE(NSTATB-1))
9860 XEQEP(IE,IQ,NTARG) = SQRT(ABS(SQEP2-SQEP**2)/DBLE(NSTATB-1))
9861 XEQET(IE,IQ,NTARG) = SQRT(ABS(SQET2-SQET**2)/DBLE(NSTATB-1))
9862 XEQE2(IE,IQ,NTARG) = SQRT(ABS(SQE22-SQE2**2)/DBLE(NSTATB-1))
9863 XEPRO(IE,IQ,NTARG) = SQRT(ABS(SPRO2-SPRO**2)/DBLE(NSTATB-1))
9864 XEDEL(IE,IQ,NTARG) = SQRT(ABS(SDEL2-SDEL**2)/DBLE(NSTATB-1))
9865 XEDQE(IE,IQ,NTARG) = SQRT(ABS(SDQE2-SDQE**2)/DBLE(NSTATB-1))
9866
9867 IF (IJPROJ.EQ.7) THEN
9868 BNORM = XSTOT(IE,IQ,NTARG)-XSELA(IE,IQ,NTARG)
9869 & -XSQEP(IE,IQ,NTARG)
9870 ELSE
9871 BNORM = XSPRO(IE,IQ,NTARG)
9872 ENDIF
9873 DO 19 I=2,NSITEB
9874 BSITE(IE,IQ,NTARG,I) = BPROD(I)/BNORM+BSITE(IE,IQ,NTARG,I-1)
9875 IF ((IE.EQ.1).AND.(IQ.EQ.1))
9876 & BSITE(0,1,NTARG,I) = BPROD(I)/BNORM+BSITE(0,1,NTARG,I-1)
9877 19 CONTINUE
9878
9879* write profile function data into file
9880 IF ((IOGLB.EQ.-1).OR.(IOGLB.EQ.-100)) THEN
9881 WRITE(LDAT,'(5I10,1P,E15.5)')
9882 & IJPROJ,NA,NB,NSTATB,NSITEB,ECMNN(IE)
9883 WRITE(LDAT,'(1P,6E12.5)')
9884 & XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),XSQEP(IE,IQ,NTARG),
9885 & XSQET(IE,IQ,NTARG),XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
9886 WRITE(LDAT,'(1P,6E12.5)')
9887 & XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),XEQEP(IE,IQ,NTARG),
9888 & XEQET(IE,IQ,NTARG),XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
9889 NLINES = INT(DBLE(NSITEB)/7.0D0)
9890 IF (NLINES.GT.0) THEN
9891 DO 20 I=1,NLINES
9892 ISTART = 7*I-6
9893 WRITE(LDAT,'(1P,7E11.4)')
9894 & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
9895 20 CONTINUE
9896 ENDIF
9897 ISTART = 7*NLINES+1
9898 IF (ISTART.LE.NSITEB) THEN
9899 WRITE(LDAT,'(1P,7E11.4)')
9900 & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
9901 ENDIF
9902 ENDIF
9903
9904 100 CONTINUE
9905
9906C IF (ABS(IOGLB).EQ.1) CLOSE(LDAT)
9907
9908 RETURN
9909 END
9910
9911*$ CREATE DT_GETBXS.FOR
9912*COPY DT_GETBXS
9913*
9914*===getbxs=============================================================*
9915*
9916 SUBROUTINE DT_GETBXS(XSFRAC,BLO,BHI,NIDX)
9917
9918************************************************************************
9919* Biasing in impact parameter space. *
9920* XSFRAC = 0 : BLO - minimum impact parameter (input) *
9921* BHI - maximum impact parameter (input) *
9922* XSFRAC - fraction of cross section corresponding *
9923* to impact parameter range (BLO,BHI) *
9924* (output) *
9925* XSFRAC > 0 : XSFRAC - fraction of cross section (input) *
9926* BHI - maximum impact parameter giving requested *
9927* fraction of cross section in impact *
9928* parameter range (0,BMAX) (output) *
9929* This version dated 17.03.00 is written by S. Roesler *
9930************************************************************************
9931
9932 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9933 SAVE
9934 PARAMETER ( LINP = 10 ,
9935 & LOUT = 6 ,
9936 & LDAT = 9 )
9937
9938 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
9939* Glauber formalism: parameters
9940 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
9941 & BMAX(NCOMPX),BSTEP(NCOMPX),
9942 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
9943 & NSITEB,NSTATB
9944
9945 NTARG = ABS(NIDX)
9946 IF (XSFRAC.LE.0.0D0) THEN
9947 ILO = MIN(NSITEB-1,INT(BLO/BSTEP(NTARG)))
9948 IHI = MIN(NSITEB-1,INT(BHI/BSTEP(NTARG)))
9949 IF (ILO.GE.IHI) THEN
9950 XSFRAC = 0.0D0
9951 RETURN
9952 ENDIF
9953 IF (ILO.EQ.NSITEB-1) THEN
9954 FRCLO = BSITE(0,1,NTARG,NSITEB)
9955 ELSE
9956 FRCLO = BSITE(0,1,NTARG,ILO+1)
9957 & +(BLO-ILO*BSTEP(NTARG))/BSTEP(NTARG)
9958 & *(BSITE(0,1,NTARG,ILO+2)-BSITE(0,1,NTARG,ILO+1))
9959 ENDIF
9960 IF (IHI.EQ.NSITEB-1) THEN
9961 FRCHI = BSITE(0,1,NTARG,NSITEB)
9962 ELSE
9963 FRCHI = BSITE(0,1,NTARG,IHI+1)
9964 & +(BHI-IHI*BSTEP(NTARG))/BSTEP(NTARG)
9965 & *(BSITE(0,1,NTARG,IHI+2)-BSITE(0,1,NTARG,IHI+1))
9966 ENDIF
9967 XSFRAC = FRCHI-FRCLO
9968 ELSE
9969 BLO = 0.0D0
9970 BHI = BMAX(NTARG)
9971 DO 1 I=1,NSITEB-1
9972 IF (XSFRAC.LT.BSITE(0,1,NTARG,I+1)) THEN
9973 FAC = (XSFRAC -BSITE(0,1,NTARG,I))/
9974 & (BSITE(0,1,NTARG,I+1)-BSITE(0,1,NTARG,I))
9975 BHI = DBLE(I-1)*BSTEP(NTARG)+BSTEP(NTARG)*FAC
9976 GOTO 2
9977 ENDIF
9978 1 CONTINUE
9979 2 CONTINUE
9980 ENDIF
9981
9982 RETURN
9983 END
9984
9985*$ CREATE DT_CONUCL.FOR
9986*COPY DT_CONUCL
9987*
9988*===conucl=============================================================*
9989*
9990 SUBROUTINE DT_CONUCL(X,N,R,MODE)
9991
9992************************************************************************
9993* Calculation of coordinates of nucleons within nuclei. *
9994* X(3,N) spatial coordinates of nucleons (in fm) (output) *
9995* N / R number of nucleons / radius of nucleus (input) *
9996* MODE = 0 coordinates not sorted *
9997* = 1 coordinates sorted with increasing X(3,i) *
9998* = 2 coordinates sorted with decreasing X(3,i) *
9999* This version dated 26.10.95 is revised by S. Roesler *
10000************************************************************************
10001
10002 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10003 SAVE
10004 PARAMETER ( LINP = 10 ,
10005 & LOUT = 6 ,
10006 & LDAT = 9 )
10007
10008 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10009 & ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10010
10011 PARAMETER (TWOPI = 6.283185307179586454D+00 )
10012
10013 PARAMETER (NSRT=10)
10014 DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10015 DIMENSION X(3,N),XTMP(3,260)
10016
10017 CALL DT_COORDI(XTMP,IDXSRT,ICSRT,N,R)
10018
10019 IF ((MODE.NE.0).AND.(N.GT.4)) THEN
10020 K = 0
10021 DO 1 I=1,NSRT
10022 IF (MODE.EQ.2) THEN
10023 ISRT = NSRT+1-I
10024 ELSE
10025 ISRT = I
10026 ENDIF
10027 K1 = K
10028 DO 2 J=1,ICSRT(ISRT)
10029 K = K+1
10030 X(1,K) = XTMP(1,IDXSRT(ISRT,J))
10031 X(2,K) = XTMP(2,IDXSRT(ISRT,J))
10032 X(3,K) = XTMP(3,IDXSRT(ISRT,J))
10033 2 CONTINUE
10034 IF (ICSRT(ISRT).GT.1) THEN
10035 I0 = K1+1
10036 I1 = K
10037 CALL DT_SORT(X,N,I0,I1,MODE)
10038 ENDIF
10039 1 CONTINUE
10040 ELSEIF ((MODE.NE.0).AND.(N.GE.2).AND.(N.LE.4)) THEN
10041 DO 3 I=1,N
10042 X(1,I) = XTMP(1,I)
10043 X(2,I) = XTMP(2,I)
10044 X(3,I) = XTMP(3,I)
10045 3 CONTINUE
10046 CALL DT_SORT(X,N,1,N,MODE)
10047 ELSE
10048 DO 4 I=1,N
10049 X(1,I) = XTMP(1,I)
10050 X(2,I) = XTMP(2,I)
10051 X(3,I) = XTMP(3,I)
10052 4 CONTINUE
10053 ENDIF
10054
10055 RETURN
10056 END
10057
10058*$ CREATE DT_COORDI.FOR
10059*COPY DT_COORDI
10060*
10061*===coordi=============================================================*
10062*
10063 SUBROUTINE DT_COORDI(X,IDXSRT,ICSRT,N,R)
10064
10065************************************************************************
10066* Calculation of coordinates of nucleons within nuclei. *
10067* X(3,N) spatial coordinates of nucleons (in fm) (output) *
10068* N / R number of nucleons / radius of nucleus (input) *
10069* Based on the original version by Shmakov et al. *
10070* This version dated 26.10.95 is revised by S. Roesler *
10071************************************************************************
10072
10073 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10074 SAVE
10075 PARAMETER ( LINP = 10 ,
10076 & LOUT = 6 ,
10077 & LDAT = 9 )
10078
10079 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10080 & ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10081
10082 PARAMETER (TWOPI = 6.283185307179586454D+00 )
10083
10084 LOGICAL LSTART
10085
10086 PARAMETER (NSRT=10)
10087 DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10088 DIMENSION X(3,260),WD(4),RD(3)
10089
10090 DATA PDIF/0.545D0/,R2MIN/0.16D0/
10091 DATA WD / 0.0D0, 0.178D0, 0.465D0, 1.0D0/
10092 DATA RD /2.09D0, 0.935D0, 0.697D0/
10093
10094 X1SUM = ZERO
10095 X2SUM = ZERO
10096 X3SUM = ZERO
10097
10098 IF (N.EQ.1) THEN
10099 X(1,1) = ZERO
10100 X(2,1) = ZERO
10101 X(3,1) = ZERO
10102 ELSEIF (N.EQ.2) THEN
10103 EPS = DT_RNDM(RD(1))
10104 DO 30 I=1,3
10105 IF ((EPS.GE.WD(I)).AND.(EPS.LE.WD(I+1))) GOTO 40
10106 30 CONTINUE
10107 40 CONTINUE
10108 DO 50 J=1,3
10109 CALL DT_RANNOR(X1,X2)
10110 X(J,1) = RD(I)*X1
10111 X(J,2) = -X(J,1)
10112 50 CONTINUE
10113 ELSEIF ((N.EQ.3).OR.(N.EQ.4)) THEN
10114 SIGMA = R/SQRTWO
10115 LSTART = .TRUE.
10116 CALL DT_RANNOR(X3,X4)
10117 DO 100 I=1,N
10118 CALL DT_RANNOR(X1,X2)
10119 X(1,I) = SIGMA*X1
10120 X(2,I) = SIGMA*X2
10121 IF (LSTART) GOTO 80
10122 X(3,I) = SIGMA*X4
10123 CALL DT_RANNOR(X3,X4)
10124 GOTO 90
10125 80 CONTINUE
10126 X(3,I) = SIGMA*X3
10127 90 CONTINUE
10128 LSTART = .NOT.LSTART
10129 X1SUM = X1SUM+X(1,I)
10130 X2SUM = X2SUM+X(2,I)
10131 X3SUM = X3SUM+X(3,I)
10132 100 CONTINUE
10133 X1SUM = X1SUM/DBLE(N)
10134 X2SUM = X2SUM/DBLE(N)
10135 X3SUM = X3SUM/DBLE(N)
10136 DO 101 I=1,N
10137 X(1,I) = X(1,I)-X1SUM
10138 X(2,I) = X(2,I)-X2SUM
10139 X(3,I) = X(3,I)-X3SUM
10140 101 CONTINUE
10141 ELSE
10142
10143* maximum nuclear radius for coordinate sampling
10144 RMAX = R+4.605D0*PDIF
10145
10146* initialize pre-sorting
10147 DO 121 I=1,NSRT
10148 ICSRT(I) = 0
10149 121 CONTINUE
10150 DR = TWO*RMAX/DBLE(NSRT)
10151
10152* sample coordinates for N nucleons
10153 DO 140 I=1,N
10154 120 CONTINUE
10155 RAD = RMAX*(DT_RNDM(DR))**ONETHI
10156 F = DT_DENSIT(N,RAD,R)
10157 IF (DT_RNDM(RAD).GT.F) GOTO 120
10158* theta, phi uniformly distributed
10159 CT = ONE-TWO*DT_RNDM(F)
10160 ST = SQRT((ONE-CT)*(ONE+CT))
10161 CALL DT_DSFECF(SFE,CFE)
10162 X(1,I) = RAD*ST*CFE
10163 X(2,I) = RAD*ST*SFE
10164 X(3,I) = RAD*CT
10165* ensure that distance between two nucleons is greater than R2MIN
10166 IF (I.LT.2) GOTO 122
10167 I1 = I-1
10168 DO 130 I2=1,I1
10169 DIST2 = (X(1,I)-X(1,I2))**2+(X(2,I)-X(2,I2))**2+
10170 & (X(3,I)-X(3,I2))**2
10171 IF (DIST2.LE.R2MIN) GOTO 120
10172 130 CONTINUE
10173 122 CONTINUE
10174* save index according to z-bin
10175 IDXZ = INT( (X(3,I)+RMAX)/DR )+1
10176 ICSRT(IDXZ) = ICSRT(IDXZ)+1
10177 IDXSRT(IDXZ,ICSRT(IDXZ)) = I
10178 X1SUM = X1SUM+X(1,I)
10179 X2SUM = X2SUM+X(2,I)
10180 X3SUM = X3SUM+X(3,I)
10181 140 CONTINUE
10182 X1SUM = X1SUM/DBLE(N)
10183 X2SUM = X2SUM/DBLE(N)
10184 X3SUM = X3SUM/DBLE(N)
10185 DO 141 I=1,N
10186 X(1,I) = X(1,I)-X1SUM
10187 X(2,I) = X(2,I)-X2SUM
10188 X(3,I) = X(3,I)-X3SUM
10189 141 CONTINUE
10190
10191 ENDIF
10192
10193 RETURN
10194 END
10195
10196*$ CREATE DT_DENSIT.FOR
10197*COPY DT_DENSIT
10198*
10199*===densit=============================================================*
10200*
10201 DOUBLE PRECISION FUNCTION DT_DENSIT(NA,R,RA)
10202
10203 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10204 SAVE
10205
10206 PARAMETER ( LINP = 10 ,
10207 & LOUT = 6 ,
10208 & LDAT = 9 )
10209 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10210 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
10211 & PI = TWOPI/TWO)
10212
10213 DIMENSION R0(18),FNORM(18)
10214 DATA R0 / ZERO, ZERO, ZERO, ZERO, 2.12D0,
10215 & 2.56D0, 2.41D0, 2.46D0, 2.52D0, 2.45D0,
10216 & 2.37D0, 2.46D0, 2.44D0, 2.54D0, 2.58D0,
10217 & 2.72D0, 2.66D0, 2.79D0/
10218 DATA FNORM /.1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10219 & .1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10220 & .1012D+01,.1039D+01,.1075D+01,.1118D+01,.1164D+01,
10221 & .1214D+01,.1265D+01,.1318D+01/
10222 DATA PDIF /0.545D0/
10223
10224 DT_DENSIT = ZERO
10225* shell model
10226 IF (NA.LE.4) THEN
10227 STOP 'DT_DENSIT-0'
10228 ELSEIF ((NA.GT.4).AND.(NA.LE.18)) THEN
10229 R1 = R0(NA)/SQRT(2.5D0-4.0D0/DBLE(NA))
10230 DT_DENSIT = (ONE+(DBLE(NA)-4.0D0)/6.0D0*(R/R1)**2)
10231 & *EXP(-(R/R1)**2)/FNORM(NA)
10232* Woods-Saxon
10233 ELSEIF (NA.GT.18) THEN
10234 DT_DENSIT = ONE/(ONE+EXP((R-RA)/PDIF))
10235 ENDIF
10236
10237 RETURN
10238 END
10239
10240*$ CREATE DT_RNCLUS.FOR
10241*COPY DT_RNCLUS
10242*
10243*===rnclus=============================================================*
10244*
10245 DOUBLE PRECISION FUNCTION DT_RNCLUS(N)
10246
10247************************************************************************
10248* Nuclear radius for nucleus with mass number N. *
10249* This version dated 26.9.00 is written by S. Roesler *
10250************************************************************************
10251
10252 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10253 SAVE
10254
10255 PARAMETER (ONE=1.0D0,THREE=3.0D0,ONETHI=ONE/THREE)
10256
10257* nucleon radius
10258 PARAMETER (RNUCLE = 1.12D0)
10259
10260* nuclear radii for selected nuclei
10261 DIMENSION RADNUC(18)
10262 DATA RADNUC / 8*0.0D0,2.52D0,2.45D0,2.37D0,2.45D0,2.44D0,2.55D0,
10263 & 2.58D0,2.71D0,2.66D0,2.71D0/
10264
10265 IF (N.LE.18) THEN
10266 IF (RADNUC(N).GT.0.0D0) THEN
10267 DT_RNCLUS = RADNUC(N)
10268 ELSE
10269 DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10270 ENDIF
10271 ELSE
10272 DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10273 ENDIF
10274
10275 RETURN
10276 END
10277
10278*$ CREATE DT_DENTST.FOR
10279*COPY DT_DENTST
10280*
10281*===dentst=============================================================*
10282*
10283C PROGRAM DT_DENTST
10284 SUBROUTINE DT_DENTST
10285
10286 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10287 SAVE
10288
10289 OPEN(40,FILE='dentst.out',STATUS='UNKNOWN')
10290 OPEN(41,FILE='denmax.out',STATUS='UNKNOWN')
10291
10292 RMIN = 0.0D0
10293 RMAX = 8.0D0
10294 NBINS = 500.0D0
10295 DR = (RMAX-RMIN)/DBLE(NBINS)
10296 DO 1 IA=5,18
10297 FMAX = 0.0D0
10298 DO 2 IR=1,NBINS+1
10299 R = RMIN+DBLE(IR-1)*DR
10300 F = DT_DENSIT(IA,R,R)
10301 IF (F.GT.FMAX) FMAX = F
10302 WRITE(40,'(1X,I3,2E15.5)') IA,R,F
10303 2 CONTINUE
10304 WRITE(41,'(1X,I3,E15.5)') IA,FMAX
10305 1 CONTINUE
10306
10307 CLOSE(40)
10308 CLOSE(41)
10309
10310 END
10311
10312*$ CREATE DT_SHMAKI.FOR
10313*COPY DT_SHMAKI
10314*
10315*===shmaki=============================================================*
10316*
10317 SUBROUTINE DT_SHMAKI(NA,NCA,NB,NCB,IJP,PPN,MODE)
10318
10319************************************************************************
10320* Initialisation of Glauber formalism. This subroutine has to be *
10321* called once (in case of target emulsions as often as many different *
10322* target nuclei are considered) before events are sampled. *
10323* NA / NCA mass number/charge of projectile nucleus *
10324* NB / NCB mass number/charge of target nucleus *
10325* IJP identity of projectile (hadrons/leptons/photons) *
10326* PPN projectile momentum (for projectile nuclei: *
10327* momentum per nucleon) in target rest system *
10328* MODE = 0 Glauber formalism invoked *
10329* = 1 fitted results are loaded from data-file *
10330* = 99 NTARG is forced to be 1 *
10331* (used in connection with GLAUBERI-card only) *
10332* This version dated 22.03.96 is based on the original SHMAKI-routine *
10333* and revised by S. Roesler. *
10334************************************************************************
10335
10336 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10337 SAVE
10338 PARAMETER ( LINP = 10 ,
10339 & LOUT = 6 ,
10340 & LDAT = 9 )
10341 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
10342 & THREE=3.0D0)
10343
10344 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10345* Glauber formalism: parameters
10346 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10347 & BMAX(NCOMPX),BSTEP(NCOMPX),
10348 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10349 & NSITEB,NSTATB
10350* Lorentz-parameters of the current interaction
10351 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10352 & UMO,PPCM,EPROJ,PPROJ
10353* properties of photon/lepton projectiles
10354 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10355* kinematical cuts for lepton-nucleus interactions
10356 COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
10357 & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
10358* Glauber formalism: cross sections
10359 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10360 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10361 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10362 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10363 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10364 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10365 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10366 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10367 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10368 & BSLOPE,NEBINI,NQBINI
10369* cuts for variable energy runs
10370 COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
10371* nucleon-nucleon event-generator
10372 CHARACTER*8 CMODEL
10373 LOGICAL LPHOIN
10374 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10375* Glauber formalism: flags and parameters for statistics
10376 LOGICAL LPROD
10377 CHARACTER*8 CGLB
10378 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10379
10380 DATA NTARG,ICOUT,IVEOUT /0,0,0/
10381
10382C CALL DT_HISHAD
10383C STOP
10384
10385 NTARG = NTARG+1
10386 IF (MODE.EQ.99) NTARG = 1
10387 NIDX = -NTARG
10388 IF (MODE.EQ.-1) NIDX = NTARG
10389
10390 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) ICOUT = ICOUT+1
10391 IF (ICOUT.EQ.1) WRITE(LOUT,1000)
10392 1000 FORMAT(//,1X,'SHMAKI: Glauber formalism (Shmakov et. al) -',
10393 & ' initialization',/,12X,'--------------------------',
10394 & '-------------------------',/)
10395
10396 IF (MODE.EQ.2) THEN
10397 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10398 CALL DT_SHFAST(MODE,PPN,IBACK)
10399 STOP ' Glauber pre-initialization done'
10400 ENDIF
10401 IF (MODE.EQ.1) THEN
10402 CALL DT_PROFBI(NA,NB,PPN,NTARG)
10403 ELSE
10404 IBACK = 1
10405 IF (MODE.EQ.3) CALL DT_SHFAST(MODE,PPN,IBACK)
10406 IF (IBACK.EQ.1) THEN
10407* lepton-nucleus (variable energy runs)
10408 IF ((IJP.EQ. 3).OR.(IJP.EQ. 4).OR.
10409 & (IJP.EQ.10).OR.(IJP.EQ.11)) THEN
10410 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10411 & WRITE(LOUT,1002) NB,NCB
10412 1002 FORMAT(1X,'variable energy run: projectile-id: 7',
10413 & ' target A/Z: ',I3,' /',I3,/,/,8X,
10414 & 'E_cm (GeV) Q^2 (GeV^2)',
10415 & ' Sigma_tot (mb) Sigma_in (mb)',/,7X,
10416 & '--------------------------------',
10417 & '------------------------------')
10418 AECMLO = LOG10(MIN(UMO,ECMLI))
10419 AECMHI = LOG10(MIN(UMO,ECMHI))
10420 IESTEP = NEB-1
10421 DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
10422 IF (AECMLO.EQ.AECMHI) IESTEP = 0
10423 DO 1 I=1,IESTEP+1
10424 ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10425 IF (Q2HI.GT.0.1D0) THEN
10426 IF (Q2LI.LT.0.01D0) THEN
10427 CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10428 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10429 & WRITE(LOUT,1003)
10430 & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10431 Q2LI = 0.01D0
10432 IBIN = 2
10433 ELSE
10434 IBIN = 1
10435 ENDIF
10436 IQSTEP = NQB-IBIN
10437 AQ2LO = LOG10(Q2LI)
10438 AQ2HI = LOG10(Q2HI)
10439 DAQ2 = (AQ2HI-AQ2LO)/MAX(DBLE(IQSTEP),ONE)
10440 DO 2 J=IBIN,IQSTEP+IBIN
10441 Q2 = 10.0D0**(AQ2LO+DBLE(J-IBIN)*DAQ2)
10442 CALL DT_XSGLAU(NA,NB,7,ZERO,Q2,ECM,I,J,NIDX)
10443 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10444 & WRITE(LOUT,1003) ECMNN(I),
10445 & Q2G(J),XSTOT(I,J,NTARG),XSPRO(I,J,NTARG)
10446 2 CONTINUE
10447 ELSE
10448 CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10449 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10450 & WRITE(LOUT,1003)
10451 & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10452 ENDIF
10453 1003 FORMAT(9X,F6.1,9X,F6.2,8X,F8.3,11X,F8.3)
10454 1 CONTINUE
10455 IVEOUT = 1
10456 ELSE
10457* hadron/photon/nucleus-nucleus
10458 IF ((ABS(VAREHI).GT.ZERO).AND.
10459 & (ABS(VAREHI).GT.ABS(VARELO))) THEN
10460 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) THEN
10461 WRITE(LOUT,1004) NA,NB,NCB
10462 1004 FORMAT(1X,'variable energy run: projectile-id:',
10463 & I3,' target A/Z: ',I3,' /',I3,/)
10464 WRITE(LOUT,1005)
10465 1005 FORMAT(' E_cm (GeV) E_Lab (GeV) sig_tot^pp (mb)'
10466 & ,' Sigma_tot (mb) Sigma_prod (mb)',/,
10467 & ' -------------------------------------',
10468 & '--------------------------------------')
10469 ENDIF
10470 AECMLO = LOG10(VARCLO)
10471 AECMHI = LOG10(VARCHI)
10472 IESTEP = NEB-1
10473 DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
10474 IF (AECMLO.EQ.AECMHI) IESTEP = 0
10475 DO 3 I=1,IESTEP+1
10476 ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10477 AMP = 0.938D0
10478 AMT = 0.938D0
10479 AMP2 = AMP**2
10480 AMT2 = AMT**2
10481 ELAB = (ECM**2-AMP2-AMT2)/(TWO*AMT)
10482 PLAB = SQRT((ELAB+AMP)*(ELAB-AMP))
10483 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,ECM,I,1,NIDX)
10484 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10485 & WRITE(LOUT,1006)
10486 & ECM,PLAB,SIGSH,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10487 1006 FORMAT(1X,F9.1,1X,E11.3,1X,F12.2,8X,F10.3,8X,F8.3)
10488 3 CONTINUE
10489 IVEOUT = 1
10490 ELSE
10491 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10492 ENDIF
10493 ENDIF
10494 ENDIF
10495 ENDIF
10496
10497 IF ((ICOUT.LT.15).AND.(IVEOUT.EQ.0).AND.(MCGENE.NE.4).AND.
10498 & (IOGLB.NE.100)) THEN
10499 WRITE(LOUT,1001) NA,NCA,NB,NCB,ECMNN(1),SIGSH*10.0D0,ROSH,
10500 & BSLOPE,NSITEB,NSTATB,XSPRO(1,1,NTARG)
10501 1001 FORMAT(38X,'projectile',
10502 & ' target',/,1X,'Mass number / charge',
10503 & 17X,I3,' /',I3,6X,I3,' /',I3,/,/,1X,
10504 & 'Nucleon-nucleon c.m. energy',9X,F10.2,' GeV',/,/,1X,
10505 & 'Parameters of elastic scattering amplitude:',/,5X,
10506 & 'sigma =',F7.2,' mb',6X,'rho = ',F9.4,6X,'slope = ',
10507 & F4.1,' GeV^-2',/,/,1X,'Number of b-steps',4X,I3,8X,
10508 & 'statistics at each b-step',4X,I5,/,/,1X,
10509 & 'Prod. cross section ',5X,F10.4,' mb',/)
10510 ENDIF
10511
10512 RETURN
10513 END
10514
10515*$ CREATE DT_PROFBI.FOR
10516*COPY DT_PROFBI
10517*
10518*===profbi=============================================================*
10519*
10520 SUBROUTINE DT_PROFBI(NA,NB,PPN,NTARG)
10521
10522************************************************************************
10523* Integral over profile function (to be used for impact-parameter *
10524* sampling during event generation). *
10525* Fitted results are used. *
10526* NA / NB mass numbers of proj./target nuclei *
10527* PPN projectile momentum (for projectile nuclei: *
10528* momentum per nucleon) in target rest system *
10529* NTARG index of target material (i.e. kind of nucleus) *
10530* This version dated 31.05.95 is revised by S. Roesler *
10531************************************************************************
10532
10533 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10534 SAVE
10535 PARAMETER ( LINP = 10 ,
10536 & LOUT = 6 ,
10537 & LDAT = 9 )
454792a9 10538CPH SAVE
9aaba0d6 10539
10540 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
10541
10542 LOGICAL LSTART
10543 CHARACTER CNAME*80
10544
10545 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10546* Glauber formalism: parameters
10547 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10548 & BMAX(NCOMPX),BSTEP(NCOMPX),
10549 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10550 & NSITEB,NSTATB
10551* Glauber formalism: cross sections
10552 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10553 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10554 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10555 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10556 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10557 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10558 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10559 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10560 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10561 & BSLOPE,NEBINI,NQBINI
10562
10563 PARAMETER (NGLMAX=8000)
10564 DIMENSION NGLIT(NGLMAX),NGLIP(NGLMAX),GLAPPN(NGLMAX),
10565 & GLASIG(NGLMAX),GLAFIT(5,NGLMAX)
10566
10567 DATA LSTART /.TRUE./
10568
10569 IF (LSTART) THEN
10570* read fit-parameters from file
10571 OPEN(47,FILE='inpdata/glpara.dat',STATUS='UNKNOWN')
10572 I = 0
10573 1 CONTINUE
10574 READ(47,'(A80)') CNAME
10575 IF (CNAME.EQ.'STOP') GOTO 2
10576 I = I+1
10577 READ(CNAME,*) NGLIP(I),NGLIT(I),GLAPPN(I),GLASIG(I),
10578 & GLAFIT(1,I),GLAFIT(2,I),GLAFIT(3,I),
10579 & GLAFIT(4,I),GLAFIT(5,I)
10580 IF (I+1.GT.NGLMAX) THEN
10581 WRITE(LOUT,1000)
10582 1000 FORMAT(1X,'PROFBI: warning! array size exceeded - ',
10583 & 'program stopped')
10584 STOP
10585 ENDIF
10586 GOTO 1
10587 2 CONTINUE
10588 NGLPAR = I
10589 LSTART = .FALSE.
10590 ENDIF
10591
10592 NNA = NA
10593 NNB = NB
10594 IF (NA.GT.NB) THEN
10595 NNA = NB
10596 NNB = NA
10597 ENDIF
10598 IDXGLA = 0
10599 DO 3 J=1,NGLPAR
10600 IF ((NNB.LT.NGLIT(J)).OR.(J.EQ.NGLPAR)) THEN
10601 IF (NNB.NE.NGLIT(J-1)) NNB = NGLIT(J-1)
10602 DO 4 K=1,J-1
10603 IPOINT = J-K
10604 IF (J.EQ.NGLPAR) IPOINT = J+1-K
10605 IF ((NNA.GT.NGLIP(IPOINT)).OR.
10606 & (NNB.NE.NGLIT(IPOINT)).OR.(IPOINT.EQ.1)) THEN
10607 IF (IPOINT.EQ.1) IPOINT = 0
10608 NATMP = NGLIP(IPOINT+1)
10609 IF (PPN.LT.GLAPPN(IPOINT+1)) THEN
10610 IDXGLA = IPOINT+1
10611 GOTO 6
10612 ELSE
10613 J1BEG = IPOINT+1
10614 J1END = J
10615C IF (J.EQ.NGLPAR) THEN
10616C J1BEG = IPOINT
10617C J1END = J
10618C ENDIF
10619 DO 5 J1=J1BEG,J1END
10620 IF (NGLIP(J1).EQ.NATMP) THEN
10621 IF (PPN.LT.GLAPPN(J1)) THEN
10622 IDXGLA = J1
10623 GOTO 6
10624 ENDIF
10625 ELSE
10626 IDXGLA = J1-1
10627 GOTO 6
10628 ENDIF
10629 5 CONTINUE
10630 IF ((J.EQ.NGLPAR).AND.(PPN.GT.GLAPPN(NGLPAR)))
10631 & IDXGLA = NGLPAR
10632 ENDIF
10633 ENDIF
10634 4 CONTINUE
10635 ENDIF
10636 3 CONTINUE
10637
10638 6 CONTINUE
10639 IF (IDXGLA.EQ.0) THEN
10640 WRITE(LOUT,1001) NNA,NNB,PPN
10641 1001 FORMAT(1X,'PROFBI: configuration (NA,NB,PPN = ',
10642 & 2I4,F6.0,') not found ')
10643 STOP
10644 ENDIF
10645
10646* no interpolation yet available
10647 XSPRO(1,1,NTARG) = GLASIG(IDXGLA)
10648
10649 BSITE(1,1,NTARG,1) = ZERO
10650 DO 10 I=2,NSITEB
10651 XX = DBLE(I)
10652 POLY = GLAFIT(1,IDXGLA)+GLAFIT(2,IDXGLA)*XX+
10653 & GLAFIT(3,IDXGLA)*XX**2+GLAFIT(4,IDXGLA)*XX**3+
10654 & GLAFIT(5,IDXGLA)*XX**4
10655 IF (ABS(POLY).GT.35.0D0) POLY = SIGN(35.0D0,POLY)
10656 BSITE(1,1,NTARG,I) = (1.0D0-EXP(-POLY))
10657 IF (BSITE(1,1,NTARG,I).LT.ZERO) BSITE(1,1,NTARG,I) = ZERO
10658 10 CONTINUE
10659
10660 RETURN
10661 END
10662
10663*$ CREATE DT_GLAUBE.FOR
10664*COPY DT_GLAUBE
10665*
10666*===glaube=============================================================*
10667*
10668 SUBROUTINE DT_GLAUBE(NA,NB,IJPROJ,B,INTT,INTA,INTB,JS,JT,NIDX)
10669
10670************************************************************************
10671* Calculation of configuartion of interacting nucleons for one event. *
10672* NB / NB mass numbers of proj./target nuclei (input) *
10673* B impact parameter (output) *
10674* INTT total number of wounded nucleons " *
10675* INTA / INTB number of wounded nucleons in proj. / target " *
10676* JS / JT(i) number of collisions proj. / target nucleon i is *
10677* involved (output) *
10678* NIDX index of projectile/target material (input) *
10679* = -2 call within FLUKA transport calculation *
10680* This is an update of the original routine SHMAKO by J.Ranft/HJM *
10681* This version dated 22.03.96 is revised by S. Roesler *
10682* *
10683* Last change 27.12.2006 by S. Roesler. *
10684************************************************************************
10685
10686 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10687 SAVE
10688 PARAMETER ( LINP = 10 ,
10689 & LOUT = 6 ,
10690 & LDAT = 9 )
10691 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
10692 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
10693
10694 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10695 PARAMETER ( MAXNCL = 260,
10696 & MAXVQU = MAXNCL,
10697 & MAXSQU = 20*MAXVQU,
10698 & MAXINT = MAXVQU+MAXSQU)
10699* Glauber formalism: parameters
10700 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10701 & BMAX(NCOMPX),BSTEP(NCOMPX),
10702 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10703 & NSITEB,NSTATB
10704* Glauber formalism: cross sections
10705 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10706 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10707 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10708 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10709 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10710 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10711 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10712 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10713 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10714 & BSLOPE,NEBINI,NQBINI
10715* Lorentz-parameters of the current interaction
10716 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10717 & UMO,PPCM,EPROJ,PPROJ
10718* properties of photon/lepton projectiles
10719 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10720* Glauber formalism: collision properties
10721 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
e3f546f5 10722 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
10723 & NCP,NCT
9aaba0d6 10724* Glauber formalism: flags and parameters for statistics
10725 LOGICAL LPROD
10726 CHARACTER*8 CGLB
10727 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10728
10729 DIMENSION JS(MAXNCL),JT(MAXNCL)
10730
10731 NTARG = ABS(NIDX)
10732
10733* get actual energy from /DTLTRA/
10734 ECMNOW = UMO
10735 Q2 = VIRT
10736*
10737* new patch for pre-initialized variable projectile/target/energy runs,
10738* bypassed for use within FLUKA (Nidx=-2)
10739 IF (IOGLB.EQ.100) THEN
10740 IF (NIDX.NE.-2) CALL DT_GLBSET(IJPROJ,NA,NB,EPROJ,1)
10741*
10742* variable energy run, interpolate profile function
10743 ELSE
10744 I1 = 1
10745 I2 = 1
10746 RATE = ONE
10747 IF (NEBINI.GT.1) THEN
10748 IF (ECMNOW.GE.ECMNN(NEBINI)) THEN
10749 I1 = NEBINI
10750 I2 = NEBINI
10751 RATE = ONE
10752 ELSEIF (ECMNOW.GT.ECMNN(1)) THEN
10753 DO 1 I=2,NEBINI
10754 IF (ECMNOW.LT.ECMNN(I)) THEN
10755 I1 = I-1
10756 I2 = I
10757 RATE = (ECMNOW-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
10758 GOTO 2
10759 ENDIF
10760 1 CONTINUE
10761 2 CONTINUE
10762 ENDIF
10763 ENDIF
10764 J1 = 1
10765 J2 = 1
10766 RATQ = ONE
10767 IF (NQBINI.GT.1) THEN
10768 IF (Q2.GE.Q2G(NQBINI)) THEN
10769 J1 = NQBINI
10770 J2 = NQBINI
10771 RATQ = ONE
10772 ELSEIF (Q2.GT.Q2G(1)) THEN
10773 DO 3 I=2,NQBINI
10774 IF (Q2.LT.Q2G(I)) THEN
10775 J1 = I-1
10776 J2 = I
10777 RATQ = LOG10( Q2/MAX(Q2G(J1),TINY14))/
10778 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
10779C RATQ = (Q2-Q2G(J1))/(Q2G(J2)-Q2G(J1))
10780 GOTO 4
10781 ENDIF
10782 3 CONTINUE
10783 4 CONTINUE
10784 ENDIF
10785 ENDIF
10786
10787 DO 5 I=1,KSITEB
10788 BSITE(0,1,NTARG,I) = BSITE(I1,J1,NTARG,I)+
10789 & RATE*(BSITE(I2,J1,NTARG,I)-BSITE(I1,J1,NTARG,I))+
10790 & RATQ*(BSITE(I1,J2,NTARG,I)-BSITE(I1,J1,NTARG,I))+
10791 & RATE*RATQ*(BSITE(I2,J2,NTARG,I)-BSITE(I1,J2,NTARG,I)+
10792 & BSITE(I1,J1,NTARG,I)-BSITE(I2,J1,NTARG,I))
10793 5 CONTINUE
10794 ENDIF
10795
10796 CALL DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,INTT,INTA,INTB,IDIREC,NIDX)
10797 IF (NIDX.LE.-1) THEN
10798 RPROJ = RASH(1)
10799 RTARG = RBSH(NTARG)
10800 ELSE
10801 RPROJ = RASH(NTARG)
10802 RTARG = RBSH(1)
10803 ENDIF
10804
10805 RETURN
10806 END
10807
10808*$ CREATE DT_DIAGR.FOR
10809*COPY DT_DIAGR
10810*
10811*===diagr==============================================================*
10812*
10813 SUBROUTINE DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,JNT,INTA,INTB,IDIREC,
10814 & NIDX)
10815
10816************************************************************************
10817* Based on the original version by Shmakov et al. *
10818* This version dated 21.04.95 is revised by S. Roesler *
10819************************************************************************
10820
10821 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10822 SAVE
10823 PARAMETER ( LINP = 10 ,
10824 & LOUT = 6 ,
10825 & LDAT = 9 )
10826 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10827 PARAMETER (TWOPI = 6.283185307179586454D+00,
10828 & PI = TWOPI/TWO,
10829 & GEV2MB = 0.38938D0,
10830 & GEV2FM = 0.1972D0,
10831 & ALPHEM = ONE/137.0D0,
10832* proton mass
10833 & AMP = 0.938D0,
10834 & AMP2 = AMP**2,
10835* rho0 mass
10836 & AMRHO0 = 0.77D0)
10837
10838 COMPLEX*16 C,CA,CI
10839 PARAMETER ( MAXNCL = 260,
10840 & MAXVQU = MAXNCL,
10841 & MAXSQU = 20*MAXVQU,
10842 & MAXINT = MAXVQU+MAXSQU)
10843* particle properties (BAMJET index convention)
10844 CHARACTER*8 ANAME
10845 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
10846 & IICH(210),IIBAR(210),K1(210),K2(210)
10847 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10848* emulsion treatment
10849 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
10850 & NCOMPO,IEMUL
10851* Glauber formalism: parameters
10852 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10853 & BMAX(NCOMPX),BSTEP(NCOMPX),
10854 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10855 & NSITEB,NSTATB
10856* Glauber formalism: cross sections
10857 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10858 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10859 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10860 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10861 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10862 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10863 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10864 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10865 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10866 & BSLOPE,NEBINI,NQBINI
10867* VDM parameter for photon-nucleus interactions
10868 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
10869* nucleon-nucleon event-generator
10870 CHARACTER*8 CMODEL
10871 LOGICAL LPHOIN
10872 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10873**PHOJET105a
10874C COMMON /CUTOFF/ PTCUT(4),CUTMU(4),FPS(4),FPH(4),PSOMIN,XSOMIN
10875**PHOJET112
10876C obsolete cut-off information
10877 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
10878 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
10879**
10880* coordinates of nucleons
10881 COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
10882* interface between Glauber formalism and DPM
10883 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
10884 & INTER1(MAXINT),INTER2(MAXINT)
10885* statistics: Glauber-formalism
10886 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
10887* n-n cross section fluctuations
10888 PARAMETER (NBINS = 1000)
10889 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
10890
10891 DIMENSION JS(MAXNCL),JT(MAXNCL),
10892 & JS0(MAXNCL),JT0(MAXNCL,MAXNCL),
10893 & JI1(MAXNCL,MAXNCL),JI2(MAXNCL,MAXNCL),JNT0(MAXNCL)
10894 DIMENSION NWA(0:210),NWB(0:210)
10895
10896 LOGICAL LFIRST
10897 DATA LFIRST /.TRUE./
10898
10899 DATA NTARGO,ICNT /0,0/
10900
10901 NTARG = ABS(NIDX)
10902
10903 IF (LFIRST) THEN
10904 LFIRST = .FALSE.
10905 IF (NCOMPO.EQ.0) THEN
10906 NCALL = 0
10907 NWAMAX = NA
10908 NWBMAX = NB
10909 DO 17 I=0,210
10910 NWA(I) = 0
10911 NWB(I) = 0
10912 17 CONTINUE
10913 ENDIF
10914 ENDIF
10915 IF (NTARG.EQ.-1) THEN
10916 IF (NCOMPO.EQ.0) THEN
10917 WRITE(LOUT,*) ' DIAGR: distribution of wounded nucleons'
10918 WRITE(LOUT,'(8X,A,3I7)') 'NCALL,NWAMAX,NWBMAX = ',
10919 & NCALL,NWAMAX,NWBMAX
10920 DO 18 I=1,MAX(NWAMAX,NWBMAX)
10921 WRITE(LOUT,'(8X,2I7,E12.4,I7,E12.4)')
10922 & I,NWA(I),DBLE(NWA(I))/DBLE(NCALL),
10923 & NWB(I),DBLE(NWB(I))/DBLE(NCALL)
10924 18 CONTINUE
10925 ENDIF
10926 RETURN
10927 ENDIF
10928
10929 DCOH = 1.0D10
10930 IPNT = 0
10931
10932 SQ2 = Q2
10933 IF (SQ2.LE.ZERO) SQ2 = 0.0001D0
10934 S = ECMNOW**2
10935 X = SQ2/(S+SQ2-AMP2)
10936 XNU = (S+SQ2-AMP2)/(TWO*AMP)
10937* photon projectiles: recalculate photon-nucleon amplitude
10938 IF (IJPROJ.EQ.7) THEN
10939 15 CONTINUE
10940* VDM assumption: mass of V-meson
10941 AMV2 = DT_SAM2(SQ2,ECMNOW)
10942 AMV = SQRT(AMV2)
10943 IF (AMV.GT.2.0D0*PTCUT(1)) GOTO 15
10944* check for pointlike interaction
10945 CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,1)
10946**sr 27.10.
10947C SIGSH = DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
10948 SIGSH = (ONE-RPNT)*DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
10949**
10950 ROSH = 0.1D0
10951 BSLOPE = 2.0D0*(2.0D0+AMRHO0**2/(AMV2+SQ2)
10952 & +0.25D0*LOG(S/(AMV2+SQ2)))
10953* coherence length
10954 IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+SQ2)*GEV2FM
10955 ELSEIF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
10956 IF (MCGENE.EQ.2) THEN
10957 ZERO1 = ZERO
10958 CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SDUM1,SDUM2,SDUM3,
10959 & BSLOPE,0)
10960 ELSE
10961 BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
10962 ENDIF
10963 IF (ECMNOW.LE.3.0D0) THEN
10964 ROSH = -0.43D0
10965 ELSEIF ((ECMNOW.GT.3.0D0).AND.(ECMNOW.LE.50.D0)) THEN
10966 ROSH = -0.63D0+0.175D0*LOG(ECMNOW)
10967 ELSEIF (ECMNOW.GT.50.0D0) THEN
10968 ROSH = 0.1D0
10969 ENDIF
10970 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
10971 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
10972 IF (MCGENE.EQ.2) THEN
10973 ZERO1 = ZERO
10974 CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SIGSH,SDUM2,SDUM3,
10975 & BDUM,0)
10976 SIGSH = SIGSH/10.0D0
10977 ELSE
10978C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
10979 DUMZER = ZERO
10980 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
10981 SIGSH = SIGSH/10.0D0
10982 ENDIF
10983 ELSE
10984 BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
10985 ROSH = 0.01D0
10986 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
10987 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
10988C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
10989 DUMZER = ZERO
10990 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
10991 SIGSH = SIGSH/10.0D0
10992 ENDIF
10993 GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
10994 GAM = GSH
10995 RCA = GAM*SIGSH/TWOPI
10996 FCA = -ROSH*RCA
10997 CA = DCMPLX(RCA,FCA)
10998 CI = DCMPLX(ONE,ZERO)
10999
11000 16 CONTINUE
11001* impact parameter
11002 IF (MCGENE.NE.3) CALL DT_MODB(B,NIDX)
11003
11004 NTRY = 0
11005 3 CONTINUE
11006 NTRY = NTRY+1
11007* initializations
11008 JNT = 0
11009 DO 1 I=1,NA
11010 JS(I) = 0
11011 1 CONTINUE
11012 DO 2 I=1,NB
11013 JT(I) = 0
11014 2 CONTINUE
11015 IF (IJPROJ.EQ.7) THEN
11016 DO 8 I=1,MAXNCL
11017 JS0(I) = 0
11018 JNT0(I)= 0
11019 DO 9 J=1,NB
11020 JT0(I,J) = 0
11021 9 CONTINUE
11022 8 CONTINUE
11023 ENDIF
11024
11025* nucleon configuration
11026C IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,5).EQ.0)) THEN
11027 IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,1).EQ.0)) THEN
11028C CALL DT_CONUCL(PKOO,NA,RASH,2)
11029C CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),1)
11030 IF (NIDX.LE.-1) THEN
11031 CALL DT_CONUCL(PKOO,NA,RASH(1),0)
11032 CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),0)
11033 ELSE
11034 CALL DT_CONUCL(PKOO,NA,RASH(NTARG),0)
11035 CALL DT_CONUCL(TKOO,NB,RBSH(1),0)
11036 ENDIF
11037 NTARGO = NTARG
11038 ENDIF
11039 ICNT = ICNT+1
11040
11041* LEPTO: pick out one struck nucleon
11042 IF (MCGENE.EQ.3) THEN
11043 JNT = 1
11044 JS(1) = 1
11045 IDX = INT(DT_RNDM(X)*NB)+1
11046 JT(IDX) = 1
11047 B = ZERO
11048 GOTO 19
11049 ENDIF
11050
11051 DO 4 INA=1,NA
11052* cross section fluctuations
11053 AFLUC = ONE
11054 IF (IFLUCT.EQ.1) THEN
11055 IFLUK = INT((DT_RNDM(X)+0.001D0)*1000.0D0)
11056 AFLUC = FLUIXX(IFLUK)
11057 ENDIF
11058 KK1 = 1
11059 KINT = 1
11060 DO 5 INB=1,NB
11061* photon-projectile: check for supression by coherence length
11062 IF (IJPROJ.EQ.7) THEN
11063 IF (ABS(TKOO(3,INB)-TKOO(3,KK1)).GT.DCOH) THEN
11064 KK1 = INB
11065 KINT = KINT+1
11066 ENDIF
11067 ENDIF
11068 QQ1 = B+TKOO(1,INB)-PKOO(1,INA)
11069 QQ2 = TKOO(2,INB)-PKOO(2,INA)
11070 XY = GAM*(QQ1*QQ1+QQ2*QQ2)
11071 IF (XY.LE.15.0D0) THEN
11072 C = CI-CA*AFLUC*EXP(-XY)
11073 AR = DBLE(C)
11074 AI = DIMAG(C)
11075 P = AR*AR+AI*AI
11076 IF (DT_RNDM(XY).GE.P) THEN
11077 JNT = JNT+1
11078 IF (IJPROJ.EQ.7) THEN
11079 JNT0(KINT) = JNT0(KINT)+1
11080 IF (JNT0(KINT).GT.MAXNCL) THEN
11081 WRITE(LOUT,1001) MAXNCL
11082 1001 FORMAT(1X,
11083 & 'DIAGR: no. of requested interactions',
11084 & ' exceeds array dimensions ',I4)
11085 STOP
11086 ENDIF
11087 JS0(KINT) = JS0(KINT)+1
11088 JT0(KINT,INB) = JT0(KINT,INB)+1
11089 JI1(KINT,JNT0(KINT)) = INA
11090 JI2(KINT,JNT0(KINT)) = INB
11091 ELSE
11092 IF (JNT.GT.MAXINT) THEN
11093 WRITE(LOUT,1000) JNT, MAXINT
11094 1000 FORMAT(1X,
11095 & 'DIAGR: no. of requested interactions ('
11096 & ,I4,') exceeds array dimensions (',I4,')')
11097 STOP
11098 ENDIF
11099 JS(INA) = JS(INA)+1
11100 JT(INB) = JT(INB)+1
11101 INTER1(JNT) = INA
11102 INTER2(JNT) = INB
11103 ENDIF
11104 ENDIF
11105 ENDIF
11106 5 CONTINUE
11107 4 CONTINUE
11108
11109 IF (JNT.EQ.0) THEN
11110 IF (NTRY.LT.500) THEN
11111 GOTO 3
11112 ELSE
11113C WRITE(6,*) ' new impact parameter required (old= ',B,')'
11114 GOTO 16
11115 ENDIF
11116 ENDIF
11117
11118 IDIREC = 0
11119 IF (IJPROJ.EQ.7) THEN
11120 K = INT(ONE+DT_RNDM(X)*DBLE(KINT))
11121 10 CONTINUE
11122 IF (JNT0(K).EQ.0) THEN
11123 K = K+1
11124 IF (K.GT.KINT) K = 1
11125 GOTO 10
11126 ENDIF
11127* supress Glauber-cascade by direct photon processes
11128 CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,2)
11129 IF (IPNT.GT.0) THEN
11130 JNT = 1
11131 JS(1) = 1
11132 DO 11 INB=1,NB
11133 JT(INB) = JT0(K,INB)
11134 IF (JT(INB).GT.0) GOTO 12
11135 11 CONTINUE
11136 12 CONTINUE
11137 INTER1(1) = 1
11138 INTER2(1) = INB
11139 IDIREC = IPNT
11140 ELSE
11141 JNT = JNT0(K)
11142 JS(1) = JS0(K)
11143 DO 13 INB=1,NB
11144 JT(INB) = JT0(K,INB)
11145 13 CONTINUE
11146 DO 14 I=1,JNT
11147 INTER1(I) = JI1(K,I)
11148 INTER2(I) = JI2(K,I)
11149 14 CONTINUE
11150 ENDIF
11151 ENDIF
11152
11153 19 CONTINUE
11154 INTA = 0
11155 INTB = 0
11156 DO 6 I=1,NA
11157 IF (JS(I).NE.0) INTA=INTA+1
11158 6 CONTINUE
11159 DO 7 I=1,NB
11160 IF (JT(I).NE.0) INTB=INTB+1
11161 7 CONTINUE
11162 ICWPG = INTA
11163 ICWTG = INTB
11164 ICIG = JNT
11165 IPGLB = IPGLB+INTA
11166 ITGLB = ITGLB+INTB
11167 NGLB = NGLB+1
11168
11169 IF (NCOMPO.EQ.0) THEN
11170 NCALL = NCALL+1
11171 NWA(INTA) = NWA(INTA)+1
11172 NWB(INTB) = NWB(INTB)+1
11173 ENDIF
11174
11175 RETURN
11176 END
11177
11178*$ CREATE DT_MODB.FOR
11179*COPY DT_MODB
11180*
11181*===modb===============================================================*
11182*
11183 SUBROUTINE DT_MODB(B,NIDX)
11184
11185************************************************************************
11186* Sampling of impact parameter of collision. *
11187* B impact parameter (output) *
11188* NIDX index of projectile/target material (input)*
11189* Based on the original version by Shmakov et al. *
11190* This version dated 21.04.95 is revised by S. Roesler *
11191* *
11192* Last change 27.12.2006 by S. Roesler. *
11193************************************************************************
11194
11195 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11196 SAVE
11197 PARAMETER ( LINP = 10 ,
11198 & LOUT = 6 ,
11199 & LDAT = 9 )
11200 PARAMETER (ZERO=0.0D0,TINY15=1.0D-15,ONE=1.0D0,TWO=2.0D0)
11201
11202 LOGICAL LEFT,LFIRST
11203
11204* central particle production, impact parameter biasing
11205 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
11206 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11207* Glauber formalism: parameters
11208 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11209 & BMAX(NCOMPX),BSTEP(NCOMPX),
11210 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11211 & NSITEB,NSTATB
11212* Glauber formalism: cross sections
11213 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11214 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11215 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11216 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11217 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11218 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11219 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11220 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11221 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11222 & BSLOPE,NEBINI,NQBINI
11223
11224 DATA LFIRST /.TRUE./
11225
11226 NTARG = ABS(NIDX)
11227 IF (NIDX.LE.-1) THEN
11228 RA = RASH(1)
11229 RB = RBSH(NTARG)
11230 ELSE
11231 RA = RASH(NTARG)
11232 RB = RBSH(1)
11233 ENDIF
11234
11235 IF (ICENTR.EQ.2) THEN
11236 IF (RA.EQ.RB) THEN
11237 BB = DT_RNDM(B)*(0.3D0*RA)**2
11238 B = SQRT(BB)
11239 ELSEIF(RA.LT.RB)THEN
11240 BB = DT_RNDM(B)*1.4D0*(RB-RA)**2
11241 B = SQRT(BB)
11242 ELSEIF(RA.GT.RB)THEN
11243 BB = DT_RNDM(B)*1.4D0*(RA-RB)**2
11244 B = SQRT(BB)
11245 ENDIF
11246 ELSE
11247 9 CONTINUE
11248 Y = DT_RNDM(BB)
11249 I0 = 1
11250 I2 = NSITEB
11251 10 CONTINUE
11252 I1 = (I0+I2)/2
11253 LEFT = ((BSITE(0,1,NTARG,I0)-Y)
11254 & *(BSITE(0,1,NTARG,I1)-Y)).LT.ZERO
11255 IF (LEFT) GOTO 20
11256 I0 = I1
11257 GOTO 30
11258 20 CONTINUE
11259 I2 = I1
11260 30 CONTINUE
11261 IF (I2-I0-2) 40,50,60
11262 40 CONTINUE
11263 I1 = I2+1
11264 IF (I1.GT.NSITEB) I1 = I0-1
11265 GOTO 70
11266 50 CONTINUE
11267 I1 = I0+1
11268 GOTO 70
11269 60 CONTINUE
11270 GOTO 10
11271 70 CONTINUE
11272 X0 = DBLE(I0-1)*BSTEP(NTARG)
11273 X1 = DBLE(I1-1)*BSTEP(NTARG)
11274 X2 = DBLE(I2-1)*BSTEP(NTARG)
11275 Y0 = BSITE(0,1,NTARG,I0)
11276 Y1 = BSITE(0,1,NTARG,I1)
11277 Y2 = BSITE(0,1,NTARG,I2)
11278 80 CONTINUE
11279 B = X0*(Y-Y1)*(Y-Y2)/((Y0-Y1)*(Y0-Y2)+TINY15)+
11280 & X1*(Y-Y0)*(Y-Y2)/((Y1-Y0)*(Y1-Y2)+TINY15)+
11281 & X2*(Y-Y0)*(Y-Y1)/((Y2-Y0)*(Y2-Y1)+TINY15)
11282**sr 5.4.98: shift B by half the bin width to be in agreement with BPROD
11283 B = B+0.5D0*BSTEP(NTARG)
11284 IF (B.LT.ZERO) B = X1
11285 IF (B.GT.BMAX(NTARG)) B = BMAX(NTARG)
11286 IF (ICENTR.LT.0) THEN
11287 IF (LFIRST) THEN
11288 LFIRST = .FALSE.
11289 IF (ICENTR.LE.-100) THEN
11290 BIMIN = 0.0D0
11291 ELSE
11292 XSFRAC = 0.0D0
11293 ENDIF
11294 CALL DT_GETBXS(XSFRAC,BIMIN,BIMAX,NTARG)
11295 WRITE(LOUT,1000) RASH(1),RBSH(NTARG),BMAX(NTARG),
11296 & BIMIN,BIMAX,XSFRAC*100.0D0,
11297 & XSFRAC*XSPRO(1,1,NTARG)
11298 10000 FORMAT(/,1X,'DT_MODB: Biasing in impact parameter',
11299 & /,15X,'---------------------------'/,/,4X,
11300 & 'average radii of proj / targ :',F10.3,' fm /',
11301 & F7.3,' fm',/,4X,'corresp. b_max (4*(r_p+r_t)) :',
11302 & F10.3,' fm',/,/,21X,'b_lo / b_hi :',
11303 & F10.3,' fm /',F7.3,' fm',/,5X,'percentage of',
11304 & ' cross section :',F10.3,' %',/,5X,
11305 & 'corresponding cross section :',F10.3,' mb',/)
11306 ENDIF
11307 IF (ABS(BIMAX-BIMIN).LT.1.0D-3) THEN
11308 B = BIMIN
11309 ELSE
11310 IF ((B.LT.BIMIN).OR.(B.GT.BIMAX)) GOTO 9
11311 ENDIF
11312 ENDIF
11313 ENDIF
11314
11315 RETURN
11316 END
11317
11318*$ CREATE DT_SHFAST.FOR
11319*COPY DT_SHFAST
11320*
11321*===shfast=============================================================*
11322*
11323 SUBROUTINE DT_SHFAST(MODE,PPN,IBACK)
11324
11325 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11326 SAVE
11327 PARAMETER ( LINP = 10 ,
11328 & LOUT = 6 ,
11329 & LDAT = 9 )
11330 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY1=1.0D-1,
11331 & ONE=1.0D0,TWO=2.0D0)
11332
11333 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11334* Glauber formalism: parameters
11335 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11336 & BMAX(NCOMPX),BSTEP(NCOMPX),
11337 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11338 & NSITEB,NSTATB
11339* properties of interacting particles
11340 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11341* Glauber formalism: cross sections
11342 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11343 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11344 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11345 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11346 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11347 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11348 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11349 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11350 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11351 & BSLOPE,NEBINI,NQBINI
11352
11353 IBACK = 0
11354
11355 IF (MODE.EQ.2) THEN
11356 OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11357 WRITE(47,1000) IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG,PPN
11358 1000 FORMAT(1X,8I5,E15.5)
11359 WRITE(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11360 1001 FORMAT(1X,4E15.5)
11361 WRITE(47,1002) SIGSH,ROSH,GSH
11362 1002 FORMAT(1X,3E15.5)
11363 DO 10 I=1,100
11364 WRITE(47,'(1X,E15.5)') BSITE(1,1,1,I)
11365 10 CONTINUE
11366 WRITE(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11367 1003 FORMAT(1X,2I10,3E15.5)
11368 CLOSE(47)
11369 ELSE
11370 OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11371 READ(47,1000) JT,JTZ,JP,JPZ,JJPROJ,JBPROJ,JJTARG,JBTARG,PP
11372 IF ((JT.EQ.IT).AND.(JTZ.EQ.ITZ).AND.(JP.EQ.IP).AND.
11373 & (JPZ.EQ.IPZ).AND.(JJPROJ.EQ.IJPROJ).AND.(JBPROJ.EQ.IBPROJ)
11374 & .AND.(JJTARG.EQ.IJTARG).AND.(JBTARG.EQ.IBTARG).AND.
11375 & (ABS(PP-PPN).LT.(PPN*0.01D0))) THEN
11376 READ(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11377 READ(47,1002) SIGSH,ROSH,GSH
11378 DO 11 I=1,100
11379 READ(47,'(1X,E15.5)') BSITE(1,1,1,I)
11380 11 CONTINUE
11381 READ(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11382 ELSE
11383 IBACK = 1
11384 ENDIF
11385 CLOSE(47)
11386 ENDIF
11387
11388 RETURN
11389 END
11390
11391*$ CREATE DT_POILIK.FOR
11392*COPY DT_POILIK
11393*
11394*===poilik=============================================================*
11395*
11396 SUBROUTINE DT_POILIK(NB,NTARG,ECM,VIRT,IPNT,RPNT,MODE)
11397
11398 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
11399 SAVE
11400
11401 PARAMETER ( LINP = 10 ,
11402 & LOUT = 6 ,
11403 & LDAT = 9 )
11404 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.0D0)
11405 PARAMETER (NE = 8)
11406
11407**PHOJET105a
11408C CHARACTER*8 MDLNA
11409C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
11410C PARAMETER (IEETAB=10)
11411C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
11412**PHOJET110
11413C model switches and parameters
11414 CHARACTER*8 MDLNA
11415 INTEGER ISWMDL,IPAMDL
11416 DOUBLE PRECISION PARMDL
11417 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11418C energy-interpolation table
11419 INTEGER IEETA2
11420 PARAMETER ( IEETA2 = 20 )
11421 INTEGER ISIMAX
11422 DOUBLE PRECISION SIGTAB,SIGECM
11423 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
11424**
11425* VDM parameter for photon-nucleus interactions
11426 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
11427**sr 22.7.97
11428 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11429* Glauber formalism: cross sections
11430 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11431 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11432 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11433 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11434 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11435 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11436 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11437 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11438 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11439 & BSLOPE,NEBINI,NQBINI
11440**
11441
11442 DATA ECMOLD,Q2OLD /-1.0D0,-1.0D0/
11443
11444 IF ((ECM.EQ.ECMOLD).AND.(VIRT.EQ.Q2OLD)) GOTO 3
11445
11446* load cross sections from interpolation table
11447 IP = 1
11448 IF(ECM.LE.SIGECM(IP,1)) THEN
11449 I1 = 1
11450 I2 = 1
11451 ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
11452 DO 50 I=2,ISIMAX
11453 IF(ECM.LE.SIGECM(IP,I)) GOTO 200
11454 50 CONTINUE
11455 200 CONTINUE
11456 I1 = I-1
11457 I2 = I
11458 ELSE
11459 WRITE(LOUT,'(/1X,A,2E12.3)')
11460 & 'POILIK:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
11461 I1 = ISIMAX
11462 I2 = ISIMAX
11463 ENDIF
11464 FAC2 = ZERO
11465 IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
11466 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
11467 FAC1 = ONE-FAC2
11468
11469 SIGANO = DT_SANO(ECM)
11470
11471* cross section dependence on photon virtuality
11472 FSUP1 = ZERO
11473 DO 150 I=1,3
11474 FSUP1 = FSUP1+PARMDL(26+I)*(ONE+VIRT/(4.D0*PARMDL(30+I)))
11475 & /(ONE+VIRT/PARMDL(30+I))**2
11476 150 CONTINUE
11477 FSUP1 = FSUP1+PARMDL(30)/(ONE+VIRT/PARMDL(34))
11478 FAC1 = FAC1*FSUP1
11479 FAC2 = FAC2*FSUP1
11480 FSUP2 = ONE
11481
11482 ECMOLD = ECM
11483 Q2OLD = VIRT
11484
11485 3 CONTINUE
11486
11487C SIGTOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
11488 CALL DT_SIGGP(ZERO,VIRT,ECM,ZERO,SIGTOT,DUM1,DUM2)
11489 IF (ISHAD(1).EQ.1) THEN
11490 SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
11491 ELSE
11492 SIGDIR = ZERO
11493 ENDIF
11494 SIGANO = FSUP1*FSUP2*SIGANO
11495 SIGTOT = SIGTOT-SIGDIR-SIGANO
11496 SIGDIR = SIGDIR/(FSUP1*FSUP2)
11497 SIGANO = SIGANO/(FSUP1*FSUP2)
11498 SIGTOT = SIGTOT+SIGDIR+SIGANO
11499
11500 RR = DT_RNDM(SIGTOT)
11501 IF (RR.LT.SIGDIR/SIGTOT) THEN
11502 IPNT = 1
11503 ELSEIF ((RR.GE.SIGDIR/SIGTOT).AND.
11504 & (RR.LT.(SIGDIR+SIGANO)/SIGTOT)) THEN
11505 IPNT = 2
11506 ELSE
11507 IPNT = 0
11508 ENDIF
11509 RPNT = (SIGDIR+SIGANO)/SIGTOT
11510C WRITE(LOUT,'(I3,2F15.5)') ISHAD(1),FAC1,FAC2
11511C WRITE(LOUT,'(I3,2F15.5)') MODE,SIGDIR,SIGANO
11512C WRITE(LOUT,'(I3,4F15.5)') MODE,SIGDIR+SIGANO,SIGTOT,RPNT,ECM
11513C WRITE(LOUT,'(1X,6E12.4)') ECM,VIRT,SIGTOT,SIGDIR,SIGANO,RPNT
11514 IF (MODE.EQ.1) RETURN
11515
11516**sr 22.7.97
11517 K1 = 1
11518 K2 = 1
11519 RATE = ZERO
11520 IF (ECM.GE.ECMNN(NEBINI)) THEN
11521 K1 = NEBINI
11522 K2 = NEBINI
11523 RATE = ONE
11524 ELSEIF (ECM.GT.ECMNN(1)) THEN
11525 DO 10 I=2,NEBINI
11526 IF (ECM.LT.ECMNN(I)) THEN
11527 K1 = I-1
11528 K2 = I
11529 RATE = (ECM-ECMNN(K1))/(ECMNN(K2)-ECMNN(K1))
11530 GOTO 11
11531 ENDIF
11532 10 CONTINUE
11533 11 CONTINUE
11534 ENDIF
11535 J1 = 1
11536 J2 = 1
11537 RATQ = ZERO
11538 IF (NQBINI.GT.1) THEN
11539 IF (VIRT.GE.Q2G(NQBINI)) THEN
11540 J1 = NQBINI
11541 J2 = NQBINI
11542 RATQ = ONE
11543 ELSEIF (VIRT.GT.Q2G(1)) THEN
11544 DO 12 I=2,NQBINI
11545 IF (VIRT.LT.Q2G(I)) THEN
11546 J1 = I-1
11547 J2 = I
11548 RATQ = LOG10( VIRT/MAX(Q2G(J1),TINY14))/
11549 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
11550 GOTO 13
11551 ENDIF
11552 12 CONTINUE
11553 13 CONTINUE
11554 ENDIF
11555 ENDIF
11556 SGA = XSPRO(K1,J1,NTARG)+
11557 & RATE*(XSPRO(K2,J1,NTARG)-XSPRO(K1,J1,NTARG))+
11558 & RATQ*(XSPRO(K1,J2,NTARG)-XSPRO(K1,J1,NTARG))+
11559 & RATE*RATQ*(XSPRO(K2,J2,NTARG)-XSPRO(K1,J2,NTARG)+
11560 & XSPRO(K1,J1,NTARG)-XSPRO(K2,J1,NTARG))
11561 SDI = DBLE(NB)*SIGDIR
11562 SAN = DBLE(NB)*SIGANO
11563 SPL = SDI+SAN
11564 RR = DT_RNDM(SPL)
11565 IF (RR.LT.SDI/SGA) THEN
11566 IPNT = 1
11567 ELSEIF ((RR.GE.SDI/SGA).AND.
11568 & (RR.LT.SPL/SGA)) THEN
11569 IPNT = 2
11570 ELSE
11571 IPNT = 0
11572 ENDIF
11573 RPNT = SPL/SGA
11574C WRITE(LOUT,'(I3,4F15.5)') MODE,SPL,SGA,RPNT,ECM
11575**
11576
11577 RETURN
11578 END
11579
11580*$ CREATE DT_GLBINI.FOR
11581*COPY DT_GLBINI
11582*
11583*===glbini=============================================================*
11584*
11585 SUBROUTINE DT_GLBINI(WHAT)
11586
11587************************************************************************
11588* Pre-initialization of profile function *
11589* This version dated 28.11.00 is written by S. Roesler. *
11590* *
11591* Last change 27.12.2006 by S. Roesler. *
11592************************************************************************
11593
11594 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11595 SAVE
11596
11597 PARAMETER ( LINP = 10 ,
11598 & LOUT = 6 ,
11599 & LDAT = 9 )
11600 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.D-14)
11601
11602 LOGICAL LCMS
11603
11604* particle properties (BAMJET index convention)
11605 CHARACTER*8 ANAME
11606 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11607 & IICH(210),IIBAR(210),K1(210),K2(210)
11608* properties of interacting particles
11609 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11610 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11611* emulsion treatment
11612 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11613 & NCOMPO,IEMUL
11614* Glauber formalism: flags and parameters for statistics
11615 LOGICAL LPROD
11616 CHARACTER*8 CGLB
11617 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11618* number of data sets other than protons and nuclei
11619* at the moment = 2 (pions and kaons)
11620 PARAMETER (MAXOFF=2)
11621 DIMENSION IJPINI(5),IOFFST(25)
11622 DATA IJPINI / 13, 15, 0, 0, 0/
11623* Glauber data-set to be used for hadron projectiles
11624* (0=proton, 1=pion, 2=kaon)
11625 DATA (IOFFST(K),K=1,25) /
11626 & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
11627 & 0, 0, 1, 2, 2/
11628* Acceptance interval for target nucleus mass
11629 PARAMETER (KBACC = 6)
11630* flags for input different options
11631 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
11632 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
11633 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
11634
11635 PARAMETER (MAXMSS = 100)
11636 DIMENSION IASAV(MAXMSS),IBSAV(MAXMSS)
11637 DIMENSION WHAT(6)
11638
11639 DATA JPEACH,JPSTEP / 18, 5 /
11640
11641* temporary patch until fix has been implemented in phojet:
11642* maximum energy for pion projectile
11643 DATA ECMXPI / 100000.0D0 /
11644*
11645*--------------------------------------------------------------------------
11646* general initializations
11647*
11648* steps in projectile mass number for initialization
11649 IF (WHAT(4).GT.ZERO) JPEACH = INT(WHAT(4))
11650 IF (WHAT(5).GT.ZERO) JPSTEP = INT(WHAT(5))
11651*
11652* energy range and binning
11653 ELO = ABS(WHAT(1))
11654 EHI = ABS(WHAT(2))
11655 IF (ELO.GT.EHI) ELO = EHI
11656 NEBIN = MAX(INT(WHAT(3)),1)
11657 IF (ELO.EQ.EHI) NEBIN = 0
11658 LCMS = (WHAT(1).LT.ZERO).OR.(WHAT(2).LT.ZERO)
11659 IF (LCMS) THEN
11660 ECMINI = EHI
11661 ELSE
11662 ECMINI = SQRT(AAM(IJPROJ)**2+AAM(IJTARG)**2
11663 & +2.0D0*AAM(IJTARG)*EHI)
11664 ENDIF
11665*
11666* default arguments for Glauber-routine
11667 XI = ZERO
11668 Q2I = ZERO
11669*
11670* initialize nuclear parameters, etc.
11671 CALL DT_BERTTP
11672 CALL DT_INCINI
11673*
11674* open Glauber-data output file
11675 IDX = INDEX(CGLB,' ')
11676 K = 12
11677 IF (IDX.GT.1) K = IDX-1
11678 OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
11679*
11680*--------------------------------------------------------------------------
11681* Glauber-initialization for proton and nuclei projectiles
11682*
11683* initialize phojet for proton-proton interactions
11684 ELAB = ZERO
11685 PLAB = ZERO
11686 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
11687 CALL DT_PHOINI
11688*
11689* record projectile masses
11690 NASAV = 0
11691 NPROJ = MIN(IP,JPEACH)
11692 DO 10 KPROJ=1,NPROJ
11693 NASAV = NASAV+1
11694 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11695 IASAV(NASAV) = KPROJ
11696 10 CONTINUE
11697 IF (IP.GT.JPEACH) THEN
11698 NPROJ = DBLE(IP-JPEACH)/DBLE(JPSTEP)
11699 IF (NPROJ.EQ.0) THEN
11700 NASAV = NASAV+1
11701 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11702 IASAV(NASAV) = IP
11703 ELSE
11704 DO 11 IPROJ=1,NPROJ
11705 KPROJ = JPEACH+IPROJ*JPSTEP
11706 NASAV = NASAV+1
11707 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11708 IASAV(NASAV) = KPROJ
11709 11 CONTINUE
11710 IF (KPROJ.LT.IP) THEN
11711 NASAV = NASAV+1
11712 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11713 IASAV(NASAV) = IP
11714 ENDIF
11715 ENDIF
11716 ENDIF
11717*
11718* record target masses
11719 NBSAV = 0
11720 NTARG = 1
11721 IF (NCOMPO.GT.0) NTARG = NCOMPO
11722 DO 12 ITARG=1,NTARG
11723 NBSAV = NBSAV+1
11724 IF (NBSAV.GT.MAXMSS) STOP ' GLBINI: NBSAV > MAXMSS ! '
11725 IF (NCOMPO.GT.0) THEN
11726 IBSAV(NBSAV) = IEMUMA(ITARG)
11727 ELSE
11728 IBSAV(NBSAV) = IT
11729 ENDIF
11730 12 CONTINUE
11731*
11732* print masses
11733 WRITE(LDAT,1000) NEBIN,': ',SIGN(ELO,WHAT(1)),SIGN(EHI,WHAT(2))
11734 1000 FORMAT(I4,A,1P,2E13.5)
11735 NLINES = DBLE(NASAV)/18.0D0
11736 IF (NLINES.GT.0) THEN
11737 DO 13 I=1,NLINES
11738 IF (I.EQ.1) THEN
11739 WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=1,18)
11740 ELSE
11741 WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=18*I-17,18*I)
11742 ENDIF
11743 13 CONTINUE
11744 ENDIF
11745 I0 = 18*NLINES+1
11746 IF (I0.LE.NASAV) THEN
11747 IF (I0.EQ.1) THEN
11748 WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=I0,NASAV)
11749 ELSE
11750 WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=I0,NASAV)
11751 ENDIF
11752 ENDIF
11753 NLINES = DBLE(NBSAV)/18.0D0
11754 IF (NLINES.GT.0) THEN
11755 DO 14 I=1,NLINES
11756 IF (I.EQ.1) THEN
11757 WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=1,18)
11758 ELSE
11759 WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=18*I-17,18*I)
11760 ENDIF
11761 14 CONTINUE
11762 ENDIF
11763 I0 = 18*NLINES+1
11764 IF (I0.LE.NBSAV) THEN
11765 IF (I0.EQ.1) THEN
11766 WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=I0,NBSAV)
11767 ELSE
11768 WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=I0,NBSAV)
11769 ENDIF
11770 ENDIF
11771*
11772* calculate Glauber-data for each energy and mass combination
11773*
11774* loop over energy bins
11775 ELO = LOG10(ELO)
11776 EHI = LOG10(EHI)
11777 DEBIN = (EHI-ELO)/MAX(DBLE(NEBIN),ONE)
11778 DO 1 IE=1,NEBIN+1
11779 E = ELO+DBLE(IE-1)*DEBIN
11780 E = 10**E
11781 IF (LCMS) THEN
11782 E = MAX(2.0D0*AAM(IJPROJ)+0.1D0,E)
11783 ECM = E
11784 ELSE
11785 PLAB = ZERO
11786 ECM = ZERO
11787 E = MAX(AAM(IJPROJ)+0.1D0,E)
11788 CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
11789 ENDIF
11790*
11791* loop over projectile and target masses
11792 DO 2 ITARG=1,NBSAV
11793 DO 3 IPROJ=1,NASAV
11794 CALL DT_XSGLAU(IASAV(IPROJ),IBSAV(ITARG),IJPROJ,
11795 & XI,Q2I,ECM,1,1,-1)
11796 3 CONTINUE
11797 2 CONTINUE
11798*
11799 1 CONTINUE
11800*
11801*--------------------------------------------------------------------------
11802* Glauber-initialization for pion, kaon, ... projectiles
11803*
11804 DO 6 IJ=1,MAXOFF
11805*
11806* initialize phojet for this interaction
11807 ELAB = ZERO
11808 PLAB = ZERO
11809 IJPROJ = IJPINI(IJ)
11810 IP = 1
11811 IPZ = 1
11812*
11813* temporary patch until fix has been implemented in phojet:
11814 IF (ECMINI.GT.ECMXPI) THEN
11815 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMXPI,1)
11816 ELSE
11817 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
11818 ENDIF
11819 CALL DT_PHOINI
11820*
11821* calculate Glauber-data for each energy and mass combination
11822*
11823* loop over energy bins
11824 DO 4 IE=1,NEBIN+1
11825 E = ELO+DBLE(IE-1)*DEBIN
11826 E = 10**E
11827 IF (LCMS) THEN
11828 E = MAX(2.0D0*AAM(IJPROJ)+TINY14,E)
11829 ECM = E
11830 ELSE
11831 PLAB = ZERO
11832 ECM = ZERO
11833 E = MAX(AAM(IJPROJ)+TINY14,E)
11834 CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
11835 ENDIF
11836*
11837* loop over projectile and target masses
11838 DO 5 ITARG=1,NBSAV
11839 CALL DT_XSGLAU(1,IBSAV(ITARG),IJPROJ,XI,Q2I,ECM,1,1,-1)
11840 5 CONTINUE
11841*
11842 4 CONTINUE
11843*
11844 6 CONTINUE
11845
11846*--------------------------------------------------------------------------
11847* close output unit(s), etc.
11848*
11849 CLOSE(LDAT)
11850
11851 RETURN
11852 END
11853
11854*$ CREATE DT_GLBSET.FOR
11855*COPY DT_GLBSET
11856*
11857*===glbset=============================================================*
11858*
11859 SUBROUTINE DT_GLBSET(IDPROJ,NA,NB,ELAB,MODE)
11860************************************************************************
11861* Interpolation of pre-initialized profile functions *
11862* This version dated 28.11.00 is written by S. Roesler. *
11863************************************************************************
11864
11865 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11866 SAVE
11867
11868 PARAMETER ( LINP = 10 ,
11869 & LOUT = 6 ,
11870 & LDAT = 9 )
11871 PARAMETER (ZERO=0.0D0,ONE=1.0D0)
11872
11873 LOGICAL LCMS,LREAD,LFRST1,LFRST2
11874
11875* particle properties (BAMJET index convention)
11876 CHARACTER*8 ANAME
11877 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11878 & IICH(210),IIBAR(210),K1(210),K2(210)
11879* Glauber formalism: flags and parameters for statistics
11880 LOGICAL LPROD
11881 CHARACTER*8 CGLB
11882 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11883 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11884* Glauber formalism: parameters
11885 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11886 & BMAX(NCOMPX),BSTEP(NCOMPX),
11887 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11888 & NSITEB,NSTATB
11889* Glauber formalism: cross sections
11890 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11891 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11892 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11893 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11894 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11895 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11896 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11897 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11898 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11899 & BSLOPE,NEBINI,NQBINI
11900* number of data sets other than protons and nuclei
11901* at the moment = 2 (pions and kaons)
11902 PARAMETER (MAXOFF=2)
11903 DIMENSION IJPINI(5),IOFFST(25)
11904 DATA IJPINI / 13, 15, 0, 0, 0/
11905* Glauber data-set to be used for hadron projectiles
11906* (0=proton, 1=pion, 2=kaon)
11907 DATA (IOFFST(K),K=1,25) /
11908 & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
11909 & 0, 0, 1, 2, 2/
11910* Acceptance interval for target nucleus mass
11911 PARAMETER (KBACC = 6)
11912* emulsion treatment
11913 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11914 & NCOMPO,IEMUL
11915
11916 PARAMETER (MAXSET=5000,
11917 & MAXBIN=100)
11918 DIMENSION XSIG(MAXSET,6),XERR(MAXSET,6),BPROFL(MAXSET,KSITEB)
11919 DIMENSION IABIN(MAXBIN),IBBIN(MAXBIN),XS(6),XE(6),
11920 & BPRO0(KSITEB),BPRO1(KSITEB),BPRO(KSITEB),
11921 & IAIDX(10)
11922
11923 DATA LREAD,LFRST1,LFRST2 /.FALSE.,.TRUE.,.TRUE./
11924*
11925* read data from file
11926*
11927 IF (MODE.EQ.0) THEN
11928
11929 IF (LREAD) RETURN
11930
11931 DO 1 I=1,MAXSET
11932 DO 2 J=1,6
11933 XSIG(I,J) = ZERO
11934 XERR(I,J) = ZERO
11935 2 CONTINUE
11936 DO 3 J=1,KSITEB
11937 BPROFL(I,J) = ZERO
11938 3 CONTINUE
11939 1 CONTINUE
11940 DO 4 I=1,MAXBIN
11941 IABIN(I) = 0
11942 IBBIN(I) = 0
11943 4 CONTINUE
11944 DO 5 I=1,KSITEB
11945 BPRO0(I) = ZERO
11946 BPRO1(I) = ZERO
11947 BPRO(I) = ZERO
11948 5 CONTINUE
11949
11950 IDX = INDEX(CGLB,' ')
11951 K = 12
11952 IF (IDX.GT.1) K = IDX-1
11953 OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
11954 WRITE(LOUT,1000) CGLB(1:K)//'.glb'
11955 1000 FORMAT(/,' GLBSET: impact parameter distributions read from ',
11956 & 'file ',A12,/)
11957*
11958* read binning information
11959 READ(LDAT,'(I4,2X,2E13.5)') NEBIN,ELO,EHI
11960* return lower energy threshold to Fluka-interface
11961 ELAB = ELO
11962 LCMS = ELO.LT.ZERO
11963 WRITE(LOUT,'(1X,A)') ' equidistant logarithmic energy binning:'
11964 IF (LCMS) THEN
11965 WRITE(LOUT,1001) '(cms)',ABS(ELO),ABS(EHI),NEBIN
11966 ELSE
11967 WRITE(LOUT,1001) '(lab)',ABS(ELO),ABS(EHI),NEBIN
11968 ENDIF
11969 1001 FORMAT(2X,A5,' E_lo = ',1P,E9.3,' E_hi = ',1P,E9.3,4X,
11970 & 'No. of bins:',I5,/)
11971 ELO = LOG10(ABS(ELO))
11972 EHI = LOG10(ABS(EHI))
11973 DEBIN = (EHI-ELO)/ABS(DBLE(NEBIN))
11974 WRITE(LOUT,'(/,1X,A)') ' projectiles: (mass number)'
11975 READ(LDAT,'(I4,2X,18I4)') NABIN,(IABIN(J),J=1,18)
11976 IF (NABIN.LT.18) THEN
11977 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,NABIN)
11978 ELSE
11979 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,18)
11980 ENDIF
11981 IF (NABIN.GT.MAXBIN) STOP ' GLBSET: NABIN > MAXBIN !'
11982 IF (NABIN.GT.18) THEN
11983 NLINES = DBLE(NABIN-18)/18.0D0
11984 IF (NLINES.GT.0) THEN
11985 DO 7 I=1,NLINES
11986 I0 = 18*(I+1)-17
11987 READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
11988 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
11989 7 CONTINUE
11990 ENDIF
11991 I0 = 18*(NLINES+1)+1
11992 IF (I0.LE.NABIN) THEN
11993 READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
11994 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
11995 ENDIF
11996 ENDIF
11997 WRITE(LOUT,'(/,1X,A)') ' targets: (mass number)'
11998 READ(LDAT,'(I4,2X,18I4)') NBBIN,(IBBIN(J),J=1,18)
11999 IF (NBBIN.LT.18) THEN
12000 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,NBBIN)
12001 ELSE
12002 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,18)
12003 ENDIF
12004 IF (NBBIN.GT.MAXBIN) STOP ' GLBSET: NBBIN > MAXBIN !'
12005 IF (NBBIN.GT.18) THEN
12006 NLINES = DBLE(NBBIN-18)/18.0D0
12007 IF (NLINES.GT.0) THEN
12008 DO 8 I=1,NLINES
12009 I0 = 18*(I+1)-17
12010 READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12011 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12012 8 CONTINUE
12013 ENDIF
12014 I0 = 18*(NLINES+1)+1
12015 IF (I0.LE.NBBIN) THEN
12016 READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12017 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12018 ENDIF
12019 ENDIF
12020* number of data sets to follow in the Glauber data file
12021* this variable is used for checks of consistency of projectile
12022* and target mass configurations given in header of Glauber data
12023* file and the data-sets which follow in this file
12024 NSET0 = (NEBIN+1)*(NABIN+MAXOFF)*NBBIN
12025*
12026* read profile function data
12027 NSET = 0
12028 NAIDX = 0
12029 IPOLD = 0
12030 10 CONTINUE
12031 NSET = NSET+1
12032 IF (NSET.GT.MAXSET) STOP ' GLBSET: NSET > MAXSET ! '
12033 READ(LDAT,1002,END=100) IP,IA,IB,ISTATB,ISITEB,ECM
12034 1002 FORMAT(5I10,E15.5)
12035 IF ((IP.NE.1).AND.(IP.NE.IPOLD)) THEN
12036 NAIDX = NAIDX+1
12037 IF (NAIDX.GT.10) STOP ' GLBSET: NAIDX > 10 !'
12038 IAIDX(NAIDX) = IP
12039 IPOLD = IP
12040 ENDIF
12041 READ(LDAT,'(6E12.5)') (XSIG(NSET,I),I=1,6)
12042 READ(LDAT,'(6E12.5)') (XERR(NSET,I),I=1,6)
12043 NLINES = INT(DBLE(ISITEB)/7.0D0)
12044 IF (NLINES.GT.0) THEN
12045 DO 11 I=1,NLINES
12046 READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=7*I-6,7*I)
12047 11 CONTINUE
12048 ENDIF
12049 I0 = 7*NLINES+1
12050 IF (I0.LE.ISITEB)
12051 & READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=I0,ISITEB)
12052 GOTO 10
12053 100 CONTINUE
12054 NSET = NSET-1
12055 IF (NSET.NE.NSET0) STOP ' GLBSET: NSET.NE.NSET0 !'
12056 WRITE(LOUT,'(/,1X,A)')
12057 & ' projectiles other than protons and nuclei: (particle index)'
12058 IF (NAIDX.GT.0) THEN
12059 WRITE(LOUT,'(6X,18I4)') (IAIDX(J),J=1,NAIDX)
12060 ELSE
12061 WRITE(LOUT,'(6X,A)') 'none'
12062 ENDIF
12063*
12064 CLOSE(LDAT)
12065 WRITE(LOUT,*)
12066 LREAD = .TRUE.
12067
12068 IF (NCOMPO.EQ.0) THEN
12069 DO 12 J=1,NBBIN
12070 NCOMPO = NCOMPO+1
12071 IEMUMA(NCOMPO) = IBBIN(J)
12072 IEMUCH(NCOMPO) = IEMUMA(NCOMPO)/2
12073 EMUFRA(NCOMPO) = 1.0D0
12074 12 CONTINUE
12075 IEMUL = 1
12076 ENDIF
12077*
12078* calculate profile function for certain set of parameters
12079*
12080 ELSE
12081
12082c write(*,*) 'glbset called for ',IDPROJ,NA,NB,ELAB,MODE
12083*
12084* check for type of projectile and set index-offset to entry in
12085* Glauber data array correspondingly
12086 IF (IDPROJ.GT.25) STOP ' GLBSET: IDPROJ > 25 !'
12087 IF (IOFFST(IDPROJ).EQ.-1) THEN
12088 STOP ' GLBSET: no data for this projectile !'
12089 ELSEIF (IOFFST(IDPROJ).GT.0) THEN
12090 IDXOFF = (NEBIN+1)*(NABIN+IOFFST(IDPROJ)-1)*NBBIN
12091 ELSE
12092 IDXOFF = 0
12093 ENDIF
12094*
12095* get energy bin and interpolation factor
12096 IF (LCMS) THEN
12097 E = SQRT(AAM(IDPROJ)**2+AAM(1)**2+2.0D0*AAM(1)*ELAB)
12098 ELSE
12099 E = ELAB
12100 ENDIF
12101 E = LOG10(E)
12102 IF (E.LT.ELO) THEN
12103 IF (LFRST1) THEN
12104 WRITE(LOUT,*) ' GLBSET: Too low energy! (E_lo,E) ',ELO,E
12105 LFRST1 = .FALSE.
12106 ENDIF
12107 E = ELO
12108 ENDIF
12109 IF (E.GT.EHI) THEN
12110 IF (LFRST2) THEN
12111 WRITE(LOUT,*) ' GLBSET: Too high energy! (E_hi,E) ',EHI,E
12112 LFRST2 = .FALSE.
12113 ENDIF
12114 E = EHI
12115 ENDIF
12116 IE0 = (E-ELO)/DEBIN+1
12117 IE1 = IE0+1
12118 FACE = (E-(ELO+DBLE(IE0-1)*DEBIN))/DEBIN
12119*
12120* get target nucleus index
12121 KB = 0
12122 NBACC = KBACC
12123 DO 20 I=1,NBBIN
12124 NBDIFF = ABS(NB-IBBIN(I))
12125 IF (NB.EQ.IBBIN(I)) THEN
12126 KB = I
12127 GOTO 21
12128 ELSEIF (NBDIFF.LE.NBACC) THEN
12129 KB = I
12130 NBACC = NBDIFF
12131 ENDIF
12132 20 CONTINUE
12133 IF (KB.NE.0) GOTO 21
12134 WRITE(LOUT,*) ' GLBSET: data not found for target ',NB
12135 STOP
12136 21 CONTINUE
12137*
12138* get projectile nucleus bin and interpolation factor
12139 KA0 = 0
12140 KA1 = 0
12141 FACNA = 0
12142 IF (IDXOFF.GT.0) THEN
12143 KA0 = 1
12144 KA1 = 1
12145 KABIN = 1
12146 ELSE
12147 IF (NA.GT.IABIN(NABIN)) STOP ' GLBSET: NA > IABIN(NABIN) !'
12148 DO 22 I=1,NABIN
12149 IF (NA.EQ.IABIN(I)) THEN
12150 KA0 = I
12151 KA1 = I
12152 GOTO 23
12153 ELSEIF (NA.LT.IABIN(I)) THEN
12154 KA0 = I-1
12155 KA1 = I
12156 GOTO 23
12157 ENDIF
12158 22 CONTINUE
12159 WRITE(LOUT,*) ' GLBSET: data not found for projectile ',NA
12160 STOP
12161 23 CONTINUE
12162 IF (KA0.NE.KA1)
12163 & FACNA = DBLE(NA-IABIN(KA0))/DBLE(IABIN(KA1)-IABIN(KA0))
12164 KABIN = NABIN
12165 ENDIF
12166*
12167* interpolate profile functions for interactions ka0-kb and ka1-kb
12168* for energy E separately
12169 IDX0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12170 IDX1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12171 IDY0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12172 IDY1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12173 DO 30 I=1,ISITEB
12174 BPRO0(I) = BPROFL(IDX0,I)
12175 & +FACE*(BPROFL(IDX1,I)-BPROFL(IDX0,I))
12176 BPRO1(I) = BPROFL(IDY0,I)
12177 & +FACE*(BPROFL(IDY1,I)-BPROFL(IDY0,I))
12178 30 CONTINUE
12179 RADB = DT_RNCLUS(NB)
12180 BSTP0 = 2.0D0*(DT_RNCLUS(IABIN(KA0))+RADB)/DBLE(ISITEB-1)
12181 BSTP1 = 2.0D0*(DT_RNCLUS(IABIN(KA1))+RADB)/DBLE(ISITEB-1)
12182*
12183* interpolate cross sections for energy E and projectile mass
12184 DO 31 I=1,6
12185 XS0 = XSIG(IDX0,I)+FACE*(XSIG(IDX1,I)-XSIG(IDX0,I))
12186 XS1 = XSIG(IDY0,I)+FACE*(XSIG(IDY1,I)-XSIG(IDY0,I))
12187 XS(I) = XS0+FACNA*(XS1-XS0)
12188 XE0 = XERR(IDX0,I)+FACE*(XERR(IDX1,I)-XERR(IDX0,I))
12189 XE1 = XERR(IDY0,I)+FACE*(XERR(IDY1,I)-XERR(IDY0,I))
12190 XE(I) = XE0+FACNA*(XE1-XE0)
12191 31 CONTINUE
12192*
12193* interpolate between ka0 and ka1
12194 RADA = DT_RNCLUS(NA)
12195 BMX = 2.0D0*(RADA+RADB)
12196 BSTP = BMX/DBLE(ISITEB-1)
12197 BPRO(1) = ZERO
12198 DO 32 I=1,ISITEB-1
12199 B = DBLE(I)*BSTP
12200*
12201* calculate values of profile functions at B
12202 IDX0 = B/BSTP0+1
12203 IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12204 IDX1 = MIN(IDX0+1,ISITEB)
12205 FACB = (B-DBLE(IDX0-1)*BSTP0)/BSTP0
12206 BPR0 = BPRO0(IDX0)+FACB*(BPRO0(IDX1)-BPRO0(IDX0))
12207 IDX0 = B/BSTP1+1
12208 IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12209 IDX1 = MIN(IDX0+1,ISITEB)
12210 FACB = (B-DBLE(IDX0-1)*BSTP1)/BSTP1
12211 BPR1 = BPRO1(IDX0)+FACB*(BPRO1(IDX1)-BPRO1(IDX0))
12212*
12213 BPRO(I+1) = BPR0+FACNA*(BPR1-BPR0)
12214 32 CONTINUE
12215*
12216* fill common dtglam
12217 NSITEB = ISITEB
12218 RASH(1) = RADA
12219 RBSH(1) = RADB
12220 BMAX(1) = BMX
12221 BSTEP(1) = BSTP
12222 DO 33 I=1,KSITEB
12223 BSITE(0,1,1,I) = BPRO(I)
12224 33 CONTINUE
12225*
12226* fill common dtglxs
12227 XSTOT(1,1,1) = XS(1)
12228 XSELA(1,1,1) = XS(2)
12229 XSQEP(1,1,1) = XS(3)
12230 XSQET(1,1,1) = XS(4)
12231 XSQE2(1,1,1) = XS(5)
12232 XSPRO(1,1,1) = XS(6)
12233 XETOT(1,1,1) = XE(1)
12234 XEELA(1,1,1) = XE(2)
12235 XEQEP(1,1,1) = XE(3)
12236 XEQET(1,1,1) = XE(4)
12237 XEQE2(1,1,1) = XE(5)
12238 XEPRO(1,1,1) = XE(6)
12239
12240 ENDIF
12241
12242 RETURN
12243 END
12244
12245*$ CREATE DT_XKSAMP.FOR
12246*COPY DT_XKSAMP
12247*
12248*===xksamp=============================================================*
12249*
12250 SUBROUTINE DT_XKSAMP(NN,ECM)
12251
12252************************************************************************
12253* Sampling of parton x-values and chain system for one interaction. *
12254* processed by S. Roesler, 9.8.95 *
12255************************************************************************
12256
12257 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12258 SAVE
12259 PARAMETER ( LINP = 10 ,
12260 & LOUT = 6 ,
12261 & LDAT = 9 )
12262 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
454792a9 12263CPH SAVE
9aaba0d6 12264
12265 PARAMETER (
12266* lower cuts for (valence-sea/sea-valence) chain masses
12267* antiquark-quark (u/d-sea quark) (s-sea quark)
12268 & AMIU = 0.5D0, AMIS = 0.8D0,
12269* quark-diquark (u/d-sea quark) (s-sea quark)
12270 & AMAU = 2.6D0, AMAS = 2.6D0,
12271* maximum lower valence-x threshold
12272 & XVMAX = 0.98D0,
12273* fraction of sea-diquarks sampled out of sea-partons
12274**test
12275C & FRCDIQ = 0.9D0,
12276**
12277*
12278 & SQMA = 0.7D0,
12279*
12280* maximum number of trials to generate x's for the required number
12281* of sea quark pairs for a given hadron
12282 & NSEATY = 12
12283C & NSEATY = 3
12284 & )
12285
12286 LOGICAL ZUOVP,ZUOSP,ZUOVT,ZUOST,INTLO
12287
12288 PARAMETER ( MAXNCL = 260,
12289 & MAXVQU = MAXNCL,
12290 & MAXSQU = 20*MAXVQU,
12291 & MAXINT = MAXVQU+MAXSQU)
12292* event history
12293 PARAMETER (NMXHKK=200000)
12294 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
12295 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
12296 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
12297* particle properties (BAMJET index convention)
12298 CHARACTER*8 ANAME
12299 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12300 & IICH(210),IIBAR(210),K1(210),K2(210)
12301* interface between Glauber formalism and DPM
12302 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
12303 & INTER1(MAXINT),INTER2(MAXINT)
12304* properties of interacting particles
12305 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
12306* threshold values for x-sampling (DTUNUC 1.x)
12307 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
12308 & SSMIMQ,VVMTHR
12309* x-values of partons (DTUNUC 1.x)
12310 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
12311 & XTVQ(MAXVQU),XTVD(MAXVQU),
12312 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
12313 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
12314* flavors of partons (DTUNUC 1.x)
12315 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
12316 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
12317 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
12318 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
12319 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
12320 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
12321 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
12322* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12323 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
12324 & IXPV,IXPS,IXTV,IXTS,
12325 & INTVV1(MAXVQU),INTVV2(MAXVQU),
12326 & INTSV1(MAXVQU),INTSV2(MAXVQU),
12327 & INTVS1(MAXVQU),INTVS2(MAXVQU),
12328 & INTSS1(MAXSQU),INTSS2(MAXSQU),
12329 & INTDV1(MAXVQU),INTDV2(MAXVQU),
12330 & INTVD1(MAXVQU),INTVD2(MAXVQU),
12331 & INTDS1(MAXSQU),INTDS2(MAXSQU),
12332 & INTSD1(MAXSQU),INTSD2(MAXSQU)
12333* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12334 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
12335 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
12336* auxiliary common for chain system storage (DTUNUC 1.x)
12337 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
12338* flags for input different options
12339 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
12340 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
12341 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
12342* various options for treatment of partons (DTUNUC 1.x)
12343* (chain recombination, Cronin,..)
12344 LOGICAL LCO2CR,LINTPT
12345 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
12346 & LCO2CR,LINTPT
12347
12348 DIMENSION ZUOVP(MAXVQU),ZUOSP(MAXSQU),ZUOVT(MAXVQU),ZUOST(MAXSQU),
12349 & INTLO(MAXINT)
12350
12351* (1) initializations
12352*-----------------------------------------------------------------------
12353
12354**test
12355 IF (ECM.LT.4.5D0) THEN
12356C FRCDIQ = 0.6D0
12357 FRCDIQ = 0.4D0
12358 ELSEIF ((ECM.GE.4.5D0).AND.(ECM.LT.7.5)) THEN
12359C FRCDIQ = 0.6D0+(ECM-4.5D0)/3.0D0*0.3D0
12360 FRCDIQ = 0.4D0+(ECM-4.5D0)/3.0D0*0.3D0
12361 ELSE
12362C FRCDIQ = 0.9D0
12363 FRCDIQ = 0.7D0
12364 ENDIF
12365**
12366 DO 30 I=1,MAXSQU
12367 ZUOSP(I) = .FALSE.
12368 ZUOST(I) = .FALSE.
12369 IF (I.LE.MAXVQU) THEN
12370 ZUOVP(I) = .FALSE.
12371 ZUOVT(I) = .FALSE.
12372 ENDIF
12373 30 CONTINUE
12374
12375* lower thresholds for x-selection
12376* sea-quarks (default: CSEA=0.2)
12377 IF (ECM.LT.10.0D0) THEN
12378**!!test
12379 XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM
12380C XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM**2.0D0
12381 NSEA = NSEATY
12382C XSTHR = ONE/ECM**2
12383 ELSE
12384**sr 30.3.98
12385C XSTHR = CSEA/ECM
12386 XSTHR = CSEA/ECM**2
12387C XSTHR = ONE/ECM**2
12388**
12389 IF ((IP.GE.150).AND.(IT.GE.150))
12390 & XSTHR = 2.5D0/(ECM*SQRT(ECM))
12391 NSEA = NSEATY
12392 ENDIF
12393* (default: SSMIMA=0.14) used for sea-diquarks (?)
12394 XSSTHR = SSMIMA/ECM
12395 BSQMA = SQMA/ECM
12396* valence-quarks (default: CVQ=1.0)
12397 XVTHR = CVQ/ECM
12398* valence-diquarks (default: CDQ=2.0)
12399 XDTHR = CDQ/ECM
12400
12401* maximum-x for sea-quarks
12402 XVCUT = XVTHR+XDTHR
12403 IF (XVCUT.GT.XVMAX) THEN
12404 XVCUT = XVMAX
12405 XVTHR = XVCUT/3.0D0
12406 XDTHR = XVCUT-XVTHR
12407 ENDIF
12408 XXSEAM = ONE-XVCUT
12409**sr 18.4. test: DPMJET
12410C XXSEAM=1.0 - XVTHR*(1.D0+0.3D0*DT_RNDM(V1))
12411C & - XDTHR*(1.D0+0.3D0*DT_RNDM(V2))
12412C & -0.01*(1.D0+1.5D0*DT_RNDM(V3))
12413**
12414* maximum number of sea-pairs allowed kinematically
12415C NSMAX = INT(OHALF*XXSEAM/XSTHR)
12416 RNSMAX = OHALF*XXSEAM/XSTHR
12417 IF (RNSMAX.GT.10000.0D0) THEN
12418 NSMAX = 10000
12419 ELSE
12420 NSMAX = INT(OHALF*XXSEAM/XSTHR)
12421 ENDIF
12422* check kinematical limit for valence-x thresholds
12423* (should be obsolete now)
12424 IF (XVCUT.GT.XVMAX) THEN
12425 WRITE(LOUT,1000) XVCUT,ECM
12426 1000 FORMAT(' XKSAMP: kin. limit for valence-x',
12427 & ' thresholds not allowed (',2E9.3,')')
12428C XVTHR = XVMAX-XDTHR
12429C IF (XVTHR.LT.ZERO) STOP
12430 STOP
12431 ENDIF
12432
12433* set eta for valence-x sampling (BETREJ)
12434* (UNON per default, UNOM used for projectile mesons only)
12435 IF ((IJPROJ.NE.0).AND.(IBPROJ.EQ.0)) THEN
12436 UNOPRV = UNOM
12437 ELSE
12438 UNOPRV = UNON
12439 ENDIF
12440
12441* (2) select parton x-values of interacting projectile nucleons
12442*-----------------------------------------------------------------------
12443
12444 IXPV = 0
12445 IXPS = 0
12446
12447 DO 100 IPP=1,IP
12448* get interacting projectile nucleon as sampled by Glauber
12449 IF (JSSH(IPP).NE.0) THEN
12450 IXSTMP = IXPS
12451 IXVTMP = IXPV
12452 99 CONTINUE
12453 IXPS = IXSTMP
12454 IXPV = IXVTMP
12455* JIPP is the actual number of sea-pairs sampled for this nucleon
12456 JIPP = MIN(JSSH(IPP)-1,NSMAX)
12457 41 CONTINUE
12458 XXSEA = ZERO
12459 IF (JIPP.GT.0) THEN
12460 XSMAX = XXSEAM-2.0D0*DBLE(JIPP)*XSTHR
12461*???
12462 IF (XSTHR.GE.XSMAX) THEN
12463 JIPP = JIPP-1
12464 GOTO 41
12465 ENDIF
12466
12467*>>>get x-values of sea-quark pairs
12468 NSCOUN = 0
12469 PLW = 0.5D0
12470 40 CONTINUE
12471* accumulator for sea x-values
12472 XXSEA = ZERO
12473 NSCOUN = NSCOUN+1
12474 IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
12475 IF (NSCOUN.GT.NSEA) THEN
12476* decrease the number of interactions after NSEA trials
12477 JIPP = JIPP-1
12478 NSCOUN = 0
12479 ENDIF
12480 DO 70 ISQ=1,JIPP
12481* sea-quarks
12482 IF (IPSQ(IXPS+1).LE.2) THEN
12483**sr 8.4.98 (1/sqrt(x))
12484C XPSQI = DT_SAMPEX(XSTHR,XSMAX)
12485C XPSQI = DT_SAMSQX(XSTHR,XSMAX)
12486 XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12487**
12488 ELSE
12489 IF (XSMAX.GT.XSTHR+BSQMA) THEN
12490 XPSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12491 ELSE
12492**sr 8.4.98 (1/sqrt(x))
12493C XPSQI = DT_SAMPEX(XSTHR,XSMAX)
12494C XPSQI = DT_SAMSQX(XSTHR,XSMAX)
12495 XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12496**
12497 ENDIF
12498 ENDIF
12499* sea-antiquarks
12500 IF (IPSAQ(IXPS+1).GE.-2) THEN
12501**sr 8.4.98 (1/sqrt(x))
12502C XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
12503C XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
12504 XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12505**
12506 ELSE
12507 IF (XSMAX.GT.XSTHR+BSQMA) THEN
12508 XPSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12509 ELSE
12510**sr 8.4.98 (1/sqrt(x))
12511C XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
12512C XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
12513 XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12514**
12515 ENDIF
12516 ENDIF
12517 XXSEA = XXSEA+XPSQI+XPSAQI
12518* check for maximum allowed sea x-value
12519 IF (XXSEA.GE.XXSEAM) THEN
12520 IXPS = IXPS-ISQ+1
12521 GOTO 40
12522 ENDIF
12523* accept this sea-quark pair
12524 IXPS = IXPS+1
12525 XPSQ(IXPS) = XPSQI
12526 XPSAQ(IXPS) = XPSAQI
12527 IFROSP(IXPS) = IPP
12528 ZUOSP(IXPS) = .TRUE.
12529 70 CONTINUE
12530 ENDIF
12531
12532*>>>get x-values of valence partons
12533* valence quark
12534 IF (XVTHR.GT.0.05D0) THEN
12535 XVHI = ONE-XXSEA-XDTHR
12536 XPVQI = DT_BETREJ(OHALF,UNOPRV,XVTHR,XVHI)
12537 ELSE
12538 90 CONTINUE
12539 XPVQI = DT_DBETAR(OHALF,UNOPRV)
12540 IF ((XPVQI.LT.XVTHR).OR.(ONE-XPVQI-XXSEA.LT.XDTHR))
12541 & GOTO 90
12542 ENDIF
12543* valence diquark
12544 XPVDI = ONE-XPVQI-XXSEA
12545* reject according to x**1.5
12546 XDTMP = XPVDI**1.5D0
12547 IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 99
12548* accept these valence partons
12549 IXPV = IXPV+1
12550 XPVQ(IXPV) = XPVQI
12551 XPVD(IXPV) = XPVDI
12552 IFROVP(IXPV) = IPP
12553 ITOVP(IPP) = IXPV
12554 ZUOVP(IXPV) = .TRUE.
12555
12556 ENDIF
12557 100 CONTINUE
12558
12559* (3) select parton x-values of interacting target nucleons
12560*-----------------------------------------------------------------------
12561
12562 IXTV = 0
12563 IXTS = 0
12564
12565 DO 170 ITT=1,IT
12566* get interacting target nucleon as sampled by Glauber
12567 IF (JTSH(ITT).NE.0) THEN
12568 IXSTMP = IXTS
12569 IXVTMP = IXTV
12570 169 CONTINUE
12571 IXTS = IXSTMP
12572 IXTV = IXVTMP
12573* JITT is the actual number of sea-pairs sampled for this nucleon
12574 JITT = MIN(JTSH(ITT)-1,NSMAX)
12575 111 CONTINUE
12576 XXSEA = ZERO
12577 IF (JITT.GT.0) THEN
12578 XSMAX = XXSEAM-2.0D0*DBLE(JITT)*XSTHR
12579*???
12580 IF (XSTHR.GE.XSMAX) THEN
12581 JITT = JITT-1
12582 GOTO 111
12583 ENDIF
12584
12585*>>>get x-values of sea-quark pairs
12586 NSCOUN = 0
12587 PLW = 0.5D0
12588 110 CONTINUE
12589* accumulator for sea x-values
12590 XXSEA = ZERO
12591 NSCOUN = NSCOUN+1
12592 IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
12593 IF (NSCOUN.GT.NSEA)THEN
12594* decrease the number of interactions after NSEA trials
12595 JITT = JITT-1
12596 NSCOUN = 0
12597 ENDIF
12598 DO 140 ISQ=1,JITT
12599* sea-quarks
12600 IF (ITSQ(IXTS+1).LE.2) THEN
12601**sr 8.4.98 (1/sqrt(x))
12602C XTSQI = DT_SAMPEX(XSTHR,XSMAX)
12603C XTSQI = DT_SAMSQX(XSTHR,XSMAX)
12604 XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12605**
12606 ELSE
12607 IF (XSMAX.GT.XSTHR+BSQMA) THEN
12608 XTSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12609 ELSE
12610**sr 8.4.98 (1/sqrt(x))
12611C XTSQI = DT_SAMPEX(XSTHR,XSMAX)
12612C XTSQI = DT_SAMSQX(XSTHR,XSMAX)
12613 XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12614**
12615 ENDIF
12616 ENDIF
12617* sea-antiquarks
12618 IF (ITSAQ(IXTS+1).GE.-2) THEN
12619**sr 8.4.98 (1/sqrt(x))
12620C XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
12621C XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
12622 XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12623**
12624 ELSE
12625 IF (XSMAX.GT.XSTHR+BSQMA) THEN
12626 XTSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12627 ELSE
12628**sr 8.4.98 (1/sqrt(x))
12629C XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
12630C XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
12631 XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12632**
12633 ENDIF
12634 ENDIF
12635 XXSEA = XXSEA+XTSQI+XTSAQI
12636* check for maximum allowed sea x-value
12637 IF (XXSEA.GE.XXSEAM) THEN
12638 IXTS = IXTS-ISQ+1
12639 GOTO 110
12640 ENDIF
12641* accept this sea-quark pair
12642 IXTS = IXTS+1
12643 XTSQ(IXTS) = XTSQI
12644 XTSAQ(IXTS) = XTSAQI
12645 IFROST(IXTS) = ITT
12646 ZUOST(IXTS) = .TRUE.
12647 140 CONTINUE
12648 ENDIF
12649
12650*>>>get x-values of valence partons
12651* valence quark
12652 IF (XVTHR.GT.0.05D0) THEN
12653 XVHI = ONE-XXSEA-XDTHR
12654 XTVQI = DT_BETREJ(OHALF,UNON,XVTHR,XVHI)
12655 ELSE
12656 160 CONTINUE
12657 XTVQI = DT_DBETAR(OHALF,UNON)
12658 IF ((XTVQI.LT.XVTHR).OR.(ONE-XTVQI-XXSEA.LT.XDTHR))
12659 & GOTO 160
12660 ENDIF
12661* valence diquark
12662 XTVDI = ONE-XTVQI-XXSEA
12663* reject according to x**1.5
12664 XDTMP = XTVDI**1.5D0
12665 IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 169
12666* accept these valence partons
12667 IXTV = IXTV+1
12668 XTVQ(IXTV) = XTVQI
12669 XTVD(IXTV) = XTVDI
12670 IFROVT(IXTV) = ITT
12671 ITOVT(ITT) = IXTV
12672 ZUOVT(IXTV) = .TRUE.
12673
12674 ENDIF
12675 170 CONTINUE
12676
12677* (4) get valence-valence chains
12678*-----------------------------------------------------------------------
12679
12680 NVV = 0
12681 DO 240 I=1,NN
12682 INTLO(I) = .TRUE.
12683 IPVAL = ITOVP(INTER1(I))
12684 ITVAL = ITOVT(INTER2(I))
12685 IF (ZUOVP(IPVAL).AND.ZUOVT(ITVAL)) THEN
12686 INTLO(I) = .FALSE.
12687 ZUOVP(IPVAL) = .FALSE.
12688 ZUOVT(ITVAL) = .FALSE.
12689 NVV = NVV+1
12690 ISKPCH(8,NVV) = 0
12691 INTVV1(NVV) = IPVAL
12692 INTVV2(NVV) = ITVAL
12693 ENDIF
12694 240 CONTINUE
12695
12696* (5) get sea-valence chains
12697*-----------------------------------------------------------------------
12698
12699 NSV = 0
12700 NDV = 0
12701 PLW = 0.5D0
12702 DO 270 I=1,NN
12703 IF (INTLO(I)) THEN
12704 IPVAL = ITOVP(INTER1(I))
12705 ITVAL = ITOVT(INTER2(I))
12706 DO 250 J=1,IXPS
12707 IF (ZUOSP(J).AND.(IFROSP(J).EQ.INTER1(I)).AND.
12708 & ZUOVT(ITVAL)) THEN
12709 ZUOSP(J) = .FALSE.
12710 ZUOVT(ITVAL) = .FALSE.
12711 INTLO(I) = .FALSE.
12712 IF (LSEADI.AND.(DT_RNDM(PLW).GT.FRCDIQ)) THEN
12713* sample sea-diquark pair
12714 CALL DT_SAMSDQ(ECM,ITVAL,J,2,IREJ1)
12715 IF (IREJ1.EQ.0) GOTO 260
12716 ENDIF
12717 NSV = NSV+1
12718 ISKPCH(4,NSV) = 0
12719 INTSV1(NSV) = J
12720 INTSV2(NSV) = ITVAL
12721
12722*>>>correct chain kinematics according to minimum chain masses
12723* the actual chain masses
12724 AMSVQ1 = XPSQ(J) *XTVD(ITVAL)*ECM**2
12725 AMSVQ2 = XPSAQ(J)*XTVQ(ITVAL)*ECM**2
12726* get lower mass cuts
12727 IF (IPSQ(J).EQ.3) THEN
12728* q being s-quark
12729 AMCHK1 = AMAS
12730 AMCHK2 = AMIS
12731 ELSE
12732* q being u/d-quark
12733 AMCHK1 = AMAU
12734 AMCHK2 = AMIU
12735 ENDIF
12736* q-qq chain
12737* chain mass above minimum - resampling of sea-q x-value
12738 IF (AMSVQ1.GT.AMCHK1) THEN
12739 XPSQTH = AMCHK1/(XTVD(ITVAL)*ECM**2)
12740**sr 8.4.98 (1/sqrt(x))
12741C XPSQXX = DT_SAMPEX(XPSQTH,XPSQ(J))
12742C XPSQXX = DT_SAMSQX(XPSQTH,XPSQ(J))
12743 XPSQXX = DT_SAMPLW(XPSQTH,XPSQ(J),PLW)
12744**
12745 XPVD(IPVAL) = XPVD(IPVAL)+XPSQ(J)-XPSQXX
12746 XPSQ(J) = XPSQXX
12747* chain mass below minimum - reset sea-q x-value and correct
12748* diquark-x of the same nucleon
12749 ELSEIF (AMSVQ1.LT.AMCHK1) THEN
12750 XPSQW = AMCHK1/(XTVD(ITVAL)*ECM**2)
12751 DXPSQ = XPSQW-XPSQ(J)
12752 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
12753 XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
12754 XPSQ(J) = XPSQW
12755 ENDIF
12756 ENDIF
12757* aq-q chain
12758* chain mass below minimum - reset sea-aq x-value and correct
12759* diquark-x of the same nucleon
12760 IF (AMSVQ2.LT.AMCHK2) THEN
12761 XPSQW = AMCHK2/(XTVQ(ITVAL)*ECM**2)
12762 DXPSQ = XPSQW-XPSAQ(J)
12763 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
12764 XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
12765 XPSAQ(J) = XPSQW
12766 ENDIF
12767 ENDIF
12768*>>>end of chain mass correction
12769
12770 GOTO 260
12771 ENDIF
12772 250 CONTINUE
12773 ENDIF
12774 260 CONTINUE
12775 270 CONTINUE
12776
12777* (6) get valence-sea chains
12778*-----------------------------------------------------------------------
12779
12780 NVS = 0
12781 NVD = 0
12782 DO 300 I=1,NN
12783 IF (INTLO(I)) THEN
12784 IPVAL = ITOVP(INTER1(I))
12785 ITVAL = ITOVT(INTER2(I))
12786 DO 280 J=1,IXTS
12787 IF (ZUOVP(IPVAL).AND.ZUOST(J).AND.
12788 & (IFROST(J).EQ.INTER2(I))) THEN
12789 ZUOST(J) = .FALSE.
12790 ZUOVP(IPVAL) = .FALSE.
12791 INTLO(I) = .FALSE.
12792 IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
12793* sample sea-diquark pair
12794 CALL DT_SAMSDQ(ECM,IPVAL,J,1,IREJ1)
12795 IF (IREJ1.EQ.0) GOTO 290
12796 ENDIF
12797 NVS = NVS + 1
12798 ISKPCH(6,NVS) = 0
12799 INTVS1(NVS) = IPVAL
12800 INTVS2(NVS) = J
12801
12802*>>>correct chain kinematics according to minimum chain masses
12803* the actual chain masses
12804 AMVSQ1 = XPVQ(IPVAL)*XTSAQ(J)*ECM**2
12805 AMVSQ2 = XPVD(IPVAL)*XTSQ(J) *ECM**2
12806* get lower mass cuts
12807 IF (ITSQ(J).EQ.3) THEN
12808* q being s-quark
12809 AMCHK1 = AMIS
12810 AMCHK2 = AMAS
12811 ELSE
12812* q being u/d-quark
12813 AMCHK1 = AMIU
12814 AMCHK2 = AMAU
12815 ENDIF
12816* q-aq chain
12817* chain mass below minimum - reset sea-aq x-value and correct
12818* diquark-x of the same nucleon
12819 IF (AMVSQ1.LT.AMCHK1) THEN
12820 XTSQW = AMCHK1/(XPVQ(IPVAL)*ECM**2)
12821 DXTSQ = XTSQW-XTSAQ(J)
12822 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
12823 XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
12824 XTSAQ(J) = XTSQW
12825 ENDIF
12826 ENDIF
12827* qq-q chain
12828* chain mass above minimum - resampling of sea-q x-value
12829 IF (AMVSQ2.GT.AMCHK2) THEN
12830 XTSQTH = AMCHK2/(XPVD(IPVAL)*ECM**2)
12831**sr 8.4.98 (1/sqrt(x))
12832C XTSQXX = DT_SAMPEX(XTSQTH,XTSQ(J))
12833C XTSQXX = DT_SAMSQX(XTSQTH,XTSQ(J))
12834 XTSQXX = DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
12835**
12836 XTVD(ITVAL) = XTVD(ITVAL)+XTSQ(J)-XTSQXX
12837 XTSQ(J) = XTSQXX
12838* chain mass below minimum - reset sea-q x-value and correct
12839* diquark-x of the same nucleon
12840 ELSEIF (AMVSQ2.LT.AMCHK2) THEN
12841 XTSQW = AMCHK2/(XPVD(IPVAL)*ECM**2)
12842 DXTSQ = XTSQW-XTSQ(J)
12843 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
12844 XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
12845 XTSQ(J) = XTSQW
12846 ENDIF
12847 ENDIF
12848*>>>end of chain mass correction
12849
12850 GOTO 290
12851 ENDIF
12852 280 CONTINUE
12853 ENDIF
12854 290 CONTINUE
12855 300 CONTINUE
12856
12857* (7) get sea-sea chains
12858*-----------------------------------------------------------------------
12859
12860 NSS = 0
12861 NDS = 0
12862 NSD = 0
12863 DO 420 I=1,NN
12864 IF (INTLO(I)) THEN
12865 IPVAL = ITOVP(INTER1(I))
12866 ITVAL = ITOVT(INTER2(I))
12867* loop over target partons not yet matched
12868 DO 400 J=1,IXTS
12869 IF (ZUOST(J).AND.(IFROST(J).EQ.INTER2(I))) THEN
12870* loop over projectile partons not yet matched
12871 DO 390 JJ=1,IXPS
12872 IF (ZUOSP(JJ).AND.(IFROSP(JJ).EQ.INTER1(I))) THEN
12873 ZUOSP(JJ) = .FALSE.
12874 ZUOST(J) = .FALSE.
12875 INTLO(I) = .FALSE.
12876 NSS = NSS+1
12877 ISKPCH(1,NSS) = 0
12878 INTSS1(NSS) = JJ
12879 INTSS2(NSS) = J
12880
12881*---->chain recombination option
12882 VALFRA = DBLE(NVV/(NVV+IXPS+IXTS))
12883 IF (IRECOM.EQ.1.AND.(DT_RNDM(BSQMA).GT.VALFRA))
12884 & THEN
12885* sea-sea chains may recombine with valence-valence chains
12886* only if they have the same projectile or target nucleon
12887 DO 4201 IVV=1,NVV
12888 IF (ISKPCH(8,IVV).NE.99) THEN
12889 IXVPR = INTVV1(IVV)
12890 IXVTA = INTVV2(IVV)
12891 IF ((INTER1(I).EQ.IFROVP(IXVPR)).OR.
12892 & (INTER2(I).EQ.IFROVT(IXVTA))) THEN
12893* recombination possible, drop old v-v and s-s chains
12894 ISKPCH(1,NSS) = 99
12895 ISKPCH(8,IVV) = 99
12896
12897* (a) assign new s-v chains
12898* ~~~~~~~~~~~~~~~~~~~~~~~~~
12899 IF (LSEADI.AND.
12900 & (DT_RNDM(VALFRA).GT.FRCDIQ))
12901 & THEN
12902* sample sea-diquark pair
12903 CALL DT_SAMSDQ(ECM,IXVTA,JJ,2,
12904 & IREJ1)
12905 IF (IREJ1.EQ.0) GOTO 4202
12906 ENDIF
12907 NSV = NSV+1
12908 ISKPCH(4,NSV) = 0
12909 INTSV1(NSV) = JJ
12910 INTSV2(NSV) = IXVTA
12911*>>>>>>>>>>>correct chain kinematics according to minimum chain masses
12912* the actual chain masses
12913 AMSVQ1 = XPSQ(JJ) *XTVD(IXVTA)
12914 & *ECM**2
12915 AMSVQ2 = XPSAQ(JJ)*XTVQ(IXVTA)
12916 & *ECM**2
12917* get lower mass cuts
12918 IF (IPSQ(JJ).EQ.3) THEN
12919* q being s-quark
12920 AMCHK1 = AMAS
12921 AMCHK2 = AMIS
12922 ELSE
12923* q being u/d-quark
12924 AMCHK1 = AMAU
12925 AMCHK2 = AMIU
12926 ENDIF
12927* q-qq chain
12928* chain mass above minimum - resampling of sea-q x-value
12929 IF (AMSVQ1.GT.AMCHK1) THEN
12930 XPSQTH =
12931 & AMCHK1/(XTVD(IXVTA)*ECM**2)
12932**sr 8.4.98 (1/sqrt(x))
12933 XPSQXX =
12934 & DT_SAMPLW(XPSQTH,XPSQ(JJ),PLW)
12935C & DT_SAMSQX(XPSQTH,XPSQ(JJ))
12936C & DT_SAMPEX(XPSQTH,XPSQ(JJ))
12937**
12938 XPVD(IPVAL) =
12939 & XPVD(IPVAL)+XPSQ(JJ)-XPSQXX
12940 XPSQ(JJ) = XPSQXX
12941* chain mass below minimum - reset sea-q x-value and correct
12942* diquark-x of the same nucleon
12943 ELSEIF (AMSVQ1.LT.AMCHK1) THEN
12944 XPSQW =
12945 & AMCHK1/(XTVD(IXVTA)*ECM**2)
12946 DXPSQ = XPSQW-XPSQ(JJ)
12947 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
12948 & THEN
12949 XPVD(IPVAL) =
12950 & XPVD(IPVAL)-DXPSQ
12951 XPSQ(JJ) = XPSQW
12952 ENDIF
12953 ENDIF
12954* aq-q chain
12955* chain mass below minimum - reset sea-aq x-value and correct
12956* diquark-x of the same nucleon
12957 IF (AMSVQ2.LT.AMCHK2) THEN
12958 XPSQW =
12959 & AMCHK2/(XTVQ(IXVTA)*ECM**2)
12960 DXPSQ = XPSQW-XPSAQ(JJ)
12961 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
12962 & THEN
12963 XPVD(IPVAL) =
12964 & XPVD(IPVAL)-DXPSQ
12965 XPSAQ(JJ) = XPSQW
12966 ENDIF
12967 ENDIF
12968*>>>>>>>>>>>end of chain mass correction
12969 4202 CONTINUE
12970
12971* (b) assign new v-s chains
12972* ~~~~~~~~~~~~~~~~~~~~~~~~~
12973 IF (LSEADI.AND.(
12974 & DT_RNDM(AMSVQ2).GT.FRCDIQ))
12975 & THEN
12976* sample sea-diquark pair
12977 CALL DT_SAMSDQ(ECM,IXVPR,J,1,
12978 & IREJ1)
12979 IF (IREJ1.EQ.0) GOTO 4203
12980 ENDIF
12981 NVS = NVS+1
12982 ISKPCH(6,NVS) = 0
12983 INTVS1(NVS) = IXVPR
12984 INTVS2(NVS) = J
12985*>>>>>>>>>>>correct chain kinematics according to minimum chain masses
12986* the actual chain masses
12987 AMVSQ1 = XPVQ(IXVPR)*XTSAQ(J)*ECM**2
12988 AMVSQ2 = XPVD(IXVPR)*XTSQ(J) *ECM**2
12989* get lower mass cuts
12990 IF (ITSQ(J).EQ.3) THEN
12991* q being s-quark
12992 AMCHK1 = AMIS
12993 AMCHK2 = AMAS
12994 ELSE
12995* q being u/d-quark
12996 AMCHK1 = AMIU
12997 AMCHK2 = AMAU
12998 ENDIF
12999* q-aq chain
13000* chain mass below minimum - reset sea-aq x-value and correct
13001* diquark-x of the same nucleon
13002 IF (AMVSQ1.LT.AMCHK1) THEN
13003 XTSQW =
13004 & AMCHK1/(XPVQ(IXVPR)*ECM**2)
13005 DXTSQ = XTSQW-XTSAQ(J)
13006 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13007 & THEN
13008 XTVD(ITVAL) =
13009 & XTVD(ITVAL)-DXTSQ
13010 XTSAQ(J) = XTSQW
13011 ENDIF
13012 ENDIF
13013 IF (AMVSQ2.GT.AMCHK2) THEN
13014 XTSQTH =
13015 & AMCHK2/(XPVD(IXVPR)*ECM**2)
13016**sr 8.4.98 (1/sqrt(x))
13017 XTSQXX =
13018 & DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
13019C & DT_SAMSQX(XTSQTH,XTSQ(J))
13020C & DT_SAMPEX(XTSQTH,XTSQ(J))
13021**
13022 XTVD(ITVAL) =
13023 & XTVD(ITVAL)+XTSQ(J)-XTSQXX
13024 XTSQ(J) = XTSQXX
13025 ELSEIF (AMVSQ2.LT.AMCHK2) THEN
13026 XTSQW =
13027 & AMCHK2/(XPVD(IXVPR)*ECM**2)
13028 DXTSQ = XTSQW-XTSQ(J)
13029 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13030 & THEN
13031 XTVD(ITVAL) =
13032 & XTVD(ITVAL)-DXTSQ
13033 XTSQ(J) = XTSQW
13034 ENDIF
13035 ENDIF
13036*>>>>>>>>>end of chain mass correction
13037 4203 CONTINUE
13038* jump out of s-s chain loop
13039 GOTO 420
13040 ENDIF
13041 ENDIF
13042 4201 CONTINUE
13043 ENDIF
13044*---->end of chain recombination option
13045
13046* sample sea-diquark pair (projectile)
13047 IF (LSEADI.AND.(DT_RNDM(BSQMA).GT.FRCDIQ)) THEN
13048 CALL DT_SAMSDQ(ECM,J,JJ,4,IREJ1)
13049 IF (IREJ1.EQ.0) THEN
13050 ISKPCH(1,NSS) = 99
13051 GOTO 410
13052 ENDIF
13053 ENDIF
13054* sample sea-diquark pair (target)
13055 IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
13056 CALL DT_SAMSDQ(ECM,JJ,J,3,IREJ1)
13057 IF (IREJ1.EQ.0) THEN
13058 ISKPCH(1,NSS) = 99
13059 GOTO 410
13060 ENDIF
13061 ENDIF
13062*>>>>>correct chain kinematics according to minimum chain masses
13063* the actual chain masses
13064 SSMA1Q = XPSQ(JJ) *XTSAQ(J)*ECM**2
13065 SSMA2Q = XPSAQ(JJ)*XTSQ(J) *ECM**2
13066* check for lower mass cuts
13067 IF ((SSMA1Q.LT.SSMIMQ).OR.
13068 & (SSMA2Q.LT.SSMIMQ)) THEN
13069 IPVAL = ITOVP(INTER1(I))
13070 ITVAL = ITOVT(INTER2(I))
13071 IF ((XPVD(IPVAL).GT.XDTHR+3.5D0*XSSTHR).AND.
13072 & (XTVD(ITVAL).GT.XDTHR+3.5D0*XSSTHR))THEN
13073* maximum allowed x values for sea quarks
13074 XSPMAX = ONE-XPVQ(IPVAL)-XDTHR-
13075 & 1.2D0*XSSTHR
13076 XSTMAX = ONE-XTVQ(ITVAL)-XDTHR-
13077 & 1.2D0*XSSTHR
13078* resampling of x values not possible - skip sea-sea chains
13079 IF ((XSPMAX.LE.XSSTHR+0.05D0).OR.
13080 & (XSTMAX.LE.XSSTHR+0.05D0)) GOTO 380
13081* resampling of x for projectile sea quark pair
13082 ICOUS = 0
13083 310 CONTINUE
13084 ICOUS = ICOUS+1
13085 IF (XSSTHR.GT.0.05D0) THEN
13086 XPSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13087 & XSPMAX)
13088 XPSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13089 & XSPMAX)
13090 ELSE
13091 320 CONTINUE
13092 XPSQI = DT_DBETAR(XSEACU,UNOSEA)
13093 IF ((XPSQI.LT.XSSTHR).OR.
13094 & (XPSQI.GT.XSPMAX)) GOTO 320
13095 330 CONTINUE
13096 XPSAQI = DT_DBETAR(XSEACU,UNOSEA)
13097 IF ((XPSAQI.LT.XSSTHR).OR.
13098 & (XPSAQI.GT.XSPMAX)) GOTO 330
13099 ENDIF
13100* final test of remaining x for projectile diquark
13101 XPVDCO = XPVD(IPVAL)-XPSQI-XPSAQI
13102 & +XPSQ(JJ)+XPSAQ(JJ)
13103 IF (XPVDCO.LE.XDTHR) THEN
13104*!!!
13105C IF (ICOUS.LT.5) GOTO 310
13106 IF (ICOUS.LT.0.5D0) GOTO 310
13107 GOTO 380
13108 ENDIF
13109* resampling of x for target sea quark pair
13110 ICOUS = 0
13111 350 CONTINUE
13112 ICOUS = ICOUS+1
13113 IF (XSSTHR.GT.0.05D0) THEN
13114 XTSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13115 & XSTMAX)
13116 XTSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13117 & XSTMAX)
13118 ELSE
13119 360 CONTINUE
13120 XTSQI = DT_DBETAR(XSEACU,UNOSEA)
13121 IF ((XTSQI.LT.XSSTHR).OR.
13122 & (XTSQI.GT.XSTMAX)) GOTO 360
13123 370 CONTINUE
13124 XTSAQI = DT_DBETAR(XSEACU,UNOSEA)
13125 IF ((XTSAQI.LT.XSSTHR).OR.
13126 & (XTSAQI.GT.XSTMAX)) GOTO 370
13127 ENDIF
13128* final test of remaining x for target diquark
13129 XTVDCO = XTVD(ITVAL)-XTSQI-XTSAQI
13130 & +XTSQ(J)+XTSAQ(J)
13131 IF (XTVDCO.LT.XDTHR) THEN
13132 IF (ICOUS.LT.5) GOTO 350
13133 GOTO 380
13134 ENDIF
13135 XPVD(IPVAL) = XPVDCO
13136 XTVD(ITVAL) = XTVDCO
13137 XPSQ(JJ) = XPSQI
13138 XPSAQ(JJ) = XPSAQI
13139 XTSQ(J) = XTSQI
13140 XTSAQ(J) = XTSAQI
13141*>>>>>end of chain mass correction
13142 GOTO 410
13143 ENDIF
13144* come here to discard s-s interaction
13145* resampling of x values not allowed or unsuccessful
13146 380 CONTINUE
13147 INTLO(I) = .FALSE.
13148 ZUOST(J) = .TRUE.
13149 ZUOSP(JJ) = .TRUE.
13150 NSS = NSS-1
13151 ENDIF
13152* consider next s-s interaction
13153 GOTO 410
13154 ENDIF
13155 390 CONTINUE
13156 ENDIF
13157 400 CONTINUE
13158 ENDIF
13159 410 CONTINUE
13160 420 CONTINUE
13161
13162* correct x-values of valence quarks for non-matching sea quarks
13163 DO 430 I=1,IXPS
13164 IF (ZUOSP(I)) THEN
13165 IPVAL = ITOVP(IFROSP(I))
13166 XPVQ(IPVAL) = XPVQ(IPVAL)+XPSQ(I)+XPSAQ(I)
13167 XPSQ(I) = ZERO
13168 XPSAQ(I) = ZERO
13169 ZUOSP(I) = .FALSE.
13170 ENDIF
13171 430 CONTINUE
13172 DO 440 I=1,IXTS
13173 IF (ZUOST(I)) THEN
13174 ITVAL = ITOVT(IFROST(I))
13175 XTVQ(ITVAL) = XTVQ(ITVAL)+XTSQ(I)+XTSAQ(I)
13176 XTSQ(I) = ZERO
13177 XTSAQ(I) = ZERO
13178 ZUOST(I) = .FALSE.
13179 ENDIF
13180 440 CONTINUE
13181 DO 450 I=1,IXPV
13182 IF (ZUOVP(I)) ISTHKK(IFROVP(I)) = 13
13183 450 CONTINUE
13184 DO 460 I=1,IXTV
13185 IF (ZUOVT(I)) ISTHKK(IFROVT(I)+IP) = 14
13186 460 CONTINUE
13187
13188 RETURN
13189 END
13190
13191*$ CREATE DT_SAMSDQ.FOR
13192*COPY DT_SAMSDQ
13193*
13194*===samsdq=============================================================*
13195*
13196 SUBROUTINE DT_SAMSDQ(ECM,IDX1,IDX2,MODE,IREJ)
13197
13198************************************************************************
13199* SAMpling of Sea-DiQuarks *
13200* ECM cm-energy of the nucleon-nucleon system *
13201* IDX1,2 indices of x-values of the participating *
13202* partons (IDX2 is always the sea-q-pair to be *
13203* changed to sea-qq-pair) *
13204* MODE = 1 valence-q - sea-diq *
13205* = 2 sea-diq - valence-q *
13206* = 3 sea-q - sea-diq *
13207* = 4 sea-diq - sea-q *
13208* Based on DIQVS, DIQSV, DIQSSD, DIQDSS. *
13209* This version dated 17.10.95 is written by S. Roesler *
13210************************************************************************
13211
13212 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13213 SAVE
13214
13215 PARAMETER (ZERO=0.0D0)
13216
13217* threshold values for x-sampling (DTUNUC 1.x)
13218 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
13219 & SSMIMQ,VVMTHR
13220* various options for treatment of partons (DTUNUC 1.x)
13221* (chain recombination, Cronin,..)
13222 LOGICAL LCO2CR,LINTPT
13223 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
13224 & LCO2CR,LINTPT
13225 PARAMETER ( MAXNCL = 260,
13226 & MAXVQU = MAXNCL,
13227 & MAXSQU = 20*MAXVQU,
13228 & MAXINT = MAXVQU+MAXSQU)
13229* x-values of partons (DTUNUC 1.x)
13230 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
13231 & XTVQ(MAXVQU),XTVD(MAXVQU),
13232 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
13233 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
13234* flavors of partons (DTUNUC 1.x)
13235 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
13236 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
13237 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
13238 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
13239 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
13240 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
13241 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
13242* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13243 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
13244 & IXPV,IXPS,IXTV,IXTS,
13245 & INTVV1(MAXVQU),INTVV2(MAXVQU),
13246 & INTSV1(MAXVQU),INTSV2(MAXVQU),
13247 & INTVS1(MAXVQU),INTVS2(MAXVQU),
13248 & INTSS1(MAXSQU),INTSS2(MAXSQU),
13249 & INTDV1(MAXVQU),INTDV2(MAXVQU),
13250 & INTVD1(MAXVQU),INTVD2(MAXVQU),
13251 & INTDS1(MAXSQU),INTDS2(MAXSQU),
13252 & INTSD1(MAXSQU),INTSD2(MAXSQU)
13253* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13254 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
13255 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
13256* auxiliary common for chain system storage (DTUNUC 1.x)
13257 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
13258
13259 IREJ = 0
13260* threshold-x for valence diquarks
13261 XDTHR = CDQ/ECM
13262
13263 GOTO (1,2,3,4) MODE
13264
13265*---------------------------------------------------------------------
13266* proj. valence partons - targ. sea partons
13267* get x-values and flavors for target sea-diquark pair
13268
13269 1 CONTINUE
13270 IDXVP = IDX1
13271 IDXST = IDX2
13272
13273* index of corr. val-diquark-x in target nucleon
13274 IDXVT = ITOVT(IFROST(IDXST))
13275* available x above diquark thresholds for valence- and sea-diquarks
13276 XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13277
13278 IF (XXD.GE.ZERO) THEN
13279* x-values for the three diquarks of the target nucleon
13280 RR1 = DT_RNDM(XXD)
13281 RR2 = DT_RNDM(RR1)
13282 RR3 = DT_RNDM(RR2)
13283 SR123 = RR1+RR2+RR3
13284 XXTV = XDTHR+RR1*XXD/SR123
13285 XXTSQ = XDTHR+RR2*XXD/SR123
13286 XXTSAQ = XDTHR+RR3*XXD/SR123
13287 ELSE
13288 XXTV = XTVD(IDXVT)
13289 XXTSQ = XTSQ(IDXST)
13290 XXTSAQ = XTSAQ(IDXST)
13291 ENDIF
13292* flavor of the second quarks in the sea-diquark pair
13293 ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13294 ITSAQ2(IDXST) = -ITSQ2(IDXST)
13295* check masses of the new val-q - sea-qq, val-qq - sea-aqaq chains
13296 AM1 = XXTSQ *XPVQ(IDXVP)*ECM**2
13297 AM2 = XXTSAQ*XPVD(IDXVP)*ECM**2
13298 IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13299* ss-asas pair
13300 & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN
13301 IREJ = 1
13302 RETURN
13303 ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13304* at least one strange quark
13305 & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN
13306 IREJ = 1
13307 RETURN
13308 ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13309 IREJ = 1
13310 RETURN
13311 ENDIF
13312* accept the new sea-diquark
13313 XTVD(IDXVT) = XXTV
13314 XTSQ(IDXST) = XXTSQ
13315 XTSAQ(IDXST) = XXTSAQ
13316 NVD = NVD+1
13317 INTVD1(NVD) = IDXVP
13318 INTVD2(NVD) = IDXST
13319 ISKPCH(7,NVD) = 0
13320 RETURN
13321
13322*---------------------------------------------------------------------
13323* proj. sea partons - targ. valence partons
13324* get x-values and flavors for projectile sea-diquark pair
13325
13326 2 CONTINUE
13327 IDXSP = IDX2
13328 IDXVT = IDX1
13329
13330* index of corr. val-diquark-x in projectile nucleon
13331 IDXVP = ITOVP(IFROSP(IDXSP))
13332* available x above diquark thresholds for valence- and sea-diquarks
13333 XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13334
13335 IF (XXD.GE.ZERO) THEN
13336* x-values for the three diquarks of the projectile nucleon
13337 RR1 = DT_RNDM(XXD)
13338 RR2 = DT_RNDM(RR1)
13339 RR3 = DT_RNDM(RR2)
13340 SR123 = RR1+RR2+RR3
13341 XXPV = XDTHR+RR1*XXD/SR123
13342 XXPSQ = XDTHR+RR2*XXD/SR123
13343 XXPSAQ = XDTHR+RR3*XXD/SR123
13344 ELSE
13345 XXPV = XPVD(IDXVP)
13346 XXPSQ = XPSQ(IDXSP)
13347 XXPSAQ = XPSAQ(IDXSP)
13348 ENDIF
13349* flavor of the second quarks in the sea-diquark pair
13350 IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13351 IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13352* check masses of the new sea-qq - val-q, sea-aqaq - val-qq chains
13353 AM1 = XXPSQ *XTVQ(IDXVT)*ECM**2
13354 AM2 = XXPSAQ*XTVD(IDXVT)*ECM**2
13355 IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13356* ss-asas pair
13357 & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN
13358 IREJ = 1
13359 RETURN
13360 ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13361* at least one strange quark
13362 & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN
13363 IREJ = 1
13364 RETURN
13365 ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13366 IREJ = 1
13367 RETURN
13368 ENDIF
13369* accept the new sea-diquark
13370 XPVD(IDXVP) = XXPV
13371 XPSQ(IDXSP) = XXPSQ
13372 XPSAQ(IDXSP) = XXPSAQ
13373 NDV = NDV+1
13374 INTDV1(NDV) = IDXSP
13375 INTDV2(NDV) = IDXVT
13376 ISKPCH(5,NDV) = 0
13377 RETURN
13378
13379*---------------------------------------------------------------------
13380* proj. sea partons - targ. sea partons
13381* get x-values and flavors for target sea-diquark pair
13382
13383 3 CONTINUE
13384 IDXSP = IDX1
13385 IDXST = IDX2
13386
13387* index of corr. val-diquark-x in target nucleon
13388 IDXVT = ITOVT(IFROST(IDXST))
13389* available x above diquark thresholds for valence- and sea-diquarks
13390 XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13391
13392 IF (XXD.GE.ZERO) THEN
13393* x-values for the three diquarks of the target nucleon
13394 RR1 = DT_RNDM(XXD)
13395 RR2 = DT_RNDM(RR1)
13396 RR3 = DT_RNDM(RR2)
13397 SR123 = RR1+RR2+RR3
13398 XXTV = XDTHR+RR1*XXD/SR123
13399 XXTSQ = XDTHR+RR2*XXD/SR123
13400 XXTSAQ = XDTHR+RR3*XXD/SR123
13401 ELSE
13402 XXTV = XTVD(IDXVT)
13403 XXTSQ = XTSQ(IDXST)
13404 XXTSAQ = XTSAQ(IDXST)
13405 ENDIF
13406* flavor of the second quarks in the sea-diquark pair
13407 ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13408 ITSAQ2(IDXST) = -ITSQ2(IDXST)
13409* check masses of the new sea-q - sea-qq, sea-aq - sea-aqaq chains
13410 AM1 = XXTSQ *XPSQ(IDXSP)*ECM**2
13411 AM2 = XXTSAQ*XPSAQ(IDXSP)*ECM**2
13412 IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13413* ss-asas pair
13414 & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN
13415 IREJ = 1
13416 RETURN
13417 ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13418* at least one strange quark
13419 & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN
13420 IREJ = 1
13421 RETURN
13422 ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
13423 IREJ = 1
13424 RETURN
13425 ENDIF
13426* accept the new sea-diquark
13427 XTVD(IDXVT) = XXTV
13428 XTSQ(IDXST) = XXTSQ
13429 XTSAQ(IDXST) = XXTSAQ
13430 NSD = NSD+1
13431 INTSD1(NSD) = IDXSP
13432 INTSD2(NSD) = IDXST
13433 ISKPCH(3,NSD) = 0
13434 RETURN
13435
13436*---------------------------------------------------------------------
13437* proj. sea partons - targ. sea partons
13438* get x-values and flavors for projectile sea-diquark pair
13439
13440 4 CONTINUE
13441 IDXSP = IDX2
13442 IDXST = IDX1
13443
13444* index of corr. val-diquark-x in projectile nucleon
13445 IDXVP = ITOVP(IFROSP(IDXSP))
13446* available x above diquark thresholds for valence- and sea-diquarks
13447 XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13448
13449 IF (XXD.GE.ZERO) THEN
13450* x-values for the three diquarks of the projectile nucleon
13451 RR1 = DT_RNDM(XXD)
13452 RR2 = DT_RNDM(RR1)
13453 RR3 = DT_RNDM(RR2)
13454 SR123 = RR1+RR2+RR3
13455 XXPV = XDTHR+RR1*XXD/SR123
13456 XXPSQ = XDTHR+RR2*XXD/SR123
13457 XXPSAQ = XDTHR+RR3*XXD/SR123
13458 ELSE
13459 XXPV = XPVD(IDXVP)
13460 XXPSQ = XPSQ(IDXSP)
13461 XXPSAQ = XPSAQ(IDXSP)
13462 ENDIF
13463* flavor of the second quarks in the sea-diquark pair
13464 IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13465 IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13466* check masses of the new sea-qq - sea-q, sea-aqaq - sea-qq chains
13467 AM1 = XXPSQ *XTSQ(IDXST)*ECM**2
13468 AM2 = XXPSAQ*XTSAQ(IDXST)*ECM**2
13469 IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13470* ss-asas pair
13471 & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN
13472 IREJ = 1
13473 RETURN
13474 ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13475* at least one strange quark
13476 & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN
13477 IREJ = 1
13478 RETURN
13479 ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
13480 IREJ = 1
13481 RETURN
13482 ENDIF
13483* accept the new sea-diquark
13484 XPVD(IDXVP) = XXPV
13485 XPSQ(IDXSP) = XXPSQ
13486 XPSAQ(IDXSP) = XXPSAQ
13487 NDS = NDS+1
13488 INTDS1(NDS) = IDXSP
13489 INTDS2(NDS) = IDXST
13490 ISKPCH(2,NDS) = 0
13491 RETURN
13492 END
13493
13494*$ CREATE DT_DIFEVT.FOR
13495*COPY DT_DIFEVT
13496*
13497*===difevt=============================================================*
13498*
13499 SUBROUTINE DT_DIFEVT(IFP1,IFP2,PP,MOP,
13500 & IFT1,IFT2,PT,MOT,JDIFF,NCSY,IREJ)
13501
13502************************************************************************
13503* Interface to treatment of diffractive interactions. *
13504* (input) IFP1/2 PDG-indizes of projectile partons *
13505* (baryon: IFP2 - adiquark) *
13506* PP(4) projectile 4-momentum *
13507* IFT1/2 PDG-indizes of target partons *
13508* (baryon: IFT1 - adiquark) *
13509* PT(4) target 4-momentum *
13510* (output) JDIFF = 0 no diffraction *
13511* = 1/-1 LMSD/LMDD *
13512* = 2/-2 HMSD/HMDD *
13513* NCSY counter for two-chain systems *
13514* dumped to DTEVT1 *
13515* This version dated 14.02.95 is written by S. Roesler *
13516************************************************************************
13517
13518 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13519 SAVE
13520 PARAMETER ( LINP = 10 ,
13521 & LOUT = 6 ,
13522 & LDAT = 9 )
13523 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5,
13524 & OHALF=0.5D0)
13525
13526* event history
13527 PARAMETER (NMXHKK=200000)
13528 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
13529 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
13530 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
13531* extended event history
13532 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
13533 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
13534 & IHIST(2,NMXHKK)
13535* flags for diffractive interactions (DTUNUC 1.x)
13536 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
13537
13538 DIMENSION PP(4),PT(4)
13539
13540 LOGICAL LFIRST
13541 DATA LFIRST /.TRUE./
13542
13543 IREJ = 0
13544 JDIFF = 0
13545 IFLAGD = JDIFF
13546
13547* cm. energy
13548 XM = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
13549 & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
13550* identities of projectile hadron / target nucleon
13551 KPROJ = IDT_ICIHAD(IDHKK(MOP))
13552 KTARG = IDT_ICIHAD(IDHKK(MOT))
13553
13554* single diffractive xsections
13555 CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM)
13556* double diffractive xsections
13557**!! no double diff yet
13558C CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM,DDTOT,DDHM)
13559 DDTOT = 0.0D0
13560 DDHM = 0.0D0
13561**!!
13562* total inelastic xsection
13563C SIGIN = DT_SHNTOT(KPROJ,KTARG,XM,ZERO)-DT_SHNELA(KPROJ,KTARG,XM)
13564 DUMZER = ZERO
13565 CALL DT_XSHN(KPROJ,KTARG,DUMZER,XM,SIGTO,SIGEL)
13566 SIGIN = MAX(SIGTO-SIGEL,ZERO)
13567
13568* fraction of diffractive processes
13569 FRADIF = (SDTOT+DDTOT)/SIGIN
13570
13571 IF (LFIRST) THEN
13572 WRITE(LOUT,1000) XM,SDTOT,SIGIN
13573 1000 FORMAT(1X,'DIFEVT: single diffraction requested at E_cm = ',
13574 & F5.1,' GeV',/,9X,'sigma_sd = ',F4.1,' mb, sigma_in = ',
13575 & F5.1,' mb',/)
13576 LFIRST = .FALSE.
13577 ENDIF
13578
13579 IF ((DT_RNDM(DDHM).LE.FRADIF).OR.
13580 & (ISINGD.GT.1).OR.(IDOUBD.GT.1)) THEN
13581* diffractive interaction requested by x-section or by user
13582 FRASD = SDTOT/(SDTOT+DDTOT)
13583 FRASDH = SDHM/SDTOT
13584**sr needs to be specified!!
13585C FRADDH = DDHM/DDTOT
13586 FRADDH = 1.0D0
13587**
13588 IF ((DT_RNDM(FRASD).LE.FRASD).OR.(ISINGD.GT.1)) THEN
13589* single diffraction
13590 KDIFF = 1
13591 IF (DT_RNDM(DDTOT).LE.FRASDH) THEN
13592 KP = 2
13593 KT = 0
13594 IF (((ISINGD.EQ.4).OR.(DT_RNDM(DDTOT).GE.OHALF)).AND.
13595 & ISINGD.NE.3) THEN
13596 KP = 0
13597 KT = 2
13598 ENDIF
13599 ELSE
13600 KP = 1
13601 KT = 0
13602 IF (((ISINGD.EQ.4).OR.(DT_RNDM(FRADDH).GE.OHALF)).AND.
13603 & ISINGD.NE.3) THEN
13604 KP = 0
13605 KT = 1
13606 ENDIF
13607 ENDIF
13608 ELSE
13609* double diffraction
13610 KDIFF = -1
13611 IF (DT_RNDM(FRADDH).LE.FRADDH) THEN
13612 KP = 2
13613 KT = 2
13614 ELSE
13615 KP = 1
13616 KT = 1
13617 ENDIF
13618 ENDIF
13619 CALL DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
13620 & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
13621 IF (IREJ1.EQ.0) THEN
13622 IFLAGD = 2*KDIFF
13623 IF ((KP.EQ.1).OR.(KT.EQ.1)) IFLAGD = KDIFF
13624 ELSE
13625 GOTO 9999
13626 ENDIF
13627 ENDIF
13628 JDIFF = IFLAGD
13629
13630 RETURN
13631
13632 9999 CONTINUE
13633 IREJ = 1
13634 RETURN
13635 END
13636
13637*$ CREATE DT_DIFFKI.FOR
13638*COPY DT_DIFFKI
13639*
13640*===difkin=============================================================*
13641*
13642 SUBROUTINE DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
13643 & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ)
13644
13645************************************************************************
13646* Kinematics of diffractive nucleon-nucleon interaction. *
13647* IFP1/2 PDG-indizes of projectile partons *
13648* (baryon: IFP2 - adiquark) *
13649* PP(4) projectile 4-momentum *
13650* IFT1/2 PDG-indizes of target partons *
13651* (baryon: IFT1 - adiquark) *
13652* PT(4) target 4-momentum *
13653* KP = 0 projectile quasi-elastically scattered *
13654* = 1 excited to low-mass diff. state *
13655* = 2 excited to high-mass diff. state *
13656* KT = 0 target quasi-elastically scattered *
13657* = 1 excited to low-mass diff. state *
13658* = 2 excited to high-mass diff. state *
13659* This version dated 12.02.95 is written by S. Roesler *
13660************************************************************************
13661
13662 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13663 SAVE
13664 PARAMETER ( LINP = 10 ,
13665 & LOUT = 6 ,
13666 & LDAT = 9 )
13667 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5)
13668
13669 LOGICAL LSTART
13670
13671* particle properties (BAMJET index convention)
13672 CHARACTER*8 ANAME
13673 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
13674 & IICH(210),IIBAR(210),K1(210),K2(210)
13675* flags for input different options
13676 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
13677 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
13678 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
13679* rejection counter
13680 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
13681 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
13682 & IREXCI(3),IRDIFF(2),IRINC
13683* kinematics of diffractive interactions (DTUNUC 1.x)
13684 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
13685 & PPF(4),PTF(4),
13686 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
13687 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
13688
13689 DIMENSION PITOT(4),BGTOT(4),PP1(4),PT1(4),PPBLOB(4),PTBLOB(4),
13690 & PP(4),PT(4),PPOM1(4),DEV1(4),DEV2(4)
13691
13692 DATA LSTART /.TRUE./
13693
13694 IF (LSTART) THEN
13695 WRITE(LOUT,2000)
13696 2000 FORMAT(/,1X,'DIFEVT: diffractive interactions treated ')
13697 LSTART = .FALSE.
13698 ENDIF
13699
13700 IREJ = 0
13701
13702* initialize common /DTDIKI/
13703 CALL DT_DIFINI
13704* store momenta of initial incoming particles for emc-check
13705 IF (LEMCCK) THEN
13706 CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM,IDUM)
13707 CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM,IDUM)
13708 ENDIF
13709
13710* masses of initial particles
13711 XMP2 = PP(4)**2-PP(1)**2-PP(2)**2-PP(3)**2
13712 XMT2 = PT(4)**2-PT(1)**2-PT(2)**2-PT(3)**2
13713 IF ((XMP2.LT.ZERO).OR.(XMT2.LT.ZERO)) GOTO 9999
13714 XMP = SQRT(XMP2)
13715 XMT = SQRT(XMT2)
13716* check quark-input (used to adjust coherence cond. for M-selection)
13717 IBP = 0
13718 IF ((ABS(IFP1).GE.1000).OR.(ABS(IFP2).GE.1000)) IBP = 1
13719 IBT = 0
13720 IF ((ABS(IFT1).GE.1000).OR.(ABS(IFT2).GE.1000)) IBT = 1
13721
13722* parameter for Lorentz-transformation into nucleon-nucleon cms
13723 DO 3 K=1,4
13724 PITOT(K) = PP(K)+PT(K)
13725 3 CONTINUE
13726 XMTOT2 = PITOT(4)**2-PITOT(1)**2-PITOT(2)**2-PITOT(3)**2
13727 IF (XMTOT2.LE.ZERO) THEN
13728 WRITE(LOUT,1000) XMTOT2
13729 1000 FORMAT(1X,'DIFEVT: negative cm. energy! ',
13730 & 'XMTOT2 = ',E12.3)
13731 GOTO 9999
13732 ENDIF
13733 XMTOT = SQRT(XMTOT2)
13734 DO 4 K=1,4
13735 BGTOT(K) = PITOT(K)/XMTOT
13736 4 CONTINUE
13737* transformation of nucleons into cms
13738 CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PP(1),PP(2),
13739 & PP(3),PP(4),PPTOT,PP1(1),PP1(2),PP1(3),PP1(4))
13740 CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PT(1),PT(2),
13741 & PT(3),PT(4),PTTOT,PT1(1),PT1(2),PT1(3),PT1(4))
13742* rotation angles
13743 COD = PP1(3)/PPTOT
13744C SID = SQRT((ONE-COD)*(ONE+COD))
13745 PPT = SQRT(PP1(1)**2+PP1(2)**2)
13746 SID = PPT/PPTOT
13747 COF = ONE
13748 SIF = ZERO
13749 IF(PPTOT*SID.GT.TINY10) THEN
13750 COF = PP1(1)/(SID*PPTOT)
13751 SIF = PP1(2)/(SID*PPTOT)
13752 ANORF = SQRT(COF*COF+SIF*SIF)
13753 COF = COF/ANORF
13754 SIF = SIF/ANORF
13755 ENDIF
13756* check consistency
13757 DO 5 K=1,4
13758 DEV1(K) = ABS(PP1(K)+PT1(K))
13759 5 CONTINUE
13760 DEV1(4) = ABS(DEV1(4)-XMTOT)
13761 IF ((DEV1(1).GT.TINY10).OR.(DEV1(2).GT.TINY10).OR.
13762 & (DEV1(3).GT.TINY10).OR.(DEV1(4).GT.TINY10)) THEN
13763 WRITE(LOUT,1001) DEV1
13764 1001 FORMAT(1X,'DIFEVT: inconsitent Lorentz-transformation! ',
13765 & /,8X,4E12.3)
13766 GOTO 9999
13767 ENDIF
13768
13769* select x-fractions in high-mass diff. interactions
13770 IF ((KP.EQ.2).OR.(KT.EQ.2)) CALL DT_XVALHM(KP,KT)
13771
13772* select diffractive masses
13773* - projectile
13774 IF (KP.EQ.1) THEN
13775 XMPF = DT_XMLMD(XMTOT)
13776 CALL DT_LM2RES(IFP1,IFP2,XMPF,IDPR,IDXPR,IREJ1)
13777 IF (IREJ1.GT.0) GOTO 9999
13778 ELSEIF (KP.EQ.2) THEN
13779 XMPF = DT_XMHMD(XMTOT,IBP,1)
13780 ELSE
13781 XMPF = XMP
13782 ENDIF
13783* - target
13784 IF (KT.EQ.1) THEN
13785 XMTF = DT_XMLMD(XMTOT)
13786 CALL DT_LM2RES(IFT1,IFT2,XMTF,IDTR,IDXTR,IREJ1)
13787 IF (IREJ1.GT.0) GOTO 9999
13788 ELSEIF (KT.EQ.2) THEN
13789 XMTF = DT_XMHMD(XMTOT,IBT,2)
13790 ELSE
13791 XMTF = XMT
13792 ENDIF
13793
13794* kinematical treatment of "two-particle" system (masses - XMPF,XMTF)
13795 XMPF2 = XMPF**2
13796 XMTF2 = XMTF**2
13797 PPBLOB(3) = DT_YLAMB(XMTOT2,XMPF2,XMTF2)/(2.D0*XMTOT)
13798 PPBLOB(4) = SQRT(XMPF2+PPBLOB(3)**2)
13799
13800* select momentum transfer (all t-values used here are <0)
13801* minimum absolute value to produce diffractive masses
13802 TMIN = XMP2+XMPF2-2.0D0*(PP1(4)*PPBLOB(4)-PPTOT*PPBLOB(3))
13803 TT = DT_TDIFF(XMTOT,TMIN,XMPF,KP,XMTF,KT,IREJ1)
13804 IF (IREJ1.GT.0) GOTO 9999
13805
13806* longitudinal momentum of excited/elastically scattered projectile
13807 PPBLOB(3) = (TT-XMP2-XMPF2+2.0D0*PP1(4)*PPBLOB(4))/(2.0D0*PPTOT)
13808* total transverse momentum due to t-selection
13809 PPBLT2 = PPBLOB(4)**2-PPBLOB(3)**2-XMPF2
13810 IF (PPBLT2.LT.ZERO) THEN
13811 WRITE(LOUT,1002) PPBLT2,KP,PP1,XMPF,KT,PT1,XMTF,TT
13812 1002 FORMAT(1X,'DIFEVT: inconsistent transverse momentum! ',
13813 & E12.3,2(/,1X,I2,5E12.3),/,1X,E12.3)
13814 GOTO 9999
13815 ENDIF
13816 CALL DT_DSFECF(SINPHI,COSPHI)
13817 PPBLT = SQRT(PPBLT2)
13818 PPBLOB(1) = COSPHI*PPBLT
13819 PPBLOB(2) = SINPHI*PPBLT
13820
13821* rotate excited/elastically scattered projectile into n-n cms.
13822 CALL DT_MYTRAN(1,PPBLOB(1),PPBLOB(2),PPBLOB(3),COD,SID,COF,SIF,
13823 & XX,YY,ZZ)
13824 PPBLOB(1) = XX
13825 PPBLOB(2) = YY
13826 PPBLOB(3) = ZZ
13827
13828* 4-momentum of excited/elastically scattered target and of exchanged
13829* Pomeron
13830 DO 6 K=1,4
13831 IF (K.LT.4) PTBLOB(K) = -PPBLOB(K)
13832 PPOM1(K) = PP1(K)-PPBLOB(K)
13833 6 CONTINUE
13834 PTBLOB(4) = XMTOT-PPBLOB(4)
13835
13836* Lorentz-transformation back into system of initial diff. collision
13837 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13838 & PPBLOB(1),PPBLOB(2),PPBLOB(3),PPBLOB(4),
13839 & PPTOTF,PPF(1),PPF(2),PPF(3),PPF(4))
13840 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13841 & PTBLOB(1),PTBLOB(2),PTBLOB(3),PTBLOB(4),
13842 & PTTOTF,PTF(1),PTF(2),PTF(3),PTF(4))
13843 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13844 & PPOM1(1),PPOM1(2),PPOM1(3),PPOM1(4),
13845 & PPOMTO,PPOM(1),PPOM(2),PPOM(3),PPOM(4))
13846
13847* store 4-momentum of elastically scattered particle (in single diff.
13848* events)
13849 IF (KP.EQ.0) THEN
13850 DO 7 K=1,4
13851 PSC(K) = PPF(K)
13852 7 CONTINUE
13853 ELSEIF (KT.EQ.0) THEN
13854 DO 8 K=1,4
13855 PSC(K) = PTF(K)
13856 8 CONTINUE
13857 ENDIF
13858
13859* check consistency of kinematical treatment so far
13860 IF (LEMCCK) THEN
13861 CALL DT_EVTEMC(-PPF(1),-PPF(2),-PPF(3),-PPF(4),2,IDUM,IDUM)
13862 CALL DT_EVTEMC(-PTF(1),-PTF(2),-PTF(3),-PTF(4),2,IDUM,IDUM)
13863 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,60,IREJ1)
13864 IF (IREJ1.NE.0) GOTO 9999
13865 ENDIF
13866 DO 9 K=1,4
13867 DEV1(K) = ABS(PP(K)-PPF(K)-PPOM(K))
13868 DEV2(K) = ABS(PT(K)-PTF(K)+PPOM(K))
13869 9 CONTINUE
13870 IF ((DEV1(1).GT.TINY5).OR.(DEV1(2).GT.TINY5).OR.
13871 & (DEV1(3).GT.TINY5).OR.(DEV1(4).GT.TINY5).OR.
13872 & (DEV2(1).GT.TINY5).OR.(DEV2(2).GT.TINY5).OR.
13873 & (DEV2(3).GT.TINY5).OR.(DEV2(4).GT.TINY5)) THEN
13874 WRITE(LOUT,1003) DEV1,DEV2
13875 1003 FORMAT(1X,'DIFEVT: inconsitent kinematical treatment! ',
13876 & 2(/,8X,4E12.3))
13877 GOTO 9999
13878 ENDIF
13879
13880* kinematical treatment for low-mass diffraction
13881 CALL DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ1)
13882 IF (IREJ1.NE.0) GOTO 9999
13883
13884* dump diffractive chains into DTEVT1
13885 CALL DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
13886 IF (IREJ1.NE.0) GOTO 9999
13887
13888 RETURN
13889
13890 9999 CONTINUE
13891 IRDIFF(1) = IRDIFF(1)+1
13892 IREJ = 1
13893 RETURN
13894 END
13895
13896*$ CREATE DT_XMHMD.FOR
13897*COPY DT_XMHMD
13898*
13899*===xmhmd==============================================================*
13900*
13901 DOUBLE PRECISION FUNCTION DT_XMHMD(ECM,IB,MODE)
13902
13903************************************************************************
13904* Diffractive mass in high mass single/double diffractive events. *
13905* This version dated 11.02.95 is written by S. Roesler *
13906************************************************************************
13907
13908 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13909 SAVE
13910 PARAMETER ( LINP = 10 ,
13911 & LOUT = 6 ,
13912 & LDAT = 9 )
13913 PARAMETER (OHALF=0.5D0,ONE=1.0D0,ZERO=0.0D0)
13914
13915* kinematics of diffractive interactions (DTUNUC 1.x)
13916 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
13917 & PPF(4),PTF(4),
13918 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
13919 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
13920
13921C DATA XCOLOW /0.05D0/
13922 DATA XCOLOW /0.15D0/
13923
13924 DT_XMHMD = ZERO
13925 XH = XPH(2)
13926 IF (MODE.EQ.2) XH = XTH(2)
13927
13928* minimum Pomeron-x for high-mass diffraction
13929* (adjusted to get a smooth transition between HM and LM component)
13930 R = DT_RNDM(XH)
13931 XDIMIN = (3.0D0+400.0D0*R**2)/(XH*ECM**2)
13932 IF (ECM.LE.300.0D0) THEN
13933 RR = (1.0D0-EXP(-((ECM/140.0D0)**4)))
13934 XDIMIN = (3.0D0+400.0D0*(R**2)*RR)/(XH*ECM**2)
13935 ENDIF
13936* maximum Pomeron-x for high-mass diffraction
13937* (coherence condition, adjusted to fit to experimental data)
13938 IF (IB.NE.0) THEN
13939* baryon-diffraction
13940 XDIMAX = XCOLOW*(1.0D0+EXP(-((ECM/420.0D0)**2)))
13941 ELSE
13942* meson-diffraction
13943 XDIMAX = XCOLOW*(1.0D0+4.0D0*EXP(-((ECM/420.0D0)**2)))
13944 ENDIF
13945* check boundaries
13946 IF (XDIMIN.GE.XDIMAX) THEN
13947 XDIMIN = OHALF*XDIMAX
13948 ENDIF
13949
13950 KLOOP = 0
13951 1 CONTINUE
13952 KLOOP = KLOOP+1
13953 IF (KLOOP.GT.20) RETURN
13954* sample Pomeron-x from 1/x-distribution (critical Pomeron)
13955 XDIFF = DT_SAMPEX(XDIMIN,XDIMAX)
13956* corr. diffr. mass
13957 DT_XMHMD = ECM*SQRT(XDIFF)
13958 IF (DT_XMHMD.LT.2.5D0) GOTO 1
13959
13960 RETURN
13961 END
13962
13963*$ CREATE DT_XMLMD.FOR
13964*COPY DT_XMLMD
13965*
13966*===xmlmd==============================================================*
13967*
13968 DOUBLE PRECISION FUNCTION DT_XMLMD(ECM)
13969
13970************************************************************************
13971* Diffractive mass in high mass single/double diffractive events. *
13972* This version dated 11.02.95 is written by S. Roesler *
13973************************************************************************
13974
13975 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13976 SAVE
13977 PARAMETER ( LINP = 10 ,
13978 & LOUT = 6 ,
13979 & LDAT = 9 )
13980
13981* minimum Pomeron-x for low-mass diffraction
13982C AMO = 1.5D0
13983 AMO = 2.0D0
13984* maximum Pomeron-x for low-mass diffraction
13985* (adjusted to get a smooth transition between HM and LM component)
13986 R = DT_RNDM(AMO)
13987 SAM = 1.0D0
13988 IF (ECM.LE.300.0D0) SAM = 1.0D0-EXP(-((ECM/200.0D0)**4))
13989 R = DT_RNDM(AMO)*SAM
13990 AMAX= (1.0D0-SAM)*SQRT(0.1D0*ECM**2)+SAM*SQRT(400.0D0)
13991 AMU = R*SQRT(100.0D0)+(1.0D0-R)*AMAX
13992
13993* selection of diffractive mass
13994* (adjusted to get a smooth transition between HM and LM component)
13995 R = DT_RNDM(AMU)
13996 IF (ECM.LE.50.0D0) THEN
13997 DT_XMLMD = AMO*(AMU/AMO)**R
13998 ELSE
13999 A = 0.7D0
14000 IF (ECM.LE.300.0D0) A = 0.7D0*(1.0D0-EXP(-((ECM/100.0D0)**2)))
14001 DT_XMLMD = 1.0D0/((R/(AMU**A)+(1.0D0-R)/(AMO**A))**(1.0D0/A))
14002 ENDIF
14003
14004 RETURN
14005 END
14006
14007*$ CREATE DT_TDIFF.FOR
14008*COPY DT_TDIFF
14009*
14010*===tdiff==============================================================*
14011*
14012 DOUBLE PRECISION FUNCTION DT_TDIFF(ECM,TMIN,XM1I,K1,XM2I,K2,IREJ)
14013
14014************************************************************************
14015* t-selection for single/double diffractive interactions. *
14016* ECM cm. energy *
14017* TMIN minimum momentum transfer to produce diff. masses *
14018* XM1/XM2 diffractively produced masses *
14019* (for single diffraction XM2 is obsolete) *
14020* K1/K2= 0 not excited *
14021* = 1 low-mass excitation *
14022* = 2 high-mass excitation *
14023* This version dated 11.02.95 is written by S. Roesler *
14024************************************************************************
14025
14026 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14027 SAVE
14028 PARAMETER ( LINP = 10 ,
14029 & LOUT = 6 ,
14030 & LDAT = 9 )
14031 PARAMETER (ZERO=0.0D0)
14032
14033 PARAMETER ( BTP0 = 3.7D0,
14034 & ALPHAP = 0.24D0 )
14035
14036 IREJ = 0
14037 NCLOOP = 0
14038 DT_TDIFF = ZERO
14039
14040 IF (K1.GT.0) THEN
14041 XM1 = XM1I
14042 XM2 = XM2I
14043 ELSE
14044 XM1 = XM2I
14045 ENDIF
14046 XDI = (XM1/ECM)**2
14047 IF ((K1.EQ.0).OR.(K2.EQ.0)) THEN
14048* slope for single diffraction
14049 SLOPE = BTP0-2.0D0*ALPHAP*LOG(XDI)
14050 ELSE
14051* slope for double diffraction
14052 SLOPE = -2.0D0*ALPHAP*LOG(XDI*XM2**2)
14053 ENDIF
14054
14055 1 CONTINUE
14056 NCLOOP = NCLOOP+1
14057 IF (MOD(NCLOOP,1000).EQ.0) GOTO 9999
14058 Y = DT_RNDM(XDI)
14059 T = -LOG(1.0D0-Y)/SLOPE
14060 IF (ABS(T).LE.ABS(TMIN)) GOTO 1
14061 DT_TDIFF = -ABS(T)
14062
14063 RETURN
14064
14065 9999 CONTINUE
14066 WRITE(LOUT,1000) ECM,TMIN,XM1I,XM2I,K1,K2
14067 1000 FORMAT(1X,'DT_TDIFF: t-selection rejected!',/,
14068 & 1X,'ECM = ',E12.3,' TMIN = ',E12.2,/,1X,'XM1I = ',
14069 & E12.3,' XM2I = ',E12.3,' K1 = ',I2,' K2 = ',I2)
14070 IREJ = 1
14071 RETURN
14072 END
14073
14074*$ CREATE DT_XVALHM.FOR
14075*COPY DT_XVALHM
14076*
14077*===xvalhm=============================================================*
14078*
14079 SUBROUTINE DT_XVALHM(KP,KT)
14080
14081************************************************************************
14082* Sampling of parton x-values in high-mass diffractive interactions. *
14083* This version dated 12.02.95 is written by S. Roesler *
14084************************************************************************
14085
14086 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14087 SAVE
14088 PARAMETER ( LINP = 10 ,
14089 & LOUT = 6 ,
14090 & LDAT = 9 )
14091 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0,TINY2=1.0D-2)
14092
14093* kinematics of diffractive interactions (DTUNUC 1.x)
14094 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14095 & PPF(4),PTF(4),
14096 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14097 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14098* various options for treatment of partons (DTUNUC 1.x)
14099* (chain recombination, Cronin,..)
14100 LOGICAL LCO2CR,LINTPT
14101 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
14102 & LCO2CR,LINTPT
14103
14104 DATA UNON,XVQTHR /2.0D0,0.8D0/
14105
14106 IF (KP.EQ.2) THEN
14107* x-fractions of projectile valence partons
14108 1 CONTINUE
14109 XPH(1) = DT_DBETAR(OHALF,UNON)
14110 IF (XPH(1).GE.XVQTHR) GOTO 1
14111 XPH(2) = ONE-XPH(1)
14112* x-fractions of Pomeron q-aq-pair
14113 XPOLO = TINY2
14114 XPOHI = ONE-TINY2
14115 XPPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14116 XPPO(2) = ONE-XPPO(1)
14117* flavors of Pomeron q-aq-pair
14118 IFLAV = INT(ONE+DT_RNDM(UNON)*(2.0D0+SEASQ))
14119 IFPPO(1) = IFLAV
14120 IFPPO(2) = -IFLAV
14121 IF (DT_RNDM(UNON).GT.OHALF) THEN
14122 IFPPO(1) = -IFLAV
14123 IFPPO(2) = IFLAV
14124 ENDIF
14125 ENDIF
14126
14127 IF (KT.EQ.2) THEN
14128* x-fractions of projectile target partons
14129 2 CONTINUE
14130 XTH(1) = DT_DBETAR(OHALF,UNON)
14131 IF (XTH(1).GE.XVQTHR) GOTO 2
14132 XTH(2) = ONE-XTH(1)
14133* x-fractions of Pomeron q-aq-pair
14134 XPOLO = TINY2
14135 XPOHI = ONE-TINY2
14136 XTPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14137 XTPO(2) = ONE-XTPO(1)
14138* flavors of Pomeron q-aq-pair
14139 IFLAV = INT(ONE+DT_RNDM(XPOLO)*(2.0D0+SEASQ))
14140 IFTPO(1) = IFLAV
14141 IFTPO(2) = -IFLAV
14142 IF (DT_RNDM(XPOLO).GT.OHALF) THEN
14143 IFTPO(1) = -IFLAV
14144 IFTPO(2) = IFLAV
14145 ENDIF
14146 ENDIF
14147
14148 RETURN
14149 END
14150
14151*$ CREATE DT_LM2RES.FOR
14152*COPY DT_LM2RES
14153*
14154*===lm2res=============================================================*
14155*
14156 SUBROUTINE DT_LM2RES(IF1,IF2,XM,IDR,IDXR,IREJ)
14157
14158************************************************************************
14159* Check low-mass diffractive excitation for resonance mass. *
14160* (input) IF1/2 PDG-indizes of valence partons *
14161* (in/out) XM diffractive mass requested/corrected *
14162* (output) IDR/IDXR id./BAMJET-index of resonance *
14163* This version dated 12.02.95 is written by S. Roesler *
14164************************************************************************
14165
14166 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14167 SAVE
14168 PARAMETER ( LINP = 10 ,
14169 & LOUT = 6 ,
14170 & LDAT = 9 )
14171 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14172
14173* kinematics of diffractive interactions (DTUNUC 1.x)
14174 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14175 & PPF(4),PTF(4),
14176 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14177 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14178
14179 IREJ = 0
14180 IF1B = 0
14181 IF2B = 0
14182 XMI = XM
14183
14184* BAMJET indices of partons
14185 IF1A = IDT_IPDG2B(IF1,1,2)
14186 IF (ABS(IF1).GE.1000) IF1B = IDT_IPDG2B(IF1,2,2)
14187 IF2A = IDT_IPDG2B(IF2,1,2)
14188 IF (ABS(IF2).GE.1000) IF2B = IDT_IPDG2B(IF2,2,2)
14189
14190* get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq)
14191 IDCH = 2
14192 IF ((IF1B.EQ.0).AND.(IF2B.EQ.0)) IDCH = 1
14193
14194* check for resonance mass
14195 CALL DT_CH2RES(IF1A,IF1B,IF2A,IF2B,IDR,IDXR,XMI,XMN,IDCH,IREJ1)
14196 IF (IREJ1.NE.0) GOTO 9999
14197
14198 XM = XMN
14199 RETURN
14200
14201 9999 CONTINUE
14202 IREJ = 1
14203 RETURN
14204 END
14205
14206*$ CREATE DT_LMKINE.FOR
14207*COPY DT_LMKINE
14208*
14209*===lmkine=============================================================*
14210*
14211 SUBROUTINE DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ)
14212
14213************************************************************************
14214* Kinematical treatment of low-mass excitations. *
14215* This version dated 12.02.95 is written by S. Roesler *
14216************************************************************************
14217
14218 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14219 SAVE
14220 PARAMETER ( LINP = 10 ,
14221 & LOUT = 6 ,
14222 & LDAT = 9 )
14223 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14224
14225* flags for input different options
14226 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14227 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14228 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14229* kinematics of diffractive interactions (DTUNUC 1.x)
14230 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14231 & PPF(4),PTF(4),
14232 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14233 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14234
14235 DIMENSION P1(4),P2(4)
14236
14237 IREJ = 0
14238
14239 IF (KP.EQ.1) THEN
14240 PABS = SQRT(PPF(1)**2+PPF(2)**2+PPF(3)**2)
14241 POE = PPF(4)/PABS
14242 FAC1 = OHALF*(POE+ONE)
14243 FAC2 = -OHALF*(POE-ONE)
14244 DO 1 K=1,3
14245 PPLM1(K) = FAC1*PPF(K)
14246 PPLM2(K) = FAC2*PPF(K)
14247 1 CONTINUE
14248 PPLM1(4) = FAC1*PABS
14249 PPLM2(4) = -FAC2*PABS
14250 IF (IMSHL.EQ.1) THEN
14251 XM1 = PYMASS(IFP1)
14252 XM2 = PYMASS(IFP2)
14253 CALL DT_MASHEL(PPLM1,PPLM2,XM1,XM2,P1,P2,IREJ1)
14254 IF (IREJ1.NE.0) GOTO 9999
14255 DO 2 K=1,4
14256 PPLM1(K) = P1(K)
14257 PPLM2(K) = P2(K)
14258 2 CONTINUE
14259 ENDIF
14260 ENDIF
14261
14262 IF (KT.EQ.1) THEN
14263 PABS = SQRT(PTF(1)**2+PTF(2)**2+PTF(3)**2)
14264 POE = PTF(4)/PABS
14265 FAC1 = OHALF*(POE+ONE)
14266 FAC2 = -OHALF*(POE-ONE)
14267 DO 3 K=1,3
14268 PTLM2(K) = FAC1*PTF(K)
14269 PTLM1(K) = FAC2*PTF(K)
14270 3 CONTINUE
14271 PTLM2(4) = FAC1*PABS
14272 PTLM1(4) = -FAC2*PABS
14273 IF (IMSHL.EQ.1) THEN
14274 XM1 = PYMASS(IFT1)
14275 XM2 = PYMASS(IFT2)
14276 CALL DT_MASHEL(PTLM1,PTLM2,XM1,XM2,P1,P2,IREJ1)
14277 IF (IREJ1.NE.0) GOTO 9999
14278 DO 4 K=1,4
14279 PTLM1(K) = P1(K)
14280 PTLM2(K) = P2(K)
14281 4 CONTINUE
14282 ENDIF
14283 ENDIF
14284
14285 RETURN
14286
14287 9999 CONTINUE
14288 WRITE(LOUT,'(A)') 'LMKINE: kinematical treatment rejected'
14289 IREJ = 1
14290 RETURN
14291 END
14292
14293*$ CREATE DT_DIFINI.FOR
14294*COPY DT_DIFINI
14295*
14296*===difini=============================================================*
14297*
14298 SUBROUTINE DT_DIFINI
14299
14300************************************************************************
14301* Initialization of common /DTDIKI/ *
14302* This version dated 12.02.95 is written by S. Roesler *
14303************************************************************************
14304
14305 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14306 SAVE
14307 PARAMETER ( LINP = 10 ,
14308 & LOUT = 6 ,
14309 & LDAT = 9 )
14310 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14311
14312* kinematics of diffractive interactions (DTUNUC 1.x)
14313 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14314 & PPF(4),PTF(4),
14315 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14316 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14317
14318 DO 1 K=1,4
14319 PPOM(K) = ZERO
14320 PSC(K) = ZERO
14321 PPF(K) = ZERO
14322 PTF(K) = ZERO
14323 PPLM1(K) = ZERO
14324 PPLM2(K) = ZERO
14325 PTLM1(K) = ZERO
14326 PTLM2(K) = ZERO
14327 1 CONTINUE
14328 DO 2 K=1,2
14329 XPH(K) = ZERO
14330 XPPO(K) = ZERO
14331 XTH(K) = ZERO
14332 XTPO(K) = ZERO
14333 IFPPO(K) = 0
14334 IFTPO(K) = 0
14335 2 CONTINUE
14336 IDPR = 0
14337 IDXPR = 0
14338 IDTR = 0
14339 IDXTR = 0
14340
14341 RETURN
14342 END
14343
14344*$ CREATE DT_DIFPUT.FOR
14345*COPY DT_DIFPUT
14346*
14347*===difput=============================================================*
14348*
14349 SUBROUTINE DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,
14350 & IREJ)
14351
14352************************************************************************
14353* Dump diffractive chains into DTEVT1 *
14354* This version dated 12.02.95 is written by S. Roesler *
14355************************************************************************
14356
14357 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14358 SAVE
14359 PARAMETER ( LINP = 10 ,
14360 & LOUT = 6 ,
14361 & LDAT = 9 )
14362 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14363
14364 LOGICAL LCHK
14365
14366* kinematics of diffractive interactions (DTUNUC 1.x)
14367 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14368 & PPF(4),PTF(4),
14369 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14370 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14371* event history
14372 PARAMETER (NMXHKK=200000)
14373 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14374 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14375 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14376* extended event history
14377 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14378 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14379 & IHIST(2,NMXHKK)
14380* rejection counter
14381 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
14382 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
14383 & IREXCI(3),IRDIFF(2),IRINC
14384
14385 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PCH(4),PP(4),PT(4),
14386 & P1(4),P2(4),P3(4),P4(4)
14387
14388 IREJ = 0
14389
14390 IF (KP.EQ.1) THEN
14391 DO 1 K=1,4
14392 PCH(K) = PPLM1(K)+PPLM2(K)
14393 1 CONTINUE
14394 ID1 = IFP1
14395 ID2 = IFP2
14396 IF (DT_RNDM(PT).GT.OHALF) THEN
14397 ID1 = IFP2
14398 ID2 = IFP1
14399 ENDIF
14400 CALL DT_EVTPUT(21,ID1,MOP,0,PPLM1(1),PPLM1(2),PPLM1(3),
14401 & PPLM1(4),0,0,0)
14402 CALL DT_EVTPUT(21,ID2,MOP,0,PPLM2(1),PPLM2(2),PPLM2(3),
14403 & PPLM2(4),0,0,0)
14404 CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
14405 & IDPR,IDXPR,8)
14406 ELSEIF (KP.EQ.2) THEN
14407 DO 2 K=1,4
14408 PP1(K) = XPH(1)*PP(K)
14409 PP2(K) = XPH(2)*PP(K)
14410 PT1(K) = -XPPO(1)*PPOM(K)
14411 PT2(K) = -XPPO(2)*PPOM(K)
14412 2 CONTINUE
14413 CALL DT_CHKCSY(IFP1,IFPPO(1),LCHK)
14414 XM1 = ZERO
14415 XM2 = ZERO
14416 IF (LCHK) THEN
14417 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
14418 IF (IREJ1.NE.0) GOTO 9999
14419 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
14420 IF (IREJ1.NE.0) GOTO 9999
14421 DO 3 K=1,4
14422 PP1(K) = P1(K)
14423 PT1(K) = P2(K)
14424 PP2(K) = P3(K)
14425 PT2(K) = P4(K)
14426 3 CONTINUE
14427 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
14428 & 0,0,8)
14429 CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
14430 & PT1(4),0,0,8)
14431 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
14432 & 0,0,8)
14433 CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
14434 & PT2(4),0,0,8)
14435 ELSE
14436 CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
14437 IF (IREJ1.NE.0) GOTO 9999
14438 CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
14439 IF (IREJ1.NE.0) GOTO 9999
14440 DO 4 K=1,4
14441 PP1(K) = P1(K)
14442 PT2(K) = P2(K)
14443 PP2(K) = P3(K)
14444 PT1(K) = P4(K)
14445 4 CONTINUE
14446 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
14447 & 0,0,8)
14448 CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
14449 & PT2(4),0,0,8)
14450 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
14451 & 0,0,8)
14452 CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
14453 & PT1(4),0,0,8)
14454 ENDIF
14455 NCSY = NCSY+1
14456 ELSE
14457 CALL DT_EVTPUT(1,IDHKK(MOP),MOP,0,PSC(1),PSC(2),PSC(3),PSC(4),
14458 & 0,0,0)
14459 ENDIF
14460
14461 IF (KT.EQ.1) THEN
14462 DO 5 K=1,4
14463 PCH(K) = PTLM1(K)+PTLM2(K)
14464 5 CONTINUE
14465 ID1 = IFT1
14466 ID2 = IFT2
14467 IF (DT_RNDM(PT).GT.OHALF) THEN
14468 ID1 = IFT2
14469 ID2 = IFT1
14470 ENDIF
14471 CALL DT_EVTPUT(22,ID1,MOT,0,PTLM1(1),PTLM1(2),PTLM1(3),
14472 & PTLM1(4),0,0,0)
14473 CALL DT_EVTPUT(22,ID2,MOT,0,PTLM2(1),PTLM2(2),PTLM2(3),
14474 & PTLM2(4),0,0,0)
14475 CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
14476 & IDTR,IDXTR,8)
14477 ELSEIF (KT.EQ.2) THEN
14478 DO 6 K=1,4
14479 PP1(K) = XTPO(1)*PPOM(K)
14480 PP2(K) = XTPO(2)*PPOM(K)
14481 PT1(K) = XTH(2)*PT(K)
14482 PT2(K) = XTH(1)*PT(K)
14483 6 CONTINUE
14484 CALL DT_CHKCSY(IFTPO(1),IFT1,LCHK)
14485 XM1 = ZERO
14486 XM2 = ZERO
14487 IF (LCHK) THEN
14488 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
14489 IF (IREJ1.NE.0) GOTO 9999
14490 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
14491 IF (IREJ1.NE.0) GOTO 9999
14492 DO 7 K=1,4
14493 PP1(K) = P1(K)
14494 PT1(K) = P2(K)
14495 PP2(K) = P3(K)
14496 PT2(K) = P4(K)
14497 7 CONTINUE
14498 CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
14499 & PP1(4),0,0,8)
14500 CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
14501 & 0,0,8)
14502 CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
14503 & PP2(4),0,0,8)
14504 CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
14505 & 0,0,8)
14506 ELSE
14507 CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
14508 IF (IREJ1.NE.0) GOTO 9999
14509 CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
14510 IF (IREJ1.NE.0) GOTO 9999
14511 DO 8 K=1,4
14512 PP1(K) = P1(K)
14513 PT2(K) = P2(K)
14514 PP2(K) = P3(K)
14515 PT1(K) = P4(K)
14516 8 CONTINUE
14517 CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
14518 & PP1(4),0,0,8)
14519 CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
14520 & 0,0,8)
14521 CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
14522 & PP2(4),0,0,8)
14523 CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
14524 & 0,0,8)
14525 ENDIF
14526 NCSY = NCSY+1
14527 ELSE
14528 CALL DT_EVTPUT(1,IDHKK(MOT),MOT,0,PSC(1),PSC(2),PSC(3),PSC(4),
14529 & 0,0,0)
14530 ENDIF
14531
14532 RETURN
14533
14534 9999 CONTINUE
14535 IRDIFF(2) = IRDIFF(2)+1
14536 IREJ = 1
14537 RETURN
14538 END
14539
14540*$ CREATE DT_EVTFRG.FOR
14541*COPY DT_EVTFRG
14542*
14543*===evtfrg=============================================================*
14544*
14545 SUBROUTINE DT_EVTFRG(KMODE,NFRG,NPYMEM,IREJ)
14546
14547************************************************************************
14548* Hadronization of chains in DTEVT1. *
14549* *
14550* Input: *
14551* KMODE = 1 hadronization of PHOJET-chains (id=77xxx) *
14552* = 2 hadronization of DTUNUC-chains (id=88xxx) *
14553* NFRG if KMODE = 1 : upper index of PHOJET-scatterings to be *
14554* hadronized with one PYEXEC call *
14555* if KMODE = 2 : max. number of DTUNUC-chains to be hadronized *
14556* with one PYEXEC call *
14557* Output: *
14558* NPYMEM number of entries in JETSET-common after hadronization *
14559* IREJ rejection flag *
14560* *
14561* This version dated 17.09.00 is written by S. Roesler *
14562************************************************************************
14563
14564 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14565 SAVE
14566 PARAMETER ( LINP = 10 ,
14567 & LOUT = 6 ,
14568 & LDAT = 9 )
14569 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1)
14570 PARAMETER (ONE=1.0D0,ZERO=0.0D0)
14571
14572 LOGICAL LACCEP
14573
14574 PARAMETER (MXJOIN=200)
14575
14576* event history
14577 PARAMETER (NMXHKK=200000)
14578 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14579 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14580 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14581* extended event history
14582 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14583 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14584 & IHIST(2,NMXHKK)
14585* flags for input different options
14586 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14587 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14588 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14589* statistics
14590 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
14591 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
14592 & ICEVTG(8,0:30)
14593* flags for diffractive interactions (DTUNUC 1.x)
14594 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
14595* nucleon-nucleon event-generator
14596 CHARACTER*8 CMODEL
14597 LOGICAL LPHOIN
14598 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
14599* phojet
14600C model switches and parameters
14601 CHARACTER*8 MDLNA
14602 INTEGER ISWMDL,IPAMDL
14603 DOUBLE PRECISION PARMDL
14604 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14605* jetset
14606 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
1ddc441c 14607 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
9aaba0d6 14608 PARAMETER (MAXLND=4000)
14609 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
14610 INTEGER PYK
14611 DIMENSION IJOIN(MXJOIN),ISJOIN(MXJOIN),IHISMO(8000),IFLG(4000)
1ddc441c 14612 INTEGER PYCOMP
9aaba0d6 14613 MODE = KMODE
14614 ISTSTG = 7
14615 IF (MODE.NE.1) ISTSTG = 8
14616 IREJ = 0
14617
14618 IP = 0
14619 ISH = 0
14620 INIEMC = 1
14621 NEND = NHKK
14622 NACCEP = 0
14623 IFRG = 0
14624 IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
14625 DO 10 I=NPOINT(3),NEND
14626* sr 14.02.00: seems to be not necessary anymore, commented
14627C LACCEP = ((NOBAM(I).EQ.0).AND.(MODE.EQ.1)).OR.
14628C & ((NOBAM(I).NE.0).AND.(MODE.EQ.2))
14629 LACCEP = .TRUE.
14630* pick up chains from dtevt1
14631 IDCHK = IDHKK(I)/10000
14632 IF ((IDCHK.EQ.ISTSTG).AND.LACCEP) THEN
14633 IF (IDCHK.EQ.7) THEN
14634 IPJE = IDHKK(I)-IDCHK*10000
14635 IF (IPJE.NE.IFRG) THEN
14636 IFRG = IPJE
14637 IF (IFRG.GT.NFRG) GOTO 16
14638 ENDIF
14639 ELSE
14640 IPJE = 1
14641 IFRG = IFRG+1
14642 IF (IFRG.GT.NFRG) THEN
14643 NFRG = -1
14644 GOTO 16
14645 ENDIF
14646 ENDIF
14647* statistics counter
14648c IF (IDCH(I).LE.8)
14649c & ICCHAI(2,IDCH(I)) = ICCHAI(2,IDCH(I))+1
14650c IF (IDRES(I).NE.0) ICRES(IDCH(I)) = ICRES(IDCH(I))+1
14651* special treatment for small chains already corrected to hadrons
14652 IF (IDRES(I).NE.0) THEN
14653 IF (IDRES(I).EQ.11) THEN
14654 ID = IDXRES(I)
14655 ELSE
14656 ID = IDT_IPDGHA(IDXRES(I))
14657 ENDIF
14658 IF (LEMCCK) THEN
14659 CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
14660 & PHKK(4,I),INIEMC,IDUM,IDUM)
14661 INIEMC = 2
14662 ENDIF
14663 IP = IP+1
14664 IF (IP.GT.MSTU(4)) STOP ' NEWFRA 1: IP.GT.MSTU(4) !'
14665 P(IP,1) = PHKK(1,I)
14666 P(IP,2) = PHKK(2,I)
14667 P(IP,3) = PHKK(3,I)
14668 P(IP,4) = PHKK(4,I)
14669 P(IP,5) = PHKK(5,I)
14670 K(IP,1) = 1
14671 K(IP,2) = ID
14672 K(IP,3) = 0
14673 K(IP,4) = 0
14674 K(IP,5) = 0
14675 IHIST(2,I) = 10000*IPJE+IP
14676 IF (IHIST(1,I).LE.-100) THEN
14677 ISH = ISH+1
14678 IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
14679 ISJOIN(ISH) = I
14680 ENDIF
14681 N = IP
14682 IHISMO(IP) = I
14683 ELSE
14684 IJ = 0
14685 DO 11 KK=JMOHKK(1,I),JMOHKK(2,I)
14686 IF (LEMCCK) THEN
14687 CALL DT_EVTEMC(PHKK(1,KK),PHKK(2,KK),PHKK(3,KK),
14688 & PHKK(4,KK),INIEMC,IDUM,IDUM)
14689 CALL DT_EVTFLC(IDHKK(KK),1,INIEMC,IDUM,IDUM)
14690 INIEMC = 2
14691 ENDIF
14692 ID = IDHKK(KK)
14693 IF (ID.EQ.0) ID = 21
14694c PTOT = SQRT(PHKK(1,KK)**2+PHKK(2,KK)**2+PHKK(3,KK)**2)
14695c AM0 = SQRT(ABS((PHKK(4,KK)-PTOT)*(PHKK(4,KK)+PTOT)))
14696c AMRQ = PYMASS(ID)
14697c AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
14698c IF ((ABS(AMDIF2).GT.TINY3).AND.(PTOT.GT.ZERO).AND.
14699c & (ABS(IDIFF).EQ.0)) THEN
14700cC WRITE(LOUT,*)'here: ',NEVHKK,AM0,AMRQ
14701c DELTA = -AMDIF2/(2.0D0*(PHKK(4,KK)+PTOT))
14702c PHKK(4,KK) = PHKK(4,KK)+DELTA
14703c PTOT1 = PTOT-DELTA
14704c PHKK(1,KK) = PHKK(1,KK)*PTOT1/PTOT
14705c PHKK(2,KK) = PHKK(2,KK)*PTOT1/PTOT
14706c PHKK(3,KK) = PHKK(3,KK)*PTOT1/PTOT
14707c PHKK(5,KK) = AMRQ
14708c ENDIF
14709 IP = IP+1
14710 IF (IP.GT.MSTU(4)) STOP ' NEWFRA 2: IP.GT.MSTU(4) !'
14711 P(IP,1) = PHKK(1,KK)
14712 P(IP,2) = PHKK(2,KK)
14713 P(IP,3) = PHKK(3,KK)
14714 P(IP,4) = PHKK(4,KK)
14715 P(IP,5) = PHKK(5,KK)
14716 K(IP,1) = 1
14717 K(IP,2) = ID
14718 K(IP,3) = 0
14719 K(IP,4) = 0
14720 K(IP,5) = 0
14721 IHIST(2,KK) = 10000*IPJE+IP
14722 IF (IHIST(1,KK).LE.-100) THEN
14723 ISH = ISH+1
14724 IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
14725 ISJOIN(ISH) = KK
14726 ENDIF
14727 IJ = IJ+1
14728 IF (IJ.GT.MXJOIN) STOP 'IJ > MXJOIN !'
14729 IJOIN(IJ) = IP
14730 IHISMO(IP) = I
14731 11 CONTINUE
14732 N = IP
14733* join the two-parton system
14734 CALL PYJOIN(IJ,IJOIN)
14735 ENDIF
14736 IDHKK(I) = 99999
14737 ENDIF
14738 10 CONTINUE
14739 16 CONTINUE
14740 N = IP
14741
14742 IF (IP.GT.0) THEN
14743
14744* final state parton shower
14745 DO 136 NPJE=1,IPJE
14746 IF ((MCGENE.EQ.2).AND.(ISH.GE.2)) THEN
14747 IF ((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
14748 DO 130 K1=1,ISH
14749 IF (ISJOIN(K1).EQ.0) GOTO 130
14750 I = ISJOIN(K1)
14751 IF ((IPAMDL(102).EQ.1).AND.(IHIST(1,I).NE.-100))
14752 & GOTO 130
14753 IH1 = IHIST(2,I)/10000
14754 IF (IH1.NE.NPJE) GOTO 130
14755 IH1 = IHIST(2,I)-IH1*10000
14756 DO 135 K2=K1+1,ISH
14757 IF (ISJOIN(K2).EQ.0) GOTO 135
14758 II = ISJOIN(K2)
14759 IH2 = IHIST(2,II)/10000
14760 IF (IH2.NE.NPJE) GOTO 135
14761 IH2 = IHIST(2,II)-IH2*10000
14762 IF (IHIST(1,I).EQ.IHIST(1,II)) THEN
14763 PT1 = SQRT(PHKK(1,II)**2+PHKK(2,II)**2)
14764 PT2 = SQRT(PHKK(1, I)**2+PHKK(2, I)**2)
14765 RQLUN = MIN(PT1,PT2)
14766 CALL PYSHOW(IH1,IH2,RQLUN)
14767
14768 ISJOIN(K1) = 0
14769 ISJOIN(K2) = 0
14770 GOTO 130
14771 ENDIF
14772 135 CONTINUE
14773 130 CONTINUE
14774 ENDIF
14775 ENDIF
14776 136 CONTINUE
14777
14778 CALL DT_INITJS(MODE)
14779* hadronization
14780
14781 CALL PYEXEC
14782
14783 IF (MSTU(24).NE.0) THEN
14784 WRITE(LOUT,*) ' JETSET-reject at event',
14785 & NEVHKK,MSTU(24),KMODE
14786C CALL DT_EVTOUT(4)
14787
14788C CALL PYLIST(2)
14789
14790 GOTO 9999
14791 ENDIF
14792
14793* number of entries in LUJETS
14794
14795 NLINES = PYK(0,1)
14796
14797 NPYMEM = NLINES
14798
14799 DO 12 I=1,NLINES
14800 IFLG(I) = 0
14801 12 CONTINUE
14802
14803 DO 13 II=1,NLINES
14804
14805 IF ((PYK(II,7).EQ.1).AND.(IFLG(II).NE.1)) THEN
14806
14807* pick up mother resonance if possible and put it together with
14808* their decay-products into the common
14809 IDXMOR = K(II,3)
14810 IF ((IDXMOR.GE.1).AND.(IDXMOR.LE.MAXLND)) THEN
14811 KFMOR = K(IDXMOR,2)
14812 ISMOR = K(IDXMOR,1)
14813 ELSE
14814 KFMOR = 91
14815 ISMOR = 1
14816 ENDIF
14817 IF ((KFMOR.NE.91).AND.(KFMOR.NE.92).AND.
14818 & (KFMOR.NE.94).AND.(ISMOR.EQ.11)) THEN
14819 ID = K(IDXMOR,2)
14820 MO = IHISMO(PYK(IDXMOR,15))
14821 PX = PYP(IDXMOR,1)
14822 PY = PYP(IDXMOR,2)
14823 PZ = PYP(IDXMOR,3)
14824 PE = PYP(IDXMOR,4)
14825 CALL DT_EVTPUT(2,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14826 IFLG(IDXMOR) = 1
14827 MO = NHKK
14828 DO 15 JDAUG=K(IDXMOR,4),K(IDXMOR,5)
14829 IF (PYK(JDAUG,7).EQ.1) THEN
14830 ID = PYK(JDAUG,8)
14831 PX = PYP(JDAUG,1)
14832 PY = PYP(JDAUG,2)
14833 PZ = PYP(JDAUG,3)
14834 PE = PYP(JDAUG,4)
14835 CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14836 IF (LEMCCK) THEN
14837 PX = -PYP(JDAUG,1)
14838 PY = -PYP(JDAUG,2)
14839 PZ = -PYP(JDAUG,3)
14840 PE = -PYP(JDAUG,4)
14841 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
14842 ENDIF
14843 IFLG(JDAUG) = 1
14844 ENDIF
14845 15 CONTINUE
14846 ELSE
14847* there was no mother resonance
14848 MO = IHISMO(PYK(II,15))
14849 ID = PYK(II,8)
14850 PX = PYP(II,1)
14851 PY = PYP(II,2)
14852 PZ = PYP(II,3)
14853 PE = PYP(II,4)
14854 CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14855 IF (LEMCCK) THEN
14856 PX = -PYP(II,1)
14857 PY = -PYP(II,2)
14858 PZ = -PYP(II,3)
14859 PE = -PYP(II,4)
14860 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
14861 ENDIF
14862 ENDIF
14863 ENDIF
14864 13 CONTINUE
14865 IF (LEMCCK) THEN
14866 CHKLEV = TINY1
14867 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,6,IREJ1)
14868C IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
14869 ENDIF
14870
14871* global energy-momentum & flavor conservation check
14872**sr 16.5. this check is skipped in case of phojet-treatment
14873 IF (MCGENE.EQ.1)
14874 & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,12,IREJ3)
14875
14876* update statistics-counter for diffraction
14877c IF (IFLAGD.NE.0) THEN
14878c ICDIFF(1) = ICDIFF(1)+1
14879c IF (IFLAGD.EQ. 1) ICDIFF(2) = ICDIFF(2)+1
14880c IF (IFLAGD.EQ. 2) ICDIFF(3) = ICDIFF(3)+1
14881c IF (IFLAGD.EQ.-1) ICDIFF(4) = ICDIFF(4)+1
14882c IF (IFLAGD.EQ.-2) ICDIFF(5) = ICDIFF(5)+1
14883c ENDIF
14884
14885 ENDIF
14886
14887 RETURN
14888
14889 9999 CONTINUE
14890 IREJ = 1
14891 RETURN
14892 END
14893
14894*$ CREATE DT_DECAYS.FOR
14895*COPY DT_DECAYS
14896*
14897*===decay==============================================================*
14898*
14899 SUBROUTINE DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
14900
14901************************************************************************
14902* Resonance-decay. *
14903* This subroutine replaces DDECAY/DECHKK. *
14904* PIN(4) 4-momentum of resonance (input) *
14905* IDXIN BAMJET-index of resonance (input) *
14906* POUT(20,4) 4-momenta of decay-products (output) *
14907* IDXOUT(20) BAMJET-indices of decay-products (output) *
14908* NSEC number of secondaries (output) *
14909* Adopted from the original version DECHKK. *
14910* This version dated 09.01.95 is written by S. Roesler *
14911************************************************************************
14912
14913 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14914 SAVE
14915 PARAMETER ( LINP = 10 ,
14916 & LOUT = 6 ,
14917 & LDAT = 9 )
14918 PARAMETER (TINY17=1.0D-17)
14919
14920* HADRIN: decay channel information
14921 PARAMETER (IDMAX9=602)
14922 CHARACTER*8 ZKNAME
14923 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
14924* particle properties (BAMJET index convention)
14925 CHARACTER*8 ANAME
14926 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
14927 & IICH(210),IIBAR(210),K1(210),K2(210)
14928* flags for input different options
14929 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14930 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14931 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14932
14933 DIMENSION PIN(4),PI(20,4),POUT(20,4),IDXOUT(20),
14934 & EF(3),PF(3),PFF(3),IDXSTK(20),IDX(3),
14935 & CODF(3),COFF(3),SIFF(3),DCOS(3),DCOSF(3)
14936
14937* ISTAB = 1 strong and weak decays
14938* = 2 strong decays only
14939* = 3 strong decays, weak decays for charmed particles and tau
14940* leptons only
14941 DATA ISTAB /2/
14942
14943 IREJ = 0
14944 NSEC = 0
14945* put initial resonance to stack
14946 NSTK = 1
14947 IDXSTK(NSTK) = IDXIN
14948 DO 5 I=1,4
14949 PI(NSTK,I) = PIN(I)
14950 5 CONTINUE
14951
14952* store initial configuration for energy-momentum cons. check
14953 IF (LEMCCK) CALL DT_EVTEMC(PI(NSTK,1),PI(NSTK,2),PI(NSTK,3),
14954 & PI(NSTK,4),1,IDUM,IDUM)
14955
14956 100 CONTINUE
14957* get particle from stack
14958 IDXI = IDXSTK(NSTK)
14959* skip stable particles
14960 IF (ISTAB.EQ.1) THEN
14961 IF ((IDXI.EQ.135).OR. (IDXI.EQ.136)) GOTO 10
14962 IF ((IDXI.GE. 1).AND.(IDXI.LE. 7)) GOTO 10
14963 ELSEIF (ISTAB.EQ.2) THEN
14964 IF ((IDXI.GE. 1).AND.(IDXI.LE. 30)) GOTO 10
14965 IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
14966 IF ((IDXI.GE.115).AND.(IDXI.LE.122)) GOTO 10
14967 IF ((IDXI.GE.131).AND.(IDXI.LE.136)) GOTO 10
14968 IF ( IDXI.EQ.109) GOTO 10
14969 IF ((IDXI.GE.137).AND.(IDXI.LE.160)) GOTO 10
14970 ELSEIF (ISTAB.EQ.3) THEN
14971 IF ((IDXI.GE. 1).AND.(IDXI.LE. 23)) GOTO 10
14972 IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
14973 IF ((IDXI.GE.109).AND.(IDXI.LE.115)) GOTO 10
14974 IF ((IDXI.GE.133).AND.(IDXI.LE.136)) GOTO 10
14975 ENDIF
14976
14977* calculate direction cosines and Lorentz-parameter of decaying part.
14978 PTOT = SQRT(PI(NSTK,1)**2+PI(NSTK,2)**2+PI(NSTK,3)**2)
14979 PTOT = MAX(PTOT,TINY17)
14980 DO 1 I=1,3
14981 DCOS(I) = PI(NSTK,I)/PTOT
14982 1 CONTINUE
14983 GAM = PI(NSTK,4)/AAM(IDXI)
14984 BGAM = PTOT/AAM(IDXI)
14985
14986* get decay-channel
14987 KCHAN = K1(IDXI)-1
14988 2 CONTINUE
14989 KCHAN = KCHAN+1
14990 IF ((DT_RNDM(GAM)-TINY17).GT.WT(KCHAN)) GOTO 2
14991
14992* identities of secondaries
14993 IDX(1) = NZK(KCHAN,1)
14994 IDX(2) = NZK(KCHAN,2)
14995 IF (IDX(2).LT.1) GOTO 9999
14996 IDX(3) = NZK(KCHAN,3)
14997
14998* handle decay in rest system of decaying particle
14999 IF (IDX(3).EQ.0) THEN
15000* two-particle decay
15001 NDEC = 2
15002 CALL DT_DTWOPD(AAM(IDXI),EF(1),EF(2),PF(1),PF(2),
15003 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
15004 & AAM(IDX(1)),AAM(IDX(2)))
15005 ELSE
15006* three-particle decay
15007 NDEC = 3
15008 CALL DT_DTHREP(AAM(IDXI),EF(1),EF(2),EF(3),PF(1),PF(2),PF(3),
15009 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
15010 & CODF(3),COFF(3),SIFF(3),
15011 & AAM(IDX(1)),AAM(IDX(2)),AAM(IDX(3)))
15012 ENDIF
15013 NSTK = NSTK-1
15014
15015* transform decay products back
15016 DO 3 I=1,NDEC
15017 NSTK = NSTK+1
15018 CALL DT_DTRAFO(GAM,BGAM,DCOS(1),DCOS(2),DCOS(3),
15019 & CODF(I),COFF(I),SIFF(I),PF(I),EF(I),
15020 & PFF(I),DCOSF(1),DCOSF(2),DCOSF(3),PI(NSTK,4))
15021* add particle to stack
15022 IDXSTK(NSTK) = IDX(I)
15023 DO 4 J=1,3
15024 PI(NSTK,J) = DCOSF(J)*PFF(I)
15025 4 CONTINUE
15026 3 CONTINUE
15027 GOTO 100
15028
15029 10 CONTINUE
15030* stable particle, put to output-arrays
15031 NSEC = NSEC+1
15032 DO 6 I=1,4
15033 POUT(NSEC,I) = PI(NSTK,I)
15034 6 CONTINUE
15035 IDXOUT(NSEC) = IDXSTK(NSTK)
15036* store secondaries for energy-momentum conservation check
15037 IF (LEMCCK)
15038 &CALL DT_EVTEMC(-POUT(NSEC,1),-POUT(NSEC,2),-POUT(NSEC,3),
15039 & -POUT(NSEC,4),2,IDUM,IDUM)
15040 NSTK = NSTK-1
15041 IF (NSTK.GT.0) GOTO 100
15042
15043* check energy-momentum conservation
15044 IF (LEMCCK) THEN
15045 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,5,IREJ1)
15046 IF (IREJ1.NE.0) GOTO 9999
15047 ENDIF
15048
15049 RETURN
15050
15051 9999 CONTINUE
15052 IREJ = 1
15053 RETURN
15054 END
15055
15056*$ CREATE DT_DECAY1.FOR
15057*COPY DT_DECAY1
15058*
15059*===decay1=============================================================*
15060*
15061 SUBROUTINE DT_DECAY1
15062
15063************************************************************************
15064* Decay of resonances stored in DTEVT1. *
15065* This version dated 20.01.95 is written by S. Roesler *
15066************************************************************************
15067
15068 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15069 SAVE
15070 PARAMETER ( LINP = 10 ,
15071 & LOUT = 6 ,
15072 & LDAT = 9 )
15073
15074* event history
15075 PARAMETER (NMXHKK=200000)
15076 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15077 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15078 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15079* extended event history
15080 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15081 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15082 & IHIST(2,NMXHKK)
15083
15084 DIMENSION PIN(4),POUT(20,4),IDXOUT(20)
15085
15086 NEND = NHKK
15087C DO 1 I=NPOINT(5),NEND
15088 DO 1 I=NPOINT(4),NEND
15089 IF (ABS(ISTHKK(I)).EQ.1) THEN
15090 DO 2 K=1,4
15091 PIN(K) = PHKK(K,I)
15092 2 CONTINUE
15093 IDXIN = IDBAM(I)
15094 CALL DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
15095 IF (NSEC.GT.1) THEN
15096 DO 3 N=1,NSEC
15097 IDHAD = IDT_IPDGHA(IDXOUT(N))
15098 CALL DT_EVTPUT(1,IDHAD,I,0,POUT(N,1),POUT(N,2),
15099 & POUT(N,3),POUT(N,4),0,0,0)
15100 3 CONTINUE
15101 ENDIF
15102 ENDIF
15103 1 CONTINUE
15104
15105 RETURN
15106 END
15107
15108*$ CREATE DT_DECPI0.FOR
15109*COPY DT_DECPI0
15110*
15111*===decpi0=============================================================*
15112*
15113 SUBROUTINE DT_DECPI0
15114
15115************************************************************************
15116* Decay of pi0 handled with JETSET. *
15117* This version dated 18.02.96 is written by S. Roesler *
15118************************************************************************
15119
15120 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15121 SAVE
15122 PARAMETER ( LINP = 10 ,
15123 & LOUT = 6 ,
15124 & LDAT = 9 )
15125 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0,ZERO=0.0D0)
15126
15127* event history
15128 PARAMETER (NMXHKK=200000)
15129 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15130 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15131 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15132* extended event history
15133 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15134 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15135 & IHIST(2,NMXHKK)
bd378884 15136 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
9aaba0d6 15137 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15138 PARAMETER (MAXLND=4000)
15139 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
15140* flags for input different options
15141 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15142 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15143 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15144
15145 INTEGER PYCOMP,PYK
15146
15147 DIMENSION IHISMO(NMXHKK),P1(4)
15148
15149 TWOPI = 2.0D0*ATAN2(0.0D0,-1.0D0)
15150
15151 CALL DT_INITJS(2)
15152* allow pi0 decay
15153 KC = PYCOMP(111)
15154 MDCY(KC,1) = 1
15155
15156 NN = 0
15157 INI = 0
15158 DO 1 I=1,NHKK
15159 IF ((ISTHKK(I).EQ.1).AND.(IDHKK(I).EQ.111)) THEN
15160 IF (INI.EQ.0) THEN
15161 INI = 1
15162 ELSE
15163 INI = 2
15164 ENDIF
15165 IF (LEMCCK) CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
15166 & PHKK(4,I),INI,IDUM,IDUM)
15167 PT = SQRT(PHKK(1,I)**2+PHKK(2,I)**2)
15168 PTOT = SQRT(PT**2+PHKK(3,I)**2)
15169 COSTH = PHKK(3,I)/(PTOT+TINY10)
15170 IF (COSTH.GT.ONE) THEN
15171 THETA = ZERO
15172 ELSEIF (COSTH.LT.-ONE) THEN
15173 THETA = TWOPI/2.0D0
15174 ELSE
15175 THETA = ACOS(COSTH)
15176 ENDIF
15177 PHI = ASIN(PHKK(2,I)/(PT +TINY10))
15178 IF (PHKK(1,I).LT.0.0D0)
15179 & PHI = SIGN(TWOPI/2.0D0-ABS(PHI),PHI)
15180 ENER = PHKK(4,I)
15181 NN = NN+1
15182 KTEMP = MSTU(10)
15183 MSTU(10)= 1
15184 P(NN,5) = PHKK(5,I)
15185 CALL PY1ENT(NN,111,ENER,THETA,PHI)
15186 MSTU(10) = KTEMP
15187 IHISMO(NN)= I
15188 ENDIF
15189 1 CONTINUE
15190 IF (NN.GT.0) THEN
15191 CALL PYEXEC
15192 NLINES = PYK(0,1)
15193 DO 2 II=1,NLINES
15194 IF (PYK(II,7).EQ.1) THEN
15195 DO 3 KK=1,4
15196 P1(KK) = PYP(II,KK)
15197 3 CONTINUE
15198 ID = PYK(II,8)
15199 MO = IHISMO(PYK(II,15))
15200 CALL DT_EVTPUT(1,ID,MO,0,P1(1),P1(2),P1(3),P1(4),0,0,0)
15201 IF (LEMCCK)
15202 & CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,
15203 & IDUM,IDUM)
15204*sr: flag with neg. sign (for HELIOS p/A-W jobs)
15205 ISTHKK(MO) = -2
15206 ENDIF
15207 2 CONTINUE
15208 IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,7000,IREJ1)
15209 ENDIF
15210 MDCY(KC,1) = 0
15211
15212 RETURN
15213 END
15214
15215*$ CREATE DT_DTWOPD.FOR
15216*COPY DT_DTWOPD
15217*
15218*===dtwopd=============================================================*
15219*
15220 SUBROUTINE DT_DTWOPD(UMO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,COD2,
15221 & COF2,SIF2,AM1,AM2)
15222
15223************************************************************************
15224* Two-particle decay. *
15225* UMO cm-energy of the decaying system (input) *
15226* AM1/AM2 masses of the decay products (input) *
15227* ECM1,ECM2/PCM1,PCM2 cm-energies/momenta of the decay prod. (output) *
15228* COD,COF,SIF direction cosines of the decay prod. (output) *
15229* Revised by S. Roesler, 20.11.95 *
15230************************************************************************
15231
15232 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15233 SAVE
15234 PARAMETER ( LINP = 10 ,
15235 & LOUT = 6 ,
15236 & LDAT = 9 )
15237 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,ZERO=0.0D0)
15238
15239 IF (UMO.LT.(AM1+AM2)) THEN
15240 WRITE(LOUT,1000) UMO,AM1,AM2
15241 1000 FORMAT(1X,'DTWOPD: inconsistent kinematics - UMO,AM1,AM2 ',
15242 & 3E12.3)
15243 STOP
15244 ENDIF
15245
15246 ECM1 = ((UMO-AM2)*(UMO+AM2)+AM1*AM1)/(TWO*UMO)
15247 ECM2 = UMO-ECM1
15248 PCM1 = SQRT((ECM1-AM1)*(ECM1+AM1))
15249 PCM2 = PCM1
15250 CALL DT_DSFECF(SIF1,COF1)
15251 COD1 = TWO*DT_RNDM(PCM2)-ONE
15252 COD2 = -COD1
15253 COF2 = -COF1
15254 SIF2 = -SIF1
15255
15256 RETURN
15257 END
15258
15259*$ CREATE DT_DTHREP.FOR
15260*COPY DT_DTHREP
15261*
15262*===dthrep=============================================================*
15263*
15264 SUBROUTINE DT_DTHREP(UMO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,
15265 & SIF1,COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
15266
15267************************************************************************
15268* Three-particle decay. *
15269* UMO cm-energy of the decaying system (input) *
15270* AM1/2/3 masses of the decay products (input) *
15271* ECM1/2/2,PCM1/2/3 cm-energies/momenta of the decay prod. (output) *
15272* COD,COF,SIF direction cosines of the decay prod. (output) *
15273* *
15274* Threpd89: slight revision by A. Ferrari *
15275* Last change on 11-oct-93 by Alfredo Ferrari, INFN - Milan *
15276* Revised by S. Roesler, 20.11.95 *
15277************************************************************************
15278
15279 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15280 SAVE
15281 PARAMETER ( LINP = 10 ,
15282 & LOUT = 6 ,
15283 & LDAT = 9 )
15284
15285 PARAMETER ( ANGLSQ = 2.5D-31 )
15286 PARAMETER ( AZRZRZ = 1.0D-30 )
15287 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
15288 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
15289 PARAMETER ( ONEONE = 1.D+00 )
15290 PARAMETER ( TWOTWO = 2.D+00 )
15291 PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
15292
15293 COMMON /HNGAMR/ REDU,AMO,AMM(15)
15294* flags for input different options
15295 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15296 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15297 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15298
15299 DIMENSION F(5),XX(5)
15300 DATA EPS /AZRZRZ/
15301
15302 UMOO=UMO+UMO
15303C***S1, S2, S3 ARE THE INVARIANT MASSES OF THE PARTICLES 1, 2, 3
15304C***J. VON NEUMANN - RANDOM - SELECTION OF S2
15305C***CALCULATION OF THE MAXIMUM OF THE S2 - DISTRIBUTION
15306 UUMO=UMO
15307 AAM1=AM1
15308 AAM2=AM2
15309 AAM3=AM3
15310 GU=(AM2+AM3)**2
15311 GO=(UMO-AM1)**2
15312* UFAK=1.0000000000001D0
15313* IF (GU.GT.GO) UFAK=0.9999999999999D0
15314 IF (GU.GT.GO) THEN
15315 UFAK=ONEMNS
15316 ELSE
15317 UFAK=ONEPLS
15318 END IF
15319 OFAK=2.D0-UFAK
15320 GU=GU*UFAK
15321 GO=GO*OFAK
15322 DS2=(GO-GU)/99.D0
15323 AM11=AM1*AM1
15324 AM22=AM2*AM2
15325 AM33=AM3*AM3
15326 UMO2=UMO*UMO
15327 RHO2=0.D0
15328 S22=GU
15329 DO 124 I=1,100
15330 S21=S22
15331 S22=GU+(I-1.D0)*DS2
15332 RHO1=RHO2
15333 RHO2=DT_YLAMB(S22,UMO2,AM11)*DT_YLAMB(S22,AM22,AM33)/
15334 * (S22+EPS)
15335 IF(RHO2.LT.RHO1) GO TO 125
15336 124 CONTINUE
15337 125 S2SUP=(S22-S21)*.5D0+S21
15338 SUPRHO=DT_YLAMB(S2SUP,UMO2,AM11)*DT_YLAMB(S2SUP,AM22,AM33)/
15339 * (S2SUP+EPS)
15340 SUPRHO=SUPRHO*1.05D0
15341 XO=S21-DS2
15342 IF (GU.LT.GO.AND.XO.LT.GU) XO=GU
15343 IF (GU.GT.GO.AND.XO.GT.GU) XO=GU
15344 XX(1)=XO
15345 XX(3)=S22
15346 X1=(XO+S22)*0.5D0
15347 XX(2)=X1
15348 F(3)=RHO2
15349 F(1)=DT_YLAMB(XO,UMO2,AM11)*DT_YLAMB(XO,AM22,AM33)/(XO+EPS)
15350 F(2)=DT_YLAMB(X1,UMO2,AM11)*DT_YLAMB(X1,AM22,AM33)/(X1+EPS)
15351 DO 126 I=1,16
15352 X4=(XX(1)+XX(2))*0.5D0
15353 X5=(XX(2)+XX(3))*0.5D0
15354 F(4)=DT_YLAMB(X4,UMO2,AM11)*DT_YLAMB(X4,AM22,AM33)/
15355 * (X4+EPS)
15356 F(5)=DT_YLAMB(X5,UMO2,AM11)*DT_YLAMB(X5,AM22,AM33)/
15357 * (X5+EPS)
15358 XX(4)=X4
15359 XX(5)=X5
15360 DO 128 II=1,5
15361 IA=II
15362 DO 128 III=IA,5
15363 IF (F (II).GE.F (III)) GO TO 128
15364 FH=F(II)
15365 F(II)=F(III)
15366 F(III)=FH
15367 FH=XX(II)
15368 XX(II)=XX(III)
15369 XX(III)=FH
15370128 CONTINUE
15371 SUPRHO=F(1)
15372 S2SUP=XX(1)
15373 DO 129 II=1,3
15374 IA=II
15375 DO 129 III=IA,3
15376 IF (XX(II).GE.XX(III)) GO TO 129
15377 FH=F(II)
15378 F(II)=F(III)
15379 F(III)=FH
15380 FH=XX(II)
15381 XX(II)=XX(III)
15382 XX(III)=FH
15383129 CONTINUE
15384126 CONTINUE
15385 AM23=(AM2+AM3)**2
15386 ITH=0
15387 REDU=2.D0
15388 1 CONTINUE
15389 ITH=ITH+1
15390 IF (ITH.GT.200) REDU=-9.D0
15391 IF (ITH.GT.200) GO TO 400
15392 C=DT_RNDM(REDU)
15393* S2=AM23+C*((UMO-AM1)**2-AM23)
15394 S2=AM23+C*(UMO-AM1-AM2-AM3)*(UMO-AM1+AM2+AM3)
15395 Y=DT_RNDM(S2)
15396 Y=Y*SUPRHO
15397 RHO=DT_YLAMB(S2,UMO2,AM11)*DT_YLAMB(S2,AM22,AM33)/S2
15398 IF(Y.GT.RHO) GO TO 1
15399C***RANDOM SELECTION OF S3 AND CALCULATION OF S1
15400 S1=DT_RNDM(S2)
15401 S1=S1*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)/(2.D0*S2)-
15402 &RHO*.5D0
15403 S3=UMO2+AM11+AM22+AM33-S1-S2
15404 ECM1=(UMO2+AM11-S2)/UMOO
15405 ECM2=(UMO2+AM22-S3)/UMOO
15406 ECM3=(UMO2+AM33-S1)/UMOO
15407 PCM1=SQRT((ECM1+AM1)*(ECM1-AM1))
15408 PCM2=SQRT((ECM2+AM2)*(ECM2-AM2))
15409 PCM3=SQRT((ECM3+AM3)*(ECM3-AM3))
15410 CALL DT_DSFECF(SFE,CFE)
15411C***TH IS THE ANGLE BETWEEN PARTICLES 1 AND 2
15412C***TH1, TH2 ARE THE ANGLES BETWEEN PARTICLES 1, 2 AND THE DIRECTION OF
15413 PCM12 = PCM1 * PCM2
15414 IF ( PCM12 .LT. ANGLSQ ) GO TO 200
15415 COSTH=(ECM1*ECM2+0.5D+00*(AM11+AM22-S1))/PCM12
15416 GO TO 300
15417 200 CONTINUE
15418 UW=DT_RNDM(S1)
15419 COSTH=(UW-0.5D+00)*2.D+00
15420 300 CONTINUE
15421* IF(ABS(COSTH).GT.0.9999999999999999D0)
15422* &COSTH=SIGN(0.9999999999999999D0,COSTH)
15423 IF(ABS(COSTH).GT.ONEONE)
15424 &COSTH=SIGN(ONEONE,COSTH)
15425 IF (REDU.LT.1.D+00) RETURN
15426 COSTH2=(PCM3*PCM3+PCM2*PCM2-PCM1*PCM1)/(2.D+00*PCM2*PCM3)
15427* IF(ABS(COSTH2).GT.0.9999999999999999D0)
15428* &COSTH2=SIGN(0.9999999999999999D0,COSTH2)
15429 IF(ABS(COSTH2).GT.ONEONE)
15430 &COSTH2=SIGN(ONEONE,COSTH2)
15431 SINTH2=SQRT((ONEONE-COSTH2)*(ONEONE+COSTH2))
15432 SINTH =SQRT((ONEONE-COSTH)*(ONEONE+COSTH))
15433 SINTH1=COSTH2*SINTH-COSTH*SINTH2
15434 COSTH1=COSTH*COSTH2+SINTH2*SINTH
15435C***RANDOM SELECTION OF THE SPHERICAL COORDINATES OF THE DIRECTION OF PA
15436C***CFE, SFE ARE COS AND SIN OF THE ROTATION ANGLE OF THE SYSTEM 1, 2 AR
15437C***THE DIRECTION OF PARTICLE 3
15438C***CALCULATION OF THE SPHERICAL COORDINATES OF PARTICLES 1, 2
15439 CX11=-COSTH1
15440 CY11=SINTH1*CFE
15441 CZ11=SINTH1*SFE
15442 CX22=-COSTH2
15443 CY22=-SINTH2*CFE
15444 CZ22=-SINTH2*SFE
15445 CALL DT_DSFECF(SIF3,COF3)
15446 COD3=TWOTWO*DT_RNDM(CX11)-ONEONE
15447 SID3=SQRT((1.D+00-COD3)*(1.D+00+COD3))
15448 2 FORMAT(5F20.15)
15449 COD1=CX11*COD3+CZ11*SID3
15450 CHLP=(ONEONE-COD1)*(ONEONE+COD1)
15451 IF(CHLP.LT.1.D-14)WRITE(LOUT,2)COD1,COF3,SID3,
15452 &CX11,CZ11
15453 SID1=SQRT(CHLP)
15454 COF1=(CX11*SID3*COF3-CY11*SIF3-CZ11*COD3*COF3)/SID1
15455 SIF1=(CX11*SID3*SIF3+CY11*COF3-CZ11*COD3*SIF3)/SID1
15456 COD2=CX22*COD3+CZ22*SID3
15457 SID2=SQRT((ONEONE-COD2)*(ONEONE+COD2))
15458 COF2=(CX22*SID3*COF3-CY22*SIF3-CZ22*COD3*COF3)/SID2
15459 SIF2=(CX22*SID3*SIF3+CY22*COF3-CZ22*COD3*SIF3)/SID2
15460 400 CONTINUE
15461* === Energy conservation check: === *
15462 EOCHCK = UMO - ECM1 - ECM2 - ECM3
15463* SID1 = SQRT ( ( ONEONE - COD1 ) * ( ONEONE + COD1 ) )
15464* SID2 = SQRT ( ( ONEONE - COD2 ) * ( ONEONE + COD2 ) )
15465* SID3 = SQRT ( ( ONEONE - COD3 ) * ( ONEONE + COD3 ) )
15466 PZCHCK = PCM1 * COD1 + PCM2 * COD2 + PCM3 * COD3
15467 PXCHCK = PCM1 * COF1 * SID1 + PCM2 * COF2 * SID2
15468 & + PCM3 * COF3 * SID3
15469 PYCHCK = PCM1 * SIF1 * SID1 + PCM2 * SIF2 * SID2
15470 & + PCM3 * SIF3 * SID3
15471 EOCMPR = 1.D-12 * UMO
15472 IF ( ABS (EOCHCK) + ABS (PXCHCK) + ABS (PYCHCK) + ABS (PZCHCK)
15473 & .GT. EOCMPR ) THEN
15474**sr 5.5.95 output-unit changed
15475 IF (IOULEV(1).GT.0) THEN
15476 WRITE(LOUT,*)
15477 & ' *** Threpd: energy/momentum conservation failure! ***',
15478 & EOCHCK,PXCHCK,PYCHCK,PZCHCK
15479 WRITE(LOUT,*)' *** SID1,SID2,SID3',SID1,SID2,SID3
15480 ENDIF
15481**
15482 END IF
15483 RETURN
15484 END
15485
15486*$ CREATE DT_DBKLAS.FOR
15487*COPY DT_DBKLAS
15488*
15489*===dbklas=============================================================*
15490*
15491 SUBROUTINE DT_DBKLAS(I,J,K,I8,I10)
15492
15493 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15494 SAVE
15495 PARAMETER ( LINP = 10 ,
15496 & LOUT = 6 ,
15497 & LDAT = 9 )
15498
15499* quark-content to particle index conversion (DTUNUC 1.x)
15500 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
15501 & IA08(6,21),IA10(6,21)
15502
15503 IF (I) 20,20,10
15504* baryons
15505 10 CONTINUE
15506 CALL DT_INDEXD(J,K,IND)
15507 I8 = IB08(I,IND)
15508 I10 = IB10(I,IND)
15509 IF (I8.LE.0) I8 = I10
15510 RETURN
15511* antibaryons
15512 20 CONTINUE
15513 II = IABS(I)
15514 JJ = IABS(J)
15515 KK = IABS(K)
15516 CALL DT_INDEXD(JJ,KK,IND)
15517 I8 = IA08(II,IND)
15518 I10 = IA10(II,IND)
15519 IF (I8.LE.0) I8 = I10
15520
15521 RETURN
15522 END
15523
15524*$ CREATE DT_INDEXD.FOR
15525*COPY DT_INDEXD
15526*
15527*===indexd=============================================================*
15528*
15529 SUBROUTINE DT_INDEXD(KA,KB,IND)
15530
15531 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15532 SAVE
15533 PARAMETER ( LINP = 10 ,
15534 & LOUT = 6 ,
15535 & LDAT = 9 )
15536
15537 KP = KA*KB
15538 KS = KA+KB
15539 IF (KP.EQ.1) IND=1
15540 IF (KP.EQ.2) IND=2
15541 IF (KP.EQ.3) IND=3
15542 IF ((KP.EQ.4).AND.(KS.EQ.5)) IND=4
15543 IF (KP.EQ.5) IND=5
15544 IF ((KP.EQ.6).AND.(KS.EQ.7)) IND=6
15545 IF ((KP.EQ.4).AND.(KS.EQ.4)) IND=7
15546 IF ((KP.EQ.6).AND.(KS.EQ.5)) IND=8
15547 IF (KP.EQ.8) IND=9
15548 IF (KP.EQ.10) IND=10
15549 IF ((KP.EQ.12).AND.(KS.EQ.8)) IND=11
15550 IF (KP.EQ.9) IND=12
15551 IF ((KP.EQ.12).AND.(KS.EQ.7)) IND=13
15552 IF (KP.EQ.15) IND=14
15553 IF (KP.EQ.18) IND=15
15554 IF (KP.EQ.16) IND=16
15555 IF (KP.EQ.20) IND=17
15556 IF (KP.EQ.24) IND=18
15557 IF (KP.EQ.25) IND=19
15558 IF (KP.EQ.30) IND=20
15559 IF (KP.EQ.36) IND=21
15560
15561 RETURN
15562 END
15563
15564*$ CREATE DT_DCHANT.FOR
15565*COPY DT_DCHANT
15566*
15567*===dchant=============================================================*
15568*
15569 SUBROUTINE DT_DCHANT
15570
15571 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15572 SAVE
15573 PARAMETER ( LINP = 10 ,
15574 & LOUT = 6 ,
15575 & LDAT = 9 )
15576 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15577
15578* HADRIN: decay channel information
15579 PARAMETER (IDMAX9=602)
15580 CHARACTER*8 ZKNAME
15581 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
15582* particle properties (BAMJET index convention)
15583 CHARACTER*8 ANAME
15584 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
15585 & IICH(210),IIBAR(210),K1(210),K2(210)
15586
15587 DIMENSION HWT(IDMAX9)
15588
15589* change of weights wt from absolut values into the sum of wt of a dec.
15590 DO 10 J=1,IDMAX9
15591 HWT(J) = ZERO
15592 10 CONTINUE
15593C DO 999 KKK=1,210
15594C WRITE(LOUT,'(A8,F5.2,2E10.3,2I4,2I10)')
15595C & ANAME(KKK),AAM(KKK),GA(KKK),TAU(KKK),IICH(KKK),IIBAR(KKK),
15596C & K1(KKK),K2(KKK)
15597C 999 CONTINUE
15598C STOP
15599 DO 30 I=1,210
15600 IK1 = K1(I)
15601 IK2 = K2(I)
15602 HV = ZERO
15603 DO 20 J=IK1,IK2
15604 HV = HV+WT(J)
15605 HWT(J) = HV
15606**sr 13.1.95
15607 IF (HWT(J).GT.1.0001) WRITE(LOUT,1000) HWT(J),J,I,IK1
15608 1000 FORMAT(2X,15H ERROR IN HWT =,1F10.5,8H J,I,K1=,3I5)
15609 20 CONTINUE
15610 30 CONTINUE
15611 DO 40 J=1,IDMAX9
15612 WT(J) = HWT(J)
15613 40 CONTINUE
15614
15615 RETURN
15616 END
15617
15618*$ CREATE DT_DDATAR.FOR
15619*COPY DT_DDATAR
15620*
15621*===ddatar=============================================================*
15622*
15623 SUBROUTINE DT_DDATAR
15624
15625 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15626 SAVE
15627 PARAMETER ( LINP = 10 ,
15628 & LOUT = 6 ,
15629 & LDAT = 9 )
15630 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15631
15632* quark-content to particle index conversion (DTUNUC 1.x)
15633 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
15634 & IA08(6,21),IA10(6,21)
15635
15636 DIMENSION IV(36),IP(36),IB(126),IBB(126),IA(126),IAA(126)
15637
15638 DATA IV/ 33, 34, 38,123, 0, 0, 32, 33, 39,124,
15639 & 0, 0, 36, 37, 96,127, 0, 0,126,125,
15640 & 128,129,14*0/
15641 DATA IP/ 23, 14, 16,116, 0, 0, 13, 23, 25,117,
15642 & 0, 0, 15, 24, 31,120, 0, 0,119,118,
15643 & 121,122,14*0/
15644 DATA IB/ 0, 1, 21,140, 0, 0, 8, 22,137, 0,
15645 & 0, 97,138, 0, 0,146, 0, 0, 0, 0,
15646 & 0, 1, 8, 22,137, 0, 0, 0, 20,142,
15647 & 0, 0, 98,139, 0, 0,147, 0, 0, 0,
15648 & 0, 0, 21, 22, 97,138, 0, 0, 20, 98,
15649 & 139, 0, 0, 0,145, 0, 0,148, 0, 0,
15650 & 0, 0, 0,140,137,138,146, 0, 0,142,
15651 & 139,147, 0, 0,145,148, 50*0/
15652 DATA IBB/53, 54,104,161, 0, 0, 55,105,162, 0,
15653 & 0,107,164, 0, 0,167, 0, 0, 0, 0,
15654 & 0, 54, 55,105,162, 0, 0, 56,106,163,
15655 & 0, 0,108,165, 0, 0,168, 0, 0, 0,
15656 & 0, 0,104,105,107,164, 0, 0,106,108,
15657 & 165, 0, 0,109,166, 0, 0,169, 0, 0,
15658 & 0, 0, 0,161,162,164,167, 0, 0,163,
15659 & 165,168, 0, 0,166,169, 0, 0,170,47*0/
15660 DATA IA/ 0, 2, 99,152, 0, 0, 9,100,149, 0,
15661 & 0,102,150, 0, 0,158, 0, 0, 0, 0,
15662 & 0, 2, 9,100,149, 0, 0, 0,101,154,
15663 & 0, 0,103,151, 0, 0,159, 0, 0, 0,
15664 & 0, 0, 99,100,102,150, 0, 0,101,103,
15665 & 151, 0, 0, 0,157, 0, 0,160, 0, 0,
15666 & 0, 0, 0,152,149,150,158, 0, 0,154,
15667 & 151,159, 0, 0,157,160, 50*0/
15668 DATA IAA/67, 68,110,171, 0, 0, 69,111,172, 0,
15669 & 0,113,174, 0, 0,177, 0, 0, 0, 0,
15670 & 0, 68, 69,111,172, 0, 0, 70,112,173,
15671 & 0, 0,114,175, 0, 0,178, 0, 0, 0,
15672 & 0, 0,110,111,113,174, 0, 0,112,114,
15673 & 175, 0, 0,115,176, 0, 0,179, 0, 0,
15674 & 0, 0, 0,171,172,174,177, 0, 0,173,
15675 & 175,178, 0, 0,176,179, 0, 0,180,47*0/
15676
15677 L=0
15678 DO 2 I=1,6
15679 DO 1 J=1,6
15680 L = L+1
15681 IMPS(I,J) = IP(L)
15682 IMVE(I,J) = IV(L)
15683 1 CONTINUE
15684 2 CONTINUE
15685 L=0
15686 DO 4 I=1,6
15687 DO 3 J=1,21
15688 L = L+1
15689 IB08(I,J) = IB(L)
15690 IB10(I,J) = IBB(L)
15691 IA08(I,J) = IA(L)
15692 IA10(I,J) = IAA(L)
15693 3 CONTINUE
15694 4 CONTINUE
15695C A1 = 0.88D0
15696C B1 = 3.0D0
15697C B2 = 3.0D0
15698C B3 = 8.0D0
15699C LT = 0
15700C LB = 0
15701C BET = 12.0D0
15702C AS = 0.25D0
15703C B8 = 0.33D0
15704C AME = 0.95D0
15705C DIQ = 0.375D0
15706C ISU = 4
15707
15708 RETURN
15709 END
15710
15711*$ CREATE DT_INITJS.FOR
15712*COPY DT_INITJS
15713*
15714*===initjs=============================================================*
15715*
15716 SUBROUTINE DT_INITJS(MODE)
15717
15718************************************************************************
15719* Initialize JETSET paramters. *
15720* MODE = 0 default settings *
15721* = 1 PHOJET settings *
15722* = 2 DTUNUC settings *
15723* This version dated 16.02.96 is written by S. Roesler *
15724* *
15725* Last change 27.12.2006 by S. Roesler. *
15726************************************************************************
15727
15728 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15729 SAVE
15730 PARAMETER ( LINP = 10 ,
15731 & LOUT = 6 ,
15732 & LDAT = 9 )
15733 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15734
15735 LOGICAL LFIRST,LFIRDT,LFIRPH
15736
15737 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15738 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
bd378884 15739 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
9aaba0d6 15740* flags for particle decays
15741 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
15742 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
15743 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
15744* flags for input different options
15745 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15746 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15747 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15748
15749 INTEGER PYCOMP
15750
15751 DIMENSION IDXSTA(40)
15752 DATA IDXSTA
15753* K0s pi0 lam alam sig+ asig+ sig- asig- tet0 atet0
15754 & / 310, 111, 3122,-3122, 3222,-3222, 3112,-3112, 3322,-3322,
15755* tet- atet- om- aom- D+ D- D0 aD0 Ds+ aDs+
15756 & 3312,-3312, 3334,-3334, 411, -411, 421, -421, 431, -431,
15757* etac lamc+alamc+sigc++ sigc+ sigc0asigc++asigc+asigc0 Ksic+
15758 & 441, 4122,-4122, 4222, 4212, 4112,-4222,-4212,-4112, 4232,
15759* Ksic0 aKsic+aKsic0 sig0 asig0
15760 & 4132,-4232,-4132, 3212,-3212, 5*0/
15761
15762 DATA LFIRST,LFIRDT,LFIRPH /.TRUE.,.TRUE.,.TRUE./
15763
15764 IF (LFIRST) THEN
15765* save default settings
15766 PDEF1 = PARJ(1)
15767 PDEF2 = PARJ(2)
15768 PDEF3 = PARJ(3)
15769 PDEF5 = PARJ(5)
15770 PDEF6 = PARJ(6)
15771 PDEF7 = PARJ(7)
15772 PDEF18 = PARJ(18)
15773 PDEF19 = PARJ(19)
15774 PDEF21 = PARJ(21)
15775 PDEF42 = PARJ(42)
15776 MDEF12 = MSTJ(12)
15777* LUJETS / PYJETS array-dimensions
15778 MSTU(4) = 4000
15779* increase maximum number of JETSET-error prints
15780 MSTU(22) = 50000
15781* prevent particles decaying
15782 DO 1 I=1,35
15783 IF (I.LT.34) THEN
15784 KC = PYCOMP(IDXSTA(I))
15785 IF (KC.GT.0) THEN
15786 IF (I.EQ.2) THEN
15787* pi0 decay
15788C MDCY(KC,1) = 1
15789 MDCY(KC,1) = 0
15790**cr mode
15791C ELSEIF ((I.EQ.4).OR.(I.EQ. 6).OR.
15792C & (I.EQ.8).OR.(I.EQ.10)) THEN
15793C ELSEIF (I.EQ.4) THEN
15794C MDCY(KC,1) = 1
15795**
15796 ELSE
1ddc441c 15797C AM MDCY(KC,1) = 0
9aaba0d6 15798 ENDIF
15799 ENDIF
15800 ELSEIF (((I.EQ.34).OR.(I.EQ.35)).AND.(ISIG0.EQ.0)) THEN
15801 KC = PYCOMP(IDXSTA(I))
15802 IF (KC.GT.0) THEN
1ddc441c 15803C AM MDCY(KC,1) = 0
9aaba0d6 15804 ENDIF
15805 ENDIF
15806 1 CONTINUE
15807*
15808*
15809* popcorn:
15810 IF (PDB.LE.ZERO) THEN
15811* no popcorn-mechanism
15812 MSTJ(12) = 1
15813 ELSE
15814 MSTJ(12) = 3
15815 PARJ(5) = PDB
15816 ENDIF
15817* set JETSET-parameter requested by input cards
15818 IF (NMSTU.GT.0) THEN
15819 DO 2 I=1,NMSTU
15820 MSTU(IMSTU(I)) = MSTUX(I)
15821 2 CONTINUE
15822 ENDIF
15823 IF (NMSTJ.GT.0) THEN
15824 DO 3 I=1,NMSTJ
15825 MSTJ(IMSTJ(I)) = MSTJX(I)
15826 3 CONTINUE
15827 ENDIF
15828 IF (NPARU.GT.0) THEN
15829 DO 4 I=1,NPARU
15830 PARU(IPARU(I)) = PARUX(I)
15831 4 CONTINUE
15832 ENDIF
15833 LFIRST = .FALSE.
15834 ENDIF
15835*
15836* PARJ(1) suppression of qq-aqaq pair prod. compared to
15837* q-aq pair prod. (default: 0.1)
15838* PARJ(2) strangeness suppression (default: 0.3)
15839* PARJ(3) extra suppression of strange diquarks (default: 0.4)
15840* PARJ(6) extra suppression of sas-pair shared by B and
15841* aB in BMaB (default: 0.5)
15842* PARJ(7) extra suppression of strange meson M in BMaB
15843* configuration (default: 0.5)
15844* PARJ(18) spin 3/2 baryon suppression (default: 1.0)
15845* PARJ(21) width sigma in Gaussian p_x, p_y transverse
15846* momentum distrib. for prim. hadrons (default: 0.35)
15847* PARJ(42) b-parameter for symmetric Lund-fragmentation
15848* function (default: 0.9 GeV^-2)
15849*
15850* PHOJET settings
15851 IF (MODE.EQ.1) THEN
15852* JETSET default
15853C PARJ(1) = PDEF1
15854C PARJ(2) = PDEF2
15855C PARJ(3) = PDEF3
15856C PARJ(6) = PDEF6
15857C PARJ(7) = PDEF7
15858C PARJ(18) = PDEF18
15859C PARJ(21) = PDEF21
15860C PARJ(42) = PDEF42
15861**sr 18.11.98 parameter tuning
15862C PARJ(1) = 0.092D0
15863C PARJ(2) = 0.25D0
15864C PARJ(3) = 0.45D0
15865C PARJ(19) = 0.3D0
15866C PARJ(21) = 0.45D0
15867C PARJ(42) = 1.0D0
15868**sr 28.04.99 parameter tuning (May 99 minor modifications)
15869 PARJ(1) = 0.085D0
15870 PARJ(2) = 0.26D0
15871 PARJ(3) = 0.8D0
15872 PARJ(11) = 0.38D0
15873 PARJ(18) = 0.3D0
15874 PARJ(19) = 0.4D0
15875 PARJ(21) = 0.36D0
15876 PARJ(41) = 0.3D0
15877 PARJ(42) = 0.86D0
15878 IF (NPARJ.GT.0) THEN
15879 DO 10 I=1,NPARJ
15880 IF (IPARJ(I).GT.0) PARJ(IPARJ(I)) = PARJX(I)
15881 10 CONTINUE
15882 ENDIF
15883 IF (LFIRPH) THEN
15884 WRITE(LOUT,'(1X,A)')
15885 & 'DT_INITJS: JETSET-parameter for PHOJET'
15886 CALL DT_JSPARA(0)
15887 LFIRPH = .FALSE.
15888 ENDIF
15889* DTUNUC settings
15890 ELSEIF (MODE.EQ.2) THEN
15891 IF (IFRAG(2).EQ.1) THEN
15892**sr parameters before 9.3.96
15893C PARJ(2) = 0.27D0
15894C PARJ(3) = 0.6D0
15895C PARJ(6) = 0.75D0
15896C PARJ(7) = 0.75D0
15897C PARJ(21) = 0.55D0
15898C PARJ(42) = 1.3D0
15899**sr 18.11.98 parameter tuning
15900C PARJ(1) = 0.05D0
15901C PARJ(2) = 0.27D0
15902C PARJ(3) = 0.4D0
15903C PARJ(19) = 0.2D0
15904C PARJ(21) = 0.45D0
15905C PARJ(42) = 1.0D0
15906**sr 28.04.99 parameter tuning
15907 PARJ(1) = 0.11D0
15908 PARJ(2) = 0.36D0
15909 PARJ(3) = 0.8D0
15910 PARJ(19) = 0.2D0
15911 PARJ(21) = 0.3D0
15912 PARJ(41) = 0.3D0
15913 PARJ(42) = 0.58D0
15914 IF (NPARJ.GT.0) THEN
15915 DO 20 I=1,NPARJ
15916 IF (IPARJ(I).LT.0) THEN
15917 IDX = ABS(IPARJ(I))
15918 PARJ(IDX) = PARJX(I)
15919 ENDIF
15920 20 CONTINUE
15921 ENDIF
15922 IF (LFIRDT) THEN
15923 WRITE(LOUT,'(1X,A)')
15924 & 'DT_INITJS: JETSET-parameter for DTUNUC'
15925 CALL DT_JSPARA(0)
15926 LFIRDT = .FALSE.
15927 ENDIF
15928 ELSEIF (IFRAG(2).EQ.2) THEN
15929 PARJ(1) = 0.11D0
15930 PARJ(2) = 0.27D0
15931 PARJ(3) = 0.3D0
15932 PARJ(6) = 0.35D0
15933 PARJ(7) = 0.45D0
15934 PARJ(18) = 0.66D0
15935C PARJ(21) = 0.55D0
15936C PARJ(42) = 1.0D0
15937 PARJ(21) = 0.60D0
15938 PARJ(42) = 1.3D0
15939 ELSE
15940 PARJ(1) = PDEF1
15941 PARJ(2) = PDEF2
15942 PARJ(3) = PDEF3
15943 PARJ(6) = PDEF6
15944 PARJ(7) = PDEF7
15945 PARJ(18) = PDEF18
15946 PARJ(21) = PDEF21
15947 PARJ(42) = PDEF42
15948 ENDIF
15949 ELSE
15950 PARJ(1) = PDEF1
15951 PARJ(2) = PDEF2
15952 PARJ(3) = PDEF3
15953 PARJ(5) = PDEF5
15954 PARJ(6) = PDEF6
15955 PARJ(7) = PDEF7
15956 PARJ(18) = PDEF18
15957 PARJ(19) = PDEF19
15958 PARJ(21) = PDEF21
15959 PARJ(42) = PDEF42
15960 MSTJ(12) = MDEF12
15961 ENDIF
15962
15963 RETURN
15964 END
15965
15966*$ CREATE DT_JSPARA.FOR
15967*COPY DT_JSPARA
15968*
15969*===jspara=============================================================*
15970*
15971 SUBROUTINE DT_JSPARA(MODE)
15972
15973 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15974 SAVE
15975 PARAMETER ( LINP = 10 ,
15976 & LOUT = 6 ,
15977 & LDAT = 9 )
15978 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1,
15979 & ONE=1.0D0,ZERO=0.0D0)
15980
15981 LOGICAL LFIRST
15982
15983 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15984
15985 DIMENSION ISTU(200),QARU(200),ISTJ(200),QARJ(200)
15986
15987 DATA LFIRST /.TRUE./
15988
15989* save the default JETSET-parameter on the first call
15990 IF (LFIRST) THEN
15991 DO 1 I=1,200
15992 ISTU(I) = MSTU(I)
15993 QARU(I) = PARU(I)
15994 ISTJ(I) = MSTJ(I)
15995 QARJ(I) = PARJ(I)
15996 1 CONTINUE
15997 LFIRST = .FALSE.
15998 ENDIF
15999
16000 WRITE(LOUT,1000)
16001 1000 FORMAT(1X,'DT_JSPARA: new value (default value)')
16002
16003* compare the default JETSET-parameter with the present values
16004 DO 2 I=1,200
16005 IF ((MSTU(I).NE.ISTU(I)).AND.(I.NE.31)) THEN
16006 WRITE(LOUT,1002) 'MSTU(',I,MSTU(I),ISTU(I)
16007C ISTU(I) = MSTU(I)
16008 ENDIF
16009 DIFF = ABS(PARU(I)-QARU(I))
16010 IF ((DIFF.GE.1.0D-5).AND.(I.NE.21)) THEN
16011 WRITE(LOUT,1001) 'PARU(',I,PARU(I),QARU(I)
16012C QARU(I) = PARU(I)
16013 ENDIF
16014 IF (MSTJ(I).NE.ISTJ(I)) THEN
16015 WRITE(LOUT,1002) 'MSTJ(',I,MSTJ(I),ISTJ(I)
16016C ISTJ(I) = MSTJ(I)
16017 ENDIF
16018 DIFF = ABS(PARJ(I)-QARJ(I))
16019 IF (DIFF.GE.1.0D-5) THEN
16020 WRITE(LOUT,1001) 'PARJ(',I,PARJ(I),QARJ(I)
16021C QARJ(I) = PARJ(I)
16022 ENDIF
16023 2 CONTINUE
16024 1001 FORMAT(12X,A5,I3,'): ',F6.3,' (',F6.3,')')
16025 1002 FORMAT(12X,A5,I3,'): ',I6,' (',I6,')')
16026
16027 RETURN
16028 END
16029
16030*$ CREATE DT_FOZOCA.FOR
16031*COPY DT_FOZOCA
16032*
16033*===fozoca=============================================================*
16034*
16035 SUBROUTINE DT_FOZOCA(LFZC,IREJ)
16036
16037************************************************************************
16038* This subroutine treats the complete FOrmation ZOne supressed intra- *
16039* nuclear CAscade. *
16040* LFZC = .true. cascade has been treated *
16041* = .false. cascade skipped *
16042* This is a completely revised version of the original FOZOKL. *
16043* This version dated 18.11.95 is written by S. Roesler *
16044************************************************************************
16045
16046 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16047 SAVE
16048 PARAMETER ( LINP = 10 ,
16049 & LOUT = 6 ,
16050 & LDAT = 9 )
16051 PARAMETER (DLARGE=1.0D10,OHALF=0.5D0,ZERO=0.0D0)
16052 PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16053
16054 LOGICAL LSTART,LCAS,LFZC
16055
16056* event history
16057 PARAMETER (NMXHKK=200000)
16058 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16059 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16060 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16061* extended event history
16062 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16063 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16064 & IHIST(2,NMXHKK)
16065* rejection counter
16066 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
16067 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
16068 & IREXCI(3),IRDIFF(2),IRINC
16069* properties of interacting particles
16070 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
16071* Glauber formalism: collision properties
16072 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
e3f546f5 16073 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
16074 & NCP,NCT
9aaba0d6 16075* flags for input different options
16076 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16077 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16078 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16079* final state after intranuclear cascade step
16080 COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16081* parameter for intranuclear cascade
16082 LOGICAL LPAULI
16083 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16084
16085 DIMENSION NCWOUN(2)
16086
16087 DATA LSTART /.TRUE./
16088
16089 LFZC = .TRUE.
16090 IREJ = 0
16091
16092* skip cascade if hadron-hadron interaction or if supressed by user
16093 IF (((IP.EQ.1).AND.(IT.EQ.1)).OR.(KTAUGE.LT.1)) GOTO 9999
16094* skip cascade if not all possible chains systems are hadronized
16095 DO 1 I=1,8
16096 IF (.NOT.LHADRO(I)) GOTO 9999
16097 1 CONTINUE
16098
16099 IF (LSTART) THEN
16100 WRITE(LOUT,1000) KTAUGE,TAUFOR,INCMOD
16101 1000 FORMAT(/,1X,'FOZOCA: intranuclear cascade treated for a ',
16102 & 'maximum of',I4,' generations',/,10X,'formation time ',
16103 & 'parameter:',F5.1,' fm/c',9X,'modus:',I2)
16104 IF (ITAUVE.EQ.1) WRITE(LOUT,1001)
16105 IF (ITAUVE.EQ.2) WRITE(LOUT,1002)
16106 1001 FORMAT(10X,'p_t dependent formation zone',/)
16107 1002 FORMAT(10X,'constant formation zone',/)
16108 LSTART = .FALSE.
16109 ENDIF
16110
16111* in order to avoid wasting of cpu-time the DTEVT1-indices of nucleons
16112* which may interact with final state particles are stored in a seperate
16113* array - here all proj./target nucleon-indices (just for simplicity)
16114 NOINC = 0
16115 DO 9 I=1,NPOINT(1)-1
16116 NOINC = NOINC+1
16117 IDXINC(NOINC) = I
16118 9 CONTINUE
16119
16120* initialize Pauli-principle treatment (find wounded nucleons)
16121 NWOUND(1) = 0
16122 NWOUND(2) = 0
16123 NCWOUN(1) = 0
16124 NCWOUN(2) = 0
16125 DO 2 J=1,NPOINT(1)
16126 DO 3 I=1,2
16127 IF (ISTHKK(J).EQ.10+I) THEN
16128 NWOUND(I) = NWOUND(I)+1
16129 EWOUND(I,NWOUND(I)) = PHKK(4,J)
16130 IF (IDHKK(J).EQ.2212) NCWOUN(I) = NCWOUN(I)+1
16131 ENDIF
16132 3 CONTINUE
16133 2 CONTINUE
16134
16135* modify nuclear potential for wounded nucleons
16136 IPRCL = IP -NWOUND(1)
16137 IPZRCL = IPZ-NCWOUN(1)
16138 ITRCL = IT -NWOUND(2)
16139 ITZRCL = ITZ-NCWOUN(2)
16140 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
16141
16142 NSTART = NPOINT(4)
16143 NEND = NHKK
16144
16145 7 CONTINUE
16146 DO 8 I=NSTART,NEND
16147
16148 IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDCH(I).LT.KTAUGE)) THEN
16149* select nucleus the cascade starts first (proj. - 1, target - -1)
16150 NCAS = 1
16151* projectile/target with probab. 1/2
16152 IF ((INCMOD.EQ.1).OR.(IDCH(I).GT.0)) THEN
16153 IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16154* in the nucleus with highest mass
16155 ELSEIF (INCMOD.EQ.2) THEN
16156 IF (IP.GT.IT) THEN
16157 NCAS = -NCAS
16158 ELSEIF (IP.EQ.IT) THEN
16159 IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16160 ENDIF
16161* the nucleus the cascade starts first is requested to be the one
16162* moving in the direction of the secondary
16163 ELSEIF (INCMOD.EQ.3) THEN
16164 NCAS = INT(SIGN(1.0D0,PHKK(3,I)))
16165 ENDIF
16166* check that the selected "nucleus" is not a hadron
16167 IF (((NCAS.EQ. 1).AND.(IP.LE.1)).OR.
16168 & ((NCAS.EQ.-1).AND.(IT.LE.1))) NCAS = -NCAS
16169
16170* treat intranuclear cascade in the nucleus selected first
16171 LCAS = .FALSE.
16172 CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
16173 IF (IREJ1.NE.0) GOTO 9998
16174* treat intranuclear cascade in the other nucleus if this isn't a had.
16175 NCAS = -NCAS
16176 IF (((NCAS.EQ. 1).AND.(IP.GT.1)).OR.
16177 & ((NCAS.EQ.-1).AND.(IT.GT.1))) THEN
16178 IF (LCAS) CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
16179 IF (IREJ1.NE.0) GOTO 9998
16180 ENDIF
16181
16182 ENDIF
16183
16184 8 CONTINUE
16185 NSTART = NEND+1
16186 NEND = NHKK
16187 IF (NSTART.LE.NEND) GOTO 7
16188
16189 RETURN
16190
16191 9998 CONTINUE
16192* reject this event
16193 IRINC = IRINC+1
16194 IREJ = 1
16195
16196 9999 CONTINUE
16197* intranucl. cascade not treated because of interaction properties or
16198* it is supressed by user or it was rejected or...
16199 LFZC = .FALSE.
16200* reset flag characterizing direction of motion in n-n-cms
16201**sr14-11-95
16202C DO 9990 I=NPOINT(5),NHKK
16203C IF (ISTHKK(I).EQ.-1) ISTHKK(I)=1
16204C9990 CONTINUE
16205
16206 RETURN
16207 END
16208
16209*$ CREATE DT_INUCAS.FOR
16210*COPY DT_INUCAS
16211*
16212*===inucas=============================================================*
16213*
16214 SUBROUTINE DT_INUCAS(IT,IP,IDXCAS,LCAS,NCAS,IREJ)
16215
16216************************************************************************
16217* Formation zone supressed IntraNUclear CAScade for one final state *
16218* particle. *
16219* IT, IP mass numbers of target, projectile nuclei *
16220* IDXCAS index of final state particle in DTEVT1 *
16221* NCAS = 1 intranuclear cascade in projectile *
16222* = -1 intranuclear cascade in target *
16223* This version dated 18.11.95 is written by S. Roesler *
16224************************************************************************
16225
16226 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16227 SAVE
16228 PARAMETER ( LINP = 10 ,
16229 & LOUT = 6 ,
16230 & LDAT = 9 )
16231
16232 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
16233 & OHALF=0.5D0,ONE=1.0D0)
16234 PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16235 PARAMETER (TWOPI=6.283185307179586454D+00)
16236 PARAMETER (PLOWH=0.01D0,PHIH=9.0D0)
16237
16238 LOGICAL LABSOR,LCAS
16239
16240* event history
16241 PARAMETER (NMXHKK=200000)
16242 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16243 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16244 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16245* extended event history
16246 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16247 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16248 & IHIST(2,NMXHKK)
16249* final state after inc step
16250 PARAMETER (MAXFSP=10)
16251 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
16252* flags for input different options
16253 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16254 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16255 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16256* particle properties (BAMJET index convention)
16257 CHARACTER*8 ANAME
16258 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
16259 & IICH(210),IIBAR(210),K1(210),K2(210)
16260* Glauber formalism: collision properties
16261 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
e3f546f5 16262 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
16263 & NCP,NCT
9aaba0d6 16264* nuclear potential
16265 LOGICAL LFERMI
16266 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
16267 & EBINDP(2),EBINDN(2),EPOT(2,210),
16268 & ETACOU(2),ICOUL,LFERMI
16269* parameter for intranuclear cascade
16270 LOGICAL LPAULI
16271 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16272* final state after intranuclear cascade step
16273 COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16274* nucleon-nucleon event-generator
16275 CHARACTER*8 CMODEL
16276 LOGICAL LPHOIN
16277 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
16278* statistics: residual nuclei
16279 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
16280 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
16281 & NINCST(2,4),NINCEV(2),
16282 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
16283 & NRESPB(2),NRESCH(2),NRESEV(4),
16284 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
16285 & NEVAFI(2,2)
16286
16287 DIMENSION PCAS(2,5),PTOCAS(2),COSCAS(2,3),VTXCAS(2,4),VTXCA1(2,4),
16288 & PCAS1(5),PNUC(5),BGTA(4),
16289 & BGCAS(2),GACAS(2),BECAS(2),
16290 & RNUC(2),BIMPC(2),VTXDST(3),IDXSPE(2),IDSPE(2),NWTMP(2)
16291
16292 DATA PDIF /0.545D0/
16293
16294 IREJ = 0
16295
16296* update counter
16297 IF (NINCEV(1).NE.NEVHKK) THEN
16298 NINCEV(1) = NEVHKK
16299 NINCEV(2) = NINCEV(2)+1
16300 ENDIF
16301
16302* "BAMJET-index" of this hadron
16303 IDCAS = IDBAM(IDXCAS)
16304 IF (IDT_MCHAD(IDCAS).EQ.-1) RETURN
16305
16306* skip gammas, electrons, etc..
16307 IF (AAM(IDCAS).LT.TINY2) RETURN
16308
16309* Lorentz-trsf. into projectile rest system
16310 IF (IP.GT.1) THEN
16311 CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
16312 & PHKK(4,IDXCAS),PCAS(1,1),PCAS(1,2),PCAS(1,3),
16313 & PCAS(1,4),IDCAS,-2)
16314 PTOCAS(1) = SQRT(PCAS(1,1)**2+PCAS(1,2)**2+PCAS(1,3)**2)
16315 PCAS(1,5) = (PCAS(1,4)-PTOCAS(1))*(PCAS(1,4)+PTOCAS(1))
16316 IF (PCAS(1,5).GT.ZERO) THEN
16317 PCAS(1,5) = SQRT(PCAS(1,5))
16318 ELSE
16319 PCAS(1,5) = AAM(IDCAS)
16320 ENDIF
16321 DO 20 K=1,3
16322 COSCAS(1,K) = PCAS(1,K)/MAX(PTOCAS(1),TINY10)
16323 20 CONTINUE
16324* Lorentz-parameters
16325* particle rest system --> projectile rest system
16326 BGCAS(1) = PTOCAS(1)/MAX(PCAS(1,5),TINY10)
16327 GACAS(1) = PCAS(1,4)/MAX(PCAS(1,5),TINY10)
16328 BECAS(1) = BGCAS(1)/GACAS(1)
16329 ELSE
16330 DO 21 K=1,5
16331 PCAS(1,K) = ZERO
16332 IF (K.LE.3) COSCAS(1,K) = ZERO
16333 21 CONTINUE
16334 PTOCAS(1) = ZERO
16335 BGCAS(1) = ZERO
16336 GACAS(1) = ZERO
16337 BECAS(1) = ZERO
16338 ENDIF
16339* Lorentz-trsf. into target rest system
16340 IF (IT.GT.1) THEN
16341* LEPTO: final state particles are already in target rest frame
16342C IF (MCGENE.EQ.3) THEN
16343C PCAS(2,1) = PHKK(1,IDXCAS)
16344C PCAS(2,2) = PHKK(2,IDXCAS)
16345C PCAS(2,3) = PHKK(3,IDXCAS)
16346C PCAS(2,4) = PHKK(4,IDXCAS)
16347C ELSE
16348 CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
16349 & PHKK(4,IDXCAS),PCAS(2,1),PCAS(2,2),PCAS(2,3),
16350 & PCAS(2,4),IDCAS,-3)
16351C ENDIF
16352 PTOCAS(2) = SQRT(PCAS(2,1)**2+PCAS(2,2)**2+PCAS(2,3)**2)
16353 PCAS(2,5) = (PCAS(2,4)-PTOCAS(2))*(PCAS(2,4)+PTOCAS(2))
16354 IF (PCAS(2,5).GT.ZERO) THEN
16355 PCAS(2,5) = SQRT(PCAS(2,5))
16356 ELSE
16357 PCAS(2,5) = AAM(IDCAS)
16358 ENDIF
16359 DO 22 K=1,3
16360 COSCAS(2,K) = PCAS(2,K)/MAX(PTOCAS(2),TINY10)
16361 22 CONTINUE
16362* Lorentz-parameters
16363* particle rest system --> target rest system
16364 BGCAS(2) = PTOCAS(2)/MAX(PCAS(2,5),TINY10)
16365 GACAS(2) = PCAS(2,4)/MAX(PCAS(2,5),TINY10)
16366 BECAS(2) = BGCAS(2)/GACAS(2)
16367 ELSE
16368 DO 23 K=1,5
16369 PCAS(2,K) = ZERO
16370 IF (K.LE.3) COSCAS(2,K) = ZERO
16371 23 CONTINUE
16372 PTOCAS(2) = ZERO
16373 BGCAS(2) = ZERO
16374 GACAS(2) = ZERO
16375 BECAS(2) = ZERO
16376 ENDIF
16377
16378* radii of nuclei (mm) modified by the wall-depth of the Woods-Saxon-
16379* potential (see CONUCL)
16380 RNUC(1) = (RPROJ+4.605D0*PDIF)*FM2MM
16381 RNUC(2) = (RTARG+4.605D0*PDIF)*FM2MM
16382* impact parameter (the projectile moving along z)
16383 BIMPC(1) = ZERO
16384 BIMPC(2) = BIMPAC*FM2MM
16385
16386* get position of initial hadron in projectile/target rest-syst.
16387 DO 3 K=1,4
16388 VTXCAS(1,K) = WHKK(K,IDXCAS)
16389 VTXCAS(2,K) = VHKK(K,IDXCAS)
16390 3 CONTINUE
16391
16392 ICAS = 1
16393 I2 = 2
16394 IF (NCAS.EQ.-1) THEN
16395 ICAS = 2
16396 I2 = 1
16397 ENDIF
16398
16399 IF (PTOCAS(ICAS).LT.TINY10) THEN
16400 WRITE(LOUT,1000) PTOCAS
16401 1000 FORMAT(1X,'INUCAS: warning! zero momentum of initial',
16402 & ' hadron ',/,20X,2E12.4)
16403 GOTO 9999
16404 ENDIF
16405
16406* reset spectator flags
16407 NSPE = 0
16408 IDXSPE(1) = 0
16409 IDXSPE(2) = 0
16410 IDSPE(1) = 0
16411 IDSPE(2) = 0
16412
16413* formation length (in fm)
16414C IF (LCAS) THEN
16415C DEL0 = ZERO
16416C ELSE
16417 DEL0 = TAUFOR*BGCAS(ICAS)
16418 IF (ITAUVE.EQ.1) THEN
16419 AMT = PCAS(ICAS,1)**2+PCAS(ICAS,2)**2+PCAS(ICAS,5)**2
16420 DEL0 = DEL0*PCAS(ICAS,5)**2/AMT
16421 ENDIF
16422C ENDIF
16423* sample from exp(-del/del0)
16424 DEL1 = -DEL0*LOG(MAX(DT_RNDM(DEL0),TINY10))
16425* save formation time
16426 TAUSA1 = DEL1/BGCAS(ICAS)
16427 REL1 = TAUSA1*BGCAS(I2)
16428
16429 DEL = DEL1
16430 TAUSAM = DEL/BGCAS(ICAS)
16431 REL = TAUSAM*BGCAS(I2)
16432
16433* special treatment for negative particles unable to escape
16434* nuclear potential (implemented for ap, pi-, K- only)
16435 LABSOR = .FALSE.
16436 IF ((IICH(IDCAS).EQ.-1).AND.(IDCAS.LT.20)) THEN
16437* threshold energy = nuclear potential + Coulomb potential
16438* (nuclear potential for hadron-nucleus interactions only)
16439 ETHR = AAM(IDCAS)+EPOT(ICAS,IDCAS)+ETACOU(ICAS)
16440 IF (PCAS(ICAS,4).LT.ETHR) THEN
16441 DO 4 K=1,5
16442 PCAS1(K) = PCAS(ICAS,K)
16443 4 CONTINUE
16444* "absorb" negative particle in nucleus
16445 CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,0,IREJ1)
16446 IF (IREJ1.NE.0) GOTO 9999
16447 IF (NSPE.GE.1) LABSOR = .TRUE.
16448 ENDIF
16449 ENDIF
16450
16451* if the initial particle has not been absorbed proceed with
16452* "normal" cascade
16453 IF (.NOT.LABSOR) THEN
16454
16455* calculate coordinates of hadron at the end of the formation zone
16456* transport-time and -step in the rest system where this step is
16457* treated
16458 DSTEP = DEL*FM2MM
16459 DTIME = DSTEP/BECAS(ICAS)
16460 RSTEP = REL*FM2MM
16461 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16462 RTIME = RSTEP/BECAS(I2)
16463 ELSE
16464 RTIME = ZERO
16465 ENDIF
16466* save step whithout considering the overlapping region
16467 DSTEP1 = DEL1*FM2MM
16468 DTIME1 = DSTEP1/BECAS(ICAS)
16469 RSTEP1 = REL1*FM2MM
16470 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16471 RTIME1 = RSTEP1/BECAS(I2)
16472 ELSE
16473 RTIME1 = ZERO
16474 ENDIF
16475* transport to the end of the formation zone in this system
16476 DO 5 K=1,3
16477 VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+DSTEP1*COSCAS(ICAS,K)
16478 VTXCA1(I2,K) = VTXCAS(I2,K) +RSTEP1*COSCAS(I2,K)
16479 VTXCAS(ICAS,K) = VTXCAS(ICAS,K)+DSTEP*COSCAS(ICAS,K)
16480 VTXCAS(I2,K) = VTXCAS(I2,K) +RSTEP*COSCAS(I2,K)
16481 5 CONTINUE
16482 VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME1
16483 VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME1
16484 VTXCAS(ICAS,4) = VTXCAS(ICAS,4)+DTIME
16485 VTXCAS(I2,4) = VTXCAS(I2,4) +RTIME
16486
16487 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16488 XCAS = VTXCAS(ICAS,1)
16489 YCAS = VTXCAS(ICAS,2)
16490 XNCLTA = BIMPAC*FM2MM
16491 RNCLPR = (RPROJ+RNUCLE)*FM2MM
16492 RNCLTA = (RTARG+RNUCLE)*FM2MM
16493C RNCLPR = (RPROJ+1.605D0*PDIF)*FM2MM
16494C RNCLTA = (RTARG+1.605D0*PDIF)*FM2MM
16495C RNCLPR = (RPROJ)*FM2MM
16496C RNCLTA = (RTARG)*FM2MM
16497 RCASPR = SQRT( XCAS**2 +YCAS**2)
16498 RCASTA = SQRT((XCAS-XNCLTA)**2+YCAS**2)
16499 IF ((RCASPR.LT.RNCLPR).AND.(RCASTA.LT.RNCLTA)) THEN
16500 IF (IDCH(IDXCAS).EQ.0) NOBAM(IDXCAS) = 3
16501 ENDIF
16502 ENDIF
16503
16504* check if particle is already outside of the corresp. nucleus
16505 RDIST = SQRT((VTXCAS(ICAS,1)-BIMPC(ICAS))**2+
16506 & VTXCAS(ICAS,2)**2+VTXCAS(ICAS,3)**2)
16507 IF (RDIST.GE.RNUC(ICAS)) THEN
16508* here: IDCH is the generation of the final state part. starting
16509* with zero for hadronization products
16510* flag particles of generation 0 being outside the nuclei after
16511* formation time (to be used for excitation energy calculation)
16512 IF ((IDCH(IDXCAS).EQ.0).AND.(NOBAM(IDXCAS).LT.3))
16513 & NOBAM(IDXCAS) = NOBAM(IDXCAS)+ICAS
16514 GOTO 9997
16515 ENDIF
16516 DIST = DLARGE
16517 DISTP = DLARGE
16518 DISTN = DLARGE
16519 IDXP = 0
16520 IDXN = 0
16521
16522* already here: skip particles being outside HADRIN "energy-window"
16523* to avoid wasting of time
16524 NINCHR(ICAS,1) = NINCHR(ICAS,1)+1
16525 IF ((PTOCAS(ICAS).LE.PLOWH).OR.(PTOCAS(ICAS).GE.PHIH)) THEN
16526 NINCHR(ICAS,2) = NINCHR(ICAS,2)+1
16527C WRITE(LOUT,1002) IDXCAS,IDCAS,ICAS,PTOCAS(ICAS),NEVHKK
16528C1002 FORMAT(1X,'INUCAS: warning! momentum of particle with ',
16529C & 'index ',I5,' (id: ',I3,') ',I3,/,11X,'p_tot = ',
16530C & E12.4,', above or below HADRIN-thresholds',I6)
16531 NSPE = 0
16532 GOTO 9997
16533 ENDIF
16534
16535 DO 7 IDXHKK=1,NOINC
16536 I = IDXINC(IDXHKK)
16537* scan DTEVT1 for unwounded or excited nucleons
16538 IF ((ISTHKK(I).EQ.12+ICAS).OR.(ISTHKK(I).EQ.14+ICAS)) THEN
16539 DO 8 K=1,3
16540 IF (ICAS.EQ.1) THEN
16541 VTXDST(K) = WHKK(K,I)-VTXCAS(1,K)
16542 ELSEIF (ICAS.EQ.2) THEN
16543 VTXDST(K) = VHKK(K,I)-VTXCAS(2,K)
16544 ENDIF
16545 8 CONTINUE
16546 POSNUC = VTXDST(1)*COSCAS(ICAS,1)+
16547 & VTXDST(2)*COSCAS(ICAS,2)+
16548 & VTXDST(3)*COSCAS(ICAS,3)
16549* check if nucleon is situated in forward direction
16550 IF (POSNUC.GT.ZERO) THEN
16551* distance between hadron and this nucleon
16552 DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16553 & VTXDST(3)**2)
16554* impact parameter
16555 BIMNU2 = DISTNU**2-POSNUC**2
16556 IF (BIMNU2.LT.ZERO) THEN
16557 WRITE(LOUT,1001) DISTNU,POSNUC,BIMNU2
16558 1001 FORMAT(1X,'INUCAS: warning! inconsistent impact',
16559 & ' parameter ',/,20X,3E12.4)
16560 GOTO 7
16561 ENDIF
16562 BIMNU = SQRT(BIMNU2)
16563* maximum impact parameter to have interaction
16564 IDNUC = IDT_ICIHAD(IDHKK(I))
16565 IDNUC1 = IDT_MCHAD(IDNUC)
16566 IDCAS1 = IDT_MCHAD(IDCAS)
16567 DO 19 K=1,5
16568 PCAS1(K) = PCAS(ICAS,K)
16569 PNUC(K) = PHKK(K,I)
16570 19 CONTINUE
16571* Lorentz-parameter for trafo into rest-system of target
16572 DO 18 K=1,4
16573 BGTA(K) = PNUC(K)/MAX(PNUC(5),TINY10)
16574 18 CONTINUE
16575* transformation of projectile into rest-system of target
16576 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
16577 & PCAS1(1),PCAS1(2),PCAS1(3),PCAS1(4),
16578 & PPTOT,PX,PY,PZ,PE)
16579**
16580C CALL DT_SIHNIN(IDCAS1,IDNUC1,PPTOT,SIGIN)
16581C CALL DT_SIHNEL(IDCAS1,IDNUC1,PPTOT,SIGEL)
16582 DUMZER = ZERO
16583 CALL DT_XSHN(IDCAS1,IDNUC1,PPTOT,DUMZER,SIGTOT,SIGEL)
16584 CALL DT_SIHNAB(IDCAS1,IDNUC1,PPTOT,SIGAB)
16585 IF (((IDCAS1.EQ.13).OR.(IDCAS1.EQ.14)).AND.
16586 & (PPTOT.LT.0.15D0)) SIGEL = SIGEL/2.0D0
16587 SIGIN = SIGTOT-SIGEL-SIGAB
16588C SIGTOT = SIGIN+SIGEL+SIGAB
16589**
16590 BIMMAX = SQRT(SIGTOT/(5.0D0*TWOPI))*FM2MM
16591* check if interaction is possible
16592 IF (BIMNU.LE.BIMMAX) THEN
16593* get nucleon with smallest distance and kind of interaction
16594* (elastic/inelastic)
16595 IF (DISTNU.LT.DIST) THEN
16596 DIST = DISTNU
16597 BINT = BIMNU
16598 IF (IDNUC.NE.IDSPE(1)) THEN
16599 IDSPE(2) = IDSPE(1)
16600 IDXSPE(2) = IDXSPE(1)
16601 IDSPE(1) = IDNUC
16602 ENDIF
16603 IDXSPE(1) = I
16604 NSPE = 1
16605**sr
16606 SELA = SIGEL
16607 SABS = SIGAB
16608 STOT = SIGTOT
16609C IF ((IDCAS.EQ.2).OR.(IDCAS.EQ.9)) THEN
16610C SELA = SIGEL
16611C STOT = SIGIN+SIGEL
16612C ELSE
16613C SELA = SIGEL+0.75D0*SIGIN
16614C STOT = 0.25D0*SIGIN+SELA
16615C ENDIF
16616**
16617 ENDIF
16618 ENDIf
16619 ENDIF
16620 DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16621 & VTXDST(3)**2)
16622 IDNUC = IDT_ICIHAD(IDHKK(I))
16623 IF (IDNUC.EQ.1) THEN
16624 IF (DISTNU.LT.DISTP) THEN
16625 DISTP = DISTNU
16626 IDXP = I
16627 POSP = POSNUC
16628 ENDIF
16629 ELSEIF (IDNUC.EQ.8) THEN
16630 IF (DISTNU.LT.DISTN) THEN
16631 DISTN = DISTNU
16632 IDXN = I
16633 POSN = POSNUC
16634 ENDIF
16635 ENDIF
16636 ENDIF
16637 7 CONTINUE
16638
16639* there is no nucleon for a secondary interaction
16640 IF (NSPE.EQ.0) GOTO 9997
16641
16642C IF ((IDCAS.EQ.13).AND.((PCAS(ICAS,4)-PCAS(ICAS,5)).LT.0.1D0))
16643C & WRITE(LOUT,*) STOT,SELA,SABS,IDXSPE
16644 IF (IDXSPE(2).EQ.0) THEN
16645 IF ((IDSPE(1).EQ.1).AND.(IDXN.GT.0)) THEN
16646C DO 80 K=1,3
16647C IF (ICAS.EQ.1) THEN
16648C VTXDST(K) = WHKK(K,IDXN)-WHKK(K,IDXSPE(1))
16649C ELSEIF (ICAS.EQ.2) THEN
16650C VTXDST(K) = VHKK(K,IDXN)-VHKK(K,IDXSPE(1))
16651C ENDIF
16652C 80 CONTINUE
16653C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16654C & VTXDST(3)**2)
16655C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSN.GT.ZERO)) THEN
16656 IDXSPE(2) = IDXN
16657 IDSPE(2) = 8
16658C ELSE
16659C STOT = STOT-SABS
16660C SABS = ZERO
16661C ENDIF
16662 ELSEIF ((IDSPE(1).EQ.8).AND.(IDXP.GT.0)) THEN
16663C DO 81 K=1,3
16664C IF (ICAS.EQ.1) THEN
16665C VTXDST(K) = WHKK(K,IDXP)-WHKK(K,IDXSPE(1))
16666C ELSEIF (ICAS.EQ.2) THEN
16667C VTXDST(K) = VHKK(K,IDXP)-VHKK(K,IDXSPE(1))
16668C ENDIF
16669C 81 CONTINUE
16670C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16671C & VTXDST(3)**2)
16672C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSP.GT.ZERO)) THEN
16673 IDXSPE(2) = IDXP
16674 IDSPE(2) = 1
16675C ELSE
16676C STOT = STOT-SABS
16677C SABS = ZERO
16678C ENDIF
16679 ELSE
16680 STOT = STOT-SABS
16681 SABS = ZERO
16682 ENDIF
16683 ENDIF
16684 RR = DT_RNDM(DIST)
16685 IF (RR.LT.SELA/STOT) THEN
16686 IPROC = 2
16687 ELSEIF ((RR.GE.SELA/STOT).AND.(RR.LT.(SELA+SABS)/STOT)) THEN
16688 IPROC = 3
16689 ELSE
16690 IPROC = 1
16691 ENDIF
16692
16693 DO 9 K=1,5
16694 PCAS1(K) = PCAS(ICAS,K)
16695 PNUC(K) = PHKK(K,IDXSPE(1))
16696 9 CONTINUE
16697 IF (IPROC.EQ.3) THEN
16698* 2-nucleon absorption of pion
16699 NSPE = 2
16700 CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,1,IREJ1)
16701 IF (IREJ1.NE.0) GOTO 9999
16702 IF (NSPE.GE.1) LABSOR = .TRUE.
16703 ELSE
16704* sample secondary interaction
16705 IDNUC = IDBAM(IDXSPE(1))
16706 CALL DT_HADRIN(IDCAS,PCAS1,IDNUC,PNUC,IPROC,IREJ1)
16707 IF (IREJ1.EQ.1) GOTO 9999
16708 IF (IREJ1.GT.1) GOTO 9998
16709 ENDIF
16710 ENDIF
16711
16712* update arrays to include Pauli-principle
16713 DO 10 I=1,NSPE
16714 IF (NWOUND(ICAS).LE.299) THEN
16715 NWOUND(ICAS) = NWOUND(ICAS)+1
16716 EWOUND(ICAS,NWOUND(ICAS)) = PHKK(4,IDXSPE(I))
16717 ENDIF
16718 10 CONTINUE
16719
16720* dump initial hadron for energy-momentum conservation check
16721 IF (LEMCCK)
16722 & CALL DT_EVTEMC(PCAS(ICAS,1),PCAS(ICAS,2),PCAS(ICAS,3),
16723 & PCAS(ICAS,4),1,IDUM,IDUM)
16724
16725* dump final state particles into DTEVT1
16726
16727* check if Pauli-principle is fulfilled
16728 NPAULI = 0
16729 NWTMP(1) = NWOUND(1)
16730 NWTMP(2) = NWOUND(2)
16731 DO 111 I=1,NFSP
16732 NPAULI = 0
16733 J1 = 2
16734 IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
16735 & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1
16736 DO 117 J=1,J1
16737 IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 117
16738 IF (J.EQ.1) THEN
16739 IDX = ICAS
16740 PE = PFSP(4,I)
16741 ELSE
16742 IDX = I2
16743 MODE = 1
16744 IF (IDX.EQ.1) MODE = -1
16745 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,MODE)
16746 ENDIF
16747* first check if cascade step is forbidden due to Pauli-principle
16748* (in case of absorpion this step is forced)
16749 IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
16750 & (IDFSP(I).EQ.8))) THEN
16751* get nuclear potential barrier
16752 POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
16753 IF (IDFSP(I).EQ.1) THEN
16754 POTLOW = POT-EBINDP(IDX)
16755 ELSE
16756 POTLOW = POT-EBINDN(IDX)
16757 ENDIF
16758* final state particle not able to escape nucleus
16759 IF (PE.LE.POTLOW) THEN
16760* check if there are wounded nucleons
16761 IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
16762 & EWOUND(IDX,NWOUND(IDX)))) THEN
16763 NPAULI = NPAULI+1
16764 NWOUND(IDX) = NWOUND(IDX)-1
16765 ELSE
16766* interaction prohibited by Pauli-principle
16767 NWOUND(1) = NWTMP(1)
16768 NWOUND(2) = NWTMP(2)
16769 GOTO 9997
16770 ENDIF
16771 ENDIF
16772 ENDIF
16773 117 CONTINUE
16774 111 CONTINUE
16775
16776 NPAULI = 0
16777 NWOUND(1) = NWTMP(1)
16778 NWOUND(2) = NWTMP(2)
16779
16780 DO 11 I=1,NFSP
16781
16782 IST = ISTHKK(IDXCAS)
16783
16784 NPAULI = 0
16785 J1 = 2
16786 IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
16787 & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1
16788 DO 17 J=1,J1
16789 IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 17
16790 IDX = ICAS
16791 PE = PFSP(4,I)
16792 IF (J.EQ.2) THEN
16793 IDX = I2
16794 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,NCAS)
16795 ENDIF
16796* first check if cascade step is forbidden due to Pauli-principle
16797* (in case of absorpion this step is forced)
16798 IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
16799 & (IDFSP(I).EQ.8))) THEN
16800* get nuclear potential barrier
16801 POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
16802 IF (IDFSP(I).EQ.1) THEN
16803 POTLOW = POT-EBINDP(IDX)
16804 ELSE
16805 POTLOW = POT-EBINDN(IDX)
16806 ENDIF
16807* final state particle not able to escape nucleus
16808 IF (PE.LE.POTLOW) THEN
16809* check if there are wounded nucleons
16810 IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
16811 & EWOUND(IDX,NWOUND(IDX)))) THEN
16812 NWOUND(IDX) = NWOUND(IDX)-1
16813 NPAULI = NPAULI+1
16814 IST = 14+IDX
16815 ELSE
16816* interaction prohibited by Pauli-principle
16817 NWOUND(1) = NWTMP(1)
16818 NWOUND(2) = NWTMP(2)
16819 GOTO 9997
16820 ENDIF
16821**sr
16822c ELSEIF (PE.LE.POT) THEN
16823cC ELSEIF ((PE.LE.POT).AND.(NWOUND(IDX).GE.1)) THEN
16824cC NWOUND(IDX) = NWOUND(IDX)-1
16825c**
16826c NPAULI = NPAULI+1
16827c IST = 14+IDX
16828 ENDIF
16829 ENDIF
16830 17 CONTINUE
16831
16832* dump final state particles for energy-momentum conservation check
16833 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),-PFSP(3,I),
16834 & -PFSP(4,I),2,IDUM,IDUM)
16835
16836 PX = PFSP(1,I)
16837 PY = PFSP(2,I)
16838 PZ = PFSP(3,I)
16839 PE = PFSP(4,I)
16840 IF (ABS(IST).EQ.1) THEN
16841* transform particles back into n-n cms
16842* LEPTO: leave final state particles in target rest frame
16843C IF (MCGENE.EQ.3) THEN
16844C PFSP(1,I) = PX
16845C PFSP(2,I) = PY
16846C PFSP(3,I) = PZ
16847C PFSP(4,I) = PE
16848C ELSE
16849 IMODE = ICAS+1
16850 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
16851 & PFSP(4,I),IDFSP(I),IMODE)
16852C ENDIF
16853 ELSEIF ((ICAS.EQ.2).AND.(IST.EQ.15)) THEN
16854* target cascade but fsp got stuck in proj. --> transform it into
16855* proj. rest system
16856 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
16857 & PFSP(4,I),IDFSP(I),-1)
16858 ELSEIF ((ICAS.EQ.1).AND.(IST.EQ.16)) THEN
16859* proj. cascade but fsp got stuck in target --> transform it into
16860* target rest system
16861 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
16862 & PFSP(4,I),IDFSP(I),1)
16863 ENDIF
16864
16865* dump final state particles into DTEVT1
16866 IGEN = IDCH(IDXCAS)+1
16867 ID = IDT_IPDGHA(IDFSP(I))
16868 IXR = 0
16869 IF (LABSOR) IXR = 99
16870 CALL DT_EVTPUT(IST,ID,IDXCAS,IDXSPE(1),PFSP(1,I),
16871 & PFSP(2,I),PFSP(3,I),PFSP(4,I),0,IXR,IGEN)
16872
16873* update the counter for particles which got stuck inside the nucleus
16874 IF ((IST.EQ.15).OR.(IST.EQ.16)) THEN
16875 NOINC = NOINC+1
16876 IDXINC(NOINC) = NHKK
16877 ENDIF
16878 IF (LABSOR) THEN
16879* in case of absorption the spatial treatment is an approximate
16880* solution anyway (the positions of the nucleons which "absorb" the
16881* cascade particle are not taken into consideration) therefore the
16882* particles are produced at the position of the cascade particle
16883 DO 12 K=1,4
16884 WHKK(K,NHKK) = WHKK(K,IDXCAS)
16885 VHKK(K,NHKK) = VHKK(K,IDXCAS)
16886 12 CONTINUE
16887 ELSE
16888* DDISTL - distance the cascade particle moves to the intera. point
16889* (the position where impact-parameter = distance to the interacting
16890* nucleon), DIST - distance to the interacting nucleon at the time of
16891* formation of the cascade particle, BINT - impact-parameter of this
16892* cascade-interaction
16893 DDISTL = SQRT(DIST**2-BINT**2)
16894 DTIME = DDISTL/BECAS(ICAS)
16895 DTIMEL = DDISTL/BGCAS(ICAS)
16896 RDISTL = DTIMEL*BGCAS(I2)
16897 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16898 RTIME = RDISTL/BECAS(I2)
16899 ELSE
16900 RTIME = ZERO
16901 ENDIF
16902* RDISTL, RTIME are this step and time in the rest system of the other
16903* nucleus
16904 DO 13 K=1,3
16905 VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+COSCAS(ICAS,K)*DDISTL
16906 VTXCA1(I2,K) = VTXCAS(I2,K) +COSCAS(I2,K) *RDISTL
16907 13 CONTINUE
16908 VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME
16909 VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME
16910* position of particle production is half the impact-parameter to
16911* the interacting nucleon
16912 DO 14 K=1,3
16913 WHKK(K,NHKK) = OHALF*(VTXCA1(1,K)+WHKK(K,IDXSPE(1)))
16914 VHKK(K,NHKK) = OHALF*(VTXCA1(2,K)+VHKK(K,IDXSPE(1)))
16915 14 CONTINUE
16916* time of production of secondary = time of interaction
16917 WHKK(4,NHKK) = VTXCA1(1,4)
16918 VHKK(4,NHKK) = VTXCA1(2,4)
16919 ENDIF
16920
16921 11 CONTINUE
16922
16923* modify status and position of cascade particle (the latter for
16924* statistics reasons only)
16925 ISTHKK(IDXCAS) = 2
16926 IF (LABSOR) ISTHKK(IDXCAS) = 19
16927 IF (.NOT.LABSOR) THEN
16928 DO 15 K=1,4
16929 WHKK(K,IDXCAS) = VTXCA1(1,K)
16930 VHKK(K,IDXCAS) = VTXCA1(2,K)
16931 15 CONTINUE
16932 ENDIF
16933
16934 DO 16 I=1,NSPE
16935 IS = IDXSPE(I)
16936* dump interacting nucleons for energy-momentum conservation check
16937 IF (LEMCCK)
16938 & CALL DT_EVTEMC(PHKK(1,IS),PHKK(2,IS),PHKK(3,IS),PHKK(4,IS),
16939 & 2,IDUM,IDUM)
16940* modify entry for interacting nucleons
16941 IF (ISTHKK(IS).EQ.12+ICAS) ISTHKK(IS)=16+ICAS
16942 IF (ISTHKK(IS).EQ.14+ICAS) ISTHKK(IS)=2
16943 IF (I.GE.2) THEN
16944 JDAHKK(1,IS) = JDAHKK(1,IDXSPE(1))
16945 JDAHKK(2,IS) = JDAHKK(2,IDXSPE(1))
16946 ENDIF
16947 16 CONTINUE
16948
16949* check energy-momentum conservation
16950 IF (LEMCCK) THEN
16951 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,500,IREJ1)
16952 IF (IREJ1.NE.0) GOTO 9999
16953 ENDIF
16954
16955* update counter
16956 IF (LABSOR) THEN
16957 NINCCO(ICAS,1) = NINCCO(ICAS,1)+1
16958 ELSE
16959 IF (IPROC.EQ.1) NINCCO(ICAS,2) = NINCCO(ICAS,2)+1
16960 IF (IPROC.EQ.2) NINCCO(ICAS,3) = NINCCO(ICAS,3)+1
16961 ENDIF
16962
16963 RETURN
16964
16965 9997 CONTINUE
16966 9998 CONTINUE
16967* transport-step but no cascade step due to configuration (i.e. there
16968* is no nucleon for interaction etc.)
16969 IF (LCAS) THEN
16970 DO 100 K=1,4
16971C WHKK(K,IDXCAS) = VTXCAS(1,K)
16972C VHKK(K,IDXCAS) = VTXCAS(2,K)
16973 WHKK(K,IDXCAS) = VTXCA1(1,K)
16974 VHKK(K,IDXCAS) = VTXCA1(2,K)
16975 100 CONTINUE
16976 ENDIF
16977
16978C9998 CONTINUE
16979* no cascade-step because of configuration
16980* (i.e. hadron outside nucleus etc.)
16981 LCAS = .TRUE.
16982 RETURN
16983
16984 9999 CONTINUE
16985* rejection
16986 IREJ = 1
16987 RETURN
16988 END
16989
16990*$ CREATE DT_ABSORP.FOR
16991*COPY DT_ABSORP
16992*
16993*===absorp=============================================================*
16994*
16995 SUBROUTINE DT_ABSORP(IDCAS,PCAS,NCAS,NSPE,IDSPE,IDXSPE,MODE,IREJ)
16996
16997************************************************************************
16998* Two-nucleon absorption of antiprotons, pi-, and K-. *
16999* Antiproton absorption is handled by HADRIN. *
17000* The following channels for meson-absorption are considered: *
17001* pi- + p + p ---> n + p *
17002* pi- + p + n ---> n + n *
17003* K- + p + p ---> sigma+ + n / Lam + p / sigma0 + p *
17004* K- + p + n ---> sigma- + n / Lam + n / sigma0 + n *
17005* K- + p + p ---> sigma- + n *
17006* IDCAS, PCAS identity, momentum of particle to be absorbed *
17007* NCAS = 1 intranuclear cascade in projectile *
17008* = -1 intranuclear cascade in target *
17009* NSPE number of spectator nucleons involved *
17010* IDXSPE(2) DTEVT1-indices of spectator nucleons involved *
17011* Revised version of the original STOPIK written by HJM and J. Ranft. *
17012* This version dated 24.02.95 is written by S. Roesler *
17013************************************************************************
17014
17015 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17016 SAVE
17017 PARAMETER ( LINP = 10 ,
17018 & LOUT = 6 ,
17019 & LDAT = 9 )
17020 PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,ONE=1.0D0,
17021 & ONETHI=0.3333D0,TWOTHI=0.6666D0)
17022
17023* event history
17024 PARAMETER (NMXHKK=200000)
17025 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17026 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17027 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17028* extended event history
17029 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17030 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17031 & IHIST(2,NMXHKK)
17032* flags for input different options
17033 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17034 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17035 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17036* final state after inc step
17037 PARAMETER (MAXFSP=10)
17038 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17039* particle properties (BAMJET index convention)
17040 CHARACTER*8 ANAME
17041 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17042 & IICH(210),IIBAR(210),K1(210),K2(210)
17043
17044 DIMENSION PCAS(5),IDXSPE(2),IDSPE(2),PSPE(2,5),PSPE1(5),
17045 & PTOT3P(4),BG3P(4),
17046 & ECMF(2),PCMF(2),CODF(2),COFF(2),SIFF(2)
17047
17048 IREJ = 0
17049 NFSP = 0
17050
17051* skip particles others than ap, pi-, K- for mode=0
17052 IF ((MODE.EQ.0).AND.
17053 & (IDCAS.NE.2).AND.(IDCAS.NE.14).AND.(IDCAS.NE.16)) RETURN
17054* skip particles others than pions for mode=1
17055* (2-nucleon absorption in intranuclear cascade)
17056 IF ((MODE.EQ.1).AND.
17057 & (IDCAS.NE.13).AND.(IDCAS.NE.14).AND.(IDCAS.NE.23)) RETURN
17058
17059 NUCAS = NCAS
17060 IF (NUCAS.EQ.-1) NUCAS = 2
17061
17062 IF (MODE.EQ.0) THEN
17063* scan spectator nucleons for nucleons being able to "absorb"
17064 NSPE = 0
17065 IDXSPE(1) = 0
17066 IDXSPE(2) = 0
17067 DO 1 I=1,NHKK
17068 IF ((ISTHKK(I).EQ.12+NUCAS).OR.(ISTHKK(I).EQ.14+NUCAS)) THEN
17069 NSPE = NSPE+1
17070 IDXSPE(NSPE) = I
17071 IDSPE(NSPE) = IDBAM(I)
17072 IF ((NSPE.EQ.1).AND.(IDCAS.EQ.2)) GOTO 2
17073 IF (NSPE.EQ.2) THEN
17074 IF ((IDCAS.EQ.14).AND.(IDSPE(1).EQ.8).AND.
17075 & (IDSPE(2).EQ.8)) THEN
17076* there is no pi-+n+n channel
17077 NSPE = 1
17078 GOTO 1
17079 ELSE
17080 GOTO 2
17081 ENDIF
17082 ENDIF
17083 ENDIF
17084 1 CONTINUE
17085
17086 2 CONTINUE
17087 ENDIF
17088* transform excited projectile nucleons (status=15) into proj. rest s.
17089 DO 3 I=1,NSPE
17090 DO 4 K=1,5
17091 PSPE(I,K) = PHKK(K,IDXSPE(I))
17092 4 CONTINUE
17093 3 CONTINUE
17094
17095* antiproton absorption
17096 IF ((IDCAS.EQ.2).AND.(NSPE.GE.1)) THEN
17097 DO 5 K=1,5
17098 PSPE1(K) = PSPE(1,K)
17099 5 CONTINUE
17100 CALL DT_HADRIN(IDCAS,PCAS,IDSPE(1),PSPE1,1,IREJ1)
17101 IF (IREJ1.NE.0) GOTO 9999
17102
17103* meson absorption
17104 ELSEIF (((IDCAS.EQ.13).OR.(IDCAS.EQ.14).OR.(IDCAS.EQ.23)
17105 & .OR.(IDCAS.EQ.16)).AND.(NSPE.GE.2)) THEN
17106 IF (IDCAS.EQ.14) THEN
17107* pi- absorption
17108 IDFSP(1) = 8
17109 IDFSP(2) = 8
17110 IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) IDFSP(2) = 1
17111 ELSEIF (IDCAS.EQ.13) THEN
17112* pi+ absorption
17113 IDFSP(1) = 1
17114 IDFSP(2) = 1
17115 IF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) IDFSP(2) = 8
17116 ELSEIF (IDCAS.EQ.23) THEN
17117* pi0 absorption
17118 IDFSP(1) = IDSPE(1)
17119 IDFSP(2) = IDSPE(2)
17120 ELSEIF (IDCAS.EQ.16) THEN
17121* K- absorption
17122 R = DT_RNDM(PCAS)
17123 IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) THEN
17124 IF (R.LT.ONETHI) THEN
17125 IDFSP(1) = 21
17126 IDFSP(2) = 8
17127 ELSEIF (R.LT.TWOTHI) THEN
17128 IDFSP(1) = 17
17129 IDFSP(2) = 1
17130 ELSE
17131 IDFSP(1) = 22
17132 IDFSP(2) = 1
17133 ENDIF
17134 ELSEIF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) THEN
17135 IDFSP(1) = 20
17136 IDFSP(2) = 8
17137 ELSE
17138 IF (R.LT.ONETHI) THEN
17139 IDFSP(1) = 20
17140 IDFSP(2) = 1
17141 ELSEIF (R.LT.TWOTHI) THEN
17142 IDFSP(1) = 17
17143 IDFSP(2) = 8
17144 ELSE
17145 IDFSP(1) = 22
17146 IDFSP(2) = 8
17147 ENDIF
17148 ENDIF
17149 ENDIF
17150* dump initial particles for energy-momentum cons. check
17151 IF (LEMCCK) THEN
17152 CALL DT_EVTEMC(PCAS(1),PCAS(2),PCAS(3),PCAS(4),1,IDUM,IDUM)
17153 CALL DT_EVTEMC(PSPE(1,1),PSPE(1,2),PSPE(1,3),PSPE(1,4),2,
17154 & IDUM,IDUM)
17155 CALL DT_EVTEMC(PSPE(2,1),PSPE(2,2),PSPE(2,3),PSPE(2,4),2,
17156 & IDUM,IDUM)
17157 ENDIF
17158* get Lorentz-parameter of 3 particle initial state
17159 DO 6 K=1,4
17160 PTOT3P(K) = PCAS(K)+PSPE(1,K)+PSPE(2,K)
17161 6 CONTINUE
17162 P3P = SQRT(PTOT3P(1)**2+PTOT3P(2)**2+PTOT3P(3)**2)
17163 AM3P = SQRT( (PTOT3P(4)-P3P)*(PTOT3P(4)+P3P) )
17164 DO 7 K=1,4
17165 BG3P(K) = PTOT3P(K)/MAX(AM3P,TINY10)
17166 7 CONTINUE
17167* 2-particle decay of the 3-particle compound system
17168 CALL DT_DTWOPD(AM3P,ECMF(1),ECMF(2),PCMF(1),PCMF(2),
17169 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
17170 & AAM(IDFSP(1)),AAM(IDFSP(2)))
17171 DO 8 I=1,2
17172 SDF = SQRT((ONE-CODF(I))*(ONE+CODF(I)))
17173 PX = PCMF(I)*COFF(I)*SDF
17174 PY = PCMF(I)*SIFF(I)*SDF
17175 PZ = PCMF(I)*CODF(I)
17176 CALL DT_DALTRA(BG3P(4),BG3P(1),BG3P(2),BG3P(3),PX,PY,PZ,
17177 & ECMF(I),PTOFSP,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17178 & PFSP(4,I))
17179 PFSP(5,I) = SQRT( (PFSP(4,I)-PTOFSP)*(PFSP(4,I)+PTOFSP) )
17180* check consistency of kinematics
17181 IF (ABS(AAM(IDFSP(I))-PFSP(5,I)).GT.TINY5) THEN
17182 WRITE(LOUT,1001) IDFSP(I),AAM(IDFSP(I)),PFSP(5,I)
17183 1001 FORMAT(1X,'ABSORP: warning! inconsistent',
17184 & ' tree-particle kinematics',/,20X,'id: ',I3,
17185 & ' AAM = ',E10.4,' MFSP = ',E10.4)
17186 ENDIF
17187* dump final state particles for energy-momentum cons. check
17188 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
17189 & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
17190 8 CONTINUE
17191 NFSP = 2
17192 IF (LEMCCK) THEN
17193 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,100,IREJ1)
17194 IF (IREJ1.NE.0) THEN
17195 WRITE(LOUT,*)'ABSORB: EMC ',AAM(IDFSP(1)),AAM(IDFSP(2)),
17196 & AM3P
17197 GOTO 9999
17198 ENDIF
17199 ENDIF
17200 ELSE
17201 IF (IOULEV(3).GT.0) WRITE(LOUT,1000) IDCAS,NSPE
17202 1000 FORMAT(1X,'ABSORP: warning! absorption for particle ',I3,
17203 & ' impossible',/,20X,'too few spectators (',I2,')')
17204 NSPE = 0
17205 ENDIF
17206
17207 RETURN
17208
17209 9999 CONTINUE
17210 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in ABSORP'
17211 IREJ = 1
17212 RETURN
17213 END
17214
17215*$ CREATE DT_HADRIN.FOR
17216*COPY DT_HADRIN
17217*
17218*===hadrin=============================================================*
17219*
17220 SUBROUTINE DT_HADRIN(IDPR,PPR,IDTA,PTA,MODE,IREJ)
17221
17222************************************************************************
17223* Interface to the HADRIN-routines for inelastic and elastic *
17224* scattering. *
17225* IDPR,PPR(5) identity, momentum of projectile *
17226* IDTA,PTA(5) identity, momentum of target *
17227* MODE = 1 inelastic interaction *
17228* = 2 elastic interaction *
17229* Revised version of the original FHAD. *
17230* This version dated 27.10.95 is written by S. Roesler *
17231************************************************************************
17232
17233 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17234 SAVE
17235 PARAMETER ( LINP = 10 ,
17236 & LOUT = 6 ,
17237 & LDAT = 9 )
17238 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,
17239 & TINY2=1.0D-2,TINY1=1.0D-1,ONE=1.0D0)
17240
17241 LOGICAL LCORR,LMSSG
17242
17243* flags for input different options
17244 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17245 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17246 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17247* final state after inc step
17248 PARAMETER (MAXFSP=10)
17249 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17250* particle properties (BAMJET index convention)
17251 CHARACTER*8 ANAME
17252 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17253 & IICH(210),IIBAR(210),K1(210),K2(210)
17254* output-common for DHADRI/ELHAIN
17255* final state from HADRIN interaction
17256 PARAMETER (MAXFIN=10)
17257 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
17258 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
17259
17260 DIMENSION PPR(5),PPR1(5),PTA(5),BGTA(4),
17261 & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4),IMCORR(2)
17262
17263 DATA LMSSG /.TRUE./
17264
17265 IREJ = 0
17266 NFSP = 0
17267 KCORR = 0
17268 IMCORR(1) = 0
17269 IMCORR(2) = 0
17270 LCORR = .FALSE.
17271
17272* dump initial particles for energy-momentum cons. check
17273 IF (LEMCCK) THEN
17274 CALL DT_EVTEMC(PPR(1),PPR(2),PPR(3),PPR(4),1,IDUM,IDUM)
17275 CALL DT_EVTEMC(PTA(1),PTA(2),PTA(3),PTA(4),2,IDUM,IDUM)
17276 ENDIF
17277
17278 AMP2 = PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2
17279 AMT2 = PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2
17280 IF ((AMP2.LT.ZERO).OR.(AMT2.LT.ZERO).OR.
17281 & (ABS(AMP2-AAM(IDPR)**2).GT.TINY5).OR.
17282 & (ABS(AMT2-AAM(IDTA)**2).GT.TINY5)) THEN
17283 IF (LMSSG.AND.(IOULEV(3).GT.0))
17284 & WRITE(LOUT,1000) AMP2,AAM(IDPR)**2,AMT2,AAM(IDTA)**2
17285 1000 FORMAT(1X,'HADRIN: warning! inconsistent projectile/target',
17286 & ' mass',/,20X,'AMP2 = ',E12.4,', AAM(IDPR)**2 = ',
17287 & E12.4,/,20X,'AMT2 = ',E12.4,', AAM(IDTA)**2 = ',E12.4)
17288 LMSSG = .FALSE.
17289 LCORR = .TRUE.
17290 ENDIF
17291
17292* convert initial state particles into particles which can be
17293* handled by HADRIN
17294 IDHPR = IDPR
17295 IDHTA = IDTA
17296 IF ((IDHPR.LE.0).OR.(IDHPR.GE.111).OR.LCORR) THEN
17297 IF ((IDHPR.LE.0).OR.(IDHPR.GE.111)) IDHPR = 1
17298 DO 1 K=1,4
17299 P1IN(K) = PPR(K)
17300 P2IN(K) = PTA(K)
17301 1 CONTINUE
17302 XM1 = AAM(IDHPR)
17303 XM2 = AAM(IDHTA)
17304 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
17305 IF (IREJ1.GT.0) THEN
17306 WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.'
17307 GOTO 9999
17308 ENDIF
17309 DO 2 K=1,4
17310 PPR(K) = P1OUT(K)
17311 PTA(K) = P2OUT(K)
17312 2 CONTINUE
17313 PPR(5) = SQRT(PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2)
17314 PTA(5) = SQRT(PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2)
17315 ENDIF
17316
17317* Lorentz-parameter for trafo into rest-system of target
17318 DO 3 K=1,4
17319 BGTA(K) = PTA(K)/PTA(5)
17320 3 CONTINUE
17321* transformation of projectile into rest-system of target
17322 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),PPR(1),PPR(2),
17323 & PPR(3),PPR(4),PPRTO1,PPR1(1),PPR1(2),PPR1(3),
17324 & PPR1(4))
17325
17326* direction cosines of projectile in target rest system
17327 CX = PPR1(1)/PPRTO1
17328 CY = PPR1(2)/PPRTO1
17329 CZ = PPR1(3)/PPRTO1
17330
17331* sample inelastic interaction
17332 IF (MODE.EQ.1) THEN
17333 CALL DT_DHADRI(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA)
17334 IF (IRH.EQ.1) GOTO 9998
17335* sample elastic interaction
17336 ELSEIF (MODE.EQ.2) THEN
17337 CALL DT_ELHAIN(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA,IREJ1)
17338 IF (IREJ1.NE.0) THEN
17339 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in HADRIN'
17340 GOTO 9999
17341 ENDIF
17342 IF (IRH.EQ.1) GOTO 9998
17343 ELSE
17344 WRITE(LOUT,1001) MODE,INTHAD
17345 1001 FORMAT(1X,'HADRIN: warning! inconsistent interaction mode',
17346 & I4,' (INTHAD =',I4,')')
17347 GOTO 9999
17348 ENDIF
17349
17350* transform final state particles back into Lab.
17351 DO 4 I=1,IRH
17352 NFSP = NFSP+1
17353 PX = CXRH(I)*PLRH(I)
17354 PY = CYRH(I)*PLRH(I)
17355 PZ = CZRH(I)*PLRH(I)
17356 CALL DT_DALTRA(BGTA(4),BGTA(1),BGTA(2),BGTA(3),
17357 & PX,PY,PZ,ELRH(I),PTOFSP,PFSP(1,NFSP),
17358 & PFSP(2,NFSP),PFSP(3,NFSP),PFSP(4,NFSP))
17359 IDFSP(NFSP) = ITRH(I)
17360 AMFSP2 = PFSP(4,NFSP)**2-PFSP(1,NFSP)**2-PFSP(2,NFSP)**2-
17361 & PFSP(3,NFSP)**2
17362 IF (AMFSP2.LT.-TINY3) THEN
17363 WRITE(LOUT,1002) IDFSP(NFSP),PFSP(1,NFSP),PFSP(2,NFSP),
17364 & PFSP(3,NFSP),PFSP(4,NFSP),AMFSP2
17365 1002 FORMAT(1X,'HADRIN: warning! final state particle (id = ',
17366 & I2,') with negative mass^2',/,1X,5E12.4)
17367 GOTO 9999
17368 ELSE
17369 PFSP(5,NFSP) = SQRT(ABS(AMFSP2))
17370 IF (ABS(PFSP(5,NFSP)-AAM(IDFSP(NFSP))).GT.TINY1) THEN
17371 WRITE(LOUT,1003) IDFSP(NFSP),AAM(IDFSP(NFSP)),
17372 & PFSP(5,NFSP)
17373 1003 FORMAT(1X,'HADRIN: warning! final state particle',
17374 & ' (id = ',I2,') with inconsistent mass',/,1X,
17375 & 2E12.4)
17376 KCORR = KCORR+1
17377 IF (KCORR.GT.2) GOTO 9999
17378 IMCORR(KCORR) = NFSP
17379 ENDIF
17380 ENDIF
17381* dump final state particles for energy-momentum cons. check
17382 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
17383 & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
17384 4 CONTINUE
17385
17386* transform momenta on mass shell in case of inconsistencies in
17387* HADRIN
17388 IF (KCORR.GT.0) THEN
17389 IF (KCORR.EQ.2) THEN
17390 I1 = IMCORR(1)
17391 I2 = IMCORR(2)
17392 ELSE
17393 IF (IMCORR(1).EQ.1) THEN
17394 I1 = 1
17395 I2 = 2
17396 ELSE
17397 I1 = 1
17398 I2 = IMCORR(1)
17399 ENDIF
17400 ENDIF
17401 IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I1),PFSP(2,I1),
17402 & PFSP(3,I1),PFSP(4,I1),2,IDUM,IDUM)
17403 IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I2),PFSP(2,I2),
17404 & PFSP(3,I2),PFSP(4,I2),2,IDUM,IDUM)
17405 DO 5 K=1,4
17406 P1IN(K) = PFSP(K,I1)
17407 P2IN(K) = PFSP(K,I2)
17408 5 CONTINUE
17409 XM1 = AAM(IDFSP(I1))
17410 XM2 = AAM(IDFSP(I2))
17411 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
17412 IF (IREJ1.GT.0) THEN
17413 WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.'
17414C GOTO 9999
17415 ENDIF
17416 DO 6 K=1,4
17417 PFSP(K,I1) = P1OUT(K)
17418 PFSP(K,I2) = P2OUT(K)
17419 6 CONTINUE
17420 PFSP(5,I1) = SQRT(PFSP(4,I1)**2-PFSP(1,I1)**2
17421 & -PFSP(2,I1)**2-PFSP(3,I1)**2)
17422 PFSP(5,I2) = SQRT(PFSP(4,I2)**2-PFSP(1,I2)**2
17423 & -PFSP(2,I2)**2-PFSP(3,I2)**2)
17424* dump final state particles for energy-momentum cons. check
17425 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I1),-PFSP(2,I1),
17426 & -PFSP(3,I1),-PFSP(4,I1),2,IDUM,IDUM)
17427 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I2),-PFSP(2,I2),
17428 & -PFSP(3,I2),-PFSP(4,I2),2,IDUM,IDUM)
17429 ENDIF
17430
17431* check energy-momentum conservation
17432 IF (LEMCCK) THEN
17433 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,102,IREJ1)
17434 IF (IREJ1.NE.0) GOTO 9999
17435 ENDIF
17436
17437 RETURN
17438
17439 9998 CONTINUE
17440 IREJ = 2
17441 RETURN
17442
17443 9999 CONTINUE
17444 IREJ = 1
17445 RETURN
17446 END
17447
17448*$ CREATE DT_HADCOL.FOR
17449*COPY DT_HADCOL
17450*
17451*===hadcol=============================================================*
17452*
17453 SUBROUTINE DT_HADCOL(IDPROJ,PPN,IDXTAR,IREJ)
17454
17455************************************************************************
17456* Interface to the HADRIN-routines for inelastic and elastic *
17457* scattering. This subroutine samples hadron-nucleus interactions *
17458* below DPM-threshold. *
17459* IDPROJ BAMJET-index of projectile hadron *
17460* PPN projectile momentum in target rest frame *
17461* IDXTAR DTEVT1-index of target nucleon undergoing *
17462* interaction with projectile hadron *
17463* This subroutine replaces HADHAD. *
17464* This version dated 5.5.95 is written by S. Roesler *
17465************************************************************************
17466
17467 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17468 SAVE
17469 PARAMETER ( LINP = 10 ,
17470 & LOUT = 6 ,
17471 & LDAT = 9 )
17472 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0)
17473
17474 LOGICAL LSTART
17475
17476* event history
17477 PARAMETER (NMXHKK=200000)
17478 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17479 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17480 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17481* extended event history
17482 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17483 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17484 & IHIST(2,NMXHKK)
17485* nuclear potential
17486 LOGICAL LFERMI
17487 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17488 & EBINDP(2),EBINDN(2),EPOT(2,210),
17489 & ETACOU(2),ICOUL,LFERMI
17490* interface HADRIN-DPM
17491 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
17492* parameter for intranuclear cascade
17493 LOGICAL LPAULI
17494 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
17495* final state after inc step
17496 PARAMETER (MAXFSP=10)
17497 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17498* particle properties (BAMJET index convention)
17499 CHARACTER*8 ANAME
17500 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17501 & IICH(210),IIBAR(210),K1(210),K2(210)
17502
17503 DIMENSION PPROJ(5),PNUC(5)
17504
17505 DATA LSTART /.TRUE./
17506
17507 IREJ = 0
17508
17509 NPOINT(1) = NHKK+1
17510
17511 TAUSAV = TAUFOR
17512**sr 6/9/01 commented
17513C TAUFOR = TAUFOR/2.0D0
17514**
17515 IF (LSTART) THEN
17516 WRITE(LOUT,1000)
17517 1000 FORMAT(/,1X,'HADCOL: Scattering handled by HADRIN')
17518 WRITE(LOUT,1001) TAUFOR
17519 1001 FORMAT(/,1X,'HADCOL: Formation zone parameter set to ',
17520 & F5.1,' fm/c')
17521 LSTART = .FALSE.
17522 ENDIF
17523
17524 IDNUC = IDBAM(IDXTAR)
17525 IDNUC1 = IDT_MCHAD(IDNUC)
17526 IDPRO1 = IDT_MCHAD(IDPROJ)
17527
17528 IF ((INTHAD.EQ.1).OR.(INTHAD.EQ.2)) THEN
17529 IPROC = INTHAD
17530 ELSE
17531**
17532C CALL DT_SIHNIN(IDPRO1,IDNUC1,PPN,SIGIN)
17533C CALL DT_SIHNEL(IDPRO1,IDNUC1,PPN,SIGEL)
17534 DUMZER = ZERO
17535 CALL DT_XSHN(IDPRO1,IDNUC1,PPN,DUMZER,SIGTOT,SIGEL)
17536 SIGIN = SIGTOT-SIGEL
17537C SIGTOT = SIGIN+SIGEL
17538**
17539 IPROC = 1
17540 IF (DT_RNDM(SIGIN).LT.SIGEL/SIGTOT) IPROC = 2
17541 ENDIF
17542
17543 PPROJ(1) = ZERO
17544 PPROJ(2) = ZERO
17545 PPROJ(3) = PPN
17546 PPROJ(5) = AAM(IDPROJ)
17547 PPROJ(4) = SQRT(PPROJ(5)**2+PPROJ(3)**2)
17548 DO 1 K=1,5
17549 PNUC(K) = PHKK(K,IDXTAR)
17550 1 CONTINUE
17551
17552 ILOOP = 0
17553 2 CONTINUE
17554 ILOOP = ILOOP+1
17555 IF (ILOOP.GT.100) GOTO 9999
17556
17557 CALL DT_HADRIN(IDPROJ,PPROJ,IDNUC,PNUC,IPROC,IREJ1)
17558 IF (IREJ1.EQ.1) GOTO 9999
17559
17560 IF (IREJ1.GT.1) THEN
17561* no interaction possible
17562* require Pauli blocking
17563 IF ((IDPROJ.EQ.1).AND.(PPROJ(4).LE.PFERMP(2)+PPROJ(5))) GOTO 2
17564 IF ((IDPROJ.EQ.8).AND.(PPROJ(4).LE.PFERMN(2)+PPROJ(5))) GOTO 2
17565 IF ((IIBAR(IDPROJ).NE.1).AND.
17566 & (PPROJ(4).LE.EPOT(2,IDPROJ)+PPROJ(5))) GOTO 2
17567* store incoming particle as final state particle
17568 CALL DT_LTNUC(PPROJ(3),PPROJ(4),PCMS,ECMS,3)
17569 CALL DT_EVTPUT(1,IDPROJ,1,0,PPROJ(1),PPROJ(2),PCMS,ECMS,0,0,0)
17570 NPOINT(4) = NHKK
17571 ELSE
17572* require Pauli blocking for final state nucleons
17573 DO 4 I=1,NFSP
17574 IF ((IDFSP(I).EQ.1).AND.
17575 & (PFSP(4,I).LE.PFERMP(2)+AAM(IDFSP(I)))) GOTO 2
17576 IF ((IDFSP(I).EQ.8).AND.
17577 & (PFSP(4,I).LE.PFERMN(2)+AAM(IDFSP(I)))) GOTO 2
17578 IF ((IIBAR(IDFSP(I)).NE.1).AND.
17579 & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I))))GOTO 2
17580 4 CONTINUE
17581* store final state particles
17582 DO 5 I=1,NFSP
17583 IST = 1
17584 IF ((IIBAR(IDFSP(I)).EQ.1).AND.
17585 & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I)))) IST = 16
17586 IDHAD = IDT_IPDGHA(IDFSP(I))
17587 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PCMS,ECMS,3)
17588 CALL DT_EVTPUT(IST,IDHAD,1,IDXTAR,PFSP(1,I),PFSP(2,I),
17589 & PCMS,ECMS,0,0,0)
17590 IF (I.EQ.1) NPOINT(4) = NHKK
17591 VHKK(1,NHKK) = 0.5D0*(VHKK(1,1)+VHKK(1,IDXTAR))
17592 VHKK(2,NHKK) = 0.5D0*(VHKK(2,1)+VHKK(2,IDXTAR))
17593 VHKK(3,NHKK) = VHKK(3,IDXTAR)
17594 VHKK(4,NHKK) = VHKK(4,IDXTAR)
17595 WHKK(1,NHKK) = 0.5D0*(WHKK(1,1)+WHKK(1,IDXTAR))
17596 WHKK(2,NHKK) = 0.5D0*(WHKK(2,1)+WHKK(2,IDXTAR))
17597 WHKK(3,NHKK) = WHKK(3,1)
17598 WHKK(4,NHKK) = WHKK(4,1)
17599 5 CONTINUE
17600 ENDIF
17601 TAUFOR = TAUSAV
17602 RETURN
17603
17604 9999 CONTINUE
17605 IREJ = 1
17606 TAUFOR = TAUSAV
17607 RETURN
17608 END
17609
17610*$ CREATE DT_GETEMU.FOR
17611*COPY DT_GETEMU
17612*
17613*===getemu=============================================================*
17614*
17615 SUBROUTINE DT_GETEMU(IT,ITZ,KKMAT,MODE)
17616
17617************************************************************************
17618* Sampling of emulsion component to be considered as target-nucleus. *
17619* This version dated 6.5.95 is written by S. Roesler. *
17620************************************************************************
17621
17622 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17623 SAVE
17624 PARAMETER ( LINP = 10 ,
17625 & LOUT = 6 ,
17626 & LDAT = 9 )
17627 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
17628
17629 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
17630* emulsion treatment
17631 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
17632 & NCOMPO,IEMUL
17633* Glauber formalism: flags and parameters for statistics
17634 LOGICAL LPROD
17635 CHARACTER*8 CGLB
17636 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
17637
17638 IF (MODE.EQ.0) THEN
17639 SUMFRA = ZERO
17640 RR = DT_RNDM(SUMFRA)
17641 IT = 0
17642 ITZ = 0
17643 DO 1 ICOMP=1,NCOMPO
17644 SUMFRA = SUMFRA+EMUFRA(ICOMP)
17645 IF (SUMFRA.GT.RR) THEN
17646 IT = IEMUMA(ICOMP)
17647 ITZ = IEMUCH(ICOMP)
17648 KKMAT = ICOMP
17649 GOTO 2
17650 ENDIF
17651 1 CONTINUE
17652 2 CONTINUE
17653 IF (IT.LE.0) THEN
17654 WRITE(LOUT,'(1X,A,E12.3)')
17655 & 'Warning! norm. failure within emulsion fractions',
17656 & SUMFRA
17657 STOP
17658 ENDIF
17659 ELSEIF (MODE.EQ.1) THEN
17660 NDIFF = 10000
17661 DO 3 I=1,NCOMPO
17662 IDIFF = ABS(IT-IEMUMA(I))
17663 IF (IDIFF.LT.NDIFF) THEN
17664 KKMAT = I
17665 NDIFF = IDIFF
17666 ENDIF
17667 3 CONTINUE
17668 ELSE
17669 STOP 'DT_GETEMU'
17670 ENDIF
17671
17672* bypass for variable projectile/target/energy runs: the correct
17673* Glauber data will be always loaded on kkmat=1
17674 IF (IOGLB.EQ.100) THEN
17675 KKMAT = 1
17676 ENDIF
17677
17678 RETURN
17679 END
17680
17681*$ CREATE DT_NCLPOT.FOR
17682*COPY DT_NCLPOT
17683*
17684*===nclpot=============================================================*
17685*
17686 SUBROUTINE DT_NCLPOT(IPZ,IP,ITZ,IT,AFERP,AFERT,MODE)
17687
17688************************************************************************
17689* Calculation of Coulomb and nuclear potential for a given configurat. *
17690* IPZ, IP charge/mass number of proj. *
17691* ITZ, IT charge/mass number of targ. *
17692* AFERP,AFERT factors modifying proj./target pot. *
17693* if =0, FERMOD is used *
17694* MODE = 0 calculation of binding energy *
17695* = 1 pre-calculated binding energy is used *
17696* This version dated 16.11.95 is written by S. Roesler. *
17697* *
17698* Last change 28.12.2006 by S. Roesler. *
17699************************************************************************
17700
17701 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17702 SAVE
17703 PARAMETER ( LINP = 10 ,
17704 & LOUT = 6 ,
17705 & LDAT = 9 )
17706 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
17707 & TINY10=1.0D-10)
17708
17709 LOGICAL LSTART
17710
17711* particle properties (BAMJET index convention)
17712 CHARACTER*8 ANAME
17713 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17714 & IICH(210),IIBAR(210),K1(210),K2(210)
17715* nuclear potential
17716 LOGICAL LFERMI
17717 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17718 & EBINDP(2),EBINDN(2),EPOT(2,210),
17719 & ETACOU(2),ICOUL,LFERMI
17720
17721 DIMENSION IDXPOT(14)
17722* ap an lam alam sig- sig+ sig0 tet0 tet- asig-
17723 DATA IDXPOT / 2, 9, 17, 18, 20, 21, 22, 97, 98, 99,
17724* asig0 asig+ atet0 atet+
17725 & 100, 101, 102, 103/
17726
17727 DATA AN /0.4D0/
17728 DATA LSTART /.TRUE./
17729
17730 IF (MODE.EQ.0) THEN
17731 EBINDP(1) = ZERO
17732 EBINDN(1) = ZERO
17733 EBINDP(2) = ZERO
17734 EBINDN(2) = ZERO
17735 ENDIF
17736 AIP = DBLE(IP)
17737 AIPZ = DBLE(IPZ)
17738 AIT = DBLE(IT)
17739 AITZ = DBLE(ITZ)
17740
17741 FERMIP = AFERP
17742 IF (AFERP.LE.ZERO) FERMIP = FERMOD
17743 FERMIT = AFERT
17744 IF (AFERT.LE.ZERO) FERMIT = FERMOD
17745
17746* Fermi momenta and binding energy for projectile
17747 IF ((IP.GT.1).AND.LFERMI) THEN
17748 IF (MODE.EQ.0) THEN
17749C EBINDP(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ-1)
17750C EBINDN(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ)
17751 BIP = AIP -ONE
17752 BIPZ = AIPZ-ONE
17753 EBINDP(1) = 1.0D-3*(DT_ENERGY(ONE,ONE)+DT_ENERGY(BIP,BIPZ)
17754 & -DT_ENERGY(AIP,AIPZ))
17755 IF (AIP.LE.AIPZ) THEN
17756 EBINDN(1) = EBINDP(1)
17757 WRITE(LOUT,*) ' DT_NCLPOT: AIP.LE.AIPZ (',AIP,AIPZ,')'
17758 ELSE
17759 EBINDN(1) = 1.0D-3*(DT_ENERGY(ONE,ZERO)
17760 & +DT_ENERGY(BIP,AIPZ)-DT_ENERGY(AIP,AIPZ))
17761 ENDIF
17762 ENDIF
17763 PFERMP(1) = FERMIP*AN*(AIPZ/AIP)**0.333333D0
17764 PFERMN(1) = FERMIP*AN*((AIP-AIPZ)/AIP)**0.33333D0
17765 ELSE
17766 PFERMP(1) = ZERO
17767 PFERMN(1) = ZERO
17768 ENDIF
17769* effective nuclear potential for projectile
17770C EPOT(1,1) = PFERMP(1)**2/(2.0D0*AAM(1)) + EBINDP(1)
17771C EPOT(1,8) = PFERMN(1)**2/(2.0D0*AAM(8)) + EBINDN(1)
17772 EPOT(1,1) = SQRT(PFERMP(1)**2+AAM(1)**2) -AAM(1) + EBINDP(1)
17773 EPOT(1,8) = SQRT(PFERMN(1)**2+AAM(8)**2) -AAM(8) + EBINDN(1)
17774
17775* Fermi momenta and binding energy for target
17776 IF ((IT.GT.1).AND.LFERMI) THEN
17777 IF (MODE.EQ.0) THEN
17778C EBINDP(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ-1)
17779C EBINDN(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ)
17780 BIT = AIT -ONE
17781 BITZ = AITZ-ONE
17782
17783 EBINDP(2) = 1.0D-3*(DT_ENERGY(ONE,ONE)+DT_ENERGY(BIT,BITZ)
17784 & -DT_ENERGY(AIT,AITZ))
17785
17786 IF (AIT.LE.AITZ) THEN
17787 EBINDN(2) = EBINDP(2)
17788 WRITE(LOUT,*) ' DT_NCLPOT: AIT.LE.AIPT (',AIT,AIPT,')'
17789 ELSE
17790
17791 EBINDN(2) = 1.0D-3*(DT_ENERGY(ONE,ZERO)
17792 & +DT_ENERGY(BIT,AITZ)-DT_ENERGY(AIT,AITZ))
17793
17794 ENDIF
17795 ENDIF
17796 PFERMP(2) = FERMIT*AN*(AITZ/AIT)**0.333333D0
17797 PFERMN(2) = FERMIT*AN*((AIT-AITZ)/AIT)**0.33333D0
17798 ELSE
17799 PFERMP(2) = ZERO
17800 PFERMN(2) = ZERO
17801 ENDIF
17802* effective nuclear potential for target
17803C EPOT(2,1) = PFERMP(2)**2/(2.0D0*AAM(1)) + EBINDP(2)
17804C EPOT(2,8) = PFERMN(2)**2/(2.0D0*AAM(8)) + EBINDN(2)
17805 EPOT(2,1) = SQRT(PFERMP(2)**2+AAM(1)**2) -AAM(1) + EBINDP(2)
17806 EPOT(2,8) = SQRT(PFERMN(2)**2+AAM(8)**2) -AAM(8) + EBINDN(2)
17807
17808 DO 2 I=1,14
17809 EPOT(1,IDXPOT(I)) = EPOT(1,8)
17810 EPOT(2,IDXPOT(I)) = EPOT(2,8)
17811 2 CONTINUE
17812
17813* Coulomb energy
17814 ETACOU(1) = ZERO
17815 ETACOU(2) = ZERO
17816 IF (ICOUL.EQ.1) THEN
17817 IF (IP.GT.1)
17818 & ETACOU(1) = 0.001116D0*AIPZ/(1.0D0+AIP**0.333D0)
17819 IF (IT.GT.1)
17820 & ETACOU(2) = 0.001116D0*AITZ/(1.0D0+AIT**0.333D0)
17821 ENDIF
17822
17823 IF (LSTART) THEN
17824 WRITE(LOUT,1000) IP,IPZ,IT,ITZ,EBINDP,EBINDN,
17825 & EPOT(1,1)-EBINDP(1),EPOT(2,1)-EBINDP(2),
17826 & EPOT(1,8)-EBINDN(1),EPOT(2,8)-EBINDN(2),
17827 & FERMOD,ETACOU
17828 1000 FORMAT(/,/,1X,'NCLPOT: quantities for inclusion of nuclear'
17829 & ,' effects',/,12X,'---------------------------',
17830 & '----------------',/,/,38X,'projectile',
17831 & ' target',/,/,1X,'Mass number / charge',
17832 & 17X,I3,' /',I3,6X,I3,' /',I3,/,1X,'Binding energy -',
17833 & ' proton (GeV) ',2E14.4,/,17X,'- neutron (GeV)'
17834 & ,1X,2E14.4,/,1X,'Fermi-potential - proton (GeV)',
17835 & 1X,2E14.4,/,17X,'- neutron (GeV) ',2E14.4,/,/,
17836 & 1X,'Scale factor for Fermi-momentum ',F4.2,/,
17837 & /,1X,'Coulomb-energy ',2(E14.4,' GeV '),/,/)
17838 LSTART = .FALSE.
17839 ENDIF
17840
17841 RETURN
17842 END
17843
17844*$ CREATE DT_RESNCL.FOR
17845*COPY DT_RESNCL
17846*
17847*===resncl=============================================================*
17848*
17849 SUBROUTINE DT_RESNCL(EPN,NLOOP,MODE)
17850
17851************************************************************************
17852* Treatment of residual nuclei and nuclear effects. *
17853* MODE = 1 initializations *
17854* = 2 treatment of final state *
17855* This version dated 16.11.95 is written by S. Roesler. *
17856* *
17857* Last change 05.01.2007 by S. Roesler. *
17858************************************************************************
17859
17860 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17861 SAVE
17862 PARAMETER ( LINP = 10 ,
17863 & LOUT = 6 ,
17864 & LDAT = 9 )
17865 PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,THREE=3.D0,TINY3=1.0D-3,
17866 & TINY2=1.0D-2,TINY1=1.0D-1,TINY4=1.0D-4,TINY10=1.0D-10,
17867 & ONETHI=ONE/THREE)
17868 PARAMETER (AMUAMU = 0.93149432D0,
17869 & FM2MM = 1.0D-12,
17870 & RNUCLE = 1.12D0)
17871 PARAMETER ( EMVGEV = 1.0 D-03 )
17872 PARAMETER ( AMUGEV = 0.93149432 D+00 )
17873 PARAMETER ( AMPRTN = 0.93827231 D+00 )
17874 PARAMETER ( AMNTRN = 0.93956563 D+00 )
17875 PARAMETER ( AMELCT = 0.51099906 D-03 )
17876 PARAMETER ( HLFHLF = 0.5D+00 )
17877 PARAMETER ( FERTHO = 14.33 D-09 )
17878 PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
17879 PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
17880 PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
17881
17882* event history
17883 PARAMETER (NMXHKK=200000)
17884 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17885 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17886 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17887* extended event history
17888 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17889 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17890 & IHIST(2,NMXHKK)
17891* particle properties (BAMJET index convention)
17892 CHARACTER*8 ANAME
17893 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17894 & IICH(210),IIBAR(210),K1(210),K2(210)
17895* flags for input different options
17896 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17897 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17898 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17899* nuclear potential
17900 LOGICAL LFERMI
17901 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17902 & EBINDP(2),EBINDN(2),EPOT(2,210),
17903 & ETACOU(2),ICOUL,LFERMI
17904* properties of interacting particles
17905 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
17906* properties of photon/lepton projectiles
17907 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
17908* Lorentz-parameters of the current interaction
17909 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
17910 & UMO,PPCM,EPROJ,PPROJ
17911* treatment of residual nuclei: wounded nucleons
17912 COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
17913* treatment of residual nuclei: 4-momenta
17914 LOGICAL LRCLPR,LRCLTA
17915 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
17916 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
17917
17918 DIMENSION PFSP(4),PSEC(4),PSEC0(4)
17919 DIMENSION PMOMB(5000),IDXB(5000),PMOMM(10000),IDXM(10000),
17920 & IDXCOR(15000),IDXOTH(NMXHKK)
17921
17922 GOTO (1,2) MODE
17923
17924*------- initializations
17925 1 CONTINUE
17926
17927* initialize arrays for residual nuclei
17928 DO 10 K=1,5
17929 IF (K.LE.4) THEN
17930 PFSP(K) = ZERO
17931 ENDIF
17932 PINIPR(K) = ZERO
17933 PINITA(K) = ZERO
17934 PRCLPR(K) = ZERO
17935 PRCLTA(K) = ZERO
17936 TRCLPR(K) = ZERO
17937 TRCLTA(K) = ZERO
17938 10 CONTINUE
17939 SCPOT = ONE
17940 NLOOP = 0
17941
17942* correction of projectile 4-momentum for effective target pot.
17943* and Coulomb-energy (in case of hadron-nucleus interaction only)
9b65428d
AM		 17944* IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
17945* EPNI = EPN
9aaba0d6 17946* Coulomb-energy:
17947* positively charged hadron - check energy for Coloumb pot.
9b65428d
AM		 17948* IF (IICH(IJPROJ).EQ.1) THEN
17949* THRESH = ETACOU(2)+AAM(IJPROJ)
17950* IF (EPNI.LE.THRESH) THEN
17951* WRITE(LOUT,1000)
17952* 1000 FORMAT(/,1X,'KKINC: WARNING! projectile energy',
17953* & ' below Coulomb threshold - event rejected',/)
17954* ISTHKK(1) = 1
17955* RETURN
17956* ENDIF
9aaba0d6 17957* negatively charged hadron - increase energy by Coulomb energy
9b65428d
AM		 17958* ELSEIF (IICH(IJPROJ).EQ.-1) THEN
17959* EPNI = EPNI+ETACOU(2)
17960* ENDIF
17961* IF ((IJPROJ.EQ.1).OR.(IJPROJ.EQ.8)) THEN
9aaba0d6 17962* Effective target potential
17963*sr 6.6. binding energy only (to avoid negative exc. energies)
17964C EPNI = EPNI+EPOT(2,IJPROJ)
9b65428d
AM		 17965* EBIPOT = EBINDP(2)
17966* IF ((IJPROJ.NE.1).AND.(ABS(EPOT(2,IJPROJ)).GT.5.0D-3))
17967* & EBIPOT = EBINDN(2)
17968* EPNI = EPNI+ABS(EBIPOT)
9aaba0d6 17969* re-initialization of DTLTRA
9b65428d
AM		 17970* DUM1 = ZERO
17971* DUM2 = ZERO
17972*
17973* CALL DT_LTINI(IJPROJ,IJTARG,EPNI,DUM1,DUM2,0)
17974* ENDIF
17975* ENDIF
9aaba0d6 17976
17977* projectile in n-n cms
17978 IF ((IP.LE.1).AND.(IT.GT.1)) THEN
17979 PMASS1 = AAM(IJPROJ)
17980C* VDM assumption
17981C IF (IJPROJ.EQ.7) PMASS1 = AAM(33)
17982 IF (IJPROJ.EQ.7) PMASS1 = AAM(IJPROJ)-SQRT(VIRT)
17983 PMASS2 = AAM(1)
17984 PM1 = SIGN(PMASS1**2,PMASS1)
17985 PM2 = SIGN(PMASS2**2,PMASS2)
17986 PINIPR(4) = (UMO**2-PM2+PM1)/(TWO*UMO)
17987 PINIPR(5) = PMASS1
17988 IF (PMASS1.GT.ZERO) THEN
17989 PINIPR(3) = SQRT((PINIPR(4)-PINIPR(5))
17990 & *(PINIPR(4)+PINIPR(5)))
17991 ELSE
17992 PINIPR(3) = SQRT(PINIPR(4)**2-PM1)
17993 ENDIF
17994 AIT = DBLE(IT)
17995 AITZ = DBLE(ITZ)
17996 PINITA(5) = AIT*AMUAMU+1.0D-3*DT_ENERGY(AIT,AITZ)
17997 CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
17998 ELSEIF ((IP.GT.1).AND.(IT.LE.1)) THEN
17999 PMASS1 = AAM(1)
18000 PMASS2 = AAM(IJTARG)
18001 PM1 = SIGN(PMASS1**2,PMASS1)
18002 PM2 = SIGN(PMASS2**2,PMASS2)
18003 PINITA(4) = (UMO**2-PM1+PM2)/(TWO*UMO)
18004 PINITA(5) = PMASS2
18005 PINITA(3) = -SQRT((PINITA(4)-PINITA(5))
18006 & *(PINITA(4)+PINITA(5)))
18007 AIP = DBLE(IP)
18008 AIPZ = DBLE(IPZ)
18009 PINIPR(5) = AIP*AMUAMU+1.0D-3*DT_ENERGY(AIP,AIPZ)
18010 CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
18011 ELSEIF ((IP.GT.1).AND.(IT.GT.1)) THEN
18012 AIP = DBLE(IP)
18013 AIPZ = DBLE(IPZ)
18014 PINIPR(5) = AIP*AMUAMU+1.0D-3*DT_ENERGY(AIP,AIPZ)
18015 CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
18016 AIT = DBLE(IT)
18017 AITZ = DBLE(ITZ)
18018 PINITA(5) = AIT*AMUAMU+1.0D-3*DT_ENERGY(AIT,AITZ)
18019 CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
18020 ENDIF
18021
18022 RETURN
18023
18024*------- treatment of final state
18025 2 CONTINUE
18026
18027 NLOOP = NLOOP+1
18028 IF (NLOOP.GT.1) SCPOT = 0.10D0
18029C WRITE(LOUT,*) 'event ',NEVHKK,NLOOP,SCPOT
18030
18031 JPW = NPW
18032 JPCW = NPCW
18033 JTW = NTW
18034 JTCW = NTCW
18035 DO 40 K=1,4
18036 PFSP(K) = ZERO
18037 40 CONTINUE
18038
18039 NOB = 0
18040 NOM = 0
18041 DO 900 I=NPOINT(4),NHKK
18042 IDXOTH(I) = -1
18043 IF (ISTHKK(I).EQ.1) THEN
18044 IF (IDBAM(I).EQ.7) GOTO 900
18045 IPOT = 0
18046 IOTHER = 0
18047* particle moving into forward direction
18048 IF (PHKK(3,I).GE.ZERO) THEN
18049* most likely to be effected by projectile potential
18050 IPOT = 1
18051* there is no projectile nucleus, try target
18052 IF ((IP.LE.1).OR.((IP-NPW).LE.1)) THEN
18053 IPOT = 2
18054 IF (IP.GT.1) IOTHER = 1
18055* there is no target nucleus --> skip
18056 IF ((IT.LE.1).OR.((IT-NTW).LE.1)) GOTO 900
18057 ENDIF
18058* particle moving into backward direction
18059 ELSE
18060* most likely to be effected by target potential
18061 IPOT = 2
18062* there is no target nucleus, try projectile
18063 IF ((IT.LE.1).OR.((IT-NTW).LE.1)) THEN
18064 IPOT = 1
18065 IF (IT.GT.1) IOTHER = 1
18066* there is no projectile nucleus --> skip
18067 IF ((IP.LE.1).OR.((IP-NPW).LE.1)) GOTO 900
18068 ENDIF
18069 ENDIF
18070 IFLG = -IPOT
18071* nobam=3: particle is in overlap-region or neither inside proj. nor target
18072* =1: particle is not in overlap-region AND is inside target (2)
18073* =2: particle is not in overlap-region AND is inside projectile (1)
18074* flag particles which are inside the nucleus ipot but not in its
18075* overlap region
18076 IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) IFLG = IPOT
18077 IF (IDBAM(I).NE.0) THEN
18078* baryons: keep all nucleons and all others where flag is set
18079 IF (IIBAR(IDBAM(I)).NE.0) THEN
18080 IF ((IDBAM(I).EQ.1).OR.(IDBAM(I).EQ.8).OR.(IFLG.GT.0))
18081 & THEN
18082 NOB = NOB+1
18083 PMOMB(NOB) = PHKK(3,I)
18084 IDXB(NOB) = SIGN(10000000*IABS(IFLG)
18085 & +1000000*IOTHER+I,IFLG)
18086 ENDIF
18087* mesons: keep only those mesons where flag is set
18088 ELSE
18089 IF (IFLG.GT.0) THEN
18090 NOM = NOM+1
18091 PMOMM(NOM) = PHKK(3,I)
18092 IDXM(NOM) = 10000000*IFLG+1000000*IOTHER+I
18093 ENDIF
18094 ENDIF
18095 ENDIF
18096 ENDIF
18097 900 CONTINUE
18098*
18099* sort particles in the arrays according to increasing long. momentum
18100 CALL DT_SORT1(PMOMB,IDXB,NOB,1,NOB,1)
18101 CALL DT_SORT1(PMOMM,IDXM,NOM,1,NOM,1)
18102*
18103* shuffle indices into one and the same array according to the later
18104* sequence of correction
18105 NCOR = 0
18106 IF (IT.GT.1) THEN
18107 DO 910 I=1,NOB
18108 IF (PMOMB(I).GT.ZERO) GOTO 911
18109 NCOR = NCOR+1
18110 IDXCOR(NCOR) = IDXB(I)
18111 910 CONTINUE
18112 911 CONTINUE
18113 IF (IP.GT.1) THEN
18114 DO 912 J=1,NOB
18115 I = NOB+1-J
18116 IF (PMOMB(I).LT.ZERO) GOTO 913
18117 NCOR = NCOR+1
18118 IDXCOR(NCOR) = IDXB(I)
18119 912 CONTINUE
18120 913 CONTINUE
18121 ELSE
18122 DO 914 I=1,NOB
18123 IF (PMOMB(I).GT.ZERO) THEN
18124 NCOR = NCOR+1
18125 IDXCOR(NCOR) = IDXB(I)
18126 ENDIF
18127 914 CONTINUE
18128 ENDIF
18129 ELSE
18130 DO 915 J=1,NOB
18131 I = NOB+1-J
18132 NCOR = NCOR+1
18133 IDXCOR(NCOR) = IDXB(I)
18134 915 CONTINUE
18135 ENDIF
18136 DO 925 I=1,NOM
18137 IF (PMOMM(I).GT.ZERO) GOTO 926
18138 NCOR = NCOR+1
18139 IDXCOR(NCOR) = IDXM(I)
18140 925 CONTINUE
18141 926 CONTINUE
18142 DO 927 J=1,NOM
18143 I = NOM+1-J
18144 IF (PMOMM(I).LT.ZERO) GOTO 928
18145 NCOR = NCOR+1
18146 IDXCOR(NCOR) = IDXM(I)
18147 927 CONTINUE
18148 928 CONTINUE
18149*
18150C IF (NEVHKK.EQ.484) THEN
18151C WRITE(LOUT,9000) JPCW,JPW-JPCW,JTCW,JTW-JTCW
18152C 9000 FORMAT(1X,'wounded nucleons (proj.-p,n targ.-p,n)',/,4I10)
18153C WRITE(LOUT,9001) NOB,NOM,NCOR
18154C 9001 FORMAT(1X,'produced particles (baryons,mesons,all)',3I10)
18155C WRITE(LOUT,'(/,A)') ' baryons '
18156C DO 950 I=1,NOB
18157CC J = IABS(IDXB(I))
18158CC INDEX = J-IABS(J/10000000)*10000000
18159C IPOT = IABS(IDXB(I))/10000000
18160C IOTHER = IABS(IDXB(I))/1000000-IPOT*10
18161C INDEX = IABS(IDXB(I))-IPOT*10000000-IOTHER*1000000
18162C WRITE(LOUT,9002) I,INDEX,IDXB(I),IDBAM(INDEX),PMOMB(I)
18163C 950 CONTINUE
18164C WRITE(LOUT,'(/,A)') ' mesons '
18165C DO 951 I=1,NOM
18166CC INDEX = IDXM(I)-IABS(IDXM(I)/10000000)*10000000
18167C IPOT = IABS(IDXM(I))/10000000
18168C IOTHER = IABS(IDXM(I))/1000000-IPOT*10
18169C INDEX = IABS(IDXM(I))-IPOT*10000000-IOTHER*1000000
18170C WRITE(LOUT,9002) I,INDEX,IDXM(I),IDBAM(INDEX),PMOMM(I)
18171C 951 CONTINUE
18172C 9002 FORMAT(1X,4I14,E14.5)
18173C WRITE(LOUT,'(/,A)') ' all '
18174C DO 952 I=1,NCOR
18175CC J = IABS(IDXCOR(I))
18176CC INDEX = J-IABS(J/10000000)*10000000
18177CC IPOT = IABS(IDXCOR(I))/10000000
18178C IOTHER = IABS(IDXCOR(I))/1000000-IPOT*10
18179C INDEX = IABS(IDXCOR(I))-IPOT*10000000-IOTHER*1000000
18180C WRITE(LOUT,9003) I,INDEX,IDXCOR(I),IDBAM(INDEX)
18181C 952 CONTINUE
18182C 9003 FORMAT(1X,4I14)
18183C ENDIF
18184*
18185 DO 20 ICOR=1,NCOR
18186 IPOT = IABS(IDXCOR(ICOR))/10000000
18187 IOTHER = IABS(IDXCOR(ICOR))/1000000-IPOT*10
18188 I = IABS(IDXCOR(ICOR))-IPOT*10000000-IOTHER*1000000
18189 IDXOTH(I) = 1
18190
18191 IDSEC = IDBAM(I)
18192
18193* reduction of particle momentum by corresponding nuclear potential
18194* (this applies only if Fermi-momenta are requested)
18195
18196 IF (LFERMI) THEN
18197
18198* Lorentz-transformation into the rest system of the selected nucleus
18199 IMODE = -IPOT-1
18200 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
18201 & PSEC(1),PSEC(2),PSEC(3),PSEC(4),IDSEC,IMODE)
18202 PSECO = SQRT(PSEC(1)**2+PSEC(2)**2+PSEC(3)**2)
18203 AMSEC = SQRT(ABS((PSEC(4)-PSECO)*(PSEC(4)+PSECO)))
18204 JPMOD = 0
18205
18206 CHKLEV = TINY3
18207 IF ((EPROJ.GE.1.0D4).AND.(IDSEC.EQ.7)) CHKLEV = TINY1
18208 IF (EPROJ.GE.2.0D6) CHKLEV = 1.0D0
18209 IF (ABS(AMSEC-AAM(IDSEC)).GT.CHKLEV) THEN
18210 IF (IOULEV(3).GT.0)
18211 & WRITE(LOUT,2000) I,NEVHKK,IDSEC,AMSEC,AAM(IDSEC)
18212 2000 FORMAT(1X,'RESNCL: inconsistent mass of particle',
18213 & ' at entry ',I5,' (evt.',I8,')',/,' IDSEC: ',
18214 & I4,' AMSEC: ',E12.3,' AAM(IDSEC): ',E12.3,/)
18215 GOTO 23
18216 ENDIF
18217
18218 DO 21 K=1,4
18219 PSEC0(K) = PSEC(K)
18220 21 CONTINUE
18221
18222* the correction for nuclear potential effects is applied to as many
18223* p/n as many nucleons were wounded; the momenta of other final state
18224* particles are corrected only if they materialize inside the corresp.
18225* nucleus (here: NOBAM = 1 part. outside proj., = 2 part. outside targ
18226* = 3 part. outside proj. and targ., >=10 in overlapping region)
18227 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) THEN
18228 IF (IPOT.EQ.1) THEN
18229 IF ((JPW.GT.0).AND.(IOTHER.EQ.0)) THEN
18230* this is most likely a wounded nucleon
18231**test
18232C RDIST = SQRT((VHKK(1,IPW(JPW))/FM2MM)**2
18233C & +(VHKK(2,IPW(JPW))/FM2MM)**2
18234C & +(VHKK(3,IPW(JPW))/FM2MM)**2)
18235C RAD = RNUCLE*DBLE(IP)**ONETHI
18236C FDEN = 1.4D0*DT_DENSIT(IP,RDIST,RAD)
18237C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
18238**
18239 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18240 JPW = JPW-1
18241 JPMOD = 1
18242 ELSE
18243* correct only if part. was materialized inside nucleus
18244* and if it is ouside the overlapping region
18245 IF ((NOBAM(I).NE.1).AND.(NOBAM(I).LT.3)) THEN
18246 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18247 JPMOD = 1
18248 ENDIF
18249 ENDIF
18250 ELSEIF (IPOT.EQ.2) THEN
18251 IF ((JTW.GT.0).AND.(IOTHER.EQ.0)) THEN
18252* this is most likely a wounded nucleon
18253**test
18254C RDIST = SQRT((VHKK(1,ITW(JTW))/FM2MM)**2
18255C & +(VHKK(2,ITW(JTW))/FM2MM)**2
18256C & +(VHKK(3,ITW(JTW))/FM2MM)**2)
18257C RAD = RNUCLE*DBLE(IT)**ONETHI
18258C FDEN = 1.4D0*DT_DENSIT(IT,RDIST,RAD)
18259C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
18260**
18261 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18262 JTW = JTW-1
18263 JPMOD = 1
18264 ELSE
18265* correct only if part. was materialized inside nucleus
18266 IF ((NOBAM(I).NE.2).AND.(NOBAM(I).LT.3)) THEN
18267 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18268 JPMOD = 1
18269 ENDIF
18270 ENDIF
18271 ENDIF
18272 ELSE
18273 IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) THEN
18274 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18275 JPMOD = 1
18276 ENDIF
18277 ENDIF
18278
18279 IF (NLOOP.EQ.1) THEN
18280* Coulomb energy correction:
18281* the treatment of Coulomb potential correction is similar to the
18282* one for nuclear potential
18283 IF (IDSEC.EQ.1) THEN
18284 IF ((IPOT.EQ.1).AND.(JPCW.GT.0)) THEN
18285 JPCW = JPCW-1
18286 ELSEIF ((IPOT.EQ.2).AND.(JTCW.GT.0)) THEN
18287 JTCW = JTCW-1
18288 ELSE
18289 IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
18290 ENDIF
18291 ELSE
18292 IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
18293 ENDIF
18294 IF (IICH(IDSEC).EQ.1) THEN
18295* pos. particles: check if they are able to escape Coulomb potential
18296 IF (PSEC(4).LT.AMSEC+ETACOU(IPOT)) THEN
18297 ISTHKK(I) = 14+IPOT
18298 IF (ISTHKK(I).EQ.15) THEN
18299 DO 26 K=1,4
18300 PHKK(K,I) = PSEC0(K)
18301 TRCLPR(K) = TRCLPR(K)+PSEC0(K)
18302 26 CONTINUE
18303 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
18304 IF (IDSEC.EQ.1) NPCW = NPCW-1
18305 ELSEIF (ISTHKK(I).EQ.16) THEN
18306 DO 27 K=1,4
18307 PHKK(K,I) = PSEC0(K)
18308 TRCLTA(K) = TRCLTA(K)+PSEC0(K)
18309 27 CONTINUE
18310 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
18311 IF (IDSEC.EQ.1) NTCW = NTCW-1
18312 ENDIF
18313 GOTO 20
18314 ENDIF
18315 ELSEIF (IICH(IDSEC).EQ.-1) THEN
18316* neg. particles: decrease energy by Coulomb-potential
18317 PSEC(4) = PSEC(4)-ETACOU(IPOT)
18318 JPMOD = 1
18319 ENDIF
18320 ENDIF
18321
18322 25 CONTINUE
18323
18324 IF (PSEC(4).LT.AMSEC) THEN
18325 IF (IOULEV(6).GT.0)
18326 & WRITE(LOUT,2001) I,IDSEC,PSEC(4),AMSEC
18327 2001 FORMAT(1X,'KKINC: particle at DTEVT1-pos. ',I5,
18328 & ' is not allowed to escape nucleus',/,
18329 & 8X,'id : ',I3,' reduced energy: ',E15.4,
18330 & ' mass: ',E12.3)
18331 ISTHKK(I) = 14+IPOT
18332 IF (ISTHKK(I).EQ.15) THEN
18333 DO 28 K=1,4
18334 PHKK(K,I) = PSEC0(K)
18335 TRCLPR(K) = TRCLPR(K)+PSEC0(K)
18336 28 CONTINUE
18337 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
18338 IF (IDSEC.EQ.1) NPCW = NPCW-1
18339 ELSEIF (ISTHKK(I).EQ.16) THEN
18340 DO 29 K=1,4
18341 PHKK(K,I) = PSEC0(K)
18342 TRCLTA(K) = TRCLTA(K)+PSEC0(K)
18343 29 CONTINUE
18344 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
18345 IF (IDSEC.EQ.1) NTCW = NTCW-1
18346 ENDIF
18347 GOTO 20
18348 ENDIF
18349
18350 IF (JPMOD.EQ.1) THEN
18351 PSECN = SQRT( (PSEC(4)-AMSEC)*(PSEC(4)+AMSEC) )
18352* 4-momentum after correction for nuclear potential
18353 DO 22 K=1,3
18354 PSEC(K) = PSEC(K)*PSECN/PSECO
18355 22 CONTINUE
18356
18357* store recoil momentum from particles escaping the nuclear potentials
18358 DO 30 K=1,4
18359 IF (IPOT.EQ.1) THEN
18360 TRCLPR(K) = TRCLPR(K)+PSEC0(K)-PSEC(K)
18361 ELSEIF (IPOT.EQ.2) THEN
18362 TRCLTA(K) = TRCLTA(K)+PSEC0(K)-PSEC(K)
18363 ENDIF
18364 30 CONTINUE
18365
18366* transform momentum back into n-n cms
18367 IMODE = IPOT+1
18368 CALL DT_LTRANS(PSEC(1),PSEC(2),PSEC(3),PSEC(4),
18369 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
18370 & IDSEC,IMODE)
18371 ENDIF
18372
18373 ENDIF
18374
18375 23 CONTINUE
18376 DO 31 K=1,4
18377 PFSP(K) = PFSP(K)+PHKK(K,I)
18378 31 CONTINUE
18379
18380 20 CONTINUE
18381
18382 DO 33 I=NPOINT(4),NHKK
18383 IF ((ISTHKK(I).EQ.1).AND.(IDXOTH(I).LT.0)) THEN
18384 PFSP(1) = PFSP(1)+PHKK(1,I)
18385 PFSP(2) = PFSP(2)+PHKK(2,I)
18386 PFSP(3) = PFSP(3)+PHKK(3,I)
18387 PFSP(4) = PFSP(4)+PHKK(4,I)
18388 ENDIF
18389 33 CONTINUE
18390
18391 DO 34 K=1,5
18392 PRCLPR(K) = TRCLPR(K)
18393 PRCLTA(K) = TRCLTA(K)
18394 34 CONTINUE
18395
18396 IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
18397* hadron-nucleus interactions: get residual momentum from energy-
18398* momentum conservation
18399 DO 32 K=1,4
18400 PRCLPR(K) = ZERO
18401 PRCLTA(K) = PINIPR(K)+PINITA(K)-PFSP(K)
18402 32 CONTINUE
18403 ELSE
18404* nucleus-hadron, nucleus-nucleus: get residual momentum from
18405* accumulated recoil momenta of particles leaving the spectators
18406* transform accumulated recoil momenta of residual nuclei into
18407* n-n cms
18408 PZI = PRCLPR(3)
18409 PEI = PRCLPR(4)
18410 CALL DT_LTNUC(PZI,PEI,PRCLPR(3),PRCLPR(4),2)
18411 PZI = PRCLTA(3)
18412 PEI = PRCLTA(4)
18413 CALL DT_LTNUC(PZI,PEI,PRCLTA(3),PRCLTA(4),3)
18414C IF (IP.GT.1) THEN
18415 PRCLPR(3) = PRCLPR(3)+PINIPR(3)
18416 PRCLPR(4) = PRCLPR(4)+PINIPR(4)
18417C ENDIF
18418 IF (IT.GT.1) THEN
18419 PRCLTA(3) = PRCLTA(3)+PINITA(3)
18420 PRCLTA(4) = PRCLTA(4)+PINITA(4)
18421 ENDIF
18422 ENDIF
18423
18424* check momenta of residual nuclei
18425 IF (LEMCCK) THEN
18426 CALL DT_EVTEMC(-PINIPR(1),-PINIPR(2),-PINIPR(3),-PINIPR(4),
18427 & 1,IDUM,IDUM)
18428 CALL DT_EVTEMC(-PINITA(1),-PINITA(2),-PINITA(3),-PINITA(4),
18429 & 2,IDUM,IDUM)
18430 CALL DT_EVTEMC(PRCLPR(1),PRCLPR(2),PRCLPR(3),PRCLPR(4),
18431 & 2,IDUM,IDUM)
18432 CALL DT_EVTEMC(PRCLTA(1),PRCLTA(2),PRCLTA(3),PRCLTA(4),
18433 & 2,IDUM,IDUM)
18434 CALL DT_EVTEMC(PFSP(1),PFSP(2),PFSP(3),PFSP(4),2,IDUM,IDUM)
18435**sr 19.12. changed to avoid output when used with phojet
18436C CHKLEV = TINY3
18437 CHKLEV = TINY1
18438 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,501,IREJ1)
18439C IF ((NEVHKK.EQ.409).OR.(NEVHKK.EQ.460).OR.(NEVHKK.EQ.765))
18440C & CALL DT_EVTOUT(4)
18441 IF (IREJ1.GT.0) RETURN
18442 ENDIF
18443
18444 RETURN
18445 END
18446
18447*$ CREATE DT_SCN4BA.FOR
18448*COPY DT_SCN4BA
18449*
18450*===scn4ba=============================================================*
18451*
18452 SUBROUTINE DT_SCN4BA
18453
18454************************************************************************
18455* SCan /DTEVT1/ 4 BAryons which are not able to escape nuclear pot. *
18456* This version dated 12.12.95 is written by S. Roesler. *
18457************************************************************************
18458
18459 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18460 SAVE
18461 PARAMETER ( LINP = 10 ,
18462 & LOUT = 6 ,
18463 & LDAT = 9 )
18464 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
18465 & TINY10=1.0D-10)
18466
18467* event history
18468 PARAMETER (NMXHKK=200000)
18469 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18470 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18471 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18472* extended event history
18473 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18474 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18475 & IHIST(2,NMXHKK)
18476* particle properties (BAMJET index convention)
18477 CHARACTER*8 ANAME
18478 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18479 & IICH(210),IIBAR(210),K1(210),K2(210)
18480* properties of interacting particles
18481 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
18482* nuclear potential
18483 LOGICAL LFERMI
18484 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18485 & EBINDP(2),EBINDN(2),EPOT(2,210),
18486 & ETACOU(2),ICOUL,LFERMI
18487* treatment of residual nuclei: wounded nucleons
18488 COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
18489* treatment of residual nuclei: 4-momenta
18490 LOGICAL LRCLPR,LRCLTA
18491 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18492 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18493
18494 DIMENSION PLAB(2,5),PCMS(4)
18495
18496 IREJ = 0
18497
18498* get number of wounded nucleons
18499 NPW = 0
18500 NPW0 = 0
18501 NPCW = 0
18502 NPSTCK = 0
18503 NTW = 0
18504 NTW0 = 0
18505 NTCW = 0
18506 NTSTCK = 0
18507
18508 ISGLPR = 0
18509 ISGLTA = 0
18510 LRCLPR = .FALSE.
18511 LRCLTA = .FALSE.
18512
18513C DO 2 I=1,NHKK
18514 DO 2 I=1,NPOINT(1)
18515* projectile nucleons wounded in primary interaction and in fzc
18516 IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.17)) THEN
18517 NPW = NPW+1
18518 IPW(NPW) = I
18519 NPSTCK = NPSTCK+1
18520 IF (IDHKK(I).EQ.2212) NPCW = NPCW+1
18521 IF (ISTHKK(I).EQ.11) NPW0 = NPW0+1
18522C IF (IP.GT.1) THEN
18523 DO 5 K=1,4
18524 TRCLPR(K) = TRCLPR(K)-PHKK(K,I)
18525 5 CONTINUE
18526C ENDIF
18527* target nucleons wounded in primary interaction and in fzc
18528 ELSEIF ((ISTHKK(I).EQ.12).OR.(ISTHKK(I).EQ.18)) THEN
18529 NTW = NTW+1
18530 ITW(NTW) = I
18531 NTSTCK = NTSTCK+1
18532 IF (IDHKK(I).EQ.2212) NTCW = NTCW+1
18533 IF (ISTHKK(I).EQ.12) NTW0 = NTW0+1
18534 IF (IT.GT.1) THEN
18535 DO 6 K=1,4
18536 TRCLTA(K) = TRCLTA(K)-PHKK(K,I)
18537 6 CONTINUE
18538 ENDIF
18539 ELSEIF (ISTHKK(I).EQ.13) THEN
18540 ISGLPR = I
18541 ELSEIF (ISTHKK(I).EQ.14) THEN
18542 ISGLTA = I
18543 ENDIF
18544 2 CONTINUE
18545
18546 DO 11 I=NPOINT(4),NHKK
18547* baryons which are unable to escape the nuclear potential of proj.
18548 IF (ISTHKK(I).EQ.15) THEN
18549 ISGLPR = I
18550 NPSTCK = NPSTCK-1
18551 IF (IIBAR(IDBAM(I)).NE.0) THEN
18552 NPW = NPW-1
18553 IF (IICH(IDBAM(I)).GT.0) NPCW = NPCW-1
18554 ENDIF
18555 DO 7 K=1,4
18556 TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
18557 7 CONTINUE
18558* baryons which are unable to escape the nuclear potential of targ.
18559 ELSEIF (ISTHKK(I).EQ.16) THEN
18560 ISGLTA = I
18561 NTSTCK = NTSTCK-1
18562 IF (IIBAR(IDBAM(I)).NE.0) THEN
18563 NTW = NTW-1
18564 IF (IICH(IDBAM(I)).GT.0) NTCW = NTCW-1
18565 ENDIF
18566 DO 8 K=1,4
18567 TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
18568 8 CONTINUE
18569 ENDIF
18570 11 CONTINUE
18571
18572* residual nuclei so far
18573 IRESP = IP-NPSTCK
18574 IREST = IT-NTSTCK
18575
18576* ckeck for "residual nuclei" consisting of one nucleon only
18577* treat it as final state particle
18578 IF (IRESP.EQ.1) THEN
18579 ID = IDBAM(ISGLPR)
18580 IST = ISTHKK(ISGLPR)
18581 CALL DT_LTRANS(PHKK(1,ISGLPR),PHKK(2,ISGLPR),
18582 & PHKK(3,ISGLPR),PHKK(4,ISGLPR),
18583 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,2)
18584 IF (IST.EQ.13) THEN
18585 ISTHKK(ISGLPR) = 11
18586 ELSE
18587 ISTHKK(ISGLPR) = 2
18588 ENDIF
18589 CALL DT_EVTPUT(1,IDHKK(ISGLPR),ISGLPR,0,
18590 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),
18591 & IDRES(ISGLPR),IDXRES(ISGLPR),IDCH(ISGLPR))
18592 NOBAM(NHKK) = NOBAM(ISGLPR)
18593 JDAHKK(1,ISGLPR) = NHKK
18594 DO 21 K=1,4
18595 TRCLPR(K) = TRCLPR(K)-PHKK(K,ISGLPR)
18596 21 CONTINUE
18597 ENDIF
18598 IF (IREST.EQ.1) THEN
18599 ID = IDBAM(ISGLTA)
18600 IST = ISTHKK(ISGLTA)
18601 CALL DT_LTRANS(PHKK(1,ISGLTA),PHKK(2,ISGLTA),
18602 & PHKK(3,ISGLTA),PHKK(4,ISGLTA),
18603 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,3)
18604 IF (IST.EQ.14) THEN
18605 ISTHKK(ISGLTA) = 12
18606 ELSE
18607 ISTHKK(ISGLTA) = 2
18608 ENDIF
18609 CALL DT_EVTPUT(1,IDHKK(ISGLTA),ISGLTA,0,
18610 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),
18611 & IDRES(ISGLTA),IDXRES(ISGLTA),IDCH(ISGLTA))
18612 NOBAM(NHKK) = NOBAM(ISGLTA)
18613 JDAHKK(1,ISGLTA) = NHKK
18614 DO 22 K=1,4
18615 TRCLTA(K) = TRCLTA(K)-PHKK(K,ISGLTA)
18616 22 CONTINUE
18617 ENDIF
18618
18619* get nuclear potential corresp. to the residual nucleus
18620 IPRCL = IP -NPW
18621 IPZRCL = IPZ-NPCW
18622 ITRCL = IT -NTW
18623 ITZRCL = ITZ-NTCW
18624 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
18625
18626* baryons unable to escape the nuclear potential are treated as
18627* excited nucleons (ISTHKK=15,16)
18628 DO 3 I=NPOINT(4),NHKK
18629 IF (ISTHKK(I).EQ.1) THEN
18630 ID = IDBAM(I)
18631 IF ( ((ID.EQ.1).OR.(ID.EQ.8)).AND.(NOBAM(I).NE.3) ) THEN
18632* final state n and p not being outside of both nuclei are considered
18633 NPOTP = 1
18634 NPOTT = 1
18635 IF ( (IP.GT.1) .AND.(IRESP.GT.1).AND.
18636 & (NOBAM(I).NE.1).AND.(NPW.GT.0) ) THEN
18637* Lorentz-trsf. into proj. rest sys. for those being inside proj.
18638 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
18639 & PHKK(4,I),PLAB(1,1),PLAB(1,2),PLAB(1,3),
18640 & PLAB(1,4),ID,-2)
18641 PLABT = SQRT(PLAB(1,1)**2+PLAB(1,2)**2+PLAB(1,3)**2)
18642 PLAB(1,5) = SQRT(ABS( (PLAB(1,4)-PLABT)*
18643 & (PLAB(1,4)+PLABT) ))
18644 EKIN = PLAB(1,4)-PLAB(1,5)
18645 IF (EKIN.LE.EPOT(1,ID)) NPOTP = 15
18646 IF ((ID.EQ.1).AND.(NPCW.LE.0)) NPOTP = 1
18647 ENDIF
18648 IF ( (IT.GT.1) .AND.(IREST.GT.1).AND.
18649 & (NOBAM(I).NE.2).AND.(NTW.GT.0) ) THEN
18650* Lorentz-trsf. into targ. rest sys. for those being inside targ.
18651 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
18652 & PHKK(4,I),PLAB(2,1),PLAB(2,2),PLAB(2,3),
18653 & PLAB(2,4),ID,-3)
18654 PLABT = SQRT(PLAB(2,1)**2+PLAB(2,2)**2+PLAB(2,3)**2)
18655 PLAB(2,5) = SQRT(ABS( (PLAB(2,4)-PLABT)*
18656 & (PLAB(2,4)+PLABT) ))
18657 EKIN = PLAB(2,4)-PLAB(2,5)
18658 IF (EKIN.LE.EPOT(2,ID)) NPOTT = 16
18659 IF ((ID.EQ.1).AND.(NTCW.LE.0)) NPOTT = 1
18660 ENDIF
18661 IF (PHKK(3,I).GE.ZERO) THEN
18662 ISTHKK(I) = NPOTT
18663 IF (NPOTP.NE.1) ISTHKK(I) = NPOTP
18664 ELSE
18665 ISTHKK(I) = NPOTP
18666 IF (NPOTT.NE.1) ISTHKK(I) = NPOTT
18667 ENDIF
18668 IF (ISTHKK(I).NE.1) THEN
18669 J = ISTHKK(I)-14
18670 DO 4 K=1,5
18671 PHKK(K,I) = PLAB(J,K)
18672 4 CONTINUE
18673 IF (ISTHKK(I).EQ.15) THEN
18674 NPW = NPW-1
18675 IF (ID.EQ.1) NPCW = NPCW-1
18676 DO 9 K=1,4
18677 TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
18678 9 CONTINUE
18679 ELSEIF (ISTHKK(I).EQ.16) THEN
18680 NTW = NTW-1
18681 IF (ID.EQ.1) NTCW = NTCW-1
18682 DO 10 K=1,4
18683 TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
18684 10 CONTINUE
18685 ENDIF
18686 ENDIF
18687 ENDIF
18688 ENDIF
18689 3 CONTINUE
18690
18691* again: get nuclear potential corresp. to the residual nucleus
18692 IPRCL = IP -NPW
18693 IPZRCL = IPZ-NPCW
18694 ITRCL = IT -NTW
18695 ITZRCL = ITZ-NTCW
18696c AFERP = 1.2D0*FERMOD*(ONE+(DBLE(IP+10-NPW0)/DBLE(IP+10))**1.1D0)
18697cC AFERP = 1.21D0*FERMOD*(ONE+(DBLE(IP+40-NPW0)/DBLE(IP+40))**1.1D0)
18698c & *(0.94D0+0.3D0*EXP(-DBLE(NPW0)/5.0D0)) /2.0D0
18699C AFERP = 0.0D0
18700c AFERT = 1.2D0*FERMOD*(ONE+(DBLE(IT+10-NTW0)/DBLE(IT+10))**1.1D0)
18701cC AFERT = 1.21D0*FERMOD*(ONE+(DBLE(IT+40-NTW0)/DBLE(IT+40))**1.1D0)
18702c & *(0.94D0+0.3D0*EXP(-DBLE(NTW0)/5.0D0)) /2.0D0
18703C AFERT = 0.0D0
18704C IF (AFERP.LT.FERMOD) AFERP = FERMOD+0.1
18705C IF (AFERT.LT.FERMOD) AFERT = FERMOD+0.1
18706C IF (AFERP.GT.0.85D0) AFERP = 0.85D0
18707C IF (AFERT.GT.0.85D0) AFERT = 0.85D0
18708 AFERP = FERMOD+0.1D0
18709 AFERT = FERMOD+0.1D0
18710
18711 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,AFERP,AFERT,1)
18712
18713 RETURN
18714 END
18715
18716*$ CREATE DT_FICONF.FOR
18717*COPY DT_FICONF
18718*
18719*===ficonf=============================================================*
18720*
18721 SUBROUTINE DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ)
18722
18723************************************************************************
18724* Treatment of FInal CONFiguration including evaporation, fission and *
18725* Fermi-break-up (for light nuclei only). *
18726* Adopted from the original routine FINALE and extended to residual *
18727* projectile nuclei. *
18728* This version dated 12.12.95 is written by S. Roesler. *
18729* *
18730* Last change 27.12.2006 by S. Roesler. *
18731************************************************************************
18732
18733 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18734 SAVE
18735 PARAMETER ( LINP = 10 ,
18736 & LOUT = 6 ,
18737 & LDAT = 9 )
18738 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
18739 PARAMETER (ANGLGB=5.0D-16)
18740 PARAMETER (AMUAMU=0.93149432D0,AMELEC=0.51099906D-3)
18741
18742* event history
18743 PARAMETER (NMXHKK=200000)
18744 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18745 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18746 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18747* extended event history
18748 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18749 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18750 & IHIST(2,NMXHKK)
18751* rejection counter
18752 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
18753 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
18754 & IREXCI(3),IRDIFF(2),IRINC
18755* central particle production, impact parameter biasing
18756 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
18757* particle properties (BAMJET index convention)
18758 CHARACTER*8 ANAME
18759 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18760 & IICH(210),IIBAR(210),K1(210),K2(210)
18761* treatment of residual nuclei: 4-momenta
18762 LOGICAL LRCLPR,LRCLTA
18763 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18764 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18765* treatment of residual nuclei: properties of residual nuclei
18766 COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
18767 & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
18768 & NTOTFI(2),NPROFI(2)
18769* statistics: residual nuclei
18770 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
18771 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
18772 & NINCST(2,4),NINCEV(2),
18773 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
18774 & NRESPB(2),NRESCH(2),NRESEV(4),
18775 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
18776 & NEVAFI(2,2)
18777* flags for input different options
18778 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18779 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18780 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18781* (original name: FINUC)
18782 PARAMETER (MXP=999)
18783 COMMON /FKFINU/ CXR (MXP), CYR (MXP), CZR (MXP),
18784 & CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP),
18785 & TKI (MXP), PLR (MXP), WEI (MXP),
18786 & TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP,
18787 & KPART (MXP)
18788* (original name: RESNUC)
18789 LOGICAL LRNFSS, LFRAGM
18790 COMMON /FKRESN/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
18791 & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
18792 & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES,
18793 & PYRES, PZRES, PTRES2, KTARP, KTARN, IGREYP,
18794 & IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,
18795 & ICRES, IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU,
18796 & IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG,
18797 & IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS,
18798 & LFRAGM
18799 COMMON /FKNDAT/ AV0WEL, APFRMX, AEFRMX, AEFRMA,
18800 & RDSNUC, V0WELL (2), PFRMMX (2), EFRMMX (2),
18801 & EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2),
18802 & VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2),
18803 & PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2),
18804 & EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2),
18805 & ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV ,
18806 & AMRCSQ , ATO1O3 , ZTO1O3 , ELBNDE (0:100)
18807* (original name: PAREVT)
18808 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
18809 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
18810 PARAMETER ( NALLWP = 39 )
18811 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
18812 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
18813 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
18814 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
18815* event flag
18816 COMMON /DTEVNO/ NEVENT,ICASCA
18817
18818 DIMENSION INUC(2),IDXPAR(2),IDPAR(2),AIF(2),AIZF(2),AMRCL(2),
18819 & PRCL(2,4),MO1(2),MO2(2),VRCL(2,4),WRCL(2,4),
18820 & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4)
18821
18822 DIMENSION EXPNUC(2),EXC(2,260),NEXC(2,260)
18823 LOGICAL LLCPOT
18824 DATA EXC,NEXC /520*ZERO,520*0/
18825 DATA EXPNUC /4.0D-3,4.0D-3/
18826
18827 IREJ = 0
18828 LRCLPR = .FALSE.
18829 LRCLTA = .FALSE.
18830
18831* skip residual nucleus treatment if not requested or in case
18832* of central collisions
18833 IF ((.NOT.LEVPRT).OR.(ICENTR.GT.0).OR.(ICENTR.EQ.-1)) RETURN
18834
18835 DO 1 K=1,2
18836 IDPAR(K) = 0
18837 IDXPAR(K)= 0
18838 NTOT(K) = 0
18839 NTOTFI(K)= 0
18840 NPRO(K) = 0
18841 NPROFI(K)= 0
18842 NN(K) = 0
18843 NH(K) = 0
18844 NHPOS(K) = 0
18845 NQ(K) = 0
18846 EEXC(K) = ZERO
18847 MO1(K) = 0
18848 MO2(K) = 0
18849 DO 2 I=1,4
18850 VRCL(K,I) = ZERO
18851 WRCL(K,I) = ZERO
18852 2 CONTINUE
18853 1 CONTINUE
18854 NFSP = 0
18855 INUC(1) = IP
18856 INUC(2) = IT
18857
18858 DO 3 I=1,NHKK
18859
18860* number of final state particles
18861 IF (ABS(ISTHKK(I)).EQ.1) THEN
18862 NFSP = NFSP+1
18863 IDFSP = IDBAM(I)
18864 ENDIF
18865
18866* properties of remaining nucleon configurations
18867 KF = 0
18868 IF ((ISTHKK(I).EQ.13).OR.(ISTHKK(I).EQ.15)) KF = 1
18869 IF ((ISTHKK(I).EQ.14).OR.(ISTHKK(I).EQ.16)) KF = 2
18870 IF (KF.GT.0) THEN
18871 IF (MO1(KF).EQ.0) MO1(KF) = I
18872 MO2(KF) = I
18873* position of residual nucleus = average position of nucleons
18874 DO 4 K=1,4
18875 VRCL(KF,K) = VRCL(KF,K)+VHKK(K,I)
18876 WRCL(KF,K) = WRCL(KF,K)+WHKK(K,I)
18877 4 CONTINUE
18878* total number of particles contributing to each residual nucleus
18879 NTOT(KF) = NTOT(KF)+1
18880 IDTMP = IDBAM(I)
18881 IDXTMP = I
18882* total charge of residual nuclei
18883 NQ(KF) = NQ(KF)+IICH(IDTMP)
18884* number of protons
18885 IF (IDHKK(I).EQ.2212) THEN
18886 NPRO(KF) = NPRO(KF)+1
18887* number of neutrons
18888 ELSEIF (IDHKK(I).EQ.2112) THEN
18889 NN(KF) = NN(KF)+1
18890 ELSE
18891* number of baryons other than n, p
18892 IF (IIBAR(IDTMP).EQ.1) THEN
18893 NH(KF) = NH(KF)+1
18894 IF (IICH(IDTMP).EQ.1) NHPOS(KF) = NHPOS(KF)+1
18895 ELSE
18896* any other mesons (status set to 1)
18897C WRITE(LOUT,1002) KF,IDTMP
18898C1002 FORMAT(1X,'FICONF: residual nucleus ',I2,
18899C & ' containing meson ',I4,', status set to 1')
18900 ISTHKK(I) = 1
18901 IDTMP = IDPAR(KF)
18902 IDXTMP = IDXPAR(KF)
18903 NTOT(KF) = NTOT(KF)-1
18904 ENDIF
18905 ENDIF
18906 IDPAR(KF) = IDTMP
18907 IDXPAR(KF) = IDXTMP
18908 ENDIF
18909 3 CONTINUE
18910
18911* reject elastic events (def: one final state particle = projectile)
18912 IF ((IP.EQ.1).AND.(NFSP.EQ.1).AND.(IDFSP.EQ.IJPROJ)) THEN
18913 IREXCI(3) = IREXCI(3)+1
18914 GOTO 9999
18915C RETURN
18916 ENDIF
18917
18918* check if one nucleus disappeared..
18919C IF ((IP.GT.1).AND.(NTOT(1).EQ.0).AND.(NTOT(2).NE.0)) THEN
18920C DO 5 K=1,4
18921C PRCLTA(K) = PRCLTA(K)+PRCLPR(K)
18922C PRCLPR(K) = ZERO
18923C 5 CONTINUE
18924C ELSEIF ((IT.GT.1).AND.(NTOT(2).EQ.0).AND.(NTOT(1).NE.0)) THEN
18925C DO 6 K=1,4
18926C PRCLPR(K) = PRCLPR(K)+PRCLTA(K)
18927C PRCLTA(K) = ZERO
18928C 6 CONTINUE
18929C ENDIF
18930
18931 ICOR = 0
18932 INORCL = 0
18933 DO 7 I=1,2
18934 DO 8 K=1,4
18935* get the average of the nucleon positions
18936 VRCL(I,K) = VRCL(I,K)/MAX(NTOT(I),1)
18937 WRCL(I,K) = WRCL(I,K)/MAX(NTOT(I),1)
18938 IF (I.EQ.1) PRCL(1,K) = PRCLPR(K)
18939 IF (I.EQ.2) PRCL(2,K) = PRCLTA(K)
18940 8 CONTINUE
18941* mass number and charge of residual nuclei
18942 AIF(I) = DBLE(NTOT(I))
18943 AIZF(I) = DBLE(NPRO(I)+NHPOS(I))
18944 IF (NTOT(I).GT.1) THEN
18945* masses of residual nuclei in ground state
18946 AMRCL0(I) = AIF(I)*AMUAMU+1.0D-3*DT_ENERGY(AIF(I),AIZF(I))
18947* masses of residual nuclei
18948 PTORCL = SQRT(PRCL(I,1)**2+PRCL(I,2)**2+PRCL(I,3)**2)
18949 AMRCL(I) = (PRCL(I,4)-PTORCL)*(PRCL(I,4)+PTORCL)
18950 IF (AMRCL(I).GT.ZERO) AMRCL(I) = SQRT(AMRCL(I))
18951*
18952* M_res^2 < 0 : configuration not allowed
18953*
18954* a) re-calculate E_exc with scaled nuclear potential
18955* (conditional jump to label 9998)
18956* b) or reject event if N_loop(max) is exceeded
18957* (conditional jump to label 9999)
18958*
18959 IF (AMRCL(I).LE.ZERO) THEN
18960 IF (IOULEV(3).GT.0)
18961 & WRITE(LOUT,1000) I,PRCL(I,1),PRCL(I,2),PRCL(I,3),
18962 & PRCL(I,4),NTOT
18963 1000 FORMAT(1X,'warning! negative excitation energy',/,
18964 & I4,4E15.4,2I4)
18965 AMRCL(I) = ZERO
18966 EEXC(I) = ZERO
18967 IF (NLOOP.LE.500) THEN
18968 GOTO 9998
18969 ELSE
18970 IREXCI(2) = IREXCI(2)+1
18971 GOTO 9999
18972 ENDIF
18973*
18974* 0 < M_res < M_res0 : mass below ground-state mass
18975*
18976* a) we had residual nuclei with mass N_tot and reasonable E_exc
18977* before- assign average E_exc of those configurations to this
18978* one ( Nexc(i,N_tot) > 0 )
18979* b) or (and this applies always if run in transport codes) go up
18980* one mass number and
18981* i) if mass now larger than proj/targ mass or if run in
18982* transport codes assign average E_exc per wounded nucleon
18983* x number of wounded nucleons (Inuc-Ntot)
18984* ii) or assign average E_exc of those configurations to this
18985* one ( Nexc(i,m) > 0 )
18986*
18987 ELSEIF ((AMRCL(I).GT.ZERO).AND.(AMRCL(I).LT.AMRCL0(I)))
18988 & THEN
18989 M = MIN(NTOT(I),260)
18990 IF (NEXC(I,M).GT.0) THEN
18991 AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
18992 ELSE
18993 70 CONTINUE
18994 M = M+1
18995**sr corrected 27.12.06
18996* IF (M.GE.INUC(I)) THEN
18997* AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I))
18998 IF ((M.GE.INUC(I)).OR.(ICASCA.GT.0)) THEN
18999 IF ( INUC (I) .GT. NTOT (I) ) THEN
19000 AMRCL(I) = AMRCL0(I)
19001 & + EXPNUC(I)*DBLE(MAX(INUC(I)-NTOT(I),0))
19002 ELSE
19003 AMRCL(I) = AMRCL0(I) + 0.5D+00 * EXPNUC(I)
19004 END IF
19005**
19006 ELSE
19007 IF (NEXC(I,M).GT.0) THEN
19008 AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
19009 ELSE
19010 GOTO 70
19011 ENDIF
19012 ENDIF
19013 ENDIF
19014 EEXC(I) = AMRCL(I)-AMRCL0(I)
19015 ICOR = ICOR+I
19016*
19017* M_res > 2.5 x M_res0 : unreasonably(?) high E_exc
19018*
19019* a) re-calculate E_exc with scaled nuclear potential
19020* (conditional jump to label 9998)
19021* b) or reject event if N_loop(max) is exceeded
19022* (conditional jump to label 9999)
19023*
19024*
19025 ELSEIF (AMRCL(I).GE.2.5D0*AMRCL0(I)) THEN
19026 IF (IOULEV(3).GT.0)
19027 & WRITE(LOUT,1004) I,AMRCL(I),AMRCL0(I),NTOT,NEVHKK
19028 1004 FORMAT(1X,'warning! too high excitation energy',/,
19029 & I4,1P,2E15.4,3I5)
19030 AMRCL(I) = ZERO
19031 EEXC(I) = ZERO
19032 IF (NLOOP.LE.500) THEN
19033 GOTO 9998
19034 ELSE
19035 IREXCI(2) = IREXCI(2)+1
19036 GOTO 9999
19037 ENDIF
19038*
19039* Otherwise (reasonable E_exc) :
19040* E_exc = M_res - M_res0
19041* in addition: calculate and save E_exc per wounded nucleon as
19042* well as E_exc in <E_exc> counter
19043*
19044 ELSE
19045* excitation energies of residual nuclei
19046 EEXC(I) = AMRCL(I)-AMRCL0(I)
19047**sr 27.12.06 new excitation energy correction by A.F.
19048*
19049* all parts with Ilcopt<3 commented since not used
19050*
19051* still to be done/decided:
19052* Increase Icor and put back both residual nuclei on mass shell
19053* with the exciting correction further below.
19054* For the moment the modification in the excitation energy is simply
19055* corrected by scaling the energy of the residual nucleus.
19056*
19057 LLCPOT = .TRUE.
19058 ILCOPT = 3
19059 IF ( LLCPOT ) THEN
19060 NNCHIT = MAX ( INUC (I) - NTOT (I), 0 )
19061 IF ( ILCOPT .LE. 2 ) THEN
19062C* Patch for Fermi momentum reduction correlated with impact parameter:
19063C FRMRDC = MIN ( (PFRMAV(INUC(I))/APFRMX)**3, ONE )
19064C DLKPRH = 0.1D+00 + 0.5D+00 / SQRT(DBLE(INUC(I)))
19065C AKPRHO = ONE - DLKPRH
19066C* f x K rho_cen + (1-f) x 0.5 x K rho_cen = frmrdc x rho_cen
19067C FRCFLL = MAX ( 2.D+00 * FRMRDC / AKPRHO - ONE,
19068C & 0.05D+00 )
19069C* REDORI = 0.75D+00
19070C* REDORI = ONE
19071C REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
19072 ELSE
19073 DLKPRH = ZERO
19074 RDCORE = 1.14D+00 * DBLE(INUC(I))**(ONE/3.D+00)
19075* Take out roughly one/half of the skin:
19076 RDCORE = RDCORE - 0.5D+00
19077 FRCFLL = RDCORE**3
19078 PRSKIN = (RDCORE+2.4D+00)**3 - FRCFLL
19079 PRSKIN = 0.5D+00 * PRSKIN / ( PRSKIN + FRCFLL )
19080 FRCFLL = ONE - PRSKIN
19081 FRMRDC = FRCFLL + 0.5D+00 * PRSKIN
19082 REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
19083 END IF
19084 IF ( NNCHIT .GT. 0 ) THEN
19085C IF ( ILCOPT .EQ. 1 ) THEN
19086C SKINRH = ONE - FRCFLL / (DBLE(INUC(I))-ONE)
19087C DO 1220 NCH = 1, 10
19088C ETAETA = ( ONE - SKINRH**INUC(I)
19089C & - DBLE(INUC(I))* ( ONE - FRCFLL )
19090C & * ( ONE - SKINRH ) )
19091C & / ( SKINRH**INUC(I) - DBLE (INUC(I))
19092C & * ( ONE - FRCFLL) * SKINRH )
19093C SKINRH = SKINRH * ( ONE + ETAETA )
19094C 1220 CONTINUE
19095C PRSKIN = SKINRH**(NNCHIT-1)
19096C ELSE IF ( ILCOPT .EQ. 2 ) THEN
19097C PRSKIN = ONE - FRCFLL
19098C END IF
19099 REDCTN = ZERO
19100 DO 1230 NCH = 1, NNCHIT
19101 IF (DT_RNDM(PRFRMI) .LT. PRSKIN) THEN
19102 PRFRMI = (( ONE - 2.D+00 * DLKPRH )
19103 & * DT_RNDM(PRFRMI))**0.333333333333D+00
19104 ELSE
19105 PRFRMI = ( ONE - 2.D+00 * DLKPRH
19106 & * DT_RNDM(PRFRMI))**0.333333333333D+00
19107 END IF
19108 REDCTN = REDCTN + PRFRMI**2
19109 1230 CONTINUE
19110 REDCTN = REDCTN / DBLE (NNCHIT)
19111 ELSE
19112 REDCTN = 0.5D+00
19113 END IF
19114 EEXC (I) = EEXC (I) * REDCTN / REDORI
19115 AMRCL (I) = AMRCL0 (I) + EEXC (I)
19116 PRCL(I,4) = SQRT ( PTORCL**2 + AMRCL(I)**2 )
19117 END IF
19118**
19119 IF (ICASCA.EQ.0) THEN
19120 EXPNUC(I) = EEXC(I)/MAX(1,INUC(I)-NTOT(I))
19121 M = MIN(NTOT(I),260)
19122 EXC(I,M) = EXC(I,M)+EEXC(I)
19123 NEXC(I,M) = NEXC(I,M)+1
19124 ENDIF
19125 ENDIF
19126 ELSEIF (NTOT(I).EQ.1) THEN
19127 WRITE(LOUT,1003) I
19128 1003 FORMAT(1X,'FICONF: warning! NTOT(I)=1? (I=',I3,')')
19129 GOTO 9999
19130 ELSE
19131 AMRCL0(I) = ZERO
19132 AMRCL(I) = ZERO
19133 EEXC(I) = ZERO
19134 INORCL = INORCL+I
19135 ENDIF
19136 7 CONTINUE
19137
19138 PRCLPR(5) = AMRCL(1)
19139 PRCLTA(5) = AMRCL(2)
19140
19141 IF (ICOR.GT.0) THEN
19142 IF (INORCL.EQ.0) THEN
19143* one or both residual nuclei consist of one nucleon only, transform
19144* this nucleon on mass shell
19145 DO 9 K=1,4
19146 P1IN(K) = PRCL(1,K)
19147 P2IN(K) = PRCL(2,K)
19148 9 CONTINUE
19149 XM1 = AMRCL(1)
19150 XM2 = AMRCL(2)
19151 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
19152 IF (IREJ1.GT.0) THEN
19153 WRITE(LOUT,*) 'ficonf-mashel rejection'
19154 GOTO 9999
19155 ENDIF
19156 DO 10 K=1,4
19157 PRCL(1,K) = P1OUT(K)
19158 PRCL(2,K) = P2OUT(K)
19159 PRCLPR(K) = P1OUT(K)
19160 PRCLTA(K) = P2OUT(K)
19161 10 CONTINUE
19162 PRCLPR(5) = AMRCL(1)
19163 PRCLTA(5) = AMRCL(2)
19164 ELSE
19165 IF (IOULEV(3).GT.0)
19166 & WRITE(LOUT,1001) NEVHKK,INT(AIF(1)),INT(AIZF(1)),
19167 & INT(AIF(2)),INT(AIZF(2)),AMRCL0(1),
19168 & AMRCL(1),AMRCL(1)-AMRCL0(1),AMRCL0(2),
19169 & AMRCL(2),AMRCL(2)-AMRCL0(2)
19170 1001 FORMAT(1X,'FICONF: warning! no residual nucleus for',
19171 & ' correction',/,11X,'at event',I8,
19172 & ', nucleon config. 1:',2I4,' 2:',2I4,
19173 & 2(/,11X,3E12.3))
19174 IF (NLOOP.LE.500) THEN
19175 GOTO 9998
19176 ELSE
19177 IREXCI(1) = IREXCI(1)+1
19178 ENDIF
19179 ENDIF
19180 ENDIF
19181
19182* update counter
19183C IF (NRESEV(1).NE.NEVHKK) THEN
19184C NRESEV(1) = NEVHKK
19185C NRESEV(2) = NRESEV(2)+1
19186C ENDIF
19187 NRESEV(2) = NRESEV(2)+1
19188 DO 15 I=1,2
19189 EXCDPM(I) = EXCDPM(I)+EEXC(I)
19190 EXCDPM(I+2) = EXCDPM(I+2)+(EEXC(I)/MAX(NTOT(I),1))
19191 NRESTO(I) = NRESTO(I)+NTOT(I)
19192 NRESPR(I) = NRESPR(I)+NPRO(I)
19193 NRESNU(I) = NRESNU(I)+NN(I)
19194 NRESBA(I) = NRESBA(I)+NH(I)
19195 NRESPB(I) = NRESPB(I)+NHPOS(I)
19196 NRESCH(I) = NRESCH(I)+NQ(I)
19197 15 CONTINUE
19198
19199* evaporation
19200 IF (LEVPRT) THEN
19201 DO 13 I=1,2
19202* initialize evaporation counter
19203 EEXCFI(I) = ZERO
19204 IF ((INUC(I).GT.1).AND.(AIF(I).GT.ONE).AND.
19205 & (EEXC(I).GT.ZERO)) THEN
19206* put residual nuclei into DTEVT1
19207 IDRCL = 80000
19208 JMASS = INT( AIF(I))
19209 JCHAR = INT(AIZF(I))
19210* the following patch is required to transmit the correct excitation
19211* energy to Eventd
19212 IF (ITRSPT.EQ.1) THEN
19213 IF ((ABS(AMRCL(I)-AMRCL0(I)-EEXC(I)).GT.1.D-04).AND.
19214 & (IOULEV(3).GT.0))
19215 & WRITE(LOUT,*)
19216 & ' DT_FICONF:AMRCL(I),AMRCL0(I),EEXC(I)',
19217 & AMRCL(I),AMRCL0(I),EEXC(I)
19218 PRCL0 = PRCL(I,4)
19219 PRCL(I,4) =SQRT(AMRCL(I)**2+PRCL(I,1)**2+PRCL(I,2)**2
19220 & +PRCL(I,3)**2)
19221 IF (ABS(PRCL0-PRCL(I,4)).GT.0.1D0) THEN
19222 WRITE(LOUT,*)
19223 & ' PRCL(I,4) recalculated :',PRCL0,PRCL(I,4)
19224 ENDIF
19225 ENDIF
19226 CALL DT_EVTPUT(1000,IDRCL,MO1(I),MO2(I),PRCL(I,1),
19227 & PRCL(I,2),PRCL(I,3),PRCL(I,4),JMASS,JCHAR,0)
19228**sr 22.6.97
19229 NOBAM(NHKK) = I
19230**
19231 DO 14 J=1,4
19232 VHKK(J,NHKK) = VRCL(I,J)
19233 WHKK(J,NHKK) = WRCL(I,J)
19234 14 CONTINUE
19235* interface to evaporation module - fill final residual nucleus into
19236* common FKRESN
19237* fill resnuc only if code is not used as event generator in Fluka
19238 IF (ITRSPT.NE.1) THEN
19239 PXRES = PRCL(I,1)
19240 PYRES = PRCL(I,2)
19241 PZRES = PRCL(I,3)
19242 IBRES = NPRO(I)+NN(I)+NH(I)
19243 ICRES = NPRO(I)+NHPOS(I)
19244 ANOW = DBLE(IBRES)
19245 ZNOW = DBLE(ICRES)
19246 PTRES = SQRT(PXRES**2+PYRES**2+PZRES**2)
19247* ground state mass of the residual nucleus (should be equal to AM0T)
19248 AMMRES = AMRCL0(I)
19249 AMNRES = AMMRES-ZNOW*AMELEC+ELBNDE(ICRES)
19250* common FKFINU
19251 TV = ZERO
19252* kinetic energy of residual nucleus
19253 TVRECL = PRCL(I,4)-AMRCL(I)
19254* excitation energy of residual nucleus
19255 TVCMS = EEXC(I)
19256 PTOLD = PTRES
19257 PTRES = SQRT(ABS(TVRECL*(TVRECL+
19258 & 2.0D0*(AMMRES+TVCMS))))
19259 IF (PTOLD.LT.ANGLGB) THEN
19260 CALL DT_RACO(PXRES,PYRES,PZRES)
19261 PTOLD = ONE
19262 ENDIF
19263 PXRES = PXRES*PTRES/PTOLD
19264 PYRES = PYRES*PTRES/PTOLD
19265 PZRES = PZRES*PTRES/PTOLD
19266* zero counter of secondaries from evaporation
19267 NP = 0
19268* evaporation
19269 WE = ONE
19270 CALL DT_EVEVAP(WE)
19271* put evaporated particles and residual nuclei to DTEVT1
19272 MO = NHKK
19273 CALL DT_EVA2HE(MO,EXCITF,I,IREJ1)
19274 ENDIF
19275 EEXCFI(I) = EXCITF
19276 EXCEVA(I) = EXCEVA(I)+EXCITF
19277 ENDIF
19278 13 CONTINUE
19279 ENDIF
19280
19281 RETURN
19282
19283C9998 IREXCI(1) = IREXCI(1)+1
19284 9998 IREJ = IREJ+1
19285 9999 CONTINUE
19286 LRCLPR = .TRUE.
19287 LRCLTA = .TRUE.
19288 IREJ = IREJ+1
19289 RETURN
19290 END
19291
19292*$ CREATE DT_EVA2HE.FOR
19293*COPY DT_EVA2HE
19294* *
19295*====eva2he============================================================*
19296* *
19297 SUBROUTINE DT_EVA2HE(MO,EEXCF,IRCL,IREJ)
19298
19299************************************************************************
19300* Interface between common's of evaporation module (FKFINU,FKFHVY) *
19301* and DTEVT1. *
19302* MO DTEVT1-index of "mother" (residual) nucleus before evap. *
19303* EEXCF exitation energy of residual nucleus after evaporation *
19304* IRCL = 1 projectile residual nucleus *
19305* = 2 target residual nucleus *
19306* This version dated 19.04.95 is written by S. Roesler. *
19307* *
19308* Last change 27.12.2006 by S. Roesler. *
19309************************************************************************
19310
19311 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19312 SAVE
19313 PARAMETER ( LINP = 10 ,
19314 & LOUT = 6 ,
19315 & LDAT = 9 )
19316 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3)
19317
19318* event history
19319 PARAMETER (NMXHKK=200000)
19320 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
19321 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
19322 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
19323* Note: DTEVT2 - special use for heavy fragments !
19324* (IDRES(I) = mass number, IDXRES(I) = charge)
19325* extended event history
19326 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
19327 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
19328 & IHIST(2,NMXHKK)
19329* particle properties (BAMJET index convention)
19330 CHARACTER*8 ANAME
19331 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19332 & IICH(210),IIBAR(210),K1(210),K2(210)
19333* flags for input different options
19334 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
19335 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
19336 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
19337* statistics: residual nuclei
19338 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
19339 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
19340 & NINCST(2,4),NINCEV(2),
19341 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
19342 & NRESPB(2),NRESCH(2),NRESEV(4),
19343 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
19344 & NEVAFI(2,2)
19345* treatment of residual nuclei: properties of residual nuclei
19346 COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
19347 & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
19348 & NTOTFI(2),NPROFI(2)
19349* (original name: FINUC)
19350 PARAMETER (MXP=999)
19351 COMMON /FKFINU/ CXR (MXP), CYR (MXP), CZR (MXP),
19352 & CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP),
19353 & TKI (MXP), PLR (MXP), WEI (MXP),
19354 & TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP,
19355 & KPART (MXP)
19356* (original name: FHEAVY,FHEAVC)
19357 PARAMETER ( MXHEAV = 100 )
19358 CHARACTER*8 ANHEAV
19359 COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV),
19360 & CZHEAV (MXHEAV), TKHEAV (MXHEAV),
19361 & PHEAVY (MXHEAV), WHEAVY (MXHEAV),
19362 & AMHEAV ( 12 ) , AMNHEA ( 12 ) ,
19363 & KHEAVY (MXHEAV), ICHEAV ( 12 ) ,
19364 & IBHEAV ( 12 ) , NPHEAV
19365 COMMON /FKFHVC/ ANHEAV ( 12 )
19366* (original name: RESNUC)
19367 LOGICAL LRNFSS, LFRAGM
19368 COMMON /FKRESN/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
19369 & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
19370 & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES,
19371 & PYRES, PZRES, PTRES2, KTARP, KTARN, IGREYP,
19372 & IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,
19373 & ICRES, IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU,
19374 & IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG,
19375 & IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS,
19376 & LFRAGM
19377
19378 DIMENSION IPTOKP(39)
19379 DATA IPTOKP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
19380 & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 99,
19381 & 100, 101, 97, 102, 98, 103, 109, 115 /
19382
19383 IREJ = 0
19384
19385* skip if evaporation package is not included
19386 IF (.NOT.LEVAPO) RETURN
19387
19388* update counter
19389 IF (NRESEV(3).NE.NEVHKK) THEN
19390 NRESEV(3) = NEVHKK
19391 NRESEV(4) = NRESEV(4)+1
19392 ENDIF
19393
19394 IF (LEMCCK)
19395 & CALL DT_EVTEMC(PHKK(1,MO),PHKK(2,MO),PHKK(3,MO),PHKK(4,MO),1,
19396 & IDUM,IDUM)
19397* mass number/charge of residual nucleus before evaporation
19398 IBTOT = IDRES(MO)
19399 IZTOT = IDXRES(MO)
19400
19401* protons/neutrons/gammas
19402 DO 1 I=1,NP
19403 PX = CXR(I)*PLR(I)
19404 PY = CYR(I)*PLR(I)
19405 PZ = CZR(I)*PLR(I)
19406 ID = IPTOKP(KPART(I))
19407 IDPDG = IDT_IPDGHA(ID)
19408 AM = ((PLR(I)+TKI(I))*(PLR(I)-TKI(I)))/
19409 & (2.0D0*MAX(TKI(I),TINY10))
19410 IF (ABS(AM-AAM(ID)).GT.TINY3) THEN
19411 WRITE(LOUT,1000) ID,AM,AAM(ID)
19412 1000 FORMAT(1X,'EVA2HE: inconsistent mass of evap. ',
19413 & 'particle',I3,2E10.3)
19414 ENDIF
19415 PE = TKI(I)+AM
19416 CALL DT_EVTPUT(-1,IDPDG,MO,0,PX,PY,PZ,PE,0,0,0)
19417 NOBAM(NHKK) = IRCL
19418 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
19419 IBTOT = IBTOT-IIBAR(ID)
19420 IZTOT = IZTOT-IICH(ID)
19421 1 CONTINUE
19422
19423* heavy fragments
19424 DO 2 I=1,NPHEAV
19425 PX = CXHEAV(I)*PHEAVY(I)
19426 PY = CYHEAV(I)*PHEAVY(I)
19427 PZ = CZHEAV(I)*PHEAVY(I)
19428 IDHEAV = 80000
19429 AM = ((PHEAVY(I)+TKHEAV(I))*(PHEAVY(I)-TKHEAV(I)))/
19430 & (2.0D0*MAX(TKHEAV(I),TINY10))
19431 PE = TKHEAV(I)+AM
19432 CALL DT_EVTPUT(-1,IDHEAV,MO,0,PX,PY,PZ,PE,
19433 & IBHEAV(KHEAVY(I)),ICHEAV(KHEAVY(I)),0)
19434 NOBAM(NHKK) = IRCL
19435 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
19436 IBTOT = IBTOT-IBHEAV(KHEAVY(I))
19437 IZTOT = IZTOT-ICHEAV(KHEAVY(I))
19438 2 CONTINUE
19439
19440 IF (IBRES.GT.0) THEN
19441* residual nucleus after evaporation
19442 IDNUC = 80000
19443 CALL DT_EVTPUT(1001,IDNUC,MO,0,PXRES,PYRES,PZRES,ERES,
19444 & IBRES,ICRES,0)
19445 NOBAM(NHKK) = IRCL
19446 ENDIF
19447 EEXCF = TVCMS
19448 NTOTFI(IRCL) = IBRES
19449 NPROFI(IRCL) = ICRES
19450 IF (LEMCCK) CALL DT_EVTEMC(-PXRES,-PYRES,-PZRES,-ERES,2,IDUM,IDUM)
19451 IBTOT = IBTOT-IBRES
19452 IZTOT = IZTOT-ICRES
19453
19454* count events with fission
19455 NEVAFI(1,IRCL) = NEVAFI(1,IRCL)+1
19456 IF (LRNFSS) NEVAFI(2,IRCL) = NEVAFI(2,IRCL)+1
19457
19458* energy-momentum conservation check
19459 IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,40,IREJ)
19460C IF (IREJ.GT.0) THEN
19461C CALL DT_EVTOUT(4)
19462C WRITE(*,*) EEXC(2),EEXCFI(2),NP,NPHEAV
19463C ENDIF
19464* baryon-number/charge conservation check
19465 IF (IBTOT+IZTOT.NE.0) THEN
19466 WRITE(LOUT,1001) NEVHKK,IBTOT,IZTOT
19467 1001 FORMAT(1X,'EVA2HE: baryon-number/charge conservation ',
19468 & 'failure at event ',I8,' : IBTOT,IZTOT = ',2I3)
19469 ENDIF
19470
19471 RETURN
19472 END
19473
19474*$ CREATE DT_EBIND.FOR
19475*COPY DT_EBIND
19476*
19477*===ebind==============================================================*
19478*
19479 DOUBLE PRECISION FUNCTION DT_EBIND(IA,IZ)
19480
19481************************************************************************
19482* Binding energy for nuclei. *
19483* (Shirokov & Yudin, Yad. Fizika, Nauka, Moskva 1972) *
19484* IA mass number *
19485* IZ atomic number *
19486* This version dated 5.5.95 is updated by S. Roesler. *
19487************************************************************************
19488
19489 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19490 SAVE
19491 PARAMETER ( LINP = 10 ,
19492 & LOUT = 6 ,
19493 & LDAT = 9 )
19494 PARAMETER (ZERO=0.0D0)
19495
19496 DATA A1, A2, A3, A4, A5
19497 & / 0.01575D0, 0.0178D0, 0.000710D0, 0.0237D0, 0.034D0/
19498
19499 IF ((IA.LE.1).OR.(IZ.EQ.0)) THEN
19500 WRITE(LOUT,'(1X,A,2I5)') 'DT_EBIND IA,IZ set EBIND=0. ',IA,IZ
19501 DT_EBIND = ZERO
19502 RETURN
19503 ENDIF
19504 AA = IA
19505 DT_EBIND = A1*AA - A2*AA**0.666667D0-A3*IZ*IZ*AA**(-0.333333D0)
19506 & -A4*(IA-2*IZ)**2/AA
19507 IF (MOD(IA,2).EQ.1) THEN
19508 IA5 = 0
19509 ELSEIF (MOD(IZ,2).EQ.1) THEN
19510 IA5 = 1
19511 ELSE
19512 IA5 = -1
19513 ENDIF
19514 DT_EBIND = DT_EBIND - IA5*A5*AA**(-0.75D0)
19515
19516 RETURN
19517 END
19518
19519**sr 30.6. routine replaced completely
19520*$ CREATE DT_ENERGY.FOR
19521*COPY DT_ENERGY
19522* *
19523*=== energy ===========================================================*
19524* *
19525 DOUBLE PRECISION FUNCTION DT_ENERGY( A, Z )
19526
19527C INCLUDE '(DBLPRC)'
19528* DBLPRC.ADD
19529 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19530 SAVE
19531* (original name: GLOBAL)
19532 PARAMETER ( KALGNM = 2 )
19533 PARAMETER ( ANGLGB = 5.0D-16 )
19534 PARAMETER ( ANGLSQ = 2.5D-31 )
19535 PARAMETER ( AXCSSV = 0.2D+16 )
19536 PARAMETER ( ANDRFL = 1.0D-38 )
19537 PARAMETER ( AVRFLW = 1.0D+38 )
19538 PARAMETER ( AINFNT = 1.0D+30 )
19539 PARAMETER ( AZRZRZ = 1.0D-30 )
19540 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
19541 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
19542 PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
19543 PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
19544 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
19545 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
19546 PARAMETER ( CSNNRM = 2.0D-15 )
19547 PARAMETER ( DMXTRN = 1.0D+08 )
19548 PARAMETER ( ZERZER = 0.D+00 )
19549 PARAMETER ( ONEONE = 1.D+00 )
19550 PARAMETER ( TWOTWO = 2.D+00 )
19551 PARAMETER ( THRTHR = 3.D+00 )
19552 PARAMETER ( FOUFOU = 4.D+00 )
19553 PARAMETER ( FIVFIV = 5.D+00 )
19554 PARAMETER ( SIXSIX = 6.D+00 )
19555 PARAMETER ( SEVSEV = 7.D+00 )
19556 PARAMETER ( EIGEIG = 8.D+00 )
19557 PARAMETER ( ANINEN = 9.D+00 )
19558 PARAMETER ( TENTEN = 10.D+00 )
19559 PARAMETER ( HLFHLF = 0.5D+00 )
19560 PARAMETER ( ONETHI = ONEONE / THRTHR )
19561 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
19562 PARAMETER ( ONEFOU = ONEONE / FOUFOU )
19563 PARAMETER ( THRTWO = THRTHR / TWOTWO )
19564 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
19565 PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
19566 PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
19567 PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
19568 PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
19569 PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
19570 PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
19571 PARAMETER ( EULERO = 0.577215664901532860606512 D+00 )
19572 PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 )
19573 PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 )
19574 PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 )
19575 PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
19576 PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
19577 PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
19578 PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
19579 PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
19580 PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
19581 PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
19582 PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
19583 PARAMETER ( CLIGHT = 2.99792458 D+10 )
19584 PARAMETER ( AVOGAD = 6.0221367 D+23 )
19585 PARAMETER ( BOLTZM = 1.380658 D-23 )
19586 PARAMETER ( AMELGR = 9.1093897 D-28 )
19587 PARAMETER ( PLCKBR = 1.05457266 D-27 )
19588 PARAMETER ( ELCCGS = 4.8032068 D-10 )
19589 PARAMETER ( ELCMKS = 1.60217733 D-19 )
19590 PARAMETER ( AMUGRM = 1.6605402 D-24 )
19591 PARAMETER ( AMMUMU = 0.113428913 D+00 )
19592 PARAMETER ( AMPRMU = 1.007276470 D+00 )
19593 PARAMETER ( AMNEMU = 1.008664904 D+00 )
19594 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
19595 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
19596 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
19597 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
19598 PARAMETER ( PLABRC = 0.197327053 D+00 )
19599 PARAMETER ( AMELCT = 0.51099906 D-03 )
19600 PARAMETER ( AMUGEV = 0.93149432 D+00 )
19601 PARAMETER ( AMMUON = 0.105658389 D+00 )
19602 PARAMETER ( AMPRTN = 0.93827231 D+00 )
19603 PARAMETER ( AMNTRN = 0.93956563 D+00 )
19604 PARAMETER ( AMDEUT = 1.87561339 D+00 )
19605 PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
19606 & * 1.D-09 )
19607 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
19608 PARAMETER ( BLTZMN = 8.617385 D-14 )
19609 PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
19610 PARAMETER ( GFOHB3 = 1.16639 D-05 )
19611 PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
19612 PARAMETER ( SIN2TW = 0.2319 D+00 )
19613 PARAMETER ( GEVMEV = 1.0 D+03 )
19614 PARAMETER ( EMVGEV = 1.0 D-03 )
19615 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
19616 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
19617 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
19618 LOGICAL LGBIAS, LGBANA
19619 COMMON /FKGLOB/ LGBIAS, LGBANA
19620C INCLUDE '(DIMPAR)'
19621* DIMPAR.ADD
19622 PARAMETER ( MXXRGN = 5000 )
19623 PARAMETER ( MXXMDF = 82 )
19624 PARAMETER ( MXXMDE = 54 )
19625 PARAMETER ( MFSTCK = 1000 )
19626 PARAMETER ( MESTCK = 100 )
19627 PARAMETER ( NALLWP = 39 )
19628 PARAMETER ( NELEMX = 80 )
19629 PARAMETER ( MPDPDX = 8 )
19630 PARAMETER ( ICOMAX = 180 )
19631 PARAMETER ( NSTBIS = 304 )
19632 PARAMETER ( IDMAXP = 220 )
19633 PARAMETER ( IDMXDC = 640 )
19634 PARAMETER ( MKBMX1 = 1 )
19635 PARAMETER ( MKBMX2 = 1 )
19636C INCLUDE '(IOUNIT)'
19637* IOUNIT.ADD
19638 PARAMETER ( LUNIN = 5 )
19639 PARAMETER ( LUNOUT = 6 )
19640**sr 19.5. set error output-unit from 15 to 6
19641 PARAMETER ( LUNERR = 6 )
19642 PARAMETER ( LUNBER = 14 )
19643 PARAMETER ( LUNECH = 8 )
19644 PARAMETER ( LUNFLU = 13 )
19645 PARAMETER ( LUNGEO = 16 )
19646 PARAMETER ( LUNPMF = 12 )
19647 PARAMETER ( LUNRAN = 2 )
19648 PARAMETER ( LUNXSC = 9 )
19649 PARAMETER ( LUNDET = 17 )
19650 PARAMETER ( LUNRAY = 10 )
19651 PARAMETER ( LUNRDB = 1 )
19652 PARAMETER ( LUNPGO = 7 )
19653 PARAMETER ( LUNPGS = 4 )
19654 PARAMETER ( LUNSCR = 3 )
19655*
19656*----------------------------------------------------------------------*
19657* *
19658* Revised version of the original routine from EVAP: *
19659* *
19660* Created on 15 may 1990 by Alfredo Ferrari & Paola Sala *
19661* Infn - Milan *
19662* *
19663* Last change on 19-sep-95 by Alfredo Ferrari *
19664* *
19665* !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
19666* !!! It is supposed to be used with the updated atomic !!! *
19667* !!! mass data file !!! *
19668* !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
19669* *
19670*----------------------------------------------------------------------*
19671*
19672* Mass number below which "unknown" isotopes out of the Z-interval
19673* reported in the mass tabulations are completely unstable and made
19674* up by Z proton masses + N neutron masses:
19675 PARAMETER ( KAFREE = 4 )
19676* Mass number below which "unknown" isotopes out of the Z-interval
19677* reported in the mass tabulations are supposed to be particle unstable
19678 PARAMETER ( KAPUNS = 12 )
19679* Minimum energy required for particle unstable isotopes
19680 PARAMETER ( DEPUNS = 0.5D+00 )
19681*
19682* (original name: EVA0)
19683 COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
19684 * FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
19685 * CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
19686 * T (4,7), RMASS (297), ALPH (297), BET (297),
19687 * APRIME (250), IA (6), IZ (6)
19688* (original name: ISOTOP)
19689 PARAMETER ( NAMSMX = 270 )
19690 PARAMETER ( NZGVAX = 15 )
19691 PARAMETER ( NISMMX = 574 )
19692 COMMON /FKISOT/ WAPS (NAMSMX,NZGVAX), T12NUC (NAMSMX,NZGVAX),
19693 & WAPISM (NISMMX), T12ISM (NISMMX),
19694 & ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260),
19695 & AMSSST (100) , ISOMNM (NSTBIS), ISONDX (2,100),
19696 & JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX),
19697 & INWAPS (NAMSMX), JSPISM (NISMMX),
19698 & JPTISM (NISMMX), IZWISM (NISMMX),
19699 & INWISM (0:NAMSMX)
19700*
454792a9 19701CPH SAVE KA0, KZ0, IZ0
9aaba0d6 19702 DATA KA0, KZ0, IZ0 / -1, -1, -1 /
19703*
19704 IFLAG = 1
19705 GO TO 10
19706*======================================================================*
19707* *
19708* Entry ENergy - KNOWn *
19709* *
19710*======================================================================*
19711 ENTRY DT_ENKNOW ( A, Z, IZZ0 )
19712 IZZ0 =-1
19713 IFLAG = 2
19714 10 CONTINUE
19715*
19716 KA0 = NINT ( A )
19717 KZ0 = NINT ( Z )
19718 N = KA0 - KZ0
19719* +-------------------------------------------------------------------*
19720* | Null residual nucleus:
19721 IF ( KA0 .EQ. 0 .AND. KZ0 .LE. 0 ) THEN
19722 IF ( IFLAG .EQ. 1 ) THEN
19723 DT_ENERGY = ZERZER
19724 ELSE
19725 DT_ENKNOW = ZERZER
19726 IZZ0 = -1
19727 END IF
19728 RETURN
19729* |
19730* +-------------------------------------------------------------------*
19731* | Only protons:
19732 ELSE IF ( N .LE. 0 ) THEN
19733 IF ( N .LT. 0 ) THEN
19734 WRITE ( LUNOUT, * )
19735 & ' DPMJET stopped in energy: mass number =< atomic number !!',
19736 & KA0, KZ0
19737 WRITE ( LUNOUT, * )
19738 & ' DPMJET stopped in energy: mass number =< atomic number !!',
19739 & KA0, KZ0
19740 WRITE ( 77, * )
19741 & ' ^^^DPMJET stopped in energy: mass number =< atomic number !!',
19742 & KA0, KZ0
19743 STOP 'DT_ENERGY:KA0-KZ0'
19744 END IF
19745 IZ0 = -1
19746 IF ( IFLAG .EQ. 1 ) THEN
19747 DT_ENERGY = Z * WAPS ( 1, 2 )
19748 ELSE
19749 DT_ENKNOW = Z * WAPS ( 1, 2 )
19750 IZZ0 = -1
19751 END IF
19752 RETURN
19753* |
19754* +-------------------------------------------------------------------*
19755* | Only neutrons:
19756 ELSE IF ( KZ0 .LE. 0 ) THEN
19757 IF ( KZ0 .LT. 0 ) THEN
19758 WRITE ( LUNOUT, * )
19759 & ' DPMJET stopped in energy: negative atomic number !!',KA0,KZ0
19760 WRITE ( LUNOUT, * )
19761 & ' DPMJET stopped in energy: negative atomic number !!',KA0,KZ0
19762 WRITE ( 77, * )
19763 &' ^^^DPMJET stopped in energy: negative atomic number !!',KA0,KZ0
19764 STOP 'DT_ENERGY:KZ0<0'
19765 END IF
19766 IZ0 = -1
19767 IF ( IFLAG .EQ. 1 ) THEN
19768 DT_ENERGY = A * WAPS ( 1, 1 )
19769 ELSE
19770 DT_ENKNOW = A * WAPS ( 1, 1 )
19771 IZZ0 = -1
19772 END IF
19773 RETURN
19774 END IF
19775* |
19776* +-------------------------------------------------------------------*
19777* +-------------------------------------------------------------------*
19778* | No actual nucleus
19779* |
19780* +-------------------------------------------------------------------*
19781* +-------------------------------------------------------------------*
19782* | A larger than maximum allowed:
19783 IF ( KA0 .GT. NAMSMX ) THEN
19784 IZ0 = -1
19785 IF ( IFLAG .EQ. 1 ) THEN
19786 DT_ENERGY = DT_ENRG( A, Z )
19787 ELSE
19788 DT_ENKNOW = DT_ENRG( A, Z )
19789 IZZ0 = -1
19790 END IF
19791 RETURN
19792 END IF
19793* |
19794* +-------------------------------------------------------------------*
19795 IZZ = INWAPS ( KA0 )
19796* +-------------------------------------------------------------------*
19797* | Too much neutron rich with respect to the stability line:
19798 IF ( KZ0 .LT. IZZ ) THEN
19799* | +----------------------------------------------------------------*
19800* | | Up to A=Kafree all "bound" masses are known, set it unbound:
19801 IF ( KA0 .LE. KAFREE ) THEN
19802 DT_ENERGY = AINFNT
19803* | |
19804* | +----------------------------------------------------------------*
19805* | | Up to Kapuns: be sure it is particle unstable
19806 ELSE IF ( KA0 .LE. KAPUNS ) THEN
19807* | | Exp. excess mass for A,IZZ
19808 ENEEXP = WAPS ( KA0, 1 )
19809* | | Cameron excess mass for A, IZZ
19810 ENECA1 = DT_ENRG( A, DBLE (IZZ) )
19811* | | Cameron excess mass for A, Z
19812 DT_ENERGY = DT_ENRG( A, Z )
19813* | | Use just the difference according to Cameron!!!
19814 DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19815 JZZ = INWAPS ( KA0 - 1 )
19816 LZZ = INWAPS ( KA0 - 2 )
19817* | | +-------------------------------------------------------------*
19818* | | | Residual mass for n-decay known:
19819 IF ( KZ0 .GE. JZZ .AND. KZ0 .LE. JZZ + NZGVAX - 1 ) THEN
19820 IZ0 = KZ0 - JZZ + 1
19821 DT_ENERGY = MAX(DT_ENERGY,WAPS (KA0-1,IZ0) + WAPS (1,1)
19822 & + DEPUNS )
19823* | | |
19824* | | +-------------------------------------------------------------*
19825* | | | Residual mass for 2n-decay known:
19826 ELSE IF ( KZ0 .GE. LZZ .AND. KZ0 .LE. LZZ + NZGVAX - 1 )THEN
19827 IZ0 = KZ0 - LZZ + 1
19828 DT_ENERGY = MAX ( DT_ENERGY, WAPS (KA0-2,IZ0) + TWOTWO *
19829 & ( WAPS (1,1) + DEPUNS ) )
19830* | | |
19831* | | +-------------------------------------------------------------*
19832* | | | Set it unbound:
19833 ELSE
19834 DT_ENERGY = AINFNT
19835 END IF
19836* | | |
19837* | | +-------------------------------------------------------------*
19838* | |
19839* | +----------------------------------------------------------------*
19840* | | Proceed as usual:
19841 ELSE
19842* | | Exp. excess mass for A,IZZ
19843 ENEEXP = WAPS ( KA0, 1 )
19844* | | Cameron excess mass for A, IZZ
19845 ENECA1 = DT_ENRG( A, DBLE (IZZ) )
19846* | | Cameron excess mass for A, Z
19847 DT_ENERGY = DT_ENRG( A, Z )
19848* | | Use just the difference according to Cameron!!!
19849 DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19850 END IF
19851* | |
19852* | +----------------------------------------------------------------*
19853* | Be sure not to have a positive energy state:
19854 DT_ENERGY = MIN(DT_ENERGY,(A-Z) * WAPS (1,1) + Z * WAPS (1,2) )
19855 IZ0 = -1
19856 IF ( IFLAG .EQ. 2 ) THEN
19857 DT_ENKNOW = DT_ENERGY
19858 IZZ0 = -1
19859 END IF
19860 RETURN
19861* |
19862* +-------------------------------------------------------------------*
19863* | Too much proton rich with respect to the stability line:
19864 ELSE IF ( KZ0 .GT. IZZ + NZGVAX - 1 ) THEN
19865* | +----------------------------------------------------------------*
19866* | | Up to A=Kafree all "bound" masses are known, set it unbound:
19867 IF ( KA0 .LE. KAFREE ) THEN
19868 DT_ENERGY = AINFNT
19869* | |
19870* | +----------------------------------------------------------------*
19871* | | Up to Kapuns: be sure it is particle unstable
19872 ELSE IF ( KA0 .LE. KAPUNS ) THEN
19873* | | Exp. excess mass for A,IZZ+NZGVAX-1
19874 ENEEXP = WAPS ( KA0, NZGVAX )
19875* | | Cameron excess mass for A, IZZ+NZGVAX-1
19876 ENECA1 = DT_ENRG( A, DBLE (IZZ+NZGVAX-1) )
19877* | | Cameron excess mass for A, Z
19878 DT_ENERGY = DT_ENRG( A, Z )
19879* | | Use just the difference according to Cameron!!!
19880 DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19881 JZZ = INWAPS ( KA0 - 1 )
19882 LZZ = INWAPS ( KA0 - 2 )
19883* | | +-------------------------------------------------------------*
19884* | | | Residual mass for p-decay known:
19885 IF ( KZ0-1 .GE. JZZ .AND. KZ0-1 .LE. JZZ + NZGVAX - 1 ) THEN
19886 IZ0 = KZ0 - 1 - JZZ + 1
19887 DT_ENERGY = MAX (DT_ENERGY, WAPS (KA0-1,IZ0) + WAPS (1,2)
19888 & + DEPUNS )
19889* | | |
19890* | | +-------------------------------------------------------------*
19891* | | | Residual mass for 2p-decay known:
19892 ELSE IF ( KZ0-2 .GE. LZZ .AND. KZ0-2 .LE. LZZ + NZGVAX - 1 )
19893 & THEN
19894 IZ0 = KZ0 - 2 - LZZ + 1
19895 DT_ENERGY = MAX ( DT_ENERGY, WAPS (KA0-2,IZ0) + TWOTWO *
19896 & ( WAPS (1,2) + DEPUNS ) )
19897* | | |
19898* | | +-------------------------------------------------------------*
19899* | | | Set it unbound:
19900 ELSE
19901 DT_ENERGY = AINFNT
19902 END IF
19903* | | |
19904* | | +-------------------------------------------------------------*
19905* | |
19906* | +----------------------------------------------------------------*
19907* | | Proceed as usual:
19908 ELSE
19909* | | Exp. excess mass for A,IZZ+NZGVAX-1
19910 ENEEXP = WAPS ( KA0, NZGVAX )
19911* | | Cameron excess mass for A, IZZ+NZGVAX-1
19912 ENECA1 = DT_ENRG( A, DBLE (IZZ+NZGVAX-1) )
19913* | | Cameron excess mass for A, Z
19914 DT_ENERGY = DT_ENRG( A, Z )
19915* | | Use just the difference according to Cameron!!!
19916 DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19917 END IF
19918* | |
19919* | +----------------------------------------------------------------*
19920* | Be sure not to have a positive energy state:
19921 DT_ENERGY = MIN(DT_ENERGY,(A-Z) * WAPS (1,1) + Z * WAPS (1,2) )
19922 IZ0 = -1
19923 IF ( IFLAG .EQ. 2 ) THEN
19924 DT_ENKNOW = DT_ENERGY
19925 IZZ0 = -1
19926 END IF
19927 RETURN
19928* |
19929* +-------------------------------------------------------------------*
19930* | Known isotope or anyway isotope "inside" the stability zone
19931 ELSE
19932 IZ0 = KZ0 - IZZ + 1
19933 DT_ENERGY = WAPS ( KA0, IZ0 )
19934 IF ( IFLAG .EQ. 2 ) IZZ0 = IZ0
19935* | +----------------------------------------------------------------*
19936* | | Mass not known
19937 IF ( ABS (DT_ENERGY) .LT. ANGLGB .AND. (KA0 .NE. 12 .OR. KZ0
19938 & .NE. 6) ) THEN
19939 IF ( IFLAG .EQ. 2 ) IZZ0 = -1
19940* | | +-------------------------------------------------------------*
19941* | | | Set it unbound:
19942 IF ( KA0 .LE. KAFREE ) THEN
19943 DT_ENERGY = AINFNT
19944* | | |
19945* | | +-------------------------------------------------------------*
19946* | | | Try to get a reasonable excess mass:
19947 ELSE
19948 JZ0 = -100
19949* | | | +----------------------------------------------------------*
19950* | | | | Check the closest one known:
19951 DO 500 JZZ = 1, NZGVAX
19952 IF ( ABS ( WAPS (KA0,JZZ) ) .GT. ANGLGB .AND.
19953 & ABS (JZZ-IZ0) .LT. ABS (JZ0-IZ0) ) JZ0 = JZZ
19954 IF ( ABS (JZ0-IZ0) .EQ. 1 ) GO TO 550
19955 500 CONTINUE
19956* | | | |
19957* | | | +----------------------------------------------------------*
19958 550 CONTINUE
19959* | | | Exp. excess mass for A,IZZ+JZ0-1
19960 ENEEXP = WAPS ( KA0, JZ0 )
19961* | | | Cameron excess mass for A, IZZ+JZ0-1
19962 ENECA1 = DT_ENRG( A, DBLE (IZZ+JZ0-1) )
19963* | | | Cameron excess mass for A, Z
19964 DT_ENERGY = DT_ENRG( A, Z )
19965* | | | Use just the difference according to Cameron!!!
19966 DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19967 IZ0 = -1
19968 END IF
19969* | | |
19970* | | +-------------------------------------------------------------*
19971* | | Be sure not to have a positive energy state:
19972 DT_ENERGY = MIN(DT_ENERGY,(A-Z)*WAPS(1,1)+Z*WAPS (1,2) )
19973 END IF
19974* | |
19975* | +----------------------------------------------------------------*
19976 IF ( IFLAG .EQ. 2 ) DT_ENKNOW = DT_ENERGY
19977 RETURN
19978 END IF
19979* |
19980* +-------------------------------------------------------------------*
19981*=== End of Function Energy ===========================================*
19982* RETURN
19983 END
19984**
19985
19986*$ CREATE DT_ENRG.FOR
19987*COPY DT_ENRG
19988* *
19989*=== enrg =============================================================*
19990* *
19991 DOUBLE PRECISION FUNCTION DT_ENRG(A,Z)
19992
19993 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19994 SAVE
19995
19996 PARAMETER ( ZERZER = 0.D+00 )
19997 PARAMETER ( ONEONE = 1.D+00 )
19998 PARAMETER ( LUNIN = 5 )
19999 PARAMETER ( LUNOUT = 6 )
20000*
20001*----------------------------------------------------------------------*
20002* *
20003* Revised version of the original routine from EVAP: *
20004* *
20005* Created on 15 may 1990 by Alfredo Ferrari & Paola Sala *
20006* Infn - Milan *
20007* *
20008* Last change on 01-oct-94 by Alfredo Ferrari *
20009* *
20010* !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
20011* !!! It is supposed to be used with the updated atomic !!! *
20012* !!! mass data file !!! *
20013* !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
20014* *
20015*----------------------------------------------------------------------*
20016*
20017 PARAMETER ( O16OLD = 931.145 D+00 )
20018 PARAMETER ( O16NEW = 931.19826D+00 )
20019 PARAMETER ( O16RAT = O16NEW / O16OLD )
20020 PARAMETER ( C12NEW = 931.49432D+00 )
20021 PARAMETER ( ADJUST = -8.322737768178909D-02 )
20022 PARAMETER ( AINFNT = 1.0D+30 )
20023* (original name: EVA0)
20024 COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
20025 * FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
20026 * CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
20027 * T (4,7), RMASS (297), ALPH (297), BET (297),
20028 * APRIME (250), IA (6), IZ (6)
20029 LOGICAL LFIRST
454792a9 20030CPH SAVE LFIRST, EXHYDR, EXNEUT
9aaba0d6 20031 DATA LFIRST / .TRUE. /
20032*
20033 IF ( LFIRST ) THEN
20034 LFIRST = .FALSE.
20035**sr 30.6.
20036C EXHYDR = DT_ENERGY( ONEONE, ONEONE )
20037C EXNEUT = DT_ENERGY( ONEONE, ZERZER )
20038 EXHYDR = A
20039 EXNEUT = Z
20040 DT_ENRG = -AINFNT
20041 RETURN
20042**
20043 END IF
20044 IZ0 = NINT (Z)
20045 IF ( IZ0 .LE. 0 ) THEN
20046 DT_ENRG = A * EXNEUT
20047 RETURN
20048 END IF
20049 N = NINT (A-Z)
20050 IF ( N .LE. 0 ) THEN
20051 DT_ENRG = Z * EXHYDR
20052 RETURN
20053 END IF
20054 AM2ZOA= (A-Z-Z)/A
20055 AM2ZOA=AM2ZOA*AM2ZOA
20056 A13 = RMASS(NINT(A))
20057* A13 = A**.3333333333333333D+00
20058 AM13 = 1.D+00/A13
20059 EV=-17.0354D+00*(1.D+00 -1.84619 D+00*AM2ZOA)*A
20060 ES= 25.8357D+00*(1.D+00 -1.712185D+00*AM2ZOA)*
20061 & (1.D+00 -0.62025D+00*AM13*AM13)*
20062 & (A13*A13 -.62025D+00)
20063 EC= 0.799D+00*Z*(Z-1.D+00)*AM13*(((1.5772D+00*AM13 +1.2273D+00)*
20064 & AM13-1.5849D+00)*
20065 & AM13*AM13 +1.D+00)
20066 EEX= -0.4323D+00*AM13*Z**1.3333333D+00*
20067 & (((0.49597D+00*AM13 -0.14518D+00)*AM13 -0.57811D+00) * AM13
20068 & + 1.D+00)
20069 DT_ENRG=8.367D+00*A-0.783D+00*Z +EV +ES +EC +EEX+CAM2(IZ0)+CAM3(N)
20070 DT_ENRG=(DT_ENRG + A * O16OLD ) * O16RAT - A * ( C12NEW - ADJUST )
20071 DT_ENRG = MIN ( DT_ENRG, Z * EXHYDR + ( A - Z ) * EXNEUT )
20072 RETURN
20073*=== End of function Enrg =============================================*
20074 END
20075
20076*$ CREATE DT_INCINI.FOR
20077*COPY DT_INCINI
20078* *
20079*=== incini ===========================================================*
20080* *
20081 SUBROUTINE DT_INCINI
20082
20083 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20084 SAVE
20085
20086 PARAMETER ( ZERZER = 0.D+00 )
20087 PARAMETER ( ONEONE = 1.D+00 )
20088 PARAMETER ( TWOTWO = 2.D+00 )
20089 PARAMETER ( THRTHR = 3.D+00 )
20090 PARAMETER ( FOUFOU = 4.D+00 )
20091 PARAMETER ( EIGEIG = 8.D+00 )
20092 PARAMETER ( ANINEN = 9.D+00 )
20093 PARAMETER ( HLFHLF = 0.5D+00 )
20094 PARAMETER ( ONETHI = ONEONE / THRTHR )
20095 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
20096 PARAMETER ( PLABRC = 0.197327053 D+00 )
20097 PARAMETER ( AMELCT = 0.51099906 D-03 )
20098 PARAMETER ( AMUGEV = 0.93149432 D+00 )
20099 PARAMETER ( AMPRTN = 0.93827231 D+00 )
20100 PARAMETER ( AMNTRN = 0.93956563 D+00 )
20101 PARAMETER ( AMDEUT = 1.87561339 D+00 )
20102 PARAMETER ( EMVGEV = 1.0 D-03 )
20103
20104 PARAMETER ( LUNOUT = 6 )
20105*
20106*----------------------------------------------------------------------*
20107* *
20108* Created on 10 june 1990 by Alfredo Ferrari & Paola Sala *
20109* Infn - Milan *
20110* *
20111* Last change on 02-may-95 by Alfredo Ferrari *
20112* *
20113* *
20114*----------------------------------------------------------------------*
20115*
20116* (original name: FHEAVY,FHEAVC)
20117 PARAMETER ( MXHEAV = 100 )
20118 CHARACTER*8 ANHEAV
20119 COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV),
20120 & CZHEAV (MXHEAV), TKHEAV (MXHEAV),
20121 & PHEAVY (MXHEAV), WHEAVY (MXHEAV),
20122 & AMHEAV ( 12 ) , AMNHEA ( 12 ) ,
20123 & KHEAVY (MXHEAV), ICHEAV ( 12 ) ,
20124 & IBHEAV ( 12 ) , NPHEAV
20125 COMMON /FKFHVC/ ANHEAV ( 12 )
20126* (original name: INPFLG)
20127 COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
20128* (original name: FRBKCM)
20129 PARAMETER ( MXFFBK = 6 )
20130 PARAMETER ( MXZFBK = 9 )
20131 PARAMETER ( MXNFBK = 10 )
20132 PARAMETER ( MXAFBK = 16 )
20133 PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
20134 PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
20135 PARAMETER ( NXAFBK = MXAFBK + 1 )
20136 PARAMETER ( MXPSST = 300 )
20137 PARAMETER ( MXPSFB = 41000 )
20138 LOGICAL LFRMBK, LNCMSS
20139 COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
20140 & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
20141 & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
20142 & IFRBKN (MXPSST), IFRBKZ (MXPSST),
20143 & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
20144 & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
20145 & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
20146 & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
20147 & IFBFRB, NBUFBK, LFRMBK, LNCMSS
20148* (original name: NUCDAT)
20149 PARAMETER ( AMUAMU = AMUGEV )
20150 PARAMETER ( AMPROT = AMPRTN )
20151 PARAMETER ( AMNEUT = AMNTRN )
20152 PARAMETER ( AMELEC = AMELCT )
20153 PARAMETER ( R0NUCL = 1.12 D+00 )
20154 PARAMETER ( RCCOUL = 1.7 D+00 )
20155 PARAMETER ( FERTHO = 14.33 D-09 )
20156 PARAMETER ( EXPEBN = 2.39 D+00 )
20157 PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
20158 PARAMETER ( AMUC12 = AMUGEV - HLFHLF * AMELCT + BEXC12 / 12.D+00 )
20159 PARAMETER ( AMHYDR = AMPRTN + AMELCT )
20160 PARAMETER ( AMHTON = AMHYDR - AMNTRN )
20161 PARAMETER ( AMNTOU = AMNTRN - AMUC12 )
20162 PARAMETER ( AMUCSQ = AMUC12 * AMUC12 )
20163 PARAMETER ( EBNDAV = HLFHLF * (AMPRTN + AMNTRN) - AMUC12 )
20164 PARAMETER ( GAMMIN = 1.0D-06 )
20165 PARAMETER ( GAMNSQ = 2.0D+00 * GAMMIN * GAMMIN )
20166 PARAMETER ( TVEPSI = GAMMIN / 100.D+00 )
20167 COMMON /FKNDAT/ AV0WEL, APFRMX, AEFRMX, AEFRMA,
20168 & RDSNUC, V0WELL (2), PFRMMX (2), EFRMMX (2),
20169 & EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2),
20170 & VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2),
20171 & PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2),
20172 & EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2),
20173 & ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV ,
20174 & AMRCSQ , ATO1O3 , ZTO1O3 , ELBNDE (0:100)
20175* (original name: PAREVT)
20176 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
20177 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
20178 PARAMETER ( NALLWP = 39 )
20179 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
20180 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
20181 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
20182 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
20183* (original name: NUCOLD)
20184 COMMON /FKNOLD/ HELP (2), HHLP (2), FTVTH (2), FINCX (2),
20185 & EKPOLD (2), BBOLD, ZZOLD, SQROLD, ASEASQ,
20186 & FSPRED, FEX0RD
20187*
20188 BBOLD = - 1.D+10
20189 ZZOLD = - 1.D+10
20190 SQROLD = - 1.D+10
20191 APFRMX = PLABRC * ( ANINEN * PIPIPI / EIGEIG )**ONETHI / R0NUCL
20192 AMNUCL (1) = AMPROT
20193 AMNUCL (2) = AMNEUT
20194 AMNUSQ (1) = AMPROT * AMPROT
20195 AMNUSQ (2) = AMNEUT * AMNEUT
20196 AMNHLP = HLFHLF * ( AMNUCL (1) + AMNUCL (2) )
20197 ASQHLP = AMNHLP**2
20198* ASQHLP = HLFHLF * ( AMNUSQ (1) + AMNUSQ (2) )
20199 AEFRMX = SQRT ( ASQHLP + APFRMX**2 ) - AMNHLP
20200 AEFRMA = 0.3D+00 * APFRMX**2 / AMNHLP * ( ONEONE - APFRMX**2 /
20201 & ( 5.6D+00 * ASQHLP ) )
20202 AV0WEL = AEFRMX + EBNDAV
20203 EBNDNG (1) = EBNDAV
20204 EBNDNG (2) = EBNDAV
20205 AEXC12 = EMVGEV * DT_ENERGY( 12.D+00, 6.D+00 )
20206 CEXC12 = EMVGEV * DT_ENRG( 12.D+00, 6.D+00 )
20207 AMMC12 = 12.D+00 * AMUGEV + AEXC12
20208 AMNC12 = AMMC12 - 6.D+00 * AMELCT + FERTHO * 6.D+00**EXPEBN
20209 AEXO16 = EMVGEV * DT_ENERGY( 16.D+00, 8.D+00 )
20210 CEXO16 = EMVGEV * DT_ENRG( 16.D+00, 8.D+00 )
20211 AMMO16 = 16.D+00 * AMUGEV + AEXO16
20212 AMNO16 = AMMO16 - 8.D+00 * AMELCT + FERTHO * 8.D+00**EXPEBN
20213 AEXS28 = EMVGEV * DT_ENERGY( 28.D+00, 14.D+00 )
20214 CEXS28 = EMVGEV * DT_ENRG( 28.D+00, 14.D+00 )
20215 AMMS28 = 28.D+00 * AMUGEV + AEXS28
20216 AMNS28 = AMMS28 - 14.D+00 * AMELCT + FERTHO * 14.D+00**EXPEBN
20217 AEXC40 = EMVGEV * DT_ENERGY( 40.D+00, 20.D+00 )
20218 CEXC40 = EMVGEV * DT_ENRG( 40.D+00, 20.D+00 )
20219 AMMC40 = 40.D+00 * AMUGEV + AEXC40
20220 AMNC40 = AMMC40 - 20.D+00 * AMELCT + FERTHO * 20.D+00**EXPEBN
20221 AEXF56 = EMVGEV * DT_ENERGY( 56.D+00, 26.D+00 )
20222 CEXF56 = EMVGEV * DT_ENRG( 56.D+00, 26.D+00 )
20223 AMMF56 = 56.D+00 * AMUGEV + AEXF56
20224 AMNF56 = AMMF56 - 26.D+00 * AMELCT + FERTHO * 26.D+00**EXPEBN
20225 AEX107 = EMVGEV * DT_ENERGY( 107.D+00, 47.D+00 )
20226 CEX107 = EMVGEV * DT_ENRG( 107.D+00, 47.D+00 )
20227 AMM107 = 107.D+00 * AMUGEV + AEX107
20228 AMN107 = AMM107 - 47.D+00 * AMELCT + FERTHO * 47.D+00**EXPEBN
20229 AEX132 = EMVGEV * DT_ENERGY( 132.D+00, 54.D+00 )
20230 CEX132 = EMVGEV * DT_ENRG( 132.D+00, 54.D+00 )
20231 AMM132 = 132.D+00 * AMUGEV + AEX132
20232 AMN132 = AMM132 - 54.D+00 * AMELCT + FERTHO * 54.D+00**EXPEBN
20233 AEX181 = EMVGEV * DT_ENERGY( 181.D+00, 73.D+00 )
20234 CEX181 = EMVGEV * DT_ENRG( 181.D+00, 73.D+00 )
20235 AMM181 = 181.D+00 * AMUGEV + AEX181
20236 AMN181 = AMM181 - 73.D+00 * AMELCT + FERTHO * 73.D+00**EXPEBN
20237 AEX208 = EMVGEV * DT_ENERGY( 208.D+00, 82.D+00 )
20238 CEX208 = EMVGEV * DT_ENRG( 208.D+00, 82.D+00 )
20239 AMM208 = 208.D+00 * AMUGEV + AEX208
20240 AMN208 = AMM208 - 82.D+00 * AMELCT + FERTHO * 82.D+00**EXPEBN
20241 AEX238 = EMVGEV * DT_ENERGY( 238.D+00, 92.D+00 )
20242 CEX238 = EMVGEV * DT_ENRG( 238.D+00, 92.D+00 )
20243 AMM238 = 238.D+00 * AMUGEV + AEX238
20244 AMN238 = AMM238 - 92.D+00 * AMELCT + FERTHO * 92.D+00**EXPEBN
20245
20246 AMHEAV (1) = AMUGEV + EMVGEV * DT_ENERGY( ONEONE, ZERZER )
20247 AMHEAV (2) = AMUGEV + EMVGEV * DT_ENERGY( ONEONE, ONEONE )
20248 AMHEAV (3) = TWOTWO * AMUGEV
20249 & + EMVGEV * DT_ENERGY( TWOTWO, ONEONE )
20250 AMHEAV (4) = THRTHR * AMUGEV
20251 & + EMVGEV * DT_ENERGY( THRTHR, ONEONE )
20252 AMHEAV (5) = THRTHR * AMUGEV
20253 & + EMVGEV * DT_ENERGY( THRTHR, TWOTWO )
20254 AMHEAV (6) = FOUFOU * AMUGEV
20255 & + EMVGEV * DT_ENERGY( FOUFOU, TWOTWO )
20256 ELBNDE (0) = ZERZER
20257 ELBNDE (1) = 13.6D-09
20258 DO 2000 IZ = 2, 100
20259 ELBNDE ( IZ ) = FERTHO * DBLE ( IZ )**EXPEBN
202602000 CONTINUE
20261 AMNHEA (1) = AMHEAV (1) + ELBNDE (0)
20262 AMNHEA (2) = AMHEAV (2) - AMELCT + ELBNDE (1)
20263 AMNHEA (3) = AMHEAV (3) - AMELCT + ELBNDE (1)
20264 AMNHEA (4) = AMHEAV (4) - AMELCT + ELBNDE (1)
20265 AMNHEA (5) = AMHEAV (5) - TWOTWO * AMELCT + ELBNDE (2)
20266 AMNHEA (6) = AMHEAV (6) - TWOTWO * AMELCT + ELBNDE (2)
20267 IF ( LEVPRT ) THEN
20268 WRITE ( LUNOUT, * )' **** Evaporation from residual nucleus',
20269 & ' activated **** '
20270 IF ( LDEEXG ) WRITE ( LUNOUT, * )' **** Deexcitation gamma',
20271 & ' production activated **** '
20272**sr 18.5.95
20273* commented, since obsolete
20274C IF ( LHEAVY ) WRITE ( LUNOUT, * )' **** Evaporated "heavies"',
20275C & ' transport activated **** '
20276 IF ( IFISS .GT. 0 )
20277 & WRITE ( LUNOUT, * )' **** High Energy fission ',
20278 & ' requested & activated **** '
20279 IF ( LFRMBK )
20280 & WRITE ( LUNOUT, * )' **** Fermi Break Up ',
20281 & ' requested & activated **** '
20282 IF ( LFRMBK ) CALL DT_FRBKIN(.FALSE.,.FALSE.)
20283 ELSE
20284 LDEEXG = .FALSE.
20285 LHEAVY = .FALSE.
20286 LFRMBK = .FALSE.
20287 IFISS = 0
20288 END IF
20289 RETURN
20290*=== End of subroutine incini =========================================*
20291 END
20292
20293*$ CREATE DT_STALIN.FOR
20294*COPY DT_STALIN
20295* *
20296*=== stalin ===========================================================*
20297* *
20298 SUBROUTINE DT_STALIN
20299
20300 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20301 SAVE
20302 PARAMETER ( ANGLGB = 5.0D-16 )
20303 PARAMETER ( ZERZER = 0.D+00 )
20304 PARAMETER ( ONEONE = 1.D+00 )
20305 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
20306 PARAMETER ( AMUGEV = 0.93149432 D+00 )
20307 PARAMETER ( EMVGEV = 1.0 D-03 )
20308 PARAMETER ( NSTBIS = 304 )
20309 PARAMETER ( LUNIN = 5 )
20310 PARAMETER ( LUNOUT = 6 )
20311*
20312*----------------------------------------------------------------------*
20313* *
20314* STAbility LINe calculation: *
20315* *
20316* Created on 04 december 1992 by Alfredo Ferrari & Paola Sala *
20317* Infn - Milan *
20318* *
20319* Last change on 04-dec-92 by Alfredo Ferrari *
20320* *
20321* *
20322*----------------------------------------------------------------------*
20323*
20324* (original name: ISOTOP)
20325 PARAMETER ( NAMSMX = 270 )
20326 PARAMETER ( NZGVAX = 15 )
20327 PARAMETER ( NISMMX = 574 )
20328 COMMON /FKISOT/ WAPS (NAMSMX,NZGVAX), T12NUC (NAMSMX,NZGVAX),
20329 & WAPISM (NISMMX), T12ISM (NISMMX),
20330 & ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260),
20331 & AMSSST (100) , ISOMNM (NSTBIS), ISONDX (2,100),
20332 & JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX),
20333 & INWAPS (NAMSMX), JSPISM (NISMMX),
20334 & JPTISM (NISMMX), IZWISM (NISMMX),
20335 & INWISM (0:NAMSMX)
20336*
20337 DIMENSION ZNORM (260)
20338* +-------------------------------------------------------------------*
20339* |
20340 DO 1000 IZ=1,100
20341 DO 500 J=1,2
20342 ASTLIN (J,IZ) = ZERZER
20343 500 CONTINUE
20344 1000 CONTINUE
20345* |
20346* +-------------------------------------------------------------------*
20347* +-------------------------------------------------------------------*
20348* |
20349 DO 2000 IA=1,260
20350 ZNORM (IA) = ZERZER
20351 DO 1500 J=1,2
20352 ZSTLIN (J,IA) = ZERZER
20353 1500 CONTINUE
20354 2000 CONTINUE
20355* |
20356* +-------------------------------------------------------------------*
20357* +-------------------------------------------------------------------*
20358* | Loop on the Atomic Number
20359 DO 3000 IZ=1,100
20360 AMSSST (IZ) = ZERZER
20361 ANORM = ONEONE
20362 ZTAR = IZ
20363* | +----------------------------------------------------------------*
20364* | | Loop on the stable isotopes
20365 DO 2500 IS = ISONDX (1,IZ), ISONDX (2,IZ)
20366 IA = ISOMNM (IS)
20367 ASTLIN (1,IZ) = ASTLIN (1,IZ) + ABUISO (IS) * IA
20368 ASTLIN (2,IZ) = ASTLIN (2,IZ) + ABUISO (IS) * IA**2
20369 ZNORM (IA) = ZNORM (IA) + ABUISO (IS)
20370 ZSTLIN (1,IA) = ZSTLIN (1,IA) + ABUISO (IS) * IZ
20371 ZSTLIN (2,IA) = ZSTLIN (2,IA) + ABUISO (IS) * IZ**2
20372 AHELP = IA
20373 IF ( AHELP .LE. 1.00001D+00 ) THEN
20374 ANORM = ONEONE / ( ONEONE - ABUISO (IS) )
20375 GO TO 2500
20376 END IF
20377 AMSSST (IZ) = ABUISO (IS) * ( AHELP * AMUGEV
20378 & + EMVGEV * DT_ENERGY(AHELP,ZTAR) ) + AMSSST (IZ)
20379 2500 CONTINUE
20380* | |
20381* | +----------------------------------------------------------------*
20382 AMSSST (IZ) = ANORM * AMSSST (IZ) / AMUGEV
20383* | Normalize and print A_stab versus Z data:
20384 ASTLIN (2,IZ) = MAX ( SQRT (ASTLIN(2,IZ)-ASTLIN(1,IZ)**2),
20385 & 0.5D+00 )
20386* WRITE (LUNOUT,*)' Z:',IZ,' A_stab:',SNGL(ASTLIN(1,IZ)),
20387* & ' Sigma_st',SNGL(ASTLIN(2,IZ))
20388 3000 CONTINUE
20389* |
20390* +-------------------------------------------------------------------*
20391* +-------------------------------------------------------------------*
20392* | Normalize and print Z_stab versus A data:
20393 DO 4000 IA=1,260
20394 ZSTLIN (1,IA) = ZSTLIN (1,IA) / MAX ( ZNORM (IA), 1.D-10 )
20395 ZSTLIN (2,IA) = ZSTLIN (2,IA) / MAX ( ZNORM (IA), 1.D-10 )
20396 ZSTLIN (2,IA) = MAX ( ZSTLIN (2,IA), ZSTLIN (1,IA)**2 )
20397 IF ( ZNORM (IA) .GT. ANGLGB )
20398**sr 2.11. avoid underflows at Pentium
20399 & ZSTLIN (2,IA) =
20400 & MAX ( SQRT ( ABS(ZSTLIN(2,IA)-ZSTLIN(1,IA)**2) ),
20401C & ZSTLIN (2,IA) = MAX ( SQRT (ZSTLIN(2,IA)-ZSTLIN(1,IA)**2),
20402 & 0.3D+00 )
20403 4000 CONTINUE
20404* |
20405* +-------------------------------------------------------------------*
20406* +-------------------------------------------------------------------*
20407* | Normalize and print Z_stab versus A data:
20408 DO 5000 IA=1,260
20409 IF ( ZNORM (IA) .LE. ANGLGB ) THEN
20410 DO 4200 JA = IA-1,1,-1
20411 IF ( ZNORM (JA) .GT. ANGLGB ) THEN
20412 IA1 = JA
20413 GO TO 4300
20414 END IF
20415 4200 CONTINUE
20416 4300 CONTINUE
20417 DO 4400 JA = IA+1,260
20418 IF ( ZNORM (JA) .GT. ANGLGB ) THEN
20419 IA2 = JA
20420 GO TO 4500
20421 END IF
20422 4400 CONTINUE
20423 IA2 = IA1
20424 IA1 = IA1 - 1
20425 4500 CONTINUE
20426 ZSTLIN (1,IA) = DBLE (IA-IA1) / DBLE (IA2-IA1)
20427 & * ( ZSTLIN (1,IA2) - ZSTLIN (1,IA1) )
20428 & + ZSTLIN (1,IA1)
20429 ZSTLIN (2,IA) = DBLE (IA-IA1) / DBLE (IA2-IA1)
20430 & * ( ZSTLIN (2,IA2) - ZSTLIN (2,IA1) )
20431 & + ZSTLIN (2,IA1)
20432 END IF
20433 IZ = MIN ( 100, NINT (ZSTLIN(1,IA)) )
20434 ATOZ = IZ / ASTLIN (1,IZ)
20435 ZSTLIN (2,IA) = MAX ( ZSTLIN (2,IA), ATOZ * ASTLIN (2,IZ) )
20436* WRITE (LUNOUT,*)' A:',IA,' Z_stab:',SNGL(ZSTLIN(1,IA)),
20437* & ' Sigma_st',SNGL(ZSTLIN(2,IA))
20438 5000 CONTINUE
20439* |
20440* +-------------------------------------------------------------------*
20441 RETURN
20442 END
20443
20444*$ CREATE DT_BERTTP.FOR
20445*COPY DT_BERTTP
20446*
20447*=== berttp ===========================================================*
20448* *
20449 SUBROUTINE DT_BERTTP
20450
20451 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20452 SAVE
20453
20454 PARAMETER ( CSNNRM = 2.0D-15 )
20455 PARAMETER ( ZERZER = 0.D+00 )
20456 PARAMETER ( ONEONE = 1.D+00 )
20457 PARAMETER ( THRTHR = 3.D+00 )
20458 PARAMETER ( SIXSIX = 6.D+00 )
20459 PARAMETER ( ONETHI = ONEONE / THRTHR )
20460 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
20461 PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
20462 PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
20463 PARAMETER ( EMVGEV = 1.0 D-03 )
20464
20465 PARAMETER ( NSTBIS = 304 )
20466
20467 PARAMETER ( LUNIN = 5 )
20468 PARAMETER ( LUNOUT = 6 )
20469**sr 19.5. set error output-unit from 15 to 6
20470 PARAMETER ( LUNERR = 6 )
20471C---------------------------------------------------------------------
20472C SUBNAME = DT_BERTTP --- READ BERTINI DATA
20473C---------------------------------------------------------------------
20474C ---------------------------------- I-N-C DATA
20475C COMMON R8(2127),R4(64),CRSC(600,4),R8B(336),CS(29849)
20476C REAL*8 R8,R8B,CRSC,CS
20477C REAL*4 R4
20478C --------------------------------- EVAPORATION DATA
20479* (original name: COOKCM)
20480 PARAMETER ( ASMTOG = SIXSIX / PIPIPI**2 )
20481 LOGICAL LDEFOZ, LDEFON
20482 PARAMETER ( INCOOK = 150, IZCOOK = 98 )
20483 COMMON /FKCOOK/ ALPIGN, BETIGN, GAMIGN, POWIGN,
20484 & SZCOOK (IZCOOK), SNCOOK (INCOOK), PZCOOK (IZCOOK),
20485 & PNCOOK (INCOOK), LDEFOZ (IZCOOK), LDEFON (INCOOK)
20486* (original name: EVA0)
20487 COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
20488 * FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
20489 * CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
20490 * T (4,7), RMASS (297), ALPH (297), BET (297),
20491 * APRIME (250), IA (6), IZ (6)
20492* (original name: FRBKCM)
20493 PARAMETER ( MXFFBK = 6 )
20494 PARAMETER ( MXZFBK = 9 )
20495 PARAMETER ( MXNFBK = 10 )
20496 PARAMETER ( MXAFBK = 16 )
20497 PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
20498 PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
20499 PARAMETER ( NXAFBK = MXAFBK + 1 )
20500 PARAMETER ( MXPSST = 300 )
20501 PARAMETER ( MXPSFB = 41000 )
20502 LOGICAL LFRMBK, LNCMSS
20503 COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
20504 & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
20505 & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
20506 & IFRBKN (MXPSST), IFRBKZ (MXPSST),
20507 & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
20508 & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
20509 & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
20510 & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
20511 & IFBFRB, NBUFBK, LFRMBK, LNCMSS
20512* (original name: HETTP)
20513 COMMON /FKHETP/ NHSTP,NBERTP,IOSUB,INSRS
20514* (original name: INPFLG)
20515 COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
20516* (original name: ISOTOP)
20517 PARAMETER ( NAMSMX = 270 )
20518 PARAMETER ( NZGVAX = 15 )
20519 PARAMETER ( NISMMX = 574 )
20520 COMMON /FKISOT/ WAPS (NAMSMX,NZGVAX), T12NUC (NAMSMX,NZGVAX),
20521 & WAPISM (NISMMX), T12ISM (NISMMX),
20522 & ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260),
20523 & AMSSST (100) , ISOMNM (NSTBIS), ISONDX (2,100),
20524 & JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX),
20525 & INWAPS (NAMSMX), JSPISM (NISMMX),
20526 & JPTISM (NISMMX), IZWISM (NISMMX),
20527 & INWISM (0:NAMSMX)
20528* (original name: NUCGID,NUCGEO,NUCGE2,NUCPWI,NUCGII)
20529 PARAMETER ( PI = PIPIPI )
20530 PARAMETER ( PISQ = PIPISQ )
20531 PARAMETER ( SKTOHL = 0.5456645846610345D+00 )
20532 PARAMETER ( RZNUCL = 1.12 D+00 )
20533 PARAMETER ( RMSPRO = 0.8 D+00 )
20534 PARAMETER ( R0PROT = RMSPRO / SQRT12 )
20535 PARAMETER ( ARHPRO = 1.D+00 / 8.D+00 / PI / R0PROT / R0PROT
20536 & / R0PROT )
20537 PARAMETER ( RLLE04 = RZNUCL )
20538 PARAMETER ( RLLE16 = RZNUCL )
20539 PARAMETER ( RLGT16 = RZNUCL )
20540 PARAMETER ( RCLE04 = 0.75D+00 / PI / RLLE04 / RLLE04 / RLLE04 )
20541 PARAMETER ( RCLE16 = 0.75D+00 / PI / RLLE16 / RLLE16 / RLLE16 )
20542 PARAMETER ( RCGT16 = 0.75D+00 / PI / RLGT16 / RLGT16 / RLGT16 )
20543 PARAMETER ( SKLE04 = 1.4D+00 )
20544 PARAMETER ( SKLE16 = 1.9D+00 )
20545 PARAMETER ( SKGT16 = 2.4D+00 )
20546 PARAMETER ( HLLE04 = SKTOHL * SKLE04 )
20547 PARAMETER ( HLLE16 = SKTOHL * SKLE16 )
20548 PARAMETER ( HLGT16 = SKTOHL * SKGT16 )
20549 PARAMETER ( ALPHA0 = 0.1D+00 )
20550 PARAMETER ( OMALH0 = 1.D+00 - ALPHA0 )
20551 PARAMETER ( GAMSK0 = 0.9D+00 )
20552 PARAMETER ( OMGAS0 = 1.D+00 - GAMSK0 )
20553 PARAMETER ( POTME0 = 0.6666666666666667D+00 )
20554 PARAMETER ( POTBA0 = 1.D+00 )
20555 PARAMETER ( PNFRAT = 1.533D+00 )
20556 PARAMETER ( RADPIM = 0.035D+00 )
20557 PARAMETER ( RDPMHL = 14.D+00 )
20558 PARAMETER ( APMRST = 4.D+00 / 44.D+00 )
20559 PARAMETER ( APMPRO = 1.D+00 / 6.D+00 )
20560 PARAMETER ( APPPRO = 5.D+00 / 6.D+00 )
20561 PARAMETER ( AP0PFS = 0.5D+00 )
20562 PARAMETER ( AP0PFP = 1.D+00 / 3.D+00 )
20563 PARAMETER ( AP0NFP = 2.D+00 / 3.D+00 )
20564 PARAMETER ( XPAUCO = 1.88495407241652 D+00 )
20565 PARAMETER ( MXSCIN = 50 )
20566 LOGICAL LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH, LNCDCY,
20567 & LNUSCT, LPREEQ, LNPHTC, LNWRAD, LPNRHO, LFTCMP, LFTCAC
20568 COMMON /FKNGID/ RHOTAB (2:260), RHATAB (2:260), ALPTAB (2:260),
20569 & RADTAB (2:260), SKITAB (2:260), HALTAB (2:260),
20570 & SK3TAB (2:260), SK4TAB (2:260), HABTAB (2:260),
20571 & CWSTAB (2:260), EKATAB (2:260), PFATAB (2:260),
20572 & PFRTAB (2:260)
20573 COMMON /FKNGEO/ RADTOT, RADIU1, RADIU0, RAD1O2, SKINDP, HALODP,
20574 & ALPHAL, OMALHL, RADSKN, SKNEFF, CPARWS, RADPRO,
20575 & RADCOR, RADCO2, RADMAX, BIMPTR, RIMPTR, XIMPTR,
20576 & YIMPTR, ZIMPTR, RHOIMT, EKFPRO, PFRPRO, RHOCEN,
20577 & RHOCOR, RHOSKN, EKFCEN (2), PFRCEN (2), EKFBIM,
20578 & PFRBIM, RHOIMP, EKFIMP, PFRIMP, RHOIM2, EKFIM2,
20579 & PFRIM2, RHOIM3, EKFIM3, PFRIM3, VPRWLL, RIMPCT,
20580 & BIMPCT, XIMPCT, YIMPCT, ZIMPCT, RIMPC2, XIMPC2,
20581 & YIMPC2, ZIMPC2, RIMPC3, XIMPC3, YIMPC3, ZIMPC3,
20582 & XBIMPC, YBIMPC, ZBIMPC, CXIMPC, CYIMPC, CZIMPC,
20583 & SQRIMP, SIGMAP, SIGMAN, SIGMAA, RHORED, R0TRAJ,
20584 & R1TRAJ, SBUSED, SBTOT , SBRES , RHOAVE, EKFAVE,
20585 & PFRAVE, AVEBIN, ACOLL , ZCOLL , RADSIG, OPACTY,
20586 & EKECON, PNUCCO, EKEWLL, PPRWLL, PXPROJ, PYPROJ,
20587 & PZPROJ, EKFERM, PNFRMI, PXFERM, PYFERM, PZFERM,
20588 & EKFER2, PNFRM2, PXFER2, PYFER2, PZFER2, EKFER3,
20589 & PNFRM3, PXFER3, PYFER3, PZFER3, RHOMEM, EKFMEM,
20590 & BIMMEM, WLLRED, VPRBIM, POTINC, POTOUT, EEXMIN
20591 COMMON /FKNGE2/ RDTTNC (2), RHONCP (2), RHONC2 (2), RHONC3 (2),
20592 & RHONCT (2), AMOTHR, EKOTHR, AMCREA, EKNCLN,
20593 & EEXDEL, EEXANY, CLMBBR, RDCLMB, BFCLMB, BFCEFF,
20594 & BNPROJ, BNDNUC, DEBRLM, SK4PAR, UBIMPC, VBIMPC,
20595 & WBIMPC, BNDPOT, SIGMAT, SIGABP, SIGABN, WLLRES,
20596 & POTBAR, POTMES, AGEPRI, OPNOPA, ETHRND,
20597 & BNENRG (3), DEFNUC (2), SIGMPR (4), SIGMNU (4),
20598 & SIGPAB (3), SIGNAB (3), HHLP (2), FORTOT (2),
20599 & FPNBLC, DPNBLC, FFTFLG, IFTFLG,
20600 & IPWELL, ITNCMX, KPRIN , NTARGT, KNUCIM, KNUCI2,
20601 & KNUCI3, IEVPRE, ISFCOL, ISFTAR, ISFTA2, ISFTA3,
20602 & NPOTHR, ICOTHR, IBOTHR, NPUMFN, ISTNCL, ITAUCM,
20603 & IABCOU, IADFLG, IGSFLG, IALFLG, ICBFLG, LPREEQ,
20604 & LNPHTC, LPNRHO, LNWRAD, LFTCMP, LFTCAC
20605 COMMON /FKNPWI/ ALMBAR, BIMMAX, SIGGEO, LLLMAX, LLLACT
20606 COMMON /FKNGII/ HOLEXP (2*MXSCIN), XEXPIN (3,0:MXSCIN),
20607 & YEXPIN (3,0:MXSCIN), ZEXPIN (3,0:MXSCIN),
20608 & AGEXIN (0:MXSCIN), RHOEXP (2), EKFEXP, EHLFIX,
20609 & NHLEXP, NHLFIX, IPRTYP, NNCEXI (0:MXSCIN),
20610 & NCEXPI (3,0:MXSCIN), ISEXIN (3,0:MXSCIN),
20611 & ISCTYP (0:MXSCIN), NUSCIN, NEXPEM,
20612 & LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH,
20613 & LNCDCY, LNUSCT
20614 DIMENSION AWSTAB (2:260), SIGMAB (3)
20615 EQUIVALENCE ( DEFPRO, DEFNUC (1) )
20616 EQUIVALENCE ( DEFNEU, DEFNUC (2) )
20617 EQUIVALENCE ( RHOIPP, RHONCP (1) )
20618 EQUIVALENCE ( RHOINP, RHONCP (2) )
20619 EQUIVALENCE ( RHOIP2, RHONC2 (1) )
20620 EQUIVALENCE ( RHOIN2, RHONC2 (2) )
20621 EQUIVALENCE ( RHOIP3, RHONC3 (1) )
20622 EQUIVALENCE ( RHOIN3, RHONC3 (2) )
20623 EQUIVALENCE ( RHOIPT, RHONCT (1) )
20624 EQUIVALENCE ( RHOINT, RHONCT (2) )
20625 EQUIVALENCE ( OMALHL, SK3PAR )
20626 EQUIVALENCE ( ALPHAL, HABPAR )
20627 EQUIVALENCE ( ALPTAB (2), AWSTAB (2) )
20628 EQUIVALENCE ( SIGMPE, SIGMPR (1) )
20629 EQUIVALENCE ( SIGMPC, SIGMPR (2) )
20630 EQUIVALENCE ( SIGMPI, SIGMPR (3) )
20631 EQUIVALENCE ( SIGMPA, SIGMPR (4) )
20632 EQUIVALENCE ( SIGMNE, SIGMNU (1) )
20633 EQUIVALENCE ( SIGMNC, SIGMNU (2) )
20634 EQUIVALENCE ( SIGMNI, SIGMNU (3) )
20635 EQUIVALENCE ( SIGMNA, SIGMNU (4) )
20636 EQUIVALENCE ( SIGMA2, SIGPAB (1) )
20637 EQUIVALENCE ( SIGMA3, SIGPAB (2) )
20638 EQUIVALENCE ( SIGMAS, SIGPAB (3) )
20639 EQUIVALENCE ( SIGPAB (1), SIGMAB (1) )
20640* (original name: NUCLEV)
20641 LOGICAL LCLVSL, LFLVSL, LRLVSL, LEQSBL
20642 COMMON /FKNLEV/ PAENUC (200,2), SHENUC (200,2), DEFRMI (2),
20643 & DEFMAG (2), ENNCLV (160,2), RANCLV (160,2),
20644 & CUMRAD (0:160,2), RUSNUC (2),
20645 & ENPLVL (114), ENNLVL(164), JUSNUC (160,2),
20646 & NTANUC (2), NAVNUC (2), NLSNUC (2), NCONUC (2),
20647 & NSKNUC (2), NHANUC (2), NUSNUC (2), NACNUC (2),
20648 & JMXNUC (2), IPRNUC (3), JPRNUC (3), MAGNUM (8),
20649 & MAGNUC (2), MGSNUC (8,2), MGSSNC (25,2),
20650 & NSBSHL (2), NMNSBS (2), NPRNUC, INUCLV, LCLVSL,
20651 & LFLVSL, LRLVSL, LEQSBL
20652 DIMENSION JUSPRO (160), JUSNEU (160), MGSPRO (8), MGSNEU (8),
20653 & MGSSPR (19) , MGSSNE (25)
20654 EQUIVALENCE ( RUSNUC (1), RUSPRO )
20655 EQUIVALENCE ( RUSNUC (2), RUSNEU )
20656 EQUIVALENCE ( JUSNUC (1,1), JUSPRO (1) )
20657 EQUIVALENCE ( JUSNUC (1,2), JUSNEU (1) )
20658 EQUIVALENCE ( MGSNUC (1,1), MGSPRO (1) )
20659 EQUIVALENCE ( MGSNUC (1,2), MGSNEU (1) )
20660 EQUIVALENCE ( MGSSNC (1,1), MGSSPR (1) )
20661 EQUIVALENCE ( MGSSNC (1,2), MGSSNE (1) )
20662 EQUIVALENCE ( NTANUC (1), NTAPRO )
20663 EQUIVALENCE ( NTANUC (2), NTANEU )
20664 EQUIVALENCE ( NAVNUC (1), NAVPRO )
20665 EQUIVALENCE ( NAVNUC (2), NAVNEU )
20666 EQUIVALENCE ( NLSNUC (1), NLSPRO )
20667 EQUIVALENCE ( NLSNUC (2), NLSNEU )
20668 EQUIVALENCE ( NCONUC (1), NCOPRO )
20669 EQUIVALENCE ( NCONUC (2), NCONEU )
20670 EQUIVALENCE ( NSKNUC (1), NSKPRO )
20671 EQUIVALENCE ( NSKNUC (2), NSKNEU )
20672 EQUIVALENCE ( NHANUC (1), NHAPRO )
20673 EQUIVALENCE ( NHANUC (2), NHANEU )
20674 EQUIVALENCE ( NUSNUC (1), NUSPRO )
20675 EQUIVALENCE ( NUSNUC (2), NUSNEU )
20676 EQUIVALENCE ( NACNUC (1), NACPRO )
20677 EQUIVALENCE ( NACNUC (2), NACNEU )
20678 EQUIVALENCE ( JMXNUC (1), JMXPRO )
20679 EQUIVALENCE ( JMXNUC (2), JMXNEU )
20680 EQUIVALENCE ( MAGNUC (1), MAGPRO )
20681 EQUIVALENCE ( MAGNUC (2), MAGNEU )
20682* (original name: PAREVT)
20683 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
20684 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
20685 PARAMETER ( NALLWP = 39 )
20686 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
20687 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
20688 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
20689 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
20690* (original name: XSEPAR)
20691 COMMON /FKXSEP/ AANXSE (100), BBNXSE (100), CCNXSE (100),
20692 & DDNXSE (100), EENXSE (100), ZZNXSE (100),
20693 & EMNXSE (100), XMNXSE (100),
20694 & AAPXSE (100), BBPXSE (100), CCPXSE (100),
20695 & DDPXSE (100), EEPXSE (100), FFPXSE (100),
20696 & ZZPXSE (100), EMPXSE (100), XMPXSE (100)
20697
20698C---------------------------------------------------------------------
20699**sr 17.5.95
20700* modified for use in DPMJET
20701C WRITE( LUNOUT,'(A,I2)')
20702C & ' *** Reading evaporation and nuclear data from unit: ', NBERTP
20703C REWIND NBERTP
20704 IF (LEVPRT) WRITE(LUNOUT,1000)
20705 1000 FORMAT(/,1X,'BERTTP:',4X,'Initialization of evaporation module',
20706 & /,12X,'------------------------------------',/)
20707 NBERNW = 23
f87dab60 20708CPH OPEN (UNIT=NBERNW,FILE='dpmjet.dat',STATUS='UNKNOWN')
9aaba0d6 20709
20710**sr 17.5.
20711*!!!! changed to be able to read the ASCII !!!!
20712**
20713C A. Ferrari: first of all read isotopic data
20714 READ (NBERNW,*) ISONDX
20715 READ (NBERNW,*) ISOMNM
20716 READ (NBERNW,*) ABUISO
20717C READ (NBERTP) ISONDX
20718C READ (NBERTP) ISOMNM
20719C READ (NBERTP) ABUISO
20720 DO 1 I=1,4
20721C READ (NBERTP) (CRSC(J,I),J=1,600)
20722C A. Ferrari: commented also the dummy read to save disk space
20723C READ (NBERTP)
20724 1 CONTINUE
20725C READ (NBERTP) CS
20726C A. Ferrari: commented also the dummy read to save disk space
20727C READ (NBERTP)
20728C---------------------------------------------------------------------
20729 READ (NBERNW,*) (P0(I),P1(I),P2(I),I=1,1001)
20730 READ (NBERNW,*) IA,IZ
20731 DO 2 I=1,6
20732 FLA(I)=IA(I)
20733 FLZ(I)=IZ(I)
20734 2 CONTINUE
20735 READ (NBERNW,*) RHO,OMEGA
20736 READ (NBERNW,*) EXMASS
20737 READ (NBERNW,*) CAM2
20738 READ (NBERNW,*) CAM3
20739 READ (NBERNW,*) CAM4
20740 READ (NBERNW,*) CAM5
20741 READ (NBERNW,*) ((T(I,J),J=1,7),I=1,3)
20742 DO 3 I=1,7
20743 T(4,I) = ZERZER
20744 3 CONTINUE
20745 READ (NBERNW,*) RMASS
20746 READ (NBERNW,*) ALPH
20747 READ (NBERNW,*) BET
20748 READ (NBERNW,*) INWAPS
20749 READ (NBERNW,*) WAPS
20750 READ (NBERNW,*) T12NUC
20751 READ (NBERNW,*) JSPNUC
20752 READ (NBERNW,*) JPTNUC
20753 READ (NBERNW,*) INWISM
20754 READ (NBERNW,*) IZWISM
20755 READ (NBERNW,*) WAPISM
20756 READ (NBERNW,*) T12ISM
20757 READ (NBERNW,*) JSPISM
20758 READ (NBERNW,*) JPTISM
20759 READ (NBERNW,*) APRIME
20760 IF (LEVPRT)
20761 &WRITE( LUNOUT,'(A)' ) ' *** Evaporation: using 1977 Waps data ***'
20762 READ (NBERNW,*) AHELP , BHELP , LRMSCH, LRD1O2, LTRASP
20763 IF ( ABS (AHELP-ALPHA0) .GT. CSNNRM * ALPHA0 .OR.
20764 & ABS (BHELP-GAMSK0) .GT. CSNNRM * GAMSK0 ) THEN
20765 WRITE (LUNOUT,*)
20766 & ' *** Inconsistent Nuclear Geometry data on file ***'
20767 STOP
20768 END IF
20769 READ (NBERNW,*) RHOTAB, RHATAB, ALPTAB, RADTAB, SKITAB, HALTAB,
20770 & EKATAB, PFATAB, PFRTAB
20771 READ (NBERNW,*) AANXSE, BBNXSE, CCNXSE, DDNXSE, EENXSE, ZZNXSE,
20772 & EMNXSE, XMNXSE
20773 READ (NBERNW,*) AAPXSE, BBPXSE, CCPXSE, DDPXSE, EEPXSE, FFPXSE,
20774 & ZZPXSE, EMPXSE, XMPXSE
20775* Data about Fermi-breakup:
20776 READ (NBERNW,*) IPOSST, MXPDUM, MXADUM, MXNDUM, MXZDUM, IFBSTF
20777 IF ( MXADUM .NE. MXAFBK .OR. MXNDUM .NE. MXNFBK .OR. MXZDUM .NE.
20778 & MXZFBK .OR. MXPDUM .NE. MXPSST ) THEN
20779 WRITE (LUNOUT,*)' *** Inconsistent Fermi BreakUp data',
20780 & ' in the Nuclear Data file ***'
20781 STOP 'STOP:BERTTP-INCONS-FERMI-BREAKUP-DATA'
20782 END IF
20783 READ (NBERNW,*) IFRBKN
20784 READ (NBERNW,*) IFRBKZ
20785 READ (NBERNW,*) IFBKSP
20786 READ (NBERNW,*) IFBKST
20787 READ (NBERNW,*) EEXFBK
20788
20789 CLOSE (UNIT=NBERNW)
20790
20791C READ (NBERTP) (P0(I),P1(I),P2(I),I=1,1001)
20792C READ (NBERTP) IA,IZ
20793C DO 2 I=1,6
20794C FLA(I)=IA(I)
20795C FLZ(I)=IZ(I)
20796C 2 CONTINUE
20797C READ (NBERTP) RHO,OMEGA
20798C READ (NBERTP) EXMASS
20799C READ (NBERTP) CAM2
20800C READ (NBERTP) CAM3
20801C READ (NBERTP) CAM4
20802C READ (NBERTP) CAM5
20803C READ (NBERTP) ((T(I,J),J=1,7),I=1,3)
20804C DO 3 I=1,7
20805C T(4,I) = ZERZER
20806C 3 CONTINUE
20807C READ (NBERTP) RMASS
20808C READ (NBERTP) ALPH
20809C READ (NBERTP) BET
20810C READ (NBERTP) INWAPS
20811C READ (NBERTP) WAPS
20812C READ (NBERTP) T12NUC
20813C READ (NBERTP) JSPNUC
20814C READ (NBERTP) JPTNUC
20815C READ (NBERTP) INWISM
20816C READ (NBERTP) IZWISM
20817C READ (NBERTP) WAPISM
20818C READ (NBERTP) T12ISM
20819C READ (NBERTP) JSPISM
20820C READ (NBERTP) JPTISM
20821C READ (NBERTP) APRIME
20822C WRITE( LUNOUT,'(A)' ) ' *** Evaporation: using 1977 Waps data ***'
20823C READ (NBERTP) AHELP , BHELP , LRMSCH, LRD1O2, LTRASP
20824C IF ( ABS (AHELP-ALPHA0) .GT. CSNNRM * ALPHA0 .OR.
20825C & ABS (BHELP-GAMSK0) .GT. CSNNRM * GAMSK0 ) THEN
20826C WRITE (LUNOUT,*)
20827C & ' *** Inconsistent Nuclear Geometry data on file ***'
20828C STOP
20829C END IF
20830C READ (NBERTP) RHOTAB, RHATAB, ALPTAB, RADTAB, SKITAB, HALTAB,
20831C & EKATAB, PFATAB, PFRTAB
20832C READ (NBERTP) AANXSE, BBNXSE, CCNXSE, DDNXSE, EENXSE, ZZNXSE,
20833C & EMNXSE, XMNXSE
20834C READ (NBERTP) AAPXSE, BBPXSE, CCPXSE, DDPXSE, EEPXSE, FFPXSE,
20835C & ZZPXSE, EMPXSE, XMPXSE
20836* Data about Fermi-breakup:
20837C READ (NBERTP) IPOSST, MXPDUM, MXADUM, MXNDUM, MXZDUM, IFBSTF
20838C IF ( MXADUM .NE. MXAFBK .OR. MXNDUM .NE. MXNFBK .OR. MXZDUM .NE.
20839C & MXZFBK .OR. MXPDUM .NE. MXPSST ) THEN
20840C WRITE (LUNOUT,*)' *** Inconsistent Fermi BreakUp data',
20841C & ' in the Nuclear Data file ***'
20842C STOP 'STOP:BERTTP-INCONS-FERMI-BREAKUP-DATA'
20843C END IF
20844C READ (NBERTP) IFRBKN
20845C READ (NBERTP) IFRBKZ
20846C READ (NBERTP) IFBKSP
20847C READ (NBERTP) IFBKST
20848C READ (NBERTP) EEXFBK
20849C CLOSE (UNIT=NBERTP)
20850 DO 100 JZ = 1, 130
20851 SHENUC ( JZ, 1 ) = EMVGEV * ( CAM2 (JZ) + CAM4 (JZ) )
20852 100 CONTINUE
20853 DO 200 JA = 1, 200
20854 SHENUC ( JA, 2 ) = EMVGEV * ( CAM3 (JA) + CAM5 (JA) )
20855 200 CONTINUE
20856 CALL DT_STALIN
20857 IF ( ILVMOD .LE. 0 ) THEN
20858 ILVMOD = IB0
20859 ELSE
20860 IB0 = ILVMOD
20861 END IF
20862 IF ( LLVMOD ) THEN
20863 DO 300 JZ = 1, IZCOOK
20864 CAM4 (JZ) = PZCOOK (JZ)
20865 300 CONTINUE
20866 DO 400 JN = 1, INCOOK
20867 CAM5 (JN) = PNCOOK (JZ)
20868 400 CONTINUE
20869 END IF
20870**sr
20871 IF (LEVPRT) THEN
20872 WRITE (LUNOUT,*)
20873 IF ( ILVMOD .EQ. 1 ) THEN
20874 WRITE (LUNOUT,*)
20875 & ' **** Standard EVAP T=0 level density used ****'
20876 ELSE IF ( ILVMOD .EQ. 2 ) THEN
20877 WRITE (LUNOUT,*)
20878 & ' **** Gilbert & Cameron T=0 N,Z-dep. level density used ****'
20879 ELSE IF ( ILVMOD .EQ. 3 ) THEN
20880 WRITE (LUNOUT,*)
20881 & ' **** Julich A-dependent level density used ****'
20882 ELSE IF ( ILVMOD .EQ. 4 ) THEN
20883 WRITE (LUNOUT,*)
20884 & ' **** Brancazio & Cameron T=0 N,Z-dep. level density used',
20885 & ' ****'
20886 ELSE
20887 WRITE (LUNOUT,*)
20888 & ' **** Unknown T=0 level density option requested ****'
20889 STOP 'BERTTP-ILVMOD'
20890 END IF
20891 IF ( JLVMOD .LE. 0 ) THEN
20892 GAMIGN = ZERZER
20893 WRITE (LUNOUT,*)
20894 & ' **** No Excitation en. dependence for level densities ****'
20895 ELSE IF ( JLVMOD .EQ. 1 ) THEN
20896 WRITE (LUNOUT,*)
20897 & ' **** Ignyatuk (1975, 1st) level density en. dep. used ****'
20898 WRITE (LUNOUT,*)
20899 & ' **** with Ignyatuk (1975, 1st) set of parameters for T=oo',
20900 & ' ****'
20901 GAMIGN = 0.054D+00
20902 BETIGN = -6.3 D-05
20903 ALPIGN = 0.154D+00
20904 POWIGN = ZERZER
20905 ELSE IF ( JLVMOD .EQ. 2 ) THEN
20906 WRITE (LUNOUT,*)
20907 & ' **** Ignyatuk (1975, 1st) level density en. dep. used ****'
20908 WRITE (LUNOUT,*)
20909 & ' **** with UNKNOWN set of parameters for T=oo ****'
20910 STOP 'BERTTP-JLVMOD'
20911 ELSE IF ( JLVMOD .EQ. 3 ) THEN
20912 WRITE (LUNOUT,*)
20913 & ' **** Ignyatuk (1975, 1st) level density en. dep. used ****'
20914 WRITE (LUNOUT,*)
20915 & ' **** with UNKNOWN set of parameters for T=oo ****'
20916 STOP 'BERTTP-JLVMOD'
20917 ELSE IF ( JLVMOD .EQ. 4 ) THEN
20918 WRITE (LUNOUT,*)
20919 & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****'
20920 WRITE (LUNOUT,*)
20921 & ' **** with Ignyatuk (1975, 2nd) set of parameters for T=oo',
20922 & ' ****'
20923 GAMIGN = 0.054D+00
20924 BETIGN = 0.162D+00
20925 ALPIGN = 0.114D+00
20926 POWIGN = -ONETHI
20927 ELSE IF ( JLVMOD .EQ. 5 ) THEN
20928 WRITE (LUNOUT,*)
20929 & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****'
20930 WRITE (LUNOUT,*)
20931 & ' **** with Iljinov & Mebel 1st set of parameters for T=oo****'
20932 GAMIGN = 0.051D+00
20933 BETIGN = 0.098D+00
20934 ALPIGN = 0.114D+00
20935 POWIGN = -ONETHI
20936 ELSE IF ( JLVMOD .EQ. 6 ) THEN
20937 WRITE (LUNOUT,*)
20938 & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****'
20939 WRITE (LUNOUT,*)
20940 & ' **** with Iljinov & Mebel 2nd set of parameters for T=oo****'
20941 GAMIGN = -0.46D+00
20942 BETIGN = 0.107D+00
20943 ALPIGN = 0.111D+00
20944 POWIGN = -ONETHI
20945 ELSE IF ( JLVMOD .EQ. 7 ) THEN
20946 WRITE (LUNOUT,*)
20947 & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****'
20948 WRITE (LUNOUT,*)
20949 & ' **** with Iljinov & Mebel 3rd set of parameters for T=oo****'
20950 GAMIGN = 0.059D+00
20951 BETIGN = 0.257D+00
20952 ALPIGN = 0.072D+00
20953 POWIGN = -ONETHI
20954 ELSE IF ( JLVMOD .EQ. 8 ) THEN
20955 WRITE (LUNOUT,*)
20956 & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****'
20957 WRITE (LUNOUT,*)
20958 & ' **** with Iljinov & Mebel 4th set of parameters for T=oo****'
20959 GAMIGN = -0.37D+00
20960 BETIGN = 0.229D+00
20961 ALPIGN = 0.077D+00
20962 POWIGN = -ONETHI
20963 ELSE
20964 WRITE (LUNOUT,*)
20965 & ' **** Unknown T=oo level density option requested ****'
20966 STOP 'BERTTP-JLVMOD'
20967 END IF
20968 IF ( LLVMOD ) THEN
20969 WRITE (LUNOUT,*)
20970 & ' **** Cook''s modified pairing energy used ****'
20971 ELSE
20972 WRITE (LUNOUT,*)
20973 & ' **** Original Gilbert/Cameron pairing energy used ****'
20974 END IF
20975 ENDIF
20976**
20977
20978 ILVMOD = IB0
20979 DO 500 JZ = 1, 130
20980 PAENUC ( JZ, 1 ) = EMVGEV * CAM4 (JZ)
20981 500 CONTINUE
20982 DO 600 JA = 1, 200
20983 PAENUC ( JA, 2 ) = EMVGEV * CAM5 (JA)
20984 600 CONTINUE
20985 RETURN
20986 END
20987
20988*$ CREATE DT_EVEVAP.FOR
20989*COPY DT_EVEVAP
20990*
20991*====evevap============================================================*
20992*
20993 SUBROUTINE DT_EVEVAP(WE)
20994
20995 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20996 SAVE
20997 PARAMETER ( LINP = 10 ,
20998 & LOUT = 6 ,
20999 & LDAT = 9 )
21000
21001* flags for input different options
21002 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
21003 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
21004 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
21005
21006 LEVAPO = .FALSE.
21007
21008 RETURN
21009 END
21010
21011*$ CREATE DT_FRBKIN.FOR
21012*COPY DT_FRBKIN
21013*
21014*====frbkin============================================================*
21015*
21016 SUBROUTINE DT_FRBKIN(LDUM1,LDUM2)
21017
21018 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21019 SAVE
21020 PARAMETER ( LINP = 10 ,
21021 & LOUT = 6 ,
21022 & LDAT = 9 )
21023
21024 LOGICAL LDUM1,LDUM2
21025
21026 RETURN
21027 END
21028
21029*$ CREATE DT_EXPLOD.FOR
21030*COPY DT_EXPLOD
21031*
21032*=== explod ===========================================================*
21033*
21034 SUBROUTINE DT_EXPLOD( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
21035 & PYEXPL, PZEXPL )
21036
21037 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21038 SAVE
21039
21040 DIMENSION PXEXPL (NPEXPL), PYEXPL (NPEXPL), PZEXPL (NPEXPL),
21041 & ETEXPL (NPEXPL), AMEXPL (NPEXPL)
21042
21043 RETURN
21044 END
21045
21046************************************************************************
21047* *
21048* DPMJET 3.0: cross section routines *
21049* *
21050************************************************************************
21051*
21052*
21053* SUBROUTINE DT_SHNDIF
21054* diffractive cross sections (all energies)
21055* SUBROUTINE DT_PHOXS
21056* total and inel. cross sections from PHOJET interpol. tables
21057* SUBROUTINE DT_XSHN
21058* total and el. cross sections for all energies
21059* SUBROUTINE DT_SIHNAB
21060* pion 2-nucleon absorption cross sections
21061* SUBROUTINE DT_SIGEMU
21062* cross section for target "compounds"
21063* SUBROUTINE DT_SIGGA
21064* photon nucleus cross sections
21065* SUBROUTINE DT_SIGGAT
21066* photon nucleus cross sections from tables
21067* SUBROUTINE DT_SANO
21068* anomalous hard photon-nucleon cross sections from tables
21069* SUBROUTINE DT_SIGGP
21070* photon nucleon cross sections
21071* SUBROUTINE DT_SIGVEL
21072* quasi-elastic vector meson prod. cross sections
21073* DOUBLE PRECISION FUNCTION DT_SIGVP
21074* sigma_VN(tilde)
21075* DOUBLE PRECISION FUNCTION DT_RRM2
21076* DOUBLE PRECISION FUNCTION DT_RM2
21077* DOUBLE PRECISION FUNCTION DT_SAM2
21078* SUBROUTINE DT_CKMT
21079* SUBROUTINE DT_CKMTX
21080* SUBROUTINE DT_PDF0
21081* SUBROUTINE DT_CKMTQ0
21082* SUBROUTINE DT_CKMTDE
21083* SUBROUTINE DT_CKMTPR
21084* FUNCTION DT_CKMTFF
21085*
21086* SUBROUTINE DT_FLUINI
21087* total nucleon cross section fluctuation treatment
21088*
21089* SUBROUTINE DT_SIGTBL
21090* pre-tabulation of low-energy elastic x-sec. using SIHNEL
21091* SUBROUTINE DT_XSTABL
21092* service routines
21093*
21094*
21095*$ CREATE DT_SHNDIF.FOR
21096*COPY DT_SHNDIF
21097*
21098*===shndif===============================================================*
21099*
21100 SUBROUTINE DT_SHNDIF(ECM,KPROJ,KTARG,SIGDIF,SIGDIH)
21101
21102**********************************************************************
21103* Single diffractive hadron-nucleon cross sections *
21104* S.Roesler 14/1/93 *
21105* *
21106* The cross sections are calculated from extrapolated single *
21107* diffractive antiproton-proton cross sections (DTUJET92) using *
21108* scaling relations between total and single diffractive cross *
21109* sections. *
21110**********************************************************************
21111
21112 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21113 SAVE
21114 PARAMETER (ZERO=0.0D0)
21115
21116* particle properties (BAMJET index convention)
21117 CHARACTER*8 ANAME
21118 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21119 & IICH(210),IIBAR(210),K1(210),K2(210)
21120*
21121 CSD1 = 4.201483727D0
21122 CSD4 = -0.4763103556D-02
21123 CSD5 = 0.4324148297D0
21124*
21125 CHMSD1 = 0.8519297242D0
21126 CHMSD4 = -0.1443076599D-01
21127 CHMSD5 = 0.4014954567D0
21128*
21129 EPN = (ECM**2 -AAM(KPROJ)**2 -AAM(KTARG)**2)/(2.0D0*AAM(KTARG))
21130 PPN = SQRT((EPN-AAM(KPROJ))*(EPN+AAM(KPROJ)))
21131*
21132 SDIAPP = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
21133 SHMSD = CHMSD1+CHMSD4*LOG(PPN)**2+CHMSD5*LOG(PPN)
21134 FRAC = SHMSD/SDIAPP
21135*
21136 GOTO( 10, 20,999,999,999,999,999, 10, 20,999,
21137 & 999, 20, 20, 20, 20, 20, 10, 20, 20, 10,
21138 & 10, 10, 20, 20, 20) KPROJ
21139*
21140 10 CONTINUE
21141*---------------------------- p - p , n - p , sigma0+- - p ,
21142* Lambda - p
21143 CSD1 = 6.004476070D0
21144 CSD4 = -0.1257784606D-03
21145 CSD5 = 0.2447335720D0
21146 SIGDIF = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
21147 SIGDIH = FRAC*SIGDIF
21148 RETURN
21149*
21150 20 CONTINUE
21151*
21152 KPSCAL = 2
21153 KTSCAL = 1
21154C F = SDIAPP/DT_SHNTOT(KPSCAL,KTSCAL,ECM,ZERO)
21155 DUMZER = ZERO
21156 CALL DT_XSHN(KPSCAL,KTSCAL,DUMZER,ECM,SIGTO,SIGEL)
21157 F = SDIAPP/SIGTO
21158 KT = 1
21159C SIGDIF = DT_SHNTOT(KPROJ,KT,ECM,ZERO)*F
21160 CALL DT_XSHN(KPROJ,KT,DUMZER,ECM,SIGTO,SIGEL)
21161 SIGDIF = SIGTO*F
21162 SIGDIH = FRAC*SIGDIF
21163 RETURN
21164*
21165 999 CONTINUE
21166*-------------------------- leptons..
21167 SIGDIF = 1.D-10
21168 SIGDIH = 1.D-10
21169 RETURN
21170 END
21171
21172*$ CREATE DT_PHOXS.FOR
21173*COPY DT_PHOXS
21174*
21175*===phoxs================================================================*
21176*
21177 SUBROUTINE DT_PHOXS(KPROJ,KTARG,ECM,PLAB,STOT,SINE,SDIF1,BEL,MODE)
21178
21179************************************************************************
21180* Total/inelastic proton-nucleon cross sections taken from PHOJET- *
21181* interpolation tables. *
21182* This version dated 05.11.97 is written by S. Roesler *
21183************************************************************************
21184
21185 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21186 SAVE
21187
21188 PARAMETER ( LINP = 10 ,
21189 & LOUT = 6 ,
21190 & LDAT = 9 )
21191 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21192 PARAMETER (TWOPI = 6.283185307179586454D+00,
21193 & PI = TWOPI/TWO,
21194 & GEV2MB = 0.38938D0)
21195
21196 LOGICAL LFIRST
21197 DATA LFIRST /.TRUE./
21198
21199* nucleon-nucleon event-generator
21200 CHARACTER*8 CMODEL
21201 LOGICAL LPHOIN
21202 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21203* particle properties (BAMJET index convention)
21204 CHARACTER*8 ANAME
21205 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21206 & IICH(210),IIBAR(210),K1(210),K2(210)
21207
21208**PHOJET105a
21209C PARAMETER (IEETAB=10)
21210C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
21211**PHOJET110
21212C energy-interpolation table
21213 INTEGER IEETA2
21214 PARAMETER ( IEETA2 = 20 )
21215 INTEGER ISIMAX
21216 DOUBLE PRECISION SIGTAB,SIGECM
21217 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
21218**
21219
21220 IF ((MCGENE.NE.2).AND.(MODE.NE.1)) THEN
21221 WRITE(LOUT,*) MCGENE
21222 1000 FORMAT(1X,'PHOXS: warning! PHOJET not initialized (',I2,')')
21223 STOP
21224 ENDIF
21225
21226 IF (ECM.LE.ZERO) THEN
21227 EPN = SQRT(AAM(KPROJ)**2+PLAB**2)
21228 ECM = SQRT(AAM(KPROJ)**2+AAM(KTARG)**2+2.0D0*EPN*AAM(KTARG))
21229 ENDIF
21230
21231 IF (MODE.EQ.1) THEN
21232* DL
21233 DELDL = 0.0808D0
21234 EPSDL = -0.4525D0
21235 S = ECM*ECM
21236 STOT = 21.7D0*S**DELDL+56.08D0*S**EPSDL
21237 ALPHAP= 0.25D0
21238 BEL = 8.5D0+2.D0*ALPHAP*LOG(S)
21239 SIGEL = STOT**2/(16.D0*PI*BEL*GEV2MB)
21240 SINE = STOT-SIGEL
21241 SDIF1 = ZERO
21242 ELSE
21243* Phojet
21244 IP = 1
21245 IF(ECM.LE.SIGECM(IP,1)) THEN
21246 I1 = 1
21247 I2 = 1
21248 ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
21249 DO 1 I=2,ISIMAX
21250 IF (ECM.LE.SIGECM(IP,I)) GOTO 2
21251 1 CONTINUE
21252 2 CONTINUE
21253 I1 = I-1
21254 I2 = I
21255 ELSE
21256 IF (LFIRST) THEN
21257 WRITE(LOUT,'(/1X,A,2E12.3)')
21258 & 'PHOXS: warning! energy above initialization limit (',
21259 & ECM,SIGECM(IP,ISIMAX)
21260 LFIRST = .FALSE.
21261 ENDIF
21262 I1 = ISIMAX
21263 I2 = ISIMAX
21264 ENDIF
21265 FAC2 = ZERO
21266 IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
21267 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
21268 FAC1 = ONE-FAC2
21269 STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
21270 SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
21271 SDIF1 = FAC2*(SIGTAB(IP,30,I2)+SIGTAB(IP,32,I2))+
21272 & FAC1*(SIGTAB(IP,30,I1)+SIGTAB(IP,32,I1))
21273 BEL = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
21274 ENDIF
21275
21276 RETURN
21277 END
21278
21279*$ CREATE DT_XSHN.FOR
21280*COPY DT_XSHN
21281*
21282*===xshn===============================================================*
21283*
21284 SUBROUTINE DT_XSHN(IP,IT,PL,ECM,STOT,SELA)
21285
21286************************************************************************
21287* Total and elastic hadron-nucleon cross section. *
21288* Below 500GeV cross sections are based on the '98 data compilation *
21289* of the PDG. At higher energies PHOJET results are used (patched to *
21290* the low energy data at 500GeV). *
21291* IP projectile index (BAMJET numbering scheme) *
21292* (should be in the range 1..25) *
21293* IT target index (BAMJET numbering scheme) *
21294* (1 = proton, 8 = neutron) *
21295* PL laboratory momentum *
21296* ECM cm. energy (ignored if PL>0) *
21297* STOT total cross section *
21298* SELA elastic cross section *
21299* Last change: 24.4.99 by S. Roesler *
21300************************************************************************
21301
21302 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21303 SAVE
21304
21305 PARAMETER ( LINP = 10 ,
21306 & LOUT = 6 ,
21307 & LDAT = 9 )
21308 PARAMETER (ZERO=0.0D0,ONE=1.0D0)
21309
21310 PARAMETER (NPOIN1 = 54, NPOIN2 = 8,
21311 & PLABLO = 0.1D0, PTHRE = 5.0D0, PLABHI = 500.0D0)
21312 PARAMETER (NPOINT = NPOIN1+NPOIN2+1)
21313
21314 LOGICAL LFIRST
21315* particle properties (BAMJET index convention)
21316 CHARACTER*8 ANAME
21317 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21318 & IICH(210),IIBAR(210),K1(210),K2(210)
21319* nucleon-nucleon event-generator
21320 CHARACTER*8 CMODEL
21321 LOGICAL LPHOIN
21322 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21323**PHOJET105a
21324C PARAMETER (IEETAB=10)
21325C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
21326**PHOJET110
21327C energy-interpolation table
21328 INTEGER IEETA2
21329 PARAMETER ( IEETA2 = 20 )
21330 INTEGER ISIMAX
21331 DOUBLE PRECISION SIGTAB,SIGECM
21332 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
21333
21334 DIMENSION APL(NPOINT),ASIGTO(10,NPOINT),ASIGEL(10,NPOINT)
21335 DIMENSION IDXDAT(25,2)
21336*
21337 DATA APL /
21338 &-1.000,-0.969,-0.937,-0.906,-0.874,-0.843,-0.811,-0.780,-0.748,
21339 &-0.717,-0.685,-0.654,-0.622,-0.591,-0.560,-0.528,-0.497,-0.465,
21340 &-0.434,-0.402,-0.371,-0.339,-0.308,-0.276,-0.245,-0.213,-0.182,
21341 &-0.151,-0.119,-0.088,-0.056,-0.025, 0.007, 0.038, 0.070, 0.101,
21342 & 0.133, 0.164, 0.196, 0.227, 0.258, 0.290, 0.321, 0.353, 0.384,
21343 & 0.416, 0.447, 0.479, 0.510, 0.542, 0.573, 0.605, 0.636, 0.668,
21344 & 0.699, 0.949, 1.199, 1.449, 1.699, 1.949, 2.199, 2.449, 2.699/
21345*
21346* total cross sections:
21347* p p
21348 DATA (ASIGTO(1,K),K=1,NPOINT) /
21349 & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
21350 & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
21351 & 1.577, 1.518, 1.462, 1.420, 1.393, 1.375, 1.363, 1.356, 1.352,
21352 & 1.350, 1.351, 1.359, 1.381, 1.410, 1.444, 1.487, 1.544, 1.596,
21353 & 1.650, 1.672, 1.676, 1.677, 1.677, 1.675, 1.675, 1.669, 1.664,
21354 & 1.658, 1.653, 1.645, 1.640, 1.634, 1.630, 1.625, 1.620, 1.617,
21355 & 1.614, 1.602, 1.594, 1.589, 1.581, 1.583, 1.588, 1.596, 1.603/
21356* pbar p
21357 DATA (ASIGTO(2,K),K=1,NPOINT) /
21358 & 2.778, 2.759, 2.739, 2.718, 2.697, 2.675, 2.651, 2.626, 2.598,
21359 & 2.569, 2.537, 2.502, 2.471, 2.443, 2.420, 2.389, 2.361, 2.329,
21360 & 2.313, 2.304, 2.268, 2.244, 2.222, 2.212, 2.178, 2.162, 2.151,
21361 & 2.132, 2.109, 2.097, 2.089, 2.078, 2.063, 2.049, 2.035, 2.024,
21362 & 2.014, 2.004, 1.993, 1.981, 1.970, 1.958, 1.946, 1.933, 1.921,
21363 & 1.909, 1.894, 1.885, 1.871, 1.854, 1.836, 1.825, 1.816, 1.802,
21364 & 1.790, 1.744, 1.694, 1.663, 1.642, 1.614, 1.623, 1.623, 1.630/
21365* n p
21366 DATA (ASIGTO(3,K),K=1,NPOINT) /
21367 & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
21368 & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
21369 & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
21370 & 1.547, 1.534, 1.526, 1.522, 1.520, 1.525, 1.536, 1.550, 1.566,
21371 & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
21372 & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
21373 & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
21374* pi+ p
21375 DATA (ASIGTO(4,K),K=1,NPOINT) /
21376 & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
21377 & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
21378 & 2.001, 1.875, 1.801, 1.665, 1.609, 1.484, 1.412, 1.334, 1.195,
21379 & 1.160, 1.166, 1.208, 1.309, 1.356, 1.394, 1.406, 1.419, 1.473,
21380 & 1.540, 1.596, 1.570, 1.533, 1.516, 1.484, 1.471, 1.478, 1.492,
21381 & 1.497, 1.491, 1.479, 1.465, 1.453, 1.449, 1.450, 1.444, 1.428,
21382 & 1.422, 1.406, 1.384, 1.369, 1.364, 1.369, 1.374, 1.388, 1.395/
21383* pi- p
21384 DATA (ASIGTO(5,K),K=1,NPOINT) /
21385 & 0.458, 0.540, 0.626, 0.718, 0.819, 0.933, 1.063, 1.208, 1.226,
21386 & 1.436, 1.470, 1.594, 1.708, 1.786, 1.852, 1.836, 1.763, 1.679,
21387 & 1.590, 1.492, 1.445, 1.426, 1.423, 1.433, 1.473, 1.506, 1.547,
21388 & 1.660, 1.671, 1.545, 1.591, 1.687, 1.808, 1.656, 1.582, 1.543,
21389 & 1.562, 1.560, 1.537, 1.540, 1.549, 1.557, 1.557, 1.551, 1.535,
21390 & 1.527, 1.511, 1.510, 1.507, 1.500, 1.491, 1.483, 1.478, 1.468,
21391 & 1.463, 1.435, 1.408, 1.394, 1.384, 1.380, 1.383, 1.393, 1.411/
21392* K+ p
21393 DATA (ASIGTO(6,K),K=1,NPOINT) /
21394 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
21395 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
21396 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.096, 1.095,
21397 & 1.098, 1.105, 1.111, 1.139, 1.169, 1.209, 1.248, 1.259, 1.268,
21398 & 1.262, 1.257, 1.254, 1.252, 1.250, 1.249, 1.246, 1.244, 1.244,
21399 & 1.243, 1.240, 1.238, 1.237, 1.236, 1.235, 1.235, 1.236, 1.236,
21400 & 1.236, 1.233, 1.238, 1.248, 1.257, 1.272, 1.292, 1.311, 1.336/
21401* K- p
21402 DATA (ASIGTO(7,K),K=1,NPOINT) /
21403 & 2.003, 2.002, 2.001, 2.000, 1.999, 1.998, 1.998, 1.997, 1.997,
21404 & 1.996, 1.995, 1.993, 1.990, 1.992, 1.974, 1.912, 1.865, 1.847,
21405 & 1.896, 1.950, 1.827, 1.681, 1.637, 1.616, 1.589, 1.545, 1.543,
21406 & 1.532, 1.603, 1.604, 1.616, 1.658, 1.700, 1.658, 1.595, 1.508,
21407 & 1.493, 1.514, 1.531, 1.523, 1.501, 1.479, 1.474, 1.467, 1.463,
21408 & 1.450, 1.444, 1.435, 1.426, 1.424, 1.423, 1.415, 1.401, 1.396,
21409 & 1.384, 1.364, 1.330, 1.313, 1.310, 1.309, 1.317, 1.329, 1.338/
21410* K+ n
21411 DATA (ASIGTO(8,K),K=1,NPOINT) /
21412 & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21413 & 0.631, 0.675, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21414 & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.102, 1.125, 1.147,
21415 & 1.168, 1.187, 1.205, 1.224, 1.248, 1.279, 1.315, 1.324, 1.301,
21416 & 1.285, 1.279, 1.274, 1.273, 1.272, 1.271, 1.267, 1.263, 1.261,
21417 & 1.259, 1.256, 1.252, 1.247, 1.244, 1.241, 1.240, 1.240, 1.240,
21418 & 1.241, 1.243, 1.245, 1.253, 1.265, 1.275, 1.293, 1.314, 1.342/
21419* K- n
21420 DATA (ASIGTO(9,K),K=1,NPOINT) /
21421 & 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778,
21422 & 1.778, 1.778, 1.778, 1.778, 1.778, 1.779, 1.779, 1.778, 1.773,
21423 & 1.765, 1.746, 1.703, 1.646, 1.561, 1.488, 1.454, 1.437, 1.437,
21424 & 1.458, 1.505, 1.561, 1.588, 1.593, 1.581, 1.551, 1.500, 1.454,
21425 & 1.427, 1.408, 1.390, 1.372, 1.361, 1.356, 1.351, 1.347, 1.343,
21426 & 1.341, 1.340, 1.338, 1.337, 1.335, 1.334, 1.332, 1.331, 1.330,
21427 & 1.330, 1.313, 1.303, 1.288, 1.288, 1.297, 1.305, 1.320, 1.342/
21428* Lambda p
21429 DATA (ASIGTO(10,K),K=1,NPOINT) /
21430 & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21431 & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.629,
21432 & 1.599, 1.576, 1.558, 1.543, 1.530, 1.520, 1.512, 1.505, 1.499,
21433 & 1.495, 1.495, 1.497, 1.504, 1.514, 1.525, 1.536, 1.550, 1.567,
21434 & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
21435 & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
21436 & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
21437*
21438* elastic cross sections:
21439* p p
21440 DATA (ASIGEL(1,K),K=1,NPOINT) /
21441 & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
21442 & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
21443 & 1.577, 1.518, 1.462, 1.420, 1.393, 1.374, 1.360, 1.353, 1.350,
21444 & 1.351, 1.356, 1.362, 1.369, 1.376, 1.384, 1.385, 1.399, 1.397,
21445 & 1.389, 1.385, 1.379, 1.366, 1.358, 1.344, 1.320, 1.294, 1.275,
21446 & 1.260, 1.248, 1.235, 1.219, 1.199, 1.172, 1.144, 1.126, 1.115,
21447 & 1.104, 1.013, 0.962, 0.905, 0.869, 0.845, 0.846, 0.850, 0.868/
21448* pbar p
21449 DATA (ASIGEL(2,K),K=1,NPOINT) /
21450 & 1.987, 1.985, 1.983, 1.980, 1.978, 1.975, 1.971, 1.968, 1.963,
21451 & 1.958, 1.951, 1.944, 1.935, 1.925, 1.914, 1.902, 1.889, 1.875,
21452 & 1.859, 1.845, 1.834, 1.817, 1.792, 1.769, 1.754, 1.738, 1.720,
21453 & 1.702, 1.688, 1.676, 1.667, 1.659, 1.652, 1.645, 1.640, 1.636,
21454 & 1.620, 1.591, 1.562, 1.546, 1.540, 1.524, 1.496, 1.475, 1.457,
21455 & 1.429, 1.402, 1.373, 1.344, 1.330, 1.306, 1.294, 1.265, 1.228,
21456 & 1.204, 1.086, 0.977, 0.933, 0.914, 0.850, 0.862, 0.848, 0.845/
21457* n p
21458 DATA (ASIGEL(3,K),K=1,NPOINT) /
21459 & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
21460 & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
21461 & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
21462 & 1.544, 1.527, 1.514, 1.504, 1.495, 1.486, 1.476, 1.466, 1.454,
21463 & 1.440, 1.425, 1.409, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21464 & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21465 & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21466* pi+ p
21467 DATA (ASIGEL(4,K),K=1,NPOINT) /
21468 & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
21469 & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
21470 & 2.001, 1.875, 1.801, 1.664, 1.610, 1.479, 1.423, 1.299, 1.166,
21471 & 1.097, 1.020, 0.958, 0.914, 1.013, 1.088, 1.153, 1.167, 1.235,
21472 & 1.240, 1.237, 1.202, 1.135, 1.090, 1.026, 0.975, 0.941, 0.904,
21473 & 0.894, 0.884, 0.862, 0.850, 0.845, 0.827, 0.805, 0.789, 0.776,
21474 & 0.763, 0.686, 0.626, 0.562, 0.505, 0.518, 0.525, 0.528, 0.528/
21475* pi- p
21476 DATA (ASIGEL(5,K),K=1,NPOINT) /
21477 & 0.266, 0.278, 0.294, 0.320, 0.360, 0.419, 0.503, 0.608, 0.727,
21478 & 0.850, 0.968, 1.071, 1.167, 1.305, 1.369, 1.404, 1.446, 1.217,
21479 & 1.112, 1.071, 1.014, 1.002, 0.996, 1.008, 1.070, 1.126, 1.209,
21480 & 1.300, 1.281, 1.188, 1.156, 1.341, 1.423, 1.314, 1.171, 1.140,
21481 & 1.106, 1.071, 1.011, 1.037, 1.026, 1.024, 0.988, 0.953, 0.895,
21482 & 0.894, 0.880, 0.871, 0.864, 0.853, 0.837, 0.820, 0.809, 0.800,
21483 & 0.782, 0.674, 0.612, 0.530, 0.521, 0.528, 0.524, 0.542, 0.569/
21484* K+ p
21485 DATA (ASIGEL(6,K),K=1,NPOINT) /
21486 & 1.064, 1.065, 1.065, 1.066, 1.066, 1.066, 1.066, 1.066, 1.066,
21487 & 1.065, 1.064, 1.063, 1.062, 1.062, 1.062, 1.064, 1.066, 1.070,
21488 & 1.076, 1.082, 1.088, 1.096, 1.103, 1.104, 1.104, 1.102, 1.093,
21489 & 1.087, 1.084, 1.079, 1.075, 1.067, 1.058, 1.040, 1.029, 1.012,
21490 & 1.003, 0.985, 0.935, 0.909, 0.880, 0.846, 0.790, 0.771, 0.759,
21491 & 0.743, 0.718, 0.681, 0.666, 0.645, 0.622, 0.606, 0.594, 0.584,
21492 & 0.575, 0.513, 0.453, 0.403, 0.356, 0.365, 0.389, 0.430, 0.477/
21493* K- p
21494 DATA (ASIGEL(7,K),K=1,NPOINT) /
21495 & 1.941, 1.936, 1.931, 1.926, 1.919, 1.912, 1.903, 1.892, 1.878,
21496 & 1.863, 1.844, 1.821, 1.791, 1.755, 1.713, 1.666, 1.615, 1.561,
21497 & 1.533, 1.531, 1.518, 1.511, 1.452, 1.339, 1.265, 1.233, 1.188,
21498 & 1.184, 1.236, 1.316, 1.333, 1.336, 1.333, 1.277, 1.216, 1.077,
21499 & 1.018, 0.912, 0.926, 0.920, 0.910, 0.894, 0.830, 0.825, 0.800,
21500 & 0.788, 0.747, 0.703, 0.707, 0.689, 0.643, 0.633, 0.635, 0.618,
21501 & 0.584, 0.579, 0.461, 0.403, 0.405, 0.399, 0.408, 0.418, 0.413/
21502* K+ n
21503 DATA (ASIGEL(8,K),K=1,NPOINT) /
21504 & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21505 & 0.631, 0.676, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21506 & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.103, 1.126, 1.148,
21507 & 1.168, 1.187, 1.205, 1.223, 1.248, 1.282, 1.269, 1.185, 1.111,
21508 & 1.063, 1.031, 0.998, 0.964, 0.928, 0.889, 0.849, 0.814, 0.785,
21509 & 0.760, 0.738, 0.720, 0.703, 0.688, 0.674, 0.660, 0.648, 0.635,
21510 & 0.624, 0.536, 0.473, 0.442, 0.428, 0.428, 0.436, 0.453, 0.477/
21511* K- n
21512 DATA (ASIGEL(9,K),K=1,NPOINT) /
21513 & 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613,
21514 & 1.613, 1.613, 1.613, 1.612, 1.613, 1.614, 1.614, 1.612, 1.606,
21515 & 1.593, 1.564, 1.498, 1.402, 1.240, 1.071, 0.977, 0.922, 0.914,
21516 & 0.961, 1.077, 1.214, 1.271, 1.290, 1.281, 1.217, 1.096, 0.979,
21517 & 0.896, 0.822, 0.736, 0.655, 0.608, 0.591, 0.580, 0.569, 0.559,
21518 & 0.550, 0.540, 0.531, 0.522, 0.514, 0.507, 0.500, 0.494, 0.489,
21519 & 0.485, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477/
21520* Lambda p
21521 DATA (ASIGEL(10,K),K=1,NPOINT) /
21522 & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21523 & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.630,
21524 & 1.600, 1.577, 1.558, 1.542, 1.528, 1.518, 1.510, 1.505, 1.502,
21525 & 1.501, 1.500, 1.499, 1.496, 1.491, 1.485, 1.477, 1.466, 1.454,
21526 & 1.440, 1.425, 1.408, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21527 & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21528 & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21529
21530 DATA (IDXDAT(K,1),K=1,25) /
21531 & 1, 2, 0, 0, 0, 0, 0, 3, 2, 0, 0,67, 4, 5, 6, 7,10, 2,67, 3,
21532 & 1, 3,45, 8, 9/
21533 DATA (IDXDAT(K,2),K=1,25) /
21534 & 3, 2, 0, 0, 0, 0, 0, 1, 2, 0, 0,89, 5, 4, 8, 9, 1, 2,89, 1,
21535 & 3, 1,45, 6, 7/
21536
21537 DATA LFIRST /.TRUE./
21538
21539 IF (LFIRST) THEN
21540 APLABL = LOG10(PLABLO)
21541 APLABH = LOG10(PLABHI)
21542 APTHRE = LOG10(PTHRE)
21543 ADP1 = (APTHRE-APLABL)/DBLE(NPOIN1)
21544 ADP2 = (APLABH-APTHRE)/DBLE(NPOIN2)
21545 DUM0 = ZERO
21546 PHOPLA = PLABHI
21547 PHOELA = SQRT(AAM(1)**2+PHOPLA**2)
21548 ECMS = SQRT(2.0D0*AAM(1)**2+2.0D0*AAM(1)*PHOELA)
21549 IF (MCGENE.EQ.2) THEN
21550 IF (ECMS.LE.SIGECM(1,ISIMAX)) THEN
21551 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,0)
21552 ELSE
21553 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21554 ENDIF
21555 ELSE
21556 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21557 ENDIF
21558 PHOSEL = PHOSTO-PHOSIN
21559 APHOST = LOG10(PHOSTO)
21560 APHOSE = LOG10(PHOSEL)
21561 LFIRST = .FALSE.
21562 ENDIF
21563 STOT = ZERO
21564 SELA = ZERO
21565 PLAB = PL
21566 ECMS = ECM
21567 IF ( (IP.LT.1).OR.((IT.NE.1).AND.(IT.NE.8)) ) THEN
21568 WRITE(LOUT,1000) IP,IT
21569 1000 FORMAT(1X,'DT_XSHN: cross sections not implemented for ',
21570 & 'proj/target',2I4)
21571 STOP
21572 ENDIF
21573
21574 IF ((PLAB.LE.ZERO).AND.(ECMS.GT.ZERO)) THEN
21575 ELAB = (ECMS**2-AAM(IP)**2-AAM(IT)**2)/(2.0D0*AAM(IT))
21576 PLAB = SQRT((ELAB-AAM(IP))*(ELAB+AAM(IP)))
21577 ELSEIF ((PLAB.LE.ZERO).AND.(ECMS.LE.ZERO)) THEN
21578 WRITE(LOUT,1001) PLAB,ECMS
21579 1001 FORMAT(1X,'DT_XSHN: invalid momentum/cm-energy ',2E15.5)
21580 STOP
21581 ENDIF
21582
21583* index of spectrum
21584 IDXP = IP
21585 IF (IP.GT.25) THEN
21586 IF (AAM(IP).GT.ZERO) THEN
21587 IF (ABS(IIBAR(IP)).GT.0) THEN
21588 IDXP = 1
21589 ELSE
21590 IDXP = 13
21591 ENDIF
21592 ELSE
21593 IDXP = 7
21594 ENDIF
21595 ENDIF
21596 IDXT = 1
21597 IF (IT.EQ.8) IDXT = 2
21598 IDXS = IDXDAT(IDXP,IDXT)
21599 IF (IDXS.EQ.0) RETURN
21600
21601* compute momentum bin indices
21602 IF (PLAB.LT.PLABLO) THEN
21603 IDX0 = 1
21604 IDX1 = 1
21605 ELSEIF (PLAB.GE.PLABHI) THEN
21606 IDX0 = NPOINT
21607 IDX1 = NPOINT
21608 ELSE
21609 APLAB = LOG10(PLAB)
21610 IF ((PLAB.GE.PLABLO).AND.(PLAB.LT.PTHRE )) THEN
21611 IDX0 = INT((APLAB-APLABL)/ADP1)+1
21612 ELSEIF ((PLAB.GE.PTHRE ).AND.(PLAB.LT.PLABHI)) THEN
21613 IDX0 = INT((APLAB-APTHRE)/ADP2)+NPOIN1+1
21614 ENDIF
21615 IDX1 = IDX0+1
21616 ENDIF
21617
21618* interpolate cross section
21619 IF (IDXS.GT.10) THEN
21620 IDXS1 = IDXS/10
21621 IDXS2 = IDXS-10*IDXS1
21622 IF (IDX0.EQ.IDX1) THEN
21623 IF (IDX0.EQ.1) THEN
21624 ASTOT = 0.5D0*(ASIGTO(IDXS1,IDX0)+ASIGTO(IDXS2,IDX0))
21625 ASELA = 0.5D0*(ASIGEL(IDXS1,IDX0)+ASIGEL(IDXS2,IDX0))
21626 ELSE
21627 DUM0 = ZERO
21628 CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21629 PHOSEL = PHOSTO-PHOSIN
21630 ASTOT1 = ASIGTO(IDXS1,NPOINT)-APHOST+LOG10(PHOSTO)
21631 ASELA1 = ASIGEL(IDXS1,NPOINT)-APHOSE+LOG10(PHOSEL)
21632 ASTOT2 = ASIGTO(IDXS2,NPOINT)-APHOST+LOG10(PHOSTO)
21633 ASELA2 = ASIGEL(IDXS2,NPOINT)-APHOSE+LOG10(PHOSEL)
21634 ASTOT = 0.5D0*(ASTOT1+ASTOT2)
21635 ASELA = 0.5D0*(ASELA1+ASELA2)
21636 ENDIF
21637 ELSE
21638 FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21639 ASTOT1 = ASIGTO(IDXS1,IDX0)+
21640 & FAC*(ASIGTO(IDXS1,IDX1)-ASIGTO(IDXS1,IDX0))
21641 ASTOT2 = ASIGTO(IDXS2,IDX0)+
21642 & FAC*(ASIGTO(IDXS2,IDX1)-ASIGTO(IDXS2,IDX0))
21643 ASTOT = 0.5D0*(ASTOT1+ASTOT2)
21644 ASELA1 = ASIGEL(IDXS1,IDX0)+
21645 & FAC*(ASIGEL(IDXS1,IDX1)-ASIGEL(IDXS1,IDX0))
21646 ASELA2 = ASIGEL(IDXS2,IDX0)+
21647 & FAC*(ASIGEL(IDXS2,IDX1)-ASIGEL(IDXS2,IDX0))
21648 ASELA = 0.5D0*(ASELA1+ASELA2)
21649 ENDIF
21650 ELSE
21651 IF (IDX0.EQ.IDX1) THEN
21652 IF (IDX0.EQ.1) THEN
21653 ASTOT = ASIGTO(IDXS,IDX0)
21654 ASELA = ASIGEL(IDXS,IDX0)
21655 ELSE
21656 DUM0 = ZERO
21657 CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21658 PHOSEL = PHOSTO-PHOSIN
21659 ASTOT = ASIGTO(IDXS,NPOINT)-APHOST+LOG10(PHOSTO)
21660 ASELA = ASIGEL(IDXS,NPOINT)-APHOSE+LOG10(PHOSEL)
21661 ENDIF
21662 ELSE
21663 FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21664 ASTOT = ASIGTO(IDXS,IDX0)+
21665 & FAC*(ASIGTO(IDXS,IDX1)-ASIGTO(IDXS,IDX0))
21666 ASELA = ASIGEL(IDXS,IDX0)+
21667 & FAC*(ASIGEL(IDXS,IDX1)-ASIGEL(IDXS,IDX0))
21668 ENDIF
21669 ENDIF
21670 STOT = 10.0D0**ASTOT
21671 SELA = 10.0D0**ASELA
21672
21673 RETURN
21674 END
21675
21676*$ CREATE DT_SIHNAB.FOR
21677*COPY DT_SIHNAB
21678*
21679*===sihnab===============================================================*
21680*
21681 SUBROUTINE DT_SIHNAB(IDP,IDT,PLAB,SIGABS)
21682
21683**********************************************************************
21684* Pion 2-nucleon absorption cross sections. *
21685* (sigma_tot for pi+ d --> p p, pi- d --> n n *
21686* taken from Ritchie PRC 28 (1983) 926 ) *
21687* This version dated 18.05.96 is written by S. Roesler *
21688**********************************************************************
21689
21690 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21691 SAVE
21692 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY3=1.0D-3)
21693 PARAMETER (AMPR = 938.0D0,
21694 & AMPI = 140.0D0,
21695 & AMDE = TWO*AMPR,
21696 & A = -1.2D0,
21697 & B = 3.5D0,
21698 & C = 7.4D0,
21699 & D = 5600.0D0,
21700 & ER = 2136.0D0)
21701
21702 SIGABS = ZERO
21703 IF ( ((IDP.NE.13).AND.(IDP.NE.14).AND.(IDP.NE.23))
21704 & .OR.((IDT.NE.1).AND.(IDT.NE.8)) ) RETURN
21705 PTOT = PLAB*1.0D3
21706 EKIN = SQRT(AMPI**2+PTOT**2)-AMPI
21707 IF ((EKIN.LT.TINY3).OR.(EKIN.GT.400.0D0)) RETURN
21708 ECM = SQRT( (AMPI+AMDE)**2+TWO*EKIN*AMDE )
21709 SIGABS = A+B/SQRT(EKIN)+C*1.0D4/((ECM-ER)**2+D)
21710* approximate 3N-abs., I=1-abs. etc.
21711 SIGABS = SIGABS/0.40D0
21712* pi0-absorption (rough approximation!!)
21713 IF (IDP.EQ.23) SIGABS = 0.5D0*SIGABS
21714
21715 RETURN
21716 END
21717
21718*$ CREATE DT_SIGEMU.FOR
21719*COPY DT_SIGEMU
21720*
21721*===sigemu=============================================================*
21722*
21723 SUBROUTINE DT_SIGEMU
21724
21725************************************************************************
21726* Combined cross section for target compounds. *
21727* This version dated 6.4.98 is written by S. Roesler *
21728************************************************************************
21729
21730 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21731 SAVE
21732 PARAMETER ( LINP = 10 ,
21733 & LOUT = 6 ,
21734 & LDAT = 9 )
21735 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21736 & OHALF=0.5D0,ONE=1.0D0)
21737
21738 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21739* Glauber formalism: cross sections
21740 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21741 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21742 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21743 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21744 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21745 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21746 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21747 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21748 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21749 & BSLOPE,NEBINI,NQBINI
21750* emulsion treatment
21751 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
21752 & NCOMPO,IEMUL
21753* nucleon-nucleon event-generator
21754 CHARACTER*8 CMODEL
21755 LOGICAL LPHOIN
21756 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21757
21758 IF (MCGENE.NE.4) THEN
21759 WRITE(LOUT,'(A)') ' DT_SIGEMU: Combined cross sections'
21760 WRITE(LOUT,'(15X,A)') '-----------------------'
21761 ENDIF
21762 DO 1 IE=1,NEBINI
21763 DO 2 IQ=1,NQBINI
21764 SIGTOT = ZERO
21765 SIGELA = ZERO
21766 SIGQEP = ZERO
21767 SIGQET = ZERO
21768 SIGQE2 = ZERO
21769 SIGPRO = ZERO
21770 SIGDEL = ZERO
21771 SIGDQE = ZERO
21772 ERRTOT = ZERO
21773 ERRELA = ZERO
21774 ERRQEP = ZERO
21775 ERRQET = ZERO
21776 ERRQE2 = ZERO
21777 ERRPRO = ZERO
21778 ERRDEL = ZERO
21779 ERRDQE = ZERO
21780 IF (NCOMPO.GT.0) THEN
21781 DO 3 IC=1,NCOMPO
21782 SIGTOT = SIGTOT+EMUFRA(IC)*XSTOT(IE,IQ,IC)
21783 SIGELA = SIGELA+EMUFRA(IC)*XSELA(IE,IQ,IC)
21784 SIGQEP = SIGQEP+EMUFRA(IC)*XSQEP(IE,IQ,IC)
21785 SIGQET = SIGQET+EMUFRA(IC)*XSQET(IE,IQ,IC)
21786 SIGQE2 = SIGQE2+EMUFRA(IC)*XSQE2(IE,IQ,IC)
21787 SIGPRO = SIGPRO+EMUFRA(IC)*XSPRO(IE,IQ,IC)
21788 SIGDEL = SIGDEL+EMUFRA(IC)*XSDEL(IE,IQ,IC)
21789 SIGDQE = SIGDQE+EMUFRA(IC)*XSDQE(IE,IQ,IC)
21790 ERRTOT = ERRTOT+XETOT(IE,IQ,IC)**2
21791 ERRELA = ERRELA+XEELA(IE,IQ,IC)**2
21792 ERRQEP = ERRQEP+XEQEP(IE,IQ,IC)**2
21793 ERRQET = ERRQET+XEQET(IE,IQ,IC)**2
21794 ERRQE2 = ERRQE2+XEQE2(IE,IQ,IC)**2
21795 ERRPRO = ERRPRO+XEPRO(IE,IQ,IC)**2
21796 ERRDEL = ERRDEL+XEDEL(IE,IQ,IC)**2
21797 ERRDQE = ERRDQE+XEDQE(IE,IQ,IC)**2
21798 3 CONTINUE
21799 ERRTOT = SQRT(ERRTOT)
21800 ERRELA = SQRT(ERRELA)
21801 ERRQEP = SQRT(ERRQEP)
21802 ERRQET = SQRT(ERRQET)
21803 ERRQE2 = SQRT(ERRQE2)
21804 ERRPRO = SQRT(ERRPRO)
21805 ERRDEL = SQRT(ERRDEL)
21806 ERRDQE = SQRT(ERRDQE)
21807 ELSE
21808 SIGTOT = XSTOT(IE,IQ,1)
21809 SIGELA = XSELA(IE,IQ,1)
21810 SIGQEP = XSQEP(IE,IQ,1)
21811 SIGQET = XSQET(IE,IQ,1)
21812 SIGQE2 = XSQE2(IE,IQ,1)
21813 SIGPRO = XSPRO(IE,IQ,1)
21814 SIGDEL = XSDEL(IE,IQ,1)
21815 SIGDQE = XSDQE(IE,IQ,1)
21816 ERRTOT = XETOT(IE,IQ,1)
21817 ERRELA = XEELA(IE,IQ,1)
21818 ERRQEP = XEQEP(IE,IQ,1)
21819 ERRQET = XEQET(IE,IQ,1)
21820 ERRQE2 = XEQE2(IE,IQ,1)
21821 ERRPRO = XEPRO(IE,IQ,1)
21822 ERRDEL = XEDEL(IE,IQ,1)
21823 ERRDQE = XEDQE(IE,IQ,1)
21824 ENDIF
21825 IF (MCGENE.NE.4) THEN
21826 WRITE(LOUT,1000) ECMNN(IE),Q2G(IQ)
21827 1000 FORMAT(/,1X,'E_cm =',F9.1,' GeV Q^2 =',F6.1,' GeV^2 :',/)
21828 WRITE(LOUT,1001) SIGTOT,ERRTOT
21829 1001 FORMAT(1X,'total',32X,F10.4,' +-',F11.5,' mb')
21830 WRITE(LOUT,1002) SIGELA,ERRELA
21831 1002 FORMAT(1X,'elastic',30X,F10.4,' +-',F11.5,' mb')
21832 WRITE(LOUT,1003) SIGQEP,ERRQEP
21833 1003 FORMAT(1X,'quasi-elastic (A+B-->A+X)',12X,F10.4,' +-',
21834 & F11.5,' mb')
21835 WRITE(LOUT,1004) SIGQET,ERRQET
21836 1004 FORMAT(1X,'quasi-elastic (A+B-->X+B)',12X,F10.4,' +-',
21837 & F11.5,' mb')
21838 WRITE(LOUT,1005) SIGQE2,ERRQE2
21839 1005 FORMAT(1X,'quasi-elastic (A+B-->X, excl. 2-4)',3X,F10.4,
21840 & ' +-',F11.5,' mb')
21841 WRITE(LOUT,1006) SIGPRO,ERRPRO
21842 1006 FORMAT(1X,'production',27X,F10.4,' +-',F11.5,' mb')
21843 WRITE(LOUT,1007) SIGDEL,ERRDEL
21844 1007 FORMAT(1X,'diff-el ',27X,F10.4,' +-',F11.5,' mb')
21845 WRITE(LOUT,1008) SIGDQE,ERRDQE
21846 1008 FORMAT(1X,'diff-qel ',27X,F10.4,' +-',F11.5,' mb')
21847 ENDIF
21848
21849 2 CONTINUE
21850 1 CONTINUE
21851
21852 RETURN
21853 END
21854
21855*$ CREATE DT_SIGGA.FOR
21856*COPY DT_SIGGA
21857*
21858*===sigga==============================================================*
21859*
21860 SUBROUTINE DT_SIGGA(NTI,XI,Q2I,ECMI,XNUI,STOT,ETOT,SIN,EIN,STOT0)
21861
21862************************************************************************
21863* Total/inelastic photon-nucleus cross sections. *
21864* !!!! Overwrites SHMAKI-initialization. Do not use it during *
21865* production runs !!!! *
21866* This version dated 27.03.96 is written by S. Roesler *
21867************************************************************************
21868
21869 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21870 SAVE
21871 PARAMETER ( LINP = 10 ,
21872 & LOUT = 6 ,
21873 & LDAT = 9 )
21874 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21875 & OHALF=0.5D0,ONE=1.0D0)
21876 PARAMETER (AMPROT = 0.938D0)
21877
21878 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21879* Glauber formalism: cross sections
21880 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21881 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21882 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21883 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21884 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21885 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21886 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21887 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21888 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21889 & BSLOPE,NEBINI,NQBINI
21890
21891 NT = NTI
21892 X = XI
21893 Q2 = Q2I
21894 ECM = ECMI
21895 XNU = XNUI
21896 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21897 & ECM = SQRT(AMPROT**2-Q2+2.0D0*XNUI*AMPROT)
21898 CALL DT_XSGLAU(1,NT,7,X,Q2,ECM,1,1,-1)
21899 STOT = XSTOT(1,1,1)
21900 ETOT = XETOT(1,1,1)
21901 SIN = XSPRO(1,1,1)
21902 EIN = XEPRO(1,1,1)
21903
21904 RETURN
21905 END
21906
21907*$ CREATE DT_SIGGAT.FOR
21908*COPY DT_SIGGAT
21909*
21910*===siggat=============================================================*
21911*
21912 SUBROUTINE DT_SIGGAT(Q2I,ECMI,STOT,NT)
21913
21914************************************************************************
21915* Total/inelastic photon-nucleus cross sections. *
21916* Uses pre-tabulated cross section. *
21917* This version dated 29.07.96 is written by S. Roesler *
21918************************************************************************
21919
21920 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21921 SAVE
21922 PARAMETER ( LINP = 10 ,
21923 & LOUT = 6 ,
21924 & LDAT = 9 )
21925 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21926 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21927
21928 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21929* Glauber formalism: cross sections
21930 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21931 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21932 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21933 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21934 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21935 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21936 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21937 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21938 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21939 & BSLOPE,NEBINI,NQBINI
21940
21941 NTARG = ABS(NT)
21942 I1 = 1
21943 I2 = 1
21944 RATE = ONE
21945 IF (NEBINI.GT.1) THEN
21946 IF (ECMI.GE.ECMNN(NEBINI)) THEN
21947 I1 = NEBINI
21948 I2 = NEBINI
21949 RATE = ONE
21950 ELSEIF (ECMI.GT.ECMNN(1)) THEN
21951 DO 1 I=2,NEBINI
21952 IF (ECMI.LT.ECMNN(I)) THEN
21953 I1 = I-1
21954 I2 = I
21955 RATE = (ECMI-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
21956 GOTO 2
21957 ENDIF
21958 1 CONTINUE
21959 2 CONTINUE
21960 ENDIF
21961 ENDIF
21962 J1 = 1
21963 J2 = 1
21964 RATQ = ONE
21965 IF (NQBINI.GT.1) THEN
21966 IF (Q2I.GE.Q2G(NQBINI)) THEN
21967 J1 = NQBINI
21968 J2 = NQBINI
21969 RATQ = ONE
21970 ELSEIF (Q2I.GT.Q2G(1)) THEN
21971 DO 3 I=2,NQBINI
21972 IF (Q2I.LT.Q2G(I)) THEN
21973 J1 = I-1
21974 J2 = I
21975 RATQ = LOG10( Q2I/MAX(Q2G(J1),TINY14))/
21976 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
21977C RATQ = (Q2I-Q2G(J1))/(Q2G(J2)-Q2G(J1))
21978 GOTO 4
21979 ENDIF
21980 3 CONTINUE
21981 4 CONTINUE
21982 ENDIF
21983 ENDIF
21984
21985 STOT = XSTOT(I1,J1,NTARG)+
21986 & RATE*(XSTOT(I2,J1,NTARG)-XSTOT(I1,J1,NTARG))+
21987 & RATQ*(XSTOT(I1,J2,NTARG)-XSTOT(I1,J1,NTARG))+
21988 & RATE*RATQ*(XSTOT(I2,J2,NTARG)-XSTOT(I1,J2,NTARG)+
21989 & XSTOT(I1,J1,NTARG)-XSTOT(I2,J1,NTARG))
21990
21991 RETURN
21992 END
21993
21994*$ CREATE DT_SANO.FOR
21995*COPY DT_SANO
21996*
21997*===sigano=============================================================*
21998*
21999 DOUBLE PRECISION FUNCTION DT_SANO(ECM)
22000
22001************************************************************************
22002* This version dated 31.07.96 is written by S. Roesler *
22003************************************************************************
22004
22005 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22006 SAVE
22007 PARAMETER ( LINP = 10 ,
22008 & LOUT = 6 ,
22009 & LDAT = 9 )
22010 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
22011 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
22012 PARAMETER (NE = 8)
22013
22014* VDM parameter for photon-nucleus interactions
22015 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22016* properties of interacting particles
22017 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
22018
22019 DIMENSION ECMANO(NE),FRAANO(NE),SIGHRD(NE)
22020 DATA ECMANO /
22021 & 0.200D+02,0.500D+02,0.100D+03,0.200D+03,0.500D+03,
22022 & 0.100D+04,0.200D+04,0.500D+04
22023 & /
22024* fixed cut (3 GeV/c)
22025 DATA FRAANO /
22026 & 0.085D+00,0.114D+00,0.105D+00,0.091D+00,0.073D+00,
22027 & 0.062D+00,0.054D+00,0.042D+00
22028 & /
22029 DATA SIGHRD /
22030 & 4.0099D-04,3.3104D-03,1.1905D-02,3.6435D-02,1.3493D-01,
22031 & 3.3086D-01,7.6255D-01,2.1319D+00
22032 & /
22033* running cut (based on obsolete Phojet-caluclations, bugs..)
22034C DATA FRAANO /
22035C & 0.251E+00,0.313E+00,0.279E+00,0.239E+00,0.186E+00,
22036C & 0.167E+00,0.150E+00,0.131E+00
22037C & /
22038C DATA SIGHRD /
22039C & 6.6569E-04,4.4949E-03,1.4837E-02,4.1466E-02,1.5071E-01,
22040C & 2.5736E-01,4.5593E-01,8.2550E-01
22041C & /
22042
22043 DT_SANO = ZERO
22044 IF ((ISHAD(2).NE.1).OR.(IJPROJ.NE.7)) RETURN
22045 J1 = 0
22046 J2 = 0
22047 RATE = ONE
22048 IF (ECM.GE.ECMANO(NE)) THEN
22049 J1 = NE
22050 J2 = NE
22051 ELSEIF (ECM.GT.ECMANO(1)) THEN
22052 DO 1 IE=2,NE
22053 IF (ECM.LT.ECMANO(IE)) THEN
22054 J1 = IE-1
22055 J2 = IE
22056 RATE = LOG10(ECM/ECMANO(J1))/LOG10(ECMANO(J2)/ECMANO(J1))
22057 GOTO 2
22058 ENDIF
22059 1 CONTINUE
22060 2 CONTINUE
22061 ENDIF
22062 IF ((J1.GT.0).AND.(J2.GT.0)) THEN
22063 AFRA1 = LOG10(MAX(FRAANO(J1)*SIGHRD(J1),TINY14))
22064 AFRA2 = LOG10(MAX(FRAANO(J2)*SIGHRD(J2),TINY14))
22065 DT_SANO = 10.0D0**(AFRA1+RATE*(AFRA2-AFRA1))
22066 ENDIF
22067
22068 RETURN
22069 END
22070
22071*$ CREATE DT_SIGGP.FOR
22072*COPY DT_SIGGP
22073*
22074*===siggp==============================================================*
22075*
22076 SUBROUTINE DT_SIGGP(XI,Q2I,ECMI,XNUI,STOT,SINE,SDIR)
22077
22078************************************************************************
22079* Total/inelastic photon-nucleon cross sections. *
22080* This version dated 30.04.96 is written by S. Roesler *
22081************************************************************************
22082
22083 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22084 SAVE
22085 PARAMETER ( LINP = 10 ,
22086 & LOUT = 6 ,
22087 & LDAT = 9 )
22088 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22089 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22090 & PI = TWOPI/TWO,
22091 & GEV2MB = 0.38938D0,
22092 & ALPHEM = ONE/137.0D0)
22093
22094* particle properties (BAMJET index convention)
22095 CHARACTER*8 ANAME
22096 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22097 & IICH(210),IIBAR(210),K1(210),K2(210)
22098* VDM parameter for photon-nucleus interactions
22099 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22100
22101**PHOJET105a
22102C CHARACTER*8 MDLNA
22103C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
22104C PARAMETER (IEETAB=10)
22105C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
22106**PHOJET110
22107C model switches and parameters
22108 CHARACTER*8 MDLNA
22109 INTEGER ISWMDL,IPAMDL
22110 DOUBLE PRECISION PARMDL
22111 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
22112C energy-interpolation table
22113 INTEGER IEETA2
22114 PARAMETER ( IEETA2 = 20 )
22115 INTEGER ISIMAX
22116 DOUBLE PRECISION SIGTAB,SIGECM
22117 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
22118**
22119
22120C PARAMETER (NPOINT=80)
22121 PARAMETER (NPOINT=16)
22122 DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
22123
22124 STOT = ZERO
22125 SINE = ZERO
22126 SDIR = ZERO
22127
22128 W2 = ECMI**2
22129 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
22130 & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
22131 Q2 = Q2I
22132 X = XI
22133* photoprod.
22134 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22135 Q2 = 0.0001D0
22136 X = Q2/(W2+Q2-AAM(1)**2)
22137* DIS
22138 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
22139 X = Q2/(W2+Q2-AAM(1)**2)
22140 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22141 Q2 = (W2-AAM(1)**2)*X/(ONE-X)
22142 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
22143 W2 = Q2*(ONE-X)/X+AAM(1)**2
22144 ELSE
22145 WRITE(LOUT,*) 'SIGGP: inconsistent input ',W2,Q2,X
22146 STOP
22147 ENDIF
22148 ECM = SQRT(W2)
22149
22150 IF (MODEGA.EQ.1) THEN
22151 SCALE = SQRT(Q2)
22152 CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
22153 & IDPDF)
22154C W = SQRT(W2)
22155C ALLMF2 = PHO_ALLM97(Q2,W)
22156C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
22157 STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
22158 SINE = ZERO
22159 SDIR = ZERO
22160 ELSEIF (MODEGA.EQ.2) THEN
22161 IF (INTRGE(1).EQ.1) THEN
22162 AMLO2 = (3.0D0*AAM(13))**2
22163 ELSEIF (INTRGE(1).EQ.2) THEN
22164 AMLO2 = AAM(33)**2
22165 ELSE
22166 AMLO2 = AAM(96)**2
22167 ENDIF
22168 IF (INTRGE(2).EQ.1) THEN
22169 AMHI2 = W2/TWO
22170 ELSEIF (INTRGE(2).EQ.2) THEN
22171 AMHI2 = W2/4.0D0
22172 ELSE
22173 AMHI2 = W2
22174 ENDIF
22175 AMHI20 = (ECM-AAM(1))**2
22176 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22177 XAMLO = LOG( AMLO2+Q2 )
22178 XAMHI = LOG( AMHI2+Q2 )
22179**PHOJET105a
22180C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
22181**PHOJET112
22182 CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
22183**
22184 SUM = ZERO
22185 DO 1 J=1,NPOINT
22186 AM2 = EXP(ABSZX(J))-Q2
22187 IF (AM2.LT.16.0D0) THEN
22188 R = TWO
22189 ELSEIF ((AM2.GE.16.0D0).AND.(AM2.LT.121.0D0)) THEN
22190 R = 10.0D0/3.0D0
22191 ELSE
22192 R = 11.0D0/3.0D0
22193 ENDIF
22194C FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
22195 FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
22196 & * (ONE+EPSPOL*Q2/AM2)
22197 SUM = SUM+WEIGHT(J)*FAC
22198 1 CONTINUE
22199 SINE = SUM
22200 SDIR = DT_SIGVP(X,Q2)
22201 STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*SDIR
22202 SDIR = SDIR/(0.588D0+RL2+Q2)
22203C STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*DT_SIGVP(X,Q2)
22204 ELSEIF (MODEGA.EQ.3) THEN
22205 CALL DT_SIGGA(1,XI,Q2I,ECMI,ZERO,STOT,ETOT,SINE,EINE,DUM)
22206 ELSEIF (MODEGA.EQ.4) THEN
22207* load cross sections from PHOJET interpolation table
22208 IP = 1
22209 IF(ECM.LE.SIGECM(IP,1)) THEN
22210 I1 = 1
22211 I2 = 1
22212 ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
22213 DO 2 I=2,ISIMAX
22214 IF (ECM.LE.SIGECM(IP,I)) GOTO 3
22215 2 CONTINUE
22216 3 CONTINUE
22217 I1 = I-1
22218 I2 = I
22219 ELSE
22220 WRITE(LOUT,'(/1X,A,2E12.3)')
22221 & 'SIGGP:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
22222 I1 = ISIMAX
22223 I2 = ISIMAX
22224 ENDIF
22225 FAC2 = ZERO
22226 IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
22227 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
22228 FAC1 = ONE-FAC2
22229* cross section dependence on photon virtuality
22230 FSUP1 = ZERO
22231 DO 4 I=1,3
22232 FSUP1 = FSUP1+PARMDL(26+I)*(1.D0+Q2/(4.D0*PARMDL(30+I)))
22233 & /(1.D0+Q2/PARMDL(30+I))**2
22234 4 CONTINUE
22235 FSUP1 = FSUP1+PARMDL(30)/(1.D0+Q2/PARMDL(34))
22236 FAC1 = FAC1*FSUP1
22237 FAC2 = FAC2*FSUP1
22238 FSUP2 = 1.0D0
22239 STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
22240 SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
22241 SDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
22242**re:
22243 STOT = STOT-SDIR
22244**
22245 SDIR = SDIR/(FSUP1*FSUP2)
22246**re:
22247 STOT = STOT+SDIR
22248**
22249 ENDIF
22250
22251 RETURN
22252 END
22253
22254*$ CREATE DT_SIGVEL.FOR
22255*COPY DT_SIGVEL
22256*
22257*===sigvel=============================================================*
22258*
22259 SUBROUTINE DT_SIGVEL(XI,Q2I,ECMI,XNUI,IDXV,SVEL,SIG1,SIG2)
22260
22261************************************************************************
22262* Cross section for elastic vector meson production *
22263* This version dated 10.05.96 is written by S. Roesler *
22264************************************************************************
22265
22266 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22267 SAVE
22268 PARAMETER ( LINP = 10 ,
22269 & LOUT = 6 ,
22270 & LDAT = 9 )
22271 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22272 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22273 & PI = TWOPI/TWO,
22274 & GEV2MB = 0.38938D0,
22275 & ALPHEM = ONE/137.0D0)
22276
22277* particle properties (BAMJET index convention)
22278 CHARACTER*8 ANAME
22279 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22280 & IICH(210),IIBAR(210),K1(210),K2(210)
22281* VDM parameter for photon-nucleus interactions
22282 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22283
22284 W2 = ECMI**2
22285 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
22286 & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
22287 Q2 = Q2I
22288 X = XI
22289* photoprod.
22290 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22291 Q2 = 0.0001D0
22292 X = Q2/(W2+Q2-AAM(1)**2)
22293* DIS
22294 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
22295 X = Q2/(W2+Q2-AAM(1)**2)
22296 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22297 Q2 = (W2-AAM(1)**2)*X/(ONE-X)
22298 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
22299 W2 = Q2*(ONE-X)/X+AAM(1)**2
22300 ELSE
22301 WRITE(LOUT,*) 'SIGVEL: inconsistent input ',W2,Q2,X
22302 STOP
22303 ENDIF
22304 ECM = SQRT(W2)
22305
22306 AMV = AAM(IDXV)
22307 AMV2 = AMV**2
22308
22309 BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
22310 & +0.25D0*LOG(W2/(AMV2+Q2)))*GEV2MB
22311 ROSH = 0.1D0
22312 STOVP = DT_SIGVP(X,Q2)/(AMV2+Q2+RL2)
22313 SELVP = STOVP**2*(ONE+ROSH**2)/(8.0D0*TWOPI*BSLOPE)
22314
22315 IF (IDXV.EQ.33) THEN
22316 COUPL = 0.00365D0
22317 ELSE
22318 STOP
22319 ENDIF
22320 SIG1 = (AMV2/(AMV2+Q2))**2 * (ONE+EPSPOL*Q2/AMV2)
22321 SIG2 = SELVP
22322 SVEL = COUPL * (AMV2/(AMV2+Q2))**2
22323 & * (ONE+EPSPOL*Q2/AMV2) * SELVP
22324
22325 RETURN
22326 END
22327
22328*$ CREATE DT_SIGVP.FOR
22329*COPY DT_SIGVP
22330*
22331*===sigvp==============================================================*
22332*
22333 DOUBLE PRECISION FUNCTION DT_SIGVP(XI,Q2I)
22334
22335************************************************************************
22336* sigma_Vp *
22337************************************************************************
22338
22339 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22340 SAVE
22341
22342 PARAMETER ( LINP = 10 ,
22343 & LOUT = 6 ,
22344 & LDAT = 9 )
22345 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22346 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22347 & PI = TWOPI/TWO,
22348 & GEV2MB = 0.38938D0,
22349 & AMPROT = 0.938D0,
22350 & ALPHEM = ONE/137.0D0)
22351* VDM parameter for photon-nucleus interactions
22352 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22353
22354 X = XI
22355 Q2 = Q2I
22356 IF (XI.LE.ZERO) X = 0.0001D0
22357 IF (Q2I.LE.ZERO) Q2 = 0.0001D0
22358
22359 ECM = SQRT( Q2*(ONE-X)/X+AMPROT**2 )
22360
22361 SCALE = SQRT(Q2)
22362 IF (MODEGA.EQ.1) THEN
22363 CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
22364 & IDPDF)
22365C W = ECM
22366C ALLMF2 = PHO_ALLM97(Q2,W)
22367C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
22368C STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
22369C DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))
22370 DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))*GEV2MB
22371 ELSEIF (MODEGA.EQ.4) THEN
22372 CALL DT_SIGGP(X,Q2,ECM,DUM1,STOT,DUM2,DUM3)
22373C F2 = Q2*(ONE-X)/(TWOPI**2*ALPHEM*GEV2MB) * STOT
22374 DT_SIGVP = 3.0D0*PI/(ALPHEM*DT_RRM2(X,Q2)) * STOT
22375 ELSE
22376 STOP ' DT_SIGVP: F2 not defined for this MODEGA !'
22377 ENDIF
22378
22379 RETURN
22380
22381 END
22382
22383*$ CREATE DT_RRM2.FOR
22384*COPY DT_RRM2
22385*
22386*===RRM2===============================================================*
22387*
22388 DOUBLE PRECISION FUNCTION DT_RRM2(X,Q2)
22389
22390 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22391 SAVE
22392 PARAMETER ( LINP = 10 ,
22393 & LOUT = 6 ,
22394 & LDAT = 9 )
22395 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22396 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22397 & PI = TWOPI/TWO,
22398 & GEV2MB = 0.38938D0)
22399
22400* particle properties (BAMJET index convention)
22401 CHARACTER*8 ANAME
22402 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22403 & IICH(210),IIBAR(210),K1(210),K2(210)
22404* VDM parameter for photon-nucleus interactions
22405 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22406
22407 S = Q2*(ONE-X)/X+AAM(1)**2
22408 ECM = SQRT(S)
22409
22410 IF (INTRGE(1).EQ.1) THEN
22411 AMLO2 = (3.0D0*AAM(13))**2
22412 ELSEIF (INTRGE(1).EQ.2) THEN
22413 AMLO2 = AAM(33)**2
22414 ELSE
22415 AMLO2 = AAM(96)**2
22416 ENDIF
22417 IF (INTRGE(2).EQ.1) THEN
22418 AMHI2 = S/TWO
22419 ELSEIF (INTRGE(2).EQ.2) THEN
22420 AMHI2 = S/4.0D0
22421 ELSE
22422 AMHI2 = S
22423 ENDIF
22424 AMHI20 = (ECM-AAM(1))**2
22425 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22426
22427 AM1C2 = 16.0D0
22428 AM2C2 = 121.0D0
22429 IF (AMHI2.LE.AM1C2) THEN
22430 DT_RRM2 = TWO*DT_RM2(AMLO2,AMHI2,Q2)
22431 ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22432 DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22433 & 10.0D0/3.0D0*DT_RM2(AM1C2,AMHI2,Q2)
22434 ELSE
22435 DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22436 & 10.0D0/3.0D0*DT_RM2(AM1C2,AM2C2,Q2)+
22437 & 11.0D0/3.0D0*DT_RM2(AM2C2,AMHI2,Q2)
22438 ENDIF
22439
22440 RETURN
22441 END
22442
22443*$ CREATE DT_RM2.FOR
22444*COPY DT_RM2
22445*
22446*===RM2================================================================*
22447*
22448 DOUBLE PRECISION FUNCTION DT_RM2(AMLO2,AMHI2,Q2)
22449
22450 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22451 SAVE
22452 PARAMETER ( LINP = 10 ,
22453 & LOUT = 6 ,
22454 & LDAT = 9 )
22455 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22456 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22457 & PI = TWOPI/TWO,
22458 & GEV2MB = 0.38938D0)
22459* VDM parameter for photon-nucleus interactions
22460 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22461
22462 IF (RL2.LE.ZERO) THEN
22463 DT_RM2 = -ONE/(AMHI2+Q2)+Q2/(TWO*(AMHI2+Q2)**2) -
22464 & (-ONE/(AMLO2+Q2)+Q2/(TWO*(AMLO2+Q2)**2))
22465 & +EPSPOL*(-Q2/(TWO*(AMHI2+Q2)**2)+Q2/(TWO*(AMLO2+Q2)**2))
22466 ELSE
22467 TMPMLO = LOG(ONE+RL2/(AMLO2+Q2))
22468 TMPMHI = LOG(ONE+RL2/(AMHI2+Q2))
22469 DT_RM2 = Q2/(RL2*(AMHI2+Q2))-(Q2+RL2)/RL2**2*TMPMHI
22470 & -(Q2/(RL2*(AMLO2+Q2))-(Q2+RL2)/RL2**2*TMPMLO)
22471 & +EPSPOL*(
22472 & -Q2/(RL2*(AMHI2+Q2))+Q2/RL2**2*TMPMHI
22473 & -(-Q2/(RL2*(AMLO2+Q2))+Q2/RL2**2*TMPMLO))
22474 ENDIF
22475
22476 RETURN
22477 END
22478
22479*$ CREATE DT_SAM2.FOR
22480*COPY DT_SAM2
22481*
22482*===SAM2===============================================================*
22483*
22484 DOUBLE PRECISION FUNCTION DT_SAM2(Q2,ECM)
22485
22486 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22487 SAVE
22488 PARAMETER ( LINP = 10 ,
22489 & LOUT = 6 ,
22490 & LDAT = 9 )
22491 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
22492 & TENTRD=10.0D0/3.0D0,ELVTRD=11.0D0/3.0D0)
22493 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22494 & PI = TWOPI/TWO,
22495 & GEV2MB = 0.38938D0)
22496
22497* particle properties (BAMJET index convention)
22498 CHARACTER*8 ANAME
22499 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22500 & IICH(210),IIBAR(210),K1(210),K2(210)
22501* VDM parameter for photon-nucleus interactions
22502 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22503
22504 S = ECM**2
22505 IF (INTRGE(1).EQ.1) THEN
22506 AMLO2 = (3.0D0*AAM(13))**2
22507 ELSEIF (INTRGE(1).EQ.2) THEN
22508 AMLO2 = AAM(33)**2
22509 ELSE
22510 AMLO2 = AAM(96)**2
22511 ENDIF
22512 IF (INTRGE(2).EQ.1) THEN
22513 AMHI2 = S/TWO
22514 ELSEIF (INTRGE(2).EQ.2) THEN
22515 AMHI2 = S/4.0D0
22516 ELSE
22517 AMHI2 = S
22518 ENDIF
22519 AMHI20 = (ECM-AAM(1))**2
22520 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22521
22522 AM1C2 = 16.0D0
22523 AM2C2 = 121.0D0
22524 YLO = LOG(AMLO2+Q2)
22525 YC1 = LOG(AM1C2+Q2)
22526 YC2 = LOG(AM2C2+Q2)
22527 YHI = LOG(AMHI2+Q2)
22528 IF (AMHI2.LE.AM1C2) THEN
22529 FACHI = TWO
22530 ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22531 FACHI = TENTRD
22532 ELSE
22533 FACHI = ELVTRD
22534 ENDIF
22535
22536 1 CONTINUE
22537 YSAM2 = YLO+(YHI-YLO)*DT_RNDM(AM1C2)
22538 IF (YSAM2.LE.YC1) THEN
22539 FAC = TWO
22540 ELSEIF ((YSAM2.GT.YC1).AND.(YSAM2.LE.YC2)) THEN
22541 FAC = TENTRD
22542 ELSE
22543 FAC = ELVTRD
22544 ENDIF
22545 WEIGMX = FACHI*(ONE-Q2*EXP( -YHI))
22546 XSAM2 = FAC *(ONE-Q2*EXP(-YSAM2))
22547 IF (DT_RNDM(YSAM2)*WEIGMX.GT.XSAM2) GOTO 1
22548
22549 DT_SAM2 = EXP(YSAM2)-Q2
22550
22551 RETURN
22552 END
22553
22554*$ CREATE DT_CKMT.FOR
22555*COPY DT_CKMT
22556*
22557*===ckmt===============================================================*
22558*
22559 SUBROUTINE DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,
22560 & F2,IPAR)
22561
22562************************************************************************
22563* This version dated 31.01.96 is written by S. Roesler *
22564************************************************************************
22565
22566 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22567 SAVE
22568 PARAMETER ( LINP = 10 ,
22569 & LOUT = 6 ,
22570 & LDAT = 9 )
22571 PARAMETER (ZERO=0.0D0,TWO=2.0D0,TINY10=1.0D-10)
22572
22573 PARAMETER (Q02 = 2.0D0,
22574 & DQ2 = 10.05D0,
22575 & Q12 = Q02+DQ2)
22576
22577 DIMENSION PD(-6:6),SEA(3),VAL(2)
22578
22579 CALL DT_PDF0(Q02,X,F2Q0,VAL,SEA,GLU,IPAR)
22580 CALL DT_PDF0(Q12,X,F2Q1,VAL,SEA,GLU,IPAR)
22581 ADQ2 = LOG10(Q12)-LOG10(Q02)
22582 F2P = (F2Q1-F2Q0)/ADQ2
22583 CALL DT_CKMTX(IPAR,X,Q02,PD,F2PQ0)
22584 CALL DT_CKMTX(IPAR,X,Q12,PD,F2PQ1)
22585 F2PP = (F2PQ1-F2PQ0)/ADQ2
22586 FX = (F2P-F2PP)/(F2PP+LOG(DQ2)*F2PQ0+TINY10)*Q02
22587
22588 Q2 = MAX(SCALE**2.0D0,TINY10)
22589 SMOOTH = 1.0D0+FX*(Q2-Q02)/Q2**2
22590 IF (Q2.LT.Q02) THEN
22591 CALL DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22592 UPV = VAL(1)
22593 DNV = VAL(2)
22594 USEA = SEA(1)
22595 DSEA = SEA(2)
22596 STR = SEA(3)
22597 CHM = 0.0D0
22598 BOT = 0.0D0
22599 TOP = 0.0D0
22600 GL = GLU
22601 ELSE
22602 CALL DT_CKMTX(IPAR,X,Q2,PD,F2)
22603 F2 = F2*SMOOTH
22604 UPV = PD(2)-PD(3)
22605 DNV = PD(1)-PD(3)
22606 USEA = PD(3)
22607 DSEA = PD(3)
22608 STR = PD(3)
22609 CHM = PD(4)
22610 BOT = PD(5)
22611 TOP = PD(6)
22612 GL = PD(0)
22613C UPV = UPV*SMOOTH
22614C DNV = DNV*SMOOTH
22615C USEA = USEA*SMOOTH
22616C DSEA = DSEA*SMOOTH
22617C STR = STR*SMOOTH
22618C CHM = CHM*SMOOTH
22619C GL = GL*SMOOTH
22620 ENDIF
22621
22622 RETURN
22623 END
22624C
22625
22626*$ CREATE DT_CKMTX.FOR
22627*COPY DT_CKMTX
22628 SUBROUTINE DT_CKMTX(IPAR,X,SCALE2,PD,F2)
22629C**********************************************************************
22630C
22631C PDF based on Regge theory, evolved with .... by ....
22632C
22633C input: IPAR 2212 proton (not installed)
22634C 45 Pomeron
22635C 100 Deuteron
22636C
22637C output: PD(-6:6) x*f(x) parton distribution functions
22638C (PDFLIB convention: d = PD(1), u = PD(2) )
22639C
22640C**********************************************************************
22641
22642 SAVE
22643 DOUBLE PRECISION X,SCALE2,PD(-6:6),CDN,CUP,F2
22644 PARAMETER ( LINP = 10 ,
22645 & LOUT = 6 ,
22646 & LDAT = 9 )
22647 DIMENSION QQ(7)
22648C
22649 Q2=SNGL(SCALE2)
22650 Q1S=Q2
22651 XX=SNGL(X)
22652C QCD lambda for evolution
22653 OWLAM = 0.23D0
22654 OWLAM2=OWLAM**2
22655C Q0**2 for evolution
22656 Q02 = 2.D0
22657C
22658C
22659C the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
22660C q(6)=x*charm, q(7)=x*gluon
22661C
22662 SB=0.
22663 IF(Q2-Q02) 1,1,2
22664 2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
22665 1 CONTINUE
22666 IF(IPAR.EQ.2212) THEN
22667 CALL DT_CKMTPR(1,0,XX,SB,QQ(1))
22668 CALL DT_CKMTPR(2,0,XX,SB,QQ(2))
22669 CALL DT_CKMTPR(3,0,XX,SB,QQ(3))
22670 CALL DT_CKMTPR(4,0,XX,SB,QQ(4))
22671 CALL DT_CKMTPR(5,0,XX,SB,QQ(5))
22672 CALL DT_CKMTPR(8,0,XX,SB,QQ(6))
22673 CALL DT_CKMTPR(7,0,XX,SB,QQ(7))
22674C ELSEIF (IPAR.EQ.45) THEN
22675C CALL CKMTPO(1,0,XX,SB,QQ(1))
22676C CALL CKMTPO(2,0,XX,SB,QQ(2))
22677C CALL CKMTPO(3,0,XX,SB,QQ(3))
22678C CALL CKMTPO(4,0,XX,SB,QQ(4))
22679C CALL CKMTPO(5,0,XX,SB,QQ(5))
22680C CALL CKMTPO(8,0,XX,SB,QQ(6))
22681C CALL CKMTPO(7,0,XX,SB,QQ(7))
22682 ELSEIF (IPAR.EQ.100) THEN
22683 CALL DT_CKMTDE(1,0,XX,SB,QQ(1))
22684 CALL DT_CKMTDE(2,0,XX,SB,QQ(2))
22685 CALL DT_CKMTDE(3,0,XX,SB,QQ(3))
22686 CALL DT_CKMTDE(4,0,XX,SB,QQ(4))
22687 CALL DT_CKMTDE(5,0,XX,SB,QQ(5))
22688 CALL DT_CKMTDE(8,0,XX,SB,QQ(6))
22689 CALL DT_CKMTDE(7,0,XX,SB,QQ(7))
22690 ELSE
22691 WRITE(LOUT,'(1X,A,I4,A)')
22692 & 'CKMTX: IPAR =',IPAR,' not implemented!'
22693 STOP
22694 ENDIF
22695C
22696 PD(-6) = 0.D0
22697 PD(-5) = 0.D0
22698 PD(-4) = DBLE(QQ(6))
22699 PD(-3) = DBLE(QQ(3))
22700 PD(-2) = DBLE(QQ(4))
22701 PD(-1) = DBLE(QQ(5))
22702 PD(0) = DBLE(QQ(7))
22703 PD(1) = DBLE(QQ(2))
22704 PD(2) = DBLE(QQ(1))
22705 PD(3) = DBLE(QQ(3))
22706 PD(4) = DBLE(QQ(6))
22707 PD(5) = 0.D0
22708 PD(6) = 0.D0
22709 IF(IPAR.EQ.45) THEN
22710 CDN = (PD(1)-PD(-1))/2.D0
22711 CUP = (PD(2)-PD(-2))/2.D0
22712 PD(-1) = PD(-1) + CDN
22713 PD(-2) = PD(-2) + CUP
22714 PD(1) = PD(-1)
22715 PD(2) = PD(-2)
22716 ENDIF
22717 F2 = 4.0D0/9.0D0*(PD(2)-PD(3)+2.0D0*PD(3))+
22718 & 1.0D0/9.0D0*(PD(1)-PD(3)+2.0D0*PD(3))+
22719 & 1.0D0/9.0D0*(2.0D0*PD(3))+4.0D0/9.0D0*(2.0D0*PD(4))
22720 END
22721C
22722
22723*$ CREATE DT_PDF0.FOR
22724*COPY DT_PDF0
22725*
22726*===pdf0===============================================================*
22727*
22728 SUBROUTINE DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22729
22730************************************************************************
22731* This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 *
22732* an F_2-ansatz given in Capella et al. PLB 337(1994)358. *
22733* IPAR = 2212 proton *
22734* = 100 deuteron *
22735* This version dated 31.01.96 is written by S. Roesler *
22736************************************************************************
22737
22738 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22739 SAVE
22740 PARAMETER ( LINP = 10 ,
22741 & LOUT = 6 ,
22742 & LDAT = 9 )
22743 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22744
22745 PARAMETER (
22746 & AA = 0.1502D0,
22747 & BBDEU = 1.2D0,
22748 & BUD = 0.754D0,
22749 & BDD = 0.4495D0,
22750 & BUP = 1.2064D0,
22751 & BDP = 0.1798D0,
22752 & DELTA0 = 0.07684D0,
22753 & D = 1.117D0,
22754 & C = 3.5489D0,
22755 & A = 0.2631D0,
22756 & B = 0.6452D0,
22757 & ALPHAR = 0.415D0,
22758 & E = 0.1D0
22759 & )
22760
22761 PARAMETER (NPOINT=16)
22762C DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
22763 DIMENSION SEA(3),VAL(2)
22764
22765 DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22766 AN = 1.5D0*(1.0D0+Q2/(Q2+C))
22767* proton, deuteron
22768 IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22769 CALL DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22770 SEA(1) = 0.75D0*SEA0
22771 SEA(2) = SEA(1)
22772 SEA(3) = SEA(1)
22773 VAL(1) = 9.0D0/4.0D0*VALU0
22774 VAL(2) = 9.0D0*VALD0
22775 GLU0 = SEA(1)/(1.0D0-X)
22776 F2 = SEA0+VALU0+VALD0
22777 F2PDF = 4.0D0/9.0D0*(VAL(1)+2.0D0*SEA(1))+
22778 & 1.0D0/9.0D0*(VAL(2)+2.0D0*SEA(2))+
22779 & 1.0D0/9.0D0*(2.0D0*SEA(3))
22780 IF (ABS(F2-F2PDF).GT.TINY9) THEN
22781 WRITE(LOUT,'(1X,A,2E15.5)') 'inconsistent PDF! ',F2,F2PDF
22782 STOP
22783 ENDIF
22784**PHOJET105a
22785C CALL GSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22786**PHOJET112
22787C CALL PHO_GAUSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22788**
22789C SUMQ = ZERO
22790C SUMG = ZERO
22791C DO 1 J=1,NPOINT
22792C CALL DT_CKMTQ0(Q2,ABSZX(J),IPAR,VALU0,VALD0,SEA0)
22793C VALU0 = 9.0D0/4.0D0*VALU0
22794C VALD0 = 9.0D0*VALD0
22795C SEA0 = 0.75D0*SEA0
22796C SUMQ = SUMQ+ (VALU0+VALD0+6.0D0*SEA0) *WEIGHT(J)
22797C SUMG = SUMG+ (SEA0/(1.0D0-ABSZX(J))) *WEIGHT(J)
22798C 1 CONTINUE
22799C GLU = GLU0*(1.0D0-SUMQ)/SUMG
22800 ELSE
22801 WRITE(LOUT,'(1X,A,I4,A)')
22802 & 'PDF0: IPAR =',IPAR,' not implemented!'
22803 STOP
22804 ENDIF
22805
22806 RETURN
22807 END
22808
22809*$ CREATE DT_CKMTQ0.FOR
22810*COPY DT_CKMTQ0
22811*
22812*===ckmtq0=============================================================*
22813*
22814 SUBROUTINE DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22815
22816************************************************************************
22817* This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 *
22818* an F_2-ansatz given in Capella et al. PLB 337(1994)358. *
22819* IPAR = 2212 proton *
22820* = 100 deuteron *
22821* This version dated 31.01.96 is written by S. Roesler *
22822************************************************************************
22823
22824 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22825 SAVE
22826 PARAMETER ( LINP = 10 ,
22827 & LOUT = 6 ,
22828 & LDAT = 9 )
22829 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22830
22831 PARAMETER (
22832 & AA = 0.1502D0,
22833 & BBDEU = 1.2D0,
22834 & BUD = 0.754D0,
22835 & BDD = 0.4495D0,
22836 & BUP = 1.2064D0,
22837 & BDP = 0.1798D0,
22838 & DELTA0 = 0.07684D0,
22839 & D = 1.117D0,
22840 & C = 3.5489D0,
22841 & A = 0.2631D0,
22842 & B = 0.6452D0,
22843 & ALPHAR = 0.415D0,
22844 & E = 0.1D0
22845 & )
22846
22847 DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22848 AN = 1.5D0*(1.0D0+Q2/(Q2+C))
22849* proton, deuteron
22850 IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22851 IF (IPAR.EQ.2212) THEN
22852 BU = BUP
22853 BD = BDP
22854 ELSE
22855 BU = BUD
22856 BD = BDD
22857 ENDIF
22858 SEA0 = AA*X**(-DELTA)*(1.0D0-X)**(AN+4.0D0)*
22859 & (Q2/(Q2+A))**(1.0D0+DELTA)
22860 VALU0 = BU*X**(1.0D0-ALPHAR)*(1.0D0-X)**AN*
22861 & (Q2/(Q2+B))**(ALPHAR)
22862 VALD0 = BD*X**(1.0D0-ALPHAR)*(1.0D0-X)**(AN+1.0D0)*
22863 & (Q2/(Q2+B))**(ALPHAR)
22864 ELSE
22865 WRITE(LOUT,'(1X,A,I4,A)')
22866 & 'CKMTQ0: IPAR =',IPAR,' not implemented!'
22867 STOP
22868 ENDIF
22869 RETURN
22870 END
22871C
22872C
22873
22874*$ CREATE DT_CKMTDE.FOR
22875*COPY DT_CKMTDE
22876 SUBROUTINE DT_CKMTDE(I,NDRV,X,S,ANS)
22877C
22878C**********************************************************************
22879C Deuteron - PDFs
22880C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
22881C ANS = PDF(I)
22882C This version by S. Roesler, 30.01.96
22883C**********************************************************************
22884
22885 SAVE
22886 DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
22887 EQUIVALENCE (GF(1,1,1),DL(1))
22888 DATA DELTA/.13/
22889C
22890 DATA (DL(K),K= 1, 85) /
22891 &0.351858E+00,0.388489E+00,0.325356E+00,0.325356E+00,0.325356E+00,
22892 &0.325356E+00,0.445218E+01,0.000000E+00,0.419818E+00,0.459249E+00,
22893 &0.391167E+00,0.391143E+00,0.391125E+00,0.391167E+00,0.628186E+01,
22894 &0.703797E-01,0.498333E+00,0.540626E+00,0.467466E+00,0.467423E+00,
22895 &0.467393E+00,0.467466E+00,0.837368E+01,0.151191E+00,0.587839E+00,
22896 &0.633058E+00,0.554689E+00,0.554630E+00,0.554595E+00,0.554689E+00,
22897 &0.107170E+02,0.242877E+00,0.688652E+00,0.736861E+00,0.653150E+00,
22898 &0.653080E+00,0.653046E+00,0.653150E+00,0.132960E+02,0.345760E+00,
22899 &0.800961E+00,0.852226E+00,0.763038E+00,0.762961E+00,0.762933E+00,
22900 &0.763038E+00,0.160884E+02,0.460033E+00,0.924829E+00,0.979213E+00,
22901 &0.884414E+00,0.884335E+00,0.884319E+00,0.884414E+00,0.190679E+02,
22902 &0.585764E+00,0.106016E+01,0.111773E+01,0.101719E+01,0.101711E+01,
22903 &0.101711E+01,0.101719E+01,0.222033E+02,0.722864E+00,0.120670E+01,
22904 &0.126752E+01,0.116110E+01,0.116102E+01,0.116105E+01,0.116110E+01,
22905 &0.254603E+02,0.871079E+00,0.136402E+01,0.142815E+01,0.131571E+01,
22906 &0.131565E+01,0.131570E+01,0.131571E+01,0.288020E+02,0.102998E+01,
22907 &0.153151E+01,0.159900E+01,0.148043E+01,0.148038E+01,0.148046E+01/
22908 DATA (DL(K),K= 86, 170) /
22909 &0.148043E+01,0.321898E+02,0.119897E+01,0.170838E+01,0.177930E+01,
22910 &0.165447E+01,0.165444E+01,0.165455E+01,0.165447E+01,0.355845E+02,
22911 &0.137726E+01,0.189369E+01,0.196807E+01,0.183687E+01,0.183686E+01,
22912 &0.183701E+01,0.183687E+01,0.389473E+02,0.156390E+01,0.208631E+01,
22913 &0.216422E+01,0.202653E+01,0.202654E+01,0.202673E+01,0.202653E+01,
22914 &0.422402E+02,0.175779E+01,0.228501E+01,0.236648E+01,0.222220E+01,
22915 &0.222224E+01,0.222248E+01,0.222220E+01,0.454277E+02,0.195768E+01,
22916 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22917 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22918 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22919 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22920 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22921 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22922 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22923 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22924 &0.326035E+00,0.380777E+00,0.286363E+00,0.286363E+00,0.286363E+00,
22925 &0.286363E+00,0.392252E+01,-.138778E-16,0.380092E+00,0.438587E+00/
22926 DATA (DL(K),K= 171, 255) /
22927 &0.337452E+00,0.337430E+00,0.337424E+00,0.337452E+00,0.532193E+01,
22928 &0.553645E-01,0.440879E+00,0.503177E+00,0.395208E+00,0.395169E+00,
22929 &0.395165E+00,0.395208E+00,0.686454E+01,0.117354E+00,0.508415E+00,
22930 &0.574566E+00,0.459649E+00,0.459600E+00,0.459604E+00,0.459649E+00,
22931 &0.853316E+01,0.185994E+00,0.582647E+00,0.652699E+00,0.530722E+00,
22932 &0.530667E+00,0.530687E+00,0.530722E+00,0.103093E+02,0.261237E+00,
22933 &0.663404E+00,0.737405E+00,0.608254E+00,0.608199E+00,0.608241E+00,
22934 &0.608254E+00,0.121710E+02,0.342917E+00,0.750429E+00,0.828423E+00,
22935 &0.691990E+00,0.691941E+00,0.692009E+00,0.691990E+00,0.140946E+02,
22936 &0.430783E+00,0.843361E+00,0.925391E+00,0.781571E+00,0.781533E+00,
22937 &0.781632E+00,0.781571E+00,0.160553E+02,0.524479E+00,0.941741E+00,
22938 &0.102784E+01,0.876538E+00,0.876515E+00,0.876650E+00,0.876538E+00,
22939 &0.180277E+02,0.623549E+00,0.104501E+01,0.113521E+01,0.976335E+00,
22940 &0.976332E+00,0.976506E+00,0.976335E+00,0.199863E+02,0.727439E+00,
22941 &0.115251E+01,0.124685E+01,0.108031E+01,0.108034E+01,0.108055E+01,
22942 &0.108031E+01,0.219066E+02,0.835506E+00,0.126352E+01,0.136201E+01,
22943 &0.118775E+01,0.118780E+01,0.118806E+01,0.118775E+01,0.237652E+02/
22944 DATA (DL(K),K= 256, 340) /
22945 &0.947020E+00,0.137724E+01,0.147989E+01,0.129783E+01,0.129791E+01,
22946 &0.129822E+01,0.129783E+01,0.255406E+02,0.106119E+01,0.149279E+01,
22947 &0.159961E+01,0.140972E+01,0.140984E+01,0.141019E+01,0.140972E+01,
22948 &0.272135E+02,0.117715E+01,0.160929E+01,0.172028E+01,0.152252E+01,
22949 &0.152267E+01,0.152308E+01,0.152252E+01,0.287669E+02,0.129402E+01,
22950 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22951 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22952 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22953 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22954 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22955 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22956 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22957 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22958 &0.309785E+00,0.391282E+00,0.250518E+00,0.250518E+00,0.250518E+00,
22959 &0.250518E+00,0.343842E+01,-.138778E-16,0.352113E+00,0.438463E+00,
22960 &0.288877E+00,0.288863E+00,0.288878E+00,0.288877E+00,0.446765E+01,
22961 &0.424850E-01,0.398382E+00,0.489596E+00,0.331132E+00,0.331111E+00/
22962 DATA (DL(K),K= 341, 425) /
22963 &0.331148E+00,0.331132E+00,0.555902E+01,0.888369E-01,0.448375E+00,
22964 &0.544458E+00,0.377064E+00,0.377043E+00,0.377108E+00,0.377064E+00,
22965 &0.669490E+01,0.138845E+00,0.501854E+00,0.602811E+00,0.426440E+00,
22966 &0.426425E+00,0.426523E+00,0.426440E+00,0.785892E+01,0.192281E+00,
22967 &0.558506E+00,0.664331E+00,0.478946E+00,0.478944E+00,0.479079E+00,
22968 &0.478946E+00,0.903368E+01,0.248834E+00,0.617972E+00,0.728657E+00,
22969 &0.534229E+00,0.534244E+00,0.534421E+00,0.534229E+00,0.102022E+02,
22970 &0.308155E+00,0.679844E+00,0.795370E+00,0.591883E+00,0.591921E+00,
22971 &0.592141E+00,0.591883E+00,0.113479E+02,0.369841E+00,0.743667E+00,
22972 &0.864009E+00,0.651460E+00,0.651525E+00,0.651792E+00,0.651460E+00,
22973 &0.124553E+02,0.433447E+00,0.808951E+00,0.934073E+00,0.712474E+00,
22974 &0.712571E+00,0.712885E+00,0.712474E+00,0.135102E+02,0.498486E+00,
22975 &0.875171E+00,0.100503E+01,0.774408E+00,0.774541E+00,0.774902E+00,
22976 &0.774408E+00,0.144999E+02,0.564446E+00,0.941784E+00,0.107632E+01,
22977 &0.836726E+00,0.836897E+00,0.837307E+00,0.836726E+00,0.154136E+02,
22978 &0.630788E+00,0.100823E+01,0.114738E+01,0.898879E+00,0.899092E+00,
22979 &0.899551E+00,0.898879E+00,0.162423E+02,0.696967E+00,0.107396E+01/
22980 DATA (DL(K),K= 426, 510) /
22981 &0.121764E+01,0.960319E+00,0.960577E+00,0.961084E+00,0.960319E+00,
22982 &0.169791E+02,0.762433E+00,0.113843E+01,0.128655E+01,0.102051E+01,
22983 &0.102081E+01,0.102137E+01,0.102051E+01,0.176190E+02,0.826647E+00,
22984 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22985 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22986 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22987 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22988 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22989 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22990 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22991 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22992 &0.304680E+00,0.425088E+00,0.216504E+00,0.216504E+00,0.216504E+00,
22993 &0.216504E+00,0.298356E+01,0.000000E+00,0.337300E+00,0.463627E+00,
22994 &0.244023E+00,0.244024E+00,0.244063E+00,0.244023E+00,0.370271E+01,
22995 &0.316585E-01,0.371787E+00,0.503942E+00,0.273415E+00,0.273423E+00,
22996 &0.273505E+00,0.273415E+00,0.443039E+01,0.651685E-01,0.407853E+00,
22997 &0.545739E+00,0.304395E+00,0.304418E+00,0.304545E+00,0.304395E+00/
22998 DATA (DL(K),K= 511, 595) /
22999 &0.515321E+01,0.100252E+00,0.445229E+00,0.588741E+00,0.336700E+00,
23000 &0.336744E+00,0.336918E+00,0.336700E+00,0.586004E+01,0.136648E+00,
23001 &0.483606E+00,0.632629E+00,0.370026E+00,0.370095E+00,0.370318E+00,
23002 &0.370026E+00,0.654027E+01,0.174056E+00,0.522666E+00,0.677074E+00,
23003 &0.404062E+00,0.404162E+00,0.404433E+00,0.404062E+00,0.718442E+01,
23004 &0.212167E+00,0.562075E+00,0.721735E+00,0.438483E+00,0.438618E+00,
23005 &0.438938E+00,0.438483E+00,0.778423E+01,0.250658E+00,0.601494E+00,
23006 &0.766258E+00,0.472959E+00,0.473131E+00,0.473500E+00,0.472959E+00,
23007 &0.833276E+01,0.289199E+00,0.640580E+00,0.810290E+00,0.507156E+00,
23008 &0.507369E+00,0.507784E+00,0.507156E+00,0.882448E+01,0.327457E+00,
23009 &0.678993E+00,0.853479E+00,0.540747E+00,0.541003E+00,0.541463E+00,
23010 &0.540747E+00,0.925529E+01,0.365104E+00,0.716405E+00,0.895483E+00,
23011 &0.573411E+00,0.573714E+00,0.574216E+00,0.573411E+00,0.962250E+01,
23012 &0.401821E+00,0.752501E+00,0.935975E+00,0.604848E+00,0.605197E+00,
23013 &0.605740E+00,0.604848E+00,0.992478E+01,0.437304E+00,0.786987E+00,
23014 &0.974647E+00,0.634775E+00,0.635173E+00,0.635752E+00,0.634775E+00,
23015 &0.101620E+02,0.471269E+00,0.819594E+00,0.101122E+01,0.662936E+00/
23016 DATA (DL(K),K= 596, 680) /
23017 &0.663382E+00,0.663995E+00,0.662936E+00,0.103354E+02,0.503459E+00,
23018 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23019 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23020 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23021 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23022 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23023 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23024 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23025 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23026 &0.312661E+00,0.487836E+00,0.182562E+00,0.182562E+00,0.182562E+00,
23027 &0.182562E+00,0.253626E+01,0.000000E+00,0.336910E+00,0.518440E+00,
23028 &0.200702E+00,0.200721E+00,0.200779E+00,0.200702E+00,0.299460E+01,
23029 &0.224425E-01,0.361554E+00,0.549164E+00,0.219359E+00,0.219402E+00,
23030 &0.219517E+00,0.219359E+00,0.343183E+01,0.453742E-01,0.386348E+00,
23031 &0.579759E+00,0.238296E+00,0.238367E+00,0.238536E+00,0.238296E+00,
23032 &0.384076E+01,0.685610E-01,0.411080E+00,0.610003E+00,0.257305E+00,
23033 &0.257408E+00,0.257630E+00,0.257305E+00,0.421619E+01,0.917987E-01/
23034 DATA (DL(K),K= 681, 765) /
23035 &0.435528E+00,0.639668E+00,0.276174E+00,0.276313E+00,0.276583E+00,
23036 &0.276174E+00,0.455400E+01,0.114876E+00,0.459476E+00,0.668531E+00,
23037 &0.294698E+00,0.294875E+00,0.295191E+00,0.294698E+00,0.485107E+01,
23038 &0.137589E+00,0.482719E+00,0.696375E+00,0.312682E+00,0.312900E+00,
23039 &0.313258E+00,0.312682E+00,0.510539E+01,0.159742E+00,0.505060E+00,
23040 &0.722995E+00,0.329941E+00,0.330200E+00,0.330596E+00,0.329941E+00,
23041 &0.531589E+01,0.181149E+00,0.526315E+00,0.748199E+00,0.346303E+00,
23042 &0.346604E+00,0.347034E+00,0.346303E+00,0.548250E+01,0.201638E+00,
23043 &0.546317E+00,0.771808E+00,0.361613E+00,0.361957E+00,0.362418E+00,
23044 &0.361613E+00,0.560595E+01,0.221052E+00,0.564917E+00,0.793667E+00,
23045 &0.375735E+00,0.376122E+00,0.376609E+00,0.375735E+00,0.568772E+01,
23046 &0.239253E+00,0.581987E+00,0.813638E+00,0.388553E+00,0.388982E+00,
23047 &0.389491E+00,0.388553E+00,0.572992E+01,0.256122E+00,0.597419E+00,
23048 &0.831608E+00,0.399972E+00,0.400443E+00,0.400970E+00,0.399972E+00,
23049 &0.573516E+01,0.271562E+00,0.611129E+00,0.847487E+00,0.409919E+00,
23050 &0.410430E+00,0.410972E+00,0.409919E+00,0.570642E+01,0.285497E+00,
23051 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23052 DATA (DL(K),K= 766, 850) /
23053 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23054 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23055 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23056 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23057 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23058 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23059 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23060 &0.335149E+00,0.582072E+00,0.146415E+00,0.146415E+00,0.146415E+00,
23061 &0.146415E+00,0.206772E+01,0.000000E+00,0.351552E+00,0.603437E+00,
23062 &0.156515E+00,0.156542E+00,0.156595E+00,0.156515E+00,0.231143E+01,
23063 &0.146091E-01,0.367407E+00,0.623737E+00,0.166387E+00,0.166442E+00,
23064 &0.166542E+00,0.166387E+00,0.252488E+01,0.289315E-01,0.382571E+00,
23065 &0.642832E+00,0.175891E+00,0.175976E+00,0.176118E+00,0.175891E+00,
23066 &0.270658E+01,0.428312E-01,0.396926E+00,0.660609E+00,0.184917E+00,
23067 &0.185034E+00,0.185212E+00,0.184917E+00,0.285608E+01,0.561981E-01,
23068 &0.410365E+00,0.676962E+00,0.193365E+00,0.193513E+00,0.193722E+00,
23069 &0.193365E+00,0.297375E+01,0.689319E-01,0.422792E+00,0.691796E+00/
23070 DATA (DL(K),K= 851, 935) /
23071 &0.201144E+00,0.201324E+00,0.201560E+00,0.201144E+00,0.306050E+01,
23072 &0.809434E-01,0.434123E+00,0.705030E+00,0.208181E+00,0.208393E+00,
23073 &0.208650E+00,0.208181E+00,0.311775E+01,0.921567E-01,0.444287E+00,
23074 &0.716596E+00,0.214413E+00,0.214656E+00,0.214931E+00,0.214413E+00,
23075 &0.314738E+01,0.102508E+00,0.453228E+00,0.726441E+00,0.219792E+00,
23076 &0.220066E+00,0.220354E+00,0.219792E+00,0.315156E+01,0.111949E+00,
23077 &0.460906E+00,0.734527E+00,0.224285E+00,0.224589E+00,0.224886E+00,
23078 &0.224285E+00,0.313271E+01,0.120441E+00,0.467291E+00,0.740835E+00,
23079 &0.227870E+00,0.228203E+00,0.228506E+00,0.227870E+00,0.309338E+01,
23080 &0.127963E+00,0.472372E+00,0.745357E+00,0.230541E+00,0.230902E+00,
23081 &0.231208E+00,0.230541E+00,0.303621E+01,0.134506E+00,0.476148E+00,
23082 &0.748105E+00,0.232304E+00,0.232690E+00,0.232996E+00,0.232304E+00,
23083 &0.296381E+01,0.140070E+00,0.478635E+00,0.749103E+00,0.233176E+00,
23084 &0.233586E+00,0.233889E+00,0.233176E+00,0.287874E+01,0.144672E+00,
23085 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23086 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23087 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23088 DATA (DL(K),K= 936, 1020) /
23089 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23090 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23091 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23092 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23093 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23094 &0.370162E+00,0.695827E+00,0.105823E+00,0.105823E+00,0.105823E+00,
23095 &0.105823E+00,0.154556E+01,0.208167E-16,0.378214E+00,0.703794E+00,
23096 &0.109539E+00,0.109554E+00,0.109571E+00,0.109539E+00,0.162770E+01,
23097 &0.818783E-02,0.385258E+00,0.710067E+00,0.112818E+00,0.112847E+00,
23098 &0.112879E+00,0.112818E+00,0.168578E+01,0.158212E-01,0.391264E+00,
23099 &0.714648E+00,0.115620E+00,0.115666E+00,0.115709E+00,0.115620E+00,
23100 &0.172175E+01,0.228667E-01,0.396214E+00,0.717539E+00,0.117923E+00,
23101 &0.117985E+00,0.118037E+00,0.117923E+00,0.173756E+01,0.293009E-01,
23102 &0.400098E+00,0.718759E+00,0.119711E+00,0.119790E+00,0.119848E+00,
23103 &0.119711E+00,0.173541E+01,0.351123E-01,0.402915E+00,0.718332E+00,
23104 &0.120979E+00,0.121074E+00,0.121137E+00,0.120979E+00,0.171755E+01,
23105 &0.402951E-01,0.404672E+00,0.716292E+00,0.121728E+00,0.121840E+00/
23106 DATA (DL(K),K= 1021, 1105) /
23107 &0.121905E+00,0.121728E+00,0.168619E+01,0.448514E-01,0.405385E+00,
23108 &0.712681E+00,0.121967E+00,0.122095E+00,0.122161E+00,0.121967E+00,
23109 &0.164352E+01,0.487902E-01,0.405077E+00,0.707551E+00,0.121712E+00,
23110 &0.121855E+00,0.121920E+00,0.121712E+00,0.159162E+01,0.521265E-01,
23111 &0.403778E+00,0.700963E+00,0.120984E+00,0.121141E+00,0.121204E+00,
23112 &0.120984E+00,0.153245E+01,0.548814E-01,0.401525E+00,0.692984E+00,
23113 &0.119809E+00,0.119980E+00,0.120040E+00,0.119809E+00,0.146780E+01,
23114 &0.570807E-01,0.398361E+00,0.683691E+00,0.118218E+00,0.118402E+00,
23115 &0.118457E+00,0.118218E+00,0.139928E+01,0.587542E-01,0.394333E+00,
23116 &0.673166E+00,0.116244E+00,0.116440E+00,0.116490E+00,0.116244E+00,
23117 &0.132834E+01,0.599355E-01,0.389495E+00,0.661496E+00,0.113924E+00,
23118 &0.114131E+00,0.114175E+00,0.113924E+00,0.125620E+01,0.606602E-01,
23119 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23120 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23121 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23122 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23123 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23124 DATA (DL(K),K= 1106, 1190) /
23125 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23126 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23127 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23128 &0.394012E+00,0.757115E+00,0.772117E-01,0.772117E-01,0.772117E-01,
23129 &0.772117E-01,0.117279E+01,0.346945E-17,0.395841E+00,0.752988E+00,
23130 &0.780501E-01,0.780655E-01,0.780723E-01,0.780501E-01,0.118528E+01,
23131 &0.491697E-02,0.396627E+00,0.747223E+00,0.785386E-01,0.785692E-01,
23132 &0.785806E-01,0.785386E-01,0.118242E+01,0.932754E-02,0.396401E+00,
23133 &0.739901E+00,0.786820E-01,0.787273E-01,0.787413E-01,0.786820E-01,
23134 &0.116673E+01,0.132427E-01,0.395190E+00,0.731092E+00,0.784870E-01,
23135 &0.785464E-01,0.785613E-01,0.784870E-01,0.114033E+01,0.166738E-01,
23136 &0.393030E+00,0.720878E+00,0.779683E-01,0.780410E-01,0.780555E-01,
23137 &0.779683E-01,0.110528E+01,0.196392E-01,0.389962E+00,0.709342E+00,
23138 &0.771427E-01,0.772280E-01,0.772409E-01,0.771427E-01,0.106344E+01,
23139 &0.221591E-01,0.386027E+00,0.696571E+00,0.760304E-01,0.761276E-01,
23140 &0.761378E-01,0.760304E-01,0.101653E+01,0.242567E-01,0.381274E+00,
23141 &0.682657E+00,0.746543E-01,0.747623E-01,0.747692E-01,0.746543E-01/
23142 DATA (DL(K),K= 1191, 1275) /
23143 &0.966057E+00,0.259571E-01,0.375752E+00,0.667695E+00,0.730389E-01,
23144 &0.731569E-01,0.731598E-01,0.730389E-01,0.913345E+00,0.272876E-01,
23145 &0.369514E+00,0.651782E+00,0.712104E-01,0.713374E-01,0.713358E-01,
23146 &0.712104E-01,0.859530E+00,0.282763E-01,0.362616E+00,0.635021E+00,
23147 &0.691957E-01,0.693307E-01,0.693243E-01,0.691957E-01,0.805566E+00,
23148 &0.289524E-01,0.355116E+00,0.617511E+00,0.670220E-01,0.671640E-01,
23149 &0.671526E-01,0.670220E-01,0.752235E+00,0.293453E-01,0.347072E+00,
23150 &0.599357E+00,0.647162E-01,0.648642E-01,0.648478E-01,0.647162E-01,
23151 &0.700161E+00,0.294844E-01,0.338543E+00,0.580659E+00,0.623046E-01,
23152 &0.624578E-01,0.624363E-01,0.623046E-01,0.649828E+00,0.293983E-01,
23153 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23154 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23155 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23156 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23157 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23158 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23159 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23160 DATA (DL(K),K= 1276, 1360) /
23161 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23162 &0.408305E+00,0.775318E+00,0.509141E-01,0.509141E-01,0.509141E-01,
23163 &0.509141E-01,0.818839E+00,-.867362E-17,0.403619E+00,0.758058E+00,
23164 &0.502245E-01,0.502351E-01,0.502337E-01,0.502245E-01,0.795347E+00,
23165 &0.264045E-02,0.398068E+00,0.739709E+00,0.493454E-01,0.493661E-01,
23166 &0.493626E-01,0.493454E-01,0.764942E+00,0.491508E-02,0.391719E+00,
23167 &0.720394E+00,0.482952E-01,0.483253E-01,0.483192E-01,0.482952E-01,
23168 &0.729624E+00,0.685202E-02,0.384627E+00,0.700222E+00,0.470896E-01,
23169 &0.471285E-01,0.471194E-01,0.470896E-01,0.690906E+00,0.847433E-02,
23170 &0.376851E+00,0.679300E+00,0.457475E-01,0.457946E-01,0.457822E-01,
23171 &0.457475E-01,0.650078E+00,0.980774E-02,0.368452E+00,0.657739E+00,
23172 &0.442875E-01,0.443419E-01,0.443261E-01,0.442875E-01,0.608239E+00,
23173 &0.108769E-01,0.359490E+00,0.635646E+00,0.427281E-01,0.427892E-01,
23174 &0.427698E-01,0.427281E-01,0.566280E+00,0.117061E-01,0.350026E+00,
23175 &0.613128E+00,0.410878E-01,0.411549E-01,0.411320E-01,0.410878E-01,
23176 &0.524918E+00,0.123191E-01,0.340122E+00,0.590292E+00,0.393848E-01,
23177 &0.394571E-01,0.394308E-01,0.393848E-01,0.484713E+00,0.127393E-01/
23178 DATA (DL(K),K= 1361, 1445) /
23179 &0.329838E+00,0.567240E+00,0.376363E-01,0.377132E-01,0.376836E-01,
23180 &0.376363E-01,0.446084E+00,0.129888E-01,0.319236E+00,0.544074E+00,
23181 &0.358589E-01,0.359396E-01,0.359068E-01,0.358589E-01,0.409328E+00,
23182 &0.130888E-01,0.308374E+00,0.520890E+00,0.340678E-01,0.341517E-01,
23183 &0.341160E-01,0.340678E-01,0.374641E+00,0.130594E-01,0.297312E+00,
23184 &0.497781E+00,0.322772E-01,0.323636E-01,0.323253E-01,0.322772E-01,
23185 &0.342135E+00,0.129195E-01,0.286106E+00,0.474837E+00,0.304999E-01,
23186 &0.305882E-01,0.305474E-01,0.304999E-01,0.311854E+00,0.126863E-01,
23187 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23188 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23189 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23190 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23191 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23192 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23193 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23194 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23195 &0.407248E+00,0.746438E+00,0.335640E-01,0.335640E-01,0.335640E-01/
23196 DATA (DL(K),K= 1446, 1530) /
23197 &0.335640E-01,0.573540E+00,0.173472E-16,0.397516E+00,0.719825E+00,
23198 &0.324649E-01,0.324735E-01,0.324698E-01,0.324649E-01,0.540770E+00,
23199 &0.147177E-02,0.387197E+00,0.692869E+00,0.312911E-01,0.313075E-01,
23200 &0.313000E-01,0.312911E-01,0.505972E+00,0.269995E-02,0.376365E+00,
23201 &0.665689E+00,0.300576E-01,0.300811E-01,0.300699E-01,0.300576E-01,
23202 &0.470389E+00,0.371147E-02,0.365085E+00,0.638387E+00,0.287770E-01,
23203 &0.288070E-01,0.287922E-01,0.287770E-01,0.434885E+00,0.452768E-02,
23204 &0.353423E+00,0.611066E+00,0.274623E-01,0.274980E-01,0.274797E-01,
23205 &0.274623E-01,0.400103E+00,0.516996E-02,0.341442E+00,0.583823E+00,
23206 &0.261256E-01,0.261663E-01,0.261448E-01,0.261256E-01,0.366541E+00,
23207 &0.565807E-02,0.329207E+00,0.556753E+00,0.247782E-01,0.248234E-01,
23208 &0.247989E-01,0.247782E-01,0.334555E+00,0.601048E-02,0.316777E+00,
23209 &0.529946E+00,0.234308E-01,0.234798E-01,0.234525E-01,0.234308E-01,
23210 &0.304384E+00,0.624451E-02,0.304214E+00,0.503489E+00,0.220932E-01,
23211 &0.221452E-01,0.221155E-01,0.220932E-01,0.276170E+00,0.637618E-02,
23212 &0.291575E+00,0.477462E+00,0.207739E-01,0.208286E-01,0.207966E-01,
23213 &0.207739E-01,0.249976E+00,0.642028E-02,0.278917E+00,0.451941E+00/
23214 DATA (DL(K),K= 1531, 1615) /
23215 &0.194809E-01,0.195376E-01,0.195037E-01,0.194809E-01,0.225809E+00,
23216 &0.639038E-02,0.266293E+00,0.426995E+00,0.182209E-01,0.182791E-01,
23217 &0.182436E-01,0.182209E-01,0.203629E+00,0.629880E-02,0.253754E+00,
23218 &0.402686E+00,0.169996E-01,0.170587E-01,0.170219E-01,0.169996E-01,
23219 &0.183361E+00,0.615665E-02,0.241347E+00,0.379071E+00,0.158217E-01,
23220 &0.158814E-01,0.158436E-01,0.158217E-01,0.164907E+00,0.597385E-02,
23221 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23222 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23223 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23224 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23225 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23226 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23227 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23228 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23229 &0.395106E+00,0.689399E+00,0.218554E-01,0.218554E-01,0.218554E-01,
23230 &0.218554E-01,0.398362E+00,-.173472E-17,0.381441E+00,0.656777E+00,
23231 &0.207816E-01,0.207886E-01,0.207844E-01,0.207816E-01,0.366703E+00/
23232 DATA (DL(K),K= 1616, 1700) /
23233 &0.826643E-03,0.367505E+00,0.624578E+00,0.197001E-01,0.197133E-01,
23234 &0.197053E-01,0.197001E-01,0.335573E+00,0.149886E-02,0.353373E+00,
23235 &0.592889E+00,0.186195E-01,0.186383E-01,0.186266E-01,0.186195E-01,
23236 &0.305590E+00,0.203730E-02,0.339106E+00,0.561783E+00,0.175468E-01,
23237 &0.175705E-01,0.175555E-01,0.175468E-01,0.277136E+00,0.245817E-02,
23238 &0.324766E+00,0.531331E+00,0.164887E-01,0.165166E-01,0.164986E-01,
23239 &0.164887E-01,0.250424E+00,0.277666E-02,0.310411E+00,0.501599E+00,
23240 &0.154510E-01,0.154825E-01,0.154618E-01,0.154510E-01,0.225588E+00,
23241 &0.300658E-02,0.296100E+00,0.472648E+00,0.144390E-01,0.144735E-01,
23242 &0.144504E-01,0.144390E-01,0.202681E+00,0.316040E-02,0.281885E+00,
23243 &0.444535E+00,0.134570E-01,0.134940E-01,0.134689E-01,0.134570E-01,
23244 &0.181693E+00,0.324944E-02,0.267820E+00,0.417309E+00,0.125091E-01,
23245 &0.125481E-01,0.125212E-01,0.125091E-01,0.162572E+00,0.328396E-02,
23246 &0.253953E+00,0.391017E+00,0.115984E-01,0.116389E-01,0.116106E-01,
23247 &0.115984E-01,0.145235E+00,0.327313E-02,0.240328E+00,0.365695E+00,
23248 &0.107275E-01,0.107690E-01,0.107396E-01,0.107275E-01,0.129575E+00,
23249 &0.322510E-02,0.226989E+00,0.341375E+00,0.989805E-02,0.994030E-02/
23250 DATA (DL(K),K= 1701, 1785) /
23251 &0.990998E-02,0.989805E-02,0.115477E+00,0.314713E-02,0.213972E+00,
23252 &0.318081E+00,0.911149E-02,0.915408E-02,0.912316E-02,0.911149E-02,
23253 &0.102820E+00,0.304556E-02,0.201311E+00,0.295830E+00,0.836852E-02,
23254 &0.841111E-02,0.837984E-02,0.836852E-02,0.914804E-01,0.292596E-02,
23255 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23256 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23257 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23258 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23259 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23260 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23261 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23262 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23263 &0.374678E+00,0.616087E+00,0.139531E-01,0.139531E-01,0.139531E-01,
23264 &0.139531E-01,0.272491E+00,-.693889E-17,0.358052E+00,0.580345E+00,
23265 &0.130624E-01,0.130680E-01,0.130641E-01,0.130624E-01,0.245861E+00,
23266 &0.460255E-03,0.341487E+00,0.545719E+00,0.121971E-01,0.122076E-01,
23267 &0.122002E-01,0.121971E-01,0.220877E+00,0.826785E-03,0.325046E+00/
23268 DATA (DL(K),K= 1786, 1870) /
23269 &0.512244E+00,0.113599E-01,0.113748E-01,0.113641E-01,0.113599E-01,
23270 &0.197730E+00,0.111366E-02,0.308783E+00,0.479952E+00,0.105534E-01,
23271 &0.105720E-01,0.105585E-01,0.105534E-01,0.176497E+00,0.133192E-02,
23272 &0.292747E+00,0.448868E+00,0.977938E-02,0.980112E-02,0.978518E-02,
23273 &0.977938E-02,0.157150E+00,0.149139E-02,0.276986E+00,0.419015E+00,
23274 &0.903955E-02,0.906394E-02,0.904584E-02,0.903955E-02,0.139631E+00,
23275 &0.160093E-02,0.261546E+00,0.390412E+00,0.833509E-02,0.836165E-02,
23276 &0.834171E-02,0.833509E-02,0.123850E+00,0.166838E-02,0.246467E+00,
23277 &0.363074E+00,0.766687E-02,0.769516E-02,0.767369E-02,0.766687E-02,
23278 &0.109695E+00,0.170073E-02,0.231787E+00,0.337008E+00,0.703540E-02,
23279 &0.706500E-02,0.704230E-02,0.703540E-02,0.970428E-01,0.170416E-02,
23280 &0.217542E+00,0.312218E+00,0.644083E-02,0.647137E-02,0.644772E-02,
23281 &0.644083E-02,0.857658E-01,0.168409E-02,0.203759E+00,0.288701E+00,
23282 &0.588300E-02,0.591415E-02,0.588981E-02,0.588300E-02,0.757385E-01,
23283 &0.164528E-02,0.190467E+00,0.266449E+00,0.536147E-02,0.539292E-02,
23284 &0.536812E-02,0.536147E-02,0.668383E-01,0.159185E-02,0.177686E+00,
23285 &0.245447E+00,0.487551E-02,0.490698E-02,0.488195E-02,0.487551E-02/
23286 DATA (DL(K),K= 1871, 1955) /
23287 &0.589492E-01,0.152735E-02,0.165434E+00,0.225677E+00,0.442416E-02,
23288 &0.445543E-02,0.443037E-02,0.442416E-02,0.519652E-01,0.145483E-02,
23289 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23290 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23291 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23292 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23293 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23294 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23295 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23296 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23297 &0.348042E+00,0.534691E+00,0.867977E-02,0.867977E-02,0.867977E-02,
23298 &0.867977E-02,0.182547E+00,-.693889E-17,0.329349E+00,0.498248E+00,
23299 &0.800724E-02,0.801198E-02,0.800836E-02,0.800724E-02,0.161948E+00,
23300 &0.250949E-03,0.311047E+00,0.463485E+00,0.737155E-02,0.738040E-02,
23301 &0.737356E-02,0.737155E-02,0.143267E+00,0.447662E-03,0.293181E+00,
23302 &0.430377E+00,0.677169E-02,0.678409E-02,0.677441E-02,0.677169E-02,
23303 &0.126447E+00,0.598803E-03,0.275787E+00,0.398907E+00,0.620726E-02/
23304 DATA (DL(K),K= 1956, 2040) /
23305 &0.622265E-02,0.621051E-02,0.620726E-02,0.111401E+00,0.711280E-03,
23306 &0.258900E+00,0.369051E+00,0.567741E-02,0.569532E-02,0.568106E-02,
23307 &0.567741E-02,0.979944E-01,0.790986E-03,0.242550E+00,0.340785E+00,
23308 &0.518138E-02,0.520134E-02,0.518531E-02,0.518138E-02,0.860936E-01,
23309 &0.843227E-03,0.226765E+00,0.314083E+00,0.471828E-02,0.473987E-02,
23310 &0.472238E-02,0.471828E-02,0.755615E-01,0.872644E-03,0.211568E+00,
23311 &0.288916E+00,0.428714E-02,0.430998E-02,0.429133E-02,0.428714E-02,
23312 &0.662627E-01,0.883319E-03,0.196981E+00,0.265252E+00,0.388691E-02,
23313 &0.391065E-02,0.389112E-02,0.388691E-02,0.580684E-01,0.878818E-03,
23314 &0.183020E+00,0.243053E+00,0.351645E-02,0.354077E-02,0.352060E-02,
23315 &0.351645E-02,0.508578E-01,0.862228E-03,0.169696E+00,0.222280E+00,
23316 &0.317451E-02,0.319914E-02,0.317858E-02,0.317451E-02,0.445190E-01,
23317 &0.836224E-03,0.157017E+00,0.202888E+00,0.285982E-02,0.288450E-02,
23318 &0.286376E-02,0.285982E-02,0.389523E-01,0.803096E-03,0.144987E+00,
23319 &0.184832E+00,0.257101E-02,0.259553E-02,0.257480E-02,0.257101E-02,
23320 &0.340677E-01,0.764787E-03,0.133605E+00,0.168060E+00,0.230670E-02,
23321 &0.233087E-02,0.231031E-02,0.230670E-02,0.297820E-01,0.722929E-03/
23322 DATA (DL(K),K= 2041, 2125) /
23323 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23324 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23325 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23326 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23327 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23328 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23329 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23330 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23331 &0.316867E+00,0.451111E+00,0.522815E-02,0.522815E-02,0.522815E-02,
23332 &0.522815E-02,0.119118E+00,0.889046E-17,0.296950E+00,0.415915E+00,
23333 &0.475497E-02,0.475914E-02,0.475574E-02,0.475497E-02,0.104204E+00,
23334 &0.132513E-03,0.277735E+00,0.382805E+00,0.431809E-02,0.432582E-02,
23335 &0.431944E-02,0.431809E-02,0.910279E-01,0.235347E-03,0.259241E+00,
23336 &0.351694E+00,0.391455E-02,0.392531E-02,0.391637E-02,0.391455E-02,
23337 &0.794222E-01,0.313322E-03,0.241485E+00,0.322517E+00,0.354249E-02,
23338 &0.355575E-02,0.354464E-02,0.354249E-02,0.692354E-01,0.370408E-03,
23339 &0.224480E+00,0.295202E+00,0.319987E-02,0.321518E-02,0.320226E-02/
23340 DATA (DL(K),K= 2126, 2210) /
23341 &0.319987E-02,0.603106E-01,0.409866E-03,0.208235E+00,0.269681E+00,
23342 &0.288490E-02,0.290184E-02,0.288744E-02,0.288490E-02,0.525034E-01,
23343 &0.434663E-03,0.192759E+00,0.245887E+00,0.259589E-02,0.261407E-02,
23344 &0.259852E-02,0.259589E-02,0.456838E-01,0.447393E-03,0.178054E+00,
23345 &0.223752E+00,0.233123E-02,0.235033E-02,0.233390E-02,0.233123E-02,
23346 &0.397318E-01,0.450314E-03,0.164120E+00,0.203207E+00,0.208941E-02,
23347 &0.210910E-02,0.209206E-02,0.208941E-02,0.345396E-01,0.445394E-03,
23348 &0.150954E+00,0.184182E+00,0.186896E-02,0.188897E-02,0.187155E-02,
23349 &0.186896E-02,0.300131E-01,0.434333E-03,0.138548E+00,0.166608E+00,
23350 &0.166844E-02,0.168854E-02,0.167096E-02,0.166844E-02,0.260692E-01,
23351 &0.418584E-03,0.126892E+00,0.150412E+00,0.148650E-02,0.150648E-02,
23352 &0.148891E-02,0.148650E-02,0.226325E-01,0.399380E-03,0.115971E+00,
23353 &0.135523E+00,0.132180E-02,0.134148E-02,0.132409E-02,0.132180E-02,
23354 &0.196374E-01,0.377764E-03,0.105767E+00,0.121870E+00,0.117308E-02,
23355 &0.119231E-02,0.117524E-02,0.117308E-02,0.170312E-01,0.354610E-03,
23356 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23357 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23358 DATA (DL(K),K= 2211, 2295) /
23359 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23360 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23361 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23362 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23363 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23364 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23365 &0.282579E+00,0.369670E+00,0.302765E-02,0.302765E-02,0.302765E-02,
23366 &0.302765E-02,0.752529E-01,-.455365E-17,0.262229E+00,0.337209E+00,
23367 &0.271512E-02,0.271883E-02,0.271564E-02,0.271512E-02,0.651086E-01,
23368 &0.669321E-04,0.242857E+00,0.307069E+00,0.243269E-02,0.243953E-02,
23369 &0.243360E-02,0.243269E-02,0.563252E-01,0.118744E-03,0.224455E+00,
23370 &0.279111E+00,0.217687E-02,0.218631E-02,0.217808E-02,0.217687E-02,
23371 &0.487143E-01,0.157767E-03,0.207014E+00,0.253223E+00,0.194534E-02,
23372 &0.195689E-02,0.194675E-02,0.194534E-02,0.421227E-01,0.186063E-03,
23373 &0.190523E+00,0.229293E+00,0.173585E-02,0.174909E-02,0.173741E-02,
23374 &0.173585E-02,0.364156E-01,0.205286E-03,0.174969E+00,0.207218E+00,
23375 &0.154647E-02,0.156100E-02,0.154811E-02,0.154647E-02,0.314732E-01/
23376 DATA (DL(K),K= 2296, 2380) /
23377 &0.216964E-03,0.160335E+00,0.186895E+00,0.137545E-02,0.139092E-02,
23378 &0.137713E-02,0.137545E-02,0.271927E-01,0.222455E-03,0.146604E+00,
23379 &0.168227E+00,0.122121E-02,0.123733E-02,0.122290E-02,0.122121E-02,
23380 &0.234852E-01,0.222947E-03,0.133756E+00,0.151116E+00,0.108234E-02,
23381 &0.109881E-02,0.108400E-02,0.108234E-02,0.202747E-01,0.219474E-03,
23382 &0.121765E+00,0.135471E+00,0.957502E-03,0.974107E-03,0.959112E-03,
23383 &0.957502E-03,0.174932E-01,0.212928E-03,0.110606E+00,0.121198E+00,
23384 &0.845493E-03,0.862024E-03,0.847037E-03,0.845493E-03,0.150824E-01,
23385 &0.204075E-03,0.100250E+00,0.108210E+00,0.745196E-03,0.761482E-03,
23386 &0.746662E-03,0.745196E-03,0.129965E-01,0.193573E-03,0.906661E-01,
23387 &0.964191E-01,0.655569E-03,0.671466E-03,0.656948E-03,0.655569E-03,
23388 &0.111930E-01,0.181962E-03,0.818218E-01,0.857412E-01,0.575637E-03,
23389 &0.591030E-03,0.576925E-03,0.575637E-03,0.962922E-02,0.169687E-03,
23390 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23391 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23392 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23393 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23394 DATA (DL(K),K= 2381, 2465) /
23395 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23396 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23397 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23398 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23399 &0.246444E+00,0.293515E+00,0.167124E-02,0.167124E-02,0.167124E-02,
23400 &0.167124E-02,0.456929E-01,-.260209E-17,0.226393E+00,0.264836E+00,
23401 &0.147748E-02,0.148085E-02,0.147783E-02,0.147748E-02,0.392393E-01,
23402 &0.318190E-04,0.207552E+00,0.238550E+00,0.130596E-02,0.131212E-02,
23403 &0.130656E-02,0.130596E-02,0.337276E-01,0.566426E-04,0.189877E+00,
23404 &0.214470E+00,0.115347E-02,0.116190E-02,0.115427E-02,0.115347E-02,
23405 &0.290012E-01,0.753776E-04,0.173336E+00,0.192452E+00,0.101789E-02,
23406 &0.102811E-02,0.101881E-02,0.101789E-02,0.249381E-01,0.889466E-04,
23407 &0.157889E+00,0.172355E+00,0.897268E-03,0.908872E-03,0.898270E-03,
23408 &0.897268E-03,0.214419E-01,0.980950E-04,0.143501E+00,0.154046E+00,
23409 &0.789951E-03,0.802565E-03,0.790996E-03,0.789951E-03,0.184296E-01,
23410 &0.103536E-03,0.130132E+00,0.137402E+00,0.694510E-03,0.707811E-03,
23411 &0.695568E-03,0.694510E-03,0.158331E-01,0.105929E-03,0.117743E+00/
23412 DATA (DL(K),K= 2466, 2550) /
23413 &0.122303E+00,0.609684E-03,0.623394E-03,0.610733E-03,0.609684E-03,
23414 &0.135929E-01,0.105853E-03,0.106293E+00,0.108637E+00,0.534365E-03,
23415 &0.548244E-03,0.535386E-03,0.534365E-03,0.116583E-01,0.103825E-03,
23416 &0.957386E-01,0.962976E-01,0.467572E-03,0.481416E-03,0.468551E-03,
23417 &0.467572E-03,0.999103E-02,0.100301E-03,0.860376E-01,0.851820E-01,
23418 &0.408422E-03,0.422062E-03,0.409350E-03,0.408422E-03,0.855563E-02,
23419 &0.956675E-04,0.771455E-01,0.751930E-01,0.356117E-03,0.369416E-03,
23420 &0.356989E-03,0.356117E-03,0.731542E-02,0.902499E-04,0.690178E-01,
23421 &0.662386E-01,0.309950E-03,0.322797E-03,0.310761E-03,0.309950E-03,
23422 &0.624633E-02,0.843305E-04,0.616096E-01,0.582312E-01,0.269281E-03,
23423 &0.281590E-03,0.270030E-03,0.269281E-03,0.533230E-02,0.781441E-04,
23424 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23425 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23426 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23427 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23428 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23429 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23430 DATA (DL(K),K= 2551, 2635) /
23431 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23432 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23433 &0.209608E+00,0.224862E+00,0.869706E-03,0.869706E-03,0.869706E-03,
23434 &0.869706E-03,0.264204E-01,-.138236E-17,0.190523E+00,0.200603E+00,
23435 &0.757542E-03,0.760626E-03,0.757768E-03,0.757542E-03,0.226261E-01,
23436 &0.138827E-04,0.172819E+00,0.178656E+00,0.660281E-03,0.665837E-03,
23437 &0.660670E-03,0.660281E-03,0.194018E-01,0.249832E-04,0.156420E+00,
23438 &0.158805E+00,0.575414E-03,0.582918E-03,0.575917E-03,0.575414E-03,
23439 &0.166434E-01,0.334851E-04,0.141265E+00,0.140883E+00,0.501258E-03,
23440 &0.510252E-03,0.501836E-03,0.501258E-03,0.142710E-01,0.397017E-04,
23441 &0.127291E+00,0.124732E+00,0.436386E-03,0.446473E-03,0.437008E-03,
23442 &0.436386E-03,0.122297E-01,0.439154E-04,0.114437E+00,0.110205E+00,
23443 &0.379575E-03,0.390415E-03,0.380217E-03,0.379575E-03,0.104701E-01,
23444 &0.464110E-04,0.102644E+00,0.971655E-01,0.329805E-03,0.341109E-03,
23445 &0.330448E-03,0.329805E-03,0.895086E-02,0.474758E-04,0.918521E-01,
23446 &0.854876E-01,0.286206E-03,0.297729E-03,0.286836E-03,0.286206E-03,
23447 &0.764249E-02,0.473771E-04,0.820032E-01,0.750529E-01,0.248027E-03/
23448 DATA (DL(K),K= 2636, 2720) /
23449 &0.259564E-03,0.248633E-03,0.248027E-03,0.651744E-02,0.463561E-04,
23450 &0.730394E-01,0.657510E-01,0.214611E-03,0.225995E-03,0.215186E-03,
23451 &0.214611E-03,0.554573E-02,0.446239E-04,0.649040E-01,0.574789E-01,
23452 &0.185396E-03,0.196491E-03,0.185935E-03,0.185396E-03,0.470938E-02,
23453 &0.423722E-04,0.575411E-01,0.501405E-01,0.159891E-03,0.170590E-03,
23454 &0.160391E-03,0.159891E-03,0.399752E-02,0.397689E-04,0.508960E-01,
23455 &0.436466E-01,0.137650E-03,0.147874E-03,0.138111E-03,0.137650E-03,
23456 &0.338807E-02,0.369434E-04,0.449157E-01,0.379141E-01,0.118285E-03,
23457 &0.127973E-03,0.118705E-03,0.118285E-03,0.286125E-02,0.340035E-04,
23458 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23459 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23460 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23461 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23462 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23463 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23464 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23465 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23466 DATA (DL(K),K= 2721, 2805) /
23467 &0.173133E+00,0.165162E+00,0.420483E-03,0.420483E-03,0.420483E-03,
23468 &0.420483E-03,0.143704E-01,0.418773E-17,0.155600E+00,0.145586E+00,
23469 &0.360490E-03,0.363140E-03,0.360629E-03,0.360490E-03,0.123560E-01,
23470 &0.533279E-05,0.139551E+00,0.128113E+00,0.309555E-03,0.314310E-03,
23471 &0.309792E-03,0.309555E-03,0.106262E-01,0.982612E-05,0.124876E+00,
23472 &0.112516E+00,0.265952E-03,0.272344E-03,0.266256E-03,0.265952E-03,
23473 &0.913151E-02,0.133834E-04,0.111490E+00,0.986188E-01,0.228522E-03,
23474 &0.236138E-03,0.228869E-03,0.228522E-03,0.783135E-02,0.160429E-04,
23475 &0.993081E-01,0.862590E-01,0.196336E-03,0.204821E-03,0.196706E-03,
23476 &0.196336E-03,0.670031E-02,0.178799E-04,0.882484E-01,0.752883E-01,
23477 &0.168604E-03,0.177655E-03,0.168981E-03,0.168604E-03,0.572016E-02,
23478 &0.189837E-04,0.782334E-01,0.655714E-01,0.144684E-03,0.154047E-03,
23479 &0.145058E-03,0.144684E-03,0.487276E-02,0.194655E-04,0.691885E-01,
23480 &0.569841E-01,0.124035E-03,0.133497E-03,0.124397E-03,0.124035E-03,
23481 &0.413648E-02,0.194296E-04,0.610420E-01,0.494128E-01,0.106203E-03,
23482 &0.115592E-03,0.106548E-03,0.106203E-03,0.350042E-02,0.189800E-04,
23483 &0.537249E-01,0.427533E-01,0.908141E-04,0.999895E-04,0.911377E-04/
23484 DATA (DL(K),K= 2806, 2890) /
23485 &0.908141E-04,0.295961E-02,0.182192E-04,0.471713E-01,0.369100E-01,
23486 &0.775359E-04,0.863895E-04,0.778360E-04,0.775359E-04,0.249629E-02,
23487 &0.172287E-04,0.413182E-01,0.317957E-01,0.660857E-04,0.745356E-04,
23488 &0.663611E-04,0.660857E-04,0.209482E-02,0.160791E-04,0.361056E-01,
23489 &0.273306E-01,0.562298E-04,0.642173E-04,0.564804E-04,0.562298E-04,
23490 &0.175588E-02,0.148407E-04,0.314766E-01,0.234421E-01,0.477598E-04,
23491 &0.552457E-04,0.479859E-04,0.477598E-04,0.147398E-02,0.135653E-04,
23492 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23493 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23494 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23495 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23496 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23497 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23498 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23499 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23500 &0.138007E+00,0.115214E+00,0.185072E-03,0.185072E-03,0.185072E-03,
23501 &0.185072E-03,0.722856E-02,-.380826E-17,0.122517E+00,0.100251E+00/
23502 DATA (DL(K),K= 2891, 2975) /
23503 &0.155814E-03,0.158287E-03,0.155901E-03,0.155814E-03,0.630580E-02,
23504 &0.155371E-05,0.108535E+00,0.870870E-01,0.131535E-03,0.135909E-03,
23505 &0.131680E-03,0.131535E-03,0.547867E-02,0.304952E-05,0.959260E-01,
23506 &0.754985E-01,0.111183E-03,0.116980E-03,0.111366E-03,0.111183E-03,
23507 &0.473794E-02,0.433106E-05,0.845828E-01,0.653163E-01,0.940433E-04,
23508 &0.100851E-03,0.942493E-04,0.940433E-04,0.407647E-02,0.533613E-05,
23509 &0.744017E-01,0.563870E-01,0.795843E-04,0.870596E-04,0.798007E-04,
23510 &0.795843E-04,0.349165E-02,0.606691E-05,0.652864E-01,0.485720E-01,
23511 &0.673476E-04,0.752069E-04,0.675656E-04,0.673476E-04,0.297273E-02,
23512 &0.652898E-05,0.571466E-01,0.417472E-01,0.569700E-04,0.649812E-04,
23513 &0.571831E-04,0.569700E-04,0.251732E-02,0.675028E-05,0.498975E-01,
23514 &0.358008E-01,0.481618E-04,0.561391E-04,0.483654E-04,0.481618E-04,
23515 &0.212754E-02,0.677236E-05,0.434594E-01,0.306320E-01,0.406746E-04,
23516 &0.484724E-04,0.408657E-04,0.406746E-04,0.179059E-02,0.662814E-05,
23517 &0.377578E-01,0.261500E-01,0.343050E-04,0.418123E-04,0.344818E-04,
23518 &0.343050E-04,0.149563E-02,0.635273E-05,0.327229E-01,0.222734E-01,
23519 &0.288923E-04,0.360279E-04,0.290540E-04,0.288923E-04,0.124695E-02/
23520 DATA (DL(K),K= 2976, 3060) /
23521 &0.598767E-05,0.282894E-01,0.189287E-01,0.242960E-04,0.310036E-04,
23522 &0.244423E-04,0.242960E-04,0.104112E-02,0.556344E-05,0.243968E-01,
23523 &0.160504E-01,0.203920E-04,0.266363E-04,0.205232E-04,0.203920E-04,
23524 &0.863677E-03,0.510070E-05,0.209890E-01,0.135797E-01,0.170822E-04,
23525 &0.228449E-04,0.171989E-04,0.170822E-04,0.711641E-03,0.462338E-05,
23526 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23527 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23528 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23529 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23530 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23531 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23532 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23533 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23534 &0.105155E+00,0.752467E-01,0.719932E-04,0.719932E-04,0.719932E-04,
23535 &0.719932E-04,0.328057E-02,-.758942E-18,0.920856E-01,0.645455E-01,
23536 &0.592305E-04,0.615087E-04,0.592802E-04,0.592305E-04,0.295327E-02,
23537 &0.945234E-07,0.804695E-01,0.552770E-01,0.489125E-04,0.528632E-04/
23538 DATA (DL(K),K= 3061, 3145) /
23539 &0.489946E-04,0.489125E-04,0.261804E-02,0.365139E-06,0.701499E-01,
23540 &0.472409E-01,0.404786E-04,0.456186E-04,0.405807E-04,0.404786E-04,
23541 &0.229460E-02,0.686912E-06,0.610049E-01,0.402864E-01,0.335367E-04,
23542 &0.394631E-04,0.336495E-04,0.335367E-04,0.198445E-02,0.981070E-06,
23543 &0.529201E-01,0.342803E-01,0.278134E-04,0.342044E-04,0.279301E-04,
23544 &0.278134E-04,0.169772E-02,0.122521E-05,0.457907E-01,0.291037E-01,
23545 &0.230821E-04,0.296833E-04,0.231978E-04,0.230821E-04,0.144575E-02,
23546 &0.140819E-05,0.395205E-01,0.246522E-01,0.191553E-04,0.257661E-04,
23547 &0.192666E-04,0.191553E-04,0.122125E-02,0.152152E-05,0.340212E-01,
23548 &0.208330E-01,0.158874E-04,0.223546E-04,0.159921E-04,0.158874E-04,
23549 &0.101912E-02,0.156880E-05,0.292116E-01,0.175644E-01,0.131678E-04,
23550 &0.193783E-04,0.132645E-04,0.131678E-04,0.847586E-03,0.156432E-05,
23551 &0.250173E-01,0.147740E-01,0.109029E-04,0.167762E-04,0.109910E-04,
23552 &0.109029E-04,0.705515E-03,0.151845E-05,0.213702E-01,0.123979E-01,
23553 &0.901273E-05,0.144953E-04,0.909200E-05,0.901273E-05,0.581767E-03,
23554 &0.143817E-05,0.182083E-01,0.103797E-01,0.743733E-05,0.124978E-04,
23555 &0.750792E-05,0.743733E-05,0.475483E-03,0.133574E-05,0.154751E-01/
23556 DATA (DL(K),K= 3146, 3230) /
23557 &0.867011E-02,0.612722E-05,0.107517E-04,0.618950E-05,0.612722E-05,
23558 &0.390116E-03,0.122183E-05,0.131193E-01,0.722560E-02,0.503734E-05,
23559 &0.922584E-05,0.509185E-05,0.503734E-05,0.319980E-03,0.110130E-05,
23560 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23561 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23562 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23563 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23564 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23565 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23566 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23567 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23568 &0.754424E-01,0.449848E-01,0.236444E-04,0.236444E-04,0.236444E-04,
23569 &0.236444E-04,0.129291E-02,0.113079E-17,0.650429E-01,0.379660E-01,
23570 &0.187739E-04,0.207130E-04,0.187990E-04,0.187739E-04,0.124038E-02,
23571 &-.327995E-06,0.559588E-01,0.319936E-01,0.149625E-04,0.182671E-04,
23572 &0.150033E-04,0.149625E-04,0.113497E-02,-.464337E-06,0.480234E-01,
23573 &0.269030E-01,0.119484E-04,0.161746E-04,0.119982E-04,0.119484E-04/
23574 DATA (DL(K),K= 3231, 3315) /
23575 &0.100877E-02,-.490618E-06,0.411091E-01,0.225716E-01,0.954833E-05,
23576 &0.143391E-04,0.960250E-05,0.954833E-05,0.883852E-03,-.461770E-06,
23577 &0.350995E-01,0.188947E-01,0.763738E-05,0.127129E-04,0.769248E-05,
23578 &0.763738E-05,0.760077E-03,-.403363E-06,0.298897E-01,0.157798E-01,
23579 &0.611070E-05,0.112548E-04,0.616439E-05,0.611070E-05,0.639505E-03,
23580 &-.335607E-06,0.253856E-01,0.131470E-01,0.488993E-05,0.994021E-05,
23581 &0.494070E-05,0.488993E-05,0.534131E-03,-.267652E-06,0.215026E-01,
23582 &0.109271E-01,0.391276E-05,0.875190E-05,0.395967E-05,0.391276E-05,
23583 &0.445478E-03,-.205292E-06,0.181648E-01,0.906007E-02,0.312720E-05,
23584 &0.767418E-05,0.316978E-05,0.312720E-05,0.366232E-03,-.154024E-06,
23585 &0.153041E-01,0.749382E-02,0.249633E-05,0.670002E-05,0.253440E-05,
23586 &0.249633E-05,0.297435E-03,-.112673E-06,0.128596E-01,0.618334E-02,
23587 &0.199074E-05,0.582360E-05,0.202435E-05,0.199074E-05,0.242305E-03,
23588 &-.794410E-07,0.107770E-01,0.508977E-02,0.158457E-05,0.503733E-05,
23589 &0.161393E-05,0.158457E-05,0.196927E-03,-.546702E-07,0.900806E-02,
23590 &0.417964E-02,0.125888E-05,0.433619E-05,0.128428E-05,0.125888E-05,
23591 &0.158171E-03,-.364714E-07,0.751006E-02,0.342418E-02,0.998674E-06/
23592 DATA (DL(K),K= 3316, 3400) /
23593 &0.371518E-05,0.102046E-05,0.998674E-06,0.126865E-03,-.228706E-07,
23594 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23595 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23596 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23597 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23598 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23599 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23600 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23601 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23602 &0.496787E-01,0.236961E-01,0.607312E-05,0.607312E-05,0.607312E-05,
23603 &0.607312E-05,0.415108E-03,-.140523E-17,0.420445E-01,0.196196E-01,
23604 &0.443589E-05,0.603481E-05,0.444683E-05,0.443589E-05,0.444425E-03,
23605 &-.375397E-06,0.355108E-01,0.162223E-01,0.321766E-05,0.587645E-05,
23606 &0.323504E-05,0.321766E-05,0.432635E-03,-.593989E-06,0.299148E-01,
23607 &0.133836E-01,0.231504E-05,0.562250E-05,0.233581E-05,0.231504E-05,
23608 &0.395801E-03,-.699904E-06,0.251339E-01,0.110157E-01,0.164651E-05,
23609 &0.526880E-05,0.166853E-05,0.164651E-05,0.344925E-03,-.733095E-06/
23610 DATA (DL(K),K= 3401, 3485) /
23611 &0.210605E-01,0.904539E-02,0.115940E-05,0.485739E-05,0.118122E-05,
23612 &0.115940E-05,0.294439E-03,-.715193E-06,0.175989E-01,0.740944E-02,
23613 &0.808365E-06,0.441709E-05,0.829075E-06,0.808365E-06,0.249093E-03,
23614 &-.665420E-06,0.146656E-01,0.605433E-02,0.555563E-06,0.396078E-05,
23615 &0.574607E-06,0.555563E-06,0.205675E-03,-.600648E-06,0.121872E-01,
23616 &0.493466E-02,0.375914E-06,0.350822E-05,0.393011E-06,0.375914E-06,
23617 &0.166757E-03,-.529210E-06,0.100993E-01,0.401191E-02,0.250032E-06,
23618 &0.307359E-05,0.265094E-06,0.250032E-06,0.135196E-03,-.456996E-06,
23619 &0.834582E-02,0.325348E-02,0.162261E-06,0.266488E-05,0.175325E-06,
23620 &0.162261E-06,0.108862E-03,-.388821E-06,0.687767E-02,0.263179E-02,
23621 &0.102273E-06,0.228913E-05,0.113453E-06,0.102273E-06,0.865539E-04,
23622 &-.326325E-06,0.565221E-02,0.212357E-02,0.620694E-07,0.194975E-05,
23623 &0.715290E-07,0.620694E-07,0.687156E-04,-.270547E-06,0.463248E-02,
23624 &0.170926E-02,0.351992E-07,0.164711E-05,0.431226E-07,0.351992E-07,
23625 &0.543744E-04,-.222379E-06,0.378655E-02,0.137242E-02,0.178902E-07,
23626 &0.138124E-05,0.244675E-07,0.178902E-07,0.426626E-04,-.181158E-06,
23627 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23628 DATA (DL(K),K= 3486, 3570) /
23629 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23630 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23631 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23632 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23633 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23634 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23635 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23636 &0.286141E-01,0.102357E-01,0.105702E-05,0.105702E-05,0.105702E-05,
23637 &0.105702E-05,0.963318E-04,0.591070E-18,0.236608E-01,0.827483E-02,
23638 &0.548552E-06,0.163293E-05,0.551993E-06,0.548552E-06,0.133058E-03,
23639 &-.268677E-06,0.195282E-01,0.668247E-02,0.238780E-06,0.183459E-05,
23640 &0.243802E-06,0.238780E-06,0.135119E-03,-.393414E-06,0.160742E-01,
23641 &0.538444E-02,0.599864E-07,0.183277E-05,0.655085E-07,0.599864E-07,
23642 &0.124554E-03,-.428349E-06,0.131940E-01,0.432750E-02,-.392825E-07,
23643 &0.172071E-05,-.338391E-07,-.392825E-07,0.111121E-03,-.415550E-06,
23644 &0.107996E-01,0.346954E-02,-.875089E-07,0.154604E-05,-.824926E-07,
23645 &-.875089E-07,0.941854E-04,-.376855E-06,0.881435E-02,0.277463E-02/
23646 DATA (DL(K),K= 3571, 3655) /
23647 &-.103962E-06,0.135013E-05,-.995446E-07,-.103962E-06,0.772195E-04,
23648 &-.326008E-06,0.717317E-02,0.221313E-02,-.102844E-06,0.115335E-05,
23649 &-.990733E-07,-.102844E-06,0.626565E-04,-.272858E-06,0.582050E-02,
23650 &0.176061E-02,-.929503E-07,0.967229E-06,-.898064E-07,-.929503E-07,
23651 &0.499930E-04,-.222828E-06,0.470908E-02,0.139692E-02,-.791495E-07,
23652 &0.800414E-06,-.765797E-07,-.791495E-07,0.394181E-04,-.178141E-06,
23653 &0.379875E-02,0.110542E-02,-.647230E-07,0.655119E-06,-.626567E-07,
23654 &-.647230E-07,0.309999E-04,-.140000E-06,0.305549E-02,0.872447E-03,
23655 &-.515215E-07,0.530834E-06,-.498829E-07,-.515215E-07,0.240354E-04,
23656 &-.108633E-06,0.245058E-02,0.686769E-03,-.400234E-07,0.426835E-06,
23657 &-.387401E-07,-.400234E-07,0.184613E-04,-.832544E-07,0.195984E-02,
23658 &0.539209E-03,-.304312E-07,0.341169E-06,-.294373E-07,-.304312E-07,
23659 &0.143512E-04,-.630818E-07,0.156297E-02,0.422273E-03,-.228633E-07,
23660 &0.271199E-06,-.221014E-07,-.228633E-07,0.110898E-04,-.474683E-07,
23661 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23662 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23663 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23664 DATA (DL(K),K= 3656, 3740) /
23665 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23666 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23667 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23668 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23669 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23670 &0.129345E-01,0.308444E-02,0.903693E-07,0.903693E-07,0.903693E-07,
23671 &0.903693E-07,0.123538E-04,-.166230E-18,0.103598E-01,0.241354E-02,
23672 &0.155648E-06,-.205296E-06,0.154889E-06,0.155648E-06,0.267249E-04,
23673 &0.880707E-07,0.828507E-02,0.188764E-02,0.176333E-06,-.341498E-06,
23674 &0.175220E-06,0.176333E-06,0.306432E-04,0.125718E-06,0.660736E-02,
23675 &0.147304E-02,0.173444E-06,-.383695E-06,0.172215E-06,0.173444E-06,
23676 &0.280787E-04,0.135578E-06,0.525320E-02,0.114618E-02,0.158651E-06,
23677 &-.373371E-06,0.157437E-06,0.158651E-06,0.243526E-04,0.130412E-06,
23678 &0.416429E-02,0.889584E-03,0.137131E-06,-.333468E-06,0.136012E-06,
23679 &0.137131E-06,0.203463E-04,0.116115E-06,0.329102E-02,0.688580E-03,
23680 &0.113839E-06,-.280874E-06,0.112853E-06,0.113839E-06,0.161038E-04,
23681 &0.982305E-07,0.259282E-02,0.531508E-03,0.914374E-07,-.225427E-06/
23682 DATA (DL(K),K= 3741, 3825) /
23683 &0.905971E-07,0.914374E-07,0.125639E-04,0.798741E-07,0.203641E-02,
23684 &0.409120E-03,0.709595E-07,-.173123E-06,0.702607E-07,0.709595E-07,
23685 &0.979247E-05,0.624138E-07,0.159441E-02,0.314027E-03,0.532256E-07,
23686 &-.127272E-06,0.526566E-07,0.532256E-07,0.741899E-05,0.469253E-07,
23687 &0.124447E-02,0.240357E-03,0.385509E-07,-.888851E-07,0.380956E-07,
23688 &0.385509E-07,0.554070E-05,0.339174E-07,0.968328E-03,0.183454E-03,
23689 &0.267272E-07,-.580277E-07,0.263687E-07,0.267272E-07,0.420032E-05,
23690 &0.233280E-07,0.751159E-03,0.139632E-03,0.174605E-07,-.342016E-07,
23691 &0.171822E-07,0.174605E-07,0.315522E-05,0.149727E-07,0.580936E-03,
23692 &0.105986E-03,0.104515E-07,-.164567E-07,0.102383E-07,0.104515E-07,
23693 &0.230829E-05,0.863527E-08,0.447955E-03,0.802293E-04,0.531954E-08,
23694 &-.376312E-08,0.515829E-08,0.531954E-08,0.170771E-05,0.399662E-08,
23695 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23696 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23697 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23698 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23699 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23700 DATA (DL(K),K= 3826, 3910) /
23701 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23702 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23703 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23704 &0.324478E-02,0.386879E-03,0.135983E-08,0.135983E-08,0.135983E-08,
23705 &0.135983E-08,0.371787E-06,-.274599E-19,0.246219E-02,0.286505E-03,
23706 &-.106852E-06,0.327611E-06,-.106589E-06,-.106852E-06,0.231631E-05,
23707 &-.107814E-06,0.186777E-02,0.212413E-03,-.161566E-06,0.492001E-06,
23708 &-.161179E-06,-.161566E-06,0.311589E-05,-.162249E-06,0.141322E-02,
23709 &0.157212E-03,-.183398E-06,0.557106E-06,-.182972E-06,-.183398E-06,
23710 &0.267943E-05,-.183884E-06,0.106518E-02,0.115892E-03,-.185231E-06,
23711 &0.562185E-06,-.184809E-06,-.185231E-06,0.203027E-05,-.185573E-06,
23712 &0.800350E-03,0.851995E-04,-.174680E-06,0.530096E-06,-.174290E-06,
23713 &-.174680E-06,0.165870E-05,-.174922E-06,0.599444E-03,0.624676E-04,
23714 &-.157644E-06,0.478420E-06,-.157300E-06,-.157644E-06,0.130112E-05,
23715 &-.157815E-06,0.447433E-03,0.456556E-04,-.137838E-06,0.418429E-06,
23716 &-.137543E-06,-.137838E-06,0.903220E-06,-.137958E-06,0.332836E-03,
23717 &0.332643E-04,-.117616E-06,0.357179E-06,-.117368E-06,-.117616E-06/
23718 DATA (DL(K),K= 3911, 3995) /
23719 &0.636187E-06,-.117699E-06,0.246754E-03,0.241622E-04,-.984560E-07,
23720 &0.299077E-06,-.982529E-07,-.984560E-07,0.481221E-06,-.985144E-07,
23721 &0.182315E-03,0.174961E-04,-.811089E-07,0.246465E-06,-.809446E-07,
23722 &-.811089E-07,0.342859E-06,-.811495E-07,0.134250E-03,0.126299E-04,
23723 &-.659052E-07,0.200354E-06,-.657742E-07,-.659052E-07,0.227840E-06,
23724 &-.659334E-07,0.985288E-04,0.908931E-05,-.529252E-07,0.160947E-06,
23725 &-.528218E-07,-.529252E-07,0.161641E-06,-.529447E-07,0.720750E-04,
23726 &0.652153E-05,-.420621E-07,0.127943E-06,-.419814E-07,-.420621E-07,
23727 &0.119540E-06,-.420756E-07,0.525538E-04,0.466527E-05,-.331141E-07,
23728 &0.100758E-06,-.330516E-07,-.331141E-07,0.808991E-07,-.331233E-07,
23729 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23730 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23731 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23732 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23733 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23734 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23735 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23736 DATA (DL(K),K= 3996, 4000) /
23737 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23738C
23739 ANS = 0.
23740 IF (X.GT.0.9985) RETURN
23741 IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
23742C
23743 IS = S/DELTA+1
23744 IS1 = IS+1
23745 DO 1 L=1,25
23746 KL = L+NDRV*25
23747 F1(L) = GF(I,IS,KL)
23748 F2(L) = GF(I,IS1,KL)
23749 1 CONTINUE
23750 A1 = DT_CKMTFF(X,F1)
23751 A2 = DT_CKMTFF(X,F2)
23752C A1=ALOG(A1)
23753C A2=ALOG(A2)
23754 S1 = (IS-1)*DELTA
23755 S2 = S1+DELTA
23756 ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
23757C ANS=EXP(ANS)
23758 RETURN
23759 END
23760C
23761C
23762
23763*$ CREATE DT_CKMTPR.FOR
23764*COPY DT_CKMTPR
23765 SUBROUTINE DT_CKMTPR(I,NDRV,X,S,ANS)
23766C
23767C**********************************************************************
23768C Proton - PDFs
23769C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
23770C ANS = PDF(I)
23771C This version by S. Roesler, 31.01.96
23772C**********************************************************************
23773
23774 SAVE
23775 DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
23776 EQUIVALENCE (GF(1,1,1),DL(1))
23777 DATA DELTA/.10/
23778C
23779 DATA (DL(K),K= 1, 85) /
23780 &0.367759E+00,0.350609E+00,0.325356E+00,0.325356E+00,0.325356E+00,
23781 &0.325356E+00,0.533117E+01,0.138778E-16,0.427988E+00,0.409718E+00,
23782 &0.382948E+00,0.382920E+00,0.382933E+00,0.382948E+00,0.686279E+01,
23783 &0.611113E-01,0.494752E+00,0.475328E+00,0.447011E+00,0.446959E+00,
23784 &0.446984E+00,0.447011E+00,0.855688E+01,0.128659E+00,0.568248E+00,
23785 &0.547637E+00,0.517743E+00,0.517671E+00,0.517705E+00,0.517743E+00,
23786 &0.104074E+02,0.202846E+00,0.648622E+00,0.626792E+00,0.595289E+00,
23787 &0.595201E+00,0.595244E+00,0.595289E+00,0.124065E+02,0.283819E+00,
23788 &0.735974E+00,0.712890E+00,0.679748E+00,0.679648E+00,0.679696E+00,
23789 &0.679748E+00,0.145441E+02,0.371679E+00,0.830359E+00,0.805987E+00,
23790 &0.771173E+00,0.771066E+00,0.771119E+00,0.771173E+00,0.168081E+02,
23791 &0.466485E+00,0.931778E+00,0.906084E+00,0.869566E+00,0.869456E+00,
23792 &0.869511E+00,0.869566E+00,0.191850E+02,0.568240E+00,0.104018E+01,
23793 &0.101313E+01,0.974873E+00,0.974763E+00,0.974819E+00,0.974873E+00,
23794 &0.216593E+02,0.676890E+00,0.115544E+01,0.112700E+01,0.108698E+01,
23795 &0.108687E+01,0.108693E+01,0.108698E+01,0.242146E+02,0.792321E+00,
23796 &0.127738E+01,0.124751E+01,0.120570E+01,0.120560E+01,0.120565E+01/
23797 DATA (DL(K),K= 86, 170) /
23798 &0.120570E+01,0.268333E+02,0.914356E+00,0.140577E+01,0.137444E+01,
23799 &0.133079E+01,0.133070E+01,0.133075E+01,0.133079E+01,0.294970E+02,
23800 &0.104275E+01,0.154028E+01,0.150745E+01,0.146194E+01,0.146187E+01,
23801 &0.146192E+01,0.146194E+01,0.321867E+02,0.117720E+01,0.168054E+01,
23802 &0.164619E+01,0.159879E+01,0.159874E+01,0.159877E+01,0.159879E+01,
23803 &0.348836E+02,0.131732E+01,0.182613E+01,0.179020E+01,0.174088E+01,
23804 &0.174086E+01,0.174088E+01,0.174088E+01,0.375685E+02,0.146269E+01,
23805 &0.197653E+01,0.193901E+01,0.188774E+01,0.188774E+01,0.188775E+01,
23806 &0.188774E+01,0.402228E+02,0.161282E+01,0.213121E+01,0.209205E+01,
23807 &0.203880E+01,0.203884E+01,0.203884E+01,0.203880E+01,0.428285E+02,
23808 &0.176714E+01,0.228955E+01,0.224873E+01,0.219348E+01,0.219355E+01,
23809 &0.219353E+01,0.219348E+01,0.453682E+02,0.192507E+01,0.245093E+01,
23810 &0.240840E+01,0.235113E+01,0.235123E+01,0.235120E+01,0.235113E+01,
23811 &0.478258E+02,0.208597E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23812 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23813 &0.349839E+00,0.324128E+00,0.286363E+00,0.286363E+00,0.286363E+00,
23814 &0.286363E+00,0.469694E+01,0.000000E+00,0.398361E+00,0.371065E+00/
23815 DATA (DL(K),K= 171, 255) /
23816 &0.331239E+00,0.331213E+00,0.331227E+00,0.331239E+00,0.586152E+01,
23817 &0.481683E-01,0.451010E+00,0.422096E+00,0.380182E+00,0.380137E+00,
23818 &0.380161E+00,0.380182E+00,0.711349E+01,0.100378E+00,0.507782E+00,
23819 &0.477215E+00,0.433187E+00,0.433128E+00,0.433160E+00,0.433187E+00,
23820 &0.844371E+01,0.156627E+00,0.568644E+00,0.536390E+00,0.490220E+00,
23821 &0.490152E+00,0.490190E+00,0.490220E+00,0.984291E+01,0.216886E+00,
23822 &0.633517E+00,0.599543E+00,0.551204E+00,0.551133E+00,0.551174E+00,
23823 &0.551204E+00,0.113005E+02,0.281079E+00,0.702295E+00,0.666565E+00,
23824 &0.616031E+00,0.615963E+00,0.616004E+00,0.616031E+00,0.128050E+02,
23825 &0.349101E+00,0.774832E+00,0.737311E+00,0.684556E+00,0.684495E+00,
23826 &0.684535E+00,0.684556E+00,0.143447E+02,0.420809E+00,0.850945E+00,
23827 &0.811598E+00,0.756596E+00,0.756547E+00,0.756583E+00,0.756596E+00,
23828 &0.159073E+02,0.496022E+00,0.930413E+00,0.889207E+00,0.831933E+00,
23829 &0.831901E+00,0.831931E+00,0.831933E+00,0.174801E+02,0.574524E+00,
23830 &0.101298E+01,0.969882E+00,0.910312E+00,0.910301E+00,0.910324E+00,
23831 &0.910312E+00,0.190508E+02,0.656061E+00,0.109836E+01,0.105333E+01,
23832 &0.991445E+00,0.991459E+00,0.991471E+00,0.991445E+00,0.206070E+02/
23833 DATA (DL(K),K= 256, 340) /
23834 &0.740345E+00,0.118622E+01,0.113923E+01,0.107501E+01,0.107505E+01,
23835 &0.107505E+01,0.107501E+01,0.221368E+02,0.827056E+00,0.127622E+01,
23836 &0.122724E+01,0.116065E+01,0.116073E+01,0.116072E+01,0.116065E+01,
23837 &0.236287E+02,0.915845E+00,0.136797E+01,0.131696E+01,0.124800E+01,
23838 &0.124812E+01,0.124809E+01,0.124800E+01,0.250721E+02,0.100634E+01,
23839 &0.146107E+01,0.140801E+01,0.133666E+01,0.133681E+01,0.133677E+01,
23840 &0.133666E+01,0.264571E+02,0.109813E+01,0.155511E+01,0.149996E+01,
23841 &0.142621E+01,0.142641E+01,0.142634E+01,0.142621E+01,0.277747E+02,
23842 &0.119081E+01,0.164964E+01,0.159239E+01,0.151622E+01,0.151646E+01,
23843 &0.151638E+01,0.151622E+01,0.290168E+02,0.128396E+01,0.174424E+01,
23844 &0.168485E+01,0.160626E+01,0.160655E+01,0.160645E+01,0.160626E+01,
23845 &0.301765E+02,0.137713E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23846 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23847 &0.345345E+00,0.306823E+00,0.250518E+00,0.250518E+00,0.250518E+00,
23848 &0.250518E+00,0.411726E+01,-.138778E-16,0.384210E+00,0.343514E+00,
23849 &0.284500E+00,0.284487E+00,0.284496E+00,0.284500E+00,0.496835E+01,
23850 &0.371582E-01,0.425419E+00,0.382518E+00,0.320782E+00,0.320762E+00/
23851 DATA (DL(K),K= 341, 425) /
23852 &0.320777E+00,0.320782E+00,0.585504E+01,0.765988E-01,0.468853E+00,
23853 &0.423717E+00,0.359246E+00,0.359226E+00,0.359243E+00,0.359246E+00,
23854 &0.676824E+01,0.118207E+00,0.514392E+00,0.466990E+00,0.399771E+00,
23855 &0.399758E+00,0.399775E+00,0.399771E+00,0.769967E+01,0.161865E+00,
23856 &0.561883E+00,0.512186E+00,0.442209E+00,0.442208E+00,0.442222E+00,
23857 &0.442209E+00,0.864071E+01,0.207426E+00,0.611162E+00,0.559140E+00,
23858 &0.486395E+00,0.486411E+00,0.486420E+00,0.486395E+00,0.958280E+01,
23859 &0.254727E+00,0.662044E+00,0.607667E+00,0.532145E+00,0.532185E+00,
23860 &0.532185E+00,0.532145E+00,0.105176E+02,0.303587E+00,0.714325E+00,
23861 &0.657566E+00,0.579261E+00,0.579328E+00,0.579318E+00,0.579261E+00,
23862 &0.114370E+02,0.353808E+00,0.767786E+00,0.708618E+00,0.627526E+00,
23863 &0.627625E+00,0.627603E+00,0.627526E+00,0.123333E+02,0.405174E+00,
23864 &0.822195E+00,0.760591E+00,0.676711E+00,0.676846E+00,0.676810E+00,
23865 &0.676711E+00,0.131994E+02,0.457458E+00,0.877307E+00,0.813242E+00,
23866 &0.726575E+00,0.726750E+00,0.726697E+00,0.726575E+00,0.140286E+02,
23867 &0.510420E+00,0.932865E+00,0.866317E+00,0.776867E+00,0.777085E+00,
23868 &0.777015E+00,0.776867E+00,0.148150E+02,0.563809E+00,0.988608E+00/
23869 DATA (DL(K),K= 426, 510) /
23870 &0.919556E+00,0.827330E+00,0.827594E+00,0.827505E+00,0.827330E+00,
23871 &0.155533E+02,0.617368E+00,0.104427E+01,0.972694E+00,0.877703E+00,
23872 &0.878016E+00,0.877907E+00,0.877703E+00,0.162391E+02,0.670837E+00,
23873 &0.109958E+01,0.102547E+01,0.927723E+00,0.928088E+00,0.927957E+00,
23874 &0.927723E+00,0.168687E+02,0.723954E+00,0.115428E+01,0.107761E+01,
23875 &0.977132E+00,0.977550E+00,0.977397E+00,0.977132E+00,0.174391E+02,
23876 &0.776458E+00,0.120809E+01,0.112886E+01,0.102567E+01,0.102615E+01,
23877 &0.102597E+01,0.102567E+01,0.179481E+02,0.828097E+00,0.126078E+01,
23878 &0.117898E+01,0.107310E+01,0.107363E+01,0.107343E+01,0.107310E+01,
23879 &0.183942E+02,0.878621E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23880 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23881 &0.357586E+00,0.299938E+00,0.216504E+00,0.216504E+00,0.216504E+00,
23882 &0.216504E+00,0.357260E+01,-.277556E-16,0.388529E+00,0.327984E+00,
23883 &0.241161E+00,0.241168E+00,0.241168E+00,0.241161E+00,0.415893E+01,
23884 &0.278429E-01,0.420472E+00,0.357015E+00,0.266823E+00,0.266844E+00,
23885 &0.266842E+00,0.266823E+00,0.474689E+01,0.566783E-01,0.453271E+00,
23886 &0.386886E+00,0.293349E+00,0.293389E+00,0.293381E+00,0.293349E+00/
23887 DATA (DL(K),K= 511, 595) /
23888 &0.532982E+01,0.863668E-01,0.486793E+00,0.417464E+00,0.320608E+00,
23889 &0.320673E+00,0.320657E+00,0.320608E+00,0.590219E+01,0.116779E+00,
23890 &0.520887E+00,0.448601E+00,0.348454E+00,0.348549E+00,0.348523E+00,
23891 &0.348454E+00,0.645868E+01,0.147773E+00,0.555403E+00,0.480149E+00,
23892 &0.376740E+00,0.376870E+00,0.376831E+00,0.376740E+00,0.699440E+01,
23893 &0.179201E+00,0.590183E+00,0.511950E+00,0.405314E+00,0.405482E+00,
23894 &0.405429E+00,0.405314E+00,0.750493E+01,0.210912E+00,0.625064E+00,
23895 &0.543845E+00,0.434019E+00,0.434229E+00,0.434159E+00,0.434019E+00,
23896 &0.798636E+01,0.242750E+00,0.659882E+00,0.575673E+00,0.462696E+00,
23897 &0.462952E+00,0.462864E+00,0.462696E+00,0.843528E+01,0.274558E+00,
23898 &0.694472E+00,0.607271E+00,0.491188E+00,0.491492E+00,0.491385E+00,
23899 &0.491188E+00,0.884885E+01,0.306178E+00,0.728669E+00,0.638478E+00,
23900 &0.519337E+00,0.519690E+00,0.519563E+00,0.519337E+00,0.922480E+01,
23901 &0.337451E+00,0.762311E+00,0.669133E+00,0.546987E+00,0.547392E+00,
23902 &0.547244E+00,0.546987E+00,0.956139E+01,0.368224E+00,0.795240E+00,
23903 &0.699084E+00,0.573988E+00,0.574447E+00,0.574277E+00,0.573988E+00,
23904 &0.985744E+01,0.398346E+00,0.827302E+00,0.728181E+00,0.600196E+00/
23905 DATA (DL(K),K= 596, 680) /
23906 &0.600710E+00,0.600518E+00,0.600196E+00,0.101123E+02,0.427671E+00,
23907 &0.858354E+00,0.756282E+00,0.625475E+00,0.626044E+00,0.625829E+00,
23908 &0.625475E+00,0.103258E+02,0.456064E+00,0.888257E+00,0.783256E+00,
23909 &0.649696E+00,0.650321E+00,0.650083E+00,0.649696E+00,0.104982E+02,
23910 &0.483395E+00,0.916887E+00,0.808981E+00,0.672742E+00,0.673422E+00,
23911 &0.673161E+00,0.672742E+00,0.106303E+02,0.509546E+00,0.944126E+00,
23912 &0.833345E+00,0.694506E+00,0.695243E+00,0.694958E+00,0.694506E+00,
23913 &0.107231E+02,0.534410E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23914 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23915 &0.390721E+00,0.304671E+00,0.182562E+00,0.182562E+00,0.182562E+00,
23916 &0.182562E+00,0.303699E+01,0.693889E-17,0.414806E+00,0.325059E+00,
23917 &0.199103E+00,0.199133E+00,0.199124E+00,0.199103E+00,0.339971E+01,
23918 &0.198528E-01,0.438929E+00,0.345508E+00,0.215797E+00,0.215862E+00,
23919 &0.215842E+00,0.215797E+00,0.374624E+01,0.398420E-01,0.462973E+00,
23920 &0.365903E+00,0.232531E+00,0.232635E+00,0.232601E+00,0.232531E+00,
23921 &0.407322E+01,0.598565E-01,0.486835E+00,0.386142E+00,0.249208E+00,
23922 &0.249352E+00,0.249304E+00,0.249208E+00,0.437817E+01,0.797987E-01/
23923 DATA (DL(K),K= 681, 765) /
23924 &0.510407E+00,0.406123E+00,0.265725E+00,0.265913E+00,0.265849E+00,
23925 &0.265725E+00,0.465901E+01,0.995694E-01,0.533588E+00,0.425746E+00,
23926 &0.281986E+00,0.282220E+00,0.282139E+00,0.281986E+00,0.491410E+01,
23927 &0.119072E+00,0.556274E+00,0.444912E+00,0.297897E+00,0.298178E+00,
23928 &0.298079E+00,0.297897E+00,0.514220E+01,0.138212E+00,0.578369E+00,
23929 &0.463528E+00,0.313366E+00,0.313696E+00,0.313578E+00,0.313366E+00,
23930 &0.534249E+01,0.156900E+00,0.599777E+00,0.481503E+00,0.328308E+00,
23931 &0.328688E+00,0.328549E+00,0.328308E+00,0.551456E+01,0.175048E+00,
23932 &0.620409E+00,0.498752E+00,0.342642E+00,0.343071E+00,0.342913E+00,
23933 &0.342642E+00,0.565833E+01,0.192575E+00,0.640181E+00,0.515196E+00,
23934 &0.356292E+00,0.356770E+00,0.356592E+00,0.356292E+00,0.577410E+01,
23935 &0.209407E+00,0.659017E+00,0.530764E+00,0.369190E+00,0.369718E+00,
23936 &0.369519E+00,0.369190E+00,0.586243E+01,0.225474E+00,0.676845E+00,
23937 &0.545389E+00,0.381275E+00,0.381852E+00,0.381633E+00,0.381275E+00,
23938 &0.592421E+01,0.240714E+00,0.693604E+00,0.559015E+00,0.392493E+00,
23939 &0.393118E+00,0.392880E+00,0.392493E+00,0.596052E+01,0.255072E+00,
23940 &0.709239E+00,0.571593E+00,0.402799E+00,0.403472E+00,0.403213E+00/
23941 DATA (DL(K),K= 766, 850) /
23942 &0.402799E+00,0.597267E+01,0.268502E+00,0.723703E+00,0.583081E+00,
23943 &0.412157E+00,0.412875E+00,0.412597E+00,0.412157E+00,0.596211E+01,
23944 &0.280966E+00,0.736960E+00,0.593447E+00,0.420536E+00,0.421299E+00,
23945 &0.421002E+00,0.420536E+00,0.593045E+01,0.292434E+00,0.748980E+00,
23946 &0.602669E+00,0.427918E+00,0.428723E+00,0.428408E+00,0.427918E+00,
23947 &0.587934E+01,0.302884E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23948 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23949 &0.448390E+00,0.320678E+00,0.146415E+00,0.146415E+00,0.146415E+00,
23950 &0.146415E+00,0.247594E+01,0.000000E+00,0.465760E+00,0.333734E+00,
23951 &0.155974E+00,0.156013E+00,0.156000E+00,0.155974E+00,0.265633E+01,
23952 &0.130329E-01,0.482525E+00,0.346293E+00,0.165233E+00,0.165311E+00,
23953 &0.165285E+00,0.165233E+00,0.281612E+01,0.257304E-01,0.498626E+00,
23954 &0.358294E+00,0.174131E+00,0.174249E+00,0.174209E+00,0.174131E+00,
23955 &0.295484E+01,0.380345E-01,0.514008E+00,0.369688E+00,0.182622E+00,
23956 &0.182779E+00,0.182724E+00,0.182622E+00,0.307242E+01,0.498976E-01,
23957 &0.528624E+00,0.380432E+00,0.190660E+00,0.190856E+00,0.190786E+00,
23958 &0.190660E+00,0.316911E+01,0.612760E-01,0.542428E+00,0.390485E+00/
23959 DATA (DL(K),K= 851, 935) /
23960 &0.198205E+00,0.198441E+00,0.198356E+00,0.198205E+00,0.324538E+01,
23961 &0.721303E-01,0.555382E+00,0.399810E+00,0.205224E+00,0.205498E+00,
23962 &0.205398E+00,0.205224E+00,0.330192E+01,0.824256E-01,0.567448E+00,
23963 &0.408377E+00,0.211687E+00,0.211997E+00,0.211882E+00,0.211687E+00,
23964 &0.333960E+01,0.921319E-01,0.578597E+00,0.416159E+00,0.217568E+00,
23965 &0.217915E+00,0.217784E+00,0.217568E+00,0.335945E+01,0.101224E+00,
23966 &0.588802E+00,0.423136E+00,0.222847E+00,0.223229E+00,0.223084E+00,
23967 &0.222847E+00,0.336262E+01,0.109681E+00,0.598043E+00,0.429293E+00,
23968 &0.227512E+00,0.227928E+00,0.227768E+00,0.227512E+00,0.335036E+01,
23969 &0.117489E+00,0.606305E+00,0.434619E+00,0.231551E+00,0.232000E+00,
23970 &0.231826E+00,0.231551E+00,0.332398E+01,0.124636E+00,0.613579E+00,
23971 &0.439110E+00,0.234962E+00,0.235442E+00,0.235254E+00,0.234962E+00,
23972 &0.328483E+01,0.131119E+00,0.619860E+00,0.442766E+00,0.237745E+00,
23973 &0.238254E+00,0.238053E+00,0.237745E+00,0.323429E+01,0.136936E+00,
23974 &0.625150E+00,0.445594E+00,0.239905E+00,0.240441E+00,0.240228E+00,
23975 &0.239905E+00,0.317371E+01,0.142091E+00,0.629453E+00,0.447603E+00,
23976 &0.241452E+00,0.242014E+00,0.241788E+00,0.241452E+00,0.310443E+01/
23977 DATA (DL(K),K= 936, 1020) /
23978 &0.146594E+00,0.632782E+00,0.448808E+00,0.242400E+00,0.242987E+00,
23979 &0.242749E+00,0.242400E+00,0.302775E+01,0.150456E+00,0.635151E+00,
23980 &0.449228E+00,0.242767E+00,0.243376E+00,0.243127E+00,0.242767E+00,
23981 &0.294491E+01,0.153694E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23982 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23983 &0.528765E+00,0.341825E+00,0.105823E+00,0.105823E+00,0.105823E+00,
23984 &0.105823E+00,0.185069E+01,-.138778E-16,0.538124E+00,0.347118E+00,
23985 &0.109762E+00,0.109780E+00,0.109774E+00,0.109762E+00,0.189644E+01,
23986 &0.738880E-02,0.546541E+00,0.351712E+00,0.113300E+00,0.113336E+00,
23987 &0.113324E+00,0.113300E+00,0.192700E+01,0.143076E-01,0.554014E+00,
23988 &0.355607E+00,0.116431E+00,0.116485E+00,0.116466E+00,0.116431E+00,
23989 &0.194356E+01,0.207515E-01,0.560546E+00,0.358805E+00,0.119150E+00,
23990 &0.119222E+00,0.119196E+00,0.119150E+00,0.194722E+01,0.267179E-01,
23991 &0.566139E+00,0.361311E+00,0.121459E+00,0.121549E+00,0.121515E+00,
23992 &0.121459E+00,0.193921E+01,0.322084E-01,0.570802E+00,0.363134E+00,
23993 &0.123359E+00,0.123467E+00,0.123426E+00,0.123359E+00,0.192071E+01,
23994 &0.372262E-01,0.574542E+00,0.364286E+00,0.124858E+00,0.124983E+00/
23995 DATA (DL(K),K= 1021, 1105) /
23996 &0.124933E+00,0.124858E+00,0.189295E+01,0.417774E-01,0.577372E+00,
23997 &0.364779E+00,0.125961E+00,0.126103E+00,0.126046E+00,0.125961E+00,
23998 &0.185710E+01,0.458703E-01,0.579307E+00,0.364629E+00,0.126681E+00,
23999 &0.126839E+00,0.126774E+00,0.126681E+00,0.181432E+01,0.495154E-01,
24000 &0.580363E+00,0.363857E+00,0.127029E+00,0.127202E+00,0.127130E+00,
24001 &0.127029E+00,0.176571E+01,0.527252E-01,0.580561E+00,0.362483E+00,
24002 &0.127020E+00,0.127208E+00,0.127128E+00,0.127020E+00,0.171231E+01,
24003 &0.555142E-01,0.579923E+00,0.360529E+00,0.126670E+00,0.126872E+00,
24004 &0.126785E+00,0.126670E+00,0.165511E+01,0.578985E-01,0.578474E+00,
24005 &0.358021E+00,0.125998E+00,0.126213E+00,0.126119E+00,0.125998E+00,
24006 &0.159501E+01,0.598958E-01,0.576241E+00,0.354987E+00,0.125022E+00,
24007 &0.125249E+00,0.125148E+00,0.125022E+00,0.153284E+01,0.615248E-01,
24008 &0.573252E+00,0.351453E+00,0.123762E+00,0.124000E+00,0.123893E+00,
24009 &0.123762E+00,0.146934E+01,0.628056E-01,0.569539E+00,0.347450E+00,
24010 &0.122240E+00,0.122488E+00,0.122375E+00,0.122240E+00,0.140517E+01,
24011 &0.637587E-01,0.565134E+00,0.343008E+00,0.120476E+00,0.120733E+00,
24012 &0.120615E+00,0.120476E+00,0.134093E+01,0.644054E-01,0.560071E+00/
24013 DATA (DL(K),K= 1106, 1190) /
24014 &0.338158E+00,0.118493E+00,0.118758E+00,0.118635E+00,0.118493E+00,
24015 &0.127712E+01,0.647671E-01,0.000000E+00,0.000000E+00,0.000000E+00,
24016 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24017 &0.584093E+00,0.349173E+00,0.772117E-01,0.772117E-01,0.772117E-01,
24018 &0.772117E-01,0.140433E+01,0.346945E-17,0.586736E+00,0.349017E+00,
24019 &0.785355E-01,0.785519E-01,0.785448E-01,0.785355E-01,0.139434E+01,
24020 &0.447504E-02,0.588402E+00,0.348237E+00,0.795437E-01,0.795759E-01,
24021 &0.795617E-01,0.795437E-01,0.137550E+01,0.854114E-02,0.589124E+00,
24022 &0.346861E+00,0.802498E-01,0.802970E-01,0.802758E-01,0.802498E-01,
24023 &0.134918E+01,0.122148E-01,0.588930E+00,0.344912E+00,0.806656E-01,
24024 &0.807271E-01,0.806990E-01,0.806656E-01,0.131652E+01,0.155101E-01,
24025 &0.587849E+00,0.342417E+00,0.808055E-01,0.808805E-01,0.808457E-01,
24026 &0.808055E-01,0.127862E+01,0.184435E-01,0.585912E+00,0.339402E+00,
24027 &0.806843E-01,0.807718E-01,0.807306E-01,0.806843E-01,0.123648E+01,
24028 &0.210315E-01,0.583151E+00,0.335894E+00,0.803173E-01,0.804166E-01,
24029 &0.803692E-01,0.803173E-01,0.119104E+01,0.232909E-01,0.579599E+00,
24030 &0.331923E+00,0.797205E-01,0.798308E-01,0.797775E-01,0.797205E-01/
24031 DATA (DL(K),K= 1191, 1275) /
24032 &0.114317E+01,0.252394E-01,0.575288E+00,0.327516E+00,0.789107E-01,
24033 &0.790310E-01,0.789721E-01,0.789107E-01,0.109362E+01,0.268946E-01,
24034 &0.570253E+00,0.322704E+00,0.779045E-01,0.780341E-01,0.779698E-01,
24035 &0.779045E-01,0.104307E+01,0.282745E-01,0.564530E+00,0.317515E+00,
24036 &0.767190E-01,0.768570E-01,0.767878E-01,0.767190E-01,0.992143E+00,
24037 &0.293974E-01,0.558155E+00,0.311981E+00,0.753713E-01,0.755169E-01,
24038 &0.754432E-01,0.753713E-01,0.941341E+00,0.302812E-01,0.551166E+00,
24039 &0.306131E+00,0.738784E-01,0.740308E-01,0.739528E-01,0.738784E-01,
24040 &0.891113E+00,0.309441E-01,0.543599E+00,0.299995E+00,0.722571E-01,
24041 &0.724154E-01,0.723336E-01,0.722571E-01,0.841829E+00,0.314037E-01,
24042 &0.535494E+00,0.293603E+00,0.705237E-01,0.706871E-01,0.706019E-01,
24043 &0.705237E-01,0.793794E+00,0.316774E-01,0.526888E+00,0.286986E+00,
24044 &0.686941E-01,0.688619E-01,0.687736E-01,0.686941E-01,0.747249E+00,
24045 &0.317823E-01,0.517822E+00,0.280172E+00,0.667836E-01,0.669551E-01,
24046 &0.668640E-01,0.667836E-01,0.702381E+00,0.317346E-01,0.508333E+00,
24047 &0.273189E+00,0.648068E-01,0.649814E-01,0.648879E-01,0.648068E-01,
24048 &0.659330E+00,0.315501E-01,0.000000E+00,0.000000E+00,0.000000E+00/
24049 DATA (DL(K),K= 1276, 1360) /
24050 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24051 &0.622739E+00,0.340676E+00,0.509141E-01,0.509141E-01,0.509141E-01,
24052 &0.509141E-01,0.980502E+00,-.173472E-17,0.617764E+00,0.335457E+00,
24053 &0.507607E-01,0.507701E-01,0.507651E-01,0.507607E-01,0.944375E+00,
24054 &0.242386E-02,0.611957E+00,0.329837E+00,0.504236E-01,0.504417E-01,
24055 &0.504321E-01,0.504236E-01,0.905225E+00,0.455851E-02,0.605372E+00,
24056 &0.323853E+00,0.499207E-01,0.499471E-01,0.499328E-01,0.499207E-01,
24057 &0.864035E+00,0.642656E-02,0.598052E+00,0.317537E+00,0.492668E-01,
24058 &0.493008E-01,0.492822E-01,0.492668E-01,0.821557E+00,0.804638E-02,
24059 &0.590044E+00,0.310919E+00,0.484772E-01,0.485183E-01,0.484955E-01,
24060 &0.484772E-01,0.778444E+00,0.943663E-02,0.581391E+00,0.304033E+00,
24061 &0.475665E-01,0.476142E-01,0.475874E-01,0.475665E-01,0.735263E+00,
24062 &0.106150E-01,0.572137E+00,0.296908E+00,0.465487E-01,0.466024E-01,
24063 &0.465720E-01,0.465487E-01,0.692487E+00,0.115984E-01,0.562326E+00,
24064 &0.289573E+00,0.454376E-01,0.454968E-01,0.454629E-01,0.454376E-01,
24065 &0.650510E+00,0.124032E-01,0.552003E+00,0.282060E+00,0.442463E-01,
24066 &0.443103E-01,0.442733E-01,0.442463E-01,0.609652E+00,0.130451E-01/
24067 DATA (DL(K),K= 1361, 1445) /
24068 &0.541210E+00,0.274395E+00,0.429871E-01,0.430555E-01,0.430156E-01,
24069 &0.429871E-01,0.570164E+00,0.135389E-01,0.529991E+00,0.266608E+00,
24070 &0.416720E-01,0.417443E-01,0.417018E-01,0.416720E-01,0.532237E+00,
24071 &0.138989E-01,0.518389E+00,0.258725E+00,0.403123E-01,0.403879E-01,
24072 &0.403431E-01,0.403123E-01,0.496010E+00,0.141386E-01,0.506446E+00,
24073 &0.250772E+00,0.389186E-01,0.389971E-01,0.389501E-01,0.389186E-01,
24074 &0.461573E+00,0.142708E-01,0.494204E+00,0.242775E+00,0.375006E-01,
24075 &0.375815E-01,0.375327E-01,0.375006E-01,0.428979E+00,0.143074E-01,
24076 &0.481705E+00,0.234757E+00,0.360674E-01,0.361503E-01,0.361000E-01,
24077 &0.360674E-01,0.398246E+00,0.142598E-01,0.468990E+00,0.226741E+00,
24078 &0.346276E-01,0.347120E-01,0.346605E-01,0.346276E-01,0.369363E+00,
24079 &0.141385E-01,0.456098E+00,0.218750E+00,0.331887E-01,0.332743E-01,
24080 &0.332216E-01,0.331887E-01,0.342300E+00,0.139532E-01,0.443068E+00,
24081 &0.210804E+00,0.317576E-01,0.318440E-01,0.317905E-01,0.317576E-01,
24082 &0.317005E+00,0.137130E-01,0.000000E+00,0.000000E+00,0.000000E+00,
24083 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24084 &0.631458E+00,0.318714E+00,0.335640E-01,0.335640E-01,0.335640E-01/
24085 DATA (DL(K),K= 1446, 1530) /
24086 &0.335640E-01,0.686773E+00,0.346945E-17,0.620274E+00,0.310241E+00,
24087 &0.329311E-01,0.329377E-01,0.329337E-01,0.329311E-01,0.646559E+00,
24088 &0.135960E-02,0.608504E+00,0.301610E+00,0.322083E-01,0.322210E-01,
24089 &0.322133E-01,0.322083E-01,0.606503E+00,0.252820E-02,0.596205E+00,
24090 &0.292854E+00,0.314099E-01,0.314281E-01,0.314169E-01,0.314099E-01,
24091 &0.567134E+00,0.352543E-02,0.583429E+00,0.284002E+00,0.305470E-01,
24092 &0.305704E-01,0.305558E-01,0.305470E-01,0.528824E+00,0.436693E-02,
24093 &0.570223E+00,0.275080E+00,0.296307E-01,0.296586E-01,0.296411E-01,
24094 &0.296307E-01,0.491848E+00,0.506768E-02,0.556637E+00,0.266115E+00,
24095 &0.286709E-01,0.287030E-01,0.286827E-01,0.286709E-01,0.456422E+00,
24096 &0.564157E-02,0.542717E+00,0.257131E+00,0.276770E-01,0.277128E-01,
24097 &0.276900E-01,0.276770E-01,0.422697E+00,0.610148E-02,0.528511E+00,
24098 &0.248154E+00,0.266578E-01,0.266968E-01,0.266718E-01,0.266578E-01,
24099 &0.390771E+00,0.645942E-02,0.514062E+00,0.239205E+00,0.256210E-01,
24100 &0.256629E-01,0.256359E-01,0.256210E-01,0.360700E+00,0.672653E-02,
24101 &0.499417E+00,0.230307E+00,0.245741E-01,0.246185E-01,0.245896E-01,
24102 &0.245741E-01,0.332498E+00,0.691312E-02,0.484617E+00,0.221480E+00/
24103 DATA (DL(K),K= 1531, 1615) /
24104 &0.235237E-01,0.235701E-01,0.235397E-01,0.235237E-01,0.306153E+00,
24105 &0.702875E-02,0.469706E+00,0.212745E+00,0.224757E-01,0.225238E-01,
24106 &0.224921E-01,0.224757E-01,0.281624E+00,0.708222E-02,0.454725E+00,
24107 &0.204118E+00,0.214355E-01,0.214850E-01,0.214522E-01,0.214355E-01,
24108 &0.258855E+00,0.708159E-02,0.439713E+00,0.195618E+00,0.204079E-01,
24109 &0.204586E-01,0.204249E-01,0.204079E-01,0.237774E+00,0.703428E-02,
24110 &0.424709E+00,0.187259E+00,0.193972E-01,0.194486E-01,0.194142E-01,
24111 &0.193972E-01,0.218298E+00,0.694702E-02,0.409750E+00,0.179057E+00,
24112 &0.184069E-01,0.184588E-01,0.184239E-01,0.184069E-01,0.200339E+00,
24113 &0.682594E-02,0.394870E+00,0.171023E+00,0.174402E-01,0.174924E-01,
24114 &0.174571E-01,0.174402E-01,0.183804E+00,0.667657E-02,0.380104E+00,
24115 &0.163171E+00,0.164997E-01,0.165519E-01,0.165164E-01,0.164997E-01,
24116 &0.168600E+00,0.650389E-02,0.000000E+00,0.000000E+00,0.000000E+00,
24117 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24118 &0.619056E+00,0.288873E+00,0.218554E-01,0.218554E-01,0.218554E-01,
24119 &0.218554E-01,0.477010E+00,-.867362E-17,0.602890E+00,0.278444E+00,
24120 &0.211480E-01,0.211530E-01,0.211497E-01,0.211480E-01,0.440877E+00/
24121 DATA (DL(K),K= 1616, 1700) /
24122 &0.767466E-03,0.586431E+00,0.268081E+00,0.204081E-01,0.204175E-01,
24123 &0.204113E-01,0.204081E-01,0.406417E+00,0.141432E-02,0.569736E+00,
24124 &0.257807E+00,0.196446E-01,0.196581E-01,0.196491E-01,0.196446E-01,
24125 &0.373808E+00,0.195508E-02,0.552853E+00,0.247642E+00,0.188646E-01,
24126 &0.188816E-01,0.188701E-01,0.188646E-01,0.343145E+00,0.240123E-02,
24127 &0.535829E+00,0.237603E+00,0.180743E-01,0.180945E-01,0.180808E-01,
24128 &0.180743E-01,0.314460E+00,0.276332E-02,0.518710E+00,0.227710E+00,
24129 &0.172796E-01,0.173025E-01,0.172868E-01,0.172796E-01,0.287750E+00,
24130 &0.305100E-02,0.501539E+00,0.217977E+00,0.164854E-01,0.165108E-01,
24131 &0.164933E-01,0.164854E-01,0.262983E+00,0.327305E-02,0.484360E+00,
24132 &0.208420E+00,0.156964E-01,0.157239E-01,0.157049E-01,0.156964E-01,
24133 &0.240098E+00,0.343744E-02,0.467213E+00,0.199053E+00,0.149165E-01,
24134 &0.149457E-01,0.149254E-01,0.149165E-01,0.219021E+00,0.355144E-02,
24135 &0.450140E+00,0.189889E+00,0.141493E-01,0.141800E-01,0.141586E-01,
24136 &0.141493E-01,0.199660E+00,0.362164E-02,0.433177E+00,0.180939E+00,
24137 &0.133978E-01,0.134297E-01,0.134073E-01,0.133978E-01,0.181918E+00,
24138 &0.365401E-02,0.416362E+00,0.172214E+00,0.126646E-01,0.126974E-01/
24139 DATA (DL(K),K= 1701, 1785) /
24140 &0.126742E-01,0.126646E-01,0.165692E+00,0.365394E-02,0.399729E+00,
24141 &0.163725E+00,0.119518E-01,0.119853E-01,0.119615E-01,0.119518E-01,
24142 &0.150875E+00,0.362628E-02,0.383310E+00,0.155477E+00,0.112613E-01,
24143 &0.112952E-01,0.112711E-01,0.112613E-01,0.137364E+00,0.357539E-02,
24144 &0.367138E+00,0.147479E+00,0.105945E-01,0.106287E-01,0.106042E-01,
24145 &0.105945E-01,0.125056E+00,0.350515E-02,0.351239E+00,0.139737E+00,
24146 &0.995250E-02,0.998673E-02,0.996211E-02,0.995250E-02,0.113852E+00,
24147 &0.341903E-02,0.335641E+00,0.132253E+00,0.933610E-02,0.937024E-02,
24148 &0.934557E-02,0.933610E-02,0.103659E+00,0.332009E-02,0.320367E+00,
24149 &0.125033E+00,0.874584E-02,0.877973E-02,0.875514E-02,0.874584E-02,
24150 &0.943886E-01,0.321106E-02,0.000000E+00,0.000000E+00,0.000000E+00,
24151 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24152 &0.591114E+00,0.254807E+00,0.139531E-01,0.139531E-01,0.139531E-01,
24153 &0.139531E-01,0.326288E+00,0.000000E+00,0.571121E+00,0.243424E+00,
24154 &0.133325E-01,0.133362E-01,0.133336E-01,0.133325E-01,0.296956E+00,
24155 &0.429082E-03,0.551151E+00,0.232297E+00,0.127105E-01,0.127175E-01,
24156 &0.127126E-01,0.127105E-01,0.269811E+00,0.785137E-03,0.531253E+00/
24157 DATA (DL(K),K= 1786, 1870) /
24158 &0.221436E+00,0.120916E-01,0.121015E-01,0.120945E-01,0.120916E-01,
24159 &0.244803E+00,0.107790E-02,0.511467E+00,0.210850E+00,0.114794E-01,
24160 &0.114918E-01,0.114829E-01,0.114794E-01,0.221863E+00,0.131504E-02,
24161 &0.491833E+00,0.200545E+00,0.108767E-01,0.108913E-01,0.108808E-01,
24162 &0.108767E-01,0.200886E+00,0.150337E-02,0.472388E+00,0.190531E+00,
24163 &0.102861E-01,0.103027E-01,0.102907E-01,0.102861E-01,0.181762E+00,
24164 &0.164910E-02,0.453170E+00,0.180812E+00,0.970979E-02,0.972799E-02,
24165 &0.971477E-02,0.970979E-02,0.164371E+00,0.175777E-02,0.434213E+00,
24166 &0.171394E+00,0.914959E-02,0.916916E-02,0.915488E-02,0.914959E-02,
24167 &0.148589E+00,0.183434E-02,0.415548E+00,0.162282E+00,0.860700E-02,
24168 &0.862770E-02,0.861252E-02,0.860700E-02,0.134293E+00,0.188328E-02,
24169 &0.397208E+00,0.153479E+00,0.808323E-02,0.810484E-02,0.808891E-02,
24170 &0.808323E-02,0.121361E+00,0.190856E-02,0.379220E+00,0.144989E+00,
24171 &0.757922E-02,0.760152E-02,0.758501E-02,0.757922E-02,0.109676E+00,
24172 &0.191374E-02,0.361611E+00,0.136811E+00,0.709565E-02,0.711846E-02,
24173 &0.710150E-02,0.709565E-02,0.991261E-01,0.190199E-02,0.344406E+00,
24174 &0.128948E+00,0.663300E-02,0.665614E-02,0.663885E-02,0.663300E-02/
24175 DATA (DL(K),K= 1871, 1955) /
24176 &0.896059E-01,0.187610E-02,0.327627E+00,0.121398E+00,0.619152E-02,
24177 &0.621484E-02,0.619734E-02,0.619152E-02,0.810177E-01,0.183856E-02,
24178 &0.311292E+00,0.114161E+00,0.577130E-02,0.579466E-02,0.577706E-02,
24179 &0.577130E-02,0.732709E-01,0.179155E-02,0.295421E+00,0.107235E+00,
24180 &0.537228E-02,0.539554E-02,0.537794E-02,0.537228E-02,0.662824E-01,
24181 &0.173700E-02,0.280026E+00,0.100616E+00,0.499423E-02,0.501728E-02,
24182 &0.499977E-02,0.499423E-02,0.599766E-01,0.167658E-02,0.265121E+00,
24183 &0.943000E-01,0.463683E-02,0.465958E-02,0.464223E-02,0.463683E-02,
24184 &0.542848E-01,0.161174E-02,0.000000E+00,0.000000E+00,0.000000E+00,
24185 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24186 &0.551659E+00,0.219084E+00,0.867977E-02,0.867977E-02,0.867977E-02,
24187 &0.867977E-02,0.218587E+00,-.173472E-16,0.528947E+00,0.207536E+00,
24188 &0.819621E-02,0.819909E-02,0.819696E-02,0.819621E-02,0.196367E+00,
24189 &0.234843E-03,0.506575E+00,0.196391E+00,0.772540E-02,0.773082E-02,
24190 &0.772680E-02,0.772540E-02,0.176280E+00,0.427503E-03,0.484579E+00,
24191 &0.185646E+00,0.726876E-02,0.727639E-02,0.727069E-02,0.726876E-02,
24192 &0.158158E+00,0.583933E-03,0.462988E+00,0.175298E+00,0.682746E-02/
24193 DATA (DL(K),K= 1956, 2040) /
24194 &0.683702E-02,0.682985E-02,0.682746E-02,0.141851E+00,0.708874E-03,
24195 &0.441830E+00,0.165345E+00,0.640226E-02,0.641347E-02,0.640502E-02,
24196 &0.640226E-02,0.127203E+00,0.806409E-03,0.421129E+00,0.155783E+00,
24197 &0.599380E-02,0.600641E-02,0.599686E-02,0.599380E-02,0.114065E+00,
24198 &0.880249E-03,0.400912E+00,0.146609E+00,0.560252E-02,0.561629E-02,
24199 &0.560581E-02,0.560252E-02,0.102296E+00,0.933676E-03,0.381199E+00,
24200 &0.137819E+00,0.522870E-02,0.524342E-02,0.523217E-02,0.522870E-02,
24201 &0.917608E-01,0.969607E-03,0.362011E+00,0.129407E+00,0.487247E-02,
24202 &0.488796E-02,0.487607E-02,0.487247E-02,0.823356E-01,0.990632E-03,
24203 &0.343367E+00,0.121370E+00,0.453385E-02,0.454992E-02,0.453753E-02,
24204 &0.453385E-02,0.739054E-01,0.999042E-03,0.325282E+00,0.113700E+00,
24205 &0.421272E-02,0.422921E-02,0.421644E-02,0.421272E-02,0.663651E-01,
24206 &0.996863E-03,0.307770E+00,0.106393E+00,0.390887E-02,0.392563E-02,
24207 &0.391260E-02,0.390887E-02,0.596195E-01,0.985881E-03,0.290841E+00,
24208 &0.994399E-01,0.362199E-02,0.363889E-02,0.362570E-02,0.362199E-02,
24209 &0.535826E-01,0.967664E-03,0.274506E+00,0.928343E-01,0.335170E-02,
24210 &0.336862E-02,0.335536E-02,0.335170E-02,0.481769E-01,0.943587E-03/
24211 DATA (DL(K),K= 2041, 2125) /
24212 &0.258771E+00,0.865679E-01,0.309756E-02,0.311439E-02,0.310114E-02,
24213 &0.309756E-02,0.433336E-01,0.914850E-03,0.243639E+00,0.806321E-01,
24214 &0.285905E-02,0.287571E-02,0.286255E-02,0.285905E-02,0.389912E-01,
24215 &0.882497E-03,0.229113E+00,0.750177E-01,0.263565E-02,0.265205E-02,
24216 &0.263905E-02,0.263565E-02,0.350948E-01,0.847432E-03,0.215193E+00,
24217 &0.697152E-01,0.242677E-02,0.244285E-02,0.243005E-02,0.242677E-02,
24218 &0.315960E-01,0.810432E-03,0.000000E+00,0.000000E+00,0.000000E+00,
24219 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24220 &0.503850E+00,0.183581E+00,0.522815E-02,0.522815E-02,0.522815E-02,
24221 &0.522815E-02,0.142635E+00,0.123599E-16,0.479478E+00,0.172477E+00,
24222 &0.488093E-02,0.488328E-02,0.488147E-02,0.488093E-02,0.126767E+00,
24223 &0.124505E-03,0.455750E+00,0.161879E+00,0.455054E-02,0.455493E-02,
24224 &0.455153E-02,0.455054E-02,0.112695E+00,0.225968E-03,0.432681E+00,
24225 &0.151771E+00,0.423664E-02,0.424278E-02,0.423800E-02,0.423664E-02,
24226 &0.100212E+00,0.307702E-03,0.410286E+00,0.142140E+00,0.393907E-02,
24227 &0.394671E-02,0.394073E-02,0.393907E-02,0.891488E-01,0.372395E-03,
24228 &0.388577E+00,0.132974E+00,0.365743E-02,0.366634E-02,0.365934E-02/
24229 DATA (DL(K),K= 2126, 2210) /
24230 &0.365743E-02,0.793490E-01,0.422302E-03,0.367563E+00,0.124259E+00,
24231 &0.339138E-02,0.340133E-02,0.339347E-02,0.339138E-02,0.706688E-01,
24232 &0.459484E-03,0.347256E+00,0.115984E+00,0.314049E-02,0.315129E-02,
24233 &0.314273E-02,0.314049E-02,0.629792E-01,0.485762E-03,0.327660E+00,
24234 &0.108136E+00,0.290433E-02,0.291580E-02,0.290667E-02,0.290433E-02,
24235 &0.561642E-01,0.502744E-03,0.308782E+00,0.100701E+00,0.268243E-02,
24236 &0.269440E-02,0.268483E-02,0.268243E-02,0.501207E-01,0.511853E-03,
24237 &0.290625E+00,0.936693E-01,0.247429E-02,0.248663E-02,0.247672E-02,
24238 &0.247429E-02,0.447569E-01,0.514346E-03,0.273189E+00,0.870261E-01,
24239 &0.227939E-02,0.229197E-02,0.228184E-02,0.227939E-02,0.399920E-01,
24240 &0.511328E-03,0.256475E+00,0.807592E-01,0.209722E-02,0.210991E-02,
24241 &0.209965E-02,0.209722E-02,0.357547E-01,0.503769E-03,0.240478E+00,
24242 &0.748555E-01,0.192721E-02,0.193992E-02,0.192961E-02,0.192721E-02,
24243 &0.319825E-01,0.492518E-03,0.225194E+00,0.693019E-01,0.176883E-02,
24244 &0.178147E-02,0.177117E-02,0.176883E-02,0.286209E-01,0.478318E-03,
24245 &0.210615E+00,0.640851E-01,0.162151E-02,0.163400E-02,0.162379E-02,
24246 &0.162151E-02,0.256219E-01,0.461813E-03,0.196733E+00,0.591917E-01/
24247 DATA (DL(K),K= 2211, 2295) /
24248 &0.148471E-02,0.149698E-02,0.148691E-02,0.148471E-02,0.229436E-01,
24249 &0.443561E-03,0.183536E+00,0.546085E-01,0.135786E-02,0.136986E-02,
24250 &0.135998E-02,0.135786E-02,0.205496E-01,0.424043E-03,0.171011E+00,
24251 &0.503219E-01,0.124042E-02,0.125211E-02,0.124246E-02,0.124042E-02,
24252 &0.184079E-01,0.403672E-03,0.000000E+00,0.000000E+00,0.000000E+00,
24253 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24254 &0.450310E+00,0.149685E+00,0.302765E-02,0.302765E-02,0.302765E-02,
24255 &0.302765E-02,0.901099E-01,-.108420E-17,0.425282E+00,0.139479E+00,
24256 &0.279499E-02,0.279691E-02,0.279537E-02,0.279499E-02,0.794239E-01,
24257 &0.632140E-04,0.401169E+00,0.129837E+00,0.257801E-02,0.258157E-02,
24258 &0.257870E-02,0.257801E-02,0.700941E-01,0.114711E-03,0.377966E+00,
24259 &0.120733E+00,0.237556E-02,0.238052E-02,0.237650E-02,0.237556E-02,
24260 &0.619270E-01,0.156107E-03,0.355668E+00,0.112145E+00,0.218688E-02,
24261 &0.219301E-02,0.218802E-02,0.218688E-02,0.547717E-01,0.188777E-03,
24262 &0.334269E+00,0.104052E+00,0.201113E-02,0.201823E-02,0.201243E-02,
24263 &0.201113E-02,0.484974E-01,0.213848E-03,0.313762E+00,0.964335E-01,
24264 &0.184758E-02,0.185546E-02,0.184900E-02,0.184758E-02,0.429879E-01/
24265 DATA (DL(K),K= 2296, 2380) /
24266 &0.232367E-03,0.294139E+00,0.892696E-01,0.169553E-02,0.170402E-02,
24267 &0.169703E-02,0.169553E-02,0.381432E-01,0.245270E-03,0.275389E+00,
24268 &0.825414E-01,0.155431E-02,0.156326E-02,0.155586E-02,0.155431E-02,
24269 &0.338762E-01,0.253383E-03,0.257502E+00,0.762303E-01,0.142329E-02,
24270 &0.143258E-02,0.142487E-02,0.142329E-02,0.301119E-01,0.257441E-03,
24271 &0.240464E+00,0.703180E-01,0.130188E-02,0.131138E-02,0.130347E-02,
24272 &0.130188E-02,0.267853E-01,0.258098E-03,0.224262E+00,0.647867E-01,
24273 &0.118950E-02,0.119912E-02,0.119108E-02,0.118950E-02,0.238409E-01,
24274 &0.255929E-03,0.208879E+00,0.596190E-01,0.108562E-02,0.109526E-02,
24275 &0.108717E-02,0.108562E-02,0.212308E-01,0.251442E-03,0.194298E+00,
24276 &0.547975E-01,0.989698E-03,0.999283E-03,0.991221E-03,0.989698E-03,
24277 &0.189136E-01,0.245082E-03,0.180499E+00,0.503054E-01,0.901248E-03,
24278 &0.910711E-03,0.902726E-03,0.901248E-03,0.168537E-01,0.237238E-03,
24279 &0.167463E+00,0.461263E-01,0.819789E-03,0.829074E-03,0.821215E-03,
24280 &0.819789E-03,0.150206E-01,0.228250E-03,0.155167E+00,0.422438E-01,
24281 &0.744866E-03,0.753925E-03,0.746234E-03,0.744866E-03,0.133878E-01,
24282 &0.218412E-03,0.143590E+00,0.386421E-01,0.676043E-03,0.684836E-03/
24283 DATA (DL(K),K= 2381, 2465) /
24284 &0.677349E-03,0.676043E-03,0.119320E-01,0.207976E-03,0.132706E+00,
24285 &0.353058E-01,0.612907E-03,0.621403E-03,0.614147E-03,0.612907E-03,
24286 &0.106334E-01,0.197159E-03,0.000000E+00,0.000000E+00,0.000000E+00,
24287 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24288 &0.393307E+00,0.118409E+00,0.167124E-02,0.167124E-02,0.167124E-02,
24289 &0.167124E-02,0.547140E-01,0.433681E-17,0.368555E+00,0.109414E+00,
24290 &0.152547E-02,0.152705E-02,0.152573E-02,0.152547E-02,0.479708E-01,
24291 &0.303147E-04,0.344946E+00,0.101001E+00,0.139202E-02,0.139494E-02,
24292 &0.139249E-02,0.139202E-02,0.421517E-01,0.552185E-04,0.322450E+00,
24293 &0.931345E-01,0.126960E-02,0.127363E-02,0.127024E-02,0.126960E-02,
24294 &0.371043E-01,0.753524E-04,0.301043E+00,0.857854E-01,0.115731E-02,
24295 &0.116225E-02,0.115808E-02,0.115731E-02,0.327131E-01,0.913172E-04,
24296 &0.280698E+00,0.789267E-01,0.105427E-02,0.105995E-02,0.105514E-02,
24297 &0.105427E-02,0.288844E-01,0.103605E-03,0.261390E+00,0.725323E-01,
24298 &0.959726E-03,0.965979E-03,0.960659E-03,0.959726E-03,0.255366E-01,
24299 &0.112688E-03,0.243091E+00,0.665774E-01,0.872987E-03,0.879676E-03,
24300 &0.873966E-03,0.872987E-03,0.226017E-01,0.119000E-03,0.225775E+00/
24301 DATA (DL(K),K= 2466, 2550) /
24302 &0.610385E-01,0.793435E-03,0.800438E-03,0.794441E-03,0.793435E-03,
24303 &0.200219E-01,0.122931E-03,0.209414E+00,0.558928E-01,0.720508E-03,
24304 &0.727716E-03,0.721524E-03,0.720508E-03,0.177490E-01,0.124835E-03,
24305 &0.193979E+00,0.511187E-01,0.653691E-03,0.661011E-03,0.654703E-03,
24306 &0.653691E-03,0.157425E-01,0.125031E-03,0.179441E+00,0.466950E-01,
24307 &0.592513E-03,0.599863E-03,0.593511E-03,0.592513E-03,0.139674E-01,
24308 &0.123805E-03,0.165770E+00,0.426018E-01,0.536539E-03,0.543850E-03,
24309 &0.537513E-03,0.536539E-03,0.123945E-01,0.121411E-03,0.152935E+00,
24310 &0.388195E-01,0.485370E-03,0.492584E-03,0.486314E-03,0.485370E-03,
24311 &0.109993E-01,0.118076E-03,0.140905E+00,0.353295E-01,0.438636E-03,
24312 &0.445702E-03,0.439543E-03,0.438636E-03,0.976027E-02,0.113999E-03,
24313 &0.129648E+00,0.321137E-01,0.395992E-03,0.402871E-03,0.396859E-03,
24314 &0.395992E-03,0.865895E-02,0.109353E-03,0.119131E+00,0.291550E-01,
24315 &0.357120E-03,0.363779E-03,0.357945E-03,0.357120E-03,0.767960E-02,
24316 &0.104292E-03,0.109323E+00,0.264366E-01,0.321725E-03,0.328139E-03,
24317 &0.322505E-03,0.321725E-03,0.680866E-02,0.989468E-04,0.100191E+00,
24318 &0.239428E-01,0.289531E-03,0.295679E-03,0.290266E-03,0.289531E-03/
24319 DATA (DL(K),K= 2551, 2635) /
24320 &0.603390E-02,0.934295E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24321 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24322 &0.334851E+00,0.904666E-01,0.869706E-03,0.869706E-03,0.869706E-03,
24323 &0.869706E-03,0.316365E-01,-.311708E-17,0.311223E+00,0.828706E-01,
24324 &0.784673E-03,0.785968E-03,0.784847E-03,0.784673E-03,0.277037E-01,
24325 &0.134749E-04,0.288910E+00,0.758361E-01,0.708234E-03,0.710597E-03,
24326 &0.708543E-03,0.708234E-03,0.243298E-01,0.247881E-04,0.267855E+00,
24327 &0.693222E-01,0.639256E-03,0.642491E-03,0.639671E-03,0.639256E-03,
24328 &0.214125E-01,0.340882E-04,0.248015E+00,0.632964E-01,0.576953E-03,
24329 &0.580887E-03,0.577448E-03,0.576953E-03,0.188764E-01,0.415701E-04,
24330 &0.229343E+00,0.577274E-01,0.520615E-03,0.525096E-03,0.521167E-03,
24331 &0.520615E-03,0.166642E-01,0.474027E-04,0.211794E+00,0.525860E-01,
24332 &0.469624E-03,0.474520E-03,0.470215E-03,0.469624E-03,0.147265E-01,
24333 &0.517615E-04,0.195325E+00,0.478447E-01,0.423445E-03,0.428640E-03,
24334 &0.424060E-03,0.423445E-03,0.130234E-01,0.548213E-04,0.179891E+00,
24335 &0.434776E-01,0.381606E-03,0.387001E-03,0.382232E-03,0.381606E-03,
24336 &0.115226E-01,0.567474E-04,0.165449E+00,0.394601E-01,0.343691E-03/
24337 DATA (DL(K),K= 2636, 2720) /
24338 &0.349200E-03,0.344317E-03,0.343691E-03,0.101965E-01,0.576952E-04,
24339 &0.151958E+00,0.357691E-01,0.309329E-03,0.314879E-03,0.309948E-03,
24340 &0.309329E-03,0.902217E-02,0.578101E-04,0.139374E+00,0.323826E-01,
24341 &0.278192E-03,0.283721E-03,0.278796E-03,0.278192E-03,0.798131E-02,
24342 &0.572266E-04,0.127655E+00,0.292797E-01,0.249984E-03,0.255440E-03,
24343 &0.250569E-03,0.249984E-03,0.705796E-02,0.560672E-04,0.116760E+00,
24344 &0.264406E-01,0.224440E-03,0.229782E-03,0.225002E-03,0.224440E-03,
24345 &0.623793E-02,0.544420E-04,0.106647E+00,0.238467E-01,0.201321E-03,
24346 &0.206513E-03,0.201856E-03,0.201321E-03,0.550962E-02,0.524504E-04,
24347 &0.972762E-01,0.214802E-01,0.180411E-03,0.185425E-03,0.180918E-03,
24348 &0.180411E-03,0.486321E-02,0.501804E-04,0.886073E-01,0.193242E-01,
24349 &0.161512E-03,0.166328E-03,0.161990E-03,0.161512E-03,0.428946E-02,
24350 &0.477087E-04,0.806013E-01,0.173629E-01,0.144446E-03,0.149048E-03,
24351 &0.144894E-03,0.144446E-03,0.378030E-02,0.451020E-04,0.732197E-01,
24352 &0.155814E-01,0.129049E-03,0.133425E-03,0.129467E-03,0.129049E-03,
24353 &0.332897E-02,0.424179E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24354 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24355 DATA (DL(K),K= 2721, 2805) /
24356 &0.276761E+00,0.663170E-01,0.420483E-03,0.420483E-03,0.420483E-03,
24357 &0.420483E-03,0.172075E-01,0.418773E-17,0.255003E+00,0.601925E-01,
24358 &0.374768E-03,0.375776E-03,0.374876E-03,0.374768E-03,0.151410E-01,
24359 &0.540038E-05,0.234664E+00,0.545789E-01,0.334420E-03,0.336252E-03,
24360 &0.334612E-03,0.334420E-03,0.133594E-01,0.101360E-04,0.215665E+00,
24361 &0.494328E-01,0.298611E-03,0.301108E-03,0.298867E-03,0.298611E-03,
24362 &0.118079E-01,0.141555E-04,0.197941E+00,0.447203E-01,0.266766E-03,
24363 &0.269787E-03,0.267068E-03,0.266766E-03,0.104461E-01,0.174750E-04,
24364 &0.181428E+00,0.404089E-01,0.238391E-03,0.241815E-03,0.238726E-03,
24365 &0.238391E-03,0.924609E-02,0.201244E-04,0.166064E+00,0.364687E-01,
24366 &0.213061E-03,0.216782E-03,0.213417E-03,0.213061E-03,0.818507E-02,
24367 &0.221467E-04,0.151790E+00,0.328719E-01,0.190418E-03,0.194343E-03,
24368 &0.190785E-03,0.190418E-03,0.724366E-02,0.235974E-04,0.138548E+00,
24369 &0.295925E-01,0.170150E-03,0.174202E-03,0.170521E-03,0.170150E-03,
24370 &0.640614E-02,0.245354E-04,0.126282E+00,0.266063E-01,0.151991E-03,
24371 &0.156104E-03,0.152359E-03,0.151991E-03,0.566089E-02,0.250221E-04,
24372 &0.114939E+00,0.238907E-01,0.135710E-03,0.139827E-03,0.136071E-03/
24373 DATA (DL(K),K= 2806, 2890) /
24374 &0.135710E-03,0.499773E-02,0.251191E-04,0.104465E+00,0.214245E-01,
24375 &0.121106E-03,0.125180E-03,0.121455E-03,0.121106E-03,0.440691E-02,
24376 &0.248850E-04,0.948101E-01,0.191879E-01,0.108002E-03,0.111994E-03,
24377 &0.108337E-03,0.108002E-03,0.388094E-02,0.243760E-04,0.859247E-01,
24378 &0.171625E-01,0.962435E-04,0.100124E-03,0.965624E-04,0.962435E-04,
24379 &0.341379E-02,0.236445E-04,0.777613E-01,0.153309E-01,0.856948E-04,
24380 &0.894394E-04,0.859960E-04,0.856948E-04,0.299910E-02,0.227378E-04,
24381 &0.702736E-01,0.136770E-01,0.762337E-04,0.798235E-04,0.765166E-04,
24382 &0.762337E-04,0.263116E-02,0.216984E-04,0.634174E-01,0.121859E-01,
24383 &0.677528E-04,0.711742E-04,0.680169E-04,0.677528E-04,0.230551E-02,
24384 &0.205642E-04,0.571500E-01,0.108434E-01,0.601554E-04,0.633990E-04,
24385 &0.604008E-04,0.601554E-04,0.201791E-02,0.193681E-04,0.514305E-01,
24386 &0.963651E-02,0.533545E-04,0.564148E-04,0.535814E-04,0.533545E-04,
24387 &0.176404E-02,0.181381E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24388 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24389 &0.220700E+00,0.461964E-01,0.185072E-03,0.185072E-03,0.185072E-03,
24390 &0.185072E-03,0.865568E-02,-.294090E-17,0.201438E+00,0.415162E-01/
24391 DATA (DL(K),K= 2891, 2975) /
24392 &0.162774E-03,0.163610E-03,0.162842E-03,0.162774E-03,0.772611E-02,
24393 &0.184134E-05,0.183625E+00,0.372730E-01,0.143469E-03,0.144974E-03,
24394 &0.143588E-03,0.143469E-03,0.690038E-02,0.359959E-05,0.167162E+00,
24395 &0.334245E-01,0.126634E-03,0.128666E-03,0.126791E-03,0.126634E-03,
24396 &0.616000E-02,0.518075E-05,0.151966E+00,0.299378E-01,0.111904E-03,
24397 &0.114340E-03,0.112088E-03,0.111904E-03,0.549219E-02,0.654232E-05,
24398 &0.137959E+00,0.267821E-01,0.989836E-04,0.101716E-03,0.991845E-04,
24399 &0.989836E-04,0.488896E-02,0.767008E-05,0.125065E+00,0.239289E-01,
24400 &0.876157E-04,0.905559E-04,0.878269E-04,0.876157E-04,0.434253E-02,
24401 &0.855860E-05,0.113213E+00,0.213524E-01,0.775899E-04,0.806611E-04,
24402 &0.778055E-04,0.775899E-04,0.384886E-02,0.921640E-05,0.102335E+00,
24403 &0.190285E-01,0.687292E-04,0.718676E-04,0.689446E-04,0.687292E-04,
24404 &0.340422E-02,0.965961E-05,0.923671E-01,0.169353E-01,0.608829E-04,
24405 &0.640353E-04,0.610944E-04,0.608829E-04,0.300332E-02,0.990752E-05,
24406 &0.832476E-01,0.150523E-01,0.539242E-04,0.570473E-04,0.541291E-04,
24407 &0.539242E-04,0.264288E-02,0.998320E-05,0.749179E-01,0.133608E-01,
24408 &0.477459E-04,0.508046E-04,0.479422E-04,0.477459E-04,0.232088E-02/
24409 DATA (DL(K),K= 2976, 3060) /
24410 &0.991147E-05,0.673221E-01,0.118435E-01,0.422554E-04,0.452220E-04,
24411 &0.424417E-04,0.422554E-04,0.203376E-02,0.971603E-05,0.604073E-01,
24412 &0.104845E-01,0.373730E-04,0.402263E-04,0.375483E-04,0.373730E-04,
24413 &0.177791E-02,0.941959E-05,0.541231E-01,0.926900E-02,0.330304E-04,
24414 &0.357544E-04,0.331943E-04,0.330304E-04,0.155117E-02,0.904408E-05,
24415 &0.484216E-01,0.818347E-02,0.291681E-04,0.317517E-04,0.293202E-04,
24416 &0.291681E-04,0.135108E-02,0.860921E-05,0.432578E-01,0.721549E-02,
24417 &0.257333E-04,0.281694E-04,0.258738E-04,0.257333E-04,0.117463E-02,
24418 &0.813214E-05,0.385889E-01,0.635362E-02,0.226802E-04,0.249648E-04,
24419 &0.228093E-04,0.226802E-04,0.101941E-02,0.762814E-05,0.343746E-01,
24420 &0.558739E-02,0.199682E-04,0.221003E-04,0.200863E-04,0.199682E-04,
24421 &0.883469E-03,0.711035E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24422 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24423 &0.168205E+00,0.301419E-01,0.719932E-04,0.719932E-04,0.719932E-04,
24424 &0.719932E-04,0.392825E-02,-.205998E-17,0.151922E+00,0.267932E-01,
24425 &0.623634E-04,0.630456E-04,0.624028E-04,0.623634E-04,0.361412E-02,
24426 &0.457084E-06,0.137042E+00,0.237932E-01,0.541981E-04,0.554098E-04/
24427 DATA (DL(K),K= 3061, 3145) /
24428 &0.542663E-04,0.541981E-04,0.330342E-02,0.989813E-06,0.123446E+00,
24429 &0.211038E-01,0.472163E-04,0.488314E-04,0.473050E-04,0.472163E-04,
24430 &0.300140E-02,0.152631E-05,0.111042E+00,0.186954E-01,0.412159E-04,
24431 &0.431273E-04,0.413184E-04,0.412159E-04,0.270826E-02,0.202092E-05,
24432 &0.997395E-01,0.165410E-01,0.360433E-04,0.381615E-04,0.361542E-04,
24433 &0.360433E-04,0.242968E-02,0.245400E-05,0.894558E-01,0.146159E-01,
24434 &0.315670E-04,0.338178E-04,0.316822E-04,0.315670E-04,0.216928E-02,
24435 &0.281218E-05,0.801130E-01,0.128978E-01,0.276779E-04,0.300002E-04,
24436 &0.277940E-04,0.276779E-04,0.192603E-02,0.308878E-05,0.716379E-01,
24437 &0.113663E-01,0.242878E-04,0.266317E-04,0.244024E-04,0.242878E-04,
24438 &0.170100E-02,0.328451E-05,0.639623E-01,0.100031E-01,0.213246E-04,
24439 &0.236502E-04,0.214357E-04,0.213246E-04,0.149649E-02,0.340483E-05,
24440 &0.570222E-01,0.879131E-02,0.187277E-04,0.210033E-04,0.188341E-04,
24441 &0.187277E-04,0.131163E-02,0.345656E-05,0.507574E-01,0.771565E-02,
24442 &0.164465E-04,0.186476E-04,0.165471E-04,0.164465E-04,0.114469E-02,
24443 &0.344782E-05,0.451118E-01,0.676223E-02,0.144396E-04,0.165480E-04,
24444 &0.145339E-04,0.144396E-04,0.995649E-03,0.338831E-05,0.400330E-01/
24445 DATA (DL(K),K= 3146, 3230) /
24446 &0.591841E-02,0.126720E-04,0.146744E-04,0.127597E-04,0.126720E-04,
24447 &0.863829E-03,0.328754E-05,0.354720E-01,0.517273E-02,0.111137E-04,
24448 &0.130013E-04,0.111946E-04,0.111137E-04,0.747293E-03,0.315403E-05,
24449 &0.313830E-01,0.451477E-02,0.973915E-05,0.115067E-04,0.981339E-05,
24450 &0.973915E-05,0.644664E-03,0.299600E-05,0.277237E-01,0.393511E-02,
24451 &0.852687E-05,0.101721E-04,0.859457E-05,0.852687E-05,0.555034E-03,
24452 &0.282099E-05,0.244545E-01,0.342521E-02,0.745784E-05,0.898076E-05,
24453 &0.751926E-05,0.745784E-05,0.476998E-03,0.263530E-05,0.215390E-01,
24454 &0.297737E-02,0.651555E-05,0.791817E-05,0.657100E-05,0.651555E-05,
24455 &0.409096E-03,0.244427E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24456 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24457 &0.120694E+00,0.180081E-01,0.236444E-04,0.236444E-04,0.236444E-04,
24458 &0.236444E-04,0.154817E-02,0.416656E-17,0.107713E+00,0.158098E-01,
24459 &0.200945E-04,0.206098E-04,0.201146E-04,0.200945E-04,0.151249E-02,
24460 &0.192118E-07,0.960063E-01,0.138667E-01,0.171552E-04,0.180593E-04,
24461 &0.171894E-04,0.171552E-04,0.143574E-02,0.116516E-06,0.854477E-01,
24462 &0.121473E-01,0.146986E-04,0.158894E-04,0.147425E-04,0.146986E-04/
24463 DATA (DL(K),K= 3231, 3315) /
24464 &0.133744E-02,0.251060E-06,0.759386E-01,0.106275E-01,0.126329E-04,
24465 &0.140252E-04,0.126830E-04,0.126329E-04,0.122900E-02,0.395272E-06,
24466 &0.673865E-01,0.928577E-02,0.108901E-04,0.124142E-04,0.109436E-04,
24467 &0.108901E-04,0.111367E-02,0.535145E-06,0.597062E-01,0.810254E-02,
24468 &0.941160E-05,0.110108E-04,0.946648E-05,0.941160E-05,0.996785E-03,
24469 &0.659421E-06,0.528194E-01,0.706039E-02,0.815165E-05,0.978016E-05,
24470 &0.820627E-05,0.815165E-05,0.885152E-03,0.762600E-06,0.466540E-01,
24471 &0.614371E-02,0.707299E-05,0.869464E-05,0.712616E-05,0.707299E-05,
24472 &0.780484E-03,0.842072E-06,0.411433E-01,0.533850E-02,0.614470E-05,
24473 &0.773135E-05,0.619559E-05,0.614470E-05,0.682563E-03,0.896683E-06,
24474 &0.362261E-01,0.463223E-02,0.534297E-05,0.687330E-05,0.539102E-05,
24475 &0.534297E-05,0.593317E-03,0.928176E-06,0.318459E-01,0.401364E-02,
24476 &0.464848E-05,0.610690E-05,0.469333E-05,0.464848E-05,0.513720E-03,
24477 &0.939174E-06,0.279510E-01,0.347266E-02,0.404483E-05,0.542054E-05,
24478 &0.408628E-05,0.404483E-05,0.442713E-03,0.932117E-06,0.244935E-01,
24479 &0.300029E-02,0.351893E-05,0.480507E-05,0.355692E-05,0.351893E-05,
24480 &0.379744E-03,0.910085E-06,0.214299E-01,0.258845E-02,0.306021E-05/
24481 DATA (DL(K),K= 3316, 3400) /
24482 &0.425313E-05,0.309476E-05,0.306021E-05,0.324785E-03,0.876365E-06,
24483 &0.187200E-01,0.222996E-02,0.265958E-05,0.375823E-05,0.269081E-05,
24484 &0.265958E-05,0.277080E-03,0.833755E-06,0.163273E-01,0.191840E-02,
24485 &0.230942E-05,0.331477E-05,0.233747E-05,0.230942E-05,0.235661E-03,
24486 &0.784780E-06,0.142185E-01,0.164805E-02,0.200337E-05,0.291797E-05,
24487 &0.202844E-05,0.200337E-05,0.199949E-03,0.731774E-06,0.123631E-01,
24488 &0.141382E-02,0.173596E-05,0.256351E-05,0.175824E-05,0.173596E-05,
24489 &0.169376E-03,0.676674E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24490 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24491 &0.794823E-01,0.948208E-02,0.607312E-05,0.607312E-05,0.607312E-05,
24492 &0.607312E-05,0.497062E-03,-.140523E-17,0.699344E-01,0.820355E-02,
24493 &0.500852E-05,0.538347E-05,0.501731E-05,0.500852E-05,0.542262E-03,
24494 &-.714686E-07,0.614560E-01,0.709106E-02,0.415227E-05,0.479898E-05,
24495 &0.416702E-05,0.415227E-05,0.549985E-03,-.960102E-07,0.539240E-01,
24496 &0.612155E-02,0.345977E-05,0.429563E-05,0.347839E-05,0.345977E-05,
24497 &0.531288E-03,-.894946E-07,0.472426E-01,0.527757E-02,0.289508E-05,
24498 &0.385164E-05,0.291595E-05,0.289508E-05,0.495120E-03,-.668594E-07/
24499 DATA (DL(K),K= 3401, 3485) /
24500 &0.413245E-01,0.454380E-02,0.243524E-05,0.345851E-05,0.245713E-05,
24501 &0.243524E-05,0.452156E-03,-.338861E-07,0.360903E-01,0.390658E-02,
24502 &0.205923E-05,0.310726E-05,0.208123E-05,0.205923E-05,0.406686E-03,
24503 &0.329349E-08,0.314681E-01,0.335393E-02,0.174861E-05,0.278918E-05,
24504 &0.177007E-05,0.174861E-05,0.359402E-03,0.387747E-07,0.273932E-01,
24505 &0.287528E-02,0.149082E-05,0.250013E-05,0.151127E-05,0.149082E-05,
24506 &0.313779E-03,0.705560E-07,0.238068E-01,0.246132E-02,0.127582E-05,
24507 &0.223699E-05,0.129498E-05,0.127582E-05,0.272195E-03,0.975744E-07,
24508 &0.206558E-01,0.210383E-02,0.109488E-05,0.199657E-05,0.111257E-05,
24509 &0.109488E-05,0.234227E-03,0.118651E-06,0.178921E-01,0.179558E-02,
24510 &0.941584E-06,0.177694E-05,0.957733E-06,0.941584E-06,0.199907E-03,
24511 &0.133780E-06,0.154726E-01,0.153020E-02,0.811157E-06,0.157680E-05,
24512 &0.825743E-06,0.811157E-06,0.169849E-03,0.143581E-06,0.133582E-01,
24513 &0.130209E-02,0.699567E-06,0.139481E-05,0.712624E-06,0.699567E-06,
24514 &0.143794E-03,0.148591E-06,0.115137E-01,0.110634E-02,0.603631E-06,
24515 &0.122977E-05,0.615228E-06,0.603631E-06,0.121163E-03,0.149477E-06,
24516 &0.990774E-02,0.938615E-03,0.520920E-06,0.108072E-05,0.531148E-06/
24517 DATA (DL(K),K= 3486, 3570) /
24518 &0.520920E-06,0.101725E-03,0.147055E-06,0.851194E-02,0.795146E-03,
24519 &0.449441E-06,0.946634E-06,0.458405E-06,0.449441E-06,0.852238E-04,
24520 &0.142064E-06,0.730103E-02,0.672622E-03,0.387542E-06,0.826497E-06,
24521 &0.395353E-06,0.387542E-06,0.712290E-04,0.135149E-06,0.625244E-02,
24522 &0.568155E-03,0.333888E-06,0.719316E-06,0.340658E-06,0.333888E-06,
24523 &0.593824E-04,0.126902E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24524 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24525 &0.457819E-01,0.409492E-02,0.105702E-05,0.105702E-05,0.105702E-05,
24526 &0.105702E-05,0.115350E-03,0.265810E-18,0.395724E-01,0.347873E-02,
24527 &0.812397E-06,0.103880E-05,0.815187E-06,0.812397E-06,0.160406E-03,
24528 &-.555147E-07,0.341639E-01,0.295295E-02,0.627904E-06,0.987449E-06,
24529 &0.632305E-06,0.627904E-06,0.174490E-03,-.847266E-07,0.294481E-01,
24530 &0.250329E-02,0.490075E-06,0.920197E-06,0.495305E-06,0.490075E-06,
24531 &0.174490E-03,-.944763E-07,0.253423E-01,0.211912E-02,0.387225E-06,
24532 &0.845257E-06,0.392760E-06,0.387225E-06,0.167111E-03,-.916775E-07,
24533 &0.217735E-01,0.179138E-02,0.309989E-06,0.766697E-06,0.315473E-06,
24534 &0.309989E-06,0.152540E-03,-.819158E-07,0.186760E-01,0.151211E-02/
24535 DATA (DL(K),K= 3571, 3655) /
24536 &0.252109E-06,0.688927E-06,0.257316E-06,0.252109E-06,0.135295E-03,
24537 &-.682145E-07,0.159921E-01,0.127447E-02,0.208612E-06,0.614302E-06,
24538 &0.213410E-06,0.208612E-06,0.118648E-03,-.528734E-07,0.136704E-01,
24539 &0.107254E-02,0.175203E-06,0.543807E-06,0.179526E-06,0.175203E-06,
24540 &0.102484E-03,-.379748E-07,0.116656E-01,0.901214E-03,0.149064E-06,
24541 &0.478363E-06,0.152890E-06,0.149064E-06,0.871530E-04,-.245007E-07,
24542 &0.993760E-02,0.756074E-03,0.128274E-06,0.418496E-06,0.131610E-06,
24543 &0.128274E-06,0.735682E-04,-.128491E-07,0.845081E-02,0.633315E-03,
24544 &0.111313E-06,0.364260E-06,0.114187E-06,0.111313E-06,0.617706E-04,
24545 &-.327698E-08,0.717398E-02,0.529654E-03,0.971373E-07,0.315568E-06,
24546 &0.995871E-07,0.971373E-07,0.514764E-04,0.421954E-08,0.607950E-02,
24547 &0.442265E-03,0.850687E-07,0.272228E-06,0.871375E-07,0.850687E-07,
24548 &0.426580E-04,0.982709E-08,0.514311E-02,0.368716E-03,0.746164E-07,
24549 &0.233927E-06,0.763489E-07,0.746164E-07,0.352463E-04,0.137715E-07,
24550 &0.434349E-02,0.306920E-03,0.654439E-07,0.200291E-06,0.668838E-07,
24551 &0.654439E-07,0.290260E-04,0.163078E-07,0.366196E-02,0.255085E-03,
24552 &0.573307E-07,0.170932E-06,0.585192E-07,0.573307E-07,0.238196E-04/
24553 DATA (DL(K),K= 3656, 3740) /
24554 &0.177037E-07,0.308217E-02,0.211681E-03,0.501185E-07,0.145441E-06,
24555 &0.510931E-07,0.501185E-07,0.195033E-04,0.182028E-07,0.258987E-02,
24556 &0.175396E-03,0.436915E-07,0.123415E-06,0.444860E-07,0.436915E-07,
24557 &0.159423E-04,0.180204E-07,0.000000E+00,0.000000E+00,0.000000E+00,
24558 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24559 &0.206951E-01,0.123383E-02,0.903693E-07,0.903693E-07,0.903693E-07,
24560 &0.903693E-07,0.147928E-04,0.131925E-18,0.174566E-01,0.102241E-02,
24561 &0.892028E-07,0.129792E-07,0.885875E-07,0.892028E-07,0.328931E-04,
24562 &0.168541E-07,0.147092E-01,0.846741E-03,0.841992E-07,-.346085E-07,
24563 &0.832249E-07,0.841992E-07,0.410825E-04,0.262547E-07,0.123736E-01,
24564 &0.700287E-03,0.769173E-07,-.620958E-07,0.757563E-07,0.769173E-07,
24565 &0.418512E-04,0.305542E-07,0.103910E-01,0.578275E-03,0.688622E-07,
24566 &-.753692E-07,0.676306E-07,0.688622E-07,0.392599E-04,0.318183E-07,
24567 &0.871109E-02,0.476815E-03,0.611778E-07,-.782788E-07,0.599557E-07,
24568 &0.611778E-07,0.356221E-04,0.316149E-07,0.728984E-02,0.392546E-03,
24569 &0.537256E-07,-.749101E-07,0.525642E-07,0.537256E-07,0.312295E-04,
24570 &0.301630E-07,0.608951E-02,0.322656E-03,0.466227E-07,-.678673E-07/
24571 DATA (DL(K),K= 3741, 3825) /
24572 &0.455521E-07,0.466227E-07,0.265816E-04,0.278681E-07,0.507758E-02,
24573 &0.264779E-03,0.400790E-07,-.588670E-07,0.391148E-07,0.400790E-07,
24574 &0.223044E-04,0.251720E-07,0.422604E-02,0.216927E-03,0.341205E-07,
24575 &-.492124E-07,0.332680E-07,0.341205E-07,0.185283E-04,0.222885E-07,
24576 &0.351082E-02,0.177427E-03,0.287480E-07,-.397442E-07,0.280058E-07,
24577 &0.287480E-07,0.152122E-04,0.193702E-07,0.291126E-02,0.144878E-03,
24578 &0.239699E-07,-.309608E-07,0.233320E-07,0.239699E-07,0.123840E-04,
24579 &0.165481E-07,0.240962E-02,0.118102E-03,0.197695E-07,-.231453E-07,
24580 &0.192276E-07,0.197695E-07,0.100316E-04,0.139043E-07,0.199075E-02,
24581 &0.961132E-04,0.161186E-07,-.164194E-07,0.156628E-07,0.161186E-07,
24582 &0.808648E-05,0.114903E-07,0.164168E-02,0.780880E-04,0.129826E-07,
24583 &-.107955E-07,0.126029E-07,0.129826E-07,0.648861E-05,0.933575E-08,
24584 &0.135135E-02,0.633381E-04,0.103192E-07,-.622051E-08,0.100055E-07,
24585 &0.103192E-07,0.519042E-05,0.744979E-08,0.111036E-02,0.512898E-04,
24586 &0.808255E-08,-.260101E-08,0.782557E-08,0.808255E-08,0.414192E-05,
24587 &0.582811E-08,0.910718E-03,0.414657E-04,0.622640E-08,0.177583E-09,
24588 &0.601750E-08,0.622640E-08,0.329729E-05,0.445766E-08,0.745657E-03/
24589 DATA (DL(K),K= 3826, 3910) /
24590 &0.334694E-04,0.470431E-08,0.223586E-08,0.453577E-08,0.470431E-08,
24591 &0.261981E-05,0.331859E-08,0.000000E+00,0.000000E+00,0.000000E+00,
24592 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24593 &0.519165E-02,0.154752E-03,0.135983E-08,0.135983E-08,0.135983E-08,
24594 &0.135983E-08,0.445189E-06,0.165858E-19,0.420352E-02,0.123002E-03,
24595 &-.202651E-07,0.730203E-07,-.200511E-07,-.202651E-07,0.358557E-05,
24596 &-.213089E-07,0.340143E-02,0.977718E-04,-.356451E-07,0.114908E-06,
24597 &-.353066E-07,-.356451E-07,0.384652E-05,-.364475E-07,0.274771E-02,
24598 &0.776124E-04,-.435588E-07,0.139200E-06,-.431556E-07,-.435588E-07,
24599 &0.404834E-05,-.441752E-07,0.221524E-02,0.614950E-04,-.471629E-07,
24600 &0.150069E-06,-.467352E-07,-.471629E-07,0.391615E-05,-.476355E-07,
24601 &0.178268E-02,0.486476E-04,-.477545E-07,0.151420E-06,-.473296E-07,
24602 &-.477545E-07,0.334100E-05,-.481163E-07,0.143185E-02,0.384202E-04,
24603 &-.462359E-07,0.146515E-06,-.458316E-07,-.462359E-07,0.275426E-05,
24604 &-.465126E-07,0.114781E-02,0.302894E-04,-.434031E-07,0.137587E-06,
24605 &-.430295E-07,-.434031E-07,0.226010E-05,-.436143E-07,0.918288E-03,
24606 &0.238367E-04,-.398089E-07,0.126321E-06,-.394715E-07,-.398089E-07/
24607 DATA (DL(K),K= 3911, 3995) /
24608 &0.180947E-05,-.399700E-07,0.733193E-03,0.187249E-04,-.358525E-07,
24609 &0.113940E-06,-.355529E-07,-.358525E-07,0.142045E-05,-.359751E-07,
24610 &0.584227E-03,0.146823E-04,-.318183E-07,0.101291E-06,-.315563E-07,
24611 &-.318183E-07,0.110919E-05,-.319115E-07,0.464586E-03,0.114914E-04,
24612 &-.278936E-07,0.889550E-07,-.276671E-07,-.278936E-07,0.860964E-06,
24613 &-.279643E-07,0.368700E-03,0.897731E-05,-.241972E-07,0.773096E-07,
24614 &-.240033E-07,-.241972E-07,0.662825E-06,-.242508E-07,0.292013E-03,
24615 &0.700034E-05,-.208001E-07,0.665779E-07,-.206356E-07,-.208001E-07,
24616 &0.508061E-06,-.208406E-07,0.230814E-03,0.544870E-05,-.177366E-07,
24617 &0.568734E-07,-.175982E-07,-.177366E-07,0.388493E-06,-.177672E-07,
24618 &0.182078E-03,0.423324E-05,-.150157E-07,0.482316E-07,-.149000E-07,
24619 &-.150157E-07,0.296111E-06,-.150387E-07,0.143349E-03,0.328297E-05,
24620 &-.126295E-07,0.406343E-07,-.125335E-07,-.126295E-07,0.225104E-06,
24621 &-.126468E-07,0.112639E-03,0.254145E-05,-.105595E-07,0.340280E-07,
24622 &-.104803E-07,-.105595E-07,0.170871E-06,-.105726E-07,0.883377E-04,
24623 &0.196395E-05,-.878062E-08,0.283380E-07,-.871555E-08,-.878062E-08,
24624 &0.129517E-06,-.879039E-08,0.000000E+00,0.000000E+00,0.000000E+00/
24625 DATA (DL(K),K= 3996, 4000) /
24626 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24627C
24628 ANS = 0.
24629 IF (X.GT.0.9985) RETURN
24630 IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
24631C
24632 IS = S/DELTA+1
24633 IS1 = IS+1
24634 DO 1 L=1,25
24635 KL = L+NDRV*25
24636 F1(L) = GF(I,IS,KL)
24637 F2(L) = GF(I,IS1,KL)
24638 1 CONTINUE
24639 A1 = DT_CKMTFF(X,F1)
24640 A2 = DT_CKMTFF(X,F2)
24641C A1=ALOG(A1)
24642C A2=ALOG(A2)
24643 S1 = (IS-1)*DELTA
24644 S2 = S1+DELTA
24645 ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
24646C ANS=EXP(ANS)
24647 RETURN
24648 END
24649C
24650
24651*$ CREATE DT_CKMTFF.FOR
24652*COPY DT_CKMTFF
24653 FUNCTION DT_CKMTFF(X,FVL)
24654C**********************************************************************
24655C
24656C LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
24657C FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
24658C NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
24659C IN MAIN ROUTINE.
24660C
24661C**********************************************************************
24662
24663 SAVE
24664 DIMENSION FVL(25),XGRID(25)
24665 DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
24666 *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
24667C
24668 DT_CKMTFF=0.
24669 DO 1 I=1,NX
24670 IF(X.LT.XGRID(I)) GO TO 2
24671 1 CONTINUE
24672 2 I=I-1
24673 IF(I.EQ.0) THEN
24674 I=I+1
24675 ELSE IF(I.GT.23) THEN
24676 I=23
24677 ENDIF
24678 J=I+1
24679 K=J+1
24680 AXI=LOG(XGRID(I))
24681 BXI=LOG(1.-XGRID(I))
24682 AXJ=LOG(XGRID(J))
24683 BXJ=LOG(1.-XGRID(J))
24684 AXK=LOG(XGRID(K))
24685 BXK=LOG(1.-XGRID(K))
24686 FI=LOG(ABS(FVL(I)) +1.E-15)
24687 FJ=LOG(ABS(FVL(J)) +1.E-16)
24688 FK=LOG(ABS(FVL(K)) +1.E-17)
24689 DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
24690 ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
24691 $ BXI))/DET
24692 ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
24693 BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
24694 IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
24695 1RETURN
24696C IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
24697C WRITE(6,2001) X,FVL
24698C 2001 FORMAT(8E12.4)
24699C WRITE(6,2001) ALPHA,BETA,ALOGA,DET
24700C ENDIF
24701 DT_CKMTFF=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
24702 RETURN
24703 END
24704
24705*$ CREATE DT_FLUINI.FOR
24706*COPY DT_FLUINI
24707*
24708*===fluini=============================================================*
24709*
24710 SUBROUTINE DT_FLUINI
24711
24712************************************************************************
24713* Initialisation of the nucleon-nucleon cross section fluctuation *
24714* treatment. The original version by J. Ranft. *
24715* This version dated 21.04.95 is revised by S. Roesler. *
24716************************************************************************
24717
24718 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24719 SAVE
24720 PARAMETER ( LINP = 10 ,
24721 & LOUT = 6 ,
24722 & LDAT = 9 )
24723 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
24724
24725 PARAMETER ( A = 0.1D0,
24726 & B = 0.893D0,
24727 & OM = 1.1D0,
24728 & N = 6,
24729 & DX = 0.003D0)
24730
24731* n-n cross section fluctuations
24732 PARAMETER (NBINS = 1000)
24733 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
24734 DIMENSION FLUSI(NBINS),FLUIX(NBINS)
24735
24736 WRITE(LOUT,1000)
24737 1000 FORMAT(/,1X,'FLUINI: hadronic cross section fluctuations ',
24738 & 'treated')
24739
24740 FLUSU = ZERO
24741 FLUSUU = ZERO
24742
24743 DO 1 I=1,NBINS
24744 X = DBLE(I)*DX
24745 FLUIX(I) = X
24746 FLUS = ((X-B)/(OM*B))**N
24747 IF (FLUS.LE.20.0D0) THEN
24748 FLUSI(I) = (X/B)*EXP(-FLUS)/(X/B+A)
24749 ELSE
24750 FLUSI(I) = ZERO
24751 ENDIF
24752 FLUSU = FLUSU+FLUSI(I)
24753 1 CONTINUE
24754 DO 2 I=1,NBINS
24755 FLUSUU = FLUSUU+FLUSI(I)/FLUSU
24756 FLUSI(I) = FLUSUU
24757 2 CONTINUE
24758
24759C WRITE(LOUT,1001)
24760C1001 FORMAT(1X,'FLUCTUATIONS')
24761C CALL PLOT(FLUIX,FLUSI,1000,1,1000,0.0D0,0.06D0,0.0D0,0.01D0)
24762
24763 DO 3 I=1,NBINS
24764 AF = DBLE(I)*0.001D0
24765 DO 4 J=1,NBINS
24766 IF (AF.LE.FLUSI(J)) THEN
24767 FLUIXX(I) = FLUIX(J)
24768 GOTO 5
24769 ENDIF
24770 4 CONTINUE
24771 5 CONTINUE
24772 3 CONTINUE
24773 FLUIXX(1) = FLUIX(1)
24774 FLUIXX(NBINS) = FLUIX(NBINS)
24775
24776 RETURN
24777 END
24778
24779*$ CREATE DT_SIGTBL.FOR
24780*COPY DT_SIGTBL
24781*
24782*===sigtab=============================================================*
24783*
24784 SUBROUTINE DT_SIGTBL(JP,JT,PTOT,SIGE,MODE)
24785
24786************************************************************************
24787* This version dated 18.11.95 is written by S. Roesler *
24788************************************************************************
24789
24790 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24791 SAVE
24792 PARAMETER ( LINP = 10 ,
24793 & LOUT = 6 ,
24794 & LDAT = 9 )
24795
24796 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24797 & OHALF=0.5D0,ONE=1.0D0)
24798 PARAMETER (PLO=0.01D0,PHI=20.0D0,NBINS=150)
24799
24800 LOGICAL LINIT
24801
24802* particle properties (BAMJET index convention)
24803 CHARACTER*8 ANAME
24804 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24805 & IICH(210),IIBAR(210),K1(210),K2(210)
24806
24807 DIMENSION SIGEP(5,NBINS+1),SIGEN(5,NBINS+1),IDSIG(23)
24808 DATA IDSIG / 1, 0, 0, 0, 0, 0, 0, 2, 0, 0,
24809 & 0, 0, 3, 4, 0, 0, 0, 0, 0, 0,
24810 & 0, 0, 5/
24811 DATA LINIT /.FALSE./
24812
24813* precalculation and tabulation of elastic cross sections
24814 IF (ABS(MODE).EQ.1) THEN
24815 IF (MODE.EQ.1)
24816 & OPEN(LDAT,FILE='outdata0/sigtab.out',STATUS='UNKNOWN')
24817 PLABLX = LOG10(PLO)
24818 PLABHX = LOG10(PHI)
24819 DPLAB = (PLABHX-PLABLX)/DBLE(NBINS)
24820 DO 1 I=1,NBINS+1
24821 PLAB = PLABLX+DBLE(I-1)*DPLAB
24822 PLAB = 10**PLAB
24823 DO 2 IPROJ=1,23
24824 IDX = IDSIG(IPROJ)
24825 IF (IDX.GT.0) THEN
24826C CALL DT_SIHNEL(IPROJ,1,PLAB,SIGEP(IDX,I))
24827C CALL DT_SIHNEL(IPROJ,8,PLAB,SIGEN(IDX,I))
24828 DUMZER = ZERO
24829 CALL DT_XSHN(IPROJ,1,PLAB,DUMZER,SIGTOT,SIGEP(IDX,I))
24830 CALL DT_XSHN(IPROJ,8,PLAB,DUMZER,SIGTOT,SIGEN(IDX,I))
24831 ENDIF
24832 2 CONTINUE
24833 IF (MODE.EQ.1) THEN
24834 WRITE(LDAT,1000) PLAB,(SIGEP(IDX,I),IDX=1,5),
24835 & (SIGEN(IDX,I),IDX=1,5)
24836 1000 FORMAT(F5.1,10F7.2)
24837 ENDIF
24838 1 CONTINUE
24839 IF (MODE.EQ.1) CLOSE(LDAT)
24840 LINIT = .TRUE.
24841 ELSE
24842 SIGE = -ONE
24843 IF (LINIT.AND.(JP.LE.23).AND.(PTOT.GE.PLO)
24844 & .AND.(PTOT.LE.PHI) ) THEN
24845 IDX = IDSIG(JP)
24846 IF ( (IDX.GT.0).AND.((JT.EQ.1).OR.(JT.EQ.8)) ) THEN
24847 PLABX = LOG10(PTOT)
24848 IF (PLABX.LE.PLABLX) THEN
24849 I1 = 1
24850 I2 = 1
24851 ELSEIF (PLABX.GE.PLABHX) THEN
24852 I1 = NBINS+1
24853 I2 = NBINS+1
24854 ELSE
24855 I1 = INT((PLABX-PLABLX)/DPLAB)+1
24856 I2 = I1+1
24857 ENDIF
24858 PLAB1X = PLABLX+DBLE(I1-1)*DPLAB
24859 PLAB2X = PLABLX+DBLE(I2-1)*DPLAB
24860 PBIN = PLAB2X-PLAB1X
24861 IF (PBIN.GT.TINY10) THEN
24862 RATX = (PLABX-PLAB1X)/(PLAB2X-PLAB1X)
24863 ELSE
24864 RATX = ZERO
24865 ENDIF
24866 IF (JT.EQ.1) THEN
24867 SIG1 = SIGEP(IDX,I1)
24868 SIG2 = SIGEP(IDX,I2)
24869 ELSE
24870 SIG1 = SIGEN(IDX,I1)
24871 SIG2 = SIGEN(IDX,I2)
24872 ENDIF
24873 SIGE = SIG1+RATX*(SIG2-SIG1)
24874 ENDIF
24875 ENDIF
24876 ENDIF
24877
24878 RETURN
24879 END
24880
24881*$ CREATE DT_XSTABL.FOR
24882*COPY DT_XSTABL
24883*
24884*===xstabl=============================================================*
24885*
24886 SUBROUTINE DT_XSTABL(WHAT,IXSQEL,IRATIO)
24887
24888 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24889 SAVE
24890 PARAMETER ( LINP = 10 ,
24891 & LOUT = 6 ,
24892 & LDAT = 9 )
24893 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24894 & OHALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
24895 LOGICAL LLAB,LELOG,LQLOG
24896
24897* particle properties (BAMJET index convention)
24898 CHARACTER*8 ANAME
24899 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24900 & IICH(210),IIBAR(210),K1(210),K2(210)
24901* properties of interacting particles
24902 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
24903 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
24904* Glauber formalism: cross sections
24905 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
24906 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
24907 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
24908 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
24909 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
24910 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
24911 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
24912 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
24913 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
24914 & BSLOPE,NEBINI,NQBINI
24915* emulsion treatment
24916 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
24917 & NCOMPO,IEMUL
24918
24919 DIMENSION WHAT(6)
24920
24921 LLAB = (WHAT(1).GT.ZERO).OR.(WHAT(2).GT.ZERO)
24922 ELO = ABS(WHAT(1))
24923 EHI = ABS(WHAT(2))
24924 IF (ELO.GT.EHI) ELO = EHI
24925 LELOG = WHAT(3).LT.ZERO
24926 NEBINS = MAX(INT(ABS(WHAT(3))),1)
24927 DEBINS = (EHI-ELO)/DBLE(NEBINS)
24928 IF (LELOG) THEN
24929 AELO = LOG10(ELO)
24930 AEHI = LOG10(EHI)
24931 ADEBIN = (AEHI-AELO)/DBLE(NEBINS)
24932 ENDIF
24933 Q2LO = WHAT(4)
24934 Q2HI = WHAT(5)
24935 IF (Q2LO.GT.Q2HI) Q2LO = Q2HI
24936 LQLOG = WHAT(6).LT.ZERO
24937 NQBINS = MAX(INT(ABS(WHAT(6))),1)
24938 DQBINS = (Q2HI-Q2LO)/DBLE(NQBINS)
24939 IF (LQLOG) THEN
24940 AQ2LO = LOG10(Q2LO)
24941 AQ2HI = LOG10(Q2HI)
24942 ADQBIN = (AQ2HI-AQ2LO)/DBLE(NQBINS)
24943 ENDIF
24944
24945 IF ( ELO.EQ. EHI) NEBINS = 0
24946 IF (Q2LO.EQ.Q2HI) NQBINS = 0
24947
24948 WRITE(LOUT,1000) ELO,EHI,LLAB,IXSQEL,Q2LO,Q2HI,IJPROJ,IP,IT
24949 1000 FORMAT(/,1X,'XSTABL: E_lo =',E10.3,' GeV E_hi =',E10.3,
24950 & ' GeV Lab = ',L1,' qel: ',I2,/,10X,'Q2_lo =',F10.5,
24951 & ' GeV^2 Q2_hi =',F10.5,' GeV^2',/,10X,'id_p = ',I2,
24952 & ' A_p = ',I3,' A_t = ',I3,/)
24953
24954C IF (IJPROJ.NE.7) THEN
24955 WRITE(LOUT,'(1X,A,/)')'(E,STOT,SELA,SQEP,SQET,SQE2,SINE,SPROD)'
24956* normalize fractions of emulsion components
24957 IF (NCOMPO.GT.0) THEN
24958 SUMFRA = ZERO
24959 DO 10 I=1,NCOMPO
24960 SUMFRA = SUMFRA+EMUFRA(I)
24961 10 CONTINUE
24962 IF (SUMFRA.GT.ZERO) THEN
24963 DO 11 I=1,NCOMPO
24964 EMUFRA(I) = EMUFRA(I)/SUMFRA
24965 11 CONTINUE
24966 ENDIF
24967 ENDIF
24968C ELSE
24969C WRITE(LOUT,'(1X,A,/)') '(Q2,E,STOT,ETOT,SIN,EIN,STOT0)'
24970C ENDIF
24971 DO 1 I=1,NEBINS+1
24972 IF (LELOG) THEN
24973 E = 10**(AELO+DBLE(I-1)*ADEBIN)
24974 ELSE
24975 E = ELO+DBLE(I-1)*DEBINS
24976 ENDIF
24977 DO 2 J=1,NQBINS+1
24978 IF (LQLOG) THEN
24979 Q2 = 10**(AQ2LO+DBLE(J-1)*ADQBIN)
24980 ELSE
24981 Q2 = Q2LO+DBLE(J-1)*DQBINS
24982 ENDIF
24983c IF (IJPROJ.NE.7) THEN
24984 IF (LLAB) THEN
24985 PLAB = ZERO
24986 ECM = ZERO
24987 CALL DT_LTINI(IJPROJ,1,E,PPN0,ECM,0)
24988 ELSE
24989 ECM = E
24990 ENDIF
24991 XI = ZERO
24992 Q2I = ZERO
24993 IF (IJPROJ.EQ.7) Q2I = Q2
24994 IF (NCOMPO.GT.0) THEN
24995 DO 20 IC=1,NCOMPO
24996 IIT = IEMUMA(IC)
24997 CALL DT_XSGLAU(IP,IIT,IJPROJ,XI,Q2I,ECM,1,1,-IC)
24998 20 CONTINUE
24999 ELSE
25000 CALL DT_XSGLAU(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,-1)
25001C CALL AMPLIT(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,1)
25002 ENDIF
25003 IF (NCOMPO.GT.0) THEN
25004 XTOT = ZERO
25005 ETOT = ZERO
25006 XELA = ZERO
25007 EELA = ZERO
25008 XQEP = ZERO
25009 EQEP = ZERO
25010 XQET = ZERO
25011 EQET = ZERO
25012 XQE2 = ZERO
25013 EQE2 = ZERO
25014 XPRO = ZERO
25015 EPRO = ZERO
25016 XPRO1= ZERO
25017 XDEL = ZERO
25018 EDEL = ZERO
25019 XDQE = ZERO
25020 EDQE = ZERO
25021 DO 21 IC=1,NCOMPO
25022 XTOT = XTOT+EMUFRA(IC)*XSTOT(1,1,IC)
25023 ETOT = ETOT+EMUFRA(IC)*XETOT(1,1,IC)**2
25024 XELA = XELA+EMUFRA(IC)*XSELA(1,1,IC)
25025 EELA = EELA+EMUFRA(IC)*XEELA(1,1,IC)**2
25026 XQEP = XQEP+EMUFRA(IC)*XSQEP(1,1,IC)
25027 EQEP = EQEP+EMUFRA(IC)*XEQEP(1,1,IC)**2
25028 XQET = XQET+EMUFRA(IC)*XSQET(1,1,IC)
25029 EQET = EQET+EMUFRA(IC)*XEQET(1,1,IC)**2
25030 XQE2 = XQE2+EMUFRA(IC)*XSQE2(1,1,IC)
25031 EQE2 = EQE2+EMUFRA(IC)*XEQE2(1,1,IC)**2
25032 XPRO = XPRO+EMUFRA(IC)*XSPRO(1,1,IC)
25033 EPRO = EPRO+EMUFRA(IC)*XEPRO(1,1,IC)**2
25034 XDEL = XDEL+EMUFRA(IC)*XSDEL(1,1,IC)
25035 EDEL = EDEL+EMUFRA(IC)*XEDEL(1,1,IC)**2
25036 XDQE = XDQE+EMUFRA(IC)*XSDQE(1,1,IC)
25037 EDQE = EDQE+EMUFRA(IC)*XEDQE(1,1,IC)**2
25038 YPRO = XSTOT(1,1,IC)-XSELA(1,1,IC)
25039 & -XSQEP(1,1,IC)-XSQET(1,1,IC)
25040 & -XSQE2(1,1,IC)
25041 XPRO1= XPRO1+EMUFRA(IC)*YPRO
25042 21 CONTINUE
25043 ETOT = SQRT(ETOT)
25044 EELA = SQRT(EELA)
25045 EQEP = SQRT(EQEP)
25046 EQET = SQRT(EQET)
25047 EQE2 = SQRT(EQE2)
25048 EPRO = SQRT(EPRO)
25049 EDEL = SQRT(EDEL)
25050 EDQE = SQRT(EDQE)
25051 WRITE(LOUT,'(8E9.3)')
25052 & E,XTOT,XELA,XQEP,XQET,XQE2,XPRO,XPRO1
25053C WRITE(LOUT,'(4E9.3)')
25054C & E,XDEL,XDQE,XDEL+XDQE
25055 ELSE
25056 WRITE(LOUT,'(11E10.3)')
25057 & E,
25058 & XSTOT(1,1,1),XSELA(1,1,1),XSQEP(1,1,1),XSQET(1,1,1),
25059 & XSQE2(1,1,1),XSPRO(1,1,1),
25060 & XSTOT(1,1,1)-XSELA(1,1,1)-XSQEP(1,1,1)-XSQET(1,1,1)
25061 & -XSQE2(1,1,1),XSDEL(1,1,1),XSDQE(1,1,1),
25062 & XSDEL(1,1,1)+XSDQE(1,1,1)
25063C WRITE(LOUT,'(4E9.3)') E,XSDEL(1,1,1),XSDQE(1,1,1),
25064C & XSDEL(1,1,1)+XSDQE(1,1,1)
25065 ENDIF
25066c ELSE
25067c IF (LLAB) THEN
25068c IF (IT.GT.1) THEN
25069c IF (IXSQEL.EQ.0) THEN
25070cC CALL DT_SIGGA(IT, Q2, E,ZERO,ZERO,
25071cC CALL DT_SIGGA(IT, E,Q2,ZERO,ZERO,
25072c CALL DT_SIGGA(IT,ZERO,Q2,ZERO,E,
25073c & STOT,ETOT,SIN,EIN,STOT0)
25074c IF (IRATIO.EQ.1) THEN
25075c CALL DT_SIGGP( Q2, E,ZERO,ZERO,STGP,SIGP,SDGP)
25076cC CALL DT_SIGGP( E,Q2,ZERO,ZERO,STGP,SIGP,SDGP)
25077cC CALL DT_SIGGP(ZERO,Q2,ZERO,E,STGP,SIGP,SDGP)
25078c*!! save cross sections
25079c STOTA = STOT
25080c ETOTA = ETOT
25081c STOTP = STGP
25082c*!!
25083c STOT = STOT/(DBLE(IT)*STGP)
25084c SIN = SIN/(DBLE(IT)*SIGP)
25085c STOT0 = STGP
25086c ETOT = ZERO
25087c EIN = ZERO
25088c ENDIF
25089c ELSE
25090c WRITE(LOUT,*)
25091c & ' XSTABL: qel. xs. not implemented for nuclei'
25092c STOP
25093c ENDIF
25094c ELSE
25095c ETOT = ZERO
25096c EIN = ZERO
25097c STOT0= ZERO
25098c IF (IXSQEL.EQ.0) THEN
25099c CALL DT_SIGGP(ZERO,Q2,ZERO,E,STOT,SIN,SDIR)
25100c ELSE
25101c SIN = ZERO
25102c CALL DT_SIGVEL(ZERO,Q2,ZERO,E,IXSQEL,STOT,SIN,STOT0)
25103c ENDIF
25104c ENDIF
25105c ELSE
25106c IF (IT.GT.1) THEN
25107c IF (IXSQEL.EQ.0) THEN
25108c CALL DT_SIGGA(IT,ZERO,Q2,E,ZERO,
25109c & STOT,ETOT,SIN,EIN,STOT0)
25110c IF (IRATIO.EQ.1) THEN
25111c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STGP,SIGP,SDGP)
25112c*!! save cross sections
25113c STOTA = STOT
25114c ETOTA = ETOT
25115c STOTP = STGP
25116c*!!
25117c STOT = STOT/(DBLE(IT)*STGP)
25118c SIN = SIN/(DBLE(IT)*SIGP)
25119c STOT0 = STGP
25120c ETOT = ZERO
25121c EIN = ZERO
25122c ENDIF
25123c ELSE
25124c WRITE(LOUT,*)
25125c & ' XSTABL: qel. xs. not implemented for nuclei'
25126c STOP
25127c ENDIF
25128c ELSE
25129c ETOT = ZERO
25130c EIN = ZERO
25131c STOT0= ZERO
25132c IF (IXSQEL.EQ.0) THEN
25133c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STOT,SIN,SDIR)
25134c ELSE
25135c SIN = ZERO
25136c CALL DT_SIGVEL(ZERO,Q2,E,ZERO,IXSQEL,STOT,SIN,STOT0)
25137c ENDIF
25138c ENDIF
25139c ENDIF
25140cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,STOTA,ETOTA,STOTP,ZERO
25141cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,SDIR
25142cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,STOT0
25143c WRITE(LOUT,'(1X,6E10.3)')Q2,E,STOT,ETOT,SIN,EIN
25144c ENDIF
25145 2 CONTINUE
25146 1 CONTINUE
25147
25148 RETURN
25149 END
25150
25151*$ CREATE DT_TESTXS.FOR
25152*COPY DT_TESTXS
25153*
25154*===testxs=============================================================*
25155*
25156 SUBROUTINE DT_TESTXS
25157
25158 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25159 SAVE
25160
25161 DIMENSION XSTOT(26,2),XSELA(26,2)
25162
25163 OPEN(10,FILE='testxs_ptot.out',STATUS='UNKNOWN')
25164 OPEN(11,FILE='testxs_pela.out',STATUS='UNKNOWN')
25165 OPEN(12,FILE='testxs_ntot.out',STATUS='UNKNOWN')
25166 OPEN(13,FILE='testxs_nela.out',STATUS='UNKNOWN')
25167 DUMECM = 0.0D0
25168 PLABL = 0.01D0
25169 PLABH = 10000.0D0
25170 NBINS = 120
25171 APLABL = LOG10(PLABL)
25172 APLABH = LOG10(PLABH)
25173 ADPLAB = (APLABH-APLABL)/DBLE(NBINS)
25174 DO 1 I=1,NBINS+1
25175 ADP = APLABL+DBLE(I-1)*ADPLAB
25176 P = 10.0D0**ADP
25177 DO 2 J=1,26
25178 CALL DT_XSHN(J,1,P,DUMECM,XSTOT(J,1),XSELA(J,1))
25179 CALL DT_XSHN(J,8,P,DUMECM,XSTOT(J,2),XSELA(J,2))
25180 2 CONTINUE
25181 WRITE(10,1000) P,(XSTOT(K,1),K=1,26)
25182 WRITE(11,1000) P,(XSELA(K,1),K=1,26)
25183 WRITE(12,1000) P,(XSTOT(K,2),K=1,26)
25184 WRITE(13,1000) P,(XSELA(K,2),K=1,26)
25185 1 CONTINUE
25186 1000 FORMAT(F8.3,26F9.3)
25187
25188 RETURN
25189 END
25190
25191************************************************************************
25192* *
25193* DTUNUC 2.0: library routines *
25194* processed by S. Roesler, 6.5.95 *
25195* *
25196************************************************************************
25197*
25198* 1) Handling of parton momenta
25199* SUBROUTINE MASHEL
25200* SUBROUTINE DFERMI
25201*
25202* 2) Handling of parton flavors and particle indices
25203* INTEGER FUNCTION IPDG2B
25204* INTEGER FUNCTION IB2PDG
25205* INTEGER FUNCTION IQUARK
25206* INTEGER FUNCTION IBJQUA
25207* INTEGER FUNCTION ICIHAD
25208* INTEGER FUNCTION IPDGHA
25209* INTEGER FUNCTION MCHAD
25210* SUBROUTINE FLAHAD
25211*
25212* 3) Energy-momentum and quantum number conservation check routines
25213* SUBROUTINE EMC1
25214* SUBROUTINE EMC2
25215* SUBROUTINE EVTEMC
25216* SUBROUTINE EVTFLC
25217* SUBROUTINE EVTCHG
25218*
25219* 4) Transformations
25220* SUBROUTINE LTINI
25221* SUBROUTINE LTRANS
25222* SUBROUTINE LTNUC
25223* SUBROUTINE DALTRA
25224* SUBROUTINE DTRAFO
25225* SUBROUTINE STTRAN
25226* SUBROUTINE MYTRAN
25227* SUBROUTINE LT2LAO
25228* SUBROUTINE LT2LAB
25229*
25230* 5) Sampling from distributions
25231* INTEGER FUNCTION NPOISS
25232* DOUBLE PRECISION FUNCTION SAMPXB
25233* DOUBLE PRECISION FUNCTION SAMPEX
25234* DOUBLE PRECISION FUNCTION SAMSQX
25235* DOUBLE PRECISION FUNCTION BETREJ
25236* DOUBLE PRECISION FUNCTION DGAMRN
25237* DOUBLE PRECISION FUNCTION DBETAR
25238* SUBROUTINE RANNOR
25239* SUBROUTINE DPOLI
25240* SUBROUTINE DSFECF
25241* SUBROUTINE RACO
25242*
25243* 6) Special functions, algorithms and service routines
25244* DOUBLE PRECISION FUNCTION YLAMB
25245* SUBROUTINE SORT
25246* SUBROUTINE SORT1
25247* SUBROUTINE DT_XTIME
25248*
25249* 7) Random number generator package
25250* DOUBLE PRECISION FUNCTION DT_RNDM
25251* SUBROUTINE DT_RNDMST
25252* SUBROUTINE DT_RNDMIN
25253* SUBROUTINE DT_RNDMOU
25254* SUBROUTINE DT_RNDMTE
25255*
25256************************************************************************
25257* *
25258* 1) Handling of parton momenta *
25259* *
25260************************************************************************
25261*$ CREATE DT_MASHEL.FOR
25262*COPY DT_MASHEL
25263*
25264*===mashel=============================================================*
25265*
25266 SUBROUTINE DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
25267
25268************************************************************************
25269* *
25270* rescaling of momenta of two partons to put both *
25271* on mass shell *
25272* *
25273* input: PA1,PA2 input momentum vectors *
25274* XM1,2 desired masses of particles afterwards *
25275* P1,P2 changed momentum vectors *
25276* *
25277* The original version is written by R. Engel. *
25278* This version dated 12.12.94 is modified by S. Roesler. *
25279************************************************************************
25280
25281 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25282 SAVE
25283 PARAMETER ( LINP = 10 ,
25284 & LOUT = 6 ,
25285 & LDAT = 9 )
25286 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
25287
25288 DIMENSION PA1(4),PA2(4),P1(4),P2(4)
25289
25290 IREJ = 0
25291
25292* Lorentz transformation into system CMS
25293 PX = PA1(1)+PA2(1)
25294 PY = PA1(2)+PA2(2)
25295 PZ = PA1(3)+PA2(3)
25296 EE = PA1(4)+PA2(4)
25297 XPTOT = SQRT(PX**2+PY**2+PZ**2)
25298 XMS = (EE-XPTOT)*(EE+XPTOT)
25299 IF(XMS.LT.(XM1+XM2)**2) THEN
25300C WRITE(LOUT,'(3E12.4)')XMS,XM1,XM2
25301 GOTO 9999
25302 ENDIF
25303 XMS = SQRT(XMS)
25304 BGX = PX/XMS
25305 BGY = PY/XMS
25306 BGZ = PZ/XMS
25307 GAM = EE/XMS
25308 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
25309 & PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
25310* rotation angles
25311 COD = P1(3)/PTOT1
25312C SID = SQRT((ONE-COD)*(ONE+COD))
25313 PPT = SQRT(P1(1)**2+P1(2)**2)
25314 SID = PPT/PTOT1
25315 COF = ONE
25316 SIF = ZERO
25317 IF(PTOT1*SID.GT.TINY10) THEN
25318 COF = P1(1)/(SID*PTOT1)
25319 SIF = P1(2)/(SID*PTOT1)
25320 ANORF = SQRT(COF*COF+SIF*SIF)
25321 COF = COF/ANORF
25322 SIF = SIF/ANORF
25323 ENDIF
25324* new CM momentum and energies (for masses XM1,XM2)
25325 XM12 = SIGN(XM1**2,XM1)
25326 XM22 = SIGN(XM2**2,XM2)
25327 SS = XMS**2
25328 PCMP = DT_YLAMB(SS,XM12,XM22)/(2.D0*XMS)
25329 EE1 = SQRT(XM12+PCMP**2)
25330 EE2 = XMS-EE1
25331* back rotation
25332 MODE = 1
25333 CALL DT_MYTRAN(MODE,ZERO,ZERO,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
25334 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
25335 & PTOT1,P1(1),P1(2),P1(3),P1(4))
25336 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
25337 & PTOT2,P2(1),P2(2),P2(3),P2(4))
25338* check consistency
25339 DEL = XMS*0.0001D0
25340 IF (ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
25341 IDEV = 1
25342 ELSEIF (ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
25343 IDEV = 2
25344 ELSEIF (ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
25345 IDEV = 3
25346 ELSEIF (ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
25347 IDEV = 4
25348 ELSE
25349 IDEV = 0
25350 ENDIF
25351 IF (IDEV.NE.0) THEN
25352 WRITE(LOUT,'(/1X,A,I3)')
25353 & 'MASHEL: inconsistent transformation',IDEV
25354 WRITE(LOUT,'(1X,A)') 'MASHEL: input momenta/masses:'
25355 WRITE(LOUT,'(1X,5E12.5)') (PA1(K),K=1,4),XM1
25356 WRITE(LOUT,'(1X,5E12.5)') (PA2(K),K=1,4),XM2
25357 WRITE(LOUT,'(1X,A)') 'MASHEL: output momenta:'
25358 WRITE(LOUT,'(5X,4E12.5)') (P1(K),K=1,4)
25359 WRITE(LOUT,'(5X,4E12.5)') (P2(K),K=1,4)
25360 ENDIF
25361 RETURN
25362
25363 9999 CONTINUE
25364 IREJ = 1
25365 RETURN
25366 END
25367
25368*$ CREATE DT_DFERMI.FOR
25369*COPY DT_DFERMI
25370*
25371*===dfermi=============================================================*
25372*
25373 SUBROUTINE DT_DFERMI(GPART)
25374
25375************************************************************************
25376* Find largest of three random numbers. *
25377************************************************************************
25378
25379 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25380 SAVE
25381
25382 DIMENSION G(3)
25383
25384 DO 10 I=1,3
25385 G(I)=DT_RNDM(GPART)
25386 10 CONTINUE
25387 IF (G(3).LT.G(2)) GOTO 40
25388 IF (G(3).LT.G(1)) GOTO 30
25389 GPART = G(3)
25390 20 RETURN
25391 30 GPART = G(1)
25392 GOTO 20
25393 40 IF (G(2).LT.G(1)) GOTO 30
25394 GPART = G(2)
25395 GOTO 20
25396
25397 END
25398
25399************************************************************************
25400* *
25401* 2) Handling of parton flavors and particle indices *
25402* *
25403************************************************************************
25404*$ CREATE IDT_IPDG2B.FOR
25405*COPY IDT_IPDG2B
25406*
25407*===ipdg2b=============================================================*
25408*
25409 INTEGER FUNCTION IDT_IPDG2B(ID,NN,MODE)
25410
25411************************************************************************
25412* *
25413* conversion of quark numbering scheme *
25414* *
25415* input: PDG parton numbering *
25416* for diquarks: NN number of the constituent quark *
25417* (e.g. ID=2301,NN=1 -> ICONV2=1) *
25418* *
25419* output: BAMJET particle codes *
25420* 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) *
25421* 2 d 8 a-d -2 a-d *
25422* 3 s 9 a-s -3 a-s *
25423* 4 c 10 a-c -4 a-c *
25424* *
25425* This is a modified version of ICONV2 written by R. Engel. *
25426* This version dated 13.12.94 is written by S. Roesler. *
25427************************************************************************
25428
25429 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25430 SAVE
25431 PARAMETER ( LINP = 10 ,
25432 & LOUT = 6 ,
25433 & LDAT = 9 )
25434
25435 IDA = ABS(ID)
25436* diquarks
25437 IF (IDA.GT.6) THEN
25438 KF = 3
25439 IF (IDA.GE.1000) KF = 4
25440 IDA = IDA/(10**(KF-NN))
25441 IDA = MOD(IDA,10)
25442 ENDIF
25443* exchange up and dn quarks
25444 IF (IDA.EQ.1) THEN
25445 IDA = 2
25446 ELSEIF (IDA.EQ.2) THEN
25447 IDA = 1
25448 ENDIF
25449* antiquarks
25450 IF (ID.LT.0) THEN
25451 IF (MODE.EQ.1) THEN
25452 IDA = IDA+6
25453 ELSE
25454 IDA = -IDA
25455 ENDIF
25456 ENDIF
25457 IDT_IPDG2B = IDA
25458
25459 RETURN
25460 END
25461
25462*$ CREATE IDT_IB2PDG.FOR
25463*COPY IDT_IB2PDG
25464*
25465*===ib2pdg=============================================================*
25466*
25467 INTEGER FUNCTION IDT_IB2PDG(ID1,ID2,MODE)
25468
25469************************************************************************
25470* *
25471* conversion of quark numbering scheme *
25472* *
25473* input: BAMJET particle codes *
25474* 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) *
25475* 2 d 8 a-d -2 a-d *
25476* 3 s 9 a-s -3 a-s *
25477* 4 c 10 a-c -4 a-c *
25478* *
25479* output: PDG parton numbering *
25480* *
25481* This version dated 13.12.94 is written by S. Roesler. *
25482************************************************************************
25483
25484 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25485 SAVE
25486 PARAMETER ( LINP = 10 ,
25487 & LOUT = 6 ,
25488 & LDAT = 9 )
25489
25490 DIMENSION IHKKQ(-6:6),IHKKQQ(-3:3,-3:3)
25491 DATA IHKKQ/-6,-5,-4,-3,-1,-2,0,2,1,3,4,5,6/
25492 DATA IHKKQQ/-3303,-3103,-3203,0,0,0,0, -3103,-1103,-2103,0,0,0,0,
25493 &-3203,-2103,-2203,0,0,0,0, 0,0,0,0,0,0,0, 0,0,0,0,2203,2103,3203,
25494 &0,0,0,0,2103,1103,3103, 0,0,0,0,3203,3103,3303/
25495
25496 IDA = ID1
25497 IDB = ID2
25498 IF (MODE.EQ.1) THEN
25499 IF (ID1.GT.6) IDA = -(ID1-6)
25500 IF (ID2.GT.6) IDB = -(ID2-6)
25501 ENDIF
25502 IF (ID2.EQ.0) THEN
25503 IDT_IB2PDG = IHKKQ(IDA)
25504 ELSE
25505 IDT_IB2PDG = IHKKQQ(IDA,IDB)
25506 ENDIF
25507
25508 RETURN
25509 END
25510
25511*$ CREATE IDT_IQUARK.FOR
25512*COPY IDT_IQUARK
25513*
25514*===ipdgqu=============================================================*
25515*
25516 INTEGER FUNCTION IDT_IQUARK(K,IDBAMJ)
25517
25518************************************************************************
25519* *
25520* quark contents according to PDG conventions *
25521* (random selection in case of quark mixing) *
25522* *
25523* input: IDBAMJ BAMJET particle code *
25524* K 1..3 quark number *
25525* *
25526* output: 1 d (anti --> neg.) *
25527* 2 u *
25528* 3 s *
25529* 4 c *
25530* *
25531* This version written by R. Engel. *
25532************************************************************************
25533
25534 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25535 SAVE
25536
25537 IQ = IDT_IBJQUA(K,IDBAMJ)
25538* quark-antiquark
25539 IF (IQ.GT.6) THEN
25540 IQ = 6-IQ
25541 ENDIF
25542* exchange of up and down
25543 IF (ABS(IQ).EQ.1) THEN
25544 IQ = SIGN(2,IQ)
25545 ELSEIF (ABS(IQ).EQ.2) THEN
25546 IQ = SIGN(1,IQ)
25547 ENDIF
25548 IDT_IQUARK = IQ
25549
25550 RETURN
25551 END
25552
25553*$ CREATE IDT_IBJQUA.FOR
25554*COPY IDT_IBJQUA
25555*
25556*===ibamq==============================================================*
25557*
25558 INTEGER FUNCTION IDT_IBJQUA(K,IDBAMJ)
25559
25560************************************************************************
25561* *
25562* quark contents according to BAMJET conventions *
25563* (random selection in case of quark mixing) *
25564* *
25565* input: IDBAMJ BAMJET particle code *
25566* K 1..3 quark number *
25567* *
25568* output: 1 u 7 u bar *
25569* 2 d 8 d bar *
25570* 3 s 9 s bar *
25571* 4 c 10 c bar *
25572* *
25573* This version written by R. Engel. *
25574************************************************************************
25575
25576 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25577 SAVE
25578
25579 DIMENSION ITAB(3,210)
25580 DATA ((ITAB(I,K),I=1,3),K=1,30) /
25581 & 1, 1, 2, 7, 7, 8, 0, 0, 0,
25582 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25583 & 0, 0, 0, 1, 2, 2, 7, 8, 8,
25584*sr 10.1.94
25585C & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25586 & 0, 0, 0, 0, 0, 0, 3, 8, 0,
25587*
25588 & 1, 8, 0, 2, 7, 0, 1, 9, 0,
25589*sr 10.1.94
25590C & 3, 7, 0, 0, 0, 0, 0, 0, 0,
25591 & 3, 7, 0, 3, 1, 2, 9, 7, 8,
25592*sr 10.1.94
25593C & 0, 0, 0, 2, 2, 3, 1, 1, 3,
25594 & 2, 9, 0, 2, 2, 3, 1, 1, 3,
25595*
25596 & 1, 2, 3, 201,202, 0, 2, 9, 0,
25597 & 3, 8, 0, 0, 0, 0, 0, 0, 0,
25598 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25599 DATA ((ITAB(I,K),I=1,3),K=31,60) /
25600 & 3, 9, 0, 1, 8, 0, 203,204, 0,
25601 & 2, 7, 0, 0, 0, 0, 1, 9, 0,
25602 & 2, 9, 0, 3, 7, 0, 3, 8, 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, 1, 1, 1, 1, 1, 2,
25608 & 1, 2, 2, 2, 2, 2, 0, 0, 0,
25609 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25610 DATA ((ITAB(I,K),I=1,3),K=61,90) /
25611 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25612 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25613 & 7, 7, 7, 7, 7, 8, 7, 8, 8,
25614 & 8, 8, 8, 0, 0, 0, 0, 0, 0,
25615 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25616 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25617 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25618 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25619 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25620 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25621 DATA ((ITAB(I,K),I=1,3),K=91,120) /
25622 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25623 & 0, 0, 0, 0, 0, 0, 3, 9, 0,
25624 & 1, 3, 3, 2, 3, 3, 7, 7, 9,
25625 & 7, 8, 9, 8, 8, 9, 7, 9, 9,
25626 & 8, 9, 9, 1, 1, 3, 1, 2, 3,
25627 & 2, 2, 3, 1, 3, 3, 2, 3, 3,
25628 & 3, 3, 3, 7, 7, 9, 7, 8, 9,
25629 & 8, 8, 9, 7, 9, 9, 8, 9, 9,
25630 & 9, 9, 9, 4, 7, 0, 4, 8, 0,
25631 & 2, 10, 0, 1, 10, 0, 4, 9, 0 /
25632 DATA ((ITAB(I,K),I=1,3),K=121,150) /
25633 & 3, 10, 0, 4, 10, 0, 4, 7, 0,
25634 & 4, 8, 0, 2, 10, 0, 1, 10, 0,
25635 & 4, 9, 0, 3, 10, 0, 4, 10, 0,
25636 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25637 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25638 & 0, 0, 0, 1, 2, 4, 1, 3, 4,
25639 & 2, 3, 4, 1, 1, 4, 0, 0, 0,
25640 & 2, 2, 4, 0, 0, 0, 0, 0, 0,
25641 & 3, 3, 4, 1, 4, 4, 2, 4, 4,
25642 & 3, 4, 4, 7, 8, 10, 7, 9, 10 /
25643 DATA ((ITAB(I,K),I=1,3),K=151,180) /
25644 & 8, 9, 10, 7, 7, 10, 0, 0, 0,
25645 & 8, 8, 10, 0, 0, 0, 0, 0, 0,
25646 & 9, 9, 10, 7, 10, 10, 8, 10, 10,
25647 & 9, 10, 10, 1, 1, 4, 1, 2, 4,
25648 & 2, 2, 4, 1, 3, 4, 2, 3, 4,
25649 & 3, 3, 4, 1, 4, 4, 2, 4, 4,
25650 & 3, 4, 4, 4, 4, 4, 7, 7, 10,
25651 & 7, 8, 10, 8, 8, 10, 7, 9, 10,
25652 & 8, 9, 10, 9, 9, 10, 7, 10, 10,
25653 & 8, 10, 10, 9, 10, 10, 10, 10, 10 /
25654 DATA ((ITAB(I,K),I=1,3),K=181,210) /
25655 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25656 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25657 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25658 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25659 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25660 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25661 & 0, 0, 0, 0, 0, 0, 1, 7, 0,
25662 & 2, 8, 0, 1, 7, 0, 2, 8, 0,
25663 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25664 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25665 DATA IDOLD /0/
25666
25667 ONE = 1.0D0
25668 IF (ITAB(1,IDBAMJ).LE.200) THEN
25669 ID = ITAB(K,IDBAMJ)
25670 ELSE
25671 IF(IDOLD.NE.IDBAMJ) THEN
25672 IT = AINT((ITAB(2,IDBAMJ)-ITAB(1,IDBAMJ)+0.999999D0)*
25673 & DT_RNDM(ONE)+ITAB(1,IDBAMJ))
25674 ELSE
25675 IDOLD = 0
25676 ENDIF
25677 ID = ITAB(K,IT)
25678 ENDIF
25679 IDOLD = IDBAMJ
25680 IDT_IBJQUA = ID
25681
25682 RETURN
25683 END
25684
25685*$ CREATE IDT_ICIHAD.FOR
25686*COPY IDT_ICIHAD
25687*
25688*===icihad=============================================================*
25689*
25690 INTEGER FUNCTION IDT_ICIHAD(MCIND)
25691
25692************************************************************************
25693* Conversion of particle index PDG proposal --> BAMJET-index scheme *
25694* This is a completely new version dated 25.10.95. *
25695* Renamed to be not in conflict with the modified PHOJET-version *
25696************************************************************************
25697
25698 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25699 SAVE
25700
25701* hadron index conversion (BAMJET <--> PDG)
25702 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25703 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25704 & IAMCIN(210)
25705
25706 IDT_ICIHAD = 0
25707 KPDG = ABS(MCIND)
25708 IF ((KPDG.EQ.0).OR.(KPDG.GT.70000)) RETURN
25709 IF (MCIND.LT.0) THEN
25710 JSIGN = 1
25711 ELSE
25712 JSIGN = 2
25713 ENDIF
25714 IF (KPDG.GE.10000) THEN
25715 DO 1 I=1,19
25716 IDT_ICIHAD = IBAM5(JSIGN,I)
25717 IF (IPDG5(JSIGN,I).EQ.MCIND) GOTO 5
25718 IDT_ICIHAD = 0
25719 1 CONTINUE
25720 ELSEIF (KPDG.GE.1000) THEN
25721 DO 2 I=1,29
25722 IDT_ICIHAD = IBAM4(JSIGN,I)
25723 IF (IPDG4(JSIGN,I).EQ.MCIND) GOTO 5
25724 IDT_ICIHAD = 0
25725 2 CONTINUE
25726 ELSEIF (KPDG.GE.100) THEN
25727 DO 3 I=1,22
25728 IDT_ICIHAD = IBAM3(JSIGN,I)
25729 IF (IPDG3(JSIGN,I).EQ.MCIND) GOTO 5
25730 IDT_ICIHAD = 0
25731 3 CONTINUE
25732 ELSEIF (KPDG.GE.10) THEN
25733 DO 4 I=1,7
25734 IDT_ICIHAD = IBAM2(JSIGN,I)
25735 IF (IPDG2(JSIGN,I).EQ.MCIND) GOTO 5
25736 IDT_ICIHAD = 0
25737 4 CONTINUE
25738 ENDIF
25739 5 CONTINUE
25740
25741 RETURN
25742 END
25743
25744*$ CREATE IDT_IPDGHA.FOR
25745*COPY IDT_IPDGHA
25746*
25747*===ipdgha=============================================================*
25748*
25749 INTEGER FUNCTION IDT_IPDGHA(MCIND)
25750
25751************************************************************************
25752* Conversion of particle index BAMJET-index scheme --> PDG proposal *
25753* Adopted from the original by S. Roesler. This version dated 12.5.95 *
25754* Renamed to be not in conflict with the modified PHOJET-version *
25755************************************************************************
25756
25757 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25758 SAVE
25759
25760* hadron index conversion (BAMJET <--> PDG)
25761 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25762 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25763 & IAMCIN(210)
25764
25765 IDT_IPDGHA = IAMCIN(MCIND)
25766
25767 RETURN
25768 END
25769
25770*$ CREATE DT_FLAHAD.FOR
25771*COPY DT_FLAHAD
25772*
25773*===flahad=============================================================*
25774*
25775 SUBROUTINE DT_FLAHAD(ID,IF1,IF2,IF3)
25776
25777************************************************************************
25778* sampling of FLAvor composition for HADrons/photons *
25779* ID BAMJET-id of hadron *
25780* IF1,2,3 flavor content *
25781* (u,d,s: 1,2,3; au,ad,as: -1,-1,-3) *
25782* Note: - u,d numbering as in BAMJET *
25783* - ID .le. 30 !! *
25784* This version dated 12.03.96 is written by S. Roesler *
25785************************************************************************
25786
25787 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25788 SAVE
25789
25790* auxiliary common for reggeon exchange (DTUNUC 1.x)
25791 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
25792 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
25793 & IQTCHR(-6:6),MQUARK(3,39)
25794
25795 DIMENSION JSEL(3,6)
25796 DATA JSEL/ 1,2,3, 2,3,1, 3,1,2, 1,3,2, 2,1,3, 3,2,1/
25797
25798 ONE = 1.0D0
25799 IF (ID.EQ.7) THEN
25800* photon (charge dependent flavour sampling)
25801 K = INT(DT_RNDM(ONE)*6.D0+1.D0)
25802 IF (K.LE.4) THEN
25803 IF1 = 2
25804 IF2 = -2
25805 ELSE IF(K.EQ.5) THEN
25806 IF1 = 1
25807 IF2 = -1
25808 ELSE
25809 IF1 = 3
25810 IF2 = -3
25811 ENDIF
25812 IF(DT_RNDM(ONE).LT.0.5D0) THEN
25813 K = IF1
25814 IF1 = IF2
25815 IF2 = K
25816 ENDIF
25817 IF3 = 0
25818 ELSE
25819* hadron
25820 IX = INT(1.0D0+5.99999D0*DT_RNDM(ONE))
25821 IF1 = MQUARK(JSEL(1,IX),ID)
25822 IF2 = MQUARK(JSEL(2,IX),ID)
25823 IF3 = MQUARK(JSEL(3,IX),ID)
25824 IF ((IF1.EQ.0).AND.(IF3.NE.0)) THEN
25825 IF1 = IF3
25826 IF3 = 0
25827 ELSEIF ((IF2.EQ.0).AND.(IF3.NE.0)) THEN
25828 IF2 = IF3
25829 IF3 = 0
25830 ENDIF
25831 ENDIF
25832
25833 RETURN
25834 END
25835
25836*$ CREATE IDT_MCHAD.FOR
25837*COPY IDT_MCHAD
25838*
25839*===mchad==============================================================*
25840*
25841 INTEGER FUNCTION IDT_MCHAD(ITDTU)
25842
25843************************************************************************
25844* Conversion of particle index BAMJET-index scheme --> HADRIN index s. *
25845* Adopted from the original by S. Roesler. This version dated 6.5.95 *
25846* *
25847* Last change 28.12.2006 by S. Roesler. *
25848************************************************************************
25849
25850 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25851 SAVE
25852
25853 DIMENSION ITRANS(210)
25854 DATA ITRANS / 1, 2, -1, -1, -1, -1, -1, 8, 9, -1, -1, 24, 13, 14,
25855 &15, 16, 8, 9, 25, 8, 1, 8, 23, 24, 25, -1, -1, -1, -1, -1, 23, 13,
25856 &23, 14, 23, 15, 24, 16, 25, 15, 24, 16, 25, 15, 24, 16, 25, 1, 8,
25857 &8, 8, 1, 1, 1, 8, 8, 1, 1, 8, 8, 1, 8, 1, 8, 1, 8, 2, 2, 9, 9, 2,
25858 &2, 9, 9, 2, 9, 1, 13, 23, 14, 1, 1, 8, 8, 1, 1, 23, 14, 1, 8, 1,
25859 &8, 1, 8, 23, 23, 8, 8, 2, 9, 9, 9, 9, 1, 8, 8, 8, 8, 8, 2, 9, 9,
25860 &9, 9, 9, 85*- 1,7*-1,1,8,-1/
25861
25862 IF ( ITDTU .GT. 0 ) THEN
25863 IDT_MCHAD = ITRANS(ITDTU)
25864 ELSE
25865 IDT_MCHAD = -1
25866 END IF
25867
25868 RETURN
25869 END
25870
25871************************************************************************
25872* *
25873* 3) Energy-momentum and quantum number conservation check routines *
25874* *
25875************************************************************************
25876*$ CREATE DT_EMC1.FOR
25877*COPY DT_EMC1
25878*
25879*===emc1===============================================================*
25880*
25881 SUBROUTINE DT_EMC1(PP1,PP2,PT1,PT2,MODE,IPOS,IREJ)
25882
25883************************************************************************
25884* This version dated 15.12.94 is written by S. Roesler *
25885************************************************************************
25886
25887 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25888 SAVE
25889 PARAMETER ( LINP = 10 ,
25890 & LOUT = 6 ,
25891 & LDAT = 9 )
25892 PARAMETER (TINY10=1.0D-10)
25893
25894 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
25895
25896 IREJ = 0
25897
25898 IF ((MODE.EQ.0).OR.(ABS(MODE).GT.3))
25899 & WRITE(LOUT,'(1X,A,I6)')'EMC1: not supported MODE ',MODE
25900
25901 IF ((MODE.GT.0).AND.(MODE.LT.3)) THEN
25902 IF (MODE.EQ.1) THEN
25903 CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),1,IDUM,IDUM)
25904 ELSEIF (MODE.EQ.2) THEN
25905 CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),2,IDUM,IDUM)
25906 ENDIF
25907 CALL DT_EVTEMC(PP2(1),PP2(2),PP2(3),PP2(4),2,IDUM,IDUM)
25908 CALL DT_EVTEMC(PT1(1),PT1(2),PT1(3),PT1(4),2,IDUM,IDUM)
25909 CALL DT_EVTEMC(PT2(1),PT2(2),PT2(3),PT2(4),2,IDUM,IDUM)
25910 ELSEIF (MODE.LT.0) THEN
25911 IF (MODE.EQ.-1) THEN
25912 CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),1,IDUM,IDUM)
25913 ELSEIF (MODE.EQ.-2) THEN
25914 CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),2,IDUM,IDUM)
25915 ENDIF
25916 CALL DT_EVTEMC(-PP2(1),-PP2(2),-PP2(3),-PP2(4),2,IDUM,IDUM)
25917 CALL DT_EVTEMC(-PT1(1),-PT1(2),-PT1(3),-PT1(4),2,IDUM,IDUM)
25918 CALL DT_EVTEMC(-PT2(1),-PT2(2),-PT2(3),-PT2(4),2,IDUM,IDUM)
25919 ENDIF
25920
25921 IF (ABS(MODE).EQ.3) THEN
25922 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,IPOS,IREJ1)
25923 IF (IREJ1.NE.0) GOTO 9999
25924 ENDIF
25925 RETURN
25926
25927 9999 CONTINUE
25928 IREJ = 1
25929 RETURN
25930 END
25931
25932*$ CREATE DT_EMC2.FOR
25933*COPY DT_EMC2
25934*
25935*===emc2===============================================================*
25936*
25937 SUBROUTINE DT_EMC2(IP1,IP2,IP3,IP4,IP5,MP,IN1,IN2,IN3,IN4,IN5,MN,
25938 & MODE,IPOS,IREJ)
25939
25940************************************************************************
25941* MODE = 1 energy-momentum cons. check *
25942* = 2 flavor-cons. check *
25943* = 3 energy-momentum & flavor cons. check *
25944* = 4 energy-momentum & charge cons. check *
25945* = 5 energy-momentum & flavor & charge cons. check *
25946* This version dated 16.01.95 is written by S. Roesler *
25947************************************************************************
25948
25949 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25950 SAVE
25951 PARAMETER ( LINP = 10 ,
25952 & LOUT = 6 ,
25953 & LDAT = 9 )
25954 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
25955
25956* event history
25957 PARAMETER (NMXHKK=200000)
25958 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25959 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25960 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25961* extended event history
25962 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
25963 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
25964 & IHIST(2,NMXHKK)
25965
25966 IREJ = 0
25967 IREJ1 = 0
25968 IREJ2 = 0
25969 IREJ3 = 0
25970
25971 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25972 & CALL DT_EVTEMC(ZERO,ZERO,ZERO,ZERO,1,IDUM,IDUM)
25973 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25974 & CALL DT_EVTFLC(0,IDUM,1,IDUM,IDUM)
25975 IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,1,IDUM,IDUM)
25976 DO 1 I=1,NHKK
25977 IF ((ISTHKK(I).EQ.IP1).OR.(ISTHKK(I).EQ.IP2).OR.
25978 & (ISTHKK(I).EQ.IP3).OR.(ISTHKK(I).EQ.IP4).OR.
25979 & (ISTHKK(I).EQ.IP5)) THEN
25980 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25981 & .OR.(MODE.EQ.5))
25982 & CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
25983 & 2,IDUM,IDUM)
25984 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25985 & CALL DT_EVTFLC(IDHKK(I),MP,2,IDUM,IDUM)
25986 IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25987 & CALL DT_EVTCHG(IDHKK(I),2,IDUM,IDUM)
25988 ENDIF
25989 IF ((ISTHKK(I).EQ.IN1).OR.(ISTHKK(I).EQ.IN2).OR.
25990 & (ISTHKK(I).EQ.IN3).OR.(ISTHKK(I).EQ.IN4).OR.
25991 & (ISTHKK(I).EQ.IN5)) THEN
25992 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25993 & .OR.(MODE.EQ.5))
25994 & CALL DT_EVTEMC(-PHKK(1,I),-PHKK(2,I),-PHKK(3,I),-PHKK(4,I),
25995 & 2,IDUM,IDUM)
25996 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25997 & CALL DT_EVTFLC(IDHKK(I),MN,-2,IDUM,IDUM)
25998 IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25999 & CALL DT_EVTCHG(IDHKK(I),-2,IDUM,IDUM)
26000 ENDIF
26001 1 CONTINUE
26002 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
26003 & CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,IPOS,IREJ1)
26004 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
26005 & CALL DT_EVTFLC(0,IDUM,3,IPOS,IREJ2)
26006 IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,3,IPOS,IREJ3)
26007 IF ((IREJ1.NE.0).OR.(IREJ2.NE.0).OR.(IREJ3.NE.0)) GOTO 9999
26008
26009 RETURN
26010
26011 9999 CONTINUE
26012 IREJ = 1
26013 RETURN
26014 END
26015
26016*$ CREATE DT_EVTEMC.FOR
26017*COPY DT_EVTEMC
26018*
26019*===evtemc=============================================================*
26020*
26021 SUBROUTINE DT_EVTEMC(PXIO,PYIO,PZIO,EIO,IMODE,IPOS,IREJ)
26022
26023************************************************************************
26024* This version dated 13.12.94 is written by S. Roesler *
26025************************************************************************
26026
26027 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26028 SAVE
26029 PARAMETER ( LINP = 10 ,
26030 & LOUT = 6 ,
26031 & LDAT = 9 )
26032 PARAMETER (TINY1=1.0D-1,TINY2=1.0D-2,TINY4=1.0D-4,TINY10=1.0D-10,
26033 & ZERO=0.0D0)
26034
26035* event history
26036 PARAMETER (NMXHKK=200000)
26037 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26038 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26039 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26040* flags for input different options
26041 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
26042 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
26043 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
26044
26045 IREJ = 0
26046
26047 MODE = IMODE
26048 CHKLEV = TINY10
26049 IF (MODE.EQ.4) THEN
26050 CHKLEV = TINY2
26051 MODE = 3
26052 ELSEIF (MODE.EQ.5) THEN
26053 CHKLEV = TINY1
26054 MODE = 3
26055 ELSEIF (MODE.EQ.-1) THEN
26056 CHKLEV = EIO
26057 MODE = 3
26058 ENDIF
26059
26060 IF (ABS(MODE).EQ.3) THEN
26061 PXDEV = PX
26062 PYDEV = PY
26063 PZDEV = PZ
26064 EDEV = E
26065 IF ((IFRAG(1).EQ.2).AND.(CHKLEV.LT.TINY4)) CHKLEV = TINY4
26066 IF ((ABS(PXDEV).GT.CHKLEV).OR.(ABS(PYDEV).GT.CHKLEV).OR.
26067 & (ABS(PZDEV).GT.CHKLEV).OR.(ABS(EDEV).GT.CHKLEV)) THEN
26068 IF (IOULEV(2).GT.0) WRITE(LOUT,'(1X,A,I4,A,I8,A,/,4G10.3)')
26069 & 'EVTEMC: energy-momentum cons. failure at pos. ',IPOS,
26070 & ' event ',NEVHKK,
26071 & ' ! ',PXDEV,PYDEV,PZDEV,EDEV
26072 PX = 0.0D0
26073 PY = 0.0D0
26074 PZ = 0.0D0
26075 E = 0.0D0
26076 GOTO 9999
26077 ENDIF
26078 PX = 0.0D0
26079 PY = 0.0D0
26080 PZ = 0.0D0
26081 E = 0.0D0
26082 RETURN
26083 ENDIF
26084
26085 IF (MODE.EQ.1) THEN
26086 PX = 0.0D0
26087 PY = 0.0D0
26088 PZ = 0.0D0
26089 E = 0.0D0
26090 ENDIF
26091
26092 PX = PX+PXIO
26093 PY = PY+PYIO
26094 PZ = PZ+PZIO
26095 E = E+EIO
26096
26097 RETURN
26098
26099 9999 CONTINUE
26100 IREJ = 1
26101 RETURN
26102 END
26103
26104*$ CREATE DT_EVTFLC.FOR
26105*COPY DT_EVTFLC
26106*
26107*===evtflc=============================================================*
26108*
26109 SUBROUTINE DT_EVTFLC(ID,ID1,MODE,IPOS,IREJ)
26110
26111************************************************************************
26112* Flavor conservation check. *
26113* ID identity of particle *
26114* ID1 = 1 ID for q,aq,qq,aqaq in PDG-numbering scheme *
26115* = 2 ID for particle/resonance in BAMJET numbering scheme *
26116* = 3 ID for particle/resonance in PDG numbering scheme *
26117* MODE = 1 initialization and add ID *
26118* =-1 initialization and subtract ID *
26119* = 2 add ID *
26120* =-2 subtract ID *
26121* = 3 check flavor cons. *
26122* IPOS flag to give position of call of EVTFLC to output *
26123* unit in case of violation *
26124* This version dated 10.01.95 is written by S. Roesler *
26125************************************************************************
26126
26127 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26128 SAVE
26129 PARAMETER ( LINP = 10 ,
26130 & LOUT = 6 ,
26131 & LDAT = 9 )
26132 PARAMETER (TINY10=1.0D-10)
26133
26134 IREJ = 0
26135
26136 IF (MODE.EQ.3) THEN
26137 IF (IFL.NE.0) THEN
26138 WRITE(LOUT,'(1X,A,I3,A,I3)')
26139 & 'EVTFLC: flavor-conservation failure at pos. ',IPOS,
26140 & ' ! IFL = ',IFL
26141 IFL = 0
26142 GOTO 9999
26143 ENDIF
26144 IFL = 0
26145 RETURN
26146 ENDIF
26147
26148 IF (MODE.EQ.1) IFL = 0
26149 IF (ID.EQ.0) RETURN
26150
26151 IF (ID1.EQ.1) THEN
26152 IDD = ABS(ID)
26153 NQ = 1
26154 IF ((IDD.GE.100).AND.(IDD.LT.1000)) NQ = 2
26155 IF (IDD.GE.1000) NQ = 3
26156 DO 1 I=1,NQ
26157 IFBAM = IDT_IPDG2B(ID,I,2)
26158 IF (ABS(IFBAM).EQ.1) THEN
26159 IFBAM = SIGN(2,IFBAM)
26160 ELSEIF (ABS(IFBAM).EQ.2) THEN
26161 IFBAM = SIGN(1,IFBAM)
26162 ENDIF
26163 IF (MODE.GT.0) THEN
26164 IFL = IFL+IFBAM
26165 ELSE
26166 IFL = IFL-IFBAM
26167 ENDIF
26168 1 CONTINUE
26169 RETURN
26170 ENDIF
26171
26172 IDD = ID
26173 IF (ID1.EQ.3) IDD = IDT_ICIHAD(ID)
26174 IF ((ID1.EQ.2).OR.(ID1.EQ.3)) THEN
26175 DO 2 I=1,3
26176 IF (MODE.GT.0) THEN
26177 IFL = IFL+IDT_IQUARK(I,IDD)
26178 ELSE
26179 IFL = IFL-IDT_IQUARK(I,IDD)
26180 ENDIF
26181 2 CONTINUE
26182 ENDIF
26183 RETURN
26184
26185 9999 CONTINUE
26186 IREJ = 1
26187 RETURN
26188 END
26189
26190*$ CREATE DT_EVTCHG.FOR
26191*COPY DT_EVTCHG
26192*
26193*===evtchg=============================================================*
26194*
26195 SUBROUTINE DT_EVTCHG(ID,MODE,IPOS,IREJ)
26196
26197************************************************************************
26198* Charge conservation check. *
26199* ID identity of particle (PDG-numbering scheme) *
26200* MODE = 1 initialization *
26201* =-2 subtract ID-charge *
26202* = 2 add ID-charge *
26203* = 3 check charge cons. *
26204* IPOS flag to give position of call of EVTCHG to output *
26205* unit in case of violation *
26206* This version dated 10.01.95 is written by S. Roesler *
26207* Last change: s.r. 21.01.01 *
26208************************************************************************
26209
26210 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26211 SAVE
26212 PARAMETER ( LINP = 10 ,
26213 & LOUT = 6 ,
26214 & LDAT = 9 )
26215
26216* event history
26217 PARAMETER (NMXHKK=200000)
26218 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26219 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26220 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26221* particle properties (BAMJET index convention)
26222 CHARACTER*8 ANAME
26223 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26224 & IICH(210),IIBAR(210),K1(210),K2(210)
26225
26226 IREJ = 0
26227
26228 IF (MODE.EQ.1) THEN
26229 ICH = 0
26230 IBAR = 0
26231 RETURN
26232 ENDIF
26233
26234 IF (MODE.EQ.3) THEN
26235 IF ((ICH.NE.0).OR.(IBAR.NE.0)) THEN
26236 WRITE(LOUT,'(1X,A,I3,A,2I3,A,I8)')
26237 & 'EVTCHG: charge/baryo.-cons. failure at pos. ',IPOS,
26238 & '! ICH/IBAR= ',ICH,IBAR,' event ',NEVHKK
26239 ICH = 0
26240 IBAR = 0
26241 GOTO 9999
26242 ENDIF
26243 ICH = 0
26244 IBAR = 0
26245 RETURN
26246 ENDIF
26247
26248 IF (ID.EQ.0) RETURN
26249
26250 IDD = IDT_ICIHAD(ID)
26251* modification 21.1.01: use intrinsic phojet-functions to determine charge
26252* and baryon number
26253C IF (IDD.GT.0) THEN
26254C IF (MODE.EQ.2) THEN
26255C ICH = ICH+IICH(IDD)
26256C IBAR = IBAR+IIBAR(IDD)
26257C ELSEIF (MODE.EQ.-2) THEN
26258C ICH = ICH-IICH(IDD)
26259C IBAR = IBAR-IIBAR(IDD)
26260C ENDIF
26261C ELSE
26262C WRITE(LOUT,'(1X,A,3I6)') 'EVTCHG: (IDD = 0 !), IDD,ID=',IDD,ID
26263C CALL DT_EVTOUT(4)
26264C STOP
26265C ENDIF
26266 IF (MODE.EQ.2) THEN
26267 ICH = ICH+IPHO_CHR3(ID,1)/3
26268 IBAR = IBAR+IPHO_BAR3(ID,1)/3
26269 ELSEIF (MODE.EQ.-2) THEN
26270 ICH = ICH-IPHO_CHR3(ID,1)/3
26271 IBAR = IBAR-IPHO_BAR3(ID,1)/3
26272 ENDIF
26273
26274 RETURN
26275
26276 9999 CONTINUE
26277 IREJ = 1
26278 RETURN
26279 END
26280
26281************************************************************************
26282* *
26283* 4) Transformations *
26284* *
26285************************************************************************
26286*$ CREATE DT_LTINI.FOR
26287*COPY DT_LTINI
26288*
26289*===ltini==============================================================*
26290*
26291 SUBROUTINE DT_LTINI(IDPR,IDTA,EPN0,PPN0,ECM0,MODE)
26292
26293************************************************************************
26294* Initializations of Lorentz-transformations, calculation of Lorentz- *
26295* parameters. *
26296* This version dated 13.11.95 is written by S. Roesler. *
26297************************************************************************
26298
26299 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26300 SAVE
26301 PARAMETER ( LINP = 10 ,
26302 & LOUT = 6 ,
26303 & LDAT = 9 )
26304 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,
26305 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
26306
26307* Lorentz-parameters of the current interaction
26308 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26309 & UMO,PPCM,EPROJ,PPROJ
26310* properties of photon/lepton projectiles
26311 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
26312* particle properties (BAMJET index convention)
26313 CHARACTER*8 ANAME
26314 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26315 & IICH(210),IIBAR(210),K1(210),K2(210)
26316* nucleon-nucleon event-generator
26317 CHARACTER*8 CMODEL
26318 LOGICAL LPHOIN
26319 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
26320
26321 Q2 = VIRT
26322 IDP = IDPR
26323 IF (MCGENE.NE.3) THEN
26324* lepton-projectiles and PHOJET: initialize real photon instead
26325 IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26326 & (IDPR.EQ.10).OR.(IDPR.EQ.11).OR.
26327 & (IDPR.EQ. 5).OR.(IDPR.EQ. 6)) THEN
26328 IDP = 7
26329 Q2 = ZERO
26330 ENDIF
26331 ENDIF
26332 IDT = IDTA
26333 EPN = EPN0
26334 PPN = PPN0
26335 ECM = ECM0
26336 AMP = AAM(IDP)-SQRT(ABS(Q2))
26337 AMT = AAM(IDT)
26338 AMP2 = SIGN(AMP**2,AMP)
26339 AMT2 = AMT**2
26340 IF (ECM0.GT.ZERO) THEN
26341 EPN = (ECM**2-AMP2-AMT2)/(TWO*AMT)
26342 IF (AMP2.GT.ZERO) THEN
26343 PPN = SQRT((EPN+AMP)*(EPN-AMP))
26344 ELSE
26345 PPN = SQRT(EPN**2-AMP2)
26346 ENDIF
26347 ELSE
26348 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26349 IF (IDP.EQ.7) EPN = ABS(EPN)
26350 IF (EPN.LT.ZERO) EPN = ABS(EPN)+AMP
26351 IF (AMP2.GT.ZERO) THEN
26352 PPN = SQRT((EPN+AMP)*(EPN-AMP))
26353 ELSE
26354 PPN = SQRT(EPN**2-AMP2)
26355 ENDIF
26356 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26357 IF (AMP2.GT.ZERO) THEN
26358 EPN = PPN*SQRT(ONE+(AMP/PPN)**2)
26359 ELSE
26360 EPN = SQRT(PPN**2+AMP2)
26361 ENDIF
26362 ENDIF
26363 ECM = SQRT(AMP2+AMT2+TWO*AMT*EPN)
26364 ENDIF
26365 UMO = ECM
26366 EPROJ = EPN
26367 PPROJ = PPN
26368 IF (AMP2.GT.ZERO) THEN
26369 ETARG = (ECM**2-AMP2-AMT2)/(TWO*AMP)
26370 PTARG = -SQRT((ETARG+AMT)*(ETARG-AMT))
26371 ELSE
26372 ETARG = TINY10
26373 PTARG = TINY10
26374 ENDIF
26375* photon-projectiles (get momentum in cm-frame for virtuality Q^2)
26376 IF (IDP.EQ.7) THEN
26377 PGAMM(1) = ZERO
26378 PGAMM(2) = ZERO
26379 AMGAM = AMP
26380 AMGAM2 = AMP2
26381 IF (ECM0.GT.ZERO) THEN
26382 S = ECM0**2
26383 ELSE
26384 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26385 S = AMGAM2+AMT2+TWO*AMT*ABS(EPN0)
26386 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26387 S = AMGAM2+AMT2+TWO*AMT*SQRT(PPN0**2+AMGAM2)
26388 ENDIF
26389 ENDIF
26390 PGAMM(3) = SQRT( (S**2-TWO*AMGAM2*S-TWO*AMT2*S-TWO*AMGAM2*AMT2
26391 & +AMGAM2**2+AMT2**2)/(4.0D0*S) )
26392 PGAMM(4) = SQRT(AMGAM2+PGAMM(3)**2)
26393 IF (MODE.EQ.1) THEN
26394 PNUCL(1) = ZERO
26395 PNUCL(2) = ZERO
26396 PNUCL(3) = -PGAMM(3)
26397 PNUCL(4) = SQRT(S)-PGAMM(4)
26398 ENDIF
26399 ENDIF
26400 IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26401 & (IDPR.EQ.10).OR.(IDPR.EQ.11)) THEN
26402 PLEPT0(1) = ZERO
26403 PLEPT0(2) = ZERO
26404* neglect lepton masses
26405C AMLPT2 = AAM(IDPR)**2
26406 AMLPT2 = ZERO
26407*
26408 IF (ECM0.GT.ZERO) THEN
26409 S = ECM0**2
26410 ELSE
26411 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26412 S = AMLPT2+AMT2+TWO*AMT*ABS(EPN0)
26413 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26414 S = AMLPT2+AMT2+TWO*AMT*SQRT(PPN0**2+AMLPT2)
26415 ENDIF
26416 ENDIF
26417 PLEPT0(3) = SQRT( (S**2-TWO*AMLPT2*S-TWO*AMT2*S-TWO*AMLPT2*AMT2
26418 & +AMLPT2**2+AMT2**2)/(4.0D0*S) )
26419 PLEPT0(4) = SQRT(AMLPT2+PLEPT0(3)**2)
26420 PNUCL(1) = ZERO
26421 PNUCL(2) = ZERO
26422 PNUCL(3) = -PLEPT0(3)
26423 PNUCL(4) = SQRT(S)-PLEPT0(4)
26424 ENDIF
26425* Lorentz-parameter for transformation Lab. - projectile rest system
26426 IF ((IDP.EQ.7).OR.(AMP.LT.TINY10)) THEN
26427 GALAB = TINY10
26428 BGLAB = TINY10
26429 BLAB = TINY10
26430 ELSE
26431 GALAB = EPROJ/AMP
26432 BGLAB = PPROJ/AMP
26433 BLAB = BGLAB/GALAB
26434 ENDIF
26435* Lorentz-parameter for transf. proj. rest sys. - nucl.-nucl. cms.
26436 IF (IDP.EQ.7) THEN
26437 GACMS(1) = TINY10
26438 BGCMS(1) = TINY10
26439 ELSE
26440 GACMS(1) = (ETARG+AMP)/UMO
26441 BGCMS(1) = PTARG/UMO
26442 ENDIF
26443* Lorentz-parameter for transformation Lab. - nucl.-nucl. cms.
26444 GACMS(2) = (EPROJ+AMT)/UMO
26445 BGCMS(2) = PPROJ/UMO
26446 PPCM = GACMS(2)*PPROJ-BGCMS(2)*EPROJ
26447
26448 EPN0 = EPN
26449 PPN0 = PPN
26450 ECM0 = ECM
26451
26452 RETURN
26453 END
26454
26455*$ CREATE DT_LTRANS.FOR
26456*COPY DT_LTRANS
26457*
26458*===ltrans=============================================================*
26459*
26460 SUBROUTINE DT_LTRANS(PXI,PYI,PZI,PEI,PXO,PYO,PZO,PEO,ID,MODE)
26461
26462************************************************************************
26463* Lorentz-transformations. *
26464* MODE = 1(-1) projectile rest syst. --> Lab (back) *
26465* = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) *
26466* = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) *
26467* This version dated 01.11.95 is written by S. Roesler. *
26468************************************************************************
26469
26470 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26471 SAVE
26472 PARAMETER ( LINP = 10 ,
26473 & LOUT = 6 ,
26474 & LDAT = 9 )
26475 PARAMETER (TINY3=1.0D-3,ZERO=0.0D0,TWO=2.0D0)
26476
26477 PARAMETER (SQTINF=1.0D+15)
26478
26479* particle properties (BAMJET index convention)
26480 CHARACTER*8 ANAME
26481 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26482 & IICH(210),IIBAR(210),K1(210),K2(210)
26483
26484 PXO = PXI
26485 PYO = PYI
26486 CALL DT_LTNUC(PZI,PEI,PZO,PEO,MODE)
26487
26488* check particle mass for consistency (numerical rounding errors)
26489 PO = SQRT(PXO*PXO+PYO*PYO+PZO*PZO)
26490 AMO2 = (PEO-PO)*(PEO+PO)
26491 AMORQ2 = AAM(ID)**2
26492 AMDIF2 = ABS(AMO2-AMORQ2)
26493 IF ((AMDIF2.GT.TINY3).AND.(PEO.LT.SQTINF).AND.(PO.GT.ZERO)) THEN
26494 DELTA = (AMORQ2-AMO2)/(TWO*(PEO+PO))
26495 PEO = PEO+DELTA
26496 PO1 = PO -DELTA
26497 PXO = PXO*PO1/PO
26498 PYO = PYO*PO1/PO
26499 PZO = PZO*PO1/PO
26500C WRITE(6,*) 'LTRANS corrected', AMDIF2,PZI,PEI,PZO,PEO,MODE,ID
26501 ENDIF
26502
26503 RETURN
26504 END
26505
26506*$ CREATE DT_LTNUC.FOR
26507*COPY DT_LTNUC
26508*
26509*===ltnuc==============================================================*
26510*
26511 SUBROUTINE DT_LTNUC(PIN,EIN,POUT,EOUT,MODE)
26512
26513************************************************************************
26514* Lorentz-transformations. *
26515* PIN longitudnal momentum (input) *
26516* EIN energy (input) *
26517* POUT transformed long. momentum (output) *
26518* EOUT transformed energy (output) *
26519* MODE = 1(-1) projectile rest syst. --> Lab (back) *
26520* = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) *
26521* = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) *
26522* This version dated 01.11.95 is written by S. Roesler. *
26523************************************************************************
26524
26525 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26526 SAVE
26527 PARAMETER ( LINP = 10 ,
26528 & LOUT = 6 ,
26529 & LDAT = 9 )
26530 PARAMETER (ZERO=0.0D0)
26531
26532* Lorentz-parameters of the current interaction
26533 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26534 & UMO,PPCM,EPROJ,PPROJ
26535
26536 BDUM1 = ZERO
26537 BDUM2 = ZERO
26538 PDUM1 = ZERO
26539 PDUM2 = ZERO
26540 IF (ABS(MODE).EQ.1) THEN
26541 BG = -SIGN(BGLAB,DBLE(MODE))
26542 CALL DT_DALTRA(GALAB,BDUM1,BDUM2,-BG,PDUM1,PDUM2,PIN,EIN,
26543 & DUM1,DUM2,DUM3,POUT,EOUT)
26544 ELSEIF (ABS(MODE).EQ.2) THEN
26545 BG = SIGN(BGCMS(1),DBLE(MODE))
26546 CALL DT_DALTRA(GACMS(1),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26547 & DUM1,DUM2,DUM3,POUT,EOUT)
26548 ELSEIF (ABS(MODE).EQ.3) THEN
26549 BG = -SIGN(BGCMS(2),DBLE(MODE))
26550 CALL DT_DALTRA(GACMS(2),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26551 & DUM1,DUM2,DUM3,POUT,EOUT)
26552 ELSE
26553 WRITE(LOUT,1000) MODE
26554 1000 FORMAT(1X,'LTNUC: not supported mode (MODE = ',I3,')')
26555 EOUT = EIN
26556 POUT = PIN
26557 ENDIF
26558
26559 RETURN
26560 END
26561
26562*$ CREATE DT_DALTRA.FOR
26563*COPY DT_DALTRA
26564*
26565*===daltra=============================================================*
26566*
26567 SUBROUTINE DT_DALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
26568
26569************************************************************************
26570* Arbitrary Lorentz-transformation. *
26571* Adopted from the original by S. Roesler. This version dated 15.01.95 *
26572************************************************************************
26573
26574 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26575 SAVE
26576 PARAMETER (ONE=1.0D0)
26577
26578 EP = PCX*BGX+PCY*BGY+PCZ*BGZ
26579 PE = EP/(GA+ONE)+EC
26580 PX = PCX+BGX*PE
26581 PY = PCY+BGY*PE
26582 PZ = PCZ+BGZ*PE
26583 P = SQRT(PX*PX+PY*PY+PZ*PZ)
26584 E = GA*EC+EP
26585
26586 RETURN
26587 END
26588
26589*$ CREATE DT_DTRAFO.FOR
26590*COPY DT_DTRAFO
26591*
26592*====dtrafo============================================================*
26593*
26594 SUBROUTINE DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
26595 & PL,CXL,CYL,CZL,EL)
26596
26597C LORENTZ TRANSFORMATION INTO THE LAB - SYSTEM
26598
26599 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26600 SAVE
26601
26602 IF (ABS(COD).GT.1.0D0) COD = SIGN(1.0D0,COD)
26603 SID = SQRT(1.D0-COD*COD)
26604 PLX = P*SID*COF
26605 PLY = P*SID*SIF
26606 PCMZ = P*COD
26607 PLZ = GAM*PCMZ+BGAM*ECM
26608 PL = SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
26609 EL = GAM*ECM+BGAM*PCMZ
26610C ROTATION INTO THE ORIGINAL DIRECTION
26611 COZ = PLZ/PL
26612 SIZ = SQRT(1.D0-COZ**2)
26613 CALL DT_STTRAN(CX,CY,CZ,COZ,SIZ,SIF,COF,CXL,CYL,CZL)
26614
26615 RETURN
26616 END
26617
26618*$ CREATE DT_STTRAN.FOR
26619*COPY DT_STTRAN
26620*
26621*====sttran============================================================*
26622*
26623 SUBROUTINE DT_STTRAN(XO,YO,ZO,CDE,SDE,SFE,CFE,X,Y,Z)
26624
26625 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26626 SAVE
26627 DATA ANGLSQ/1.D-30/
26628************************************************************************
26629* VERSION BY J. RANFT *
26630* LEIPZIG *
26631* *
26632* THIS IS A SUBROUTINE OF FLUKA TO GIVE NEW DIRECTION COSINES *
26633* *
26634* INPUT VARIABLES: *
26635* XO,YO,ZO = ORIGINAL DIRECTION COSINES *
26636* CDE,SDE = COSINE AND SINE OF THE POLAR (THETA) *
26637* ANGLE OF "SCATTERING" *
26638* SDE = SINE OF THE POLAR (THETA) ANGLE OF "SCATTERING" *
26639* SFE,CFE = SINE AND COSINE OF THE AZIMUTHAL (PHI) ANGLE *
26640* OF "SCATTERING" *
26641* *
26642* OUTPUT VARIABLES: *
26643* X,Y,Z = NEW DIRECTION COSINES *
26644* *
26645* ROTATION OF COORDINATE SYSTEM (SEE CERN 64-47 ) *
26646************************************************************************
26647*
26648*
26649* Changed by A. Ferrari
26650*
26651* IF (ABS(XO)-0.0001D0) 1,1,2
26652* 1 IF (ABS(YO)-0.0001D0) 3,3,2
26653* 3 CONTINUE
26654 A = XO**2 + YO**2
26655 IF ( A .LT. ANGLSQ ) THEN
26656 X=SDE*CFE
26657 Y=SDE*SFE
26658 Z=CDE*ZO
26659 ELSE
26660 XI=SDE*CFE
26661 YI=SDE*SFE
26662 ZI=CDE
26663 A=SQRT(A)
26664 X=-YO*XI/A-ZO*XO*YI/A+XO*ZI
26665 Y=XO*XI/A-ZO*YO*YI/A+YO*ZI
26666 Z=A*YI+ZO*ZI
26667 ENDIF
26668
26669 RETURN
26670 END
26671
26672*$ CREATE DT_MYTRAN.FOR
26673*COPY DT_MYTRAN
26674*
26675*===mytran=============================================================*
26676*
26677 SUBROUTINE DT_MYTRAN(IMODE,XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
26678
26679************************************************************************
26680* This subroutine rotates the coordinate frame *
26681* a) theta around y *
26682* b) phi around z if IMODE = 1 *
26683* *
26684* x' cos(ph) -sin(ph) 0 cos(th) 0 sin(th) x *
26685* y' = A B = sin(ph) cos(ph) 0 . 0 1 0 y *
26686* z' 0 0 1 -sin(th) 0 cos(th) z *
26687* *
26688* and vice versa if IMODE = 0. *
26689* This version dated 5.4.94 is based on the original version DTRAN *
26690* by J. Ranft and is written by S. Roesler. *
26691************************************************************************
26692
26693 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26694 SAVE
26695 PARAMETER ( LINP = 10 ,
26696 & LOUT = 6 ,
26697 & LDAT = 9 )
26698
26699 IF (IMODE.EQ.1) THEN
26700 X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
26701 Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
26702 Z=-SDE *XO +CDE *ZO
26703 ELSE
26704 X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
26705 Y= -SFE*XO+CFE*YO
26706 Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
26707 ENDIF
26708 RETURN
26709 END
26710
26711*$ CREATE DT_LT2LAO.FOR
26712*COPY DT_LT2LAO
26713*
26714*===lt2lab=============================================================*
26715*
26716 SUBROUTINE DT_LT2LAO
26717
26718************************************************************************
26719* Lorentz-transformation to lab-system. This subroutine scans DTEVT1 *
26720* for final state particles/fragments defined in nucleon-nucleon-cms *
26721* and transforms them back to the lab. *
26722* This version dated 16.11.95 is written by S. Roesler *
26723************************************************************************
26724
26725 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26726 SAVE
26727 PARAMETER ( LINP = 10 ,
26728 & LOUT = 6 ,
26729 & LDAT = 9 )
26730
26731* event history
26732 PARAMETER (NMXHKK=200000)
26733 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26734 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26735 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26736* extended event history
26737 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26738 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26739 & IHIST(2,NMXHKK)
26740
26741 NEND = NHKK
26742 NPOINT(5) = NHKK+1
26743 IF ( (NPOINT(4).EQ.0).OR.(NEND.LT.NPOINT(4)) ) RETURN
26744 DO 1 I=NPOINT(4),NEND
26745C DO 1 I=1,NEND
26746 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26747 & (ISTHKK(I).EQ.1001)) THEN
26748 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26749 NOB = NOBAM(I)
26750 CALL DT_EVTPUT(ISTHKK(I),IDHKK(I),I,0,PHKK(1,I),PHKK(2,I),
26751 & PZ,PE,IDRES(I),IDXRES(I),IDCH(I))
26752 IF ((ISTHKK(I).EQ.1000).OR.(ISTHKK(I).EQ.1001)) THEN
26753 ISTHKK(I) = 3*ISTHKK(I)
26754 NOBAM(NHKK) = NOB
26755 ELSE
26756 IF (ISTHKK(I).EQ.-1) NOBAM(NHKK) = NOB
26757 ISTHKK(I) = SIGN(3,ISTHKK(I))
26758 ENDIF
26759 JDAHKK(1,I) = NHKK
26760 ENDIF
26761 1 CONTINUE
26762
26763 RETURN
26764 END
26765
26766*$ CREATE DT_LT2LAB.FOR
26767*COPY DT_LT2LAB
26768*
26769*===lt2lab=============================================================*
26770*
26771 SUBROUTINE DT_LT2LAB
26772
26773************************************************************************
26774* Lorentz-transformation to lab-system. This subroutine scans DTEVT1 *
26775* for final state particles/fragments defined in nucleon-nucleon-cms *
26776* and transforms them to the lab. *
26777* This version dated 07.01.96 is written by S. Roesler *
26778************************************************************************
26779
26780 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26781 SAVE
26782 PARAMETER ( LINP = 10 ,
26783 & LOUT = 6 ,
26784 & LDAT = 9 )
26785
26786* event history
26787 PARAMETER (NMXHKK=200000)
26788 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26789 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26790 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26791* extended event history
26792 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26793 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26794 & IHIST(2,NMXHKK)
26795
26796 IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
26797 DO 1 I=NPOINT(4),NHKK
26798 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26799 & (ISTHKK(I).EQ.1001)) THEN
430525dd 26800
9aaba0d6 26801 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26802 PHKK(3,I) = PZ
26803 PHKK(4,I) = PE
26804 ENDIF
26805 1 CONTINUE
26806
26807 RETURN
26808 END
26809
26810************************************************************************
26811* *
26812* 5) Sampling from distributions *
26813* *
26814************************************************************************
26815*$ CREATE IDT_NPOISS.FOR
26816*COPY IDT_NPOISS
26817*
26818*===npoiss=============================================================*
26819*
26820 INTEGER FUNCTION IDT_NPOISS(AVN)
26821
26822************************************************************************
26823* Sample according to Poisson distribution with Poisson parameter AVN. *
26824* The original version written by J. Ranft. *
26825* This version dated 11.1.95 is written by S. Roesler. *
26826************************************************************************
26827
26828 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26829 SAVE
26830 PARAMETER ( LINP = 10 ,
26831 & LOUT = 6 ,
26832 & LDAT = 9 )
26833
26834 EXPAVN = EXP(-AVN)
26835 K = 1
26836 A = 1.0D0
26837
26838 10 CONTINUE
26839 A = DT_RNDM(A)*A
26840 IF (A.GE.EXPAVN) THEN
26841 K = K+1
26842 GOTO 10
26843 ENDIF
26844 IDT_NPOISS = K-1
26845
26846 RETURN
26847 END
26848
26849*$ CREATE DT_SAMPXB.FOR
26850*COPY DT_SAMPXB
26851*
26852*===sampxb=============================================================*
26853*
26854 DOUBLE PRECISION FUNCTION DT_SAMPXB(X1,X2,B)
26855
26856************************************************************************
26857* Sampling from f(x)=1./SQRT(X**2+B**2) between x1 and x2. *
26858* Processed by S. Roesler, 6.5.95 *
26859************************************************************************
26860
26861 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26862 SAVE
26863 PARAMETER (TWO=2.0D0)
26864
26865 A1 = LOG(X1+SQRT(X1**2+B**2))
26866 A2 = LOG(X2+SQRT(X2**2+B**2))
26867 AN = A2-A1
26868 A = AN*DT_RNDM(A1)+A1
26869 BB = EXP(A)
26870 DT_SAMPXB = (BB**2-B**2)/(TWO*BB)
26871
26872 RETURN
26873 END
26874
26875*$ CREATE DT_SAMPEX.FOR
26876*COPY DT_SAMPEX
26877*
26878*===sampex=============================================================*
26879*
26880 DOUBLE PRECISION FUNCTION DT_SAMPEX(X1,X2)
26881
26882************************************************************************
26883* Sampling from f(x)=1./x between x1 and x2. *
26884* Processed by S. Roesler, 6.5.95 *
26885************************************************************************
26886
26887 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26888 SAVE
26889 PARAMETER (ONE=1.0D0)
26890
26891 R = DT_RNDM(X1)
26892 AL1 = LOG(X1)
26893 AL2 = LOG(X2)
26894 DT_SAMPEX = EXP((ONE-R)*AL1+R*AL2)
26895
26896 RETURN
26897 END
26898
26899*$ CREATE DT_SAMSQX.FOR
26900*COPY DT_SAMSQX
26901*
26902*===samsqx=============================================================*
26903*
26904 DOUBLE PRECISION FUNCTION DT_SAMSQX(X1,X2)
26905
26906************************************************************************
26907* Sampling from f(x)=1./x^0.5 between x1 and x2. *
26908* Processed by S. Roesler, 6.5.95 *
26909************************************************************************
26910
26911 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26912 SAVE
26913 PARAMETER (ONE=1.0D0)
26914
26915 R = DT_RNDM(X1)
26916 DT_SAMSQX = (R*SQRT(X2)+(ONE-R)*SQRT(X1))**2
26917
26918 RETURN
26919 END
26920
26921*$ CREATE DT_SAMPLW.FOR
26922*COPY DT_SAMPLW
26923*
26924*===samplw=============================================================*
26925*
26926 DOUBLE PRECISION FUNCTION DT_SAMPLW(XMIN,XMAX,B)
26927
26928************************************************************************
26929* Sampling from f(x)=1/x^b between x_min and x_max. *
26930* S. Roesler, 18.4.98 *
26931************************************************************************
26932
26933 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26934 SAVE
26935 PARAMETER (ONE=1.0D0)
26936
26937 R = DT_RNDM(B)
26938 IF (B.EQ.ONE) THEN
26939 DT_SAMPLW = EXP(R*LOG(XMAX)+(ONE-R)*LOG(XMIN))
26940 ELSE
26941 ONEMB = ONE-B
26942 DT_SAMPLW = (R*XMAX**ONEMB+(ONE-R)*XMIN**ONEMB)**(ONE/ONEMB)
26943 ENDIF
26944
26945 RETURN
26946 END
26947
26948*$ CREATE DT_BETREJ.FOR
26949*COPY DT_BETREJ
26950*
26951*===betrej=============================================================*
26952*
26953 DOUBLE PRECISION FUNCTION DT_BETREJ(GAM,ETA,XMIN,XMAX)
26954
26955 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26956 SAVE
26957
26958 PARAMETER ( LINP = 10 ,
26959 & LOUT = 6 ,
26960 & LDAT = 9 )
26961 PARAMETER (ONE=1.0D0)
26962
26963 IF (XMIN.GE.XMAX)THEN
26964 WRITE (LOUT,500) XMIN,XMAX
26965 500 FORMAT(1X,'DT_BETREJ: XMIN<XMAX execution stopped ',2F10.5)
26966 STOP
26967 ENDIF
26968
26969 10 CONTINUE
26970 XX = XMIN+(XMAX-XMIN)*DT_RNDM(ETA)
26971 BETMAX = XMIN**(GAM-ONE)*(ONE-XMIN)**(ETA-ONE)
26972 YY = BETMAX*DT_RNDM(XX)
26973 BETXX = XX**(GAM-ONE)*(ONE-XX)**(ETA-ONE)
26974 IF (YY.GT.BETXX) GOTO 10
26975 DT_BETREJ = XX
26976
26977 RETURN
26978 END
26979
26980*$ CREATE DT_DGAMRN.FOR
26981*COPY DT_DGAMRN
26982*
26983*===dgamrn=============================================================*
26984*
26985 DOUBLE PRECISION FUNCTION DT_DGAMRN(ALAM,ETA)
26986
26987************************************************************************
26988* Sampling from Gamma-distribution. *
26989* F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA) *
26990* Processed by S. Roesler, 6.5.95 *
26991************************************************************************
26992
26993 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26994 SAVE
26995 PARAMETER (ZERO=0.0D0,TINY9=1.0D-9,ONE=1.0D0)
26996
26997 NCOU = 0
26998 N = INT(ETA)
26999 F = ETA-DBLE(N)
27000 IF (F.EQ.ZERO) GOTO 20
27001 10 R = DT_RNDM(F)
27002 NCOU = NCOU+1
27003 IF (NCOU.GE.11) GOTO 20
27004 IF (R.LT.F/(F+2.71828D0)) GOTO 30
27005 YYY = LOG(DT_RNDM(R)+TINY9)/F
27006 IF (ABS(YYY).GT.50.0D0) GOTO 20
27007 Y = EXP(YYY)
27008 IF (LOG(DT_RNDM(Y)+TINY9).GT.-Y) GOTO 10
27009 GOTO 40
27010 20 Y = 0.0D0
27011 GOTO 50
27012 30 Y = ONE-LOG(DT_RNDM(Y)+TINY9)
27013 IF (DT_RNDM(R).GT.Y**(F-ONE)) GOTO 10
27014 40 IF (N.EQ.0) GOTO 70
27015 50 Z = 1.0D0
27016 DO 60 I = 1,N
27017 60 Z = Z*DT_RNDM(Z)
27018 Y = Y-LOG(Z+TINY9)
27019 70 DT_DGAMRN = Y/ALAM
27020
27021 RETURN
27022 END
27023
27024*$ CREATE DT_DBETAR.FOR
27025*COPY DT_DBETAR
27026*
27027*===dbetar=============================================================*
27028*
27029 DOUBLE PRECISION FUNCTION DT_DBETAR(GAM,ETA)
27030
27031************************************************************************
27032* Sampling from Beta -distribution between 0.0 and 1.0 *
27033* F(X)=X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM)/(GAMM(GAM)*GAMM(ETA))*
27034* Processed by S. Roesler, 6.5.95 *
27035************************************************************************
27036
27037 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27038 SAVE
27039
27040 Y = DT_DGAMRN(1.0D0,GAM)
27041 Z = DT_DGAMRN(1.0D0,ETA)
27042 DT_DBETAR = Y/(Y+Z)
27043
27044 RETURN
27045 END
27046
27047*$ CREATE DT_RANNOR.FOR
27048*COPY DT_RANNOR
27049*
27050*===rannor=============================================================*
27051*
27052 SUBROUTINE DT_RANNOR(X,Y)
27053
27054************************************************************************
27055* Sampling from Gaussian distribution. *
27056* Processed by S. Roesler, 6.5.95 *
27057************************************************************************
27058
27059 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27060 SAVE
27061 PARAMETER (TINY10=1.0D-10)
27062
27063 CALL DT_DSFECF(SFE,CFE)
27064 V = MAX(TINY10,DT_RNDM(X))
27065 A = SQRT(-2.D0*LOG(V))
27066 X = A*SFE
27067 Y = A*CFE
27068
27069 RETURN
27070 END
27071
27072*$ CREATE DT_DPOLI.FOR
27073*COPY DT_DPOLI
27074*
27075*===dpoli==============================================================*
27076*
27077 SUBROUTINE DT_DPOLI(CS,SI)
27078
27079 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27080 SAVE
27081
27082 U = DT_RNDM(CS)
27083 CS = DT_RNDM(U)
27084 IF (U.LT.0.5D0) CS=-CS
27085 SI = SQRT(1.0D0-CS*CS+1.0D-10)
27086
27087 RETURN
27088 END
27089
27090*$ CREATE DT_DSFECF.FOR
27091*COPY DT_DSFECF
27092*
27093*===dsfecf=============================================================*
27094*
27095 SUBROUTINE DT_DSFECF(SFE,CFE)
27096
27097 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27098 SAVE
27099 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
27100
27101 1 CONTINUE
27102 X = DT_RNDM(SFE)
27103 Y = DT_RNDM(X)
27104 XX = X*X
27105 YY = Y*Y
27106 XY = XX+YY
27107 IF (XY.GT.ONE) GOTO 1
27108 CFE = (XX-YY)/XY
27109 SFE = TWO*X*Y/XY
27110 IF (DT_RNDM(X).LT.OHALF) SFE = -SFE
27111 RETURN
27112 END
27113
27114*$ CREATE DT_RACO.FOR
27115*COPY DT_RACO
27116*
27117*===raco===============================================================*
27118*
27119 SUBROUTINE DT_RACO(WX,WY,WZ)
27120
27121************************************************************************
27122* Direction cosines of random uniform (isotropic) direction in three *
27123* dimensional space *
27124* Processed by S. Roesler, 20.11.95 *
27125************************************************************************
27126
27127 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27128 SAVE
27129 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
27130
27131 10 CONTINUE
27132 X = TWO*DT_RNDM(WX)-ONE
27133 Y = DT_RNDM(X)
27134 X2 = X*X
27135 Y2 = Y*Y
27136 IF (X2+Y2.GT.ONE) GOTO 10
27137
27138 CFE = (X2-Y2)/(X2+Y2)
27139 SFE = TWO*X*Y/(X2+Y2)
27140* z = 1/2 [ 1 + cos (theta) ]
27141 Z = DT_RNDM(X)
27142* 1/2 sin (theta)
27143 WZ = SQRT(Z*(ONE-Z))
27144 WX = TWO*WZ*CFE
27145 WY = TWO*WZ*SFE
27146 WZ = TWO*Z-ONE
27147
27148 RETURN
27149 END
27150
27151************************************************************************
27152* *
27153* 6) Special functions, algorithms and service routines *
27154* *
27155************************************************************************
27156*$ CREATE DT_YLAMB.FOR
27157*COPY DT_YLAMB
27158*
27159*===ylamb==============================================================*
27160*
27161 DOUBLE PRECISION FUNCTION DT_YLAMB(X,Y,Z)
27162
27163************************************************************************
27164* *
27165* auxiliary function for three particle decay mode *
27166* (standard LAMBDA**(1/2) function) *
27167* *
27168* Adopted from an original version written by R. Engel. *
27169* This version dated 12.12.94 is written by S. Roesler. *
27170************************************************************************
27171
27172 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27173 SAVE
27174
27175 YZ = Y-Z
27176 XLAM = X*X-2.D0*X*(Y+Z)+YZ*YZ
27177 IF (XLAM.LE.0.D0) XLAM = ABS(XLAM)
27178 DT_YLAMB = SQRT(XLAM)
27179
27180 RETURN
27181 END
27182
27183*$ CREATE DT_SORT.FOR
27184*COPY DT_SORT
27185*
27186*===sort1==============================================================*
27187*
27188 SUBROUTINE DT_SORT(A,N,I0,I1,MODE)
27189
27190************************************************************************
27191* This subroutine sorts entries in A in increasing/decreasing order *
27192* of A(3,i). *
27193* MODE = 1 increasing in A(3,i=1..N) *
27194* = 2 decreasing in A(3,i=1..N) *
27195* This version dated 21.04.95 is revised by S. Roesler *
27196************************************************************************
27197
27198 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27199 SAVE
27200
27201 DIMENSION A(3,N)
27202
27203 M = I1
27204 10 CONTINUE
27205 M = I1-1
27206 IF (M.LE.0) RETURN
27207 L = 0
27208 DO 20 I=I0,M
27209 J = I+1
27210 IF (MODE.EQ.1) THEN
27211 IF (A(3,I).LE.A(3,J)) GOTO 20
27212 ELSE
27213 IF (A(3,I).GE.A(3,J)) GOTO 20
27214 ENDIF
27215 B = A(3,I)
27216 C = A(1,I)
27217 D = A(2,I)
27218 A(3,I) = A(3,J)
27219 A(2,I) = A(2,J)
27220 A(1,I) = A(1,J)
27221 A(3,J) = B
27222 A(1,J) = C
27223 A(2,J) = D
27224 L = 1
27225 20 CONTINUE
27226 IF (L.EQ.1) GOTO 10
27227
27228 RETURN
27229 END
27230
27231*$ CREATE DT_SORT1.FOR
27232*COPY DT_SORT1
27233*
27234*===sort1==============================================================*
27235*
27236 SUBROUTINE DT_SORT1(A,IDX,N,I0,I1,MODE)
27237
27238************************************************************************
27239* This subroutine sorts entries in A in increasing/decreasing order *
27240* of A(i). *
27241* MODE = 1 increasing in A(i=1..N) *
27242* = 2 decreasing in A(i=1..N) *
27243* This version dated 21.04.95 is revised by S. Roesler *
27244************************************************************************
27245
27246 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27247 SAVE
27248
27249 DIMENSION A(N),IDX(N)
27250
27251 M = I1
27252 10 CONTINUE
27253 M = I1-1
27254 IF (M.LE.0) RETURN
27255 L = 0
27256 DO 20 I=I0,M
27257 J = I+1
27258 IF (MODE.EQ.1) THEN
27259 IF (A(I).LE.A(J)) GOTO 20
27260 ELSE
27261 IF (A(I).GE.A(J)) GOTO 20
27262 ENDIF
27263 B = A(I)
27264 A(I) = A(J)
27265 A(J) = B
27266 IX = IDX(I)
27267 IDX(I) = IDX(J)
27268 IDX(J) = IX
27269 L = 1
27270 20 CONTINUE
27271 IF (L.EQ.1) GOTO 10
27272
27273 RETURN
27274 END
27275
27276*$ CREATE DT_XTIME.FOR
27277*COPY DT_XTIME
27278*
27279*===xtime==============================================================*
27280*
27281 SUBROUTINE DT_XTIME
27282
27283 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27284 SAVE
27285 PARAMETER ( LINP = 10 ,
27286 & LOUT = 6 ,
27287 & LDAT = 9 )
27288
27289 CHARACTER DAT*9,TIM*11
27290
27291 DAT = ' '
27292 TIM = ' '
27293C CALL GETDAT(IYEAR,IMONTH,IDAY)
27294C CALL GETTIM(IHOUR,IMINUT,ISECND,IHSCND)
27295
27296C CALL DATE(DAT)
27297C CALL TIME(TIM)
27298C WRITE(LOUT,1000) DAT,TIM
27299 1000 FORMAT(/,2X,'Date: ',A9,3X,'Time: ',A11,/)
27300
27301 RETURN
27302 END
27303
27304************************************************************************
27305* *
27306* 7) Random number generator package *
27307* *
27308* THIS IS A PACKAGE CONTAINING A RANDOM NUMBER GENERATOR AND *
27309* SERVICE ROUTINES. *
27310* THE ALGORITHM IS FROM *
27311* 'TOWARD A UNVERSAL RANDOM NUMBER GENERATOR' *
27312* G.MARSAGLIA, A.ZAMAN ; FSU-SCRI-87-50 *
27313* IMPLEMENTATION BY K. HAHN DEC. 88, *
27314* THIS GENERATOR SHOULD NOT DEPEND ON THE HARD WARE ( IF A REAL HAS *
27315* AT LEAST 24 SIGNIFICANT BITS IN INTERNAL REPRESENTATION ), *
27316* THE PERIOD IS ABOUT 2**144, *
27317* TIME FOR ONE CALL AT IBM-XT IS ABOUT 0.7 MILLISECONDS, *
27318* THE PACKAGE CONTAINS *
27319* FUNCTION DT_RNDM(I) : GENERATOR *
27320* SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB4): INITIALIZATION *
27321* SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) : PUT SEED TO GENERATOR *
27322* SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) : TAKE SEED FROM GENERATOR *
27323* SUBROUTINE DT_RNDMTE(IO) : TEST OF GENERATOR *
27324*--- *
27325* FUNCTION DT_RNDM(I) *
27326* GIVES UNIFORMLY DISTRIBUTED RANDOM NUMBERS IN (0..1) *
27327* I - DUMMY VARIABLE, NOT USED *
27328* SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1) *
27329* INITIALIZES THE GENERATOR, MUST BE CALLED BEFORE USING DT_RNDM *
27330* NA1,NA2,NA3,NB1 - VALUES FOR INITIALIZING THE GENERATOR *
27331* NA? MUST BE IN 1..178 AND NOT ALL 1 *
27332* 12,34,56 ARE THE STANDARD VALUES *
27333* NB1 MUST BE IN 1..168 *
27334* 78 IS THE STANDARD VALUE *
27335* SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) *
27336* PUTS SEED TO GENERATOR ( BRINGS GENERATOR IN THE SAME STATUS *
27337* AS AFTER THE LAST DT_RNDMOU CALL ) *
27338* U(97),C,CD,CM,I,J - SEED VALUES AS TAKEN FROM DT_RNDMOU *
27339* SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) *
27340* TAKES SEED FROM GENERATOR *
27341* U(97),C,CD,CM,I,J - SEED VALUES *
27342* SUBROUTINE DT_RNDMTE(IO) *
27343* TEST OF THE GENERATOR *
27344* IO - DEFINES OUTPUT *
27345* = 0 OUTPUT ONLY IF AN ERROR IS DETECTED *
27346* = 1 OUTPUT INDEPENDEND ON AN ERROR *
27347* DT_RNDMTE USES DT_RNDMIN AND DT_RNDMOU TO BRING GENERATOR TO *
27348* SAME STATUS *
27349* AS BEFORE CALL OF DT_RNDMTE *
27350************************************************************************
27351*$ CREATE DT_RNDM.FOR
27352*COPY DT_RNDM
27353*
839efe5b 27354c$$$*===rndm===============================================================*
27355c$$$*
27356c$$$ DOUBLE PRECISION FUNCTION DT_RNDM(VDUMMY)
27357c$$$
27358c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27359c$$$ SAVE
27360c$$$
27361c$$$* random number generator
27362c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27363c$$$
27364c$$$* counter of calls to random number generator
27365c$$$* uncomment if needed
27366c$$$C COMMON /DTRNCT/ IRNCT0,IRNCT1
27367c$$$C LOGICAL LFIRST
27368c$$$C DATA LFIRST /.TRUE./
27369c$$$
27370c$$$* counter of calls to random number generator
27371c$$$* uncomment if needed
27372c$$$C IF (LFIRST) THEN
27373c$$$C IRNCT0 = 0
27374c$$$C IRNCT1 = 0
27375c$$$C LFIRST = .FALSE.
27376c$$$C ENDIF
27377c$$$ 100 CONTINUE
27378c$$$ DT_RNDM = U(I)-U(J)
27379c$$$ IF ( DT_RNDM.LT.0.0D0 ) DT_RNDM = DT_RNDM+1.0D0
27380c$$$ U(I) = DT_RNDM
27381c$$$ I = I-1
27382c$$$ IF ( I.EQ.0 ) I = 97
27383c$$$ J = J-1
27384c$$$ IF ( J.EQ.0 ) J = 97
27385c$$$ C = C-CD
27386c$$$ IF ( C.LT.0.0D0 ) C = C+CM
27387c$$$ DT_RNDM = DT_RNDM-C
27388c$$$ IF ( DT_RNDM.LT.0.0D0 ) DT_RNDM = DT_RNDM+1.0D0
27389c$$$
27390c$$$ IF ((DT_RNDM.EQ.0.D0).OR.(DT_RNDM.EQ.1.D0)) GOTO 100
27391c$$$
27392c$$$* counter of calls to random number generator
27393c$$$* uncomment if needed
27394c$$$C IRNCT0 = IRNCT0+1
27395c$$$
27396c$$$ RETURN
27397c$$$ END
27398c$$$
27399c$$$*$ CREATE DT_RNDMST.FOR
27400c$$$*COPY DT_RNDMST
27401c$$$*
27402c$$$*===rndmst=============================================================*
27403c$$$*
27404c$$$ SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)
27405c$$$
27406c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27407c$$$ SAVE
27408c$$$
27409c$$$* random number generator
27410c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27411c$$$
27412c$$$ MA1 = NA1
27413c$$$ MA2 = NA2
27414c$$$ MA3 = NA3
27415c$$$ MB1 = NB1
27416c$$$ I = 97
27417c$$$ J = 33
27418c$$$ DO 20 II2 = 1,97
27419c$$$ S = 0
27420c$$$ T = 0.5D0
27421c$$$ DO 10 II1 = 1,24
27422c$$$ MAT = MOD(MOD(MA1*MA2,179)*MA3,179)
27423c$$$ MA1 = MA2
27424c$$$ MA2 = MA3
27425c$$$ MA3 = MAT
27426c$$$ MB1 = MOD(53*MB1+1,169)
27427c$$$ IF ( MOD(MB1*MAT,64).GE.32 ) S = S+T
27428c$$$ 10 T = 0.5D0*T
27429c$$$ 20 U(II2) = S
27430c$$$ C = 362436.0D0/16777216.0D0
27431c$$$ CD = 7654321.0D0/16777216.0D0
27432c$$$ CM = 16777213.0D0/16777216.0D0
27433c$$$ RETURN
27434c$$$ END
27435c$$$
27436c$$$*$ CREATE DT_RNDMIN.FOR
27437c$$$*COPY DT_RNDMIN
27438c$$$*
27439c$$$*===rndmin=============================================================*
27440c$$$*
27441c$$$ SUBROUTINE DT_RNDMIN(UIN,CIN,CDIN,CMIN,IIN,JIN)
27442c$$$
27443c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27444c$$$ SAVE
27445c$$$
27446c$$$* random number generator
27447c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27448c$$$
27449c$$$ DIMENSION UIN(97)
27450c$$$
27451c$$$ DO 10 KKK = 1,97
27452c$$$ 10 U(KKK) = UIN(KKK)
27453c$$$ C = CIN
27454c$$$ CD = CDIN
27455c$$$ CM = CMIN
27456c$$$ I = IIN
27457c$$$ J = JIN
27458c$$$
27459c$$$ RETURN
27460c$$$ END
27461c$$$
27462c$$$*$ CREATE DT_RNDMOU.FOR
27463c$$$*COPY DT_RNDMOU
27464c$$$*
27465c$$$*===rndmou=============================================================*
27466c$$$*
27467c$$$ SUBROUTINE DT_RNDMOU(UOUT,COUT,CDOUT,CMOUT,IOUT,JOUT)
27468c$$$
27469c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27470c$$$ SAVE
27471c$$$
27472c$$$* random number generator
27473c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27474c$$$
27475c$$$ DIMENSION UOUT(97)
27476c$$$
27477c$$$ DO 10 KKK = 1,97
27478c$$$ 10 UOUT(KKK) = U(KKK)
27479c$$$ COUT = C
27480c$$$ CDOUT = CD
27481c$$$ CMOUT = CM
27482c$$$ IOUT = I
27483c$$$ JOUT = J
27484c$$$
27485c$$$ RETURN
27486c$$$ END
27487c$$$
27488c$$$*$ CREATE DT_RNDMTE.FOR
27489c$$$*COPY DT_RNDMTE
27490c$$$*
27491c$$$*===rndmte=============================================================*
27492c$$$*
27493c$$$ SUBROUTINE DT_RNDMTE(IO)
27494c$$$
27495c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27496c$$$ SAVE
27497c$$$
27498c$$$ DIMENSION UU(97),U(6),X(6),D(6)
27499c$$$ DATA U / 6533892.D0, 14220222.D0, 7275067.D0, 6172232.D0,
27500c$$$ +8354498.D0, 10633180.D0/
27501c$$$
27502c$$$ CALL DT_RNDMOU(UU,CC,CCD,CCM,II,JJ)
27503c$$$ CALL DT_RNDMST(12,34,56,78)
27504c$$$ DO 10 II1 = 1,20000
27505c$$$ 10 XX = DT_RNDM(XX)
27506c$$$ SD = 0.0D0
27507c$$$ DO 20 II2 = 1,6
27508c$$$ X(II2) = 4096.D0*(4096.D0*DT_RNDM(SD))
27509c$$$ D(II2) = X(II2)-U(II2)
27510c$$$ 20 SD = SD+D(II2)
27511c$$$ CALL DT_RNDMIN(UU,CC,CCD,CCM,II,JJ)
27512c$$$**sr 24.01.95
27513c$$$C IF ( IO.EQ. 1.OR. SD.NE.0. 0) WRITE(6,500) (U(I),X(I),D(I),I=1,6)
27514c$$$ IF ((IO.EQ.1).OR.(SD.NE.0.0)) THEN
27515c$$$C WRITE(6,1000)
27516c$$$ 1000 FORMAT(/,/,1X,'DT_RNDMTE: Test of random-number generator...',
27517c$$$ & ' passed')
27518c$$$ ENDIF
27519c$$$**
27520c$$$ RETURN
27521c$$$ 500 FORMAT(' === TEST OF THE RANDOM-GENERATOR ===',/,
27522c$$$ &' EXPECTED VALUE CALCULATED VALUE DIFFERENCE',/, 6(F17.
27523c$$$ &1,F20.1,F15.3,/), ' === END OF TEST ;',
27524c$$$ &' GENERATOR HAS THE SAME STATUS AS BEFORE CALLING DT_RNDMTE')
27525c$$$ END
9aaba0d6 27526*
27527*$ CREATE PHO_RNDM.FOR
27528*COPY PHO_RNDM
27529*
27530*===pho_rndm===========================================================*
27531*
27532 DOUBLE PRECISION FUNCTION PHO_RNDM(DUMMY)
27533
27534 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27535 SAVE
27536
27537 PHO_RNDM = DT_RNDM(DUMMY)
27538
27539 RETURN
27540 END
27541
27542*$ CREATE PYR.FOR
27543*COPY PYR
27544*
27545*===pyr================================================================*
27546*
27547 DOUBLE PRECISION FUNCTION PYR(IDUMMY)
27548
27549 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27550 SAVE
27551
27552 DUMMY = DBLE(IDUMMY)
27553 PYR = DT_RNDM(DUMMY)
27554
27555 RETURN
27556 END
27557
27558*$ CREATE DT_TITLE.FOR
27559*COPY DT_TITLE
27560*
27561*===title==============================================================*
27562*
27563 SUBROUTINE DT_TITLE
27564
27565 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27566 SAVE
27567 PARAMETER ( LINP = 10 ,
27568 & LOUT = 6 ,
27569 & LDAT = 9 )
27570
27571 CHARACTER*6 CVERSI
27572 CHARACTER*11 CCHANG
27573 DATA CVERSI,CCHANG /'3.0-5 ','08 Jan 2007'/
27574
27575 CALL DT_XTIME
27576 WRITE(LOUT,1000) CVERSI,CCHANG
27577 1000 FORMAT(1X,'+-------------------------------------------------',
27578 & '----------------------+',/,
27579 & 1X,'|',71X,'|',/,
27580 & 1X,'|',26X,'DPMJET version ',A6,24X,'|',/,
27581 & 1X,'|',71X,'|',/,
27582 & 1X,'|',22X,'(Last change: ',A11,')',23X,'|',/,
27583 & 1X,'|',71X,'|',/,
27584 & 1X,'|',12X,'Authors: Stefan Roesler (CERN)',27X,'|',/,
27585 & 1X,'|',21X,'Ralph Engel (FZ Karlsruhe)',19X,'|',/,
27586 & 1X,'|',21X,'Johannes Ranft (Siegen Univ.)',19X,'|',/,
27587 & 1X,'|',71X,'|',/,
27588 & 1X,'|',12X,'http://home.cern.ch/~sroesler/dpmjet3.html',
27589 & 17X,'|',/,
27590 & 1X,'|',71X,'|',/,
27591 & 1X,'+-------------------------------------------------',
27592 & '----------------------+',/,
27593 & 1X,'| Please send suggestions, bug reports, etc. to: ',
27594 & 'Stefan.Roesler@cern.ch |',/,
27595 & 1X,'+-------------------------------------------------',
27596 & '----------------------+',/)
27597
27598 RETURN
27599 END
27600
27601*$ CREATE DT_EVTINI.FOR
27602*COPY DT_EVTINI
27603*
27604*===evtini=============================================================*
27605*
27606 SUBROUTINE DT_EVTINI
27607
27608************************************************************************
27609* Initialization of DTEVT1. *
27610* This version dated 15.01.94 is written by S. Roesler *
27611************************************************************************
27612
27613 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27614 SAVE
27615 PARAMETER ( LINP = 10 ,
27616 & LOUT = 6 ,
27617 & LDAT = 9 )
27618
27619* event history
27620 PARAMETER (NMXHKK=200000)
27621 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27622 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27623 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27624* extended event history
27625 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27626 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27627 & IHIST(2,NMXHKK)
27628* event flag
27629 COMMON /DTEVNO/ NEVENT,ICASCA
27630 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
27631* emulsion treatment
27632 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
27633 & NCOMPO,IEMUL
27634
27635* initialization of DTEVT1/DTEVT2
27636 NEND = NHKK
27637 IF (NEVENT.EQ.1) NEND = NMXHKK
27638 NHKK = 0
27639 NEVHKK = NEVENT
27640 DO 1 I=1,NEND
27641 ISTHKK(I) = 0
27642 IDHKK(I) = 0
27643 JMOHKK(1,I) = 0
27644 JMOHKK(2,I) = 0
27645 JDAHKK(1,I) = 0
27646 JDAHKK(2,I) = 0
27647 IDRES(I) = 0
27648 IDXRES(I) = 0
27649 NOBAM(I) = 0
27650 IDCH(I) = 0
27651 IHIST(1,I) = 0
27652 IHIST(2,I) = 0
27653 DO 2 J=1,4
27654 PHKK(J,I) = 0.0D0
27655 VHKK(J,I) = 0.0D0
27656 WHKK(J,I) = 0.0D0
27657 2 CONTINUE
27658 PHKK(5,I) = 0.0D0
27659 1 CONTINUE
27660 DO 3 I=1,10
27661 NPOINT(I) = 0
27662 3 CONTINUE
27663 CALL DT_CHASTA(-1)
27664
27665C* initialization of DTLTRA
27666C IF (NCOMPO.GT.0) CALL DT_LTINI(ID,EPN,PPN,ECM)
27667
27668 RETURN
27669 END
27670
27671*$ CREATE DT_STATIS.FOR
27672*COPY DT_STATIS
27673*
27674*===statis=============================================================*
27675*
27676 SUBROUTINE DT_STATIS(MODE)
27677
27678************************************************************************
27679* Initialization and output of run-statistics. *
27680* MODE = 1 initialization *
27681* = 2 output *
27682* This version dated 23.01.94 is written by S. Roesler *
27683************************************************************************
27684
27685 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27686 SAVE
27687 PARAMETER ( LINP = 10 ,
27688 & LOUT = 6 ,
27689 & LDAT = 9 )
27690 PARAMETER (TINY3=1.0D-3)
27691
27692* statistics
27693 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
27694 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
27695 & ICEVTG(8,0:30)
27696* rejection counter
27697 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27698 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27699 & IREXCI(3),IRDIFF(2),IRINC
27700* central particle production, impact parameter biasing
27701 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
27702* various options for treatment of partons (DTUNUC 1.x)
27703* (chain recombination, Cronin,..)
27704 LOGICAL LCO2CR,LINTPT
27705 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
27706 & LCO2CR,LINTPT
27707* nucleon-nucleon event-generator
27708 CHARACTER*8 CMODEL
27709 LOGICAL LPHOIN
27710 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
27711* flags for particle decays
27712 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
27713 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
27714 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
27715* diquark-breaking mechanism
27716 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
27717
27718 DIMENSION PP(4),PT(4)
27719
27720 GOTO (1,2) MODE
27721
27722* initialization
27723 1 CONTINUE
27724
27725* initialize statistics counter
27726 ICREQU = 0
27727 ICSAMP = 0
27728 ICCPRO = 0
27729 ICDPR = 0
27730 ICDTA = 0
27731 ICRJSS = 0
27732 ICVV2S = 0
27733 DO 10 I=1,9
27734 ICRES(I) = 0
27735 ICCHAI(1,I) = 0
27736 ICCHAI(2,I) = 0
27737 10 CONTINUE
27738* initialize rejection counter
27739 IRPT = 0
27740 IRHHA = 0
27741 LOMRES = 0
27742 LOBRES = 0
27743 IRFRAG = 0
27744 IREVT = 0
27745 IRRES(1) = 0
27746 IRRES(2) = 0
27747 IRCHKI(1) = 0
27748 IRCHKI(2) = 0
27749 IRCRON(1) = 0
27750 IRCRON(2) = 0
27751 IRCRON(3) = 0
27752 IRDIFF(1) = 0
27753 IRDIFF(2) = 0
27754 IRINC = 0
27755 DO 11 I=1,5
27756 ICDIFF(I) = 0
27757 11 CONTINUE
27758 DO 12 I=1,8
27759 DO 13 J=0,30
27760 ICEVTG(I,J) = 0
27761 13 CONTINUE
27762 12 CONTINUE
27763
27764 RETURN
27765
27766* output
27767 2 CONTINUE
27768
27769* statistics counter
27770 WRITE(LOUT,1000)
27771 1000 FORMAT(/,/,1X,'STATIS:',20X,'statistics of the run',/,
27772 & 28X,'---------------------')
be6523b4 27773 IF (ICREQU.GT.0) THEN
9aaba0d6 27774 WRITE(LOUT,1001) ICREQU,ICSAMP,DBLE(ICSAMP)/DBLE(ICREQU)
27775 1001 FORMAT(/,1X,'number of events requested / sampled',13X,
27776 & I8,' / ',I8,/,1X,'number of samp. evts per requested ',
27777 & 'event',11X,F9.1)
be6523b4 27778 ENDIF
9aaba0d6 27779 IF (ICDIFF(1).NE.0) THEN
27780 WRITE(LOUT,1009) ICDIFF
27781 1009 FORMAT(/,1X,'diffractive events: total ',I8,/,49X,
27782 & 'low mass high mass',/,24X,'single diffraction',
27783 & 7X,I8,4X,I8,/,24X,'double diffraction',7X,I8,4X,I8)
27784 ENDIF
be6523b4 27785 IF (ICENTR.GT.0.AND.ICSAMP.GT.0.AND.ICCPRO.GT.0) THEN
9aaba0d6 27786 WRITE(LOUT,1002) DBLE(ICCPRO)/DBLE(ICSAMP),
27787 & DBLE(ICSAMP)/DBLE(ICCPRO)
27788 1002 FORMAT(/,1X,'central production:',/,2X,'mean number',
27789 & ' of sampled Glauber-events per event',9X,F9.1,/,
27790 & 2X,'fraction of production cross section',21X,F10.6)
27791 ENDIF
be6523b4 27792 IF (ICSAMP.GT.0) THEN
9aaba0d6 27793 WRITE(LOUT,1003) DBLE(ICDPR)/DBLE(ICSAMP),
27794 & DBLE(ICDTA)/DBLE(ICSAMP)
27795 1003 FORMAT(/,54X,'proj. targ.',/,1X,'average number of wounded',
27796 & ' nucleons after x-sampling',2(4X,F6.2))
be6523b4 27797 ENDIF
9aaba0d6 27798
27799 IF (MCGENE.EQ.1) THEN
be6523b4 27800 IF (ICSAMP.GT.0) THEN
9aaba0d6 27801 WRITE(LOUT,1004) DBLE(ICRJSS)/DBLE(ICSAMP)
27802 1004 FORMAT(/,1X,'mean number of sea-sea chain rejections per',
27803 & ' event',3X,F9.1)
27804 IF (ISICHA.EQ.1) THEN
27805 WRITE(LOUT,1005) DBLE(ICVV2S)/DBLE(ICSAMP)
27806 1005 FORMAT(/,1X,'Reggeon contribution:',/,1X,'mean number ',
27807 & 'of single chains per event',13X,F9.1)
27808 ENDIF
be6523b4 27809 ENDIF
27810 IF (ICSAMP.GT.0.AND.ICREQU.GT.0) THEN
9aaba0d6 27811 WRITE(LOUT,1006)
27812 1006 FORMAT(/,1X,'chain system statistics: (per event)',/,
27813 & 23X,'mean number of chains mean number of chains',/,
27814 & 23X,'sampled hadronized having mass of a reso.')
27815 WRITE(LOUT,1007) (DBLE(ICCHAI(1,J))/(2.0D0*DBLE(ICSAMP)),
27816 & DBLE(ICCHAI(2,J))/(2.0D0*DBLE(ICREQU)),
27817 & DBLE(ICRES(J))/(2.0D0*DBLE(ICREQU)),J=1,8),
27818 & DBLE(ICCHAI(2,9))/MAX(DBLE(ICCHAI(1,9)),TINY3)
27819 1007 FORMAT(1X,'sea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27820 & 1X,'disea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27821 & 1X,'sea - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27822 & 1X,'sea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27823 & 1X,'disea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27824 & 1X,'valence - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27825 & 1X,'valence - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27826 & 1X,'valence - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27827 & 1X,'fused chains ',18X,F4.1,17X,F4.1,/)
27828 WRITE(LOUT,1008)
27829 & (DBLE(IRCRON(I))/MAX(DBLE(IRCRON(1)),TINY3),I=2,3),
27830 & DBLE(IRPT)/DBLE(ICREQU),(DBLE(IRRES(I))/DBLE(ICREQU),I=1,2),
27831 & DBLE(LOMRES)/DBLE(ICREQU),DBLE(LOBRES)/DBLE(ICREQU),
27832 & (DBLE(IRCHKI(I))/DBLE(ICREQU),I=1,2),
27833 & (DBLE(IRDIFF(I))/DBLE(ICREQU),I=1,2),
27834 & DBLE(IRHHA)/DBLE(ICREQU),
27835 & DBLE(IRFRAG)/DBLE(ICREQU),DBLE(IREVT)/DBLE(ICREQU),
27836 & (DBLE(IREXCI(I))/DBLE(ICREQU),I=1,2),IREXCI(3)
27837 1008 FORMAT(/,1X,'Rejection counter: (NEVT = no. of events)',/,/,
27838 & 1X,'Cronin-effect (CRONIN)',15X,'IRCRON(2)/IRCRON(1) = ',
27839 & F7.2,/,38X,'IRCRON(3)/IRCRON(1) = ',F7.2,/,1X,
27840 & 'Intrins. p_t (GETSPT)',21X,'IRPT /NEVT = ',F7.2,/,
27841 & 1X,'Chain mass corr. for resonances (EVTRES)',2X,
27842 & 'IRRES(1) /NEVT = ',F7.2,/,33X,'(CH2RES) IRRES(2) /',
27843 & 'NEVT = ',F7.2,/,43X,'LOMRES /NEVT = ',F7.2,/,
27844 & 43X,'LOBRES /NEVT = ',F7.2,/,1X,'Kinem. corr. of',
27845 & ' 2-chain systems (CHKINE) IRCHKI(1)/NEVT = ',F7.2,/,
27846 & 43X,'IRCHKI(2)/NEVT = ',F7.2,/,1X,'Diffraction',31X,
27847 & 'IRDIFF(1)/NEVT = ',F7.2,/,43X,'IRDIFF(2)/NEVT = ',
27848 & F7.2,/,1X,'Total no. of rej.',
27849 & ' in chain-systems treatment (GETCSY)',/,43X,
27850 & 'IRHHA /NEVT = ',F7.2,/,1X,'Fragmentation (EVTFRA)',
27851 & ' (not yet used!)',4X,'IRFRAG /NEVT = ',F7.2,/,
27852 & 1X,'Total no. of rej. in DPM-treatment of one event',
27853 & ' (EVENTA)',/,43X,'IREVT /NEVT = ',F7.2,/,1X,
27854 & 'Treatment of final nucleon conf.',10X,'IREXCI(1)/NEVT = '
27855 & ,F7.2,/,43X,'IREXCI(2)/NEVT = ',F7.2,/,48X,
27856 & 'IREXCI(3) = ',I5,/)
be6523b4 27857 ENDIF
9aaba0d6 27858 ELSEIF (MCGENE.EQ.2) THEN
27859 WRITE(LOUT,1010) ELOJET
27860 1010 FORMAT(/,/,1X,'PHOJET-treatment of chain systems above ',
27861 & F4.1,' GeV')
27862 WRITE(LOUT,1011)
27863 1011 FORMAT(/,1X,'1. chain system statistics - total numbers:',/,
27864 & 30X,'--------------',/,/,12X,'s-s',5X,'d-s',5X,'s-d',
27865 & 5X,'s-v',5X,'d-v',5X,'v-s',5X,'v-d',5X,'v-v')
27866 WRITE(LOUT,1012) ((ICEVTG(I,J),I=1,8),J=0,1),
27867 & (INT(ICCHAI(2,I)/2.0D0),I=1,8),
27868 & (ICEVTG(I,2),I=1,8),(ICEVTG(I,29),I=1,8),
27869 & ((ICEVTG(I,J),I=1,8),J=3,7),
27870 & ((ICEVTG(I,J),I=1,8),J=19,21),
27871 & (ICEVTG(I,8),I=1,8),
27872 & ((ICEVTG(I,J),I=1,8),J=22,24),
27873 & (ICEVTG(I,9),I=1,8),
27874 & ((ICEVTG(I,J),I=1,8),J=25,28),
27875 & ((ICEVTG(I,J),I=1,8),J=10,18)
27876 1012 FORMAT(/,1X,'req.to.',8I8,/,/,1X,'low rq.',8I8,/,1X,'low ac.',
27877 & 8I8,/,/,1X,'PHOJET ',8I8,/,' sngl ',8I8,/,/,
27878 & ' no-dif.',8I8,/,
27879 & ' el-sca.',8I8,/,' qel-sc.',8I8,/,' dbl-Po.',8I8,/,
27880 & ' diff-1 ',8I8,/,' low ',8I8,/,' high ',8I8,/,
27881 & ' h-diff',8I8,/,' diff-2 ',8I8,/,' low ',8I8,/,
27882 & ' high ',8I8,/,' h-diff',8I8,/,' dbl-di.',8I8,/,
27883 & ' lo-lo ',8I8,/,' hi-hi ',8I8,/,' lo-hi ',8I8,/,
27884 & ' hi-lo ',8I8,/,
27885 & ' dir-ga.',8I8,/,/,' dir-1 ',8I8,/,' dir-2 ',8I8,/,
27886 & ' dbl-dir',8I8,/,' s-Pom. ',8I8,/,' h-Pom. ',8I8,/,
27887 & ' s-Reg. ',8I8,/,' enh-trg',8I8,/,' enh-log',8I8)
27888 WRITE(LOUT,1013)
27889 1013 FORMAT(/,1X,'2. chain system statistics -',
27890 & ' mean numbers per evt:',/,30X,'---------------------',
27891 & /,/,16X,'s-s',7X,'d-s',7X,'s-d')
be6523b4 27892 IF (ICSAMP.GT.0) THEN
9aaba0d6 27893 WRITE(LOUT,1014)
27894 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=0,1),
27895 & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=1,3),
27896 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=2,18)
27897 1014 FORMAT(/,1X,'req.to. ',3E10.2,/,/,1X,'low rq. ',3E10.2,/,
27898 & 1X,'low ac. ',3E10.2,/,/,1X,'PHOJET ',3E10.2,/,/,
27899 & ' no-dif. ',3E10.2,/,' el-sca. ',3E10.2,/,
27900 & ' qel-sc. ',3E10.2,/,' dbl-Po. ',3E10.2,/,
27901 & ' diff-1 ',3E10.2,/,' diff-2 ',3E10.2,/,
27902 & ' dbl-di. ',3E10.2,/,' dir-ga. ',3E10.2,/,/,
27903 & ' dir-1 ',3E10.2,/,' dir-2 ',3E10.2,/,
27904 & ' dbl-dir ',3E10.2,/,' s-Pom. ',3E10.2,/,
27905 & ' h-Pom. ',3E10.2,/,' s-Reg. ',3E10.2,/,
27906 & ' enh-trg ',3E10.2,/,' enh-log ',3E10.2)
be6523b4 27907 ENDIF
9aaba0d6 27908 WRITE(LOUT,1015)
27909 1015 FORMAT(/,16X,'s-v',7X,'d-v',7X,'v-s',7X,'v-d',7X,'v-v')
be6523b4 27910 IF (ICSAMP.GT.0) THEN
9aaba0d6 27911 WRITE(LOUT,1016)
27912 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=0,1),
27913 & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=4,8),
27914 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=2,18)
27915 1016 FORMAT(/,1X,'req.to. ',5E10.2,/,/,1X,'low rq. ',5E10.2,/,
27916 & 1X,'low ac. ',5E10.2,/,/,1X,'PHOJET ',5E10.2,/,/,
27917 & ' no-dif. ',5E10.2,/,' el-sca. ',5E10.2,/,
27918 & ' qel-sc. ',5E10.2,/,' dbl-Po. ',5E10.2,/,
27919 & ' diff-1 ',5E10.2,/,' diff-2 ',5E10.2,/,
27920 & ' dbl-di. ',5E10.2,/,' dir-ga. ',5E10.2,/,/,
27921 & ' dir-1 ',5E10.2,/,' dir-2 ',5E10.2,/,
27922 & ' dbl-dir ',5E10.2,/,' s-Pom. ',5E10.2,/,
27923 & ' h-Pom. ',5E10.2,/,' s-Reg. ',5E10.2,/,
27924 & ' enh-trg ',5E10.2,/,' enh-log ',5E10.2)
be6523b4 27925 ENDIF
9aaba0d6 27926
27927 ENDIF
27928 CALL DT_CHASTA(1)
27929
27930 IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
27931 & .OR.(PDBSEA(3).GT.0.0D0)) THEN
27932 WRITE(LOUT,*)'YGS1S,YGS2S,YUS1S,YUS2S',
27933 & DBRKA(1,1)+DBRKA(2,1),DBRKA(1,2)+DBRKA(2,2),
27934 & DBRKA(1,3)+DBRKA(2,3),DBRKA(1,4)+DBRKA(2,4)
27935 WRITE(LOUT,*)'YGS1R,YGS2R,YUS1R,YUS2R',
27936 & DBRKR(1,1)+DBRKR(2,1),DBRKR(1,2)+DBRKR(2,2),
27937 & DBRKR(1,3)+DBRKR(2,3),DBRKR(1,4)+DBRKR(2,4)
27938 WRITE(LOUT,*)'YGSA1S,YGSA2S,YUSA1S,YUSA2S',
27939 & DBRKA(1,5)+DBRKA(2,5),DBRKA(1,6)+DBRKA(2,6),
27940 & DBRKA(1,7)+DBRKA(2,7),DBRKA(1,8)+DBRKA(2,8)
27941 WRITE(LOUT,*)'YGSA1R,YGSA2R,YUSA1R,YUSA2R',
27942 & DBRKR(1,5)+DBRKR(2,5),DBRKR(1,6)+DBRKR(2,6),
27943 & DBRKR(1,7)+DBRKR(2,7),DBRKR(1,8)+DBRKR(2,8)
27944 WRITE(LOUT,*)'YG31S,YG32S,YU31S,YU32S',
27945 & DBRKA(3,1),DBRKA(3,2),
27946 & DBRKA(3,3),DBRKA(3,4)
27947 WRITE(LOUT,*)'YG31R,YG32R,YU31R,YU32R',
27948 & DBRKR(3,1),DBRKR(3,2),
27949 & DBRKR(3,3),DBRKR(3,4)
27950 WRITE(LOUT,*)'YG3A1S,YG3A2S,YU3A1S,YU3A2S',
27951 & DBRKA(3,5),DBRKA(3,6),
27952 & DBRKA(3,7),DBRKA(3,8)
27953 WRITE(LOUT,*)'YG3A1R,YG3A2R,YU3A1R,YU3A2R',
27954 & DBRKR(3,5),DBRKR(3,6),
27955 & DBRKR(3,7),DBRKR(3,8)
27956 ENDIF
27957
27958 FAC = 1.0D0
27959 IF (MCGENE.EQ.2) THEN
27960C CALL PHO_PHIST(-2,SIGMAX)
27961 CALL PHO_EVENT(-2,PP,PT,FAC,IREJ1)
27962 ENDIF
27963
27964 CALL DT_XTIME
27965
27966 RETURN
27967 END
27968
27969*$ CREATE DT_EVTOUT.FOR
27970*COPY DT_EVTOUT
27971*
27972*===evtout=============================================================*
27973*
27974 SUBROUTINE DT_EVTOUT(MODE)
27975
27976************************************************************************
27977* MODE = 1 plot content of complete DTEVT1 to out. unit *
27978* 3 plot entries of extended DTEVT1 (DTEVT2) *
27979* 4 plot entries of DTEVT1 and DTEVT2 *
27980* This version dated 11.12.94 is written by S. Roesler *
27981************************************************************************
27982
27983 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27984 SAVE
27985 PARAMETER ( LINP = 10 ,
27986 & LOUT = 6 ,
27987 & LDAT = 9 )
27988* event history
27989 PARAMETER (NMXHKK=200000)
27990 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27991 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27992 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27993
27994 DIMENSION IRANGE(NMXHKK)
27995
27996 IF (MODE.EQ.2) RETURN
27997
27998 CALL DT_EVTPLO(IRANGE,MODE)
27999
28000 RETURN
28001 END
28002
28003*$ CREATE DT_EVTPLO.FOR
28004*COPY DT_EVTPLO
28005*
28006*===evtplo=============================================================*
28007*
28008 SUBROUTINE DT_EVTPLO(IRANGE,MODE)
28009
28010************************************************************************
28011* MODE = 1 plot content of complete DTEVT1 to out. unit *
28012* 2 plot entries of DTEVT1 given by IRANGE *
28013* 3 plot entries of extended DTEVT1 (DTEVT2) *
28014* 4 plot entries of DTEVT1 and DTEVT2 *
28015* 5 plot rejection counter *
28016* This version dated 11.12.94 is written by S. Roesler *
28017************************************************************************
28018
28019 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28020 SAVE
28021 PARAMETER ( LINP = 10 ,
28022 & LOUT = 6 ,
28023 & LDAT = 9 )
28024
28025 CHARACTER*16 CHAU
28026
28027* event history
28028 PARAMETER (NMXHKK=200000)
28029 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28030 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28031 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28032* extended event history
28033 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28034 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28035 & IHIST(2,NMXHKK)
28036* rejection counter
28037 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
28038 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
28039 & IREXCI(3),IRDIFF(2),IRINC
28040
28041 DIMENSION IRANGE(NMXHKK)
28042
28043 IF ((MODE.EQ.1).OR.(MODE.EQ.4)) THEN
28044 WRITE(LOUT,1000)
28045 1000 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTEVT1/',/,
28046 & 15X,' --------------------------',/,/,
28047 & ' ST ID M1 M2 D1 D2 PX PY',
28048 & ' PZ E M',/)
28049 DO 1 I=1,NHKK
28050 WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28051 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28052 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
28053 & PHKK(5,I)
28054C WRITE(LOUT,1011) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28055C & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28056C & PHKK(3,I),PHKK(4,I)
28057C WRITE(LOUT,'(4E15.4)')
28058C & VHKK(1,I),VHKK(2,I),VHKK(3,I),VHKK(4,I)
28059 1001 FORMAT(I5,I5,I6,4I5,3F7.3,F8.3,F8.4)
28060 1011 FORMAT(I5,I5,I6,4I5,2E15.5)
28061 1 CONTINUE
28062 WRITE(LOUT,*)
28063C DO 4 I=1,NHKK
28064C WRITE(LOUT,1006) I,ISTHKK(I),
28065C & VHKK(1,I),VHKK(2,I),VHKK(3,I),WHKK(1,I),
28066C & WHKK(2,I),WHKK(3,I)
28067C1006 FORMAT(1X,I4,I6,6E10.3)
28068C 4 CONTINUE
28069 ENDIF
28070
28071 IF (MODE.EQ.2) THEN
28072 WRITE(LOUT,1000)
28073 NC = 0
28074 2 CONTINUE
28075 NC = NC+1
28076 IF (IRANGE(NC).EQ.-100) GOTO 9999
28077 I = IRANGE(NC)
28078 WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28079 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28080 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
28081 & PHKK(5,I)
28082 GOTO 2
28083 ENDIF
28084
28085 IF ((MODE.EQ.3).OR.(MODE.EQ.4)) THEN
28086 WRITE(LOUT,1002)
28087 1002 FORMAT(/,1X,'EVTPLO:',14X,
28088 & ' content of COMMON /DTEVT1/,/DTEVT2/',/,
28089 & 15X,' -----------------------------------',/,/,
28090 & ' ST ID M1 M2 D1 D2 IDR IDXR',
28091 & ' NOBAM IDCH M',/)
28092 DO 3 I=1,NHKK
28093C IF ((ISTHKK(I).GT.10).OR.(ISTHKK(I).EQ.1)) THEN
28094 KF = IDHKK(I)
28095 IDCHK = KF/10000
28096 IF ((((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
28097 & (KF.NE.80000)).OR.(IDHKK(I).EQ.99999)) KF = 92
28098 CALL PYNAME(KF,CHAU)
28099 WRITE(LOUT,1003) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28100 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28101 & IDRES(I),IDXRES(I),NOBAM(I),IDCH(I),
28102 & PHKK(5,I),CHAU
28103 1003 FORMAT(I5,I5,I6,4I5,4I4,F8.4,2X,A)
28104C ENDIF
28105 3 CONTINUE
28106 ENDIF
28107
28108 IF (MODE.EQ.5) THEN
28109 WRITE(LOUT,1004)
28110 1004 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTREJC/',/,
28111 & 15X,' --------------------------',/)
28112 WRITE(LOUT,1005) IRPT,IRHHA,IRRES,LOMRES,LOBRES,IREMC,IRFRAG,
28113 & IRSEA,IRCRON
28114 1005 FORMAT(1X,'IRPT = ',I5,' IRHHA = ',I5,/,
28115 & 1X,'IRRES = ',2I5,' LOMRES = ',I5,' LOBRES = ',I5,/,
28116 & 1X,'IREMC = ',10I5,/,
28117 & 1X,'IRFRAG = ',I5,' IRSEA = ',I5,' IRCRON = ',I5,/)
28118 ENDIF
28119
28120 9999 RETURN
28121 END
28122
28123*$ CREATE DT_EVTPUT.FOR
28124*COPY DT_EVTPUT
28125*
28126*===evtput=============================================================*
28127*
28128 SUBROUTINE DT_EVTPUT(IST,ID,M1,M2,PX,PY,PZ,E,IDR,IDXR,IDC)
28129
28130 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28131 SAVE
28132 PARAMETER ( LINP = 10 ,
28133 & LOUT = 6 ,
28134 & LDAT = 9 )
28135 PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,TINY3=1.0D-3,
28136 & TINY2=1.0D-2,SQTINF=1.0D+15,ZERO=0.0D0)
28137
28138* event history
28139 PARAMETER (NMXHKK=200000)
28140 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28141 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28142 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28143* extended event history
28144 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28145 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28146 & IHIST(2,NMXHKK)
28147* Lorentz-parameters of the current interaction
28148 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28149 & UMO,PPCM,EPROJ,PPROJ
28150* particle properties (BAMJET index convention)
28151 CHARACTER*8 ANAME
28152 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28153 & IICH(210),IIBAR(210),K1(210),K2(210)
28154
28155C IF (MODE.GT.100) THEN
28156C WRITE(LOUT,'(1X,A,I5,A,I5)')
28157C & 'EVTPUT: reset NHKK = ',NHKK,' to NHKK =',NHKK-MODE+100
28158C NHKK = NHKK-MODE+100
28159C RETURN
28160C ENDIF
28161 MO1 = M1
28162 MO2 = M2
28163 NHKK = NHKK+1
28164
28165 IF (NHKK.GT.NMXHKK) THEN
28166 WRITE(LOUT,1000) NHKK
28167 1000 FORMAT(1X,'EVTPUT: NHKK exeeds NMXHKK = ',I7,
28168 & '! program execution stopped..')
28169 STOP
28170 ENDIF
28171 IF (M1.LT.0) MO1 = NHKK+M1
28172 IF (M2.LT.0) MO2 = NHKK+M2
28173 ISTHKK(NHKK) = IST
28174 IDHKK(NHKK) = ID
28175 JMOHKK(1,NHKK) = MO1
28176 JMOHKK(2,NHKK) = MO2
28177 JDAHKK(1,NHKK) = 0
28178 JDAHKK(2,NHKK) = 0
28179 IDRES(NHKK) = IDR
28180 IDXRES(NHKK) = IDXR
28181 IDCH(NHKK) = IDC
28182** here we need to do something..
28183 IF (ID.EQ.88888) THEN
28184 IDMO1 = ABS(IDHKK(MO1))
28185 IDMO2 = ABS(IDHKK(MO2))
28186 IF ((IDMO1.LT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 3
28187 IF ((IDMO1.LT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 4
28188 IF ((IDMO1.GT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 5
28189 IF ((IDMO1.GT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 6
28190 ELSE
28191 NOBAM(NHKK) = 0
28192 ENDIF
28193 IDBAM(NHKK) = IDT_ICIHAD(ID)
28194 IF (MO1.GT.0) THEN
28195 IF (JDAHKK(1,MO1).NE.0) THEN
28196 JDAHKK(2,MO1) = NHKK
28197 ELSE
28198 JDAHKK(1,MO1) = NHKK
28199 ENDIF
28200 ENDIF
28201 IF (MO2.GT.0) THEN
28202 IF (JDAHKK(1,MO2).NE.0) THEN
28203 JDAHKK(2,MO2) = NHKK
28204 ELSE
28205 JDAHKK(1,MO2) = NHKK
28206 ENDIF
28207 ENDIF
28208C IF ((IDBAM(NHKK).GT.0).AND.(IDBAM(NHKK).NE.7)) THEN
28209C PTOT = SQRT(PX**2+PY**2+PZ**2)
28210C AM0 = SQRT(ABS( (E-PTOT)*(E+PTOT) ))
28211C AMRQ = AAM(IDBAM(NHKK))
28212C AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
28213C IF ((ABS(AMDIF2).GT.TINY3).AND.(E.LT.SQTINF).AND.
28214C & (PTOT.GT.ZERO)) THEN
28215C DELTA = -AMDIF2/(2.0D0*(E+PTOT))
28216CC DELTA = (AMRQ2-AM2)/(2.0D0*(E+PTOT))
28217C E = E+DELTA
28218C PTOT1 = PTOT-DELTA
28219C PX = PX*PTOT1/PTOT
28220C PY = PY*PTOT1/PTOT
28221C PZ = PZ*PTOT1/PTOT
28222C ENDIF
28223C ENDIF
28224 PHKK(1,NHKK) = PX
28225 PHKK(2,NHKK) = PY
28226 PHKK(3,NHKK) = PZ
28227 PHKK(4,NHKK) = E
28228 PTOT = SQRT( PX**2+PY**2+PZ**2 )
28229 IF ((IDHKK(NHKK).GE.22).AND.(IDHKK(NHKK).LE.24)) THEN
28230 PHKK(5,NHKK) = PHKK(4,NHKK)**2-PTOT**2
28231 PHKK(5,NHKK) = SIGN(SQRT(ABS(PHKK(5,NHKK))),PHKK(5,NHKK))
28232 ELSE
28233 PHKK(5,NHKK) = (PHKK(4,NHKK)-PTOT)*(PHKK(4,NHKK)+PTOT)
28234C IF ((PHKK(5,NHKK).LT.0.0D0).AND.(ABS(PHKK(5,NHKK)).GT.TINY4))
28235C & WRITE(LOUT,'(1X,A,G10.3)')
28236C & 'EVTPUT: negative mass**2 ',PHKK(5,NHKK)
28237 PHKK(5,NHKK) = SQRT(ABS(PHKK(5,NHKK)))
28238 ENDIF
28239 IDCHK = ID/10000
28240 IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.(ID.NE.80000)) THEN
28241* special treatment for chains:
28242* z coordinate of chain in Lab = pos. of target nucleon
28243* time of chain-creation in Lab = time of passage of projectile
28244* nucleus at pos. of taget nucleus
28245C VHKK(1,NHKK) = 0.5D0*(VHKK(1,MO1)+VHKK(1,MO2))
28246C VHKK(2,NHKK) = 0.5D0*(VHKK(2,MO1)+VHKK(2,MO2))
28247 VHKK(1,NHKK) = VHKK(1,MO2)
28248 VHKK(2,NHKK) = VHKK(2,MO2)
28249 VHKK(3,NHKK) = VHKK(3,MO2)
28250 VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
28251C WHKK(1,NHKK) = 0.5D0*(WHKK(1,MO1)+WHKK(1,MO2))
28252C WHKK(2,NHKK) = 0.5D0*(WHKK(2,MO1)+WHKK(2,MO2))
28253 WHKK(1,NHKK) = WHKK(1,MO1)
28254 WHKK(2,NHKK) = WHKK(2,MO1)
28255 WHKK(3,NHKK) = WHKK(3,MO1)
28256 WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
28257 ELSE
28258 IF (MO1.GT.0) THEN
28259 DO 1 I=1,4
28260 VHKK(I,NHKK) = VHKK(I,MO1)
28261 WHKK(I,NHKK) = WHKK(I,MO1)
28262 1 CONTINUE
28263 ELSE
28264 DO 2 I=1,4
28265 VHKK(I,NHKK) = ZERO
28266 WHKK(I,NHKK) = ZERO
28267 2 CONTINUE
28268 ENDIF
28269 ENDIF
28270
28271 RETURN
28272 END
28273
28274*$ CREATE DT_CHASTA.FOR
28275*COPY DT_CHASTA
28276*
28277*===chasta=============================================================*
28278*
28279 SUBROUTINE DT_CHASTA(MODE)
28280
28281************************************************************************
28282* This subroutine performs CHAin STAtistics and checks sequence of *
28283* partons in dtevt1 and sorts them with projectile partons coming *
28284* first if necessary. *
28285* *
28286* This version dated 8.5.00 is written by S. Roesler. *
28287************************************************************************
28288
28289 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28290 SAVE
28291 PARAMETER ( LINP = 10 ,
28292 & LOUT = 6 ,
28293 & LDAT = 9 )
28294
28295 CHARACTER*5 CCHTYP
28296
28297* event history
28298 PARAMETER (NMXHKK=200000)
28299 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28300 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28301 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28302* extended event history
28303 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28304 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28305 & IHIST(2,NMXHKK)
28306* pointer to chains in hkkevt common (used by qq-breaking mechanisms)
28307 PARAMETER (MAXCHN=10000)
28308 COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
28309
28310 DIMENSION ICHCFG(10,10,9,2),ICHTYP(5,5),
28311 & CCHTYP(9),ICHSTA(10),ITOT(10)
28312 DATA ICHCFG /1800*0/
28313 DATA (ICHTYP(1,K),K=1,5) / 0, 1, 3, 0, 0/
28314 DATA (ICHTYP(2,K),K=1,5) / 2, 0, 0, 5, 0/
28315 DATA (ICHTYP(3,K),K=1,5) / 4, 0, 0, 7, 0/
28316 DATA (ICHTYP(4,K),K=1,5) / 0, 6, 8, 0, 0/
28317 DATA (ICHTYP(5,K),K=1,5) / 0, 0, 0, 0, 9/
28318 DATA ICHSTA / 21, 22, 31, 32, 41, 42, 51, 52, 61, 62/
28319 DATA CCHTYP / ' q aq','aq q ',' q d ',' d q ','aq ad',
28320 & 'ad aq',' d ad','ad d ',' g g '/
28321*
28322* initialization
28323*
28324 IF (MODE.EQ.-1) THEN
28325 NCHAIN = 0
28326*
28327* loop over DTEVT1 and analyse chain configurations
28328*
28329 ELSEIF (MODE.EQ.0) THEN
28330 DO 21 IDX=NPOINT(3),NHKK
28331 IDCHK = IDHKK(IDX)/10000
28332 IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
28333 & (IDHKK(IDX).NE.80000).AND.
28334 & (ISTHKK(IDX).NE.2).AND.(IDRES(IDX).EQ.0)) THEN
28335 IF (JMOHKK(1,IDX).GT.JMOHKK(2,IDX)) THEN
28336 WRITE(LOUT,*) ' CHASTA: JMOHKK(1,x) > JMOHKK(2,x) ',
28337 & ' at entry ',IDX
28338 GOTO 21
28339 ENDIF
28340*
28341 IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28342 IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28343 IMO1 = IST1/10
28344 IMO1 = IST1-10*IMO1
28345 IMO2 = IST2/10
28346 IMO2 = IST2-10*IMO2
28347* swop parton entries if necessary since we need projectile partons
28348* to come first in the common
28349 IF (IMO1.GT.IMO2) THEN
28350 NPTN = JMOHKK(2,IDX)-JMOHKK(1,IDX)+1
28351 DO 22 K=1,NPTN/2
28352 I0 = JMOHKK(1,IDX)-1+K
28353 I1 = JMOHKK(2,IDX)+1-K
28354 ITMP = ISTHKK(I0)
28355 ISTHKK(I0) = ISTHKK(I1)
28356 ISTHKK(I1) = ITMP
28357 ITMP = IDHKK(I0)
28358 IDHKK(I0) = IDHKK(I1)
28359 IDHKK(I1) = ITMP
28360 IF (JDAHKK(1,JMOHKK(1,I0)).EQ.I0)
28361 & JDAHKK(1,JMOHKK(1,I0)) = I1
28362 IF (JDAHKK(2,JMOHKK(1,I0)).EQ.I0)
28363 & JDAHKK(2,JMOHKK(1,I0)) = I1
28364 IF (JDAHKK(1,JMOHKK(2,I0)).EQ.I0)
28365 & JDAHKK(1,JMOHKK(2,I0)) = I1
28366 IF (JDAHKK(2,JMOHKK(2,I0)).EQ.I0)
28367 & JDAHKK(2,JMOHKK(2,I0)) = I1
28368 IF (JDAHKK(1,JMOHKK(1,I1)).EQ.I1)
28369 & JDAHKK(1,JMOHKK(1,I1)) = I0
28370 IF (JDAHKK(2,JMOHKK(1,I1)).EQ.I1)
28371 & JDAHKK(2,JMOHKK(1,I1)) = I0
28372 IF (JDAHKK(1,JMOHKK(2,I1)).EQ.I1)
28373 & JDAHKK(1,JMOHKK(2,I1)) = I0
28374 IF (JDAHKK(2,JMOHKK(2,I1)).EQ.I1)
28375 & JDAHKK(2,JMOHKK(2,I1)) = I0
28376 ITMP = JMOHKK(1,I0)
28377 JMOHKK(1,I0) = JMOHKK(1,I1)
28378 JMOHKK(1,I1) = ITMP
28379 ITMP = JMOHKK(2,I0)
28380 JMOHKK(2,I0) = JMOHKK(2,I1)
28381 JMOHKK(2,I1) = ITMP
28382 ITMP = JDAHKK(1,I0)
28383 JDAHKK(1,I0) = JDAHKK(1,I1)
28384 JDAHKK(1,I1) = ITMP
28385 ITMP = JDAHKK(2,I0)
28386 JDAHKK(2,I0) = JDAHKK(2,I1)
28387 JDAHKK(2,I1) = ITMP
28388 DO 23 J=1,4
28389 RTMP1 = PHKK(J,I0)
28390 RTMP2 = VHKK(J,I0)
28391 RTMP3 = WHKK(J,I0)
28392 PHKK(J,I0) = PHKK(J,I1)
28393 VHKK(J,I0) = VHKK(J,I1)
28394 WHKK(J,I0) = WHKK(J,I1)
28395 PHKK(J,I1) = RTMP1
28396 VHKK(J,I1) = RTMP2
28397 WHKK(J,I1) = RTMP3
28398 23 CONTINUE
28399 RTMP1 = PHKK(5,I0)
28400 PHKK(5,I0) = PHKK(5,I1)
28401 PHKK(5,I1) = RTMP1
28402 ITMP = IDRES(I0)
28403 IDRES(I0) = IDRES(I1)
28404 IDRES(I1) = ITMP
28405 ITMP = IDXRES(I0)
28406 IDXRES(I0) = IDXRES(I1)
28407 IDXRES(I1) = ITMP
28408 ITMP = NOBAM(I0)
28409 NOBAM(I0) = NOBAM(I1)
28410 NOBAM(I1) = ITMP
28411 ITMP = IDBAM(I0)
28412 IDBAM(I0) = IDBAM(I1)
28413 IDBAM(I1) = ITMP
28414 ITMP = IDCH(I0)
28415 IDCH(I0) = IDCH(I1)
28416 IDCH(I1) = ITMP
28417 ITMP = IHIST(1,I0)
28418 IHIST(1,I0) = IHIST(1,I1)
28419 IHIST(1,I1) = ITMP
28420 ITMP = IHIST(2,I0)
28421 IHIST(2,I0) = IHIST(2,I1)
28422 IHIST(2,I1) = ITMP
28423 22 CONTINUE
28424 ENDIF
28425 IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28426 IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28427*
28428* parton 1 (projectile side)
28429 IF (IST1.EQ.21) THEN
28430 IDX1 = 1
28431 ELSEIF (IST1.EQ.22) THEN
28432 IDX1 = 2
28433 ELSEIF (IST1.EQ.31) THEN
28434 IDX1 = 3
28435 ELSEIF (IST1.EQ.32) THEN
28436 IDX1 = 4
28437 ELSEIF (IST1.EQ.41) THEN
28438 IDX1 = 5
28439 ELSEIF (IST1.EQ.42) THEN
28440 IDX1 = 6
28441 ELSEIF (IST1.EQ.51) THEN
28442 IDX1 = 7
28443 ELSEIF (IST1.EQ.52) THEN
28444 IDX1 = 8
28445 ELSEIF (IST1.EQ.61) THEN
28446 IDX1 = 9
28447 ELSEIF (IST1.EQ.62) THEN
28448 IDX1 = 10
28449 ELSE
28450c WRITE(LOUT,*)
28451c & ' CHASTA: unknown parton status flag (',
28452c & IST1,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28453 GOTO 21
28454 ENDIF
28455 ID = IDHKK(JMOHKK(1,IDX))
28456 IF (ABS(ID).LE.4) THEN
28457 IF (ID.GT.0) THEN
28458 ITYP1 = 1
28459 ELSE
28460 ITYP1 = 2
28461 ENDIF
28462 ELSEIF (ABS(ID).GE.1000) THEN
28463 IF (ID.GT.0) THEN
28464 ITYP1 = 3
28465 ELSE
28466 ITYP1 = 4
28467 ENDIF
28468 ELSEIF (ID.EQ.21) THEN
28469 ITYP1 = 5
28470 ELSE
28471 WRITE(LOUT,*)
28472 & ' CHASTA: inconsistent parton identity (',
28473 & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28474 GOTO 21
28475 ENDIF
28476*
28477* parton 2 (target side)
28478 IF (IST2.EQ.21) THEN
28479 IDX2 = 1
28480 ELSEIF (IST2.EQ.22) THEN
28481 IDX2 = 2
28482 ELSEIF (IST2.EQ.31) THEN
28483 IDX2 = 3
28484 ELSEIF (IST2.EQ.32) THEN
28485 IDX2 = 4
28486 ELSEIF (IST2.EQ.41) THEN
28487 IDX2 = 5
28488 ELSEIF (IST2.EQ.42) THEN
28489 IDX2 = 6
28490 ELSEIF (IST2.EQ.51) THEN
28491 IDX2 = 7
28492 ELSEIF (IST2.EQ.52) THEN
28493 IDX2 = 8
28494 ELSEIF (IST2.EQ.61) THEN
28495 IDX2 = 9
28496 ELSEIF (IST2.EQ.62) THEN
28497 IDX2 = 10
28498 ELSE
28499c WRITE(LOUT,*)
28500c & ' CHASTA: unknown parton status flag (',
28501c & IST2,') at entry ',JMOHKK(2,IDX),'(',IDX,')'
28502 GOTO 21
28503 ENDIF
28504 ID = IDHKK(JMOHKK(2,IDX))
28505 IF (ABS(ID).LE.4) THEN
28506 IF (ID.GT.0) THEN
28507 ITYP2 = 1
28508 ELSE
28509 ITYP2 = 2
28510 ENDIF
28511 ELSEIF (ABS(ID).GE.1000) THEN
28512 IF (ID.GT.0) THEN
28513 ITYP2 = 3
28514 ELSE
28515 ITYP2 = 4
28516 ENDIF
28517 ELSEIF (ID.EQ.21) THEN
28518 ITYP2 = 5
28519 ELSE
28520 WRITE(LOUT,*)
28521 & ' CHASTA: inconsistent parton identity (',
28522 & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28523 GOTO 21
28524 ENDIF
28525*
28526* fill counter
28527 ITYPE = ICHTYP(ITYP1,ITYP2)
28528 IF (ITYPE.NE.0) THEN
28529 ICHCFG(IDX1,IDX2,ITYPE,1) =ICHCFG(IDX1,IDX2,ITYPE,1)+1
28530 NGLUON = JMOHKK(2,IDX)-JMOHKK(1,IDX)-1
28531 ICHCFG(IDX1,IDX2,ITYPE,2) =
28532 & ICHCFG(IDX1,IDX2,ITYPE,2)+NGLUON
28533
28534 NCHAIN = NCHAIN+1
28535 IF (NCHAIN.GT.MAXCHN) THEN
28536 WRITE(LOUT,*) ' CHASTA: NCHAIN > MAXCHN ! ',
28537 & NCHAIN,MAXCHN
28538 STOP
28539 ENDIF
28540 IDXCHN(1,NCHAIN) = IDX
28541 IDXCHN(2,NCHAIN) = ITYPE
28542 ELSE
28543 WRITE(LOUT,*)
28544 & ' CHASTA: inconsistent chain at entry ',IDX
28545 GOTO 21
28546 ENDIF
28547 ENDIF
28548 21 CONTINUE
28549*
28550* write statistics to output unit
28551*
28552 ELSEIF (MODE.EQ.1) THEN
28553 WRITE(LOUT,'(/,A)') ' CHASTA: generated chain configurations'
28554 DO 31 I=1,10
28555 WRITE(LOUT,'(/,2A)')
28556 & ' -----------------------------------------',
28557 & '------------------------------------'
28558 WRITE(LOUT,'(2A)')
28559 & ' p\\t 21 22 31 32 41',
28560 & ' 42 51 52 61 62'
28561 WRITE(LOUT,'(2A)')
28562 & ' -----------------------------------------',
28563 & '------------------------------------'
28564 DO 32 J=1,10
28565 ITOT(J) = 0
28566 DO 33 K=1,9
28567 ITOT(J) = ITOT(J)+ICHCFG(I,J,K,1)
28568 33 CONTINUE
28569 32 CONTINUE
28570 WRITE(LOUT,'(1X,I2,5X,10I7,/)') ICHSTA(I),(ITOT(J),J=1,10)
28571 DO 34 K=1,9
28572 ISUM = 0
28573 DO 35 J=1,10
28574 ISUM = ISUM+ICHCFG(I,J,K,1)
28575 35 CONTINUE
28576 IF (ISUM.GT.0)
28577 & WRITE(LOUT,'(1X,A5,2X,10I7)')
28578 & CCHTYP(K),(ICHCFG(I,J,K,1),J=1,10)
28579 34 CONTINUE
28580C WRITE(LOUT,'(2A)')
28581C & ' -----------------------------------------',
28582C & '-------------------------------'
28583 31 CONTINUE
28584*
28585 ELSE
28586 WRITE(LOUT,*) ' CHASTA: MODE ',MODE,' not supported !'
28587 STOP
28588 ENDIF
28589
28590 RETURN
28591 END
28592*$ CREATE PHO_PHIST.FOR
28593*COPY PHO_PHIST
28594*
28595*===pohist=============================================================*
28596*
28597 SUBROUTINE PHO_PHIST(IMODE,WEIGHT)
28598
28599 IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28600 SAVE
28601
28602 PARAMETER ( LINP = 10 ,
28603 & LOUT = 6 ,
28604 & LDAT = 9 )
28605 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
28606* Glauber formalism: cross sections
28607 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
28608 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
28609 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
28610 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
28611 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
28612 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
28613 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
28614 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
28615 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
28616 & BSLOPE,NEBINI,NQBINI
28617
28618 ILAB = 0
28619 IF (IMODE.EQ.10) THEN
28620 IMODE = 1
28621 ILAB = 1
28622 ENDIF
28623 IF (ABS(IMODE).LT.1000) THEN
28624* PHOJET-statistics
28625C CALL POHISX(IMODE,WEIGHT)
28626 IF (IMODE.EQ.-1) THEN
28627 MODE = 1
28628 XSTOT(1,1,1) = WEIGHT
28629 ENDIF
28630 IF (IMODE.EQ. 1) MODE = 2
28631 IF (IMODE.EQ.-2) MODE = 3
28632 IF (MODE.EQ.2) CALL DT_SWPPHO(ILAB)
28633C IF (MODE.EQ.3) WRITE(LOUT,*)
28634C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization'
28635 CALL DT_HISTOG(MODE)
28636 CALL DT_USRHIS(MODE)
28637 ELSE
28638* DTUNUC-statistics
28639 MODE = IMODE/1000
28640C IF (MODE.EQ.3) WRITE(LOUT,*)
28641C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization'
28642 CALL DT_HISTOG(MODE)
28643 CALL DT_USRHIS(MODE)
28644 ENDIF
28645
28646 RETURN
28647 END
28648
28649*$ CREATE DT_SWPPHO.FOR
28650*COPY DT_SWPPHO
28651*
28652*===swppho=============================================================*
28653*
28654 SUBROUTINE DT_SWPPHO(ILAB)
28655
28656 IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28657 SAVE
28658 PARAMETER ( LINP = 10 ,
28659 & LOUT = 6 ,
28660 & LDAT = 9 )
28661 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28662
28663 LOGICAL LSTART
28664
28665* event history
28666 PARAMETER (NMXHKK=200000)
28667 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28668 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28669 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28670* extended event history
28671 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28672 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28673 & IHIST(2,NMXHKK)
28674* flags for input different options
28675 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28676 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28677 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28678* properties of photon/lepton projectiles
28679 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
28680
28681**PHOJET105a
28682C PARAMETER (NMXHEP=2000)
28683C COMMON/HEPEVS/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28684C &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
28685C COMMON /GLOCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28686C COMMON /PLASAV/ PLAB
28687**PHOJET110
28688C standard particle data interface
28689 INTEGER NMXHEP
28690 PARAMETER (NMXHEP=4000)
28691 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28692 DOUBLE PRECISION PHEP,VHEP
28693 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28694 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
09b429a4 28695 & VHEP(4,NMXHEP),NSD1, NSD2, NDD
9aaba0d6 28696C extension to standard particle data interface (PHOJET specific)
28697 INTEGER IMPART,IPHIST,ICOLOR
28698 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28699C global event kinematics and particle IDs
28700 INTEGER IFPAP,IFPAB
28701 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
28702 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28703**
28704 DATA ICOUNT/0/
28705
28706 DATA LSTART /.TRUE./
28707
28708C IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0).AND.LSTART) THEN
28709 IF ((IFRAME.EQ.1).AND.LSTART) THEN
28710 UMO = ECM
28711 ELA = ZERO
28712 PLA = ZERO
28713 IDP = IDT_ICIHAD(IFPAP(1))
28714 IDT = IDT_ICIHAD(IFPAP(2))
28715 VIRT = PVIRT(1)
28716 CALL DT_LTINI(IDP,IDT,ELA,PLA,UMO,0)
28717 PLAB = PLA
28718 LSTART = .FALSE.
28719 ENDIF
28720
28721 NHKK = 0
28722 ICOUNT = ICOUNT+1
28723C NEVHKK = NEVHEP
28724 NEVHKK = ICOUNT
28725 IF (MOD(ICOUNT,500).EQ.0) WRITE(LOUT,*)' SWPPHO: event # ',ICOUNT
28726 DO 1 I=3,NHEP
28727 IF (ISTHEP(I).EQ.1) THEN
28728 NHKK = NHKK+1
28729 ISTHKK(NHKK) = 1
28730 IDHKK(NHKK) = IDHEP(I)
28731 JMOHKK(1,NHKK) = 0
28732 JMOHKK(2,NHKK) = 0
28733 JDAHKK(1,NHKK) = 0
28734 JDAHKK(2,NHKK) = 0
28735 DO 2 K=1,4
28736 PHKK(K,NHKK) = PHEP(K,I)
28737 VHKK(K,NHKK) = ZERO
28738 WHKK(K,NHKK) = ZERO
28739 2 CONTINUE
28740 IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0))
28741 & CALL DT_LTNUC(PHEP(3,I),PHEP(4,I),
28742 & PHKK(3,NHKK),PHKK(4,NHKK),-3)
28743 PHKK(5,NHKK) = PHEP(5,I)
28744 IDRES(NHKK) = 0
28745 IDXRES(NHKK) = 0
28746 NOBAM(NHKK) = 0
28747 IDBAM(NHKK) = IDT_ICIHAD(IDHEP(I))
28748 IDCH(NHKK) = 0
28749 ENDIF
28750 1 CONTINUE
28751
28752 RETURN
28753 END
28754
28755*$ CREATE DT_HISTOG.FOR
28756*COPY DT_HISTOG
28757*
28758*===histog=============================================================*
28759*
28760 SUBROUTINE DT_HISTOG(MODE)
28761
28762************************************************************************
28763* This version dated 25.03.96 is written by S. Roesler *
28764************************************************************************
28765
28766 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28767 SAVE
28768 PARAMETER ( LINP = 10 ,
28769 & LOUT = 6 ,
28770 & LDAT = 9 )
28771
28772 LOGICAL LFSP,LRNL
28773
28774* event history
28775 PARAMETER (NMXHKK=200000)
28776 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28777 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28778 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28779* extended event history
28780 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28781 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28782 & IHIST(2,NMXHKK)
28783* event flag used for histograms
28784 COMMON /DTNORM/ ICEVT,IEVHKK
28785* flags for activated histograms
28786 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
28787
28788 IEVHKK = NEVHKK
28789 GOTO (1,2,3) MODE
28790
28791*------------------------------------------------------------------
28792* initialization
28793 1 CONTINUE
28794 ICEVT = 0
28795 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,1)
28796 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(1)
28797
28798 RETURN
28799*------------------------------------------------------------------
28800* filling of histogram with event-record
28801 2 CONTINUE
28802 ICEVT = ICEVT+1
28803
28804 DO 20 I=1,NHKK
28805 CALL DT_SWPFSP(I,LFSP,LRNL)
28806 IF (LFSP) THEN
28807 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,2)
28808 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(2)
28809 ENDIF
28810 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,5)
28811 20 CONTINUE
28812 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,4)
28813
28814 RETURN
28815*------------------------------------------------------------------
28816* output
28817 3 CONTINUE
28818 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,3)
28819 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(3)
28820
28821 RETURN
28822 END
28823
28824*$ CREATE DT_SWPFSP.FOR
28825*COPY DT_SWPFSP
28826*
28827*===swpfsp=============================================================*
28828*
28829 SUBROUTINE DT_SWPFSP(IDX,LFSP,LRNL)
28830
28831 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28832 SAVE
28833 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28834 PARAMETER (TWOPI=6.283185307179586476925286766559D+00,
28835 & PI =TWOPI/TWO,
28836 & BOG =TWOPI/360.0D0)
28837
28838* event history
28839 PARAMETER (NMXHKK=200000)
28840 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28841 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28842 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28843* extended event history
28844 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28845 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28846 & IHIST(2,NMXHKK)
28847* particle properties (BAMJET index convention)
28848 CHARACTER*8 ANAME
28849 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28850 & IICH(210),IIBAR(210),K1(210),K2(210)
28851* Lorentz-parameters of the current interaction
28852 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28853 & UMO,PPCM,EPROJ,PPROJ
28854* flags for input different options
28855 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28856 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28857 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28858* (original name: PAREVT)
28859 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
28860 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
28861 PARAMETER ( NALLWP = 39 )
28862 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
28863 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
28864 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
28865 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
28866* temporary storage for one final state particle
28867 LOGICAL LFRAG,LGREY,LBLACK
28868 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
28869 & SINTHE,COSTHE,THETA,THECMS,
28870 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
28871 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
28872 & LFRAG,LGREY,LBLACK
28873
28874 LOGICAL LFSP,LRNL
28875
28876 LFSP = .FALSE.
28877 LRNL = .FALSE.
28878 ISTRNL = 1000
28879 MULDEF = 1
28880 IF (LEVPRT) ISTRNL = 1001
28881
28882 IF (ABS(ISTHKK(IDX)).EQ.1) THEN
28883 IST = ISTHKK(IDX)
28884 IDPDG = IDHKK(IDX)
28885 LFRAG = .FALSE.
28886 IF (IDHKK(IDX).LT.80000) THEN
28887 IDBJT = IDBAM(IDX)
28888 IBARY = IIBAR(IDBJT)
28889 ICHAR = IICH(IDBJT)
28890 AMASS = AAM(IDBJT)
28891 ELSEIF (IDHKK(IDX).EQ.80000) THEN
28892 IDBJT = 0
28893 IBARY = IDRES(IDX)
28894 ICHAR = IDXRES(IDX)
28895 AMASS = PHKK(5,IDX)
28896 INUT = IBARY-ICHAR
28897 IF ((ICHAR.EQ.1).AND.(INUT.EQ.1)) IDBJT = 116
28898 IF ((ICHAR.EQ.1).AND.(INUT.EQ.2)) IDBJT = 117
28899 IF ((ICHAR.EQ.2).AND.(INUT.EQ.1)) IDBJT = 118
28900 IF ((ICHAR.EQ.2).AND.(INUT.EQ.2)) IDBJT = 119
28901 IF (IDBJT.EQ.0) LFRAG = .TRUE.
28902 ELSE
28903 GOTO 9999
28904 ENDIF
28905 PE = PHKK(4,IDX)
28906 PX = PHKK(1,IDX)
28907 PY = PHKK(2,IDX)
28908 PZ = PHKK(3,IDX)
28909 PT2 = PX**2+PY**2
28910 PT = SQRT(PT2)
28911 PTOT = SQRT(PT2+PZ**2)
28912 SINTHE = PT/MAX(PTOT,TINY14)
28913 COSTHE = PZ/MAX(PTOT,TINY14)
28914 IF (COSTHE.GT.ONE) THEN
28915 THETA = ZERO
28916 ELSEIF (COSTHE.LT.-ONE) THEN
28917 THETA = TWOPI/2.0D0
28918 ELSE
28919 THETA = ACOS(COSTHE)
28920 ENDIF
28921 EKIN = PE-AMASS
28922**sr 15.4.96 new E_t-definition
28923 IF (IBARY.GT.0) THEN
28924 ET = EKIN*SINTHE
28925 ELSEIF (IBARY.LT.0) THEN
28926 ET = (EKIN+TWO*AMASS)*SINTHE
28927 ELSE
28928 ET = PE*SINTHE
28929 ENDIF
28930**
28931 XLAB = PZ/MAX(PPROJ,TINY14)
28932C XLAB = PE/MAX(EPROJ,TINY14)
28933 BETA = SQRT(ABS( (ONE-AMASS/MAX(PE,TINY14))
28934 & *(ONE+AMASS/MAX(PE,TINY14)) ))
28935 PPLUS = PE+PZ
28936 PMINUS = PE-PZ
28937 IF (PMINUS.GT.TINY14) THEN
28938 YY = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28939 ELSE
28940 YY = 100.0D0
28941 ENDIF
28942 IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
28943 ETA = -LOG(TAN(THETA/TWO))
28944 ELSE
28945 ETA = 100.0D0
28946 ENDIF
28947 IF (IFRAME.EQ.1) THEN
28948 CALL DT_LTNUC(PZ,PE,PZCMS,EECMS,3)
28949 PPLUS = EECMS+PZCMS
28950 PMINUS = EECMS-PZCMS
28951 IF ((PPLUS*PMINUS).GT.TINY14) THEN
28952 YYCMS = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28953 ELSE
28954 YYCMS = 100.0D0
28955 ENDIF
28956 PTOTCM = SQRT(PT2+PZCMS**2)
28957 COSTH = PZCMS/MAX(PTOTCM,TINY14)
28958 IF (COSTH.GT.ONE) THEN
28959 THECMS = ZERO
28960 ELSEIF (COSTH.LT.-ONE) THEN
28961 THECMS = TWOPI/2.0D0
28962 ELSE
28963 THECMS = ACOS(COSTH)
28964 ENDIF
28965 IF ((THECMS.GT.TINY14).AND.((PI-THECMS).GT.TINY14)) THEN
28966 ETACMS = -LOG(TAN(THECMS/TWO))
28967 ELSE
28968 ETACMS = 100.0D0
28969 ENDIF
28970 XF = PZCMS/MAX(PPCM,TINY14)
28971 THECMS = THECMS/BOG
28972 ELSE
28973 PZCMS = PZ
28974 EECMS = PE
28975 YYCMS = YY
28976 ETACMS = ETA
28977 XF = XLAB
28978 THECMS = THETA/BOG
28979 ENDIF
28980 THETA = THETA/BOG
28981
28982* set flag for "grey/black"
28983 LGREY = .FALSE.
28984 LBLACK = .FALSE.
28985 EK = EKIN
28986 IF (IDHKK(IDX).EQ.80000) EK = EKIN/DBLE(IBARY)
28987 IF (MULDEF.EQ.1) THEN
28988* EMU01-Def.
28989 IF ( ( (IDBJT.EQ. 1).AND.(EK.GT. 26.0D-3).AND.
28990 & (EK.LE.375.0D-3) ).OR.
28991 & ( (IDBJT.EQ.13).AND.(EK.GT. 12.0D-3).AND.
28992 & (EK.LE. 56.0D-3) ).OR.
28993 & ( (IDBJT.EQ.14).AND.(EK.GT. 12.0D-3).AND.
28994 & (EK.LE. 56.0D-3) ).OR.
28995 & ( (IDBJT.EQ.15).AND.(EK.GT. 20.0D-3).AND.
28996 & (EK.LE.198.0D-3) ).OR.
28997 & ( (IDBJT.EQ.16).AND.(EK.GT. 20.0D-3).AND.
28998 & (EK.LE.198.0D-3) ).OR.
28999 & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
29000 & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
29001 & (IDBJT.NE.16).AND.
29002 & (BETA.GT.0.23D0).AND.(BETA.LE.0.70D0) ) )
29003 & LGREY = .TRUE.
29004 IF ( ( (IDBJT.EQ. 1).AND.(EK.LE. 26.0D-3) ).OR.
29005 & ( (IDBJT.EQ.13).AND.(EK.LE. 12.0D-3) ).OR.
29006 & ( (IDBJT.EQ.14).AND.(EK.LE. 12.0D-3) ).OR.
29007 & ( (IDBJT.EQ.15).AND.(EK.LE. 20.0D-3) ).OR.
29008 & ( (IDBJT.EQ.16).AND.(EK.LE. 20.0D-3) ).OR.
29009 & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
29010 & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
29011 & (IDBJT.NE.16).AND.(BETA.LE.0.23D0) ) )
29012 & LBLACK = .TRUE.
29013 ELSE
29014* common Def.
29015 IF ((BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)) LGREY=.TRUE.
29016 IF (BETA.LE.0.23D0) LBLACK=.TRUE.
29017 ENDIF
29018 LFSP = .TRUE.
29019 ELSEIF (ABS(ISTHKK(IDX)).EQ.ISTRNL) THEN
29020 IST = ISTHKK(IDX)
29021 IDPDG = IDHKK(IDX)
29022 LFRAG = .TRUE.
29023 IDBJT = 0
29024 IBARY = IDRES(IDX)
29025 ICHAR = IDXRES(IDX)
29026 AMASS = PHKK(5,IDX)
29027 PE = PHKK(4,IDX)
29028 PX = PHKK(1,IDX)
29029 PY = PHKK(2,IDX)
29030 PZ = PHKK(3,IDX)
29031 PT2 = PX**2+PY**2
29032 PT = SQRT(PT2)
29033 PTOT = SQRT(PT2+PZ**2)
29034 SINTHE = PT/MAX(PTOT,TINY14)
29035 COSTHE = PZ/MAX(PTOT,TINY14)
29036 IF (COSTHE.GT.ONE) THEN
29037 THETA = ZERO
29038 ELSEIF (COSTHE.LT.-ONE) THEN
29039 THETA = TWOPI/2.0D0
29040 ELSE
29041 THETA = ACOS(COSTHE)
29042 ENDIF
29043 EKIN = PE-AMASS
29044**sr 15.4.96 new E_t-definition
29045C ET = PE*SINTHE
29046 ET = EKIN*SINTHE
29047**
29048 IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
29049 ETA = -LOG(TAN(THETA/TWO))
29050 ELSE
29051 ETA = 100.0D0
29052 ENDIF
29053 THETA = THETA/BOG
29054 LRNL = .TRUE.
29055 ENDIF
29056
29057 9999 CONTINUE
29058 RETURN
29059 END
29060
29061*$ CREATE DT_HIMULT.FOR
29062*COPY DT_HIMULT
29063*
29064*===himult=============================================================*
29065*
29066 SUBROUTINE DT_HIMULT(MODE)
29067
29068************************************************************************
29069* Tables of average energies/multiplicities. *
29070* This version dated 30.08.2000 is written by S. Roesler *
29071************************************************************************
29072
29073 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29074 SAVE
29075 PARAMETER ( LINP = 10 ,
29076 & LOUT = 6 ,
29077 & LDAT = 9 )
29078 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
29079
29080 PARAMETER (SWMEXP=1.7D0)
29081
29082 CHARACTER*8 ANAMEH(4)
29083
29084* particle properties (BAMJET index convention)
29085 CHARACTER*8 ANAME
29086 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29087 & IICH(210),IIBAR(210),K1(210),K2(210)
29088* temporary storage for one final state particle
29089 LOGICAL LFRAG,LGREY,LBLACK
29090 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
29091 & SINTHE,COSTHE,THETA,THECMS,
29092 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
29093 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
29094 & LFRAG,LGREY,LBLACK
29095* event flag used for histograms
29096 COMMON /DTNORM/ ICEVT,IEVHKK
29097* Lorentz-parameters of the current interaction
29098 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
29099 & UMO,PPCM,EPROJ,PPROJ
29100
29101 PARAMETER (NOPART=210)
29102 DIMENSION AVMULT(4,NOPART),AVE(4,NOPART),AVSWM(4,NOPART),
29103 & AVPT(4,NOPART),IAVPT(4,NOPART)
29104 DATA ANAMEH /'DEUTERON','3-H ','3-HE ','4-HE '/
29105
29106 GOTO (1,2,3) MODE
29107
29108*------------------------------------------------------------------
29109* initialization
29110 1 CONTINUE
29111 DO 10 I=1,NOPART
29112 DO 11 J=1,4
29113 AVMULT(J,I) = ZERO
29114 AVE(J,I) = ZERO
29115 AVSWM(J,I) = ZERO
29116 AVPT(J,I) = ZERO
29117 IAVPT(J,I) = 0
29118 11 CONTINUE
29119 10 CONTINUE
29120
29121 RETURN
29122
29123*------------------------------------------------------------------
29124* filling of histogram with event-record
29125 2 CONTINUE
29126 IF (PE.LT.0.0D0) THEN
29127 WRITE(LOUT,*) ' HIMULT: PE < 0 ! ',PE
29128 RETURN
29129 ENDIF
29130 IF (.NOT.LFRAG) THEN
29131 IVEL = 2
29132 IF (LGREY) IVEL = 3
29133 IF (LBLACK) IVEL = 4
29134 AVE(1,IDBJT) = AVE(1,IDBJT) +PE
29135 AVE(IVEL,IDBJT) = AVE(IVEL,IDBJT)+PE
29136 AVPT(1,IDBJT) = AVPT(1,IDBJT) +PT
29137 AVPT(IVEL,IDBJT) = AVPT(IVEL,IDBJT)+PT
29138 IAVPT(1,IDBJT) = IAVPT(1,IDBJT) +1
29139 IAVPT(IVEL,IDBJT) = IAVPT(IVEL,IDBJT)+1
29140 AVSWM(1,IDBJT) = AVSWM(1,IDBJT) +PE**SWMEXP
29141 AVSWM(IVEL,IDBJT) = AVSWM(IVEL,IDBJT)+PE**SWMEXP
29142 AVMULT(1,IDBJT) = AVMULT(1,IDBJT) +ONE
29143 AVMULT(IVEL,IDBJT) = AVMULT(IVEL,IDBJT)+ONE
29144 IF (IDBJT.LT.116) THEN
29145* total energy, multiplicity
29146 AVE(1,30) = AVE(1,30) +PE
29147 AVE(IVEL,30) = AVE(IVEL,30)+PE
29148 AVPT(1,30) = AVPT(1,30) +PT
29149 AVPT(IVEL,30) = AVPT(IVEL,30)+PT
29150 IAVPT(1,30) = IAVPT(1,30) +1
29151 IAVPT(IVEL,30) = IAVPT(IVEL,30)+1
29152 AVSWM(1,30) = AVSWM(1,30)+PE**SWMEXP
29153 AVSWM(IVEL,30) = AVSWM(IVEL,30)+PE**SWMEXP
29154 AVMULT(1,30) = AVMULT(1,30) +ONE
29155 AVMULT(IVEL,30) = AVMULT(IVEL,30)+ONE
29156* charged energy, multiplicity
29157 IF (ICHAR.LT.0) THEN
29158 AVE(1,26) = AVE(1,26) +PE
29159 AVE(IVEL,26) = AVE(IVEL,26)+PE
29160 AVPT(1,26) = AVPT(1,26) +PT
29161 AVPT(IVEL,26) = AVPT(IVEL,26)+PT
29162 IAVPT(1,26) = IAVPT(1,26) +1
29163 IAVPT(IVEL,26) = IAVPT(IVEL,26)+1
29164 AVSWM(1,26) = AVSWM(1,26) +PE**SWMEXP
29165 AVSWM(IVEL,26) = AVSWM(IVEL,26)+PE**SWMEXP
29166 AVMULT(1,26) = AVMULT(1,26) +ONE
29167 AVMULT(IVEL,26) = AVMULT(IVEL,26)+ONE
29168 ENDIF
29169 IF (ICHAR.NE.0) THEN
29170 AVE(1,27) = AVE(1,27) +PE
29171 AVE(IVEL,27) = AVE(IVEL,27)+PE
29172 AVPT(1,27) = AVPT(1,27) +PT
29173 AVPT(IVEL,27) = AVPT(IVEL,27)+PT
29174 IAVPT(1,27) = IAVPT(1,27) +1
29175 IAVPT(IVEL,27) = IAVPT(IVEL,27)+1
29176 AVSWM(1,27) = AVSWM(1,27) +PE**SWMEXP
29177 AVSWM(IVEL,27) = AVSWM(IVEL,27)+PE**SWMEXP
29178 AVMULT(1,27) = AVMULT(1,27) +ONE
29179 AVMULT(IVEL,27) = AVMULT(IVEL,27)+ONE
29180 ENDIF
29181 ENDIF
29182 ENDIF
29183
29184 RETURN
29185
29186*------------------------------------------------------------------
29187* output
29188 3 CONTINUE
29189 WRITE(LOUT,3000)
29190 3000 FORMAT(/,1X,'HIMULT:',21X,'particle - statistics',/,
29191 & 29X,'---------------------',/)
29192 IF (MULDEF.EQ.1) THEN
29193 WRITE(LOUT,'(1X,A,/)') 'fast/grey/black: EMU-def.'
29194 ELSE
29195 BETGRE = 0.7D0
29196 BETBLC = 0.23D0
29197 WRITE(LOUT,3002) BETGRE,BETGRE,BETBLC,BETBLC
29198 3002 FORMAT(1X,'fast: beta > ',F4.2,' grey: ',F4.2,' > beta > '
29199 & ,F4.2,' black: beta < ',F4.2,/)
29200 ENDIF
29201 WRITE(LOUT,3003) SWMEXP
29202 3003 FORMAT(1X,'particle |',12X,'average multiplicity',/,
29203 & 13X,'| total fast',
29204C & ' grey black K f(',F3.1,')',/,1X,
29205 & ' grey black <pt> f(',F3.1,')',/,1X,
29206 & '------------+--------------',
29207 & '-------------------------------------------------')
29208 DO 30 I=1,NOPART
29209 DO 31 J=1,4
29210 AVMULT(J,I) = AVMULT(J,I)/DBLE(MAX(ICEVT,1))
29211 AVE(J,I) = AVE(J,I)/DBLE(MAX(ICEVT,1))/EPROJ
29212 AVPT(J,I) = AVPT(J,I)/DBLE(MAX(IAVPT(J,I),1))
29213 AVSWM(J,I) = AVSWM(J,I)/DBLE(MAX(ICEVT,1))/EPROJ**SWMEXP
29214 31 CONTINUE
29215 IF (I.LE.115) THEN
29216 WRITE(LOUT,3004) ANAME(I),I,
29217 & AVMULT(1,I),AVMULT(2,I),
29218 & AVMULT(3,I),AVMULT(4,I),
29219C & AVE(1,I),AVSWM(1,I)
29220 & AVPT(1,I),AVSWM(1,I)
29221 ELSEIF (I.LE.119) THEN
29222 WRITE(LOUT,3004) ANAMEH(I-115),I,
29223 & AVMULT(1,I),AVMULT(2,I),
29224 & AVMULT(3,I),AVMULT(4,I),
29225C & AVE(1,I),AVSWM(1,I)
29226 & AVPT(1,I),AVSWM(1,I)
29227 ENDIF
29228 3004 FORMAT(1X,A8,I4,'| ',2F13.6,2F9.5,2F9.5)
29229 30 CONTINUE
29230**temporary
29231C WRITE(LOUT,'(A,F7.3)') ' number of charged heavy particles: ',
29232C & AVMULT(3,27)+AVMULT(4,27)
29233**
29234
29235 RETURN
29236 END
29237
29238*$ CREATE DT_HISTAT.FOR
29239*COPY DT_HISTAT
29240*
29241*===histat=============================================================*
29242*
29243 SUBROUTINE DT_HISTAT(IDX,MODE)
29244
29245************************************************************************
29246* This version dated 26.02.96 is written by S. Roesler *
29247* *
29248* Last change 27.12.2006 by S. Roesler. *
29249************************************************************************
29250
29251 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29252 SAVE
29253 PARAMETER ( LINP = 10 ,
29254 & LOUT = 6 ,
29255 & LDAT = 9 )
29256 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
29257 PARAMETER (NDIM=199)
29258
29259* event history
29260 PARAMETER (NMXHKK=200000)
29261 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
29262 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
29263 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
29264* extended event history
29265 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
29266 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
29267 & IHIST(2,NMXHKK)
29268* particle properties (BAMJET index convention)
29269 CHARACTER*8 ANAME
29270 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29271 & IICH(210),IIBAR(210),K1(210),K2(210)
29272 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
29273* Glauber formalism: cross sections
29274 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
29275 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
29276 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
29277 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
29278 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
29279 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
29280 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
29281 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
29282 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
29283 & BSLOPE,NEBINI,NQBINI
29284* emulsion treatment
29285 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
29286 & NCOMPO,IEMUL
29287* properties of interacting particles
29288 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
29289* rejection counter
29290 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
29291 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
29292 & IREXCI(3),IRDIFF(2),IRINC
29293* statistics: residual nuclei
29294 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
29295 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
29296 & NINCST(2,4),NINCEV(2),
29297 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
29298 & NRESPB(2),NRESCH(2),NRESEV(4),
29299 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
29300 & NEVAFI(2,2)
29301* parameter for intranuclear cascade
29302 LOGICAL LPAULI
29303 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
29304* (original name: PAREVT)
29305 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
29306 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
29307 PARAMETER ( NALLWP = 39 )
29308 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
29309 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
29310 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
29311 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
29312* (original name: FRBKCM)
29313 PARAMETER ( MXFFBK = 6 )
29314 PARAMETER ( MXZFBK = 9 )
29315 PARAMETER ( MXNFBK = 10 )
29316 PARAMETER ( MXAFBK = 16 )
29317 PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
29318 PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
29319 PARAMETER ( NXAFBK = MXAFBK + 1 )
29320 PARAMETER ( MXPSST = 300 )
29321 PARAMETER ( MXPSFB = 41000 )
29322 LOGICAL LFRMBK, LNCMSS
29323 COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
29324 & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
29325 & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
29326 & IFRBKN (MXPSST), IFRBKZ (MXPSST),
29327 & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
29328 & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
29329 & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
29330 & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
29331 & IFBFRB, NBUFBK, LFRMBK, LNCMSS
29332* (original name: INPFLG)
29333 COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
29334* temporary storage for one final state particle
29335 LOGICAL LFRAG,LGREY,LBLACK
29336 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
29337 & SINTHE,COSTHE,THETA,THECMS,
29338 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
29339 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
29340 & LFRAG,LGREY,LBLACK
29341* event flag used for histograms
29342 COMMON /DTNORM/ ICEVT,IEVHKK
29343* statistics: double-Pomeron exchange
29344 COMMON /DTFLG2/ INTFLG,IPOPO
29345
29346 DIMENSION EMUSAM(NCOMPX)
29347
29348 CHARACTER*13 CMSG(3)
29349 DATA CMSG /'not requested','not requested','not requested'/
29350
29351 GOTO (1,2,3,4,5) MODE
29352
29353*------------------------------------------------------------------
29354* initialization
29355 1 CONTINUE
29356* emulsion treatment
29357 IF (NCOMPO.GT.0) THEN
29358 DO 10 I=1,NCOMPX
29359 EMUSAM(I) = ZERO
29360 10 CONTINUE
29361 ENDIF
29362* common /DTSTA2/, statistics on i.n.c., residual nuclei, evap.
29363 NINCGE = 0
29364 DO 11 I=1,2
29365 EXCDPM(I) = ZERO
29366 EXCDPM(I+2) = ZERO
29367 EXCEVA(I) = ZERO
29368 NINCWO(I) = 0
29369 NINCEV(I) = 0
29370 NRESTO(I) = 0
29371 NRESPR(I) = 0
29372 NRESNU(I) = 0
29373 NRESBA(I) = 0
29374 NRESPB(I) = 0
29375 NRESCH(I) = 0
29376 NRESEV(I) = 0
29377 NRESEV(I+2) = 0
29378 NEVAGA(I) = 0
29379 NEVAHT(I) = 0
29380 NEVAFI(1,I) = 0
29381 NEVAFI(2,I) = 0
29382 DO 12 J=1,6
29383 IF (J.LE.2) NINCHR(I,J) = 0
29384 IF (J.LE.3) NINCCO(I,J) = 0
29385 IF (J.LE.4) NINCST(I,J) = 0
29386 NEVA(I,J) = 0
29387 12 CONTINUE
29388 DO 13 J=1,210
29389 NEVAHY(1,I,J) = 0
29390 NEVAHY(2,I,J) = 0
29391 13 CONTINUE
29392 11 CONTINUE
29393 MAXGEN = 0
29394**dble Po statistics.
29395 KPOPO = 0
29396
29397 RETURN
29398*------------------------------------------------------------------
29399* filling of histogram with event-record
29400 2 CONTINUE
29401 IF (IST.EQ.-1) THEN
29402 IF (.NOT.LFRAG) THEN
29403 IF (IDPDG.EQ.2212) THEN
29404 NEVA(NOBAM(IDX),1) = NEVA(NOBAM(IDX),1)+1
29405 ELSEIF (IDPDG.EQ.2112) THEN
29406 NEVA(NOBAM(IDX),2) = NEVA(NOBAM(IDX),2)+1
29407 ELSEIF (IDPDG.EQ.22) THEN
29408 NEVAGA(NOBAM(IDX)) = NEVAGA(NOBAM(IDX))+1
29409 ELSEIF (IDPDG.EQ.80000) THEN
29410 IF (IDBJT.EQ.116) THEN
29411 NEVA(NOBAM(IDX),3) = NEVA(NOBAM(IDX),3)+1
29412 ELSEIF (IDBJT.EQ.117) THEN
29413 NEVA(NOBAM(IDX),4) = NEVA(NOBAM(IDX),4)+1
29414 ELSEIF (IDBJT.EQ.118) THEN
29415 NEVA(NOBAM(IDX),5) = NEVA(NOBAM(IDX),5)+1
29416 ELSEIF (IDBJT.EQ.119) THEN
29417 NEVA(NOBAM(IDX),6) = NEVA(NOBAM(IDX),6)+1
29418 ENDIF
29419 ENDIF
29420 ELSE
29421* heavy fragments (here: fission products only)
29422 NEVAHY(NOBAM(IDX),1,IBARY) = NEVAHY(NOBAM(IDX),1,IBARY)+1
29423 NEVAHY(NOBAM(IDX),2,ICHAR) = NEVAHY(NOBAM(IDX),2,ICHAR)+1
29424 NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29425 ENDIF
29426 ELSEIF ((IST.EQ.1).AND.(.NOT.LFRAG)) THEN
29427 IF (IDCH(IDX).GT.MAXGEN) MAXGEN = IDCH(IDX)
29428 ENDIF
29429
29430 RETURN
29431*------------------------------------------------------------------
29432* output
29433 3 CONTINUE
29434
29435**dble Po statistics.
29436C WRITE(LOUT,'(1X,A,2I7,2E12.4)')
29437C & '# evts. / # dble-Po. evts / s_in / s_popo :',
29438C & ICEVT,KPOPO,XSPRO(1,1,1),XSPRO(1,1,1)*DBLE(KPOPO)/DBLE(ICEVT)
29439
29440* emulsion treatment
29441 IF (NCOMPO.GT.0) THEN
29442 WRITE(LOUT,3000)
29443 3000 FORMAT(/,1X,'HISTAT:',14X,'statistics - target emulsion',/,
29444 & 22X,'----------------------------',/,/,19X,
29445 & 'mass charge fraction',/,39X,
29446 & 'input treated',/)
29447 DO 30 I=1,NCOMPO
29448 WRITE(LOUT,3013) I,IEMUMA(I),IEMUCH(I),EMUFRA(I),
29449 & EMUSAM(I)/DBLE(ICEVT)
29450 3013 FORMAT(12X,I2,1X,2I8,6X,F7.3,5X,F7.3)
29451 30 CONTINUE
29452 ENDIF
29453
29454* i.n.c. statistics: output
29455 WRITE(LOUT,3001) ICEVT,NRESEV(2),IRINC
29456 3001 FORMAT(/,1X,'HISTAT:',14X,'statistics - intranuclear cascade',/,
29457 & 22X,'---------------------------------',/,/,1X,
29458 & 'no. of events for normalization: (accepted final events,',
29459 & ' evt)',4X,I6,/,34X,'(events before evap.-step, evt1)',I6,
29460 & /,1X,'no. of rejected events due to intranuclear',
29461 & ' cascade',15X,I6,/)
29462 ICEV = MAX(ICEVT,1)
29463 ICEV1 = ICEV
29464 IF (LEVPRT) ICEV1 = MAX(NRESEV(2),1)
29465 WRITE(LOUT,3002)
29466 & (DBLE(NINCWO(I))/DBLE(ICEV),I=1,2),
29467 & ((DBLE(NINCST(I,J))/DBLE(ICEV),I=1,2),J=1,4),
29468 & KTAUGE,DBLE(NINCGE)/DBLE(ICEV),
29469 & (DBLE(NINCCO(I,1)+NINCCO(I,2)+NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29470 & (DBLE(NINCCO(I,2))/DBLE(ICEV1),I=1,2),
29471 & (DBLE(NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29472 & (DBLE(NINCCO(I,1))/DBLE(ICEV1),I=1,2)
29473 3002 FORMAT(1X,'no. of wounded nucl. in proj./ target (mean per evt)',
29474 & 5X,F6.2,' /',F6.2,/,1X,'no. of particles unable to escape',
29475 & ' proj./ target (mean per evt)',/,8X,'baryons: pos. ',
29476 & F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3,/,8X,
29477 & 'mesons: pos. ',F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3,
29478 & /,1X,'maximum no. of generations treated (maximum allowed:'
29479 & ,I4,')',/,43X,'(mean per evt)',5X,F6.2,/,1X,'no. of sec.',
29480 & ' interactions in proj./ target (mean per evt1)',
29481 & F7.3,' /',F7.3,/,8X,'out of which by inelastic',
29482 & ' interactions',12X,F7.3,' /',F7.3,/,21X,'by elastic ',
29483 & 'interactions',14X,F7.3,' /',F7.3,/,21X,'by absorption ',
29484 & '(ap, K-, pi- only) ',F7.3,' /',F7.3,/)
29485 WRITE(LOUT,3003) NRESEV(2),NRESEV(4),IREXCI,
29486 & IREXCI(1)+IREXCI(2)+IREXCI(3)
29487 3003 FORMAT(/,1X,'HISTAT:',14X,'statistics - residual nuclei, ',
29488 & 'evaporation',/,22X,'-----------------------------',
29489 & '------------',/,/,1X,'no. of events for normal.: ',
29490 & '(events handled by FICONF, evt)',7X,I6,/,28X,'(events',
29491 & ' passing the evap.-step, evt1) ',I6,/,1X,'no. of',
29492 & ' rejected events (',I4,',',I4,',',I4,')',22X,I6,/)
29493
29494 WRITE(LOUT,3004)
29495 3004 FORMAT(/,22X,'1) before evaporation-step:',/)
29496 ICEV = MAX(NRESEV(2),1)
29497 WRITE(LOUT,3005)
29498 & (DBLE(NRESTO(I))/DBLE(ICEV),I=1,2),
29499 & (DBLE(NRESPR(I))/DBLE(ICEV),I=1,2),
29500 & (DBLE(NRESNU(I))/DBLE(ICEV),I=1,2),
29501 & (DBLE(NRESBA(I))/DBLE(ICEV),I=1,2),
29502 & (DBLE(NRESPB(I))/DBLE(ICEV),I=1,2),
29503 & (DBLE(NRESCH(I))/DBLE(ICEV),I=1,2),
29504 & (EXCDPM(I)/DBLE(ICEV),I=1,2),
29505 & (EXCDPM(I+2)/DBLE(ICEV),I=1,2)
29506 3005 FORMAT(1X,'residual nuclei: (mean values per evt)',12X,
29507 & 'proj. / target',/,/,8X,'total number of particles',15X,
29508 & 2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29509 & 'neutrons',18X,2F9.3,/,22X,'baryons',19X,2F9.3,/,22X,
29510 & 'pos. baryons',14X,2F9.3,/,8X,'total charge',28X,2F9.3,/,
29511 & /,8X,'excitation energy (bef. evap.-step) ',2E11.3,/,
29512 & 8X,'excitation energy per nucleon ',2E11.3,/,/)
29513
29514* evaporation / fission / fragmentation statistics: output
29515 ICEV = MAX(NRESEV(2),1)
29516 ICEV1 = MAX(NRESEV(4),1)
29517 NTEVA1 =
29518 & NEVA(1,1)+NEVA(1,2)+NEVA(1,3)+NEVA(1,4)+NEVA(1,5)+NEVA(1,6)
29519 NTEVA2 =
29520 & NEVA(2,1)+NEVA(2,2)+NEVA(2,3)+NEVA(2,4)+NEVA(2,5)+NEVA(2,6)
29521 IF (LEVPRT) THEN
29522 IF (IFISS.EQ.1) CMSG(1) = 'requested '
29523 IF (LFRMBK) CMSG(2) = 'requested '
29524 IF (LDEEXG) CMSG(3) = 'requested '
29525 WRITE(LOUT,3006)
29526 & CMSG,
29527 & DBLE(NTEVA1)/DBLE(ICEV1),DBLE(NTEVA2)/DBLE(ICEV1),
29528 & (DBLE(NEVA(I,1))/DBLE(ICEV1),I=1,2),
29529 & (DBLE(NEVA(I,2))/DBLE(ICEV1),I=1,2),
29530 & (DBLE(NEVA(I,3))/DBLE(ICEV1),I=1,2),
29531 & (DBLE(NEVA(I,4))/DBLE(ICEV1),I=1,2),
29532 & (DBLE(NEVA(I,5))/DBLE(ICEV1),I=1,2),
29533 & (DBLE(NEVA(I,6))/DBLE(ICEV1),I=1,2),
29534 & (DBLE(NEVAGA(I))/DBLE(ICEV1),I=1,2),
29535 & (DBLE(NEVAHT(I))/DBLE(ICEV1),I=1,2)
29536 3006 FORMAT(22X,'2) after evaporation-step:',/,/,1X,'Fission:',
29537 & 13X,A13,/,1X,'Fermi-Break-up:',6X,A13,/,1X,'Gamma-',
29538 & 'deexcitation:',2X,A13,/,/,
29539 & 1X,'evaporation/deexcitation: (mean values per evt1) ',
29540 & 'proj. / target',/,/,8X,'total number of evap. particles',
29541 & 9X,2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29542 & 'neutrons',18X,2F9.3,/,22X,'deuterons',17X,2F9.3,/,22X,
29543 & '3-H',23X,2F9.3,/,22X,'3-He',22X,2F9.3,/,22X,'4-He',22X,
29544 & 2F9.3,/,8X,'nucl. deexcit. gammas',19X,2F9.3,/,8X,
29545 & 'heavy fragments',25X,2F9.3,/)
29546 IF (IFISS.EQ.1) THEN
29547 WRITE(LOUT,3007) NEVAFI(1,1),NEVAFI(1,2),
29548 & NEVAFI(2,1),NEVAFI(2,2),
29549 & DBLE(NEVAFI(2,1))/DBLE(MAX(NEVAFI(1,1),1))*100.0D0,
29550 & DBLE(NEVAFI(2,2))/DBLE(MAX(NEVAFI(1,2),1))*100.0D0
29551 3007 FORMAT(1X,'Fission: total number of events',14X,2I9,/
29552 & 12X,'out of which fission occured',8X,2I9,/,
29553 & 50X,'(',F5.2,'%) (',F5.2,'%)',/)
29554 ENDIF
29555C IF ((LFRMBK).OR.(IFISS.EQ.1)) THEN
29556C WRITE(LOUT,3008)
29557C3008 FORMAT(1X,'heavy fragments - statistics:',7X,'charge',
29558C & ' proj. / target',/)
29559C DO 31 I=1,210
29560C IF ((NEVAHY(1,2,I).NE.0).OR.(NEVAHY(2,2,I).NE.0)) THEN
29561C WRITE(LOUT,3009) I,
29562C & (DBLE(NEVAHY(K,2,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29563C3009 FORMAT(38X,I3,3X,2E12.3)
29564C ENDIF
29565C 31 CONTINUE
29566C WRITE(LOUT,3010)
29567C3010 FORMAT(1X,'heavy fragments - statistics:',7X,'mass ',
29568C & ' proj. / target',/)
29569C DO 32 I=1,210
29570C IF ((NEVAHY(1,1,I).NE.0).OR.(NEVAHY(2,1,I).NE.0)) THEN
29571C WRITE(LOUT,3011) I,
29572C & (DBLE(NEVAHY(K,1,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29573C3011 FORMAT(38X,I3,3X,2E12.3)
29574C ENDIF
29575C 32 CONTINUE
29576C WRITE(LOUT,*)
29577C ENDIF
29578 ELSE
29579 WRITE(LOUT,3012)
29580 3012 FORMAT(22X,'2) after evaporation-step:',/,/,1X,
29581 & 'Evaporation: not requested',/)
29582 ENDIF
29583
29584 RETURN
29585*------------------------------------------------------------------
29586* filling of histogram with event-record
29587 4 CONTINUE
29588* emulsion treatment
29589 IF (NCOMPO.GT.0) THEN
29590 DO 40 I=1,NCOMPO
29591 IF (IT.EQ.IEMUMA(I)) THEN
29592 EMUSAM(I) = EMUSAM(I)+ONE
29593 ENDIF
29594 40 CONTINUE
29595 ENDIF
29596 NINCGE = NINCGE+MAXGEN
29597 MAXGEN = 0
29598**dble Po statistics.
29599 IF (IPOPO.EQ.1) KPOPO = KPOPO+1
29600
29601 RETURN
29602*------------------------------------------------------------------
29603* filling of histogram with event-record
29604 5 CONTINUE
29605 IF ((ISTHKK(IDX).EQ.15).OR.(ISTHKK(IDX).EQ.16)) THEN
29606 IB = IIBAR(IDBAM(IDX))
29607 IC = IICH(IDBAM(IDX))
29608 J = ISTHKK(IDX)-14
29609 IF ( ((ABS(IB).EQ.1).AND.(IC.EQ.1)).OR.(IC.EQ.0) ) THEN
29610 NINCST(J,1) = NINCST(J,1)+1
29611 ELSEIF ((ABS(IB).EQ.1).AND.(IC.EQ.-1)) THEN
29612 NINCST(J,2) = NINCST(J,2)+1
29613 ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ. 1)) THEN
29614 NINCST(J,3) = NINCST(J,3)+1
29615 ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ.-1)) THEN
29616 NINCST(J,4) = NINCST(J,4)+1
29617 ENDIF
29618 ELSEIF (ISTHKK(IDX).EQ.17) THEN
29619 NINCWO(1) = NINCWO(1)+1
29620 ELSEIF (ISTHKK(IDX).EQ.18) THEN
29621 NINCWO(2) = NINCWO(2)+1
29622 ELSEIF (ISTHKK(IDX).EQ.1001) THEN
29623 IB = IDRES(IDX)
29624 IC = IDXRES(IDX)
29625 IF (IC.GT.0) THEN
29626 NEVAHY(NOBAM(IDX),1,IB) = NEVAHY(NOBAM(IDX),1,IB)+1
29627 NEVAHY(NOBAM(IDX),2,IC) = NEVAHY(NOBAM(IDX),2,IC)+1
29628 ENDIF
29629 NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29630 ENDIF
29631
29632 RETURN
29633 END
29634
29635*$ CREATE DT_NEWHGR.FOR
29636*COPY DT_NEWHGR
29637*
29638*===newhgr=============================================================*
29639*
29640 SUBROUTINE DT_NEWHGR(XLIM1,XLIM2,XLIM3,XLIMB,IBIN,IREFN)
29641
29642************************************************************************
29643* *
29644* Histogram initialization. *
29645* *
29646* input: XLIM1/XLIM2 lower/upper edge of histogram-window *
29647* XLIM3 bin size *
29648* IBIN > 0 number of bins in equidistant lin. binning *
29649* = -1 reset histograms *
29650* < -1 |IBIN| number of bins in equidistant log. *
29651* binning or log. binning in user def. struc. *
29652* XLIMB(*) user defined bin structure *
29653* *
29654* The bin structure is sensitive to *
29655* XLIM1, XLIM3, IBIN if XLIM3 > 0 (lin.) *
29656* XLIM1, XLIM2, IBIN if XLIM3 = 0 (lin. & log.) *
29657* XLIMB, IBIN if XLIM3 < 0 *
29658* *
29659* *
29660* output: IREFN histogram index *
29661* (= -1 for inconsistent histogr. request) *
29662* *
29663* This subroutine is based on a original version by R. Engel. *
29664* This version dated 22.4.95 is written by S. Roesler. *
29665************************************************************************
29666
29667 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29668 SAVE
29669 PARAMETER ( LINP = 10 ,
29670 & LOUT = 6 ,
29671 & LDAT = 9 )
29672
29673 LOGICAL LSTART
29674
29675 PARAMETER (ZERO = 0.0D0,
29676 & TINY = 1.0D-10)
29677
29678 DIMENSION XLIMB(*)
29679
29680* histograms
29681 PARAMETER (NHIS=150, NDIM=250)
29682 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29683 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29684* auxiliary common for histograms
29685 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29686
29687 DATA LSTART /.TRUE./
29688
29689* reset histogram counter
29690 IF (LSTART.OR.(IBIN.EQ.-1)) THEN
29691 IHISL = 0
29692 IF (IBIN.EQ.-1) RETURN
29693 LSTART = .FALSE.
29694 ENDIF
29695
29696 IHIS = IHISL+1
29697* check for maximum number of allowed histograms
29698 IF (IHIS.GT.NHIS) THEN
29699 WRITE(LOUT,1003) IHIS,NHIS,IHIS
29700 1003 FORMAT(1X,'NEWHGR: warning! number of histograms (',
29701 & I4,') exceeds array size (',I4,')',/,21X,
29702 & 'histogram',I3,' skipped!')
29703 GOTO 9999
29704 ENDIF
29705
29706 IREFN = IHIS
29707 IBINS(IHIS) = ABS(IBIN)
29708* check requested number of bins
29709 IF (IBINS(IHIS).GE.NDIM) THEN
29710 WRITE(LOUT,1000) IBIN,NDIM,NDIM
29711 1000 FORMAT(1X,'NEWHGR: warning! number of bins (',
29712 & I3,') exceeds array size (',I3,')',/,21X,
29713 & 'and will be reset to ',I3)
29714 IBINS(IHIS) = NDIM
29715 ENDIF
29716 IF (IBINS(IHIS).EQ.0) THEN
29717 WRITE(LOUT,1001) IBIN,IHIS
29718 1001 FORMAT(1X,'NEWHGR: warning! inconsistent number of',
29719 & ' bins (',I3,')',/,21X,'histogram',I3,' skipped!')
29720 GOTO 9999
29721 ENDIF
29722
29723* initialize arrays
29724 DO 1 I=1,NDIM
29725 DO 2 K=1,3
29726 HIST(K,IHIS,I) = ZERO
29727 HIST(K+3,IHIS,I) = ZERO
29728 TMPHIS(K,IHIS,I) = ZERO
29729 2 CONTINUE
29730 HIST(7,IHIS,I) = ZERO
29731 1 CONTINUE
29732 DENTRY(1,IHIS)= ZERO
29733 DENTRY(2,IHIS)= ZERO
29734 OVERF(IHIS) = ZERO
29735 UNDERF(IHIS) = ZERO
29736 TMPUFL(IHIS) = ZERO
29737 TMPOFL(IHIS) = ZERO
29738
29739* bin str. sensitive to lower edge, bin size, and numb. of bins
29740 IF (XLIM3.GT.ZERO) THEN
29741 DO 3 K=1,IBINS(IHIS)+1
29742 HIST(1,IHIS,K) = XLIM1+DBLE(K-1)*XLIM3
29743 3 CONTINUE
29744 ISWI(IHIS) = 1
29745* bin str. sensitive to lower/upper edge and numb. of bins
29746 ELSEIF (XLIM3.EQ.ZERO) THEN
29747* linear binning
29748 IF (IBIN.GT.0) THEN
29749 XLOW = XLIM1
29750 XHI = XLIM2
29751 IF (XLIM2.LE.XLIM1) THEN
29752 WRITE(LOUT,1002) XLIM1,XLIM2
29753 1002 FORMAT(1X,'NEWHGR: warning! inconsistent x-range',
29754 & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29755 GOTO 9999
29756 ENDIF
29757 ISWI(IHIS) = 1
29758 ELSEIF (IBIN.LT.-1) THEN
29759* logarithmic binning
29760 IF ((XLIM1.LE.ZERO).OR.(XLIM2.LE.ZERO)) THEN
29761 WRITE(LOUT,1004) XLIM1,XLIM2
29762 1004 FORMAT(1X,'NEWHGR: warning! inconsistent log. ',
29763 & 'binning',/,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29764 GOTO 9999
29765 ENDIF
29766 IF (XLIM2.LE.XLIM1) THEN
29767 WRITE(LOUT,1005) XLIM1,XLIM2
29768 1005 FORMAT(1X,'NEWHGR: warning! inconsistent x-range',
29769 & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29770 GOTO 9999
29771 ENDIF
29772 XLOW = LOG10(XLIM1)
29773 XHI = LOG10(XLIM2)
29774 ISWI(IHIS) = 3
29775 ENDIF
29776 DX = ABS(XHI-XLOW)/DBLE(MAX(IBINS(IHIS),1))
29777 DO 4 K=1,IBINS(IHIS)+1
29778 HIST(1,IHIS,K) = XLOW+DBLE(K-1)*DX
29779 4 CONTINUE
29780 ELSE
29781* user defined bin structure
29782 DO 5 K=1,IBINS(IHIS)+1
29783 IF (IBIN.GT.0) THEN
29784 HIST(1,IHIS,K) = XLIMB(K)
29785 ISWI(IHIS) = 2
29786 ELSEIF (IBIN.LT.-1) THEN
29787 HIST(1,IHIS,K) = LOG10(XLIMB(K))
29788 ISWI(IHIS) = 4
29789 ENDIF
29790 5 CONTINUE
29791 ENDIF
29792
29793* histogram accepted
29794 IHISL = IHIS
29795
29796 RETURN
29797
29798 9999 CONTINUE
29799 IREFN = -1
29800 RETURN
29801 END
29802
29803*$ CREATE DT_FILHGR.FOR
29804*COPY DT_FILHGR
29805*
29806*===filhgr=============================================================*
29807*
29808 SUBROUTINE DT_FILHGR(XI,YI,IHIS,NEVT)
29809
29810************************************************************************
29811* *
29812* Scoring for histogram IHIS. *
29813* *
29814* This subroutine is based on a original version by R. Engel. *
29815* This version dated 23.4.95 is written by S. Roesler. *
29816************************************************************************
29817
29818 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29819 SAVE
29820 PARAMETER ( LINP = 10 ,
29821 & LOUT = 6 ,
29822 & LDAT = 9 )
29823
29824 PARAMETER (ZERO = 0.0D0,
29825 & ONE = 1.0D0,
29826 & TINY = 1.0D-10)
29827
29828* histograms
29829 PARAMETER (NHIS=150, NDIM=250)
29830 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29831 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29832* auxiliary common for histograms
29833 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29834
29835 DATA NCEVT /1/
29836
29837 X = XI
29838 Y = YI
29839
29840* dump content of temorary arrays into histograms
29841 IF ((NEVT.NE.NCEVT).OR.(NEVT.LT.0)) THEN
29842 CALL DT_EVTHIS(IDUM)
29843 NCEVT = NEVT
29844 ENDIF
29845
29846* check histogram index
29847 IF (IHIS.EQ.-1) RETURN
29848 IF ((IHIS.LT.1).OR.(IHIS.GT.IHISL)) THEN
29849C WRITE(LOUT,1000) IHIS,IHISL
29850 1000 FORMAT(1X,'FILHGR: warning! histogram index',I4,
29851 & ' out of range (1..',I3,')')
29852 RETURN
29853 ENDIF
29854
29855 IF ((ISWI(IHIS).EQ.1).OR.(ISWI(IHIS).EQ.3)) THEN
29856* bin structure not explicitly given
29857 IF ((ISWI(IHIS).EQ.3).AND.(X.GT.ZERO)) X = LOG10(X)
29858 DX = ABS(HIST(1,IHIS,2)-HIST(1,IHIS,1))
29859 IF (X.LT.HIST(1,IHIS,1)) THEN
29860 I1 = 0
29861 ELSE
29862 I1 = INT( (X-HIST(1,IHIS,1))/MAX(DX,TINY) )+1
29863 ENDIF
29864
29865 ELSEIF ((ISWI(IHIS).EQ.2).OR.(ISWI(IHIS).EQ.4)) THEN
29866* user defined bin structure
29867 IF ((ISWI(IHIS).EQ.4).AND.(X.GT.ZERO)) X = LOG10(X)
29868 IF (X.LT.HIST(1,IHIS,1)) THEN
29869 I1 = 0
29870 ELSE IF (X.GT.HIST(1,IHIS,IBINS(IHIS)+1)) THEN
29871 I1 = IBINS(IHIS)+1
29872 ELSE
29873* binary sort algorithm
29874 KMIN = 0
29875 KMAX = IBINS(IHIS)+1
29876 1 CONTINUE
29877 IF ((KMAX-KMIN).EQ.1) GOTO 2
29878 KK = (KMAX+KMIN)/2
29879 IF (X.LE.HIST(1,IHIS,KK)) THEN
29880 KMAX=KK
29881 ELSE
29882 KMIN=KK
29883 ENDIF
29884 GOTO 1
29885 2 CONTINUE
29886 I1 = KMIN
29887 ENDIF
29888
29889 ELSE
29890 WRITE(LOUT,1001)
29891 1001 FORMAT(1X,'FILHGR: warning! histogram not initialized')
29892 RETURN
29893 ENDIF
29894
29895* scoring
29896 IF (I1.LE.0) THEN
29897 TMPUFL(IHIS) = TMPUFL(IHIS)+ONE
29898 ELSEIF (I1.LE.IBINS(IHIS)) THEN
29899 TMPHIS(1,IHIS,I1) = TMPHIS(1,IHIS,I1)+ONE
29900 IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
29901 TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+10**X
29902 ELSE
29903 TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+X
29904 ENDIF
29905 TMPHIS(3,IHIS,I1) = TMPHIS(3,IHIS,I1)+Y
29906 ELSE
29907 TMPOFL(IHIS) = TMPOFL(IHIS)+ONE
29908 ENDIF
29909
29910 RETURN
29911 END
29912
29913*$ CREATE DT_EVTHIS.FOR
29914*COPY DT_EVTHIS
29915*
29916*===evthis=============================================================*
29917*
29918 SUBROUTINE DT_EVTHIS(NEVT)
29919
29920************************************************************************
29921* Dump content of temorary histograms into /DTHIS1/. This subroutine *
29922* is called after each event and for the last event before any call *
29923* to OUTHGR. *
29924* NEVT number of events dumped, this is only needed to *
29925* get the normalization after the last event *
29926* This version dated 23.4.95 is written by S. Roesler. *
29927************************************************************************
29928
29929 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29930 SAVE
29931 PARAMETER ( LINP = 10 ,
29932 & LOUT = 6 ,
29933 & LDAT = 9 )
29934
29935 LOGICAL LNOETY
29936
29937 PARAMETER (ZERO = 0.0D0,
29938 & ONE = 1.0D0,
29939 & TINY = 1.0D-10)
29940
29941* histograms
29942 PARAMETER (NHIS=150, NDIM=250)
29943 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29944 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29945* auxiliary common for histograms
29946 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29947
29948 DATA NCEVT /0/
29949
29950 NCEVT = NCEVT+1
29951 NEVT = NCEVT
29952
29953 DO 1 I=1,IHISL
29954 LNOETY = .TRUE.
29955 DO 2 J=1,IBINS(I)
29956 IF (TMPHIS(1,I,J).GT.ZERO) THEN
29957 LNOETY = .FALSE.
29958 HIST(2,I,J) = HIST(2,I,J)+ONE
29959 HIST(7,I,J) = HIST(7,I,J)+TMPHIS(1,I,J)
29960 DENTRY(2,I) = DENTRY(2,I)+TMPHIS(1,I,J)
29961 AVX = TMPHIS(2,I,J)/TMPHIS(1,I,J)
29962 HIST(3,I,J) = HIST(3,I,J)+TMPHIS(3,I,J)*AVX
29963 HIST(4,I,J) = HIST(4,I,J)+TMPHIS(3,I,J)*AVX**2
29964 HIST(5,I,J) = HIST(5,I,J)+TMPHIS(3,I,J)
29965 HIST(6,I,J) = HIST(6,I,J)+TMPHIS(3,I,J)**2
29966 TMPHIS(1,I,J) = ZERO
29967 TMPHIS(2,I,J) = ZERO
29968 TMPHIS(3,I,J) = ZERO
29969 ENDIF
29970 2 CONTINUE
29971 IF (LNOETY) THEN
29972 IF (TMPUFL(I).GT.ZERO) THEN
29973 UNDERF(I) = UNDERF(I)+ONE
29974 TMPUFL(I) = ZERO
29975 ELSEIF (TMPOFL(I).GT.ZERO) THEN
29976 OVERF(I) = OVERF(I)+ONE
29977 TMPOFL(I) = ZERO
29978 ENDIF
29979 ELSE
29980 DENTRY(1,I) = DENTRY(1,I)+ONE
29981 ENDIF
29982 1 CONTINUE
29983
29984 RETURN
29985 END
29986
29987*$ CREATE DT_OUTHGR.FOR
29988*COPY DT_OUTHGR
29989*
29990*===outhgr=============================================================*
29991*
29992 SUBROUTINE DT_OUTHGR(I1,I2,I3,I4,I5,I6,CHEAD,IHEAD,NEVTS,FAC,
29993 & ILOGY,INORM,NMODE)
29994
29995************************************************************************
29996* *
29997* Plot histogram(s) to standard output unit *
29998* *
29999* I1..6 indices of histograms to be plotted *
30000* CHEAD,IHEAD header string,integer *
30001* NEVTS number of events *
30002* FAC scaling factor *
30003* ILOGY = 1 logarithmic y-axis *
30004* INORM normalization *
30005* = 0 no further normalization (FAC is obsolete) *
30006* = 1 per event and bin width *
30007* = 2 per entry and bin width *
30008* = 3 per bin entry *
30009* = 4 per event and "bin width" x1^2...x2^2 *
30010* = 5 per event and "log. bin width" ln x1..ln x2 *
30011* = 6 per event *
30012* MODE = 0 no output but normalization applied *
30013* = 1 all valid histograms separately (small frame) *
30014* all valid histograms separately (small frame) *
30015* = -1 and tables as histograms *
30016* = 2 all valid histograms (one plot, wide frame) *
30017* all valid histograms (one plot, wide frame) *
30018* = -2 and tables as histograms *
30019* *
30020* *
30021* Note: All histograms to be plotted with one call to this *
30022* subroutine and |MODE|=2 must have the same bin structure! *
30023* There is no test included ensuring this fact. *
30024* *
30025* This version dated 23.4.95 is written by S. Roesler. *
30026************************************************************************
30027
30028 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30029 SAVE
30030 PARAMETER ( LINP = 10 ,
30031 & LOUT = 6 ,
30032 & LDAT = 9 )
30033
30034 CHARACTER*72 CHEAD
30035
30036 PARAMETER (ZERO = 0.0D0,
30037 & IZERO = 0,
30038 & ONE = 1.0D0,
30039 & TWO = 2.0D0,
30040 & OHALF = 0.5D0,
30041 & EPS = 1.0D-5,
30042 & TINY = 1.0D-8,
30043 & SMALL = -1.0D8,
30044 & RLARGE = 1.0D8 )
30045
30046* histograms
30047 PARAMETER (NHIS=150, NDIM=250)
30048 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30049 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30050
30051 PARAMETER (NDIM2 = 2*NDIM)
30052 DIMENSION XX(NDIM2),YY(NDIM2)
30053
30054 PARAMETER (NHISTO = 6)
30055 DIMENSION YY1(NDIM,NHISTO),XX1(NDIM,NHISTO),IDX1(NHISTO),
30056 & IDX(NHISTO)
30057
30058 CHARACTER*43 CNORM(0:8)
30059 DATA CNORM /'no further normalization ',
30060 & 'per event and bin width ',
30061 & 'per entry1 and bin width ',
30062 & 'per bin entry ',
30063 & 'per event and "bin width" x1^2...x2^2 ',
30064 & 'per event and "log. bin width" ln x1..ln x2',
30065 & 'per event ',
30066 & 'per bin entry1 ',
30067 & 'per entry2 and bin width '/
30068
30069 IDX1(1) = I1
30070 IDX1(2) = I2
30071 IDX1(3) = I3
30072 IDX1(4) = I4
30073 IDX1(5) = I5
30074 IDX1(6) = I6
30075
30076 MODE = NMODE
30077
30078* initialization if "wide frame" is requested
30079 IF (ABS(MODE).EQ.2) THEN
30080 DO 1 I=1,NHISTO
30081 DO 2 J=1,NDIM
30082 XX1(J,I) = ZERO
30083 YY1(J,I) = ZERO
30084 2 CONTINUE
30085 1 CONTINUE
30086 ENDIF
30087
30088* plot header
30089 WRITE(LOUT,'(/1X,A,I3,/,1X,70A1)') CHEAD,IHEAD,('=',II=1,70)
30090
30091* check histogram indices
30092 NHI = 0
30093 DO 3 I=1,NHISTO
30094 IF ((IDX1(I).GE.1).AND.(IDX1(I).LE.IHISL)) THEN
30095 IF (ISWI(IDX1(I)).NE.0) THEN
30096 IF (DENTRY(1,IDX1(I)).LT.ONE) THEN
30097 WRITE(LOUT,1000)
30098 & IDX1(I),UNDERF(IDX1(I)),OVERF(IDX1(I))
30099 1000 FORMAT(/,1X,'OUTHGR: warning! no entries in',
30100 & ' histogram ',I3,/,21X,'underflows:',F10.0,
30101 & ' overflows: ',F10.0)
30102 ELSE
30103 NHI = NHI+1
30104 IDX(NHI) = IDX1(I)
30105 ENDIF
30106 ENDIF
30107 ENDIF
30108 3 CONTINUE
30109 IF (NHI.EQ.0) THEN
30110 WRITE(LOUT,1001)
30111 1001 FORMAT(/,1X,'OUTHGR: warning! histogram indices not valid')
30112 RETURN
30113 ENDIF
30114
30115* check normalization request
30116 IF ( ((FAC.EQ.ZERO).AND.(INORM.NE.0)).OR.
30117 & ((NEVTS.LT.1).AND.((INORM.EQ.1).OR.(INORM.EQ.4).OR.
30118 & (INORM.EQ.5).OR.(INORM.EQ.6))).OR.
30119 & (INORM.LT.0).OR.(INORM.GT.8) ) THEN
30120 WRITE(LOUT,1002) NEVTS,INORM,FAC
30121 1002 FORMAT(/,1X,'OUTHGR: warning! normalization request not ',
30122 & 'valid',/,21X,'NEVTS = ',I7,4X,'INORM = ',I2,4X,
30123 & 'FAC = ',E11.4)
30124 RETURN
30125 ENDIF
30126
30127 WRITE(LOUT,'(/,1X,A,I8)') 'number of events:',NEVTS
30128
30129* apply normalization
30130 DO 4 N=1,NHI
30131
30132 I = IDX(N)
30133
30134 IF (ISWI(I).EQ.1) THEN
30135 WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30136 1003 FORMAT(/,1X,'histo.',I4,', linear binning from',2X,E10.4,
30137 & ' to',2X,E10.4,',',2X,I3,' bins')
30138 ELSEIF (ISWI(I).EQ.2) THEN
30139 WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30140 WRITE(LOUT,1007)
30141 1007 FORMAT(1X,'user defined bin structure')
30142 ELSEIF (ISWI(I).EQ.3) THEN
30143 WRITE(LOUT,1004)
30144 & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30145 1004 FORMAT(/,1X,'histo.',I4,', logar. binning from',2X,E10.4,
30146 & ' to',2X,E10.4,',',2X,I3,' bins')
30147 ELSEIF (ISWI(I).EQ.4) THEN
30148 WRITE(LOUT,1004)
30149 & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30150 WRITE(LOUT,1007)
30151 ELSE
30152 WRITE(LOUT,1008) ISWI(I)
30153 1008 FORMAT(/,1X,'warning! inconsistent bin structure flag ',I4)
30154 ENDIF
30155 WRITE(LOUT,1005) DENTRY(1,I),DENTRY(2,I),UNDERF(I),OVERF(I)
30156 1005 FORMAT(13X,'entries:',2F9.0,' underfl.:',F8.0,
30157 & ' overfl.:',F8.0)
30158 WRITE(LOUT,1009) CNORM(INORM)
30159 1009 FORMAT(1X,'normalization: ',A,/)
30160
30161 DO 5 K=1,IBINS(I)
30162 CALL DT_GETBIN(I,K,NEVTS,INORM,XLOW,XHI,XMEAN,YMEAN,YERR)
30163 YMEAN = FAC*YMEAN
30164 YERR = FAC*YERR
30165 WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,YERR,HIST(2,I,K)
30166 WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,YERR,HIST(2,I,K)
30167 1006 FORMAT(1X,5E11.3)
30168* small frame
30169 II = 2*K
30170 XX(II-1) = HIST(1,I,K)
30171 XX(II) = HIST(1,I,K+1)
30172 YY(II-1) = YMEAN
30173 YY(II) = YMEAN
30174* wide frame
30175 XX1(K,N) = XMEAN
30176 IF ((ISWI(I).EQ.3).OR.(ISWI(I).EQ.4))
30177 & XX1(K,N) = LOG10(XMEAN)
30178 YY1(K,N) = YMEAN
30179 5 CONTINUE
30180
30181* plot small frame
30182 IF (ABS(MODE).EQ.1) THEN
30183 IBIN2 = 2*IBINS(I)
30184 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30185 IF(ILOGY.EQ.1) THEN
30186 CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30187 ELSE
30188 CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30189 ENDIF
30190 ENDIF
30191
30192 4 CONTINUE
30193
30194* plot wide frame
30195 IF (ABS(MODE).EQ.2) THEN
30196 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30197 NSIZE = NDIM*NHISTO
30198 DXLOW = HIST(1,IDX(1),1)
30199 DDX = ABS(HIST(1,IDX(1),2)-HIST(1,IDX(1),1))
30200 YLOW = RLARGE
30201 YHI = SMALL
30202 DO 6 I=1,NHISTO
30203 DO 7 J=1,NDIM
30204 IF (YY1(J,I).LT.YLOW) THEN
30205 IF (ILOGY.EQ.1) THEN
30206 IF (YY1(J,I).GT.ZERO) YLOW = YY1(J,I)
30207 ELSE
30208 YLOW = YY1(J,I)
30209 ENDIF
30210 ENDIF
30211 IF (YY1(J,I).GT.YHI) YHI = YY1(J,I)
30212 7 CONTINUE
30213 6 CONTINUE
30214 DY = (YHI-YLOW)/DBLE(NDIM)
30215 IF (DY.LE.ZERO) THEN
30216 WRITE(LOUT,'(1X,A,6I4,A,2E12.4)')
30217 & 'OUTHGR: warning! zero bin width for histograms ',
30218 & IDX,': ',YLOW,YHI
30219 RETURN
30220 ENDIF
30221 IF (ILOGY.EQ.1) THEN
30222 YLOW = LOG10(YLOW)
30223 DY = (LOG10(YHI)-YLOW)/100.0D0
30224 DO 8 I=1,NHISTO
30225 DO 9 J=1,NDIM
30226 IF (YY1(J,I).LE.ZERO) THEN
30227 YY1(J,I) = YLOW
30228 ELSE
30229 YY1(J,I) = LOG10(YY1(J,I))
30230 ENDIF
30231 9 CONTINUE
30232 8 CONTINUE
30233 ENDIF
30234 CALL DT_SRPLOT(XX1,YY1,NSIZE,NHISTO,NDIM,DXLOW,DDX,YLOW,DY)
30235 ENDIF
30236
30237 RETURN
30238 END
30239
30240*$ CREATE DT_GETBIN.FOR
30241*COPY DT_GETBIN
30242*
30243*===getbin=============================================================*
30244*
30245 SUBROUTINE DT_GETBIN(IHIS,IBIN,KEVT,NORM,XLOW,XHI,
30246 & XMEAN,YMEAN,YERR)
30247
30248************************************************************************
30249* This version dated 23.4.95 is written by S. Roesler. *
30250************************************************************************
30251
30252 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30253 SAVE
30254 PARAMETER ( LINP = 10 ,
30255 & LOUT = 6 ,
30256 & LDAT = 9 )
30257
30258 PARAMETER (ZERO = 0.0D0,
30259 & ONE = 1.0D0,
30260 & TINY35 = 1.0D-35)
30261
30262* histograms
30263 PARAMETER (NHIS=150, NDIM=250)
30264 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30265 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30266
30267 XLOW = HIST(1,IHIS,IBIN)
30268 XHI = HIST(1,IHIS,IBIN+1)
30269 IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
30270 XLOW = 10**XLOW
30271 XHI = 10**XHI
30272 ENDIF
30273 IF (NORM.EQ.2) THEN
30274 DX = XHI-XLOW
30275 NEVT = INT(DENTRY(1,IHIS))
30276 ELSEIF (NORM.EQ.3) THEN
30277 DX = ONE
30278 NEVT = INT(HIST(2,IHIS,IBIN))
30279 ELSEIF (NORM.EQ.4) THEN
30280 DX = XHI**2-XLOW**2
30281 NEVT = KEVT
30282 ELSEIF (NORM.EQ.5) THEN
30283 DX = LOG(ABS(XHI))-LOG(ABS(XLOW))
30284 NEVT = KEVT
30285 ELSEIF (NORM.EQ.6) THEN
30286 DX = ONE
30287 NEVT = KEVT
30288 ELSEIF (NORM.EQ.7) THEN
30289 DX = ONE
30290 NEVT = INT(HIST(7,IHIS,IBIN))
30291 ELSEIF (NORM.EQ.8) THEN
30292 DX = XHI-XLOW
30293 NEVT = INT(DENTRY(2,IHIS))
30294 ELSE
30295 DX = ABS(XHI-XLOW)
30296 NEVT = KEVT
30297 ENDIF
30298 IF (ABS(DX).LT.TINY35) DX = ONE
30299 NEVT = MAX(NEVT,1)
30300 YMEAN = HIST(5,IHIS,IBIN)/DX/DBLE(NEVT)
30301 YMEAN2 = HIST(6,IHIS,IBIN)/DX**2/DBLE(NEVT)
30302 YERR = SQRT(ABS(YMEAN2-YMEAN**2))/SQRT(DBLE(NEVT))
30303 YSUM = HIST(5,IHIS,IBIN)
30304 IF (ABS(YSUM).LT.TINY35) YSUM = ONE
30305C XMEAN = HIST(3,IHIS,IBIN)/YSUM/MAX(HIST(2,IHIS,IBIN),ONE)
30306 XMEAN = HIST(3,IHIS,IBIN)/YSUM
30307 IF (XMEAN.EQ.ZERO) XMEAN = XLOW
30308
30309 RETURN
30310 END
30311
30312*$ CREATE DT_JOIHIS.FOR
30313*COPY DT_JOIHIS
30314*
30315*===joihis=============================================================*
30316*
30317 SUBROUTINE DT_JOIHIS(IH1,IH2,COPER,FAC1,FAC2,KEVT,NORM,ILOGY,MODE)
30318
30319************************************************************************
30320* *
30321* Operation on histograms. *
30322* *
30323* input: IH1,IH2 histogram indices to be joined *
30324* COPER character defining the requested operation, *
30325* i.e. '+', '-', '*', '/' *
30326* FAC1,FAC2 factors for joining, i.e. *
30327* FAC1*histo1 COPER FAC2*histo2 *
30328* *
30329* This version dated 23.4.95 is written by S. Roesler. *
30330************************************************************************
30331
30332 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30333 SAVE
30334 PARAMETER ( LINP = 10 ,
30335 & LOUT = 6 ,
30336 & LDAT = 9 )
30337
30338 CHARACTER COPER*1
30339
30340 PARAMETER (ZERO = 0.0D0,
30341 & ONE = 1.0D0,
30342 & OHALF = 0.5D0,
30343 & TINY8 = 1.0D-8,
30344 & SMALL = -1.0D8,
30345 & RLARGE = 1.0D8 )
30346
30347* histograms
30348 PARAMETER (NHIS=150, NDIM=250)
30349 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30350 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30351
30352 PARAMETER (NDIM2 = 2*NDIM)
30353 DIMENSION XX(NDIM2),YY(NDIM2),YY1(NDIM),XX1(NDIM)
30354
30355 CHARACTER*43 CNORM(0:6)
30356 DATA CNORM /'no further normalization ',
30357 & 'per event and bin width ',
30358 & 'per entry and bin width ',
30359 & 'per bin entry ',
30360 & 'per event and "bin width" x1^2...x2^2 ',
30361 & 'per event and "log. bin width" ln x1..ln x2',
30362 & 'per event '/
30363
30364* check histogram indices
30365 IF ((IH1.LT. 1).OR.(IH2.LT. 1).OR.
30366 & (IH1.GT.IHISL).OR.(IH2.GT.IHISL)) THEN
30367 WRITE(LOUT,1000) IH1,IH2,IHISL
30368 1000 FORMAT(1X,'JOIHIS: warning! inconsistent histogram ',
30369 & 'indices (',I3,',',I3,'),',/,21X,'valid range: 1,',I3)
30370 GOTO 9999
30371 ENDIF
30372
30373* check bin structure of histograms to be joined
30374 IF (IBINS(IH1).NE.IBINS(IH2)) THEN
30375 WRITE(LOUT,1001) IH1,IH2,IBINS(IH1),IBINS(IH2)
30376 1001 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3,
30377 & ' and ',I3,' failed',/,21X,
30378 & 'due to different numbers of bins (',I3,',',I3,')')
30379 GOTO 9999
30380 ENDIF
30381 DO 1 K=1,IBINS(IH1)+1
30382 IF (ABS(HIST(1,IH1,K)-HIST(1,IH2,K)).GT.TINY8) THEN
30383 WRITE(LOUT,1002) IH1,IH2,K,HIST(1,IH1,K),HIST(1,IH2,K)
30384 1002 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3,
30385 & ' and ',I3,' failed at bin edge ',I3,/,21X,
30386 & 'X1,X2 = ',2E11.4)
30387 GOTO 9999
30388 ENDIF
30389 1 CONTINUE
30390
30391 WRITE(LOUT,1003) IH1,IH2,COPER,FAC1,FAC2
30392 1003 FORMAT(1X,'JOIHIS: joining histograms ',I3,',',I3,' with ',
30393 & 'operation ',A,/,11X,'and factors ',2E11.4)
30394 WRITE(LOUT,1004) CNORM(NORM)
30395 1004 FORMAT(1X,'normalization: ',A,/)
30396
30397 DO 2 K=1,IBINS(IH1)
30398 CALL DT_GETBIN(IH1,K,KEVT,NORM,XLOW1,XHI1,XMEAN1,YMEAN1,YERR1)
30399 CALL DT_GETBIN(IH2,K,KEVT,NORM,XLOW2,XHI2,XMEAN2,YMEAN2,YERR2)
30400 XLOW = XLOW1
30401 XHI = XHI1
30402 XMEAN = OHALF*(XMEAN1+XMEAN2)
30403 IF (COPER.EQ.'+') THEN
30404 YMEAN = FAC1*YMEAN1+FAC2*YMEAN2
30405 ELSEIF (COPER.EQ.'*') THEN
30406 YMEAN = FAC1*YMEAN1*FAC2*YMEAN2
30407 ELSEIF (COPER.EQ.'/') THEN
30408 IF (YMEAN2.EQ.ZERO) THEN
30409 YMEAN = ZERO
30410 ELSE
30411 IF (FAC2.EQ.ZERO) FAC2 = ONE
30412 YMEAN = FAC1*YMEAN1/(FAC2*YMEAN2)
30413 ENDIF
30414 ELSE
30415 GOTO 9998
30416 ENDIF
30417 WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30418 WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30419 1006 FORMAT(1X,5E11.3)
30420* small frame
30421 II = 2*K
30422 XX(II-1) = HIST(1,IH1,K)
30423 XX(II) = HIST(1,IH1,K+1)
30424 YY(II-1) = YMEAN
30425 YY(II) = YMEAN
30426* wide frame
30427 XX1(K) = XMEAN
30428 IF ((ISWI(IH1).EQ.3).OR.(ISWI(IH1).EQ.4)) XX1(K) = LOG10(XMEAN)
30429 YY1(K) = YMEAN
30430 2 CONTINUE
30431
30432* plot small frame
30433 IF (ABS(MODE).EQ.1) THEN
30434 IBIN2 = 2*IBINS(IH1)
30435 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30436 IF(ILOGY.EQ.1) THEN
30437 CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30438 ELSE
30439 CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30440 ENDIF
30441 ENDIF
30442
30443* plot wide frame
30444 IF (ABS(MODE).EQ.2) THEN
30445 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30446 NSIZE = NDIM
30447 DXLOW = HIST(1,IH1,1)
30448 DDX = ABS(HIST(1,IH1,2)-HIST(1,IH1,1))
30449 YLOW = RLARGE
30450 YHI = SMALL
30451 DO 3 I=1,NDIM
30452 IF (YY1(I).LT.YLOW) THEN
30453 IF (ILOGY.EQ.1) THEN
30454 IF (YY1(I).GT.ZERO) YLOW = YY1(I)
30455 ELSE
30456 YLOW = YY1(I)
30457 ENDIF
30458 ENDIF
30459 IF (YY1(I).GT.YHI) YHI = YY1(I)
30460 3 CONTINUE
30461 DY = (YHI-YLOW)/DBLE(NDIM)
30462 IF (DY.LE.ZERO) THEN
30463 WRITE(LOUT,'(1X,A,2I4,A,2E12.4)')
30464 & 'JOIHIS: warning! zero bin width for histograms ',
30465 & IH1,IH2,': ',YLOW,YHI
30466 RETURN
30467 ENDIF
30468 IF (ILOGY.EQ.1) THEN
30469 YLOW = LOG10(YLOW)
30470 DY = (LOG10(YHI)-YLOW)/100.0D0
30471 DO 4 I=1,NDIM
30472 IF (YY1(I).LE.ZERO) THEN
30473 YY1(I) = YLOW
30474 ELSE
30475 YY1(I) = LOG10(YY1(I))
30476 ENDIF
30477 4 CONTINUE
30478 ENDIF
30479 CALL DT_SRPLOT(XX1,YY1,NSIZE,1,NDIM,DXLOW,DDX,YLOW,DY)
30480 ENDIF
30481
30482 RETURN
30483
30484 9998 CONTINUE
30485 WRITE(LOUT,1005) COPER
30486 1005 FORMAT(1X,'JOIHIS: unknown operation ',A)
30487
30488 9999 CONTINUE
30489 RETURN
30490 END
30491
30492*$ CREATE DT_XGRAPH.FOR
30493*COPY DT_XGRAPH
30494*
30495*===qgraph=============================================================*
30496*
30497 SUBROUTINE DT_XGRAPH(N,IARG,X,Y1,Y2)
30498C***********************************************************************
30499C
30500C calculate quasi graphic picture with 25 lines and 79 columns
30501C ranges will be chosen automatically
30502C
30503C input N dimension of input fields
30504C IARG number of curves (fields) to plot
30505C X field of X
30506C Y1 field of Y1
30507C Y2 field of Y2
30508C
30509C This subroutine is written by R. Engel.
30510C***********************************************************************
30511 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30512 SAVE
30513
30514 PARAMETER ( LINP = 10 ,
30515 & LOUT = 6 ,
30516 & LDAT = 9 )
30517C
30518 DIMENSION X(N),Y1(N),Y2(N)
30519 PARAMETER (EPS=1.D-30)
30520 PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30521 CHARACTER SYMB(5)
30522 CHARACTER COL(0:149,0:49)
30523C
30524 DATA SYMB /'0','e','z','#','x'/
30525C
30526 ISPALT=IBREIT-10
30527C
30528C*** automatic range fitting
30529C
30530 XMAX=X(1)
30531 XMIN=X(1)
30532 DO 600 I=1,N
30533 XMAX=MAX(X(I),XMAX)
30534 XMIN=MIN(X(I),XMIN)
30535 600 CONTINUE
30536 XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30537C
30538 ITEST=0
30539 DO 1100 K=0,IZEIL-1
30540 ITEST=ITEST+1
30541 IF (ITEST.EQ.IYRAST) THEN
30542 DO 1010 L=1,ISPALT-1
30543 COL(L,K)='-'
305441010 CONTINUE
30545 COL(ISPALT,K)='+'
30546 ITEST=0
30547 DO 1020 L=0,ISPALT-1,IXRAST
30548 COL(L,K)='+'
305491020 CONTINUE
30550 ELSE
30551 DO 1030 L=1,ISPALT-1
30552 COL(L,K)=' '
305531030 CONTINUE
30554 DO 1040 L=0,ISPALT-1,IXRAST
30555 COL(L,K)='|'
305561040 CONTINUE
30557 COL(ISPALT,K)='|'
30558 ENDIF
305591100 CONTINUE
30560C
30561C*** plot curve Y1
30562C
30563 YMAX=Y1(1)
30564 YMIN=Y1(1)
30565 DO 500 I=1,N
30566 YMAX=MAX(Y1(I),YMAX)
30567 YMIN=MIN(Y1(I),YMIN)
30568500 CONTINUE
30569 IF(IARG.GT.1) THEN
30570 DO 550 I=1,N
30571 YMAX=MAX(Y2(I),YMAX)
30572 YMIN=MIN(Y2(I),YMIN)
30573550 CONTINUE
30574 ENDIF
30575 YMAX=(YMAX-YMIN)/40.0D0+YMAX
30576 YMIN=YMIN-(YMAX-YMIN)/40.0D0
30577 YZOOM=(YMAX-YMIN)/DBLE(IZEIL)
30578 IF(YZOOM.LT.EPS) THEN
30579 WRITE(LOUT,'(1X,A)')
30580 & 'XGRAPH:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30581 RETURN
30582 ENDIF
30583C
30584C*** plot curve Y1
30585C
30586 ILAST=-1
30587 LLAST=-1
30588 DO 1200 K=1,N
30589 L=NINT((X(K)-XMIN)/XZOOM)
30590 I=NINT((YMAX-Y1(K))/YZOOM)
30591 IF(ILAST.GE.0) THEN
30592 LD = L-LLAST
30593 ID = I-ILAST
30594 DO 55 II=0,LD,SIGN(1,LD)
30595 DO 66 KK=0,ID,SIGN(1,ID)
30596 COL(II+LLAST,KK+ILAST)=SYMB(1)
30597 66 CONTINUE
30598 55 CONTINUE
30599 ELSE
30600 COL(L,I)=SYMB(1)
30601 ENDIF
30602 ILAST = I
30603 LLAST = L
306041200 CONTINUE
30605C
30606 IF(IARG.GT.1) THEN
30607C
30608C*** plot curve Y2
30609C
30610 DO 1250 K=1,N
30611 L=NINT((X(K)-XMIN)/XZOOM)
30612 I=NINT((YMAX-Y2(K))/YZOOM)
30613 COL(L,I)=SYMB(2)
306141250 CONTINUE
30615 ENDIF
30616C
30617C*** write it
30618C
30619 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30620C
30621C*** write range of X
30622C
30623 XZOOM = (XMAX-XMIN)/DBLE(7)
30624 WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30625C
30626 DO 1300 K=0,IZEIL-1
30627 YPOS=YMAX-((DBLE(K)+0.5D0)*YZOOM)
30628 WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30629 110 FORMAT(1X,1PE9.2,70A1)
306301300 CONTINUE
30631C
30632C*** write range of X
30633C
30634 XZOOM = (XMAX-XMIN)/DBLE(7)
30635 WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30636 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30637 120 FORMAT(6X,7(1PE10.3))
30638 END
30639
30640*$ CREATE DT_XGLOGY.FOR
30641*COPY DT_XGLOGY
30642*
30643*===qglogy=============================================================*
30644*
30645 SUBROUTINE DT_XGLOGY(N,IARG,X,Y1,Y2)
30646C***********************************************************************
30647C
30648C calculate quasi graphic picture with 25 lines and 79 columns
30649C logarithmic y axis
30650C ranges will be chosen automatically
30651C
30652C input N dimension of input fields
30653C IARG number of curves (fields) to plot
30654C X field of X
30655C Y1 field of Y1
30656C Y2 field of Y2
30657C
30658C This subroutine is written by R. Engel.
30659C***********************************************************************
30660C
30661 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30662 SAVE
30663
30664 PARAMETER ( LINP = 10 ,
30665 & LOUT = 6 ,
30666 & LDAT = 9 )
30667 DIMENSION X(N),Y1(N),Y2(N)
30668 PARAMETER (EPS=1.D-30)
30669 PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30670 CHARACTER SYMB(5)
30671 CHARACTER COL(0:149,0:49)
30672 PARAMETER (DEPS = 1.D-10)
30673C
30674 DATA SYMB /'0','e','z','#','x'/
30675C
30676 ISPALT=IBREIT-10
30677C
30678C*** automatic range fitting
30679C
30680 XMAX=X(1)
30681 XMIN=X(1)
30682 DO 600 I=1,N
30683 XMAX=MAX(X(I),XMAX)
30684 XMIN=MIN(X(I),XMIN)
30685 600 CONTINUE
30686 XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30687C
30688 ITEST=0
30689 DO 1100 K=0,IZEIL-1
30690 ITEST=ITEST+1
30691 IF (ITEST.EQ.IYRAST) THEN
30692 DO 1010 L=1,ISPALT-1
30693 COL(L,K)='-'
306941010 CONTINUE
30695 COL(ISPALT,K)='+'
30696 ITEST=0
30697 DO 1020 L=0,ISPALT-1,IXRAST
30698 COL(L,K)='+'
306991020 CONTINUE
30700 ELSE
30701 DO 1030 L=1,ISPALT-1
30702 COL(L,K)=' '
307031030 CONTINUE
30704 DO 1040 L=0,ISPALT-1,IXRAST
30705 COL(L,K)='|'
307061040 CONTINUE
30707 COL(ISPALT,K)='|'
30708 ENDIF
307091100 CONTINUE
30710C
30711C*** plot curve Y1
30712C
30713 YMAX=Y1(1)
30714 YMIN=MAX(Y1(1),EPS)
30715 DO 500 I=1,N
30716 YMAX =MAX(Y1(I),YMAX)
30717 IF(Y1(I).GT.EPS) THEN
30718 IF(YMIN.EQ.EPS) THEN
30719 YMIN = Y1(I)/10.D0
30720 ELSE
30721 YMIN = MIN(Y1(I),YMIN)
30722 ENDIF
30723 ENDIF
30724500 CONTINUE
30725 IF(IARG.GT.1) THEN
30726 DO 550 I=1,N
30727 YMAX=MAX(Y2(I),YMAX)
30728 IF(Y2(I).GT.EPS) THEN
30729 IF(YMIN.EQ.EPS) THEN
30730 YMIN = Y2(I)
30731 ELSE
30732 YMIN = MIN(Y2(I),YMIN)
30733 ENDIF
30734 ENDIF
30735550 CONTINUE
30736 ENDIF
30737C
30738 DO 560 I=1,N
30739 Y1(I) = MAX(Y1(I),YMIN)
30740 560 CONTINUE
30741 IF(IARG.GT.1) THEN
30742 DO 570 I=1,N
30743 Y2(I) = MAX(Y2(I),YMIN)
30744 570 CONTINUE
30745 ENDIF
30746C
30747 IF(YMAX.LE.YMIN) THEN
30748 WRITE(LOUT,'(/1X,A,2E12.3,/)')
30749 & 'XGLOGY:ERROR:YMIN,YMAX ',YMIN,YMAX
30750 WRITE(LOUT,'(1X,A)') 'MIN = MAX, OUTPUT SUPPRESSED'
30751 RETURN
30752 ENDIF
30753C
30754 YMA=(LOG10(YMAX)-LOG10(YMIN))/20.0D0+LOG10(YMAX)
30755 YMI=LOG10(YMIN)-(LOG10(YMAX)-LOG10(YMIN))/20.0D0
30756 YZOOM=(YMA-YMI)/DBLE(IZEIL)
30757 IF(YZOOM.LT.EPS) THEN
30758 WRITE(LOUT,'(1X,A)')
30759 & 'XGLOGY:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30760 RETURN
30761 ENDIF
30762C
30763C*** plot curve Y1
30764C
30765 ILAST=-1
30766 LLAST=-1
30767 DO 1200 K=1,N
30768 L=NINT((X(K)-XMIN)/XZOOM)
30769 I=NINT((YMA-LOG10(Y1(K)))/YZOOM)
30770 IF(ILAST.GE.0) THEN
30771 LD = L-LLAST
30772 ID = I-ILAST
30773 DO 55 II=0,LD,SIGN(1,LD)
30774 DO 66 KK=0,ID,SIGN(1,ID)
30775 COL(II+LLAST,KK+ILAST)=SYMB(1)
30776 66 CONTINUE
30777 55 CONTINUE
30778 ELSE
30779 COL(L,I)=SYMB(1)
30780 ENDIF
30781 ILAST = I
30782 LLAST = L
307831200 CONTINUE
30784C
30785 IF(IARG.GT.1) THEN
30786C
30787C*** plot curve Y2
30788C
30789 DO 1250 K=1,N
30790 L=NINT((X(K)-XMIN)/XZOOM)
30791 I=NINT((YMA-LOG10(Y2(K)))/YZOOM)
30792 COL(L,I)=SYMB(2)
307931250 CONTINUE
30794 ENDIF
30795C
30796C*** write it
30797C
30798 WRITE(LOUT,'(2X,A)') '(LOGARITHMIC Y AXIS)'
30799 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30800C
30801C*** write range of X
30802C
30803 XZOOM1 = (XMAX-XMIN)/DBLE(7)
30804 WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30805C
30806 DO 1300 K=0,IZEIL-1
30807 YPOS=10.D0**(YMA-((DBLE(K)+0.5D0)*YZOOM))
30808 WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30809 110 FORMAT(1X,1PE9.2,70A1)
308101300 CONTINUE
30811C
30812C*** write range of X
30813C
30814 WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30815 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30816 120 FORMAT(6X,7(1PE10.3))
30817C
30818 END
30819
30820*$ CREATE DT_SRPLOT.FOR
30821*COPY DT_SRPLOT
30822*
30823*===plot===============================================================*
30824*
30825 SUBROUTINE DT_SRPLOT(X,Y,N,M,MM,XO,DX,YO,DY)
30826
30827 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30828 SAVE
30829
30830 PARAMETER ( LINP = 10 ,
30831 & LOUT = 6 ,
30832 & LDAT = 9 )
30833*
30834* initial version
30835* J. Ranft, (FORTRAN-Programmierung,J.R.,Teubner, Leipzig, 72)
30836* This is a subroutine of fluka to plot Y across the page
30837* as a function of X down the page. Up to 37 curves can be
30838* plotted in the same picture with different plotting characters.
30839* Output of first 10 overprinted characters addad by FB 88
30840* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
30841*
30842* Input Variables:
30843* X = array containing the values of X
30844* Y = array containing the values of Y
30845* N = number of values in X and in Y
30846* can exceed the fixed number of lines
30847* M = number of different curves X,Y are containing
30848* MM = number of points in each curve i.e. N=M*MM
30849* XO = smallest value of X to be plotted
30850* DX = increment of X between subsequent lines
30851* YO = smallest value of Y to be plotted
30852* DY = increment of Y between subsequent character spaces
30853*
30854* other variables used inside:
30855* XX = numbers along the X-coordinate axis
30856* YY = numbers along the Y-coordinate axis
30857* LL = ten lines temporary storage for the plot
30858* L = character set used to plot different curves
30859* LOV = memorizes overprinted symbols
30860* the first 10 overprinted symbols are printed on
30861* the end of the line to avoid ambiguities
30862* (added by FB as considered quite helpful)
30863*
30864*********************************************************************
30865*
30866 DIMENSION XX(61),YY(61),LL(101,10)
30867 DIMENSION X(N),Y(N),L(40),LOV(40,10)
333481d6 30868 INTEGER*4 LL, L, LOV
9aaba0d6 30869 DATA L/
30870 11H*,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HZ,
30871 21H+,1HA,1HO,1HB,1HC,1HD,1HE,1HF,1HG,1HH,
30872 31HI,1HJ,1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,
30873 41HS,1HT,1HU,1HV,1HW,1HX,1HY,1H1,1H-,1H /
30874*
30875*
30876 MN=51
30877 DO 10 I=1,MN
30878 AI=I-1
30879 10 XX(I)=XO+AI*DX
30880 DO 20 I=1,11
30881 AI=I-1
30882 20 YY(I)=YO+10.0D0*AI*DY
30883 WRITE(LOUT, 500) (YY(I),I=1,11)
30884 MMN=MN-1
30885*
30886*
30887 DO 90 JJ=1,MMN,10
30888 JJJ=JJ-1
30889 DO 30 I=1,101
30890 DO 30 J=1,10
30891 30 LL(I,J)=L(40)
30892 DO 40 I=1,101
30893 40 LL(I,1)=L(39)
30894 DO 50 I=1,101,10
30895 DO 50 J=1,10
30896 50 LL(I,J)=L(38)
30897 DO 60 I=1,40
30898 DO 60 J=1,10
30899 60 LOV(I,J)=L(40)
30900*
30901*
30902 DO 70 I=1,M
30903 DO 70 J=1,MM
30904 II=J+(I-1)*MM
30905 AIX=(X(II)-(XO-DX/2.0D0))/DX+1.0D0
30906 AIY=(Y(II)-(YO-DY/2.0D0))/DY+1.0D0
30907 AIX=AIX-DBLE(JJJ)
30908* changed Sept.88 by FB to avoid INTEGER OVERFLOW
30909 IF( AIX .GT. 1.D0.AND. AIX .LT. 11.D0.AND. AIY .GT. 1.D0.AND
30910 + . AIY .LT. 102.D0) THEN
30911 IX=INT(AIX)
30912 IY=INT(AIY)
30913 IF( IX.GT. 0.AND. IX.LE. 10.AND. IY.GT. 0.AND. IY.LE. 101)
30914 + THEN
30915 IF(LL(IY,IX).NE.L(38).AND.LL(IY,IX).NE.L(39)) LOV(I,IX)
30916 + =LL(IY,IX)
30917 LL(IY,IX)=L(I)
30918 ENDIF
30919 ENDIF
30920 70 CONTINUE
30921*
30922*
30923 DO 80 I=1,10
30924 II=I+JJJ
30925 III=II+1
30926 WRITE(LOUT,510) XX(II),XX(III) , (LL(J,I),J=1,101) ,
30927 & (LOV(J,I),J=1,10)
30928 80 CONTINUE
30929 90 CONTINUE
30930*
30931*
30932 WRITE(LOUT, 520)
30933 WRITE(LOUT, 500) (YY(I),I=1,11)
30934 RETURN
30935*
30936 500 FORMAT(11X,11(1PE10.2),11HOVERPRINTED)
30937 510 FORMAT(1X,2(1PE10.2),101A1,1H ,10A1)
30938 520 FORMAT(20X,10('1---------'),'1')
30939 END
30940
30941*$ CREATE DT_DEFSET.FOR
30942*COPY DT_DEFSET
30943*
30944*===defset=============================================================*
30945*
30946 BLOCK DATA DT_DEFSET
30947
30948 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30949 SAVE
30950
30951* flags for input different options
30952 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
30953 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
30954 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
30955 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
30956* emulsion treatment
30957 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
30958 & NCOMPO,IEMUL
30959
30960* / DTFLG1 /
30961 DATA IFRAG / 2, 1 /
30962 DATA IRESCO / 1 /
30963 DATA IMSHL / 1 /
30964 DATA IRESRJ / 0 /
30965 DATA IOULEV / -1, -1, -1, -1, -1, -1 /
30966 DATA LEMCCK / .FALSE. /
30967 DATA LHADRO / .FALSE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,
30968 & .TRUE.,.TRUE.,.TRUE./
30969 DATA LSEADI / .TRUE. /
30970 DATA LEVAPO / .TRUE. /
30971 DATA IFRAME / 1 /
30972 DATA ITRSPT / 0 /
30973
30974* / DTCOMP /
30975 DATA EMUFRA / NCOMPX*0.0D0 /
30976 DATA IEMUMA / NCOMPX*1 /
30977 DATA IEMUCH / NCOMPX*1 /
30978 DATA NCOMPO / 0 /
30979 DATA IEMUL / 0 /
30980
30981 END
30982
30983*$ CREATE DT_HADPRP.FOR
30984*COPY DT_HADPRP
30985*
30986*===hadprp=============================================================*
30987*
30988 BLOCK DATA DT_HADPRP
30989
30990 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30991 SAVE
30992
30993* auxiliary common for reggeon exchange (DTUNUC 1.x)
30994 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
30995 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
30996 & IQTCHR(-6:6),MQUARK(3,39)
30997* hadron index conversion (BAMJET <--> PDG)
30998 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
30999 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
31000 & IAMCIN(210)
31001* names of hadrons used in input-cards
31002 CHARACTER*8 BTYPE
31003 COMMON /DTPAIN/ BTYPE(30)
31004
31005* / DTQUAR /
31006*----------------------------------------------------------------------*
31007* *
31008* Quark content of particles: *
31009* index quark el. charge bar. charge isospin isospin3 *
31010* 1 = u 2/3 1/3 1/2 1/2 *
31011* -1 = ubar -2/3 -1/3 1/2 -1/2 *
31012* 2 = d -1/3 1/3 1/2 -1/2 *
31013* -2 = dbar 1/3 -1/3 1/2 1/2 *
31014* 3 = s -1/3 1/3 0 0 *
31015* -3 = sbar 1/3 -1/3 0 0 *
31016* 4 = c 2/3 1/3 0 0 *
31017* -4 = cbar -2/3 -1/3 0 0 *
31018* 5 = b -1/3 1/3 0 0 *
31019* -5 = bbar 1/3 -1/3 0 0 *
31020* 6 = t 2/3 1/3 0 0 *
31021* -6 = tbar -2/3 -1/3 0 0 *
31022* *
31023* Mquark = particle quark composition (Paprop numbering) *
31024* Iqechr = electric charge ( in 1/3 unit ) *
31025* Iqbchr = baryonic charge ( in 1/3 unit ) *
31026* Iqichr = isospin ( in 1/2 unit ), z component *
31027* Iqschr = strangeness *
31028* Iqcchr = charm *
31029* Iquchr = beauty *
31030* Iqtchr = ...... *
31031* *
31032*----------------------------------------------------------------------*
31033 DATA IQECHR / -2, 1, -2, 1, 1, -2, 0, 2, -1, -1, 2, -1, 2 /
31034 DATA IQBCHR / 6*-1, 0, 6*1 /
31035 DATA IQICHR / 4*0, 1, -1, 0, 1, -1, 4*0 /
31036 DATA IQSCHR / 3*0, 1, 5*0, -1, 3*0 /
31037 DATA IQCCHR / 2*0, -1, 7*0, 1, 2*0 /
31038 DATA IQUCHR / 0, 1, 9*0, -1, 0 /
31039 DATA IQTCHR / -1, 11*0, 1 /
31040 DATA MQUARK /
31041 & 2, 1, 1, -2,-1,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31042 & 0, 0, 0, 0, 0, 0, 2, 2, 1, -2,-2,-1, 0, 0, 0,
31043 & 0, 0, 0, 0, 0, 0, 1,-2, 0, 2,-1, 0, 1,-3, 0,
31044 & 3,-1, 0, 1, 2, 3, -1,-2,-3, 0, 0, 0, 2, 2, 3,
31045 & 1, 1, 3, 1, 2, 3, 1,-1, 0, 2,-3, 0, 3,-2, 0,
31046 & 2,-2, 0, 3,-3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31047 & -1,-1,-3, -1,-2,-3, -2,-2,-3, 1, 3, 3, -1,-3,-3,
31048 & 2, 3, 3, -2,-3,-3, 3, 3, 3, -3,-3,-3 /
31049
31050* / DTHAIC /
31051* (renamed) (HAdron InDex COnversion)
31052* translation table version filled up by r.e. 25.01.94 *
31053 DATA IAMCIN /
31054 &2212,-2212,11,-11,12, -12,22,2112,-2112,-13,
31055 &13,130,211,-211,321, -321,3122,-3122,310,3112,
31056 &3222,3212,111,311,-311, 0,0,0,0,0,
31057 &221,213,113,-213,223, 323,313,-323,-313,10323,
31058 &10313,-10323,-10313,30323,30313, -30323,-30313,3224,3214,3114,
31059 &3216,3218,2224,2214,2114, 1114,12224,12214,12114,11114,
31060 &99999,99999,22212,22112,32124, 31214,-2224,-2214,-2114,-1114,
31061 &-12224,-12214,-12114,-11114,-2124, -1214,4*99999,
31062 &5*99999, 5*99999,
31063 &4*99999,331, 333,3322,3312,-3222,-3212,
31064 &-3112,-3322,-3312,3224,3214, 3114,3324,3314,3334,-3224,
31065 &-3214,-3114,-3324,-3314,-3334, 421,411,-411,-421,431,
31066 &-431,441,423,413,-413, -423,433,-433,20443,443,
31067 &-15,15,16,-16,14, -14,4122,4232,4132,4222,
31068 &4212,4112,3*99999, 3*99999,-4122,-4232,
31069 &-4132,-4222,-4212,-4112,99999, 5*99999,
31070 &5*99999, 5*99999,
31071 &10*99999,
31072 &5*99999 , 20211,20111,-20211,99999,20321,
31073 &-20321,20311,-20311,7*99999 ,
31074 &7*99999,12212,12112,99999/
31075
31076* / DTHAIC /
31077* (HAdron InDex COnversion)
31078 DATA (IPDG2(1,K),K=1,7)
31079 & / -11, -12, -13, -15, -16, -14, 0/
31080 DATA (IBAM2(1,K),K=1,7)
31081 & / 4, 6, 10, 131, 134, 136, 0/
31082 DATA (IPDG2(2,K),K=1,7)
31083 & / 11, 12, 22, 13, 15, 16, 14/
31084 DATA (IBAM2(2,K),K=1,7)
31085 & / 3, 5, 7, 11, 132, 133, 135/
31086 DATA (IPDG3(1,K),K=1,22)
31087 & / -211, -321, -311, -213, -323, -313, -411, -421,
31088 & -431, -413, -423, -433, 0, 0, 0, 0,
31089 & 0, 0, 0, 0, 0, 0/
31090 DATA (IBAM3(1,K),K=1,22)
31091 & / 14, 16, 25, 34, 38, 39, 118, 119,
31092 & 121, 125, 126, 128, 0, 0, 0, 0,
31093 & 0, 0, 0, 0, 0, 0/
31094 DATA (IPDG3(2,K),K=1,22)
31095 & / 130, 211, 321, 310, 111, 311, 221, 213,
31096 & 113, 223, 323, 313, 331, 333, 421, 411,
31097 & 431, 441, 423, 413, 433, 443/
31098 DATA (IBAM3(2,K),K=1,22)
31099 & / 12, 13, 15, 19, 23, 24, 31, 32,
31100 & 33, 35, 36, 37, 95, 96, 116, 117,
31101 & 120, 122, 123, 124, 127, 130/
31102 DATA (IPDG4(1,K),K=1,29)
31103 & / -2212, -2112, -3122, -2224, -2214, -2114, -1114, -2124,
31104 & -1214, -3222, -3212, -3112, -3322, -3312, -3224, -3214,
31105 & -3114, -3324, -3314, -3334, -4122, -4232, -4132, -4222,
31106 & -4212, -4112, 0, 0, 0/
31107 DATA (IBAM4(1,K),K=1,29)
31108 & / 2, 9, 18, 67, 68, 69, 70, 75,
31109 & 76, 99, 100, 101, 102, 103, 110, 111,
31110 & 112, 113, 114, 115, 149, 150, 151, 152,
31111 & 153, 154, 0, 0, 0/
31112 DATA (IPDG4(2,K),K=1,29)
31113 & / 2212, 2112, 3122, 3112, 3222, 3212, 3224, 3214,
31114 & 3114, 3216, 3218, 2224, 2214, 2114, 1114, 3322,
31115 & 3312, 3224, 3214, 3114, 3324, 3314, 3334, 4122,
31116 & 4232, 4132, 4222, 4212, 4112/
31117 DATA (IBAM4(2,K),K=1,29)
31118 & / 1, 8, 17, 20, 21, 22, 48, 49,
31119 & 50, 51, 52, 53, 54, 55, 56, 97,
31120 & 98, 104, 105, 106, 107, 108, 109, 137,
31121 & 138, 139, 140, 141, 142/
31122 DATA (IPDG5(1,K),K=1,19)
31123 & /-10323,-10313,-30323,-30313,-12224,-12214,-12114,-11114,
31124 & -20211,-20321,-20311, 0, 0, 0, 0, 0,
31125 & 0, 0, 0/
31126 DATA (IBAM5(1,K),K=1,19)
31127 & / 42, 43, 46, 47, 71, 72, 73, 74,
31128 & 188, 191, 193, 0, 0, 0, 0, 0,
31129 & 0, 0, 0/
31130 DATA (IPDG5(2,K),K=1,19)
31131 & / 10323, 10313, 30323, 30313, 12224, 12214, 12114, 11114,
31132 & 22212, 22112, 32124, 31214, 20443, 20211, 20111, 20321,
31133 & 20311, 12212, 12112/
31134 DATA (IBAM5(2,K),K=1,19)
31135 & / 40, 41, 44, 45, 57, 58, 59, 60,
31136 & 63, 64, 65, 66, 129, 186, 187, 190,
31137 & 192, 208, 209/
31138
31139* / DTPAIN /
31140* internal particle names
31141 DATA BTYPE / 'PROTON ' , 'APROTON ' , 'ELECTRON' , 'POSITRON' ,
31142 &'NEUTRIE ' , 'ANEUTRIE' , 'PHOTON ' , 'NEUTRON ' , 'ANEUTRON' ,
31143 &'MUON+ ' , 'MUON- ' , 'KAONLONG' , 'PION+ ' , 'PION- ' ,
31144 &'KAON+ ' , 'KAON- ' , 'LAMBDA ' , 'ALAMBDA ' , 'KAONSHRT' ,
31145 &'SIGMA- ' , 'SIGMA+ ' , 'SIGMAZER' , 'PIZERO ' , 'KAONZERO' ,
31146 &'AKAONZER' , 'NEUTRIM ' , 'ANEUTRIM' , 'NEUTRIT ' , 'ANEUTRIT' ,
31147 &'BLANK ' /
31148
31149 END
31150
31151*$ CREATE DT_BLKD46.FOR
31152*COPY DT_BLKD46
31153*
31154*===blkd46=============================================================*
31155*
31156 BLOCK DATA DT_BLKD46
31157
31158 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31159 SAVE
31160
31161 PARAMETER ( AMELCT = 0.51099906 D-03 )
31162 PARAMETER ( AMMUON = 0.105658389 D+00 )
31163
31164* particle properties (BAMJET index convention)
31165 CHARACTER*8 ANAME
31166 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
31167 & IICH(210),IIBAR(210),K1(210),K2(210)
31168
31169* / DTPART /
31170* Particle masses Engel version JETSET compatible
31171C DATA (AAM(K),K=1,85) /
31172C & .9383D+00, .9383D+00, AMELCT , AMELCT , .0000D+00,
31173C & .0000D+00, .0000D+00, .9396D+00, .9396D+00, AMMUON ,
31174C & AMMUON , .4977D+00, .1396D+00, .1396D+00, .4936D+00,
31175C & .4936D+00, .1116D+01, .1116D+01, .4977D+00, .1197D+01,
31176C & .1189D+01, .1193D+01, .1350D+00, .4977D+00, .4977D+00,
31177C & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31178C & .5488D+00, .7669D+00, .7700D+00, .7669D+00, .7820D+00,
31179C & .8921D+00, .8962D+00, .8921D+00, .8962D+00, .1300D+01,
31180C & .1300D+01, .1300D+01, .1300D+01, .1421D+01, .1421D+01,
31181C & .1421D+01, .1421D+01, .1383D+01, .1384D+01, .1387D+01,
31182C & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
31183C & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
31184C & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
31185C & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
31186C & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
31187C & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
31188C & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 /
31189C DATA (AAM(K),K=86,183) /
31190C & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
31191C & .1700D+01, .1700D+01, .1820D+01, .2030D+01, .9575D+00,
31192C & .1019D+01, .1315D+01, .1321D+01, .1189D+01, .1193D+01,
31193C & .1197D+01, .1315D+01, .1321D+01, .1383D+01, .1384D+01,
31194C & .1387D+01, .1532D+01, .1535D+01, .1672D+01, .1383D+01,
31195C & .1384D+01, .1387D+01, .1532D+01, .1535D+01, .1672D+01,
31196C & .1865D+01, .1869D+01, .1869D+01, .1865D+01, .1969D+01,
31197C & .1969D+01, .2980D+01, .2007D+01, .2010D+01, .2010D+01,
31198C & .2007D+01, .2113D+01, .2113D+01, .3686D+01, .3097D+01,
31199C & .1784D+01, .1784D+01, .0000D+00, .0000D+00, .0000D+00,
31200C & .0000D+00, .2285D+01, .2460D+01, .2460D+01, .2452D+01,
31201C & .2453D+01, .2454D+01, .2560D+01, .2560D+01, .2730D+01,
31202C & .3610D+01, .3610D+01, .3790D+01, .2285D+01, .2460D+01,
31203C & .2460D+01, .2452D+01, .2453D+01, .2454D+01, .2560D+01,
31204C & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
31205C & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31206C & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31207C & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31208C & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31209C & .1250D+01, .1250D+01, .1250D+01 /
31210C DATA (AAM ( I ), I = 184,210 ) /
31211C & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31212C & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31213C & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31214C & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31215C & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31216C & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31217C & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31218C & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31219C & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31220* sr 25.1.06: particle masses adjusted to Pythia
31221 DATA (AAM(K),K=1,85) /
31222 & .938270E+00,.938270E+00, AMELCT , AMELCT ,.000000E+00,
31223 & .000000E+00,.000000E+00,.939570E+00,.939570E+00, AMMUON ,
31224 & AMMUON ,.497670E+00,.139570E+00,.139570E+00,.493600E+00,
31225 & .493600E+00,.111568E+01,.111568E+01,.497670E+00,.119744E+01,
31226 & .118937E+01,.119255E+01,.134980E+00,.497670E+00,.497670E+00,
31227 & .0000D+00, .0000D+00, .0000D+00 , .0000D+00, .0000D+00,
31228 & .547450E+00,.766900E+00,.768500E+00,.766900E+00,.781940E+00,
31229 & .891600E+00,.896100E+00,.891600E+00,.896100E+00,.129000E+01,
31230 & .129000E+01,.129000E+01,.129000E+01, .1421D+01, .1421D+01,
31231 & .1421D+01, .1421D+01,.138280E+01,.138370E+01,.138720E+01,
31232 & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
31233 & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
31234 & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
31235 & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
31236 & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
31237 & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
31238 & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 /
31239 DATA (AAM(K),K=86,183) /
31240 & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
31241 & .1700D+01, .1700D+01, .1820D+01, .2030D+01,.957770E+00,
31242 & .101940E+01,.131490E+01,.132130E+01,.118937E+01,.119255E+01,
31243 & .119744E+01,.131490E+01,.132130E+01,.138280E+01,.138370E+01,
31244 & .138720E+01,.153180E+01, .1535D+01,.167245E+01,.138280E+01,
31245 & .138370E+01,.138720E+01,.153180E+01, .1535D+01,.167245E+01,
31246 & .186450E+01,.186930E+01,.186930E+01,.186450E+01,.196850E+01,
31247 & .196850E+01,.297980E+01,.200670E+01, .2010D+01, .2010D+01,
31248 & .200670E+01,.211240E+01,.211240E+01, .3686D+01,.309688E+01,
31249 & .177700E+01,.177700E+01, .0000D+00, .0000D+00, .0000D+00,
31250 & .0000D+00,.228490E+01,.246560E+01,.247030E+01,.245290E+01,
31251 & .245350E+01,.245210E+01, .2560D+01, .2560D+01, .2730D+01,
31252 & .3610D+01, .3610D+01, .3790D+01,.228490E+01,.246560E+01,
31253 & .2460D+01,.245290E+01,.245350E+01,.245210E+01, .2560D+01,
31254 & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
31255 & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31256 & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31257 & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31258 & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31259 & .1250D+01, .1250D+01, .1250D+01 /
31260 DATA (AAM ( I ), I = 184,210 ) /
31261 & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31262 & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31263 & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31264 & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31265 & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31266 & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31267 & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31268 & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31269 & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31270* Particle mean lives
31271 DATA (TAU(K),K=1,183) /
31272 & .1000D+19, .1000D+19, .1000D+19, .1000D+19, .1000D+19,
31273 & .1000D+19, .1000D+19, .9180D+03, .9180D+03, .2200D-05,
31274 & .2200D-05, .5200D-07, .2600D-07, .2600D-07, .1200D-07,
31275 & .1200D-07, .2600D-09, .2600D-09, .9000D-10, .1500D-09,
31276 & .8000D-10, .5000D-14, .8000D-16, .0000D+00, .0000D+00,
31277 & 70*.0000D+00,
31278 & .0000D+00, .3000D-09, .1700D-09, .8000D-10, .1000D-13,
31279 & .1500D-09, .3000D-09, .1700D-09, .0000D+00, .0000D+00,
31280 & .0000D+00, .0000D+00, .0000D+00, .1000D-09, .0000D+00,
31281 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .1000D-09,
31282 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31283 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31284 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31285 & .9000D-11, .9000D-11, .9000D-11, .9000D-11, .1000D+19,
31286 & .1000D+19, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31287 & 40*.0000D+00,
31288 & .0000D+00, .0000D+00, .0000D+00 /
31289 DATA ( TAU ( I ), I = 184,210 ) /
31290 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31291 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31292 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31293 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31294 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31295 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31296 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31297 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31298 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00/
31299* Resonance width Gamma in GeV
31300 DATA (GA(K),K= 1,85) /
31301 & 30*.0000D+00,
31302 & .8500D-06, .1520D+00, .1520D+00, .1520D+00, .1000D-01,
31303 & .7900D-01, .7900D-01, .7900D-01, .7900D-01, .4500D+00,
31304 & .4500D+00, .4500D+00, .4500D+00, .1080D+00, .1080D+00,
31305 & .1080D+00, .1080D+00, .5000D-01, .5000D-01, .5000D-01,
31306 & .8500D-01, .1800D+00, .1150D+00, .1150D+00, .1150D+00,
31307 & .1150D+00, .2000D+00, .2000D+00, .2000D+00, .2000D+00,
31308 & .2000D+00, .2000D+00, .1000D+00, .1000D+00, .2000D+00,
31309 & .2000D+00, .1150D+00, .1150D+00, .1150D+00, .1150D+00,
31310 & .2000D+00, .2000D+00, .2000D+00, .2000D+00, .1000D+00,
31311 & .1000D+00, .2000D+00, .1000D+00, .1000D+00, .1000D+00,
31312 & .1000D+00, .1000D+00, .1000D+00, .1000D+00, .2000D+00 /
31313 DATA (GA(K),K= 86,183) /
31314 & .2000D+00, .2000D+00, .2000D+00, .1500D+00, .1500D+00,
31315 & .1500D+00, .1500D+00, .8500D-01, .1800D+00, .2000D-02,
31316 & .4000D-02, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31317 & .0000D+00, .0000D+00, .0000D+00, .3400D-01, .3400D-01,
31318 & .3600D-01, .9000D-02, .9000D-02, .0000D+00, .3400D-01,
31319 & .3400D-01, .3600D-01, .9000D-02, .9000D-02, .0000D+00,
31320 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31321 & .0000D+00, .0000D+00, .5000D-02, .2000D-02, .2000D-02,
31322 & .5000D-02, .2000D-02, .2000D-02, .2000D-03, .7000D-03,
31323 & 50*.0000D+00,
31324 & .3000D+00, .3000D+00, .3000D+00 /
31325 DATA ( GA ( I ), I = 184,210 ) /
31326 & 2.00000000000000D-01, 2.00000000000000D-01, 3.00000000000000D-01,
31327 & 3.00000000000000D-01, 3.00000000000000D-01, 2.70000000000000D-01,
31328 & 2.50000000000000D-01, 2.50000000000000D-01, 2.50000000000000D-01,
31329 & 2.50000000000000D-01, 1.50000000000000D-01, 1.50000000000000D-01,
31330 & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31331 & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31332 & 6.00000000000000D-02, 6.00000000000000D-02, 6.00000000000000D-02,
31333 & 6.00000000000000D-02, 5.50000000000000D-02, 5.50000000000000D-02,
31334 & 2.00000000000000D-01, 2.00000000000000D-01, 0.00000000000000D+00/
31335* Particle names
31336* S+1385+Sigma+(1385) L02030+Lambda0(2030)
31337* Rho77=Rho(770) Om783=Omega(783) K*14=K*(1420) and so on
31338* designation N*@@ means N*@1(@2)
31339 DATA (ANAME(K),K=1,85) /
31340 & 'P ','AP ','E- ','E+ ','NUE ',
31341 & 'ANUE ','GAM ','NEU ','ANEU ','MUE+ ',
31342 & 'MUE- ','K0L ','PI+ ','PI- ','K+ ',
31343 & 'K- ','LAM ','ALAM ','K0S ','SIGM- ',
31344 & 'SIGM+ ','SIGM0 ','PI0 ','K0 ','AK0 ',
31345 & 'BLANK ','BLANK ','BLANK ','BLANK ','BLANK ',
31346 & 'ETA550 ','RHO+77 ','RHO077 ','RHO-77 ','OM0783 ',
31347 & 'K*+892 ','K*0892 ','K*-892 ','AK*089 ','KA+125 ',
31348 & 'KA0125 ','KA-125 ','AKA012 ','K*+142 ','K*0142 ',
31349 & 'K*-142 ','AK*014 ','S+1385 ','S01385 ','S-1385 ',
31350 & 'L01820 ','L02030 ','N*++12 ','N*+ 12 ','N*012 ',
31351 & 'N*-12 ','N*++16 ','N*+16 ','N*016 ','N*-16 ',
31352 & 'N*+14 ','N*014 ','N*+15 ','N*015 ','N*+18 ',
31353 & 'N*018 ','AN--12 ','AN*-12 ','AN*012 ','AN*+12 ',
31354 & 'AN--16 ','AN*-16 ','AN*016 ','AN*+16 ','AN*-15 ',
31355 & 'AN*015 ','DE*=24 ','RPI+49 ','RPI049 ','RPI-49 ',
31356 & 'PIN++ ','PIN+0 ','PIN+- ','PIN-0 ','PPPI ' /
31357 DATA (ANAME(K),K=86,183) /
31358 & 'PNPI ','APPPI ','APNPI ','K+PPI ','K-PPI ',
31359 & 'K+NPI ','K-NPI ','S+1820 ','S-2030 ','ETA* ',
31360 & 'PHI ','TETA0 ','TETA- ','ASIG- ','ASIG0 ',
31361 & 'ASIG+ ','ATETA0 ','ATETA+ ','SIG*+ ','SIG*0 ',
31362 & 'SIG*- ','TETA*0 ','TETA* ','OMEGA- ','ASIG*- ',
31363 & 'ASIG*0 ','ASIG*+ ','ATET*0 ','ATET*+ ','OMEGA+ ',
31364 & 'D0 ','D+ ','D- ','AD0 ','F+ ',
31365 & 'F- ','ETAC ','D*0 ','D*+ ','D*- ',
31366 & 'AD*0 ','F*+ ','F*- ','PSI ','JPSI ',
31367 & 'TAU+ ','TAU- ','NUET ','ANUET ','NUEM ',
31368 & 'ANUEM ','C0+ ','A+ ','A0 ','C1++ ',
31369 & 'C1+ ','C10 ','S+ ','S0 ','T0 ',
31370 & 'XU++ ','XD+ ','XS+ ','AC0- ','AA- ',
31371 & 'AA0 ','AC1-- ','AC1- ','AC10 ','AS- ',
31372 & 'AS0 ','AT0 ','AXU-- ','AXD- ','AXS ',
31373 & 'C1*++ ','C1*+ ','C1*0 ','S*+ ','S*0 ',
31374 & 'T*0 ','XU*++ ','XD*+ ','XS*+ ','TETA++ ',
31375 & 'AC1*-- ','AC1*- ','AC1*0 ','AS*- ','AS*0 ',
31376 & 'AT*0 ','AXU*-- ','AXD*- ','AXS*- ','ATET-- ',
31377 & 'RO ','R+ ','R- ' /
31378 DATA ( ANAME ( I ), I = 184,210 ) /
31379 &'AN*-14 ','AN*014 ','PI+130 ','PI0130 ','PI-130 ','F01400 ',
31380 &'K*+146 ','K*-146 ','K*0146 ','AK0146 ','L01600 ','AL0160 ',
31381 &'S+1660 ','S01660 ','S-1660 ','AS-166 ','AS0166 ','AS+166 ',
31382 &'X01950 ','X-1950 ','AX0195 ','AX+195 ','OM-225 ','AOM+22 ',
31383 &'N*+14 ','N*014 ','BLANK '/
31384* Charge of particles and resonances
31385 DATA (IICH ( I ), I = 1,210 ) /
31386 & 1, -1, -1, 1, 0, 0, 0, 0, 0, 1, -1, 0, 1, -1, 1,
31387 & -1, 0, 0, 0, -1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31388 & 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0,
31389 & -1, 0, 1, 0, -1, 0, 0, 2, 1, 0, -1, 2, 1, 0, -1,
31390 & 1, 0, 1, 0, 1, 0, -2, -1, 0, 1, -2, -1, 0, 1, -1,
31391 & 0, 1, 1, 0, -1, 2, 1, 0, -1, 2, 1, 0, -1, 2, 0,
31392 & 1, -1, 1, -1, 0, 0, 0, -1, -1, 0, 1, 0, 1, 1, 0,
31393 & -1, 0, -1, -1, -1, 0, 1, 0, 1, 1, 0, 1, -1, 0, 1,
31394 & -1, 0, 0, 1, -1, 0, 1, -1, 0, 0, 1, -1, 0, 0, 0,
31395 & 0, 1, 1, 0, 2, 1, 0, 1, 0, 0, 2, 1, 1, -1, -1,
31396 & 0, -2, -1, 0, -1, 0, 0, -2, -1, -1, 2, 1, 0, 1, 0,
31397 & 0, 2, 1, 1, 2, -2, -1, 0, -1, 0, 0, -2, -1, -1, -2,
31398 & 0, 1, -1, -1, 0, 1, 0, -1, 0, 1, -1, 0, 0, 0, 0,
31399 & 1, 0, -1, -1, 0, 1, 0, -1, 0, 1, -1, 1, 1, 0, 0/
31400* Particle baryonic charges
31401 DATA (IIBAR ( I ), I = 1,210 ) /
31402 & 1, -1, 0, 0, 0, 0, 0, 1, -1, 0, 0, 0, 0, 0, 0,
31403 & 0, 1, -1, 0, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0,
31404 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31405 & 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
31406 & 1, 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31407 & -1, 2, 0, 0, 0, 1, 1, 1, 1, 2, 2, 0, 0, 1, 1,
31408 & 1, 1, 1, 1, 0, 0, 1, 1, -1, -1, -1, -1, -1, 1, 1,
31409 & 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, 0, 0, 0, 0, 0,
31410 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31411 & 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, -1, -1,
31412 & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 1, 1, 1, 1, 1,
31413 & 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31414 & 0, 0, 0, -1, -1, 0, 0, 0, 0, 0, 0, 0, 0, 1, -1,
31415 & 1, 1, 1, -1, -1, -1, 1, 1, -1, -1, 1, -1, 1, 1, 0/
31416* First number of decay channels used for resonances
31417* and decaying particles
31418 DATA K1/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 16, 17,
31419 & 18, 24, 30, 34, 38, 40, 41, 43, 44, 136, 138, 330, 327, 328,
31420 & 2*330, 46, 51, 52, 54, 55, 58,
31421* 50
31422 & 60, 62, 64, 66, 68, 70, 72, 74, 82, 90, 98, 106, 109, 112, 114,
31423 & 123, 140, 141, 143, 145, 146, 150, 157, 164, 168, 174, 180, 187,
31424 & 194, 202, 210, 211, 213, 215, 216, 220, 227, 234, 238, 245, 252,
31425* 85
31426 & 254, 255, 256, 257, 259, 262, 265, 267, 269, 272, 276, 279, 282,
31427 & 286, 290, 293, 299, 331, 335, 339, 340, 341, 343, 344, 345, 346,
31428 & 347, 350, 353, 356, 358, 360, 363, 366, 369, 372, 374, 376, 379,
31429 & 383, 385, 387, 391, 394, 397, 400, 402, 405, 408, 410, 412, 414,
31430 & 417, 420, 425, 430, 431, 432, 433, 434, 448, 452, 457, 458, 459,
31431 & 460, 461, 462, 466, 468, 470, 472, 486, 490, 495, 496, 497, 498,
31432 & 499, 500, 504, 506, 508, 510, 511, 512, 513, 514, 515, 516, 517,
31433 & 518, 519, 522, 523, 524, 525, 526, 527, 528, 529, 530, 531, 534,
31434 & 537, 539, 541, 547, 553, 558, 563, 568, 572, 573, 574, 575, 576,
31435 & 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, 589,
31436 & 590, 596, 602 /
31437* Last number of decay channels used for resonances
31438* and decaying particles
31439 DATA K2/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 15, 16, 17,
31440 & 23, 29, 31, 35, 39, 40, 42, 43, 45, 137, 139, 330, 327, 328,
31441 & 2* 330, 50, 51, 53, 54, 57,
31442* 50
31443 & 59, 61, 63, 65, 67, 69, 71, 73, 81, 89, 97, 105, 108, 111, 113,
31444 & 122, 135, 140, 142, 144, 145, 149, 156, 163, 167, 173, 179, 186,
31445 & 193, 201, 209, 210, 212, 214, 215, 219, 226, 233, 237, 244, 251,
31446* 85
31447 & 253, 254, 255, 256, 258, 261, 264, 266, 268, 271, 275, 278, 281,
31448 & 285, 289, 292, 298, 307, 334, 338, 339, 340, 342, 343, 344, 345,
31449 & 346, 349, 352, 355, 357, 359, 362, 365, 368, 371, 373, 375, 378,
31450 & 382, 384, 386, 390, 393, 396, 399, 401, 404, 407, 409, 411, 413,
31451 & 416, 419, 424, 429, 430, 431, 432, 433, 447, 451, 456, 457, 458,
31452 & 459, 460, 461, 465, 467, 469, 471, 485, 489, 494, 495, 496, 497,
31453 & 498, 499, 503, 505, 507, 509, 510, 511, 512, 513, 514, 515, 516,
31454 & 517, 518, 521, 522, 523, 524, 525, 526, 527, 528, 529, 530, 533,
31455 & 536, 538, 540, 546, 552, 557, 562, 567, 571, 572, 573, 574, 575,
31456 & 576, 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588,
31457 & 589, 595, 601, 602 /
31458
31459 END
31460
31461*$ CREATE DT_BLKD47.FOR
31462*COPY DT_BLKD47
31463*
31464*===blkd47=============================================================*
31465*
31466 BLOCK DATA DT_BLKD47
31467
31468 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31469 SAVE
31470
31471* HADRIN: decay channel information
31472 PARAMETER (IDMAX9=602)
31473 CHARACTER*8 ZKNAME
31474 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
31475
31476* Name of decay channel
31477* Designation N*@ means N*@1(1236)
31478* @1=# means ++, @1 = = means --
31479* Designation P+/0/- means Pi+/Pi0/Pi- , respectively
31480 DATA (ZKNAME(K),K= 1, 85) /
31481 & 'P ','AP ','E- ','E+ ','NUE ',
31482 & 'ANUE ','GAM ','PE-NUE ','APEANU ','EANUNU ',
31483 & 'E-NUAN ','3PI0 ','PI+-0 ','PIMUNU ','PIE-NU ',
31484 & 'MU+NUE ','MU-NUE ','MU+NUE ','PI+PI0 ','PI++- ',
31485 & 'PI+00 ','M+P0NU ','E+P0NU ','MU-NU ','PI-0 ',
31486 & 'PI+-- ','PI-00 ','M-P0NU ','E-P0NU ','PPI- ',
31487 & 'NPI0 ','PD-NUE ','PM-NUE ','APPI+ ','ANPI0 ',
31488 & 'APE+NU ','APM+NU ','PI+PI- ','PI0PI0 ','NPI- ',
31489 & 'PPI0 ','NPI+ ','LAGA ','GAGA ','GAE+E- ',
31490 & 'GAGA ','GAGAP0 ','PI000 ','PI+-0 ','PI+-GA ',
31491 & 'PI+0 ','PI+- ','PI00 ','PI-0 ','PI+-0 ',
31492 & 'PI+- ','PI0GA ','K+PI0 ','K0PI+ ','KOPI0 ',
31493 & 'K+PI- ','K-PI0 ','AK0PI- ','AK0PI0 ','K-PI+ ',
31494 & 'K+PI0 ','K0PI+ ','K0PI0 ','K+PI- ','K-PI0 ',
31495 & 'K0PI- ','AK0PI0 ','K-PI+ ','K+PI0 ','K0PI+ ',
31496 & 'K+89P0 ','K08PI+ ','K+RO77 ','K0RO+7 ','K+OM07 ',
31497 & 'K+E055 ','K0PI0 ','K+PI+ ','K089P0 ','K+8PI- ' /
31498 DATA (ZKNAME(K),K= 86,170) /
31499 & 'K0R077 ','K+R-77 ','K+R-77 ','K0OM07 ','K0E055 ',
31500 & 'K-PI0 ','K0PI- ','K-89P0 ','AK08P- ','K-R077 ',
31501 & 'AK0R-7 ','K-OM07 ','K-E055 ','AK0PI0 ','K-PI+ ',
31502 & 'AK08P0 ','K-8PI+ ','AK0R07 ','AK0OM7 ','AK0E05 ',
31503 & 'LA0PI+ ','SI0PI+ ','SI+PI0 ','LA0PI0 ','SI+PI- ',
31504 & 'SI-PI+ ','LA0PI- ','SI0PI- ','NEUAK0 ','PK- ',
31505 & 'SI+PI- ','SI0PI0 ','SI-PI+ ','LA0ET0 ','S+1PI- ',
31506 & 'S-1PI+ ','SO1PI0 ','NEUAK0 ','PK- ','LA0PI0 ',
31507 & 'LA0OM0 ','LA0RO0 ','SI+RO- ','SI-RO+ ','SI0RO0 ',
31508 & 'LA0ET0 ','SI0ET0 ','SI+PI- ','SI-PI+ ','SI0PI0 ',
31509 & 'K0S ','K0L ','K0S ','K0L ','P PI+ ',
31510 & 'P PI0 ','N PI+ ','P PI- ','N PI0 ','N PI- ',
31511 & 'P PI+ ','N*#PI0 ','N*+PI+ ','PRHO+ ','P PI0 ',
31512 & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ',
31513 & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ',
31514 & 'N*-PI+ ','PRHO- ','NRHO0 ','N PI- ','N*0PI- ',
31515 & 'N*-PI0 ','NRHO- ','PETA0 ','N*#PI- ','N*+PI0 ' /
31516 DATA (ZKNAME(K),K=171,255) /
31517 & 'N*0PI+ ','PRHO0 ','NRHO+ ','NETA0 ','N*+PI- ',
31518 & 'N*0PI0 ','N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ',
31519 & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ',
31520 & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ',
31521 & 'N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ','N PI+ ',
31522 & 'PRHO0 ','NRHO+ ','LAMK+ ','S+ K0 ','S0 K+ ',
31523 & 'PETA0 ','P PI- ','N PI0 ','PRHO- ','NRHO0 ',
31524 & 'LAMK0 ','S0 K0 ','S- K+ ','NETA/ ','APPI- ',
31525 & 'APPI0 ','ANPI- ','APPI+ ','ANPI0 ','ANPI+ ',
31526 & 'APPI- ','AN*=P0 ','AN*-P- ','APRHO- ','APPI0 ',
31527 & 'ANPI- ','AN*=P+ ','AN*-P0 ','AN*0P- ','APRHO0 ',
31528 & 'ANRHO- ','APPI+ ','ANPI0 ','AN*-P+ ','AN*0P0 ',
31529 & 'AN*+P- ','APRHO+ ','ANRHO0 ','ANPI+ ','AN*0P+ ',
31530 & 'AN*+P0 ','ANRHO+ ','APPI0 ','ANPI- ','AN*=P+ ',
31531 & 'AN*-P0 ','AN*0P- ','APRHO0 ','ANRHO- ','APPI+, ',
31532 & 'ANPI0 ','AN*-P+ ','AN*0P0 ','AN*+P- ','APRHO+ ',
31533 & 'ANRHO0 ','PN*014 ','NN*=14 ','PI+0 ','PI+- ' /
31534 DATA (ZKNAME(K),K=256,340) /
31535 & 'PI-0 ','P+0 ','N++ ','P+- ','P00 ',
31536 & 'N+0 ','N+- ','N00 ','P-0 ','N-0 ',
31537 & 'P-- ','PPPI0 ','PNPI+ ','PNPI0 ','PPPI- ',
31538 & 'NNPI+ ','APPPI0 ','APNPI+ ','ANNPI0 ','ANPPI- ',
31539 & 'APNPI0 ','APPPI- ','ANNPI- ','K+PPI0 ','K+NPI+ ',
31540 & 'K0PPI0 ','K-PPI0 ','K-NPI+ ','AKPPI- ','AKNPI0 ',
31541 & 'K+NPI0 ','K+PPI- ','K0PPI0 ','K0NPI+ ','K-NPI0 ',
31542 & 'K-PPI- ','AKNPI- ','PAK0 ','SI+PI0 ','SI0PI+ ',
31543 & 'SI+ETA ','S+1PI0 ','S01PI+ ','NEUK- ','LA0PI- ',
31544 & 'SI-OM0 ','LA0RO- ','SI0RO- ','SI-RO0 ','SI-ET0 ',
31545 & 'SI0PI- ','SI-0 ','BLANC ','BLANC ','BLANC ',
31546 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31547 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31548 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31549 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31550 & 'EPI+- ','EPI00 ','GAPI+- ','GAGA* ','K+- ',
31551 & 'KLKS ','PI+-0 ','EGA ','LPI0 ','LPI ' /
31552 DATA (ZKNAME(K),K=341,425) /
31553 & 'APPI0 ','ANPI- ','ALAGA ','ANPI ','ALPI0 ',
31554 & 'ALPI+ ','LAPI+ ','SI+PI0 ','SI0PI+ ','LAPI0 ',
31555 & 'SI+PI- ','SI-PI+ ','LAPI- ','SI-PI0 ','SI0PI- ',
31556 & 'TE0PI0 ','TE-PI+ ','TE0PI- ','TE-PI0 ','TE0PI ',
31557 & 'TE-PI ','LAK- ','ALPI- ','AS-PI0 ','AS0PI- ',
31558 & 'ALPI0 ','AS+PI- ','AS-PI+ ','ALPI+ ','AS+PI0 ',
31559 & 'AS0PI+ ','AT0PI0 ','AT+PI- ','AT0PI+ ','AT+PI0 ',
31560 & 'AT0PI ','AT+PI ','ALK+ ','K-PI+ ','K-PI+0 ',
31561 & 'K0PI+- ','K0PI0 ','K-PI++ ','AK0PI+ ','K+PI-- ',
31562 & 'K0PI- ','K+PI- ','K+PI-0 ','AKPI-+ ','AK0PI0 ',
31563 & 'ETAPIF ','K++- ','K+AK0 ','ETAPI- ','K--+ ',
31564 & 'K-K0 ','PI00 ','PI+- ','GAGA ','D0PI0 ',
31565 & 'D0GA ','D0PI+ ','D+PI0 ','DFGA ','AD0PI- ',
31566 & 'D-PI0 ','D-GA ','AD0PI0 ','AD0GA ','F+GA ',
31567 & 'F+GA ','F-GA ','F-GA ','PSPI+- ','PSPI00 ',
31568 & 'PSETA ','E+E- ','MUE+- ','PI+-0 ','M+NN ',
31569 & 'E+NN ','RHO+NT ','PI+ANT ','K*+ANT ','M-NN ' /
31570 DATA (ZKNAME(K),K=426,510) /
31571 & 'E-NN ','RHO-NT ','PI-NT ','K*-NT ','NUET ',
31572 & 'ANUET ','NUEM ','ANUEM ','SI+ETA ','SI+ET* ',
31573 & 'PAK0 ','TET0K+ ','SI*+ET ','N*+AK0 ','N*++K- ',
31574 & 'LAMRO+ ','SI0RO+ ','SI+RO0 ','SI+OME ','PAK*0 ',
31575 & 'N*+AK* ','N*++K* ','SI+AK0 ','TET0PI ','SI+AK* ',
31576 & 'TET0RO ','SI0AK* ','SI+K*- ','TET0OM ','TET-RO ',
31577 & 'SI*0AK ','C0+PI+ ','C0+PI0 ','C0+PI- ','A+GAM ',
31578 & 'A0GAM ','TET0AK ','TET0K* ','OM-RO+ ','OM-PI+ ',
31579 & 'C1++AK ','A+PI+ ','C0+AK0 ','A0PI+ ','A+AK0 ',
31580 & 'T0PI+ ','ASI-ET ','ASI-E* ','APK0 ','ATET0K ',
31581 & 'ASI*-E ','AN*-K0 ','AN*--K ','ALAMRO ','ASI0RO ',
31582 & 'ASI-RO ','ASI-OM ','APK*0 ','AN*-K* ','AN*--K ',
31583 & 'ASI-K0 ','ATETPI ','ASI-K* ','ATETRO ','ASI0K* ',
31584 & 'ASI-K* ','ATE0OM ','ATE+RO ','ASI*0K ','AC-PI- ',
31585 & 'AC-PI0 ','AC-PI+ ','AA-GAM ','AA0GAM ','ATET0K ',
31586 & 'ATE0K* ','AOM+RO ','AOM+PI ','AC1--K ','AA-PI- ',
31587 & 'AC0-K0 ','AA0PI- ','AA-K0 ','AT0PI- ','C1++GA ' /
31588 DATA (ZKNAME(K),K=511,540) /
31589 & 'C1++GA ','C10GAM ','S+GAM ','S0GAM ','T0GAM ',
31590 & 'XU++GA ','XD+GAM ','XS+GAM ','A+AKPI ','T02PI+ ',
31591 & 'C1++2K ','AC1--G ','AC1-GA ','AC10GA ','AS-GAM ',
31592 & 'AS0GAM ','AT0GAM ','AXU--G ','AXD-GA ','AXS-GA ',
31593 & 'AA-KPI ','AT02PI ','AC1--K ','RH-PI+ ','RH+PI- ',
31594 & 'RH3PI0 ','RH0PI+ ','RH+PI0 ','RH0PI- ','RH-PI0 ' /
31595 DATA (ZKNAME(I),I=541,602)/
31596 & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHO0','ANRHO-','ANETA ',
31597 & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0','RH0PI+','RH+PI0',
31598 & '3PI+00','3PI-++','F0PI+ ','RH+PI-','RH0PI0','3PI000','3PI0+-',
31599 & 'F0PI0 ','RH0PI-','RH-PI0','3PI-00','3PI--+','F0PI- ','PI0PI0',
31600 & 'PI+PI-','K+K- ','K0AK0 ','L01600','AL0160','K*+146','K*-146',
31601 & 'K*0146','AK0146','S+1660','S01660','S-1660','AS-166','AS0166',
31602 & 'AS+166','X01690','X-1690','AX0169','AX+169','OM-225','AOM+22',
31603 & 'N*PPI0','N*NPI+','N*P2P0','N*PP+-','N*D+P0','N*D0P+','N*NPI0',
31604 & 'N*PPI-','N*N2P0','N*NP+-','N*D+P-','N*D0P0','BLANK '/
31605* Weight of decay channel
31606 DATA (WT(K),K= 1, 85) /
31607 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31608 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31609 & .1000D+01, .2100D+00, .1200D+00, .2700D+00, .4000D+00,
31610 & .1000D+01, .1000D+01, .6400D+00, .2100D+00, .6000D-01,
31611 & .2000D-01, .3000D-01, .4000D-01, .6400D+00, .2100D+00,
31612 & .6000D-01, .2000D-01, .3000D-01, .4000D-01, .6400D+00,
31613 & .3600D+00, .0000D+00, .0000D+00, .6400D+00, .3600D+00,
31614 & .0000D+00, .0000D+00, .6900D+00, .3100D+00, .1000D+01,
31615 & .5200D+00, .4800D+00, .1000D+01, .9900D+00, .1000D-01,
31616 & .3800D+00, .3000D-01, .3000D+00, .2400D+00, .5000D-01,
31617 & .1000D+01, .1000D+01, .0000D+00, .1000D+01, .9000D+00,
31618 & .1000D-01, .9000D-01, .3300D+00, .6700D+00, .3300D+00,
31619 & .6700D+00, .3300D+00, .6700D+00, .3300D+00, .6700D+00,
31620 & .3300D+00, .6700D+00, .3300D+00, .6700D+00, .3300D+00,
31621 & .6700D+00, .3300D+00, .6700D+00, .1900D+00, .3800D+00,
31622 & .9000D-01, .2000D+00, .3000D-01, .4000D-01, .5000D-01,
31623 & .2000D-01, .1900D+00, .3800D+00, .9000D-01, .2000D+00 /
31624 DATA (WT(K),K= 86,170) /
31625 & .3000D-01, .4000D-01, .5000D-01, .2000D-01, .1900D+00,
31626 & .3800D+00, .9000D-01, .2000D+00, .3000D-01, .4000D-01,
31627 & .5000D-01, .2000D-01, .1900D+00, .3800D+00, .9000D-01,
31628 & .2000D+00, .3000D-01, .4000D-01, .5000D-01, .2000D-01,
31629 & .8800D+00, .6000D-01, .6000D-01, .8800D+00, .6000D-01,
31630 & .6000D-01, .8800D+00, .1200D+00, .1900D+00, .1900D+00,
31631 & .1600D+00, .1600D+00, .1700D+00, .3000D-01, .3000D-01,
31632 & .3000D-01, .4000D-01, .1000D+00, .1000D+00, .2000D+00,
31633 & .1200D+00, .1000D+00, .4000D-01, .4000D-01, .5000D-01,
31634 & .7500D-01, .7500D-01, .3000D-01, .3000D-01, .4000D-01,
31635 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01,
31636 & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31637 & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31638 & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31639 & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31640 & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31641 & .2700D+00, .3000D+00, .4000D+00, .2000D+00, .1250D+00 /
31642 DATA (WT(K),K=171,255) /
31643 & .7500D-01, .7500D-01, .1250D+00, .4000D+00, .7500D-01,
31644 & .1250D+00, .2000D+00, .1250D+00, .7500D-01, .1800D+00,
31645 & .3700D+00, .1300D+00, .8000D-01, .4000D-01, .7000D-01,
31646 & .1300D+00, .3700D+00, .1800D+00, .4000D-01, .8000D-01,
31647 & .1300D+00, .1300D+00, .7000D-01, .7000D-01, .1300D+00,
31648 & .2300D+00, .4700D+00, .5000D-01, .2000D-01, .1000D-01,
31649 & .2000D-01, .1300D+00, .7000D-01, .4700D+00, .2300D+00,
31650 & .5000D-01, .1000D-01, .2000D-01, .2000D-01, .1000D+01,
31651 & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31652 & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31653 & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31654 & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31655 & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31656 & .2700D+00, .3000D+00, .1800D+00, .3700D+00, .1300D+00,
31657 & .8000D-01, .4000D-01, .7000D-01, .1300D+00, .3700D+00,
31658 & .1800D+00, .4000D-01, .8000D-01, .1300D+00, .1300D+00,
31659 & .7000D-01, .5000D+00, .5000D+00, .1000D+01, .1000D+01 /
31660 DATA (WT(K),K=256,340) /
31661 & .1000D+01, .8000D+00, .2000D+00, .6000D+00, .3000D+00,
31662 & .1000D+00, .6000D+00, .3000D+00, .1000D+00, .8000D+00,
31663 & .2000D+00, .3300D+00, .6700D+00, .6600D+00, .1700D+00,
31664 & .1700D+00, .3200D+00, .1700D+00, .3200D+00, .1900D+00,
31665 & .3300D+00, .3300D+00, .3400D+00, .3000D+00, .5000D-01,
31666 & .6500D+00, .3800D+00, .1200D+00, .3800D+00, .1200D+00,
31667 & .3800D+00, .1200D+00, .3800D+00, .1200D+00, .3000D+00,
31668 & .5000D-01, .6500D+00, .3800D+00, .2500D+00, .2500D+00,
31669 & .2000D-01, .5000D-01, .5000D-01, .2000D+00, .2000D+00,
31670 & .1200D+00, .1000D+00, .7000D-01, .7000D-01, .1400D+00,
31671 & .5000D-01, .5000D-01, .1000D+01, .1000D+01, .1000D+01,
31672 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31673 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31674 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31675 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31676 & .4800D+00, .2400D+00, .2600D+00, .2000D-01, .4700D+00,
31677 & .3500D+00, .1500D+00, .3000D-01, .1000D+01, .1000D+01 /
31678 DATA (WT(K),K=341,425) /
31679 & .5200D+00, .4800D+00, .1000D+01, .1000D+01, .1000D+01,
31680 & .1000D+01, .9000D+00, .5000D-01, .5000D-01, .9000D+00,
31681 & .5000D-01, .5000D-01, .9000D+00, .5000D-01, .5000D-01,
31682 & .3300D+00, .6700D+00, .6700D+00, .3300D+00, .2500D+00,
31683 & .2500D+00, .5000D+00, .9000D+00, .5000D-01, .5000D-01,
31684 & .9000D+00, .5000D-01, .5000D-01, .9000D+00, .5000D-01,
31685 & .5000D-01, .3300D+00, .6700D+00, .6700D+00, .3300D+00,
31686 & .2500D+00, .2500D+00, .5000D+00, .1000D+00, .5000D+00,
31687 & .1600D+00, .2400D+00, .7000D+00, .3000D+00, .7000D+00,
31688 & .3000D+00, .1000D+00, .5000D+00, .1600D+00, .2400D+00,
31689 & .3000D+00, .4000D+00, .3000D+00, .3000D+00, .4000D+00,
31690 & .3000D+00, .4900D+00, .4900D+00, .2000D-01, .5500D+00,
31691 & .4500D+00, .6800D+00, .3000D+00, .2000D-01, .6800D+00,
31692 & .3000D+00, .2000D-01, .5500D+00, .4500D+00, .9000D+00,
31693 & .1000D+00, .9000D+00, .1000D+00, .6000D+00, .3000D+00,
31694 & .1000D+00, .1000D+00, .1000D+00, .8000D+00, .2800D+00,
31695 & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .2800D+00 /
31696 DATA (WT(K),K=426,510) /
31697 & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .1000D+01,
31698 & .1000D+01, .1000D+01, .1000D+01, .2000D-01, .3000D-01,
31699 & .7000D-01, .2000D-01, .2000D-01, .4000D-01, .1300D+00,
31700 & .7000D-01, .6000D-01, .6000D-01, .2000D+00, .1400D+00,
31701 & .4000D-01, .1000D+00, .2500D+00, .3000D-01, .3000D+00,
31702 & .4200D+00, .2200D+00, .3500D+00, .1900D+00, .1600D+00,
31703 & .8000D-01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31704 & .1000D+01, .3700D+00, .2000D+00, .3600D+00, .7000D-01,
31705 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00,
31706 & .5000D+00, .2000D-01, .3000D-01, .7000D-01, .2000D-01,
31707 & .2000D-01, .4000D-01, .1300D+00, .7000D-01, .6000D-01,
31708 & .6000D-01, .2000D+00, .1400D+00, .4000D-01, .1000D+00,
31709 & .2500D+00, .3000D-01, .3000D+00, .4200D+00, .2200D+00,
31710 & .3500D+00, .1900D+00, .1600D+00, .8000D-01, .1000D+01,
31711 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .3700D+00,
31712 & .2000D+00, .3600D+00, .7000D-01, .5000D+00, .5000D+00,
31713 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01 /
31714 DATA (WT(K),K=511,540) /
31715 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31716 & .1000D+01, .1000D+01, .1000D+01, .3000D+00, .3000D+00,
31717 & .4000D+00, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31718 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31719 & .3000D+00, .3000D+00, .4000D+00, .3300D+00, .3300D+00,
31720 & .3400D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00 /
31721C
31722 DATA (WT(I),I=541,602) / .0D+00, .3334D+00, .2083D+00, 2*.125D+00,
31723 & .2083D+00, .0D+00, .125D+00, .2083D+00, .3334D+00, .2083D+00,
31724 & .125D+00, 0.2D+00, 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00,
31725 & 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, 0.2D+00, 0.3D+00,
31726 & 0.3D+00, 0.0D+00, 0.31D+00, 0.62D+00, 0.035D+00, 0.035D+00,
31727 & 18*1.D+00, 0.5D+00, 0.16D+00, 2*0.12D+00, 2*0.05D+00, 0.5D+00,
31728 & 0.16D+00, 2*0.12D+00, 2*0.05D+00, 1.D+00 /
31729* Particle numbers in decay channel
31730 DATA (NZK(K,1),K= 1,170) /
31731 & 1, 2, 3, 4, 5, 6, 7, 1, 2, 4,
31732 & 3, 23, 13, 13, 13, 10, 11, 10, 13, 13,
31733 & 13, 10, 4, 11, 14, 14, 14, 11, 3, 1,
31734 & 8, 1, 1, 2, 9, 2, 2, 13, 23, 8,
31735 & 1, 8, 17, 7, 7, 7, 23, 23, 13, 13,
31736 & 13, 13, 23, 14, 13, 13, 23, 15, 24, 24,
31737 & 15, 16, 25, 25, 16, 15, 24, 24, 15, 16,
31738 & 24, 25, 16, 15, 24, 36, 37, 15, 24, 15,
31739 & 15, 24, 15, 37, 36, 24, 15, 24, 24, 16,
31740 & 24, 38, 39, 16, 25, 16, 16, 25, 16, 39,
31741 & 38, 25, 16, 25, 25, 17, 22, 21, 17, 21,
31742 & 20, 17, 22, 8, 1, 21, 22, 20, 17, 48,
31743 & 50, 49, 8, 1, 17, 17, 17, 21, 20, 22,
31744 & 17, 22, 21, 20, 22, 19, 12, 19, 12, 1,
31745 & 1, 8, 1, 8, 8, 1, 53, 54, 1, 1,
31746 & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55,
31747 & 56, 1, 8, 8, 55, 56, 8, 1, 53, 54 /
31748 DATA (NZK(K,1),K=171,340) /
31749 & 55, 1, 8, 8, 54, 55, 56, 1, 8, 1,
31750 & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55,
31751 & 56, 1, 8, 1, 8, 1, 8, 17, 21, 22,
31752 & 1, 1, 8, 1, 8, 17, 22, 20, 8, 2,
31753 & 2, 9, 2, 9, 9, 2, 67, 68, 2, 2,
31754 & 9, 67, 68, 69, 2, 9, 2, 9, 68, 69,
31755 & 70, 2, 9, 9, 69, 70, 9, 2, 9, 67,
31756 & 68, 69, 2, 9, 2, 9, 68, 69, 70, 2,
31757 & 9, 1, 8, 13, 13, 14, 1, 8, 1, 1,
31758 & 8, 8, 8, 1, 8, 1, 1, 1, 1, 1,
31759 & 8, 2, 2, 9, 9, 2, 2, 9, 15, 15,
31760 & 24, 16, 16, 25, 25, 15, 15, 24, 24, 16,
31761 & 16, 25, 1, 21, 22, 21, 48, 49, 8, 17,
31762 & 20, 17, 22, 20, 20, 22, 20, 0, 0, 0,
31763 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31764 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31765 & 31, 31, 13, 7, 15, 12, 13, 31, 17, 17 /
31766 DATA (NZK(K,1),K=341,510) /
31767 & 2, 9, 18, 9, 18, 18, 17, 21, 22, 17,
31768 & 21, 20, 17, 20, 22, 97, 98, 97, 98, 97,
31769 & 98, 17, 18, 99, 100, 18, 101, 99, 18, 101,
31770 & 100, 102, 103, 102, 103, 102, 103, 18, 16, 16,
31771 & 24, 24, 16, 25, 15, 24, 15, 15, 25, 25,
31772 & 31, 15, 15, 31, 16, 16, 23, 13, 7, 116,
31773 & 116, 116, 117, 117, 119, 118, 118, 119, 119, 120,
31774 & 120, 121, 121, 130, 130, 130, 4, 10, 13, 10,
31775 & 4, 32, 13, 36, 11, 3, 34, 14, 38, 133,
31776 & 134, 135, 136, 21, 21, 1, 97, 104, 54, 53,
31777 & 17, 22, 21, 21, 1, 54, 53, 21, 97, 21,
31778 & 97, 22, 21, 97, 98, 105, 137, 137, 137, 138,
31779 & 139, 97, 97, 109, 109, 140, 138, 137, 139, 138,
31780 & 145, 99, 99, 2, 102, 110, 68, 67, 18, 100,
31781 & 99, 99, 2, 68, 67, 99, 102, 99, 102, 100,
31782 & 99, 102, 103, 111, 149, 149, 149, 150, 151, 113,
31783 & 113, 115, 115, 152, 150, 149, 151, 150, 157, 140 /
31784 DATA (NZK(K,1),K=511,540) /
31785 & 141, 142, 143, 144, 145, 146, 147, 148, 138, 145,
31786 & 140, 152, 153, 154, 155, 156, 157, 158, 159, 160,
31787 & 150, 157, 152, 34, 32, 33, 33, 32, 33, 34 /
31788 DATA (NZK(I,1),I=541,602) / 2, 67, 68, 69, 2, 9, 9, 68, 69,
31789 & 70, 2, 9, 33, 32, 13, 14, 189, 32, 34, 23, 23, 189, 33, 34, 14,
31790 & 14, 189, 23, 13, 15, 24, 36, 38, 37, 39, 194, 195, 196, 197,
31791 & 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 1, 8, 1, 1, 54,
31792 & 55, 8, 1, 8, 8, 54, 55, 210/
31793 DATA (NZK(K,2),K= 1,170) /
31794 & 0, 0, 0, 0, 0, 0, 0, 3, 4, 6,
31795 & 5, 23, 14, 11, 3, 5, 5, 5, 23, 13,
31796 & 23, 23, 23, 5, 23, 13, 23, 23, 23, 14,
31797 & 23, 3, 11, 13, 23, 4, 10, 14, 23, 14,
31798 & 23, 13, 7, 7, 4, 7, 7, 23, 14, 14,
31799 & 23, 14, 23, 23, 14, 14, 7, 23, 13, 23,
31800 & 14, 23, 14, 23, 13, 23, 13, 23, 14, 23,
31801 & 14, 23, 13, 23, 13, 23, 13, 33, 32, 35,
31802 & 31, 23, 14, 23, 14, 33, 34, 35, 31, 23,
31803 & 14, 23, 14, 33, 34, 35, 31, 23, 13, 23,
31804 & 13, 33, 32, 35, 31, 13, 13, 23, 23, 14,
31805 & 13, 14, 14, 25, 16, 14, 23, 13, 31, 14,
31806 & 13, 23, 25, 16, 23, 35, 33, 34, 32, 33,
31807 & 31, 31, 14, 13, 23, 0, 0, 0, 0, 13,
31808 & 23, 13, 14, 23, 14, 13, 23, 13, 78, 23,
31809 & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23,
31810 & 13, 80, 79, 14, 14, 23, 80, 31, 14, 23 /
31811 DATA (NZK(K,2),K=171,340) /
31812 & 13, 79, 78, 31, 14, 23, 13, 80, 79, 23,
31813 & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23,
31814 & 13, 80, 79, 23, 13, 33, 32, 15, 24, 15,
31815 & 31, 14, 23, 34, 33, 24, 24, 15, 31, 14,
31816 & 23, 14, 13, 23, 13, 14, 23, 14, 80, 23,
31817 & 14, 13, 23, 14, 79, 80, 13, 23, 13, 23,
31818 & 14, 78, 79, 13, 13, 23, 78, 23, 14, 13,
31819 & 23, 14, 79, 80, 13, 23, 13, 23, 14, 78,
31820 & 79, 62, 61, 23, 14, 23, 13, 13, 13, 23,
31821 & 13, 13, 23, 14, 14, 14, 1, 8, 8, 1,
31822 & 8, 1, 8, 8, 1, 8, 1, 8, 1, 8,
31823 & 1, 1, 8, 1, 8, 8, 1, 1, 8, 8,
31824 & 1, 8, 25, 23, 13, 31, 23, 13, 16, 14,
31825 & 35, 34, 34, 33, 31, 14, 23, 0, 0, 0,
31826 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31827 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31828 & 13, 23, 14, 7, 16, 19, 14, 7, 23, 14 /
31829 DATA (NZK(K,2),K=341,510) /
31830 & 23, 14, 7, 13, 23, 13, 13, 23, 13, 23,
31831 & 14, 13, 14, 23, 14, 23, 13, 14, 23, 14,
31832 & 23, 16, 14, 23, 14, 23, 14, 13, 13, 23,
31833 & 13, 23, 14, 13, 23, 13, 23, 15, 13, 13,
31834 & 13, 23, 13, 13, 14, 14, 14, 14, 14, 23,
31835 & 13, 16, 25, 14, 15, 24, 23, 14, 7, 23,
31836 & 7, 13, 23, 7, 14, 23, 7, 23, 7, 7,
31837 & 7, 7, 7, 13, 23, 31, 3, 11, 14, 135,
31838 & 5, 134, 134, 134, 136, 6, 133, 133, 133, 0,
31839 & 0, 0, 0, 31, 95, 25, 15, 31, 95, 16,
31840 & 32, 32, 33, 35, 39, 39, 38, 25, 13, 39,
31841 & 32, 39, 38, 35, 32, 39, 13, 23, 14, 7,
31842 & 7, 25, 37, 32, 13, 25, 13, 25, 13, 25,
31843 & 13, 31, 95, 24, 16, 31, 24, 15, 34, 34,
31844 & 33, 35, 37, 37, 36, 24, 14, 37, 34, 37,
31845 & 36, 35, 34, 37, 14, 23, 13, 7, 7, 24,
31846 & 39, 34, 14, 24, 14, 24, 14, 24, 14, 7 /
31847 DATA (NZK(K,2),K=511,540) /
31848 & 7, 7, 7, 7, 7, 7, 7, 7, 25, 13,
31849 & 25, 7, 7, 7, 7, 7, 7, 7, 7, 7,
31850 & 24, 14, 24, 13, 14, 23, 13, 23, 14, 23 /
31851 DATA (NZK(I,2),I=541,602) / 31, 13, 23, 14, 79, 80, 31, 13, 23,
31852 & 14, 78, 79, 13, 23, 23, 13, 13, 14, 13, 23, 13, 23, 14, 23, 23,
31853 & 14, 14, 23, 14, 16, 25,
31854 & 4*23, 14*0, 23, 13, 23, 13, 23, 13, 23, 14,
31855 & 23, 13, 14, 23, 0 /
31856 DATA (NZK(K,3),K= 1,170) /
31857 & 0, 0, 0, 0, 0, 0, 0, 5, 6, 5,
31858 & 6, 23, 23, 5, 5, 0, 0, 0, 0, 14,
31859 & 23, 5, 5, 0, 0, 14, 23, 5, 5, 0,
31860 & 0, 5, 5, 0, 0, 5, 5, 0, 0, 0,
31861 & 0, 0, 0, 0, 3, 0, 7, 23, 23, 7,
31862 & 0, 0, 0, 0, 23, 0, 0, 0, 0, 0,
31863 & 110*0 /
31864 DATA (NZK(K,3),K=171,340) /
31865 & 80*0,
31866 & 0, 0, 0, 0, 0, 0, 23, 13, 14, 23,
31867 & 23, 14, 23, 23, 23, 14, 23, 13, 23, 14,
31868 & 13, 23, 13, 23, 14, 23, 14, 14, 23, 13,
31869 & 13, 23, 13, 14, 23, 23, 14, 23, 13, 23,
31870 & 14, 14, 0, 0, 0, 0, 0, 0, 0, 0,
31871 & 30*0,
31872 & 14, 23, 7, 0, 0, 0, 23, 0, 0, 0 /
31873 DATA (NZK(K,3),K=341,510) /
31874 & 30*0,
31875 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 23,
31876 & 14, 0, 13, 0, 14, 0, 0, 23, 13, 0,
31877 & 0, 15, 0, 0, 16, 0, 0, 0, 0, 0,
31878 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31879 & 0, 0, 0, 14, 23, 0, 0, 0, 23, 134,
31880 & 134, 0, 0, 0, 133, 133, 0, 0, 0, 0,
31881 & 80*0 /
31882 DATA (NZK(K,3),K=511,540) /
31883 & 0, 0, 0, 0, 0, 0, 0, 0, 13, 13,
31884 & 25, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31885 & 14, 14, 24, 0, 0, 0, 0, 0, 0, 0 /
31886 DATA (NZK(I,3),I=541,602) / 12*0, 2*0, 23, 13, 0, 2*0, 23, 14, 0,
31887 & 2*0, 23, 13, 0, 4*0, 18*0, 2*0, 23, 14, 2*0, 2*0, 23, 14, 2*0, 0/
31888
31889 END
31890
31891*$ CREATE DT_BDEVAP.FOR
31892*COPY DT_BDEVAP
31893*
31894*=== bdevap ===========================================================*
31895*
31896 BLOCK DATA DT_BDEVAP
31897
31898C INCLUDE '(DBLPRC)'
31899* DBLPRC.ADD
31900 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31901 SAVE
31902* (original name: GLOBAL)
31903 PARAMETER ( KALGNM = 2 )
31904 PARAMETER ( ANGLGB = 5.0D-16 )
31905 PARAMETER ( ANGLSQ = 2.5D-31 )
31906 PARAMETER ( AXCSSV = 0.2D+16 )
31907 PARAMETER ( ANDRFL = 1.0D-38 )
31908 PARAMETER ( AVRFLW = 1.0D+38 )
31909 PARAMETER ( AINFNT = 1.0D+30 )
31910 PARAMETER ( AZRZRZ = 1.0D-30 )
31911 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
31912 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
31913 PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
31914 PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
31915 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
31916 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
31917 PARAMETER ( CSNNRM = 2.0D-15 )
31918 PARAMETER ( DMXTRN = 1.0D+08 )
31919 PARAMETER ( ZERZER = 0.D+00 )
31920 PARAMETER ( ONEONE = 1.D+00 )
31921 PARAMETER ( TWOTWO = 2.D+00 )
31922 PARAMETER ( THRTHR = 3.D+00 )
31923 PARAMETER ( FOUFOU = 4.D+00 )
31924 PARAMETER ( FIVFIV = 5.D+00 )
31925 PARAMETER ( SIXSIX = 6.D+00 )
31926 PARAMETER ( SEVSEV = 7.D+00 )
31927 PARAMETER ( EIGEIG = 8.D+00 )
31928 PARAMETER ( ANINEN = 9.D+00 )
31929 PARAMETER ( TENTEN = 10.D+00 )
31930 PARAMETER ( HLFHLF = 0.5D+00 )
31931 PARAMETER ( ONETHI = ONEONE / THRTHR )
31932 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
31933 PARAMETER ( ONEFOU = ONEONE / FOUFOU )
31934 PARAMETER ( THRTWO = THRTHR / TWOTWO )
31935 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
31936 PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
31937 PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
31938 PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
31939 PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
31940 PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
31941 PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
31942 PARAMETER ( EULERO = 0.577215664901532860606512 D+00 )
31943 PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 )
31944 PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 )
31945 PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 )
31946 PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
31947 PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
31948 PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
31949 PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
31950 PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
31951 PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
31952 PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
31953 PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
31954 PARAMETER ( CLIGHT = 2.99792458 D+10 )
31955 PARAMETER ( AVOGAD = 6.0221367 D+23 )
31956 PARAMETER ( BOLTZM = 1.380658 D-23 )
31957 PARAMETER ( AMELGR = 9.1093897 D-28 )
31958 PARAMETER ( PLCKBR = 1.05457266 D-27 )
31959 PARAMETER ( ELCCGS = 4.8032068 D-10 )
31960 PARAMETER ( ELCMKS = 1.60217733 D-19 )
31961 PARAMETER ( AMUGRM = 1.6605402 D-24 )
31962 PARAMETER ( AMMUMU = 0.113428913 D+00 )
31963 PARAMETER ( AMPRMU = 1.007276470 D+00 )
31964 PARAMETER ( AMNEMU = 1.008664904 D+00 )
31965 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
31966 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
31967 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
31968 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
31969 PARAMETER ( PLABRC = 0.197327053 D+00 )
31970 PARAMETER ( AMELCT = 0.51099906 D-03 )
31971 PARAMETER ( AMUGEV = 0.93149432 D+00 )
31972 PARAMETER ( AMMUON = 0.105658389 D+00 )
31973 PARAMETER ( AMPRTN = 0.93827231 D+00 )
31974 PARAMETER ( AMNTRN = 0.93956563 D+00 )
31975 PARAMETER ( AMDEUT = 1.87561339 D+00 )
31976 PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
31977 & * 1.D-09 )
31978 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
31979 PARAMETER ( BLTZMN = 8.617385 D-14 )
31980 PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
31981 PARAMETER ( GFOHB3 = 1.16639 D-05 )
31982 PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
31983 PARAMETER ( SIN2TW = 0.2319 D+00 )
31984 PARAMETER ( GEVMEV = 1.0 D+03 )
31985 PARAMETER ( EMVGEV = 1.0 D-03 )
31986 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
31987 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
31988 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
31989 LOGICAL LGBIAS, LGBANA
31990 COMMON /FKGLOB/ LGBIAS, LGBANA
31991C INCLUDE '(DIMPAR)'
31992* DIMPAR.ADD
31993 PARAMETER ( MXXRGN = 5000 )
31994 PARAMETER ( MXXMDF = 82 )
31995 PARAMETER ( MXXMDE = 54 )
31996 PARAMETER ( MFSTCK = 1000 )
31997 PARAMETER ( MESTCK = 100 )
31998 PARAMETER ( NELEMX = 80 )
31999 PARAMETER ( MPDPDX = 8 )
32000 PARAMETER ( ICOMAX = 180 )
32001 PARAMETER ( NSTBIS = 304 )
32002 PARAMETER ( IDMAXP = 220 )
32003 PARAMETER ( IDMXDC = 640 )
32004 PARAMETER ( MKBMX1 = 1 )
32005 PARAMETER ( MKBMX2 = 1 )
32006C INCLUDE '(IOUNIT)'
32007* IOUNIT.ADD
32008 PARAMETER ( LUNIN = 5 )
32009 PARAMETER ( LUNOUT = 6 )
32010**sr 19.5. set error output-unit from 15 to 6
32011 PARAMETER ( LUNERR = 6 )
32012 PARAMETER ( LUNBER = 14 )
32013 PARAMETER ( LUNECH = 8 )
32014 PARAMETER ( LUNFLU = 13 )
32015 PARAMETER ( LUNGEO = 16 )
32016 PARAMETER ( LUNPMF = 12 )
32017 PARAMETER ( LUNRAN = 2 )
32018 PARAMETER ( LUNXSC = 9 )
32019 PARAMETER ( LUNDET = 17 )
32020 PARAMETER ( LUNRAY = 10 )
32021 PARAMETER ( LUNRDB = 1 )
32022 PARAMETER ( LUNPGO = 7 )
32023 PARAMETER ( LUNPGS = 4 )
32024 PARAMETER ( LUNSCR = 3 )
32025*
32026*----------------------------------------------------------------------*
32027* *
32028* Block Data for the EVAPoration routines: *
32029* *
32030* Created on 20 may 1990 by Alfredo Ferrari & Paola Sala *
32031* Infn - Milan *
32032* *
32033* Modified from the original version of J.M.Zazula *
32034* and, for cookcm, from a LAHET block data kindly provided by *
32035* R.E.Prael-LANL *
32036* *
32037* Last change on 20-feb-95 by Alfredo Ferrari *
32038* *
32039* *
32040*----------------------------------------------------------------------*
32041*
32042* (original name: COOKCM)
32043 PARAMETER ( ASMTOG = SIXSIX / PIPIPI**2 )
32044 LOGICAL LDEFOZ, LDEFON
32045 PARAMETER ( INCOOK = 150, IZCOOK = 98 )
32046 COMMON /FKCOOK/ ALPIGN, BETIGN, GAMIGN, POWIGN,
32047 & SZCOOK (IZCOOK), SNCOOK (INCOOK), PZCOOK (IZCOOK),
32048 & PNCOOK (INCOOK), LDEFOZ (IZCOOK), LDEFON (INCOOK)
32049* (original name: EVA0)
32050 COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
32051 * FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
32052 * CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
32053 * T (4,7), RMASS (297), ALPH (297), BET (297),
32054 * APRIME (250), IA (6), IZ (6)
32055* (original name: HETTP)
32056 COMMON /FKHETP/ NHSTP,NBERTP,IOSUB,INSRS
32057* (original name: HETC7)
32058 COMMON /FKHET7/ COSKS,SINKS, COSTH,SINTH, COSPHI,SINPHI
32059* (original name: INPFLG)
32060 COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
32061*
32062 DATA B0 / 8.D+00 /, Y0 / 1.5D+00 /
32063 DATA IANG / 1 /, IFISS / 1 /, IB0 / 2 /, IGEOM / 0 /
32064 DATA ISTRAG /0/, KEYDK /0/
32065 DATA NBERTP /LUNBER/
32066 DATA COSTH /ONEONE/, SINTH /ZERZER/, COSPHI /ONEONE/,
32067 & SINPHI/ZERZER/
32068* /cookcm/
32069 DATA ( PZCOOK(I),I = 1, IZCOOK ) /
32070 & 0.000D+00, 5.440D+00, 0.000D+00, 2.760D+00, 0.000D+00, 3.340D+00,
32071 & 0.000D+00, 2.700D+00, 0.000D+00, 2.500D+00, 0.000D+00, 2.460D+00,
32072 & 0.000D+00, 2.090D+00, 0.000D+00, 1.620D+00, 0.000D+00, 1.620D+00,
32073 & 0.000D+00, 1.830D+00, 0.000D+00, 1.730D+00, 0.000D+00, 1.350D+00,
32074 & 0.000D+00, 1.540D+00, 0.000D+00, 1.280D+00, 2.600D-01, 8.800D-01,
32075 & 1.900D-01, 1.350D+00,-5.000D-02, 1.520D+00,-9.000D-02, 1.170D+00,
32076 & 4.000D-02, 1.240D+00, 2.900D-01, 1.090D+00, 2.600D-01, 1.170D+00,
32077 & 2.300D-01, 1.150D+00,-8.000D-02, 1.350D+00, 3.400D-01, 1.050D+00,
32078 & 2.800D-01, 1.270D+00, 0.000D+00, 1.050D+00, 0.000D+00, 1.000D+00,
32079 & 9.000D-02, 1.200D+00, 2.000D-01, 1.400D+00, 9.300D-01, 1.000D+00,
32080 &-2.000D-01, 1.190D+00, 9.000D-02, 9.700D-01, 0.000D+00, 9.200D-01,
32081 & 1.100D-01, 6.800D-01, 5.000D-02, 6.800D-01,-2.200D-01, 7.900D-01,
32082 & 9.000D-02, 6.900D-01, 1.000D-02, 7.200D-01, 0.000D+00, 4.000D-01,
32083 & 1.600D-01, 7.300D-01, 0.000D+00, 4.600D-01, 1.700D-01, 8.900D-01,
32084 & 0.000D+00, 7.900D-01, 0.000D+00, 8.900D-01, 0.000D+00, 8.100D-01,
32085 &-6.000D-02, 6.900D-01,-2.000D-01, 7.100D-01,-1.200D-01, 7.200D-01,
32086 & 0.000D+00, 7.700D-01/
32087 DATA ( PNCOOK(I),I = 1, 90 ) /
32088 & 0.000D+00, 5.980D+00, 0.000D+00, 2.770D+00, 0.000D+00, 3.160D+00,
32089 & 0.000D+00, 3.010D+00, 0.000D+00, 2.500D+00, 0.000D+00, 2.670D+00,
32090 & 0.000D+00, 1.800D+00, 0.000D+00, 1.670D+00, 0.000D+00, 1.860D+00,
32091 & 0.000D+00, 2.040D+00, 0.000D+00, 1.640D+00, 0.000D+00, 1.440D+00,
32092 & 0.000D+00, 1.540D+00, 0.000D+00, 1.300D+00, 0.000D+00, 1.270D+00,
32093 & 0.000D+00, 1.290D+00, 8.000D-02, 1.410D+00,-8.000D-02, 1.500D+00,
32094 &-5.000D-02, 2.240D+00,-4.700D-01, 1.430D+00,-1.500D-01, 1.440D+00,
32095 & 6.000D-02, 1.560D+00, 2.500D-01, 1.570D+00,-1.600D-01, 1.460D+00,
32096 & 0.000D+00, 9.300D-01, 1.000D-02, 6.200D-01,-5.000D-01, 1.420D+00,
32097 & 1.300D-01, 1.520D+00,-6.500D-01, 8.000D-01,-8.000D-02, 1.290D+00,
32098 &-4.700D-01, 1.250D+00,-4.400D-01, 9.700D-01, 8.000D-02, 1.650D+00,
32099 &-1.100D-01, 1.260D+00,-4.600D-01, 1.060D+00, 2.200D-01, 1.550D+00,
32100 &-7.000D-02, 1.370D+00, 1.000D-01, 1.200D+00,-2.700D-01, 9.200D-01,
32101 &-3.500D-01, 1.190D+00, 0.000D+00, 1.050D+00,-2.500D-01, 1.610D+00,
32102 &-2.100D-01, 9.000D-01,-2.100D-01, 7.400D-01,-3.800D-01, 7.200D-01/
32103 DATA ( PNCOOK(I),I = 91, INCOOK ) /
32104 &-3.400D-01, 9.200D-01,-2.600D-01, 9.400D-01, 1.000D-02, 6.500D-01,
32105 &-3.600D-01, 8.300D-01, 1.100D-01, 6.700D-01, 5.000D-02, 1.000D+00,
32106 & 5.100D-01, 1.040D+00, 3.300D-01, 6.800D-01,-2.700D-01, 8.100D-01,
32107 & 9.000D-02, 7.500D-01, 1.700D-01, 8.600D-01, 1.400D-01, 1.100D+00,
32108 &-2.200D-01, 8.400D-01,-4.700D-01, 4.800D-01, 2.000D-02, 8.800D-01,
32109 & 2.400D-01, 5.200D-01, 2.700D-01, 4.100D-01,-5.000D-02, 3.800D-01,
32110 & 1.500D-01, 6.700D-01, 0.000D+00, 6.100D-01, 0.000D+00, 7.800D-01,
32111 & 0.000D+00, 6.700D-01, 0.000D+00, 6.700D-01, 0.000D+00, 7.900D-01,
32112 & 0.000D+00, 6.000D-01, 4.000D-02, 6.400D-01,-6.000D-02, 4.500D-01,
32113 & 5.000D-02, 2.600D-01,-2.200D-01, 3.900D-01, 0.000D+00, 3.900D-01/
32114 DATA ( SZCOOK(I),I = 1, 98) /
32115 & 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
32116 & 0.000D+00, 0.000D+00,-1.100D-01,-8.100D-01,-2.910D+00,-4.170D+00,
32117 &-5.720D+00,-7.800D+00,-8.970D+00,-9.700D+00,-1.010D+01,-1.070D+01,
32118 &-1.138D+01,-1.207D+01,-1.255D+01,-1.324D+01,-1.393D+01,-1.471D+01,
32119 &-1.553D+01,-1.637D+01,-1.736D+01,-1.860D+01,-1.870D+01,-1.801D+01,
32120 &-1.787D+01,-1.708D+01,-1.660D+01,-1.675D+01,-1.650D+01,-1.635D+01,
32121 &-1.622D+01,-1.641D+01,-1.689D+01,-1.643D+01,-1.668D+01,-1.673D+01,
32122 &-1.745D+01,-1.729D+01,-1.744D+01,-1.782D+01,-1.862D+01,-1.827D+01,
32123 &-1.939D+01,-1.991D+01,-1.914D+01,-1.826D+01,-1.740D+01,-1.642D+01,
32124 &-1.577D+01,-1.437D+01,-1.391D+01,-1.310D+01,-1.311D+01,-1.143D+01,
32125 &-1.089D+01,-1.075D+01,-1.062D+01,-1.041D+01,-1.021D+01,-9.850D+00,
32126 &-9.470D+00,-9.030D+00,-8.610D+00,-8.130D+00,-7.460D+00,-7.480D+00,
32127 &-7.200D+00,-7.130D+00,-7.060D+00,-6.780D+00,-6.640D+00,-6.640D+00,
32128 &-7.680D+00,-7.890D+00,-8.410D+00,-8.490D+00,-7.880D+00,-6.300D+00,
32129 &-5.470D+00,-4.780D+00,-4.370D+00,-4.170D+00,-4.130D+00,-4.320D+00,
32130 &-4.550D+00,-5.040D+00,-5.280D+00,-6.060D+00,-6.280D+00,-6.870D+00,
32131 &-7.200D+00,-7.740D+00/
32132 DATA ( SNCOOK(I),I = 1, 90 ) /
32133 & 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
32134 & 0.000D+00, 0.000D+00, 1.030D+01, 5.660D+00, 6.800D+00, 7.530D+00,
32135 & 7.550D+00, 7.210D+00, 7.440D+00, 8.070D+00, 8.940D+00, 9.810D+00,
32136 & 1.060D+01, 1.139D+01, 1.254D+01, 1.368D+01, 1.434D+01, 1.419D+01,
32137 & 1.383D+01, 1.350D+01, 1.300D+01, 1.213D+01, 1.260D+01, 1.326D+01,
32138 & 1.413D+01, 1.492D+01, 1.552D+01, 1.638D+01, 1.716D+01, 1.755D+01,
32139 & 1.803D+01, 1.759D+01, 1.903D+01, 1.871D+01, 1.880D+01, 1.899D+01,
32140 & 1.846D+01, 1.825D+01, 1.776D+01, 1.738D+01, 1.672D+01, 1.562D+01,
32141 & 1.438D+01, 1.288D+01, 1.323D+01, 1.381D+01, 1.490D+01, 1.486D+01,
32142 & 1.576D+01, 1.620D+01, 1.762D+01, 1.773D+01, 1.816D+01, 1.867D+01,
32143 & 1.969D+01, 1.951D+01, 2.017D+01, 1.948D+01, 1.998D+01, 1.983D+01,
32144 & 2.020D+01, 1.972D+01, 1.987D+01, 1.924D+01, 1.844D+01, 1.761D+01,
32145 & 1.710D+01, 1.616D+01, 1.590D+01, 1.533D+01, 1.476D+01, 1.354D+01,
32146 & 1.263D+01, 1.065D+01, 1.010D+01, 8.890D+00, 1.025D+01, 9.790D+00,
32147 & 1.139D+01, 1.172D+01, 1.243D+01, 1.296D+01, 1.343D+01, 1.337D+01/
32148 DATA ( SNCOOK(I),I = 91, INCOOK ) /
32149 & 1.296D+01, 1.211D+01, 1.192D+01, 1.100D+01, 1.080D+01, 1.042D+01,
32150 & 1.039D+01, 9.690D+00, 9.270D+00, 8.930D+00, 8.570D+00, 8.020D+00,
32151 & 7.590D+00, 7.330D+00, 7.230D+00, 7.050D+00, 7.420D+00, 6.750D+00,
32152 & 6.600D+00, 6.380D+00, 6.360D+00, 6.490D+00, 6.250D+00, 5.850D+00,
32153 & 5.480D+00, 4.530D+00, 4.300D+00, 3.390D+00, 2.350D+00, 1.660D+00,
32154 & 8.100D-01, 4.600D-01,-9.600D-01,-1.690D+00,-2.530D+00,-3.160D+00,
32155 &-1.870D+00,-4.100D-01, 7.100D-01, 1.660D+00, 2.620D+00, 3.220D+00,
32156 & 3.760D+00, 4.100D+00, 4.460D+00, 4.830D+00, 5.090D+00, 5.180D+00,
32157 & 5.170D+00, 5.100D+00, 5.010D+00, 4.970D+00, 5.090D+00, 5.030D+00,
32158 & 4.930D+00, 5.280D+00, 5.490D+00, 5.500D+00, 5.370D+00, 5.300D+00/
32159 DATA LDEFOZ / 53*.FALSE.,25*.TRUE.,7*.FALSE.,13*.TRUE. /
32160 DATA LDEFON / 85*.FALSE.,37*.TRUE.,7*.FALSE.,21*.TRUE. /
32161*=== End of Block Data Bdevap =========================================*
32162 END
32163
32164*$ CREATE DT_BDNOPT.FOR
32165*COPY DT_BDNOPT
32166*
32167*=== bdnopt ===========================================================*
32168*== *
32169 BLOCK DATA DT_BDNOPT
32170
32171C INCLUDE '(DBLPRC)'
32172* DBLPRC.ADD
32173 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32174 SAVE
32175* (original name: GLOBAL)
32176 PARAMETER ( KALGNM = 2 )
32177 PARAMETER ( ANGLGB = 5.0D-16 )
32178 PARAMETER ( ANGLSQ = 2.5D-31 )
32179 PARAMETER ( AXCSSV = 0.2D+16 )
32180 PARAMETER ( ANDRFL = 1.0D-38 )
32181 PARAMETER ( AVRFLW = 1.0D+38 )
32182 PARAMETER ( AINFNT = 1.0D+30 )
32183 PARAMETER ( AZRZRZ = 1.0D-30 )
32184 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
32185 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
32186 PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
32187 PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
32188 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
32189 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
32190 PARAMETER ( CSNNRM = 2.0D-15 )
32191 PARAMETER ( DMXTRN = 1.0D+08 )
32192 PARAMETER ( ZERZER = 0.D+00 )
32193 PARAMETER ( ONEONE = 1.D+00 )
32194 PARAMETER ( TWOTWO = 2.D+00 )
32195 PARAMETER ( THRTHR = 3.D+00 )
32196 PARAMETER ( FOUFOU = 4.D+00 )
32197 PARAMETER ( FIVFIV = 5.D+00 )
32198 PARAMETER ( SIXSIX = 6.D+00 )
32199 PARAMETER ( SEVSEV = 7.D+00 )
32200 PARAMETER ( EIGEIG = 8.D+00 )
32201 PARAMETER ( ANINEN = 9.D+00 )
32202 PARAMETER ( TENTEN = 10.D+00 )
32203 PARAMETER ( HLFHLF = 0.5D+00 )
32204 PARAMETER ( ONETHI = ONEONE / THRTHR )
32205 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
32206 PARAMETER ( ONEFOU = ONEONE / FOUFOU )
32207 PARAMETER ( THRTWO = THRTHR / TWOTWO )
32208 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
32209 PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
32210 PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
32211 PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
32212 PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
32213 PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
32214 PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
32215 PARAMETER ( EULERO = 0.577215664901532860606512 D+00 )
32216 PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 )
32217 PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 )
32218 PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 )
32219 PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
32220 PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
32221 PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
32222 PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
32223 PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
32224 PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
32225 PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
32226 PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
32227 PARAMETER ( CLIGHT = 2.99792458 D+10 )
32228 PARAMETER ( AVOGAD = 6.0221367 D+23 )
32229 PARAMETER ( BOLTZM = 1.380658 D-23 )
32230 PARAMETER ( AMELGR = 9.1093897 D-28 )
32231 PARAMETER ( PLCKBR = 1.05457266 D-27 )
32232 PARAMETER ( ELCCGS = 4.8032068 D-10 )
32233 PARAMETER ( ELCMKS = 1.60217733 D-19 )
32234 PARAMETER ( AMUGRM = 1.6605402 D-24 )
32235 PARAMETER ( AMMUMU = 0.113428913 D+00 )
32236 PARAMETER ( AMPRMU = 1.007276470 D+00 )
32237 PARAMETER ( AMNEMU = 1.008664904 D+00 )
32238 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
32239 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
32240 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
32241 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
32242 PARAMETER ( PLABRC = 0.197327053 D+00 )
32243 PARAMETER ( AMELCT = 0.51099906 D-03 )
32244 PARAMETER ( AMUGEV = 0.93149432 D+00 )
32245 PARAMETER ( AMMUON = 0.105658389 D+00 )
32246 PARAMETER ( AMPRTN = 0.93827231 D+00 )
32247 PARAMETER ( AMNTRN = 0.93956563 D+00 )
32248 PARAMETER ( AMDEUT = 1.87561339 D+00 )
32249 PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
32250 & * 1.D-09 )
32251 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
32252 PARAMETER ( BLTZMN = 8.617385 D-14 )
32253 PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
32254 PARAMETER ( GFOHB3 = 1.16639 D-05 )
32255 PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
32256 PARAMETER ( SIN2TW = 0.2319 D+00 )
32257 PARAMETER ( GEVMEV = 1.0 D+03 )
32258 PARAMETER ( EMVGEV = 1.0 D-03 )
32259 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
32260 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
32261 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
32262 LOGICAL LGBIAS, LGBANA
32263 COMMON /FKGLOB/ LGBIAS, LGBANA
32264C INCLUDE '(DIMPAR)'
32265* DIMPAR.ADD
32266 PARAMETER ( MXXRGN = 5000 )
32267 PARAMETER ( MXXMDF = 82 )
32268 PARAMETER ( MXXMDE = 54 )
32269 PARAMETER ( MFSTCK = 1000 )
32270 PARAMETER ( MESTCK = 100 )
32271 PARAMETER ( NELEMX = 80 )
32272 PARAMETER ( MPDPDX = 8 )
32273 PARAMETER ( ICOMAX = 180 )
32274 PARAMETER ( NSTBIS = 304 )
32275 PARAMETER ( IDMAXP = 220 )
32276 PARAMETER ( IDMXDC = 640 )
32277 PARAMETER ( MKBMX1 = 1 )
32278 PARAMETER ( MKBMX2 = 1 )
32279C INCLUDE '(IOUNIT)'
32280* IOUNIT.ADD
32281 PARAMETER ( LUNIN = 5 )
32282 PARAMETER ( LUNOUT = 6 )
32283**sr 19.5. set error output-unit from 15 to 6
32284 PARAMETER ( LUNERR = 6 )
32285 PARAMETER ( LUNBER = 14 )
32286 PARAMETER ( LUNECH = 8 )
32287 PARAMETER ( LUNFLU = 13 )
32288 PARAMETER ( LUNGEO = 16 )
32289 PARAMETER ( LUNPMF = 12 )
32290 PARAMETER ( LUNRAN = 2 )
32291 PARAMETER ( LUNXSC = 9 )
32292 PARAMETER ( LUNDET = 17 )
32293 PARAMETER ( LUNRAY = 10 )
32294 PARAMETER ( LUNRDB = 1 )
32295 PARAMETER ( LUNPGO = 7 )
32296 PARAMETER ( LUNPGS = 4 )
32297 PARAMETER ( LUNSCR = 3 )
32298*
32299*----------------------------------------------------------------------*
32300* *
32301* Created on 20 september 1989 by Alfredo Ferrari - Infn Milan *
32302* *
32303* Last change on 20-apr-95 by Alfredo Ferrari *
32304* *
32305*----------------------------------------------------------------------*
32306*
32307C INCLUDE '(BLNKCM)'
32308* BLNKCM.ADD
32309**sr 17.5. commented since not used here
32310C PARAMETER ( NBLNMX = 1100000 )
32311C DIMENSION GMSTOR ( NBLNMX ), BRMBRR ( NBLNMX ), BRMEXP ( NBLNMX ),
32312C & BRMSIG ( NBLNMX ), SIGGTT ( KALGNM*NBLNMX ),
32313C & COMSCO ( NBLNMX ), LBSTOR ( KALGNM*NBLNMX )
32314C REAL SIGGTT
32315C LOGICAL LBSTOR
32316C COMMON NSTOR ( KALGNM*NBLNMX )
32317**
32318**sr 18.5. commented since not used for evap.
32319C COMMON / ADDRCM / MBLNMX, KBLNKL, KGMBGN, KGMLST, KCMBGN, KCMLST,
32320C & KISBGN, KISLST, KDTBGN, KDTLST, KUBBGN, KUBLST,
32321C & KUXBGN, KUXLST, KTCBGN, KTCLST, KRNBGN, KRNLST,
32322C & KYLBGN, KYLLST, KXSBGN, KXSLST, KIHBGN, KIHLST,
32323C & KINBGN, KINLST, KIEBGN, KIELST, KETBGN, KETLST,
32324C & KRRBGN, KRRLST, KGLBGN, KGLLST, KNABGN, KNALST,
32325C & KGDBGN, KGDLST, KDWBGN, KDWLST, KGCBGN, KGCLST,
32326C & KWLBGN, KWLLST, KWHBGN, KWHLST, KWMBGN, KWMLST,
32327C & KWSBGN, KWSLST, KNDBGN, KNDLST, KDPBGN, KDPLST,
32328C & KRGBGN, KRGLST, KSGBGN, KSGLST, KBRBGN, KBRLST,
32329C & KTMBGN
32330**
32331
32332C EQUIVALENCE ( NSTOR (1), GMSTOR (1) )
32333C EQUIVALENCE ( NSTOR (1), BRMBRR (1) )
32334C EQUIVALENCE ( NSTOR (1), BRMEXP (1) )
32335C EQUIVALENCE ( NSTOR (1), BRMSIG (1) )
32336C EQUIVALENCE ( NSTOR (1), COMSCO (1) )
32337C EQUIVALENCE ( NSTOR (1), SIGGTT (1) )
32338C EQUIVALENCE ( NSTOR (1), LBSTOR (1) )
32339C INCLUDE '(BLNTMP)'
32340* BLNTMP.ADD
32341**sr 18.5. commented since not used for evap.
32342C COMMON / BLNTMP / KIHBTM, KINBTM, KIEBTM, KRRBTM, KGLBTM, KNABTM,
32343C & KGCBTM, KGDWTM, KBDWTM, KWLOTM, KWHITM, KWMUTM,
32344C & KWSHTM, KEXTTM, KSTXTM, KSTNTM, KECTTM, KPCTTM,
32345C & KLPBTM, NXXRGN
32346**
32347C INCLUDE '(CMMDNR)'
32348* CMMDNR.ADD
32349**sr 18.5. commented since not used for evap.
32350C LOGICAL LFLDNR
32351C COMMON / CMMDNR / DDNEAR, LFLDNR
32352**
32353C INCLUDE '(CTITLE)'
32354* CTITLE.ADD
32355**sr 18.5. commented since not used for evap.
32356C CHARACTER RUNTIT*80, RUNTIM*32, RUNKEY*10
32357C COMMON / CTITLE / RUNTIT, RUNTIM, RUNKEY
32358C COMMON / CEXPCK / ITEXPI, ITEXMX
32359**
32360C INCLUDE '(DETECT)'
32361* DETECT.ADD
32362**sr 18.5. commented since not used for evap.
32363C PARAMETER (NRGNMX = 10)
32364C PARAMETER (NDTCMX = 10)
32365C PARAMETER (NSCRMX = 10)
32366C PARAMETER (NDTBIN = 1024)
32367C CHARACTER*10 TITDET,TITSCO
32368C LOGICAL LDTCTR
32369C COMMON /DETCT/ EDTMIN(NDTCMX), EDTBIN(NDTCMX), EDTCUT(NDTCMX),
32370C & KDTREG(NRGNMX,NDTCMX), KDTDET(NDTCMX,NSCRMX),
32371C & NDTSCO, NDTDET, LDTCTR, IDTREG(MXXRGN),
32372C & KDTSCD(NSCRMX)
32373C COMMON /DETCH/ TITDET(NDTCMX), TITSCO(NSCRMX)
32374**
32375C INCLUDE '(DETLOC)'
32376* DETLOC.ADD
32377**sr 18.5. commented since not used for evap.
32378C PARAMETER (NDTCM2 = 10)
32379C COMMON /DETLOC/ ACCUMP (NDTCM2), ACCUMN (NDTCM2),
32380C & ICOINC(NDTCM2), NCLAS
32381**
32382C INCLUDE '(EMGTRN)'
32383* EMGTRN.ADD
32384**sr 18.5. commented since not used for evap.
32385C LOGICAL LMCSMG
32386C COMMON / EMGTRN / UMCSMG, VMCSMG, WMCSMG, LMCSMG
32387**
32388C INCLUDE '(EMSHO)'
32389* EMSHO.ADD
32390**sr 18.5. commented since not used for evap.
32391C LOGICAL EMFLO, EMFHLO, EMFELO, LIMPRE, LEXPTE
32392C COMMON /EMSHO/ EMFETH, EMFPTH, EMFHET, EMFHPT, EMFBIA, EMFLO,
32393C & EMFHLO, EMFELO, LIMPRE, LEXPTE
32394**
32395C INCLUDE '(EPISOR)'
32396* EPISOR.ADD
32397**sr 18.5. commented since not used for evap.
32398C LOGICAL LUSSRC
32399C COMMON/EPISOR/TKESUM,LUSSRC
32400**
32401* (original name: FHEAVY,FHEAVC)
32402 PARAMETER ( MXHEAV = 100 )
32403 CHARACTER*8 ANHEAV
32404 COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV),
32405 & CZHEAV (MXHEAV), TKHEAV (MXHEAV),
32406 & PHEAVY (MXHEAV), WHEAVY (MXHEAV),
32407 & AMHEAV ( 12 ) , AMNHEA ( 12 ) ,
32408 & KHEAVY (MXHEAV), ICHEAV ( 12 ) ,
32409 & IBHEAV ( 12 ) , NPHEAV
32410 COMMON /FKFHVC/ ANHEAV ( 12 )
32411* (original name: FINUC)
32412 PARAMETER (MXP=999)
32413 COMMON /FKFINU/ CXR (MXP), CYR (MXP), CZR (MXP),
32414 & CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP),
32415 & TKI (MXP), PLR (MXP), WEI (MXP),
32416 & TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP,
32417 & KPART (MXP)
32418C INCLUDE '(GENTHR)'
32419* GENTHR.ADD
32420**sr 18.5. commented since not used for evap.
32421C COMMON / GENTHR / PEANCT, PEAPIT, PLDNCT, PTHRSH (NALLWP),
32422C & PTHDFF (NALLWP), IJNUCR (NALLWP)
32423**
32424C INCLUDE '(LOWNEU)'
32425* LOWNEU.ADD
32426**sr 18.5. commented since not used for evap.
32427C PARAMETER ( MXGTHN = 15 )
32428C PARAMETER ( MXGLWN = 200 )
32429C PARAMETER ( MXSHPP = 5 )
32430C LOGICAL LCOMPN, LIMPRN, LBIASN, LDOWNN, LRECPR, LLOWWW, LLOWET
32431C CHARACTER*10 TITLOW
32432C COMMON / LOWNEU / ATOLOW (MXXMDF), WSHPLN (MXGLWN,MXSHPP), EXTWWL,
32433C & SHPIMP (MXGLWN), EXTETL (MXGLWN), WWAMFL,
32434C & VLLNTH (MXGTHN,MXXMDF), ABLNTH (MXGTHN,MXXMDF),
32435C & STLNTH (MXGTHN,MXXMDF), TMRTLN (MXXMDF),
32436C & TMNMLN (MXXMDF), ICHCPT (MXXMDF),
32437C & IGTMRT (MXXMDF), NEUMED (MXXMDF),
32438C & ID1MED (MXXMDF), ID2MED (MXXMDF),
32439C & ID3MED (MXXMDF), MGTMED (MXXMDF),
32440C & LCOMPN (MXXMDF), LRECPR (MXXMDF), KPRLOW, NMGP,
32441C & NMTG , IGRTHN, LIMPRN, LBIASN, LDOWNN, LLOWWW,
32442C & LLOWET, ICLMED, IKRBGN, INABGN, IDWBGN, IETBGN,
32443C & I0XSEC, IDXSEC, ISENAV, ISVELN, ISPNAV, IWWLWB,
32444C & IWWLWT, IPXBGN, NPXSEC
32445C COMMON / CHLWNT / TITLOW (MXXMDF)
32446**
32447C INCLUDE '(LTCLCM)'
32448* LTCLCM.ADD
32449**sr 18.5. commented since not used for evap.
32450C COMMON / LTCLCM / MLATTC, NEWLAT, MLATLD, MLATM1, MLTSEN, MLTSM1
32451**
32452C INCLUDE '(MULBOU)'
32453* MULBOU.ADD
32454**sr 18.5. commented since not used for evap.
32455C LOGICAL LLDA , LAGAIN, LSTNEW, LARTEF, LNORML, LSENSE, LMGNOR
32456C COMMON / MULBOU / UOLD , VOLD , WOLD , UMAG , VMAG , WMAG ,
32457C & UNORML, VNORML, WNORML, USENSE, VSENSE, WSENSE,
32458C & TSENSE, DDSENS, DSMALL, NSSENS, LLDA , LAGAIN,
32459C & LSTNEW, LARTEF, LNORML, LSENSE, LMGNOR
32460**
32461C INCLUDE '(MULHD)'
32462* MULHD.ADD
32463**sr 18.5. commented since not used for evap.
32464C PARAMETER ( MXXPT1 = 1 )
32465C PARAMETER ( TIMESS = 2.00D+00 )
32466C PARAMETER ( TMSRLX = 1.50D+00 )
32467C PARAMETER ( EPSINS = 0.15D+00 )
32468C PARAMETER ( EPSRLX = 0.50D+00 )
32469C PARAMETER ( SQEPSN = 0.3872983346207417 D+00 )
32470C PARAMETER ( SQEPSR = 0.7071067811865475 D+00 )
32471C PARAMETER ( PARNSI = 1.732050807568877 D+00 * SQEPSN )
32472C PARAMETER ( PRNSR0 = 1.732050807568877 D+00 * SQEPSR )
32473C PARAMETER ( R0NCMS = 1.20 D+00 )
32474C LOGICAL LTOPT, LSRCRH, LNSCRH
32475C COMMON / MULHD / BLCC ( MXXMDF ), BLCCRA ( MXXMDF ),
32476C & XCC ( MXXMDF ), ZTILDE ( MXXMDF, 0:MXXPT1 ),
32477C & ALPZTL ( MXXMDF, 0:MXXPT1 ), RLDU ( MXXMDF ),
32478C & ALPZT2 ( MXXMDF, 0:MXXPT1 ), TEFF0 ( MXXMDF ),
32479C & XR0 ( MXXMDF ), ECUTM ( MXXMDF, 39, 2 ),
32480C & ESTEPF ( MXXMDF ), HTHNSZ ( MXXMDF, 39 ),
32481C & AE1O3 ( MXXMDF ), PARNSR ( MXXMDF ),
32482C & HEESLI ( MXXMDF ), THMSPR, THMSSC, HMSAMP,
32483C & HMREJE, LSRCRH ( MXXMDF ), LNSCRH ( MXXMDF ),
32484C & LTOPT ( MXXMDF ), NFSCAT
32485**
32486* (original name: PAREVT)
32487 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
32488 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
32489 PARAMETER ( NALLWP = 39 )
32490 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
32491 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
32492 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
32493 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
32494* (original name: RESNUC)
32495 LOGICAL LRNFSS, LFRAGM
32496 COMMON /FKRESN/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
32497 & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
32498 & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES,
32499 & PYRES, PZRES, PTRES2, KTARP, KTARN, IGREYP,
32500 & IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,
32501 & ICRES, IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU,
32502 & IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG,
32503 & IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS,
32504 & LFRAGM
32505C INCLUDE '(SCOHLP)'
32506* SCOHLP.ADD
32507**sr 18.5. commented since not used for evap.
32508C LOGICAL LSCZER
32509C COMMON / SCOHLP / ISCRNG, JSCRNG, LSCZER
32510**
32511C INCLUDE '(TRACKR)'
32512* TRACKR.ADD
32513**sr 18.5. commented since not used for evap.
32514C PARAMETER ( MXTRCK = 2500 )
32515C LOGICAL LFSSSC
32516C COMMON / TRACKR / XTRACK ( 0:MXTRCK ), YTRACK ( 0:MXTRCK ),
32517C & ZTRACK ( 0:MXTRCK ), TTRACK ( MXTRCK ),
32518C & DTRACK ( MXTRCK ), ETRACK, PTRACK, WTRACK,
32519C & ATRACK, CTRACK, AKSHRT, AKLONG, WSCRNG,
32520C & NTRACK, MTRACK, JTRACK, KTRACK, MMTRCK,
32521C & LT1TRK, LT2TRK, LTRACK, LLOUSE, LFSSSC
32522**
32523C INCLUDE '(USRBDX)'
32524* USRBDX.ADD
32525**sr 18.5. commented since not used for evap.
32526C PARAMETER ( MXUSBX = 600 )
32527C LOGICAL LUSBDX, LFUSBX, LWUSBX, LLNUSX
32528C CHARACTER*10 TITUSX
32529C COMMON /USRBX/ EBXLOW(MXUSBX), EBXHGH(MXUSBX), ABXLOW(MXUSBX),
32530C & ABXHGH(MXUSBX), DEBXBN(MXUSBX), DABXBN(MXUSBX),
32531C & AUSBDX(MXUSBX),
32532C & NEBXBN(MXUSBX), NABXBN(MXUSBX), NR1USX(MXUSBX),
32533C & NR2USX(MXUSBX), ITUSBX(MXUSBX), IDUSBX(MXUSBX),
32534C & KBUSBX(MXUSBX), IPUSBX(MXUSBX), IGMUSX(MXUSBX),
32535C & LFUSBX(MXUSBX), LWUSBX(MXUSBX), LLNUSX(MXUSBX),
32536C & NUSRBX, LUSBDX
32537C COMMON /USXCH/ TITUSX(MXUSBX)
32538**
32539C INCLUDE '(USRBIN)'
32540* USRBIN.ADD
32541**sr 18.5. commented since not used for evap.
32542C PARAMETER ( MXUSBN = 100 )
32543C LOGICAL LUSBIN, LEVTBN, LNTZER, LUSEVT, LUSTKB, LTRKBN
32544C CHARACTER*10 TITUSB
32545C COMMON /USRBN/ XLOW (MXUSBN), XHIGH (MXUSBN), YLOW (MXUSBN),
32546C & YHIGH (MXUSBN), ZLOW (MXUSBN), ZHIGH (MXUSBN),
32547C & DXUSBN(MXUSBN), DYUSBN(MXUSBN), DZUSBN(MXUSBN),
32548C & TCUSBN(MXUSBN), BKUSBN(MXUSBN), B2USBN(MXUSBN),
32549C & NXBIN (MXUSBN), NYBIN (MXUSBN), NZBIN (MXUSBN),
32550C & ITUSBN(MXUSBN), IDUSBN(MXUSBN), KBUSBN(MXUSBN),
32551C & IPUSBN(MXUSBN), LEVTBN(MXUSBN), LNTZER(MXUSBN),
32552C & LTRKBN(MXUSBN), NUSRBN, LUSBIN, LUSEVT, LUSTKB
32553C COMMON /USRCH/ TITUSB(MXUSBN)
32554**
32555C INCLUDE '(USRSNC)'
32556* USRSNC.ADD
32557**sr 18.5. commented since not used for evap.
32558C PARAMETER ( MXRSNC = 400 )
32559C PARAMETER ( NMZMIN = -5 )
32560C LOGICAL LURSNC
32561C CHARACTER*10 TIURSN
32562C COMMON /USRSNC/ VURSNC(MXRSNC), IZRHGH(MXRSNC), IMRHGH(MXRSNC),
32563C & NRURSN(MXRSNC), ITURSN(MXRSNC), KBURSN(MXRSNC),
32564C & IPURSN(MXRSNC), NURSNC, LURSNC
32565C COMMON /USRSCH/ TIURSN(MXRSNC)
32566C INCLUDE '(USRTRC)'
32567* USRTRC.ADD
32568**sr 18.5. commented since not used for evap.
32569C PARAMETER ( MXUSTC = 400 )
32570C LOGICAL LUSRTC, LUSTRK, LUSCLL, LLNUTC
32571C CHARACTER*10 TITUTC
32572C COMMON /USRTC/ ETCLOW(MXUSTC), ETCHGH(MXUSTC), DETCBN(MXUSTC),
32573C & VUSRTC(MXUSTC),
32574C & IUSTRK(MXUSTC), IUSCLL(MXUSTC), NETCBN(MXUSTC),
32575C & NRUSTC(MXUSTC), ITUSTC(MXUSTC), IDUSTC(MXUSTC),
32576C & KBUSTC(MXUSTC), IPUSTC(MXUSTC), IGMUTC(MXUSTC),
32577C & LLNUTC(MXUSTC), NUSRTC, NUSTRK, NUSCLL, LUSRTC,
32578C & LUSTRK, LUSCLL
32579C COMMON /USTCH/ TITUTC(MXUSTC)
32580**
32581C INCLUDE '(USRYLD)'
32582* USRYLD.ADD
32583**sr 18.5. commented since not used for evap.
32584C PARAMETER ( MXUSYL = 500 )
32585C LOGICAL LUSRYL, LLNUYL, LSCUYL
32586C CHARACTER*10 TITUYL
32587C COMMON /USRYL/ EYLLOW(MXUSYL), EYLHGH(MXUSYL), DEYLBN(MXUSYL),
32588C & USNRYL(MXUSYL), SGUSYL(MXUSYL), AYLLOW(MXUSYL),
32589C & AYLHGH(MXUSYL), PUSRYL, UUSRYL, VUSRYL, WUSRYL,
32590C & ETXUYL, ETYUYL, ETZUYL, GAMUYL, SQSUYL, UCMUYL,
32591C & VCMUYL, WCMUYL, IJUSYL, JTUSYL,
32592C & NEYLBN(MXUSYL), NR1UYL(MXUSYL), NR2UYL(MXUSYL),
32593C & IXUSYL(MXUSYL), ITUSYL(MXUSYL), IDUSYL(MXUSYL),
32594C & KBUSYL(MXUSYL), IPUSYL(MXUSYL), IGMUYL(MXUSYL),
32595C & IEUSYL(MXUSYL), IAUSYL(MXUSYL), LLNUYL(MXUSYL),
32596C & NUSRYL, LUSRYL, LSCUYL
32597C COMMON /USYCH/ TITUYL(MXUSYL)
32598**
32599C INCLUDE '(WWINDW)'
32600* WWINDW.ADD
32601**sr 18.5. commented since not used for evap.
32602C PARAMETER ( MXWWSP = 3 )
32603C PARAMETER ( WWSPMX = 50.D+00 )
32604C LOGICAL LWWNDW, LWWPRM
32605C COMMON / WWINDW / ETHWW1 (NALLWP), ETHWW2 (NALLWP),
32606C & WWEXWD (NALLWP), EXTWWN (NALLWP),
32607C & IWLBGN, IWHBGN, IWMBGN, LWWNDW, LWWPRM
32608**
32609
32610* /blnkcm/
32611* *** If blank common dimension has to be superseded substitute in the
32612* *** following two lines the new dimension in real*8 units to Nblnmx
32613**sr 18.5. commented since not used for evap.
32614C PARAMETER (MXDUMM = KALGNM * NBLNMX)
32615C DATA KTMBGN / NBLNMX /
32616C DATA MBLNMX / MXDUMM /
32617C DATA KBLNKL, KGMBGN, KGMLST, KCMBGN, KCMLST, KISBGN, KISLST,
32618C & KDTBGN, KDTLST, KUBBGN, KUBLST, KUXBGN, KUXLST, KTCBGN,
32619C & KTCLST, KRNBGN, KRNLST, KYLBGN, KYLLST, KXSBGN, KXSLST,
32620C & KIHBGN, KIHLST, KINBGN, KINLST, KIEBGN, KIELST, KETBGN,
32621C & KETLST, KRRBGN, KRRLST, KGLBGN, KGLLST, KNABGN, KNALST,
32622C & KGDBGN, KGDLST, KDWBGN, KDWLST, KGCBGN, KGCLST, KWLBGN,
32623C & KWLLST, KWHBGN, KWHLST, KWMBGN, KWMLST, KWSBGN, KWSLST,
32624C & KDPBGN, KDPLST, KRGBGN, KRGLST, KSGBGN, KSGLST, KBRBGN,
32625C & KBRLST / 57*0 /
32626
32627* /blntmp/
32628**sr 18.5. commented since not used for evap.
32629C DATA KIHBTM, KINBTM, KIEBTM, KRRBTM, KGLBTM, KNABTM, KGDWTM,
32630C & KBDWTM, KGCBTM, KWLOTM, KWHITM, KWMUTM, KWSHTM, KEXTTM,
32631C & KSTXTM, KSTNTM, KECTTM, KPCTTM, KLPBTM / 19*0 /
32632
32633* /cmmdnr/
32634**sr 18.5. commented since not used for evap.
32635C DATA DDNEAR / 0.D+00 /, LFLDNR / .FALSE. /
32636
32637* /ctitle/
32638**sr 18.5. commented since not used for evap.
32639C DATA RUNTIT (1:40) / '****************************************' /
32640C DATA RUNTIT(41:80) / '****************************************' /
32641C DATA ITEXPI, ITEXMX / 100000000, 150 /
32642* /detect/
32643**sr 18.5. commented since not used for evap.
32644C PARAMETER (NNN1 = NRGNMX*NDTCMX)
32645C PARAMETER (NNN2 = NSCRMX*NDTCMX)
32646C DATA LDTCTR /.FALSE./, NDTSCO /0/, NDTDET /0/
32647C DATA EDTMIN/NDTCMX*0.D0/, EDTBIN/NDTCMX*0.D0/, EDTCUT/NDTCMX*0.D0/
32648C DATA KDTREG/NNN1*0/, KDTDET/NNN2*0/, KDTSCD/NSCRMX*0/
32649C DATA TITDET/NDTCMX*' '/, TITSCO/NSCRMX*' '/
32650
32651* /detloc/
32652**sr 18.5. commented since not used for evap.
32653C DATA ACCUMP /NDTCM2*0.D0/, ACCUMN /NDTCM2*0.D0/, ICOINC /NDTCM2*0/
32654C DATA NCLAS /0/
32655
32656* /emgtrn/
32657**sr 18.5. commented since not used for evap.
32658C DATA LMCSMG / .FALSE. /
32659
32660* /emsho/
32661**sr 18.5. commented since not used for evap.
32662C DATA LIMPRE, LEXPTE / 2 * .FALSE. /
32663
32664* /episor/
32665**sr 18.5. commented since not used for evap.
32666C DATA TKESUM / 0.D+00 /, LUSSRC / .FALSE. /
32667
32668* /fheavy/
32669 DATA AMHEAV / 12 * 0.D+00 /
32670 DATA ANHEAV / 'NEUTRON ', 'PROTON ', 'DEUTERON', '3-H ',
32671 & '3-He ', '4-He ', 'H-FRAG-1', 'H-FRAG-2',
32672 & 'H-FRAG-3', 'H-FRAG-4', 'H-FRAG-5', 'H-FRAG-6'/
32673 DATA ICHEAV / 0, 1, 1, 1, 2, 2, 6*0 /,
32674 & IBHEAV / 1, 1, 2, 3, 3, 4, 6*0 /
32675 DATA NPHEAV / 0 /
32676
32677* /finuc/
32678 DATA NP / 0 /, TV / 0.D+00 /, TVCMS / 0.D+00 /, TVRECL / 0.D+00/,
32679 & TVHEAV / 0.D+00 /, TVBIND / 0.D+00 /
32680
32681* /genthr/
32682* Up to 20-apr-'95
32683* DATA PEANCT, PEAPIT / 2*1.D+00 /
32684* DATA PTHRSH / 16*5.D+00,2*2.5D+00,5.D+00,3*2.5D+00,8*5.D+00,
32685* & 9*2.5D+00 /
32686* DATA PTHDFF / 39*5.D+00 /
32687* & 9*2.5D+00 /
32688* New values:
32689**sr 18.5. commented since not used for evap.
32690C DATA PEANCT, PEAPIT / 1.3D+00, 1.1D+00 /
32691C DATA PTHRSH / 12*5.D+00, 2*3.5D+00, 2*5.D+00, 2*2.5D+00, 5.D+00,
32692C & 3*2.5D+00, 3.5D+00, 2*5.D+00, 3.5D+00, 4*5.D+00,
32693C & 9*2.5D+00 /
32694C DATA PTHDFF / 12*5.D+00, 2*3.5D+00, 8*5.D+00, 3.5D+00, 2*5.D+00,
32695C & 3.5D+00, 13*5.D+00 /
32696C DATA PLDNCT / 0.26D+00 /
32697C DATA IJNUCR / 16*1, 2*0, 1, 3*0, 8*1, 9*0 /
32698
32699* /lowneu/
32700**sr 18.5. commented since not used for evap.
32701C DATA WWAMFL / 10.D+00 /, EXTWWL / 1.D+00 /
32702C DATA IWWLWB, IWWLWT / 2 * 100000000 /
32703C DATA ICLMED, INABGN, IDWBGN, IETBGN / 4*0 /
32704C DATA IGRTHN / 1 /
32705C DATA LIMPRN / .FALSE. /, LBIASN / .FALSE. /, LDOWNN / .FALSE. /,
32706C & LLOWWW / .FALSE. /, LLOWET / .FALSE. /
32707
32708* /ltclcm/
32709**sr 18.5. commented since not used for evap.
32710C DATA MLATTC, NEWLAT, MLATLD, MLATM1, MLTSEN, MLTSM1 / 6*0 /
32711
32712* /mulbou/
32713**sr 18.5. commented since not used for evap.
32714C DATA LLDA, LAGAIN, LSTNEW, LARTEF, LSENSE, LNORML, LMGNOR
32715C & / 7 * .FALSE. /
32716C DATA TSENSE / AINFNT /, NSSENS / -1 /
32717C DATA DSMALL / ANGLGB /
32718
32719* /mulhd/
32720**sr 18.5. commented since not used for evap.
32721C DATA LTOPT / MXXMDF * .FALSE. /, NFSCAT / 0 /
32722C DATA ESTEPF / MXXMDF * 0.1D+00 /
32723C DATA LSRCRH / MXXMDF * .FALSE. /, LNSCRH / MXXMDF * .FALSE. /
32724C DATA THMSPR / 0.02D+00 /, THMSSC / 1.D+00 /
32725
32726* /parevt/
32727 DATA DPOWER /-13.D+00 /, FSPRD0 / 0.6D+00 /, FSHPFN / 0.0D+00 /,
32728 & RN1GSC /-1.0D+00 /, RN2GSC /-1.0D+00 /
32729 DATA LDIFFR / .TRUE., .TRUE., 6 * .TRUE., .TRUE., 8 * .TRUE.,
32730 & .TRUE., 4 * .TRUE., .TRUE., 3 * .TRUE.,
32731 & 4 * .FALSE., 9 * .TRUE./
32732**sr 17.5.95
32733* default value for LEVPRT changed (reset sr 25.7.97)
32734* default value for LHEAVY changed 25.7.97
32735C DATA LPOWER / .TRUE. /, LINCTV / .TRUE. /, LEVPRT / .TRUE. /,
32736C & LHEAVY / .FALSE. /, LDEEXG / .TRUE. /, LGDHPR / .TRUE. /,
32737C & LPREEX / .TRUE. /, LHLFIX / .FALSE. /, LPRFIX / .FALSE. /,
32738C & LPARWV / .TRUE. /, LSNGCH / .TRUE. /, LSCHDF / .TRUE. /
32739 DATA LPOWER / .TRUE. /, LINCTV / .TRUE. /, LEVPRT / .TRUE. /,
32740 & LHEAVY / .TRUE. /, LDEEXG / .TRUE. /, LGDHPR / .TRUE. /,
32741 & LPREEX / .TRUE. /, LHLFIX / .FALSE. /, LPRFIX / .FALSE. /,
32742 & LPARWV / .TRUE. /, LSNGCH / .TRUE. /, LSCHDF / .TRUE. /
32743**
32744**sr 27.5.97
32745* default value for ILVMOD changed
32746C DATA ILVMOD / 0 /, JLVMOD / 1 /, LLVMOD / .TRUE. /
32747 DATA ILVMOD / 1 /, JLVMOD / 1 /, LLVMOD / .TRUE. /
32748**
32749
32750* /resnuc/
32751 DATA IPREEH / 0 /, IPRTRI / 0 /, IPRDEU / 0 /, IPR3HE / 0 /,
32752 & IPR4HE / 0 /
32753 DATA IEVAPL / 0 /, IEVAPH / 0 /, IEVNEU / 0 /, IEVPRO / 0 /,
32754 & IEVTRI / 0 /, IEVDEU / 0 /, IEV3HE / 0 /, IEV4HE / 0 /,
32755 & IDEEXG / 0 /
32756 DATA LRNFSS / .FALSE. /
32757
32758* /scohlp/
32759**sr 18.5. commented since not used for evap.
32760C DATA ISCRNG, JSCRNG / 2*0 /, LSCZER / .FALSE. /
32761
32762* /trackr/
32763**sr 18.5. commented since not used for evap.
32764C DATA ETRACK /0.D+00/, WTRACK /0.D+00/, ATRACK /0.D+00/,
32765C & CTRACK /0.D+00/, NTRACK /0/, MTRACK /0/, JTRACK /0/
32766
32767* /usrbin/
32768**sr 18.5. commented since not used for evap.
32769C DATA LUSBIN, LUSEVT, LUSTKB /3*.FALSE./, NUSRBN /0/
32770
32771* /usrbdx/
32772**sr 18.5. commented since not used for evap.
32773C DATA LUSBDX /.FALSE./, NUSRBX /0/
32774
32775* /usrsnc/
32776**sr 18.5. commented since not used for evap.
32777C DATA LURSNC /.FALSE./, NURSNC /0/
32778
32779* /usrtrc/
32780**sr 18.5. commented since not used for evap.
32781C DATA LUSRTC, LUSTRK, LUSCLL / 3*.FALSE. /
32782C DATA NUSRTC, NUSTRK, NUSCLL / 3*0 /
32783
32784* /usryld/
32785**sr 18.5. commented since not used for evap.
32786C DATA LUSRYL / .FALSE./, LSCUYL / .FALSE. /, NUSRYL /0/,
32787C & IJUSYL /0/, JTUSYL /0/
32788C DATA PUSRYL, UUSRYL, VUSRYL, WUSRYL / 4*ZERZER /
32789
32790* /wwindw/
32791**sr 18.5. commented since not used for evap.
32792C DATA IWLBGN, IWHBGN, IWMBGN / 3*0 /
32793C DATA LWWPRM / .TRUE. /
32794
32795*= end*block.bdnopt *
32796 END
32797
32798*$ CREATE DT_BDPREE.FOR
32799*COPY DT_BDPREE
32800*
32801*=== bdpree ===========================================================*
32802*
32803 BLOCK DATA DT_BDPREE
32804
32805C INCLUDE '(DBLPRC)'
32806* DBLPRC.ADD
32807 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32808 SAVE
32809* (original name: GLOBAL)
32810 PARAMETER ( KALGNM = 2 )
32811 PARAMETER ( ANGLGB = 5.0D-16 )
32812 PARAMETER ( ANGLSQ = 2.5D-31 )
32813 PARAMETER ( AXCSSV = 0.2D+16 )
32814 PARAMETER ( ANDRFL = 1.0D-38 )
32815 PARAMETER ( AVRFLW = 1.0D+38 )
32816 PARAMETER ( AINFNT = 1.0D+30 )
32817 PARAMETER ( AZRZRZ = 1.0D-30 )
32818 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
32819 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
32820 PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
32821 PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
32822 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
32823 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
32824 PARAMETER ( CSNNRM = 2.0D-15 )
32825 PARAMETER ( DMXTRN = 1.0D+08 )
32826 PARAMETER ( ZERZER = 0.D+00 )
32827 PARAMETER ( ONEONE = 1.D+00 )
32828 PARAMETER ( TWOTWO = 2.D+00 )
32829 PARAMETER ( THRTHR = 3.D+00 )
32830 PARAMETER ( FOUFOU = 4.D+00 )
32831 PARAMETER ( FIVFIV = 5.D+00 )
32832 PARAMETER ( SIXSIX = 6.D+00 )
32833 PARAMETER ( SEVSEV = 7.D+00 )
32834 PARAMETER ( EIGEIG = 8.D+00 )
32835 PARAMETER ( ANINEN = 9.D+00 )
32836 PARAMETER ( TENTEN = 10.D+00 )
32837 PARAMETER ( HLFHLF = 0.5D+00 )
32838 PARAMETER ( ONETHI = ONEONE / THRTHR )
32839 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
32840 PARAMETER ( ONEFOU = ONEONE / FOUFOU )
32841 PARAMETER ( THRTWO = THRTHR / TWOTWO )
32842 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
32843 PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
32844 PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
32845 PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
32846 PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
32847 PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
32848 PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
32849 PARAMETER ( EULERO = 0.577215664901532860606512 D+00 )
32850 PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 )
32851 PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 )
32852 PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 )
32853 PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
32854 PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
32855 PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
32856 PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
32857 PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
32858 PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
32859 PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
32860 PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
32861 PARAMETER ( CLIGHT = 2.99792458 D+10 )
32862 PARAMETER ( AVOGAD = 6.0221367 D+23 )
32863 PARAMETER ( BOLTZM = 1.380658 D-23 )
32864 PARAMETER ( AMELGR = 9.1093897 D-28 )
32865 PARAMETER ( PLCKBR = 1.05457266 D-27 )
32866 PARAMETER ( ELCCGS = 4.8032068 D-10 )
32867 PARAMETER ( ELCMKS = 1.60217733 D-19 )
32868 PARAMETER ( AMUGRM = 1.6605402 D-24 )
32869 PARAMETER ( AMMUMU = 0.113428913 D+00 )
32870 PARAMETER ( AMPRMU = 1.007276470 D+00 )
32871 PARAMETER ( AMNEMU = 1.008664904 D+00 )
32872 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
32873 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
32874 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
32875 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
32876 PARAMETER ( PLABRC = 0.197327053 D+00 )
32877 PARAMETER ( AMELCT = 0.51099906 D-03 )
32878 PARAMETER ( AMUGEV = 0.93149432 D+00 )
32879 PARAMETER ( AMMUON = 0.105658389 D+00 )
32880 PARAMETER ( AMPRTN = 0.93827231 D+00 )
32881 PARAMETER ( AMNTRN = 0.93956563 D+00 )
32882 PARAMETER ( AMDEUT = 1.87561339 D+00 )
32883 PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
32884 & * 1.D-09 )
32885 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
32886 PARAMETER ( BLTZMN = 8.617385 D-14 )
32887 PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
32888 PARAMETER ( GFOHB3 = 1.16639 D-05 )
32889 PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
32890 PARAMETER ( SIN2TW = 0.2319 D+00 )
32891 PARAMETER ( GEVMEV = 1.0 D+03 )
32892 PARAMETER ( EMVGEV = 1.0 D-03 )
32893 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
32894 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
32895 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
32896 LOGICAL LGBIAS, LGBANA
32897 COMMON /FKGLOB/ LGBIAS, LGBANA
32898C INCLUDE '(DIMPAR)'
32899* DIMPAR.ADD
32900 PARAMETER ( MXXRGN = 5000 )
32901 PARAMETER ( MXXMDF = 82 )
32902 PARAMETER ( MXXMDE = 54 )
32903 PARAMETER ( MFSTCK = 1000 )
32904 PARAMETER ( MESTCK = 100 )
32905 PARAMETER ( NALLWP = 39 )
32906 PARAMETER ( NELEMX = 80 )
32907 PARAMETER ( MPDPDX = 8 )
32908 PARAMETER ( ICOMAX = 180 )
32909 PARAMETER ( NSTBIS = 304 )
32910 PARAMETER ( IDMAXP = 220 )
32911 PARAMETER ( IDMXDC = 640 )
32912 PARAMETER ( MKBMX1 = 1 )
32913 PARAMETER ( MKBMX2 = 1 )
32914C INCLUDE '(IOUNIT)'
32915* IOUNIT.ADD
32916 PARAMETER ( LUNIN = 5 )
32917 PARAMETER ( LUNOUT = 6 )
32918**sr 19.5. set error output-unit from 15 to 6
32919 PARAMETER ( LUNERR = 6 )
32920 PARAMETER ( LUNBER = 14 )
32921 PARAMETER ( LUNECH = 8 )
32922 PARAMETER ( LUNFLU = 13 )
32923 PARAMETER ( LUNGEO = 16 )
32924 PARAMETER ( LUNPMF = 12 )
32925 PARAMETER ( LUNRAN = 2 )
32926 PARAMETER ( LUNXSC = 9 )
32927 PARAMETER ( LUNDET = 17 )
32928 PARAMETER ( LUNRAY = 10 )
32929 PARAMETER ( LUNRDB = 1 )
32930 PARAMETER ( LUNPGO = 7 )
32931 PARAMETER ( LUNPGS = 4 )
32932 PARAMETER ( LUNSCR = 3 )
32933*
32934*----------------------------------------------------------------------*
32935* *
32936* Created on 16 september 1991 by Alfredo Ferrari & Paola Sala *
32937* Infn - Milan *
32938* *
32939* Last change on 03-feb-94 by Alfredo Ferrari *
32940* *
32941* *
32942*----------------------------------------------------------------------*
32943*
32944* (original name: CMPISG,CHPISG)
32945 PARAMETER ( TPPPI0 = 0.279656044337515D+00 )
32946 PARAMETER ( TNNPI0 = 0.279642680857450D+00 )
32947 PARAMETER ( TPPPIP = 0.292295207182790D+00 )
32948 PARAMETER ( TPPDEP = 0.287514778898469D+00 )
32949 PARAMETER ( TNNPIM = 0.286723140900975D+00 )
32950 PARAMETER ( TNNDEM = 0.281949292916434D+00 )
32951 PARAMETER ( TPNPI0 = 0.279456888147740D+00 )
32952 PARAMETER ( TPNDE0 = 0.274693916135245D+00 )
32953 PARAMETER ( TPNPIP = 0.292086756473890D+00 )
32954 PARAMETER ( TNPPI0 = 0.279842093144975D+00 )
32955 PARAMETER ( TNPDE0 = 0.275072555824202D+00 )
32956 PARAMETER ( TNPPIP = 0.292489370554958D+00 )
32957 PARAMETER ( PIRSMX = 1.2D+00 )
32958 PARAMETER ( NPIREA = 10 )
32959 PARAMETER ( NPIRTA = 68 )
32960 PARAMETER ( NPIRLN = 21 )
32961 PARAMETER ( NPIRLG = NPIRTA - NPIRLN )
32962 PARAMETER ( NPISIS = NPIRLN + 20 )
32963 PARAMETER ( NPISEX = NPIRLN + 21 )
32964 PARAMETER ( NPIIMN = 14 )
32965 PARAMETER ( NPIIRC = 6 )
32966 PARAMETER ( DELWLL = 0.035D+00 )
32967 CHARACTER CHPIRE*8
32968 LOGICAL LDLRES
32969 COMMON /FKCMPI/ PMNPIS, PMMPIS, PISPIS, PEXPIS, PMXPIS, DPPISG,
32970 & RTPISG, AMNPIS, AMMPIS, AISPIS, AEXPIS, AMXPIS,
32971 & ARPISG, BPISLO (NPIRLN:NPIRTA,NPIREA),
32972 & CPISLO (NPIRLN:NPIRTA,NPIREA), PPITHR (NPIREA),
32973 & SPISLO (NPIRLN:NPIRTA,NPIREA), APITHR (NPIREA),
32974 & SGPIIN (NPIIMN:NPIRTA,NPIIRC), RHPICR (1:5) ,
32975 & SGPICU (0:20,NPIRTA,NPIREA) , SGRTRS (NPIREA),
32976 & SGPIDF (0:20,NPIRTA,NPIREA) , BRREIN (NPIREA),
32977 & SGPIIS (NPIRTA,NPIREA) , BRREOU (NPIREA),
32978 & BRD3OU (2,2,-1:2), BRDEOU (2,-1:2),
32979 & SGABSR (2,2,4) , PRRSDL,
32980 & IPIREA (2,2,3:5) , IPIINE (2,3:5) , NPIRVR ,
32981 & KPIIRE (2,NPIREA), KPIORE (2,NPIREA) ,
32982 & JSTOKP (5), KPTOJS (23), ITTRRS (3:5), LDLRES
32983 COMMON /FKCHPI/ CHPIRE (NPIREA)
32984 DIMENSION SG2BRS (2,2), SGABSW (2,2), SG3BRS (2,2,2)
32985 EQUIVALENCE ( SG2BRS (1,1), SGABSR (1,1,1) )
32986 EQUIVALENCE ( SGABSW (1,1), SGABSR (1,1,2) )
32987 EQUIVALENCE ( SG3BRS (1,1,1), SGABSR (1,1,3) )
32988* (original name: FRBKCM)
32989 PARAMETER ( MXFFBK = 6 )
32990 PARAMETER ( MXZFBK = 9 )
32991 PARAMETER ( MXNFBK = 10 )
32992 PARAMETER ( MXAFBK = 16 )
32993 PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
32994 PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
32995 PARAMETER ( NXAFBK = MXAFBK + 1 )
32996 PARAMETER ( MXPSST = 300 )
32997 PARAMETER ( MXPSFB = 41000 )
32998 LOGICAL LFRMBK, LNCMSS
32999 COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
33000 & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
33001 & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
33002 & IFRBKN (MXPSST), IFRBKZ (MXPSST),
33003 & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
33004 & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
33005 & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
33006 & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
33007 & IFBFRB, NBUFBK, LFRMBK, LNCMSS
33008* (original name: NUCGID,NUCGEO,NUCGE2,NUCPWI,NUCGII)
33009 PARAMETER ( PI = PIPIPI )
33010 PARAMETER ( PISQ = PIPISQ )
33011 PARAMETER ( SKTOHL = 0.5456645846610345D+00 )
33012 PARAMETER ( RZNUCL = 1.12 D+00 )
33013 PARAMETER ( RMSPRO = 0.8 D+00 )
33014 PARAMETER ( R0PROT = RMSPRO / SQRT12 )
33015 PARAMETER ( ARHPRO = 1.D+00 / 8.D+00 / PI / R0PROT / R0PROT
33016 & / R0PROT )
33017 PARAMETER ( RLLE04 = RZNUCL )
33018 PARAMETER ( RLLE16 = RZNUCL )
33019 PARAMETER ( RLGT16 = RZNUCL )
33020 PARAMETER ( RCLE04 = 0.75D+00 / PI / RLLE04 / RLLE04 / RLLE04 )
33021 PARAMETER ( RCLE16 = 0.75D+00 / PI / RLLE16 / RLLE16 / RLLE16 )
33022 PARAMETER ( RCGT16 = 0.75D+00 / PI / RLGT16 / RLGT16 / RLGT16 )
33023 PARAMETER ( SKLE04 = 1.4D+00 )
33024 PARAMETER ( SKLE16 = 1.9D+00 )
33025 PARAMETER ( SKGT16 = 2.4D+00 )
33026 PARAMETER ( HLLE04 = SKTOHL * SKLE04 )
33027 PARAMETER ( HLLE16 = SKTOHL * SKLE16 )
33028 PARAMETER ( HLGT16 = SKTOHL * SKGT16 )
33029 PARAMETER ( ALPHA0 = 0.1D+00 )
33030 PARAMETER ( OMALH0 = 1.D+00 - ALPHA0 )
33031 PARAMETER ( GAMSK0 = 0.9D+00 )
33032 PARAMETER ( OMGAS0 = 1.D+00 - GAMSK0 )
33033 PARAMETER ( POTME0 = 0.6666666666666667D+00 )
33034 PARAMETER ( POTBA0 = 1.D+00 )
33035 PARAMETER ( PNFRAT = 1.533D+00 )
33036 PARAMETER ( RADPIM = 0.035D+00 )
33037 PARAMETER ( RDPMHL = 14.D+00 )
33038 PARAMETER ( APMRST = 4.D+00 / 44.D+00 )
33039 PARAMETER ( APMPRO = 1.D+00 / 6.D+00 )
33040 PARAMETER ( APPPRO = 5.D+00 / 6.D+00 )
33041 PARAMETER ( AP0PFS = 0.5D+00 )
33042 PARAMETER ( AP0PFP = 1.D+00 / 3.D+00 )
33043 PARAMETER ( AP0NFP = 2.D+00 / 3.D+00 )
33044 PARAMETER ( XPAUCO = 1.88495407241652 D+00 )
33045 PARAMETER ( MXSCIN = 50 )
33046 LOGICAL LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH, LNCDCY,
33047 & LNUSCT, LPREEQ, LNPHTC, LNWRAD, LPNRHO, LFTCMP, LFTCAC
33048 COMMON /FKNGID/ RHOTAB (2:260), RHATAB (2:260), ALPTAB (2:260),
33049 & RADTAB (2:260), SKITAB (2:260), HALTAB (2:260),
33050 & SK3TAB (2:260), SK4TAB (2:260), HABTAB (2:260),
33051 & CWSTAB (2:260), EKATAB (2:260), PFATAB (2:260),
33052 & PFRTAB (2:260)
33053 COMMON /FKNGEO/ RADTOT, RADIU1, RADIU0, RAD1O2, SKINDP, HALODP,
33054 & ALPHAL, OMALHL, RADSKN, SKNEFF, CPARWS, RADPRO,
33055 & RADCOR, RADCO2, RADMAX, BIMPTR, RIMPTR, XIMPTR,
33056 & YIMPTR, ZIMPTR, RHOIMT, EKFPRO, PFRPRO, RHOCEN,
33057 & RHOCOR, RHOSKN, EKFCEN (2), PFRCEN (2), EKFBIM,
33058 & PFRBIM, RHOIMP, EKFIMP, PFRIMP, RHOIM2, EKFIM2,
33059 & PFRIM2, RHOIM3, EKFIM3, PFRIM3, VPRWLL, RIMPCT,
33060 & BIMPCT, XIMPCT, YIMPCT, ZIMPCT, RIMPC2, XIMPC2,
33061 & YIMPC2, ZIMPC2, RIMPC3, XIMPC3, YIMPC3, ZIMPC3,
33062 & XBIMPC, YBIMPC, ZBIMPC, CXIMPC, CYIMPC, CZIMPC,
33063 & SQRIMP, SIGMAP, SIGMAN, SIGMAA, RHORED, R0TRAJ,
33064 & R1TRAJ, SBUSED, SBTOT , SBRES , RHOAVE, EKFAVE,
33065 & PFRAVE, AVEBIN, ACOLL , ZCOLL , RADSIG, OPACTY,
33066 & EKECON, PNUCCO, EKEWLL, PPRWLL, PXPROJ, PYPROJ,
33067 & PZPROJ, EKFERM, PNFRMI, PXFERM, PYFERM, PZFERM,
33068 & EKFER2, PNFRM2, PXFER2, PYFER2, PZFER2, EKFER3,
33069 & PNFRM3, PXFER3, PYFER3, PZFER3, RHOMEM, EKFMEM,
33070 & BIMMEM, WLLRED, VPRBIM, POTINC, POTOUT, EEXMIN
33071 COMMON /FKNGE2/ RDTTNC (2), RHONCP (2), RHONC2 (2), RHONC3 (2),
33072 & RHONCT (2), AMOTHR, EKOTHR, AMCREA, EKNCLN,
33073 & EEXDEL, EEXANY, CLMBBR, RDCLMB, BFCLMB, BFCEFF,
33074 & BNPROJ, BNDNUC, DEBRLM, SK4PAR, UBIMPC, VBIMPC,
33075 & WBIMPC, BNDPOT, SIGMAT, SIGABP, SIGABN, WLLRES,
33076 & POTBAR, POTMES, AGEPRI, OPNOPA, ETHRND,
33077 & BNENRG (3), DEFNUC (2), SIGMPR (4), SIGMNU (4),
33078 & SIGPAB (3), SIGNAB (3), HHLP (2), FORTOT (2),
33079 & FPNBLC, DPNBLC, FFTFLG, IFTFLG,
33080 & IPWELL, ITNCMX, KPRIN , NTARGT, KNUCIM, KNUCI2,
33081 & KNUCI3, IEVPRE, ISFCOL, ISFTAR, ISFTA2, ISFTA3,
33082 & NPOTHR, ICOTHR, IBOTHR, NPUMFN, ISTNCL, ITAUCM,
33083 & IABCOU, IADFLG, IGSFLG, IALFLG, ICBFLG, LPREEQ,
33084 & LNPHTC, LPNRHO, LNWRAD, LFTCMP, LFTCAC
33085 COMMON /FKNPWI/ ALMBAR, BIMMAX, SIGGEO, LLLMAX, LLLACT
33086 COMMON /FKNGII/ HOLEXP (2*MXSCIN), XEXPIN (3,0:MXSCIN),
33087 & YEXPIN (3,0:MXSCIN), ZEXPIN (3,0:MXSCIN),
33088 & AGEXIN (0:MXSCIN), RHOEXP (2), EKFEXP, EHLFIX,
33089 & NHLEXP, NHLFIX, IPRTYP, NNCEXI (0:MXSCIN),
33090 & NCEXPI (3,0:MXSCIN), ISEXIN (3,0:MXSCIN),
33091 & ISCTYP (0:MXSCIN), NUSCIN, NEXPEM,
33092 & LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH,
33093 & LNCDCY, LNUSCT
33094 DIMENSION AWSTAB (2:260), SIGMAB (3)
33095 EQUIVALENCE ( DEFPRO, DEFNUC (1) )
33096 EQUIVALENCE ( DEFNEU, DEFNUC (2) )
33097 EQUIVALENCE ( RHOIPP, RHONCP (1) )
33098 EQUIVALENCE ( RHOINP, RHONCP (2) )
33099 EQUIVALENCE ( RHOIP2, RHONC2 (1) )
33100 EQUIVALENCE ( RHOIN2, RHONC2 (2) )
33101 EQUIVALENCE ( RHOIP3, RHONC3 (1) )
33102 EQUIVALENCE ( RHOIN3, RHONC3 (2) )
33103 EQUIVALENCE ( RHOIPT, RHONCT (1) )
33104 EQUIVALENCE ( RHOINT, RHONCT (2) )
33105 EQUIVALENCE ( OMALHL, SK3PAR )
33106 EQUIVALENCE ( ALPHAL, HABPAR )
33107 EQUIVALENCE ( ALPTAB (2), AWSTAB (2) )
33108 EQUIVALENCE ( SIGMPE, SIGMPR (1) )
33109 EQUIVALENCE ( SIGMPC, SIGMPR (2) )
33110 EQUIVALENCE ( SIGMPI, SIGMPR (3) )
33111 EQUIVALENCE ( SIGMPA, SIGMPR (4) )
33112 EQUIVALENCE ( SIGMNE, SIGMNU (1) )
33113 EQUIVALENCE ( SIGMNC, SIGMNU (2) )
33114 EQUIVALENCE ( SIGMNI, SIGMNU (3) )
33115 EQUIVALENCE ( SIGMNA, SIGMNU (4) )
33116 EQUIVALENCE ( SIGMA2, SIGPAB (1) )
33117 EQUIVALENCE ( SIGMA3, SIGPAB (2) )
33118 EQUIVALENCE ( SIGMAS, SIGPAB (3) )
33119 EQUIVALENCE ( SIGPAB (1), SIGMAB (1) )
33120* (original name: NUCLEV)
33121 LOGICAL LCLVSL, LFLVSL, LRLVSL, LEQSBL
33122 COMMON /FKNLEV/ PAENUC (200,2), SHENUC (200,2), DEFRMI (2),
33123 & DEFMAG (2), ENNCLV (160,2), RANCLV (160,2),
33124 & CUMRAD (0:160,2), RUSNUC (2),
33125 & ENPLVL (114), ENNLVL(164), JUSNUC (160,2),
33126 & NTANUC (2), NAVNUC (2), NLSNUC (2), NCONUC (2),
33127 & NSKNUC (2), NHANUC (2), NUSNUC (2), NACNUC (2),
33128 & JMXNUC (2), IPRNUC (3), JPRNUC (3), MAGNUM (8),
33129 & MAGNUC (2), MGSNUC (8,2), MGSSNC (25,2),
33130 & NSBSHL (2), NMNSBS (2), NPRNUC, INUCLV, LCLVSL,
33131 & LFLVSL, LRLVSL, LEQSBL
33132 DIMENSION JUSPRO (160), JUSNEU (160), MGSPRO (8), MGSNEU (8),
33133 & MGSSPR (19) , MGSSNE (25)
33134 EQUIVALENCE ( RUSNUC (1), RUSPRO )
33135 EQUIVALENCE ( RUSNUC (2), RUSNEU )
33136 EQUIVALENCE ( JUSNUC (1,1), JUSPRO (1) )
33137 EQUIVALENCE ( JUSNUC (1,2), JUSNEU (1) )
33138 EQUIVALENCE ( MGSNUC (1,1), MGSPRO (1) )
33139 EQUIVALENCE ( MGSNUC (1,2), MGSNEU (1) )
33140 EQUIVALENCE ( MGSSNC (1,1), MGSSPR (1) )
33141 EQUIVALENCE ( MGSSNC (1,2), MGSSNE (1) )
33142 EQUIVALENCE ( NTANUC (1), NTAPRO )
33143 EQUIVALENCE ( NTANUC (2), NTANEU )
33144 EQUIVALENCE ( NAVNUC (1), NAVPRO )
33145 EQUIVALENCE ( NAVNUC (2), NAVNEU )
33146 EQUIVALENCE ( NLSNUC (1), NLSPRO )
33147 EQUIVALENCE ( NLSNUC (2), NLSNEU )
33148 EQUIVALENCE ( NCONUC (1), NCOPRO )
33149 EQUIVALENCE ( NCONUC (2), NCONEU )
33150 EQUIVALENCE ( NSKNUC (1), NSKPRO )
33151 EQUIVALENCE ( NSKNUC (2), NSKNEU )
33152 EQUIVALENCE ( NHANUC (1), NHAPRO )
33153 EQUIVALENCE ( NHANUC (2), NHANEU )
33154 EQUIVALENCE ( NUSNUC (1), NUSPRO )
33155 EQUIVALENCE ( NUSNUC (2), NUSNEU )
33156 EQUIVALENCE ( NACNUC (1), NACPRO )
33157 EQUIVALENCE ( NACNUC (2), NACNEU )
33158 EQUIVALENCE ( JMXNUC (1), JMXPRO )
33159 EQUIVALENCE ( JMXNUC (2), JMXNEU )
33160 EQUIVALENCE ( MAGNUC (1), MAGPRO )
33161 EQUIVALENCE ( MAGNUC (2), MAGNEU )
33162* (original name: PARNUC)
33163 PARAMETER ( PIGRK = PIPIPI )
33164 PARAMETER ( ALEVEL = 8.D-03 )
33165 PARAMETER ( RCNUCL = 1.12D+00 )
33166 PARAMETER ( R0SIG = 1.3D+00 )
33167 PARAMETER ( R0SIGK = 1.5D+00 )
33168 PARAMETER ( RCOULB = 1.5D+00 )
33169 PARAMETER ( COULBH = 0.88235D-03 )
33170 PARAMETER ( RHONU0 = 0.75D+00 / PIGRK / RCNUCL / RCNUCL / RCNUCL )
33171 PARAMETER ( TAUFO0 = 10.0D+00 )
33172 PARAMETER ( EKEEXP = 0.03D+00 )
33173 PARAMETER ( EKREXP = 0.05D+00 )
33174 PARAMETER ( EKEMNM = 0.01D+00 )
33175 PARAMETER ( NCPMX = 120 )
33176 COMMON /FKPARN/ EKORI , PXORI , PYORI , PZORI , PTORI , TAUFOR,
33177 & ENNUC (NCPMX), PNUCL (NCPMX), EKFNUC (NCPMX),
33178 & XSTNUC (NCPMX), YSTNUC (NCPMX), ZSTNUC (NCPMX),
33179 & PXNUCL (NCPMX), PYNUCL (NCPMX), PZNUCL (NCPMX),
33180 & RSTNUC (NCPMX), FREEPA (NCPMX), CRRPAN (NCPMX),
33181 & CRRPAP (NCPMX), BSTNUC (NCPMX), AGENUC (NCPMX),
33182 & TAUFPA (NCPMX), RHNUCL(NCPMX,2), BNDGAV, DEFMIN,
33183 & KPNUCL (NCPMX), KRFNUC (NCPMX), ILINUC (NCPMX),
33184 & INUCTS (NCPMX), ISFNUC (NCPMX), KPORI , IBORI ,
33185 & IBNUCL, NPNUC , NNUCTS
33186*
33187 DATA LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH / 6*.FALSE. /
33188 DATA POTBAR / POTBA0 /, POTMES / POTME0 /, WLLRES / 0.D+00 /
33189 DATA JUSNUC / 320 * 0 /, INUCLV / 1 /, IEVPRE / 0 /
33190 DATA MAGNUM / 2, 8, 20, 28, 50, 82, 126, 160 /
33191 DATA LPREEQ / .FALSE. /
33192* /cmpisg/
33193 DATA JSTOKP / 1, 8, 13, 14, 23 /
33194 DATA KPTOJS / 1, 6*0, 2, 4*0, 3, 4, 8*0, 5 /
33195 DATA CHPIRE / 'PI+PPI+P','PI-PPI-P','PI-PPI0N','PI0PPI0P',
33196 & 'PI0PPI+N','PI-NPI-N','PI+NPI+N','PI+NPI0P',
33197 & 'PI0NPI0N','PI0NPI-P' /
33198 DATA KPIIRE / 13, 1, 14, 1, 14, 1, 23, 1, 23, 1, 14, 8,
33199 & 13, 8, 13, 8, 23, 8, 23, 8 /
33200 DATA KPIORE / 13, 1, 14, 1, 23, 8, 23, 1, 13, 8, 14, 8,
33201 & 13, 8, 23, 1, 23, 8, 14, 1 /
33202 DATA IPIREA / 1, 0, 7, 8, 2, 3, 6, 0, 4, 5, 9, 10 /
33203 DATA IPIINE / 1, 2, 3, 4, 5, 6 /
33204* /frbkcm/
33205 DATA LFRMBK / .FALSE. /
33206 DATA NBUFBK / 500 /
33207 DATA EXMXFB / 80.0 D+00 /
33208 DATA R0FRBK / 1.18 D+00 /
33209 DATA R0CFBK / 2.173D+00 /
33210 DATA C1CFBK / 6.103D-03 /
33211 DATA C2CFBK / 9.443D-03 /
33212* /parnuc/
33213 DATA TAUFOR / TAUFO0 /
33214*=== End of Block Data Bdpree =========================================*
33215 END
33216
33217*$ CREATE DT_XHOINI.FOR
33218*COPY DT_XHOINI
33219*
33220*====phoini============================================================*
33221*
33222 SUBROUTINE DT_XHOINI
33223C SUBROUTINE DT_PHOINI
33224
33225 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33226 SAVE
33227 PARAMETER ( LINP = 10 ,
33228 & LOUT = 6 ,
33229 & LDAT = 9 )
33230
33231 RETURN
33232 END
33233
33234*$ CREATE DT_XVENTB.FOR
33235*COPY DT_XVENTB
33236*
33237*====eventb============================================================*
33238*
33239 SUBROUTINE DT_XVENTB(NCSY,IREJ)
33240C SUBROUTINE DT_EVENTB(NCSY,IREJ)
33241
33242 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33243 SAVE
33244 PARAMETER ( LINP = 10 ,
33245 & LOUT = 6 ,
33246 & LDAT = 9 )
33247
33248 WRITE(LOUT,1000)
33249 1000 FORMAT(1X,'EVENTB: PHOJET-package requested but not linked!')
33250 STOP
33251
33252 END
33253
33254*$ CREATE DT_XVENT.FOR
33255*COPY DT_XVENT
33256*
33257*===event==============================================================*
33258*
33259 SUBROUTINE DT_XVENT(IDUM,PP,PT,DUM,IREJ)
33260C SUBROUTINE EVENT(IDUM,PP,PT,DUM,IREJ)
33261
33262 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33263 SAVE
33264
33265 DIMENSION PP(4),PT(4)
33266
33267 RETURN
33268 END
33269
33270*$ CREATE DT_XOHISX.FOR
33271*COPY DT_XOHISX
33272*
33273*===pohisx=============================================================*
33274*
33275 SUBROUTINE DT_XOHISX(I,X)
33276C SUBROUTINE POHISX(I,X)
33277
33278 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33279 SAVE
33280
33281 RETURN
33282 END
33283
33284*$ CREATE PHO_LHIST.FOR
33285*COPY PHO_LHIST
33286*
33287*===poluhi=============================================================*
33288*
33289 SUBROUTINE PHO_LHIST(I,X)
33290**
33291
33292 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33293 SAVE
33294
33295 RETURN
33296 END
33297
33298*$ CREATE PDFSET.FOR
33299*COPY PDFSET
33300*
33301C**********************************************************************
33302C
33303C dummy subroutines, remove to link PDFLIB
33304C
33305C**********************************************************************
33306 SUBROUTINE PDFSET(PARAM,VALUE)
33307 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33308 DIMENSION PARAM(20),VALUE(20)
33309 CHARACTER*20 PARAM
33310 END
33311
33312*$ CREATE STRUCTM.FOR
33313*COPY STRUCTM
33314*
33315 SUBROUTINE STRUCTM(XI,SCALE2,UV,DV,US,DS,SS,CS,BS,TS,GL)
33316 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33317 END
33318
33319*$ CREATE STRUCTP.FOR
33320*COPY STRUCTP
33321*
33322 SUBROUTINE STRUCTP(XI,SCALE2,P2,IP2,UV,DV,US,DS,SS,CS,BS,TS,GL)
33323 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33324 END
33325
33326*$ CREATE DT_DIQBRK.FOR
33327*COPY DT_DIQBRK
33328*
33329*===diqbrk=============================================================*
33330*
33331 SUBROUTINE DT_XIQBRK
33332C SUBROUTINE DT_DIQBRK
33333
33334 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33335 SAVE
33336
33337 STOP 'diquark-breaking not implemeted !'
33338
33339 RETURN
33340 END
33341
33342*$ CREATE DT_ELHAIN.FOR
33343*COPY DT_ELHAIN
33344*
33345*===elhain=============================================================*
33346*
33347 SUBROUTINE DT_ELHAIN(IP,PLA,ELAB,CX,CY,CZ,IT,IREJ)
33348
33349************************************************************************
33350* Elastic hadron-hadron scattering. *
33351* This is a revised version of the original. *
33352* This version dated 03.04.98 is written by S. Roesler *
33353************************************************************************
33354
33355 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33356 SAVE
33357 PARAMETER ( LINP = 10 ,
33358 & LOUT = 6 ,
33359 & LDAT = 9 )
33360 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
33361 & TINY10=1.0D-10)
33362
33363 PARAMETER (ENNTHR = 3.5D0)
33364 PARAMETER (PLOWH=0.01D0,PHIH=9.0D0,
33365 & BLOWB=0.05D0,BHIB=0.2D0,
33366 & BLOWM=0.1D0, BHIM=2.0D0)
33367
33368* particle properties (BAMJET index convention)
33369 CHARACTER*8 ANAME
33370 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
33371 & IICH(210),IIBAR(210),K1(210),K2(210)
33372* final state from HADRIN interaction
33373 PARAMETER (MAXFIN=10)
33374 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
33375 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
33376
33377C DATA TSLOPE /10.0D0/
33378
33379 IREJ = 0
33380
33381 1 CONTINUE
33382
33383 PLAB = SQRT( (ELAB-AAM(IP))*(ELAB+AAM(IP)) )
33384 EKIN = ELAB-AAM(IP)
33385* kinematical quantities in cms of the hadrons
33386 AMP2 = AAM(IP)**2
33387 AMT2 = AAM(IT)**2
33388 S = AMP2+AMT2+TWO*ELAB*AAM(IT)
33389 ECM = SQRT(S)
33390 ECMP = OHALF*ECM+(AMP2-AMT2)/(TWO*ECM)
33391 PCM = SQRT( (ECMP-AAM(IP))*(ECMP+AAM(IP)) )
33392
33393* nucleon-nucleon scattering at E_kin<3.5: use DT_TSAMCS(HETC-KFA)
33394 IF ( ((IP.EQ.1).OR.(IP.EQ.8)).AND.
33395 & ((IT.EQ.1).OR.(IT.EQ.8)).AND.(EKIN.LT.ENNTHR) ) THEN
33396* TSAMCS treats pp and np only, therefore change pn into np and
33397* nn into pp
33398 IF (IT.EQ.1) THEN
33399 KPROJ = IP
33400 ELSE
33401 KPROJ = 8
33402 IF (IP.EQ.8) KPROJ = 1
33403 ENDIF
33404 CALL DT_TSAMCS(KPROJ,EKIN,CTCMS)
33405 T = TWO*PCM**2*(CTCMS-ONE)
33406
33407* very crude treatment otherwise: sample t from exponential dist.
33408 ELSE
33409* momentum transfer t
33410 TMAX = TWO*TWO*PCM**2
33411 RR = (PLAB-PLOWH)/(PHIH-PLOWH)
33412 IF (IIBAR(IP).NE.0) THEN
33413 TSLOPE = BLOWB+RR*(BHIB-BLOWB)
33414 ELSE
33415 TSLOPE = BLOWM+RR*(BHIM-BLOWM)
33416 ENDIF
33417 FMAX = EXP(-TSLOPE*TMAX)-ONE
33418 R = DT_RNDM(RR)
33419 T = LOG(ONE+R*FMAX+TINY10)/TSLOPE
33420 IF (T.GT.ZERO) T = LOG(ONE+R*FMAX)/TSLOPE
33421 ENDIF
33422
33423* target hadron in Lab after scattering
33424 ELRH(2) = (TWO*AMT2-T)/(TWO*AAM(IT))
33425 PLRH(2) = SQRT( ABS(ELRH(2)-AAM(IT))*(ELRH(2)+AAM(IT)) )
33426 IF (PLRH(2).LE.TINY10) THEN
33427C WRITE(*,*)'ELHAIN: T,PLRH(2) ',T,PLRH(2)
33428 GOTO 1
33429 ENDIF
33430* projectile hadron in Lab after scattering
33431 ELRH(1) = ELAB+AAM(IT)-ELRH(2)
33432 PLRH(1) = SQRT( ABS(ELRH(1)-AAM(IP))*(ELRH(1)+AAM(IP)) )
33433* scattering angle of projectile in Lab
33434 CTLABP = (T-TWO*AMP2+TWO*ELAB*ELRH(1))/(TWO*PLAB*PLRH(1))
33435 STLABP = SQRT( (ONE-CTLABP)*(ONE+CTLABP) )
33436 CALL DT_DSFECF(SPLABP,CPLABP)
33437* direction cosines of projectile in Lab
33438 CALL DT_STTRAN(CX,CY,CZ,CTLABP,STLABP,SPLABP,CPLABP,
33439 & CXRH(1),CYRH(1),CZRH(1))
33440* scattering angle of target in Lab
33441 PLLABT = PLAB-CTLABP*PLRH(1)
33442 CTLABT = PLLABT/PLRH(2)
33443 STLABT = SQRT( (ONE-CTLABT)*(ONE+CTLABT) )
33444* direction cosines of target in Lab
33445 CALL DT_STTRAN(CX,CY,CZ,CTLABT,STLABT,-SPLABP,-CPLABP,
33446 & CXRH(2),CYRH(2),CZRH(2))
33447* fill /HNFSPA/
33448 IRH = 2
33449 ITRH(1) = IP
33450 ITRH(2) = IT
33451
33452 RETURN
33453 END
33454
33455*$ CREATE DT_TSAMCS.FOR
33456*COPY DT_TSAMCS
33457*
33458*===tsamcs=============================================================*
33459*
33460 SUBROUTINE DT_TSAMCS(KPROJ,EKIN,CST)
33461
33462************************************************************************
33463* Sampling of cos(theta) for nucleon-proton scattering according to *
33464* hetkfa2/bertini parametrization. *
33465* This is a revised version of the original (HJM 24/10/88) *
33466* This version dated 28.10.95 is written by S. Roesler *
33467************************************************************************
33468
33469 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33470 SAVE
33471 PARAMETER ( LINP = 10 ,
33472 & LOUT = 6 ,
33473 & LDAT = 9 )
33474 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
33475 & TINY10=1.0D-10)
33476
33477 DIMENSION DCLIN(195),DCHN(143),DCHNA(36),DCHNB(60)
33478 DIMENSION PDCI(60),PDCH(55)
33479
33480 DATA (DCLIN(I),I=1,80) /
33481 & 5.000D-01, 1.000D+00, 0.000D+00, 1.000D+00, 0.000D+00,
33482 & 4.993D-01, 9.881D-01, 5.963D-02, 9.851D-01, 5.945D-02,
33483 & 4.936D-01, 8.955D-01, 5.224D-01, 8.727D-01, 5.091D-01,
33484 & 4.889D-01, 8.228D-01, 8.859D-01, 7.871D-01, 8.518D-01,
33485 & 4.874D-01, 7.580D-01, 1.210D+00, 7.207D-01, 1.117D+00,
33486 & 4.912D-01, 6.969D-01, 1.516D+00, 6.728D-01, 1.309D+00,
33487 & 5.075D-01, 6.471D-01, 1.765D+00, 6.667D-01, 1.333D+00,
33488 & 5.383D-01, 6.054D-01, 1.973D+00, 7.059D-01, 1.176D+00,
33489 & 5.397D-01, 5.990D-01, 2.005D+00, 7.023D-01, 1.191D+00,
33490 & 5.336D-01, 6.083D-01, 1.958D+00, 6.959D-01, 1.216D+00,
33491 & 5.317D-01, 6.075D-01, 1.962D+00, 6.897D-01, 1.241D+00,
33492 & 5.300D-01, 6.016D-01, 1.992D+00, 6.786D-01, 1.286D+00,
33493 & 5.281D-01, 6.063D-01, 1.969D+00, 6.786D-01, 1.286D+00,
33494 & 5.280D-01, 5.960D-01, 2.020D+00, 6.667D-01, 1.333D+00,
33495 & 5.273D-01, 5.920D-01, 2.040D+00, 6.604D-01, 1.358D+00,
33496 & 5.273D-01, 5.862D-01, 2.069D+00, 6.538D-01, 1.385D+00/
33497 DATA (DCLIN(I),I=81,160) /
33498 & 5.223D-01, 5.980D-01, 2.814D+00, 6.538D-01, 1.385D+00,
33499 & 5.202D-01, 5.969D-01, 2.822D+00, 6.471D-01, 1.412D+00,
33500 & 5.183D-01, 5.881D-01, 2.883D+00, 6.327D-01, 1.469D+00,
33501 & 5.159D-01, 5.866D-01, 2.894D+00, 6.250D-01, 1.500D+00,
33502 & 5.133D-01, 5.850D-01, 2.905D+00, 6.170D-01, 1.532D+00,
33503 & 5.106D-01, 5.833D-01, 2.917D+00, 6.087D-01, 1.565D+00,
33504 & 5.084D-01, 5.801D-01, 2.939D+00, 6.000D-01, 1.600D+00,
33505 & 5.063D-01, 5.763D-01, 2.966D+00, 5.909D-01, 1.636D+00,
33506 & 5.036D-01, 5.730D-01, 2.989D+00, 5.814D-01, 1.674D+00,
33507 & 5.014D-01, 5.683D-01, 3.022D+00, 5.714D-01, 1.714D+00,
33508 & 4.986D-01, 5.641D-01, 3.051D+00, 5.610D-01, 1.756D+00,
33509 & 4.964D-01, 5.580D-01, 3.094D+00, 5.500D-01, 1.800D+00,
33510 & 4.936D-01, 5.573D-01, 3.099D+00, 5.431D-01, 1.827D+00,
33511 & 4.909D-01, 5.509D-01, 3.144D+00, 5.313D-01, 1.875D+00,
33512 & 4.885D-01, 5.512D-01, 3.142D+00, 5.263D-01, 1.895D+00,
33513 & 4.857D-01, 5.437D-01, 3.194D+00, 5.135D-01, 1.946D+00/
33514 DATA (DCLIN(I),I=161,195) /
33515 & 4.830D-01, 5.353D-01, 3.253D+00, 5.000D-01, 2.000D+00,
33516 & 4.801D-01, 5.323D-01, 3.274D+00, 4.915D-01, 2.034D+00,
33517 & 4.770D-01, 5.228D-01, 3.341D+00, 4.767D-01, 2.093D+00,
33518 & 4.738D-01, 5.156D-01, 3.391D+00, 4.643D-01, 2.143D+00,
33519 & 4.701D-01, 5.010D-01, 3.493D+00, 4.444D-01, 2.222D+00,
33520 & 4.672D-01, 4.990D-01, 3.507D+00, 4.375D-01, 2.250D+00,
33521 & 4.634D-01, 4.856D-01, 3.601D+00, 4.194D-01, 2.323D+00/
33522
33523 DATA PDCI /
33524 & 4.400D+02, 1.896D-01, 1.931D-01, 1.982D-01, 1.015D-01,
33525 & 1.029D-01, 4.180D-02, 4.228D-02, 4.282D-02, 4.350D-02,
33526 & 2.204D-02, 2.236D-02, 5.900D+02, 1.433D-01, 1.555D-01,
33527 & 1.774D-01, 1.000D-01, 1.128D-01, 5.132D-02, 5.600D-02,
33528 & 6.158D-02, 6.796D-02, 3.660D-02, 3.820D-02, 6.500D+02,
33529 & 1.192D-01, 1.334D-01, 1.620D-01, 9.527D-02, 1.141D-01,
33530 & 5.283D-02, 5.952D-02, 6.765D-02, 7.878D-02, 4.796D-02,
33531 & 6.957D-02, 8.000D+02, 4.872D-02, 6.694D-02, 1.152D-01,
33532 & 9.348D-02, 1.368D-01, 6.912D-02, 7.953D-02, 9.577D-02,
33533 & 1.222D-01, 7.755D-02, 9.525D-02, 1.000D+03, 3.997D-02,
33534 & 5.456D-02, 9.804D-02, 8.084D-02, 1.208D-01, 6.520D-02,
33535 & 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02, 1.093D-01/
33536
33537 DATA PDCH /
33538 & 1.000D+03, 9.453D-02, 9.804D-02, 8.084D-02, 1.208D-01,
33539 & 6.520D-02, 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02,
33540 & 1.093D-01, 1.400D+03, 1.072D-01, 7.450D-02, 6.645D-02,
33541 & 1.136D-01, 6.750D-02, 8.580D-02, 1.110D-01, 1.530D-01,
33542 & 1.010D-01, 1.350D-01, 2.170D+03, 4.004D-02, 3.013D-02,
33543 & 2.664D-02, 5.511D-02, 4.240D-02, 7.660D-02, 1.364D-01,
33544 & 2.300D-01, 1.670D-01, 2.010D-01, 2.900D+03, 1.870D-02,
33545 & 1.804D-02, 1.320D-02, 2.970D-02, 2.860D-02, 5.160D-02,
33546 & 1.020D-01, 2.400D-01, 2.250D-01, 3.370D-01, 4.400D+03,
33547 & 1.196D-03, 8.784D-03, 1.517D-02, 2.874D-02, 2.488D-02,
33548 & 4.464D-02, 8.330D-02, 2.008D-01, 2.360D-01, 3.567D-01/
33549
33550 DATA (DCHN(I),I=1,90) /
33551 & 4.770D-01, 4.750D-01, 4.715D-01, 4.685D-01, 4.650D-01,
33552 & 4.610D-01, 4.570D-01, 4.550D-01, 4.500D-01, 4.450D-01,
33553 & 4.405D-01, 4.350D-01, 4.300D-01, 4.250D-01, 4.200D-01,
33554 & 4.130D-01, 4.060D-01, 4.000D-01, 3.915D-01, 3.840D-01,
33555 & 3.760D-01, 3.675D-01, 3.580D-01, 3.500D-01, 3.400D-01,
33556 & 3.300D-01, 3.200D-01, 3.100D-01, 3.000D-01, 2.900D-01,
33557 & 2.800D-01, 2.700D-01, 2.600D-01, 2.500D-01, 2.400D-01,
33558 & 2.315D-01, 2.240D-01, 2.150D-01, 2.060D-01, 2.000D-01,
33559 & 1.915D-01, 1.850D-01, 1.780D-01, 1.720D-01, 1.660D-01,
33560 & 1.600D-01, 1.550D-01, 1.500D-01, 1.450D-01, 1.400D-01,
33561 & 1.360D-01, 1.320D-01, 1.280D-01, 1.250D-01, 1.210D-01,
33562 & 1.180D-01, 1.150D-01, 1.120D-01, 1.100D-01, 1.070D-01,
33563 & 1.050D-01, 1.030D-01, 1.010D-01, 9.900D-02, 9.700D-02,
33564 & 9.550D-02, 9.480D-02, 9.400D-02, 9.200D-02, 9.150D-02,
33565 & 9.100D-02, 9.000D-02, 8.990D-02, 8.900D-02, 8.850D-02,
33566 & 8.750D-02, 8.700D-02, 8.650D-02, 8.550D-02, 8.500D-02,
33567 & 8.499D-02, 8.450D-02, 8.350D-02, 8.300D-02, 8.250D-02,
33568 & 8.150D-02, 8.100D-02, 8.030D-02, 8.000D-02, 7.990D-02/
33569 DATA (DCHN(I),I=91,143) /
33570 & 7.980D-02, 7.950D-02, 7.900D-02, 7.860D-02, 7.800D-02,
33571 & 7.750D-02, 7.650D-02, 7.620D-02, 7.600D-02, 7.550D-02,
33572 & 7.530D-02, 7.500D-02, 7.499D-02, 7.498D-02, 7.480D-02,
33573 & 7.450D-02, 7.400D-02, 7.350D-02, 7.300D-02, 7.250D-02,
33574 & 7.230D-02, 7.200D-02, 7.100D-02, 7.050D-02, 7.020D-02,
33575 & 7.000D-02, 6.999D-02, 6.995D-02, 6.993D-02, 6.991D-02,
33576 & 6.990D-02, 6.870D-02, 6.850D-02, 6.800D-02, 6.780D-02,
33577 & 6.750D-02, 6.700D-02, 6.650D-02, 6.630D-02, 6.600D-02,
33578 & 6.550D-02, 6.525D-02, 6.510D-02, 6.500D-02, 6.499D-02,
33579 & 6.498D-02, 6.496D-02, 6.494D-02, 6.493D-02, 6.490D-02,
33580 & 6.488D-02, 6.485D-02, 6.480D-02/
33581
33582 DATA DCHNA /
33583 & 6.300D+02, 7.810D-02, 1.421D-01, 1.979D-01, 2.479D-01,
33584 & 3.360D-01, 5.400D-01, 7.236D-01, 1.000D+00, 1.540D+03,
33585 & 2.225D-01, 3.950D-01, 5.279D-01, 6.298D-01, 7.718D-01,
33586 & 9.405D-01, 9.835D-01, 1.000D+00, 2.560D+03, 2.625D-01,
33587 & 4.550D-01, 5.963D-01, 7.020D-01, 8.380D-01, 9.603D-01,
33588 & 9.903D-01, 1.000D+00, 3.520D+03, 4.250D-01, 6.875D-01,
33589 & 8.363D-01, 9.163D-01, 9.828D-01, 1.000D+00, 1.000D+00,
33590 & 1.000D+00/
33591
33592 DATA DCHNB /
33593 & 6.300D+02, 3.800D-02, 7.164D-02, 1.275D-01, 2.171D-01,
33594 & 3.227D-01, 4.091D-01, 5.051D-01, 6.061D-01, 7.074D-01,
33595 & 8.434D-01, 1.000D+00, 2.040D+03, 1.200D-01, 2.115D-01,
33596 & 3.395D-01, 5.295D-01, 7.251D-01, 8.511D-01, 9.487D-01,
33597 & 9.987D-01, 1.000D+00, 1.000D+00, 1.000D+00, 2.200D+03,
33598 & 1.344D-01, 2.324D-01, 3.754D-01, 5.674D-01, 7.624D-01,
33599 & 8.896D-01, 9.808D-01, 1.000D+00, 1.000D+00, 1.000D+00,
33600 & 1.000D+00, 2.850D+03, 2.330D-01, 4.130D-01, 6.610D-01,
33601 & 9.010D-01, 9.970D-01, 1.000D+00, 1.000D+00, 1.000D+00,
33602 & 1.000D+00, 1.000D+00, 1.000D+00, 3.500D+03, 3.300D-01,
33603 & 5.450D-01, 7.950D-01, 1.000D+00, 1.000D+00, 1.000D+00,
33604 & 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00/
33605
33606 CST = ONE
33607 IF (EKIN.GT.3.5D0) RETURN
33608C
33609 IF(KPROJ.EQ.8) GOTO 101
33610 IF(KPROJ.EQ.1) GOTO 102
33611C* INVALID REACTION
33612 WRITE(LOUT,'(A,I5/A)')
33613 & ' INVALID PARTICLE TYPE IN DNUPRE - KPROJ=',KPROJ,
33614 & ' COS(THETA) = 1D0 RETURNED'
33615 RETURN
33616C-------------------------------- NP ELASTIC SCATTERING----------
33617101 CONTINUE
33618 IF (EKIN.GT.0.740D0)GOTO 1000
33619 IF (EKIN.LT.0.300D0)THEN
33620C EKIN .LT. 300 MEV
33621 IDAT=1
33622 ELSE
33623C 300 MEV < EKIN < 740 MEV
33624 IDAT=6
33625 END IF
33626C
33627 ENER=EKIN
33628 IE=INT(ABS(ENER/0.020D0))
33629 UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
33630C FORWARD/BACKWARD DECISION
33631 K=IDAT+5*IE
33632 BWFW=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
33633 IF (DT_RNDM(CST).LT.BWFW)THEN
33634 VALUE2=-1D0
33635 K=K+1
33636 ELSE
33637 VALUE2=1D0
33638 K=K+3
33639 END IF
33640C
33641 COEF=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
33642 RND=DT_RNDM(COEF)
33643C
33644 IF(RND.LT.COEF)THEN
33645 CST=DT_RNDM(RND)
33646 CST=CST*VALUE2
33647 ELSE
33648 R1=DT_RNDM(CST)
33649 R2=DT_RNDM(R1)
33650 R3=DT_RNDM(R2)
33651 R4=DT_RNDM(R3)
33652C
33653 IF(VALUE2.GT.0.0)THEN
33654 CST=MAX(R1,R2,R3,R4)
33655 GOTO 1500
33656 ELSE
33657 R5=DT_RNDM(R4)
33658C
33659 IF (IDAT.EQ.1)THEN
33660 CST=-MAX(R1,R2,R3,R4,R5)
33661 ELSE
33662 R6=DT_RNDM(R5)
33663 R7=DT_RNDM(R6)
33664 CST=-MAX(R1,R2,R3,R4,R5,R6,R7)
33665 END IF
33666C
33667 END IF
33668C
33669 END IF
33670C
33671 GOTO 1500
33672C
33673C******** EKIN .GT. 0.74 GEV
33674C
336751000 ENER=EKIN - 0.66D0
33676C IE=ABS(ENER/0.02)
33677 IE=INT(ENER/0.02D0)
33678 EMEV=EKIN*1D3
33679C
33680 UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
33681 K=IE
33682 BWFW=(DCHN(K+1)-DCHN(K))*UNIV + DCHN(K)
33683 RND=DT_RNDM(BWFW)
33684C FORWARD NEUTRON
33685 IF (RND.GE.BWFW)THEN
33686 DO 1200 K=10,36,9
33687 IF (DCHNA(K).GT.EMEV) THEN
33688 UNIVE=(EMEV-DCHNA(K-9))/(DCHNA(K)-DCHNA(K-9))
33689 UNIV=DT_RNDM(UNIVE)
33690 DO 1100 I=1,8
33691 II=K+I
33692 P=(DCHNA(II)-DCHNA(II-9))*UNIVE + DCHNA(II-9)
33693C
33694 IF (P.GT.UNIV)THEN
33695 UNIV=DT_RNDM(UNIVE)
33696 FLTI=DBLE(I)-UNIV
33697 GOTO(290,290,290,290,330,340,350,360) I
33698 END IF
33699 1100 CONTINUE
33700 END IF
33701 1200 CONTINUE
33702C
33703 ELSE
33704C BACKWARD NEUTRON
33705 DO 1400 K=13,60,12
33706 IF (DCHNB(K).GT.EMEV) THEN
33707 UNIVE=(EMEV-DCHNB(K-12))/(DCHNB(K)-DCHNB(K-12))
33708 UNIV=DT_RNDM(UNIVE)
33709 DO 1300 I=1,11
33710 II=K+I
33711 P=(DCHNB(II)-DCHNB(II-12))*UNIVE + DCHNB(II-12)
33712C
33713 IF (P.GT.UNIV)THEN
33714 UNIV=DT_RNDM(P)
33715 FLTI=DBLE(I)-UNIV
33716 GOTO(120,120,140,150,160,160,180,190,200,210,220) I
33717 END IF
33718 1300 CONTINUE
33719 END IF
33720 1400 CONTINUE
33721 END IF
33722C
33723120 CST=1.0D-2*FLTI-1.0D0
33724 GOTO 1500
33725140 CST=2.0D-2*UNIV-0.98D0
33726 GOTO 1500
33727150 CST=4.0D-2*UNIV-0.96D0
33728 GOTO 1500
33729160 CST=6.0D-2*FLTI-1.16D0
33730 GOTO 1500
33731180 CST=8.0D-2*UNIV-0.80D0
33732 GOTO 1500
33733190 CST=1.0D-1*UNIV-0.72D0
33734 GOTO 1500
33735200 CST=1.2D-1*UNIV-0.62D0
33736 GOTO 1500
33737210 CST=2.0D-1*UNIV-0.50D0
33738 GOTO 1500
33739220 CST=3.0D-1*(UNIV-1.0D0)
33740 GOTO 1500
33741C
33742290 CST=1.0D0-2.5d-2*FLTI
33743 GOTO 1500
33744330 CST=0.85D0+0.5D-1*UNIV
33745 GOTO 1500
33746340 CST=0.70D0+1.5D-1*UNIV
33747 GOTO 1500
33748350 CST=0.50D0+2.0D-1*UNIV
33749 GOTO 1500
33750360 CST=0.50D0*UNIV
33751C
337521500 RETURN
33753C
33754C----------------------------------- PP ELASTIC SCATTERING -------
33755C
33756 102 CONTINUE
33757 EMEV=EKIN*1D3
33758C
33759 IF (EKIN.LE.0.500D0) THEN
33760 RND=DT_RNDM(EMEV)
33761 CST=2.0D0*RND-1.0D0
33762 RETURN
33763C
33764 ELSEIF (EKIN.LT.1.0D0) THEN
33765 DO 2200 K=13,60,12
33766 IF (PDCI(K).GT.EMEV) THEN
33767 UNIVE=(EMEV-PDCI(K-12))/(PDCI(K)-PDCI(K-12))
33768 UNIV=DT_RNDM(UNIVE)
33769 SUM=0
33770 DO 2100 I=1,11
33771 II=K+I
33772 SUM=SUM + (PDCI(II)-PDCI(II-12))*UNIVE + PDCI(II-12)
33773C
33774 IF (UNIV.LT.SUM)THEN
33775 UNIV=DT_RNDM(SUM)
33776 FLTI=DBLE(I)-UNIV
33777 GOTO(55,55,55,60,60,65,65,65,65,70,70) I
33778 END IF
33779 2100 CONTINUE
33780 END IF
33781 2200 CONTINUE
33782 ELSE
33783 DO 2400 K=12,55,11
33784 IF (PDCH(K).GT.EMEV) THEN
33785 UNIVE=(EMEV-PDCH(K-11))/(PDCH(K)-PDCH(K-11))
33786 UNIV=DT_RNDM(UNIVE)
33787 SUM=0.0D0
33788 DO 2300 I=1,10
33789 II=K+I
33790 SUM=SUM + (PDCH(II)-PDCH(II-11))*UNIVE + PDCH(II-11)
33791C
33792 IF (UNIV.LT.SUM)THEN
33793 UNIV=DT_RNDM(SUM)
33794 FLTI=UNIV+DBLE(I)
33795 GOTO(50,55,60,60,65,65,65,65,70,70) I
33796 END IF
33797 2300 CONTINUE
33798 END IF
33799 2400 CONTINUE
33800 END IF
33801C
3380250 CST=0.4D0*UNIV
33803 GOTO 2500
3380455 CST=0.2D0*FLTI
33805 GOTO 2500
3380660 CST=0.3D0+0.1D0*FLTI
33807 GOTO 2500
3380865 CST=0.6D0+0.04D0*FLTI
33809 GOTO 2500
3381070 CST=0.78D0+0.02D0*FLTI
33811C
338122500 CONTINUE
33813 IF (DT_RNDM(CST).GT.0.5D0) CST=-CST
33814C
33815 RETURN
33816 END
33817
33818*$ CREATE DT_DHADRI.FOR
33819*COPY DT_DHADRI
33820*
33821*===dhadri=============================================================*
33822*
33823 SUBROUTINE DT_DHADRI(N,PLAB,ELAB,CX,CY,CZ,ITTA)
33824
33825 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33826 SAVE
33827
33828 PARAMETER ( LINP = 10 ,
33829 & LOUT = 6 ,
33830 & LDAT = 9 )
33831C
33832C-----------------------------
33833C*** INPUT VARIABLES LIST:
33834C*** SAMPLING OF HADRON NUCLEON INTERACTION FOR (ABOUT) 0.1 LE PLAB LE 6
33835C*** GEV/C LABORATORY MOMENTUM REGION
33836C*** N - PROJECTILE HADRON INDEX
33837C*** PLAB - LABORATORY MOMENTUM OF N (GEV/C)
33838C*** ELAB - LABORATORY ENERGY OF N (GEV)
33839C*** CX,CY,CZ - DIRECTION COSINES OF N IN THE LABORATORY SYSTEM
33840C*** ITTA - TARGET NUCLEON INDEX
33841C*** OUTPUT VARIABLES LIST OF PARTICLE CHARACTERISTICS IN /FINLSP/
33842C IR COUNTS THE NUMBER OF PRODUCED PARTICLES
33843C*** ITR - PARTICLE INDEX, CXR,CYR,CZR - DIRECTION COSINES (LAB. SYST.)
33844C*** ELR,PLR LAB. ENERGY AND LAB. MOMENTUM OF THE SAMPLED PARTICLE
33845C*** RESPECT., UNITS (GEV/C AND GEV)
33846C----------------------------
33847
33848 COMMON /HNGAMR/ REDU,AMO,AMM(15)
33849 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33850 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33851 & NRK(2,268),NURE(30,2)
33852* particle properties (BAMJET index convention),
33853* (dublicate of DTPART for HADRIN)
33854 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33855 & K1H(110),K2H(110)
33856 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
33857 COMMON /HNMETL/ CXS(149),CYS(149),CZS(149),ELS(149),PLS(149),
33858 & ITS(149),IS
33859 COMMON /HNDRUN/ RUNTES,EFTES
33860* particle properties (BAMJET index convention)
33861 CHARACTER*8 ANAME
33862 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
33863 & IICH(210),IIBAR(210),K1(210),K2(210)
33864* final state from HADRIN interaction
33865 PARAMETER (MAXFIN=10)
33866 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
33867 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
33868
33869 DIMENSION ITPRF(110)
33870 DATA NNN/0/
33871 DATA UMODA/0./
33872 DATA ITPRF/-1,-1,5*1,-1,-1,1,1,1,-1,-1,-1,-1,6*1,-1,-1,-1,85*1/
33873 LOWP=0
33874 IF (N.LE.0.OR.N.GE.111)N=1
33875 IF (ITPRF( N ).GT.0 .OR. ITTA.GT.8) THEN
33876 GOTO 280
33877* WRITE (6,1000)
33878* + ' FALSE USE OF THE PARTICLE TYPE INDEX: N, ITTA', N, ITTA
33879* STOP
33880*1000 FORMAT (3(5H ****/),A,2I4,3(5H ****/))
33881* + 45H FALSE USE OF THE PARTICLE TYPE INDEX, N,LUE ,I4,3(5H ****/))
33882 ENDIF
33883 IATMPT=0
33884 IF (ABS(PLAB-5.0D0).LT.4.99999D0) GO TO 20
33885C IF(IPRI.GE.1) WRITE (6,1010) PLAB
33886C STOP
33887 1010 FORMAT ( ' PROJECTILE HADRON MOMENTUM OUTSIDE OF THE
33888 + ALLOWED REGION, PLAB=',1E15.5)
33889
33890 20 CONTINUE
33891 UMODAT=N*1.11111D0+ITTA*2.19291D0
33892 IF(UMODAT.NE.UMODA) CALL DT_DCALUM(N,ITTA)
33893 UMODA=UMODAT
33894 30 IATMPT=0
33895 LOWP=LOWP+1
33896 40 CONTINUE
33897 IMACH=0
33898 REDU=2.0D0
33899 IF (LOWP.GT.20) THEN
33900C WRITE(LOUT,*) ' jump 1'
33901 GO TO 280
33902 ENDIF
33903 NNN=N
33904 IF (NNN.EQ.N) GO TO 50
33905 RUNTES=0.0D0
33906 EFTES=0.0D0
33907 50 CONTINUE
33908 IS=1
33909 IRH=0
33910 IST=1
33911 NSTAB=23
33912 IRE=NURE(N,1)
33913 IF(ITTA.GT.1) IRE=NURE(N,2)
33914C
33915C-----------------------------
33916C*** IE,AMT,ECM,SI DETERMINATION
33917C----------------------------
33918 CALL DT_DSIGIN(IRE,PLAB,N,IE,AMT ,AMN,ECM,SI,ITTA)
33919 IANTH=-1
33920**sr
33921C IF (AMH(1).NE.0.93828D0) IANTH=1
33922 IF (AMH(1).NE.0.9383D0) IANTH=1
33923**
33924 IF (IANTH.GE.0) SI=1.0D0
33925 ECMMH=ECM
33926C
33927C-----------------------------
33928C ENERGY INDEX
33929C IRE CHARACTERIZES THE REACTION
33930C IE IS THE ENERGY INDEX
33931C----------------------------
33932 IF (SI.LT.1.D-6) THEN
33933C WRITE(LOUT,*) ' jump 2'
33934 GO TO 280
33935 ENDIF
33936 IF (N.LE.NSTAB) GO TO 60
33937 RUNTES=RUNTES+1.0D0
33938 IF (RUNTES.LT.20.D0) WRITE(LOUT,1020)N
33939 1020 FORMAT(3H N=,I10,30H THE PROEKTILE IS A RESONANCE )
33940 IF(IBARH(N).EQ.1) N=8
33941 IF(IBARH(N).EQ.-1) N=9
33942 60 CONTINUE
33943 IMACH=IMACH+1
33944**sr 19.2.97: loop for direct channel suppression
33945C IF (IMACH.GT.10) THEN
33946 IF (IMACH.GT.1000) THEN
33947**
33948C WRITE(LOUT,*) ' jump 3'
33949 GO TO 280
33950 ENDIF
33951 ECM =ECMMH
33952 AMN2=AMN**2
33953 AMT2=AMT**2
33954 ECMN=(ECM**2+AMN2-AMT2)/(2.0D0*ECM )
33955 IF(ECMN.LE.AMN) ECMN=AMN
33956 PCMN=SQRT(ECMN**2-AMN2)
33957 GAM=(ELAB+AMT)/ECM
33958 BGAM=PLAB/ECM
33959 IF (IANTH.GE.0) ECM=2.1D0
33960C
33961C-----------------------------
33962C*** RANDOM CHOICE OF REACTION CHANNEL
33963C----------------------------
33964 IST=0
33965 VV=DT_RNDM(AMN2)
33966 VV=VV-1.D-17
33967C
33968C-----------------------------
33969C*** PLACE REDUCED VERSION
33970C----------------------------
33971 IIEI=IEII(IRE)
33972 IDWK=IEII(IRE+1)-IIEI
33973 IIWK=IRII(IRE)
33974 IIKI=IKII(IRE)
33975C
33976C-----------------------------
33977C*** SHRINKAGE TO THE CONSIDERED ENERGY REGION FOR THE USE OF WEIGHTS
33978C----------------------------
33979 HECM=ECM
33980 HUMO=2.0D0*UMO(IIEI+IDWK)-UMO(IIEI+IDWK-1)
33981 IF (HUMO.LT.ECM) ECM=HUMO
33982C
33983C-----------------------------
33984C*** INTERPOLATION PREPARATION
33985C----------------------------
33986 ECMO=UMO(IE)
33987 ECM1=UMO(IE-1)
33988 DECM=ECMO-ECM1
33989 DEC=ECMO-ECM
33990C
33991C-----------------------------
33992C*** RANDOM LOOP
33993C----------------------------
33994 IK=0
33995 WKK=0.0D0
33996 WICOR=0.0D0
33997 70 IK=IK+1
33998 IWK=IIWK+(IK-1)*IDWK+IE-IIEI
33999 WOK=WK(IWK)
34000 WDK=WOK-WK(IWK-1)
34001C
34002C-----------------------------
34003C*** TESTVARIABLE WICO/WICOR: IF CHANNEL IK HAS THE SAME WEIGHTS LIKE IK
34004C GO TO NEXT CHANNEL, BECAUSE WKK((IK))-WKK((IK-1))=0, IK CAN NOT
34005C CONTRIBUTE
34006C----------------------------
34007 IF (PLAB.LT.PLABF(IIEI+2)) WDK=0.0D0
34008 WICO=WOK*1.23459876D0+WDK*1.735218469D0
34009 IF (WICO.EQ.WICOR) GO TO 70
34010 IF (UMO(IIEI+IDWK).LT.HECM) WDK=0.0D0
34011 WICOR=WICO
34012C
34013C-----------------------------
34014C*** INTERPOLATION IN CHANNEL WEIGHTS
34015C----------------------------
34016 EKLIM=-THRESH(IIKI+IK)
34017 IELIM=IDT_IEFUND(EKLIM,IRE)
34018 DELIM=UMO(IELIM)+EKLIM
34019 *+1.D-16
34020 DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
34021 IF (DELIM*DELIM-DETE*DETE) 90,90,80
34022 80 DECC=DELIM
34023 GO TO 100
34024 90 DECC=DECM
34025 100 CONTINUE
34026 WKK=WOK-WDK*DEC/(DECC+1.D-9)
34027C
34028C-----------------------------
34029C*** RANDOM CHOICE
34030C----------------------------
34031C
34032 IF (VV.GT.WKK) GO TO 70
34033C
34034C***IK IS THE REACTION CHANNEL
34035C----------------------------
34036 INRK=IKII(IRE)+IK
34037 ECM=HECM
34038 I1001 =0
34039C
34040 110 CONTINUE
34041 IT1=NRK(1,INRK)
34042 AM1=DT_DAMG(IT1)
34043 IT2=NRK(2,INRK)
34044 AM2=DT_DAMG(IT2)
34045 AMS=AM1+AM2
34046 I1001=I1001+1
34047 IF (I1001.GT.50) GO TO 60
34048C
34049 IF (IT2*AMS.GT.IT2*ECM) GO TO 110
34050 IT11=IT1
34051 IT22=IT2
34052 IF (IANTH.GE.0) ECM=ELAB+AMT+0.00001D0
34053 AM11=AM1
34054 AM22=AM2
34055 IF (IT2.GT.0) GO TO 120
34056**sr 19.2.97: supress direct channel for pp-collisions
34057 IF ((N.EQ.1).AND.(ITTA.EQ.1).AND.(IT2.LE.0)) THEN
34058 RR = DT_RNDM(AM11)
34059 IF (RR.LE.0.75D0) GOTO 60
34060 ENDIF
34061**
34062C
34063C-----------------------------
34064C INCLUSION OF DIRECT RESONANCES
34065C RANDOM CHOICE OF DECAY CHANNELS OF THE DIRECT RESONANCE IT1
34066C------------------------
34067 KZ1=K1H(IT1)
34068 IST=IST+1
34069 IECO=0
34070 ECO=ECM
34071 GAM=(ELAB+AMT)/ECO
34072 BGAM=PLAB/ECO
34073 CXS(1)=CX
34074 CYS(1)=CY
34075 CZS(1)=CZ
34076 GO TO 170
34077 120 CONTINUE
34078 WW=DT_RNDM(ECO)
34079 IF(WW.LT. 0.5D0) GO TO 130
34080 IT1=IT22
34081 IT2=IT11
34082 AM1=AM22
34083 AM2=AM11
34084 130 CONTINUE
34085C
34086C-----------------------------
34087C THE FIRST PARTICLE IS DEFINED TO BE THE FORWARD GOING ONE AT SMALL T
34088 IBN=IBARH(N)
34089 IB1=IBARH(IT1)
34090 IT11=IT1
34091 IT22=IT2
34092 AM11=AM1
34093 AM22=AM2
34094 IF(IB1.EQ.IBN) GO TO 140
34095 IT1=IT22
34096 IT2=IT11
34097 AM1=AM22
34098 AM2=AM11
34099 140 CONTINUE
34100C-----------------------------
34101C***IT1,IT2 ARE THE CREATED PARTICLES
34102C***MOMENTA AND DIRECTION COSINA IN THE CM - SYSTEM
34103C------------------------
34104 CALL DT_DTWOPA(ECM1,ECM2,PCM1,PCM2,COD1,COD2,COF1,COF2,SIF1,SIF2,
34105 *IT1,IT2,ECM,ECMN,PCMN,N,AM1,AM2)
34106 IST=IST+1
34107 ITS(IST)=IT1
34108 AMM(IST)=AM1
34109C
34110C-----------------------------
34111C***TRANSFORMATION INTO LAB SYSTEM AND ROTATION
34112C----------------------------
34113 CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD1,COF1,SIF1,
34114 &PCM1,ECM1,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34115 IST=IST+1
34116 ITS(IST)=IT2
34117 AMM(IST)=AM2
34118 CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD2,COF2,SIF2,
34119 *PCM2,ECM2,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34120 150 CONTINUE
34121C
34122C-----------------------------
34123C***TEST STABLE OR UNSTABLE
34124C----------------------------
34125 IF(ITS(IST).GT.NSTAB) GO TO 160
34126 IRH=IRH+1
34127C
34128C-----------------------------
34129C***IRH IS THE NUMBER OF THE FINAL STABLE PARTICLE
34130C----------------------------
34131C* IF (REDU.LT.0.D0) GO TO 1009
34132 ITRH(IRH)=ITS(IST)
34133 PLRH(IRH)=PLS(IST)
34134 CXRH(IRH)=CXS(IST)
34135 CYRH(IRH)=CYS(IST)
34136 CZRH(IRH)=CZS(IST)
34137 ELRH(IRH)=ELS(IST)
34138 IST=IST-1
34139 IF(IST.GE.1) GO TO 150
34140 GO TO 260
34141 160 CONTINUE
34142C
34143C RANDOM CHOICE OF DECAY CHANNELS
34144C----------------------------
34145C
34146 IT=ITS(IST)
34147 ECO=AMM(IST)
34148 GAM=ELS(IST)/ECO
34149 BGAM=PLS(IST)/ECO
34150 IECO=0
34151 KZ1=K1H(IT)
34152 170 CONTINUE
34153 IECO=IECO+1
34154 VV=DT_RNDM(GAM)
34155 VV=VV-1.D-17
34156 IIK=KZ1-1
34157 180 IIK=IIK+1
34158 IF (VV.GT.WTI(IIK)) GO TO 180
34159C
34160C IIK IS THE DECAY CHANNEL
34161C----------------------------
34162 IT1=NZKI(IIK,1)
34163 I310=0
34164 190 CONTINUE
34165 I310=I310+1
34166 AM1=DT_DAMG(IT1)
34167 IT2=NZKI(IIK,2)
34168 AM2=DT_DAMG(IT2)
34169 IF (IT2-1.LT.0) GO TO 240
34170 IT3=NZKI(IIK,3)
34171 AM3=DT_DAMG(IT3)
34172 AMS=AM1+AM2+AM3
34173C
34174C IF IIK-KIN.LIM.GT.ACTUAL TOTAL CM-ENERGY, DO AGAIN RANDOM IIK-CHOICE
34175C----------------------------
34176 IF (IECO.LE.10) GO TO 200
34177 IATMPT=IATMPT+1
34178 IF(IATMPT.GT.3) THEN
34179C WRITE(LOUT,*) ' jump 4'
34180 GO TO 280
34181 ENDIF
34182 GO TO 40
34183 200 CONTINUE
34184 IF (I310.GT.50) GO TO 170
34185 IF (AMS.GT.ECO) GO TO 190
34186C
34187C FOR THE DECAY CHANNEL
34188C IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM IT
34189C----------------------------
34190 IF (REDU.LT.0.D0) GO TO 30
34191 ITWTHC=0
34192 REDU=2.0D0
34193 IF(IT3.EQ.0) GO TO 220
34194 210 CONTINUE
34195 ITWTH=1
34196 CALL DT_DTHREP(ECO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,SIF1,
34197 *COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
34198 GO TO 230
34199 220 CALL DT_DTWOPD(ECO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,
34200 &COD2,COF2,SIF2,AM1,AM2)
34201 ITWTH=-1
34202 IT3=0
34203 230 CONTINUE
34204 ITWTHC=ITWTHC+1
34205 IF (REDU.GT.0.D0) GO TO 240
34206 REDU=2.0D0
34207 IF (ITWTHC.GT.100) GO TO 30
34208 IF (ITWTH) 220,220,210
34209 240 CONTINUE
34210 ITS(IST )=IT1
34211 IF (IT2-1.LT.0) GO TO 250
34212 ITS(IST+1) =IT2
34213 ITS(IST+2)=IT3
34214 RX=CXS(IST)
34215 RY=CYS(IST)
34216 RZ=CZS(IST)
34217 AMM(IST)=AM1
34218 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD1,COF1,SIF1,PCM1,ECM1,
34219 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34220 IST=IST+1
34221 AMM(IST)=AM2
34222 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD2,COF2,SIF2,PCM2,ECM2,
34223 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34224 IF (IT3.LE.0) GO TO 250
34225 IST=IST+1
34226 AMM(IST)=AM3
34227 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD3,COF3,SIF3,PCM3,ECM3,
34228 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34229 250 CONTINUE
34230 GO TO 150
34231 260 CONTINUE
34232 270 CONTINUE
34233 RETURN
34234 280 CONTINUE
34235C
34236C----------------------------
34237C
34238C ZERO CROSS SECTION CASE
34239C----------------------------
34240C
34241 IRH=1
34242 ITRH(1)=N
34243 CXRH(1)=CX
34244 CYRH(1)=CY
34245 CZRH(1)=CZ
34246 ELRH(1)=ELAB
34247 PLRH(1)=PLAB
34248 RETURN
34249 END
34250
34251*$ CREATE DT_RUNTT.FOR
34252*COPY DT_RUNTT
34253*
34254*===runtt==============================================================*
34255*
34256 BLOCK DATA DT_RUNTT
34257
34258 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34259 SAVE
34260
34261 COMMON /HNDRUN/ RUNTES,EFTES
34262
34263 DATA RUNTES,EFTES /100.D0,100.D0/
34264
34265 END
34266
34267*$ CREATE DT_NONAME.FOR
34268*COPY DT_NONAME
34269*
34270*===noname=============================================================*
34271*
34272 BLOCK DATA DT_NONAME
34273
34274 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34275 SAVE
34276
34277* slope parameters for HADRIN interactions
34278 COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
34279 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34280
34281C DATAS DATAS DATAS DATAS DATAS
34282C****** *********
34283 DATA IKII/ 0, 15, 41, 67, 82, 93, 110, 133, 148, 159, 172, 183,
34284 & 207, 224, 241, 252, 268 /
34285 DATA IEII/ 0, 21, 46, 71, 92, 109, 126, 143, 160, 173, 186, 199,
34286 & 220, 241, 262, 279, 296 /
34287 DATA IRII/ 0, 315, 965, 1615, 1930, 2117, 2406, 2797, 3052, 3195,
34288 & 3364, 3507, 4011, 4368, 4725, 4912, 5184/
34289
34290C
34291C MASSES FOR THE SLOPE B(M) IN GEV
34292C SLOPE B(M) FOR AN MESONIC SYSTEM
34293C SLOPE B(M) FOR A BARYONIC SYSTEM
34294
34295*
34296 DATA SM,BBM,BBB/ 0.8D0, 0.85D0, 0.9D0, 0.95D0, 1.D0,
34297 & 1.05D0, 1.1D0, 1.15D0, 1.2D0, 1.25D0,
34298 & 1.3D0, 1.35D0, 1.4D0, 1.45D0, 1.5D0,
34299 & 1.55D0, 1.6D0, 1.65D0, 1.7D0, 1.75D0,
34300 & 1.8D0, 1.85D0, 1.9D0, 1.95D0, 2.D0,
34301 & 15.6D0, 14.95D0, 14.3D0, 13.65D0, 13.D0,
34302 & 12.35D0, 11.7D0, 10.85D0, 10.D0, 9.15D0,
34303 & 8.3D0, 7.8D0, 7.3D0, 7.25D0, 7.2D0,
34304 & 6.95D0, 6.7D0, 6.6D0, 6.5D0, 6.3D0,
34305 & 6.1D0, 5.85D0, 5.6D0, 5.35D0, 5.1D0,
34306 & 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0,
34307 & 14.2D0, 13.4D0, 12.6D0,
34308 & 11.8D0, 11.2D0, 10.6D0, 9.8D0, 9.D0,
34309 & 8.25D0, 7.5D0, 6.25D0, 5.D0, 4.5D0, 5*4.D0 /
34310*
34311 END
34312
34313*$ CREATE DT_DAMG.FOR
34314*COPY DT_DAMG
34315*
34316*===damg===============================================================*
34317*
34318 DOUBLE PRECISION FUNCTION DT_DAMG(IT)
34319
34320 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34321 SAVE
34322
34323* particle properties (BAMJET index convention),
34324* (dublicate of DTPART for HADRIN)
34325 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34326 & K1H(110),K2H(110)
34327
34328 DIMENSION GASUNI(14)
34329 DATA GASUNI/
34330 *-1.D0,-.98D0,-.95D0,-.87D0,-.72D0,-.48D0,
34331 *-.17D0,.17D0,.48D0,.72D0,.87D0,.95D0,.98D0,1.D0/
34332 DATA GAUNO/2.352D0/
34333 DATA GAUNON/2.4D0/
34334 DATA IO/14/
34335 DATA NSTAB/23/
34336
34337 I=1
34338 IF (IT.LE.0) GO TO 30
34339 IF (IT.LE.NSTAB) GO TO 20
34340 DGAUNI=GAUNO*GAUNON/DBLE(IO-1)
34341 VV=DT_RNDM(DGAUNI)
34342 VV=VV*2.0D0-1.0D0+1.D-16
34343 10 CONTINUE
34344 VO=GASUNI(I)
34345 I=I+1
34346 V1=GASUNI(I)
34347 IF (VV.GT.V1) GO TO 10
34348 UNIGA=DGAUNI*(DBLE(I)-2.0D0+(VV-VO+1.D-16)/
34349 & (V1-VO)-(DBLE(IO)-1.0D0)*0.5D0)
34350 DAM=GAH(IT)*UNIGA/GAUNO
34351 AAM=AMH(IT)+DAM
34352 DT_DAMG=AAM
34353 RETURN
34354 20 CONTINUE
34355 DT_DAMG=AMH(IT)
34356 RETURN
34357 30 CONTINUE
34358 DT_DAMG=0.0D0
34359 RETURN
34360 END
34361
34362*$ CREATE DT_DCALUM.FOR
34363*COPY DT_DCALUM
34364*
34365*===dcalum=============================================================*
34366*
34367 SUBROUTINE DT_DCALUM(N,ITTA)
34368
34369 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34370 SAVE
34371
34372C*** C.M.S.-ENERGY AND REACTION CHANNEL THRESHOLD CALCULATION
34373
34374* particle properties (BAMJET index convention),
34375* (dublicate of DTPART for HADRIN)
34376 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34377 & K1H(110),K2H(110)
34378 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34379 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
34380 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34381 & NRK(2,268),NURE(30,2)
34382
34383 IRE=NURE(N,ITTA/8+1)
34384 IEO=IEII(IRE)+1
34385 IEE=IEII(IRE +1)
34386 AM1=AMH(N )
34387 AM12=AM1**2
34388 AM2=AMH(ITTA)
34389 AM22=AM2**2
34390 DO 10 IE=IEO,IEE
34391 PLAB2=PLABF(IE)**2
34392 ELAB=SQRT(AM12+AM22+2.0D0*SQRT(PLAB2+AM12)*AM2)
34393 UMO(IE)=ELAB
34394 10 CONTINUE
34395 IKO=IKII(IRE)+1
34396 IKE=IKII(IRE +1)
34397 UMOO=UMO(IEO)
34398 DO 30 IK=IKO,IKE
34399 IF(NRK(2,IK).GT.0) GO TO 30
34400 IKI=NRK(1,IK)
34401 AMSS=5.0D0
34402 K11=K1H(IKI)
34403 K22=K2H(IKI)
34404 DO 20 IK1=K11,K22
34405 IN=NZKI(IK1,1)
34406 AMS=AMH(IN)
34407 IN=NZKI(IK1,2)
34408 IF(IN.GT.0)AMS=AMS+AMH(IN)
34409 IN=NZKI(IK1,3)
34410 IF(IN.GT.0) AMS=AMS+AMH(IN)
34411 IF (AMS.LT.AMSS) AMSS=AMS
34412 20 CONTINUE
34413 IF(UMOO.LT.AMSS) UMOO=AMSS
34414 THRESH(IK)=UMOO
34415 30 CONTINUE
34416 RETURN
34417 END
34418
34419*$ CREATE DT_DCHANH.FOR
34420*COPY DT_DCHANH
34421*
34422*===dchanh=============================================================*
34423*
34424 SUBROUTINE DT_DCHANH
34425
34426 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34427 SAVE
34428
34429 PARAMETER ( LINP = 10 ,
34430 & LOUT = 6 ,
34431 & LDAT = 9 )
34432* particle properties (BAMJET index convention),
34433* (dublicate of DTPART for HADRIN)
34434 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34435 & K1H(110),K2H(110)
34436 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
34437 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34438 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34439 & NRK(2,268),NURE(30,2)
34440
34441 DIMENSION HWT(460),HWK(40),SI(5184)
34442 EQUIVALENCE (WK(1),SI(1))
34443C--------------------
34444C*** USE ONLY FOR DATAPREPARATION OF PURE HADRIN
34445C*** CALCULATION OF REACTION- AND DECAY-CHANNEL-WEIGHTS,
34446C*** THRESHOLD ENERGIES+MOMENTA OF REACTION CHNLS.
34447C*** CHANGE OF WT- AND WK-INPUTDATA INTO WEIGHTS FOR THE M.-C.-PROCEDURE
34448C*** (ADDED ONE TO EACH OTHER FOR CORRESPONDING CHANNELS)
34449C--------------------------
34450 IREG=16
34451 DO 90 IRE=1,IREG
34452 IWKO=IRII(IRE)
34453 IEE=IEII(IRE+1)-IEII(IRE)
34454 IKE=IKII(IRE+1)-IKII(IRE)
34455 IEO=IEII(IRE)+1
34456 IIKA=IKII(IRE)
34457* modifications to suppress elestic scattering 24/07/91
34458 DO 80 IE=1,IEE
34459 SIS=1.D-14
34460 SINORC=0.0D0
34461 DO 10 IK=1,IKE
34462 IWK=IWKO+IEE*(IK-1)+IE
34463 IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
34464 SIS=SIS+SI(IWK)*SINORC
34465 10 CONTINUE
34466 SIIN(IEO+IE-1)=SIS
34467 SIO=0.D0
34468 IF (SIS.GE.1.D-12) GO TO 20
34469 SIS=1.D0
34470 SIO=1.D0
34471 20 CONTINUE
34472 SINORC=0.0D0
34473 DO 30 IK=1,IKE
34474 IWK=IWKO+IEE*(IK-1)+IE
34475 IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
34476 SIO=SIO+SI(IWK)*SINORC/SIS
34477 HWK(IK)=SIO
34478 30 CONTINUE
34479 DO 40 IK=1,IKE
34480 IWK=IWKO+IEE*(IK-1)+IE
34481 40 WK(IWK)=HWK(IK)
34482 IIKI=IKII(IRE)
34483 DO 70 IK=1,IKE
34484 AM111=0.D0
34485 INRK1=NRK(1,IIKI+IK)
34486 IF (INRK1.GT.0) AM111=AMH(INRK1)
34487 AM222=0.D0
34488 INRK2=NRK(2,IIKI+IK)
34489 IF (INRK2.GT.0) AM222=AMH(INRK2)
34490 THRESH(IIKI+IK)=AM111 +AM222
34491 IF (INRK2-1.GE.0) GO TO 60
34492 INRKK=K1H(INRK1)
34493 AMSS=5.D0
34494 INRKO=K2H(INRK1)
34495 DO 50 INRK1=INRKK,INRKO
34496 INZK1=NZKI(INRK1,1)
34497 INZK2=NZKI(INRK1,2)
34498 INZK3=NZKI(INRK1,3)
34499 IF (INZK1.LE.0.OR.INZK1.GT.110) GO TO 50
34500 IF (INZK2.LE.0.OR.INZK2.GT.110) GO TO 50
34501 IF (INZK3.LE.0.OR.INZK3.GT.110) GO TO 50
34502C WRITE (6,310)INRK1,INZK1,INZK2,INZK3
34503 1000 FORMAT (4I10)
34504 AMS=AMH(INZK1)+AMH(INZK2)
34505 IF (INZK3-1.GE.0) AMS=AMS+AMH(INZK3)
34506 IF (AMSS.GT.AMS) AMSS=AMS
34507 50 CONTINUE
34508 AMS=AMSS
34509 IF (AMS.LT.UMO(IEO)) AMS=UMO(IEO)
34510 THRESH(IIKI+IK)=AMS
34511 60 CONTINUE
34512 70 CONTINUE
34513 80 CONTINUE
34514 90 CONTINUE
34515 DO 100 J=1,460
34516 100 HWT(J)=0.D0
34517 DO 120 I=1,110
34518 IK1=K1H(I)
34519 IK2=K2H(I)
34520 HV=0.D0
34521 IF (IK2.GT.460)IK2=460
34522 IF (IK1.LE.0)IK1=1
34523 DO 110 J=IK1,IK2
34524 HV=HV+WTI(J)
34525 HWT(J)=HV
34526 JI=J
34527 110 CONTINUE
34528 IF (ABS(HV-1.0D0).GT.1.D-4) WRITE(LOUT,1010)I,JI,HV
34529 1010 FORMAT (35H ERROR IN HWT, FALSE USE OF CHANWH ,2I6,F10.2)
34530 120 CONTINUE
34531 DO 130 J=1,460
34532 130 WTI(J)=HWT(J)
34533 RETURN
34534 END
34535
34536*$ CREATE DT_DHADDE.FOR
34537*COPY DT_DHADDE
34538*
34539*===dhadde=============================================================*
34540*
34541 SUBROUTINE DT_DHADDE
34542
34543 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34544 SAVE
34545
34546* particle properties (BAMJET index convention)
34547 CHARACTER*8 ANAME
34548 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
34549 & IICH(210),IIBAR(210),K1(210),K2(210)
34550* HADRIN: decay channel information
34551 PARAMETER (IDMAX9=602)
34552 CHARACTER*8 ZKNAME
34553 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
34554* particle properties (BAMJET index convention),
34555* (dublicate of DTPART for HADRIN)
34556 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34557 & K1H(110),K2H(110)
34558 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
34559* decay channel information for HADRIN
34560 COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
34561 & K1Z(16),K2Z(16),WTZ(153),II22,
34562 & NZK1(153),NZK2(153),NZK3(153)
34563
34564 DATA IRETUR/0/
34565
34566 IRETUR=IRETUR+1
34567 AMH(31)=0.48D0
34568 IF (IRETUR.GT.1) RETURN
34569 DO 10 I=1,94
34570 AMH(I) = AAM(I)
34571 GAH(I) = GA(I)
34572 TAUH(I) = TAU(I)
34573 ICHH(I) = IICH(I)
34574 IBARH(I) = IIBAR(I)
34575 K1H(I) = K1(I)
34576 K2H(I) = K2(I)
34577 10 CONTINUE
34578**sr
34579C AMH(1)=0.93828D0
34580 AMH(1)=0.9383D0
34581**
34582 AMH(2)=AMH(1)
34583 DO 20 I=26,30
34584 K1H(I)=452
34585 K2H(I)=452
34586 20 CONTINUE
34587 DO 30 I=1,307
34588 WTI(I) = WT(I)
34589 NZKI(I,1) = NZK(I,1)
34590 NZKI(I,2) = NZK(I,2)
34591 NZKI(I,3) = NZK(I,3)
34592 30 CONTINUE
34593 DO 40 I=1,16
34594 L=I+94
34595 AMH(L)=AMZ(I)
34596 GAH( L)=GAZ(I)
34597 TAUH( L)=TAUZ(I)
34598 ICHH( L)=ICHZ(I)
34599 IBARH( L)=IBARZ(I)
34600 K1H( L)=K1Z(I)
34601 K2H( L)=K2Z(I)
34602 40 CONTINUE
34603 DO 50 I=1,153
34604 L=I+307
34605 WTI(L) = WTZ(I)
34606 NZKI(L,3) = NZK3(I)
34607 NZKI(L,2) = NZK2(I)
34608 NZKI(L,1) = NZK1(I)
34609 50 CONTINUE
34610 RETURN
34611 END
34612
34613*$ CREATE IDT_IEFUND.FOR
34614*COPY IDT_IEFUND
34615*
34616*===iefund=============================================================*
34617*
34618 INTEGER FUNCTION IDT_IEFUND(PL,IRE)
34619
34620 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34621 SAVE
34622
34623C*****IEFUN CALCULATES A MOMENTUM INDEX
34624
34625 PARAMETER ( LINP = 10 ,
34626 & LOUT = 6 ,
34627 & LDAT = 9 )
34628 COMMON /HNDRUN/ RUNTES,EFTES
34629 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34630 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34631 & NRK(2,268),NURE(30,2)
34632
34633 IPLA=IEII(IRE)+1
34634 *+1
34635 IPLE=IEII(IRE+1)
34636 IF (PL.LT.0.) GO TO 30
34637 DO 10 I=IPLA,IPLE
34638 J=I-IPLA+1
34639 IF (PL.LE.PLABF(I)) GO TO 60
34640 10 CONTINUE
34641 I=IPLE
34642 IF ( EFTES.GT.40.D0) GO TO 20
34643 EFTES=EFTES+1.0D0
34644 WRITE(LOUT,1000)PL,J
34645 20 CONTINUE
34646 GO TO 70
34647 30 CONTINUE
34648 DO 40 I=IPLA,IPLE
34649 J=I-IPLA+1
34650 IF (-PL.LE.UMO(I)) GO TO 60
34651 40 CONTINUE
34652 I=IPLE
34653 IF ( EFTES.GT.40.D0) GO TO 50
34654 EFTES=EFTES+1.0D0
34655 WRITE(LOUT,1000)PL,I
34656 50 CONTINUE
34657 60 CONTINUE
34658 70 CONTINUE
34659 IDT_IEFUND=I
34660 RETURN
34661 1000 FORMAT(14H PLAB OR -ECM=,E12.4,27H IS OUT OF CONSIDERED RANGE ,
34662 +7H IEFUN=,I5)
34663 END
34664
34665*$ CREATE DT_DSIGIN.FOR
34666*COPY DT_DSIGIN
34667*
34668*===dsigin=============================================================*
34669*
34670 SUBROUTINE DT_DSIGIN(IRE ,PLAB,N,IE ,AMT ,AMN,ECM ,SI ,ITAR)
34671
34672 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34673 SAVE
34674
34675* particle properties (BAMJET index convention),
34676* (dublicate of DTPART for HADRIN)
34677 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34678 & K1H(110),K2H(110)
34679 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34680 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34681 & NRK(2,268),NURE(30,2)
34682
34683 IE=IDT_IEFUND(PLAB,IRE)
34684 IF (IE.LE.IEII(IRE)) IE=IE+1
34685 AMT=AMH(ITAR)
34686 AMN=AMH(N)
34687 AMN2=AMN*AMN
34688 AMT2=AMT*AMT
34689 ECM=SQRT(AMN2+AMT2+2.0D0*AMT*SQRT(AMN2+PLAB**2))
34690C*** INTERPOLATION PREPARATION
34691 ECMO=UMO(IE)
34692 ECM1=UMO(IE-1)
34693 DECM=ECMO-ECM1
34694 DEC=ECMO-ECM
34695 IIKI=IKII(IRE)+1
34696 EKLIM=-THRESH(IIKI)
34697 WOK=SIIN(IE)
34698 WDK=WOK-SIIN(IE-1)
34699 IF (ECM.GT.ECMO) WDK=0.0D0
34700C*** INTERPOLATION IN CHANNEL WEIGHTS
34701 IELIM=IDT_IEFUND(EKLIM,IRE)
34702 DELIM=UMO(IELIM)+EKLIM
34703 *+1.D-16
34704 DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
34705 IF (DELIM*DELIM-DETE*DETE) 20,20,10
34706 10 DECC=DELIM
34707 GO TO 30
34708 20 DECC=DECM
34709 30 CONTINUE
34710 WKK=WOK-WDK*DEC/(DECC+1.D-9)
34711 IF (WKK.LT.0.0D0) WKK=0.0D0
34712 SI=WKK+1.D-12
34713 IF (-EKLIM.GT.ECM) SI=1.D-14
34714 RETURN
34715 END
34716
34717*$ CREATE DT_DTCHOI.FOR
34718*COPY DT_DTCHOI
34719*
34720*===dtchoi=============================================================*
34721*
34722 SUBROUTINE DT_DTCHOI(T,P,PP,E,EE,I,II,N,AM1,AM2)
34723
34724 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34725 SAVE
34726
34727C ****************************
34728C TCHOIC CALCULATES A RANDOM VALUE
34729C FOR THE FOUR-MOMENTUM-TRANSFER T
34730C ****************************
34731
34732* particle properties (BAMJET index convention),
34733* (dublicate of DTPART for HADRIN)
34734 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34735 & K1H(110),K2H(110)
34736* slope parameters for HADRIN interactions
34737 COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
34738
34739 AMA=AM1
34740 AMB=AM2
34741 IF (I.GT.30.AND.II.GT.30) GO TO 20
34742 III=II
34743 AM3=AM2
34744 IF (I.LE.30) GO TO 10
34745 III=I
34746 AM3=AM1
34747 10 CONTINUE
34748 GO TO 30
34749 20 CONTINUE
34750 III=II
34751 AM3=AM2
34752 IF (AMA.LE.AMB) GO TO 30
34753 III=I
34754 AM3=AM1
34755 30 CONTINUE
34756 IB=IBARH(III)
34757 AMA=AM3
34758 K=INT((AMA-0.75D0)/0.05D0)
34759 IF (K-2.LT.0) K=1
34760 IF (K-26.GE.0) K=25
34761 IF (IB)50,40,50
34762 40 BM=BBM(K)
34763 GO TO 60
34764 50 BM=BBB(K)
34765 60 CONTINUE
34766C NORMALIZATION
34767 TMIN=-2.0D0*(E*EE-P*PP)+AMH(N)**2+AM1 **2
34768 TMAX=-2.0D0*(E*EE+P*PP)+AMH(N)**2+AM1 **2
34769 VB=DT_RNDM(TMIN)
34770**sr test
34771C IF (VB.LT.0.2D0) BM=BM*0.1
34772C **0.5
34773 BM = BM*5.05D0
34774**
34775 TMI=BM*TMIN
34776 TMA=BM*TMAX
34777 ETMA=0.D0
34778 IF (ABS(TMA).GT.120.D0) GO TO 70
34779 ETMA=EXP(TMA)
34780 70 CONTINUE
34781 AN=(1.0D0/BM)*(EXP(TMI)-ETMA)
34782C*** RANDOM CHOICE OF THE T - VALUE
34783 R=DT_RNDM(TMI)
34784 T=(1.0D0/BM)*LOG(ETMA+R*AN*BM)
34785 RETURN
34786 END
34787
34788*$ CREATE DT_DTWOPA.FOR
34789*COPY DT_DTWOPA
34790*
34791*===dtwopa=============================================================*
34792*
34793 SUBROUTINE DT_DTWOPA(E1,E2,P1,P2,COD1,COD2,COF1,COF2,SIF1,SIF2,
34794 &IT1,IT2,UMOO,ECM,P,N,AM1,AM2)
34795
34796 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34797 SAVE
34798
34799C ******************************************************
34800C QUASI TWO PARTICLE PRODUCTION
34801C TWOPAR CALCULATES THE ENERGYS AND THE MOMENTA
34802C FOR THE CREATED PARTICLES OR RESONANCES IT1 AND IT2
34803C IN THE CM - SYSTEM
34804C COD1,COD2,COF1,COF2,SIF1,SIF2 ARE THE ANGLES FOR
34805C SPHERICAL COORDINATES
34806C ******************************************************
34807
34808* particle properties (BAMJET index convention),
34809* (dublicate of DTPART for HADRIN)
34810 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34811 & K1H(110),K2H(110)
34812
34813 AMA=AM1
34814 AMB=AM2
34815 AMA2=AMA*AMA
34816 E1=((UMOO-AMB)*(UMOO+AMB) + AMA2)/(2.0D0*UMOO)
34817 E2=UMOO - E1
34818 IF (E1.LT.AMA*1.00001D0) E1=AMA*1.00001D0
34819 AMTE=(E1-AMA)*(E1+AMA)
34820 AMTE=AMTE+1.D-18
34821 P1=SQRT(AMTE)
34822 P2=P1
34823C / P2 / = / P1 / BUT OPPOSITE DIRECTIONS
34824C DETERMINATION OF THE ANGLES
34825C COS(THETA1)=COD1 COS(THETA2)=COD2
34826C SIN(PHI1)=SIF1 SIN(PHI2)=SIF2
34827C COS(PHI1)=COF1 COS(PHI2)=COF2
34828C PHI IS UNIFORMLY DISTRIBUTED IN ( 0,2*PI )
34829 CALL DT_DSFECF(COF1,SIF1)
34830 COF2=-COF1
34831 SIF2=-SIF1
34832C CALCULATION OF THETA1
34833 CALL DT_DTCHOI(TR,P,P1,ECM,E1,IT1,IT2,N,AM1,AM2)
34834 COD1=(TR-AMA2-AMH(N)*AMH(N)+2.0D0*ECM*E1)/(2.0D0*P*P1+1.D-18)
34835 IF (COD1.GT.0.9999999D0) COD1=0.9999999D0
34836 COD2=-COD1
34837 RETURN
34838 END
34839
34840*$ CREATE DT_ZK.FOR
34841*COPY DT_ZK
34842*
34843*===zk=================================================================*
34844*
34845 BLOCK DATA DT_ZK
34846
34847 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34848 SAVE
34849
34850* decay channel information for HADRIN
34851 COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
34852 & K1Z(16),K2Z(16),WTZ(153),II22,
34853 & NZK1(153),NZK2(153),NZK3(153)
34854* decay channel information for HADRIN
34855 CHARACTER*8 ANAMZ,ZKNAM4,ZKNAM5,ZKNAM6
34856 COMMON /HNADDN/ ANAMZ(16),ZKNAM4(9),ZKNAM5(90),ZKNAM6(54)
34857
34858* Particle masses in GeV *
34859 DATA AMZ/ 3*2.2D0, 0.9576D0, 3*1.887D0, 2.4D0, 2.03D0, 2*1.44D0,
34860 & 2*1.7D0, 3*0.D0/
34861* Resonance width Gamma in GeV *
34862 DATA GAZ/ 3*.2D0, .1D0, 4*.2D0, .18D0, 2*.2D0, 2*.15D0, 3*0.D0 /
34863* Mean life time in seconds *
34864 DATA TAUZ / 16*0.D0 /
34865* Charge of particles and resonances *
34866 DATA ICHZ/ 0, 1, 3*0, 1, -1, 0, 1, -1, 0, 0, 1 , 3*0 /
34867* Baryonic charge *
34868 DATA IBARZ/ 2, 7*0, 1, -1, -1, 1, 1, 3*0 /
34869* First number of decay channels used for resonances *
34870* and decaying particles *
34871 DATA K1Z/ 308,310,313,317,322,365,393,421,425,434,440,446,449,
34872 & 3*460/
34873* Last number of decay channels used for resonances *
34874* and decaying particles *
34875 DATA K2Z/ 309,312,316,321,364,392,420,424,433,439,445,448,451,
34876 & 3*460/
34877* Weight of decay channel *
34878 DATA WTZ/ .17D0, .83D0, 2*.33D0, .34D0, .17D0, 2*.33D0, .17D0,
34879 & .01D0, .13D0, .36D0, .27D0, .23D0, .0014D0, .0029D0, .0014D0,
34880 & .0029D0, 4*.0007D0, .0517D0, .0718D0, .0144D0, .0431D0, .0359D0,
34881 & .0718D0, .0014D0, .0273D0, .0014D0, .0431D0, 2*.0129D0, .0259D0,
34882 & .0517D0, .0359D0, .0014D0, 2*.0144D0, .0129D0, .0014D0, .0259D0,
34883 & .0359D0, .0072D0, .0474D0, .0948D0, .0259D0, .0072D0, .0144D0,
34884 & .0287D0, .0431D0, .0144D0, .0287D0, .0474D0, .0144D0, .0075D0,
34885 & .0057D0, .0019D0, .0038D0, .0095D0, 2*.0014D0, .0191D0, .0572D0,
34886 & .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0, .0686D0,.0172D0,
34887 & .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, .0190D0,
34888 & .0057D0, .0019D0, .0038D0, .0095D0, .0014D0, .0014D0, .0191D0,
34889 & .0572D0, .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0,.0686D0,
34890 & .0172D0, .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0,
34891 & .0190D0, 4*.25D0, 2*.2D0, .12D0, .1D0, .07D0, .07D0, .14D0,
34892 & 2*.05D0, .0D0, .3334D0, .2083D0, 2*.125D0, .2083D0, .0D0, .125D0,
34893 & .2083D0, .3334D0, .2083D0, .125D0, .3D0, .05D0, .65D0, .3D0,
34894 & .05D0, .65D0, 9*1.D0 /
34895* Particle numbers in decay channel *
34896 DATA NZK1/ 8, 1, 2, 9, 1, 2, 9, 2, 9, 7, 13, 31, 15, 24, 23, 13,
34897 & 23, 13, 2*23, 14, 13, 23, 31, 98, 2*33, 32, 23, 14, 13, 35, 2*23,
34898 & 14, 13, 33, 23, 98, 31, 23, 14, 13, 35, 2*33, 32, 23, 35, 33, 32,
34899 & 98, 5*35, 4*13, 23, 13, 98, 32, 33, 23, 13, 23, 13, 14, 13, 32,
34900 & 13, 98, 23, 13, 2*32, 13, 33, 32, 98, 2*35, 4*14, 23, 14, 98,
34901 & 2*34, 23, 14, 23, 2*14, 13, 34, 14, 98, 23, 14, 2*34, 14, 33, 32,
34902 & 98, 2*35, 104, 61, 105, 62, 1, 17, 21, 17, 22, 2*21, 22, 21, 2,
34903 & 67, 68, 69, 2, 2*9, 68, 69, 70, 2, 9, 2*24, 15, 2*25, 16, 9*0/
34904 DATA NZK2/ 2*8, 1, 8, 9, 2*8, 2*1, 7, 14, 13, 16, 25, 23, 14, 23,
34905 & 14, 31, 33, 32, 34, 35, 31, 23, 31, 33, 34, 31, 32, 34, 31, 33,
34906 & 32, 2*33, 35, 31, 33, 31, 33, 32, 34, 35, 31, 33, 34, 35, 31,
34907 & 4*33, 32, 3*35, 2*23, 13, 31, 32, 33, 13, 31, 32, 2*31, 32, 33,
34908 & 32, 32, 35, 31, 2*32, 33, 31, 33, 35, 33, 3*32, 35, 2*23, 14,
34909 & 31, 34, 33, 14, 31, 33, 2*31, 34, 32, 33, 34, 35, 31, 2*34, 33,
34910 & 31, 33, 35, 33, 2*34, 33, 35, 1, 2, 8, 9, 25, 13, 35, 2*32, 33,
34911 & 31, 13, 23, 31, 13, 23, 14, 79, 80, 31, 13, 23, 14, 78, 79, 8,
34912 & 1, 8, 1, 8, 1, 9*0 /
34913 DATA NZK3/ 23, 14, 2*13, 23, 13, 2*23, 14, 0, 7, 14, 4*0, 2*23,
34914 & 10*0, 33, 2*31, 0, 33, 34, 32, 34, 0, 35, 0, 31, 3*35, 0, 3*31,
34915 & 35, 31, 33, 34, 31, 33, 34, 31, 33, 35, 0, 23, 14, 6*0, 32, 3*33,
34916 & 32, 34, 0, 35, 0, 2*35, 2*31, 35, 32, 34, 31, 33, 32, 0, 23, 13,
34917 & 6*0, 34, 2*33, 34, 33, 34, 0, 35, 0,2*35, 2*31, 35, 2*34, 31,
34918 & 2*34, 25*0, 23, 2*14, 23, 2*13, 9*0 /
34919* Particle names *
34920 DATA ANAMZ / 'NNPI', 'ANPPI', 'ANNPI', ' ETS ',' PAP ',' PAN ',
34921 & 'APN', 'DEO ', 'S+2030', 'AN*-14', 'AN*014','KONPI ','AKOPPI',
34922 & 3*'BLANK' /
34923* Name of decay channel *
34924 DATA ZKNAM4/'NNPI0','PNPI-','APPPI+','ANNPI+','ANPPI0','APNPI+',
34925 & 'ANNPI0','APPPI0','ANPPI-'/
34926 DATA ZKNAM5/' GAGA ','P+P-GA','ETP+P-','K+K- ','K0AK0 ',
34927 & ' POPO ',' P+P- ','POPOPO','P+P0P-','P0ET ','&0R0 ','P-R+ ',
34928 & 'P+R- ','POOM ',' ETET ','ETSP0 ','R0ET ',' R0R0 ','R+R- ',
34929 & 'P0ETR0','P-ETR+','P+ETR-',' OMET ','P0R0R0','P0R+R-','P-R+R0',
34930 & 'P+R-R0','R0OM ','P0ETOM','ETSR0 ','ETETET','P0R0OM','P-R+OM',
34931 & 'P+R-OM','OMOM ','R0ETET','R0R0ET','R+R-ET','P0OMOM','OMETET',
34932 & 'R0R0R0','R+R0R-','ETSRET','OMR0R0','OMR+R-','OMOMET','OMOMR0',
34933 & 'OMOMOM',
34934 & ' P+PO ','P+POPO','P+P+P-','P+ET ','P0R+ ','P+R0 ','ETSP+ ',
34935 & 'R+ET ',' R0R+ ','POETR+','P+ETR0','POR+R-','P+R0R0','P-R+R+',
34936 & 'P+R-R+','R+OM ','P+ETOM','ETSR+ ','POR+OM','P+R0OM','R+ETET',
34937 & 'R+R0ET','P+OMOM','R0R0R+','R+R+R-','ETSR+E','OMR+R0','OMOMR+',
34938 & 'P-PO ','P-POPO','P-P-P+','P-ET ','POR- ','P-R0 ','ETSP- ',
34939 & 'R-ET ','R-R0 ','POETR-','P-ETR0','POR-R0','P-R+R-','P-R0R0'/
34940 DATA ZKNAM6/'P+R-R-','R-OM ','P-ETOM','ETSR- ','POR-OM','P-R0OM',
34941 & 'R-ETET','R-R0ET','P-OMOM','R0R0R-','R+R-R-','ETSR-E','OMR0R-',
34942 & 'OMOMR-', 'PAN-14','APN+14','NAN014','ANN014','PAKO ','LPI+ ',
34943 & 'SI+OM','LAMRO+','SI0RO+','SI+RO0','SI+ETA','SI0PI+','SI+PI0',
34944 & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHOO','ANRHO-','ANETA ',
34945 & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0',
34946 & 'KONPIO','KOPPI-','K+NPI-','AKOPPO','AKONP+','K-PPI+',
34947 & 9*'BLANK'/
34948*= end*block.zk *
34949 END
34950
34951*$ CREATE DT_BLKD43.FOR
34952*COPY DT_BLKD43
34953*
34954*===blkd43=============================================================*
34955*
34956 BLOCK DATA DT_BLKD43
34957
34958 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34959 SAVE
34960
34961*
34962*=== reac =============================================================*
34963*
34964*----------------------------------------------------------------------*
34965* *
34966* Created on 10 december 1991 by Alfredo Ferrari & Paola Sala *
34967* Infn - Milan *
34968* *
34969* Last change on 10-dec-91 by Alfredo Ferrari *
34970* *
34971* This is the original common reac of Hadrin *
34972* *
34973*----------------------------------------------------------------------*
34974*
34975 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34976 & NRK(2,268),NURE(30,2)
34977
34978 DIMENSION
34979 & UMOPI(92), UMOKC(68), UMOP(39), UMON(63), UMOK0(34),
34980 & PLAPI(92), PLAKC(68), PLAP(39), PLAN(63), PLAK0(34),
34981 & SPIKP1(315), SPIKPU(278), SPIKPV(372),
34982 & SPIKPW(278), SPIKPX(372), SPIKP4(315),
34983 & SPIKP5(187), SPIKP6(289),
34984 & SKMPEL(102), SPIKP7(289), SKMNEL(68), SPIKP8(187),
34985 & SPIKP9(143), SPIKP0(169), SPKPV(143),
34986 & SAPPEL(105), SPIKPE(399), SAPNEL(84), SPIKPZ(273),
34987 & SANPEL(84) , SPIKPF(273),
34988 & SPKP15(187), SPKP16(272),
34989 & NRKPI(164), NRKKC(132), NRKP(70), NRKN(116), NRKK0(54),
34990 & NURELN(60)
34991*
34992 DIMENSION NRKLIN(532)
34993 EQUIVALENCE (NRK(1,1), NRKLIN(1))
34994 EQUIVALENCE ( UMO( 1), UMOPI(1)), ( UMO( 93), UMOKC(1))
34995 EQUIVALENCE ( UMO(161), UMOP(1)), ( UMO(200), UMON(1))
34996 EQUIVALENCE ( UMO(263), UMOK0(1))
34997 EQUIVALENCE ( PLABF( 1), PLAPI(1)), ( PLABF( 93), PLAKC(1))
34998 EQUIVALENCE ( PLABF(161), PLAP(1)), ( PLABF(200), PLAN(1))
34999 EQUIVALENCE ( PLABF(263), PLAK0(1))
35000 EQUIVALENCE ( WK( 1), SPIKP1(1)), ( WK( 316), SPIKPU(1))
35001 EQUIVALENCE ( WK( 594), SPIKPV(1)), ( WK( 966), SPIKPW(1))
35002 EQUIVALENCE ( WK(1244), SPIKPX(1)), ( WK(1616), SPIKP4(1))
35003 EQUIVALENCE ( WK(1931), SPIKP5(1)), ( WK(2118), SPIKP6(1))
35004 EQUIVALENCE ( WK(2407), SKMPEL(1)), ( WK(2509), SPIKP7(1))
35005 EQUIVALENCE ( WK(2798), SKMNEL(1)), ( WK(2866), SPIKP8(1))
35006 EQUIVALENCE ( WK(3053), SPIKP9(1)), ( WK(3196), SPIKP0(1))
35007 EQUIVALENCE ( WK(3365), SPKPV(1)), ( WK(3508), SAPPEL(1))
35008 EQUIVALENCE ( WK(3613), SPIKPE(1)), ( WK(4012), SAPNEL(1))
35009 EQUIVALENCE ( WK(4096), SPIKPZ(1)), ( WK(4369), SANPEL(1))
35010 EQUIVALENCE ( WK(4453), SPIKPF(1)), ( WK(4726), SPKP15(1))
35011 EQUIVALENCE ( WK(4913), SPKP16(1))
35012 EQUIVALENCE (NRK(1,1), NRKLIN(1))
35013 EQUIVALENCE (NRKLIN( 1), NRKPI(1)), (NRKLIN( 165), NRKKC(1))
35014 EQUIVALENCE (NRKLIN( 297), NRKP(1)), (NRKLIN( 367), NRKN(1))
35015 EQUIVALENCE (NRKLIN( 483), NRKK0(1))
35016 EQUIVALENCE (NURE(1,1), NURELN(1))
35017*
35018**** pi- p data *
35019**** pi+ n data *
35020 DATA PLAPI / 0.D0, .3D0, .5D0, .6D0, .7D0, .8D0, .9D0, .95D0,1.D0,
35021 & 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0,
35022 & 3.D0, 3.5D0, 4.D0, 0.D0, .285D0, .4D0, .45D0, .5D0, .6D0, .7D0,
35023 & .75D0, .8D0, .85D0, .9D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0,
35024 & 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0,
35025 & .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, .75D0, .8D0, .85D0, .9D0,
35026 & 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0,
35027 & 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, .3D0, .5D0, .6D0, .7D0,
35028 & .8D0, .9D0, .95D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0,
35029 & 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0 /
35030 DATA PLAKC /
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 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35038 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35039 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
35040 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35041 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35042 & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
35043 DATA PLAK0 /
35044 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35045 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35046 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
35047 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35048 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35049 & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
35050* pp pn np nn *
35051 DATA PLAP /
35052 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35053 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35054 & 0.D0, 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 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35057 & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
35058* app apn anp ann *
35059 DATA PLAN /
35060 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
35061 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35062 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35063 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
35064 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35065 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35066 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
35067 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35068 & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
35069 DATA SIIN / 296*0.D0 /
35070 DATA UMOPI/ 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
35071 & 1.557D0,1.615D0,1.6435D0,
35072 & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
35073 & 2.286D0,2.366D0,2.482D0,2.56D0,
35074 & 2.735D0,2.90D0,
35075 & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
35076 & 1.496D0,1.527D0,1.557D0,
35077 & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
35078 & 2.071D0,2.159D0,2.286D0,2.366D0,
35079 & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
35080 & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
35081 & 1.496D0,1.527D0,1.557D0,
35082 & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
35083 & 2.071D0,2.159D0,2.286D0,2.366D0,
35084 & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
35085 & 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
35086 & 1.557D0,1.615D0,1.6435D0,
35087 & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
35088 & 2.286D0,2.366D0,2.482D0,2.56D0,
35089 & 2.735D0, 2.90D0/
35090 DATA UMOKC/ 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,1.44D0,
35097 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35098 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35099 & 3.1D0,1.44D0,
35100 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35101 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35102 & 3.1D0/
35103 DATA UMOK0/ 1.44D0,
35104 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35105 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35106 & 3.1D0,1.44D0,
35107 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35108 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35109 & 3.1D0/
35110* pp pn np nn *
35111 DATA UMOP/
35112 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35113 & 3.D0,3.1D0,3.2D0,
35114 & 1.88D0,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 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35117 & 3.D0,3.1D0,3.2D0/
35118* app apn anp ann *
35119 DATA UMON /
35120 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
35121 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35122 & 3.D0,3.1D0,3.2D0,
35123 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
35124 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35125 & 3.D0,3.1D0,3.2D0,
35126 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
35127 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35128 & 3.D0,3.1D0,3.2D0/
35129**** reaction channel state particles *
35130 DATA NRKPI / 13, 1, 15, 21, 81, 0, 13, 54, 23, 53, 13, 63, 13, 58,
35131 & 23, 57, 13, 65, 1, 32, 53, 31, 54, 32, 53, 33, 53, 35, 63, 32,
35132 & 13, 8, 23, 1, 17, 15, 21, 24, 22, 15, 82, 0, 61, 0, 13, 55, 23,
35133 & 54, 14, 53, 13, 64, 23, 63, 13, 59, 23, 58, 14, 57, 13, 66, 23,
35134 & 65, 1, 31, 8, 32, 1, 33, 1, 35, 54, 31, 55, 32, 54, 33, 53, 34,
35135 & 54, 35, 14, 1, 23, 8, 17, 24, 20, 15, 22, 24, 83, 0, 62, 0, 14,
35136 & 54, 23, 55, 13, 56, 14, 63, 23, 64, 14, 58, 23, 59, 13, 60, 14,
35137 & 65, 23, 66, 8, 31, 1, 34, 8, 33, 8, 35, 55, 31, 54, 34, 55, 33,
35138 & 56, 32, 55, 35, 14, 8, 24, 20, 84, 0, 14, 55, 23, 56, 14, 64, 14,
35139 & 59, 23, 60, 14, 66, 8, 34, 56, 31, 55, 34, 56, 33, 56, 35, 64,34/
35140 DATA NRKKC/ 15, 1, 89, 0, 24, 53, 15, 54, 1, 36, 1, 40, 1, 44, 36,
35141 & 63, 15, 63, 45, 53, 44, 54, 15, 8, 24, 1, 91, 0, 24, 54, 15, 55,
35142 & 8, 36, 1, 37, 8, 40, 1, 41, 8, 44, 1, 45, 36, 64, 37, 63, 15, 64,
35143 & 24, 63, 45, 54, 44, 55, 16, 1, 25, 8, 17, 23, 21, 14, 20,
35144 & 13, 22, 23, 90, 0, 38, 1, 39, 8, 16, 54, 25, 55, 1, 42, 8, 43,
35145 & 16, 63, 25, 64, 39, 64, 38, 63, 46, 54, 47, 55, 8, 47, 1, 46, 52,
35146 & 0, 51, 0, 16, 8, 17, 14, 20, 23, 22, 14, 92, 0, 8, 38, 16, 55,
35147 & 25, 56, 8, 42, 16, 64, 38, 64, 46, 55, 47, 56, 8, 46, 94, 0 /
35148* *
35149* k0 p k0 n ak0 p ak/ n *
35150* *
35151 DATA NRKK0 / 24, 8, 106, 0, 15, 56, 24, 55, 37, 8, 41, 8, 45, 8,
35152 & 37, 64, 24, 64, 44, 56, 45, 55, 25, 1, 17, 13, 22, 13, 21, 23,
35153 & 107, 0, 39, 1, 25, 54, 16, 53, 43, 1, 25, 63, 39, 63, 47, 54, 46,
35154 & 53, 47, 1, 103, 0, 93, 0/
35155* pp pn np nn *
35156 DATA NRKP / 1, 1, 85, 0, 8, 53, 1, 54, 1, 63, 8, 57, 1, 58, 2*54,
35157 & 53, 55, 63, 54, 64, 53, 1, 8, 86, 0, 8, 54, 1, 55, 8, 63, 1, 64,
35158 & 8, 58, 1, 59, 64, 54, 63, 55, 54, 55, 53, 56, 77, 0, 2*8, 95, 0,
35159 & 8, 55, 1, 56, 8, 64, 8, 59, 1, 60, 2*55, 54, 56, 64, 55, 63, 56 /
35160* app apn anp ann *
35161 DATA NRKN/ 1, 2, 17, 18, 15, 16, 8, 9, 13, 14, 99, 0, 87, 0, 1,
35162 & 68, 8, 69, 2, 54, 9, 55, 102, 0, 2, 63, 9, 64, 1, 75, 8, 76, 53,
35163 & 67, 54, 68, 55, 69, 56, 70, 63, 68, 64, 69, 75, 54, 76, 55, 2, 8,
35164 & 18, 20, 16, 24, 14, 23, 101, 0, 88, 0, 2, 55, 9, 56, 1, 67, 8,
35165 & 68, 2, 64, 8, 75, 2, 59, 8, 72, 68, 55, 67, 54, 69, 56, 1, 9, 18,
35166 & 21, 15, 25, 13, 23, 100, 0, 96, 0, 2, 53, 9, 54, 1, 69, 8, 70, 1,
35167 & 76, 9, 63, 1, 73, 9, 58, 55, 70, 53, 68, 54, 69 /
35168**** channel cross section *
35169 DATA SPIKP1/ 0.D0, 300.D0, 40.D0, 20.D0, 13.D0,8.5D0,8.D0, 9.5D0,
35170 & 12.D0,14.D0,15.5D0,20.D0,17.D0,13.D0,10.D0,9.D0,8.5D0,8.D0,7.8D0,
35171 & 7.3D0, 6.7D0, 9*0.D0,.23D0,.35D0,.7D0,.52D0,.4D0,.3D0,.2D0,.15D0,
35172 & .13D0, .11D0, .09D0, .07D0, 0.D0, .033D0,.8D0,1.35D0,1.35D0,.5D0,
35173 & 15*0.D0, 3*0.D0,.00D0,0.80D0,2.2D0,3.6D0,4.6D0,4.7D0,3.5D0,2.4D0,
35174 &1.8D0,1.4D0,.75D0,.47D0,.25D0,.13D0,.08D0,6*0.D0,0.D0,1.2D0,3.3D0,
35175 & 5.4D0,6.9D0,7.3D0,5.3D0,3.6D0,2.7D0,2.2D0,1.1D0,.73D0,.4D0,.22D0,
35176 & .12D0,9*0.D0,.0D0,0.D0,2.0D0,4.4D0,6.8D0,9.9D0,7.9D0,6.0D0,3.8D0,
35177 &2.5D0,2.D0,1.4D0,1.D0,.6D0,.35D0,10*0.D0,.25D0,.55D0,.75D0,1.25D0,
35178 & 1.9D0,2.D0,1.8D0,1.5D0,1.25D0,1.D0,.8D0,6*0.D0,4*0.D0,.4D0,.85D0,
35179 & 1.1D0, 1.85D0, 2.8D0, 3.D0,2.7D0,2.2D0,1.85D0,1.5D0,1.2D0,6*0.D0,
35180 & 6*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, 5.6D0,
35181 & 5.2D0, 6*0.D0, 2*0.D0, .0D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0,
35182 & 2.75D0, 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 6*0.D0, 3*0.D0,
35183 & .0D0, .45D0, 1.4D0, 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0,
35184 & 8*0.D0, 5*0.D0, .0D0, .0D0, .6D0, .8D0, .95D0, .8D0, .7D0, .6D0,
35185 & .5D0, .4D0, 6*0.D0, 5*0.D0, .0D0, .00D0, .85D0, 1.2D0, 1.4D0,
35186 & 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 6*0.D0, 5*0.D0, .0D0, .00D0,
35187 & 1.D0, 1.5D0, 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 6*0.D0,
35188 & 10*0.D0, .5D0, 2.0D0, 3.3D0, 5.4D0, 7.D0 /
35189**** pi+ n data *
35190 DATA SPIKPU/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 20.D0,
35191 & 20.D0, 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
35192 & 10.D0, 10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
35193 & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
35194 & 4.2D0, 7.5D0, 3.4D0, 2.5D0, 2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0,
35195 & .6D0, .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0,
35196 & .48D0, .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0,
35197 & .065D0, .05D0, .04D0, 12*0.D0, .2D0, .25D0, .25D0, .2D0, .1D0,
35198 & .08D0, .06D0, .045D0, .03D0, .02D0, .01D0, .005D0, .003D0,
35199 & 12*0.D0, .3D0, .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0,
35200 & .09D0, .08D0, .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0,
35201 & 3.1D0, 4.5D0, 2.D0, 18*0.D0, 3*.0D0, 0.D0, 0.D0, 4.0D0, 11.D0,
35202 & 11.4D0, 10.3D0, 7.5D0, 6.8D0, 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0,
35203 & .35D0, 13*0.D0, .1D0, .34D0, .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0,
35204 & 2.3D0, 1.6D0, .95D0, .45D0, .28D0, .15D0, 10*0.D0, 2*0.D0, .17D0,
35205 & .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0, 6.2D0, 4.4D0, 3.D0, 1.8D0,
35206 & .9D0, .53D0, .28D0, 10*0.D0, 2*0.D0, .25D0, .82D0,
35207 & 1.3D0, 1.9D0, 2.8D0, 5.5D0 , 8.D0, 5.7D0, 3.9D0, 2.35D0, 1.15D0,
35208 & .69D0, .37D0, 10*0.D0, 7*0.D0, .0D0, .34D0, 1.5D0, 3.47D0,
35209 & 5.87D0, 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
35210*
35211 DATA SPIKPV/ 7*0.D0, .00D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
35212 & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 6*0.D0, 10*0.D0, .2D0,
35213 & .6D0, .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0,
35214 & 1.D0, .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0,
35215 & 3.5D0, 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0,
35216 & .31D0, .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0,
35217 & .23D0, 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0,
35218 & 5.D0, 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0,
35219 & 2.5D0, 3*0.D0, 3*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0,
35220 & 1.5D0, 1.1D0, .8D0, .7D0, .55D0, .3D0, 10*0.D0, 9*0.D0, .1D0,
35221 & .4D0, 1.D0, 1.4D0, 2.2D0, 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0,
35222 & .8D0, .6D0, .4D0, 12*0.D0, .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0,
35223 & 3.8D0, 3.3D0, 2.45D0, 2.05D0, 1.65D0, 1.2D0, .9D0, .6D0, 3*0.D0,
35224 & 9*0.D0, .10D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0,
35225 & 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, 13*0.D0, .2D0, .5D0, .7D0,
35226 & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
35227 & 17*0.D0, .2D0, .5D0, .85D0, 2.D0, 2.15D0, 2.05D0, 1.75D0, 1.D0,
35228 & 17*0.D0, .13D0, .33D0, .57D0, 1.33D0, 1.43D0, 1.36D0, 1.17D0,
35229 & .67D0, 17*0.D0, .07D0, .17D0, .28D0, .67D0, .72D0, .69D0, .58D0,
35230 & .33D0,17*0.D0,.4D0, .7D0, 1.D0, 1.6D0, 1.8D0, 2.3D0,1.9D0,1.7D0 /
35231**** pi- p data *
35232 DATA SPIKPW/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 2*20.D0,
35233 & 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
35234 & 2*10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
35235 & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
35236 & 4.2D0, 7.5D0, 3.4D0, 2*2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, .6D0,
35237 & .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, .48D0,
35238 & .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, .065D0,
35239 & .05D0, .04D0, 12*0.D0, .2D0, 2*.25D0, .2D0, .1D0, .08D0, .06D0,
35240 & .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, 12*0.D0, .3D0,
35241 & .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, .09D0, .08D0,
35242 & .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, 3.1D0, 4.5D0,
35243 & 2.D0, 23*0.D0, 4.0D0, 11.D0, 11.4D0, 10.3D0, 7.5D0, 6.8D0,
35244 & 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, .35D0, 13*0.D0, .1D0, .34D0,
35245 & .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, 2.3D0, 1.6D0, .95D0, .45D0,
35246 & .28D0, .15D0, 12*0.D0, .17D0, .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0,
35247 & 6.2D0, 4.4D0, 3.D0, 1.8D0, .9D0, .53D0, .28D0, 12*0.D0, .25D0,
35248 & .82D0, 1.3D0, 1.9D0, 2.8D0, 5.5D0, 8.D0, 5.7D0, 3.9D0, 2.35D0,
35249 & 1.15D0, .69D0, .37D0, 18*0.D0, .34D0, 1.5D0, 3.47D0, 5.87D0,
35250 & 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
35251*
35252 DATA SPIKPX/ 8*0.D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
35253 & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 16*0.D0, .2D0, .6D0,
35254 & .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, 1.D0,
35255 & .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, 3.5D0,
35256 & 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, .31D0,
35257 & .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, .23D0,
35258 & 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, 5.D0,
35259 & 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, 2.5D0,
35260 & 6*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, 1.5D0, 1.1D0,
35261 & .8D0, .7D0, .55D0, .3D0, 19*0.D0, .1D0, .4D0, 1.D0, 1.4D0, 2.2D0,
35262 & 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, .8D0, .6D0, .4D0, 12*0.D0,
35263 & .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, 3.8D0, 3.3D0, 2.45D0, 2.05D0,
35264 & 1.65D0, 1.2D0, .9D0, .6D0, 12*0.D0, .10D0, .2D0, .5D0, .7D0,
35265 & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
35266 & 13*0.D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0,
35267 & 1.35D0, 1.15D0, .95D0, .7D0, 17*0.D0, .2D0, .5D0, .85D0, 2.D0,
35268 & 2.15D0, 2.05D0, 1.75D0, 1.D0, 17*0.D0, .13D0, .33D0, .57D0,
35269 & 1.33D0, 1.43D0, 1.36D0, 1.17D0, .67D0, 17*0.D0, .07D0, .17D0,
35270 & .28D0, .67D0, .72D0, .69D0, .58D0, .33D0, 17*0.D0, .4D0, .7D0,
35271 & 1.D0, 1.6D0, 1.8D0, 2.3D0, 1.9D0, 1.7D0 /
35272**** pi- n data *
35273 DATA SPIKP4 / 0.D0, 300.D0, 40.D0, 20.D0, 13.D0, 8.5D0, 8.D0,
35274 & 9.5D0, 12.D0, 14.D0, 15.5D0, 20.D0, 17.D0, 13.D0, 10.D0, 9.D0,
35275 & 8.5D0, 8.D0, 7.8D0, 7.3D0, 6.7D0, 9*0.D0, .23D0, .35D0, .7D0,
35276 & .52D0, .4D0, .3D0, .2D0, .15D0, .13D0, .11D0, .09D0, .07D0, 0.D0,
35277 & .033D0, .8D0, 2*1.35D0, .5D0, 19*0.D0, 0.8D0, 2.2D0, 3.6D0,
35278 & 4.6D0, 4.7D0, 3.5D0, 2.4D0, 1.8D0, 1.4D0, .75D0, .47D0, .25D0,
35279 & .13D0, .08D0, 7*0.D0, 1.2D0, 3.3D0, 5.4D0, 6.9D0, 7.3D0, 5.3D0,
35280 & 3.6D0, 2.7D0, 2.2D0, 1.1D0, .73D0, .4D0, .22D0, .12D0, 11*0.D0,
35281 & 2.0D0, 4.4D0, 6.8D0, 9.9D0, 7.9D0, 6.0D0, 3.8D0, 2.5D0, 2.D0,
35282 & 1.4D0, 1.D0, .6D0, .35D0, 10*0.D0, .25D0, .55D0, .75D0, 1.25D0,
35283 & 1.9D0, 2.D0, 1.8D0, 1.5D0, 1.25D0, 1.D0, .8D0, 10*0.D0, .4D0,
35284 & .85D0, 1.1D0, 1.85D0, 2.8D0, 3.D0, 2.7D0, 2.2D0, 1.85D0, 1.5D0,
35285 & 1.2D0, 12*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0,
35286 & 5.6D0, 5.2D0, 9*0.D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, 2.75D0,
35287 & 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 10*0.D0, .45D0, 1.4D0,
35288 & 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, 15*0.D0, .6D0,
35289 & .8D0, .95D0, .8D0, .7D0, .6D0, .5D0, .4D0, 13*0.D0, .85D0, 1.2D0,
35290 & 1.4D0, 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 13*0.D0, 1.D0, 1.5D0,
35291 & 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 16*0.D0, .5D0, 2.0D0,
35292 & 3.3D0, 5.4D0, 7.D0 /
35293**** k+ p data *
35294 DATA SPIKP5/ 0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0,
35295 & 7.D0, 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
35296 & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 13*0.D0, 0.9D0,
35297 & 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0,
35298 & .45D0, .21D0, .2D0, 3*0.D0, .9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
35299 & 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
35300 & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, 1.4D0,
35301 & 1.2D0, 1.05D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, 2*1.D0, .9D0,
35302 & .7D0, .4D0, .3D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.2D0,
35303 & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
35304 & 1.71D0, 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0,
35305 & 3.5D0, 2.85D0, 2.35D0, 2.01D0, 1.8D0, 12*0.D0, .1D0, .8D0,2.05D0,
35306 & 3.31D0, 3.5D0, 12*0.D0, .034D0, .2D0, .75D0, 1.04D0, 1.24D0 /
35307**** k+ n data *
35308 DATA SPIKP6/ 0.D0, 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0,
35309 & 1.5D0, 1.2D0, 1.D0, .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0,
35310 & 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, 1.5D0, 1.2D0, 1.D0,
35311 & .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, .5D0, 1.3D0, 2.8D0,
35312 & 2.3D0, 1.6D0, .9D0, 13*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
35313 & 2.D0, 1.7D0, 1.5D0,1.2D0,.9D0,.6D0,.45D0,.21D0,.2D0,3*0.D0,0.9D0,
35314 & 2.5D0, 3.D0, 2.5D0, 2.3D0,2.D0,1.7D0,1.5D0,1.2D0,.9D0,.6D0,.45D0,
35315 & .21D0, .2D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.D0,1.8D0,1.7D0,1.4D0,
35316 & 1.2D0,1.15D0,.9D0,.66D0,.5D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.1D0,
35317 & 1.8D0,1.7D0,1.4D0,1.2D0, 1.15D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0,
35318 & 2*1.D0, .9D0, .7D0, .4D0, .35D0, .2D0, 9*0.D0, .3D0, 2*1.D0,.9D0,
35319 & .7D0, .4D0, .35D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.4D0,3.5D0,4.25D0,
35320 & 4.55D0, 4.85D0, 4.9D0, 9*0.D0, .1D0, 1.D0, 2.4D0, 3.5D0, 4.25D0,
35321 & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
35322 & 1.71D0, 1.6D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0,
35323 & 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0,4.4D0,4.D0,3.5D0,2.85D0,
35324 & 2.35D0, 2.01D0, 1.8D0, 6*0.D0, 1.4D0,3.8D0,5.D0,4.7D0,4.4D0,4.D0,
35325 & 3.5D0,2.85D0,2.35D0,2.01D0,1.8D0,12*0.D0,.1D0,.8D0,2.05D0,3.31D0,
35326 & 3.5D0, 12*0.D0, .034D0,.2D0,.75D0,1.04D0,1.24D0 /
35327**** k- p data *
35328 DATA SKMPEL/ 0.D0, 35.D0, 22.D0, 25.D0, 17.D0, 9.D0, 9.5D0, 8.D0,
35329 & 7.D0, 6.5D0, 6.1D0, 5.D0, 4.8D0, 4.6D0, 4.45D0, 4.3D0, 4.2D0,
35330 & 0.D0, 8.D0, 3.5D0, 8.D0, 3.D0, 1.9D0, 1.7D0, 1.D0, .9D0, .8D0,
35331 & .75D0, .5D0, .42D0, .38D0, .34D0, .25D0, .2D0,
35332 & 0.D0, 3.D0, 3.2D0, 3.5D0, 1.5D0, 1.4D0, 1.1D0, .6D0, .5D0,
35333 & .35D0, .28D0, .25D0, .18D0, .12D0, .1D0, .08D0, .04D0,
35334 & 0.D0, 8.5D0, 2.4D0, 1.7D0, 1.3D0, 1.3D0, 1.1D0, .5D0,
35335 & .4D0, .4D0, .35D0, .3D0, .28D0, .2D0, .16D0, .13D0, .11D0,
35336 & 0.D0, 7.D0, 4.8D0, 1.4D0, 1.9D0, .9D0, .4D0, .2D0, .13D0,
35337 & .1D0, .08D0, .06D0, .04D0, .02D0, .015D0, .01D0, .01D0,
35338 & 0.D0, 5.5D0, 1.D0, .8D0, .75D0, .32D0, .2D0, .1D0, .09D0,
35339 & .08D0, .065D0, .05D0, .04D0, .022D0, .017D0, 2*.01D0/
35340 DATA SPIKP7 / 0.D0, .56D0, 1.46D0, 3.16D0, 2.01D0, 1.28D0, .74D0,
35341 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
35342 & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 4*0.D0,
35343 & 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, 1.57D0,
35344 & 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0, 3.03D0,
35345 & 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0,
35346 & .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, 2.8D0,
35347 & 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0,
35348 & .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
35349 & .45D0, .39D0, .22D0, .07D0, 0.D0, 7*0.D0, .34D0, 1.12D0, 1.12D0,
35350 & 1.01D0, .78D0, .45D0, .39D0, .22D0, .07D0, 0.D0, 6*0.D0, 1.71D0,
35351 & 4.26D0, 5.6D0, 5.57D0, 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0,
35352 & 2.25D0, 2.D0, 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
35353 & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, .22D0,
35354 & .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 10*0.D0, .22D0, .8D0,
35355 & .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, .3D0, .7D0,1.D0,
35356 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, 1.72D0, 2.69D0,
35357 & 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 9*0.D0, .11D0, 1.72D0,
35358 & 2.69D0, 3.92D0, 4.76D0, 5.1D0, 5.44D0, 5.3D0, 5*0.D0,9.2D0,4.7D0,
35359 & 1.9D0, 10*0.D0, 2.5D0, 15.D0, 21.5D0, 15.3D0, 3.D0, 1.5D0,
35360 & 10*0.D0/
35361***** k- n data *
35362 DATA SKMNEL/0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
35363 & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0,
35364 & 0.D0, 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0,
35365 & 1.9D0, .9D0, .5D0, .3D0, .24D0, .2D0, .18D0, .1D0, .09D0,
35366 & 0.D0, 1.8D0, 2.D0, 1.1D0, .9D0, .5D0, .5D0, .4D0, .4D0,
35367 & .2D0, .1D0, .06D0, .05D0, .04D0, .03D0, .02D0, .02D0,
35368 & 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, .7D0, .65D0,
35369 & .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, .03D0/
35370 DATA SPIKP8/0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
35371 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
35372 & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,
35373 & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
35374 & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
35375 & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
35376 & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
35377 & 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, .45D0,
35378 & .39D0, .22D0, .07D0, 0.D0,
35379 & 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
35380 & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0,
35381 & 10*0.D0, .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0,
35382 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0,
35383 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0,
35384 & 9*0.D0, .11D0, 1.72D0, 2.69D0, 3.92D0, 4.76D0,
35385 & 5.10D0, 5.44D0, 5.3D0,
35386 & 4*0.D0, 0.00D0, 9.2D0, 4.7D0, 1.9D0, 9*0.D0/
35387***** p p data *
35388 DATA SPIKP9/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
35389 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
35390 & 0.D0, 3.6D0, 1.7D0, 10*0.D0,
35391 & .0D0, 0.D0, 8.7D0, 17.7D0, 18.8D0, 15.9D0,
35392 & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
35393 & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
35394 & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
35395 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
35396 & 16.9D0, 16.5D0, 11.D0, 5.5D0, 3.5D0,
35397 & 10*0.D0, 4.3D0, 7.6D0, 9.D0,
35398 & 10*0.D0, 1.7D0, 2.6D0, 3.D0,
35399 & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
35400 & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
35401 & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
35402 & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/
35403***** p n data *
35404 DATA SPIKP0/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
35405 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
35406 & 0.D0, 1.8D0, .2D0, 12*0.D0,
35407 & 3.2D0, 6.05D0, 9.9D0, 5.1D0,
35408 & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
35409 & 2*.0D0, 3.2D0, 6.05D0, 9.9D0, 5.1D0,
35410 & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
35411 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
35412 & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
35413 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
35414 & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
35415 & 10*0.D0, .7D0, 5.1D0, 8.D0,
35416 & 10*0.D0, .7D0, 5.1D0, 8.D0,
35417 & 10*.0D0, .3D0, 2.8D0, 4.7D0,
35418 & 10*.0D0, .3D0, 2.8D0, 4.7D0,
35419 & 7*0.D0, 1.2D0, 2.5D0, 3.5D0, 6.D0, 5.3D0, 2.9D0,
35420 & 7*0.D0, 1.7D0, 3.6D0, 5.4D0, 9.D0, 7.6D0, 4.2D0,
35421 & 5*0.D0, 7.7D0, 6.1D0, 2.9D0, 5*0.D0/
35422* nn - data *
35423* *
35424 DATA SPKPV/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
35425 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
35426 & 0.D0, 3.6D0, 1.7D0, 12*0.D0,
35427 & 8.7D0, 17.7D0, 18.8D0, 15.9D0,
35428 & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
35429 & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
35430 & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
35431 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0, 16.9D0, 16.5D0,
35432 & 11.D0, 5.5D0, 3.5D0,
35433 & 10*0.D0, 4.3D0, 7.6D0, 9.D0,
35434 & 10*0.D0, 1.7D0, 2.6D0, 3.D0,
35435 & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
35436 & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
35437 & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
35438 & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/
35439**************** ap - p - data *
35440 DATA SAPPEL/ 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
35441 & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
35442 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0,
35443 & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
35444 & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
35445 & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
35446 & 0.D0, 55.D0, 50.D0, 25.D0, 15.D0, 15.D0, 14.D0, 12.D0,
35447 & 10.D0, 7.D0, 6.D0, 4.D0, 3.3D0, 2.8D0, 2.4D0, 2.D0, 1.8D0,
35448 & 1.55D0, 1.3D0, .95D0, .75D0,
35449 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
35450 & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
35451 & .01D0, .008D0, .006D0, .005D0/
35452 DATA SPIKPE/0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
35453 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
35454 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0,
35455 & 9*0.D0, 2.D0, 2.5D0, .2D0, 19*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0,
35456 & 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, .3D0, 1.4D0,
35457 & 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0,
35458 & .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0,
35459 & .3D0, 10*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0,
35460 & .6D0, .5D0, .4D0, .3D0, 9*0.D0, .6D0, 2.5D0, 5.D0, 5.2D0, 5.1D0,
35461 & 5.4D0, 5.8D0, 2.8D0, 2.1D0, 1.8D0, 1.6D0, 1.2D0, 13*0.D0, 1.3D0,
35462 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
35463 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
35464 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
35465 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 14*0.D0, .2D0,
35466 & .5D0, 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0,
35467 & 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0,
35468 & 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, 1.6D0,
35469 & 1.4D0, 1.1D0, .9D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0,
35470 & .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0,
35471 & 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0 /
35472**************** ap - n - data *
35473 DATA SAPNEL/
35474 & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
35475 & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
35476 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0,
35477 & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0,
35478 & .85D0, 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0,
35479 & .14D0, .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
35480 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
35481 & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
35482 & .01D0, .008D0, .006D0, .005D0 /
35483 DATA SPIKPZ/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
35484 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
35485 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
35486 & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35487 & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
35488 & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
35489 & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
35490 & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35491 & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35492 & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35493 & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
35494 & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
35495 & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
35496 & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
35497* *
35498* *
35499**************** an - p - data *
35500* *
35501 DATA SANPEL/
35502 & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, 50.D0,
35503 & 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
35504 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0, .05D0,
35505 & .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
35506 & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
35507 & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
35508 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, .25D0,
35509 & .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
35510 & .01D0, .008D0, .006D0, .005D0 /
35511 DATA SPIKPF/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
35512 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
35513 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
35514 & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35515 & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
35516 & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
35517 & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
35518 & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35519 & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35520 & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35521 & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
35522 & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
35523 & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
35524 & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
35525**** ko - n - data *
35526 DATA SPKP15/0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, 7.D0,
35527 & 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
35528 & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 10*0.D0,
35529 & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
35530 & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
35531 & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
35532 & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
35533 & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0,
35534 & 1.4D0, 1.2D0, 1.05D0, .9D0, .66D0, .5D0,
35535 & 7*0.D0, .3D0, 1.D0, 1.D0, .9D0, .7D0, .4D0, .30D0, .2D0,
35536 & 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.20D0, 4.55D0,
35537 & 4.85D0, 4.9D0,
35538 & 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, 1.6D0,
35539 & 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, 3.5D0,
35540 & 2.85D0, 2.35D0, 2.01D0, 1.8D0,
35541 & 12*0.D0, .1D0, .8D0, 2.05D0, 3.31D0, 3.5D0,
35542 & 12*0.D0, .034D0, .20D0, .75D0, 1.04D0, 1.24D0 /
35543**** ako - p - data *
35544 DATA SPKP16/ 0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
35545 & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, 0.D0,
35546 & 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, 1.9D0, .9D0, .5D0,
35547 & .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, 0.D0, 1.8D0, 2.D0, 1.1D0,
35548 & .9D0, .5D0, .5D0, .4D0, .4D0, .2D0, .1D0, .06D0, .05D0, .04D0,
35549 & .03D0, .02D0, .02D0, 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0,
35550 & .7D0, .65D0, .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0,
35551 & .03D0, 0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
35552 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0,
35553 & 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0,
35554 & 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0,
35555 & 1.01D0, .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0,
35556 & 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0,
35557 & .5D0, .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
35558 & .45D0, .39D0, .22D0, .07D0, 7*0.D0, 1.71D0, 4.26D0, 5.6D0,5.57D0,
35559 & 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0,
35560 & .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0,
35561 & .3D0, .7D0, 1.D0, 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0,
35562 & 1.72D0, 2.69D0, 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 5*0.D0,
35563 & 9.2D0, 4.7D0, 1.9D0, 9*0.D0, .0D0,2.5D0,15.D0,
35564 & 21.5D0, 15.3D0, 3.D0, 1.5D0, 10*0.D0 /
35565 DATA NURELN/9, 12, 5*0, 10, 14, 3*0, 1, 3, 5, 7, 6*0, 2, 6, 16,
35566 & 5*0, 10, 13, 5*0, 11, 12, 3*0, 2, 4, 6, 8, 6*0, 3, 15, 7, 5*0 /
35567*= end*block.blkdt3 *
35568 END
35569
35570*$ CREATE DT_QEL_POL.FOR
35571*COPY DT_QEL_POL
35572*
35573*===qel_pol============================================================*
35574*
35575 SUBROUTINE DT_QEL_POL(ENU,LTYP,P21,P22,P23,P24,P25)
35576
35577 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35578 SAVE
35579
35580 CALL DT_MASS_INI
35581 CALL DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
35582
35583 RETURN
35584 END
35585
35586*$ CREATE DT_GEN_QEL.FOR
35587*COPY DT_GEN_QEL
35588C==================================================================
35589C Generation of a Quasi-Elastic neutrino scattering
35590C==================================================================
35591*
35592*===gen_qel============================================================*
35593*
35594 SUBROUTINE DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
35595
35596C...Generate a quasi-elastic neutrino/antineutrino
35597C. Interaction on a nuclear target
35598C. INPUT : LTYP = neutrino type (1,...,6)
35599C. ENU (GeV) = neutrino energy
35600C----------------------------------------------------
35601
35602 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35603 SAVE
35604
35605 PARAMETER ( LINP = 10 ,
35606 & LOUT = 6 ,
35607 & LDAT = 9 )
35608 PARAMETER (MAXLND=4000)
35609 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
35610* nuclear potential
35611 LOGICAL LFERMI
35612 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
35613 & EBINDP(2),EBINDN(2),EPOT(2,210),
35614 & ETACOU(2),ICOUL,LFERMI
35615* steering flags for qel neutrino scattering modules
35616 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
35617**sr - removed (not needed)
35618C COMMON /CBAD/ LBAD, NBAD
35619C COMMON /CNUC/ XMN,XMN2,PFERMI,EFERMI,EBIND,EB2,C0
35620**
35621
35622 DIMENSION PI(3),PO(3)
35623CJR+
35624 DATA ININU/0/
35625CJR-
35626C REAL*8 DBETA(3)
35627C REAL*8 MN(2), ML0(6), ML, ML2, MI, MI2, MF, MF2
35628 DIMENSION DBETA(3),DBETB(3),AMN(2),AML0(6)
35629 DATA AMN /0.93827231D0, 0.93956563D0/
35630 DATA AML0 /2*0.51100D-03,2*0.105659D0, 2*1.777D0/
35631 DATA INIPRI/0/
35632
35633C DATA PFERMI/0.22D0/
35634CGB+...Binding Energy
35635 DATA EBIND/0.008D0/
35636CGB-...
35637
35638 ININU=ININU+1
35639 IF(ININU.EQ.1)NDSIG=0
35640 LBAD = 0
35641 enu0=enu
35642c write(*,*) enu0
35643C...Lepton mass
35644 AML = AML0(LTYP) ! massa leptoni
35645 AML2 = AML**2 ! massa leptoni **2
35646C...Particle labels (LUND)
35647 N = 5
35648 K(1,1) = 21
35649 K(2,1) = 21
35650 K(3,1) = 21
35651 K(3,3) = 1
35652 K(4,1) = 1
35653 K(4,3) = 1
35654 K(5,1) = 1
35655 K(5,3) = 2
35656 K0 = (LTYP-1)/2 ! 2
35657 K1 = LTYP/2 ! 2
35658 KA = 12 + 2*K0 ! 16
35659 IS = -1 + 2*LTYP - 4*K1 ! -1 +10 -8 = 1
35660 K(1,2) = IS*KA
35661 K(4,2) = IS*(KA-1)
35662 K(3,2) = IS*24
35663 LNU = 2 - LTYP + 2*K1 ! 2 - 5 + 2 = - 1
35664 IF (LNU .EQ. 2) THEN
35665 K(2,2) = 2212
35666 K(5,2) = 2112
35667 AMI = AMN(1)
35668 AMF = AMN(2)
35669CJR+
35670 PFERMI=PFERMN(2)
35671CJR-
35672 ELSE
35673 K(2,2) = 2112
35674 K(5,2) = 2212
35675 AMI = AMN(2)
35676 AMF = AMN(1)
35677CJR+
35678 PFERMI=PFERMP(2)
35679CJR-
35680 ENDIF
35681 AMI2 = AMI**2
35682 AMF2 = AMF**2
35683
35684 DO IGB=1,5
35685 P(3,IGB) = 0.
35686 P(4,IGB) = 0.
35687 P(5,IGB) = 0.
35688 END DO
35689
35690 NTRY = 0
35691CGB+...
35692 EFMAX = SQRT(PFERMI**2 + AMI2) -AMI ! max. Fermi Energy
35693 ENWELL = EFMAX + EBIND ! depth of nuclear potential well
35694CGB-...
35695
35696 100 CONTINUE
35697
35698C...4-momentum initial lepton
35699 P(1,5) = 0. ! massa
35700 P(1,4) = ENU0 ! energia
35701 P(1,1) = 0. ! px
35702 P(1,2) = 0. ! py
35703 P(1,3) = ENU0 ! pz
35704
35705C PF = PFERMI*PYR(0)**(1./3.)
35706c write(23,*) PYR(0)
35707c write(*,*) 'Pfermi=',PF
35708c PF = 0.
35709 NTRY=NTRY+1
35710C IF(ntry.GT.2) WRITE(*,*) ntry,enu0,k2
35711 IF (NTRY .GT. 500) THEN
35712 LBAD = 1
35713 WRITE (LOUT,1001) NBAD, ENU
35714 RETURN
35715 ENDIF
35716C CT = -1. + 2.*PYR(0)
35717c CT = -1.
35718C ST = SQRT(1.-CT*CT)
35719C F = 2.*3.1415926*PYR(0)
35720c F = 0.
35721
35722C P(2,4) = SQRT(PF*PF + MI2) - EBIND ! energia
35723C P(2,1) = PF*ST*COS(F) ! px
35724C P(2,2) = PF*ST*SIN(F) ! py
35725C P(2,3) = PF*CT ! pz
35726C P(2,5) = SQRT(P(2,4)**2-PF*PF) ! massa
35727 P(2,1) = P21
35728 P(2,2) = P22
35729 P(2,3) = P23
35730 P(2,4) = P24
35731 P(2,5) = P25
35732 beta1=-p(2,1)/p(2,4)
35733 beta2=-p(2,2)/p(2,4)
35734 beta3=-p(2,3)/p(2,4)
35735 N=2
35736C WRITE(6,*)' before transforming into target rest frame'
35737 CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
35738C print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
35739 N=5
35740
35741 phi11=atan(p(1,2)/p(1,3))
35742 pi(1)=p(1,1)
35743 pi(2)=p(1,2)
35744 pi(3)=p(1,3)
35745
35746 CALL DT_TESTROT(PI,Po,PHI11,1)
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 phi12=atan(p(1,1)/p(1,3))
35755
35756 pi(1)=p(1,1)
35757 pi(2)=p(1,2)
35758 pi(3)=p(1,3)
35759 CALL DT_TESTROT(Pi,Po,PHI12,2)
35760 DO ll=1,3
35761 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35762 END DO
35763c WRITE(*,*) po
35764 p(1,1)=po(1)
35765 p(1,2)=po(2)
35766 p(1,3)=po(3)
35767
35768 enu=p(1,4)
35769
35770C...Kinematical limits in Q**2
35771c S = P(2,5)**2 + 2.*ENU*(P(2,4)-P(2,3)) ! ????
35772 S = P(2,5)**2 + 2.*ENU*P(2,5)
35773 SQS = SQRT(S) ! E centro massa
35774 IF (SQS .LT. (AML + AMF + 3.E-03)) GOTO 100
35775 ELF = (S-AMF2+AML2)/(2.*SQS) ! energia leptone finale p
35776 PSTAR = (S-P(2,5)**2)/(2.*SQS) ! p* neutrino nel c.m.
35777 PLF = SQRT(ELF**2-AML2) ! 3-momento leptone finale
35778 Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF) ! + o -
35779 Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF) ! according con cos(theta)
35780 IF (Q2MIN .LT. 0.) Q2MIN = 0. ! ??? non fisico
35781
35782C...Generate Q**2
35783 DSIGMAX = DT_DSQEL_Q2 (LTYP,ENU, Q2MIN)
35784 200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
35785 DSIG = DT_DSQEL_Q2 (LTYP,ENU, Q2)
35786 IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200
35787 CALL DT_QGAUS(Q2MIN,Q2MAX,DSIGEV,ENU,LTYP)
35788 NDSIG=NDSIG+1
35789C WRITE(6,*)' Q2,Q2min,Q2MAX,DSIGEV',
35790C &Q2,Q2min,Q2MAX,DSIGEV
35791
35792C...c.m. frame. Neutrino along z axis
35793 DETOT = (P(1,4)) + (P(2,4)) ! e totale
35794 DBETA(1) = ((P(1,1)) + (P(2,1)))/DETOT ! px1+px2/etot = beta_x
35795 DBETA(2) = ((P(1,2)) + (P(2,2)))/DETOT !
35796 DBETA(3) = ((P(1,3)) + (P(2,3)))/DETOT !
35797c WRITE(*,*)
35798c WRITE(*,*)
35799C WRITE(*,*) 'Input values laboratory frame'
35800 N=2
35801
35802 CALL PYROBO(0,0,0.0D0,0.0D0,-DBETA(1),-DBETA(2),-DBETA(3))
35803
35804 N=5
35805c STHETA = ULANGL(P(1,3),P(1,1))
35806c write(*,*) 'stheta' ,stheta
35807c stheta=0.
35808c CALL PYROBO (0,0,-STHETA,0.,0.D0,0.D0,0.D0)
35809c WRITE(*,*)
35810c WRITE(*,*)
35811C WRITE(*,*) 'Output values cm frame'
35812C...Kinematic in c.m. frame
35813 CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) ! cos(theta) cm
35814 STSTAR = SQRT(1.-CTSTAR**2)
35815 PHI = 6.28319*PYR(0) ! random phi tra 0 e 2*pi
35816 P(4,5) = AML ! massa leptone
35817 P(4,4) = ELF ! e leptone
35818 P(4,3) = PLF*CTSTAR ! px
35819 P(4,1) = PLF*STSTAR*COS(PHI) ! py
35820 P(4,2) = PLF*STSTAR*SIN(PHI) ! pz
35821
35822 P(5,5) = AMF ! barione
35823 P(5,4) = (S+AMF2-AML2)/(2.*SQS)! e barione
35824 P(5,3) = -P(4,3) ! px
35825 P(5,1) = -P(4,1) ! py
35826 P(5,2) = -P(4,2) ! pz
35827
35828 P(3,5) = -Q2
35829 P(3,1) = P(1,1)-P(4,1)
35830 P(3,2) = P(1,2)-P(4,2)
35831 P(3,3) = P(1,3)-P(4,3)
35832 P(3,4) = P(1,4)-P(4,4)
35833
35834C...Transform back to laboratory frame
35835C WRITE(*,*) 'before going back to nucl rest frame'
35836c CALL PYROBO (0,0,STHETA,0.,0.D0,0.D0,0.D0)
35837 N=5
35838
35839 CALL PYROBO(0,0,0.0D0,0.0D0,DBETA(1),DBETA(2),DBETA(3))
35840
35841C WRITE(*,*) 'Now back in nucl rest frame'
35842 IF(LTYP.GE.3) CALL DT_PREPOLA(Q2,LTYP,ENU)
35843
35844c********************************************
35845
35846 DO kw=1,5
35847 pi(1)=p(kw,1)
35848 pi(2)=p(kw,2)
35849 pi(3)=p(kw,3)
35850 CALL DT_TESTROT(Pi,Po,PHI12,3)
35851 DO ll=1,3
35852 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35853 END DO
35854 p(kw,1)=po(1)
35855 p(kw,2)=po(2)
35856 p(kw,3)=po(3)
35857 END DO
35858c********************************************
35859
35860 DO kw=1,5
35861 pi(1)=p(kw,1)
35862 pi(2)=p(kw,2)
35863 pi(3)=p(kw,3)
35864 CALL DT_TESTROT(Pi,Po,PHI11,4)
35865 DO ll=1,3
35866 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35867 END DO
35868 p(kw,1)=po(1)
35869 p(kw,2)=po(2)
35870 p(kw,3)=po(3)
35871 END DO
35872
35873c********************************************
35874
35875C WRITE(*,*) 'Now back in lab frame'
35876
35877 CALL PYROBO(1,5,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
35878
35879CGB+...
35880C...test (on final momentum of nucleon) if Fermi-blocking
35881C...is operating
35882 ENUCL = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2 + P(5,5)**2)
35883 & - P(5,5)
35884 IF (ENUCL.LT. EFMAX) THEN
35885 IF(INIPRI.LT.10)THEN
35886 INIPRI=INIPRI+1
35887C WRITE(6,*)' qel: Pauli ENUCL.LT.EFMAX ', ENUCL,EFMAX
35888C...the interaction is not possible due to Pauli-Blocking and
35889C...it must be resampled
35890 ENDIF
35891 GOTO 100
35892 ELSE IF (ENUCL.LT.ENWELL.and.ENUCL.GE.EFMAX) THEN
35893 IF(INIPRI.LT.10)THEN
35894 INIPRI=INIPRI+1
35895C WRITE(6,*)' qel: inside ENUCL.LT.ENWELL ', ENUCL,ENWELL
35896 ENDIF
35897C Reject (J:R) here all these events
35898C are otherwise rejected in dpmjet
35899 GOTO 100
35900C...the interaction is possible, but the nucleon remains inside
35901C...the nucleus. The nucleus is therefore left excited.
35902C...We treat this case as a nucleon with 0 kinetic energy.
35903C P(5,5) = AMF
35904C P(5,4) = AMF
35905C P(5,1) = 0.
35906C P(5,2) = 0.
35907C P(5,3) = 0.
35908 ELSE IF (ENUCL.GE.ENWELL) THEN
35909C WRITE(6,*)' qel ENUCL.GE.ENWELL ',ENUCL,ENWELL
35910C...the interaction is possible, the nucleon can exit the nucleus
35911C...but the nuclear well depth must be subtracted. The nucleus could be
35912C...left in an excited state.
35913 Pstart = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2)
35914C P(5,4) = ENUCL-ENWELL + AMF
35915 Pnucl = SQRT(P(5,4)**2-AMF**2)
35916C...The 3-momentum is scaled assuming that the direction remains
35917C...unaffected
35918 P(5,1) = P(5,1) * Pnucl/Pstart
35919 P(5,2) = P(5,2) * Pnucl/Pstart
35920 P(5,3) = P(5,3) * Pnucl/Pstart
35921C WRITE(6,*)' qel new P(5,4) ',P(5,4)
35922 ENDIF
35923CGB-...
35924 DSIGSU=DSIGSU+DSIGEV
35925
35926 GA=P(4,4)/P(4,5)
35927 BGX=P(4,1)/P(4,5)
35928 BGY=P(4,2)/P(4,5)
35929 BGZ=P(4,3)/P(4,5)
35930*
35931 DBETB(1)=BGX/GA
35932 DBETB(2)=BGY/GA
35933 DBETB(3)=BGZ/GA
35934 IF(NEUDEC.EQ.1.OR.NEUDEC.EQ.2) THEN
35935
35936 CALL PYROBO(6,8,0.0D0,0.0D0,DBETB(1),DBETB(2),DBETB(3))
35937
35938 ENDIF
35939c
35940C PRINT*,' FINE EVENTO '
35941 enu=enu0
35942 RETURN
35943
35944 1001 FORMAT(2X, 'DT_GEN_QEL : event rejected ', I5, G10.3)
35945 END
35946
35947*$ CREATE DT_MASS_INI.FOR
35948*COPY DT_MASS_INI
35949C====================================================================
35950C. Masses
35951C====================================================================
35952*
35953*===mass_ini===========================================================*
35954*
35955 SUBROUTINE DT_MASS_INI
35956C...Initialize the kinematics for the quasi-elastic cross section
35957
35958 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35959 SAVE
35960
35961* particle masses used in qel neutrino scattering modules
35962 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
35963 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
35964 & EMPROTSQ,EMNEUTSQ,EMNSQ
35965
35966 EML(1) = 0.51100D-03 ! e-
35967 EML(2) = EML(1) ! e+
35968 EML(3) = 0.105659D0 ! mu-
35969 EML(4) = EML(3) ! mu+
35970 EML(5) = 1.7777D0 ! tau-
35971 EML(6) = EML(5) ! tau+
35972 EMPROT = 0.93827231D0 ! p
35973 EMNEUT = 0.93956563D0 ! n
35974 EMPROTSQ = EMPROT**2
35975 EMNEUTSQ = EMNEUT**2
35976 EMN = (EMPROT + EMNEUT)/2.
35977 EMNSQ = EMN**2
35978 DO J=1,3
35979 J0 = 2*(J-1)
35980 EMN1(J0+1) = EMNEUT
35981 EMN1(J0+2) = EMPROT
35982 EMN2(J0+1) = EMPROT
35983 EMN2(J0+2) = EMNEUT
35984 ENDDO
35985 DO J=1,6
35986 EMLSQ(J) = EML(J)**2
35987 ETQE(J) = ((EMN2(J)+ EML(J))**2-EMN1(J)**2)/(2.*EMN1(J))
35988 ENDDO
35989 RETURN
35990 END
35991
35992*$ CREATE DT_DSQEL_Q2.FOR
35993*COPY DT_DSQEL_Q2
35994*
35995*===dsqel_q2===========================================================*
35996*
35997 DOUBLE PRECISION FUNCTION DT_DSQEL_Q2 (JTYP,ENU, Q2)
35998
35999C...differential cross section for Quasi-Elastic scattering
36000C. nu + N -> l + N'
36001C. From Llewellin Smith Phys.Rep. 3C, 261, (1971).
36002C.
36003C. INPUT : JTYP = 1,...,6 nu_e, ...., nubar_tau
36004C. ENU (GeV) = Neutrino energy
36005C. Q2 (GeV**2) = (Transfer momentum)**2
36006C.
36007C. OUTPUT : DSQEL_Q2 = differential cross section :
36008C. dsigma/dq**2 (10**-38 cm+2/GeV**2)
36009C------------------------------------------------------------------
36010
36011 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36012 SAVE
36013
36014* particle masses used in qel neutrino scattering modules
36015 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
36016 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
36017 & EMPROTSQ,EMNEUTSQ,EMNSQ
36018**sr - removed (not needed)
36019C COMMON /CAXIAL/ FA0, AXIAL2
36020**
36021
36022 DIMENSION SS(6)
36023 DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
36024 DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
36025 DATA AXIAL2 /1.03D0/ ! to be checked
36026
36027 FA0=-1.253D0
36028 CSI = 3.71D0 ! ???
36029 GVE = 1.D0/ (1.D0 + Q2/0.84D0**2)**2 ! G_e(q**2)
36030 GVM = (1.D0+CSI)*GVE ! G_m (q**2)
36031 X = Q2/(EMN*EMN) ! emn=massa barione
36032 XA = X/4.D0
36033 FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
36034 FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
36035 FA = FA0/(1.D0 + Q2/AXIAL2)**2
36036 FFA = FA*FA
36037 FFV1 = FV1*FV1
36038 FFV2 = FV2*FV2
36039 RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp)
36040 A1 = (4.D0+X)*FFA - (4.D0-X)*FFV1 + X*FFV2*(1.D0-XA)+4*X*FV1*FV2
36041 A2 = -RM * ((FV1 + FV2)**2 + FFA)
36042 AA = (XA+0.25D0*RM)*(A1 + A2)
36043 BB = -X*FA*(FV1 + FV2)
36044 CC = 0.25D0*(FFA + FFV1 + XA*FFV2)
36045 SU = (4.D0*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
36046 DT_DSQEL_Q2 = C0*(AA + SS(JTYP)*BB*SU + CC*SU*SU) / (ENU*ENU) !
36047 IF(DT_DSQEL_Q2 .LT. 0.D0) DT_DSQEL_Q2 = 0.D0
36048
36049 RETURN
36050 END
36051
36052*$ CREATE DT_PREPOLA.FOR
36053*COPY DT_PREPOLA
36054*
36055*===prepola============================================================*
36056*
36057 SUBROUTINE DT_PREPOLA(Q2,JTYP,ENU)
36058
36059 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36060 SAVE
36061c
36062c By G. Battistoni and E. Scapparone (sept. 1997)
36063c According to:
36064c Albright & Jarlskog, Nucl Phys B84 (1975) 467
36065c
36066c
36067 PARAMETER (MAXLND=4000)
36068 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
36069 COMMON /QNPOL/ POLARX(4),PMODUL
36070* particle masses used in qel neutrino scattering modules
36071 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
36072 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
36073 & EMPROTSQ,EMNEUTSQ,EMNSQ
36074* steering flags for qel neutrino scattering modules
36075 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
36076**sr - removed (not needed)
36077C COMMON /CAXIAL/ FA0, AXIAL2
36078C COMMON /TAUTAU/Q(4,5),ETL,PXL,PYL,PZL,
36079C & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN
36080**
36081 REAL*8 POL(4,4),BB2(3)
36082 DIMENSION SS(6)
36083C DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
36084 DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
36085**sr uncommented since common block CAXIAL is now commented
36086 DATA AXIAL2 /1.03D0/ ! to be checked
36087**
36088
36089 RML=P(4,5)
36090 RMM=0.93960D+00
36091 FM2 = RMM**2
36092 MPI = 0.135D+00
36093 OLDQ2=Q2
36094 FA0=-1.253D+00
36095 CSI = 3.71D+00 !
36096 GVE = 1.D0/ (1.D0 + Q2/(0.84D+00)**2)**2 ! G_e(q**2)
36097 GVM = (1.D0+CSI)*GVE ! G_m (q**2)
36098 X = Q2/(EMN*EMN) ! emn=massa barione
36099 XA = X/4.D0
36100 FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
36101 FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
36102 FA = FA0/(1.D0 + Q2/AXIAL2**2)**2
36103 FFA = FA*FA
36104 FFV1 = FV1*FV1
36105 FFV2 = FV2*FV2
36106 FP=2.D0*FA*RMM/(MPI**2 + Q2)
36107 RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp)
36108 A1 = (4.D0+X)*FFA-(4.D0-X)*FFV1+X*FFV2*(1.D0-XA)+4.D0*X*FV1*FV2
36109 A2 = -RM * ((FV1 + FV2)**2 + FFA)
36110 AA = (XA+0.25D+00*RM)*(A1 + A2)
36111 BB = -X*FA*(FV1 + FV2)
36112 CC = 0.25D+00*(FFA + FFV1 + XA*FFV2)
36113 SU = (4.D+00*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
36114
36115 OMEGA1=FFA+XA*(FFA+(FV1+FV2)**2 ) ! articolo di ll...-smith
36116 OMEGA2=4.D+00*CC
36117 OMEGA3=2.D+00*FA*(FV1+FV2)
36118 OMEGA4P=(-(FV1+FV2)**2-(FA+2*FP)**2+(4.0D+00+
36119 1 (Q2/FM2))*FP**2)
36120 OMEGA5=OMEGA2
36121 OMEGA4=(OMEGA4P-OMEGA2+2*OMEGA5)/4.D+00
36122 WW1=2.D+00*OMEGA1*EMN**2
36123 WW2=2.D+00*OMEGA2*EMN**2
36124 WW3=2.D+00*OMEGA3*EMN**2
36125 WW4=2.D+00*OMEGA4*EMN**2
36126 WW5=2.D+00*OMEGA5*EMN**2
36127
36128 DO I=1,3
36129 BB2(I)=-P(4,I)/P(4,4)
36130 END DO
36131c WRITE(*,*)
36132c WRITE(*,*)
36133c WRITE(*,*) 'Prepola: ready to transform to lepton rest frame'
36134 N=5
36135 CALL PYROBO(0,0,0.0D0,0.0D0,BB2(1),BB2(2),BB2(3))
36136* NOW PARTICLES ARE IN THE SCATTERED LEPTON REST FRAME
36137c WRITE(*,*)
36138c WRITE(*,*)
36139c WRITE(*,*) 'Prepola: now in lepton rest frame'
36140 EE=ENU
36141 QM2=Q2+RML**2
36142 U=Q2/(2.*RMM)
36143 FRAC=QM2*WW1 + (2.D+00*EE*(EE-U) - 0.5D+00*QM2)*WW2 - SS(JTYP)*
36144 + (0.5D+00/(RMM**2))*(2.D+00*RMM*EE*Q2 - U*QM2)*WW3 +
36145 + ((RML**2)/(2.D+00*FM2))*(QM2*WW4-2.D+00*RMM*EE*WW5) !<=FM2 inv di RMM!!
36146
36147 FACTK=2.D+00*WW1 -WW2 -SS(JTYP)*(EE/RMM)*WW3 +((EE-U)/RMM)*WW5
36148 + - ((RML**2)/FM2)*WW4 !<=FM2 inv di RMM!!
36149
36150 FACTP=2.D+00*EE/RMM*WW2 - (QM2/(2.D+00*RMM**2))*(SS(JTYP)*WW3+WW5)
36151
36152 DO I=1,3
36153 POL(4,I)=RML*SS(JTYP)*(FACTK*P(1,I)+FACTP*P(2,I))/FRAC
36154 POLARX(I)=POL(4,I)
36155 END DO
36156
36157 PMODUL=0.D0
36158 DO I=1,3
36159 PMODUL=PMODUL+POL(4,I)**2
36160 END DO
36161
36162 IF(JTYP.GT.4.AND.NEUDEC.GT.0) THEN
36163 IF(NEUDEC.EQ.1) THEN
36164 CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-2),POLARX(3),
36165 + ETL,PXL,PYL,PZL,
36166 + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
36167c
36168c Tau has decayed in muon
36169c
36170 ENDIF
36171 IF(NEUDEC.EQ.2) THEN
36172 CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-4),POLARX(3),
36173 + ETL,PXL,PYL,PZL,
36174 + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
36175c
36176c Tau has decayed in electron
36177c
36178 ENDIF
36179 K(4,1)=15
36180 K(4,4) = 6
36181 K(4,5) = 8
36182 N=N+3
36183c
36184c fill common for muon(electron)
36185c
36186 P(6,1)=PXL
36187 P(6,2)=PYL
36188 P(6,3)=PZL
36189 P(6,4)=ETL
36190 K(6,1)=1
36191 IF(JTYP.EQ.5) THEN
36192 IF(NEUDEC.EQ.1) THEN
36193 P(6,5)=EML(JTYP-2)
36194 K(6,2)=13
36195 ELSEIF(NEUDEC.EQ.2) THEN
36196 P(6,5)=EML(JTYP-4)
36197 K(6,2)=11
36198 ENDIF
36199 ELSEIF(JTYP.EQ.6) THEN
36200 IF(NEUDEC.EQ.1) THEN
36201 K(6,2)=-13
36202 ELSEIF(NEUDEC.EQ.2) THEN
36203 K(6,2)=-11
36204 ENDIF
36205 END IF
36206 K(6,3)=4
36207 K(6,4)=0
36208 K(6,5)=0
36209c
36210c fill common for tau_(anti)neutrino
36211c
36212 P(7,1)=PXB
36213 P(7,2)=PYB
36214 P(7,3)=PZB
36215 P(7,4)=ETB
36216 P(7,5)=0.
36217 K(7,1)=1
36218 IF(JTYP.EQ.5) THEN
36219 K(7,2)=16
36220 ELSEIF(JTYP.EQ.6) THEN
36221 K(7,2)=-16
36222 END IF
36223 K(7,3)=4
36224 K(7,4)=0
36225 K(7,5)=0
36226c
36227c Fill common for muon(electron)_(anti)neutrino
36228c
36229 P(8,1)=PXN
36230 P(8,2)=PYN
36231 P(8,3)=PZN
36232 P(8,4)=ETN
36233 P(8,5)=0.
36234 K(8,1)=1
36235 IF(JTYP.EQ.5) THEN
36236 IF(NEUDEC.EQ.1) THEN
36237 K(8,2)=-14
36238 ELSEIF(NEUDEC.EQ.2) THEN
36239 K(8,2)=-12
36240 ENDIF
36241 ELSEIF(JTYP.EQ.6) THEN
36242 IF(NEUDEC.EQ.1) THEN
36243 K(8,2)=14
36244 ELSEIF(NEUDEC.EQ.2) THEN
36245 K(8,2)=12
36246 ENDIF
36247 END IF
36248 K(8,3)=4
36249 K(8,4)=0
36250 K(8,5)=0
36251 ENDIF
36252c WRITE(*,*)
36253c WRITE(*,*)
36254
36255c IF(PMODUL.GE.1.D+00) THEN
36256c WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
36257c write(*,*) pmodul
36258c DO I=1,3
36259c POL(4,I)=POL(4,I)/PMODUL
36260c POLARX(I)=POL(4,I)
36261c END DO
36262c PMODUL=0.
36263c DO I=1,3
36264c PMODUL=PMODUL+POL(4,I)**2
36265c END DO
36266c WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
36267c
36268c ENDIF
36269
36270c WRITE(*,*) 'PMODUL = ',PMODUL
36271
36272c WRITE(*,*)
36273c WRITE(*,*)
36274c WRITE(*,*) 'prepola: Now back to nucl rest frame'
36275 CALL PYROBO(1,5,0.0D0,0.0D0,-BB2(1),-BB2(2),-BB2(3))
36276
36277 XDC = V(4,1)+V(4,5)*P(4,1)/P(4,5)
36278 YDC = V(4,2)+V(4,5)*P(4,2)/P(4,5)
36279 ZDC = V(4,3)+V(4,5)*P(4,3)/P(4,5)
36280 DO NDC =6,8
36281 V(NDC,1) = XDC
36282 V(NDC,2) = YDC
36283 V(NDC,3) = ZDC
36284 END DO
36285
36286 RETURN
36287 END
36288
36289*$ CREATE DT_TESTROT.FOR
36290*COPY DT_TESTROT
36291*
36292*===testrot============================================================*
36293*
36294 SUBROUTINE DT_TESTROT(PI,PO,PHI,MODE)
36295
36296 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36297 SAVE
36298
36299 DIMENSION ROT(3,3),PI(3),PO(3)
36300
36301 IF (MODE.EQ.1) THEN
36302 ROT(1,1) = 1.D0
36303 ROT(1,2) = 0.D0
36304 ROT(1,3) = 0.D0
36305 ROT(2,1) = 0.D0
36306 ROT(2,2) = COS(PHI)
36307 ROT(2,3) = -SIN(PHI)
36308 ROT(3,1) = 0.D0
36309 ROT(3,2) = SIN(PHI)
36310 ROT(3,3) = COS(PHI)
36311 ELSEIF (MODE.EQ.2) THEN
36312 ROT(1,1) = 0.D0
36313 ROT(1,2) = 1.D0
36314 ROT(1,3) = 0.D0
36315 ROT(2,1) = COS(PHI)
36316 ROT(2,2) = 0.D0
36317 ROT(2,3) = -SIN(PHI)
36318 ROT(3,1) = SIN(PHI)
36319 ROT(3,2) = 0.D0
36320 ROT(3,3) = COS(PHI)
36321 ELSEIF (MODE.EQ.3) THEN
36322 ROT(1,1) = 0.D0
36323 ROT(2,1) = 1.D0
36324 ROT(3,1) = 0.D0
36325 ROT(1,2) = COS(PHI)
36326 ROT(2,2) = 0.D0
36327 ROT(3,2) = -SIN(PHI)
36328 ROT(1,3) = SIN(PHI)
36329 ROT(2,3) = 0.D0
36330 ROT(3,3) = COS(PHI)
36331 ELSEIF (MODE.EQ.4) THEN
36332 ROT(1,1) = 1.D0
36333 ROT(2,1) = 0.D0
36334 ROT(3,1) = 0.D0
36335 ROT(1,2) = 0.D0
36336 ROT(2,2) = COS(PHI)
36337 ROT(3,2) = -SIN(PHI)
36338 ROT(1,3) = 0.D0
36339 ROT(2,3) = SIN(PHI)
36340 ROT(3,3) = COS(PHI)
36341 ELSE
36342 STOP ' TESTROT: mode not supported!'
36343 ENDIF
36344 DO 1 J=1,3
36345 PO(J) = ROT(J,1)*PI(1)+ROT(J,2)*PI(2)+ROT(J,3)*PI(3)
36346 1 CONTINUE
36347
36348 RETURN
36349 END
36350
36351*$ CREATE DT_LEPDCYP.FOR
36352*COPY DT_LEPDCYP
36353*
36354*===lepdcyp============================================================*
36355*
36356 SUBROUTINE DT_LEPDCYP(AMA,AML,POL,ETL,PXL,PYL,PZL,
36357 & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
36358C
36359C-----------------------------------------------------------------
36360C
36361C Author :- G. Battistoni 10-NOV-1995
36362C
36363C=================================================================
36364C
36365C Purpose : performs decay of polarized lepton in
36366C its rest frame: a => b + l + anti-nu
36367C (Example: mu- => nu-mu + e- + anti-nu-e)
36368C Polarization is assumed along Z-axis
36369C WARNING:
36370C 1) b AND anti-nu ARE ASSUMED TO BE NEUTRINOS
36371C OF NEGLIGIBLE MASS
36372C 2) RADIATIVE CORRECTIONS ARE NOT CONSIDERED
36373C IN THIS VERSION
36374C
36375C Method : modifies phase space distribution obtained
36376C by routine EXPLOD using a rejection against the
36377C matrix element for unpolarized lepton decay
36378C
36379C Inputs : Mass of a : AMA
36380C Mass of l : AML
36381C Polar. of a: POL
36382C (Example: fully polar. mu- decay: AMA=AMMUON, AML=AMELCT,
36383C POL = -1)
36384C
36385C Outputs : kinematic variables in the rest frame of decaying lepton
36386C ETL,PXL,PYL,PZL 4-moment of l
36387C ETB,PXB,PYB,PZB 4-moment of b
36388C ETN,PXN,PYN,PZN 4-moment of anti-nu
36389C
36390C============================================================
36391C +
36392C Declarations.
36393C -
36394 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36395 SAVE
36396
36397 PARAMETER ( LINP = 10 ,
36398 & LOUT = 6 ,
36399 & LDAT = 9 )
36400 PARAMETER ( KALGNM = 2 )
36401 PARAMETER ( ANGLGB = 5.0D-16 )
36402 PARAMETER ( ANGLSQ = 2.5D-31 )
36403 PARAMETER ( AXCSSV = 0.2D+16 )
36404 PARAMETER ( ANDRFL = 1.0D-38 )
36405 PARAMETER ( AVRFLW = 1.0D+38 )
36406 PARAMETER ( AINFNT = 1.0D+30 )
36407 PARAMETER ( AZRZRZ = 1.0D-30 )
36408 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
36409 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
36410 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
36411 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
36412 PARAMETER ( CSNNRM = 2.0D-15 )
36413 PARAMETER ( DMXTRN = 1.0D+08 )
36414 PARAMETER ( ZERZER = 0.D+00 )
36415 PARAMETER ( ONEONE = 1.D+00 )
36416 PARAMETER ( TWOTWO = 2.D+00 )
36417 PARAMETER ( THRTHR = 3.D+00 )
36418 PARAMETER ( FOUFOU = 4.D+00 )
36419 PARAMETER ( FIVFIV = 5.D+00 )
36420 PARAMETER ( SIXSIX = 6.D+00 )
36421 PARAMETER ( SEVSEV = 7.D+00 )
36422 PARAMETER ( EIGEIG = 8.D+00 )
36423 PARAMETER ( ANINEN = 9.D+00 )
36424 PARAMETER ( TENTEN = 10.D+00 )
36425 PARAMETER ( HLFHLF = 0.5D+00 )
36426 PARAMETER ( ONETHI = ONEONE / THRTHR )
36427 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
36428 PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
36429 PARAMETER ( ENEPER = 2.7182818284590452354 D+00 )
36430 PARAMETER ( SQRENT = 1.6487212707001281468 D+00 )
36431 PARAMETER ( CLIGHT = 2.99792458 D+10 )
36432 PARAMETER ( AVOGAD = 6.0221367 D+23 )
36433 PARAMETER ( AMELGR = 9.1093897 D-28 )
36434 PARAMETER ( PLCKBR = 1.05457266 D-27 )
36435 PARAMETER ( ELCCGS = 4.8032068 D-10 )
36436 PARAMETER ( ELCMKS = 1.60217733 D-19 )
36437 PARAMETER ( AMUGRM = 1.6605402 D-24 )
36438 PARAMETER ( AMMUMU = 0.113428913 D+00 )
36439 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
36440 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
36441 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
36442 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
36443 PARAMETER ( PLABRC = 0.197327053 D+00 )
36444 PARAMETER ( AMELCT = 0.51099906 D-03 )
36445 PARAMETER ( AMUGEV = 0.93149432 D+00 )
36446 PARAMETER ( AMMUON = 0.105658389 D+00 )
36447 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
36448 PARAMETER ( GEVMEV = 1.0 D+03 )
36449 PARAMETER ( EMVGEV = 1.0 D-03 )
36450 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
36451 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
36452 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
36453C +
36454C variables for EXPLOD
36455C -
36456 PARAMETER ( KPMX = 10 )
36457 DIMENSION AMEXPL (KPMX), PXEXPL (KPMX), PYEXPL (KPMX),
36458 & PZEXPL (KPMX), ETEXPL (KPMX)
36459C +
36460C test variables
36461C -
36462**sr - removed (not needed)
36463C COMMON /GBATNU/ ELERAT,NTRY
36464**
36465C +
36466C Initializes test variables
36467C -
36468 NTRY = 0
36469 ELERAT = 0.D+00
36470C +
36471C Maximum value for matrix element
36472C -
36473 ELEMAX = ( AMA**2 + AML**2 )**2 / AMA**2 * ( AMA**2 - AML**2 +
36474 & SQRT( AMA**4 + AML**4 - 3.D+00 * AMA**2 * AML**2 ) )
36475C + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
36476C Inputs for EXPLOD
36477C part. no. 1 is l (e- in mu- decay)
36478C part. no. 2 is b (nu-mu in mu- decay)
36479C part. no. 3 is anti-nu (anti-nu-e in mu- decay)
36480C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
36481 NPEXPL = 3
36482 ETOTEX = AMA
36483 AMEXPL(1) = AML
36484 AMEXPL(2) = 0.D+00
36485 AMEXPL(3) = 0.D+00
36486C +
36487C phase space distribution
36488C -
36489 100 CONTINUE
36490 NTRY = NTRY + 1
36491
36492 CALL DT_EXPLOD ( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
36493 & PYEXPL, PZEXPL )
36494
36495C +
36496C Calculates matrix element:
36497C 64*GF**2{[P(a)-ama*S(a)]*P(anti-nu)}{P(l)*P(b)}
36498C Here CTH is the cosine of the angle between anti-nu and Z axis
36499C -
36500 CTH = PZEXPL(3) / SQRT ( PXEXPL(3)**2 + PYEXPL(3)**2 +
36501 & PZEXPL(3)**2 )
36502 PROD1 = ETEXPL(3) * AMA * (1.D+00 - POL * CTH)
36503 PROD2 = ETEXPL(1) * ETEXPL(2) - PXEXPL(1)*PXEXPL(2) -
36504 & PYEXPL(1)*PYEXPL(2) - PZEXPL(1)*PZEXPL(2)
36505 ELEMAT = 16.D+00 * PROD1 * PROD2
36506 IF(ELEMAT.GT.ELEMAX) THEN
36507 WRITE(LOUT,*) 'Problems in LEPDCY',ELEMAX,ELEMAT
36508 STOP
36509 ENDIF
36510C +
36511C Here performs the rejection
36512C -
36513 TEST = DT_RNDM(ETOTEX) * ELEMAX
36514 IF ( TEST .GT. ELEMAT ) GO TO 100
36515C +
36516C final assignment of variables
36517C -
36518 ELERAT = ELEMAT/ELEMAX
36519 ETL = ETEXPL(1)
36520 PXL = PXEXPL(1)
36521 PYL = PYEXPL(1)
36522 PZL = PZEXPL(1)
36523 ETB = ETEXPL(2)
36524 PXB = PXEXPL(2)
36525 PYB = PYEXPL(2)
36526 PZB = PZEXPL(2)
36527 ETN = ETEXPL(3)
36528 PXN = PXEXPL(3)
36529 PYN = PYEXPL(3)
36530 PZN = PZEXPL(3)
36531 999 RETURN
36532 END
36533
36534*$ CREATE DT_GEN_DELTA.FOR
36535*COPY DT_GEN_DELTA
36536C==================================================================
36537C. Generation of Delta resonance events
36538C==================================================================
36539*
36540*===gen_delta==========================================================*
36541*
36542 SUBROUTINE DT_GEN_DELTA(ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25)
36543
36544 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36545 SAVE
36546
36547 PARAMETER ( LINP = 10 ,
36548 & LOUT = 6 ,
36549 & LDAT = 9 )
36550C...Generate a Delta-production neutrino/antineutrino
36551C. CC-interaction on a nucleon
36552C
36553C. INPUT ENU (GeV) = Neutrino Energy
36554C. LLEP = neutrino type
36555C. LTARG = nucleon target type 1=p, 2=n.
36556C. JINT = 1:CC, 2::NC
36557C.
36558C. OUTPUT PPL(4) 4-monentum of final lepton
36559C----------------------------------------------------
36560 PARAMETER (MAXLND=4000)
36561 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
36562**sr - removed (not needed)
36563C COMMON /CBAD/ LBAD, NBAD
36564**
36565
36566 DIMENSION PI(3),PO(3)
36567C REAL*4 AMD0, AMD, AMN(2), AML0(6), AML, AML2, AMDMIN
36568 DIMENSION AML0(6),AMN(2)
36569 DATA AMD0 /1.231/, GAMD /0.12/, DELD/0.169/, AMDMIN/1.084/
36570 DATA AMN /0.93827231, 0.93956563/
36571 DATA AML0 /2*0.51100E-03,2*0.105659, 2*1.777/
36572
36573c WRITE(6,*)' GEN_DEL',ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25
36574 LBAD = 0
36575C...Final lepton mass
36576 IF (JINT.EQ.1) THEN
36577 AML = AML0(LLEP)
36578 ELSE
36579 AML = 0.
36580 ENDIF
36581 AML2 = AML**2
36582
36583C...Particle labels (LUND)
36584 N = 5
36585 K(1,1) = 21
36586 K(2,1) = 21
36587 K(3,1) = 21
36588 K(4,1) = 1
36589 K(3,3) = 1
36590 K(4,3) = 1
36591 IF (LTARG .EQ. 1) THEN
36592 K(2,2) = 2212
36593 ELSE
36594 K(2,2) = 2112
36595 ENDIF
36596 K0 = (LLEP-1)/2
36597 K1 = LLEP/2
36598 KA = 12 + 2*K0
36599 IS = -1 + 2*LLEP - 4*K1
36600 LNU = 2 - LLEP + 2*K1
36601 K(1,2) = IS*KA
36602 K(5,1) = 1
36603 K(5,3) = 2
36604 IF (JINT .EQ. 1) THEN ! CC interactions
36605 K(3,2) = IS*24
36606 K(4,2) = IS*(KA-1)
36607 IF(LNU.EQ.1) THEN
36608 IF (LTARG .EQ. 1) THEN
36609 K(5,2) = 2224
36610 ELSE
36611 K(5,2) = 2214
36612 ENDIF
36613 ELSE
36614 IF (LTARG .EQ. 1) THEN
36615 K(5,2) = 2114
36616 ELSE
36617 K(5,2) = 1114
36618 ENDIF
36619 ENDIF
36620 ELSE
36621 K(3,2) = 23 ! NC (Z0) interactions
36622 K(4,2) = K(1,2)
36623**sr 7.5.00: swop Delta's (bug), Delta+ for proton (LTARG=1),
36624* Delta0 for neutron (LTARG=2)
36625C IF (LTARG .EQ. 1) THEN
36626C K(5,2) = 2114
36627C ELSE
36628C K(5,2) = 2214
36629C ENDIF
36630 IF (LTARG .EQ. 1) THEN
36631 K(5,2) = 2214
36632 ELSE
36633 K(5,2) = 2114
36634 ENDIF
36635**
36636 ENDIF
36637
36638C...4-momentum initial lepton
36639 P(1,5) = 0.
36640 P(1,4) = ENU
36641 P(1,1) = 0.
36642 P(1,2) = 0.
36643 P(1,3) = ENU
36644C...4-momentum initial nucleon
36645 P(2,5) = AMN(LTARG)
36646C P(2,4) = P(2,5)
36647C P(2,1) = 0.
36648C P(2,2) = 0.
36649C P(2,3) = 0.
36650 P(2,1) = P21
36651 P(2,2) = P22
36652 P(2,3) = P23
36653 P(2,4) = P24
36654 P(2,5) = P25
36655 N=2
36656 beta1=-p(2,1)/p(2,4)
36657 beta2=-p(2,2)/p(2,4)
36658 beta3=-p(2,3)/p(2,4)
36659 N=2
36660
36661 CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
36662
36663C print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
36664
36665 phi11=atan(p(1,2)/p(1,3))
36666 pi(1)=p(1,1)
36667 pi(2)=p(1,2)
36668 pi(3)=p(1,3)
36669
36670 CALL DT_TESTROT(PI,Po,PHI11,1)
36671 DO ll=1,3
36672 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36673 END DO
36674 p(1,1)=po(1)
36675 p(1,2)=po(2)
36676 p(1,3)=po(3)
36677 phi12=atan(p(1,1)/p(1,3))
36678
36679 pi(1)=p(1,1)
36680 pi(2)=p(1,2)
36681 pi(3)=p(1,3)
36682 CALL DT_TESTROT(Pi,Po,PHI12,2)
36683 DO ll=1,3
36684 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36685 END DO
36686 p(1,1)=po(1)
36687 p(1,2)=po(2)
36688 p(1,3)=po(3)
36689
36690 ENUU=P(1,4)
36691
36692C...Generate the Mass of the Delta
36693 NTRY = 0
36694100 R = PYR(0)
36695 AMD=AMD0+0.5*GAMD*TAN((2.*R-1.)*ATAN(2.*DELD/GAMD))
36696 NTRY = NTRY + 1
36697 IF (NTRY .GT. 1000) THEN
36698 LBAD = 1
36699 WRITE (LOUT,1001) NBAD, ENUU,AMD,AMDMIN,AMD0,GAMD,ET
36700 RETURN
36701 ENDIF
36702 IF (AMD .LT. AMDMIN) GOTO 100
36703 ET = ((AMD+AML)**2 - AMN(LTARG)**2)/(2.*AMN(LTARG))
36704 IF (ENUU .LT. ET) GOTO 100
36705
36706C...Kinematical limits in Q**2
36707 S = AMN(LTARG)**2 + 2.*AMN(LTARG)*ENUU
36708 SQS = SQRT(S)
36709 PSTAR = (S - AMN(LTARG)**2)/(2.*SQS)
36710 ELF = (S - AMD**2 + AML2)/(2.*SQS)
36711 PLF = SQRT(ELF**2 - AML2)
36712 Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)
36713 Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)
36714 IF (Q2MIN .LT. 0.) Q2MIN = 0.
36715
36716 DSIGMAX = DT_DSIGMA_DELTA(LNU,-Q2MIN, S, AML, AMD)
36717200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
36718 DSIG = DT_DSIGMA_DELTA(LNU,-Q2, S, AML, AMD)
36719 IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200
36720
36721C...Generate the kinematics of the final particles
36722 EISTAR = (S + AMN(LTARG)**2)/(2.*SQS)
36723 GAM = EISTAR/AMN(LTARG)
36724 BET = PSTAR/EISTAR
36725 CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF)
36726 EL = GAM*(ELF + BET*PLF*CTSTAR)
36727 PLZ = GAM*(PLF*CTSTAR + BET*ELF)
36728 PL = SQRT(EL**2 - AML2)
36729 PLT = SQRT(MAX(1.D-06,(PL*PL - PLZ*PLZ)))
36730 PHI = 6.28319*PYR(0)
36731 P(4,1) = PLT*COS(PHI)
36732 P(4,2) = PLT*SIN(PHI)
36733 P(4,3) = PLZ
36734 P(4,4) = EL
36735 P(4,5) = AML
36736
36737C...4-momentum of Delta
36738 P(5,1) = -P(4,1)
36739 P(5,2) = -P(4,2)
36740 P(5,3) = ENUU-P(4,3)
36741 P(5,4) = ENUU+AMN(LTARG)-P(4,4)
36742 P(5,5) = AMD
36743
36744C...4-momentum of intermediate boson
36745 P(3,5) = -Q2
36746 P(3,4) = P(1,4)-P(4,4)
36747 P(3,1) = P(1,1)-P(4,1)
36748 P(3,2) = P(1,2)-P(4,2)
36749 P(3,3) = P(1,3)-P(4,3)
36750 N=5
36751
36752 DO kw=1,5
36753 pi(1)=p(kw,1)
36754 pi(2)=p(kw,2)
36755 pi(3)=p(kw,3)
36756 CALL DT_TESTROT(Pi,Po,PHI12,3)
36757 DO ll=1,3
36758 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36759 END DO
36760 p(kw,1)=po(1)
36761 p(kw,2)=po(2)
36762 p(kw,3)=po(3)
36763 END DO
36764
36765c********************************************
36766
36767 DO kw=1,5
36768 pi(1)=p(kw,1)
36769 pi(2)=p(kw,2)
36770 pi(3)=p(kw,3)
36771 CALL DT_TESTROT(Pi,Po,PHI11,4)
36772 DO ll=1,3
36773 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36774 END DO
36775 p(kw,1)=po(1)
36776 p(kw,2)=po(2)
36777 p(kw,3)=po(3)
36778 END DO
36779c********************************************
36780C transform back into Lab.
36781
36782 CALL PYROBO(0,0,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
36783
36784C WRITE(6,*)' Lab fram ( fermi incl.) '
36785 N=5
36786 CALL PYEXEC
36787
36788 RETURN
367891001 FORMAT(2X, 'DT_GEN_DELTA : event rejected ', I5, 6G10.3)
36790 END
36791
36792*$ CREATE DT_DSIGMA_DELTA.FOR
36793*COPY DT_DSIGMA_DELTA
36794*
36795*===dsigma_delta=======================================================*
36796*
36797 DOUBLE PRECISION FUNCTION DT_DSIGMA_DELTA (LNU, QQ, S, AML, MD)
36798
36799 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36800 SAVE
36801
36802C...Reaction nu + N -> lepton + Delta
36803C. returns the cross section
36804C. dsigma/dt
36805C. INPUT LNU = 1, 2 (neutrino-antineutrino)
36806C. QQ = t (always negative) GeV**2
36807C. S = (c.m energy)**2 GeV**2
36808C. OUTPUT = 10**-38 cm+2/GeV**2
36809C-----------------------------------------------------
36810 REAL*8 MN, MN2, MN4, MD,MD2, MD4
36811 DATA MN /0.938/
36812 DATA PI /3.1415926/
36813
36814 GF = (1.1664 * 1.97)
36815 GF2 = GF*GF
36816 MN2 = MN*MN
36817 MN4 = MN2*MN2
36818 MD2 = MD*MD
36819 MD4 = MD2*MD2
36820 AML2 = AML*AML
36821 AML4 = AML2*AML2
36822 VQ = (MN2 - MD2 - QQ)/2.
36823 VPI = (MN2 + MD2 - QQ)/2.
36824 VK = (S + QQ - MN2 - AML2)/2.
36825 PIK = (S - MN2)/2.
36826 QK = (AML2 - QQ)/2.
36827 PIQ = (QQ + MN2 - MD2)/2.
36828 Q = SQRT(-QQ)
36829 C3V = 2.07*SQRT(EXP(-6.3*Q)*(1.+9*Q))
36830 C3 = SQRT(3.)*C3V/MN
36831 C4 = -C3/MD ! attenzione al segno
36832 C5A = 1.18/(1.-QQ/0.4225)**2
36833 C32 = C3**2
36834 C42 = C4**2
36835 C5A2 = C5A**2
36836
36837 IF (LNU .EQ. 1) THEN
36838 ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
36839 . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
36840 . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
36841 . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
36842 ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
36843 . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
36844 . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
36845 . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
36846 . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
36847 . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ-
36848 . 4.*MN*C3*C5A*MD2*VK*QQ+4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
36849 . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
36850 . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
36851 . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
36852 . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK-MD*
36853 . C3*C5A*MD2*PIK*QQ+MD*C3*C5A*MD2*QK*PIQ-3.*MD*C3*C5A
36854 . *VK*VPI*QQ+MD*C3*C5A*VK*VQ*PIQ+3.*MD*C3*C5A*VPI*VQ*
36855 . QK-MD*C3*C5A*VQ**2*PIK+C4*C5A*MD2*VK*VPI*QQ+C4*C5A*
36856 . MD2*VK*VQ*PIQ-C4*C5A*MD2*VPI*VQ*QK-C4*C5A*MD2*VQ**2
36857 . *PIK-C4*C5A*MD4*PIK*QQ+C4*C5A*MD4*QK*PIQ-2.*MD2*VK
36858 . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
36859 . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
36860 . *C42-2.*MD2*VPI*QK**2*C32+ANS3
36861 ELSE
36862 ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
36863 . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
36864 . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
36865 . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
36866 ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
36867 . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
36868 . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
36869 . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
36870 . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
36871 . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ+
36872 . 4.*MN*C3*C5A*MD2*VK*QQ-4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
36873 . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
36874 . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
36875 . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
36876 . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK+MD*
36877 . C3*C5A*MD2*PIK*QQ-MD*C3*C5A*MD2*QK*PIQ+3.*MD*C3*C5A
36878 . *VK*VPI*QQ-MD*C3*C5A*VK*VQ*PIQ-3.*MD*C3*C5A*VPI*VQ*
36879 . QK+MD*C3*C5A*VQ**2*PIK-C4*C5A*MD2*VK*VPI*QQ-C4*C5A*
36880 . MD2*VK*VQ*PIQ+C4*C5A*MD2*VPI*VQ*QK+C4*C5A*MD2*VQ**2
36881 . *PIK+C4*C5A*MD4*PIK*QQ-C4*C5A*MD4*QK*PIQ-2.*MD2*VK
36882 . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
36883 . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
36884 . *C42-2.*MD2*VPI*QK**2*C32+ANS3
36885 ENDIF
36886 ANS1=32.*ANS2
36887 ANS=ANS1/(3.*MD2)
36888 P1CM = (S-MN2)/(2.*SQRT(S))
36889 DT_DSIGMA_DELTA = GF2/2. * ANS/(64.*PI*S*P1CM**2)
36890
36891 RETURN
36892 END
36893
36894*$ CREATE DT_QGAUS.FOR
36895*COPY DT_QGAUS
36896*
36897*===qgaus==============================================================*
36898*
36899 SUBROUTINE DT_QGAUS(A,B,SS,ENU,LTYP)
36900
36901 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36902 SAVE
36903
36904 DIMENSION X(5),W(5)
36905 DATA X/.1488743389D0,.4333953941D0,
36906 & .6794095682D0,.8650633666D0,.9739065285D0
36907 */
36908 DATA W/.2955242247D0,.2692667193D0,
36909 & .2190863625D0,.1494513491D0,.0666713443D0
36910 */
36911 XM=0.5D0*(B+A)
36912 XR=0.5D0*(B-A)
36913 SS=0
36914 DO 11 J=1,5
36915 DX=XR*X(J)
36916 SS=SS+W(J)*(DT_DSQEL_Q2(LTYP,ENU,XM+DX)+
36917 * DT_DSQEL_Q2(LTYP,ENU,XM-DX))
3691811 CONTINUE
36919 SS=XR*SS
36920
36921 RETURN
36922 END
36923
36924*$ CREATE DT_DIQBRK.FOR
36925*COPY DT_DIQBRK
36926*
36927*===diqbrk=============================================================*
36928*
36929 SUBROUTINE DT_DIQBRK
36930
36931 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36932 SAVE
36933
36934* event history
36935 PARAMETER (NMXHKK=200000)
36936 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36937 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36938 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36939* extended event history
36940 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36941 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36942 & IHIST(2,NMXHKK)
36943* event flag
36944 COMMON /DTEVNO/ NEVENT,ICASCA
36945
36946C IF(DT_RNDM(VV).LE.0.5D0)THEN
36947C CALL GSQBS1(NHKK)
36948C CALL GSQBS2(NHKK)
36949C CALL USQBS1(NHKK)
36950C CALL USQBS2(NHKK)
36951C CALL GSABS1(NHKK)
36952C CALL GSABS2(NHKK)
36953C CALL USABS1(NHKK)
36954C CALL USABS2(NHKK)
36955C ELSE
36956C CALL GSQBS2(NHKK)
36957C CALL GSQBS1(NHKK)
36958C CALL USQBS2(NHKK)
36959C CALL USQBS1(NHKK)
36960C CALL GSABS2(NHKK)
36961C CALL GSABS1(NHKK)
36962C CALL USABS2(NHKK)
36963C CALL USABS1(NHKK)
36964C ENDIF
36965
36966 IF(DT_RNDM(VV).LE.0.5D0) THEN
36967 CALL DT_DBREAK(1)
36968 CALL DT_DBREAK(2)
36969 CALL DT_DBREAK(3)
36970 CALL DT_DBREAK(4)
36971 CALL DT_DBREAK(5)
36972 CALL DT_DBREAK(6)
36973 CALL DT_DBREAK(7)
36974 CALL DT_DBREAK(8)
36975 ELSE
36976 CALL DT_DBREAK(2)
36977 CALL DT_DBREAK(1)
36978 CALL DT_DBREAK(4)
36979 CALL DT_DBREAK(3)
36980 CALL DT_DBREAK(6)
36981 CALL DT_DBREAK(5)
36982 CALL DT_DBREAK(8)
36983 CALL DT_DBREAK(7)
36984 ENDIF
36985
36986 RETURN
36987 END
36988
36989*$ CREATE MUSQBS2.FOR
36990*COPY MUSQBS2
36991C
36992C
36993C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
36994 SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36995 * IP1,IP21,IP22,IPP1,IPP2,IPIP,ISQ,IGCOUN)
36996C
36997C USQBS-2 diagram (split target diquark)
36998C
36999 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37000 SAVE
37001
37002 PARAMETER ( LINP = 10 ,
37003 & LOUT = 6 ,
37004 & LDAT = 9 )
37005* event history
37006 PARAMETER (NMXHKK=200000)
37007 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
37008 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
37009 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
37010* extended event history
37011 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
37012 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37013 & IHIST(2,NMXHKK)
37014* Lorentz-parameters of the current interaction
37015 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37016 & UMO,PPCM,EPROJ,PPROJ
37017* diquark-breaking mechanism
37018 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37019
37020C
37021 PARAMETER (NTMHKK= 300)
37022 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37023 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37024 +(4,NTMHKK)
37025*KEEP,XSEADI.
37026 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37027 +SSMIMQ,VVMTHR
37028*KEEP,DPRIN.
37029 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37030 COMMON /EVFLAG/ NUMEV
37031C
37032C USQBS-2 diagram (split target diquark)
37033C
37034C
37035C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
37036C Input chain 2(NC2) sea-antiquark(NC2P)-sea-quark(NC2T)
37037C
37038C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
37039C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37040C
37041C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
37042C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37043C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37044C
37045C
37046C Put new chains into COMMON /HKKTMP/
37047C
37048 IIGLU1=NC1T-NC1P-1
37049 IIGLU2=NC2T-NC2P-1
37050 IGCOUN=0
37051C WRITE(LOUT,*)'MUSQBS2: IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
37052 CVQ=1.D0
37053 IREJ=0
37054 IF(IPIP.EQ.2)THEN
37055C IF(NUMEV.EQ.-324)THEN
37056C WRITE(LOUT,*)' MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37057C * 'IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN)',
37058C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37059C * IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN
37060 ENDIF
37061C
37062C
37063C
37064C determine x-values of NC1T diquark
37065 XDIQT=PHKK(4,NC1T)*2.D0/UMO
37066 XVQP=PHKK(4,NC1P)*2.D0/UMO
37067C
37068C determine x-values of sea quark pair
37069C
37070 IPCO=1
37071 ICOU=0
37072 2234 CONTINUE
37073 ICOU=ICOU+1
37074 IF(ICOU.GE.500)THEN
37075 IREJ=1
37076 IF(ISQ.EQ.3)IREJ=3
37077 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 2234 ICOU. GT.500'
37078 IPCO=0
37079 RETURN
37080 ENDIF
37081 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS2 call XSEAPA: UMO,XDIQT,XVQP ',
37082 * UMO, XDIQT,XVQP
37083 XSQ=0.D0
37084 XSAQ=0.D0
37085**NEW
37086C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37087 IF (IPIP.EQ.1) THEN
37088 XQMAX = XDIQT/2.0D0
37089 XAQMAX = 2.D0*XVQP/3.0D0
37090 ELSE
37091 XQMAX = 2.D0*XVQP/3.0D0
37092 XAQMAX = XDIQT/2.0D0
37093 ENDIF
37094 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37095 ISAQ = 6+ISQ
37096C write(*,*) 'MUSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
37097**
37098 IF(IPCO.GE.3)
37099 & WRITE(LOUT,*)'MUSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37100 IF(IREJ.GE.1)THEN
37101 IF(IPCO.GE.3)
37102 & WRITE(LOUT,*)'MUSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37103 IPCO=0
37104 RETURN
37105 ENDIF
37106 IF(IPIP.EQ.1)THEN
37107 IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37108 ELSEIF(IPIP.EQ.2)THEN
37109 IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37110 ENDIF
37111 IF(IPCO.GE.3)THEN
37112 WRITE(LOUT,'(A,4E12.4)')' MUSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
37113 * XDIQT,XVQP,XSQ,XSAQ
37114 ENDIF
37115C
37116C subtract xsq,xsaq from NC1T diquark and NC1P quark
37117C
37118C XSQ=0.D0
37119 IF(IPIP.EQ.1)THEN
37120 XDIQT=XDIQT-XSQ
37121 XVQP =XVQP -XSAQ
37122 ELSEIF(IPIP.EQ.2)THEN
37123 XDIQT=XDIQT-XSAQ
37124 XVQP =XVQP -XSQ
37125 ENDIF
37126 IF(IPCO.GE.3)
37127 & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
37128C
37129C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37130C
37131 XVTHRO=CVQ/UMO
37132 IVTHR=0
37133 3466 CONTINUE
37134 IF(IVTHR.EQ.10)THEN
37135 IREJ=1
37136 IF(ISQ.EQ.3)IREJ=3
37137 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 3466 reject IVTHR 10'
37138 IPCO=0
37139 RETURN
37140 ENDIF
37141 IVTHR=IVTHR+1
37142 XVTHR=XVTHRO/(201-IVTHR)
37143 UNOPRV=UNON
37144 380 CONTINUE
37145 IF(XVTHR.GT.0.66D0*XDIQT)THEN
37146 IREJ=1
37147 IF(ISQ.EQ.3)IREJ=3
37148 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 380 XVTHR large ',
37149 * XVTHR
37150 IPCO=0
37151 RETURN
37152 ENDIF
37153 IF(DT_RNDM(V).LT.0.5D0)THEN
37154 XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37155 XVTQII=XDIQT-XVTQI
37156 ELSE
37157 XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37158 XVTQI=XDIQT-XVTQII
37159 ENDIF
37160 IF(IPCO.GE.3)THEN
37161 WRITE(LOUT,'(A,2E12.4)')' MUSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
37162 ENDIF
37163C
37164C Prepare 4 momenta of new chains and chain ends
37165C
37166C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37167C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37168C +(4,NTMHKK)
37169C
37170C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
37171C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37172C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37173C
37174C SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37175C * IP1,IP21,IP22,IPP1,IPP2)
37176C
37177 IF(IPIP.EQ.1)THEN
37178 XSQ1=XSQ
37179 XSAQ1=XSAQ
37180 ISQ1=ISQ
37181 ISAQ1=ISAQ
37182 ELSEIF(IPIP.EQ.2)THEN
37183 XSQ1=XSAQ
37184 XSAQ1=XSQ
37185 ISQ1=ISAQ
37186 ISAQ1=ISQ
37187 ENDIF
37188 IDHKT(1) =IPP1
37189 ISTHKT(1) =951
37190 JMOHKT(1,1)=NC2P
37191 JMOHKT(2,1)=0
37192 JDAHKT(1,1)=3+IIGLU1
37193 JDAHKT(2,1)=0
37194C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
37195 PHKT(1,1) =PHKK(1,NC2P)
37196 PHKT(2,1) =PHKK(2,NC2P)
37197 PHKT(3,1) =PHKK(3,NC2P)
37198 PHKT(4,1) =PHKK(4,NC2P)
37199C PHKT(5,1) =PHKK(5,NC2P)
37200 XMIST =(PHKT(4,1)**2-
37201 * PHKT(3,1)**2-PHKT(2,1)**2-
37202 *PHKT(1,1)**2)
37203 IF(XMIST.GT.0.D0)THEN
37204 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
37205 *PHKT(1,1)**2)
37206 ELSE
37207C WRITE(LOUT,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
37208 PHKT(5,1)=0.D0
37209 ENDIF
37210 VHKT(1,1) =VHKK(1,NC2P)
37211 VHKT(2,1) =VHKK(2,NC2P)
37212 VHKT(3,1) =VHKK(3,NC2P)
37213 VHKT(4,1) =VHKK(4,NC2P)
37214 WHKT(1,1) =WHKK(1,NC2P)
37215 WHKT(2,1) =WHKK(2,NC2P)
37216 WHKT(3,1) =WHKK(3,NC2P)
37217 WHKT(4,1) =WHKK(4,NC2P)
37218C Add here IIGLU1 gluons to this chaina
37219 PG1=0.D0
37220 PG2=0.D0
37221 PG3=0.D0
37222 PG4=0.D0
37223 IF(IIGLU1.GE.1)THEN
37224 JJG=NC1P
37225 DO 61 IIG=2,2+IIGLU1-1
37226 KKG=JJG+IIG-1
37227 IDHKT(IIG) =IDHKK(KKG)
37228 ISTHKT(IIG) =921
37229 JMOHKT(1,IIG)=KKG
37230 JMOHKT(2,IIG)=0
37231 JDAHKT(1,IIG)=3+IIGLU1
37232 JDAHKT(2,IIG)=0
37233 PHKT(1,IIG)=PHKK(1,KKG)
37234 PG1=PG1+ PHKT(1,IIG)
37235 PHKT(2,IIG)=PHKK(2,KKG)
37236 PG2=PG2+ PHKT(2,IIG)
37237 PHKT(3,IIG)=PHKK(3,KKG)
37238 PG3=PG3+ PHKT(3,IIG)
37239 PHKT(4,IIG)=PHKK(4,KKG)
37240 PG4=PG4+ PHKT(4,IIG)
37241 PHKT(5,IIG)=PHKK(5,KKG)
37242 VHKT(1,IIG) =VHKK(1,KKG)
37243 VHKT(2,IIG) =VHKK(2,KKG)
37244 VHKT(3,IIG) =VHKK(3,KKG)
37245 VHKT(4,IIG) =VHKK(4,KKG)
37246 WHKT(1,IIG) =WHKK(1,KKG)
37247 WHKT(2,IIG) =WHKK(2,KKG)
37248 WHKT(3,IIG) =WHKK(3,KKG)
37249 WHKT(4,IIG) =WHKK(4,KKG)
37250 61 CONTINUE
37251 ENDIF
37252 IDHKT(2+IIGLU1) =IP21
37253 ISTHKT(2+IIGLU1) =952
37254 JMOHKT(1,2+IIGLU1)=NC1T
37255 JMOHKT(2,2+IIGLU1)=0
37256 JDAHKT(1,2+IIGLU1)=3+IIGLU1
37257 JDAHKT(2,2+IIGLU1)=0
37258 PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
37259 PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
37260 PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
37261 PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
37262C PHKT(5,2) =PHKK(5,NC1T)
37263 XMIST =(PHKT(4,2+IIGLU1)**2-
37264 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37265 *PHKT(1,2+IIGLU1)**2)
37266 IF(XMIST.GT.0.D0)THEN
37267 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
37268 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37269 *PHKT(1,2+IIGLU1)**2)
37270 ELSE
37271C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
37272 PHKT(5,5+IIGLU1)=0.D0
37273 ENDIF
37274 VHKT(1,2+IIGLU1) =VHKK(1,NC1T)
37275 VHKT(2,2+IIGLU1) =VHKK(2,NC1T)
37276 VHKT(3,2+IIGLU1) =VHKK(3,NC1T)
37277 VHKT(4,2+IIGLU1) =VHKK(4,NC1T)
37278 WHKT(1,2+IIGLU1) =WHKK(1,NC1T)
37279 WHKT(2,2+IIGLU1) =WHKK(2,NC1T)
37280 WHKT(3,2+IIGLU1) =WHKK(3,NC1T)
37281 WHKT(4,2+IIGLU1) =WHKK(4,NC1T)
37282 IDHKT(3+IIGLU1) =88888
37283 ISTHKT(3+IIGLU1) =95
37284 JMOHKT(1,3+IIGLU1)=1
37285 JMOHKT(2,3+IIGLU1)=2+IIGLU1
37286 JDAHKT(1,3+IIGLU1)=0
37287 JDAHKT(2,3+IIGLU1)=0
37288 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
37289 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
37290 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
37291 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
37292 XMIST
37293 * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37294 * -PHKT(3,3+IIGLU1)**2)
37295 IF(XMIST.GT.0.D0)THEN
37296 PHKT(5,3+IIGLU1)
37297 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37298 * -PHKT(3,3+IIGLU1)**2)
37299 ELSE
37300C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
37301 PHKT(5,5+IIGLU1)=0.D0
37302 ENDIF
37303 IF(IPIP.GE.2)THEN
37304C IF(NUMEV.EQ.-324)THEN
37305C WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
37306C * JDAHKT(1,1),
37307C *JDAHKT(2,1),(PHKT(III,1),III=1,5)
37308 DO 71 IIG=2,2+IIGLU1-1
37309C WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
37310C & JMOHKT(1,IIG),JMOHKT(2,IIG),
37311C * JDAHKT(1,IIG),
37312C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37313 71 CONTINUE
37314C WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
37315C * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
37316C *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
37317C WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
37318C * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
37319C *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
37320 ENDIF
37321 CHAMAL=CHAM1
37322 IF(IPIP.EQ.1)THEN
37323 IF(IPP1.LE.-3.OR.IP21.GE.3)CHAMAL=CHAM3
37324 ELSEIF(IPIP.EQ.2)THEN
37325 IF(IPP1.GE.3.OR.IP21.LE.-3)CHAMAL=CHAM3
37326 ENDIF
37327 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
37328C IREJ=1
37329 IPCO=0
37330C RETURN
37331C WRITE(LOUT,*)' MUSQBS1 jump back from chain 3'
37332 GO TO 3466
37333 ENDIF
37334 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
37335 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
37336 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
37337 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
37338 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
37339 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
37340 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
37341 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
37342 IF(IPIP.EQ.1)THEN
37343 IDHKT(4+IIGLU1) =-(ISAQ1-6)
37344 ELSEIF(IPIP.EQ.2)THEN
37345 IDHKT(4+IIGLU1) =ISAQ1
37346 ENDIF
37347 ISTHKT(4+IIGLU1) =951
37348 JMOHKT(1,4+IIGLU1)=NC1P
37349 JMOHKT(2,4+IIGLU1)=0
37350 JDAHKT(1,4+IIGLU1)=6+IIGLU1
37351 JDAHKT(2,4+IIGLU1)=0
37352C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37353 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
37354 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
37355 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
37356 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
37357C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
37358 XMIST =(PHKT(4,4+IIGLU1)**2-
37359 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37360 *PHKT(1,4+IIGLU1)**2)
37361 IF(XMIST.GT.0.D0)THEN
37362 PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2-
37363 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37364 *PHKT(1,4+IIGLU1)**2)
37365 ELSE
37366C WRITE(LOUT,*)'MUSQBS2 parton 4 mass square LT.0 ',XMIST
37367 PHKT(5,4+IIGLU1)=0.D0
37368 ENDIF
37369 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
37370 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
37371 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
37372 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
37373 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
37374 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
37375 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
37376 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
37377 IDHKT(5+IIGLU1) =IP22
37378 ISTHKT(5+IIGLU1) =952
37379 JMOHKT(1,5+IIGLU1)=NC1T
37380 JMOHKT(2,5+IIGLU1)=0
37381 JDAHKT(1,5+IIGLU1)=6+IIGLU1
37382 JDAHKT(2,5+IIGLU1)=0
37383 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
37384 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
37385 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
37386 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
37387C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
37388 XMIST =(PHKT(4,5+IIGLU1)**2-
37389 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37390 *PHKT(1,5+IIGLU1)**2)
37391 IF(XMIST.GT.0.D0)THEN
37392 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
37393 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37394 *PHKT(1,5+IIGLU1)**2)
37395 ELSE
37396C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37397 PHKT(5,5+IIGLU1)=0.D0
37398 ENDIF
37399 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
37400 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
37401 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
37402 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
37403 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
37404 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
37405 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
37406 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
37407 IDHKT(6+IIGLU1) =88888
37408 ISTHKT(6+IIGLU1) =95
37409 JMOHKT(1,6+IIGLU1)=4+IIGLU1
37410 JMOHKT(2,6+IIGLU1)=5+IIGLU1
37411 JDAHKT(1,6+IIGLU1)=0
37412 JDAHKT(2,6+IIGLU1)=0
37413 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37414 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37415 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37416 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37417 XMIST
37418 * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37419 * -PHKT(3,6+IIGLU1)**2)
37420 IF(XMIST.GT.0.D0)THEN
37421 PHKT(5,6+IIGLU1)
37422 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37423 * -PHKT(3,6+IIGLU1)**2)
37424 ELSE
37425C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37426 PHKT(5,5+IIGLU1)=0.D0
37427 ENDIF
37428C IF(IPIP.GE.2)THEN
37429C IF(NUMEV.EQ.-324)THEN
37430C WRITE(6,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
37431C * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
37432C *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
37433C WRITE(6,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
37434C * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
37435C *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
37436C WRITE(6,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
37437C * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
37438C *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
37439C ENDIF
37440 CHAMAL=CHAM1
37441 IF(IPIP.EQ.1)THEN
37442 IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
37443 ELSEIF(IPIP.EQ.2)THEN
37444 IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
37445 ENDIF
37446 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37447C IREJ=1
37448 IPCO=0
37449C RETURN
37450C WRITE(6,*)' MUSQBS1 jump back from chain 6',
37451C * CHAMAL,PHKT(5,6+IIGLU1)
37452 GO TO 3466
37453 ENDIF
37454 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
37455 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
37456 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
37457 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
37458 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
37459 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
37460 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
37461 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
37462C IDHKT(7) =1000*IPP1+100*ISQ+1
37463 IDHKT(7+IIGLU1) =IP1
37464 ISTHKT(7+IIGLU1) =951
37465 JMOHKT(1,7+IIGLU1)=NC1P
37466 JMOHKT(2,7+IIGLU1)=0
37467**NEW
37468C JDAHKT(1,7+IIGLU1)=9+IIGLU1
37469 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
37470**
37471 JDAHKT(2,7+IIGLU1)=0
37472 PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
37473 PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
37474 PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
37475 PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
37476C PHKT(5,7+IIGLU1) =PHKK(5,NC1P)
37477 XMIST =(PHKT(4,7+IIGLU1)**2-
37478 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
37479 *PHKT(1,7+IIGLU1)**2)
37480 IF(XMIST.GT.0.D0)THEN
37481 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
37482 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
37483 *PHKT(1,7+IIGLU1)**2)
37484 ELSE
37485C WRITE(6,*)'MUSQBS2 parton 7 mass square LT.0 ',XMIST
37486 PHKT(5,7+IIGLU1)=0.D0
37487 ENDIF
37488 VHKT(1,7+IIGLU1) =VHKK(1,NC1P)
37489 VHKT(2,7+IIGLU1) =VHKK(2,NC1P)
37490 VHKT(3,7+IIGLU1) =VHKK(3,NC1P)
37491 VHKT(4,7+IIGLU1) =VHKK(4,NC1P)
37492 WHKT(1,7+IIGLU1) =WHKK(1,NC1P)
37493 WHKT(2,7+IIGLU1) =WHKK(2,NC1P)
37494 WHKT(3,7+IIGLU1) =WHKK(3,NC1P)
37495 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
37496C Insert here the IIGLU2 gluons
37497 PG1=0.D0
37498 PG2=0.D0
37499 PG3=0.D0
37500 PG4=0.D0
37501 IF(IIGLU2.GE.1)THEN
37502 JJG=NC2P
37503 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37504 KKG=JJG+IIG-7-IIGLU1
37505 IDHKT(IIG) =IDHKK(KKG)
37506 ISTHKT(IIG) =921
37507 JMOHKT(1,IIG)=KKG
37508 JMOHKT(2,IIG)=0
37509 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
37510 JDAHKT(2,IIG)=0
37511 PHKT(1,IIG)=PHKK(1,KKG)
37512 PG1=PG1+ PHKT(1,IIG)
37513 PHKT(2,IIG)=PHKK(2,KKG)
37514 PG2=PG2+ PHKT(2,IIG)
37515 PHKT(3,IIG)=PHKK(3,KKG)
37516 PG3=PG3+ PHKT(3,IIG)
37517 PHKT(4,IIG)=PHKK(4,KKG)
37518 PG4=PG4+ PHKT(4,IIG)
37519 PHKT(5,IIG)=PHKK(5,KKG)
37520 VHKT(1,IIG) =VHKK(1,KKG)
37521 VHKT(2,IIG) =VHKK(2,KKG)
37522 VHKT(3,IIG) =VHKK(3,KKG)
37523 VHKT(4,IIG) =VHKK(4,KKG)
37524 WHKT(1,IIG) =WHKK(1,KKG)
37525 WHKT(2,IIG) =WHKK(2,KKG)
37526 WHKT(3,IIG) =WHKK(3,KKG)
37527 WHKT(4,IIG) =WHKK(4,KKG)
37528 81 CONTINUE
37529 ENDIF
37530 IF(IPIP.EQ.1)THEN
37531 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3
37532 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
37533 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
37534 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
37535 ELSEIF(IPIP.EQ.2)THEN
37536 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3
37537 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
37538 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
37539 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
37540 ENDIF
37541 ISTHKT(8+IIGLU1+IIGLU2) =952
37542 JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
37543 JMOHKT(2,8+IIGLU1+IIGLU2)=0
37544 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
37545 JDAHKT(2,8+IIGLU1+IIGLU2)=0
37546 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC2T)+
37547 * PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
37548 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC2T)+
37549 * PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
37550 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC2T)+
37551 * PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
37552 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC2T)+
37553 * PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
37554C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
37555C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
37556 IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
37557C IREJ=1
37558C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
37559C * ,PHKT(4,8+IIGLU1+IIGLU2), PHKK(4,NC2T),NC2T
37560 IPCO=0
37561C RETURN
37562 GO TO 3466
37563 ENDIF
37564C PHKT(5,8) =PHKK(5,NC2T)
37565 XMIST =(PHKT(4,8+IIGLU1+IIGLU2)**2-
37566 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37567 *PHKT(1,8+IIGLU1+IIGLU2)**2)
37568 IF(XMIST.GT.0.D0)THEN
37569 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
37570 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37571 *PHKT(1,8+IIGLU1+IIGLU2)**2)
37572 ELSE
37573C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37574 PHKT(5,5+IIGLU1)=0.D0
37575 ENDIF
37576 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T)
37577 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T)
37578 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T)
37579 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T)
37580 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T)
37581 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T)
37582 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T)
37583 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T)
37584 IDHKT(9+IIGLU1+IIGLU2) =88888
37585 ISTHKT(9+IIGLU1+IIGLU2) =95
37586 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
37587 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
37588 JDAHKT(1,9+IIGLU1+IIGLU2)=0
37589 JDAHKT(2,9+IIGLU1+IIGLU2)=0
37590**NEW
37591C PHKT(1,9+IIGLU1+IIGLU2)
37592C * =PHKT(1,7+IIGLU1+IIGLU2)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
37593C PHKT(2,9+IIGLU1+IIGLU2)
37594C * =PHKT(2,7+IIGLU1+IIGLU2)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
37595C PHKT(3,9+IIGLU1+IIGLU2)
37596C * =PHKT(3,7+IIGLU1+IIGLU2)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
37597C PHKT(4,9+IIGLU1+IIGLU2)
37598C * =PHKT(4,7+IIGLU1+IIGLU2)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
37599 PHKT(1,9+IIGLU1+IIGLU2)
37600 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
37601 PHKT(2,9+IIGLU1+IIGLU2)
37602 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
37603 PHKT(3,9+IIGLU1+IIGLU2)
37604 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
37605 PHKT(4,9+IIGLU1+IIGLU2)
37606 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
37607**
37608 XMIST
37609 * =(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37610 * -PHKT(2,9+IIGLU1+IIGLU2)**2
37611 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
37612 IF(XMIST.GT.0.D0)THEN
37613 PHKT(5,9+IIGLU1+IIGLU2)
37614 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37615 * -PHKT(2,9+IIGLU1+IIGLU2)**2
37616 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
37617 ELSE
37618C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37619 PHKT(5,5+IIGLU1)=0.D0
37620 ENDIF
37621 IF(IPIP.GE.2)THEN
37622C IF(NUMEV.EQ.-324)THEN
37623C WRITE(6,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
37624C * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
37625C *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
37626C DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37627C WRITE(6,*)IIG,ISTHKT(IIG),IDHKT(IIG),JMOHKT(1,IIG),JMOHKT(2,IIG),
37628C * JDAHKT(1,IIG),
37629C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37630C 91 CONTINUE
37631C WRITE(6,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
37632C * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
37633C *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
37634C *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
37635C WRITE(6,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
37636C * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
37637C *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
37638C *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
37639 ENDIF
37640 CHAMAL=CHAB1
37641 IF(IPIP.EQ.1)THEN
37642 IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
37643 ELSEIF(IPIP.EQ.2)THEN
37644 IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
37645 ENDIF
37646 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
37647C IREJ=1
37648 IPCO=0
37649C RETURN
37650C WRITE(6,*)' MUSQBS1 jump back from chain 9',
37651C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
37652 GO TO 3466
37653 ENDIF
37654 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
37655 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
37656 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
37657 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
37658 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
37659 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
37660 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
37661 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
37662C
37663 IPCO=0
37664 IGCOUN=9+IIGLU1+IIGLU2
37665 RETURN
37666 END
37667
37668*$ CREATE MGSQBS2.FOR
37669*COPY MGSQBS2
37670C
37671C
37672C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
37673 SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37674 * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,ISQ,IGCOUN)
37675C
37676C GSQBS-2 diagram (split target diquark)
37677C
37678 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37679 SAVE
37680
37681 PARAMETER ( LINP = 10 ,
37682 & LOUT = 6 ,
37683 & LDAT = 9 )
37684* event history
37685 PARAMETER (NMXHKK=200000)
37686 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
37687 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
37688 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
37689* extended event history
37690 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
37691 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37692 & IHIST(2,NMXHKK)
37693* Lorentz-parameters of the current interaction
37694 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37695 & UMO,PPCM,EPROJ,PPROJ
37696* diquark-breaking mechanism
37697 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37698
37699C
37700 PARAMETER (NTMHKK= 300)
37701 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37702 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37703 +(4,NTMHKK)
37704
37705*KEEP,XSEADI.
37706 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37707 +SSMIMQ,VVMTHR
37708*KEEP,DPRIN.
37709 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37710C
37711C GSQBS-2 diagram (split target diquark)
37712C
37713C
37714C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
37715C Input chain 2(NC2) valence-diquark(NC2P)-sea-quark(NC2T)
37716C
37717C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
37718C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37719C
37720C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
37721C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37722C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37723C
37724C
37725C
37726C Put new chains into COMMON /HKKTMP/
37727C
37728 IIGLU1=NC1T-NC1P-1
37729 IIGLU2=NC2T-NC2P-1
37730 IGCOUN=0
37731C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
37732 CVQ=1.D0
37733 IREJ=0
37734C IF(IPIP.EQ.2)THEN
37735C WRITE(6,*)' MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37736C * 'IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN)',
37737C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37738C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN
37739C ENDIF
37740C
37741C
37742C
37743C determine x-values of NC1T diquark
37744 XDIQT=PHKK(4,NC1T)*2.D0/UMO
37745 XVQP=PHKK(4,NC1P)*2.D0/UMO
37746C
37747C determine x-values of sea quark pair
37748C
37749 IPCO=1
37750 ICOU=0
37751 2234 CONTINUE
37752 ICOU=ICOU+1
37753 IF(ICOU.GE.500)THEN
37754 IREJ=1
37755 IF(ISQ.EQ.3)IREJ=3
37756 IF(IPCO.GE.3)
37757 & WRITE(LOUT,*)' MGSQBS2 Rejection 2234 ICOU. GT.500'
37758 IPCO=0
37759 RETURN
37760 ENDIF
37761 IF(IPCO.GE.3)
37762 & WRITE(LOUT,*)'MGSQBS2 call XSEAPA: UMO,XDIQT,XVQP ',
37763 * UMO, XDIQT,XVQP
37764 XSQ=0.D0
37765 XSAQ=0.D0
37766**NEW
37767C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37768 IF (IPIP.EQ.1) THEN
37769 XQMAX = XDIQT/2.0D0
37770 XAQMAX = 2.D0*XVQP/3.0D0
37771 ELSE
37772 XQMAX = 2.D0*XVQP/3.0D0
37773 XAQMAX = XDIQT/2.0D0
37774 ENDIF
37775 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37776 ISAQ = 6+ISQ
37777C write(*,*) 'MGSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
37778**
37779 IF(IPCO.GE.3)
37780 & WRITE(LOUT,*)'MGSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37781 IF(IREJ.GE.1)THEN
37782 IF(IPCO.GE.3)
37783 & WRITE(LOUT,*)'MGSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37784 IPCO=0
37785 RETURN
37786 ENDIF
37787 IF(IPIP.EQ.1)THEN
37788 IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37789 ELSEIF(IPIP.EQ.2)THEN
37790 IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37791 ENDIF
37792 IF(IPCO.GE.3)THEN
37793 WRITE(LOUT,'(A,4E12.4)')' MGSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
37794 * XDIQT,XVQP,XSQ,XSAQ
37795 ENDIF
37796C
37797C subtract xsq,xsaq from NC1T diquark and NC1P quark
37798C
37799C XSQ=0.D0
37800 IF(IPIP.EQ.1)THEN
37801 XDIQT=XDIQT-XSQ
37802 XVQP =XVQP -XSAQ
37803 ELSEIF(IPIP.EQ.2)THEN
37804 XDIQT=XDIQT-XSAQ
37805 XVQP =XVQP -XSQ
37806 ENDIF
37807 IF(IPCO.GE.3)
37808 & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
37809C
37810C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37811C
37812 XVTHRO=CVQ/UMO
37813 IVTHR=0
37814 3466 CONTINUE
37815 IF(IVTHR.EQ.10)THEN
37816 IREJ=1
37817 IF(ISQ.EQ.3)IREJ=3
37818 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 3466 reject IVTHR 10'
37819 IPCO=0
37820 RETURN
37821 ENDIF
37822 IVTHR=IVTHR+1
37823 XVTHR=XVTHRO/(201-IVTHR)
37824 UNOPRV=UNON
37825 380 CONTINUE
37826 IF(XVTHR.GT.0.66D0*XDIQT)THEN
37827 IREJ=1
37828 IF(ISQ.EQ.3)IREJ=3
37829 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 Rejection 380 XVTHR large ',
37830 * XVTHR
37831 IPCO=0
37832 RETURN
37833 ENDIF
37834 IF(DT_RNDM(V).LT.0.5D0)THEN
37835 XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37836 XVTQII=XDIQT-XVTQI
37837 ELSE
37838 XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37839 XVTQI=XDIQT-XVTQII
37840 ENDIF
37841 IF(IPCO.GE.3)THEN
37842 WRITE(LOUT,'(A,2E12.4)')' MGSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
37843 ENDIF
37844C
37845C Prepare 4 momenta of new chains and chain ends
37846C
37847C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37848C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37849C +(4,NTMHKK)
37850C
37851C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
37852C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37853C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37854C
37855C SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37856C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IGCOUN)
37857C
37858 IF(IPIP.EQ.1)THEN
37859 XSQ1=XSQ
37860 XSAQ1=XSAQ
37861 ISQ1=ISQ
37862 ISAQ1=ISAQ
37863 ELSEIF(IPIP.EQ.2)THEN
37864 XSQ1=XSAQ
37865 XSAQ1=XSQ
37866 ISQ1=ISAQ
37867 ISAQ1=ISQ
37868 ENDIF
37869 KK11=IP21
37870C IDHKT(1) =1000*IPP11+100*IPP12+1
37871 KK21=IPP11
37872 KK22=IPP12
37873 XGIVE=0.D0
37874 IF(IPIP.EQ.1)THEN
37875 IDHKT(4+IIGLU1) =-(ISAQ1-6)
37876 ELSEIF(IPIP.EQ.2)THEN
37877 IDHKT(4+IIGLU1) =ISAQ1
37878 ENDIF
37879 ISTHKT(4+IIGLU1) =961
37880 JMOHKT(1,4+IIGLU1)=NC1P
37881 JMOHKT(2,4+IIGLU1)=0
37882 JDAHKT(1,4+IIGLU1)=6+IIGLU1
37883 JDAHKT(2,4+IIGLU1)=0
37884C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37885 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
37886 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
37887 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
37888 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
37889C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
37890 XXMIST=(PHKT(4,4+IIGLU1)**2-
37891 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37892 *PHKT(1,4+IIGLU1)**2)
37893 IF(XXMIST.GT.0.D0)THEN
37894 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
37895 ELSE
37896 WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
37897 XXMIST=ABS(XXMIST)
37898 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
37899 ENDIF
37900 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
37901 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
37902 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
37903 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
37904 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
37905 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
37906 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
37907 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
37908 IDHKT(5+IIGLU1) =IP22
37909 ISTHKT(5+IIGLU1) =962
37910 JMOHKT(1,5+IIGLU1)=NC1T
37911 JMOHKT(2,5+IIGLU1)=0
37912 JDAHKT(1,5+IIGLU1)=6+IIGLU1
37913 JDAHKT(2,5+IIGLU1)=0
37914 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
37915 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
37916 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
37917 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
37918C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
37919 XXMIST=(PHKT(4,5+IIGLU1)**2-
37920 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37921 *PHKT(1,5+IIGLU1)**2)
37922 IF(XXMIST.GT.0.D0)THEN
37923 PHKT(5,5+IIGLU1) =SQRT(XXMIST)
37924 ELSE
37925 WRITE(LOUT,*)' MGSQBS2 XXMIST', XXMIST
37926 XXMIST=ABS(XXMIST)
37927 PHKT(5,5+IIGLU1) =SQRT(XXMIST)
37928 ENDIF
37929 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
37930 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
37931 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
37932 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
37933 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
37934 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
37935 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
37936 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
37937 IDHKT(6+IIGLU1) =88888
37938 ISTHKT(6+IIGLU1) =96
37939 JMOHKT(1,6+IIGLU1)=4+IIGLU1
37940 JMOHKT(2,6+IIGLU1)=5+IIGLU1
37941 JDAHKT(1,6+IIGLU1)=0
37942 JDAHKT(2,6+IIGLU1)=0
37943 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37944 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37945 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37946 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37947 PHKT(5,6+IIGLU1)
37948 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37949 * -PHKT(3,6+IIGLU1)**2)
37950 CHAMAL=CHAM1
37951 IF(IPIP.EQ.1)THEN
37952 IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
37953 ELSEIF(IPIP.EQ.2)THEN
37954 IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
37955 ENDIF
37956C---------------------------------------------------
37957 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37958 IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
37959C we drop chain 6 and give the energy to chain 3
37960 IDHKT(6+IIGLU1)=22888
37961 XGIVE=1.D0
37962C WRITE(6,*)' drop chain 6 xgive=1'
37963 GO TO 7788
37964 ELSEIF(IDHKT(4+IIGLU1).EQ.-IP21)THEN
37965C we drop chain 6 and give the energy to chain 3
37966C and change KK11 to IDHKT(5)
37967 IDHKT(6+IIGLU1)=22888
37968 XGIVE=1.D0
37969C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(5)'
37970 KK11=IDHKT(5+IIGLU1)
37971 GO TO 7788
37972 ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP11)THEN
37973C we drop chain 6 and give the energy to chain 3
37974C and change KK21 to IDHKT(5+IIGLU1)
37975C IDHKT(1) =1000*IPP11+100*IPP12+1
37976 IDHKT(6+IIGLU1)=22888
37977 XGIVE=1.D0
37978C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(5+IIGLU1)'
37979 KK21=IDHKT(5+IIGLU1)
37980 GO TO 7788
37981 ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP12)THEN
37982C we drop chain 6 and give the energy to chain 3
37983C and change KK22 to IDHKT(5)
37984C IDHKT(1) =1000*IPP11+100*IPP12+1
37985 IDHKT(6+IIGLU1)=22888
37986 XGIVE=1.D0
37987C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(5+IIGLU1)'
37988 KK22=IDHKT(5+IIGLU1)
37989 GO TO 7788
37990 ENDIF
37991C IREJ=1
37992 IPCO=0
37993C RETURN
37994 GO TO 3466
37995 ENDIF
37996 7788 CONTINUE
37997C---------------------------------------------------
37998 IF(IPIP.GE.3)THEN
37999 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
38000 * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
38001 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
38002 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
38003 * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
38004 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
38005 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
38006 * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
38007 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
38008 ENDIF
38009 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
38010 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
38011 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
38012 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
38013 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
38014 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
38015 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
38016 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
38017C IDHKT(1) =1000*IPP11+100*IPP12+1
38018 IF(IPIP.EQ.1)THEN
38019 IDHKT(1) =1000*KK21+100*KK22+3
38020 IF(IDHKT(1).EQ.1203)IDHKT(1)=2103
38021 IF(IDHKT(1).EQ.1303)IDHKT(1)=3103
38022 IF(IDHKT(1).EQ.2303)IDHKT(1)=3203
38023 ELSEIF(IPIP.EQ.2)THEN
38024 IDHKT(1) =1000*KK21+100*KK22-3
38025 IF(IDHKT(1).EQ.-1203)IDHKT(1)=-2103
38026 IF(IDHKT(1).EQ.-1303)IDHKT(1)=-3103
38027 IF(IDHKT(1).EQ.-2303)IDHKT(1)=-3203
38028 ENDIF
38029 ISTHKT(1) =961
38030 JMOHKT(1,1)=NC2P
38031 JMOHKT(2,1)=0
38032 JDAHKT(1,1)=3+IIGLU1
38033 JDAHKT(2,1)=0
38034C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
38035 PHKT(1,1) =PHKK(1,NC2P)
38036 *+XGIVE*PHKT(1,4+IIGLU1)
38037 PHKT(2,1) =PHKK(2,NC2P)
38038 *+XGIVE*PHKT(2,4+IIGLU1)
38039 PHKT(3,1) =PHKK(3,NC2P)
38040 *+XGIVE*PHKT(3,4+IIGLU1)
38041 PHKT(4,1) =PHKK(4,NC2P)
38042 *+XGIVE*PHKT(4,4+IIGLU1)
38043C PHKT(5,1) =PHKK(5,NC2P)
38044 XXMIST=PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38045 *PHKT(1,1)**2
38046 IF(XXMIST.GT.0.D0)THEN
38047 PHKT(5,1) =SQRT(XXMIST)
38048 ELSE
38049 WRITE(LOUT,*)'MGSQBS2',XXMIST
38050 XXMIST=ABS(XXMIST)
38051 PHKT(5,1) =SQRT(XXMIST)
38052 ENDIF
38053 VHKT(1,1) =VHKK(1,NC2P)
38054 VHKT(2,1) =VHKK(2,NC2P)
38055 VHKT(3,1) =VHKK(3,NC2P)
38056 VHKT(4,1) =VHKK(4,NC2P)
38057 WHKT(1,1) =WHKK(1,NC2P)
38058 WHKT(2,1) =WHKK(2,NC2P)
38059 WHKT(3,1) =WHKK(3,NC2P)
38060 WHKT(4,1) =WHKK(4,NC2P)
38061C Add here IIGLU1 gluons to this chaina
38062 PG1=0.D0
38063 PG2=0.D0
38064 PG3=0.D0
38065 PG4=0.D0
38066 IF(IIGLU1.GE.1)THEN
38067 JJG=NC1P
38068 DO 61 IIG=2,2+IIGLU1-1
38069 KKG=JJG+IIG-1
38070 IDHKT(IIG) =IDHKK(KKG)
38071 ISTHKT(IIG) =921
38072 JMOHKT(1,IIG)=KKG
38073 JMOHKT(2,IIG)=0
38074 JDAHKT(1,IIG)=3+IIGLU1
38075 JDAHKT(2,IIG)=0
38076 PHKT(1,IIG)=PHKK(1,KKG)
38077 PG1=PG1+ PHKT(1,IIG)
38078 PHKT(2,IIG)=PHKK(2,KKG)
38079 PG2=PG2+ PHKT(2,IIG)
38080 PHKT(3,IIG)=PHKK(3,KKG)
38081 PG3=PG3+ PHKT(3,IIG)
38082 PHKT(4,IIG)=PHKK(4,KKG)
38083 PG4=PG4+ PHKT(4,IIG)
38084 PHKT(5,IIG)=PHKK(5,KKG)
38085 VHKT(1,IIG) =VHKK(1,KKG)
38086 VHKT(2,IIG) =VHKK(2,KKG)
38087 VHKT(3,IIG) =VHKK(3,KKG)
38088 VHKT(4,IIG) =VHKK(4,KKG)
38089 WHKT(1,IIG) =WHKK(1,KKG)
38090 WHKT(2,IIG) =WHKK(2,KKG)
38091 WHKT(3,IIG) =WHKK(3,KKG)
38092 WHKT(4,IIG) =WHKK(4,KKG)
38093 61 CONTINUE
38094 ENDIF
38095C IDHKT(2) =IP21
38096 IDHKT(2+IIGLU1) =KK11
38097 ISTHKT(2+IIGLU1) =962
38098 JMOHKT(1,2+IIGLU1)=NC1T
38099 JMOHKT(2,2+IIGLU1)=0
38100 JDAHKT(1,2+IIGLU1)=3+IIGLU1
38101 JDAHKT(2,2+IIGLU1)=0
38102 PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
38103C * +0.5D0*PHKK(1,NC2T)
38104 *+XGIVE*PHKT(1,5+IIGLU1)
38105 PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
38106C *+0.5D0*PHKK(2,NC2T)
38107 *+XGIVE*PHKT(2,5+IIGLU1)
38108 PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
38109C *+0.5D0*PHKK(3,NC2T)
38110 *+XGIVE*PHKT(3,5+IIGLU1)
38111 PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
38112C *+0.5D0*PHKK(4,NC2T)
38113 *+XGIVE*PHKT(4,5+IIGLU1)
38114C PHKT(5,2) =PHKK(5,NC1T)
38115 XXMIST=(PHKT(4,2+IIGLU1)**2-
38116 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38117 *PHKT(1,2+IIGLU1)**2)
38118 IF(XXMIST.GT.0.D0)THEN
38119 PHKT(5,2+IIGLU1) =SQRT(XXMIST)
38120 ELSE
38121 WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
38122 XXMIST=ABS(XXMIST)
38123 PHKT(5,2+IIGLU1) =SQRT(XXMIST)
38124 ENDIF
38125 VHKT(1,2+IIGLU1) =VHKK(1,NC1T)
38126 VHKT(2,2+IIGLU1) =VHKK(2,NC1T)
38127 VHKT(3,2+IIGLU1) =VHKK(3,NC1T)
38128 VHKT(4,2+IIGLU1) =VHKK(4,NC1T)
38129 WHKT(1,2+IIGLU1) =WHKK(1,NC1T)
38130 WHKT(2,2+IIGLU1) =WHKK(2,NC1T)
38131 WHKT(3,2+IIGLU1) =WHKK(3,NC1T)
38132 WHKT(4,2+IIGLU1) =WHKK(4,NC1T)
38133 IDHKT(3+IIGLU1) =88888
38134 ISTHKT(3+IIGLU1) =96
38135 JMOHKT(1,3+IIGLU1)=1
38136 JMOHKT(2,3+IIGLU1)=2+IIGLU1
38137 JDAHKT(1,3+IIGLU1)=0
38138 JDAHKT(2,3+IIGLU1)=0
38139 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
38140 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
38141 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
38142 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
38143 PHKT(5,3+IIGLU1)
38144 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38145 * -PHKT(3,3+IIGLU1)**2)
38146 IF(IPIP.EQ.3)THEN
38147 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
38148 * JDAHKT(1,1),
38149 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
38150 DO 71 IIG=2,2+IIGLU1-1
38151 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38152 & JMOHKT(1,IIG),JMOHKT(2,IIG),
38153 * JDAHKT(1,IIG),
38154 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38155 71 CONTINUE
38156 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
38157 * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
38158 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
38159 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
38160 * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
38161 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
38162 ENDIF
38163 CHAMAL=CHAB1
38164 IF(IPIP.EQ.1)THEN
38165 IF(IPP11.GE.3.OR.IPP12.GE.3.OR.IP21.GE.3)CHAMAL=CHAB3
38166 ELSEIF(IPIP.EQ.2)THEN
38167 IF(IPP11.LE.-3.OR.IPP12.LE.-3.OR.IP21.LE.-3)CHAMAL=CHAB3
38168 ENDIF
38169 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
38170C IREJ=1
38171 IPCO=0
38172C RETURN
38173 GO TO 3466
38174 ENDIF
38175 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
38176 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
38177 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
38178 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
38179 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
38180 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
38181 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
38182 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
38183C IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+1
38184 IDHKT(7+IIGLU1) =IP1
38185 ISTHKT(7+IIGLU1) =961
38186 JMOHKT(1,7+IIGLU1)=NC1P
38187 JMOHKT(2,7+IIGLU1)=0
38188 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
38189 JDAHKT(2,7+IIGLU1)=0
38190 PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
38191 PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
38192 PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
38193 PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
38194C PHKT(5,7+IIGLU1) =PHKK(5,NC1P)
38195 XXMIST=(PHKT(4,7+IIGLU1)**2-
38196 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
38197 *PHKT(1,7+IIGLU1)**2)
38198 IF(XXMIST.GT.0.D0)THEN
38199 PHKT(5,7+IIGLU1) =SQRT(XXMIST)
38200 ELSE
38201 WRITE(LOUT,*)' MGSQBS2, XXMIST',XXMIST
38202 XXMIST=ABS(XXMIST)
38203 PHKT(5,7+IIGLU1) =SQRT(XXMIST)
38204 ENDIF
38205 VHKT(1,7+IIGLU1) =VHKK(1,NC1P)
38206 VHKT(2,7+IIGLU1) =VHKK(2,NC1P)
38207 VHKT(3,7+IIGLU1) =VHKK(3,NC1P)
38208 VHKT(4,7+IIGLU1) =VHKK(4,NC1P)
38209 WHKT(1,7+IIGLU1) =WHKK(1,NC1P)
38210 WHKT(2,7+IIGLU1) =WHKK(2,NC1P)
38211 WHKT(3,7+IIGLU1) =WHKK(3,NC1P)
38212 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
38213C IDHKT(7) =1000*IPP1+100*ISQ+1
38214C Insert here the IIGLU2 gluons
38215 PG1=0.D0
38216 PG2=0.D0
38217 PG3=0.D0
38218 PG4=0.D0
38219 IF(IIGLU2.GE.1)THEN
38220 JJG=NC2P
38221 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38222 KKG=JJG+IIG-7-IIGLU1
38223 IDHKT(IIG) =IDHKK(KKG)
38224 ISTHKT(IIG) =921
38225 JMOHKT(1,IIG)=KKG
38226 JMOHKT(2,IIG)=0
38227 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
38228 JDAHKT(2,IIG)=0
38229 PHKT(1,IIG)=PHKK(1,KKG)
38230 PG1=PG1+ PHKT(1,IIG)
38231 PHKT(2,IIG)=PHKK(2,KKG)
38232 PG2=PG2+ PHKT(2,IIG)
38233 PHKT(3,IIG)=PHKK(3,KKG)
38234 PG3=PG3+ PHKT(3,IIG)
38235 PHKT(4,IIG)=PHKK(4,KKG)
38236 PG4=PG4+ PHKT(4,IIG)
38237 PHKT(5,IIG)=PHKK(5,KKG)
38238 VHKT(1,IIG) =VHKK(1,KKG)
38239 VHKT(2,IIG) =VHKK(2,KKG)
38240 VHKT(3,IIG) =VHKK(3,KKG)
38241 VHKT(4,IIG) =VHKK(4,KKG)
38242 WHKT(1,IIG) =WHKK(1,KKG)
38243 WHKT(2,IIG) =WHKK(2,KKG)
38244 WHKT(3,IIG) =WHKK(3,KKG)
38245 WHKT(4,IIG) =WHKK(4,KKG)
38246 81 CONTINUE
38247 ENDIF
38248 IF(IPIP.EQ.1)THEN
38249 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3
38250 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
38251 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
38252 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
38253 ELSEIF(IPIP.EQ.2)THEN
38254**NEW
38255C IDHKT(8) =1000*IPP2+100*(-ISQ1+6)-3
38256 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3
38257**
38258 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
38259 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
38260 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
38261 ENDIF
38262 ISTHKT(8+IIGLU1+IIGLU2) =962
38263 JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
38264 JMOHKT(2,8+IIGLU1+IIGLU2)=0
38265 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
38266 JDAHKT(2,8+IIGLU1+IIGLU2)=0
38267C PHKT(1,8) =0.5D0*PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ/(XDIQT+XSQ)
38268C PHKT(2,8) =0.5D0*PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ/(XDIQT+XSQ)
38269C PHKT(3,8) =0.5D0*PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ/(XDIQT+XSQ)
38270C PHKT(4,8) =0.5D0*PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ/(XDIQT+XSQ)
38271 PHKT(1,8+IIGLU1+IIGLU2) =
38272 * PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
38273 PHKT(2,8+IIGLU1+IIGLU2) =
38274 * PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
38275 PHKT(3,8+IIGLU1+IIGLU2) =
38276 * PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
38277 PHKT(4,8+IIGLU1+IIGLU2) =
38278 * PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
38279C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
38280C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
38281 IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
38282C IREJ=1
38283C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
38284 IPCO=0
38285C RETURN
38286 GO TO 3466
38287 ENDIF
38288C PHKT(5,8) =PHKK(5,NC2T)
38289 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
38290 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38291 *PHKT(1,8+IIGLU1+IIGLU2)**2)
38292 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T)
38293 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T)
38294 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T)
38295 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T)
38296 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T)
38297 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T)
38298 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T)
38299 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T)
38300 IDHKT(9+IIGLU1+IIGLU2) =88888
38301 ISTHKT(9+IIGLU1+IIGLU2) =96
38302 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
38303 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
38304 JDAHKT(1,9+IIGLU1+IIGLU2)=0
38305 JDAHKT(2,9+IIGLU1+IIGLU2)=0
38306 PHKT(1,9+IIGLU1+IIGLU2)
38307 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
38308 PHKT(2,9+IIGLU1+IIGLU2)
38309 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
38310 PHKT(3,9+IIGLU1+IIGLU2)
38311 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
38312 PHKT(4,9+IIGLU1+IIGLU2)
38313 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
38314 PHKT(5,9+IIGLU1+IIGLU2)
38315 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
38316 * PHKT(2,9+IIGLU1+IIGLU2)**2
38317 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
38318 IF(IPIP.GE.3)THEN
38319 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
38320 * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
38321 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
38322 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38323 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38324 & JMOHKT(1,IIG),JMOHKT(2,IIG),
38325 * JDAHKT(1,IIG),
38326 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38327 91 CONTINUE
38328 WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
38329 * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
38330 *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
38331 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
38332 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
38333 * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
38334 *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
38335 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
38336 ENDIF
38337 CHAMAL=CHAB1
38338 IF(IPIP.EQ.1)THEN
38339 IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
38340 ELSEIF(IPIP.EQ.2)THEN
38341 IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
38342 ENDIF
38343 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
38344C IREJ=1
38345 IPCO=0
38346C RETURN
38347 GO TO 3466
38348 ENDIF
38349 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
38350 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
38351 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
38352 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
38353 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
38354 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
38355 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
38356 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
38357C
38358 IPCO=0
38359 IGCOUN=9+IIGLU1+IIGLU2
38360 RETURN
38361 END
38362
38363*$ CREATE MUSQBS1.FOR
38364*COPY MUSQBS1
38365C
38366C
38367C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
38368 SUBROUTINE MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
38369 * IP11,IP12,IP2,IPP1,IPP2,IPIP,ISQ,IGCOUN)
38370C
38371C USQBS-1 diagram (split projectile diquark)
38372C
38373 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38374 SAVE
38375
38376 PARAMETER ( LINP = 10 ,
38377 & LOUT = 6 ,
38378 & LDAT = 9 )
38379* event history
38380 PARAMETER (NMXHKK=200000)
38381 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38382 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38383 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38384* extended event history
38385 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38386 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38387 & IHIST(2,NMXHKK)
38388* Lorentz-parameters of the current interaction
38389 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
38390 & UMO,PPCM,EPROJ,PPROJ
38391* diquark-breaking mechanism
38392 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
38393
38394C
38395 PARAMETER (NTMHKK= 300)
38396 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38397 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38398 +(4,NTMHKK)
38399*KEEP,XSEADI.
38400 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
38401 +SSMIMQ,VVMTHR
38402*KEEP,DPRIN.
38403 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
38404 COMMON /EVFLAG/ NUMEV
38405C
38406C USQBS-1 diagram (split projectile diquark)
38407C
38408C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
38409C Input chain 2(NC2) sea-quark(NC2P)-sea-antiquark(NC2T)
38410C
38411C Create quark(qsP)-antiquark(aqsT) pair, energy from NC1P and NC1T
38412C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
38413C
38414C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
38415C 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
38416C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
38417C
38418C Put new chains into COMMON /HKKTMP/
38419C
38420 IIGLU1=NC1T-NC1P-1
38421 IIGLU2=NC2T-NC2P-1
38422 IGCOUN=0
38423C WRITE(6,*)'MUSQBS1: IIGLU1,IIGLU2,IPIP ',IIGLU1,IIGLU2,IPIP
38424 CVQ=1.D0
38425 IREJ=0
38426 IF(IPIP.EQ.3)THEN
38427C IF(NUMEV.EQ.-324)THEN
38428 WRITE(LOUT,*)' MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
38429 * ' IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN)',
38430 *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
38431 * IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN
38432 ENDIF
38433C
38434C
38435C
38436C determine x-values of NC1P diquark
38437 XDIQP=PHKK(4,NC1P)*2.D0/UMO
38438 XVQT=PHKK(4,NC1T)*2.D0/UMO
38439C
38440C determine x-values of sea quark pair
38441C
38442 IPCO=1
38443 ICOU=0
38444 2234 CONTINUE
38445 ICOU=ICOU+1
38446 IF(ICOU.GE.500)THEN
38447 IREJ=1
38448 IF(ISQ.EQ.3)IREJ=3
38449 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 2234 ICOU. GT.100'
38450 IPCO=0
38451 RETURN
38452 ENDIF
38453 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 call XSEAPA: UMO,XDIQP,XVQT ',
38454 * UMO, XDIQP,XVQT
38455 XSQ=0.D0
38456 XSAQ=0.D0
38457**NEW
38458C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
38459 IF (IPIP.EQ.1) THEN
38460 XQMAX = XDIQP/2.0D0
38461 XAQMAX = 2.D0*XVQT/3.0D0
38462 ELSE
38463 XQMAX = 2.D0*XVQT/3.0D0
38464 XAQMAX = XDIQP/2.0D0
38465 ENDIF
38466 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
38467 ISAQ = 6+ISQ
38468C write(*,*) 'MUSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
38469**
38470 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
38471 IF(IREJ.GE.1)THEN
38472 IF(IPCO.GE.3)
38473 & WRITE(LOUT,*)'MUSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
38474 IPCO=0
38475 RETURN
38476 ENDIF
38477 IF(IPIP.EQ.1)THEN
38478 IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
38479 ELSEIF(IPIP.EQ.2)THEN
38480 IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
38481 ENDIF
38482 IF(IPCO.GE.3)THEN
38483 WRITE(LOUT,'(A,4E12.4)')' MUSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
38484 * XDIQP,XVQT,XSQ,XSAQ
38485 ENDIF
38486C
38487C subtract xsq,xsaq from NC1P diquark and NC1T quark
38488C
38489C XSQ=0.D0
38490 IF(IPIP.EQ.1)THEN
38491 XDIQP=XDIQP-XSQ
38492 XVQT =XVQT -XSAQ
38493 ELSEIF(IPIP.EQ.2)THEN
38494 XDIQP=XDIQP-XSAQ
38495 XVQT =XVQT -XSQ
38496 ENDIF
38497 IF(IPCO.GE.3)
38498 & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
38499C
38500C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
38501C
38502 XVTHRO=CVQ/UMO
38503 IVTHR=0
38504 3466 CONTINUE
38505 IF(IVTHR.EQ.10)THEN
38506 IREJ=1
38507 IF(ISQ.EQ.3)IREJ=3
38508 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 3466 reject IVTHR 10'
38509 IPCO=0
38510 RETURN
38511 ENDIF
38512 IVTHR=IVTHR+1
38513 XVTHR=XVTHRO/(201-IVTHR)
38514 UNOPRV=UNON
38515 380 CONTINUE
38516 IF(XVTHR.GT.0.66D0*XDIQP)THEN
38517 IREJ=1
38518 IF(ISQ.EQ.3)IREJ=3
38519 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 380 XVTHR large ',
38520 * XVTHR
38521 IPCO=0
38522 RETURN
38523 ENDIF
38524 IF(DT_RNDM(V).LT.0.5D0)THEN
38525 XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
38526 XVPQII=XDIQP-XVPQI
38527 ELSE
38528 XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
38529 XVPQI=XDIQP-XVPQII
38530 ENDIF
38531 IF(IPCO.GE.3)THEN
38532 WRITE(LOUT,'(A,2E12.4)')' MUSQBS1:XVPQI,XVPQII ',XVPQI,XVPQII
38533 ENDIF
38534C
38535C Prepare 4 momenta of new chains and chain ends
38536C
38537C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38538C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38539C +(4,NTMHKK)
38540C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
38541C 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
38542C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
38543 IF(IPIP.EQ.1)THEN
38544 XSQ1=XSQ
38545 XSAQ1=XSAQ
38546 ISQ1=ISQ
38547 ISAQ1=ISAQ
38548 ELSEIF(IPIP.EQ.2)THEN
38549 XSQ1=XSAQ
38550 XSAQ1=XSQ
38551 ISQ1=ISAQ
38552 ISAQ1=ISQ
38553 ENDIF
38554 IDHKT(1) =IP11
38555 ISTHKT(1) =931
38556 JMOHKT(1,1)=NC1P
38557 JMOHKT(2,1)=0
38558 JDAHKT(1,1)=3+IIGLU1
38559 JDAHKT(2,1)=0
38560C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
38561 PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
38562 PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
38563 PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
38564 PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
38565C PHKT(5,1) =PHKK(5,NC1P)
38566 XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38567 *PHKT(1,1)**2)
38568 IF(XMIST.GE.0.D0)THEN
38569 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38570 *PHKT(1,1)**2)
38571 ELSE
38572C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38573 PHKT(5,1)=0.D0
38574 ENDIF
38575 VHKT(1,1) =VHKK(1,NC1P)
38576 VHKT(2,1) =VHKK(2,NC1P)
38577 VHKT(3,1) =VHKK(3,NC1P)
38578 VHKT(4,1) =VHKK(4,NC1P)
38579 WHKT(1,1) =WHKK(1,NC1P)
38580 WHKT(2,1) =WHKK(2,NC1P)
38581 WHKT(3,1) =WHKK(3,NC1P)
38582 WHKT(4,1) =WHKK(4,NC1P)
38583C Add here IIGLU1 gluons to this chaina
38584 PG1=0.D0
38585 PG2=0.D0
38586 PG3=0.D0
38587 PG4=0.D0
38588 IF(IIGLU1.GE.1)THEN
38589 JJG=NC1P
38590 DO 61 IIG=2,2+IIGLU1-1
38591 KKG=JJG+IIG-1
38592 IDHKT(IIG) =IDHKK(KKG)
38593 ISTHKT(IIG) =921
38594 JMOHKT(1,IIG)=KKG
38595 JMOHKT(2,IIG)=0
38596 JDAHKT(1,IIG)=3+IIGLU1
38597 JDAHKT(2,IIG)=0
38598 PHKT(1,IIG)=PHKK(1,KKG)
38599 PG1=PG1+ PHKT(1,IIG)
38600 PHKT(2,IIG)=PHKK(2,KKG)
38601 PG2=PG2+ PHKT(2,IIG)
38602 PHKT(3,IIG)=PHKK(3,KKG)
38603 PG3=PG3+ PHKT(3,IIG)
38604 PHKT(4,IIG)=PHKK(4,KKG)
38605 PG4=PG4+ PHKT(4,IIG)
38606 PHKT(5,IIG)=PHKK(5,KKG)
38607 VHKT(1,IIG) =VHKK(1,KKG)
38608 VHKT(2,IIG) =VHKK(2,KKG)
38609 VHKT(3,IIG) =VHKK(3,KKG)
38610 VHKT(4,IIG) =VHKK(4,KKG)
38611 WHKT(1,IIG) =WHKK(1,KKG)
38612 WHKT(2,IIG) =WHKK(2,KKG)
38613 WHKT(3,IIG) =WHKK(3,KKG)
38614 WHKT(4,IIG) =WHKK(4,KKG)
38615 61 CONTINUE
38616 ENDIF
38617 IDHKT(2+IIGLU1) =IPP2
38618 ISTHKT(2+IIGLU1) =932
38619 JMOHKT(1,2+IIGLU1)=NC2T
38620 JMOHKT(2,2+IIGLU1)=0
38621 JDAHKT(1,2+IIGLU1)=3+IIGLU1
38622 JDAHKT(2,2+IIGLU1)=0
38623 PHKT(1,2+IIGLU1) =PHKK(1,NC2T)
38624 PHKT(2,2+IIGLU1) =PHKK(2,NC2T)
38625 PHKT(3,2+IIGLU1) =PHKK(3,NC2T)
38626 PHKT(4,2+IIGLU1) =PHKK(4,NC2T)
38627C PHKT(5,2+IIGLU1) =PHKK(5,NC2T)
38628 XMIST=(PHKT(4,2+IIGLU1)**2-
38629 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38630 *PHKT(1,2+IIGLU1)**2)
38631 IF(XMIST.GT.0.D0)THEN
38632 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
38633 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38634 *PHKT(1,2+IIGLU1)**2)
38635 ELSE
38636C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38637 PHKT(5,2+IIGLU1)=0.D0
38638 ENDIF
38639 VHKT(1,2+IIGLU1) =VHKK(1,NC2T)
38640 VHKT(2,2+IIGLU1) =VHKK(2,NC2T)
38641 VHKT(3,2+IIGLU1) =VHKK(3,NC2T)
38642 VHKT(4,2+IIGLU1) =VHKK(4,NC2T)
38643 WHKT(1,2+IIGLU1) =WHKK(1,NC2T)
38644 WHKT(2,2+IIGLU1) =WHKK(2,NC2T)
38645 WHKT(3,2+IIGLU1) =WHKK(3,NC2T)
38646 WHKT(4,2+IIGLU1) =WHKK(4,NC2T)
38647 IDHKT(3+IIGLU1) =88888
38648 ISTHKT(3+IIGLU1) =94
38649 JMOHKT(1,3+IIGLU1)=1
38650 JMOHKT(2,3+IIGLU1)=2+IIGLU1
38651 JDAHKT(1,3+IIGLU1)=0
38652 JDAHKT(2,3+IIGLU1)=0
38653 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
38654 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
38655 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
38656 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
38657 XMIST
38658 * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38659 * -PHKT(3,3+IIGLU1)**2)
38660 IF(XMIST.GE.0.D0)THEN
38661 PHKT(5,3+IIGLU1)
38662 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38663 * -PHKT(3,3+IIGLU1)**2)
38664 ELSE
38665C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38666 PHKT(5,1)=0.D0
38667 ENDIF
38668 IF(IPIP.GE.3)THEN
38669C IF(NUMEV.EQ.-324)THEN
38670 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),
38671 * JMOHKT(2,1),JDAHKT(1,1),
38672 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
38673 DO 71 IIG=2,2+IIGLU1-1
38674 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38675 & JMOHKT(1,IIG),JMOHKT(2,IIG),
38676 * JDAHKT(1,IIG),
38677 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38678 71 CONTINUE
38679 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
38680 * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
38681 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
38682 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
38683 * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
38684 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
38685 ENDIF
38686 CHAMAL=CHAM1
38687 IF(IPIP.EQ.1)THEN
38688 IF(IP11.GE.3.OR.IPP2.GE.3)CHAMAL=CHAM3
38689 ELSEIF(IPIP.EQ.2)THEN
38690 IF(IP11.LE.-3.OR.IPP2.LE.-3)CHAMAL=CHAM3
38691 ENDIF
38692 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
38693C IREJ=1
38694 IPCO=0
38695C RETURN
38696C WRITE(6,*)' MUSQBS1 jump back from chain 3'
38697 GO TO 3466
38698 ENDIF
38699 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
38700 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
38701 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
38702 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
38703 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
38704 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
38705 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
38706 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
38707 IDHKT(4+IIGLU1) =IP12
38708 ISTHKT(4+IIGLU1) =931
38709 JMOHKT(1,4+IIGLU1)=NC1P
38710 JMOHKT(2,4+IIGLU1)=0
38711 JDAHKT(1,4+IIGLU1)=6+IIGLU1
38712 JDAHKT(2,4+IIGLU1)=0
38713C create chain 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
38714 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
38715 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
38716 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
38717 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
38718C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
38719 XMIST =(PHKT(4,4+IIGLU1)**2-
38720 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
38721 *PHKT(1,4+IIGLU1)**2)
38722 IF(XMIST.GT.0.D0)THEN
38723 PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2-
38724 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
38725 *PHKT(1,4+IIGLU1)**2)
38726 ELSE
38727C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38728 PHKT(5,4+IIGLU1)=0.D0
38729 ENDIF
38730 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
38731 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
38732 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
38733 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
38734 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
38735 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
38736 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
38737 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
38738 IF(IPIP.EQ.1)THEN
38739 IDHKT(5+IIGLU1) =-(ISAQ1-6)
38740 ELSEIF(IPIP.EQ.2)THEN
38741 IDHKT(5+IIGLU1) =ISAQ1
38742 ENDIF
38743 ISTHKT(5+IIGLU1) =932
38744 JMOHKT(1,5+IIGLU1)=NC1T
38745 JMOHKT(2,5+IIGLU1)=0
38746 JDAHKT(1,5+IIGLU1)=6+IIGLU1
38747 JDAHKT(2,5+IIGLU1)=0
38748 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
38749 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
38750 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
38751 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
38752C IF( PHKT(4,5).EQ.0.D0)THEN
38753C IREJ=1
38754CIPCO=0
38755CRETURN
38756C ENDIF
38757C PHKT(5,5) =PHKK(5,NC1T)
38758 XMIST=(PHKT(4,5+IIGLU1)**2-
38759 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
38760 *PHKT(1,5+IIGLU1)**2)
38761 IF(XMIST.GT.0.D0)THEN
38762 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
38763 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
38764 *PHKT(1,5+IIGLU1)**2)
38765 ELSE
38766C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38767 PHKT(5,5+IIGLU1)=0.D0
38768 ENDIF
38769 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
38770 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
38771 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
38772 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
38773 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
38774 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
38775 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
38776 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
38777 IDHKT(6+IIGLU1) =88888
38778 ISTHKT(6+IIGLU1) =94
38779 JMOHKT(1,6+IIGLU1)=4+IIGLU1
38780 JMOHKT(2,6+IIGLU1)=5+IIGLU1
38781 JDAHKT(1,6+IIGLU1)=0
38782 JDAHKT(2,6+IIGLU1)=0
38783 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
38784 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
38785 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
38786 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
38787 XMIST
38788 * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
38789 * -PHKT(3,6+IIGLU1)**2)
38790 IF(XMIST.GE.0.D0)THEN
38791 PHKT(5,6+IIGLU1)
38792 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
38793 * -PHKT(3,6+IIGLU1)**2)
38794 ELSE
38795C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38796 PHKT(5,1)=0.D0
38797 ENDIF
38798C IF(IPIP.EQ.3)THEN
38799 CHAMAL=CHAM1
38800 IF(IPIP.EQ.1)THEN
38801 IF(IP12.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
38802 ELSEIF(IPIP.EQ.2)THEN
38803 IF(IP12.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
38804 ENDIF
38805 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
38806C IREJ=1
38807 IPCO=0
38808C RETURN
38809C WRITE(6,*)' MGSQBS1 jump back from chain 6',
38810C * CHAMAL,PHKT(5,6+IIGLU1)
38811 GO TO 3466
38812 ENDIF
38813 IF(IPIP.GE.3)THEN
38814C IF(NUMEV.EQ.-324)THEN
38815 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
38816 * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
38817 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
38818 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
38819 * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
38820 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
38821 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
38822 * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
38823 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
38824 ENDIF
38825 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
38826 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
38827 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
38828 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
38829 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
38830 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
38831 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
38832 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
38833 IF(IPIP.EQ.1)THEN
38834 IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+3
38835 IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
38836 IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
38837 IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
38838 ELSEIF(IPIP.EQ.2)THEN
38839 IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3
38840 IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
38841 IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
38842 IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
38843C WRITE(6,*)'IDHKT(7+IIGLU1),IPP1,ISQ1',IDHKT(7+IIGLU1),IPP1,ISQ1
38844 ENDIF
38845 ISTHKT(7+IIGLU1) =931
38846 JMOHKT(1,7+IIGLU1)=NC2P
38847 JMOHKT(2,7+IIGLU1)=0
38848 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
38849 JDAHKT(2,7+IIGLU1)=0
38850C create chain 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
38851 PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
38852 PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
38853 PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
38854 PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
38855C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
38856C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
38857 IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
38858C IREJ=1
38859C WRITE(6,*)'reject PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P)'
38860 IPCO=0
38861C RETURN
38862 GO TO 3466
38863 ENDIF
38864C PHKT(5,7) =PHKK(5,NC2P)
38865 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
38866 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
38867 *PHKT(1,7+IIGLU1)**2)
38868 VHKT(1,7+IIGLU1) =VHKK(1,NC2P)
38869 VHKT(2,7+IIGLU1) =VHKK(2,NC2P)
38870 VHKT(3,7+IIGLU1) =VHKK(3,NC2P)
38871 VHKT(4,7+IIGLU1) =VHKK(4,NC2P)
38872 WHKT(1,7+IIGLU1) =WHKK(1,NC2P)
38873 WHKT(2,7+IIGLU1) =WHKK(2,NC2P)
38874 WHKT(3,7+IIGLU1) =WHKK(3,NC2P)
38875 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
38876C Insert here the IIGLU2 gluons
38877 PG1=0.D0
38878 PG2=0.D0
38879 PG3=0.D0
38880 PG4=0.D0
38881 IF(IIGLU2.GE.1)THEN
38882 JJG=NC2P
38883 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38884 KKG=JJG+IIG-7-IIGLU1
38885 IDHKT(IIG) =IDHKK(KKG)
38886 ISTHKT(IIG) =921
38887 JMOHKT(1,IIG)=KKG
38888 JMOHKT(2,IIG)=0
38889 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
38890 JDAHKT(2,IIG)=0
38891 PHKT(1,IIG)=PHKK(1,KKG)
38892 PG1=PG1+ PHKT(1,IIG)
38893 PHKT(2,IIG)=PHKK(2,KKG)
38894 PG2=PG2+ PHKT(2,IIG)
38895 PHKT(3,IIG)=PHKK(3,KKG)
38896 PG3=PG3+ PHKT(3,IIG)
38897 PHKT(4,IIG)=PHKK(4,KKG)
38898 PG4=PG4+ PHKT(4,IIG)
38899 PHKT(5,IIG)=PHKK(5,KKG)
38900 VHKT(1,IIG) =VHKK(1,KKG)
38901 VHKT(2,IIG) =VHKK(2,KKG)
38902 VHKT(3,IIG) =VHKK(3,KKG)
38903 VHKT(4,IIG) =VHKK(4,KKG)
38904 WHKT(1,IIG) =WHKK(1,KKG)
38905 WHKT(2,IIG) =WHKK(2,KKG)
38906 WHKT(3,IIG) =WHKK(3,KKG)
38907 WHKT(4,IIG) =WHKK(4,KKG)
38908 81 CONTINUE
38909 ENDIF
38910 IDHKT(8+IIGLU1+IIGLU2) =IP2
38911 ISTHKT(8+IIGLU1+IIGLU2) =932
38912 JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
38913 JMOHKT(2,8+IIGLU1+IIGLU2)=0
38914 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
38915 JDAHKT(2,8+IIGLU1+IIGLU2)=0
38916 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
38917 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
38918 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
38919 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
38920C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T)
38921 XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
38922 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38923 *PHKT(1,8+IIGLU1+IIGLU2)**2)
38924 IF(XMIST.GT.0.D0)THEN
38925 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
38926 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38927 *PHKT(1,8+IIGLU1+IIGLU2)**2)
38928 ELSE
38929C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38930 PHKT(5,8+IIGLU1+IIGLU2)=0.D0
38931 ENDIF
38932 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T)
38933 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T)
38934 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T)
38935 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T)
38936 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T)
38937 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T)
38938 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T)
38939 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T)
38940 IDHKT(9+IIGLU1+IIGLU2) =88888
38941 ISTHKT(9+IIGLU1+IIGLU2) =94
38942 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
38943 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
38944 JDAHKT(1,9+IIGLU1+IIGLU2)=0
38945 JDAHKT(2,9+IIGLU1+IIGLU2)=0
38946 PHKT(1,9+IIGLU1+IIGLU2)
38947 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
38948 PHKT(2,9+IIGLU1+IIGLU2)
38949 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
38950 PHKT(3,9+IIGLU1+IIGLU2)
38951 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
38952 PHKT(4,9+IIGLU1+IIGLU2)
38953 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
38954 XMIST
38955 *=(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
38956 * -PHKT(2,9+IIGLU1+IIGLU2)**2
38957 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
38958 IF(XMIST.GE.0.D0)THEN
38959 PHKT(5,9+IIGLU1+IIGLU2)
38960 *=SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
38961 * -PHKT(2,9+IIGLU1+IIGLU2)**2
38962 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
38963 ELSE
38964C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38965 PHKT(5,1)=0.D0
38966 ENDIF
38967 IF(IPIP.GE.3)THEN
38968C IF(NUMEV.EQ.-324)THEN
38969 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
38970 * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
38971 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
38972 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38973 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38974 & JMOHKT(1,IIG),JMOHKT(2,IIG),
38975 * JDAHKT(1,IIG),
38976 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38977 91 CONTINUE
38978 WRITE(LOUT,*)8+IIGLU1+IIGLU2,
38979 * ISTHKT(8+IIGLU1+IIGLU2),IDHKT(8+IIGLU1+IIGLU2),
38980 * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
38981 *JDAHKT(1,8+IIGLU1+IIGLU2),
38982 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
38983 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
38984 * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
38985 *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
38986 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
38987 ENDIF
38988 CHAMAL=CHAB1
38989 IF(IPIP.EQ.1)THEN
38990 IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
38991 ELSEIF(IPIP.EQ.2)THEN
38992 IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
38993 ENDIF
38994 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
38995C IREJ=1
38996 IPCO=0
38997C RETURN
38998C WRITE(6,*)' MGSQBS1 jump back from chain 9',
38999C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
39000 GO TO 3466
39001 ENDIF
39002 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
39003 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
39004 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
39005 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
39006 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
39007 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
39008 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
39009 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
39010C
39011 IPCO=0
39012 IGCOUN=9+IIGLU1+IIGLU2
39013 RETURN
39014 END
39015
39016*$ CREATE MGSQBS1.FOR
39017*COPY MGSQBS1
39018C
39019C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
39020 SUBROUTINE MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
39021 * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,ISQ,IGCOUN)
39022C
39023C GSQBS-1 diagram (split projectile diquark)
39024C
39025 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39026 SAVE
39027
39028 PARAMETER ( LINP = 10 ,
39029 & LOUT = 6 ,
39030 & LDAT = 9 )
39031* event history
39032 PARAMETER (NMXHKK=200000)
39033 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
39034 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
39035 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
39036* extended event history
39037 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
39038 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
39039 & IHIST(2,NMXHKK)
39040* Lorentz-parameters of the current interaction
39041 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
39042 & UMO,PPCM,EPROJ,PPROJ
39043* diquark-breaking mechanism
39044 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
39045
39046C
39047 PARAMETER (NTMHKK= 300)
39048 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
39049 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
39050 +(4,NTMHKK)
39051*KEEP,XSEADI.
39052 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
39053 +SSMIMQ,VVMTHR
39054*KEEP,DPRIN.
39055 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
39056C
39057C GSQBS-1 diagram (split projectile diquark)
39058C
39059C
39060C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
39061C Input chain 2(NC2) sea-quark(NC2P)-valence-diquark(NC2T)
39062C
39063C Create quark(qs)-antiquark(aqs) pair energy from NC1P and NC1T
39064C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
39065C
39066C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
39067C 6 valence quark(vq2P 4)-sea-quark(aqsP 5)
39068C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
39069C
39070C Put new chains into COMMON /HKKTMP/
39071C
39072 IIGLU1=NC1T-NC1P-1
39073 IIGLU2=NC2T-NC2P-1
39074 IGCOUN=0
39075C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
39076 CVQ=1.D0
39077 NNNC1=IDHKK(NC1)/1000
39078 MMMC1=IDHKK(NC1)-NNNC1*1000
39079 KKKC1=ISTHKK(NC1)
39080 NNNC2=IDHKK(NC2)/1000
39081 MMMC2=IDHKK(NC2)-NNNC2*1000
39082 KKKC2=ISTHKK(NC2)
39083 IREJ=0
39084 IF(IPIP.EQ.3)THEN
39085 WRITE(LOUT,*)' MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
39086 * ' IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN)',
39087 *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
39088 * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN
39089 ENDIF
39090C
39091C
39092C
39093C determine x-values of NC1P diquark
39094 XDIQP=PHKK(4,NC1P)*2.D0/UMO
39095 XVQT=PHKK(4,NC1T)*2.D0/UMO
39096C
39097C determine x-values of sea quark pair
39098C
39099 IPCO=1
39100 ICOU=0
39101 2234 CONTINUE
39102 ICOU=ICOU+1
39103 IF(ICOU.GE.500)THEN
39104 IREJ=1
39105 IF(ISQ.EQ.3)IREJ=3
39106 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 Rejection 2234 ICOU. GT.100'
39107 IPCO=0
39108 RETURN
39109 ENDIF
39110 IF(IPCO.GE.3)WRITE(LOUT,*)'MGSQBS1 call XSEAPA: UMO,XDIQP,XVQT ',
39111 * UMO, XDIQP,XVQT
39112 XSQ=0.D0
39113 XSAQ=0.D0
39114**NEW
39115C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
39116 IF (IPIP.EQ.1) THEN
39117 XQMAX = XDIQP/2.0D0
39118 XAQMAX = 2.D0*XVQT/3.0D0
39119 ELSE
39120 XQMAX = 2.D0*XVQT/3.0D0
39121 XAQMAX = XDIQP/2.0D0
39122 ENDIF
39123 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
39124 ISAQ = 6+ISQ
39125C write(*,*) 'MGSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
39126**
39127 IF(IPCO.GE.3)
39128 & WRITE(LOUT,*)'MGSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
39129 IF(IREJ.GE.1)THEN
39130 IF(IPCO.GE.3)
39131 & WRITE(LOUT,*)'MGSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
39132 IPCO=0
39133 RETURN
39134 ENDIF
39135 IF(IPIP.EQ.1)THEN
39136 IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
39137 ELSEIF(IPIP.EQ.2)THEN
39138 IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
39139 ENDIF
39140 IF(IPCO.GE.3)THEN
39141 WRITE(LOUT,'(A,4E12.4)')' MGSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
39142 * XDIQP,XVQT,XSQ,XSAQ
39143 ENDIF
39144C
39145C subtract xsq,xsaq from NC1P diquark and NC1T quark
39146C
39147C XSQ=0.D0
39148 IF(IPIP.EQ.1)THEN
39149 XDIQP=XDIQP-XSQ
39150**NEW
39151C IF (XDIQP.LT.0.0D0) WRITE(*,*) ' mgsqbs1: XDIQP<0!!',XDIQP
39152**
39153 XVQT =XVQT -XSAQ
39154 ELSEIF(IPIP.EQ.2)THEN
39155 XDIQP=XDIQP-XSAQ
39156 XVQT =XVQT -XSQ
39157 ENDIF
39158 IF(IPCO.GE.3)
39159 & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
39160C
39161C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
39162C
39163 XVTHRO=CVQ/UMO
39164 IVTHR=0
39165 3466 CONTINUE
39166 IF(IVTHR.EQ.10)THEN
39167 IREJ=1
39168 IF(ISQ.EQ.3)IREJ=3
39169 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 3466 reject IVTHR 10'
39170 IPCO=0
39171 RETURN
39172 ENDIF
39173 IVTHR=IVTHR+1
39174 XVTHR=XVTHRO/(201-IVTHR)
39175 UNOPRV=UNON
39176 380 CONTINUE
39177 IF(XVTHR.GT.0.66D0*XDIQP)THEN
39178 IREJ=1
39179 IF(ISQ.EQ.3)IREJ=3
39180 IF(IPCO.GE.3)
39181 & WRITE(LOUT,*)' MGSQBS1 Rejection 380 XVTHR large ',
39182 * XVTHR
39183 IPCO=0
39184 RETURN
39185 ENDIF
39186 IF(DT_RNDM(V).LT.0.5D0)THEN
39187 XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
39188 XVPQII=XDIQP-XVPQI
39189 ELSE
39190 XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
39191 XVPQI=XDIQP-XVPQII
39192 ENDIF
39193 IF(IPCO.GE.3)THEN
39194 WRITE(LOUT,'(A,4E12.4)')' MGSQBS1:XVTHR,XDIQP,XVPQI,XVPQII ',
39195 * XVTHR,XDIQP,XVPQI,XVPQII
39196 ENDIF
39197C
39198C Prepare 4 momenta of new chains and chain ends
39199C
39200C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
39201C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
39202C +(4,NTMHKK)
39203C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
39204C 6 valence quark(vq2P 4)-sea-quark(aqsP 5)
39205C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
39206 IF(IPIP.EQ.1)THEN
39207 XSQ1=XSQ
39208 XSAQ1=XSAQ
39209 ISQ1=ISQ
39210 ISAQ1=ISAQ
39211 ELSEIF(IPIP.EQ.2)THEN
39212 XSQ1=XSAQ
39213 XSAQ1=XSQ
39214 ISQ1=ISAQ
39215 ISAQ1=ISQ
39216 ENDIF
39217 KK11=IP11
39218C IDHKT(2) =1000*IPP21+100*IPP22+1
39219 KK21= IPP21
39220 KK22= IPP22
39221 XGIVE=0.D0
39222 IDHKT(4+IIGLU1) =IP12
39223 ISTHKT(4+IIGLU1) =921
39224 JMOHKT(1,4+IIGLU1)=NC1P
39225 JMOHKT(2,4+IIGLU1)=0
39226 JDAHKT(1,4+IIGLU1)=6+IIGLU1
39227 JDAHKT(2,4+IIGLU1)=0
39228**NEW
39229 IF ((XDIQP.LT.0.0D0).OR.(XVPQII.LT.0.0D0).OR.
39230 & (XSQ1.LT.0.0D0)) WRITE(LOUT,*) ' mgsqbs1: ',XDIQP,XVPQII,XSQ1
39231**
39232 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
39233 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
39234 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
39235 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
39236C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
39237 XXMIST=(PHKT(4,4+IIGLU1)**2-
39238 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
39239 * PHKT(1,4+IIGLU1)**2)
39240 IF(XXMIST.GT.0.D0)THEN
39241 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
39242 ELSE
39243 WRITE(LOUT,*)'MGSQBS1 XXMIST',XXMIST
39244 XXMIST=ABS(XXMIST)
39245 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
39246 ENDIF
39247 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
39248 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
39249 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
39250 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
39251 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
39252 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
39253 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
39254 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
39255 IF(IPIP.EQ.1)THEN
39256 IDHKT(5+IIGLU1) =-(ISAQ1-6)
39257 ELSEIF(IPIP.EQ.2)THEN
39258 IDHKT(5+IIGLU1) =ISAQ1
39259 ENDIF
39260 ISTHKT(5+IIGLU1) =922
39261 JMOHKT(1,5+IIGLU1)=NC1T
39262 JMOHKT(2,5+IIGLU1)=0
39263 JDAHKT(1,5+IIGLU1)=6+IIGLU1
39264 JDAHKT(2,5+IIGLU1)=0
39265**NEW
39266 IF ((XSAQ1.LT.0.0D0).OR.(XVQT .LT.0.0D0))
39267 & WRITE(LOUT,*) ' mgsqbs2: ',XSAQ1,XVQT
39268**
39269 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
39270 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
39271 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
39272 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
39273C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
39274 XMIST=(PHKT(4,5+IIGLU1)**2-
39275 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
39276 *PHKT(1,5+IIGLU1)**2)
39277 IF(XMIST.GT.0.D0)THEN
39278 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
39279 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
39280 *PHKT(1,5+IIGLU1)**2)
39281 ELSE
39282C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
39283 PHKT(5,5+IIGLU1)=0.D0
39284 ENDIF
39285 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
39286 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
39287 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
39288 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
39289 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
39290 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
39291 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
39292 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
39293 IDHKT(6+IIGLU1) =88888
39294C IDHKT(6) =1000*NNNC1+MMMC1
39295 ISTHKT(6+IIGLU1) =93
39296C ISTHKT(6) =KKKC1
39297 JMOHKT(1,6+IIGLU1)=4+IIGLU1
39298 JMOHKT(2,6+IIGLU1)=5+IIGLU1
39299 JDAHKT(1,6+IIGLU1)=0
39300 JDAHKT(2,6+IIGLU1)=0
39301 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
39302 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
39303 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
39304 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
39305 PHKT(5,6+IIGLU1)
39306 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
39307 * -PHKT(3,6+IIGLU1)**2)
39308 CHAMAL=CHAM1
39309 IF(IPIP.EQ.1)THEN
39310 IF(IP12.GE.3.OR.ISAQ.GE.9)CHAMAL=CHAM3
39311 ELSEIF(IPIP.EQ.2)THEN
39312 IF(IP12.LE.-3.OR.ISAQ.GE.3)CHAMAL=CHAM3
39313 ENDIF
39314 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
39315 IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
39316C we drop chain 6 and give the energy to chain 3
39317 IDHKT(6+IIGLU1)=33888
39318 XGIVE=1.D0
39319C WRITE(6,*)' drop chain 6 xgive=1'
39320 GO TO 7788
39321 ELSEIF(IDHKT(5+IIGLU1).EQ.-IP11)THEN
39322C we drop chain 6 and give the energy to chain 3
39323C and change KK11 to IDHKT(4)
39324 IDHKT(6+IIGLU1)=33888
39325 XGIVE=1.D0
39326C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(4+IIGLU1)'
39327 KK11=IDHKT(4+IIGLU1)
39328 GO TO 7788
39329 ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP21)THEN
39330C we drop chain 6 and give the energy to chain 3
39331C and change KK21 to IDHKT(4)
39332C IDHKT(2) =1000*IPP21+100*IPP22+1
39333 IDHKT(6+IIGLU1)=33888
39334 XGIVE=1.D0
39335C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(4+IIGLU1)'
39336 KK21=IDHKT(4+IIGLU1)
39337 GO TO 7788
39338 ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP22)THEN
39339C we drop chain 6 and give the energy to chain 3
39340C and change KK22 to IDHKT(4)
39341C IDHKT(2) =1000*IPP21+100*IPP22+1
39342 IDHKT(6+IIGLU1)=33888
39343 XGIVE=1.D0
39344C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(4+IIGLU1)'
39345 KK22=IDHKT(4+IIGLU1)
39346 GO TO 7788
39347 ENDIF
39348C IREJ=1
39349 IPCO=0
39350C RETURN
39351C WRITE(6,*)' MGSQBS1 jump back from chain 6'
39352 GO TO 3466
39353 ENDIF
39354 7788 CONTINUE
39355 IF(IPIP.GE.3)THEN
39356 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
39357 * JMOHKT(1,4+IIGLU1),
39358 * JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
39359 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
39360 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
39361 * JMOHKT(1,5+IIGLU1),
39362 * JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
39363 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
39364 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
39365 * JMOHKT(1,6+IIGLU1),
39366 * JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
39367 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
39368 ENDIF
39369 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
39370 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
39371 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
39372 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
39373 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
39374 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
39375 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
39376 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
39377C IDHKT(1) =IP11
39378 IDHKT(1) =KK11
39379 ISTHKT(1) =921
39380 JMOHKT(1,1)=NC1P
39381 JMOHKT(2,1)=0
39382 JDAHKT(1,1)=3+IIGLU1
39383 JDAHKT(2,1)=0
39384 PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
39385C * +0.5D0*PHKK(1,NC2P)
39386 *+XGIVE*PHKT(1,4+IIGLU1)
39387 PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
39388C * +0.5D0*PHKK(2,NC2P)
39389 *+XGIVE*PHKT(2,4+IIGLU1)
39390 PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
39391C * +0.5D0*PHKK(3,NC2P)
39392 *+XGIVE*PHKT(3,4+IIGLU1)
39393 PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
39394C * +0.5D0*PHKK(4,NC2P)
39395 *+XGIVE*PHKT(4,4+IIGLU1)
39396C PHKT(5,1) =PHKK(5,NC1P)
39397 XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
39398 *PHKT(1,1)**2)
39399 IF(XMIST.GE.0.D0)THEN
39400 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
39401 *PHKT(1,1)**2)
39402 ELSE
39403C WRITE(6,*)'MGSQBS1 parton 1 mass square LT.0 ',XMIST
39404 PHKT(5,1)=0.D0
39405 ENDIF
39406 VHKT(1,1) =VHKK(1,NC1P)
39407 VHKT(2,1) =VHKK(2,NC1P)
39408 VHKT(3,1) =VHKK(3,NC1P)
39409 VHKT(4,1) =VHKK(4,NC1P)
39410 WHKT(1,1) =WHKK(1,NC1P)
39411 WHKT(2,1) =WHKK(2,NC1P)
39412 WHKT(3,1) =WHKK(3,NC1P)
39413 WHKT(4,1) =WHKK(4,NC1P)
39414C Add here IIGLU1 gluons to this chaina
39415 PG1=0.D0
39416 PG2=0.D0
39417 PG3=0.D0
39418 PG4=0.D0
39419 IF(IIGLU1.GE.1)THEN
39420 JJG=NC1P
39421 DO 61 IIG=2,2+IIGLU1-1
39422 KKG=JJG+IIG-1
39423 IDHKT(IIG) =IDHKK(KKG)
39424 ISTHKT(IIG) =921
39425 JMOHKT(1,IIG)=KKG
39426 JMOHKT(2,IIG)=0
39427 JDAHKT(1,IIG)=3+IIGLU1
39428 JDAHKT(2,IIG)=0
39429 PHKT(1,IIG)=PHKK(1,KKG)
39430 PG1=PG1+ PHKT(1,IIG)
39431 PHKT(2,IIG)=PHKK(2,KKG)
39432 PG2=PG2+ PHKT(2,IIG)
39433 PHKT(3,IIG)=PHKK(3,KKG)
39434 PG3=PG3+ PHKT(3,IIG)
39435 PHKT(4,IIG)=PHKK(4,KKG)
39436 PG4=PG4+ PHKT(4,IIG)
39437 PHKT(5,IIG)=PHKK(5,KKG)
39438 VHKT(1,IIG) =VHKK(1,KKG)
39439 VHKT(2,IIG) =VHKK(2,KKG)
39440 VHKT(3,IIG) =VHKK(3,KKG)
39441 VHKT(4,IIG) =VHKK(4,KKG)
39442 WHKT(1,IIG) =WHKK(1,KKG)
39443 WHKT(2,IIG) =WHKK(2,KKG)
39444 WHKT(3,IIG) =WHKK(3,KKG)
39445 WHKT(4,IIG) =WHKK(4,KKG)
39446 61 CONTINUE
39447 ENDIF
39448C IDHKT(2) =1000*IPP21+100*IPP22+1
39449 IF(IPIP.EQ.1)THEN
39450 IDHKT(2+IIGLU1) =1000*KK21+100*KK22+3
39451 IF(IDHKT(2+IIGLU1).EQ.1203)IDHKT(2+IIGLU1)=2103
39452 IF(IDHKT(2+IIGLU1).EQ.1303)IDHKT(2+IIGLU1)=3103
39453 IF(IDHKT(2+IIGLU1).EQ.2303)IDHKT(2+IIGLU1)=3203
39454 ELSEIF(IPIP.EQ.2)THEN
39455 IDHKT(2+IIGLU1) =1000*KK21+100*KK22-3
39456 IF(IDHKT(2+IIGLU1).EQ.-1203)IDHKT(2+IIGLU1)=-2103
39457 IF(IDHKT(2+IIGLU1).EQ.-1303)IDHKT(2+IIGLU1)=-3103
39458 IF(IDHKT(2+IIGLU1).EQ.-2303)IDHKT(2+IIGLU1)=-3203
39459 ENDIF
39460 ISTHKT(2+IIGLU1) =922
39461 JMOHKT(1,2+IIGLU1)=NC2T
39462 JMOHKT(2,2+IIGLU1)=0
39463 JDAHKT(1,2+IIGLU1)=3+IIGLU1
39464 JDAHKT(2,2+IIGLU1)=0
39465 PHKT(1,2+IIGLU1) =PHKK(1,NC2T)
39466 *+XGIVE*PHKT(1,5+IIGLU1)
39467 PHKT(2,2+IIGLU1) =PHKK(2,NC2T)
39468 *+XGIVE*PHKT(2,5+IIGLU1)
39469 PHKT(3,2+IIGLU1) =PHKK(3,NC2T)
39470 *+XGIVE*PHKT(3,5+IIGLU1)
39471 PHKT(4,2+IIGLU1) =PHKK(4,NC2T)
39472 *+XGIVE*PHKT(4,5+IIGLU1)
39473C PHKT(5,2) =PHKK(5,NC2T)
39474 XMIST=(PHKT(4,2+IIGLU1)**2-
39475 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
39476 *PHKT(1,2+IIGLU1)**2)
39477 IF(XMIST.GT.0.D0)THEN
39478 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
39479 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
39480 *PHKT(1,2+IIGLU1)**2)
39481 ELSE
39482C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
39483 PHKT(5,2+IIGLU1)=0.D0
39484 ENDIF
39485 VHKT(1,2+IIGLU1) =VHKK(1,NC2T)
39486 VHKT(2,2+IIGLU1) =VHKK(2,NC2T)
39487 VHKT(3,2+IIGLU1) =VHKK(3,NC2T)
39488 VHKT(4,2+IIGLU1) =VHKK(4,NC2T)
39489 WHKT(1,2+IIGLU1) =WHKK(1,NC2T)
39490 WHKT(2,2+IIGLU1) =WHKK(2,NC2T)
39491 WHKT(3,2+IIGLU1) =WHKK(3,NC2T)
39492 WHKT(4,2+IIGLU1) =WHKK(4,NC2T)
39493 IDHKT(3+IIGLU1) =88888
39494C IDHKT(3) =1000*NNNC1+MMMC1+10
39495 ISTHKT(3+IIGLU1) =93
39496C ISTHKT(3) =KKKC1
39497 JMOHKT(1,3+IIGLU1)=1
39498 JMOHKT(2,3+IIGLU1)=2+IIGLU1
39499 JDAHKT(1,3+IIGLU1)=0
39500 JDAHKT(2,3+IIGLU1)=0
39501 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
39502 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
39503 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
39504 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
39505 PHKT(5,3+IIGLU1)
39506 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
39507 * -PHKT(3,3+IIGLU1)**2)
39508 IF(IPIP.GE.3)THEN
39509 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
39510 * JDAHKT(1,1),
39511 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
39512 DO 71 IIG=2,2+IIGLU1-1
39513 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
39514 & JMOHKT(1,IIG),JMOHKT(2,IIG),
39515 * JDAHKT(1,IIG),
39516 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
39517 71 CONTINUE
39518 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),
39519 & IDHKT(2),JMOHKT(1,2+IIGLU1),
39520 * JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
39521 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
39522 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
39523 * JMOHKT(1,3+IIGLU1),
39524 * JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
39525 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
39526 ENDIF
39527 CHAMAL=CHAB1
39528**NEW
39529C IF(IPIP.EQ.1)THEN
39530C IF(IPP21.GE.3.OR.IPP22.GE.3.OR.IP11.GE.3)CHAMAL=CHAB3
39531C ELSEIF(IPIP.EQ.2)THEN
39532C IF(IPP21.LE.-3.OR.IPP22.LE.-3.OR.IP11.LE.-3)CHAMAL=CHAB3
39533C ENDIF
39534 IF(IPIP.EQ.1)THEN
39535 IF(KK21.GE.3.OR.KK22.GE.3.OR.KK11.GE.3)CHAMAL=CHAB3
39536 ELSEIF(IPIP.EQ.2)THEN
39537 IF(KK21.LE.-3.OR.KK22.LE.-3.OR.KK11.LE.-3)CHAMAL=CHAB3
39538 ENDIF
39539**
39540 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
39541C IREJ=1
39542 IPCO=0
39543C RETURN
39544C WRITE(6,*)' MGSQBS1 jump back from chain 3'
39545 GO TO 3466
39546 ENDIF
39547 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
39548 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
39549 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
39550 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
39551 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
39552 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
39553 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
39554 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
39555 IF(IPIP.EQ.1)THEN
39556 IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ1+3
39557 IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
39558 IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
39559 IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
39560 ELSEIF(IPIP.EQ.2)THEN
39561 IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3
39562 IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
39563 IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
39564 IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
39565C WRITE(6,*)'IDHKT(7),IPP1,ISQ1',IDHKT(7),IPP1,ISQ1
39566 ENDIF
39567 ISTHKT(7+IIGLU1) =921
39568 JMOHKT(1,7+IIGLU1)=NC2P
39569 JMOHKT(2,7+IIGLU1)=0
39570 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
39571 JDAHKT(2,7+IIGLU1)=0
39572C PHKT(1,7) =0.5D0*PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ/(XDIQP+XSQ)
39573C PHKT(2,7) =0.5D0*PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ/(XDIQP+XSQ)
39574C PHKT(3,7) =0.5D0*PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ/(XDIQP+XSQ)
39575C PHKT(4,7+IIGLU1) =0.5D0*PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ/(XDIQP+XSQ)
39576**NEW
39577 IF ((XSQ1 .LT.0.0D0).OR.(XDIQP .LT.0.0D0))
39578 & WRITE(LOUT,*) ' mgsqbs3: ',XSQ1,XDIQP
39579**
39580 PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
39581 PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
39582 PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
39583 PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
39584C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
39585C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
39586 IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
39587C IREJ=1
39588C WRITE(6,*)'reject PHKT(4,7).GE. PHKK(4,NC1P)'
39589 IPCO=0
39590C RETURN
39591 GO TO 3466
39592 ENDIF
39593C PHKT(5,7) =PHKK(5,NC2P)
39594 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
39595 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
39596 *PHKT(1,7+IIGLU1)**2)
39597 VHKT(1,7+IIGLU1) =VHKK(1,NC2P)
39598 VHKT(2,7+IIGLU1) =VHKK(2,NC2P)
39599 VHKT(3,7+IIGLU1) =VHKK(3,NC2P)
39600 VHKT(4,7+IIGLU1) =VHKK(4,NC2P)
39601 WHKT(1,7+IIGLU1) =WHKK(1,NC2P)
39602 WHKT(2,7+IIGLU1) =WHKK(2,NC2P)
39603 WHKT(3,7+IIGLU1) =WHKK(3,NC2P)
39604 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
39605C Insert here the IIGLU2 gluons
39606 PG1=0.D0
39607 PG2=0.D0
39608 PG3=0.D0
39609 PG4=0.D0
39610 IF(IIGLU2.GE.1)THEN
39611 JJG=NC2P
39612 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
39613 KKG=JJG+IIG-7-IIGLU1
39614 IDHKT(IIG) =IDHKK(KKG)
39615 ISTHKT(IIG) =921
39616 JMOHKT(1,IIG)=KKG
39617 JMOHKT(2,IIG)=0
39618 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
39619 JDAHKT(2,IIG)=0
39620 PHKT(1,IIG)=PHKK(1,KKG)
39621 PG1=PG1+ PHKT(1,IIG)
39622 PHKT(2,IIG)=PHKK(2,KKG)
39623 PG2=PG2+ PHKT(2,IIG)
39624 PHKT(3,IIG)=PHKK(3,KKG)
39625 PG3=PG3+ PHKT(3,IIG)
39626 PHKT(4,IIG)=PHKK(4,KKG)
39627 PG4=PG4+ PHKT(4,IIG)
39628 PHKT(5,IIG)=PHKK(5,KKG)
39629 VHKT(1,IIG) =VHKK(1,KKG)
39630 VHKT(2,IIG) =VHKK(2,KKG)
39631 VHKT(3,IIG) =VHKK(3,KKG)
39632 VHKT(4,IIG) =VHKK(4,KKG)
39633 WHKT(1,IIG) =WHKK(1,KKG)
39634 WHKT(2,IIG) =WHKK(2,KKG)
39635 WHKT(3,IIG) =WHKK(3,KKG)
39636 WHKT(4,IIG) =WHKK(4,KKG)
39637 81 CONTINUE
39638 ENDIF
39639 IDHKT(8+IIGLU1+IIGLU2) =IP2
39640 ISTHKT(8+IIGLU1+IIGLU2) =922
39641 JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
39642 JMOHKT(2,8+IIGLU1+IIGLU2)=0
39643 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
39644 JDAHKT(2,8+IIGLU1+IIGLU2)=0
39645**NEW
39646 IF ((XVQT.LT.0.0D0).OR.(XSAQ1 .LT.0.0D0))
39647 & WRITE(LOUT,*) ' mgsqbs4: ',XVQT,XSAQ1
39648**
39649 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
39650 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
39651 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
39652 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
39653C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T)
39654 XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
39655 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
39656 *PHKT(1,8+IIGLU1+IIGLU2)**2)
39657 IF(XMIST.GT.0.D0)THEN
39658 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
39659 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
39660 *PHKT(1,8+IIGLU1+IIGLU2)**2)
39661 ELSE
39662C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
39663 PHKT(5,8+IIGLU1+IIGLU2)=0.D0
39664 ENDIF
39665 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T)
39666 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T)
39667 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T)
39668 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T)
39669 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T)
39670 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T)
39671 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T)
39672 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T)
39673 IDHKT(9+IIGLU1+IIGLU2) =88888
39674C IDHKT(9) =1000*NNNC2+MMMC2+10
39675 ISTHKT(9+IIGLU1+IIGLU2) =93
39676C ISTHKT(9) =KKKC2
39677 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
39678 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
39679 JDAHKT(1,9+IIGLU1+IIGLU2)=0
39680 JDAHKT(2,9+IIGLU1+IIGLU2)=0
39681 PHKT(1,9+IIGLU1+IIGLU2) =PHKT(1,7+IIGLU1)
39682 * +PHKT(1,8+IIGLU1+IIGLU2)+PG1
39683 PHKT(2,9+IIGLU1+IIGLU2) =PHKT(2,7+IIGLU1)
39684 * +PHKT(2,8+IIGLU1+IIGLU2)+PG2
39685 PHKT(3,9+IIGLU1+IIGLU2) =PHKT(3,7+IIGLU1)
39686 * +PHKT(3,8+IIGLU1+IIGLU2)+PG3
39687 PHKT(4,9+IIGLU1+IIGLU2) =PHKT(4,7+IIGLU1)
39688 * +PHKT(4,8+IIGLU1+IIGLU2)+PG4
39689 PHKT(5,9+IIGLU1+IIGLU2)
39690 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
39691 * PHKT(2,9+IIGLU1+IIGLU2)**2
39692 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
39693 IF(IPIP.GE.3)THEN
39694 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
39695 * JMOHKT(1,7+IIGLU1),
39696 * JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
39697 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
39698 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
39699 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
39700 & JMOHKT(1,IIG),JMOHKT(2,IIG),
39701 * JDAHKT(1,IIG),
39702 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
39703 91 CONTINUE
39704 WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
39705 * IDHKT(8+IIGLU1+IIGLU2),
39706 * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
39707 * JDAHKT(1,8+IIGLU1+IIGLU2),
39708 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
39709 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
39710 * IDHKT(9+IIGLU1+IIGLU2),
39711 * JMOHKT(1,9+IIGLU1+IIGLU2),JMOHKT(2,9+IIGLU1+IIGLU2),
39712 * JDAHKT(1,9+IIGLU1+IIGLU2),
39713 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
39714 ENDIF
39715 CHAMAL=CHAB1
39716 IF(IPIP.EQ.1)THEN
39717 IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
39718 ELSEIF(IPIP.EQ.2)THEN
39719 IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
39720 ENDIF
39721 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
39722C IREJ=1
39723 IPCO=0
39724C RETURN
39725C WRITE(6,*)' MGSQBS1 jump back from chain 9',
39726C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
39727 GO TO 3466
39728 ENDIF
39729 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
39730 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
39731 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
39732 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
39733 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
39734 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
39735 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
39736 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
39737C
39738 IGCOUN=9+IIGLU1+IIGLU2
39739 IPCO=0
39740 RETURN
39741 END
39742
39743*$ CREATE HKKHKT.FOR
39744*COPY HKKHKT
39745C
39746C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
39747C
39748 SUBROUTINE HKKHKT(I,J)
39749 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39750 SAVE
39751
39752* event history
39753 PARAMETER (NMXHKK=200000)
39754 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
39755 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
39756 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
39757* extended event history
39758 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
39759 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
39760 & IHIST(2,NMXHKK)
39761
39762 PARAMETER (NTMHKK= 300)
39763 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
39764 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
39765 +(4,NTMHKK)
39766C
39767 ISTHKK(I) =ISTHKT(J)
39768 IDHKK(I) =IDHKT(J)
39769C IF(J.EQ.3.OR.J.EQ.6.OR.J.EQ.9)THEN
39770 IF(IDHKK(I).EQ.88888)THEN
39771C JMOHKK(1,I)=I-2
39772C JMOHKK(2,I)=I-1
39773 JMOHKK(1,I)=I-(J-JMOHKT(1,J))
39774 JMOHKK(2,I)=I-(J-JMOHKT(2,J))
39775 ELSE
39776 JMOHKK(1,I)=JMOHKT(1,J)
39777 JMOHKK(2,I)=JMOHKT(2,J)
39778 ENDIF
39779 JDAHKK(1,I)=JDAHKT(1,J)
39780 JDAHKK(2,I)=JDAHKT(2,J)
39781C IF(J.EQ.1.OR.J.EQ.4.OR.J.EQ.7)THEN
39782C JDAHKK(1,I)=I+2
39783C ELSEIF(J.EQ.2.OR.J.EQ.5.OR.J.EQ.8)THEN
39784C JDAHKK(1,I)=I+1
39785C ENDIF
39786 IF(JDAHKT(1,J).GT.0)THEN
39787 JDAHKK(1,I)=I+(JDAHKT(1,J)-J)
39788 ENDIF
39789 PHKK(1,I) =PHKT(1,J)
39790 PHKK(2,I) =PHKT(2,J)
39791 PHKK(3,I) =PHKT(3,J)
39792 PHKK(4,I) =PHKT(4,J)
39793 PHKK(5,I) =PHKT(5,J)
39794 VHKK(1,I) =VHKT(1,J)
39795 VHKK(2,I) =VHKT(2,J)
39796 VHKK(3,I) =VHKT(3,J)
39797 VHKK(4,I) =VHKT(4,J)
39798 WHKK(1,I) =WHKT(1,J)
39799 WHKK(2,I) =WHKT(2,J)
39800 WHKK(3,I) =WHKT(3,J)
39801 WHKK(4,I) =WHKT(4,J)
39802 RETURN
39803 END
39804
39805*$ CREATE DT_DBREAK.FOR
39806*COPY DT_DBREAK
39807*
39808*===dbreak=============================================================*
39809*
39810 SUBROUTINE DT_DBREAK(MODE)
39811
39812************************************************************************
39813* This is the steering subroutine for the different diquark breaking *
39814* mechanisms. *
39815* *
39816* MODE = 1 breaking of projectile diquark in qq-q chain using *
39817* a sea quark (q-qq chain) of the same projectile *
39818* = 2 breaking of target diquark in q-qq chain using *
39819* a sea quark (qq-q chain) of the same target *
39820* = 3 breaking of projectile diquark in qq-q chain using *
39821* a sea quark (q-aq chain) of the same projectile *
39822* = 4 breaking of target diquark in q-qq chain using *
39823* a sea quark (aq-q chain) of the same target *
39824* = 5 breaking of projectile anti-diquark in aqaq-aq chain using *
39825* a sea anti-quark (aq-aqaq chain) of the same projectile *
39826* = 6 breaking of target anti-diquark in aq-aqaq chain using *
39827* a sea anti-quark (aqaq-aq chain) of the same target *
39828* = 7 breaking of projectile anti-diquark in aqaq-aq chain using *
39829* a sea anti-quark (aq-q chain) of the same projectile *
39830* = 8 breaking of target anti-diquark in aq-aqaq chain using *
39831* a sea anti-quark (q-aq chain) of the same target *
39832* *
39833* Original version by J. Ranft. *
39834* This version dated 17.5.00 is written by S. Roesler. *
39835************************************************************************
39836
39837 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39838 SAVE
39839 PARAMETER ( LINP = 10 ,
39840 & LOUT = 6 ,
39841 & LDAT = 9 )
39842
39843* event history
39844 PARAMETER (NMXHKK=200000)
39845 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
39846 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
39847 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
39848* extended event history
39849 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
39850 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
39851 & IHIST(2,NMXHKK)
39852* flags for input different options
39853 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
39854 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
39855 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
39856* pointer to chains in hkkevt common (used by qq-breaking mechanisms)
39857 PARAMETER (MAXCHN=10000)
39858 COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
39859* diquark-breaking mechanism
39860 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
39861* flags for particle decays
39862 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
39863 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
39864 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
39865
39866*
39867* chain identifiers
39868* ( 1 = q-aq, 2 = aq-q, 3 = q-qq, 4 = qq-q,
39869* 5 = aq-adq, 6 = adq-aq, 7 = dq-adq, 8 = adq-dq )
39870 DIMENSION IDCHN1(8),IDCHN2(8)
39871 DATA IDCHN1 / 4, 3, 4, 3, 6, 5, 6, 5/
39872 DATA IDCHN2 / 3, 4, 1, 2, 5, 6, 2, 1/
39873*
39874* parton identifiers
39875* ( +-21/22 = valence, +-31/32 = Glauber-sea, +-41/42 = Pomeron (diff),
39876* +-51/52 = unitarity-sea, +-61/62 = gluons )
39877 DIMENSION ISP1P(8,3),ISP1T(8,3),ISP2P(8,3),ISP2T(8,3)
39878 DATA ISP1P / 21, 21, 21, 21, 21, 21, 21, 21,
39879 & 31, 31, 31, 31, 31, 31, 31, 31,
39880 & 41, 41, 41, 41, 51, 51, 51, 51/
39881 DATA ISP1T / 22, 22, 22, 22, 22, 22, 22, 22,
39882 & 32, 32, 32, 32, 32, 32, 32, 32,
39883 & 42, 42, 42, 42, 52, 52, 52, 52/
39884 DATA ISP2P / 31, 21, 31, 31, 21, 21, 21, 21,
39885 & 51, 31, 41, 41, 31, 31, 31, 31,
39886 & 0, 41, 51, 51, 51, 51, 51, 51/
39887 DATA ISP2T / 22, 32, 32, 32, 22, 22, 22, 22,
39888 & 32, 52, 42, 42, 32, 32, 32, 32,
39889 & 42, 0, 52, 52, 52, 52, 52, 52/
39890
39891 IF (NCHAIN.LE.0) RETURN
39892 DO 1 I=1,NCHAIN
39893 IDX1 = IDXCHN(1,I)
39894 IS1P = ABS(ISTHKK(JMOHKK(1,IDX1)))
39895 IS1T = ABS(ISTHKK(JMOHKK(2,IDX1)))
39896 IF ( (IDXCHN(2,I).EQ.IDCHN1(MODE))
39897 & .AND.
39898 & ((IS1P.EQ.ISP1P(MODE,1)).OR.(IS1P.EQ.ISP1P(MODE,2)).OR.
39899 & (IS1P.EQ.ISP1P(MODE,3)))
39900 & .AND.
39901 & ((IS1T.EQ.ISP1T(MODE,1)).OR.(IS1T.EQ.ISP1T(MODE,2)).OR.
39902 & (IS1T.EQ.ISP1T(MODE,3)))
39903 & ) THEN
39904 DO 2 J=1,NCHAIN
39905 IDX2 = IDXCHN(1,J)
39906 IS2P = ABS(ISTHKK(JMOHKK(1,IDX2)))
39907 IS2T = ABS(ISTHKK(JMOHKK(2,IDX2)))
39908 IF ( (IDXCHN(2,J).EQ.IDCHN2(MODE))
39909 & .AND.
39910 & ((IS2P.EQ.ISP2P(MODE,1)).OR.(IS2P.EQ.ISP2P(MODE,2))
39911 & .OR.(IS2P.EQ.ISP2P(MODE,3)))
39912 & .AND.
39913 & ((IS2T.EQ.ISP2T(MODE,1)).OR.(IS2T.EQ.ISP2T(MODE,2))
39914 & .OR.(IS2T.EQ.ISP2T(MODE,3)))
39915 & ) THEN
39916* find mother nucleons of the diquark to be splitted and of the
39917* sea-quark and reject this combination if it is not the same
39918 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.
39919 & (MODE.EQ.5).OR.(MODE.EQ.7)) THEN
39920 IANCES = 1
39921 ELSE
39922 IANCES = 2
39923 ENDIF
39924 IDXMO1 = JMOHKK(IANCES,IDX1)
39925 4 CONTINUE
39926 IF ((JMOHKK(1,IDXMO1).NE.0).AND.
39927 & (JMOHKK(2,IDXMO1).NE.0)) THEN
39928 IANC = IANCES
39929 ELSE
39930 IANC = 1
39931 ENDIF
39932 IF (JMOHKK(IANC,IDXMO1).NE.0) THEN
39933 IDXMO1 = JMOHKK(IANC,IDXMO1)
39934 GOTO 4
39935 ENDIF
39936 IDXMO2 = JMOHKK(IANCES,IDX2)
39937 5 CONTINUE
39938 IF ((JMOHKK(1,IDXMO2).NE.0).AND.
39939 & (JMOHKK(2,IDXMO2).NE.0)) THEN
39940 IANC = IANCES
39941 ELSE
39942 IANC = 1
39943 ENDIF
39944 IF (JMOHKK(IANC,IDXMO2).NE.0) THEN
39945 IDXMO2 = JMOHKK(IANC,IDXMO2)
39946 GOTO 5
39947 ENDIF
39948 IF (IDXMO1.NE.IDXMO2) GOTO 2
39949* quark content of projectile parton
39950 IP1 = IDHKK(JMOHKK(1,IDX1))
39951 IP11 = IP1/1000
39952 IP12 = (IP1-1000*IP11)/100
39953 IP2 = IDHKK(JMOHKK(2,IDX1))
39954 IP21 = IP2/1000
39955 IP22 = (IP2-1000*IP21)/100
39956* quark content of target parton
39957 IT1 = IDHKK(JMOHKK(1,IDX2))
39958 IT11 = IT1/1000
39959 IT12 = (IT1-1000*IT11)/100
39960 IT2 = IDHKK(JMOHKK(2,IDX2))
39961 IT21 = IT2/1000
39962 IT22 = (IT2-1000*IT21)/100
39963* split diquark and form new chains
39964 IF (MODE.EQ.1) THEN
39965 IF (IT1.EQ.4) GOTO 2
39966 CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39967 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39968 & IP11,IP12,IP2,IT1,IT21,IT22,1,IPQ,IGCOUN)
39969 ELSEIF (MODE.EQ.2) THEN
39970 IF (IT2.EQ.4) GOTO 2
39971 CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39972 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39973 & IP1,IP21,IP22,IT11,IT12,IT2,1,IPQ,IGCOUN)
39974 ELSEIF (MODE.EQ.3) THEN
39975 IF (IT1.EQ.4) GOTO 2
39976 CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39977 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39978 & IP11,IP12,IP2,IT1,IT2,1,IPQ,IGCOUN)
39979 ELSEIF (MODE.EQ.4) THEN
39980 IF (IT2.EQ.4) GOTO 2
39981 CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39982 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39983 & IP1,IP21,IP22,IT1,IT2,1,IPQ,IGCOUN)
39984 ELSEIF (MODE.EQ.5) THEN
39985 CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39986 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39987 & IP11,IP12,IP2,IT1,IT21,IT22,2,IPQ,IGCOUN)
39988 ELSEIF (MODE.EQ.6) THEN
39989 CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39990 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39991 & IP1,IP21,IP22,IT11,IT12,IT2,2,IPQ,IGCOUN)
39992 ELSEIF (MODE.EQ.7) THEN
39993 CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39994 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39995 & IP11,IP12,IP2,IT1,IT2,2,IPQ,IGCOUN)
39996 ELSEIF (MODE.EQ.8) THEN
39997 CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39998 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39999 & IP1,IP21,IP22,IT1,IT2,2,IPQ,IGCOUN)
40000 ENDIF
40001 IF (IREJ.GE.1) THEN
40002 if ((ipq.lt.0).or.(ipq.ge.4))
40003 & write(LOUT,*) 'ipq !!!',ipq,mode
40004 DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
40005* accept or reject new chains corresponding to PDBSEA
40006 ELSE
40007 IF ((IPQ.EQ.1).OR.(IPQ.EQ.2)) THEN
40008 ACC = DBRKA(1,MODE)+DBRKA(2,MODE)
40009 REJ = DBRKR(1,MODE)+DBRKR(2,MODE)
40010 ELSEIF (IPQ.EQ.3) THEN
40011 ACC = DBRKA(3,MODE)
40012 REJ = DBRKR(3,MODE)
40013 ELSE
40014 WRITE(LOUT,*) ' inconsistent IPQ ! ',IPQ
40015 STOP
40016 ENDIF
40017 IF (ACC/(ACC+REJ).LE.PDBSEA(IPQ)) THEN
40018 DBRKA(IPQ,MODE) = DBRKA(IPQ,MODE)+1.0D0
40019 IACC = 1
40020 ELSE
40021 DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
40022 IACC = 0
40023 ENDIF
40024* new chains have been accepted and are now copied into HKKEVT
40025 IF (IACC.EQ.1) THEN
40026 IF (LEMCCK) THEN
40027 CALL DT_EVTEMC(PHKK(1,IDX1),PHKK(2,IDX1),
40028 & PHKK(3,IDX1),PHKK(4,IDX1),
40029 & 1,IDUM1,IDUM2)
40030 CALL DT_EVTEMC(PHKK(1,IDX2),PHKK(2,IDX2),
40031 & PHKK(3,IDX2),PHKK(4,IDX2),
40032 & 2,IDUM1,IDUM2)
40033 ENDIF
40034 IDHKK(IDX1) = 99888
40035 IDHKK(IDX2) = 99888
40036 IDXCHN(2,I) = -1
40037 IDXCHN(2,J) = -1
40038 DO 3 K=1,IGCOUN
40039 NHKK = NHKK+1
40040 CALL HKKHKT(NHKK,K)
40041 IF ((LEMCCK).AND.(IDHKK(NHKK).EQ.88888))THEN
40042 PX = -PHKK(1,NHKK)
40043 PY = -PHKK(2,NHKK)
40044 PZ = -PHKK(3,NHKK)
40045 PE = -PHKK(4,NHKK)
40046 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
40047 ENDIF
40048 3 CONTINUE
40049 IF (LEMCCK) THEN
40050 CHKLEV = 0.1D0
40051 CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,9000,
40052 & IREJ)
40053 IF (IREJ.NE.0) CALL DT_EVTOUT(4)
40054 ENDIF
40055 GOTO 1
40056 ENDIF
40057 ENDIF
40058 ENDIF
40059 2 CONTINUE
40060 ENDIF
40061 1 CONTINUE
40062 RETURN
40063 END
40064
40065*$ CREATE DT_CQPAIR.FOR
40066*COPY DT_CQPAIR
40067*
40068*===cqpair=============================================================*
40069*
40070 SUBROUTINE DT_CQPAIR(XQMAX,XAQMAX,XQ,XAQ,IFLV,IREJ)
40071
40072************************************************************************
40073* This subroutine Creates a Quark-antiquark PAIR from the sea. *
40074* *
40075* XQMAX maxium energy fraction of quark (input) *
40076* XAQMAX maxium energy fraction of antiquark (input) *
40077* XQ energy fraction of quark (output) *
40078* XAQ energy fraction of antiquark (output) *
40079* IFLV quark flavour (- antiquark flavor) (output) *
40080* *
40081* This version dated 14.5.00 is written by S. Roesler. *
40082************************************************************************
40083
40084 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
40085 SAVE
40086 PARAMETER ( LINP = 10 ,
40087 & LOUT = 6 ,
40088 & LDAT = 9 )
40089
40090* Lorentz-parameters of the current interaction
40091 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
40092 & UMO,PPCM,EPROJ,PPROJ
40093
40094*
40095 IREJ = 0
40096 XQ = 0.0D0
40097 XAQ = 0.0D0
40098*
40099* sample quark flavour
40100*
40101* set seasq here (the one from DTCHAI should be used in the future)
40102 SEASQ = 0.5D0
40103 IFLV = INT(1.0D0+DT_RNDM(XQMAX)*(2.0D0+SEASQ))
40104*
40105* sample energy fractions of sea pair
40106* we first sample the energy fraction of a gluon and then split the gluon
40107*
40108* maximum energy fraction of the gluon forced via input
40109 XGMAXI = XQMAX+XAQMAX
40110* minimum energy fraction of the gluon
40111 XTHR1 = 4.0D0 /UMO**2
40112 XTHR2 = 0.54D0/UMO**1.5D0
40113 XGMIN = MAX(XTHR1,XTHR2)
40114* maximum energy fraction of the gluon
40115 XGMAX = 0.3D0
40116 XGMAX = MIN(XGMAXI,XGMAX)
40117 IF (XGMIN.GE.XGMAX) THEN
40118 IREJ = 1
40119 RETURN
40120 ENDIF
40121*
40122* sample energy fraction of the gluon
40123 NLOOP = 0
40124 1 CONTINUE
40125 NLOOP = NLOOP+1
40126 IF (NLOOP.GE.50) THEN
40127 IREJ = 1
40128 RETURN
40129 ENDIF
40130 XGLUON = DT_SAMSQX(XGMIN,XGMAX)
40131 EGLUON = XGLUON*UMO/2.0D0
40132*
40133* split gluon into q-aq pair (we follow PHOJET's subroutine PHO_GLU2QU)
40134 ZMIN = MIN(0.1D0,0.5D0/EGLUON)
40135 ZMAX = 1.0D0-ZMIN
40136 RZ = DT_RNDM(ZMAX)
40137 XHLP = ((1.0D0-RZ)*ZMIN**3+RZ*ZMAX**3)**0.33333
40138 RQ = DT_RNDM(ZMAX)
40139 IF (RQ.LT.0.5D0) THEN
40140 XQ = XGLUON*XHLP
40141 XAQ = XGLUON-XQ
40142 ELSE
40143 XAQ = XGLUON*XHLP
40144 XQ = XGLUON-XAQ
40145 ENDIF
40146 IF ((XQ.GT.XQMAX).OR.(XAQ.GT.XAQMAX)) GOTO 1
40147
40148 RETURN
40149 END