]> 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
Removed obsolete default chamber resolution parameters from AliMUONConstants (now...
[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)
172 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
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
2102 IF ((IP.GT.1).AND.(MKCRON.GT.0)) THEN
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
2169 PARAMETER (NMXHKK=200000)
2170 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
2171 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
2172 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
2173* extended event history
2174 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
2175 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
2176 & IHIST(2,NMXHKK)
2177* particle properties (BAMJET index convention)
2178 CHARACTER*8 ANAME
2179 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2180 & IICH(210),IIBAR(210),K1(210),K2(210)
2181* properties of interacting particles
2182 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2183* Lorentz-parameters of the current interaction
2184 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
2185 & UMO,PPCM,EPROJ,PPROJ
2186* flags for input different options
2187 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2188 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2189 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2190* flags for particle decays
2191 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
2192 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
2193 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
2194* cuts for variable energy runs
2195 COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
2196* Glauber formalism: flags and parameters for statistics
2197 LOGICAL LPROD
2198 CHARACTER*8 CGLB
2199 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
2200
2201 DIMENSION WHAT(6)
2202
2203 IREJ = 0
2204 ILOOP = 0
2205 100 CONTINUE
2206 IF (ILOOP.EQ.4) THEN
2207 WRITE(LOUT,1000) NEVHKK
2208 1000 FORMAT(1X,'KKINC: event ',I8,' rejected!')
2209 GOTO 9999
2210 ENDIF
2211 ILOOP = ILOOP+1
2212
2213* variable energy-runs, recalculate parameters for LT's
2214 IF ((ABS(VAREHI).GT.ZERO).OR.(IOGLB.EQ.100)) THEN
2215 PDUM = ZERO
2216 CDUM = ZERO
2217 CALL DT_LTINI(IDP,1,EPN,PDUM,CDUM,1)
2218 ENDIF
2219 IF (EPN.GT.EPROJ) THEN
2220 WRITE(LOUT,'(A,E9.3,2A,E9.3,A)')
2221 & ' Requested energy (',EPN,'GeV) exceeds',
2222 & ' initialization energy (',EPROJ,'GeV) !'
2223 STOP
2224 ENDIF
2225
2226* re-initialize /DTPRTA/
2227 IP = NPMASS
2228 IPZ = NPCHAR
2229 IT = NTMASS
2230 ITZ = NTCHAR
2231 IJPROJ = IDP
2232 IBPROJ = IIBAR(IJPROJ)
2233
2234* calculate nuclear potentials (common /DTNPOT/)
2235 CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
2236
2237* initialize treatment for residual nuclei
2238 CALL DT_RESNCL(EPN,NLOOP,1)
2239
2240* sample hadron/nucleus-nucleus interaction
2241 CALL DT_KKEVNT(KKMAT,IREJ1)
2242 IF (IREJ1.GT.0) THEN
2243 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKINC'
2244 GOTO 9999
2245 ENDIF
2246
2247 IF ((NPMASS.GT.1).OR.(NTMASS.GT.1)) THEN
2248
2249* intranuclear cascade of final state particles for KTAUGE generations
2250* of secondaries
2251 CALL DT_FOZOCA(LFZC,IREJ1)
2252 IF (IREJ1.GT.0) THEN
2253 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKINC'
2254 GOTO 9999
2255 ENDIF
2256
2257* baryons unable to escape the nuclear potential are treated as
2258* excited nucleons (ISTHKK=15,16)
2259 CALL DT_SCN4BA
2260
2261* decay of resonances produced in intranuclear cascade processes
2262**sr 15-11-95 should be obsolete
2263C IF (LFZC) CALL DT_DECAY1
2264
2265 101 CONTINUE
2266* treatment of residual nuclei
2267 CALL DT_RESNCL(EPN,NLOOP,2)
2268
2269* evaporation / fission / fragmentation
2270* (if intranuclear cascade was sampled only)
2271 IF (LFZC) THEN
2272 CALL DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ1)
2273 IF (IREJ1.GT.1) GOTO 101
2274 IF (IREJ1.EQ.1) GOTO 100
2275 ENDIF
2276
2277 ENDIF
2278
2279* rejection of unphysical configurations
2280 CALL DT_REJUCO(1,IREJ1)
2281 IF (IREJ1.GT.0) THEN
2282 IF (IOULEV(1).GT.0)
2283 & WRITE(LOUT,*) 'rejected 3 in KKINC: too large x'
2284 GOTO 100
2285 ENDIF
2286
2287* transform finale state into Lab.
2288 IFLAG = 2
2289 CALL DT_BEAMPR(WHAT,DUM,IFLAG)
2290 IF ((IFRAME.EQ.1).AND.(IFLAG.EQ.-1)) CALL DT_LT2LAB
2291
2292 IF (IPI0.EQ.1) CALL DT_DECPI0
2293
2294C IF (NEVHKK.EQ.5) CALL DT_EVTOUT(4)
2295
2296 RETURN
2297 9999 CONTINUE
2298 IREJ = 1
2299 RETURN
2300 END
2301
2302*$ CREATE DT_DEFAUL.FOR
2303*COPY DT_DEFAUL
2304*
2305*===defaul=============================================================*
2306*
2307 SUBROUTINE DT_DEFAUL(EPN,PPN)
2308
2309************************************************************************
2310* Variables are set to default values. *
2311* This version dated 8.5.95 is written by S. Roesler. *
2312************************************************************************
2313
2314 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2315 SAVE
2316 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
2317 PARAMETER (TWOPI = 6.283185307179586454D+00)
2318
2319* particle properties (BAMJET index convention)
2320 CHARACTER*8 ANAME
2321 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2322 & IICH(210),IIBAR(210),K1(210),K2(210)
2323* nuclear potential
2324 LOGICAL LFERMI
2325 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
2326 & EBINDP(2),EBINDN(2),EPOT(2,210),
2327 & ETACOU(2),ICOUL,LFERMI
2328* interface HADRIN-DPM
2329 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
2330* central particle production, impact parameter biasing
2331 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
2332* properties of interacting particles
2333 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2334* properties of photon/lepton projectiles
2335 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
2336 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2337* emulsion treatment
2338 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2339 & NCOMPO,IEMUL
2340* parameter for intranuclear cascade
2341 LOGICAL LPAULI
2342 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
2343* various options for treatment of partons (DTUNUC 1.x)
2344* (chain recombination, Cronin,..)
2345 LOGICAL LCO2CR,LINTPT
2346 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
2347 & LCO2CR,LINTPT
2348* threshold values for x-sampling (DTUNUC 1.x)
2349 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
2350 & SSMIMQ,VVMTHR
2351* flags for input different options
2352 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2353 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2354 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2355* n-n cross section fluctuations
2356 PARAMETER (NBINS = 1000)
2357 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
2358* flags for particle decays
2359 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
2360 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
2361 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
2362* diquark-breaking mechanism
2363 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
2364* nucleon-nucleon event-generator
2365 CHARACTER*8 CMODEL
2366 LOGICAL LPHOIN
2367 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
2368* flags for diffractive interactions (DTUNUC 1.x)
2369 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
2370* VDM parameter for photon-nucleus interactions
2371 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
2372* Glauber formalism: flags and parameters for statistics
2373 LOGICAL LPROD
2374 CHARACTER*8 CGLB
2375 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
2376* kinematical cuts for lepton-nucleus interactions
2377 COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
2378 & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
2379* flags for activated histograms
2380 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
2381* cuts for variable energy runs
2382 COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
2383* parameters for hA-diffraction
2384 COMMON /DTDIHA/ DIBETA,DIALPH
2385* LEPTO
2386 REAL RPPN
2387 COMMON /LEPTOI/ RPPN,LEPIN,INTER
2388* steering flags for qel neutrino scattering modules
2389 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
2390* event flag
2391 COMMON /DTEVNO/ NEVENT,ICASCA
2392
2393 DATA POTMES /0.002D0/
2394
2395* common /DTNPOT/
2396 DO 10 I=1,2
2397 PFERMP(I) = ZERO
2398 PFERMN(I) = ZERO
2399 EBINDP(I) = ZERO
2400 EBINDN(I) = ZERO
2401 DO 11 J=1,210
2402 EPOT(I,J) = ZERO
2403 11 CONTINUE
2404* nucleus independent meson potential
2405 EPOT(I,13) = POTMES
2406 EPOT(I,14) = POTMES
2407 EPOT(I,15) = POTMES
2408 EPOT(I,16) = POTMES
2409 EPOT(I,23) = POTMES
2410 EPOT(I,24) = POTMES
2411 EPOT(I,25) = POTMES
2412 10 CONTINUE
2413 FERMOD = 0.55D0
2414 ETACOU(1) = ZERO
2415 ETACOU(2) = ZERO
2416 ICOUL = 1
2417 LFERMI = .TRUE.
2418
2419* common /HNTHRE/
2420 EHADTH = -99.0D0
2421 EHADLO = 4.06D0
2422 EHADHI = 6.0D0
2423 INTHAD = 1
2424 IDXTA = 2
2425
2426* common /DTIMPA/
2427 ICENTR = 0
2428 BIMIN = ZERO
2429 BIMAX = 1.0D10
2430 XSFRAC = 1.0D0
2431
2432* common /DTPRTA/
2433 IP = 1
2434 IPZ = 1
2435 IT = 1
2436 ITZ = 1
2437 IJPROJ = 1
2438 IBPROJ = 1
2439 IJTARG = 1
2440 IBTARG = 1
2441* common /DTGPRO/
2442 VIRT = ZERO
2443 DO 14 I=1,4
2444 PGAMM(I) = ZERO
2445 PLEPT0(I) = ZERO
2446 PLEPT1(I) = ZERO
2447 PNUCL(I) = ZERO
2448 14 CONTINUE
2449 IDIREC = 0
2450
2451* common /DTFOTI/
2452**sr 7.4.98: changed after corrected B-sampling
2453C TAUFOR = 4.4D0
2454 TAUFOR = 3.5D0
2455 KTAUGE = 25
2456 ITAUVE = 1
2457 INCMOD = 1
2458 LPAULI = .TRUE.
2459
2460* common /DTCHAI/
2461 SEASQ = ONE
2462 MKCRON = 1
2463 CRONCO = 0.64D0
2464 ISICHA = 0
2465 CUTOF = 100.0D0
2466 LCO2CR = .FALSE.
2467 IRECOM = 1
2468 LINTPT = .TRUE.
2469
2470* common /DTXCUT/
2471* definition of soft quark distributions
2472 XSEACU = 0.05D0
2473 UNON = 2.0D0
2474 UNOM = 1.5D0
2475 UNOSEA = 5.0D0
2476* cutoff parameters for x-sampling
2477 CVQ = 1.0D0
2478 CDQ = 2.0D0
2479C CSEA = 0.3D0
2480 CSEA = 0.1D0
2481 SSMIMA = 1.2D0
2482 SSMIMQ = SSMIMA**2
2483 VVMTHR = 2.0D0
2484
2485* common /DTXSFL/
2486 IFLUCT = 0
2487
2488* common /DTFRPA/
2489 PDB = 0.15D0
2490 PDBSEA(1) = 0.0D0
2491 PDBSEA(2) = 0.0D0
2492 PDBSEA(3) = 0.0D0
2493 ISIG0 = 0
2494 IPI0 = 0
2495 NMSTU = 0
2496 NPARU = 0
2497 NMSTJ = 0
2498 NPARJ = 0
2499
2500* common /DTDIQB/
2501 DO 15 I=1,8
2502 DBRKR(1,I) = 5.0D0
2503 DBRKR(2,I) = 5.0D0
2504 DBRKR(3,I) = 10.0D0
2505 DBRKA(1,I) = ZERO
2506 DBRKA(2,I) = ZERO
2507 DBRKA(3,I) = ZERO
2508 15 CONTINUE
2509 CHAM1 = 0.2D0
2510 CHAM3 = 0.5D0
2511 CHAB1 = 0.7D0
2512 CHAB3 = 1.0D0
2513
2514* common /DTFLG3/
2515 ISINGD = 0
2516 IDOUBD = 0
2517 IFLAGD = 0
2518 IDIFF = 0
2519
2520* common /DTMODL/
2521 MCGENE = 2
2522 CMODEL(1) = 'DTUNUC '
2523 CMODEL(2) = 'PHOJET '
2524 CMODEL(3) = 'LEPTO '
2525 CMODEL(4) = 'QNEUTRIN'
2526 LPHOIN = .TRUE.
2527 ELOJET = 5.0D0
2528
2529* common /DTLCUT/
2530 ECMIN = 3.5D0
2531 ECMAX = 1.0D10
2532 XBJMIN = ZERO
2533 ELMIN = ZERO
2534 EGMIN = ZERO
2535 EGMAX = 1.0D10
2536 YMIN = TINY10
2537 YMAX = 0.999D0
2538 Q2MIN = TINY10
2539 Q2MAX = 10.0D0
2540 THMIN = ZERO
2541 THMAX = TWOPI
2542 Q2LI = ZERO
2543 Q2HI = 1.0D10
2544 ECMLI = ZERO
2545 ECMHI = 1.0D10
2546
2547* common /DTVDMP/
2548 RL2 = 2.0D0
2549 INTRGE(1) = 1
2550 INTRGE(2) = 3
2551 IDPDF = 2212
2552 MODEGA = 4
2553 ISHAD(1) = 1
2554 ISHAD(2) = 1
2555 ISHAD(3) = 1
2556 EPSPOL = ZERO
2557
2558* common /DTGLGP/
2559 JSTATB = 1000
2560 JBINSB = 49
2561 CGLB = ' '
2562 IF (ITRSPT.EQ.1) THEN
2563 IOGLB = 100
2564 ELSE
2565 IOGLB = 0
2566 ENDIF
2567 LPROD = .TRUE.
2568
2569* common /DTHIS3/
2570 DO 16 I=1,50
2571 IHISPP(I) = 0
2572 IHISXS(I) = 0
2573 16 CONTINUE
2574 IXSTBL = 0
2575
2576* common /DTVARE/
2577 VARELO = ZERO
2578 VAREHI = ZERO
2579 VARCLO = ZERO
2580 VARCHI = ZERO
2581
2582* common /DTDIHA/
2583 DIBETA = -1.0D0
2584 DIALPH = ZERO
2585
2586* common /LEPTOI/
2587 RPPN = 0.0
2588 LEPIN = 0
2589 INTER = 0
2590
2591* common /QNEUTO/
2592 NEUTYP = 1
2593 NEUDEC = 0
2594
2595* common /DTEVNO/
2596 NEVENT = 1
2597 IF (ITRSPT.EQ.1) THEN
2598 ICASCA = 1
2599 ELSE
2600 ICASCA = 0
2601 ENDIF
2602
2603* default Lab.-energy
2604 EPN = 200.0D0
2605 PPN = SQRT((EPN-AAM(IJPROJ))*(EPN+AAM(IJPROJ)))
2606
2607 RETURN
2608 END
2609
2610*$ CREATE DT_AAEVT.FOR
2611*COPY DT_AAEVT
2612*
2613*===aaevt==============================================================*
2614*
2615 SUBROUTINE DT_AAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
2616 & IDP,IGLAU)
2617
2618************************************************************************
2619* This version dated 22.03.96 is written by S. Roesler. *
2620************************************************************************
2621
2622 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2623 SAVE
2624 PARAMETER ( LINP = 10 ,
2625 & LOUT = 6 ,
2626 & LDAT = 9 )
2627
2628 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2629* emulsion treatment
2630 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2631 & NCOMPO,IEMUL
2632* event flag
2633 COMMON /DTEVNO/ NEVENT,ICASCA
2634
2635 CHARACTER*8 DATE,HHMMSS
2636 DIMENSION IDMNYR(3)
2637
2638 KKMAT = 1
2639 NMSG = MAX(NEVTS/100,1)
2640
2641* initialization of run-statistics and histograms
2642 CALL DT_STATIS(1)
2643 CALL PHO_PHIST(1000,DUM)
2644
2645* initialization of Glauber-formalism
2646 IF (NCOMPO.LE.0) THEN
2647 CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
2648 ELSE
2649 DO 1 I=1,NCOMPO
2650 CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
2651 1 CONTINUE
2652 ENDIF
2653 CALL DT_SIGEMU
2654
2655 CALL IDATE(IDMNYR)
2656 WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2657 & IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
2658 CALL ITIME(IDMNYR)
2659 WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)')
2660 & IDMNYR(1),IDMNYR(2),IDMNYR(3)
2661 WRITE(LOUT,1001) DATE,HHMMSS
2662 1001 FORMAT(/,' DT_AAEVT: Initialisation finished. ( Date: ',A8,
2663 & ' Time: ',A8,' )')
2664
2665* generate NEVTS events
2666 DO 2 IEVT=1,NEVTS
2667
2668* print run-status message
2669 IF (MOD(IEVT,NMSG).EQ.0) THEN
2670 CALL IDATE(IDMNYR)
2671 WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2672 & IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
2673 CALL ITIME(IDMNYR)
2674 WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)')
2675 & IDMNYR(1),IDMNYR(2),IDMNYR(3)
2676 WRITE(LOUT,1000) IEVT-1,NEVTS,DATE,HHMMSS
2677 1000 FORMAT(/,1X,I8,' out of ',I8,' events sampled ( Date: ',A,
2678 & ' Time: ',A,' )',/)
2679C WRITE(LOUT,1000) IEVT-1
2680C1000 FORMAT(1X,I8,' events sampled')
2681 ENDIF
2682 NEVENT = IEVT
2683* treat nuclear emulsions
2684 IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
2685* composite targets only
2686 KKMAT = -KKMAT
2687* sample this event
2688 CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,IREJ)
2689
2690 CALL PHO_PHIST(2000,DUM)
2691
2692 2 CONTINUE
2693
2694* print run-statistics and histograms to output-unit 6
2695 CALL PHO_PHIST(3000,DUM)
2696 CALL DT_STATIS(2)
2697
2698 RETURN
2699 END
2700
2701*$ CREATE DT_LAEVT.FOR
2702*COPY DT_LAEVT
2703*
2704*===laevt==============================================================*
2705*
2706 SUBROUTINE DT_LAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
2707 & IDP,IGLAU)
2708
2709************************************************************************
2710* Interface to run DPMJET for lepton-nucleus interactions. *
2711* Kinematics is sampled using the equivalent photon approximation *
2712* Based on GPHERA-routine by R. Engel. *
2713* This version dated 23.03.96 is written by S. Roesler. *
2714************************************************************************
2715
2716 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2717 SAVE
2718 PARAMETER ( LINP = 10 ,
2719 & LOUT = 6 ,
2720 & LDAT = 9 )
2721 PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,
2722 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
2723 PARAMETER (TWOPI = 6.283185307179586454D+00,
2724 & PI = TWOPI/TWO,
2725 & ALPHEM = ONE/137.0D0)
2726
2727C CHARACTER*72 HEADER
2728
2729* particle properties (BAMJET index convention)
2730 CHARACTER*8 ANAME
2731 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2732 & IICH(210),IIBAR(210),K1(210),K2(210)
2733* event history
2734 PARAMETER (NMXHKK=200000)
2735 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
2736 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
2737 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
2738* extended event history
2739 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
2740 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
2741 & IHIST(2,NMXHKK)
2742* kinematical cuts for lepton-nucleus interactions
2743 COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
2744 & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
2745* properties of interacting particles
2746 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2747* properties of photon/lepton projectiles
2748 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
2749* kinematics at lepton-gamma vertex
2750 COMMON /DTLGVX/ PPL0(4),PPL1(4),PPG(4),PPA(4)
2751* flags for activated histograms
2752 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
2753 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2754* emulsion treatment
2755 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2756 & NCOMPO,IEMUL
2757* Glauber formalism: cross sections
2758 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
2759 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
2760 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
2761 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
2762 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
2763 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
2764 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
2765 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
2766 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
2767 & BSLOPE,NEBINI,NQBINI
2768* nucleon-nucleon event-generator
2769 CHARACTER*8 CMODEL
2770 LOGICAL LPHOIN
2771 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
2772* flags for input different options
2773 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2774 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2775 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2776* event flag
2777 COMMON /DTEVNO/ NEVENT,ICASCA
2778
2779 DIMENSION XDUMB(40),BGTA(4)
2780
2781* LEPTO
2782 IF (MCGENE.EQ.3) THEN
2783 STOP ' This version does not contain LEPTO !'
2784 ENDIF
2785
2786 KKMAT = 1
2787 NMSG = MAX(NEVTS/10,1)
2788
2789* mass of incident lepton
2790 AMLPT = AAM(IDP)
2791 AMLPT2 = AMLPT**2
2792 IDPPDG = IDT_IPDGHA(IDP)
2793
2794* consistency of kinematical limits
2795 Q2MIN = MAX(Q2MIN,TINY10)
2796 Q2MAX = MAX(Q2MAX,TINY10)
2797 YMIN = MIN(MAX(YMIN,TINY10),0.999D0)
2798 YMAX = MIN(MAX(YMAX,TINY10),0.999D0)
2799
2800* total energy of the lepton-nucleon system
2801 PTOTLN = SQRT( (PLEPT0(1)+PNUCL(1))**2+(PLEPT0(2)+PNUCL(2))**2
2802 & +(PLEPT0(3)+PNUCL(3))**2 )
2803 ETOTLN = PLEPT0(4)+PNUCL(4)
2804 ECMLN = SQRT((ETOTLN-PTOTLN)*(ETOTLN+PTOTLN))
2805 ECMAX = MIN(ECMAX,ECMLN)
2806 WRITE(LOUT,1003) ECMIN,ECMAX,YMIN,YMAX,Q2MIN,Q2MAX,EGMIN,
2807 & THMIN,THMAX,ELMIN
2808 1003 FORMAT(1X,'LAEVT:',16X,'kinematical cuts',/,22X,
2809 & '------------------',/,9X,'W (min) =',
2810 & F7.1,' GeV (max) =',F7.1,' GeV',/,9X,'y (min) =',
2811 & F7.3,8X,'(max) =',F7.3,/,9X,'Q^2 (min) =',F7.1,
2812 & ' GeV^2 (max) =',F7.1,' GeV^2',/,' (Lab) E_g (min) ='
2813 & ,F7.1,' GeV',/,' (Lab) theta (min) =',F7.4,8X,'(max) =',
2814 & F7.4,' for E_lpt >',F7.1,' GeV',/)
2815
2816* Lorentz-parameter for transf. into Lab
2817 BGTA(1) = PNUCL(1)/AAM(1)
2818 BGTA(2) = PNUCL(2)/AAM(1)
2819 BGTA(3) = PNUCL(3)/AAM(1)
2820 BGTA(4) = PNUCL(4)/AAM(1)
2821* LT of incident lepton into Lab and dump it in DTEVT1
2822 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
2823 & PLEPT0(1),PLEPT0(2),PLEPT0(3),PLEPT0(4),
2824 & PLTOT,PPL0(1),PPL0(2),PPL0(3),PPL0(4))
2825 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
2826 & PNUCL(1),PNUCL(2),PNUCL(3),PNUCL(4),
2827 & PLTOT,PPA(1),PPA(2),PPA(3),PPA(4))
2828* maximum energy of photon nucleon system
2829 PTOTGN = SQRT((YMAX*PPL0(1)+PPA(1))**2+(YMAX*PPL0(2)+PPA(2))**2
2830 & +(YMAX*PPL0(3)+PPA(3))**2)
2831 ETOTGN = YMAX*PPL0(4)+PPA(4)
2832 EGNMAX = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN))
2833 EGNMAX = MIN(EGNMAX,ECMAX)
2834* minimum energy of photon nucleon system
2835 PTOTGN = SQRT((YMIN*PPL0(1)+PPA(1))**2+(YMIN*PPL0(2)+PPA(2))**2
2836 & +(YMIN*PPL0(3)+PPA(3))**2)
2837 ETOTGN = YMIN*PPL0(4)+PPA(4)
2838 EGNMIN = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN))
2839 EGNMIN = MAX(EGNMIN,ECMIN)
2840
2841* limits for Glauber-initialization
2842 Q2LI = Q2MIN
2843 Q2HI = MAX(Q2LI,MIN(Q2HI,Q2MAX))
2844 ECMLI = MAX(EGNMIN,THREE)
2845 ECMHI = EGNMAX
2846 WRITE(LOUT,1004) EGNMIN,EGNMAX,ECMLI,ECMHI,Q2LI,Q2HI
2847 1004 FORMAT(1X,'resulting limits:',/,9X,'W (min) =',F7.1,
2848 & ' GeV (max) =',F7.1,' GeV',/,/,' limits for ',
2849 & 'Glauber-initialization:',/,9X,'W (min) =',F7.1,
2850 & ' GeV (max) =',F7.1,' GeV',/,9X,'Q^2 (min) =',F7.1,
2851 & ' GeV^2 (max) =',F7.1,' GeV^2',/)
2852* initialization of Glauber-formalism
2853 IF (NCOMPO.LE.0) THEN
2854 CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
2855 ELSE
2856 DO 9 I=1,NCOMPO
2857 CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
2858 9 CONTINUE
2859 ENDIF
2860 CALL DT_SIGEMU
2861
2862* initialization of run-statistics and histograms
2863 CALL DT_STATIS(1)
2864 CALL PHO_PHIST(1000,DUM)
2865
2866* maximum photon-nucleus cross section
2867 I1 = 1
2868 I2 = 1
2869 RAT = ONE
2870 IF (EGNMAX.GE.ECMNN(NEBINI)) THEN
2871 I1 = NEBINI
2872 I2 = NEBINI
2873 RAT = ONE
2874 ELSEIF (EGNMAX.GT.ECMNN(1)) THEN
2875 DO 5 I=2,NEBINI
2876 IF (EGNMAX.LT.ECMNN(I)) THEN
2877 I1 = I-1
2878 I2 = I
2879 RAT = (EGNMAX-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
2880 GOTO 6
2881 ENDIF
2882 5 CONTINUE
2883 6 CONTINUE
2884 ENDIF
2885 SIGMAX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
2886 EGNXX = EGNMAX
2887 I1 = 1
2888 I2 = 1
2889 RAT = ONE
2890 IF (EGNMIN.GE.ECMNN(NEBINI)) THEN
2891 I1 = NEBINI
2892 I2 = NEBINI
2893 RAT = ONE
2894 ELSEIF (EGNMIN.GT.ECMNN(1)) THEN
2895 DO 7 I=2,NEBINI
2896 IF (EGNMIN.LT.ECMNN(I)) THEN
2897 I1 = I-1
2898 I2 = I
2899 RAT = (EGNMIN-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
2900 GOTO 8
2901 ENDIF
2902 7 CONTINUE
2903 8 CONTINUE
2904 ENDIF
2905 SIGXX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
2906 IF (SIGXX.GT.SIGMAX) EGNXX = EGNMIN
2907 SIGMAX = MAX(SIGMAX,SIGXX)
2908 WRITE(LOUT,'(9X,A,F8.3,A)') 'Sigma_tot (max) =',SIGMAX,' mb'
2909
2910* plot photon flux table
2911 AYMIN = LOG(YMIN)
2912 AYMAX = LOG(YMAX)
2913 AYRGE = AYMAX-AYMIN
2914 MAXTAB = 50
2915 ADY = LOG(YMAX/YMIN)/DBLE(MAXTAB-1)
2916C WRITE(LOUT,'(/,1X,A)') 'LAEVT: photon flux '
2917 DO 1 I=1,MAXTAB
2918 Y = EXP(AYMIN+ADY*DBLE(I-1))
2919 Q2LOW = MAX(Q2MIN,AMLPT2*Y**2/(ONE-Y))
2920 FF1 = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
2921 & -TWO*AMLPT2*Y*(ONE/Q2LOW-ONE/Q2MAX))
2922 FF2 = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
2923 & -TWO*(ONE-Y)/Y*(ONE-Q2LOW/Q2MAX))
2924C WRITE(LOUT,'(5X,3E15.4)') Y,FF1,FF2
2925 1 CONTINUE
2926
2927* maximum residual weight for flux sampling (dy/y)
2928 YY = YMIN
2929 Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY))
2930 WGHMAX = (ONE+(ONE-YY)**2)*LOG(Q2MAX/Q2LOW)
2931 & -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY
2932
2933 CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY0)
2934 CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY1)
2935 CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY2)
2936 CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ0)
2937 CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ1)
2938 CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ2)
2939 CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE0)
2940 CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE1)
2941 CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE2)
2942 CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU0)
2943 CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU1)
2944 CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU2)
2945 XBLOW = 0.001D0
2946 CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX0)
2947 CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX1)
2948 CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX2)
2949
2950 ITRY = 0
2951 ITRW = 0
2952 NC0 = 0
2953 NC1 = 0
2954
2955* generate events
2956 DO 2 IEVT=1,NEVTS
2957 IF (MOD(IEVT,NMSG).EQ.0) THEN
2958C OPEN(LDAT,FILE='/scrtch3/hr/sroesler/statusd5.out',
2959C & STATUS='UNKNOWN')
2960 WRITE(LOUT,'(1X,I8,A)') IEVT-1,' events sampled'
2961C CLOSE(LDAT)
2962 ENDIF
2963 NEVENT = IEVT
2964
2965 100 CONTINUE
2966 ITRY = ITRY+1
2967
2968* sample y
2969 101 CONTINUE
2970 ITRW = ITRW+1
2971 YY = EXP(AYRGE*DT_RNDM(RAT)+AYMIN)
2972 Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY))
2973 Q2LOG = LOG(Q2MAX/Q2LOW)
2974 WGH = (ONE+(ONE-YY)**2)*Q2LOG
2975 & -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY
2976 IF (WGHMAX.LT.WGH) WRITE(LOUT,1000) YY,WGHMAX,WGH
2977 1000 FORMAT(1X,'LAEVT: weight error!',3E12.5)
2978 IF (DT_RNDM(YY)*WGHMAX.GT.WGH) GOTO 101
2979
2980* sample Q2
2981 YEFF = ONE+(ONE-YY)**2
2982 102 CONTINUE
2983 Q2 = Q2LOW*EXP(Q2LOG*DT_RNDM(YY))
2984 WGH = (YEFF-TWO*(ONE-YY)*Q2LOW/Q2)/YEFF
2985 IF (WGH.LT.DT_RNDM(Q2)) GOTO 102
2986
2987c NC0 = NC0+1
2988c CALL DT_FILHGR(YY,ONE,IHFLY0,NC0)
2989c CALL DT_FILHGR(Q2,ONE,IHFLQ0,NC0)
2990
2991* kinematics at lepton-photon vertex
2992* scattered electron
2993 YQ2 = SQRT((ONE-YY)*Q2)
2994 Q2E = Q2/(4.0D0*PLEPT0(4))
2995 E1Y = (ONE-YY)*PLEPT0(4)
2996 CALL DT_DSFECF(SIF,COF)
2997 PLEPT1(1) = YQ2*COF
2998 PLEPT1(2) = YQ2*SIF
2999 PLEPT1(3) = E1Y-Q2E
3000 PLEPT1(4) = E1Y+Q2E
3001C THETA = ACOS( (E1Y-Q2E)/(E1Y+Q2E) )
3002* radiated photon
3003 PGAMM(1) = -PLEPT1(1)
3004 PGAMM(2) = -PLEPT1(2)
3005 PGAMM(3) = PLEPT0(3)-PLEPT1(3)
3006 PGAMM(4) = PLEPT0(4)-PLEPT1(4)
3007* E_cm cut
3008 PTOTGN = SQRT( (PGAMM(1)+PNUCL(1))**2+(PGAMM(2)+PNUCL(2))**2
3009 & +(PGAMM(3)+PNUCL(3))**2 )
3010 ETOTGN = PGAMM(4)+PNUCL(4)
3011 ECMGN = (ETOTGN-PTOTGN)*(ETOTGN+PTOTGN)
3012 IF (ECMGN.LT.0.1D0) GOTO 101
3013 ECMGN = SQRT(ECMGN)
3014 IF ((ECMGN.LT.ECMIN).OR.(ECMGN.GT.ECMAX)) GOTO 101
3015
3016* Lorentz-transformation into nucleon-rest system
3017 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3018 & PGAMM(1),PGAMM(2),PGAMM(3),PGAMM(4),
3019 & PGTOT,PPG(1),PPG(2),PPG(3),PPG(4))
3020 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3021 & PLEPT1(1),PLEPT1(2),PLEPT1(3),PLEPT1(4),
3022 & PLTOT,PPL1(1),PPL1(2),PPL1(3),PPL1(4))
3023* temporary checks..
3024 Q2TMP = ABS(PPG(4)**2-PGTOT**2)
3025 IF (ABS(Q2-Q2TMP).GT.0.01D0) WRITE(LOUT,1001) Q2,Q2TMP
3026 1001 FORMAT(1X,'LAEVT: inconsistent kinematics (Q2,Q2TMP) ',
3027 & 2F10.4)
3028 ECMTMP = SQRT((PPG(4)+AAM(1)-PGTOT)*(PPG(4)+AAM(1)+PGTOT))
3029 IF (ABS(ECMGN-ECMTMP).GT.TINY10) WRITE(LOUT,1002) ECMGN,ECMTMP
3030 1002 FORMAT(1X,'LAEVT: inconsistent kinematics (ECMGN,ECMTMP) ',
3031 & 2F10.2)
3032 YYTMP = PPG(4)/PPL0(4)
3033 IF (ABS(YY-YYTMP).GT.0.01D0) WRITE(LOUT,1005) YY,YYTMP
3034 1005 FORMAT(1X,'LAEVT: inconsistent kinematics (YY,YYTMP) ',
3035 & 2F10.4)
3036
3037* lepton tagger (Lab)
3038 THETA = ACOS( PPL1(3)/PLTOT )
3039 IF (PPL1(4).GT.ELMIN) THEN
3040 IF ((THETA.LT.THMIN).OR.(THETA.GT.THMAX)) GOTO 101
3041 ENDIF
3042* photon energy-cut (Lab)
3043 IF (PPG(4).LT.EGMIN) GOTO 101
3044 IF (PPG(4).GT.EGMAX) GOTO 101
3045* x_Bj cut
3046 XBJ = ABS(Q2/(1.876D0*PPG(4)))
3047 IF (XBJ.LT.XBJMIN) GOTO 101
3048
3049 NC0 = NC0+1
3050 CALL DT_FILHGR( Q2,ONE,IHFLQ0,NC0)
3051 CALL DT_FILHGR( YY,ONE,IHFLY0,NC0)
3052 CALL DT_FILHGR( XBJ,ONE,IHFLX0,NC0)
3053 CALL DT_FILHGR(PPG(4),ONE,IHFLU0,NC0)
3054 CALL DT_FILHGR( ECMGN,ONE,IHFLE0,NC0)
3055
3056* rotation angles against z-axis
3057 COD = PPG(3)/PGTOT
3058C SID = SQRT((ONE-COD)*(ONE+COD))
3059 PPT = SQRT(PPG(1)**2+PPG(2)**2)
3060 SID = PPT/PGTOT
3061 COF = ONE
3062 SIF = ZERO
3063 IF (PGTOT*SID.GT.TINY10) THEN
3064 COF = PPG(1)/(SID*PGTOT)
3065 SIF = PPG(2)/(SID*PGTOT)
3066 ANORF = SQRT(COF*COF+SIF*SIF)
3067 COF = COF/ANORF
3068 SIF = SIF/ANORF
3069 ENDIF
3070
3071 IF (IXSTBL.EQ.0) THEN
3072* change to photon projectile
3073 IJPROJ = 7
3074* set virtuality
3075 VIRT = Q2
3076* re-initialize LTs with new kinematics
3077* !!PGAMM ist set in cms (ECMGN) along z
3078 EPN = ZERO
3079 PPN = ZERO
3080 CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,ECMGN,0)
3081* force Lab-system
3082 IFRAME = 1
3083* get emulsion component if requested
3084 IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
3085* convolute with cross section
3086 CALL DT_SIGGAT(Q2LOW,EGNXX,STOTX,KKMAT)
3087 CALL DT_SIGGAT(Q2,ECMGN,STOT,KKMAT)
3088 IF (STOTX.LT.STOT) WRITE(LOUT,'(1X,A,/,6E12.3)')
3089 & 'LAEVT: warning STOTX<STOT ! ',Q2LOW,EGNMAX,STOTX,
3090 & Q2,ECMGN,STOT
3091 IF (DT_RNDM(Q2)*STOTX.GT.STOT) GOTO 100
3092 NC1 = NC1+1
3093 CALL DT_FILHGR( Q2,ONE,IHFLQ1,NC1)
3094 CALL DT_FILHGR( YY,ONE,IHFLY1,NC1)
3095 CALL DT_FILHGR( XBJ,ONE,IHFLX1,NC1)
3096 CALL DT_FILHGR(PPG(4),ONE,IHFLU1,NC1)
3097 CALL DT_FILHGR( ECMGN,ONE,IHFLE1,NC1)
3098* composite targets only
3099 KKMAT = -KKMAT
3100* sample this event
3101 CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IJPROJ,EPN,KKMAT,
3102 & IREJ)
3103* rotate momenta of final state particles back in photon-nucleon syst.
3104 DO 4 I=NPOINT(4),NHKK
3105 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
3106 & (ISTHKK(I).EQ.1001)) THEN
3107 PX = PHKK(1,I)
3108 PY = PHKK(2,I)
3109 PZ = PHKK(3,I)
3110 CALL DT_MYTRAN(1,PX,PY,PZ,COD,SID,COF,SIF,
3111 & PHKK(1,I),PHKK(2,I),PHKK(3,I))
3112 ENDIF
3113 4 CONTINUE
3114 ENDIF
3115
3116 CALL DT_FILHGR( Q2,ONE,IHFLQ2,NC1)
3117 CALL DT_FILHGR( YY,ONE,IHFLY2,NC1)
3118 CALL DT_FILHGR( XBJ,ONE,IHFLX2,NC1)
3119 CALL DT_FILHGR(PPG(4),ONE,IHFLU2,NC1)
3120 CALL DT_FILHGR( ECMGN,ONE,IHFLE2,NC1)
3121
3122* dump this event to histograms
3123 CALL PHO_PHIST(2000,DUM)
3124
3125 2 CONTINUE
3126
3127 WGY = ALPHEM/TWOPI*WGHMAX*DBLE(ITRY)/DBLE(ITRW)
3128 WGY = WGY*LOG(YMAX/YMIN)
3129 WEIGHT = WGY*SIGMAX*DBLE(NEVTS)/DBLE(ITRY)
3130
3131C HEADER = ' LAEVT: Q^2 distribution 0'
3132C CALL DT_OUTHGR(IHFLQ0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3133C HEADER = ' LAEVT: Q^2 distribution 1'
3134C CALL DT_OUTHGR(IHFLQ1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3135C HEADER = ' LAEVT: Q^2 distribution 2'
3136C CALL DT_OUTHGR(IHFLQ2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3137C HEADER = ' LAEVT: y distribution 0'
3138C CALL DT_OUTHGR(IHFLY0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3139C HEADER = ' LAEVT: y distribution 1'
3140C CALL DT_OUTHGR(IHFLY1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3141C HEADER = ' LAEVT: y distribution 2'
3142C CALL DT_OUTHGR(IHFLY2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3143C HEADER = ' LAEVT: x distribution 0'
3144C CALL DT_OUTHGR(IHFLX0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3145C HEADER = ' LAEVT: x distribution 1'
3146C CALL DT_OUTHGR(IHFLX1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3147C HEADER = ' LAEVT: x distribution 2'
3148C CALL DT_OUTHGR(IHFLX2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3149C HEADER = ' LAEVT: E_g distribution 0'
3150C CALL DT_OUTHGR(IHFLU0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3151C HEADER = ' LAEVT: E_g distribution 1'
3152C CALL DT_OUTHGR(IHFLU1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3153C HEADER = ' LAEVT: E_g distribution 2'
3154C CALL DT_OUTHGR(IHFLU2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3155C HEADER = ' LAEVT: E_c distribution 0'
3156C CALL DT_OUTHGR(IHFLE0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3157C HEADER = ' LAEVT: E_c distribution 1'
3158C CALL DT_OUTHGR(IHFLE1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3159C HEADER = ' LAEVT: E_c distribution 2'
3160C CALL DT_OUTHGR(IHFLE2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3161
3162* print run-statistics and histograms to output-unit 6
3163 CALL PHO_PHIST(3000,DUM)
3164 IF (IXSTBL.EQ.0) CALL DT_STATIS(2)
3165
3166 RETURN
3167 END
3168
3169*$ CREATE DT_DTUINI.FOR
3170*COPY DT_DTUINI
3171*
3172*===dtuini=============================================================*
3173*
3174 SUBROUTINE DT_DTUINI(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
3175 & IDP,IEMU)
3176
3177 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3178 SAVE
3179
3180 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
3181* emulsion treatment
3182 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
3183 & NCOMPO,IEMUL
3184* Glauber formalism: flags and parameters for statistics
3185 LOGICAL LPROD
3186 CHARACTER*8 CGLB
3187 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
3188
3189 CALL DT_INIT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,IGLAU)
3190 CALL DT_STATIS(1)
3191 CALL PHO_PHIST(1000,DUM)
3192 IF (NCOMPO.LE.0) THEN
3193 CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
3194 ELSE
3195 DO 1 I=1,NCOMPO
3196 CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
3197 1 CONTINUE
3198 ENDIF
3199 IF (IOGLB.NE.100) CALL DT_SIGEMU
3200 IEMU = IEMUL
3201
3202 RETURN
3203 END
3204
3205*$ CREATE DT_DTUOUT.FOR
3206*COPY DT_DTUOUT
3207*
3208*===dtuout=============================================================*
3209*
3210 SUBROUTINE DT_DTUOUT
3211
3212 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3213 SAVE
3214
3215 CALL PHO_PHIST(3000,DUM)
3216 CALL DT_STATIS(2)
3217
3218 RETURN
3219 END
3220
3221*$ CREATE DT_BEAMPR.FOR
3222*COPY DT_BEAMPR
3223*
3224*===beampr=============================================================*
3225*
3226 SUBROUTINE DT_BEAMPR(WHAT,PLAB,MODE)
3227
3228************************************************************************
3229* Initialization of event generation *
3230* This version dated 7.4.98 is written by S. Roesler. *
3231************************************************************************
3232
3233 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3234 SAVE
3235
3236 PARAMETER ( LINP = 10 ,
3237 & LOUT = 6 ,
3238 & LDAT = 9 )
3239 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
3240 PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
3241
3242 LOGICAL LBEAM
3243
3244* event history
3245 PARAMETER (NMXHKK=200000)
3246 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3247 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3248 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3249* extended event history
3250 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3251 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3252 & IHIST(2,NMXHKK)
3253* properties of interacting particles
3254 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
3255* particle properties (BAMJET index convention)
3256 CHARACTER*8 ANAME
3257 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
3258 & IICH(210),IIBAR(210),K1(210),K2(210)
3259* beam momenta
3260 COMMON /DTBEAM/ P1(4),P2(4)
3261
3262C DIMENSION WHAT(6),P1(4),P2(4),P1CMS(4),P2CMS(4)
3263 DIMENSION WHAT(6),P1CMS(4),P2CMS(4)
3264
3265 DATA LBEAM /.FALSE./
3266
3267 GOTO (1,2) MODE
3268
3269 1 CONTINUE
3270
3271 E1 = WHAT(1)
3272 IF (E1.LT.ZERO) E1 = DBLE(IPZ)/DBLE(IP)*ABS(WHAT(1))
3273 E2 = WHAT(2)
3274 IF (E2.LT.ZERO) E2 = DBLE(ITZ)/DBLE(IT)*ABS(WHAT(2))
3275 PP1 = SQRT( (E1+AAM(IJPROJ))*(E1-AAM(IJPROJ)) )
3276 PP2 = SQRT( (E2+AAM(IJTARG))*(E2-AAM(IJTARG)) )
3277 TH = 1.D-6*WHAT(3)/2.D0
3278 PH = WHAT(4)*BOG
3279 P1(1) = PP1*SIN(TH)*COS(PH)
3280 P1(2) = PP1*SIN(TH)*SIN(PH)
3281 P1(3) = PP1*COS(TH)
3282 P1(4) = E1
3283 P2(1) = PP2*SIN(TH)*COS(PH)
3284 P2(2) = PP2*SIN(TH)*SIN(PH)
3285 P2(3) = -PP2*COS(TH)
3286 P2(4) = E2
3287 ECM = SQRT( (P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))**2
3288 & -(P1(3)+P2(3))**2 )
3289 ELAB = (ECM**2-AAM(IJPROJ)**2-AAM(IJTARG)**2)/(2.0D0*AAM(IJTARG))
3290 PLAB = SQRT( (ELAB+AAM(IJPROJ))*(ELAB-AAM(IJPROJ)) )
3291 BGX = (P1(1)+P2(1))/ECM
3292 BGY = (P1(2)+P2(2))/ECM
3293 BGZ = (P1(3)+P2(3))/ECM
3294 BGE = (P1(4)+P2(4))/ECM
3295 CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P1(1),P1(2),P1(3),P1(4),
3296 & P1TOT,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4))
3297 CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P2(1),P2(2),P2(3),P2(4),
3298 & P2TOT,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4))
3299 COD = P1CMS(3)/P1TOT
3300C SID = SQRT((ONE-COD)*(ONE+COD))
3301 PPT = SQRT(P1CMS(1)**2+P1CMS(2)**2)
3302 SID = PPT/P1TOT
3303 COF = ONE
3304 SIF = ZERO
3305 IF (P1TOT*SID.GT.TINY10) THEN
3306 COF = P1CMS(1)/(SID*P1TOT)
3307 SIF = P1CMS(2)/(SID*P1TOT)
3308 ANORF = SQRT(COF*COF+SIF*SIF)
3309 COF = COF/ANORF
3310 SIF = SIF/ANORF
3311 ENDIF
3312**check
3313C WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
3314C WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
3315C WRITE(LOUT,'(5E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),P1TOT
3316C WRITE(LOUT,'(5E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),P2TOT
3317C PAX = ZERO
3318C PAY = ZERO
3319C PAZ = P1TOT
3320C PAE = SQRT(AAM(IJPROJ)**2+PAZ**2)
3321C PBX = ZERO
3322C PBY = ZERO
3323C PBZ = -P2TOT
3324C PBE = SQRT(AAM(IJTARG)**2+PBZ**2)
3325C WRITE(LOUT,'(4E15.4)') PAX,PAY,PAZ,PAE
3326C WRITE(LOUT,'(4E15.4)') PBX,PBY,PBZ,PBE
3327C CALL DT_MYTRAN(1,PAX,PAY,PAZ,COD,SID,COF,SIF,
3328C & P1CMS(1),P1CMS(2),P1CMS(3))
3329C CALL DT_MYTRAN(1,PBX,PBY,PBZ,COD,SID,COF,SIF,
3330C & P2CMS(1),P2CMS(2),P2CMS(3))
3331C WRITE(LOUT,'(4E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4)
3332C WRITE(LOUT,'(4E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4)
3333C CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),
3334C & P1TOT,P1(1),P1(2),P1(3),P1(4))
3335C CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),
3336C & P2TOT,P2(1),P2(2),P2(3),P2(4))
3337C WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
3338C WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
3339C STOP
3340**
3341
3342 LBEAM = .TRUE.
3343
3344 RETURN
3345
3346 2 CONTINUE
3347
3348 IF (LBEAM) THEN
3349 IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
3350 DO 20 I=NPOINT(4),NHKK
3351 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
3352 & (ISTHKK(I).EQ.1001)) THEN
3353 CALL DT_MYTRAN(1,PHKK(1,I),PHKK(2,I),PHKK(3,I),
3354 & COD,SID,COF,SIF,PXCMS,PYCMS,PZCMS)
3355 PECMS = PHKK(4,I)
3356 CALL DT_DALTRA(BGE,BGX,BGY,BGZ,PXCMS,PYCMS,PZCMS,PECMS,
3357 & PTOT,PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I))
3358 ENDIF
3359 20 CONTINUE
3360 ELSE
3361 MODE = -1
3362 ENDIF
3363
3364 RETURN
3365 END
3366
3367*$ CREATE DT_REJUCO.FOR
3368*COPY DT_REJUCO
3369*
3370*===rejuco=============================================================*
3371*
3372 SUBROUTINE DT_REJUCO(MODE,IREJ)
3373
3374************************************************************************
3375* REJection of Unphysical COnfigurations *
3376* MODE = 1 rejection of particles with unphysically large energy *
3377* *
3378* This version dated 27.12.2006 is written by S. Roesler. *
3379************************************************************************
3380
3381 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3382 SAVE
3383
3384 PARAMETER ( LINP = 10 ,
3385 & LOUT = 6 ,
3386 & LDAT = 9 )
3387 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
3388 PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
3389
3390* maximum x_cms of final state particle
3391 PARAMETER (XCMSMX = 1.4D0)
3392
3393* event history
3394 PARAMETER (NMXHKK=200000)
3395 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3396 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3397 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3398* extended event history
3399 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3400 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3401 & IHIST(2,NMXHKK)
3402* Lorentz-parameters of the current interaction
3403 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
3404 & UMO,PPCM,EPROJ,PPROJ
3405
3406 IREJ = 0
3407
3408 IF (MODE.EQ.1) THEN
3409 IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
3410 ECMHLF = UMO/2.0D0
3411 DO 10 I=NPOINT(4),NHKK
3412 IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDHKK(I).NE.80000)) THEN
3413 XCMS = ABS(PHKK(4,I))/ECMHLF
3414 IF (XCMS.GT.XCMSMX) GOTO 9999
3415 ENDIF
3416 10 CONTINUE
3417 ENDIF
3418
3419 RETURN
3420 9999 CONTINUE
3421 IREJ = 1
3422 RETURN
3423 END
3424
3425*$ CREATE DT_EVENTB.FOR
3426*COPY DT_EVENTB
3427*
3428*===eventb=============================================================*
3429*
3430 SUBROUTINE DT_EVENTB(NCSY,IREJ)
3431
3432************************************************************************
3433* Treatment of nucleon-nucleon interactions with full two-component *
3434* Dual Parton Model. *
3435* NCSY number of nucleon-nucleon interactions *
3436* IREJ rejection flag *
3437* This version dated 14.01.2000 is written by S. Roesler *
3438************************************************************************
3439
3440 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3441 SAVE
3442 PARAMETER ( LINP = 10 ,
3443 & LOUT = 6 ,
3444 & LDAT = 9 )
3445 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
3446
3447* event history
3448 PARAMETER (NMXHKK=200000)
3449 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3450 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3451 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3452* extended event history
3453 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3454 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3455 & IHIST(2,NMXHKK)
3456*! uncomment this line for internal phojet-fragmentation
3457C #include "dtu_dtevtp.inc"
3458* particle properties (BAMJET index convention)
3459 CHARACTER*8 ANAME
3460 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
3461 & IICH(210),IIBAR(210),K1(210),K2(210)
3462* flags for input different options
3463 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
3464 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
3465 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
3466* rejection counter
3467 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
3468 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
3469 & IREXCI(3),IRDIFF(2),IRINC
3470* properties of interacting particles
3471 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
3472* properties of photon/lepton projectiles
3473 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
3474* various options for treatment of partons (DTUNUC 1.x)
3475* (chain recombination, Cronin,..)
3476 LOGICAL LCO2CR,LINTPT
3477 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
3478 & LCO2CR,LINTPT
3479* statistics
3480 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
3481 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
3482 & ICEVTG(8,0:30)
3483* DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
3484 COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
3485* Glauber formalism: collision properties
3486 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
3487 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
3488* flags for diffractive interactions (DTUNUC 1.x)
3489 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
3490* statistics: double-Pomeron exchange
3491 COMMON /DTFLG2/ INTFLG,IPOPO
3492* flags for particle decays
3493 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
3494 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
3495 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
3496* nucleon-nucleon event-generator
3497 CHARACTER*8 CMODEL
3498 LOGICAL LPHOIN
3499 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
3500C nucleon-nucleus / nucleus-nucleus interface to DPMJET
3501 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
3502 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
3503 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
3504 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
3505C model switches and parameters
3506 CHARACTER*8 MDLNA
3507 INTEGER ISWMDL,IPAMDL
3508 DOUBLE PRECISION PARMDL
3509 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
3510C initial state parton radiation (internal part)
3511 INTEGER MXISR3,MXISR4
3512 PARAMETER ( MXISR3 = 50, MXISR4 = 100 )
3513 INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC
3514 DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT
3515 COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3),
3516 & ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3),
3517 & IFL1(2,MXISR3),IFL2(2,MXISR3),
3518 & IBRA(2,MXISR4),IFANO(2),ISH(2),NACC
3519C event debugging information
3520 INTEGER NMAXD
3521 PARAMETER (NMAXD=100)
3522 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
3523 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3524 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
3525 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3526C general process information
3527 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
3528 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
3529
3530 DIMENSION PP(4),PT(4),PTOT(4),PP1(4),PP2(4),PT1(4),PT2(4),
3531 & PPNN(4),PTNN(4),PTOTNN(4),PPSUB(4),PTSUB(4),
3532 & PPTCMS(4),PTTCMS(4),PPTMP(4),PTTMP(4),
3533 & KPRON(15),ISINGL(2000)
3534
3535* initial values for max. number of phojet scatterings and dtunuc chains
3536* to be fragmented with one pyexec call
3537 DATA MXPHFR,MXDTFR /10,100/
3538
3539 IREJ = 0
3540* pointer to first parton of the first chain in dtevt common
3541 NPOINT(3) = NHKK+1
3542* special flag for double-Pomeron statistics
3543 IPOPO = 1
3544* counter for low-mass (DTUNUC) interactions
3545 NDTUSC = 0
3546* counter for interactions treated by PHOJET
3547 NPHOSC = 0
3548
3549* scan interactions for single nucleon-nucleon interactions
3550* (this has to be checked here because Cronin modifies parton momenta)
3551 NC = NPOINT(2)
3552 IF (NCSY.GT.2000) STOP ' DT_EVENTB: NCSY > 2000 ! '
3553 DO 8 I=1,NCSY
3554 ISINGL(I) = 0
3555 MOP = JMOHKK(1,NC)
3556 MOT = JMOHKK(1,NC+1)
3557 DIFF1 = ABS(PHKK(4,MOP)-PHKK(4, NC)-PHKK(4,NC+2))
3558 DIFF2 = ABS(PHKK(4,MOT)-PHKK(4,NC+1)-PHKK(4,NC+3))
3559 IF ((DIFF1.LT.TINY10).AND.(DIFF2.LT.TINY10)) ISINGL(I) = 1
3560 NC = NC+4
3561 8 CONTINUE
3562
3563* multiple scattering of chain ends
3564 IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
3565 IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
3566
3567* switch to PHOJET-settings for JETSET parameter
3568 CALL DT_INITJS(1)
3569
3570* loop over nucleon-nucleon interaction
3571 NC = NPOINT(2)
3572 DO 2 I=1,NCSY
3573*
3574* pick up one nucleon-nucleon interaction from DTEVT1
3575* ppnn / ptnn - momenta of the interacting nucleons (cms)
3576* ptotnn - total momentum of the interacting nucleons (cms)
3577* pp1,2 / pt1,2 - momenta of the four partons
3578* pp / pt - total momenta of the proj / targ partons
3579* ptot - total momentum of the four partons
3580 MOP = JMOHKK(1,NC)
3581 MOT = JMOHKK(1,NC+1)
3582 DO 3 K=1,4
3583 PPNN(K) = PHKK(K,MOP)
3584 PTNN(K) = PHKK(K,MOT)
3585 PTOTNN(K) = PPNN(K)+PTNN(K)
3586 PP1(K) = PHKK(K,NC)
3587 PT1(K) = PHKK(K,NC+1)
3588 PP2(K) = PHKK(K,NC+2)
3589 PT2(K) = PHKK(K,NC+3)
3590 PP(K) = PP1(K)+PP2(K)
3591 PT(K) = PT1(K)+PT2(K)
3592 PTOT(K) = PP(K)+PT(K)
3593 3 CONTINUE
3594*
3595*-----------------------------------------------------------------------
3596* this is a complete nucleon-nucleon interaction
3597*
3598 IF (ISINGL(I).EQ.1) THEN
3599*
3600* initialize PHOJET-variables for remnant/valence-partons
3601 IHFLD(1,1) = 0
3602 IHFLD(1,2) = 0
3603 IHFLD(2,1) = 0
3604 IHFLD(2,2) = 0
3605 IHFLS(1) = 1
3606 IHFLS(2) = 1
3607* save current settings of PHOJET process and min. bias flags
3608 DO 9 K=1,11
3609 KPRON(K) = IPRON(K,1)
3610 9 CONTINUE
3611 ISWSAV = ISWMDL(2)
3612*
3613* check if forced sampling of diffractive interaction requested
3614 IF (ISINGD.LT.-1) THEN
3615 DO 90 K=1,11
3616 IPRON(K,1) = 0
3617 90 CONTINUE
3618 IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-3)) IPRON(5,1) = 1
3619 IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-4)) IPRON(6,1) = 1
3620 IF (ISINGD.EQ.-5) IPRON(4,1) = 1
3621 ENDIF
3622*
3623* for photons: a direct/anomalous interaction is not sampled
3624* in PHOJET but already in Glauber-formalism. Here we check if such
3625* an interaction is requested
3626 IF (IJPROJ.EQ.7) THEN
3627* first switch off direct interactions
3628 IPRON(8,1) = 0
3629* this is a direct interactions
3630 IF (IDIREC.EQ.1) THEN
3631 DO 12 K=1,11
3632 IPRON(K,1) = 0
3633 12 CONTINUE
3634 IPRON(8,1) = 1
3635* this is an anomalous interactions
3636* (iswmdl(2) = 0 only hard int. generated ( = 1 min. bias) )
3637 ELSEIF (IDIREC.EQ.2) THEN
3638 ISWMDL(2) = 0
3639 ENDIF
3640 ELSE
3641 IF (IDIREC.NE.0) STOP ' DT_EVENTB: IDIREC > 0 ! '
3642 ENDIF
3643*
3644* make sure that total momenta of partons, pp and pt, are on mass
3645* shell (Cronin may have srewed this up..)
3646 CALL DT_MASHEL(PP,PT,PHKK(5,MOP),PHKK(5,MOT),PPNN,PTNN,IR1)
3647 IF (IR1.NE.0) THEN
3648 IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A)')
3649 & 'EVENTB: mass shell correction rejected'
3650 GOTO 9999
3651 ENDIF
3652*
3653* initialize the incoming particles in PHOJET
3654 IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
3655 CALL PHO_SETPAR(1,22,0,VIRT)
3656 ELSE
3657 CALL PHO_SETPAR(1,IDHKK(MOP),0,ZERO)
3658 ENDIF
3659 CALL PHO_SETPAR(2,IDHKK(MOT),0,ZERO)
3660*
3661* initialize rejection loop counter for anomalous processes
3662 IRJANO = 0
3663 800 CONTINUE
3664 IRJANO = IRJANO+1
3665*
3666* temporary fix for ifano problem
3667 IFANO(1) = 0
3668 IFANO(2) = 0
3669*
3670* generate complete hadron/nucleon/photon-nucleon event with PHOJET
3671 CALL PHO_EVENT(2,PPNN,PTNN,DUM,IREJ1)
3672*
3673* for photons: special consistency check for anomalous interactions
3674 IF (IJPROJ.EQ.7) THEN
3675 IF (IRJANO.LT.30) THEN
3676 IF (IFANO(1).NE.0) THEN
3677* here, an anomalous interaction was generated. Check if it
3678* was also requested. Otherwise reject this event.
3679 IF (IDIREC.EQ.0) GOTO 800
3680 ELSE
3681* here, an anomalous interaction was not generated. Check if it
3682* was requested in which case we need to reject this event.
3683 IF (IDIREC.EQ.2) GOTO 800
3684 ENDIF
3685 ELSE
3686 WRITE(LOUT,*) ' DT_EVENTB: Warning! IRJANO > 30 ',
3687 & IRJANO,IDIREC,NEVHKK
3688 ENDIF
3689 ENDIF
3690*
3691* copy back original settings of PHOJET process and min. bias flags
3692 DO 10 K=1,11
3693 IPRON(K,1) = KPRON(K)
3694 10 CONTINUE
3695 ISWMDL(2) = ISWSAV
3696*
3697* check if PHOJET has rejected this event
3698 IF (IREJ1.NE.0) THEN
3699C IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
3700 WRITE(LOUT,'(1X,A,I4)')
3701 & 'EVENTB: chain system rejected',IDIREC
3702 CALL PHO_PREVNT(0)
3703 GOTO 9999
3704 ENDIF
3705*
3706* copy partons and strings from PHOJET common back into DTEVT for
3707* external fragmentation
3708 MO1 = NC
3709 MO2 = NC+3
3710*! uncomment this line for internal phojet-fragmentation
3711C CALL DT_GETFSP(MO1,MO2,PPNN,PTNN,-1)
3712 NPHOSC = NPHOSC+1
3713 CALL DT_GETPJE(MO1,MO2,PPNN,PTNN,-1,NPHOSC,IREJ1)
3714 IF (IREJ1.NE.0) THEN
3715 IF (IOULEV(1).GT.0)
3716 & WRITE(LOUT,'(1X,A,I4)') 'EVENTB: chain system rejected 1'
3717 GOTO 9999
3718 ENDIF
3719*
3720* update statistics counter
3721 ICEVTG(IDCH(NC),29) = ICEVTG(IDCH(NC),29)+1
3722*
3723*-----------------------------------------------------------------------
3724* this interaction involves "remnants"
3725*
3726 ELSE
3727*
3728* total mass of this system
3729 PPTOT = SQRT(PTOT(1)**2+PTOT(2)**2+PTOT(3)**2)
3730 AMTOT2 = (PTOT(4)-PPTOT)*(PTOT(4)+PPTOT)
3731 IF (AMTOT2.LT.ZERO) THEN
3732 AMTOT = ZERO
3733 ELSE
3734 AMTOT = SQRT(AMTOT2)
3735 ENDIF
3736*
3737* systems with masses larger than elojet are treated with PHOJET
3738 IF (AMTOT.GT.ELOJET) THEN
3739*
3740* initialize PHOJET-variables for remnant/valence-partons
3741* projectile parton flavors and valence flag
3742 IHFLD(1,1) = IDHKK(NC)
3743 IHFLD(1,2) = IDHKK(NC+2)
3744 IHFLS(1) = 0
3745 IF ((IDCH(NC).EQ.6).OR.(IDCH(NC).EQ.7)
3746 & .OR.(IDCH(NC).EQ.8)) IHFLS(1) = 1
3747* target parton flavors and valence flag
3748 IHFLD(2,1) = IDHKK(NC+1)
3749 IHFLD(2,2) = IDHKK(NC+3)
3750 IHFLS(2) = 0
3751 IF ((IDCH(NC).EQ.4).OR.(IDCH(NC).EQ.5)
3752 & .OR.(IDCH(NC).EQ.8)) IHFLS(2) = 1
3753* flag signalizing PHOJET how to treat the remnant:
3754* iremn = -1 sea-quark remnant: PHOJET takes flavors from ihfld
3755* iremn > -1 valence remnant: PHOJET assumes flavors according
3756* to mother particle
3757 IREMN1 = IHFLS(1)-1
3758 IREMN2 = IHFLS(2)-1
3759*
3760* initialize the incoming particles in PHOJET
3761 IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
3762 CALL PHO_SETPAR(1,22,IREMN1,VIRT)
3763 ELSE
3764 CALL PHO_SETPAR(1,IDHKK(MOP),IREMN1,ZERO)
3765 ENDIF
3766 CALL PHO_SETPAR(2,IDHKK(MOT),IREMN2,ZERO)
3767*
3768* calculate Lorentz parameter of the nucleon-nucleon cm-system
3769 PPTOTN = SQRT(PTOTNN(1)**2+PTOTNN(2)**2+PTOTNN(3)**2)
3770 AMNN = SQRT( (PTOTNN(4)-PPTOTN)*(PTOTNN(4)+PPTOTN) )
3771 BGX = PTOTNN(1)/AMNN
3772 BGY = PTOTNN(2)/AMNN
3773 BGZ = PTOTNN(3)/AMNN
3774 GAM = PTOTNN(4)/AMNN
3775* transform interacting nucleons into nucleon-nucleon cm-system
3776 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3777 & PPNN(1),PPNN(2),PPNN(3),PPNN(4),PPCMS,
3778 & PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4))
3779 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3780 & PTNN(1),PTNN(2),PTNN(3),PTNN(4),PTCMS,
3781 & PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4))
3782* transform (total) momenta of the proj and targ partons into
3783* nucleon-nucleon cm-system
3784 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3785 & PP(1),PP(2),PP(3),PP(4),
3786 & PPTSUB,PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4))
3787 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3788 & PT(1),PT(2),PT(3),PT(4),
3789 & PTTSUB,PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4))
3790* energy fractions of the proj and targ partons
3791 XPSUB = MIN(PPSUB(4)/PPTCMS(4),ONE)
3792 XTSUB = MIN(PTSUB(4)/PTTCMS(4),ONE)
3793***
3794* testprint
3795c PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
3796c & (PPTCMS(2)+PTTCMS(2))**2 +
3797c & (PPTCMS(3)+PTTCMS(3))**2 )
3798c EOLDCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
3799c & (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
3800c PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
3801c & (PPSUB(2)+PTSUB(2))**2 +
3802c & (PPSUB(3)+PTSUB(3))**2 )
3803c EOLDSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
3804c & (PPSUB(4)+PTSUB(4)+PTOTSU) )
3805***
3806*
3807* save current settings of PHOJET process and min. bias flags
3808 DO 7 K=1,11
3809 KPRON(K) = IPRON(K,1)
3810 7 CONTINUE
3811* disallow direct photon int. (does not make sense here anyway)
3812 IPRON(8,1) = 0
3813* disallow double pomeron processes (due to technical problems
3814* in PHOJET, needs to be solved sometime)
3815 IPRON(4,1) = 0
3816* disallow diffraction for sea-diquarks
3817 IF ((IABS(IHFLD(1,1)).GT.1100).AND.
3818 & (IABS(IHFLD(1,2)).GT.1100)) THEN
3819 IPRON(3,1) = 0
3820 IPRON(6,1) = 0
3821 ENDIF
3822 IF ((IABS(IHFLD(2,1)).GT.1100).AND.
3823 & (IABS(IHFLD(2,2)).GT.1100)) THEN
3824 IPRON(3,1) = 0
3825 IPRON(5,1) = 0
3826 ENDIF
3827*
3828* we need massless partons: transform them on mass shell
3829 XMP = ZERO
3830 XMT = ZERO
3831 DO 6 K=1,4
3832 PPTMP(K) = PPSUB(K)
3833 PTTMP(K) = PTSUB(K)
3834 6 CONTINUE
3835 CALL DT_MASHEL(PPTMP,PTTMP,XMP,XMT,PPSUB,PTSUB,IREJ1)
3836 PPSUTO = SQRT(PPSUB(1)**2+PPSUB(2)**2+PPSUB(3)**2)
3837 PTSUTO = SQRT(PTSUB(1)**2+PTSUB(2)**2+PTSUB(3)**2)
3838 PSUTOT = SQRT((PPSUB(1)+PTSUB(1))**2+
3839 & (PPSUB(2)+PTSUB(2))**2+(PPSUB(3)+PTSUB(3))**2)
3840* total energy of the subsysten after mass transformation
3841* (should be the same as before..)
3842 SECM = SQRT( (PPSUB(4)+PTSUB(4)-PSUTOT)*
3843 & (PPSUB(4)+PTSUB(4)+PSUTOT) )
3844*
3845* after mass shell transformation the x_sub - relation has to be
3846* corrected. We therefore create "pseudo-momenta" of mother-nucleons.
3847*
3848* The old version was to scale based on the original x_sub and the
3849* 4-momenta of the subsystem. At very high energy this could lead to
3850* "pseudo-cm energies" of the parent system considerably exceeding
3851* the true cm energy. Now we keep the true cm energy and calculate
3852* new x_sub instead.
3853C old version PPTCMS(4) = PPSUB(4)/XPSUB
3854 PPTCMS(4) = MAX(PPTCMS(4),PPSUB(4))
3855 XPSUB = PPSUB(4)/PPTCMS(4)
3856 IF (IJPROJ.EQ.7) THEN
3857 AMP2 = PHKK(5,MOT)**2
3858 PTOT1 = SQRT(PPTCMS(4)**2-AMP2)
3859 ELSE
3860*???????
3861 PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOP))
3862 & *(PPTCMS(4)+PHKK(5,MOP)))
3863C PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOT))
3864C & *(PPTCMS(4)+PHKK(5,MOT)))
3865 ENDIF
3866C old version PTTCMS(4) = PTSUB(4)/XTSUB
3867 PTTCMS(4) = MAX(PTTCMS(4),PTSUB(4))
3868 XTSUB = PTSUB(4)/PTTCMS(4)
3869 PTOT2 = SQRT((PTTCMS(4)-PHKK(5,MOT))
3870 & *(PTTCMS(4)+PHKK(5,MOT)))
3871 DO 4 K=1,3
3872 PPTCMS(K) = PTOT1*PPSUB(K)/PPSUTO
3873 PTTCMS(K) = PTOT2*PTSUB(K)/PTSUTO
3874 4 CONTINUE
3875***
3876* testprint
3877*
3878* ppnn / ptnn - momenta of the int. nucleons (cms, negl. Fermi)
3879* ptotnn - total momentum of the int. nucleons (cms, negl. Fermi)
3880* pptcms/ pttcms - momenta of the interacting nucleons (cms)
3881* pp1,2 / pt1,2 - momenta of the four partons
3882*
3883* pp / pt - total momenta of the pr/ta partons (cms, negl. Fermi)
3884* ptot - total momentum of the four partons (cms, negl. Fermi)
3885* ppsub / ptsub - total momenta of the proj / targ partons (cms)
3886*
3887c PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
3888c & (PPTCMS(2)+PTTCMS(2))**2 +
3889c & (PPTCMS(3)+PTTCMS(3))**2 )
3890c ENEWCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
3891c & (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
3892c PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
3893c & (PPSUB(2)+PTSUB(2))**2 +
3894c & (PPSUB(3)+PTSUB(3))**2 )
3895c ENEWSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
3896c & (PPSUB(4)+PTSUB(4)+PTOTSU) )
3897c IF (ENEWCM/EOLDCM.GT.1.1D0) THEN
3898c WRITE(*,*) ' EOLDCM, ENEWCM : ',EOLDCM,ENEWCM
3899c WRITE(*,*) ' EOLDSU, ENEWSU : ',EOLDSU,ENEWSU
3900c WRITE(*,*) ' XPSUB, XTSUB : ',XPSUB,XTSUB
3901c ENDIF
3902c BBGX = (PPTCMS(1)+PTTCMS(1))/ENEWCM
3903c BBGY = (PPTCMS(2)+PTTCMS(2))/ENEWCM
3904c BBGZ = (PPTCMS(3)+PTTCMS(3))/ENEWCM
3905c BGAM = (PPTCMS(4)+PTTCMS(4))/ENEWCM
3906* transform interacting nucleons into nucleon-nucleon cm-system
3907c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3908c & PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4),PPTOT,
3909c & PPNEW1,PPNEW2,PPNEW3,PPNEW4)
3910c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3911c & PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4),PTTOT,
3912c & PTNEW1,PTNEW2,PTNEW3,PTNEW4)
3913c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3914c & PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4),PPTOT,
3915c & PPSUB1,PPSUB2,PPSUB3,PPSUB4)
3916c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3917c & PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4),PTTOT,
3918c & PTSUB1,PTSUB2,PTSUB3,PTSUB4)
3919c PTSTCM = SQRT( (PPNEW1+PTNEW1)**2 +
3920c & (PPNEW2+PTNEW2)**2 +
3921c & (PPNEW3+PTNEW3)**2 )
3922c ETSTCM = SQRT( (PPNEW4+PTNEW4-PTSTCM) *
3923c & (PPNEW4+PTNEW4+PTSTCM) )
3924c PTSTSU = SQRT( (PPSUB1+PTSUB1)**2 +
3925c & (PPSUB2+PTSUB2)**2 +
3926c & (PPSUB3+PTSUB3)**2 )
3927c ETSTSU = SQRT( (PPSUB4+PTSUB4-PTSTSU) *
3928c & (PPSUB4+PTSUB4+PTSTSU) )
3929C WRITE(*,*) ' mother cmE :'
3930C WRITE(*,*) ETSTCM,ENEWCM
3931C WRITE(*,*) ' subsystem cmE :'
3932C WRITE(*,*) ETSTSU,ENEWSU
3933C WRITE(*,*) ' projectile mother :'
3934C WRITE(*,*) PPNEW1,PPNEW2,PPNEW3,PPNEW4
3935C WRITE(*,*) ' target mother :'
3936C WRITE(*,*) PTNEW1,PTNEW2,PTNEW3,PTNEW4
3937C WRITE(*,*) ' projectile subsystem:'
3938C WRITE(*,*) PPSUB1,PPSUB2,PPSUB3,PPSUB4
3939C WRITE(*,*) ' target subsystem:'
3940C WRITE(*,*) PTSUB1,PTSUB2,PTSUB3,PTSUB4
3941C WRITE(*,*) ' projectile subsystem should be:'
3942C WRITE(*,*) ZERO,ZERO,XPSUB*ETSTCM/2.0D0,
3943C & XPSUB*ETSTCM/2.0D0
3944C WRITE(*,*) ' target subsystem should be:'
3945C WRITE(*,*) ZERO,ZERO,-XTSUB*ETSTCM/2.0D0,
3946C & XTSUB*ETSTCM/2.0D0
3947C WRITE(*,*) ' subsystem cmE should be: '
3948C WRITE(*,*) SQRT(XPSUB*XTSUB)*ETSTCM,XPSUB,XTSUB
3949***
3950*
3951* generate complete remnant - nucleon/remnant event with PHOJET
3952 CALL PHO_EVENT(3,PPTCMS,PTTCMS,DUM,IREJ1)
3953*
3954* copy back original settings of PHOJET process flags
3955 DO 11 K=1,11
3956 IPRON(K,1) = KPRON(K)
3957 11 CONTINUE
3958*
3959* check if PHOJET has rejected this event
3960 IF (IREJ1.NE.0) THEN
3961 IF (IOULEV(1).GT.0)
3962 & WRITE(LOUT,'(1X,A)') 'EVENTB: chain system rejected'
3963 WRITE(LOUT,*)
3964 & 'XPSUB,XTSUB,SECM ',XPSUB,XTSUB,SECM,AMTOT
3965 CALL PHO_PREVNT(0)
3966 GOTO 9999
3967 ENDIF
3968*
3969* copy partons and strings from PHOJET common back into DTEVT for
3970* external fragmentation
3971 MO1 = NC
3972 MO2 = NC+3
3973*! uncomment this line for internal phojet-fragmentation
3974C CALL DT_GETFSP(MO1,MO2,PP,PT,1)
3975 NPHOSC = NPHOSC+1
3976 CALL DT_GETPJE(MO1,MO2,PP,PT,1,NPHOSC,IREJ1)
3977 IF (IREJ1.NE.0) THEN
3978 IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
3979 & 'EVENTB: chain system rejected 2'
3980 GOTO 9999
3981 ENDIF
3982*
3983* update statistics counter
3984 ICEVTG(IDCH(NC),2) = ICEVTG(IDCH(NC),2)+1
3985*
3986*-----------------------------------------------------------------------
3987* two-chain approx. for smaller systems
3988*
3989 ELSE
3990*
3991 NDTUSC = NDTUSC+1
3992* special flag for double-Pomeron statistics
3993 IPOPO = 0
3994*
3995* pick up flavors at the ends of the two chains
3996 IFP1 = IDHKK(NC)
3997 IFT1 = IDHKK(NC+1)
3998 IFP2 = IDHKK(NC+2)
3999 IFT2 = IDHKK(NC+3)
4000* ..and the indices of the mothers
4001 MOP1 = NC
4002 MOT1 = NC+1
4003 MOP2 = NC+2
4004 MOT2 = NC+3
4005 CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
4006 & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
4007*
4008* check if this chain system was rejected
4009 IF (IREJ1.GT.0) THEN
4010 IF (IOULEV(1).GT.0) THEN
4011 WRITE(LOUT,*) 'rejected 1 in EVENTB'
4012 WRITE(LOUT,'(1X,4(I6,4E12.3,/),E12.3)')
4013 & IFP1,PP1,IFT1,PT1,IFP2,PP2,IFT2,PT2,AMTOT
4014 ENDIF
4015 IRHHA = IRHHA+1
4016 GOTO 9999
4017 ENDIF
4018* the following lines are for sea-sea chains rejected in GETCSY
4019 IF (IREJ1.EQ.-1) NDTUSC = NDTUSC-1
4020 ICEVTG(IDCH(NC),1) = ICEVTG(IDCH(NC),1)+1
4021 ENDIF
4022*
4023 ENDIF
4024*
4025* update statistics counter
4026 ICEVTG(IDCH(NC),0) = ICEVTG(IDCH(NC),0)+1
4027*
4028 NC = NC+4
4029*
4030 2 CONTINUE
4031*
4032*-----------------------------------------------------------------------
4033* treatment of low-mass chains (if there are any)
4034*
4035 IF (NDTUSC.GT.0) THEN
4036*
4037* correct chains of very low masses for possible resonances
4038 IF (IRESCO.EQ.1) THEN
4039 CALL DT_EVTRES(IREJ1)
4040 IF (IREJ1.GT.0) THEN
4041 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2a in EVENTB'
4042 IRRES(1) = IRRES(1)+1
4043 GOTO 9999
4044 ENDIF
4045 ENDIF
4046* fragmentation of low-mass chains
4047*! uncomment this line for internal phojet-fragmentation
4048* (of course it will still be fragmented by DPMJET-routines but it
4049* has to be done here instead of further below)
4050C CALL DT_EVTFRA(IREJ1)
4051C IF (IREJ1.GT.0) THEN
4052C IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2b in EVENTB'
4053C IRFRAG = IRFRAG+1
4054C GOTO 9999
4055C ENDIF
4056 ELSE
4057*! uncomment this line for internal phojet-fragmentation
4058C NPOINT(4) = NHKK+1
4059 IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
4060 ENDIF
4061*
4062*-----------------------------------------------------------------------
4063* new di-quark breaking mechanisms
4064*
4065 MXLEFT = 2
4066 CALL DT_CHASTA(0)
4067 IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
4068 & .OR.(PDBSEA(3).GT.0.0D0)) THEN
4069 CALL DT_DIQBRK
4070 MXLEFT = 4
4071 ENDIF
4072*
4073*-----------------------------------------------------------------------
4074* hadronize this event
4075*
4076* hadronize PHOJET chain systems
4077 NPYMAX = 0
4078 NPJE = NPHOSC/MXPHFR
4079 IF (MXPHFR.LT.MXLEFT) MXLEFT = 2
4080 IF (NPJE.GT.1) THEN
4081 NLEFT = NPHOSC-NPJE*MXPHFR
4082 DO 20 JFRG=1,NPJE
4083 NFRG = JFRG*MXPHFR
4084 IF ((JFRG.EQ.NPJE).AND.(NLEFT.LE.MXLEFT)) THEN
4085 CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4086 IF (IREJ1.GT.0) GOTO 22
4087 NLEFT = 0
4088 ELSE
4089 CALL DT_EVTFRG(1,NFRG,NPYMEM,IREJ1)
4090 IF (IREJ1.GT.0) GOTO 22
4091 ENDIF
4092 IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4093 20 CONTINUE
4094 IF (NLEFT.GT.0) THEN
4095 CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4096 IF (IREJ1.GT.0) GOTO 22
4097 IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4098 ENDIF
4099 ELSE
4100 CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4101 IF (IREJ1.GT.0) GOTO 22
4102 IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4103 ENDIF
4104*
4105* check max. filling level of jetset common and
4106* reduce mxphfr if necessary
4107 IF (NPYMAX.GT.3000) THEN
4108 IF (NPYMAX.GT.3500) THEN
4109 MXPHFR = MAX(1,MXPHFR-2)
4110 ELSE
4111 MXPHFR = MAX(1,MXPHFR-1)
4112 ENDIF
4113C WRITE(LOUT,*) ' EVENTB: Mxphfr reduced to ',MXPHFR
4114 ENDIF
4115*
4116* hadronize DTUNUC chain systems
4117 23 CONTINUE
4118 IBACK = MXDTFR
4119 CALL DT_EVTFRG(2,IBACK,NPYMEM,IREJ2)
4120 IF (IREJ2.GT.0) GOTO 22
4121*
4122* check max. filling level of jetset common and
4123* reduce mxdtfr if necessary
4124 IF (NPYMEM.GT.3000) THEN
4125 IF (NPYMEM.GT.3500) THEN
4126 MXDTFR = MAX(1,MXDTFR-20)
4127 ELSE
4128 MXDTFR = MAX(1,MXDTFR-10)
4129 ENDIF
4130C WRITE(LOUT,*) ' EVENTB: Mxdtfr reduced to ',MXDTFR
4131 ENDIF
4132*
4133 IF (IBACK.EQ.-1) GOTO 23
4134*
4135 22 CONTINUE
4136C CALL DT_EVTFRG(1,IREJ1)
4137C CALL DT_EVTFRG(2,IREJ2)
4138 IF ((IREJ1.GT.0).OR.(IREJ2.GT.0)) THEN
4139 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTB'
4140 IRFRAG = IRFRAG+1
4141 GOTO 9999
4142 ENDIF
4143*
4144* get final state particles from /DTEVTP/
4145*! uncomment this line for internal phojet-fragmentation
4146C CALL DT_GETFSP(IDUM,IDUM,PP,PT,2)
4147
4148 IF (IJPROJ.NE.7)
4149 & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,88,IREJ3)
4150C IF (IREJ3.NE.0) GOTO 9999
4151
4152 RETURN
4153
4154 9999 CONTINUE
4155 IREVT = IREVT+1
4156 IREJ = 1
4157 RETURN
4158 END
4159
4160*$ CREATE DT_GETPJE.FOR
4161*COPY DT_GETPJE
4162*
4163*===getpje=============================================================*
4164*
4165 SUBROUTINE DT_GETPJE(MO1,MO2,PP,PT,MODE,IPJE,IREJ)
4166
4167************************************************************************
4168* This subroutine copies PHOJET partons and strings from POEVT1 into *
4169* DTEVT1. *
4170* MO1,MO2 indices of first and last mother-parton in DTEVT1 *
4171* PP,PT 4-momenta of projectile/target being handled by *
4172* PHOJET *
4173* This version dated 11.12.99 is written by S. Roesler *
4174************************************************************************
4175
4176 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4177 SAVE
4178 PARAMETER ( LINP = 10 ,
4179 & LOUT = 6 ,
4180 & LDAT = 9 )
4181 PARAMETER (TINY10=1.0D-10,TINY1=1.0D-1,
4182 & ZERO=0.0D0,ONE=1.0D0,OHALF=0.5D0)
4183
4184 LOGICAL LFLIP
4185
4186* event history
4187 PARAMETER (NMXHKK=200000)
4188 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
4189 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
4190 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
4191* extended event history
4192 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
4193 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
4194 & IHIST(2,NMXHKK)
4195* Lorentz-parameters of the current interaction
4196 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4197 & UMO,PPCM,EPROJ,PPROJ
4198* DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
4199 COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
4200* flags for input different options
4201 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
4202 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
4203 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
4204* statistics: double-Pomeron exchange
4205 COMMON /DTFLG2/ INTFLG,IPOPO
4206* statistics
4207 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
4208 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
4209 & ICEVTG(8,0:30)
4210* rejection counter
4211 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
4212 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
4213 & IREXCI(3),IRDIFF(2),IRINC
4214C standard particle data interface
4215 INTEGER NMXHEP
4216 PARAMETER (NMXHEP=4000)
4217 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
4218 DOUBLE PRECISION PHEP,VHEP
4219 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
4220 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
4221 & VHEP(4,NMXHEP)
4222C extension to standard particle data interface (PHOJET specific)
4223 INTEGER IMPART,IPHIST,ICOLOR
4224 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
4225C color string configurations including collapsed strings and hadrons
4226 INTEGER MSTR
4227 PARAMETER (MSTR=500)
4228 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
4229 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
4230 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
4231 & NNCH(MSTR),IBHAD(MSTR),ISTR
4232C general process information
4233 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
4234 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
4235C model switches and parameters
4236 CHARACTER*8 MDLNA
4237 INTEGER ISWMDL,IPAMDL
4238 DOUBLE PRECISION PARMDL
4239 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4240C event debugging information
4241 INTEGER NMAXD
4242 PARAMETER (NMAXD=100)
4243 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4244 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4245 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4246 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4247
4248 DIMENSION PP(4),PT(4)
4249 DATA MAXLOP /10000/
4250
4251 INHKK = NHKK
4252 LFLIP = .TRUE.
4253 1 CONTINUE
4254 NPVAL = 0
4255 NTVAL = 0
4256 IREJ = 0
4257
4258* store initial momenta for energy-momentum conservation check
4259 IF (LEMCCK) THEN
4260 CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM1,IDUM2)
4261 CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM1,IDUM2)
4262 ENDIF
4263* copy partons and strings from POEVT1 into DTEVT1
4264 DO 11 I=1,ISTR
4265C IF ((NCODE(I).EQ.-99).AND.(IPAMDL(17).EQ.0)) THEN
4266 IF (NCODE(I).EQ.-99) THEN
4267 IDXSTG = NPOS(1,I)
4268 IDSTG = IDHEP(IDXSTG)
4269 PX = PHEP(1,IDXSTG)
4270 PY = PHEP(2,IDXSTG)
4271 PZ = PHEP(3,IDXSTG)
4272 PE = PHEP(4,IDXSTG)
4273 IF (MODE.LT.0) THEN
4274 ISTAT = 70000+IPJE
4275 CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PX,PY,PZ,PE,
4276 & 11,IDSTG,0)
4277 IF (LEMCCK) THEN
4278 PX = -PX
4279 PY = -PY
4280 PZ = -PZ
4281 PE = -PE
4282 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4283 ENDIF
4284 ELSE
4285 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4286 & PPX,PPY,PPZ,PPE)
4287 ISTAT = 70000+IPJE
4288 CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PPX,PPY,PPZ,PPE,
4289 & 11,IDSTG,0)
4290 IF (LEMCCK) THEN
4291 PX = -PPX
4292 PY = -PPY
4293 PZ = -PPZ
4294 PE = -PPE
4295 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4296 ENDIF
4297 ENDIF
4298 NOBAM(NHKK) = 0
4299 IHIST(1,NHKK) = IPHIST(1,IDXSTG)
4300 IHIST(2,NHKK) = 0
4301 ELSEIF (NCODE(I).GE.0) THEN
4302* indices of partons and string in POEVT1
4303 IDX1 = ABS(JMOHEP(1,NPOS(1,I)))
4304 IDX2 = ABS(JMOHEP(2,NPOS(1,I)))
4305 IF ((IDX1.GT.IDX2).OR.(JMOHEP(2,NPOS(1,I)).GT.0)) THEN
4306 WRITE(LOUT,*) ' GETPJE: IDX1.GT.IDX2 ',IDX1,IDX2,
4307 & ' or JMOHEP(2,NPOS(1,I)).GT.0 ',JMOHEP(2,NPOS(1,I)),' ! '
4308 STOP ' GETPJE 1'
4309 ENDIF
4310 IDXSTG = NPOS(1,I)
4311* find "mother" string of the string
4312 IDXMS1 = ABS(JMOHEP(1,IDX1))
4313 IDXMS2 = ABS(JMOHEP(1,IDX2))
4314 IF (IDXMS1.NE.IDXMS2) THEN
4315 IDXMS1 = IDXSTG
4316 IDXMS2 = IDXSTG
4317C STOP ' GETPJE: IDXMS1.NE.IDXMS2 !'
4318 ENDIF
4319* search POEVT1 for the original hadron of the parton
4320 ILOOP = 0
4321 IPOM1 = 0
4322 14 CONTINUE
4323 ILOOP = ILOOP+1
4324 IF (IDHEP(IDXMS1).EQ.990) IPOM1 = 1
4325 IDXMS1 = ABS(JMOHEP(1,IDXMS1))
4326 IF ((IDXMS1.NE.1).AND.(IDXMS1.NE.2).AND.
4327 & (ILOOP.LT.MAXLOP)) GOTO 14
4328 IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 1 ! '
4329 IPOM2 = 0
4330 ILOOP = 0
4331 15 CONTINUE
4332 ILOOP = ILOOP+1
4333 IF (IDHEP(IDXMS2).EQ.990) IPOM2 = 1
4334 IF ((ILOOP.EQ.1).OR.(IDHEP(IDXMS2).GE.7777)) THEN
4335 IDXMS2 = ABS(JMOHEP(2,IDXMS2))
4336 ELSE
4337 IDXMS2 = ABS(JMOHEP(1,IDXMS2))
4338 ENDIF
4339 IF ((IDXMS2.NE.1).AND.(IDXMS2.NE.2).AND.
4340 & (ILOOP.LT.MAXLOP)) GOTO 15
4341 IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 5 ! '
4342* parton 1
4343 IF (IDXMS1.EQ.1) THEN
4344 ISPTN1 = ISTHKK(MO1)
4345 M1PTN1 = MO1
4346 M2PTN1 = MO1+2
4347 ELSE
4348 ISPTN1 = ISTHKK(MO2)
4349 M1PTN1 = MO2-2
4350 M2PTN1 = MO2
4351 ENDIF
4352* parton 2
4353 IF (IDXMS2.EQ.1) THEN
4354 ISPTN2 = ISTHKK(MO1)
4355 M1PTN2 = MO1
4356 M2PTN2 = MO1+2
4357 ELSE
4358 ISPTN2 = ISTHKK(MO2)
4359 M1PTN2 = MO2-2
4360 M2PTN2 = MO2
4361 ENDIF
4362* check for mis-identified mothers and switch mother indices if necessary
4363 IF ((IDXMS1.EQ.IDXMS2).AND.(IPROCE.NE.5).AND.(IPROCE.NE.6)
4364 & .AND.((IDHEP(IDX1).NE.21).OR.(IDHEP(IDX2).NE.21)).AND.
4365 & (LFLIP)) THEN
4366 IF (PHEP(3,IDX1).GT.PHEP(3,IDX2)) THEN
4367 ISPTN1 = ISTHKK(MO1)
4368 M1PTN1 = MO1
4369 M2PTN1 = MO1+2
4370 ISPTN2 = ISTHKK(MO2)
4371 M1PTN2 = MO2-2
4372 M2PTN2 = MO2
4373 ELSE
4374 ISPTN1 = ISTHKK(MO2)
4375 M1PTN1 = MO2-2
4376 M2PTN1 = MO2
4377 ISPTN2 = ISTHKK(MO1)
4378 M1PTN2 = MO1
4379 M2PTN2 = MO1+2
4380 ENDIF
4381 ENDIF
4382* register partons in temporary common
4383* parton at chain end
4384 PX = PHEP(1,IDX1)
4385 PY = PHEP(2,IDX1)
4386 PZ = PHEP(3,IDX1)
4387 PE = PHEP(4,IDX1)
4388* flag only partons coming from Pomeron with 41/42
4389C IF ((IPOM1.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4390 IF (IPOM1.NE.0) THEN
4391 ISTX = ABS(ISPTN1)/10
4392 IMO = ABS(ISPTN1)-10*ISTX
4393 ISPTN1 = -(40+IMO)
4394 ELSE
4395 IF ((ICOLOR(2,IDX1).EQ.0).OR.(IDHEP(IDX1).EQ.21)) THEN
4396 ISTX = ABS(ISPTN1)/10
4397 IMO = ABS(ISPTN1)-10*ISTX
4398 IF ((IDHEP(IDX1).EQ.21).OR.
4399 & (ABS(IPHIST(1,IDX1)).GE.100)) THEN
4400 ISPTN1 = -(60+IMO)
4401 ELSE
4402 ISPTN1 = -(50+IMO)
4403 ENDIF
4404 ENDIF
4405 ENDIF
4406 IF (ISPTN1.EQ.-21) NPVAL = NPVAL+1
4407 IF (ISPTN1.EQ.-22) NTVAL = NTVAL+1
4408 IF (MODE.LT.0) THEN
4409 CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PX,PY,
4410 & PZ,PE,0,0,0)
4411 ELSE
4412 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4413 & PPX,PPY,PPZ,PPE)
4414 CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PPX,PPY,
4415 & PPZ,PPE,0,0,0)
4416 ENDIF
4417 IHIST(1,NHKK) = IPHIST(1,IDX1)
4418 IHIST(2,NHKK) = 0
4419 DO 19 KK=1,4
4420 VHKK(KK,NHKK) = VHKK(KK,M2PTN1)
4421 WHKK(KK,NHKK) = WHKK(KK,M1PTN1)
4422 19 CONTINUE
4423 VHKK(4,NHKK) = VHKK(3,M2PTN1)/BLAB-VHKK(3,M1PTN1)/BGLAB
4424 WHKK(4,NHKK) = -WHKK(3,M1PTN1)/BLAB+WHKK(3,M2PTN1)/BGLAB
4425 M1STRG = NHKK
4426* gluon kinks
4427 NGLUON = IDX2-IDX1-1
4428 IF (NGLUON.GT.0) THEN
4429 DO 17 IGLUON=1,NGLUON
4430 IDX = IDX1+IGLUON
4431 IDXMS = ABS(JMOHEP(1,IDX))
4432 IF ((IDXMS.NE.1).AND.(IDXMS.NE.2)) THEN
4433 ILOOP = 0
4434 16 CONTINUE
4435 ILOOP = ILOOP+1
4436 IDXMS = ABS(JMOHEP(1,IDXMS))
4437 IF ((IDXMS.NE.1).AND.(IDXMS.NE.2).AND.
4438 & (ILOOP.LT.MAXLOP)) GOTO 16
4439 IF (ILOOP.EQ.MAXLOP)
4440 & WRITE(LOUT,*) ' GETPJE: MAXLOP in 3 ! '
4441 ENDIF
4442 IF (IDXMS.EQ.1) THEN
4443 ISPTN = ISTHKK(MO1)
4444 M1PTN = MO1
4445 M2PTN = MO1+2
4446 ELSE
4447 ISPTN = ISTHKK(MO2)
4448 M1PTN = MO2-2
4449 M2PTN = MO2
4450 ENDIF
4451 PX = PHEP(1,IDX)
4452 PY = PHEP(2,IDX)
4453 PZ = PHEP(3,IDX)
4454 PE = PHEP(4,IDX)
4455 IF ((ICOLOR(2,IDX).EQ.0).OR.(IDHEP(IDX).EQ.21)) THEN
4456 ISTX = ABS(ISPTN)/10
4457 IMO = ABS(ISPTN)-10*ISTX
4458 IF ((IDHEP(IDX).EQ.21).OR.
4459 & (ABS(IPHIST(1,IDX)).GE.100)) THEN
4460 ISPTN = -(60+IMO)
4461 ELSE
4462 ISPTN = -(50+IMO)
4463 ENDIF
4464 ENDIF
4465 IF (ISPTN.EQ.-21) NPVAL = NPVAL+1
4466 IF (ISPTN.EQ.-22) NTVAL = NTVAL+1
4467 IF (MODE.LT.0) THEN
4468 CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4469 & PX,PY,PZ,PE,0,0,0)
4470 ELSE
4471 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4472 & PPX,PPY,PPZ,PPE)
4473 CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4474 & PPX,PPY,PPZ,PPE,0,0,0)
4475 ENDIF
4476 IHIST(1,NHKK) = IPHIST(1,IDX)
4477 IHIST(2,NHKK) = 0
4478 DO 20 KK=1,4
4479 VHKK(KK,NHKK) = VHKK(KK,M2PTN)
4480 WHKK(KK,NHKK) = WHKK(KK,M1PTN)
4481 20 CONTINUE
4482 VHKK(4,NHKK)= VHKK(3,M2PTN)/BLAB-VHKK(3,M1PTN)/BGLAB
4483 WHKK(4,NHKK)= -WHKK(3,M1PTN)/BLAB+WHKK(3,M2PTN)/BGLAB
4484 17 CONTINUE
4485 ENDIF
4486* parton at chain end
4487 PX = PHEP(1,IDX2)
4488 PY = PHEP(2,IDX2)
4489 PZ = PHEP(3,IDX2)
4490 PE = PHEP(4,IDX2)
4491* flag only partons coming from Pomeron with 41/42
4492C IF ((IPOM2.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4493 IF (IPOM2.NE.0) THEN
4494 ISTX = ABS(ISPTN2)/10
4495 IMO = ABS(ISPTN2)-10*ISTX
4496 ISPTN2 = -(40+IMO)
4497 ELSE
4498 IF ((ICOLOR(2,IDX2).EQ.0).OR.(IDHEP(IDX2).EQ.21)) THEN
4499 ISTX = ABS(ISPTN2)/10
4500 IMO = ABS(ISPTN2)-10*ISTX
4501 IF ((IDHEP(IDX2).EQ.21).OR.
4502 & (ABS(IPHIST(1,IDX2)).GE.100)) THEN
4503 ISPTN2 = -(60+IMO)
4504 ELSE
4505 ISPTN2 = -(50+IMO)
4506 ENDIF
4507 ENDIF
4508 ENDIF
4509 IF (ISPTN2.EQ.-21) NPVAL = NPVAL+1
4510 IF (ISPTN2.EQ.-22) NTVAL = NTVAL+1
4511 IF (MODE.LT.0) THEN
4512 CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4513 & PX,PY,PZ,PE,0,0,0)
4514 ELSE
4515 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4516 & PPX,PPY,PPZ,PPE)
4517 CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4518 & PPX,PPY,PPZ,PPE,0,0,0)
4519 ENDIF
4520 IHIST(1,NHKK) = IPHIST(1,IDX2)
4521 IHIST(2,NHKK) = 0
4522 DO 21 KK=1,4
4523 VHKK(KK,NHKK) = VHKK(KK,M2PTN2)
4524 WHKK(KK,NHKK) = WHKK(KK,M1PTN2)
4525 21 CONTINUE
4526 VHKK(4,NHKK) = VHKK(3,M2PTN2)/BLAB-VHKK(3,M1PTN2)/BGLAB
4527 WHKK(4,NHKK) = -WHKK(3,M1PTN2)/BLAB+WHKK(3,M2PTN2)/BGLAB
4528 M2STRG = NHKK
4529* register string
4530 JSTRG = 100*IPROCE+NCODE(I)
4531 PX = PHEP(1,IDXSTG)
4532 PY = PHEP(2,IDXSTG)
4533 PZ = PHEP(3,IDXSTG)
4534 PE = PHEP(4,IDXSTG)
4535 IF (MODE.LT.0) THEN
4536 ISTAT = 70000+IPJE
4537 CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4538 & PX,PY,PZ,PE,0,0,0)
4539 IF (LEMCCK) THEN
4540 PX = -PX
4541 PY = -PY
4542 PZ = -PZ
4543 PE = -PE
4544 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4545 ENDIF
4546 ELSE
4547 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4548 & PPX,PPY,PPZ,PPE)
4549 ISTAT = 70000+IPJE
4550 CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4551 & PPX,PPY,PPZ,PPE,0,0,0)
4552 IF (LEMCCK) THEN
4553 PX = -PPX
4554 PY = -PPY
4555 PZ = -PPZ
4556 PE = -PPE
4557 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4558 ENDIF
4559 ENDIF
4560 NOBAM(NHKK) = 0
4561 IHIST(1,NHKK) = 0
4562 IHIST(2,NHKK) = 0
4563 DO 18 KK=1,4
4564 VHKK(KK,NHKK) = VHKK(KK,MO2)
4565 WHKK(KK,NHKK) = WHKK(KK,MO1)
4566 18 CONTINUE
4567 VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
4568 WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
4569 ENDIF
4570 11 CONTINUE
4571
4572 IF ( ((NPVAL.GT.2).OR.(NTVAL.GT.2)).AND.(LFLIP) ) THEN
4573 NHKK = INHKK
4574 LFLIP = .FALSE.
4575 GOTO 1
4576 ENDIF
4577
4578 IF (LEMCCK) THEN
4579 IF (UMO.GT.1.0D5) THEN
4580 CHKLEV = 1.0D0
4581 ELSE
4582 CHKLEV = TINY1
4583 ENDIF
4584 CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,1000,IREJ2)
4585 IF (IREJ2.GT.ZERO) CALL PHO_PREVNT(0)
4586 ENDIF
4587
4588* internal statistics
4589* dble-Po statistics.
4590 IF (IPROCE.NE.4) IPOPO = 0
4591
4592 INTFLG = IPROCE
4593 IDCHSY = IDCH(MO1)
4594 IF ((IPROCE.GE.1).AND.(IPROCE.LE.8)) THEN
4595 ICEVTG(IDCHSY,IPROCE+2) = ICEVTG(IDCHSY,IPROCE+2)+1
4596 ELSE
4597 WRITE(LOUT,1000) IPROCE,NEVHKK,MO1
4598 1000 FORMAT(1X,'GETFSP: warning! incons. process id. (',I2,
4599 & ') at evt(chain) ',I6,'(',I2,')')
4600 ENDIF
4601 IF (IPROCE.EQ.5) THEN
4602 IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3)) THEN
4603 ICEVTG(IDCHSY,18+IDIFR1) = ICEVTG(IDCHSY,18+IDIFR1)+1
4604 ELSE
4605C WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4606 1001 FORMAT(1X,'GETFSP: warning! incons. diffrac. id. ',
4607 & '(IPROCE,IDIFR1,IDIFR2=',3I3,')')
4608 ENDIF
4609 ELSEIF (IPROCE.EQ.6) THEN
4610 IF ((IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4611 ICEVTG(IDCHSY,21+IDIFR2) = ICEVTG(IDCHSY,21+IDIFR2)+1
4612 ELSE
4613C WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4614 ENDIF
4615 ELSEIF (IPROCE.EQ.7) THEN
4616 IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3).AND.
4617 & (IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4618 IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.1))
4619 & ICEVTG(IDCHSY,25) = ICEVTG(IDCHSY,25)+1
4620 IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.2))
4621 & ICEVTG(IDCHSY,26) = ICEVTG(IDCHSY,26)+1
4622 IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.2))
4623 & ICEVTG(IDCHSY,27) = ICEVTG(IDCHSY,27)+1
4624 IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.1))
4625 & ICEVTG(IDCHSY,28) = ICEVTG(IDCHSY,28)+1
4626 ELSE
4627 WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4628 ENDIF
4629 ENDIF
4630 IF ((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GE.1).AND.(KHDIR.LE.3))
4631 & THEN
4632 ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4633 ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4634 ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4635 ENDIF
4636 ICEVTG(IDCHSY,14) = ICEVTG(IDCHSY,14)+KSPOM
4637 ICEVTG(IDCHSY,15) = ICEVTG(IDCHSY,15)+KHPOM
4638 ICEVTG(IDCHSY,16) = ICEVTG(IDCHSY,16)+KSREG
4639 ICEVTG(IDCHSY,17) = ICEVTG(IDCHSY,17)+(KSTRG+KHTRG)
4640 ICEVTG(IDCHSY,18) = ICEVTG(IDCHSY,18)+(KSLOO+KHLOO)
4641
4642 RETURN
4643
4644 9999 CONTINUE
4645 IREJ = 1
4646 RETURN
4647 END
4648
4649*$ CREATE DT_PHOINI.FOR
4650*COPY DT_PHOINI
4651*
4652*===phoini=============================================================*
4653*
4654 SUBROUTINE DT_PHOINI
4655
4656************************************************************************
4657* Initialization PHOJET-event generator for nucleon-nucleon interact. *
4658* This version dated 16.11.95 is written by S. Roesler *
4659* *
4660* Last change 27.12.2006 by S. Roesler. *
4661************************************************************************
4662
4663 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4664 SAVE
4665 PARAMETER ( LINP = 10 ,
4666 & LOUT = 6 ,
4667 & LDAT = 9 )
4668 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
4669
4670* nucleon-nucleon event-generator
4671 CHARACTER*8 CMODEL
4672 LOGICAL LPHOIN
4673 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
4674* particle properties (BAMJET index convention)
4675 CHARACTER*8 ANAME
4676 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
4677 & IICH(210),IIBAR(210),K1(210),K2(210)
4678* Lorentz-parameters of the current interaction
4679 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4680 & UMO,PPCM,EPROJ,PPROJ
4681* properties of interacting particles
4682 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
4683* properties of photon/lepton projectiles
4684 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
4685 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
4686* emulsion treatment
4687 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
4688 & NCOMPO,IEMUL
4689* VDM parameter for photon-nucleus interactions
4690 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
4691* nuclear potential
4692 LOGICAL LFERMI
4693 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
4694 & EBINDP(2),EBINDN(2),EPOT(2,210),
4695 & ETACOU(2),ICOUL,LFERMI
4696* Glauber formalism: flags and parameters for statistics
4697 LOGICAL LPROD
4698 CHARACTER*8 CGLB
4699 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
4700*
4701* parameters for cascade calculations:
4702* maximum mumber of PDF's which can be defined in phojet (limited
4703* by the dimension of ipdfs in pho_setpdf)
4704 PARAMETER (MAXPDF = 20)
4705* PDF parametrization and number of set for the first 30 hadrons in
4706* the bamjet-code list
4707* negative numbers mean that the PDF is set in phojet,
4708* zero stands for "not a hadron"
4709 DIMENSION IPARPD(30),ISETPD(30)
4710* PDF parametrization
4711 DATA IPARPD /
4712 & -5,-5, 0, 0, 0, 0,-5,-5,-5, 0, 0, 5,-5,-5, 5, 5, 5, 5, 5, 5,
4713 & 5, 5,-5, 5, 5, 0, 0, 0, 0, 0/
4714* number of set
4715 DATA ISETPD /
4716 & -6,-6, 0, 0, 0, 0,-3,-6,-6, 0, 0, 2,-2,-2, 2, 2, 6, 6, 2, 6,
4717 & 6, 6,-2, 2, 2, 0, 0, 0, 0, 0/
4718
4719**PHOJET105a
4720C COMMON /GLOCMS/ XECM,XPCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
4721C PARAMETER ( MAXPRO = 16 )
4722C PARAMETER ( MAXTAB = 20 )
4723C COMMON /HAXSEC/ XSECTA(4,-1:MAXPRO,4,MAXTAB),XSECT(6,-1:MAXPRO),
4724C & MXSECT(0:4,-1:MAXPRO,4),ECMSH(4,MAXTAB),ISTTAB
4725C CHARACTER*8 MDLNA
4726C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
4727C COMMON /PROCES/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15)
4728**PHOJET110
4729C global event kinematics and particle IDs
4730 INTEGER IFPAP,IFPAB
4731 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
4732 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
4733C hard cross sections and MC selection weights
4734 INTEGER Max_pro_2
4735 PARAMETER ( Max_pro_2 = 16 )
4736 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
4737 & MH_acc_1,MH_acc_2
4738 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
4739 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
4740 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
4741 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
4742 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
4743 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
4744C model switches and parameters
4745 CHARACTER*8 MDLNA
4746 INTEGER ISWMDL,IPAMDL
4747 DOUBLE PRECISION PARMDL
4748 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4749C general process information
4750 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
4751 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
4752**
4753 DIMENSION PP(4),PT(4)
4754
4755 LOGICAL LSTART
4756 DATA LSTART /.TRUE./
4757
4758 IJP = IJPROJ
4759 IJT = IJTARG
4760 Q2 = VIRT
4761* lepton-projectiles: initialize real photon instead
4762 IF ((IJP.EQ.3).OR.(IJP.EQ.4).OR.(IJP.EQ.10).OR.(IJP.EQ.11)) THEN
4763 IJP = 7
4764 Q2 = ZERO
4765 ENDIF
4766 IF (LPHOIN) CALL PHO_INIT(-1,LOUT,IDUM)
4767* switch Reggeon off
4768C IPAMDL(3)= 0
4769 IF (IP.EQ.1) THEN
4770 IFPAP(1) = IDT_IPDGHA(IJP)
4771 IFPAB(1) = IJP
4772 ELSE
4773 IFPAP(1) = 2212
4774 IFPAB(1) = IDT_ICIHAD(IFPAP(1))
4775 ENDIF
4776 PMASS(1) = AAM(IFPAB(1))-SQRT(Q2)
4777 PVIRT(1) = PMASS(1)**2
4778 IF (IT.EQ.1) THEN
4779 IFPAP(2) = IDT_IPDGHA(IJT)
4780 IFPAB(2) = IJT
4781 ELSE
4782 IFPAP(2) = 2212
4783 IFPAB(2) = IDT_ICIHAD(IFPAP(2))
4784 ENDIF
4785 PMASS(2) = AAM(IFPAB(2))
4786 PVIRT(2) = ZERO
4787 DO 1 K=1,4
4788 PP(K) = ZERO
4789 PT(K) = ZERO
4790 1 CONTINUE
4791* get max. possible momenta of incoming particles to be used for PHOJET ini.
4792 PPF = ZERO
4793 PTF = ZERO
4794 SCPF= 1.5D0
4795 IF (UMO.GE.1.E5) THEN
4796 SCPF= 5.0D0
4797 ENDIF
4798 IF (NCOMPO.GT.0) THEN
4799 DO 2 I=1,NCOMPO
4800 IF (IT.GT.1) THEN
4801 CALL DT_NCLPOT(IEMUCH(I),IEMUMA(I),ITZ,IT,ZERO,ZERO,0)
4802 ELSE
4803 CALL DT_NCLPOT(IPZ,IP,IEMUCH(I),IEMUMA(I),ZERO,ZERO,0)
4804 ENDIF
4805 PPFTMP = MAX(PFERMP(1),PFERMN(1))
4806 PTFTMP = MAX(PFERMP(2),PFERMN(2))
4807 IF (PPFTMP.GT.PPF) PPF = PPFTMP
4808 IF (PTFTMP.GT.PTF) PTF = PTFTMP
4809 2 CONTINUE
4810 ELSE
4811 CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
4812 PPF = MAX(PFERMP(1),PFERMN(1))
4813 PTF = MAX(PFERMP(2),PFERMN(2))
4814 ENDIF
4815 PTF = -PTF
4816 PPF = SCPF*PPF
4817 PTF = SCPF*PTF
4818 IF (IJP.EQ.7) THEN
4819 AMP2 = SIGN(PMASS(1)**2,PMASS(1))
4820 PP(3) = PPCM
4821 PP(4) = SQRT(AMP2+PP(3)**2)
4822 ELSE
4823 EPF = SQRT(PPF**2+PMASS(1)**2)
4824 CALL DT_LTNUC(PPF,EPF,PP(3),PP(4),2)
4825 ENDIF
4826 ETF = SQRT(PTF**2+PMASS(2)**2)
4827 CALL DT_LTNUC(PTF,ETF,PT(3),PT(4),3)
4828 ECMINI = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
4829 & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
4830 IF (LSTART) THEN
4831 WRITE(LOUT,1001) IP,IPZ,SCPF,PPF,PP
4832 1001 FORMAT(
4833 & ' DT_PHOINI: PHOJET initialized for projectile A,Z = ',
4834 & I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
4835 IF (NCOMPO.GT.0) THEN
4836 WRITE(LOUT,1002) SCPF,PTF,PT
4837 ELSE
4838 WRITE(LOUT,1003) IT,ITZ,SCPF,PTF,PT
4839 ENDIF
4840 1002 FORMAT(
4841 & ' DT_PHOINI: PHOJET initialized for target emulsion ',
4842 & /,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
4843 1003 FORMAT(
4844 & ' DT_PHOINI: PHOJET initialized for target A,Z = ',
4845 & I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
4846 WRITE(LOUT,1004) ECMINI
4847 1004 FORMAT(' E_cm = ',E10.3)
4848 IF (IJP.EQ.8) WRITE(LOUT,1005)
4849 1005 FORMAT(
4850 & ' DT_PHOINI: warning! proton parameters used for neutron',
4851 & ' projectile')
4852 LSTART = .FALSE.
4853 ENDIF
4854* switch off new diffractive cross sections at low energies for nuclei
4855* (temporary solution)
4856 IF ((ISWMDL(30).NE.0).AND.((IP.GT.1).OR.(IT.GT.1))) THEN
4857 WRITE(LOUT,'(1X,A)')
4858 & ' DT_PHOINI: model-switch 30 for nuclei re-set !'
4859 CALL PHO_SETMDL(30,0,1)
4860 ENDIF
4861*
4862C IF (IJP.EQ.7) THEN
4863C AMP2 = SIGN(PMASS(1)**2,PMASS(1))
4864C PP(3) = PPCM
4865C PP(4) = SQRT(AMP2+PP(3)**2)
4866C ELSE
4867C PFERMX = ZERO
4868C IF (IP.GT.1) PFERMX = 0.5D0
4869C EFERMX = SQRT(PFERMX**2+PMASS(1)**2)
4870C CALL DT_LTNUC(PFERMX,EFERMX,PP(3),PP(4),2)
4871C ENDIF
4872C PFERMX = ZERO
4873C IF ((IT.GT.1).OR.(NCOMPO.GT.0)) PFERMX = -0.5D0
4874C EFERMX = SQRT(PFERMX**2+PMASS(2)**2)
4875C CALL DT_LTNUC(PFERMX,EFERMX,PT(3),PT(4),3)
4876**sr 26.10.96
4877 ISAV = IPAMDL(13)
4878 IF ((ISHAD(2).EQ.1).AND.
4879 & ((IJPROJ.EQ. 7).OR.(IJPROJ.EQ.3).OR.(IJPROJ.EQ.4).OR.
4880 & (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11))) IPAMDL(13) = 1
4881**
4882 CALL PHO_EVENT(-1,PP,PT,SIGMAX,IREJ1)
4883**sr 26.10.96
4884 IPAMDL(13) = ISAV
4885**
4886*
4887* patch for cascade calculations:
4888* define parton distribution functions for other hadrons, i.e. other
4889* then defined already in phojet
4890 IF (IOGLB.EQ.100) THEN
4891 WRITE(LOUT,1006)
4892 1006 FORMAT(/,1X,'PHOINI: additional parton distribution functions',
4893 & ' assiged (ID,IPAR,ISET)',/)
4894 NPDF = 0
4895 DO 3 I=1,30
4896 IF (IPARPD(I).NE.0) THEN
4897 NPDF = NPDF+1
4898 IF (NPDF.GT.MAXPDF) STOP ' PHOINI: npdf > maxpdf !'
4899 IF ((IPARPD(I).GT.0).AND.(ISETPD(I).GT.0)) THEN
4900 IDPDG = IDT_IPDGHA(I)
4901 IPAR = IPARPD(I)
4902 ISET = ISETPD(I)
4903 WRITE(LOUT,'(13X,A8,3I6)') ANAME(I),IDPDG,IPAR,ISET
4904 CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,0,0,-1)
4905 ENDIF
4906 ENDIF
4907 3 CONTINUE
4908 ENDIF
4909
4910C CALL PHO_PHIST(-1,SIGMAX)
4911 IF (IREJ1.NE.0) THEN
4912 WRITE(LOUT,1000)
4913 1000 FORMAT(1X,'PHOINI: PHOJET event-initialization failed!')
4914 STOP
4915 ENDIF
4916
4917 RETURN
4918 END
4919
4920*$ CREATE DT_EVENTD.FOR
4921*COPY DT_EVENTD
4922*
4923*===eventd=============================================================*
4924*
4925 SUBROUTINE DT_EVENTD(IREJ)
4926
4927************************************************************************
4928* Quasi-elastic neutrino nucleus scattering. *
4929* This version dated 29.04.00 is written by S. Roesler. *
4930************************************************************************
4931
4932 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4933 SAVE
4934 PARAMETER ( LINP = 10 ,
4935 & LOUT = 6 ,
4936 & LDAT = 9 )
4937 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY5=1.0D-5)
4938 PARAMETER (SQTINF=1.0D+15)
4939
4940 LOGICAL LFIRST
4941
4942* event history
4943 PARAMETER (NMXHKK=200000)
4944 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
4945 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
4946 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
4947* extended event history
4948 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
4949 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
4950 & IHIST(2,NMXHKK)
4951* flags for input different options
4952 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
4953 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
4954 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
4955 PARAMETER (MAXLND=4000)
4956 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
4957* properties of interacting particles
4958 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
4959* Lorentz-parameters of the current interaction
4960 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4961 & UMO,PPCM,EPROJ,PPROJ
4962* nuclear potential
4963 LOGICAL LFERMI
4964 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
4965 & EBINDP(2),EBINDN(2),EPOT(2,210),
4966 & ETACOU(2),ICOUL,LFERMI
4967* steering flags for qel neutrino scattering modules
4968 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
4969 COMMON /QNPOL/ POLARX(4),PMODUL
4970 INTEGER PYK
4971
4972 DATA LFIRST /.TRUE./
4973
4974 IREJ = 0
4975
4976 IF (LFIRST) THEN
4977 LFIRST = .FALSE.
4978 CALL DT_MASS_INI
4979 ENDIF
4980
4981* JETSET parameter
4982 CALL DT_INITJS(0)
4983
4984* interacting target nucleon
4985 LTYP = NEUTYP
4986 IF (NEUDEC.LE.9) THEN
4987 IF ((LTYP.EQ.1).OR.(LTYP.EQ.3).OR.(LTYP.EQ.5)) THEN
4988 NUCTYP = 2112
4989 NUCTOP = 2
4990 ELSE
4991 NUCTYP = 2212
4992 NUCTOP = 1
4993 ENDIF
4994 ELSE
4995 RTYP = DT_RNDM(RTYP)
4996 ZFRAC = DBLE(ITZ)/DBLE(IT)
4997 IF (RTYP.LE.ZFRAC) THEN
4998 NUCTYP = 2212
4999 NUCTOP = 1
5000 ELSE
5001 NUCTYP = 2112
5002 NUCTOP = 2
5003 ENDIF
5004 ENDIF
5005
5006* select first nucleon in list with matching id and reset all other
5007* nucleons which have been marked as "wounded" by ININUC
5008 IFOUND = 0
5009 DO 1 I=1,NHKK
5010 IF ((IDHKK(I).EQ.NUCTYP).AND.(IFOUND.EQ.0)) THEN
5011 ISTHKK(I) = 12
5012 IFOUND = 1
5013 IDX = I
5014 ELSE
5015 IF (ISTHKK(I).EQ.12) ISTHKK(I) = 14
5016 ENDIF
5017 1 CONTINUE
5018 IF (IFOUND.EQ.0)
5019 & STOP ' EVENTD: interacting target nucleon not found! '
5020
5021* correct position of proj. lepton: assume position of target nucleon
5022 DO 3 I=1,4
5023 VHKK(I,1) = VHKK(I,IDX)
5024 WHKK(I,1) = WHKK(I,IDX)
5025 3 CONTINUE
5026
5027* load initial momenta for conservation check
5028 IF (LEMCCK) THEN
5029 CALL DT_EVTEMC(ZERO,ZERO,PPROJ,EPROJ,1,IDUM,IDUM)
5030 CALL DT_EVTEMC(PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),PHKK(4,IDX),
5031 & 2,IDUM,IDUM)
5032 ENDIF
5033
5034* quasi-elastic scattering
5035 IF (NEUDEC.LT.9) THEN
5036 CALL DT_QEL_POL(EPROJ,LTYP,PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),
5037 & PHKK(4,IDX),PHKK(5,IDX))
5038* CC event on p or n
5039 ELSEIF (NEUDEC.EQ.10) THEN
5040 CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,1,PHKK(1,IDX),PHKK(2,IDX),
5041 & PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5042* NC event on p or n
5043 ELSEIF (NEUDEC.EQ.11) THEN
5044 CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,2,PHKK(1,IDX),PHKK(2,IDX),
5045 & PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5046 ENDIF
5047
5048* get final state particles from Lund-common and write them into HKKEVT
5049 NPOINT(1) = NHKK+1
5050 NPOINT(4) = NHKK+1
5051 NLINES = PYK(0,1)
5052 NHKK0 = NHKK+1
5053 DO 4 I=4,NLINES
5054 IF (K(I,1).EQ.1) THEN
5055 ID = K(I,2)
5056 PX = P(I,1)
5057 PY = P(I,2)
5058 PZ = P(I,3)
5059 PE = P(I,4)
5060 CALL DT_EVTPUT(1,ID,1,IDX,PX,PY,PZ,PE,0,0,0)
5061 IDBJ = IDT_ICIHAD(ID)
5062 EKIN = PHKK(4,NHKK)-PHKK(5,NHKK)
5063 IF ((IDBJ.EQ.1).OR.(IDBJ.EQ.8)) THEN
5064 IF (EKIN.LE.EPOT(2,IDBJ)) ISTHKK(NHKK) = 16
5065 ENDIF
5066 VHKK(1,NHKK) = VHKK(1,IDX)
5067 VHKK(2,NHKK) = VHKK(2,IDX)
5068 VHKK(3,NHKK) = VHKK(3,IDX)
5069 VHKK(4,NHKK) = VHKK(4,IDX)
5070C IF (I.EQ.4) THEN
5071C WHKK(1,NHKK) = POLARX(1)
5072C WHKK(2,NHKK) = POLARX(2)
5073C WHKK(3,NHKK) = POLARX(3)
5074C WHKK(4,NHKK) = POLARX(4)
5075C ELSE
5076 WHKK(1,NHKK) = WHKK(1,IDX)
5077 WHKK(2,NHKK) = WHKK(2,IDX)
5078 WHKK(3,NHKK) = WHKK(3,IDX)
5079 WHKK(4,NHKK) = WHKK(4,IDX)
5080C ENDIF
5081 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
5082 ENDIF
5083 4 CONTINUE
5084
5085 IF (LEMCCK) THEN
5086 CHKLEV = TINY5
5087 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,778,IREJ1)
5088 IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
5089 ENDIF
5090
5091* transform momenta into cms (as required for inc etc.)
5092 DO 5 I=NHKK0,NHKK
5093 IF (ISTHKK(I).EQ.1) THEN
5094 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,3)
5095 PHKK(3,I) = PZ
5096 PHKK(4,I) = PE
5097 ENDIF
5098 5 CONTINUE
5099
5100 RETURN
5101 END
5102
5103*$ CREATE DT_KKEVNT.FOR
5104*COPY DT_KKEVNT
5105*
5106*===kkevnt=============================================================*
5107*
5108 SUBROUTINE DT_KKEVNT(KKMAT,IREJ)
5109
5110************************************************************************
5111* Treatment of complete nucleus-nucleus or hadron-nucleus scattering *
5112* without nuclear effects (one event). *
5113* This subroutine is an update of the previous version (KKEVT) written *
5114* by J. Ranft/ H.-J. Moehring. *
5115* This version dated 20.04.95 is written by S. Roesler *
5116************************************************************************
5117
5118 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5119 SAVE
5120 PARAMETER ( LINP = 10 ,
5121 & LOUT = 6 ,
5122 & LDAT = 9 )
5123 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10)
5124
5125 PARAMETER ( MAXNCL = 260,
5126 & MAXVQU = MAXNCL,
5127 & MAXSQU = 20*MAXVQU,
5128 & MAXINT = MAXVQU+MAXSQU)
5129* event history
5130 PARAMETER (NMXHKK=200000)
5131 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5132 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5133 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5134* extended event history
5135 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5136 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5137 & IHIST(2,NMXHKK)
5138* flags for input different options
5139 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5140 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5141 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5142* rejection counter
5143 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
5144 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
5145 & IREXCI(3),IRDIFF(2),IRINC
5146* statistics
5147 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5148 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5149 & ICEVTG(8,0:30)
5150* properties of interacting particles
5151 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5152* Lorentz-parameters of the current interaction
5153 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5154 & UMO,PPCM,EPROJ,PPROJ
5155* flags for diffractive interactions (DTUNUC 1.x)
5156 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
5157* interface HADRIN-DPM
5158 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5159* nucleon-nucleon event-generator
5160 CHARACTER*8 CMODEL
5161 LOGICAL LPHOIN
5162 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
5163* coordinates of nucleons
5164 COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
5165* interface between Glauber formalism and DPM
5166 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
5167 & INTER1(MAXINT),INTER2(MAXINT)
5168* Glauber formalism: collision properties
5169 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5170 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
5171* central particle production, impact parameter biasing
5172 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5173**temporary
5174* statistics: Glauber-formalism
5175 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
5176**
5177
5178 DATA NEVOLD,IPOLD,ITOLD,JJPOLD,EPROLD /4*0,0.0D0/
5179
5180 IREJ = 0
5181 ICREQU = ICREQU+1
5182 NC = 0
5183
5184 1 CONTINUE
5185 ICSAMP = ICSAMP+1
5186 NC = NC+1
5187 IF (MOD(NC,10).EQ.0) THEN
5188 WRITE(LOUT,1000) NEVHKK
5189 1000 FORMAT(1X,'KKEVNT: event ',I8,' rejected!')
5190 GOTO 9999
5191 ENDIF
5192
5193* initialize DTEVT1/DTEVT2
5194 CALL DT_EVTINI
5195
5196* We need the following only in order to sample nucleon coordinates.
5197* However we don't have parameters (cross sections, slope etc.)
5198* for neutrinos available. Therefore switch projectile to proton
5199* in this case.
5200 IF (MCGENE.EQ.4) THEN
5201 JJPROJ = 1
5202 ELSE
5203 JJPROJ = IJPROJ
5204 ENDIF
5205
5206 10 CONTINUE
5207 IF ( (NEVHKK.NE.NEVOLD).OR.(ICENTR.GT.0).OR.
5208* make sure that Glauber-formalism is called each time the interaction
5209* configuration changed
5210 & (IP.NE.IPOLD).OR.(IT.NE.ITOLD).OR.(JJPROJ.NE.JJPOLD).OR.
5211 & (ABS(EPROJ-EPROLD).GT.TINY10) ) THEN
5212* sample number of nucleon-nucleon coll. according to Glauber-form.
5213 CALL DT_GLAUBE(IP,IT,JJPROJ,BIMPAC,NN,NP,NT,JSSH,JTSH,KKMAT)
5214 NWTSAM = NN
5215 NWASAM = NP
5216 NWBSAM = NT
5217 NEVOLD = NEVHKK
5218 IPOLD = IP
5219 ITOLD = IT
5220 JJPOLD = JJPROJ
5221 EPROLD = EPROJ
5222 ENDIF
5223
5224* force diffractive particle production in h-K interactions
5225 IF (((ABS(ISINGD).GT.1).OR.(ABS(IDOUBD).GT.1)).AND.
5226 & (IP.EQ.1).AND.(NN.NE.1)) THEN
5227 NEVOLD = 0
5228 GOTO 10
5229 ENDIF
5230
5231* check number of involved proj. nucl. (NP) if central prod.is requested
5232 IF (ICENTR.GT.0) THEN
5233 CALL DT_CHKCEN(IP,IT,NP,NT,IBACK)
5234 IF (IBACK.GT.0) GOTO 10
5235 ENDIF
5236
5237* get initial nucleon-configuration in projectile and target
5238* rest-system (including Fermi-momenta if requested)
5239 CALL DT_ININUC(IJPROJ,IP,IPZ,PKOO,JSSH,1)
5240 MODE = 2
5241 IF (EPROJ.LE.EHADTH) MODE = 3
5242 CALL DT_ININUC(IJTARG,IT,ITZ,TKOO,JTSH,MODE)
5243
5244 IF ((MCGENE.NE.3).AND.(MCGENE.NE.4)) THEN
5245
5246* activate HADRIN at low energies (implemented for h-N scattering only)
5247 IF (EPROJ.LE.EHADHI) THEN
5248 IF (EHADTH.LT.ZERO) THEN
5249* smooth transition btwn. DPM and HADRIN
5250 FRAC = (EPROJ-EHADLO)/(EHADHI-EHADLO)
5251 RR = DT_RNDM(FRAC)
5252 IF (RR.GT.FRAC) THEN
5253 IF (IP.EQ.1) THEN
5254 CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5255 IF (IREJ1.GT.0) GOTO 1
5256 RETURN
5257 ELSE
5258 WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5259 ENDIF
5260 ENDIF
5261 ELSE
5262* fixed threshold for onset of production via HADRIN
5263 IF (EPROJ.LE.EHADTH) THEN
5264 IF (IP.EQ.1) THEN
5265 CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5266 IF (IREJ1.GT.0) GOTO 1
5267 RETURN
5268 ELSE
5269 WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5270 ENDIF
5271 ENDIF
5272 ENDIF
5273 ENDIF
5274 1001 FORMAT(1X,'KKEVNT: warning! interaction of proj. (m=',
5275 & I3,') with target (m=',I3,')',/,11X,
5276 & 'at E_lab=',F5.1,'GeV (threshold-energy: ',F3.1,
5277 & 'GeV) cannot be handled')
5278
5279* sampling of momentum-x fractions & flavors of chain ends
5280 CALL DT_SPLPTN(NN)
5281
5282* Lorentz-transformation of wounded nucleons into nucl.-nucl. cms
5283 CALL DT_NUC2CM
5284
5285* collect momenta of chain ends and put them into DTEVT1
5286 CALL DT_GETPTN(IP,NN,NCSY,IREJ1)
5287 IF (IREJ1.NE.0) GOTO 1
5288
5289 ENDIF
5290
5291* handle chains including fragmentation (two-chain approximation)
5292 IF (MCGENE.EQ.1) THEN
5293* two-chain approximation
5294 CALL DT_EVENTA(IJPROJ,IP,IT,NCSY,IREJ1)
5295 IF (IREJ1.NE.0) THEN
5296 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKEVNT'
5297 GOTO 1
5298 ENDIF
5299 ELSEIF (MCGENE.EQ.2) THEN
5300* multiple-Po exchange including minijets
5301 CALL DT_EVENTB(NCSY,IREJ1)
5302 IF (IREJ1.NE.0) THEN
5303 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKEVNT'
5304 GOTO 1
5305 ENDIF
5306 ELSEIF (MCGENE.EQ.3) THEN
5307 STOP ' This version does not contain LEPTO !'
5308 ELSEIF (MCGENE.EQ.4) THEN
5309* quasi-elastic neutrino scattering
5310 CALL DT_EVENTD(IREJ1)
5311 IF (IREJ1.NE.0) THEN
5312 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 4 in KKEVNT'
5313 GOTO 1
5314 ENDIF
5315 ELSE
5316 WRITE(LOUT,1002) MCGENE
5317 1002 FORMAT(1X,'KKEVNT: warning! event-generator',I4,
5318 & ' not available - program stopped')
5319 STOP
5320 ENDIF
5321
5322 RETURN
5323
5324 9999 CONTINUE
5325 IREJ = 1
5326 RETURN
5327 END
5328
5329*$ CREATE DT_CHKCEN.FOR
5330*COPY DT_CHKCEN
5331*
5332*===chkcen=============================================================*
5333*
5334 SUBROUTINE DT_CHKCEN(IP,IT,NP,NT,IBACK)
5335
5336************************************************************************
5337* Check of number of involved projectile nucleons if central production*
5338* is requested. *
5339* Adopted from a part of the old KKEVT routine which was written by *
5340* J. Ranft/H.-J.Moehring. *
5341* This version dated 13.01.95 is written by S. Roesler *
5342************************************************************************
5343
5344 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5345 SAVE
5346 PARAMETER ( LINP = 10 ,
5347 & LOUT = 6 ,
5348 & LDAT = 9 )
5349
5350* statistics
5351 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5352 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5353 & ICEVTG(8,0:30)
5354* central particle production, impact parameter biasing
5355 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5356
5357 IBACK = 0
5358
5359* old version
5360 IF (ICENTR.EQ.2) THEN
5361 IF (IP.LT.IT) THEN
5362 IF (IP.LE.8) THEN
5363 IF (NP.LT.IP-1) IBACK = 1
5364 ELSEIF (IP.LE.16) THEN
5365 IF (NP.LT.IP-2) IBACK = 1
5366 ELSEIF (IP.LE.32) THEN
5367 IF (NP.LT.IP-3) IBACK = 1
5368 ELSEIF (IP.GE.33) THEN
5369 IF (NP.LT.IP-5) IBACK = 1
5370 ENDIF
5371 ELSEIF (IP.EQ.IT) THEN
5372 IF (IP.EQ.32) THEN
5373 IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5374 ELSE
5375 IF (NP.LT.IP-IP/8) IBACK = 1
5376 ENDIF
5377 ELSEIF (ABS(IP-IT).LT.3) THEN
5378 IF (NP.LT.IP-IP/8) IBACK = 1
5379 ENDIF
5380 ELSE
5381* new version (DPMJET, 5.6.99)
5382 IF (IP.LT.IT) THEN
5383 IF (IP.LE.8) THEN
5384 IF (NP.LT.IP-1) IBACK = 1
5385 ELSEIF (IP.LE.16) THEN
5386 IF (NP.LT.IP-2) IBACK = 1
5387 ELSEIF (IP.LT.32) THEN
5388 IF (NP.LT.IP-3) IBACK = 1
5389 ELSEIF (IP.GE.32) THEN
5390 IF (IT.LE.150) THEN
5391* Example: S-Ag
5392 IF (NP.LT.IP-1) IBACK = 1
5393 ELSE
5394* Example: S-Au
5395 IF (NP.LT.IP) IBACK = 1
5396 ENDIF
5397 ENDIF
5398 ELSEIF (IP.EQ.IT) THEN
5399* Example: S-S
5400 IF (IP.EQ.32) THEN
5401 IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5402* Example: Pb-Pb
5403 ELSE
5404 IF (NP.LT.IP-IP/4) IBACK = 1
5405 ENDIF
5406 ELSEIF (ABS(IP-IT).LT.3) THEN
5407 IF (NP.LT.IP-IP/8) IBACK = 1
5408 ENDIF
5409 ENDIF
5410
5411 ICCPRO = ICCPRO+1
5412
5413 RETURN
5414 END
5415
5416*$ CREATE DT_ININUC.FOR
5417*COPY DT_ININUC
5418*
5419*===ininuc=============================================================*
5420*
5421 SUBROUTINE DT_ININUC(ID,NMASS,NCH,COORD,JS,IMODE)
5422
5423************************************************************************
5424* Samples initial configuration of nucleons in nucleus with mass NMASS *
5425* including Fermi-momenta (if reqested). *
5426* ID BAMJET-code for hadrons (instead of nuclei) *
5427* NMASS mass number of nucleus (number of nucleons) *
5428* NCH charge of nucleus *
5429* COORD(3,NMASS) coordinates of nucleons inside nucleus in fm *
5430* JS(NMASS) > 0 nucleon undergoes nucleon-nucleon interact. *
5431* IMODE = 1 projectile nucleus *
5432* = 2 target nucleus *
5433* = 3 target nucleus (E_lab<E_thr for HADRIN) *
5434* Adopted from a part of the old KKEVT routine which was written by *
5435* J. Ranft/H.-J.Moehring. *
5436* This version dated 13.01.95 is written by S. Roesler *
5437************************************************************************
5438
5439 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5440 SAVE
5441 PARAMETER ( LINP = 10 ,
5442 & LOUT = 6 ,
5443 & LDAT = 9 )
5444 PARAMETER (FM2MM=1.0D-12)
5445
5446 PARAMETER ( MAXNCL = 260,
5447 & MAXVQU = MAXNCL,
5448 & MAXSQU = 20*MAXVQU,
5449 & MAXINT = MAXVQU+MAXSQU)
5450* event history
5451 PARAMETER (NMXHKK=200000)
5452 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5453 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5454 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5455* extended event history
5456 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5457 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5458 & IHIST(2,NMXHKK)
5459* flags for input different options
5460 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5461 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5462 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5463* auxiliary common for chain system storage (DTUNUC 1.x)
5464 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
5465* nuclear potential
5466 LOGICAL LFERMI
5467 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5468 & EBINDP(2),EBINDN(2),EPOT(2,210),
5469 & ETACOU(2),ICOUL,LFERMI
5470* properties of photon/lepton projectiles
5471 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5472* particle properties (BAMJET index convention)
5473 CHARACTER*8 ANAME
5474 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5475 & IICH(210),IIBAR(210),K1(210),K2(210)
5476* Glauber formalism: collision properties
5477 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5478 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
5479* flavors of partons (DTUNUC 1.x)
5480 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5481 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5482 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
5483 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5484 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
5485 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5486 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
5487* interface HADRIN-DPM
5488 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5489
5490 DIMENSION PF(4),PFTOT(4),COORD(3,MAXNCL),JS(MAXNCL)
5491
5492* number of neutrons
5493 NNEU = NMASS-NCH
5494* initializations
5495 NP = 0
5496 NN = 0
5497 DO 1 K=1,4
5498 PFTOT(K) = 0.0D0
5499 1 CONTINUE
5500 MODE = IMODE
5501 IF (IMODE.GT.2) MODE = 2
5502**sr 29.5. new NPOINT(1)-definition
5503C IF (IMODE.GE.2) NPOINT(1) = NHKK+1
5504**
5505 NHADRI = 0
5506 NC = NHKK
5507
5508* get initial configuration
5509 DO 2 I=1,NMASS
5510 NHKK = NHKK+1
5511 IF (JS(I).GT.0) THEN
5512 ISTHKK(NHKK) = 10+MODE
5513 IF (IMODE.EQ.3) THEN
5514* additional treatment if HADRIN-generator is requested
5515 NHADRI = NHADRI+1
5516 IF (NHADRI.EQ.1) IDXTA = NHKK
5517 IF (NHADRI.GT.1) ISTHKK(NHKK) = 14
5518 ENDIF
5519 ELSE
5520 ISTHKK(NHKK) = 12+MODE
5521 ENDIF
5522 IF (NMASS.GE.2) THEN
5523* treatment for nuclei
5524 FRAC = 1.0D0-DBLE(NCH)/DBLE(NMASS)
5525 RR = DT_RNDM(FRAC)
5526 IF ((RR.LT.FRAC).AND.(NN.LT.NNEU)) THEN
5527 IDX = 8
5528 NN = NN+1
5529 ELSEIF ((RR.GE.FRAC).AND.(NP.LT.NCH)) THEN
5530 IDX = 1
5531 NP = NP+1
5532 ELSEIF (NN.LT.NNEU) THEN
5533 IDX = 8
5534 NN = NN+1
5535 ELSEIF (NP.LT.NCH) THEN
5536 IDX = 1
5537 NP = NP+1
5538 ENDIF
5539 IDHKK(NHKK) = IDT_IPDGHA(IDX)
5540 IDBAM(NHKK) = IDX
5541 IF (MODE.EQ.1) THEN
5542 IPOSP(I) = NHKK
5543 KKPROJ(I) = IDX
5544 ELSE
5545 IPOST(I) = NHKK
5546 KKTARG(I) = IDX
5547 ENDIF
5548 IF (IDX.EQ.1) THEN
5549 PFER = PFERMP(MODE)
5550 PBIN = SQRT(2.0D0*EBINDP(MODE)*AAM(1))
5551 ELSE
5552 PFER = PFERMN(MODE)
5553 PBIN = SQRT(2.0D0*EBINDN(MODE)*AAM(8))
5554 ENDIF
5555 CALL DT_FER4M(PFER,PBIN,PF(1),PF(2),PF(3),PF(4),IDX)
5556 DO 3 K=1,4
5557 PFTOT(K) = PFTOT(K)+PF(K)
5558 PHKK(K,NHKK) = PF(K)
5559 3 CONTINUE
5560 PHKK(5,NHKK) = AAM(IDX)
5561 ELSE
5562* treatment for hadrons
5563 IDHKK(NHKK) = IDT_IPDGHA(ID)
5564 IDBAM(NHKK) = ID
5565 PHKK(4,NHKK) = AAM(ID)
5566 PHKK(5,NHKK) = AAM(ID)
5567C* VDM assumption
5568C IF (IDHKK(NHKK).EQ.22) THEN
5569C PHKK(4,NHKK) = AAM(33)
5570C PHKK(5,NHKK) = AAM(33)
5571C ENDIF
5572 IF (MODE.EQ.1) THEN
5573 IPOSP(I) = NHKK
5574 KKPROJ(I) = ID
5575 PHKK(5,NHKK) = PHKK(5,NHKK)-SQRT(VIRT)
5576 ELSE
5577 IPOST(I) = NHKK
5578 KKTARG(I) = ID
5579 ENDIF
5580 ENDIF
5581 DO 4 K=1,3
5582 VHKK(K,NHKK) = COORD(K,I)*FM2MM
5583 WHKK(K,NHKK) = COORD(K,I)*FM2MM
5584 4 CONTINUE
5585 IF (MODE.EQ.2) VHKK(1,NHKK) = VHKK(1,NHKK)+BIMPAC*FM2MM
5586 IF (MODE.EQ.2) WHKK(1,NHKK) = WHKK(1,NHKK)+BIMPAC*FM2MM
5587 VHKK(4,NHKK) = 0.0D0
5588 WHKK(4,NHKK) = 0.0D0
5589 2 CONTINUE
5590
5591* balance Fermi-momenta
5592 IF (NMASS.GE.2) THEN
5593 DO 5 I=1,NMASS
5594 NC = NC+1
5595 DO 6 K=1,3
5596 PHKK(K,NC) = PHKK(K,NC)-PFTOT(K)/DBLE(NMASS)
5597 6 CONTINUE
5598 PHKK(4,NC) = SQRT(PHKK(5,NC)**2+PHKK(1,NC)**2+
5599 & PHKK(2,NC)**2+PHKK(3,NC)**2)
5600 5 CONTINUE
5601 ENDIF
5602
5603 RETURN
5604 END
5605
5606*$ CREATE DT_FER4M.FOR
5607*COPY DT_FER4M
5608*
5609*===fer4m==============================================================*
5610*
5611 SUBROUTINE DT_FER4M(PFERM,PBIND,PXT,PYT,PZT,ET,KT)
5612
5613************************************************************************
5614* Sampling of nucleon Fermi-momenta from distributions at T=0. *
5615* processed by S. Roesler, 17.10.95 *
5616************************************************************************
5617
5618 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5619 SAVE
5620 PARAMETER ( LINP = 10 ,
5621 & LOUT = 6 ,
5622 & LDAT = 9 )
5623
5624 LOGICAL LSTART
5625
5626* particle properties (BAMJET index convention)
5627 CHARACTER*8 ANAME
5628 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5629 & IICH(210),IIBAR(210),K1(210),K2(210)
5630* nuclear potential
5631 LOGICAL LFERMI
5632 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5633 & EBINDP(2),EBINDN(2),EPOT(2,210),
5634 & ETACOU(2),ICOUL,LFERMI
5635
5636 DATA LSTART /.TRUE./
5637
5638 ILOOP = 0
5639 IF (LFERMI) THEN
5640 IF (LSTART) THEN
5641 WRITE(LOUT,1000)
5642 1000 FORMAT(/,1X,'FER4M: sampling of Fermi-momenta activated')
5643 LSTART = .FALSE.
5644 ENDIF
5645 1 CONTINUE
5646 CALL DT_DFERMI(PABS)
5647 PABS = PFERM*PABS
5648C IF (PABS.GE.PBIND) THEN
5649C ILOOP = ILOOP+1
5650C IF (MOD(ILOOP,500).EQ.0) THEN
5651C WRITE(LOUT,1001) PABS,PBIND,ILOOP
5652C1001 FORMAT(1X,'FER4M: Fermi-mom. corr. for binding',
5653C & ' energy ',2E12.3,I6)
5654C ENDIF
5655C GOTO 1
5656C ENDIF
5657 CALL DT_DPOLI(POLC,POLS)
5658 CALL DT_DSFECF(SFE,CFE)
5659 CXTA = POLS*CFE
5660 CYTA = POLS*SFE
5661 CZTA = POLC
5662 ET = SQRT(PABS*PABS+AAM(KT)**2)
5663 PXT = CXTA*PABS
5664 PYT = CYTA*PABS
5665 PZT = CZTA*PABS
5666 ELSE
5667 ET = AAM(KT)
5668 PXT = 0.0D0
5669 PYT = 0.0D0
5670 PZT = 0.0D0
5671 ENDIF
5672
5673 RETURN
5674 END
5675
5676*$ CREATE DT_NUC2CM.FOR
5677*COPY DT_NUC2CM
5678*
5679*===nuc2cm=============================================================*
5680*
5681 SUBROUTINE DT_NUC2CM
5682
5683************************************************************************
5684* Lorentz-transformation of all wounded nucleons from Lab. to nucl.- *
5685* nucl. cms. (This subroutine replaces NUCMOM.) *
5686* This version dated 15.01.95 is written by S. Roesler *
5687************************************************************************
5688
5689 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5690 SAVE
5691 PARAMETER ( LINP = 10 ,
5692 & LOUT = 6 ,
5693 & LDAT = 9 )
5694 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
5695
5696* event history
5697 PARAMETER (NMXHKK=200000)
5698 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5699 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5700 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5701* extended event history
5702 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5703 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5704 & IHIST(2,NMXHKK)
5705* statistics
5706 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5707 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5708 & ICEVTG(8,0:30)
5709* properties of photon/lepton projectiles
5710 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5711* particle properties (BAMJET index convention)
5712 CHARACTER*8 ANAME
5713 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5714 & IICH(210),IIBAR(210),K1(210),K2(210)
5715* Glauber formalism: collision properties
5716 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5717 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
5718**temporary
5719* statistics: Glauber-formalism
5720 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
5721**
5722
5723 ICWP = 0
5724 ICWT = 0
5725 NWTACC = 0
5726 NWAACC = 0
5727 NWBACC = 0
5728
5729 NPOINT(1) = NHKK+1
5730 NEND = NHKK
5731 DO 1 I=1,NEND
5732 IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.12)) THEN
5733 IF (ISTHKK(I).EQ.11) NWAACC = NWAACC+1
5734 IF (ISTHKK(I).EQ.12) NWBACC = NWBACC+1
5735 MODE = ISTHKK(I)-9
5736C IF (IDHKK(I).EQ.22) THEN
5737C* VDM assumption
5738C PEIN = AAM(33)
5739C IDB = 33
5740C ELSE
5741C PEIN = PHKK(4,I)
5742C IDB = IDBAM(I)
5743C ENDIF
5744C CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PEIN,
5745C & PX,PY,PZ,PE,IDB,MODE)
5746 IF (PHKK(5,I).GT.ZERO) THEN
5747 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
5748 & PX,PY,PZ,PE,IDBAM(I),MODE)
5749 ELSE
5750 PX = PGAMM(1)
5751 PY = PGAMM(2)
5752 PZ = PGAMM(3)
5753 PE = PGAMM(4)
5754 ENDIF
5755 IST = ISTHKK(I)-2
5756 ID = IDHKK(I)
5757C* VDM assumption
5758C IF (ID.EQ.22) ID = 113
5759 CALL DT_EVTPUT(IST,ID,I,0,PX,PY,PZ,PE,0,0,0)
5760 IF (ISTHKK(I).EQ.11) ICWP = ICWP+1
5761 IF (ISTHKK(I).EQ.12) ICWT = ICWT+1
5762 ENDIF
5763 1 CONTINUE
5764
5765 NWTACC = MAX(NWAACC,NWBACC)
5766 ICDPR = ICDPR+ICWP
5767 ICDTA = ICDTA+ICWT
5768**temporary
5769 IF ((ICWP.EQ.0).OR.(ICWT.EQ.0)) THEN
5770 CALL DT_EVTOUT(4)
5771 STOP
5772 ENDIF
5773
5774 RETURN
5775 END
5776
5777*$ CREATE DT_SPLPTN.FOR
5778*COPY DT_SPLPTN
5779*
5780*===splptn=============================================================*
5781*
5782 SUBROUTINE DT_SPLPTN(NN)
5783
5784************************************************************************
5785* SamPLing of ParToN momenta and flavors. *
5786* This version dated 15.01.95 is written by S. Roesler *
5787************************************************************************
5788
5789 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5790 SAVE
5791 PARAMETER ( LINP = 10 ,
5792 & LOUT = 6 ,
5793 & LDAT = 9 )
5794
5795* Lorentz-parameters of the current interaction
5796 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5797 & UMO,PPCM,EPROJ,PPROJ
5798
5799* sample flavors of sea-quarks
5800 CALL DT_SPLFLA(NN,1)
5801
5802* sample x-values of partons at chain ends
5803 ECM = UMO
5804 CALL DT_XKSAMP(NN,ECM)
5805
5806* samle flavors
5807 CALL DT_SPLFLA(NN,2)
5808
5809 RETURN
5810 END
5811
5812*$ CREATE DT_SPLFLA.FOR
5813*COPY DT_SPLFLA
5814*
5815*===splfla=============================================================*
5816*
5817 SUBROUTINE DT_SPLFLA(NN,MODE)
5818
5819************************************************************************
5820* SamPLing of FLAvors of partons at chain ends. *
5821* This subroutine replaces FLKSAA/FLKSAM. *
5822* NN number of nucleon-nucleon interactions *
5823* MODE = 1 sea-flavors *
5824* = 2 valence-flavors *
5825* Based on the original version written by J. Ranft/H.-J. Moehring. *
5826* This version dated 16.01.95 is written by S. Roesler *
5827************************************************************************
5828
5829 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5830 SAVE
5831 PARAMETER ( LINP = 10 ,
5832 & LOUT = 6 ,
5833 & LDAT = 9 )
5834
5835 PARAMETER ( MAXNCL = 260,
5836 & MAXVQU = MAXNCL,
5837 & MAXSQU = 20*MAXVQU,
5838 & MAXINT = MAXVQU+MAXSQU)
5839* flavors of partons (DTUNUC 1.x)
5840 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5841 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5842 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
5843 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5844 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
5845 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5846 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
5847* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5848 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
5849 & IXPV,IXPS,IXTV,IXTS,
5850 & INTVV1(MAXVQU),INTVV2(MAXVQU),
5851 & INTSV1(MAXVQU),INTSV2(MAXVQU),
5852 & INTVS1(MAXVQU),INTVS2(MAXVQU),
5853 & INTSS1(MAXSQU),INTSS2(MAXSQU),
5854 & INTDV1(MAXVQU),INTDV2(MAXVQU),
5855 & INTVD1(MAXVQU),INTVD2(MAXVQU),
5856 & INTDS1(MAXSQU),INTDS2(MAXSQU),
5857 & INTSD1(MAXSQU),INTSD2(MAXSQU)
5858* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5859 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
5860 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
5861* particle properties (BAMJET index convention)
5862 CHARACTER*8 ANAME
5863 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5864 & IICH(210),IIBAR(210),K1(210),K2(210)
5865* various options for treatment of partons (DTUNUC 1.x)
5866* (chain recombination, Cronin,..)
5867 LOGICAL LCO2CR,LINTPT
5868 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
5869 & LCO2CR,LINTPT
5870
5871 IF (MODE.EQ.1) THEN
5872* sea-flavors
5873 DO 1 I=1,NN
5874 IPSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
5875 IPSAQ(I) = -IPSQ(I)
5876 1 CONTINUE
5877 DO 2 I=1,NN
5878 ITSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
5879 ITSAQ(I)= -ITSQ(I)
5880 2 CONTINUE
5881 ELSEIF (MODE.EQ.2) THEN
5882* valence flavors
5883 DO 3 I=1,IXPV
5884 CALL DT_FLAHAD(KKPROJ(IFROVP(I)),IPVQ(I),IPPV1(I),IPPV2(I))
5885 3 CONTINUE
5886 DO 4 I=1,IXTV
5887 CALL DT_FLAHAD(KKTARG(IFROVT(I)),ITVQ(I),ITTV1(I),ITTV2(I))
5888 4 CONTINUE
5889 ENDIF
5890
5891 RETURN
5892 END
5893
5894*$ CREATE DT_GETPTN.FOR
5895*COPY DT_GETPTN
5896*
5897*===getptn=============================================================*
5898*
5899 SUBROUTINE DT_GETPTN(IP,NN,NCSY,IREJ)
5900
5901************************************************************************
5902* This subroutine collects partons at chain ends from temporary *
5903* commons and puts them into DTEVT1. *
5904* This version dated 15.01.95 is written by S. Roesler *
5905************************************************************************
5906
5907 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5908 SAVE
5909 PARAMETER ( LINP = 10 ,
5910 & LOUT = 6 ,
5911 & LDAT = 9 )
5912 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0)
5913
5914 LOGICAL LCHK
5915
5916 PARAMETER ( MAXNCL = 260,
5917 & MAXVQU = MAXNCL,
5918 & MAXSQU = 20*MAXVQU,
5919 & MAXINT = MAXVQU+MAXSQU)
5920* event history
5921 PARAMETER (NMXHKK=200000)
5922 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5923 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5924 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5925* extended event history
5926 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5927 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5928 & IHIST(2,NMXHKK)
5929* flags for input different options
5930 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5931 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5932 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5933* auxiliary common for chain system storage (DTUNUC 1.x)
5934 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
5935* statistics
5936 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5937 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5938 & ICEVTG(8,0:30)
5939* flags for diffractive interactions (DTUNUC 1.x)
5940 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
5941* x-values of partons (DTUNUC 1.x)
5942 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
5943 & XTVQ(MAXVQU),XTVD(MAXVQU),
5944 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
5945 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
5946* flavors of partons (DTUNUC 1.x)
5947 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5948 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5949 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
5950 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5951 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
5952 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5953 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
5954* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5955 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
5956 & IXPV,IXPS,IXTV,IXTS,
5957 & INTVV1(MAXVQU),INTVV2(MAXVQU),
5958 & INTSV1(MAXVQU),INTSV2(MAXVQU),
5959 & INTVS1(MAXVQU),INTVS2(MAXVQU),
5960 & INTSS1(MAXSQU),INTSS2(MAXSQU),
5961 & INTDV1(MAXVQU),INTDV2(MAXVQU),
5962 & INTVD1(MAXVQU),INTVD2(MAXVQU),
5963 & INTDS1(MAXSQU),INTDS2(MAXSQU),
5964 & INTSD1(MAXSQU),INTSD2(MAXSQU)
5965* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5966 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
5967 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
5968
5969 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PP(4),PT(4)
5970
5971 DATA AMSS,AMVS,AMDS,AMVD,AMVV/0.4D0,2.0D0,2.0D0,2.5D0,2.0D0/
5972
5973 IREJ = 0
5974 NCSY = 0
5975 NPOINT(2) = NHKK+1
5976
5977* sea-sea chains
5978 DO 10 I=1,NSS
5979 IF (ISKPCH(1,I).EQ.99) GOTO 10
5980 ICCHAI(1,1) = ICCHAI(1,1)+2
5981 IDXP = INTSS1(I)
5982 IDXT = INTSS2(I)
5983 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
5984 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
5985 DO 11 K=1,4
5986 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
5987 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
5988 PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
5989 PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
5990 11 CONTINUE
5991 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
5992 & +(PP1(3)+PT1(3))**2)
5993 ECH = PP1(4)+PT1(4)
5994 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
5995 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
5996 & +(PP2(3)+PT2(3))**2)
5997 ECH = PP2(4)+PT2(4)
5998 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
5999 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6000 AM1 = SQRT(AM1)
6001 AM2 = SQRT(AM2)
6002 IF ((AM1.LT.AMSS).OR.(AM2.LT.AMSS)) THEN
6003C WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6004 5000 FORMAT(1X,'incon. chain mass SS: ',2I5,2E10.3)
6005 ENDIF
6006 ELSE
6007 WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6008 ENDIF
6009 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6010 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6011 IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6012 IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6013 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6014 & 0,0,1)
6015 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6016 & 0,0,1)
6017 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6018 & 0,0,1)
6019 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6020 & 0,0,1)
6021 NCSY = NCSY+1
6022 10 CONTINUE
6023
6024* disea-sea chains
6025 DO 20 I=1,NDS
6026 IF (ISKPCH(2,I).EQ.99) GOTO 20
6027 ICCHAI(1,2) = ICCHAI(1,2)+2
6028 IDXP = INTDS1(I)
6029 IDXT = INTDS2(I)
6030 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6031 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6032 DO 21 K=1,4
6033 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6034 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6035 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6036 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6037 21 CONTINUE
6038 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6039 & +(PP1(3)+PT1(3))**2)
6040 ECH = PP1(4)+PT1(4)
6041 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6042 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6043 & +(PP2(3)+PT2(3))**2)
6044 ECH = PP2(4)+PT2(4)
6045 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6046 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6047 AM1 = SQRT(AM1)
6048 AM2 = SQRT(AM2)
6049 IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6050C WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6051 5001 FORMAT(1X,'incon. chain mass DS: ',2I5,2E10.3)
6052 ENDIF
6053 ELSE
6054 WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6055 ENDIF
6056 IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6057 IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6058 IFT1 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6059 IFT2 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6060 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6061 & 0,0,2)
6062 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6063 & 0,0,2)
6064 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6065 & 0,0,2)
6066 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6067 & 0,0,2)
6068 NCSY = NCSY+1
6069 20 CONTINUE
6070
6071* sea-disea chains
6072 DO 30 I=1,NSD
6073 IF (ISKPCH(3,I).EQ.99) GOTO 30
6074 ICCHAI(1,3) = ICCHAI(1,3)+2
6075 IDXP = INTSD1(I)
6076 IDXT = INTSD2(I)
6077 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6078 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6079 DO 31 K=1,4
6080 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6081 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6082 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6083 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6084 31 CONTINUE
6085 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6086 & +(PP1(3)+PT1(3))**2)
6087 ECH = PP1(4)+PT1(4)
6088 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6089 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6090 & +(PP2(3)+PT2(3))**2)
6091 ECH = PP2(4)+PT2(4)
6092 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6093 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6094 AM1 = SQRT(AM1)
6095 AM2 = SQRT(AM2)
6096 IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6097C WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6098 5002 FORMAT(1X,'incon. chain mass SD: ',2I5,2E10.3)
6099 ENDIF
6100 ELSE
6101 WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6102 ENDIF
6103 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6104 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6105 IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6106 IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6107 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6108 & 0,0,3)
6109 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6110 & 0,0,3)
6111 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6112 & 0,0,3)
6113 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6114 & 0,0,3)
6115 NCSY = NCSY+1
6116 30 CONTINUE
6117
6118* disea-valence chains
6119 DO 50 I=1,NDV
6120 IF (ISKPCH(5,I).EQ.99) GOTO 50
6121 ICCHAI(1,5) = ICCHAI(1,5)+2
6122 IDXP = INTDV1(I)
6123 IDXT = INTDV2(I)
6124 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6125 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6126 DO 51 K=1,4
6127 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6128 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6129 PT1(K) = XTVQ(IDXT) *PHKK(K,MOT)
6130 PT2(K) = XTVD(IDXT) *PHKK(K,MOT)
6131 51 CONTINUE
6132 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6133 & +(PP1(3)+PT1(3))**2)
6134 ECH = PP1(4)+PT1(4)
6135 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6136 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6137 & +(PP2(3)+PT2(3))**2)
6138 ECH = PP2(4)+PT2(4)
6139 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6140 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6141 AM1 = SQRT(AM1)
6142 AM2 = SQRT(AM2)
6143 IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6144C WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6145 5003 FORMAT(1X,'incon. chain mass DV: ',2I5,2E10.3)
6146 ENDIF
6147 ELSE
6148 WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6149 ENDIF
6150 IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6151 IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6152 IFT1 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6153 IFT2 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6154 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6155 & 0,0,5)
6156 CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6157 & 0,0,5)
6158 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6159 & 0,0,5)
6160 CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6161 & 0,0,5)
6162 NCSY = NCSY+1
6163 50 CONTINUE
6164
6165* valence-sea chains
6166 DO 60 I=1,NVS
6167 IF (ISKPCH(6,I).EQ.99) GOTO 60
6168 ICCHAI(1,6) = ICCHAI(1,6)+2
6169 IDXP = INTVS1(I)
6170 IDXT = INTVS2(I)
6171 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6172 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6173 DO 61 K=1,4
6174 PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6175 PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6176 PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6177 PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6178 61 CONTINUE
6179 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6180 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6181 IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6182 IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6183 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6184 IF (LCHK) THEN
6185 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6186 & 0,0,6)
6187 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6188 & 0,0,6)
6189 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6190 & 0,0,6)
6191 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6192 & 0,0,6)
6193 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6194 & +(PP1(3)+PT1(3))**2)
6195 ECH = PP1(4)+PT1(4)
6196 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6197 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6198 & +(PP2(3)+PT2(3))**2)
6199 ECH = PP2(4)+PT2(4)
6200 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6201 ELSE
6202 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6203 & 0,0,6)
6204 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6205 & 0,0,6)
6206 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6207 & 0,0,6)
6208 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6209 & 0,0,6)
6210 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6211 & +(PP1(3)+PT2(3))**2)
6212 ECH = PP1(4)+PT2(4)
6213 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6214 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6215 & +(PP2(3)+PT1(3))**2)
6216 ECH = PP2(4)+PT1(4)
6217 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6218 ENDIF
6219 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6220 AM1 = SQRT(AM1)
6221 AM2 = SQRT(AM2)
6222 IF ((AM1.LT.AMSS).OR.(AM2.LT.AMVS)) THEN
6223C WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6224 5004 FORMAT(1X,'incon. chain mass VS: ',2I5,2E10.3)
6225 ENDIF
6226 ELSE
6227 WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6228 ENDIF
6229 NCSY = NCSY+1
6230 60 CONTINUE
6231
6232* sea-valence chains
6233 DO 40 I=1,NSV
6234 IF (ISKPCH(4,I).EQ.99) GOTO 40
6235 ICCHAI(1,4) = ICCHAI(1,4)+2
6236 IDXP = INTSV1(I)
6237 IDXT = INTSV2(I)
6238 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6239 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6240 DO 41 K=1,4
6241 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6242 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6243 PT1(K) = XTVD(IDXT) *PHKK(K,MOT)
6244 PT2(K) = XTVQ(IDXT) *PHKK(K,MOT)
6245 41 CONTINUE
6246 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6247 & +(PP1(3)+PT1(3))**2)
6248 ECH = PP1(4)+PT1(4)
6249 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6250 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6251 & +(PP2(3)+PT2(3))**2)
6252 ECH = PP2(4)+PT2(4)
6253 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6254 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6255 AM1 = SQRT(AM1)
6256 AM2 = SQRT(AM2)
6257 IF ((AM1.LT.AMVS).OR.(AM2.LT.AMSS)) THEN
6258C WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6259 5005 FORMAT(1X,'incon. chain mass SV: ',2I5,2E10.3)
6260 ENDIF
6261 ELSE
6262 WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6263 ENDIF
6264 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6265 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6266 IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6267 IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6268 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6269 & 0,0,4)
6270 CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6271 & 0,0,4)
6272 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6273 & 0,0,4)
6274 CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6275 & 0,0,4)
6276 NCSY = NCSY+1
6277 40 CONTINUE
6278
6279* valence-disea chains
6280 DO 70 I=1,NVD
6281 IF (ISKPCH(7,I).EQ.99) GOTO 70
6282 ICCHAI(1,7) = ICCHAI(1,7)+2
6283 IDXP = INTVD1(I)
6284 IDXT = INTVD2(I)
6285 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6286 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6287 DO 71 K=1,4
6288 PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6289 PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6290 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6291 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6292 71 CONTINUE
6293 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6294 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6295 IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6296 IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6297 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6298 IF (LCHK) THEN
6299 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6300 & 0,0,7)
6301 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6302 & 0,0,7)
6303 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6304 & 0,0,7)
6305 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6306 & 0,0,7)
6307 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6308 & +(PP1(3)+PT1(3))**2)
6309 ECH = PP1(4)+PT1(4)
6310 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6311 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6312 & +(PP2(3)+PT2(3))**2)
6313 ECH = PP2(4)+PT2(4)
6314 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6315 ELSE
6316 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6317 & 0,0,7)
6318 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6319 & 0,0,7)
6320 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6321 & 0,0,7)
6322 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6323 & 0,0,7)
6324 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6325 & +(PP1(3)+PT2(3))**2)
6326 ECH = PP1(4)+PT2(4)
6327 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6328 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6329 & +(PP2(3)+PT1(3))**2)
6330 ECH = PP2(4)+PT1(4)
6331 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6332 ENDIF
6333 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6334 AM1 = SQRT(AM1)
6335 AM2 = SQRT(AM2)
6336 IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6337C WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6338 5006 FORMAT(1X,'incon. chain mass VD: ',2I5,2E10.3)
6339 ENDIF
6340 ELSE
6341 WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6342 ENDIF
6343 NCSY = NCSY+1
6344 70 CONTINUE
6345
6346* valence-valence chains
6347 DO 80 I=1,NVV
6348 IF (ISKPCH(8,I).EQ.99) GOTO 80
6349 ICCHAI(1,8) = ICCHAI(1,8)+2
6350 IDXP = INTVV1(I)
6351 IDXT = INTVV2(I)
6352 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6353 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6354 DO 81 K=1,4
6355 PP1(K) = XPVQ(IDXP)*PHKK(K,MOP)
6356 PP2(K) = XPVD(IDXP)*PHKK(K,MOP)
6357 PT1(K) = XTVD(IDXT)*PHKK(K,MOT)
6358 PT2(K) = XTVQ(IDXT)*PHKK(K,MOT)
6359 81 CONTINUE
6360 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6361 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6362 IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6363 IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6364
6365* check for diffractive event
6366 IDIFF = 0
6367 IF (((ISINGD.GT.0).OR.(IDOUBD.GT.0)).AND.
6368 & (IP.EQ.1).AND.(NN.EQ.1)) THEN
6369 DO 800 K=1,4
6370 PP(K) = PP1(K)+PP2(K)
6371 PT(K) = PT1(K)+PT2(K)
6372 800 CONTINUE
6373 ISTCK = NHKK
6374 CALL DT_DIFEVT(IFP1,IFP2,PP,MOP,
6375 & IFT1,IFT2,PT,MOT,IDIFF,NCSY,IREJ1)
6376C IF (IREJ1.NE.0) GOTO 9999
6377 IF (IREJ1.NE.0) THEN
6378 IDIFF = 0
6379 NHKK = ISTCK
6380 ENDIF
6381 ELSE
6382 IDIFF = 0
6383 ENDIF
6384
6385 IF (IDIFF.EQ.0) THEN
6386* valence-valence chain system
6387 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6388 IF (LCHK) THEN
6389* baryon-baryon
6390 CALL DT_EVTPUT(-21,IFP1,MOP,0,
6391 & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6392 CALL DT_EVTPUT(-22,IFT1,MOT,0,
6393 & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6394 CALL DT_EVTPUT(-21,IFP2,MOP,0,
6395 & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6396 CALL DT_EVTPUT(-22,IFT2,MOT,0,
6397 & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6398 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6399 & +(PP1(3)+PT1(3))**2)
6400 ECH = PP1(4)+PT1(4)
6401 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6402 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6403 & +(PP2(3)+PT2(3))**2)
6404 ECH = PP2(4)+PT2(4)
6405 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6406 ELSE
6407* antibaryon-baryon
6408 CALL DT_EVTPUT(-21,IFP1,MOP,0,
6409 & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6410 CALL DT_EVTPUT(-22,IFT2,MOT,0,
6411 & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6412 CALL DT_EVTPUT(-21,IFP2,MOP,0,
6413 & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6414 CALL DT_EVTPUT(-22,IFT1,MOT,0,
6415 & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6416 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6417 & +(PP1(3)+PT2(3))**2)
6418 ECH = PP1(4)+PT2(4)
6419 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6420 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6421 & +(PP2(3)+PT1(3))**2)
6422 ECH = PP2(4)+PT1(4)
6423 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6424 ENDIF
6425 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6426 AM1 = SQRT(AM1)
6427 AM2 = SQRT(AM2)
6428 IF ((AM1.LT.AMVV).OR.(AM2.LT.AMVV)) THEN
6429C WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6430 5007 FORMAT(1X,'incon. chain mass VV: ',2I5,2E10.3)
6431 ENDIF
6432 ELSE
6433 WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6434 ENDIF
6435 NCSY = NCSY+1
6436 ENDIF
6437 80 CONTINUE
6438 IF (ISTHKK(NPOINT(2)).EQ.1) NPOINT(2) = NPOINT(2)+1
6439
6440* energy-momentum & flavor conservation check
6441 IF (ABS(IDIFF).NE.1) THEN
6442 IF (IDIFF.NE.0) THEN
6443 IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-41,1,0,
6444 & 1,3,10,IREJ)
6445 ELSE
6446 IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-31,-32,0,
6447 & 1,3,10,IREJ)
6448 ENDIF
6449 IF (IREJ.NE.0) THEN
6450 CALL DT_EVTOUT(4)
6451 STOP
6452 ENDIF
6453 ENDIF
6454
6455 RETURN
6456
6457 9999 CONTINUE
6458 IREJ = 1
6459 RETURN
6460 END
6461
6462*$ CREATE DT_CHKCSY.FOR
6463*COPY DT_CHKCSY
6464*
6465*===chkcsy=============================================================*
6466*
6467 SUBROUTINE DT_CHKCSY(ID1,ID2,LCHK)
6468
6469************************************************************************
6470* CHeCk Chain SYstem for consistency of partons at chain ends. *
6471* ID1,ID2 PDG-numbers of partons at chain ends *
6472* LCHK = .true. consistent chain *
6473* = .false. inconsistent chain *
6474* This version dated 18.01.95 is written by S. Roesler *
6475************************************************************************
6476
6477 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6478 SAVE
6479 PARAMETER ( LINP = 10 ,
6480 & LOUT = 6 ,
6481 & LDAT = 9 )
6482
6483 LOGICAL LCHK
6484
6485 LCHK = .TRUE.
6486
6487* q-aq chain
6488 IF ((ABS(ID1).LE.6).AND.(ABS(ID2).LE.6)) THEN
6489 IF (ID1*ID2.GT.0) LCHK = .FALSE.
6490* q-qq, aq-aqaq chain
6491 ELSEIF (((ABS(ID1).LE.6).AND.(ABS(ID2).GT.6)).OR.
6492 & ((ABS(ID1).GT.6).AND.(ABS(ID2).LE.6))) THEN
6493 IF (ID1*ID2.LT.0) LCHK = .FALSE.
6494* qq-aqaq chain
6495 ELSEIF ((ABS(ID1).GT.6).AND.(ABS(ID2).GT.6)) THEN
6496 IF (ID1*ID2.GT.0) LCHK = .FALSE.
6497 ENDIF
6498
6499 RETURN
6500 END
6501
6502*$ CREATE DT_EVENTA.FOR
6503*COPY DT_EVENTA
6504*
6505*===eventa=============================================================*
6506*
6507 SUBROUTINE DT_EVENTA(ID,IP,IT,NCSY,IREJ)
6508
6509************************************************************************
6510* Treatment of nucleon-nucleon interactions in a two-chain *
6511* approximation. *
6512* (input) ID BAMJET-index of projectile hadron (in case of *
6513* h-K scattering) *
6514* IP/IT mass number of projectile/target nucleus *
6515* NCSY number of two chain systems *
6516* IREJ rejection flag *
6517* This version dated 15.01.95 is written by S. Roesler *
6518************************************************************************
6519
6520 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6521 SAVE
6522 PARAMETER ( LINP = 10 ,
6523 & LOUT = 6 ,
6524 & LDAT = 9 )
6525 PARAMETER (TINY10=1.0D-10)
6526
6527* event history
6528 PARAMETER (NMXHKK=200000)
6529 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6530 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6531 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6532* extended event history
6533 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6534 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6535 & IHIST(2,NMXHKK)
6536* rejection counter
6537 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6538 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6539 & IREXCI(3),IRDIFF(2),IRINC
6540* flags for diffractive interactions (DTUNUC 1.x)
6541 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6542* particle properties (BAMJET index convention)
6543 CHARACTER*8 ANAME
6544 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6545 & IICH(210),IIBAR(210),K1(210),K2(210)
6546* flags for input different options
6547 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6548 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6549 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6550* various options for treatment of partons (DTUNUC 1.x)
6551* (chain recombination, Cronin,..)
6552 LOGICAL LCO2CR,LINTPT
6553 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
6554 & LCO2CR,LINTPT
6555
6556 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
6557
6558 IREJ = 0
6559 NPOINT(3) = NHKK+1
6560
6561* skip following treatment for low-mass diffraction
6562 IF (ABS(IFLAGD).EQ.1) THEN
6563 NPOINT(3) = NPOINT(2)
6564 GOTO 5
6565 ENDIF
6566
6567* multiple scattering of chain ends
6568 IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
6569 IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
6570
6571 NC = NPOINT(2)
6572* get a two-chain system from DTEVT1
6573 DO 3 I=1,NCSY
6574 IFP1 = IDHKK(NC)
6575 IFT1 = IDHKK(NC+1)
6576 IFP2 = IDHKK(NC+2)
6577 IFT2 = IDHKK(NC+3)
6578 DO 4 K=1,4
6579 PP1(K) = PHKK(K,NC)
6580 PT1(K) = PHKK(K,NC+1)
6581 PP2(K) = PHKK(K,NC+2)
6582 PT2(K) = PHKK(K,NC+3)
6583 4 CONTINUE
6584 MOP1 = NC
6585 MOT1 = NC+1
6586 MOP2 = NC+2
6587 MOT2 = NC+3
6588 CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
6589 & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
6590 IF (IREJ1.GT.0) THEN
6591 IRHHA = IRHHA+1
6592 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTA'
6593 GOTO 9999
6594 ENDIF
6595 NC = NC+4
6596 3 CONTINUE
6597
6598* meson/antibaryon projectile:
6599* sample single-chain valence-valence systems (Reggeon contrib.)
6600 IF ((IP.EQ.1).AND.(ISICHA.EQ.1)) THEN
6601 IF (IIBAR(ID).LE.0) CALL DT_VV2SCH
6602 ENDIF
6603
6604 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6605* check DTEVT1 for remaining resonance mass corrections
6606 CALL DT_EVTRES(IREJ1)
6607 IF (IREJ1.GT.0) THEN
6608 IRRES(1) = IRRES(1)+1
6609 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in EVENTA'
6610 GOTO 9999
6611 ENDIF
6612 ENDIF
6613
6614* assign p_t to two-"chain" systems consisting of two resonances only
6615* since only entries for chains will be affected, this is obsolete
6616* in case of JETSET-fragmetation
6617 CALL DT_RESPT
6618
6619* combine q-aq chains to color ropes (qq-aqaq) (chain fusion)
6620 IF (LCO2CR) CALL DT_COM2CR
6621
6622 5 CONTINUE
6623
6624* fragmentation of the complete event
6625**uncomment for internal phojet-fragmentation
6626C CALL DT_EVTFRA(IREJ1)
6627 CALL DT_EVTFRG(2,IDUM,NPYMEM,IREJ1)
6628 IF (IREJ1.GT.0) THEN
6629 IRFRAG = IRFRAG+1
6630 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 3 in EVENTA'
6631 GOTO 9999
6632 ENDIF
6633
6634* decay of possible resonances (should be obsolete)
6635 CALL DT_DECAY1
6636
6637 RETURN
6638
6639 9999 CONTINUE
6640 IREVT = IREVT+1
6641 IREJ = 1
6642 RETURN
6643 END
6644
6645*$ CREATE DT_GETCSY.FOR
6646*COPY DT_GETCSY
6647*
6648*===getcsy=============================================================*
6649*
6650 SUBROUTINE DT_GETCSY(IFPR1,PP1,MOP1,IFPR2,PP2,MOP2,
6651 & IFTA1,PT1,MOT1,IFTA2,PT2,MOT2,IREJ)
6652
6653************************************************************************
6654* This version dated 15.01.95 is written by S. Roesler *
6655************************************************************************
6656
6657 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6658 SAVE
6659 PARAMETER ( LINP = 10 ,
6660 & LOUT = 6 ,
6661 & LDAT = 9 )
6662 PARAMETER (TINY10=1.0D-10)
6663
6664* event history
6665 PARAMETER (NMXHKK=200000)
6666 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6667 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6668 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6669* extended event history
6670 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6671 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6672 & IHIST(2,NMXHKK)
6673* rejection counter
6674 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6675 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6676 & IREXCI(3),IRDIFF(2),IRINC
6677* flags for input different options
6678 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6679 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6680 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6681* flags for diffractive interactions (DTUNUC 1.x)
6682 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6683
6684 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),
6685 & IFP1(2),IFP2(2),IFT1(2),IFT2(2),PCH1(4),PCH2(4)
6686
6687 IREJ = 0
6688
6689* get quark content of partons
6690 DO 1 I=1,2
6691 IFP1(I) = 0
6692 IFP2(I) = 0
6693 IFT1(I) = 0
6694 IFT2(I) = 0
6695 1 CONTINUE
6696 IFP1(1) = IDT_IPDG2B(IFPR1,1,2)
6697 IF (ABS(IFPR1).GE.1000) IFP1(2) = IDT_IPDG2B(IFPR1,2,2)
6698 IFP2(1) = IDT_IPDG2B(IFPR2,1,2)
6699 IF (ABS(IFPR2).GE.1000) IFP2(2) = IDT_IPDG2B(IFPR2,2,2)
6700 IFT1(1) = IDT_IPDG2B(IFTA1,1,2)
6701 IF (ABS(IFTA1).GE.1000) IFT1(2) = IDT_IPDG2B(IFTA1,2,2)
6702 IFT2(1) = IDT_IPDG2B(IFTA2,1,2)
6703 IF (ABS(IFTA2).GE.1000) IFT2(2) = IDT_IPDG2B(IFTA2,2,2)
6704
6705* get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq, 3 - qq-aqaq)
6706 IDCH1 = 2
6707 IF ((IFP1(2).EQ.0).AND.(IFT1(2).EQ.0)) IDCH1 = 1
6708 IF ((IFP1(2).NE.0).AND.(IFT1(2).NE.0)) IDCH1 = 3
6709 IDCH2 = 2
6710 IF ((IFP2(2).EQ.0).AND.(IFT2(2).EQ.0)) IDCH2 = 1
6711 IF ((IFP2(2).NE.0).AND.(IFT2(2).NE.0)) IDCH2 = 3
6712
6713* store initial configuration for energy-momentum cons. check
6714 IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IDUM)
6715
6716* sample intrinsic p_t at chain-ends
6717 CALL DT_GETSPT(PP1,IFPR1,IFP1,PP2,IFPR2,IFP2,
6718 & PT1,IFTA1,IFT1,PT2,IFTA2,IFT2,
6719 & AMCH1,IDCH1,AMCH2,IDCH2,IDCH(MOP1),IREJ1)
6720 IF (IREJ1.NE.0) THEN
6721 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in GETCSY'
6722 IRPT = IRPT+1
6723 GOTO 9999
6724 ENDIF
6725
6726C IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6727C IF ((IDCH1.EQ.3).OR.((IDCH1.GT.1).AND.(IDCH2.EQ.1))) THEN
6728C* check second chain for resonance
6729C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6730C & AMCH2,AMCH2N,IDCH2,IREJ1)
6731C IF (IREJ1.NE.0) GOTO 9999
6732C IF (IDR2.NE.0) THEN
6733C CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6734C & AMCH2,AMCH2N,AMCH1,IREJ1)
6735C IF (IREJ1.NE.0) GOTO 9999
6736C ENDIF
6737C* check first chain for resonance
6738C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6739C & AMCH1,AMCH1N,IDCH1,IREJ1)
6740C IF (IREJ1.NE.0) GOTO 9999
6741C IF (IDR1.NE.0) IDR1 = 100*IDR1
6742C ELSE
6743C* check first chain for resonance
6744C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6745C & AMCH1,AMCH1N,IDCH1,IREJ1)
6746C IF (IREJ1.NE.0) GOTO 9999
6747C IF (IDR1.NE.0) THEN
6748C CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6749C & AMCH1,AMCH1N,AMCH2,IREJ1)
6750C IF (IREJ1.NE.0) GOTO 9999
6751C ENDIF
6752C* check second chain for resonance
6753C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6754C & AMCH2,AMCH2N,IDCH2,IREJ1)
6755C IF (IREJ1.NE.0) GOTO 9999
6756C IF (IDR2.NE.0) IDR2 = 100*IDR2
6757C ENDIF
6758C ENDIF
6759
6760 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6761* check chains for resonances
6762 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6763 & AMCH1,AMCH1N,IDCH1,IREJ1)
6764 IF (IREJ1.NE.0) GOTO 9999
6765 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6766 & AMCH2,AMCH2N,IDCH2,IREJ1)
6767 IF (IREJ1.NE.0) GOTO 9999
6768* change kinematics corresponding to resonance-masses
6769 IF ( (IDR1.NE.0).AND.(IDR2.EQ.0) ) THEN
6770 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6771 & AMCH1,AMCH1N,AMCH2,IREJ1)
6772 IF (IREJ1.GT.0) GOTO 9999
6773 IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
6774 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6775 & AMCH2,AMCH2N,IDCH2,IREJ1)
6776 IF (IREJ1.NE.0) GOTO 9999
6777 IF (IDR2.NE.0) IDR2 = 100*IDR2
6778 ELSEIF ( (IDR1.EQ.0).AND.(IDR2.NE.0) ) THEN
6779 CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6780 & AMCH2,AMCH2N,AMCH1,IREJ1)
6781 IF (IREJ1.GT.0) GOTO 9999
6782 IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
6783 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6784 & AMCH1,AMCH1N,IDCH1,IREJ1)
6785 IF (IREJ1.NE.0) GOTO 9999
6786 IF (IDR1.NE.0) IDR1 = 100*IDR1
6787 ELSEIF ( (IDR1.NE.0).AND.(IDR2.NE.0) ) THEN
6788 AMDIF1 = ABS(AMCH1-AMCH1N)
6789 AMDIF2 = ABS(AMCH2-AMCH2N)
6790 IF (AMDIF2.LT.AMDIF1) THEN
6791 CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6792 & AMCH2,AMCH2N,AMCH1,IREJ1)
6793 IF (IREJ1.GT.0) GOTO 9999
6794 IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
6795 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),
6796 & IDR1,IDXR1,AMCH1,AMCH1N,IDCH1,IREJ1)
6797 IF (IREJ1.NE.0) GOTO 9999
6798 IF (IDR1.NE.0) IDR1 = 100*IDR1
6799 ELSE
6800 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6801 & AMCH1,AMCH1N,AMCH2,IREJ1)
6802 IF (IREJ1.GT.0) GOTO 9999
6803 IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
6804 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),
6805 & IDR2,IDXR2,AMCH2,AMCH2N,IDCH2,IREJ1)
6806 IF (IREJ1.NE.0) GOTO 9999
6807 IF (IDR2.NE.0) IDR2 = 100*IDR2
6808 ENDIF
6809 ENDIF
6810 ENDIF
6811
6812* store final configuration for energy-momentum cons. check
6813 IF (LEMCCK) THEN
6814 CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IDUM)
6815 CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
6816 IF (IREJ1.NE.0) GOTO 9999
6817 ENDIF
6818
6819* put partons and chains into DTEVT1
6820 DO 10 I=1,4
6821 PCH1(I) = PP1(I)+PT1(I)
6822 PCH2(I) = PP2(I)+PT2(I)
6823 10 CONTINUE
6824 CALL DT_EVTPUT(-ISTHKK(MOP1),IFPR1,MOP1,0,PP1(1),PP1(2),
6825 & PP1(3),PP1(4),0,0,0)
6826 CALL DT_EVTPUT(-ISTHKK(MOT1),IFTA1,MOT1,0,PT1(1),PT1(2),
6827 & PT1(3),PT1(4),0,0,0)
6828 KCH = 100+IDCH(MOP1)*10+1
6829 CALL DT_EVTPUT(KCH,88888,-2,-1,
6830 & PCH1(1),PCH1(2),PCH1(3),PCH1(4),IDR1,IDXR1,IDCH(MOP1))
6831 CALL DT_EVTPUT(-ISTHKK(MOP2),IFPR2,MOP2,0,PP2(1),PP2(2),
6832 & PP2(3),PP2(4),0,0,0)
6833 CALL DT_EVTPUT(-ISTHKK(MOT2),IFTA2,MOT2,0,PT2(1),PT2(2),
6834 & PT2(3),PT2(4),0,0,0)
6835 KCH = KCH+1
6836 CALL DT_EVTPUT(KCH,88888,-2,-1,
6837 & PCH2(1),PCH2(2),PCH2(3),PCH2(4),IDR2,IDXR2,IDCH(MOP2))
6838
6839 RETURN
6840
6841 9999 CONTINUE
6842 IF ((IDCH(MOP1).LE.3).AND.(IDCH(MOP2).LE.3)) THEN
6843* "cancel" sea-sea chains
6844 CALL DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ1)
6845 IF (IREJ1.NE.0) GOTO 9998
6846**sr 16.5. flag for EVENTB
6847 IREJ = -1
6848 RETURN
6849 ENDIF
6850 9998 CONTINUE
6851 IREJ = 1
6852 RETURN
6853 END
6854
6855*$ CREATE DT_CHKINE.FOR
6856*COPY DT_CHKINE
6857*
6858*===chkine=============================================================*
6859*
6860 SUBROUTINE DT_CHKINE(PP1I,IFP1,PP2I,IFP2,PT1I,IFT1,PT2I,IFT2,
6861 & AMCH1,AMCH1N,AMCH2,IREJ)
6862
6863************************************************************************
6864* This subroutine replaces CORMOM. *
6865* This version dated 05.01.95 is written by S. Roesler *
6866************************************************************************
6867
6868 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6869 SAVE
6870 PARAMETER ( LINP = 10 ,
6871 & LOUT = 6 ,
6872 & LDAT = 9 )
6873 PARAMETER (TINY10=1.0D-10)
6874
6875* flags for input different options
6876 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6877 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6878 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6879* rejection counter
6880 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6881 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6882 & IREXCI(3),IRDIFF(2),IRINC
6883
6884 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),P1(4),P2(4),
6885 & PP1I(4),PP2I(4),PT1I(4),PT2I(4)
6886
6887 IREJ = 0
6888 JMSHL = IMSHL
6889
6890 SCALE = AMCH1N/MAX(AMCH1,TINY10)
6891 DO 10 I=1,4
6892 PP1(I) = PP1I(I)
6893 PP2(I) = PP2I(I)
6894 PT1(I) = PT1I(I)
6895 PT2(I) = PT2I(I)
6896 PP2(I) = PP2(I)+(1.0D0-SCALE)*PP1(I)
6897 PT2(I) = PT2(I)+(1.0D0-SCALE)*PT1(I)
6898 PP1(I) = SCALE*PP1(I)
6899 PT1(I) = SCALE*PT1(I)
6900 10 CONTINUE
6901 IF ((PP1(4).LT.0.0D0).OR.(PP2(4).LT.0.0D0).OR.
6902 & (PT1(4).LT.0.0D0).OR.(PT2(4).LT.0.0D0)) GOTO 9997
6903
6904 ECH = PP2(4)+PT2(4)
6905 PCH = SQRT( (PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2+
6906 & (PP2(3)+PT2(3))**2 )
6907 AMCH22 = (ECH-PCH)*(ECH+PCH)
6908 IF (AMCH22.LT.0.0D0) THEN
6909 IF (IOULEV(1).GT.0)
6910 & WRITE(LOUT,'(1X,A)') 'CHKINE: inconsistent treatment!'
6911 GOTO 9997
6912 ENDIF
6913
6914 AMCH1 = AMCH1N
6915 AMCH2 = SQRT(AMCH22)
6916
6917* put partons again on mass shell
6918 13 CONTINUE
6919 XM1 = 0.0D0
6920 XM2 = 0.0D0
6921 IF (JMSHL.EQ.1) THEN
6922 XM1 = PYMASS(IFP1)
6923 XM2 = PYMASS(IFT1)
6924 ENDIF
6925 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
6926 IF (IREJ1.NE.0) THEN
6927 IF (JMSHL.EQ.0) GOTO 9998
6928 JMSHL = 0
6929 GOTO 13
6930 ENDIF
6931 JMSHL = IMSHL
6932 DO 11 I=1,4
6933 PP1(I) = P1(I)
6934 PT1(I) = P2(I)
6935 11 CONTINUE
6936 14 CONTINUE
6937 XM1 = 0.0D0
6938 XM2 = 0.0D0
6939 IF (JMSHL.EQ.1) THEN
6940 XM1 = PYMASS(IFP2)
6941 XM2 = PYMASS(IFT2)
6942 ENDIF
6943 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P1,P2,IREJ1)
6944 IF (IREJ1.NE.0) THEN
6945 IF (JMSHL.EQ.0) GOTO 9998
6946 JMSHL = 0
6947 GOTO 14
6948 ENDIF
6949 DO 12 I=1,4
6950 PP2(I) = P1(I)
6951 PT2(I) = P2(I)
6952 12 CONTINUE
6953 DO 15 I=1,4
6954 PP1I(I) = PP1(I)
6955 PP2I(I) = PP2(I)
6956 PT1I(I) = PT1(I)
6957 PT2I(I) = PT2(I)
6958 15 CONTINUE
6959 RETURN
6960
6961 9997 IRCHKI(1) = IRCHKI(1)+1
6962**sr
6963C GOTO 9999
6964 IREJ = -1
6965 RETURN
6966**
6967 9998 IRCHKI(2) = IRCHKI(2)+1
6968
6969 9999 CONTINUE
6970 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in CHKINE'
6971 IREJ = 1
6972 RETURN
6973 END
6974
6975*$ CREATE DT_CH2RES.FOR
6976*COPY DT_CH2RES
6977*
6978*===ch2res=============================================================*
6979*
6980 SUBROUTINE DT_CH2RES(IF1,IF2,IF3,IF4,IDR,IDXR,
6981 & AM,AMN,IMODE,IREJ)
6982
6983************************************************************************
6984* Check chains for resonance production. *
6985* This subroutine replaces COMCMA/COBCMA/COMCM2 *
6986* input: *
6987* IF1,2,3,4 input flavors (q,aq in any order) *
6988* AM chain mass *
6989* MODE = 1 check q-aq chain for meson-resonance *
6990* = 2 check q-qq, aq-aqaq chain for baryon-resonance *
6991* = 3 check qq-aqaq chain for lower mass cut *
6992* output: *
6993* IDR = 0 no resonances found *
6994* = -1 pseudoscalar meson/octet baryon *
6995* = 1 vector-meson/decuplet baryon *
6996* IDXR BAMJET-index of corresponding resonance *
6997* AMN mass of corresponding resonance *
6998* *
6999* IREJ rejection flag *
7000* This version dated 06.01.95 is written by S. Roesler *
7001************************************************************************
7002
7003 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7004 SAVE
7005 PARAMETER ( LINP = 10 ,
7006 & LOUT = 6 ,
7007 & LDAT = 9 )
7008
7009* particle properties (BAMJET index convention)
7010 CHARACTER*8 ANAME
7011 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7012 & IICH(210),IIBAR(210),K1(210),K2(210)
7013* quark-content to particle index conversion (DTUNUC 1.x)
7014 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
7015 & IA08(6,21),IA10(6,21)
7016* rejection counter
7017 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7018 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7019 & IREXCI(3),IRDIFF(2),IRINC
7020* flags for input different options
7021 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7022 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7023 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7024
7025 DIMENSION IF(4),JF(4)
7026
7027**sr 4.7. test
7028C DATA AMLOM,AMLOB /0.08D0,0.2D0/
7029 DATA AMLOM,AMLOB /0.1D0,0.7D0/
7030**
7031C DATA AMLOM,AMLOB /0.001D0,0.001D0/
7032
7033 MODE = ABS(IMODE)
7034
7035 IF ((MODE.LT.1).OR.(MODE.GT.3)) THEN
7036 WRITE(LOUT,1000) MODE
7037 1000 FORMAT(1X,'CH2RES: MODE ',I4,' not supported!',/,
7038 & 1X,' program stopped')
7039 STOP
7040 ENDIF
7041
7042 AMX = AM
7043 IREJ = 0
7044 IDR = 0
7045 IDXR = 0
7046 AMN = AMX
7047 IF ((AM.LE.0.0D0).AND.(MODE.EQ.1)) AMX = AMLOM
7048 IF ((AM.LE.0.0D0).AND.(MODE.EQ.2)) AMX = AMLOB
7049
7050 IF(1) = IF1
7051 IF(2) = IF2
7052 IF(3) = IF3
7053 IF(4) = IF4
7054 NF = 0
7055 DO 100 I=1,4
7056 IF (IF(I).NE.0) THEN
7057 NF = NF+1
7058 JF(NF) = IF(I)
7059 ENDIF
7060 100 CONTINUE
7061 IF (NF.LE.MODE) THEN
7062 WRITE(LOUT,1001) MODE,IF
7063 1001 FORMAT(1X,'CH2RES: inconsistent input flavors in MODE ',
7064 & I4,' IF1 = ',I4,' IF2 = ',I4,' IF3 = ',I4,' IF4 = ',I4)
7065 GOTO 9999
7066 ENDIF
7067
7068 GOTO (1,2,3) MODE
7069
7070* check for meson resonance
7071 1 CONTINUE
7072 IFQ = JF(1)
7073 IFAQ = ABS(JF(2))
7074 IF (JF(2).GT.0) THEN
7075 IFQ = JF(2)
7076 IFAQ = ABS(JF(1))
7077 ENDIF
7078 IFPS = IMPS(IFAQ,IFQ)
7079 IFV = IMVE(IFAQ,IFQ)
7080 AMPS = AAM(IFPS)
7081 AMV = AAM(IFV)
7082 AMHI = AMV+0.3D0
7083 IF (AMX.LT.AMV) THEN
7084 IF (AMX.LT.AMPS) THEN
7085 IF (IMODE.GT.0) THEN
7086 IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOM)) GOTO 9999
7087 ELSE
7088 IF (AMX.LT.0.8D0*AMPS) GOTO 9999
7089 ENDIF
7090 LOMRES = LOMRES+1
7091 ENDIF
7092* replace chain by pseudoscalar meson
7093 IDR = -1
7094 IDXR = IFPS
7095 AMN = AMPS
7096 ELSEIF (AMX.LT.AMHI) THEN
7097* replace chain by vector-meson
7098 IDR = 1
7099 IDXR = IFV
7100 AMN = AMV
7101 ENDIF
7102 RETURN
7103
7104* check for baryon resonance
7105 2 CONTINUE
7106 CALL DT_DBKLAS(JF(1),JF(2),JF(3),JB8,JB10)
7107 AM8 = AAM(JB8)
7108 AM10 = AAM(JB10)
7109 AMHI = AM10+0.3D0
7110 IF (AMX.LT.AM10) THEN
7111 IF (AMX.LT.AM8) THEN
7112 IF (IMODE.GT.0) THEN
7113 IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOB)) GOTO 9999
7114 ELSE
7115 IF (AMX.LT.0.8D0*AM8) GOTO 9999
7116 ENDIF
7117 LOBRES = LOBRES+1
7118 ENDIF
7119* replace chain by oktet baryon
7120 IDR = -1
7121 IDXR = JB8
7122 AMN = AM8
7123 ELSEIF (AMX.LT.AMHI) THEN
7124 IDR = 1
7125 IDXR = JB10
7126 AMN = AM10
7127 ENDIF
7128 RETURN
7129
7130* check qq-aqaq for lower mass cut
7131 3 CONTINUE
7132* empirical definition of AMHI to allow for (b-antib)-pair prod.
7133 AMHI = 2.5D0
7134 IF (AMX.LT.AMHI) GOTO 9999
7135 RETURN
7136
7137 9999 CONTINUE
7138 IF ((IOULEV(1).GT.0).AND.(IMODE.GT.0))
7139 & WRITE(LOUT,*) 'rejected 1 in CH2RES',IMODE
7140 IREJ = 1
7141 IRRES(2) = IRRES(2)+1
7142 RETURN
7143 END
7144
7145*$ CREATE DT_RJSEAC.FOR
7146*COPY DT_RJSEAC
7147*
7148*===rjseac=============================================================*
7149*
7150 SUBROUTINE DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ)
7151
7152************************************************************************
7153* ReJection of SEA-sea Chains. *
7154* MOP1/2 entries of projectile sea-partons in DTEVT1 *
7155* MOT1/2 entries of projectile sea-partons in DTEVT1 *
7156* This version dated 16.01.95 is written by S. Roesler *
7157************************************************************************
7158
7159 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7160 SAVE
7161 PARAMETER ( LINP = 10 ,
7162 & LOUT = 6 ,
7163 & LDAT = 9 )
7164 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
7165
7166* event history
7167 PARAMETER (NMXHKK=200000)
7168 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7169 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7170 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7171* extended event history
7172 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7173 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7174 & IHIST(2,NMXHKK)
7175* statistics
7176 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7177 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7178 & ICEVTG(8,0:30)
7179
7180 DIMENSION IDXSEA(2,2),IDXNUC(2),ISTVAL(2)
7181
7182 IREJ = 0
7183
7184* projectile sea q-aq-pair
7185* indices of sea-pair
7186 IDXSEA(1,1) = MOP1
7187 IDXSEA(1,2) = MOP2
7188* index of mother-nucleon
7189 IDXNUC(1) = JMOHKK(1,MOP1)
7190* status of valence quarks to be corrected
7191 ISTVAL(1) = -21
7192
7193* target sea q-aq-pair
7194* indices of sea-pair
7195 IDXSEA(2,1) = MOT1
7196 IDXSEA(2,2) = MOT2
7197* index of mother-nucleon
7198 IDXNUC(2) = JMOHKK(1,MOT1)
7199* status of valence quarks to be corrected
7200 ISTVAL(2) = -22
7201
7202 DO 1 N=1,2
7203 IDONE = 0
7204 DO 2 I=NPOINT(2),NHKK
7205 IF ((ISTHKK(I).EQ.ISTVAL(N)).AND.
7206 & (JMOHKK(1,I).EQ.IDXNUC(N))) THEN
7207* valence parton found
7208* inrease 4-momentum by sea 4-momentum
7209 DO 3 K=1,4
7210 PHKK(K,I) = PHKK(K,I)+PHKK(K,IDXSEA(N,1))+
7211 & PHKK(K,IDXSEA(N,2))
7212 3 CONTINUE
7213 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
7214 & PHKK(2,I)**2-PHKK(3,I)**2))
7215* "cancel" sea-pair
7216 DO 4 J=1,2
7217 ISTHKK(IDXSEA(N,J)) = 100
7218 IDHKK(IDXSEA(N,J)) = 0
7219 JMOHKK(1,IDXSEA(N,J)) = 0
7220 JMOHKK(2,IDXSEA(N,J)) = 0
7221 JDAHKK(1,IDXSEA(N,J)) = 0
7222 JDAHKK(2,IDXSEA(N,J)) = 0
7223 DO 5 K=1,4
7224 PHKK(K,IDXSEA(N,J)) = ZERO
7225 VHKK(K,IDXSEA(N,J)) = ZERO
7226 WHKK(K,IDXSEA(N,J)) = ZERO
7227 5 CONTINUE
7228 PHKK(5,IDXSEA(N,J)) = ZERO
7229 4 CONTINUE
7230 IDONE = 1
7231 ENDIF
7232 2 CONTINUE
7233 IF (IDONE.NE.1) THEN
7234 WRITE(LOUT,1000) NEVHKK,MOP1,MOP2,MOT1,MOT2
7235 1000 FORMAT(1X,'RJSEAC: event ',I8,': inconsistent event',
7236 & '-record!',/,1X,' sea-quark pairs ',
7237 & 2I5,4X,2I5,' could not be canceled!')
7238 GOTO 9999
7239 ENDIF
7240 1 CONTINUE
7241 ICRJSS = ICRJSS+1
7242 RETURN
7243
7244 9999 CONTINUE
7245 IREJ = 1
7246 RETURN
7247 END
7248
7249*$ CREATE DT_VV2SCH.FOR
7250*COPY DT_VV2SCH
7251*
7252*===vv2sch=============================================================*
7253*
7254 SUBROUTINE DT_VV2SCH
7255
7256************************************************************************
7257* Change Valence-Valence chain systems to Single CHain systems for *
7258* hadron-nucleus collisions with meson or antibaryon projectile. *
7259* (Reggeon contribution) *
7260* The single chain system is approximately treated as one chain and a *
7261* meson at rest. *
7262* This version dated 18.01.95 is written by S. Roesler *
7263************************************************************************
7264
7265 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7266 SAVE
7267 PARAMETER ( LINP = 10 ,
7268 & LOUT = 6 ,
7269 & LDAT = 9 )
7270 PARAMETER (ZERO=0.0D0,TINY7=1.0D-7,TINY3=1.0D-3)
7271
7272 LOGICAL LSTART
7273
7274* event history
7275 PARAMETER (NMXHKK=200000)
7276 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7277 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7278 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7279* extended event history
7280 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7281 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7282 & IHIST(2,NMXHKK)
7283* flags for input different options
7284 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7285 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7286 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7287* statistics
7288 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7289 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7290 & ICEVTG(8,0:30)
7291
7292 DIMENSION IF(4,2),MO(4),PP1(4),PP2(4),PT1(4),PT2(4),PCH1(4),
7293 & PCH2(4)
7294
7295 DATA LSTART /.TRUE./
7296
7297 IFSC = 0
7298 IF (LSTART) THEN
7299 WRITE(LOUT,1000)
7300 1000 FORMAT(/,1X,'VV2SCH: Reggeon contribution to valance-',
7301 & 'valence chains treated')
7302 LSTART = .FALSE.
7303 ENDIF
7304
7305 NSTOP = NHKK
7306
7307* get index of first chain
7308 DO 1 I=NPOINT(3),NHKK
7309 IF (IDHKK(I).EQ.88888) THEN
7310 NC = I
7311 GOTO 2
7312 ENDIF
7313 1 CONTINUE
7314
7315 2 CONTINUE
7316 IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)
7317 & .AND.(NC.LT.NSTOP)) THEN
7318* get valence-valence chains
7319 IF ((IDCH(NC).EQ.8).AND.(IDCH(NC+3).EQ.8)) THEN
7320* get "mother"-hadron indices
7321 MO1 = JMOHKK(1,JMOHKK(1,JMOHKK(1,NC)))
7322 MO2 = JMOHKK(1,JMOHKK(1,JMOHKK(2,NC)))
7323 KPROJ = IDT_ICIHAD(IDHKK(MO1))
7324 KTARG = IDT_ICIHAD(IDHKK(MO2))
7325* Lab momentum of projectile hadron
7326 CALL DT_LTNUC(PHKK(3,MO1),PHKK(4,MO1),PPZ,PPE,-3)
7327 PTOT = SQRT(PHKK(1,MO1)**2+PHKK(2,MO1)**2+
7328 & PHKK(3,MO1)**2)
7329
7330 SICHAP = DT_PHNSCH(KPROJ,KTARG,PTOT)
7331 IF (DT_RNDM(PTOT).LE.SICHAP) THEN
7332 ICVV2S = ICVV2S+1
7333* single chain requested
7334* get flavors of chain-end partons
7335 MO(1) = JMOHKK(1,NC)
7336 MO(2) = JMOHKK(2,NC)
7337 MO(3) = JMOHKK(1,NC+3)
7338 MO(4) = JMOHKK(2,NC+3)
7339 DO 3 I=1,4
7340 IF(I,1) = IDT_IPDG2B(IDHKK(MO(I)),1,2)
7341 IF(I,2) = 0
7342 IF (ABS(IDHKK(MO(I))).GE.1000)
7343 & IF(I,2) = IDT_IPDG2B(IDHKK(MO(I)),2,2)
7344 3 CONTINUE
7345* which one is the q-aq chain?
7346* N1,N1+1 - DTEVT1-entries for q-aq system
7347* N2,N2+1 - DTEVT1-entries for the other chain
7348 IF ((IF(1,2).EQ.0).AND.(IF(2,2).EQ.0)) THEN
7349 K1 = 1
7350 K2 = 3
7351 N1 = NC-2
7352 N2 = NC+1
7353 ELSEIF ((IF(3,2).EQ.0).AND.(IF(4,2).EQ.0)) THEN
7354 K1 = 3
7355 K2 = 1
7356 N1 = NC+1
7357 N2 = NC-2
7358 ELSE
7359 GOTO 10
7360 ENDIF
7361 DO 4 K=1,4
7362 PP1(K) = PHKK(K,N1)
7363 PT1(K) = PHKK(K,N1+1)
7364 PP2(K) = PHKK(K,N2)
7365 PT2(K) = PHKK(K,N2+1)
7366 4 CONTINUE
7367 AMCH1 = PHKK(5,N1+2)
7368 AMCH2 = PHKK(5,N2+2)
7369* get meson-identity corresponding to flavors of q-aq chain
7370 ITMP = IRESRJ
7371 IRESRJ = 0
7372 CALL DT_CH2RES(IF(K1,1),IF(K1+1,1),0,0,IDR1,IDXR1,
7373 & ZERO,AMCH1N,1,IDUM)
7374 IRESRJ = ITMP
7375* change kinematics of chains
7376 CALL DT_CHKINE(PP1,IDHKK(N1), PP2,IDHKK(N2),
7377 & PT1,IDHKK(N1+1),PT2,IDHKK(N2+1),
7378 & AMCH1,AMCH1N,AMCH2,IREJ1)
7379 IF (IREJ1.NE.0) GOTO 10
7380* check second chain for resonance
7381 IDCHAI = 2
7382 IF ((IF(K2,2).NE.0).AND.(IF(K2+1,2).NE.0)) IDCHAI = 3
7383 CALL DT_CH2RES(IF(K2,1),IF(K2,2),IF(K2+1,1),IF(K2+1,2),
7384 & IDR2,IDXR2,AMCH2,AMCH2N,IDCHAI,IREJ1)
7385 IF (IREJ1.NE.0) GOTO 10
7386 IF (IDR2.NE.0) IDR2 = 100*IDR2
7387* add partons and chains to DTEVT1
7388 DO 5 K=1,4
7389 PCH1(K) = PP1(K)+PT1(K)
7390 PCH2(K) = PP2(K)+PT2(K)
7391 5 CONTINUE
7392 CALL DT_EVTPUT(ISTHKK(N1),IDHKK(N1),N1,0,PP1(1),PP1(2),
7393 & PP1(3),PP1(4),0,0,0)
7394 CALL DT_EVTPUT(ISTHKK(N1+1),IDHKK(N1+1),N1+1,0,PT1(1),
7395 & PT1(2),PT1(3),PT1(4),0,0,0)
7396 KCH = ISTHKK(N1+2)+100
7397 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH1(1),PCH1(2),PCH1(3),
7398 & PCH1(4),IDR1,IDXR1,IDCH(N1+2))
7399 IDHKK(N1+2) = 22222
7400 CALL DT_EVTPUT(ISTHKK(N2),IDHKK(N2),N2,0,PP2(1),PP2(2),
7401 & PP2(3),PP2(4),0,0,0)
7402 CALL DT_EVTPUT(ISTHKK(N2+1),IDHKK(N2+1),N2+1,0,PT2(1),
7403 & PT2(2),PT2(3),PT2(4),0,0,0)
7404 KCH = ISTHKK(N2+2)+100
7405 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH2(1),PCH2(2),PCH2(3),
7406 & PCH2(4),IDR2,IDXR2,IDCH(N2+2))
7407 IDHKK(N2+2) = 22222
7408 ENDIF
7409 ENDIF
7410 ELSE
7411 GOTO 11
7412 ENDIF
7413 10 CONTINUE
7414 NC = NC+6
7415 GOTO 2
7416
7417 11 CONTINUE
7418
7419 RETURN
7420 END
7421
7422*$ CREATE DT_PHNSCH.FOR
7423*COPY DT_PHNSCH
7424*
7425*=== phnsch ===========================================================*
7426*
7427 DOUBLE PRECISION FUNCTION DT_PHNSCH( KP, KTARG, PLAB )
7428
7429*----------------------------------------------------------------------*
7430* *
7431* Probability for Hadron Nucleon Single CHain interactions: *
7432* *
7433* Created on 30 december 1993 by Alfredo Ferrari & Paola Sala *
7434* Infn - Milan *
7435* *
7436* Last change on 04-jan-94 by Alfredo Ferrari *
7437* *
7438* modified by J.R.for use in DTUNUC 6.1.94 *
7439* *
7440* Input variables: *
7441* Kp = hadron projectile index (Part numbering *
7442* scheme) *
7443* Ktarg = target nucleon index (1=proton, 8=neutron) *
7444* Plab = projectile laboratory momentum (GeV/c) *
7445* Output variable: *
7446* Phnsch = probability per single chain (particle *
7447* exchange) interactions *
7448* *
7449*----------------------------------------------------------------------*
7450
7451 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7452 SAVE
7453
7454 PARAMETER ( LUNOUT = 6 )
7455 PARAMETER ( LUNERR = 6 )
7456 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
7457 PARAMETER ( ZERZER = 0.D+00 )
7458 PARAMETER ( ONEONE = 1.D+00 )
7459 PARAMETER ( TWOTWO = 2.D+00 )
7460 PARAMETER ( FIVFIV = 5.D+00 )
7461 PARAMETER ( HLFHLF = 0.5D+00 )
7462
7463 PARAMETER ( NALLWP = 39 )
7464 PARAMETER ( IDMAXP = 210 )
7465
7466 DIMENSION ICHRGE(39),AM(39)
7467
7468* particle properties (BAMJET index convention)
7469 CHARACTER*8 ANAME
7470 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7471 & IICH(210),IIBAR(210),K1(210),K2(210)
7472
7473 DIMENSION KPTOIP(210)
7474* auxiliary common for reggeon exchange (DTUNUC 1.x)
7475 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
7476 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
7477 & IQTCHR(-6:6),MQUARK(3,39)
7478
7479 DIMENSION SGTCOE (5,33), IHLP (NALLWP)
7480 DIMENSION SGTCO1(5,10),SGTCO2(5,8),SGTCO3(5,15)
454792a9 7481CPH SAVE SGTCOE, IHLP
7482CPH SAVE IQFSC1, IQFSC2, IQBSC1, IQBSC2
9aaba0d6 7483 EQUIVALENCE (SGTCO1(1,1),SGTCOE(1,1))
7484 EQUIVALENCE (SGTCO2(1,1),SGTCOE(1,11))
7485 EQUIVALENCE (SGTCO3(1,1),SGTCOE(1,19))
7486
7487* Conversion from part to paprop numbering
7488 DATA KPTOIP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
7489 & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 66*0,
7490 & 34, 36, 31, 32, 33, 35, 37, 5*0, 38, 5*0, 39, 19*0, 27, 28, 74*0/
7491
7492* 1=baryon, 2=pion, 3=kaon, 4=antibaryon:
7493 DATA IHLP/1,4,5*0,1,4,2*0,3,2*2,2*3,1,4,3,3*1,2,
7494 & 2*3, 2, 4*0, 3*4, 1, 4, 1, 4, 1, 4 /
7495C DATA ( ( SGTCOE (J,I), J=1,5 ), I=1,10 ) /
7496 DATA SGTCO1 /
7497* 1st reaction: gamma p total
7498 &0.147 D+00, ZERZER , ZERZER , 0.0022D+00, -0.0170D+00,
7499* 2nd reaction: gamma d total
7500 &0.300 D+00, ZERZER , ZERZER , 0.0095D+00, -0.057 D+00,
7501* 3rd reaction: pi+ p total
7502 &16.4 D+00, 19.3D+00, -0.42D+00, 0.19 D+00, ZERZER ,
7503* 4th reaction: pi- p total
7504 &33.0 D+00, 14.0D+00, -1.36D+00, 0.456 D+00, -4.03 D+00,
7505* 5th reaction: pi+/- d total
7506 &56.8 D+00, 42.2D+00, -1.45D+00, 0.65 D+00, -5.39 D+00,
7507* 6th reaction: K+ p total
7508 &18.1 D+00, ZERZER , ZERZER , 0.26 D+00, -1.0 D+00,
7509* 7th reaction: K+ n total
7510 &18.7 D+00, ZERZER , ZERZER , 0.21 D+00, -0.89 D+00,
7511* 8th reaction: K+ d total
7512 &34.2 D+00, 7.9 D+00, -2.1 D+00, 0.346 D+00, -0.99 D+00,
7513* 9th reaction: K- p total
7514 &32.1 D+00, ZERZER , ZERZER , 0.66 D+00, -5.6 D+00,
7515* 10th reaction: K- n total
7516 &25.2 D+00, ZERZER , ZERZER , 0.38 D+00, -2.9 D+00/
7517C DATA ( ( SGTCOE (J,I), J=1,5 ), I=11,18 ) /
7518 DATA SGTCO2 /
7519* 11th reaction: K- d total
7520 &57.6 D+00, ZERZER , ZERZER , 1.17 D+00, -9.5 D+00,
7521* 12th reaction: p p total
7522 &48.0 D+00, ZERZER , ZERZER , 0.522 D+00, -4.51 D+00,
7523* 13th reaction: p n total
7524 &47.30 D+00, ZERZER , ZERZER , 0.513 D+00, -4.27 D+00,
7525* 14th reaction: p d total
7526 &91.3 D+00, ZERZER , ZERZER , 1.05 D+00, -8.8 D+00,
7527* 15th reaction: pbar p total
7528 &38.4 D+00, 77.6D+00, -0.64D+00, 0.26 D+00, -1.2 D+00,
7529* 16th reaction: pbar n total
7530 &ZERZER ,133.6D+00, -0.70D+00, -1.22 D+00, 13.7 D+00,
7531* 17th reaction: pbar d total
7532 &112. D+00, 125.D+00, -1.08D+00, 1.14 D+00, -12.4 D+00,
7533* 18th reaction: Lamda p total
7534 &30.4 D+00, ZERZER , ZERZER , ZERZER , 1.6 D+00/
7535C DATA ( ( SGTCOE (J,I), J=1,5 ), I=19,33 ) /
7536 DATA SGTCO3 /
7537* 19th reaction: pi+ p elastic
7538 &ZERZER , 11.4D+00, -0.4 D+00, 0.079 D+00, ZERZER ,
7539* 20th reaction: pi- p elastic
7540 &1.76 D+00, 11.2D+00, -0.64D+00, 0.043 D+00, ZERZER ,
7541* 21st reaction: K+ p elastic
7542 &5.0 D+00, 8.1 D+00, -1.8 D+00, 0.16 D+00, -1.3 D+00,
7543* 22nd reaction: K- p elastic
7544 &7.3 D+00, ZERZER , ZERZER , 0.29 D+00, -2.40 D+00,
7545* 23rd reaction: p p elastic
7546 &11.9 D+00, 26.9D+00, -1.21D+00, 0.169 D+00, -1.85 D+00,
7547* 24th reaction: p d elastic
7548 &16.1 D+00, ZERZER , ZERZER , 0.32 D+00, -3.4 D+00,
7549* 25th reaction: pbar p elastic
7550 &10.2 D+00, 52.7D+00, -1.16D+00, 0.125 D+00, -1.28 D+00,
7551* 26th reaction: pbar p elastic bis
7552 &10.6 D+00, 53.1D+00, -1.19D+00, 0.136 D+00, -1.41 D+00,
7553* 27th reaction: pbar n elastic
7554 &36.5 D+00, ZERZER , ZERZER , ZERZER , -11.9 D+00,
7555* 28th reaction: Lamda p elastic
7556 &12.3 D+00, ZERZER , ZERZER , ZERZER , -2.4 D+00,
7557* 29th reaction: K- p ela bis
7558 &7.24 D+00, 46.0D+00, -4.71D+00, 0.279 D+00, -2.35 D+00,
7559* 30th reaction: pi- p cx
7560 &ZERZER ,0.912D+00, -1.22D+00, ZERZER , ZERZER ,
7561* 31st reaction: K- p cx
7562 &ZERZER , 3.39D+00, -1.75D+00, ZERZER , ZERZER ,
7563* 32nd reaction: K+ n cx
7564 &ZERZER , 7.18D+00, -2.01D+00, ZERZER , ZERZER ,
7565* 33rd reaction: pbar p cx
7566 &ZERZER , 18.8D+00, -2.01D+00, ZERZER , ZERZER /
7567*
7568* +-------------------------------------------------------------------*
7569 ICHRGE(KTARG)=IICH(KTARG)
7570 AM (KTARG)=AAM (KTARG)
7571* | Check for pi0 (d-dbar)
7572 IF ( KP .NE. 26 ) THEN
7573 IP = KPTOIP (KP)
7574 IF(IP.EQ.0)IP=1
7575 ICHRGE(IP)=IICH(KP)
7576 AM (IP)=AAM (KP)
7577* |
7578* +-------------------------------------------------------------------*
7579* |
7580 ELSE
7581 IP = 23
7582 ICHRGE(IP)=0
7583 END IF
7584* |
7585* +-------------------------------------------------------------------*
7586* +-------------------------------------------------------------------*
7587* | No such interactions for baryon-baryon
7588 IF ( IIBAR (KP) .GT. 0 ) THEN
7589 DT_PHNSCH = ZERZER
7590 RETURN
7591* |
7592* +-------------------------------------------------------------------*
7593* | No "annihilation" diagram possible for K+ p/n
7594 ELSE IF ( IP .EQ. 15 ) THEN
7595 DT_PHNSCH = ZERZER
7596 RETURN
7597* |
7598* +-------------------------------------------------------------------*
7599* | No "annihilation" diagram possible for K0 p/n
7600 ELSE IF ( IP .EQ. 24 ) THEN
7601 DT_PHNSCH = ZERZER
7602 RETURN
7603* |
7604* +-------------------------------------------------------------------*
7605* | No "annihilation" diagram possible for Omebar p/n
7606 ELSE IF ( IP .GE. 38 ) THEN
7607 DT_PHNSCH = ZERZER
7608 RETURN
7609 END IF
7610* |
7611* +-------------------------------------------------------------------*
7612* +-------------------------------------------------------------------*
7613* | If the momentum is larger than 50 GeV/c, compute the single
7614* | chain probability at 50 GeV/c and extrapolate to the present
7615* | momentum according to 1/sqrt(s)
7616* | sigma = sigma_sch (50) * sqrt (s(50)/s) + sigma_dch
7617* | P_sch (50) = sigma_sch (50) / ( sigma_dch + sigma_sch (50) )
7618* | sigma_dch / sigma_sch (50) = 1 / P_sch (50) - 1
7619* | sigma_dch / sigma_sch = 1 / P_sch - 1 = ( 1 / P_sch (50) - 1 )
7620* | x sqrt(s/s(50))
7621* | P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
7622 IF ( PLAB .GT. 50.D+00 ) THEN
7623 PLA = 50.D+00
7624 AMPSQ = AM (IP)**2
7625 AMTSQ = AM (KTARG)**2
7626 EPROJ = SQRT ( PLAB**2 + AMPSQ )
7627 UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7628 EPROJ = SQRT ( PLA**2 + AMPSQ )
7629 UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7630 UMORAT = SQRT ( UMOSQ / UMO50 )
7631* |
7632* +-------------------------------------------------------------------*
7633* | P < 3 GeV/c
7634 ELSE IF ( PLAB .LT. 3.D+00 ) THEN
7635 PLA = 3.D+00
7636 AMPSQ = AM (IP)**2
7637 AMTSQ = AM (KTARG)**2
7638 EPROJ = SQRT ( PLAB**2 + AMPSQ )
7639 UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7640 EPROJ = SQRT ( PLA**2 + AMPSQ )
7641 UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7642 UMORAT = SQRT ( UMOSQ / UMO50 )
7643* |
7644* +-------------------------------------------------------------------*
7645* | P < 50 GeV/c
7646 ELSE
7647 PLA = PLAB
7648 UMORAT = ONEONE
7649 END IF
7650* |
7651* +-------------------------------------------------------------------*
7652 ALGPLA = LOG (PLA)
7653* +-------------------------------------------------------------------*
7654* | Pions:
7655 IF ( IHLP (IP) .EQ. 2 ) THEN
7656 ACOF = SGTCOE (1,3)
7657 BCOF = SGTCOE (2,3)
7658 ENNE = SGTCOE (3,3)
7659 CCOF = SGTCOE (4,3)
7660 DCOF = SGTCOE (5,3)
7661* | Compute the pi+ p total cross section:
7662 SPPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7663 & + DCOF * ALGPLA
7664 ACOF = SGTCOE (1,19)
7665 BCOF = SGTCOE (2,19)
7666 ENNE = SGTCOE (3,19)
7667 CCOF = SGTCOE (4,19)
7668 DCOF = SGTCOE (5,19)
7669* | Compute the pi+ p elastic cross section:
7670 SPPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7671 & + DCOF * ALGPLA
7672* | Compute the pi+ p inelastic cross section:
7673 SPPPIN = SPPPTT - SPPPEL
7674 ACOF = SGTCOE (1,4)
7675 BCOF = SGTCOE (2,4)
7676 ENNE = SGTCOE (3,4)
7677 CCOF = SGTCOE (4,4)
7678 DCOF = SGTCOE (5,4)
7679* | Compute the pi- p total cross section:
7680 SPMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7681 & + DCOF * ALGPLA
7682 ACOF = SGTCOE (1,20)
7683 BCOF = SGTCOE (2,20)
7684 ENNE = SGTCOE (3,20)
7685 CCOF = SGTCOE (4,20)
7686 DCOF = SGTCOE (5,20)
7687* | Compute the pi- p elastic cross section:
7688 SPMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7689 & + DCOF * ALGPLA
7690* | Compute the pi- p inelastic cross section:
7691 SPMPIN = SPMPTT - SPMPEL
7692 SIGDIA = SPMPIN - SPPPIN
7693* | +----------------------------------------------------------------*
7694* | | Charged pions: besides isospin consideration it is supposed
7695* | | that (pi+ n)el is almost equal to (pi- p)el
7696* | | and (pi+ p)el " " " " (pi- n)el
7697* | | and all are almost equal among each others
7698* | | (reasonable above 5 GeV/c)
7699 IF ( ICHRGE (IP) .NE. 0 ) THEN
7700 KHELP = KTARG / 8
7701 JREAC = 3 + IP - 13 + ICHRGE (IP) * KHELP
7702 ACOF = SGTCOE (1,JREAC)
7703 BCOF = SGTCOE (2,JREAC)
7704 ENNE = SGTCOE (3,JREAC)
7705 CCOF = SGTCOE (4,JREAC)
7706 DCOF = SGTCOE (5,JREAC)
7707* | | Compute the total cross section:
7708 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7709 & + DCOF * ALGPLA
7710 JREAC = 19 + IP - 13 + ICHRGE (IP) * KHELP
7711 ACOF = SGTCOE (1,JREAC)
7712 BCOF = SGTCOE (2,JREAC)
7713 ENNE = SGTCOE (3,JREAC)
7714 CCOF = SGTCOE (4,JREAC)
7715 DCOF = SGTCOE (5,JREAC)
7716* | | Compute the elastic cross section:
7717 SHNCEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7718 & + DCOF * ALGPLA
7719* | | Compute the inelastic cross section:
7720 SHNCIN = SHNCTT - SHNCEL
7721* | | Number of diagrams:
7722 NDIAGR = 1 + IP - 13 + ICHRGE (IP) * KHELP
7723* | | Now compute the chain end (anti)quark-(anti)diquark
7724 IQFSC1 = 1 + IP - 13
7725 IQFSC2 = 0
7726 IQBSC1 = 1 + KHELP
7727 IQBSC2 = 1 + IP - 13
7728* | |
7729* | +----------------------------------------------------------------*
7730* | | pi0: besides isospin consideration it is supposed that the
7731* | | elastic cross section is not very different from
7732* | | pi+ p and/or pi- p (reasonable above 5 GeV/c)
7733 ELSE
7734 KHELP = KTARG / 8
7735 K2HLP = ( KP - 23 ) / 3
7736* | | Number of diagrams:
7737* | | For u ubar (k2hlp=0):
7738* NDIAGR = 2 - KHELP
7739* | | For d dbar (k2hlp=1):
7740* NDIAGR = 2 + KHELP - K2HLP
7741 NDIAGR = 2 + KHELP * ( 2 * K2HLP - 1 ) - K2HLP
7742 SHNCIN = HLFHLF * ( SPPPIN + SPMPIN )
7743* | | Now compute the chain end (anti)quark-(anti)diquark
7744 IQFSC1 = 1 + K2HLP
7745 IQFSC2 = 0
7746 IQBSC1 = 1 + KHELP
7747 IQBSC2 = 2 - K2HLP
7748 END IF
7749* | |
7750* | +----------------------------------------------------------------*
7751* | end pi's
7752* +-------------------------------------------------------------------*
7753* | Kaons:
7754 ELSE IF ( IHLP (IP) .EQ. 3 ) THEN
7755 ACOF = SGTCOE (1,6)
7756 BCOF = SGTCOE (2,6)
7757 ENNE = SGTCOE (3,6)
7758 CCOF = SGTCOE (4,6)
7759 DCOF = SGTCOE (5,6)
7760* | Compute the K+ p total cross section:
7761 SKPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7762 & + DCOF * ALGPLA
7763 ACOF = SGTCOE (1,21)
7764 BCOF = SGTCOE (2,21)
7765 ENNE = SGTCOE (3,21)
7766 CCOF = SGTCOE (4,21)
7767 DCOF = SGTCOE (5,21)
7768* | Compute the K+ p elastic cross section:
7769 SKPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7770 & + DCOF * ALGPLA
7771* | Compute the K+ p inelastic cross section:
7772 SKPPIN = SKPPTT - SKPPEL
7773 ACOF = SGTCOE (1,9)
7774 BCOF = SGTCOE (2,9)
7775 ENNE = SGTCOE (3,9)
7776 CCOF = SGTCOE (4,9)
7777 DCOF = SGTCOE (5,9)
7778* | Compute the K- p total cross section:
7779 SKMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7780 & + DCOF * ALGPLA
7781 ACOF = SGTCOE (1,22)
7782 BCOF = SGTCOE (2,22)
7783 ENNE = SGTCOE (3,22)
7784 CCOF = SGTCOE (4,22)
7785 DCOF = SGTCOE (5,22)
7786* | Compute the K- p elastic cross section:
7787 SKMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7788 & + DCOF * ALGPLA
7789* | Compute the K- p inelastic cross section:
7790 SKMPIN = SKMPTT - SKMPEL
7791 SIGDIA = HLFHLF * ( SKMPIN - SKPPIN )
7792* | +----------------------------------------------------------------*
7793* | | Charged Kaons: actually only K-
7794 IF ( ICHRGE (IP) .NE. 0 ) THEN
7795 KHELP = KTARG / 8
7796* | | +-------------------------------------------------------------*
7797* | | | Proton target:
7798 IF ( KHELP .EQ. 0 ) THEN
7799 SHNCIN = SKMPIN
7800* | | | Number of diagrams:
7801 NDIAGR = 2
7802* | | |
7803* | | +-------------------------------------------------------------*
7804* | | | Neutron target: besides isospin consideration it is supposed
7805* | | | that (K- n)el is almost equal to (K- p)el
7806* | | | (reasonable above 5 GeV/c)
7807 ELSE
7808 ACOF = SGTCOE (1,10)
7809 BCOF = SGTCOE (2,10)
7810 ENNE = SGTCOE (3,10)
7811 CCOF = SGTCOE (4,10)
7812 DCOF = SGTCOE (5,10)
7813* | | | Compute the total cross section:
7814 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7815 & + DCOF * ALGPLA
7816* | | | Compute the elastic cross section:
7817 SHNCEL = SKMPEL
7818* | | | Compute the inelastic cross section:
7819 SHNCIN = SHNCTT - SHNCEL
7820* | | | Number of diagrams:
7821 NDIAGR = 1
7822 END IF
7823* | | |
7824* | | +-------------------------------------------------------------*
7825* | | Now compute the chain end (anti)quark-(anti)diquark
7826 IQFSC1 = 3
7827 IQFSC2 = 0
7828 IQBSC1 = 1 + KHELP
7829 IQBSC2 = 2
7830* | |
7831* | +----------------------------------------------------------------*
7832* | | K0's: (actually only K0bar)
7833 ELSE
7834 KHELP = KTARG / 8
7835* | | +-------------------------------------------------------------*
7836* | | | Proton target: (K0bar p)in supposed to be given by
7837* | | | (K- p)in - Sig_diagr
7838 IF ( KHELP .EQ. 0 ) THEN
7839 SHNCIN = SKMPIN - SIGDIA
7840* | | | Number of diagrams:
7841 NDIAGR = 1
7842* | | |
7843* | | +-------------------------------------------------------------*
7844* | | | Neutron target: (K0bar n)in supposed to be given by
7845* | | | (K- n)in + Sig_diagr
7846* | | | besides isospin consideration it is supposed
7847* | | | that (K- n)el is almost equal to (K- p)el
7848* | | | (reasonable above 5 GeV/c)
7849 ELSE
7850 ACOF = SGTCOE (1,10)
7851 BCOF = SGTCOE (2,10)
7852 ENNE = SGTCOE (3,10)
7853 CCOF = SGTCOE (4,10)
7854 DCOF = SGTCOE (5,10)
7855* | | | Compute the total cross section:
7856 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7857 & + DCOF * ALGPLA
7858* | | | Compute the elastic cross section:
7859 SHNCEL = SKMPEL
7860* | | | Compute the inelastic cross section:
7861 SHNCIN = SHNCTT - SHNCEL + SIGDIA
7862* | | | Number of diagrams:
7863 NDIAGR = 2
7864 END IF
7865* | | |
7866* | | +-------------------------------------------------------------*
7867* | | Now compute the chain end (anti)quark-(anti)diquark
7868 IQFSC1 = 3
7869 IQFSC2 = 0
7870 IQBSC1 = 1
7871 IQBSC2 = 1 + KHELP
7872 END IF
7873* | |
7874* | +----------------------------------------------------------------*
7875* | end Kaon's
7876* +-------------------------------------------------------------------*
7877* | Antinucleons:
7878 ELSE IF ( IHLP (IP) .EQ. 4 .AND. IP .LE. 9 ) THEN
7879* | For momenta between 3 and 5 GeV/c the use of tabulated data
7880* | should be implemented!
7881 ACOF = SGTCOE (1,15)
7882 BCOF = SGTCOE (2,15)
7883 ENNE = SGTCOE (3,15)
7884 CCOF = SGTCOE (4,15)
7885 DCOF = SGTCOE (5,15)
7886* | Compute the pbar p total cross section:
7887 SAPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7888 & + DCOF * ALGPLA
7889 IF ( PLA .LT. FIVFIV ) THEN
7890 JREAC = 26
7891 ELSE
7892 JREAC = 25
7893 END IF
7894 ACOF = SGTCOE (1,JREAC)
7895 BCOF = SGTCOE (2,JREAC)
7896 ENNE = SGTCOE (3,JREAC)
7897 CCOF = SGTCOE (4,JREAC)
7898 DCOF = SGTCOE (5,JREAC)
7899* | Compute the pbar p elastic cross section:
7900 SAPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7901 & + DCOF * ALGPLA
7902* | Compute the pbar p inelastic cross section:
7903 SAPPIN = SAPPTT - SAPPEL
7904 ACOF = SGTCOE (1,12)
7905 BCOF = SGTCOE (2,12)
7906 ENNE = SGTCOE (3,12)
7907 CCOF = SGTCOE (4,12)
7908 DCOF = SGTCOE (5,12)
7909* | Compute the p p total cross section:
7910 SPPTOT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7911 & + DCOF * ALGPLA
7912 ACOF = SGTCOE (1,23)
7913 BCOF = SGTCOE (2,23)
7914 ENNE = SGTCOE (3,23)
7915 CCOF = SGTCOE (4,23)
7916 DCOF = SGTCOE (5,23)
7917* | Compute the p p elastic cross section:
7918 SPPELA = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7919 & + DCOF * ALGPLA
7920* | Compute the K- p inelastic cross section:
7921 SPPINE = SPPTOT - SPPELA
7922 SIGDIA = ( SAPPIN - SPPINE ) / FIVFIV
7923 KHELP = KTARG / 8
7924* | +----------------------------------------------------------------*
7925* | | Pbar:
7926 IF ( ICHRGE (IP) .NE. 0 ) THEN
7927 NDIAGR = 5 - KHELP
7928* | | +-------------------------------------------------------------*
7929* | | | Proton target:
7930 IF ( KHELP .EQ. 0 ) THEN
7931* | | | Number of diagrams:
7932 SHNCIN = SAPPIN
7933 PUUBAR = 0.8D+00
7934* | | |
7935* | | +-------------------------------------------------------------*
7936* | | | Neutron target: it is supposed that (ap n)el is almost equal
7937* | | | to (ap p)el (reasonable above 5 GeV/c)
7938 ELSE
7939 ACOF = SGTCOE (1,16)
7940 BCOF = SGTCOE (2,16)
7941 ENNE = SGTCOE (3,16)
7942 CCOF = SGTCOE (4,16)
7943 DCOF = SGTCOE (5,16)
7944* | | | Compute the total cross section:
7945 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7946 & + DCOF * ALGPLA
7947* | | | Compute the elastic cross section:
7948 SHNCEL = SAPPEL
7949* | | | Compute the inelastic cross section:
7950 SHNCIN = SHNCTT - SHNCEL
7951 PUUBAR = HLFHLF
7952 END IF
7953* | | |
7954* | | +-------------------------------------------------------------*
7955* | | Now compute the chain end (anti)quark-(anti)diquark
7956* | | there are different possibilities, make a random choiche:
7957 IQFSC1 = -1
7958 RNCHEN = DT_RNDM(PUUBAR)
7959 IF ( RNCHEN .LT. PUUBAR ) THEN
7960 IQFSC2 = -2
7961 ELSE
7962 IQFSC2 = -1
7963 END IF
7964 IQBSC1 = -IQFSC1 + KHELP
7965 IQBSC2 = -IQFSC2
7966* | |
7967* | +----------------------------------------------------------------*
7968* | | nbar:
7969 ELSE
7970 NDIAGR = 4 + KHELP
7971* | | +-------------------------------------------------------------*
7972* | | | Proton target: (nbar p)in supposed to be given by
7973* | | | (pbar p)in - Sig_diagr
7974 IF ( KHELP .EQ. 0 ) THEN
7975 SHNCIN = SAPPIN - SIGDIA
7976 PDDBAR = HLFHLF
7977* | | |
7978* | | +-------------------------------------------------------------*
7979* | | | Neutron target: (nbar n)el is supposed to be equal to
7980* | | | (pbar p)el (reasonable above 5 GeV/c)
7981 ELSE
7982* | | | Compute the total cross section:
7983 SHNCTT = SAPPTT
7984* | | | Compute the elastic cross section:
7985 SHNCEL = SAPPEL
7986* | | | Compute the inelastic cross section:
7987 SHNCIN = SHNCTT - SHNCEL
7988 PDDBAR = 0.8D+00
7989 END IF
7990* | | |
7991* | | +-------------------------------------------------------------*
7992* | | Now compute the chain end (anti)quark-(anti)diquark
7993* | | there are different possibilities, make a random choiche:
7994 IQFSC1 = -2
7995 RNCHEN = DT_RNDM(RNCHEN)
7996 IF ( RNCHEN .LT. PDDBAR ) THEN
7997 IQFSC2 = -1
7998 ELSE
7999 IQFSC2 = -2
8000 END IF
8001 IQBSC1 = -IQFSC1 + KHELP - 1
8002 IQBSC2 = -IQFSC2
8003 END IF
8004* | |
8005* | +----------------------------------------------------------------*
8006* |
8007* +-------------------------------------------------------------------*
8008* | Others: not yet implemented
8009 ELSE
8010 SIGDIA = ZERZER
8011 SHNCIN = ONEONE
8012 NDIAGR = 0
8013 DT_PHNSCH = ZERZER
8014 RETURN
8015 END IF
8016* | end others
8017* +-------------------------------------------------------------------*
8018 DT_PHNSCH = NDIAGR * SIGDIA / SHNCIN
8019 IQECHC = IQECHR (IQFSC1) + IQECHR (IQFSC2) + IQECHR (IQBSC1)
8020 & + IQECHR (IQBSC2)
8021 IQBCHC = IQBCHR (IQFSC1) + IQBCHR (IQFSC2) + IQBCHR (IQBSC1)
8022 & + IQBCHR (IQBSC2)
8023 IQECHC = IQECHC / 3
8024 IQBCHC = IQBCHC / 3
8025 IQSCHC = IQSCHR (IQFSC1) + IQSCHR (IQFSC2) + IQSCHR (IQBSC1)
8026 & + IQSCHR (IQBSC2)
8027 IQSPRO = IQSCHR (MQUARK(1,IP)) + IQSCHR (MQUARK(2,IP))
8028 & + IQSCHR (MQUARK(3,IP))
8029* +-------------------------------------------------------------------*
8030* | Consistency check:
8031 IF ( DT_PHNSCH .LE. ZERZER .OR. DT_PHNSCH .GT. ONEONE ) THEN
8032 WRITE (LUNOUT,*)' *** Phnsch,kp,ktarg,pla',
8033 & DT_PHNSCH,KP,KTARG,PLA,' ****'
8034 WRITE (LUNERR,*)' *** Phnsch,kp,ktarg,pla',
8035 & DT_PHNSCH,KP,KTARG,PLA,' ****'
8036 DT_PHNSCH = MAX ( DT_PHNSCH, ZERZER )
8037 DT_PHNSCH = MIN ( DT_PHNSCH, ONEONE )
8038 END IF
8039* |
8040* +-------------------------------------------------------------------*
8041* +-------------------------------------------------------------------*
8042* | Consistency check:
8043 IF ( IQSPRO .NE. IQSCHC .OR. ICHRGE (IP) + ICHRGE (KTARG)
8044 & .NE. IQECHC .OR. IIBAR (KP) + IIBAR (KTARG) .NE. IQBCHC) THEN
8045 WRITE (LUNOUT,*)
8046 &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8047 & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8048 WRITE (LUNERR,*)
8049 &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8050 & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8051 END IF
8052* |
8053* +-------------------------------------------------------------------*
8054* P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
8055 IF ( UMORAT .GT. ONEPLS )
8056 & DT_PHNSCH = ONEONE / ( ( ONEONE / DT_PHNSCH
8057 & - ONEONE ) * UMORAT + ONEONE )
8058 RETURN
8059*
8060 ENTRY DT_SCHQUA ( JQFSC1, JQFSC2, JQBSC1, JQBSC2 )
8061 DT_SCHQUA = ONEONE
8062 JQFSC1 = IQFSC1
8063 JQFSC2 = IQFSC2
8064 JQBSC1 = IQBSC1
8065 JQBSC2 = IQBSC2
8066*=== End of function Phnsch ===========================================*
8067 RETURN
8068 END
8069
8070*$ CREATE DT_RESPT.FOR
8071*COPY DT_RESPT
8072*
8073*===respt==============================================================*
8074*
8075 SUBROUTINE DT_RESPT
8076
8077************************************************************************
8078* Check DTEVT1 for two-resonance systems and sample intrinsic p_t. *
8079* This version dated 18.01.95 is written by S. Roesler *
8080************************************************************************
8081
8082 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8083 SAVE
8084 PARAMETER ( LINP = 10 ,
8085 & LOUT = 6 ,
8086 & LDAT = 9 )
8087 PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8088
8089* event history
8090 PARAMETER (NMXHKK=200000)
8091 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8092 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8093 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8094* extended event history
8095 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8096 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8097 & IHIST(2,NMXHKK)
8098
8099* get index of first chain
8100 DO 1 I=NPOINT(3),NHKK
8101 IF (IDHKK(I).EQ.88888) THEN
8102 NC = I
8103 GOTO 2
8104 ENDIF
8105 1 CONTINUE
8106
8107 2 CONTINUE
8108 IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)) THEN
8109C WRITE(LOUT,*)NC,NC+3,IDRES(NC),IDRES(NC+3)
8110* skip VV-,SS- systems
8111 IF ((IDCH(NC ).NE.1).AND.(IDCH(NC ).NE.8).AND.
8112 & (IDCH(NC+3).NE.1).AND.(IDCH(NC+3).NE.8)) THEN
8113* check if both "chains" are resonances
8114 IF ((IDRES(NC).NE.0).AND.(IDRES(NC+3).NE.0)) THEN
8115 CALL DT_SAPTRE(NC,NC+3)
8116 ENDIF
8117 ENDIF
8118 ELSE
8119 GOTO 3
8120 ENDIF
8121 NC = NC+6
8122 GOTO 2
8123
8124 3 CONTINUE
8125
8126 RETURN
8127 END
8128
8129*$ CREATE DT_EVTRES.FOR
8130*COPY DT_EVTRES
8131*
8132*===evtres=============================================================*
8133*
8134 SUBROUTINE DT_EVTRES(IREJ)
8135
8136************************************************************************
8137* This version dated 14.12.94 is written by S. Roesler *
8138************************************************************************
8139
8140 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8141 SAVE
8142 PARAMETER ( LINP = 10 ,
8143 & LOUT = 6 ,
8144 & LDAT = 9 )
8145 PARAMETER (TINY5=1.0D-5,TINY10=1.0D-10)
8146
8147* event history
8148 PARAMETER (NMXHKK=200000)
8149 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8150 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8151 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8152* extended event history
8153 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8154 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8155 & IHIST(2,NMXHKK)
8156* flags for input different options
8157 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8158 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8159 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8160* particle properties (BAMJET index convention)
8161 CHARACTER*8 ANAME
8162 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
8163 & IICH(210),IIBAR(210),K1(210),K2(210)
8164
8165 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),IFP(2),IFT(2)
8166
8167 IREJ = 0
8168
8169 DO 1 I=NPOINT(3),NHKK
8170 IF (ABS(IDRES(I)).GE.100) THEN
8171 AMMX = 0.0D0
8172 DO 2 J=NPOINT(3),NHKK
8173 IF (IDHKK(J).EQ.88888) THEN
8174 IF (PHKK(5,J).GT.AMMX) THEN
8175 AMMX = PHKK(5,J)
8176 IMMX = J
8177 ENDIF
8178 ENDIF
8179 2 CONTINUE
8180 IF (IDRES(IMMX).NE.0) THEN
8181 IF (IOULEV(3).GT.0) THEN
8182 WRITE(LOUT,'(1X,A)')
8183 & 'EVTRES: no chain for correc. found'
8184C GOTO 6
8185 GOTO 9999
8186 ELSE
8187 GOTO 9999
8188 ENDIF
8189 ENDIF
8190 IMO11 = JMOHKK(1,I)
8191 IMO12 = JMOHKK(2,I)
8192 IF (PHKK(3,IMO11).LT.0.0D0) THEN
8193 IMO11 = JMOHKK(2,I)
8194 IMO12 = JMOHKK(1,I)
8195 ENDIF
8196 IMO21 = JMOHKK(1,IMMX)
8197 IMO22 = JMOHKK(2,IMMX)
8198 IF (PHKK(3,IMO21).LT.0.0D0) THEN
8199 IMO21 = JMOHKK(2,IMMX)
8200 IMO22 = JMOHKK(1,IMMX)
8201 ENDIF
8202 AMCH1 = PHKK(5,I)
8203 AMCH1N = AAM(IDXRES(I))
8204
8205 IFPR1 = IDHKK(IMO11)
8206 IFPR2 = IDHKK(IMO21)
8207 IFTA1 = IDHKK(IMO12)
8208 IFTA2 = IDHKK(IMO22)
8209 DO 4 J=1,4
8210 PP1(J) = PHKK(J,IMO11)
8211 PP2(J) = PHKK(J,IMO21)
8212 PT1(J) = PHKK(J,IMO12)
8213 PT2(J) = PHKK(J,IMO22)
8214 4 CONTINUE
8215* store initial configuration for energy-momentum cons. check
8216 IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IREJ1)
8217* correct kinematics of second chain
8218 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
8219 & AMCH1,AMCH1N,AMCH2,IREJ1)
8220 IF (IREJ1.NE.0) GOTO 9999
8221* check now this chain for resonance mass
8222 IFP(1) = IDT_IPDG2B(IFPR2,1,2)
8223 IFP(2) = 0
8224 IF (ABS(IFPR2).GE.1000) IFP(2) = IDT_IPDG2B(IFPR2,2,2)
8225 IFT(1) = IDT_IPDG2B(IFTA2,1,2)
8226 IFT(2) = 0
8227 IF (ABS(IFTA2).GE.1000) IFT(2) = IDT_IPDG2B(IFTA2,2,2)
8228 IDCH2 = 2
8229 IF ((IFP(2).EQ.0).AND.(IFT(2).EQ.0)) IDCH2 = 1
8230 IF ((IFP(2).NE.0).AND.(IFT(2).NE.0)) IDCH2 = 3
8231 CALL DT_CH2RES(IFP(1),IFP(2),IFT(1),IFT(2),IDR2,IDXR2,
8232 & AMCH2,AMCH2N,IDCH2,IREJ1)
8233 IF ((IREJ1.NE.0).OR.(IDR2.NE.0)) THEN
8234 IF (IOULEV(1).GT.0)
8235 & WRITE(LOUT,*) ' correction for resonance not poss.'
8236**sr test
8237C GOTO 1
8238C GOTO 9999
8239**
8240 ENDIF
8241* store final configuration for energy-momentum cons. check
8242 IF (LEMCCK) THEN
8243 CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IREJ1)
8244 CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
8245 IF (IREJ1.NE.0) GOTO 9999
8246 ENDIF
8247 DO 5 J=1,4
8248 PHKK(J,IMO11) = PP1(J)
8249 PHKK(J,IMO21) = PP2(J)
8250 PHKK(J,IMO12) = PT1(J)
8251 PHKK(J,IMO22) = PT2(J)
8252 5 CONTINUE
8253* correct entries of chains
8254 DO 3 K=1,4
8255 PHKK(K,I) = PHKK(K,IMO11)+PHKK(K,IMO12)
8256 PHKK(K,IMMX) = PHKK(K,IMO21)+PHKK(K,IMO22)
8257 3 CONTINUE
8258 AM1 = PHKK(4,I)**2-PHKK(1,I)**2-PHKK(2,I)**2-PHKK(3,I)**2
8259 AM2 = PHKK(4,IMMX)**2-PHKK(1,IMMX)**2-PHKK(2,IMMX)**2-
8260 & PHKK(3,IMMX)**2
8261* ?? the following should now be obsolete
8262**sr test
8263C IF ((AM1.LT.0.0D0).OR.(AM2.LT.1.0D0)) THEN
8264 IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8265**
8266 WRITE(LOUT,'(1X,A,4G10.3)')
8267 & 'EVTRES: inonsistent mass-corr.',AM1,AM2
8268C GOTO 9999
8269 GOTO 1
8270 ENDIF
8271 PHKK(5,I) = SQRT(AM1)
8272 PHKK(5,IMMX) = SQRT(AM2)
8273 IDRES(I) = IDRES(I)/100
8274 IF ((ABS(PHKK(5,I)-AMCH1N).GT.TINY5).OR.
8275 & (ABS(PHKK(5,IMMX)-AMCH2).GT.TINY5)) THEN
8276 WRITE(LOUT,'(1X,A,4G10.3)')
8277 & 'EVTRES: inconsistent chain-masses',
8278 & PHKK(5,I),AMCH1N,PHKK(5,IMMX),AMCH2
8279 GOTO 9999
8280 ENDIF
8281 ENDIF
8282 1 CONTINUE
8283 6 CONTINUE
8284 RETURN
8285
8286 9999 CONTINUE
8287 IREJ = 1
8288 RETURN
8289 END
8290
8291*$ CREATE DT_GETSPT.FOR
8292*COPY DT_GETSPT
8293*
8294*===getspt=============================================================*
8295*
8296 SUBROUTINE DT_GETSPT(PP1I,IFPR1,IFP1,PP2I,IFPR2,IFP2,
8297 & PT1I,IFTA1,IFT1,PT2I,IFTA2,IFT2,
8298 & AM1,IDCH1,AM2,IDCH2,IDCHAI,IREJ)
8299
8300************************************************************************
8301* This version dated 12.12.94 is written by S. Roesler *
8302************************************************************************
8303
8304 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8305 SAVE
8306 PARAMETER ( LINP = 10 ,
8307 & LOUT = 6 ,
8308 & LDAT = 9 )
8309 PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,ZERO=0.0D0)
8310
8311* various options for treatment of partons (DTUNUC 1.x)
8312* (chain recombination, Cronin,..)
8313 LOGICAL LCO2CR,LINTPT
8314 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8315 & LCO2CR,LINTPT
8316* flags for input different options
8317 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8318 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8319 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8320* flags for diffractive interactions (DTUNUC 1.x)
8321 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
8322
8323 DIMENSION PP1(4),PP1I(4),PP2(4),PP2I(4),PT1(4),PT1I(4),
8324 & PT2(4),PT2I(4),P1(4),P2(4),
8325 & IFP1(2),IFP2(2),IFT1(2),IFT2(2),
8326 & PTOTI(4),PTOTF(4),DIFF(4)
8327
8328 IC = 0
8329 IREJ = 0
8330C B33P = 4.0D0
8331C B33T = 4.0D0
8332C IF ((IDCHAI.EQ.6).OR.(IDCHAI.EQ.7).OR.(IDCHAI.EQ.8)) B33P = 2.0D0
8333C IF ((IDCHAI.EQ.4).OR.(IDCHAI.EQ.5).OR.(IDCHAI.EQ.8)) B33T = 2.0D0
8334 REDU = 1.0D0
8335C B33P = 3.5D0
8336C B33T = 3.5D0
8337 B33P = 4.0D0
8338 B33T = 4.0D0
8339 IF (IDIFF.NE.0) THEN
8340 B33P = 16.0D0
8341 B33T = 16.0D0
8342 ENDIF
8343
8344 DO 1 I=1,4
8345 PTOTI(I) = PP1I(I)+PP2I(I)+PT1I(I)+PT2I(I)
8346 PP1(I) = PP1I(I)
8347 PP2(I) = PP2I(I)
8348 PT1(I) = PT1I(I)
8349 PT2(I) = PT2I(I)
8350 1 CONTINUE
8351* get initial chain masses
8352 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8353 & +(PP1(3)+PT1(3))**2)
8354 ECH = PP1(4)+PT1(4)
8355 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
8356 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8357 & +(PP2(3)+PT2(3))**2)
8358 ECH = PP2(4)+PT2(4)
8359 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
8360 IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8361 IF (IOULEV(1).GT.0)
8362 & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 1',
8363 & AM1,AM2
8364 GOTO 9999
8365 ENDIF
8366 AM1 = SQRT(AM1)
8367 AM2 = SQRT(AM2)
8368 AM1N = ZERO
8369 AM2N = ZERO
8370
8371 MODE = 0
8372C IF ((AM1.GE.3.0D0).AND.(AM2.GE.3.0D0)) THEN
8373C MODE = 0
8374C ELSE
8375C MODE = 1
8376C IF (AM1.LT.0.6) THEN
8377C B33P = 10.0D0
8378C ELSEIF ((AM1.GE.1.2).AND.(AM1.LT.3.0D0)) THEN
8379CC B33P = 4.0D0
8380C ENDIF
8381C IF (AM2.LT.0.6) THEN
8382C B33T = 10.0D0
8383C ELSEIF ((AM2.GE.1.2).AND.(AM2.LT.3.0D0)) THEN
8384CC B33T = 4.0D0
8385C ENDIF
8386C ENDIF
8387
8388* check chain masses for very low mass chains
8389C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8390C & AM1,DUM,-IDCH1,IREJ1)
8391C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8392C & AM2,DUM,-IDCH2,IREJ2)
8393C IF ((IREJ1.NE.0).OR.(IREJ2.NE.0)) THEN
8394C B33P = 20.0D0
8395C B33T = 20.0D0
8396C ENDIF
8397
8398 JMSHL = IMSHL
8399
8400 2 CONTINUE
8401 IC = IC+1
8402 IF (MOD(IC,15).EQ.0) B33P = 2.0D0*B33P
8403 IF (MOD(IC,15).EQ.0) B33T = 2.0D0*B33T
8404 IF (MOD(IC,18).EQ.0) REDU = 0.0D0
8405C IF (MOD(IC,19).EQ.0) JMSHL = 0
8406 IF (MOD(IC,20).EQ.0) GOTO 7
8407C WRITE(LOUT,'(1X,A)') 'GETSPT: rejection '
8408C RETURN
8409C GOTO 9999
8410C ENDIF
8411
8412* get transverse momentum
8413 IF (LINTPT) THEN
8414 ES = -2.0D0/(B33P**2)
8415 & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8416 HPSP = SQRT(ES*ES+2.0D0*ES*0.94D0)
8417 HPSP = HPSP*REDU
8418 ES = -2.0D0/(B33T**2)
8419 & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8420 HPST = SQRT(ES*ES+2.0D0*ES*0.94D0)
8421 HPST = HPST*REDU
8422 ELSE
8423 HPSP = ZERO
8424 HPST = ZERO
8425 ENDIF
8426 CALL DT_DSFECF(SFE1,CFE1)
8427 CALL DT_DSFECF(SFE2,CFE2)
8428 IF (MODE.EQ.0) THEN
8429 PP1(1) = PP1I(1)+HPSP*CFE1
8430 PP1(2) = PP1I(2)+HPSP*SFE1
8431 PP2(1) = PP2I(1)-HPSP*CFE1
8432 PP2(2) = PP2I(2)-HPSP*SFE1
8433 PT1(1) = PT1I(1)+HPST*CFE2
8434 PT1(2) = PT1I(2)+HPST*SFE2
8435 PT2(1) = PT2I(1)-HPST*CFE2
8436 PT2(2) = PT2I(2)-HPST*SFE2
8437 ELSE
8438 PP1(1) = PP1I(1)+HPSP*CFE1
8439 PP1(2) = PP1I(2)+HPSP*SFE1
8440 PT1(1) = PT1I(1)-HPSP*CFE1
8441 PT1(2) = PT1I(2)-HPSP*SFE1
8442 PP2(1) = PP2I(1)+HPST*CFE2
8443 PP2(2) = PP2I(2)+HPST*SFE2
8444 PT2(1) = PT2I(1)-HPST*CFE2
8445 PT2(2) = PT2I(2)-HPST*SFE2
8446 ENDIF
8447
8448* put partons on mass shell
8449 XMP1 = 0.0D0
8450 XMT1 = 0.0D0
8451 IF (JMSHL.EQ.1) THEN
8452 XMP1 = PYMASS(IFPR1)
8453 XMT1 = PYMASS(IFTA1)
8454 ENDIF
8455 CALL DT_MASHEL(PP1,PT1,XMP1,XMT1,P1,P2,IREJ1)
8456 IF (IREJ1.NE.0) GOTO 2
8457 DO 3 I=1,4
8458 PTOTF(I) = P1(I)+P2(I)
8459 PP1(I) = P1(I)
8460 PT1(I) = P2(I)
8461 3 CONTINUE
8462 XMP2 = 0.0D0
8463 XMT2 = 0.0D0
8464 IF (JMSHL.EQ.1) THEN
8465 XMP2 = PYMASS(IFPR2)
8466 XMT2 = PYMASS(IFTA2)
8467 ENDIF
8468 CALL DT_MASHEL(PP2,PT2,XMP2,XMT2,P1,P2,IREJ1)
8469 IF (IREJ1.NE.0) GOTO 2
8470 DO 4 I=1,4
8471 PTOTF(I) = PTOTF(I)+P1(I)+P2(I)
8472 PP2(I) = P1(I)
8473 PT2(I) = P2(I)
8474 4 CONTINUE
8475
8476* check consistency
8477 DO 5 I=1,4
8478 DIFF(I) = PTOTI(I)-PTOTF(I)
8479 5 CONTINUE
8480 IF ((ABS(DIFF(1)).GT.TINY5).OR.(ABS(DIFF(2)).GT.TINY5).OR.
8481 & (ABS(DIFF(3)).GT.TINY5).OR.(ABS(DIFF(4)).GT.TINY5)) THEN
8482 WRITE(LOUT,'(1X,A,4G10.3)') 'GETSPT: inconsistencies ',DIFF
8483 GOTO 9999
8484 ENDIF
8485 PTOTP1 = SQRT(PP1(1)**2+PP1(2)**2+PP1(3)**2)
8486 AMP1 = SQRT(ABS( (PP1(4)-PTOTP1)*(PP1(4)+PTOTP1) ))
8487 PTOTP2 = SQRT(PP2(1)**2+PP2(2)**2+PP2(3)**2)
8488 AMP2 = SQRT(ABS( (PP2(4)-PTOTP2)*(PP2(4)+PTOTP2) ))
8489 PTOTT1 = SQRT(PT1(1)**2+PT1(2)**2+PT1(3)**2)
8490 AMT1 = SQRT(ABS( (PT1(4)-PTOTT1)*(PT1(4)+PTOTT1) ))
8491 PTOTT2 = SQRT(PT2(1)**2+PT2(2)**2+PT2(3)**2)
8492 AMT2 = SQRT(ABS( (PT2(4)-PTOTT2)*(PT2(4)+PTOTT2) ))
8493 IF ((ABS(AMP1-XMP1).GT.TINY3).OR.(ABS(AMP2-XMP2).GT.TINY3).OR.
8494 & (ABS(AMT1-XMT1).GT.TINY3).OR.(ABS(AMT2-XMT2).GT.TINY3))
8495 & THEN
8496 WRITE(LOUT,'(1X,A,2(4G10.3,/))')
8497 & 'GETSPT: inconsistent masses',
8498 & AMP1,XMP1,AMP2,XMP2,AMT1,XMT1,AMT2,XMT2
8499* sr 22.11.00: commented. It should only have inconsistent masses for
8500* ultrahigh energies due to rounding problems
8501C GOTO 9999
8502 ENDIF
8503
8504* get chain masses
8505 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8506 & +(PP1(3)+PT1(3))**2)
8507 ECH = PP1(4)+PT1(4)
8508 AM1N = (ECH+PTOCH)*(ECH-PTOCH)
8509 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8510 & +(PP2(3)+PT2(3))**2)
8511 ECH = PP2(4)+PT2(4)
8512 AM2N = (ECH+PTOCH)*(ECH-PTOCH)
8513 IF ((AM1N.LT.0.0D0).OR.(AM2N.LT.0.0D0)) THEN
8514 IF (IOULEV(1).GT.0)
8515 & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 2',
8516 & AM1N,AM2N
8517 GOTO 2
8518 ENDIF
8519 AM1N = SQRT(AM1N)
8520 AM2N = SQRT(AM2N)
8521
8522* check chain masses for very low mass chains
8523 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8524 & AM1N,DUM,-IDCH1,IREJ1)
8525 IF (IREJ1.NE.0) GOTO 2
8526 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8527 & AM2N,DUM,-IDCH2,IREJ2)
8528 IF (IREJ2.NE.0) GOTO 2
8529
8530 7 CONTINUE
8531 IF (AM1N.GT.ZERO) THEN
8532 AM1 = AM1N
8533 AM2 = AM2N
8534 ENDIF
8535 DO 6 I=1,4
8536 PP1I(I) = PP1(I)
8537 PP2I(I) = PP2(I)
8538 PT1I(I) = PT1(I)
8539 PT2I(I) = PT2(I)
8540 6 CONTINUE
8541
8542 RETURN
8543
8544 9999 CONTINUE
8545 IREJ = 1
8546 RETURN
8547 END
8548
8549*$ CREATE DT_SAPTRE.FOR
8550*COPY DT_SAPTRE
8551*
8552*===saptre=============================================================*
8553*
8554 SUBROUTINE DT_SAPTRE(IDX1,IDX2)
8555
8556************************************************************************
8557* p-t sampling for two-resonance systems. ("BAMJET-like" method) *
8558* IDX1,IDX2 indices of resonances ("chains") in DTEVT1 *
8559* Adopted from the original SAPTRE written by J. Ranft. *
8560* This version dated 18.01.95 is written by S. Roesler *
8561************************************************************************
8562
8563 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8564 SAVE
8565 PARAMETER ( LINP = 10 ,
8566 & LOUT = 6 ,
8567 & LDAT = 9 )
8568 PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8569
8570* event history
8571 PARAMETER (NMXHKK=200000)
8572 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8573 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8574 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8575* extended event history
8576 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8577 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8578 & IHIST(2,NMXHKK)
8579* flags for input different options
8580 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8581 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8582 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8583
8584 DIMENSION PA1(4),PA2(4),P1(4),P2(4)
8585
8586 DATA B3 /4.0D0/
8587
8588 ESMAX1 = PHKK(4,IDX1)-PHKK(5,IDX1)
8589 ESMAX2 = PHKK(4,IDX2)-PHKK(5,IDX2)
8590 ESMAX = MIN(ESMAX1,ESMAX2)
8591 IF (ESMAX.LE.0.05D0) RETURN
8592
8593 HMA = PHKK(5,IDX1)
8594 DO 1 K=1,4
8595 PA1(K) = PHKK(K,IDX1)
8596 PA2(K) = PHKK(K,IDX2)
8597 1 CONTINUE
8598
8599 IF (LEMCCK) THEN
8600 CALL DT_EVTEMC(PA1(1),PA1(2),PA1(3),PA1(4),1,IDUM,IDUM)
8601 CALL DT_EVTEMC(PA2(1),PA2(2),PA2(3),PA2(4),2,IDUM,IDUM)
8602 ENDIF
8603
8604 EXEB = 0.0D0
8605 IF (B3*ESMAX.LE.60.0D0) EXEB = EXP(-B3*ESMAX)
8606 BEXP = HMA*(1.0D0-EXEB)/B3
8607 AXEXP = (1.0D0-(B3*ESMAX-1.0D0)*EXEB)/B3**2
8608 WA = AXEXP/(BEXP+AXEXP)
8609 XAB = DT_RNDM(WA)
8610 10 CONTINUE
8611* ES is the transverse kinetic energy
8612 IF (XAB.LT.WA)THEN
8613 X = DT_RNDM(WA)
8614 Y = DT_RNDM(WA)
8615 ES = -2.0D0/(B3**2)*LOG(X*Y+TINY7)
8616 ELSE
8617 X = DT_RNDM(Y)
8618 ES = ABS(-LOG(X+TINY7)/B3)
8619 ENDIF
8620 IF (ES.GT.ESMAX) GOTO 10
8621 ES = ES+HMA
8622* transverse momentum
8623 HPS = SQRT((ES-HMA)*(ES+HMA))
8624
8625 CALL DT_DSFECF(SFE,CFE)
8626 HPX = HPS*CFE
8627 HPY = HPS*SFE
8628 PZ1NSQ = PA1(3)**2-HPS**2-2.0D0*PA1(1)*HPX-2.0D0*PA1(2)*HPY
8629 PZ2NSQ = PA2(3)**2-HPS**2+2.0D0*PA2(1)*HPX+2.0D0*PA2(2)*HPY
8630 IF ((PZ1NSQ.LT.TINY3).OR.(PZ2NSQ.LT.TINY3)) RETURN
8631
8632C PA1(3) = SIGN(SQRT(PZ1NSQ),PA1(3))
8633C PA2(3) = SIGN(SQRT(PZ2NSQ),PA2(3))
8634 PA1(1) = PA1(1)+HPX
8635 PA1(2) = PA1(2)+HPY
8636 PA2(1) = PA2(1)-HPX
8637 PA2(2) = PA2(2)-HPY
8638
8639* put resonances on mass-shell again
8640 XM1 = PHKK(5,IDX1)
8641 XM2 = PHKK(5,IDX2)
8642 CALL DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ1)
8643 IF (IREJ1.NE.0) RETURN
8644
8645 IF (LEMCCK) THEN
8646 CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,IDUM,IDUM)
8647 CALL DT_EVTEMC(-P2(1),-P2(2),-P2(3),-P2(4),2,IDUM,IDUM)
8648 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,12,IREJ1)
8649 IF (IREJ1.NE.0) RETURN
8650 ENDIF
8651
8652 DO 2 K=1,4
8653 PHKK(K,IDX1) = P1(K)
8654 PHKK(K,IDX2) = P2(K)
8655 2 CONTINUE
8656
8657 RETURN
8658 END
8659
8660*$ CREATE DT_CRONIN.FOR
8661*COPY DT_CRONIN
8662*
8663*===cronin=============================================================*
8664*
8665 SUBROUTINE DT_CRONIN(INCL)
8666
8667************************************************************************
8668* Cronin-Effect. Multiple scattering of partons at chain ends. *
8669* INCL = 1 multiple sc. in projectile *
8670* = 2 multiple sc. in target *
8671* This version dated 05.01.96 is written by S. Roesler. *
8672************************************************************************
8673
8674 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8675 SAVE
8676 PARAMETER ( LINP = 10 ,
8677 & LOUT = 6 ,
8678 & LDAT = 9 )
8679 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
8680
8681* event history
8682 PARAMETER (NMXHKK=200000)
8683 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8684 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8685 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8686* extended event history
8687 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8688 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8689 & IHIST(2,NMXHKK)
8690* rejection counter
8691 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
8692 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
8693 & IREXCI(3),IRDIFF(2),IRINC
8694* Glauber formalism: collision properties
8695 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
8696 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
8697
8698 DIMENSION R(3),PIN(4),POUT(4),DEV(4)
8699
8700 DO 1 K=1,4
8701 DEV(K) = ZERO
8702 1 CONTINUE
8703
8704 DO 2 I=NPOINT(2),NHKK
8705 IF (ISTHKK(I).LT.0) THEN
8706* get z-position of the chain
8707 R(1) = VHKK(1,I)*1.0D12
8708 IF (INCL.EQ.2) R(1) = VHKK(1,I)*1.0D12-BIMPAC
8709 R(2) = VHKK(2,I)*1.0D12
8710 IDXNU = JMOHKK(1,I)
8711 IF ( (INCL.EQ.1).AND.(ISTHKK(IDXNU).EQ.10) )
8712 & IDXNU = JMOHKK(1,I-1)
8713 IF ( (INCL.EQ.2).AND.(ISTHKK(IDXNU).EQ. 9) )
8714 & IDXNU = JMOHKK(1,I+1)
8715 R(3) = VHKK(3,IDXNU)*1.0D12
8716* position of target parton the chain is connected to
8717 DO 3 K=1,4
8718 PIN(K) = PHKK(K,I)
8719 3 CONTINUE
8720* multiple scattering of parton with DTEVT1-index I
8721 CALL DT_CROMSC(PIN,R,POUT,INCL)
8722**testprint
8723C IF (NEVHKK.EQ.5) THEN
8724C AMIN = PIN(4)**2-PIN(1)**2-PIN(2)**2-PIN(3)**2
8725C AMOU = POUT(4)**2-POUT(1)**2-POUT(2)**2-POUT(3)**2
8726C AMIN = SIGN(SQRT(ABS(AMIN)),AMIN)
8727C AMOU = SIGN(SQRT(ABS(AMOU)),AMOU)
8728C WRITE(6,'(A,I4,2E15.5)')'I,AMIN,AMOU: ',I,AMIN,AMOU
8729C WRITE(6,'(A,4E15.5)')'PIN: ',PIN
8730C WRITE(6,'(A,4E15.5)')'POUT: ',POUT
8731C ENDIF
8732**
8733* increase accumulator by energy-momentum difference
8734 DO 4 K=1,4
8735 DEV(K) = DEV(K)+POUT(K)-PIN(K)
8736 PHKK(K,I) = POUT(K)
8737 4 CONTINUE
8738 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
8739 & PHKK(2,I)**2-PHKK(3,I)**2))
8740 ENDIF
8741 2 CONTINUE
8742
8743* dump accumulator to momenta of valence partons
8744 NVAL = 0
8745 ETOT = 0.0D0
8746 DO 5 I=NPOINT(2),NHKK
8747 IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
8748 NVAL = NVAL+1
8749 ETOT = ETOT+PHKK(4,I)
8750 ENDIF
8751 5 CONTINUE
8752C WRITE(LOUT,1000) NVAL,(DEV(K)/DBLE(NVAL),K=1,4)
8753 1000 FORMAT(1X,'CRONIN : number of val. partons ',I4,/,
8754 & 9X,4E12.4)
8755 DO 6 I=NPOINT(2),NHKK
8756 IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
8757 E = PHKK(4,I)
8758 DO 7 K=1,4
8759C PHKK(K,I) = PHKK(K,I)-DEV(K)/DBLE(NVAL)
8760 PHKK(K,I) = PHKK(K,I)-DEV(K)*E/ETOT
8761 7 CONTINUE
8762 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
8763 & PHKK(2,I)**2-PHKK(3,I)**2))
8764 ENDIF
8765 6 CONTINUE
8766
8767 RETURN
8768 END
8769
8770*$ CREATE DT_CROMSC.FOR
8771*COPY DT_CROMSC
8772*
8773*===cromsc=============================================================*
8774*
8775 SUBROUTINE DT_CROMSC(PIN,R,POUT,INCL)
8776
8777************************************************************************
8778* Cronin-Effect. Multiple scattering of one parton passing through *
8779* nuclear matter. *
8780* PIN(4) input 4-momentum of parton *
8781* POUT(4) 4-momentum of parton after mult. scatt. *
8782* R(3) spatial position of parton in target nucleus *
8783* INCL = 1 multiple sc. in projectile *
8784* = 2 multiple sc. in target *
8785* This is a revised version of the original version written by J. Ranft*
8786* This version dated 17.01.95 is written by S. Roesler. *
8787************************************************************************
8788
8789 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8790 SAVE
8791 PARAMETER ( LINP = 10 ,
8792 & LOUT = 6 ,
8793 & LDAT = 9 )
8794 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
8795
8796 LOGICAL LSTART
8797
8798* rejection counter
8799 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
8800 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
8801 & IREXCI(3),IRDIFF(2),IRINC
8802* Glauber formalism: collision properties
8803 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
8804 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
8805* various options for treatment of partons (DTUNUC 1.x)
8806* (chain recombination, Cronin,..)
8807 LOGICAL LCO2CR,LINTPT
8808 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8809 & LCO2CR,LINTPT
8810
8811 DIMENSION PIN(4),POUT(4),R(3)
8812
8813 DATA LSTART /.TRUE./
8814
8815 IRCRON(1) = IRCRON(1)+1
8816
8817 IF (LSTART) THEN
8818 WRITE(LOUT,1000) CRONCO
8819 1000 FORMAT(/,1X,'CROMSC: multiple scattering of chain ends',
8820 & ' treated',/,10X,'with parameter CRONCO = ',F5.2)
8821 LSTART = .FALSE.
8822 ENDIF
8823
8824 NCBACK = 0
8825 RNCL = RPROJ
8826 IF (INCL.EQ.2) RNCL = RTARG
8827
8828* Lorentz-transformation into Lab.
8829 MODE = -(INCL+1)
8830 CALL DT_LTNUC(PIN(3),PIN(4),PZ,PE,MODE)
8831
8832 PTOT = SQRT(PIN(1)**2+PIN(2)**2+PZ**2)
8833 IF (PTOT.LE.8.0D0) GOTO 9997
8834
8835* direction cosines of parton before mult. scattering
8836 COSX = PIN(1)/PTOT
8837 COSY = PIN(2)/PTOT
8838 COSZ = PZ/PTOT
8839
8840 RTESQ = R(1)**2+R(2)**2+R(3)**2-RNCL**2
8841 IF (RTESQ.GE.-TINY3) GOTO 9999
8842
8843* calculate distance (DIST) from R to surface of nucleus (radius RNCL)
8844* in the direction of particle motion
8845
8846 A = COSX*R(1)+COSY*R(2)+COSZ*R(3)
8847 TMP = A**2-RTESQ
8848 IF (TMP.LT.ZERO) GOTO 9998
8849 DIST = -A+SQRT(TMP)
8850
8851* multiple scattering angle
8852 THETO = CRONCO*SQRT(DIST)/PTOT
8853 IF (THETO.GT.0.1D0) THETO=0.1D0
8854
8855 1 CONTINUE
8856* Gaussian sampling of spatial angle
8857 CALL DT_RANNOR(R1,R2)
8858 THETA = ABS(R1*THETO)
8859 IF (THETA.GT.0.3D0) GOTO 9997
8860 CALL DT_DSFECF(SFE,CFE)
8861 COSTH = COS(THETA)
8862 SINTH = SIN(THETA)
8863
8864* new direction cosines
8865 CALL DT_MYTRAN(1,COSX,COSY,COSZ,COSTH,SINTH,SFE,CFE,
8866 & COSXN,COSYN,COSZN)
8867
8868 POUT(1) = COSXN*PTOT
8869 POUT(2) = COSYN*PTOT
8870 PZ = COSZN*PTOT
8871* Lorentz-transformation into nucl.-nucl. cms
8872 MODE = INCL+1
8873 CALL DT_LTNUC(PZ,PE,POUT(3),POUT(4),MODE)
8874
8875C IF (ABS(PIN(4)-POUT(4)).GT.0.2D0) THEN
8876C IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.1D0 ) THEN
8877 IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.05D0 ) THEN
8878 THETO = THETO/2.0D0
8879 NCBACK = NCBACK+1
8880 IF (MOD(NCBACK,200).EQ.0) THEN
8881 WRITE(LOUT,1001) THETO,PIN,POUT
8882 1001 FORMAT(1X,'CROMSC: inconsistent scattering angle ',
8883 & E12.4,/,1X,' PIN :',4E12.4,/,
8884 & 1X,' POUT:',4E12.4)
8885 GOTO 9997
8886 ENDIF
8887 GOTO 1
8888 ENDIF
8889
8890 RETURN
8891
8892 9997 IRCRON(2) = IRCRON(2)+1
8893 GOTO 9999
8894 9998 IRCRON(3) = IRCRON(3)+1
8895
8896 9999 CONTINUE
8897 DO 100 K=1,4
8898 POUT(K) = PIN(K)
8899 100 CONTINUE
8900 RETURN
8901 END
8902
8903*$ CREATE DT_COM2CR.FOR
8904*COPY DT_COM2CR
8905*
8906*===com2sr=============================================================*
8907*
8908 SUBROUTINE DT_COM2CR
8909
8910************************************************************************
8911* COMbine q-aq chains to Color Ropes (qq-aqaq). *
8912* CUTOF parameter determining minimum number of not *
8913* combined q-aq chains *
8914* This subroutine replaces KKEVCC etc. *
8915* This version dated 11.01.95 is written by S. Roesler. *
8916************************************************************************
8917
8918 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8919 SAVE
8920 PARAMETER ( LINP = 10 ,
8921 & LOUT = 6 ,
8922 & LDAT = 9 )
8923
8924* event history
8925 PARAMETER (NMXHKK=200000)
8926 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8927 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8928 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8929* extended event history
8930 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8931 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8932 & IHIST(2,NMXHKK)
8933* statistics
8934 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
8935 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
8936 & ICEVTG(8,0:30)
8937* various options for treatment of partons (DTUNUC 1.x)
8938* (chain recombination, Cronin,..)
8939 LOGICAL LCO2CR,LINTPT
8940 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8941 & LCO2CR,LINTPT
8942
8943 DIMENSION IDXQA(248),IDXAQ(248)
8944
8945 ICCHAI(1,9) = ICCHAI(1,9)+1
8946 NQA = 0
8947 NAQ = 0
8948* scan DTEVT1 for q-aq, aq-q chains
8949 DO 10 I=NPOINT(3),NHKK
8950* skip "chains" which are resonances
8951 IF ((IDHKK(I).EQ.88888).AND.(IDRES(I).EQ.0)) THEN
8952 MO1 = JMOHKK(1,I)
8953 MO2 = JMOHKK(2,I)
8954 IF ((ABS(IDHKK(MO1)).LE.6).AND.(ABS(IDHKK(MO2)).LE.6)) THEN
8955* q-aq, aq-q chain found, keep index
8956 IF (IDHKK(MO1).GT.0) THEN
8957 NQA = NQA+1
8958 IDXQA(NQA) = I
8959 ELSE
8960 NAQ = NAQ+1
8961 IDXAQ(NAQ) = I
8962 ENDIF
8963 ENDIF
8964 ENDIF
8965 10 CONTINUE
8966
8967* minimum number of q-aq chains requested for the same projectile/
8968* target
8969 NCHMIN = IDT_NPOISS(CUTOF)
8970
8971* combine q-aq chains of the same projectile
8972 CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,1)
8973* combine q-aq chains of the same target
8974 CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,2)
8975* combine aq-q chains of the same projectile
8976 CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,1)
8977* combine aq-q chains of the same target
8978 CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,2)
8979
8980 RETURN
8981 END
8982
8983*$ CREATE DT_SCN4CR.FOR
8984*COPY DT_SCN4CR
8985*
8986*===scn4cr=============================================================*
8987*
8988 SUBROUTINE DT_SCN4CR(NCH,IDXCH,NCHMIN,MODE)
8989
8990************************************************************************
8991* SCan q-aq chains for Color Ropes. *
8992* This version dated 11.01.95 is written by S. Roesler. *
8993************************************************************************
8994
8995 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8996 SAVE
8997 PARAMETER ( LINP = 10 ,
8998 & LOUT = 6 ,
8999 & LDAT = 9 )
9000
9001* event history
9002 PARAMETER (NMXHKK=200000)
9003 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9004 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9005 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9006* extended event history
9007 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9008 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9009 & IHIST(2,NMXHKK)
9010
9011 DIMENSION IDXCH(248),IDXJN(248)
9012
9013 DO 1 I=1,NCH
9014 IF (IDXCH(I).GT.0) THEN
9015 NJOIN = 1
9016 IDXMO = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(I))))
9017 IDXJN(NJOIN) = I
9018 IF (I.LT.NCH) THEN
9019 DO 2 J=I+1,NCH
9020 IF (IDXCH(J).GT.0) THEN
9021 IDXMO1 = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(J))))
9022 IF (IDXMO.EQ.IDXMO1) THEN
9023 NJOIN = NJOIN+1
9024 IDXJN(NJOIN) = J
9025 ENDIF
9026 ENDIF
9027 2 CONTINUE
9028 ENDIF
9029 IF (NJOIN.GE.NCHMIN+2) THEN
9030 NJ = INT(DBLE(NJOIN-NCHMIN)/2.0D0)
9031 DO 3 J=1,2*NJ,2
9032 CALL DT_JOIN(IDXCH(IDXJN(J)),IDXCH(IDXJN(J+1)),IREJ1)
9033 IF (IREJ1.NE.0) GOTO 3
9034 IDXCH(IDXJN(J)) = 0
9035 IDXCH(IDXJN(J+1)) = 0
9036 3 CONTINUE
9037 ENDIF
9038 ENDIF
9039 1 CONTINUE
9040
9041 RETURN
9042 END
9043
9044*$ CREATE DT_JOIN.FOR
9045*COPY DT_JOIN
9046*
9047*===join===============================================================*
9048*
9049 SUBROUTINE DT_JOIN(IDX1,IDX2,IREJ)
9050
9051************************************************************************
9052* This subroutine joins two q-aq chains to one qq-aqaq chain. *
9053* IDX1, IDX2 DTEVT1 indices of chains to be joined *
9054* This version dated 11.01.95 is written by S. Roesler. *
9055************************************************************************
9056
9057 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9058 SAVE
9059 PARAMETER ( LINP = 10 ,
9060 & LOUT = 6 ,
9061 & LDAT = 9 )
9062
9063* event history
9064 PARAMETER (NMXHKK=200000)
9065 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9066 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9067 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9068* extended event history
9069 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9070 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9071 & IHIST(2,NMXHKK)
9072* flags for input different options
9073 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
9074 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
9075 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
9076* statistics
9077 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9078 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9079 & ICEVTG(8,0:30)
9080
9081 DIMENSION MO(2,2),ID(2,2),IDX(2),PCH(4),PP(4),PT(4),P1(4),P2(4)
9082
9083 IREJ = 0
9084
9085 IDX(1) = IDX1
9086 IDX(2) = IDX2
9087 DO 1 I=1,2
9088 DO 2 J=1,2
9089 MO(I,J) = JMOHKK(J,IDX(I))
9090 ID(I,J) = IDT_IPDG2B(IDHKK(MO(I,J)),1,2)
9091 2 CONTINUE
9092 1 CONTINUE
9093
9094* check consistency
9095 IF ((ABS(ID(1,1)).GT.6).OR.(ABS(ID(1,2)).GT.6).OR.
9096 & (ABS(ID(2,1)).GT.6).OR.(ABS(ID(2,2)).GT.6).OR.
9097 & ((ID(1,1)*ID(2,1)).LT.0).OR.
9098 & ((ID(1,2)*ID(2,2)).LT.0)) THEN
9099 WRITE(LOUT,1000) IDX(1),MO(1,1),MO(1,2),IDX(2),MO(2,1),
9100 & MO(2,2)
9101 1000 FORMAT(1X,'JOIN: incons. chain system! chain ',I4,':',
9102 & 2I5,' chain ',I4,':',2I5)
9103 ENDIF
9104
9105* join chains
9106 DO 3 K=1,4
9107 PP(K) = PHKK(K,MO(1,1))+PHKK(K,MO(2,1))
9108 PT(K) = PHKK(K,MO(1,2))+PHKK(K,MO(2,2))
9109 3 CONTINUE
9110 IF1 = IDT_IB2PDG(ID(1,1),ID(2,1),2)
9111 IF2 = IDT_IB2PDG(ID(1,2),ID(2,2),2)
9112 IST1 = ISTHKK(MO(1,1))
9113 IST2 = ISTHKK(MO(1,2))
9114
9115* put partons again on mass shell
9116 XM1 = 0.0D0
9117 XM2 = 0.0D0
9118 IF (IMSHL.EQ.1) THEN
9119 XM1 = PYMASS(IF1)
9120 XM2 = PYMASS(IF2)
9121 ENDIF
9122 CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1)
9123 IF (IREJ1.NE.0) GOTO 9999
9124 DO 4 I=1,4
9125 PP(I) = P1(I)
9126 PT(I) = P2(I)
9127 4 CONTINUE
9128
9129* store new partons in DTEVT1
9130 CALL DT_EVTPUT(IST1,IF1,MO(1,1),MO(2,1),PP(1),PP(2),PP(3),PP(4),
9131 & 0,0,0)
9132 CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4),
9133 & 0,0,0)
9134 DO 5 K=1,4
9135 PCH(K) = PP(K)+PT(K)
9136 5 CONTINUE
9137
9138* check new chain for lower mass limit
9139 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
9140 AMCH = SQRT(ABS(PCH(4)**2-PCH(1)**2-PCH(2)**2-PCH(3)**2))
9141 CALL DT_CH2RES(ID(1,1),ID(2,1),ID(1,2),ID(2,2),IDUM,IDUM,
9142 & AMCH,AMCHN,3,IREJ1)
9143 IF (IREJ1.NE.0) THEN
9144 NHKK = NHKK-2
9145 GOTO 9999
9146 ENDIF
9147 ENDIF
9148
9149 ICCHAI(2,9) = ICCHAI(2,9)+1
9150* store new chain in DTEVT1
9151 KCH = 191
9152 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),0,0,9)
9153 IDHKK(IDX(1)) = 22222
9154 IDHKK(IDX(2)) = 22222
9155* special treatment for space-time coordinates
9156 DO 6 K=1,4
9157 VHKK(K,NHKK) = (VHKK(K,IDX(1))+VHKK(K,IDX(2)))/2.0D0
9158 WHKK(K,NHKK) = (WHKK(K,IDX(1))+WHKK(K,IDX(2)))/2.0D0
9159 6 CONTINUE
9160 RETURN
9161
9162 9999 CONTINUE
9163 IREJ = 1
9164 RETURN
9165 END
9166
9167*$ CREATE DT_XSGLAU.FOR
9168*COPY DT_XSGLAU
9169*
9170*===xsglau=============================================================*
9171*
9172 SUBROUTINE DT_XSGLAU(NA,NB,JJPROJ,XI,Q2I,ECMI,IE,IQ,NIDX)
9173
9174************************************************************************
9175* Total, elastic, quasi-elastic, inelastic cross sections according to *
9176* Glauber's approach. *
9177* NA / NB mass numbers of proj./target nuclei *
9178* JJPROJ bamjet-index of projectile (=1 in case of proj.nucleus) *
9179* XI,Q2I,ECMI kinematical variables x, Q^2, E_cm *
9180* IE,IQ indices of energy and virtuality (the latter for gamma *
9181* projectiles only) *
9182* NIDX index of projectile/target nucleus *
9183* This version dated 17.3.98 is written by S. Roesler *
9184************************************************************************
9185
9186 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9187 SAVE
9188 PARAMETER ( LINP = 10 ,
9189 & LOUT = 6 ,
9190 & LDAT = 9 )
9191
9192 COMPLEX*16 CZERO,CONE,CTWO
9193 CHARACTER*12 CFILE
9194 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
9195 & ONETHI=ONE/THREE,TINY25=1.0D-25)
9196 PARAMETER (TWOPI = 6.283185307179586454D+00,
9197 & PI = TWOPI/TWO,
9198 & GEV2MB = 0.38938D0,
9199 & GEV2FM = 0.1972D0,
9200 & ALPHEM = ONE/137.0D0,
9201* proton mass
9202 & AMP = 0.938D0,
9203 & AMP2 = AMP**2,
9204* approx. nucleon radius
9205 & RNUCLE = 1.12D0)
9206
9207* particle properties (BAMJET index convention)
9208 CHARACTER*8 ANAME
9209 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
9210 & IICH(210),IIBAR(210),K1(210),K2(210)
9211 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
9212 PARAMETER ( MAXNCL = 260,
9213 & MAXVQU = MAXNCL,
9214 & MAXSQU = 20*MAXVQU,
9215 & MAXINT = MAXVQU+MAXSQU)
9216* Glauber formalism: parameters
9217 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
9218 & BMAX(NCOMPX),BSTEP(NCOMPX),
9219 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
9220 & NSITEB,NSTATB
9221* Glauber formalism: cross sections
9222 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
9223 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
9224 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
9225 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
9226 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
9227 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
9228 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
9229 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
9230 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
9231 & BSLOPE,NEBINI,NQBINI
9232* Glauber formalism: flags and parameters for statistics
9233 LOGICAL LPROD
9234 CHARACTER*8 CGLB
9235 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
9236* nucleon-nucleon event-generator
9237 CHARACTER*8 CMODEL
9238 LOGICAL LPHOIN
9239 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
9240* VDM parameter for photon-nucleus interactions
9241 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
9242* parameters for hA-diffraction
9243 COMMON /DTDIHA/ DIBETA,DIALPH
9244
9245 COMPLEX*16 PP11(MAXNCL),PP12(MAXNCL),PP21(MAXNCL),PP22(MAXNCL),
9246 & OMPP11,OMPP12,OMPP21,OMPP22,
9247 & DIPP11,DIPP12,DIPP21,DIPP22,AVDIPP,
9248 & PPTMP1,PPTMP2
9249 COMPLEX*16 C,CA,CI
9250 DIMENSION COOP1(3,MAXNCL),COOT1(3,MAXNCL),
9251 & COOP2(3,MAXNCL),COOT2(3,MAXNCL),
9252 & BPROD(KSITEB)
9253
9254 PARAMETER (NPOINT=16)
9255 DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
9256
9257 LOGICAL LFIRST,LOPEN
9258 DATA LFIRST,LOPEN /.TRUE.,.FALSE./
9259
9260 NTARG = ABS(NIDX)
9261* for quasi-elastic neutrino scattering set projectile to proton
9262* it should not have an effect since the whole Glauber-formalism is
9263* not needed for these interactions..
9264 IF (MCGENE.EQ.4) THEN
9265 IJPROJ = 1
9266 ELSE
9267 IJPROJ = JJPROJ
9268 ENDIF
9269
9270 IF ((ABS(IOGLB).EQ.1).AND.(.NOT.LOPEN)) THEN
9271 I = INDEX(CGLB,' ')
9272 IF (I.EQ.0) THEN
9273 CFILE = CGLB//'.glb'
9274 OPEN(LDAT,FILE=CGLB//'.glb',STATUS='UNKNOWN')
9275 ELSEIF (I.GT.1) THEN
9276 CFILE = CGLB(1:I-1)//'.glb'
9277 OPEN(LDAT,FILE=CGLB(1:I-1)//'.glb',STATUS='UNKNOWN')
9278 ELSE
9279 STOP 'XSGLAU 1'
9280 ENDIF
9281 LOPEN = .TRUE.
9282 ENDIF
9283
9284 CZERO = DCMPLX(ZERO,ZERO)
9285 CONE = DCMPLX(ONE,ZERO)
9286 CTWO = DCMPLX(TWO,ZERO)
9287 NEBINI = IE
9288 NQBINI = IQ
9289
9290* re-define kinematics
9291 S = ECMI**2
9292 Q2 = Q2I
9293 X = XI
9294* g(Q2=0)-A, h-A, A-A scattering
9295 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9296 Q2 = 0.0001D0
9297 X = Q2/(S+Q2-AMP2)
9298* g(Q2>0)-A scattering
9299 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(S.GT.ZERO)) THEN
9300 X = Q2/(S+Q2-AMP2)
9301 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9302 Q2 = (S-AMP2)*X/(ONE-X)
9303 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
9304 S = Q2*(ONE-X)/X+AMP2
9305 ELSE
9306 WRITE(LOUT,*) 'XSGLAU: inconsistent input ',S,Q2,X
9307 STOP
9308 ENDIF
9309 ECMNN(IE) = SQRT(S)
9310 Q2G(IQ) = Q2
9311 XNU = (S+Q2-AMP2)/(TWO*AMP)
9312
9313* parameters determining statistics in evaluating Glauber-xsection
9314 NSTATB = JSTATB
9315 NSITEB = JBINSB
9316 IF (NSITEB.GT.KSITEB) NSITEB = KSITEB
9317
9318* set up interaction geometry (common /DTGLAM/)
9319* projectile/target radii
9320 RPRNCL = DT_RNCLUS(NA)
9321 RTANCL = DT_RNCLUS(NB)
9322 IF (IJPROJ.EQ.7) THEN
9323 RASH(1) = ZERO
9324 RBSH(NTARG) = RTANCL
9325 BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9326 ELSE
9327 IF (NIDX.LE.-1) THEN
9328 RASH(1) = RPRNCL
9329 RBSH(NTARG) = RTANCL
9330 BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9331 ELSE
9332 RASH(NTARG) = RPRNCL
9333 RBSH(1) = RTANCL
9334 BMAX(NTARG) = 2.0D0*(RASH(NTARG)+RBSH(1))
9335 ENDIF
9336 ENDIF
9337* maximum impact-parameter
9338 BSTEP(NTARG)= BMAX(NTARG)/DBLE(NSITEB-1)
9339
9340* slope, rho ( Re(f(0))/Im(f(0)) )
9341 IF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
9342 IF (MCGENE.EQ.2) THEN
9343 ZERO1 = ZERO
9344 CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,SDUM1,SDUM2,SDUM3,
9345 & BSLOPE,0)
9346 ELSE
9347 BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
9348 ENDIF
9349 IF (ECMNN(IE).LE.3.0D0) THEN
9350 ROSH = -0.43D0
9351 ELSEIF ((ECMNN(IE).GT.3.0D0).AND.(ECMNN(IE).LE.50.D0)) THEN
9352 ROSH = -0.63D0+0.175D0*LOG(ECMNN(IE))
9353 ELSEIF (ECMNN(IE).GT.50.0D0) THEN
9354 ROSH = 0.1D0
9355 ENDIF
9356 ELSEIF (IJPROJ.EQ.7) THEN
9357 ROSH = 0.1D0
9358 ELSE
9359 BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
9360 ROSH = 0.01D0
9361 ENDIF
9362
9363* projectile-nucleon xsection (in fm)
9364 IF (IJPROJ.EQ.7) THEN
9365 SIGSH = DT_SIGVP(X,Q2)/10.0D0
9366 ELSE
9367 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
9368 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
9369C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
9370 DUMZER = ZERO
9371 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
9372 SIGSH = SIGSH/10.0D0
9373 ENDIF
9374
9375* parameters for projectile diffraction (hA scattering only)
9376 IF ((MCGENE.EQ.2).AND.(NA.EQ.1).AND.(NB.GT.1).AND.(IJPROJ.NE.7)
9377 & .AND.(DIBETA.GE.ZERO)) THEN
9378 ZERO1 = ZERO
9379 CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,STOT,SDUM2,SDIF1,BDUM,0)
9380C DIBETA = SDIF1/STOT
9381 DIBETA = 0.2D0
9382 DIGAMM = SQRT(DIALPH**2+DIBETA**2)
9383 IF (DIBETA.LE.ZERO) THEN
9384 ALPGAM = ONE
9385 ELSE
9386 ALPGAM = DIALPH/DIGAMM
9387 ENDIF
9388 FACDI1 = ONE-ALPGAM
9389 FACDI2 = ONE+ALPGAM
9390 FACDI = SQRT(FACDI1*FACDI2)
9391 WRITE(LOUT,*)'DIBETA,DIALPH,DIGAMM: ',DIBETA,DIALPH,DIGAMM
9392 ELSE
9393 DIBETA = -1.0D0
9394 DIALPH = ZERO
9395 DIGAMM = ZERO
9396 FACDI1 = ZERO
9397 FACDI2 = 2.0D0
9398 FACDI = ZERO
9399 ENDIF
9400
9401* initializations
9402 DO 10 I=1,NSITEB
9403 BSITE( 0,IQ,NTARG,I) = ZERO
9404 BSITE(IE,IQ,NTARG,I) = ZERO
9405 BPROD(I) = ZERO
9406 10 CONTINUE
9407 STOT = ZERO
9408 STOT2 = ZERO
9409 SELA = ZERO
9410 SELA2 = ZERO
9411 SQEP = ZERO
9412 SQEP2 = ZERO
9413 SQET = ZERO
9414 SQET2 = ZERO
9415 SQE2 = ZERO
9416 SQE22 = ZERO
9417 SPRO = ZERO
9418 SPRO2 = ZERO
9419 SDEL = ZERO
9420 SDEL2 = ZERO
9421 SDQE = ZERO
9422 SDQE2 = ZERO
9423 FACN = ONE/DBLE(NSTATB)
9424
9425 IPNT = 0
9426 RPNT = ZERO
9427
9428* initialize Gauss-integration for photon-proj.
9429 JPOINT = 1
9430 IF (IJPROJ.EQ.7) THEN
9431 IF (INTRGE(1).EQ.1) THEN
9432 AMLO2 = (3.0D0*AAM(13))**2
9433 ELSEIF (INTRGE(1).EQ.2) THEN
9434 AMLO2 = AAM(33)**2
9435 ELSE
9436 AMLO2 = AAM(96)**2
9437 ENDIF
9438 IF (INTRGE(2).EQ.1) THEN
9439 AMHI2 = S/TWO
9440 ELSEIF (INTRGE(2).EQ.2) THEN
9441 AMHI2 = S/4.0D0
9442 ELSE
9443 AMHI2 = S
9444 ENDIF
9445 AMHI20 = (ECMNN(IE)-AMP)**2
9446 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
9447 XAMLO = LOG( AMLO2+Q2 )
9448 XAMHI = LOG( AMHI2+Q2 )
9449**PHOJET105a
9450C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9451**PHOJET112
9452 CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9453**
9454 JPOINT = NPOINT
9455* ratio direct/total photon-nucleon xsection
9456 CALL DT_POILIK(NB,NTARG,ECMNN(IE),Q2,IPNT,RPNT,1)
9457 ENDIF
9458
9459* read pre-initialized profile-function from file
9460 IF (IOGLB.EQ.1) THEN
9461 READ(LDAT,'(5I10,E15.5)') KJPROJ,IA,IB,ISTATB,ISITEB,DUM
9462 IF ((IA.NE.NA).OR.(IB.NE.NB)) THEN
9463 WRITE(LOUT,1000) CFILE,IA,IB,ISTATB,ISITEB,
9464 & NA,NB,NSTATB,NSITEB
9465 1000 FORMAT(' XSGLAU: inconsistent input data in file ',A12,/,
9466 & ' (IA,IB,ISTATB,ISITEB) ',4I10,/,
9467 & ' (NA,NB,NSTATB,NSITEB) ',4I10)
9468 STOP
9469 ENDIF
9470 IF (LFIRST) WRITE(LOUT,1001) CFILE
9471 1001 FORMAT(/,' XSGLAU: impact parameter distribution read from ',
9472 & 'file ',A12,/)
9473 READ(LDAT,'(6E12.5)') XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),
9474 & XSQEP(IE,IQ,NTARG),XSQET(IE,IQ,NTARG),
9475 & XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
9476 READ(LDAT,'(6E12.5)') XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),
9477 & XEQEP(IE,IQ,NTARG),XEQET(IE,IQ,NTARG),
9478 & XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
9479 NLINES = INT(DBLE(NSITEB)/7.0D0)
9480 IF (NLINES.GT.0) THEN
9481 DO 21 I=1,NLINES
9482 ISTART = 7*I-6
9483 READ(LDAT,'(7E11.4)')
9484 & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
9485 21 CONTINUE
9486 ENDIF
9487 ISTART = 7*NLINES+1
9488 IF (ISTART.LE.NSITEB) THEN
9489 READ(LDAT,'(7E11.4)')
9490 & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
9491 ENDIF
9492 LFIRST = .FALSE.
9493 GOTO 100
9494* variable projectile/target/energy runs:
9495* read pre-initialized profile-functions from file
9496 ELSEIF (IOGLB.EQ.100) THEN
9497 CALL DT_GLBSET(IJPROJ,IINA,IINB,RRELAB,0)
9498 GOTO 100
9499 ENDIF
9500
9501* cross sections averaged over NSTATB nucleon configurations
9502 DO 11 IS=1,NSTATB
9503C IF ((NA.EQ.207).AND.(NB.EQ.207)) WRITE(LOUT,*) 'conf. ',IS
9504 STOTN = ZERO
9505 SELAN = ZERO
9506 SQEPN = ZERO
9507 SQETN = ZERO
9508 SQE2N = ZERO
9509 SPRON = ZERO
9510 SDELN = ZERO
9511 SDQEN = ZERO
9512
9513 IF (NIDX.LE.-1) THEN
9514 CALL DT_CONUCL(COOP1,NA,RASH(1),0)
9515 CALL DT_CONUCL(COOT1,NB,RBSH(NTARG),1)
9516 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9517 CALL DT_CONUCL(COOP2,NA,RASH(1),0)
9518 CALL DT_CONUCL(COOT2,NB,RBSH(NTARG),1)
9519 ENDIF
9520 ELSE
9521 CALL DT_CONUCL(COOP1,NA,RASH(NTARG),0)
9522 CALL DT_CONUCL(COOT1,NB,RBSH(1),1)
9523 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9524 CALL DT_CONUCL(COOP2,NA,RASH(NTARG),0)
9525 CALL DT_CONUCL(COOT2,NB,RBSH(1),1)
9526 ENDIF
9527 ENDIF
9528
9529* integration over impact parameter B
9530 DO 12 IB=1,NSITEB-1
9531 STOTB = ZERO
9532 SELAB = ZERO
9533 SQEPB = ZERO
9534 SQETB = ZERO
9535 SQE2B = ZERO
9536 SPROB = ZERO
9537 SDIR = ZERO
9538 SDELB = ZERO
9539 SDQEB = ZERO
9540 B = DBLE(IB)*BSTEP(NTARG)
9541 FACB = 10.0D0*TWOPI*B*BSTEP(NTARG)
9542
9543* integration over M_V^2 for photon-proj.
9544 DO 14 IM=1,JPOINT
9545 PP11(1) = CONE
9546 PP12(1) = CONE
9547 PP21(1) = CONE
9548 PP22(1) = CONE
9549 IF (IJPROJ.EQ.7) THEN
9550 DO 13 K=2,NB
9551 PP11(K) = CONE
9552 PP12(K) = CONE
9553 PP21(K) = CONE
9554 PP22(K) = CONE
9555 13 CONTINUE
9556 ENDIF
9557 SHI = ZERO
9558 FACM = ONE
9559 DCOH = 1.0D10
9560
9561 IF (IJPROJ.EQ.7) THEN
9562 AMV2 = EXP(ABSZX(IM))-Q2
9563 AMV = SQRT(AMV2)
9564 IF (AMV2.LT.16.0D0) THEN
9565 R = TWO
9566 ELSEIF ((AMV2.GE.16.0D0).AND.(AMV2.LT.121.0D0)) THEN
9567 R = 10.0D0/3.0D0
9568 ELSE
9569 R = 11.0D0/3.0D0
9570 ENDIF
9571* define M_V dependent properties of nucleon scattering amplitude
9572* V_M-nucleon xsection
9573 SIGMVD = RPNT*SIGSH/(AMV2+Q2+RL2)*10.0D0
9574 SIGMV = (ONE-RPNT)*SIGSH/(AMV2+Q2+RL2)
9575* slope-parametrisation a la Kaidalov
9576 BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
9577 & +0.25D0*LOG(S/(AMV2+Q2)))
9578* coherence length
9579 IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+Q2)*GEV2FM
9580* integration weight factor
9581 FACM = ALPHEM/(3.0D0*PI*(ONE-X))*
9582 & R*AMV2/(AMV2+Q2)*(ONE+EPSPOL*Q2/AMV2)*WEIGHT(IM)
9583 ENDIF
9584 GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
9585 GAM = GSH
9586 IF (IJPROJ.EQ.7) THEN
9587 RCA = GAM*SIGMV/TWOPI
9588 ELSE
9589 RCA = GAM*SIGSH/TWOPI
9590 ENDIF
9591 FCA = -ROSH*RCA
9592 CA = DCMPLX(RCA,FCA)
9593 CI = CONE
9594
9595 DO 15 INA=1,NA
9596 KK1 = 1
9597 INT1 = 1
9598 KK2 = 1
9599 INT2 = 1
9600 DO 16 INB=1,NB
9601* photon-projectile: check for supression by coherence length
9602 IF (IJPROJ.EQ.7) THEN
9603 IF (ABS(COOT1(3,INB)-COOT1(3,KK1)).GT.DCOH)THEN
9604 KK1 = INB
9605 INT1 = INT1+1
9606 ENDIF
9607 IF (ABS(COOT2(3,INB)-COOT2(3,KK2)).GT.DCOH)THEN
9608 KK2 = INB
9609 INT2 = INT2+1
9610 ENDIF
9611 ENDIF
9612
9613 X11 = B+COOT1(1,INB)-COOP1(1,INA)
9614 Y11 = COOT1(2,INB)-COOP1(2,INA)
9615 XY11 = GAM*(X11*X11+Y11*Y11)
9616 IF (XY11.LE.15.0D0) THEN
9617 C = CONE-CA*EXP(-XY11)
9618 AR = DBLE(PP11(INT1))
9619 AI = DIMAG(PP11(INT1))
9620 IF (ABS(AR).LT.TINY25) AR = ZERO
9621 IF (ABS(AI).LT.TINY25) AI = ZERO
9622 PP11(INT1) = DCMPLX(AR,AI)
9623 PP11(INT1) = PP11(INT1)*C
9624 AR = DBLE(C)
9625 AI = DIMAG(C)
9626 SHI = SHI+LOG(AR*AR+AI*AI)
9627 ENDIF
9628 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9629 X12 = B+COOT2(1,INB)-COOP1(1,INA)
9630 Y12 = COOT2(2,INB)-COOP1(2,INA)
9631 XY12 = GAM*(X12*X12+Y12*Y12)
9632 IF (XY12.LE.15.0D0) THEN
9633 C = CONE-CA*EXP(-XY12)
9634 AR = DBLE(PP12(INT2))
9635 AI = DIMAG(PP12(INT2))
9636 IF (ABS(AR).LT.TINY25) AR = ZERO
9637 IF (ABS(AI).LT.TINY25) AI = ZERO
9638 PP12(INT2) = DCMPLX(AR,AI)
9639 PP12(INT2) = PP12(INT2)*C
9640 ENDIF
9641 X21 = B+COOT1(1,INB)-COOP2(1,INA)
9642 Y21 = COOT1(2,INB)-COOP2(2,INA)
9643 XY21 = GAM*(X21*X21+Y21*Y21)
9644 IF (XY21.LE.15.0D0) THEN
9645 C = CONE-CA*EXP(-XY21)
9646 AR = DBLE(PP21(INT1))
9647 AI = DIMAG(PP21(INT1))
9648 IF (ABS(AR).LT.TINY25) AR = ZERO
9649 IF (ABS(AI).LT.TINY25) AI = ZERO
9650 PP21(INT1) = DCMPLX(AR,AI)
9651 PP21(INT1) = PP21(INT1)*C
9652 ENDIF
9653 X22 = B+COOT2(1,INB)-COOP2(1,INA)
9654 Y22 = COOT2(2,INB)-COOP2(2,INA)
9655 XY22 = GAM*(X22*X22+Y22*Y22)
9656 IF (XY22.LE.15.0D0) THEN
9657 C = CONE-CA*EXP(-XY22)
9658 AR = DBLE(PP22(INT2))
9659 AI = DIMAG(PP22(INT2))
9660 IF (ABS(AR).LT.TINY25) AR = ZERO
9661 IF (ABS(AI).LT.TINY25) AI = ZERO
9662 PP22(INT2) = DCMPLX(AR,AI)
9663 PP22(INT2) = PP22(INT2)*C
9664 ENDIF
9665 ENDIF
9666 16 CONTINUE
9667 15 CONTINUE
9668
9669 OMPP11 = CZERO
9670 OMPP21 = CZERO
9671 DIPP11 = CZERO
9672 DIPP21 = CZERO
9673 DO 17 K=1,INT1
9674 IF (PP11(K).EQ.CZERO) THEN
9675 PPTMP1 = CZERO
9676 PPTMP2 = CZERO
9677 ELSE
9678 PPTMP1 = PP11(K)**(ONE-DIALPH-DIGAMM)
9679 PPTMP2 = PP11(K)**(ONE-DIALPH+DIGAMM)
9680 ENDIF
9681 AVDIPP = 0.5D0*
9682 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9683 OMPP11 = OMPP11+AVDIPP
9684C OMPP11 = OMPP11+(CONE-PP11(K))
9685 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9686 DIPP11 = DIPP11+AVDIPP
9687 IF (PP21(K).EQ.CZERO) THEN
9688 PPTMP1 = CZERO
9689 PPTMP2 = CZERO
9690 ELSE
9691 PPTMP1 = PP21(K)**(ONE-DIALPH-DIGAMM)
9692 PPTMP2 = PP21(K)**(ONE-DIALPH+DIGAMM)
9693 ENDIF
9694 AVDIPP = 0.5D0*
9695 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9696 OMPP21 = OMPP21+AVDIPP
9697C OMPP21 = OMPP21+(CONE-PP21(K))
9698 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9699 DIPP21 = DIPP21+AVDIPP
9700 17 CONTINUE
9701 OMPP12 = CZERO
9702 OMPP22 = CZERO
9703 DIPP12 = CZERO
9704 DIPP22 = CZERO
9705 DO 18 K=1,INT2
9706 IF (PP12(K).EQ.CZERO) THEN
9707 PPTMP1 = CZERO
9708 PPTMP2 = CZERO
9709 ELSE
9710 PPTMP1 = PP12(K)**(ONE-DIALPH-DIGAMM)
9711 PPTMP2 = PP12(K)**(ONE-DIALPH+DIGAMM)
9712 ENDIF
9713 AVDIPP = 0.5D0*
9714 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9715 OMPP12 = OMPP12+AVDIPP
9716C OMPP12 = OMPP12+(CONE-PP12(K))
9717 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9718 DIPP12 = DIPP12+AVDIPP
9719 IF (PP22(K).EQ.CZERO) THEN
9720 PPTMP1 = CZERO
9721 PPTMP2 = CZERO
9722 ELSE
9723 PPTMP1 = PP22(K)**(ONE-DIALPH-DIGAMM)
9724 PPTMP2 = PP22(K)**(ONE-DIALPH+DIGAMM)
9725 ENDIF
9726 AVDIPP = 0.5D0*
9727 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9728 OMPP22 = OMPP22+AVDIPP
9729C OMPP22 = OMPP22+(CONE-PP22(K))
9730 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9731 DIPP22 = DIPP22+AVDIPP
9732 18 CONTINUE
9733
9734 SPROM = ONE-EXP(SHI)
9735 SPROB = SPROB+FACM*SPROM
9736 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9737 STOTM = DBLE(OMPP11+OMPP22)
9738 SELAM = DBLE(OMPP11*DCONJG(OMPP22))
9739 SQEPM = DBLE(OMPP11*DCONJG(OMPP21))-SELAM
9740 SQETM = DBLE(OMPP11*DCONJG(OMPP12))-SELAM
9741 SQE2M = DBLE(OMPP11*DCONJG(OMPP11))-SELAM-SQEPM-SQETM
9742 SDELM = DBLE(DIPP11*DCONJG(DIPP22))
9743 SDQEM = DBLE(DIPP11*DCONJG(DIPP21))-SDELM
9744 STOTB = STOTB+FACM*STOTM
9745 SELAB = SELAB+FACM*SELAM
9746 SDELB = SDELB+FACM*SDELM
9747 IF (NB.GT.1) THEN
9748 SQEPB = SQEPB+FACM*SQEPM
9749 SDQEB = SDQEB+FACM*SDQEM
9750 ENDIF
9751 IF (NA.GT.1) SQETB = SQETB+FACM*SQETM
9752 IF ((NA.GT.1).AND.(NB.GT.1)) SQE2B = SQE2B+FACM*SQE2M
9753 IF (IJPROJ.EQ.7) SDIR = SDIR+FACM*SIGMVD
9754 ENDIF
9755
9756 14 CONTINUE
9757
9758 STOTN = STOTN+FACB*STOTB
9759 SELAN = SELAN+FACB*SELAB
9760 SQEPN = SQEPN+FACB*SQEPB
9761 SQETN = SQETN+FACB*SQETB
9762 SQE2N = SQE2N+FACB*SQE2B
9763 SPRON = SPRON+FACB*SPROB
9764 SDELN = SDELN+FACB*SDELB
9765 SDQEN = SDQEN+FACB*SDQEB
9766
9767 IF (IJPROJ.EQ.7) THEN
9768 BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*(STOTB-SELAB-SQEPB)
9769 ELSE
9770 IF (DIBETA.GT.ZERO) THEN
9771 BPROD(IB+1)= BPROD(IB+1)
9772 & +FACN*FACB*(STOTB-SELAB-SQEPB-SQETB-SQE2B)
9773 ELSE
9774 BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*SPROB
9775 ENDIF
9776 ENDIF
9777
9778 12 CONTINUE
9779
9780 STOT = STOT +FACN*STOTN
9781 STOT2 = STOT2+FACN*STOTN**2
9782 SELA = SELA +FACN*SELAN
9783 SELA2 = SELA2+FACN*SELAN**2
9784 SQEP = SQEP +FACN*SQEPN
9785 SQEP2 = SQEP2+FACN*SQEPN**2
9786 SQET = SQET +FACN*SQETN
9787 SQET2 = SQET2+FACN*SQETN**2
9788 SQE2 = SQE2 +FACN*SQE2N
9789 SQE22 = SQE22+FACN*SQE2N**2
9790 SPRO = SPRO +FACN*SPRON
9791 SPRO2 = SPRO2+FACN*SPRON**2
9792 SDEL = SDEL +FACN*SDELN
9793 SDEL2 = SDEL2+FACN*SDELN**2
9794 SDQE = SDQE +FACN*SDQEN
9795 SDQE2 = SDQE2+FACN*SDQEN**2
9796
9797 11 CONTINUE
9798
9799* final cross sections
9800* 1) total
9801 XSTOT(IE,IQ,NTARG) = STOT
9802 IF (IJPROJ.EQ.7)
9803 & XSTOT(IE,IQ,NTARG) = XSTOT(IE,IQ,NTARG)+DBLE(NB)*SDIR
9804* 2) elastic
9805 XSELA(IE,IQ,NTARG) = SELA
9806* 3) quasi-el.: A+B-->A+X (excluding 2)
9807 XSQEP(IE,IQ,NTARG) = SQEP
9808* 4) quasi-el.: A+B-->X+B (excluding 2)
9809 XSQET(IE,IQ,NTARG) = SQET
9810* 5) quasi-el.: A+B-->X (excluding 2-4)
9811 XSQE2(IE,IQ,NTARG) = SQE2
9812* 6) production (= STOT-SELA-SQEP-SQET-SQE2!)
9813 IF (SDEL.GT.ZERO) THEN
9814 XSPRO(IE,IQ,NTARG) = STOT-SELA-SQEP-SQET-SQE2
9815 ELSE
9816 XSPRO(IE,IQ,NTARG) = SPRO
9817 ENDIF
9818* 7) projectile diffraction (el. scatt. off target)
9819 XSDEL(IE,IQ,NTARG) = SDEL
9820* 8) projectile diffraction (quasi-el. scatt. off target)
9821 XSDQE(IE,IQ,NTARG) = SDQE
9822* stat. errors
9823 XETOT(IE,IQ,NTARG) = SQRT(ABS(STOT2-STOT**2)/DBLE(NSTATB-1))
9824 XEELA(IE,IQ,NTARG) = SQRT(ABS(SELA2-SELA**2)/DBLE(NSTATB-1))
9825 XEQEP(IE,IQ,NTARG) = SQRT(ABS(SQEP2-SQEP**2)/DBLE(NSTATB-1))
9826 XEQET(IE,IQ,NTARG) = SQRT(ABS(SQET2-SQET**2)/DBLE(NSTATB-1))
9827 XEQE2(IE,IQ,NTARG) = SQRT(ABS(SQE22-SQE2**2)/DBLE(NSTATB-1))
9828 XEPRO(IE,IQ,NTARG) = SQRT(ABS(SPRO2-SPRO**2)/DBLE(NSTATB-1))
9829 XEDEL(IE,IQ,NTARG) = SQRT(ABS(SDEL2-SDEL**2)/DBLE(NSTATB-1))
9830 XEDQE(IE,IQ,NTARG) = SQRT(ABS(SDQE2-SDQE**2)/DBLE(NSTATB-1))
9831
9832 IF (IJPROJ.EQ.7) THEN
9833 BNORM = XSTOT(IE,IQ,NTARG)-XSELA(IE,IQ,NTARG)
9834 & -XSQEP(IE,IQ,NTARG)
9835 ELSE
9836 BNORM = XSPRO(IE,IQ,NTARG)
9837 ENDIF
9838 DO 19 I=2,NSITEB
9839 BSITE(IE,IQ,NTARG,I) = BPROD(I)/BNORM+BSITE(IE,IQ,NTARG,I-1)
9840 IF ((IE.EQ.1).AND.(IQ.EQ.1))
9841 & BSITE(0,1,NTARG,I) = BPROD(I)/BNORM+BSITE(0,1,NTARG,I-1)
9842 19 CONTINUE
9843
9844* write profile function data into file
9845 IF ((IOGLB.EQ.-1).OR.(IOGLB.EQ.-100)) THEN
9846 WRITE(LDAT,'(5I10,1P,E15.5)')
9847 & IJPROJ,NA,NB,NSTATB,NSITEB,ECMNN(IE)
9848 WRITE(LDAT,'(1P,6E12.5)')
9849 & XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),XSQEP(IE,IQ,NTARG),
9850 & XSQET(IE,IQ,NTARG),XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
9851 WRITE(LDAT,'(1P,6E12.5)')
9852 & XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),XEQEP(IE,IQ,NTARG),
9853 & XEQET(IE,IQ,NTARG),XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
9854 NLINES = INT(DBLE(NSITEB)/7.0D0)
9855 IF (NLINES.GT.0) THEN
9856 DO 20 I=1,NLINES
9857 ISTART = 7*I-6
9858 WRITE(LDAT,'(1P,7E11.4)')
9859 & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
9860 20 CONTINUE
9861 ENDIF
9862 ISTART = 7*NLINES+1
9863 IF (ISTART.LE.NSITEB) THEN
9864 WRITE(LDAT,'(1P,7E11.4)')
9865 & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
9866 ENDIF
9867 ENDIF
9868
9869 100 CONTINUE
9870
9871C IF (ABS(IOGLB).EQ.1) CLOSE(LDAT)
9872
9873 RETURN
9874 END
9875
9876*$ CREATE DT_GETBXS.FOR
9877*COPY DT_GETBXS
9878*
9879*===getbxs=============================================================*
9880*
9881 SUBROUTINE DT_GETBXS(XSFRAC,BLO,BHI,NIDX)
9882
9883************************************************************************
9884* Biasing in impact parameter space. *
9885* XSFRAC = 0 : BLO - minimum impact parameter (input) *
9886* BHI - maximum impact parameter (input) *
9887* XSFRAC - fraction of cross section corresponding *
9888* to impact parameter range (BLO,BHI) *
9889* (output) *
9890* XSFRAC > 0 : XSFRAC - fraction of cross section (input) *
9891* BHI - maximum impact parameter giving requested *
9892* fraction of cross section in impact *
9893* parameter range (0,BMAX) (output) *
9894* This version dated 17.03.00 is written by S. Roesler *
9895************************************************************************
9896
9897 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9898 SAVE
9899 PARAMETER ( LINP = 10 ,
9900 & LOUT = 6 ,
9901 & LDAT = 9 )
9902
9903 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
9904* Glauber formalism: parameters
9905 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
9906 & BMAX(NCOMPX),BSTEP(NCOMPX),
9907 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
9908 & NSITEB,NSTATB
9909
9910 NTARG = ABS(NIDX)
9911 IF (XSFRAC.LE.0.0D0) THEN
9912 ILO = MIN(NSITEB-1,INT(BLO/BSTEP(NTARG)))
9913 IHI = MIN(NSITEB-1,INT(BHI/BSTEP(NTARG)))
9914 IF (ILO.GE.IHI) THEN
9915 XSFRAC = 0.0D0
9916 RETURN
9917 ENDIF
9918 IF (ILO.EQ.NSITEB-1) THEN
9919 FRCLO = BSITE(0,1,NTARG,NSITEB)
9920 ELSE
9921 FRCLO = BSITE(0,1,NTARG,ILO+1)
9922 & +(BLO-ILO*BSTEP(NTARG))/BSTEP(NTARG)
9923 & *(BSITE(0,1,NTARG,ILO+2)-BSITE(0,1,NTARG,ILO+1))
9924 ENDIF
9925 IF (IHI.EQ.NSITEB-1) THEN
9926 FRCHI = BSITE(0,1,NTARG,NSITEB)
9927 ELSE
9928 FRCHI = BSITE(0,1,NTARG,IHI+1)
9929 & +(BHI-IHI*BSTEP(NTARG))/BSTEP(NTARG)
9930 & *(BSITE(0,1,NTARG,IHI+2)-BSITE(0,1,NTARG,IHI+1))
9931 ENDIF
9932 XSFRAC = FRCHI-FRCLO
9933 ELSE
9934 BLO = 0.0D0
9935 BHI = BMAX(NTARG)
9936 DO 1 I=1,NSITEB-1
9937 IF (XSFRAC.LT.BSITE(0,1,NTARG,I+1)) THEN
9938 FAC = (XSFRAC -BSITE(0,1,NTARG,I))/
9939 & (BSITE(0,1,NTARG,I+1)-BSITE(0,1,NTARG,I))
9940 BHI = DBLE(I-1)*BSTEP(NTARG)+BSTEP(NTARG)*FAC
9941 GOTO 2
9942 ENDIF
9943 1 CONTINUE
9944 2 CONTINUE
9945 ENDIF
9946
9947 RETURN
9948 END
9949
9950*$ CREATE DT_CONUCL.FOR
9951*COPY DT_CONUCL
9952*
9953*===conucl=============================================================*
9954*
9955 SUBROUTINE DT_CONUCL(X,N,R,MODE)
9956
9957************************************************************************
9958* Calculation of coordinates of nucleons within nuclei. *
9959* X(3,N) spatial coordinates of nucleons (in fm) (output) *
9960* N / R number of nucleons / radius of nucleus (input) *
9961* MODE = 0 coordinates not sorted *
9962* = 1 coordinates sorted with increasing X(3,i) *
9963* = 2 coordinates sorted with decreasing X(3,i) *
9964* This version dated 26.10.95 is revised by S. Roesler *
9965************************************************************************
9966
9967 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9968 SAVE
9969 PARAMETER ( LINP = 10 ,
9970 & LOUT = 6 ,
9971 & LDAT = 9 )
9972
9973 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
9974 & ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
9975
9976 PARAMETER (TWOPI = 6.283185307179586454D+00 )
9977
9978 PARAMETER (NSRT=10)
9979 DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
9980 DIMENSION X(3,N),XTMP(3,260)
9981
9982 CALL DT_COORDI(XTMP,IDXSRT,ICSRT,N,R)
9983
9984 IF ((MODE.NE.0).AND.(N.GT.4)) THEN
9985 K = 0
9986 DO 1 I=1,NSRT
9987 IF (MODE.EQ.2) THEN
9988 ISRT = NSRT+1-I
9989 ELSE
9990 ISRT = I
9991 ENDIF
9992 K1 = K
9993 DO 2 J=1,ICSRT(ISRT)
9994 K = K+1
9995 X(1,K) = XTMP(1,IDXSRT(ISRT,J))
9996 X(2,K) = XTMP(2,IDXSRT(ISRT,J))
9997 X(3,K) = XTMP(3,IDXSRT(ISRT,J))
9998 2 CONTINUE
9999 IF (ICSRT(ISRT).GT.1) THEN
10000 I0 = K1+1
10001 I1 = K
10002 CALL DT_SORT(X,N,I0,I1,MODE)
10003 ENDIF
10004 1 CONTINUE
10005 ELSEIF ((MODE.NE.0).AND.(N.GE.2).AND.(N.LE.4)) THEN
10006 DO 3 I=1,N
10007 X(1,I) = XTMP(1,I)
10008 X(2,I) = XTMP(2,I)
10009 X(3,I) = XTMP(3,I)
10010 3 CONTINUE
10011 CALL DT_SORT(X,N,1,N,MODE)
10012 ELSE
10013 DO 4 I=1,N
10014 X(1,I) = XTMP(1,I)
10015 X(2,I) = XTMP(2,I)
10016 X(3,I) = XTMP(3,I)
10017 4 CONTINUE
10018 ENDIF
10019
10020 RETURN
10021 END
10022
10023*$ CREATE DT_COORDI.FOR
10024*COPY DT_COORDI
10025*
10026*===coordi=============================================================*
10027*
10028 SUBROUTINE DT_COORDI(X,IDXSRT,ICSRT,N,R)
10029
10030************************************************************************
10031* Calculation of coordinates of nucleons within nuclei. *
10032* X(3,N) spatial coordinates of nucleons (in fm) (output) *
10033* N / R number of nucleons / radius of nucleus (input) *
10034* Based on the original version by Shmakov et al. *
10035* This version dated 26.10.95 is revised by S. Roesler *
10036************************************************************************
10037
10038 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10039 SAVE
10040 PARAMETER ( LINP = 10 ,
10041 & LOUT = 6 ,
10042 & LDAT = 9 )
10043
10044 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10045 & ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10046
10047 PARAMETER (TWOPI = 6.283185307179586454D+00 )
10048
10049 LOGICAL LSTART
10050
10051 PARAMETER (NSRT=10)
10052 DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10053 DIMENSION X(3,260),WD(4),RD(3)
10054
10055 DATA PDIF/0.545D0/,R2MIN/0.16D0/
10056 DATA WD / 0.0D0, 0.178D0, 0.465D0, 1.0D0/
10057 DATA RD /2.09D0, 0.935D0, 0.697D0/
10058
10059 X1SUM = ZERO
10060 X2SUM = ZERO
10061 X3SUM = ZERO
10062
10063 IF (N.EQ.1) THEN
10064 X(1,1) = ZERO
10065 X(2,1) = ZERO
10066 X(3,1) = ZERO
10067 ELSEIF (N.EQ.2) THEN
10068 EPS = DT_RNDM(RD(1))
10069 DO 30 I=1,3
10070 IF ((EPS.GE.WD(I)).AND.(EPS.LE.WD(I+1))) GOTO 40
10071 30 CONTINUE
10072 40 CONTINUE
10073 DO 50 J=1,3
10074 CALL DT_RANNOR(X1,X2)
10075 X(J,1) = RD(I)*X1
10076 X(J,2) = -X(J,1)
10077 50 CONTINUE
10078 ELSEIF ((N.EQ.3).OR.(N.EQ.4)) THEN
10079 SIGMA = R/SQRTWO
10080 LSTART = .TRUE.
10081 CALL DT_RANNOR(X3,X4)
10082 DO 100 I=1,N
10083 CALL DT_RANNOR(X1,X2)
10084 X(1,I) = SIGMA*X1
10085 X(2,I) = SIGMA*X2
10086 IF (LSTART) GOTO 80
10087 X(3,I) = SIGMA*X4
10088 CALL DT_RANNOR(X3,X4)
10089 GOTO 90
10090 80 CONTINUE
10091 X(3,I) = SIGMA*X3
10092 90 CONTINUE
10093 LSTART = .NOT.LSTART
10094 X1SUM = X1SUM+X(1,I)
10095 X2SUM = X2SUM+X(2,I)
10096 X3SUM = X3SUM+X(3,I)
10097 100 CONTINUE
10098 X1SUM = X1SUM/DBLE(N)
10099 X2SUM = X2SUM/DBLE(N)
10100 X3SUM = X3SUM/DBLE(N)
10101 DO 101 I=1,N
10102 X(1,I) = X(1,I)-X1SUM
10103 X(2,I) = X(2,I)-X2SUM
10104 X(3,I) = X(3,I)-X3SUM
10105 101 CONTINUE
10106 ELSE
10107
10108* maximum nuclear radius for coordinate sampling
10109 RMAX = R+4.605D0*PDIF
10110
10111* initialize pre-sorting
10112 DO 121 I=1,NSRT
10113 ICSRT(I) = 0
10114 121 CONTINUE
10115 DR = TWO*RMAX/DBLE(NSRT)
10116
10117* sample coordinates for N nucleons
10118 DO 140 I=1,N
10119 120 CONTINUE
10120 RAD = RMAX*(DT_RNDM(DR))**ONETHI
10121 F = DT_DENSIT(N,RAD,R)
10122 IF (DT_RNDM(RAD).GT.F) GOTO 120
10123* theta, phi uniformly distributed
10124 CT = ONE-TWO*DT_RNDM(F)
10125 ST = SQRT((ONE-CT)*(ONE+CT))
10126 CALL DT_DSFECF(SFE,CFE)
10127 X(1,I) = RAD*ST*CFE
10128 X(2,I) = RAD*ST*SFE
10129 X(3,I) = RAD*CT
10130* ensure that distance between two nucleons is greater than R2MIN
10131 IF (I.LT.2) GOTO 122
10132 I1 = I-1
10133 DO 130 I2=1,I1
10134 DIST2 = (X(1,I)-X(1,I2))**2+(X(2,I)-X(2,I2))**2+
10135 & (X(3,I)-X(3,I2))**2
10136 IF (DIST2.LE.R2MIN) GOTO 120
10137 130 CONTINUE
10138 122 CONTINUE
10139* save index according to z-bin
10140 IDXZ = INT( (X(3,I)+RMAX)/DR )+1
10141 ICSRT(IDXZ) = ICSRT(IDXZ)+1
10142 IDXSRT(IDXZ,ICSRT(IDXZ)) = I
10143 X1SUM = X1SUM+X(1,I)
10144 X2SUM = X2SUM+X(2,I)
10145 X3SUM = X3SUM+X(3,I)
10146 140 CONTINUE
10147 X1SUM = X1SUM/DBLE(N)
10148 X2SUM = X2SUM/DBLE(N)
10149 X3SUM = X3SUM/DBLE(N)
10150 DO 141 I=1,N
10151 X(1,I) = X(1,I)-X1SUM
10152 X(2,I) = X(2,I)-X2SUM
10153 X(3,I) = X(3,I)-X3SUM
10154 141 CONTINUE
10155
10156 ENDIF
10157
10158 RETURN
10159 END
10160
10161*$ CREATE DT_DENSIT.FOR
10162*COPY DT_DENSIT
10163*
10164*===densit=============================================================*
10165*
10166 DOUBLE PRECISION FUNCTION DT_DENSIT(NA,R,RA)
10167
10168 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10169 SAVE
10170
10171 PARAMETER ( LINP = 10 ,
10172 & LOUT = 6 ,
10173 & LDAT = 9 )
10174 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10175 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
10176 & PI = TWOPI/TWO)
10177
10178 DIMENSION R0(18),FNORM(18)
10179 DATA R0 / ZERO, ZERO, ZERO, ZERO, 2.12D0,
10180 & 2.56D0, 2.41D0, 2.46D0, 2.52D0, 2.45D0,
10181 & 2.37D0, 2.46D0, 2.44D0, 2.54D0, 2.58D0,
10182 & 2.72D0, 2.66D0, 2.79D0/
10183 DATA FNORM /.1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10184 & .1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10185 & .1012D+01,.1039D+01,.1075D+01,.1118D+01,.1164D+01,
10186 & .1214D+01,.1265D+01,.1318D+01/
10187 DATA PDIF /0.545D0/
10188
10189 DT_DENSIT = ZERO
10190* shell model
10191 IF (NA.LE.4) THEN
10192 STOP 'DT_DENSIT-0'
10193 ELSEIF ((NA.GT.4).AND.(NA.LE.18)) THEN
10194 R1 = R0(NA)/SQRT(2.5D0-4.0D0/DBLE(NA))
10195 DT_DENSIT = (ONE+(DBLE(NA)-4.0D0)/6.0D0*(R/R1)**2)
10196 & *EXP(-(R/R1)**2)/FNORM(NA)
10197* Woods-Saxon
10198 ELSEIF (NA.GT.18) THEN
10199 DT_DENSIT = ONE/(ONE+EXP((R-RA)/PDIF))
10200 ENDIF
10201
10202 RETURN
10203 END
10204
10205*$ CREATE DT_RNCLUS.FOR
10206*COPY DT_RNCLUS
10207*
10208*===rnclus=============================================================*
10209*
10210 DOUBLE PRECISION FUNCTION DT_RNCLUS(N)
10211
10212************************************************************************
10213* Nuclear radius for nucleus with mass number N. *
10214* This version dated 26.9.00 is written by S. Roesler *
10215************************************************************************
10216
10217 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10218 SAVE
10219
10220 PARAMETER (ONE=1.0D0,THREE=3.0D0,ONETHI=ONE/THREE)
10221
10222* nucleon radius
10223 PARAMETER (RNUCLE = 1.12D0)
10224
10225* nuclear radii for selected nuclei
10226 DIMENSION RADNUC(18)
10227 DATA RADNUC / 8*0.0D0,2.52D0,2.45D0,2.37D0,2.45D0,2.44D0,2.55D0,
10228 & 2.58D0,2.71D0,2.66D0,2.71D0/
10229
10230 IF (N.LE.18) THEN
10231 IF (RADNUC(N).GT.0.0D0) THEN
10232 DT_RNCLUS = RADNUC(N)
10233 ELSE
10234 DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10235 ENDIF
10236 ELSE
10237 DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10238 ENDIF
10239
10240 RETURN
10241 END
10242
10243*$ CREATE DT_DENTST.FOR
10244*COPY DT_DENTST
10245*
10246*===dentst=============================================================*
10247*
10248C PROGRAM DT_DENTST
10249 SUBROUTINE DT_DENTST
10250
10251 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10252 SAVE
10253
10254 OPEN(40,FILE='dentst.out',STATUS='UNKNOWN')
10255 OPEN(41,FILE='denmax.out',STATUS='UNKNOWN')
10256
10257 RMIN = 0.0D0
10258 RMAX = 8.0D0
10259 NBINS = 500.0D0
10260 DR = (RMAX-RMIN)/DBLE(NBINS)
10261 DO 1 IA=5,18
10262 FMAX = 0.0D0
10263 DO 2 IR=1,NBINS+1
10264 R = RMIN+DBLE(IR-1)*DR
10265 F = DT_DENSIT(IA,R,R)
10266 IF (F.GT.FMAX) FMAX = F
10267 WRITE(40,'(1X,I3,2E15.5)') IA,R,F
10268 2 CONTINUE
10269 WRITE(41,'(1X,I3,E15.5)') IA,FMAX
10270 1 CONTINUE
10271
10272 CLOSE(40)
10273 CLOSE(41)
10274
10275 END
10276
10277*$ CREATE DT_SHMAKI.FOR
10278*COPY DT_SHMAKI
10279*
10280*===shmaki=============================================================*
10281*
10282 SUBROUTINE DT_SHMAKI(NA,NCA,NB,NCB,IJP,PPN,MODE)
10283
10284************************************************************************
10285* Initialisation of Glauber formalism. This subroutine has to be *
10286* called once (in case of target emulsions as often as many different *
10287* target nuclei are considered) before events are sampled. *
10288* NA / NCA mass number/charge of projectile nucleus *
10289* NB / NCB mass number/charge of target nucleus *
10290* IJP identity of projectile (hadrons/leptons/photons) *
10291* PPN projectile momentum (for projectile nuclei: *
10292* momentum per nucleon) in target rest system *
10293* MODE = 0 Glauber formalism invoked *
10294* = 1 fitted results are loaded from data-file *
10295* = 99 NTARG is forced to be 1 *
10296* (used in connection with GLAUBERI-card only) *
10297* This version dated 22.03.96 is based on the original SHMAKI-routine *
10298* and revised by S. Roesler. *
10299************************************************************************
10300
10301 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10302 SAVE
10303 PARAMETER ( LINP = 10 ,
10304 & LOUT = 6 ,
10305 & LDAT = 9 )
10306 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
10307 & THREE=3.0D0)
10308
10309 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10310* Glauber formalism: parameters
10311 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10312 & BMAX(NCOMPX),BSTEP(NCOMPX),
10313 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10314 & NSITEB,NSTATB
10315* Lorentz-parameters of the current interaction
10316 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10317 & UMO,PPCM,EPROJ,PPROJ
10318* properties of photon/lepton projectiles
10319 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10320* kinematical cuts for lepton-nucleus interactions
10321 COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
10322 & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
10323* Glauber formalism: cross sections
10324 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10325 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10326 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10327 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10328 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10329 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10330 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10331 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10332 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10333 & BSLOPE,NEBINI,NQBINI
10334* cuts for variable energy runs
10335 COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
10336* nucleon-nucleon event-generator
10337 CHARACTER*8 CMODEL
10338 LOGICAL LPHOIN
10339 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10340* Glauber formalism: flags and parameters for statistics
10341 LOGICAL LPROD
10342 CHARACTER*8 CGLB
10343 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10344
10345 DATA NTARG,ICOUT,IVEOUT /0,0,0/
10346
10347C CALL DT_HISHAD
10348C STOP
10349
10350 NTARG = NTARG+1
10351 IF (MODE.EQ.99) NTARG = 1
10352 NIDX = -NTARG
10353 IF (MODE.EQ.-1) NIDX = NTARG
10354
10355 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) ICOUT = ICOUT+1
10356 IF (ICOUT.EQ.1) WRITE(LOUT,1000)
10357 1000 FORMAT(//,1X,'SHMAKI: Glauber formalism (Shmakov et. al) -',
10358 & ' initialization',/,12X,'--------------------------',
10359 & '-------------------------',/)
10360
10361 IF (MODE.EQ.2) THEN
10362 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10363 CALL DT_SHFAST(MODE,PPN,IBACK)
10364 STOP ' Glauber pre-initialization done'
10365 ENDIF
10366 IF (MODE.EQ.1) THEN
10367 CALL DT_PROFBI(NA,NB,PPN,NTARG)
10368 ELSE
10369 IBACK = 1
10370 IF (MODE.EQ.3) CALL DT_SHFAST(MODE,PPN,IBACK)
10371 IF (IBACK.EQ.1) THEN
10372* lepton-nucleus (variable energy runs)
10373 IF ((IJP.EQ. 3).OR.(IJP.EQ. 4).OR.
10374 & (IJP.EQ.10).OR.(IJP.EQ.11)) THEN
10375 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10376 & WRITE(LOUT,1002) NB,NCB
10377 1002 FORMAT(1X,'variable energy run: projectile-id: 7',
10378 & ' target A/Z: ',I3,' /',I3,/,/,8X,
10379 & 'E_cm (GeV) Q^2 (GeV^2)',
10380 & ' Sigma_tot (mb) Sigma_in (mb)',/,7X,
10381 & '--------------------------------',
10382 & '------------------------------')
10383 AECMLO = LOG10(MIN(UMO,ECMLI))
10384 AECMHI = LOG10(MIN(UMO,ECMHI))
10385 IESTEP = NEB-1
10386 DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
10387 IF (AECMLO.EQ.AECMHI) IESTEP = 0
10388 DO 1 I=1,IESTEP+1
10389 ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10390 IF (Q2HI.GT.0.1D0) THEN
10391 IF (Q2LI.LT.0.01D0) THEN
10392 CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10393 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10394 & WRITE(LOUT,1003)
10395 & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10396 Q2LI = 0.01D0
10397 IBIN = 2
10398 ELSE
10399 IBIN = 1
10400 ENDIF
10401 IQSTEP = NQB-IBIN
10402 AQ2LO = LOG10(Q2LI)
10403 AQ2HI = LOG10(Q2HI)
10404 DAQ2 = (AQ2HI-AQ2LO)/MAX(DBLE(IQSTEP),ONE)
10405 DO 2 J=IBIN,IQSTEP+IBIN
10406 Q2 = 10.0D0**(AQ2LO+DBLE(J-IBIN)*DAQ2)
10407 CALL DT_XSGLAU(NA,NB,7,ZERO,Q2,ECM,I,J,NIDX)
10408 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10409 & WRITE(LOUT,1003) ECMNN(I),
10410 & Q2G(J),XSTOT(I,J,NTARG),XSPRO(I,J,NTARG)
10411 2 CONTINUE
10412 ELSE
10413 CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10414 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10415 & WRITE(LOUT,1003)
10416 & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10417 ENDIF
10418 1003 FORMAT(9X,F6.1,9X,F6.2,8X,F8.3,11X,F8.3)
10419 1 CONTINUE
10420 IVEOUT = 1
10421 ELSE
10422* hadron/photon/nucleus-nucleus
10423 IF ((ABS(VAREHI).GT.ZERO).AND.
10424 & (ABS(VAREHI).GT.ABS(VARELO))) THEN
10425 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) THEN
10426 WRITE(LOUT,1004) NA,NB,NCB
10427 1004 FORMAT(1X,'variable energy run: projectile-id:',
10428 & I3,' target A/Z: ',I3,' /',I3,/)
10429 WRITE(LOUT,1005)
10430 1005 FORMAT(' E_cm (GeV) E_Lab (GeV) sig_tot^pp (mb)'
10431 & ,' Sigma_tot (mb) Sigma_prod (mb)',/,
10432 & ' -------------------------------------',
10433 & '--------------------------------------')
10434 ENDIF
10435 AECMLO = LOG10(VARCLO)
10436 AECMHI = LOG10(VARCHI)
10437 IESTEP = NEB-1
10438 DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
10439 IF (AECMLO.EQ.AECMHI) IESTEP = 0
10440 DO 3 I=1,IESTEP+1
10441 ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10442 AMP = 0.938D0
10443 AMT = 0.938D0
10444 AMP2 = AMP**2
10445 AMT2 = AMT**2
10446 ELAB = (ECM**2-AMP2-AMT2)/(TWO*AMT)
10447 PLAB = SQRT((ELAB+AMP)*(ELAB-AMP))
10448 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,ECM,I,1,NIDX)
10449 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10450 & WRITE(LOUT,1006)
10451 & ECM,PLAB,SIGSH,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10452 1006 FORMAT(1X,F9.1,1X,E11.3,1X,F12.2,8X,F10.3,8X,F8.3)
10453 3 CONTINUE
10454 IVEOUT = 1
10455 ELSE
10456 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10457 ENDIF
10458 ENDIF
10459 ENDIF
10460 ENDIF
10461
10462 IF ((ICOUT.LT.15).AND.(IVEOUT.EQ.0).AND.(MCGENE.NE.4).AND.
10463 & (IOGLB.NE.100)) THEN
10464 WRITE(LOUT,1001) NA,NCA,NB,NCB,ECMNN(1),SIGSH*10.0D0,ROSH,
10465 & BSLOPE,NSITEB,NSTATB,XSPRO(1,1,NTARG)
10466 1001 FORMAT(38X,'projectile',
10467 & ' target',/,1X,'Mass number / charge',
10468 & 17X,I3,' /',I3,6X,I3,' /',I3,/,/,1X,
10469 & 'Nucleon-nucleon c.m. energy',9X,F10.2,' GeV',/,/,1X,
10470 & 'Parameters of elastic scattering amplitude:',/,5X,
10471 & 'sigma =',F7.2,' mb',6X,'rho = ',F9.4,6X,'slope = ',
10472 & F4.1,' GeV^-2',/,/,1X,'Number of b-steps',4X,I3,8X,
10473 & 'statistics at each b-step',4X,I5,/,/,1X,
10474 & 'Prod. cross section ',5X,F10.4,' mb',/)
10475 ENDIF
10476
10477 RETURN
10478 END
10479
10480*$ CREATE DT_PROFBI.FOR
10481*COPY DT_PROFBI
10482*
10483*===profbi=============================================================*
10484*
10485 SUBROUTINE DT_PROFBI(NA,NB,PPN,NTARG)
10486
10487************************************************************************
10488* Integral over profile function (to be used for impact-parameter *
10489* sampling during event generation). *
10490* Fitted results are used. *
10491* NA / NB mass numbers of proj./target nuclei *
10492* PPN projectile momentum (for projectile nuclei: *
10493* momentum per nucleon) in target rest system *
10494* NTARG index of target material (i.e. kind of nucleus) *
10495* This version dated 31.05.95 is revised by S. Roesler *
10496************************************************************************
10497
10498 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10499 SAVE
10500 PARAMETER ( LINP = 10 ,
10501 & LOUT = 6 ,
10502 & LDAT = 9 )
454792a9 10503CPH SAVE
9aaba0d6 10504
10505 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
10506
10507 LOGICAL LSTART
10508 CHARACTER CNAME*80
10509
10510 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10511* Glauber formalism: parameters
10512 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10513 & BMAX(NCOMPX),BSTEP(NCOMPX),
10514 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10515 & NSITEB,NSTATB
10516* Glauber formalism: cross sections
10517 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10518 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10519 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10520 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10521 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10522 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10523 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10524 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10525 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10526 & BSLOPE,NEBINI,NQBINI
10527
10528 PARAMETER (NGLMAX=8000)
10529 DIMENSION NGLIT(NGLMAX),NGLIP(NGLMAX),GLAPPN(NGLMAX),
10530 & GLASIG(NGLMAX),GLAFIT(5,NGLMAX)
10531
10532 DATA LSTART /.TRUE./
10533
10534 IF (LSTART) THEN
10535* read fit-parameters from file
10536 OPEN(47,FILE='inpdata/glpara.dat',STATUS='UNKNOWN')
10537 I = 0
10538 1 CONTINUE
10539 READ(47,'(A80)') CNAME
10540 IF (CNAME.EQ.'STOP') GOTO 2
10541 I = I+1
10542 READ(CNAME,*) NGLIP(I),NGLIT(I),GLAPPN(I),GLASIG(I),
10543 & GLAFIT(1,I),GLAFIT(2,I),GLAFIT(3,I),
10544 & GLAFIT(4,I),GLAFIT(5,I)
10545 IF (I+1.GT.NGLMAX) THEN
10546 WRITE(LOUT,1000)
10547 1000 FORMAT(1X,'PROFBI: warning! array size exceeded - ',
10548 & 'program stopped')
10549 STOP
10550 ENDIF
10551 GOTO 1
10552 2 CONTINUE
10553 NGLPAR = I
10554 LSTART = .FALSE.
10555 ENDIF
10556
10557 NNA = NA
10558 NNB = NB
10559 IF (NA.GT.NB) THEN
10560 NNA = NB
10561 NNB = NA
10562 ENDIF
10563 IDXGLA = 0
10564 DO 3 J=1,NGLPAR
10565 IF ((NNB.LT.NGLIT(J)).OR.(J.EQ.NGLPAR)) THEN
10566 IF (NNB.NE.NGLIT(J-1)) NNB = NGLIT(J-1)
10567 DO 4 K=1,J-1
10568 IPOINT = J-K
10569 IF (J.EQ.NGLPAR) IPOINT = J+1-K
10570 IF ((NNA.GT.NGLIP(IPOINT)).OR.
10571 & (NNB.NE.NGLIT(IPOINT)).OR.(IPOINT.EQ.1)) THEN
10572 IF (IPOINT.EQ.1) IPOINT = 0
10573 NATMP = NGLIP(IPOINT+1)
10574 IF (PPN.LT.GLAPPN(IPOINT+1)) THEN
10575 IDXGLA = IPOINT+1
10576 GOTO 6
10577 ELSE
10578 J1BEG = IPOINT+1
10579 J1END = J
10580C IF (J.EQ.NGLPAR) THEN
10581C J1BEG = IPOINT
10582C J1END = J
10583C ENDIF
10584 DO 5 J1=J1BEG,J1END
10585 IF (NGLIP(J1).EQ.NATMP) THEN
10586 IF (PPN.LT.GLAPPN(J1)) THEN
10587 IDXGLA = J1
10588 GOTO 6
10589 ENDIF
10590 ELSE
10591 IDXGLA = J1-1
10592 GOTO 6
10593 ENDIF
10594 5 CONTINUE
10595 IF ((J.EQ.NGLPAR).AND.(PPN.GT.GLAPPN(NGLPAR)))
10596 & IDXGLA = NGLPAR
10597 ENDIF
10598 ENDIF
10599 4 CONTINUE
10600 ENDIF
10601 3 CONTINUE
10602
10603 6 CONTINUE
10604 IF (IDXGLA.EQ.0) THEN
10605 WRITE(LOUT,1001) NNA,NNB,PPN
10606 1001 FORMAT(1X,'PROFBI: configuration (NA,NB,PPN = ',
10607 & 2I4,F6.0,') not found ')
10608 STOP
10609 ENDIF
10610
10611* no interpolation yet available
10612 XSPRO(1,1,NTARG) = GLASIG(IDXGLA)
10613
10614 BSITE(1,1,NTARG,1) = ZERO
10615 DO 10 I=2,NSITEB
10616 XX = DBLE(I)
10617 POLY = GLAFIT(1,IDXGLA)+GLAFIT(2,IDXGLA)*XX+
10618 & GLAFIT(3,IDXGLA)*XX**2+GLAFIT(4,IDXGLA)*XX**3+
10619 & GLAFIT(5,IDXGLA)*XX**4
10620 IF (ABS(POLY).GT.35.0D0) POLY = SIGN(35.0D0,POLY)
10621 BSITE(1,1,NTARG,I) = (1.0D0-EXP(-POLY))
10622 IF (BSITE(1,1,NTARG,I).LT.ZERO) BSITE(1,1,NTARG,I) = ZERO
10623 10 CONTINUE
10624
10625 RETURN
10626 END
10627
10628*$ CREATE DT_GLAUBE.FOR
10629*COPY DT_GLAUBE
10630*
10631*===glaube=============================================================*
10632*
10633 SUBROUTINE DT_GLAUBE(NA,NB,IJPROJ,B,INTT,INTA,INTB,JS,JT,NIDX)
10634
10635************************************************************************
10636* Calculation of configuartion of interacting nucleons for one event. *
10637* NB / NB mass numbers of proj./target nuclei (input) *
10638* B impact parameter (output) *
10639* INTT total number of wounded nucleons " *
10640* INTA / INTB number of wounded nucleons in proj. / target " *
10641* JS / JT(i) number of collisions proj. / target nucleon i is *
10642* involved (output) *
10643* NIDX index of projectile/target material (input) *
10644* = -2 call within FLUKA transport calculation *
10645* This is an update of the original routine SHMAKO by J.Ranft/HJM *
10646* This version dated 22.03.96 is revised by S. Roesler *
10647* *
10648* Last change 27.12.2006 by S. Roesler. *
10649************************************************************************
10650
10651 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10652 SAVE
10653 PARAMETER ( LINP = 10 ,
10654 & LOUT = 6 ,
10655 & LDAT = 9 )
10656 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
10657 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
10658
10659 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10660 PARAMETER ( MAXNCL = 260,
10661 & MAXVQU = MAXNCL,
10662 & MAXSQU = 20*MAXVQU,
10663 & MAXINT = MAXVQU+MAXSQU)
10664* Glauber formalism: parameters
10665 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10666 & BMAX(NCOMPX),BSTEP(NCOMPX),
10667 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10668 & NSITEB,NSTATB
10669* Glauber formalism: cross sections
10670 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10671 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10672 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10673 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10674 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10675 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10676 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10677 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10678 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10679 & BSLOPE,NEBINI,NQBINI
10680* Lorentz-parameters of the current interaction
10681 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10682 & UMO,PPCM,EPROJ,PPROJ
10683* properties of photon/lepton projectiles
10684 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10685* Glauber formalism: collision properties
10686 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
10687 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
10688* Glauber formalism: flags and parameters for statistics
10689 LOGICAL LPROD
10690 CHARACTER*8 CGLB
10691 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10692
10693 DIMENSION JS(MAXNCL),JT(MAXNCL)
10694
10695 NTARG = ABS(NIDX)
10696
10697* get actual energy from /DTLTRA/
10698 ECMNOW = UMO
10699 Q2 = VIRT
10700*
10701* new patch for pre-initialized variable projectile/target/energy runs,
10702* bypassed for use within FLUKA (Nidx=-2)
10703 IF (IOGLB.EQ.100) THEN
10704 IF (NIDX.NE.-2) CALL DT_GLBSET(IJPROJ,NA,NB,EPROJ,1)
10705*
10706* variable energy run, interpolate profile function
10707 ELSE
10708 I1 = 1
10709 I2 = 1
10710 RATE = ONE
10711 IF (NEBINI.GT.1) THEN
10712 IF (ECMNOW.GE.ECMNN(NEBINI)) THEN
10713 I1 = NEBINI
10714 I2 = NEBINI
10715 RATE = ONE
10716 ELSEIF (ECMNOW.GT.ECMNN(1)) THEN
10717 DO 1 I=2,NEBINI
10718 IF (ECMNOW.LT.ECMNN(I)) THEN
10719 I1 = I-1
10720 I2 = I
10721 RATE = (ECMNOW-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
10722 GOTO 2
10723 ENDIF
10724 1 CONTINUE
10725 2 CONTINUE
10726 ENDIF
10727 ENDIF
10728 J1 = 1
10729 J2 = 1
10730 RATQ = ONE
10731 IF (NQBINI.GT.1) THEN
10732 IF (Q2.GE.Q2G(NQBINI)) THEN
10733 J1 = NQBINI
10734 J2 = NQBINI
10735 RATQ = ONE
10736 ELSEIF (Q2.GT.Q2G(1)) THEN
10737 DO 3 I=2,NQBINI
10738 IF (Q2.LT.Q2G(I)) THEN
10739 J1 = I-1
10740 J2 = I
10741 RATQ = LOG10( Q2/MAX(Q2G(J1),TINY14))/
10742 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
10743C RATQ = (Q2-Q2G(J1))/(Q2G(J2)-Q2G(J1))
10744 GOTO 4
10745 ENDIF
10746 3 CONTINUE
10747 4 CONTINUE
10748 ENDIF
10749 ENDIF
10750
10751 DO 5 I=1,KSITEB
10752 BSITE(0,1,NTARG,I) = BSITE(I1,J1,NTARG,I)+
10753 & RATE*(BSITE(I2,J1,NTARG,I)-BSITE(I1,J1,NTARG,I))+
10754 & RATQ*(BSITE(I1,J2,NTARG,I)-BSITE(I1,J1,NTARG,I))+
10755 & RATE*RATQ*(BSITE(I2,J2,NTARG,I)-BSITE(I1,J2,NTARG,I)+
10756 & BSITE(I1,J1,NTARG,I)-BSITE(I2,J1,NTARG,I))
10757 5 CONTINUE
10758 ENDIF
10759
10760 CALL DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,INTT,INTA,INTB,IDIREC,NIDX)
10761 IF (NIDX.LE.-1) THEN
10762 RPROJ = RASH(1)
10763 RTARG = RBSH(NTARG)
10764 ELSE
10765 RPROJ = RASH(NTARG)
10766 RTARG = RBSH(1)
10767 ENDIF
10768
10769 RETURN
10770 END
10771
10772*$ CREATE DT_DIAGR.FOR
10773*COPY DT_DIAGR
10774*
10775*===diagr==============================================================*
10776*
10777 SUBROUTINE DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,JNT,INTA,INTB,IDIREC,
10778 & NIDX)
10779
10780************************************************************************
10781* Based on the original version by Shmakov et al. *
10782* This version dated 21.04.95 is revised by S. Roesler *
10783************************************************************************
10784
10785 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10786 SAVE
10787 PARAMETER ( LINP = 10 ,
10788 & LOUT = 6 ,
10789 & LDAT = 9 )
10790 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10791 PARAMETER (TWOPI = 6.283185307179586454D+00,
10792 & PI = TWOPI/TWO,
10793 & GEV2MB = 0.38938D0,
10794 & GEV2FM = 0.1972D0,
10795 & ALPHEM = ONE/137.0D0,
10796* proton mass
10797 & AMP = 0.938D0,
10798 & AMP2 = AMP**2,
10799* rho0 mass
10800 & AMRHO0 = 0.77D0)
10801
10802 COMPLEX*16 C,CA,CI
10803 PARAMETER ( MAXNCL = 260,
10804 & MAXVQU = MAXNCL,
10805 & MAXSQU = 20*MAXVQU,
10806 & MAXINT = MAXVQU+MAXSQU)
10807* particle properties (BAMJET index convention)
10808 CHARACTER*8 ANAME
10809 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
10810 & IICH(210),IIBAR(210),K1(210),K2(210)
10811 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10812* emulsion treatment
10813 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
10814 & NCOMPO,IEMUL
10815* Glauber formalism: parameters
10816 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10817 & BMAX(NCOMPX),BSTEP(NCOMPX),
10818 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10819 & NSITEB,NSTATB
10820* Glauber formalism: cross sections
10821 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10822 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10823 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10824 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10825 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10826 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10827 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10828 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10829 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10830 & BSLOPE,NEBINI,NQBINI
10831* VDM parameter for photon-nucleus interactions
10832 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
10833* nucleon-nucleon event-generator
10834 CHARACTER*8 CMODEL
10835 LOGICAL LPHOIN
10836 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10837**PHOJET105a
10838C COMMON /CUTOFF/ PTCUT(4),CUTMU(4),FPS(4),FPH(4),PSOMIN,XSOMIN
10839**PHOJET112
10840C obsolete cut-off information
10841 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
10842 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
10843**
10844* coordinates of nucleons
10845 COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
10846* interface between Glauber formalism and DPM
10847 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
10848 & INTER1(MAXINT),INTER2(MAXINT)
10849* statistics: Glauber-formalism
10850 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
10851* n-n cross section fluctuations
10852 PARAMETER (NBINS = 1000)
10853 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
10854
10855 DIMENSION JS(MAXNCL),JT(MAXNCL),
10856 & JS0(MAXNCL),JT0(MAXNCL,MAXNCL),
10857 & JI1(MAXNCL,MAXNCL),JI2(MAXNCL,MAXNCL),JNT0(MAXNCL)
10858 DIMENSION NWA(0:210),NWB(0:210)
10859
10860 LOGICAL LFIRST
10861 DATA LFIRST /.TRUE./
10862
10863 DATA NTARGO,ICNT /0,0/
10864
10865 NTARG = ABS(NIDX)
10866
10867 IF (LFIRST) THEN
10868 LFIRST = .FALSE.
10869 IF (NCOMPO.EQ.0) THEN
10870 NCALL = 0
10871 NWAMAX = NA
10872 NWBMAX = NB
10873 DO 17 I=0,210
10874 NWA(I) = 0
10875 NWB(I) = 0
10876 17 CONTINUE
10877 ENDIF
10878 ENDIF
10879 IF (NTARG.EQ.-1) THEN
10880 IF (NCOMPO.EQ.0) THEN
10881 WRITE(LOUT,*) ' DIAGR: distribution of wounded nucleons'
10882 WRITE(LOUT,'(8X,A,3I7)') 'NCALL,NWAMAX,NWBMAX = ',
10883 & NCALL,NWAMAX,NWBMAX
10884 DO 18 I=1,MAX(NWAMAX,NWBMAX)
10885 WRITE(LOUT,'(8X,2I7,E12.4,I7,E12.4)')
10886 & I,NWA(I),DBLE(NWA(I))/DBLE(NCALL),
10887 & NWB(I),DBLE(NWB(I))/DBLE(NCALL)
10888 18 CONTINUE
10889 ENDIF
10890 RETURN
10891 ENDIF
10892
10893 DCOH = 1.0D10
10894 IPNT = 0
10895
10896 SQ2 = Q2
10897 IF (SQ2.LE.ZERO) SQ2 = 0.0001D0
10898 S = ECMNOW**2
10899 X = SQ2/(S+SQ2-AMP2)
10900 XNU = (S+SQ2-AMP2)/(TWO*AMP)
10901* photon projectiles: recalculate photon-nucleon amplitude
10902 IF (IJPROJ.EQ.7) THEN
10903 15 CONTINUE
10904* VDM assumption: mass of V-meson
10905 AMV2 = DT_SAM2(SQ2,ECMNOW)
10906 AMV = SQRT(AMV2)
10907 IF (AMV.GT.2.0D0*PTCUT(1)) GOTO 15
10908* check for pointlike interaction
10909 CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,1)
10910**sr 27.10.
10911C SIGSH = DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
10912 SIGSH = (ONE-RPNT)*DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
10913**
10914 ROSH = 0.1D0
10915 BSLOPE = 2.0D0*(2.0D0+AMRHO0**2/(AMV2+SQ2)
10916 & +0.25D0*LOG(S/(AMV2+SQ2)))
10917* coherence length
10918 IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+SQ2)*GEV2FM
10919 ELSEIF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
10920 IF (MCGENE.EQ.2) THEN
10921 ZERO1 = ZERO
10922 CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SDUM1,SDUM2,SDUM3,
10923 & BSLOPE,0)
10924 ELSE
10925 BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
10926 ENDIF
10927 IF (ECMNOW.LE.3.0D0) THEN
10928 ROSH = -0.43D0
10929 ELSEIF ((ECMNOW.GT.3.0D0).AND.(ECMNOW.LE.50.D0)) THEN
10930 ROSH = -0.63D0+0.175D0*LOG(ECMNOW)
10931 ELSEIF (ECMNOW.GT.50.0D0) THEN
10932 ROSH = 0.1D0
10933 ENDIF
10934 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
10935 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
10936 IF (MCGENE.EQ.2) THEN
10937 ZERO1 = ZERO
10938 CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SIGSH,SDUM2,SDUM3,
10939 & BDUM,0)
10940 SIGSH = SIGSH/10.0D0
10941 ELSE
10942C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
10943 DUMZER = ZERO
10944 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
10945 SIGSH = SIGSH/10.0D0
10946 ENDIF
10947 ELSE
10948 BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
10949 ROSH = 0.01D0
10950 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
10951 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
10952C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
10953 DUMZER = ZERO
10954 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
10955 SIGSH = SIGSH/10.0D0
10956 ENDIF
10957 GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
10958 GAM = GSH
10959 RCA = GAM*SIGSH/TWOPI
10960 FCA = -ROSH*RCA
10961 CA = DCMPLX(RCA,FCA)
10962 CI = DCMPLX(ONE,ZERO)
10963
10964 16 CONTINUE
10965* impact parameter
10966 IF (MCGENE.NE.3) CALL DT_MODB(B,NIDX)
10967
10968 NTRY = 0
10969 3 CONTINUE
10970 NTRY = NTRY+1
10971* initializations
10972 JNT = 0
10973 DO 1 I=1,NA
10974 JS(I) = 0
10975 1 CONTINUE
10976 DO 2 I=1,NB
10977 JT(I) = 0
10978 2 CONTINUE
10979 IF (IJPROJ.EQ.7) THEN
10980 DO 8 I=1,MAXNCL
10981 JS0(I) = 0
10982 JNT0(I)= 0
10983 DO 9 J=1,NB
10984 JT0(I,J) = 0
10985 9 CONTINUE
10986 8 CONTINUE
10987 ENDIF
10988
10989* nucleon configuration
10990C IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,5).EQ.0)) THEN
10991 IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,1).EQ.0)) THEN
10992C CALL DT_CONUCL(PKOO,NA,RASH,2)
10993C CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),1)
10994 IF (NIDX.LE.-1) THEN
10995 CALL DT_CONUCL(PKOO,NA,RASH(1),0)
10996 CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),0)
10997 ELSE
10998 CALL DT_CONUCL(PKOO,NA,RASH(NTARG),0)
10999 CALL DT_CONUCL(TKOO,NB,RBSH(1),0)
11000 ENDIF
11001 NTARGO = NTARG
11002 ENDIF
11003 ICNT = ICNT+1
11004
11005* LEPTO: pick out one struck nucleon
11006 IF (MCGENE.EQ.3) THEN
11007 JNT = 1
11008 JS(1) = 1
11009 IDX = INT(DT_RNDM(X)*NB)+1
11010 JT(IDX) = 1
11011 B = ZERO
11012 GOTO 19
11013 ENDIF
11014
11015 DO 4 INA=1,NA
11016* cross section fluctuations
11017 AFLUC = ONE
11018 IF (IFLUCT.EQ.1) THEN
11019 IFLUK = INT((DT_RNDM(X)+0.001D0)*1000.0D0)
11020 AFLUC = FLUIXX(IFLUK)
11021 ENDIF
11022 KK1 = 1
11023 KINT = 1
11024 DO 5 INB=1,NB
11025* photon-projectile: check for supression by coherence length
11026 IF (IJPROJ.EQ.7) THEN
11027 IF (ABS(TKOO(3,INB)-TKOO(3,KK1)).GT.DCOH) THEN
11028 KK1 = INB
11029 KINT = KINT+1
11030 ENDIF
11031 ENDIF
11032 QQ1 = B+TKOO(1,INB)-PKOO(1,INA)
11033 QQ2 = TKOO(2,INB)-PKOO(2,INA)
11034 XY = GAM*(QQ1*QQ1+QQ2*QQ2)
11035 IF (XY.LE.15.0D0) THEN
11036 C = CI-CA*AFLUC*EXP(-XY)
11037 AR = DBLE(C)
11038 AI = DIMAG(C)
11039 P = AR*AR+AI*AI
11040 IF (DT_RNDM(XY).GE.P) THEN
11041 JNT = JNT+1
11042 IF (IJPROJ.EQ.7) THEN
11043 JNT0(KINT) = JNT0(KINT)+1
11044 IF (JNT0(KINT).GT.MAXNCL) THEN
11045 WRITE(LOUT,1001) MAXNCL
11046 1001 FORMAT(1X,
11047 & 'DIAGR: no. of requested interactions',
11048 & ' exceeds array dimensions ',I4)
11049 STOP
11050 ENDIF
11051 JS0(KINT) = JS0(KINT)+1
11052 JT0(KINT,INB) = JT0(KINT,INB)+1
11053 JI1(KINT,JNT0(KINT)) = INA
11054 JI2(KINT,JNT0(KINT)) = INB
11055 ELSE
11056 IF (JNT.GT.MAXINT) THEN
11057 WRITE(LOUT,1000) JNT, MAXINT
11058 1000 FORMAT(1X,
11059 & 'DIAGR: no. of requested interactions ('
11060 & ,I4,') exceeds array dimensions (',I4,')')
11061 STOP
11062 ENDIF
11063 JS(INA) = JS(INA)+1
11064 JT(INB) = JT(INB)+1
11065 INTER1(JNT) = INA
11066 INTER2(JNT) = INB
11067 ENDIF
11068 ENDIF
11069 ENDIF
11070 5 CONTINUE
11071 4 CONTINUE
11072
11073 IF (JNT.EQ.0) THEN
11074 IF (NTRY.LT.500) THEN
11075 GOTO 3
11076 ELSE
11077C WRITE(6,*) ' new impact parameter required (old= ',B,')'
11078 GOTO 16
11079 ENDIF
11080 ENDIF
11081
11082 IDIREC = 0
11083 IF (IJPROJ.EQ.7) THEN
11084 K = INT(ONE+DT_RNDM(X)*DBLE(KINT))
11085 10 CONTINUE
11086 IF (JNT0(K).EQ.0) THEN
11087 K = K+1
11088 IF (K.GT.KINT) K = 1
11089 GOTO 10
11090 ENDIF
11091* supress Glauber-cascade by direct photon processes
11092 CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,2)
11093 IF (IPNT.GT.0) THEN
11094 JNT = 1
11095 JS(1) = 1
11096 DO 11 INB=1,NB
11097 JT(INB) = JT0(K,INB)
11098 IF (JT(INB).GT.0) GOTO 12
11099 11 CONTINUE
11100 12 CONTINUE
11101 INTER1(1) = 1
11102 INTER2(1) = INB
11103 IDIREC = IPNT
11104 ELSE
11105 JNT = JNT0(K)
11106 JS(1) = JS0(K)
11107 DO 13 INB=1,NB
11108 JT(INB) = JT0(K,INB)
11109 13 CONTINUE
11110 DO 14 I=1,JNT
11111 INTER1(I) = JI1(K,I)
11112 INTER2(I) = JI2(K,I)
11113 14 CONTINUE
11114 ENDIF
11115 ENDIF
11116
11117 19 CONTINUE
11118 INTA = 0
11119 INTB = 0
11120 DO 6 I=1,NA
11121 IF (JS(I).NE.0) INTA=INTA+1
11122 6 CONTINUE
11123 DO 7 I=1,NB
11124 IF (JT(I).NE.0) INTB=INTB+1
11125 7 CONTINUE
11126 ICWPG = INTA
11127 ICWTG = INTB
11128 ICIG = JNT
11129 IPGLB = IPGLB+INTA
11130 ITGLB = ITGLB+INTB
11131 NGLB = NGLB+1
11132
11133 IF (NCOMPO.EQ.0) THEN
11134 NCALL = NCALL+1
11135 NWA(INTA) = NWA(INTA)+1
11136 NWB(INTB) = NWB(INTB)+1
11137 ENDIF
11138
11139 RETURN
11140 END
11141
11142*$ CREATE DT_MODB.FOR
11143*COPY DT_MODB
11144*
11145*===modb===============================================================*
11146*
11147 SUBROUTINE DT_MODB(B,NIDX)
11148
11149************************************************************************
11150* Sampling of impact parameter of collision. *
11151* B impact parameter (output) *
11152* NIDX index of projectile/target material (input)*
11153* Based on the original version by Shmakov et al. *
11154* This version dated 21.04.95 is revised by S. Roesler *
11155* *
11156* Last change 27.12.2006 by S. Roesler. *
11157************************************************************************
11158
11159 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11160 SAVE
11161 PARAMETER ( LINP = 10 ,
11162 & LOUT = 6 ,
11163 & LDAT = 9 )
11164 PARAMETER (ZERO=0.0D0,TINY15=1.0D-15,ONE=1.0D0,TWO=2.0D0)
11165
11166 LOGICAL LEFT,LFIRST
11167
11168* central particle production, impact parameter biasing
11169 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
11170 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11171* Glauber formalism: parameters
11172 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11173 & BMAX(NCOMPX),BSTEP(NCOMPX),
11174 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11175 & NSITEB,NSTATB
11176* Glauber formalism: cross sections
11177 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11178 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11179 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11180 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11181 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11182 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11183 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11184 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11185 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11186 & BSLOPE,NEBINI,NQBINI
11187
11188 DATA LFIRST /.TRUE./
11189
11190 NTARG = ABS(NIDX)
11191 IF (NIDX.LE.-1) THEN
11192 RA = RASH(1)
11193 RB = RBSH(NTARG)
11194 ELSE
11195 RA = RASH(NTARG)
11196 RB = RBSH(1)
11197 ENDIF
11198
11199 IF (ICENTR.EQ.2) THEN
11200 IF (RA.EQ.RB) THEN
11201 BB = DT_RNDM(B)*(0.3D0*RA)**2
11202 B = SQRT(BB)
11203 ELSEIF(RA.LT.RB)THEN
11204 BB = DT_RNDM(B)*1.4D0*(RB-RA)**2
11205 B = SQRT(BB)
11206 ELSEIF(RA.GT.RB)THEN
11207 BB = DT_RNDM(B)*1.4D0*(RA-RB)**2
11208 B = SQRT(BB)
11209 ENDIF
11210 ELSE
11211 9 CONTINUE
11212 Y = DT_RNDM(BB)
11213 I0 = 1
11214 I2 = NSITEB
11215 10 CONTINUE
11216 I1 = (I0+I2)/2
11217 LEFT = ((BSITE(0,1,NTARG,I0)-Y)
11218 & *(BSITE(0,1,NTARG,I1)-Y)).LT.ZERO
11219 IF (LEFT) GOTO 20
11220 I0 = I1
11221 GOTO 30
11222 20 CONTINUE
11223 I2 = I1
11224 30 CONTINUE
11225 IF (I2-I0-2) 40,50,60
11226 40 CONTINUE
11227 I1 = I2+1
11228 IF (I1.GT.NSITEB) I1 = I0-1
11229 GOTO 70
11230 50 CONTINUE
11231 I1 = I0+1
11232 GOTO 70
11233 60 CONTINUE
11234 GOTO 10
11235 70 CONTINUE
11236 X0 = DBLE(I0-1)*BSTEP(NTARG)
11237 X1 = DBLE(I1-1)*BSTEP(NTARG)
11238 X2 = DBLE(I2-1)*BSTEP(NTARG)
11239 Y0 = BSITE(0,1,NTARG,I0)
11240 Y1 = BSITE(0,1,NTARG,I1)
11241 Y2 = BSITE(0,1,NTARG,I2)
11242 80 CONTINUE
11243 B = X0*(Y-Y1)*(Y-Y2)/((Y0-Y1)*(Y0-Y2)+TINY15)+
11244 & X1*(Y-Y0)*(Y-Y2)/((Y1-Y0)*(Y1-Y2)+TINY15)+
11245 & X2*(Y-Y0)*(Y-Y1)/((Y2-Y0)*(Y2-Y1)+TINY15)
11246**sr 5.4.98: shift B by half the bin width to be in agreement with BPROD
11247 B = B+0.5D0*BSTEP(NTARG)
11248 IF (B.LT.ZERO) B = X1
11249 IF (B.GT.BMAX(NTARG)) B = BMAX(NTARG)
11250 IF (ICENTR.LT.0) THEN
11251 IF (LFIRST) THEN
11252 LFIRST = .FALSE.
11253 IF (ICENTR.LE.-100) THEN
11254 BIMIN = 0.0D0
11255 ELSE
11256 XSFRAC = 0.0D0
11257 ENDIF
11258 CALL DT_GETBXS(XSFRAC,BIMIN,BIMAX,NTARG)
11259 WRITE(LOUT,1000) RASH(1),RBSH(NTARG),BMAX(NTARG),
11260 & BIMIN,BIMAX,XSFRAC*100.0D0,
11261 & XSFRAC*XSPRO(1,1,NTARG)
11262 10000 FORMAT(/,1X,'DT_MODB: Biasing in impact parameter',
11263 & /,15X,'---------------------------'/,/,4X,
11264 & 'average radii of proj / targ :',F10.3,' fm /',
11265 & F7.3,' fm',/,4X,'corresp. b_max (4*(r_p+r_t)) :',
11266 & F10.3,' fm',/,/,21X,'b_lo / b_hi :',
11267 & F10.3,' fm /',F7.3,' fm',/,5X,'percentage of',
11268 & ' cross section :',F10.3,' %',/,5X,
11269 & 'corresponding cross section :',F10.3,' mb',/)
11270 ENDIF
11271 IF (ABS(BIMAX-BIMIN).LT.1.0D-3) THEN
11272 B = BIMIN
11273 ELSE
11274 IF ((B.LT.BIMIN).OR.(B.GT.BIMAX)) GOTO 9
11275 ENDIF
11276 ENDIF
11277 ENDIF
11278
11279 RETURN
11280 END
11281
11282*$ CREATE DT_SHFAST.FOR
11283*COPY DT_SHFAST
11284*
11285*===shfast=============================================================*
11286*
11287 SUBROUTINE DT_SHFAST(MODE,PPN,IBACK)
11288
11289 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11290 SAVE
11291 PARAMETER ( LINP = 10 ,
11292 & LOUT = 6 ,
11293 & LDAT = 9 )
11294 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY1=1.0D-1,
11295 & ONE=1.0D0,TWO=2.0D0)
11296
11297 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11298* Glauber formalism: parameters
11299 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11300 & BMAX(NCOMPX),BSTEP(NCOMPX),
11301 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11302 & NSITEB,NSTATB
11303* properties of interacting particles
11304 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11305* Glauber formalism: cross sections
11306 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11307 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11308 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11309 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11310 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11311 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11312 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11313 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11314 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11315 & BSLOPE,NEBINI,NQBINI
11316
11317 IBACK = 0
11318
11319 IF (MODE.EQ.2) THEN
11320 OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11321 WRITE(47,1000) IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG,PPN
11322 1000 FORMAT(1X,8I5,E15.5)
11323 WRITE(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11324 1001 FORMAT(1X,4E15.5)
11325 WRITE(47,1002) SIGSH,ROSH,GSH
11326 1002 FORMAT(1X,3E15.5)
11327 DO 10 I=1,100
11328 WRITE(47,'(1X,E15.5)') BSITE(1,1,1,I)
11329 10 CONTINUE
11330 WRITE(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11331 1003 FORMAT(1X,2I10,3E15.5)
11332 CLOSE(47)
11333 ELSE
11334 OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11335 READ(47,1000) JT,JTZ,JP,JPZ,JJPROJ,JBPROJ,JJTARG,JBTARG,PP
11336 IF ((JT.EQ.IT).AND.(JTZ.EQ.ITZ).AND.(JP.EQ.IP).AND.
11337 & (JPZ.EQ.IPZ).AND.(JJPROJ.EQ.IJPROJ).AND.(JBPROJ.EQ.IBPROJ)
11338 & .AND.(JJTARG.EQ.IJTARG).AND.(JBTARG.EQ.IBTARG).AND.
11339 & (ABS(PP-PPN).LT.(PPN*0.01D0))) THEN
11340 READ(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11341 READ(47,1002) SIGSH,ROSH,GSH
11342 DO 11 I=1,100
11343 READ(47,'(1X,E15.5)') BSITE(1,1,1,I)
11344 11 CONTINUE
11345 READ(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11346 ELSE
11347 IBACK = 1
11348 ENDIF
11349 CLOSE(47)
11350 ENDIF
11351
11352 RETURN
11353 END
11354
11355*$ CREATE DT_POILIK.FOR
11356*COPY DT_POILIK
11357*
11358*===poilik=============================================================*
11359*
11360 SUBROUTINE DT_POILIK(NB,NTARG,ECM,VIRT,IPNT,RPNT,MODE)
11361
11362 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
11363 SAVE
11364
11365 PARAMETER ( LINP = 10 ,
11366 & LOUT = 6 ,
11367 & LDAT = 9 )
11368 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.0D0)
11369 PARAMETER (NE = 8)
11370
11371**PHOJET105a
11372C CHARACTER*8 MDLNA
11373C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
11374C PARAMETER (IEETAB=10)
11375C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
11376**PHOJET110
11377C model switches and parameters
11378 CHARACTER*8 MDLNA
11379 INTEGER ISWMDL,IPAMDL
11380 DOUBLE PRECISION PARMDL
11381 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11382C energy-interpolation table
11383 INTEGER IEETA2
11384 PARAMETER ( IEETA2 = 20 )
11385 INTEGER ISIMAX
11386 DOUBLE PRECISION SIGTAB,SIGECM
11387 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
11388**
11389* VDM parameter for photon-nucleus interactions
11390 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
11391**sr 22.7.97
11392 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11393* Glauber formalism: cross sections
11394 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11395 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11396 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11397 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11398 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11399 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11400 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11401 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11402 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11403 & BSLOPE,NEBINI,NQBINI
11404**
11405
11406 DATA ECMOLD,Q2OLD /-1.0D0,-1.0D0/
11407
11408 IF ((ECM.EQ.ECMOLD).AND.(VIRT.EQ.Q2OLD)) GOTO 3
11409
11410* load cross sections from interpolation table
11411 IP = 1
11412 IF(ECM.LE.SIGECM(IP,1)) THEN
11413 I1 = 1
11414 I2 = 1
11415 ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
11416 DO 50 I=2,ISIMAX
11417 IF(ECM.LE.SIGECM(IP,I)) GOTO 200
11418 50 CONTINUE
11419 200 CONTINUE
11420 I1 = I-1
11421 I2 = I
11422 ELSE
11423 WRITE(LOUT,'(/1X,A,2E12.3)')
11424 & 'POILIK:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
11425 I1 = ISIMAX
11426 I2 = ISIMAX
11427 ENDIF
11428 FAC2 = ZERO
11429 IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
11430 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
11431 FAC1 = ONE-FAC2
11432
11433 SIGANO = DT_SANO(ECM)
11434
11435* cross section dependence on photon virtuality
11436 FSUP1 = ZERO
11437 DO 150 I=1,3
11438 FSUP1 = FSUP1+PARMDL(26+I)*(ONE+VIRT/(4.D0*PARMDL(30+I)))
11439 & /(ONE+VIRT/PARMDL(30+I))**2
11440 150 CONTINUE
11441 FSUP1 = FSUP1+PARMDL(30)/(ONE+VIRT/PARMDL(34))
11442 FAC1 = FAC1*FSUP1
11443 FAC2 = FAC2*FSUP1
11444 FSUP2 = ONE
11445
11446 ECMOLD = ECM
11447 Q2OLD = VIRT
11448
11449 3 CONTINUE
11450
11451C SIGTOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
11452 CALL DT_SIGGP(ZERO,VIRT,ECM,ZERO,SIGTOT,DUM1,DUM2)
11453 IF (ISHAD(1).EQ.1) THEN
11454 SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
11455 ELSE
11456 SIGDIR = ZERO
11457 ENDIF
11458 SIGANO = FSUP1*FSUP2*SIGANO
11459 SIGTOT = SIGTOT-SIGDIR-SIGANO
11460 SIGDIR = SIGDIR/(FSUP1*FSUP2)
11461 SIGANO = SIGANO/(FSUP1*FSUP2)
11462 SIGTOT = SIGTOT+SIGDIR+SIGANO
11463
11464 RR = DT_RNDM(SIGTOT)
11465 IF (RR.LT.SIGDIR/SIGTOT) THEN
11466 IPNT = 1
11467 ELSEIF ((RR.GE.SIGDIR/SIGTOT).AND.
11468 & (RR.LT.(SIGDIR+SIGANO)/SIGTOT)) THEN
11469 IPNT = 2
11470 ELSE
11471 IPNT = 0
11472 ENDIF
11473 RPNT = (SIGDIR+SIGANO)/SIGTOT
11474C WRITE(LOUT,'(I3,2F15.5)') ISHAD(1),FAC1,FAC2
11475C WRITE(LOUT,'(I3,2F15.5)') MODE,SIGDIR,SIGANO
11476C WRITE(LOUT,'(I3,4F15.5)') MODE,SIGDIR+SIGANO,SIGTOT,RPNT,ECM
11477C WRITE(LOUT,'(1X,6E12.4)') ECM,VIRT,SIGTOT,SIGDIR,SIGANO,RPNT
11478 IF (MODE.EQ.1) RETURN
11479
11480**sr 22.7.97
11481 K1 = 1
11482 K2 = 1
11483 RATE = ZERO
11484 IF (ECM.GE.ECMNN(NEBINI)) THEN
11485 K1 = NEBINI
11486 K2 = NEBINI
11487 RATE = ONE
11488 ELSEIF (ECM.GT.ECMNN(1)) THEN
11489 DO 10 I=2,NEBINI
11490 IF (ECM.LT.ECMNN(I)) THEN
11491 K1 = I-1
11492 K2 = I
11493 RATE = (ECM-ECMNN(K1))/(ECMNN(K2)-ECMNN(K1))
11494 GOTO 11
11495 ENDIF
11496 10 CONTINUE
11497 11 CONTINUE
11498 ENDIF
11499 J1 = 1
11500 J2 = 1
11501 RATQ = ZERO
11502 IF (NQBINI.GT.1) THEN
11503 IF (VIRT.GE.Q2G(NQBINI)) THEN
11504 J1 = NQBINI
11505 J2 = NQBINI
11506 RATQ = ONE
11507 ELSEIF (VIRT.GT.Q2G(1)) THEN
11508 DO 12 I=2,NQBINI
11509 IF (VIRT.LT.Q2G(I)) THEN
11510 J1 = I-1
11511 J2 = I
11512 RATQ = LOG10( VIRT/MAX(Q2G(J1),TINY14))/
11513 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
11514 GOTO 13
11515 ENDIF
11516 12 CONTINUE
11517 13 CONTINUE
11518 ENDIF
11519 ENDIF
11520 SGA = XSPRO(K1,J1,NTARG)+
11521 & RATE*(XSPRO(K2,J1,NTARG)-XSPRO(K1,J1,NTARG))+
11522 & RATQ*(XSPRO(K1,J2,NTARG)-XSPRO(K1,J1,NTARG))+
11523 & RATE*RATQ*(XSPRO(K2,J2,NTARG)-XSPRO(K1,J2,NTARG)+
11524 & XSPRO(K1,J1,NTARG)-XSPRO(K2,J1,NTARG))
11525 SDI = DBLE(NB)*SIGDIR
11526 SAN = DBLE(NB)*SIGANO
11527 SPL = SDI+SAN
11528 RR = DT_RNDM(SPL)
11529 IF (RR.LT.SDI/SGA) THEN
11530 IPNT = 1
11531 ELSEIF ((RR.GE.SDI/SGA).AND.
11532 & (RR.LT.SPL/SGA)) THEN
11533 IPNT = 2
11534 ELSE
11535 IPNT = 0
11536 ENDIF
11537 RPNT = SPL/SGA
11538C WRITE(LOUT,'(I3,4F15.5)') MODE,SPL,SGA,RPNT,ECM
11539**
11540
11541 RETURN
11542 END
11543
11544*$ CREATE DT_GLBINI.FOR
11545*COPY DT_GLBINI
11546*
11547*===glbini=============================================================*
11548*
11549 SUBROUTINE DT_GLBINI(WHAT)
11550
11551************************************************************************
11552* Pre-initialization of profile function *
11553* This version dated 28.11.00 is written by S. Roesler. *
11554* *
11555* Last change 27.12.2006 by S. Roesler. *
11556************************************************************************
11557
11558 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11559 SAVE
11560
11561 PARAMETER ( LINP = 10 ,
11562 & LOUT = 6 ,
11563 & LDAT = 9 )
11564 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.D-14)
11565
11566 LOGICAL LCMS
11567
11568* particle properties (BAMJET index convention)
11569 CHARACTER*8 ANAME
11570 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11571 & IICH(210),IIBAR(210),K1(210),K2(210)
11572* properties of interacting particles
11573 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11574 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11575* emulsion treatment
11576 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11577 & NCOMPO,IEMUL
11578* Glauber formalism: flags and parameters for statistics
11579 LOGICAL LPROD
11580 CHARACTER*8 CGLB
11581 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11582* number of data sets other than protons and nuclei
11583* at the moment = 2 (pions and kaons)
11584 PARAMETER (MAXOFF=2)
11585 DIMENSION IJPINI(5),IOFFST(25)
11586 DATA IJPINI / 13, 15, 0, 0, 0/
11587* Glauber data-set to be used for hadron projectiles
11588* (0=proton, 1=pion, 2=kaon)
11589 DATA (IOFFST(K),K=1,25) /
11590 & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
11591 & 0, 0, 1, 2, 2/
11592* Acceptance interval for target nucleus mass
11593 PARAMETER (KBACC = 6)
11594* flags for input different options
11595 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
11596 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
11597 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
11598
11599 PARAMETER (MAXMSS = 100)
11600 DIMENSION IASAV(MAXMSS),IBSAV(MAXMSS)
11601 DIMENSION WHAT(6)
11602
11603 DATA JPEACH,JPSTEP / 18, 5 /
11604
11605* temporary patch until fix has been implemented in phojet:
11606* maximum energy for pion projectile
11607 DATA ECMXPI / 100000.0D0 /
11608*
11609*--------------------------------------------------------------------------
11610* general initializations
11611*
11612* steps in projectile mass number for initialization
11613 IF (WHAT(4).GT.ZERO) JPEACH = INT(WHAT(4))
11614 IF (WHAT(5).GT.ZERO) JPSTEP = INT(WHAT(5))
11615*
11616* energy range and binning
11617 ELO = ABS(WHAT(1))
11618 EHI = ABS(WHAT(2))
11619 IF (ELO.GT.EHI) ELO = EHI
11620 NEBIN = MAX(INT(WHAT(3)),1)
11621 IF (ELO.EQ.EHI) NEBIN = 0
11622 LCMS = (WHAT(1).LT.ZERO).OR.(WHAT(2).LT.ZERO)
11623 IF (LCMS) THEN
11624 ECMINI = EHI
11625 ELSE
11626 ECMINI = SQRT(AAM(IJPROJ)**2+AAM(IJTARG)**2
11627 & +2.0D0*AAM(IJTARG)*EHI)
11628 ENDIF
11629*
11630* default arguments for Glauber-routine
11631 XI = ZERO
11632 Q2I = ZERO
11633*
11634* initialize nuclear parameters, etc.
11635 CALL DT_BERTTP
11636 CALL DT_INCINI
11637*
11638* open Glauber-data output file
11639 IDX = INDEX(CGLB,' ')
11640 K = 12
11641 IF (IDX.GT.1) K = IDX-1
11642 OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
11643*
11644*--------------------------------------------------------------------------
11645* Glauber-initialization for proton and nuclei projectiles
11646*
11647* initialize phojet for proton-proton interactions
11648 ELAB = ZERO
11649 PLAB = ZERO
11650 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
11651 CALL DT_PHOINI
11652*
11653* record projectile masses
11654 NASAV = 0
11655 NPROJ = MIN(IP,JPEACH)
11656 DO 10 KPROJ=1,NPROJ
11657 NASAV = NASAV+1
11658 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11659 IASAV(NASAV) = KPROJ
11660 10 CONTINUE
11661 IF (IP.GT.JPEACH) THEN
11662 NPROJ = DBLE(IP-JPEACH)/DBLE(JPSTEP)
11663 IF (NPROJ.EQ.0) THEN
11664 NASAV = NASAV+1
11665 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11666 IASAV(NASAV) = IP
11667 ELSE
11668 DO 11 IPROJ=1,NPROJ
11669 KPROJ = JPEACH+IPROJ*JPSTEP
11670 NASAV = NASAV+1
11671 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11672 IASAV(NASAV) = KPROJ
11673 11 CONTINUE
11674 IF (KPROJ.LT.IP) THEN
11675 NASAV = NASAV+1
11676 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11677 IASAV(NASAV) = IP
11678 ENDIF
11679 ENDIF
11680 ENDIF
11681*
11682* record target masses
11683 NBSAV = 0
11684 NTARG = 1
11685 IF (NCOMPO.GT.0) NTARG = NCOMPO
11686 DO 12 ITARG=1,NTARG
11687 NBSAV = NBSAV+1
11688 IF (NBSAV.GT.MAXMSS) STOP ' GLBINI: NBSAV > MAXMSS ! '
11689 IF (NCOMPO.GT.0) THEN
11690 IBSAV(NBSAV) = IEMUMA(ITARG)
11691 ELSE
11692 IBSAV(NBSAV) = IT
11693 ENDIF
11694 12 CONTINUE
11695*
11696* print masses
11697 WRITE(LDAT,1000) NEBIN,': ',SIGN(ELO,WHAT(1)),SIGN(EHI,WHAT(2))
11698 1000 FORMAT(I4,A,1P,2E13.5)
11699 NLINES = DBLE(NASAV)/18.0D0
11700 IF (NLINES.GT.0) THEN
11701 DO 13 I=1,NLINES
11702 IF (I.EQ.1) THEN
11703 WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=1,18)
11704 ELSE
11705 WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=18*I-17,18*I)
11706 ENDIF
11707 13 CONTINUE
11708 ENDIF
11709 I0 = 18*NLINES+1
11710 IF (I0.LE.NASAV) THEN
11711 IF (I0.EQ.1) THEN
11712 WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=I0,NASAV)
11713 ELSE
11714 WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=I0,NASAV)
11715 ENDIF
11716 ENDIF
11717 NLINES = DBLE(NBSAV)/18.0D0
11718 IF (NLINES.GT.0) THEN
11719 DO 14 I=1,NLINES
11720 IF (I.EQ.1) THEN
11721 WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=1,18)
11722 ELSE
11723 WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=18*I-17,18*I)
11724 ENDIF
11725 14 CONTINUE
11726 ENDIF
11727 I0 = 18*NLINES+1
11728 IF (I0.LE.NBSAV) THEN
11729 IF (I0.EQ.1) THEN
11730 WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=I0,NBSAV)
11731 ELSE
11732 WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=I0,NBSAV)
11733 ENDIF
11734 ENDIF
11735*
11736* calculate Glauber-data for each energy and mass combination
11737*
11738* loop over energy bins
11739 ELO = LOG10(ELO)
11740 EHI = LOG10(EHI)
11741 DEBIN = (EHI-ELO)/MAX(DBLE(NEBIN),ONE)
11742 DO 1 IE=1,NEBIN+1
11743 E = ELO+DBLE(IE-1)*DEBIN
11744 E = 10**E
11745 IF (LCMS) THEN
11746 E = MAX(2.0D0*AAM(IJPROJ)+0.1D0,E)
11747 ECM = E
11748 ELSE
11749 PLAB = ZERO
11750 ECM = ZERO
11751 E = MAX(AAM(IJPROJ)+0.1D0,E)
11752 CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
11753 ENDIF
11754*
11755* loop over projectile and target masses
11756 DO 2 ITARG=1,NBSAV
11757 DO 3 IPROJ=1,NASAV
11758 CALL DT_XSGLAU(IASAV(IPROJ),IBSAV(ITARG),IJPROJ,
11759 & XI,Q2I,ECM,1,1,-1)
11760 3 CONTINUE
11761 2 CONTINUE
11762*
11763 1 CONTINUE
11764*
11765*--------------------------------------------------------------------------
11766* Glauber-initialization for pion, kaon, ... projectiles
11767*
11768 DO 6 IJ=1,MAXOFF
11769*
11770* initialize phojet for this interaction
11771 ELAB = ZERO
11772 PLAB = ZERO
11773 IJPROJ = IJPINI(IJ)
11774 IP = 1
11775 IPZ = 1
11776*
11777* temporary patch until fix has been implemented in phojet:
11778 IF (ECMINI.GT.ECMXPI) THEN
11779 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMXPI,1)
11780 ELSE
11781 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
11782 ENDIF
11783 CALL DT_PHOINI
11784*
11785* calculate Glauber-data for each energy and mass combination
11786*
11787* loop over energy bins
11788 DO 4 IE=1,NEBIN+1
11789 E = ELO+DBLE(IE-1)*DEBIN
11790 E = 10**E
11791 IF (LCMS) THEN
11792 E = MAX(2.0D0*AAM(IJPROJ)+TINY14,E)
11793 ECM = E
11794 ELSE
11795 PLAB = ZERO
11796 ECM = ZERO
11797 E = MAX(AAM(IJPROJ)+TINY14,E)
11798 CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
11799 ENDIF
11800*
11801* loop over projectile and target masses
11802 DO 5 ITARG=1,NBSAV
11803 CALL DT_XSGLAU(1,IBSAV(ITARG),IJPROJ,XI,Q2I,ECM,1,1,-1)
11804 5 CONTINUE
11805*
11806 4 CONTINUE
11807*
11808 6 CONTINUE
11809
11810*--------------------------------------------------------------------------
11811* close output unit(s), etc.
11812*
11813 CLOSE(LDAT)
11814
11815 RETURN
11816 END
11817
11818*$ CREATE DT_GLBSET.FOR
11819*COPY DT_GLBSET
11820*
11821*===glbset=============================================================*
11822*
11823 SUBROUTINE DT_GLBSET(IDPROJ,NA,NB,ELAB,MODE)
11824************************************************************************
11825* Interpolation of pre-initialized profile functions *
11826* This version dated 28.11.00 is written by S. Roesler. *
11827************************************************************************
11828
11829 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11830 SAVE
11831
11832 PARAMETER ( LINP = 10 ,
11833 & LOUT = 6 ,
11834 & LDAT = 9 )
11835 PARAMETER (ZERO=0.0D0,ONE=1.0D0)
11836
11837 LOGICAL LCMS,LREAD,LFRST1,LFRST2
11838
11839* particle properties (BAMJET index convention)
11840 CHARACTER*8 ANAME
11841 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11842 & IICH(210),IIBAR(210),K1(210),K2(210)
11843* Glauber formalism: flags and parameters for statistics
11844 LOGICAL LPROD
11845 CHARACTER*8 CGLB
11846 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11847 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11848* Glauber formalism: parameters
11849 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11850 & BMAX(NCOMPX),BSTEP(NCOMPX),
11851 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11852 & NSITEB,NSTATB
11853* Glauber formalism: cross sections
11854 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11855 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11856 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11857 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11858 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11859 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11860 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11861 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11862 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11863 & BSLOPE,NEBINI,NQBINI
11864* number of data sets other than protons and nuclei
11865* at the moment = 2 (pions and kaons)
11866 PARAMETER (MAXOFF=2)
11867 DIMENSION IJPINI(5),IOFFST(25)
11868 DATA IJPINI / 13, 15, 0, 0, 0/
11869* Glauber data-set to be used for hadron projectiles
11870* (0=proton, 1=pion, 2=kaon)
11871 DATA (IOFFST(K),K=1,25) /
11872 & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
11873 & 0, 0, 1, 2, 2/
11874* Acceptance interval for target nucleus mass
11875 PARAMETER (KBACC = 6)
11876* emulsion treatment
11877 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11878 & NCOMPO,IEMUL
11879
11880 PARAMETER (MAXSET=5000,
11881 & MAXBIN=100)
11882 DIMENSION XSIG(MAXSET,6),XERR(MAXSET,6),BPROFL(MAXSET,KSITEB)
11883 DIMENSION IABIN(MAXBIN),IBBIN(MAXBIN),XS(6),XE(6),
11884 & BPRO0(KSITEB),BPRO1(KSITEB),BPRO(KSITEB),
11885 & IAIDX(10)
11886
11887 DATA LREAD,LFRST1,LFRST2 /.FALSE.,.TRUE.,.TRUE./
11888*
11889* read data from file
11890*
11891 IF (MODE.EQ.0) THEN
11892
11893 IF (LREAD) RETURN
11894
11895 DO 1 I=1,MAXSET
11896 DO 2 J=1,6
11897 XSIG(I,J) = ZERO
11898 XERR(I,J) = ZERO
11899 2 CONTINUE
11900 DO 3 J=1,KSITEB
11901 BPROFL(I,J) = ZERO
11902 3 CONTINUE
11903 1 CONTINUE
11904 DO 4 I=1,MAXBIN
11905 IABIN(I) = 0
11906 IBBIN(I) = 0
11907 4 CONTINUE
11908 DO 5 I=1,KSITEB
11909 BPRO0(I) = ZERO
11910 BPRO1(I) = ZERO
11911 BPRO(I) = ZERO
11912 5 CONTINUE
11913
11914 IDX = INDEX(CGLB,' ')
11915 K = 12
11916 IF (IDX.GT.1) K = IDX-1
11917 OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
11918 WRITE(LOUT,1000) CGLB(1:K)//'.glb'
11919 1000 FORMAT(/,' GLBSET: impact parameter distributions read from ',
11920 & 'file ',A12,/)
11921*
11922* read binning information
11923 READ(LDAT,'(I4,2X,2E13.5)') NEBIN,ELO,EHI
11924* return lower energy threshold to Fluka-interface
11925 ELAB = ELO
11926 LCMS = ELO.LT.ZERO
11927 WRITE(LOUT,'(1X,A)') ' equidistant logarithmic energy binning:'
11928 IF (LCMS) THEN
11929 WRITE(LOUT,1001) '(cms)',ABS(ELO),ABS(EHI),NEBIN
11930 ELSE
11931 WRITE(LOUT,1001) '(lab)',ABS(ELO),ABS(EHI),NEBIN
11932 ENDIF
11933 1001 FORMAT(2X,A5,' E_lo = ',1P,E9.3,' E_hi = ',1P,E9.3,4X,
11934 & 'No. of bins:',I5,/)
11935 ELO = LOG10(ABS(ELO))
11936 EHI = LOG10(ABS(EHI))
11937 DEBIN = (EHI-ELO)/ABS(DBLE(NEBIN))
11938 WRITE(LOUT,'(/,1X,A)') ' projectiles: (mass number)'
11939 READ(LDAT,'(I4,2X,18I4)') NABIN,(IABIN(J),J=1,18)
11940 IF (NABIN.LT.18) THEN
11941 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,NABIN)
11942 ELSE
11943 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,18)
11944 ENDIF
11945 IF (NABIN.GT.MAXBIN) STOP ' GLBSET: NABIN > MAXBIN !'
11946 IF (NABIN.GT.18) THEN
11947 NLINES = DBLE(NABIN-18)/18.0D0
11948 IF (NLINES.GT.0) THEN
11949 DO 7 I=1,NLINES
11950 I0 = 18*(I+1)-17
11951 READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
11952 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
11953 7 CONTINUE
11954 ENDIF
11955 I0 = 18*(NLINES+1)+1
11956 IF (I0.LE.NABIN) THEN
11957 READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
11958 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
11959 ENDIF
11960 ENDIF
11961 WRITE(LOUT,'(/,1X,A)') ' targets: (mass number)'
11962 READ(LDAT,'(I4,2X,18I4)') NBBIN,(IBBIN(J),J=1,18)
11963 IF (NBBIN.LT.18) THEN
11964 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,NBBIN)
11965 ELSE
11966 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,18)
11967 ENDIF
11968 IF (NBBIN.GT.MAXBIN) STOP ' GLBSET: NBBIN > MAXBIN !'
11969 IF (NBBIN.GT.18) THEN
11970 NLINES = DBLE(NBBIN-18)/18.0D0
11971 IF (NLINES.GT.0) THEN
11972 DO 8 I=1,NLINES
11973 I0 = 18*(I+1)-17
11974 READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
11975 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
11976 8 CONTINUE
11977 ENDIF
11978 I0 = 18*(NLINES+1)+1
11979 IF (I0.LE.NBBIN) THEN
11980 READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
11981 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
11982 ENDIF
11983 ENDIF
11984* number of data sets to follow in the Glauber data file
11985* this variable is used for checks of consistency of projectile
11986* and target mass configurations given in header of Glauber data
11987* file and the data-sets which follow in this file
11988 NSET0 = (NEBIN+1)*(NABIN+MAXOFF)*NBBIN
11989*
11990* read profile function data
11991 NSET = 0
11992 NAIDX = 0
11993 IPOLD = 0
11994 10 CONTINUE
11995 NSET = NSET+1
11996 IF (NSET.GT.MAXSET) STOP ' GLBSET: NSET > MAXSET ! '
11997 READ(LDAT,1002,END=100) IP,IA,IB,ISTATB,ISITEB,ECM
11998 1002 FORMAT(5I10,E15.5)
11999 IF ((IP.NE.1).AND.(IP.NE.IPOLD)) THEN
12000 NAIDX = NAIDX+1
12001 IF (NAIDX.GT.10) STOP ' GLBSET: NAIDX > 10 !'
12002 IAIDX(NAIDX) = IP
12003 IPOLD = IP
12004 ENDIF
12005 READ(LDAT,'(6E12.5)') (XSIG(NSET,I),I=1,6)
12006 READ(LDAT,'(6E12.5)') (XERR(NSET,I),I=1,6)
12007 NLINES = INT(DBLE(ISITEB)/7.0D0)
12008 IF (NLINES.GT.0) THEN
12009 DO 11 I=1,NLINES
12010 READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=7*I-6,7*I)
12011 11 CONTINUE
12012 ENDIF
12013 I0 = 7*NLINES+1
12014 IF (I0.LE.ISITEB)
12015 & READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=I0,ISITEB)
12016 GOTO 10
12017 100 CONTINUE
12018 NSET = NSET-1
12019 IF (NSET.NE.NSET0) STOP ' GLBSET: NSET.NE.NSET0 !'
12020 WRITE(LOUT,'(/,1X,A)')
12021 & ' projectiles other than protons and nuclei: (particle index)'
12022 IF (NAIDX.GT.0) THEN
12023 WRITE(LOUT,'(6X,18I4)') (IAIDX(J),J=1,NAIDX)
12024 ELSE
12025 WRITE(LOUT,'(6X,A)') 'none'
12026 ENDIF
12027*
12028 CLOSE(LDAT)
12029 WRITE(LOUT,*)
12030 LREAD = .TRUE.
12031
12032 IF (NCOMPO.EQ.0) THEN
12033 DO 12 J=1,NBBIN
12034 NCOMPO = NCOMPO+1
12035 IEMUMA(NCOMPO) = IBBIN(J)
12036 IEMUCH(NCOMPO) = IEMUMA(NCOMPO)/2
12037 EMUFRA(NCOMPO) = 1.0D0
12038 12 CONTINUE
12039 IEMUL = 1
12040 ENDIF
12041*
12042* calculate profile function for certain set of parameters
12043*
12044 ELSE
12045
12046c write(*,*) 'glbset called for ',IDPROJ,NA,NB,ELAB,MODE
12047*
12048* check for type of projectile and set index-offset to entry in
12049* Glauber data array correspondingly
12050 IF (IDPROJ.GT.25) STOP ' GLBSET: IDPROJ > 25 !'
12051 IF (IOFFST(IDPROJ).EQ.-1) THEN
12052 STOP ' GLBSET: no data for this projectile !'
12053 ELSEIF (IOFFST(IDPROJ).GT.0) THEN
12054 IDXOFF = (NEBIN+1)*(NABIN+IOFFST(IDPROJ)-1)*NBBIN
12055 ELSE
12056 IDXOFF = 0
12057 ENDIF
12058*
12059* get energy bin and interpolation factor
12060 IF (LCMS) THEN
12061 E = SQRT(AAM(IDPROJ)**2+AAM(1)**2+2.0D0*AAM(1)*ELAB)
12062 ELSE
12063 E = ELAB
12064 ENDIF
12065 E = LOG10(E)
12066 IF (E.LT.ELO) THEN
12067 IF (LFRST1) THEN
12068 WRITE(LOUT,*) ' GLBSET: Too low energy! (E_lo,E) ',ELO,E
12069 LFRST1 = .FALSE.
12070 ENDIF
12071 E = ELO
12072 ENDIF
12073 IF (E.GT.EHI) THEN
12074 IF (LFRST2) THEN
12075 WRITE(LOUT,*) ' GLBSET: Too high energy! (E_hi,E) ',EHI,E
12076 LFRST2 = .FALSE.
12077 ENDIF
12078 E = EHI
12079 ENDIF
12080 IE0 = (E-ELO)/DEBIN+1
12081 IE1 = IE0+1
12082 FACE = (E-(ELO+DBLE(IE0-1)*DEBIN))/DEBIN
12083*
12084* get target nucleus index
12085 KB = 0
12086 NBACC = KBACC
12087 DO 20 I=1,NBBIN
12088 NBDIFF = ABS(NB-IBBIN(I))
12089 IF (NB.EQ.IBBIN(I)) THEN
12090 KB = I
12091 GOTO 21
12092 ELSEIF (NBDIFF.LE.NBACC) THEN
12093 KB = I
12094 NBACC = NBDIFF
12095 ENDIF
12096 20 CONTINUE
12097 IF (KB.NE.0) GOTO 21
12098 WRITE(LOUT,*) ' GLBSET: data not found for target ',NB
12099 STOP
12100 21 CONTINUE
12101*
12102* get projectile nucleus bin and interpolation factor
12103 KA0 = 0
12104 KA1 = 0
12105 FACNA = 0
12106 IF (IDXOFF.GT.0) THEN
12107 KA0 = 1
12108 KA1 = 1
12109 KABIN = 1
12110 ELSE
12111 IF (NA.GT.IABIN(NABIN)) STOP ' GLBSET: NA > IABIN(NABIN) !'
12112 DO 22 I=1,NABIN
12113 IF (NA.EQ.IABIN(I)) THEN
12114 KA0 = I
12115 KA1 = I
12116 GOTO 23
12117 ELSEIF (NA.LT.IABIN(I)) THEN
12118 KA0 = I-1
12119 KA1 = I
12120 GOTO 23
12121 ENDIF
12122 22 CONTINUE
12123 WRITE(LOUT,*) ' GLBSET: data not found for projectile ',NA
12124 STOP
12125 23 CONTINUE
12126 IF (KA0.NE.KA1)
12127 & FACNA = DBLE(NA-IABIN(KA0))/DBLE(IABIN(KA1)-IABIN(KA0))
12128 KABIN = NABIN
12129 ENDIF
12130*
12131* interpolate profile functions for interactions ka0-kb and ka1-kb
12132* for energy E separately
12133 IDX0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12134 IDX1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12135 IDY0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12136 IDY1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12137 DO 30 I=1,ISITEB
12138 BPRO0(I) = BPROFL(IDX0,I)
12139 & +FACE*(BPROFL(IDX1,I)-BPROFL(IDX0,I))
12140 BPRO1(I) = BPROFL(IDY0,I)
12141 & +FACE*(BPROFL(IDY1,I)-BPROFL(IDY0,I))
12142 30 CONTINUE
12143 RADB = DT_RNCLUS(NB)
12144 BSTP0 = 2.0D0*(DT_RNCLUS(IABIN(KA0))+RADB)/DBLE(ISITEB-1)
12145 BSTP1 = 2.0D0*(DT_RNCLUS(IABIN(KA1))+RADB)/DBLE(ISITEB-1)
12146*
12147* interpolate cross sections for energy E and projectile mass
12148 DO 31 I=1,6
12149 XS0 = XSIG(IDX0,I)+FACE*(XSIG(IDX1,I)-XSIG(IDX0,I))
12150 XS1 = XSIG(IDY0,I)+FACE*(XSIG(IDY1,I)-XSIG(IDY0,I))
12151 XS(I) = XS0+FACNA*(XS1-XS0)
12152 XE0 = XERR(IDX0,I)+FACE*(XERR(IDX1,I)-XERR(IDX0,I))
12153 XE1 = XERR(IDY0,I)+FACE*(XERR(IDY1,I)-XERR(IDY0,I))
12154 XE(I) = XE0+FACNA*(XE1-XE0)
12155 31 CONTINUE
12156*
12157* interpolate between ka0 and ka1
12158 RADA = DT_RNCLUS(NA)
12159 BMX = 2.0D0*(RADA+RADB)
12160 BSTP = BMX/DBLE(ISITEB-1)
12161 BPRO(1) = ZERO
12162 DO 32 I=1,ISITEB-1
12163 B = DBLE(I)*BSTP
12164*
12165* calculate values of profile functions at B
12166 IDX0 = B/BSTP0+1
12167 IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12168 IDX1 = MIN(IDX0+1,ISITEB)
12169 FACB = (B-DBLE(IDX0-1)*BSTP0)/BSTP0
12170 BPR0 = BPRO0(IDX0)+FACB*(BPRO0(IDX1)-BPRO0(IDX0))
12171 IDX0 = B/BSTP1+1
12172 IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12173 IDX1 = MIN(IDX0+1,ISITEB)
12174 FACB = (B-DBLE(IDX0-1)*BSTP1)/BSTP1
12175 BPR1 = BPRO1(IDX0)+FACB*(BPRO1(IDX1)-BPRO1(IDX0))
12176*
12177 BPRO(I+1) = BPR0+FACNA*(BPR1-BPR0)
12178 32 CONTINUE
12179*
12180* fill common dtglam
12181 NSITEB = ISITEB
12182 RASH(1) = RADA
12183 RBSH(1) = RADB
12184 BMAX(1) = BMX
12185 BSTEP(1) = BSTP
12186 DO 33 I=1,KSITEB
12187 BSITE(0,1,1,I) = BPRO(I)
12188 33 CONTINUE
12189*
12190* fill common dtglxs
12191 XSTOT(1,1,1) = XS(1)
12192 XSELA(1,1,1) = XS(2)
12193 XSQEP(1,1,1) = XS(3)
12194 XSQET(1,1,1) = XS(4)
12195 XSQE2(1,1,1) = XS(5)
12196 XSPRO(1,1,1) = XS(6)
12197 XETOT(1,1,1) = XE(1)
12198 XEELA(1,1,1) = XE(2)
12199 XEQEP(1,1,1) = XE(3)
12200 XEQET(1,1,1) = XE(4)
12201 XEQE2(1,1,1) = XE(5)
12202 XEPRO(1,1,1) = XE(6)
12203
12204 ENDIF
12205
12206 RETURN
12207 END
12208
12209*$ CREATE DT_XKSAMP.FOR
12210*COPY DT_XKSAMP
12211*
12212*===xksamp=============================================================*
12213*
12214 SUBROUTINE DT_XKSAMP(NN,ECM)
12215
12216************************************************************************
12217* Sampling of parton x-values and chain system for one interaction. *
12218* processed by S. Roesler, 9.8.95 *
12219************************************************************************
12220
12221 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12222 SAVE
12223 PARAMETER ( LINP = 10 ,
12224 & LOUT = 6 ,
12225 & LDAT = 9 )
12226 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
454792a9 12227CPH SAVE
9aaba0d6 12228
12229 PARAMETER (
12230* lower cuts for (valence-sea/sea-valence) chain masses
12231* antiquark-quark (u/d-sea quark) (s-sea quark)
12232 & AMIU = 0.5D0, AMIS = 0.8D0,
12233* quark-diquark (u/d-sea quark) (s-sea quark)
12234 & AMAU = 2.6D0, AMAS = 2.6D0,
12235* maximum lower valence-x threshold
12236 & XVMAX = 0.98D0,
12237* fraction of sea-diquarks sampled out of sea-partons
12238**test
12239C & FRCDIQ = 0.9D0,
12240**
12241*
12242 & SQMA = 0.7D0,
12243*
12244* maximum number of trials to generate x's for the required number
12245* of sea quark pairs for a given hadron
12246 & NSEATY = 12
12247C & NSEATY = 3
12248 & )
12249
12250 LOGICAL ZUOVP,ZUOSP,ZUOVT,ZUOST,INTLO
12251
12252 PARAMETER ( MAXNCL = 260,
12253 & MAXVQU = MAXNCL,
12254 & MAXSQU = 20*MAXVQU,
12255 & MAXINT = MAXVQU+MAXSQU)
12256* event history
12257 PARAMETER (NMXHKK=200000)
12258 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
12259 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
12260 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
12261* particle properties (BAMJET index convention)
12262 CHARACTER*8 ANAME
12263 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12264 & IICH(210),IIBAR(210),K1(210),K2(210)
12265* interface between Glauber formalism and DPM
12266 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
12267 & INTER1(MAXINT),INTER2(MAXINT)
12268* properties of interacting particles
12269 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
12270* threshold values for x-sampling (DTUNUC 1.x)
12271 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
12272 & SSMIMQ,VVMTHR
12273* x-values of partons (DTUNUC 1.x)
12274 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
12275 & XTVQ(MAXVQU),XTVD(MAXVQU),
12276 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
12277 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
12278* flavors of partons (DTUNUC 1.x)
12279 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
12280 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
12281 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
12282 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
12283 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
12284 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
12285 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
12286* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12287 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
12288 & IXPV,IXPS,IXTV,IXTS,
12289 & INTVV1(MAXVQU),INTVV2(MAXVQU),
12290 & INTSV1(MAXVQU),INTSV2(MAXVQU),
12291 & INTVS1(MAXVQU),INTVS2(MAXVQU),
12292 & INTSS1(MAXSQU),INTSS2(MAXSQU),
12293 & INTDV1(MAXVQU),INTDV2(MAXVQU),
12294 & INTVD1(MAXVQU),INTVD2(MAXVQU),
12295 & INTDS1(MAXSQU),INTDS2(MAXSQU),
12296 & INTSD1(MAXSQU),INTSD2(MAXSQU)
12297* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12298 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
12299 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
12300* auxiliary common for chain system storage (DTUNUC 1.x)
12301 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
12302* flags for input different options
12303 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
12304 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
12305 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
12306* various options for treatment of partons (DTUNUC 1.x)
12307* (chain recombination, Cronin,..)
12308 LOGICAL LCO2CR,LINTPT
12309 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
12310 & LCO2CR,LINTPT
12311
12312 DIMENSION ZUOVP(MAXVQU),ZUOSP(MAXSQU),ZUOVT(MAXVQU),ZUOST(MAXSQU),
12313 & INTLO(MAXINT)
12314
12315* (1) initializations
12316*-----------------------------------------------------------------------
12317
12318**test
12319 IF (ECM.LT.4.5D0) THEN
12320C FRCDIQ = 0.6D0
12321 FRCDIQ = 0.4D0
12322 ELSEIF ((ECM.GE.4.5D0).AND.(ECM.LT.7.5)) THEN
12323C FRCDIQ = 0.6D0+(ECM-4.5D0)/3.0D0*0.3D0
12324 FRCDIQ = 0.4D0+(ECM-4.5D0)/3.0D0*0.3D0
12325 ELSE
12326C FRCDIQ = 0.9D0
12327 FRCDIQ = 0.7D0
12328 ENDIF
12329**
12330 DO 30 I=1,MAXSQU
12331 ZUOSP(I) = .FALSE.
12332 ZUOST(I) = .FALSE.
12333 IF (I.LE.MAXVQU) THEN
12334 ZUOVP(I) = .FALSE.
12335 ZUOVT(I) = .FALSE.
12336 ENDIF
12337 30 CONTINUE
12338
12339* lower thresholds for x-selection
12340* sea-quarks (default: CSEA=0.2)
12341 IF (ECM.LT.10.0D0) THEN
12342**!!test
12343 XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM
12344C XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM**2.0D0
12345 NSEA = NSEATY
12346C XSTHR = ONE/ECM**2
12347 ELSE
12348**sr 30.3.98
12349C XSTHR = CSEA/ECM
12350 XSTHR = CSEA/ECM**2
12351C XSTHR = ONE/ECM**2
12352**
12353 IF ((IP.GE.150).AND.(IT.GE.150))
12354 & XSTHR = 2.5D0/(ECM*SQRT(ECM))
12355 NSEA = NSEATY
12356 ENDIF
12357* (default: SSMIMA=0.14) used for sea-diquarks (?)
12358 XSSTHR = SSMIMA/ECM
12359 BSQMA = SQMA/ECM
12360* valence-quarks (default: CVQ=1.0)
12361 XVTHR = CVQ/ECM
12362* valence-diquarks (default: CDQ=2.0)
12363 XDTHR = CDQ/ECM
12364
12365* maximum-x for sea-quarks
12366 XVCUT = XVTHR+XDTHR
12367 IF (XVCUT.GT.XVMAX) THEN
12368 XVCUT = XVMAX
12369 XVTHR = XVCUT/3.0D0
12370 XDTHR = XVCUT-XVTHR
12371 ENDIF
12372 XXSEAM = ONE-XVCUT
12373**sr 18.4. test: DPMJET
12374C XXSEAM=1.0 - XVTHR*(1.D0+0.3D0*DT_RNDM(V1))
12375C & - XDTHR*(1.D0+0.3D0*DT_RNDM(V2))
12376C & -0.01*(1.D0+1.5D0*DT_RNDM(V3))
12377**
12378* maximum number of sea-pairs allowed kinematically
12379C NSMAX = INT(OHALF*XXSEAM/XSTHR)
12380 RNSMAX = OHALF*XXSEAM/XSTHR
12381 IF (RNSMAX.GT.10000.0D0) THEN
12382 NSMAX = 10000
12383 ELSE
12384 NSMAX = INT(OHALF*XXSEAM/XSTHR)
12385 ENDIF
12386* check kinematical limit for valence-x thresholds
12387* (should be obsolete now)
12388 IF (XVCUT.GT.XVMAX) THEN
12389 WRITE(LOUT,1000) XVCUT,ECM
12390 1000 FORMAT(' XKSAMP: kin. limit for valence-x',
12391 & ' thresholds not allowed (',2E9.3,')')
12392C XVTHR = XVMAX-XDTHR
12393C IF (XVTHR.LT.ZERO) STOP
12394 STOP
12395 ENDIF
12396
12397* set eta for valence-x sampling (BETREJ)
12398* (UNON per default, UNOM used for projectile mesons only)
12399 IF ((IJPROJ.NE.0).AND.(IBPROJ.EQ.0)) THEN
12400 UNOPRV = UNOM
12401 ELSE
12402 UNOPRV = UNON
12403 ENDIF
12404
12405* (2) select parton x-values of interacting projectile nucleons
12406*-----------------------------------------------------------------------
12407
12408 IXPV = 0
12409 IXPS = 0
12410
12411 DO 100 IPP=1,IP
12412* get interacting projectile nucleon as sampled by Glauber
12413 IF (JSSH(IPP).NE.0) THEN
12414 IXSTMP = IXPS
12415 IXVTMP = IXPV
12416 99 CONTINUE
12417 IXPS = IXSTMP
12418 IXPV = IXVTMP
12419* JIPP is the actual number of sea-pairs sampled for this nucleon
12420 JIPP = MIN(JSSH(IPP)-1,NSMAX)
12421 41 CONTINUE
12422 XXSEA = ZERO
12423 IF (JIPP.GT.0) THEN
12424 XSMAX = XXSEAM-2.0D0*DBLE(JIPP)*XSTHR
12425*???
12426 IF (XSTHR.GE.XSMAX) THEN
12427 JIPP = JIPP-1
12428 GOTO 41
12429 ENDIF
12430
12431*>>>get x-values of sea-quark pairs
12432 NSCOUN = 0
12433 PLW = 0.5D0
12434 40 CONTINUE
12435* accumulator for sea x-values
12436 XXSEA = ZERO
12437 NSCOUN = NSCOUN+1
12438 IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
12439 IF (NSCOUN.GT.NSEA) THEN
12440* decrease the number of interactions after NSEA trials
12441 JIPP = JIPP-1
12442 NSCOUN = 0
12443 ENDIF
12444 DO 70 ISQ=1,JIPP
12445* sea-quarks
12446 IF (IPSQ(IXPS+1).LE.2) THEN
12447**sr 8.4.98 (1/sqrt(x))
12448C XPSQI = DT_SAMPEX(XSTHR,XSMAX)
12449C XPSQI = DT_SAMSQX(XSTHR,XSMAX)
12450 XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12451**
12452 ELSE
12453 IF (XSMAX.GT.XSTHR+BSQMA) THEN
12454 XPSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12455 ELSE
12456**sr 8.4.98 (1/sqrt(x))
12457C XPSQI = DT_SAMPEX(XSTHR,XSMAX)
12458C XPSQI = DT_SAMSQX(XSTHR,XSMAX)
12459 XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12460**
12461 ENDIF
12462 ENDIF
12463* sea-antiquarks
12464 IF (IPSAQ(IXPS+1).GE.-2) THEN
12465**sr 8.4.98 (1/sqrt(x))
12466C XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
12467C XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
12468 XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12469**
12470 ELSE
12471 IF (XSMAX.GT.XSTHR+BSQMA) THEN
12472 XPSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12473 ELSE
12474**sr 8.4.98 (1/sqrt(x))
12475C XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
12476C XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
12477 XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12478**
12479 ENDIF
12480 ENDIF
12481 XXSEA = XXSEA+XPSQI+XPSAQI
12482* check for maximum allowed sea x-value
12483 IF (XXSEA.GE.XXSEAM) THEN
12484 IXPS = IXPS-ISQ+1
12485 GOTO 40
12486 ENDIF
12487* accept this sea-quark pair
12488 IXPS = IXPS+1
12489 XPSQ(IXPS) = XPSQI
12490 XPSAQ(IXPS) = XPSAQI
12491 IFROSP(IXPS) = IPP
12492 ZUOSP(IXPS) = .TRUE.
12493 70 CONTINUE
12494 ENDIF
12495
12496*>>>get x-values of valence partons
12497* valence quark
12498 IF (XVTHR.GT.0.05D0) THEN
12499 XVHI = ONE-XXSEA-XDTHR
12500 XPVQI = DT_BETREJ(OHALF,UNOPRV,XVTHR,XVHI)
12501 ELSE
12502 90 CONTINUE
12503 XPVQI = DT_DBETAR(OHALF,UNOPRV)
12504 IF ((XPVQI.LT.XVTHR).OR.(ONE-XPVQI-XXSEA.LT.XDTHR))
12505 & GOTO 90
12506 ENDIF
12507* valence diquark
12508 XPVDI = ONE-XPVQI-XXSEA
12509* reject according to x**1.5
12510 XDTMP = XPVDI**1.5D0
12511 IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 99
12512* accept these valence partons
12513 IXPV = IXPV+1
12514 XPVQ(IXPV) = XPVQI
12515 XPVD(IXPV) = XPVDI
12516 IFROVP(IXPV) = IPP
12517 ITOVP(IPP) = IXPV
12518 ZUOVP(IXPV) = .TRUE.
12519
12520 ENDIF
12521 100 CONTINUE
12522
12523* (3) select parton x-values of interacting target nucleons
12524*-----------------------------------------------------------------------
12525
12526 IXTV = 0
12527 IXTS = 0
12528
12529 DO 170 ITT=1,IT
12530* get interacting target nucleon as sampled by Glauber
12531 IF (JTSH(ITT).NE.0) THEN
12532 IXSTMP = IXTS
12533 IXVTMP = IXTV
12534 169 CONTINUE
12535 IXTS = IXSTMP
12536 IXTV = IXVTMP
12537* JITT is the actual number of sea-pairs sampled for this nucleon
12538 JITT = MIN(JTSH(ITT)-1,NSMAX)
12539 111 CONTINUE
12540 XXSEA = ZERO
12541 IF (JITT.GT.0) THEN
12542 XSMAX = XXSEAM-2.0D0*DBLE(JITT)*XSTHR
12543*???
12544 IF (XSTHR.GE.XSMAX) THEN
12545 JITT = JITT-1
12546 GOTO 111
12547 ENDIF
12548
12549*>>>get x-values of sea-quark pairs
12550 NSCOUN = 0
12551 PLW = 0.5D0
12552 110 CONTINUE
12553* accumulator for sea x-values
12554 XXSEA = ZERO
12555 NSCOUN = NSCOUN+1
12556 IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
12557 IF (NSCOUN.GT.NSEA)THEN
12558* decrease the number of interactions after NSEA trials
12559 JITT = JITT-1
12560 NSCOUN = 0
12561 ENDIF
12562 DO 140 ISQ=1,JITT
12563* sea-quarks
12564 IF (ITSQ(IXTS+1).LE.2) THEN
12565**sr 8.4.98 (1/sqrt(x))
12566C XTSQI = DT_SAMPEX(XSTHR,XSMAX)
12567C XTSQI = DT_SAMSQX(XSTHR,XSMAX)
12568 XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12569**
12570 ELSE
12571 IF (XSMAX.GT.XSTHR+BSQMA) THEN
12572 XTSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12573 ELSE
12574**sr 8.4.98 (1/sqrt(x))
12575C XTSQI = DT_SAMPEX(XSTHR,XSMAX)
12576C XTSQI = DT_SAMSQX(XSTHR,XSMAX)
12577 XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12578**
12579 ENDIF
12580 ENDIF
12581* sea-antiquarks
12582 IF (ITSAQ(IXTS+1).GE.-2) THEN
12583**sr 8.4.98 (1/sqrt(x))
12584C XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
12585C XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
12586 XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12587**
12588 ELSE
12589 IF (XSMAX.GT.XSTHR+BSQMA) THEN
12590 XTSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12591 ELSE
12592**sr 8.4.98 (1/sqrt(x))
12593C XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
12594C XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
12595 XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12596**
12597 ENDIF
12598 ENDIF
12599 XXSEA = XXSEA+XTSQI+XTSAQI
12600* check for maximum allowed sea x-value
12601 IF (XXSEA.GE.XXSEAM) THEN
12602 IXTS = IXTS-ISQ+1
12603 GOTO 110
12604 ENDIF
12605* accept this sea-quark pair
12606 IXTS = IXTS+1
12607 XTSQ(IXTS) = XTSQI
12608 XTSAQ(IXTS) = XTSAQI
12609 IFROST(IXTS) = ITT
12610 ZUOST(IXTS) = .TRUE.
12611 140 CONTINUE
12612 ENDIF
12613
12614*>>>get x-values of valence partons
12615* valence quark
12616 IF (XVTHR.GT.0.05D0) THEN
12617 XVHI = ONE-XXSEA-XDTHR
12618 XTVQI = DT_BETREJ(OHALF,UNON,XVTHR,XVHI)
12619 ELSE
12620 160 CONTINUE
12621 XTVQI = DT_DBETAR(OHALF,UNON)
12622 IF ((XTVQI.LT.XVTHR).OR.(ONE-XTVQI-XXSEA.LT.XDTHR))
12623 & GOTO 160
12624 ENDIF
12625* valence diquark
12626 XTVDI = ONE-XTVQI-XXSEA
12627* reject according to x**1.5
12628 XDTMP = XTVDI**1.5D0
12629 IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 169
12630* accept these valence partons
12631 IXTV = IXTV+1
12632 XTVQ(IXTV) = XTVQI
12633 XTVD(IXTV) = XTVDI
12634 IFROVT(IXTV) = ITT
12635 ITOVT(ITT) = IXTV
12636 ZUOVT(IXTV) = .TRUE.
12637
12638 ENDIF
12639 170 CONTINUE
12640
12641* (4) get valence-valence chains
12642*-----------------------------------------------------------------------
12643
12644 NVV = 0
12645 DO 240 I=1,NN
12646 INTLO(I) = .TRUE.
12647 IPVAL = ITOVP(INTER1(I))
12648 ITVAL = ITOVT(INTER2(I))
12649 IF (ZUOVP(IPVAL).AND.ZUOVT(ITVAL)) THEN
12650 INTLO(I) = .FALSE.
12651 ZUOVP(IPVAL) = .FALSE.
12652 ZUOVT(ITVAL) = .FALSE.
12653 NVV = NVV+1
12654 ISKPCH(8,NVV) = 0
12655 INTVV1(NVV) = IPVAL
12656 INTVV2(NVV) = ITVAL
12657 ENDIF
12658 240 CONTINUE
12659
12660* (5) get sea-valence chains
12661*-----------------------------------------------------------------------
12662
12663 NSV = 0
12664 NDV = 0
12665 PLW = 0.5D0
12666 DO 270 I=1,NN
12667 IF (INTLO(I)) THEN
12668 IPVAL = ITOVP(INTER1(I))
12669 ITVAL = ITOVT(INTER2(I))
12670 DO 250 J=1,IXPS
12671 IF (ZUOSP(J).AND.(IFROSP(J).EQ.INTER1(I)).AND.
12672 & ZUOVT(ITVAL)) THEN
12673 ZUOSP(J) = .FALSE.
12674 ZUOVT(ITVAL) = .FALSE.
12675 INTLO(I) = .FALSE.
12676 IF (LSEADI.AND.(DT_RNDM(PLW).GT.FRCDIQ)) THEN
12677* sample sea-diquark pair
12678 CALL DT_SAMSDQ(ECM,ITVAL,J,2,IREJ1)
12679 IF (IREJ1.EQ.0) GOTO 260
12680 ENDIF
12681 NSV = NSV+1
12682 ISKPCH(4,NSV) = 0
12683 INTSV1(NSV) = J
12684 INTSV2(NSV) = ITVAL
12685
12686*>>>correct chain kinematics according to minimum chain masses
12687* the actual chain masses
12688 AMSVQ1 = XPSQ(J) *XTVD(ITVAL)*ECM**2
12689 AMSVQ2 = XPSAQ(J)*XTVQ(ITVAL)*ECM**2
12690* get lower mass cuts
12691 IF (IPSQ(J).EQ.3) THEN
12692* q being s-quark
12693 AMCHK1 = AMAS
12694 AMCHK2 = AMIS
12695 ELSE
12696* q being u/d-quark
12697 AMCHK1 = AMAU
12698 AMCHK2 = AMIU
12699 ENDIF
12700* q-qq chain
12701* chain mass above minimum - resampling of sea-q x-value
12702 IF (AMSVQ1.GT.AMCHK1) THEN
12703 XPSQTH = AMCHK1/(XTVD(ITVAL)*ECM**2)
12704**sr 8.4.98 (1/sqrt(x))
12705C XPSQXX = DT_SAMPEX(XPSQTH,XPSQ(J))
12706C XPSQXX = DT_SAMSQX(XPSQTH,XPSQ(J))
12707 XPSQXX = DT_SAMPLW(XPSQTH,XPSQ(J),PLW)
12708**
12709 XPVD(IPVAL) = XPVD(IPVAL)+XPSQ(J)-XPSQXX
12710 XPSQ(J) = XPSQXX
12711* chain mass below minimum - reset sea-q x-value and correct
12712* diquark-x of the same nucleon
12713 ELSEIF (AMSVQ1.LT.AMCHK1) THEN
12714 XPSQW = AMCHK1/(XTVD(ITVAL)*ECM**2)
12715 DXPSQ = XPSQW-XPSQ(J)
12716 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
12717 XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
12718 XPSQ(J) = XPSQW
12719 ENDIF
12720 ENDIF
12721* aq-q chain
12722* chain mass below minimum - reset sea-aq x-value and correct
12723* diquark-x of the same nucleon
12724 IF (AMSVQ2.LT.AMCHK2) THEN
12725 XPSQW = AMCHK2/(XTVQ(ITVAL)*ECM**2)
12726 DXPSQ = XPSQW-XPSAQ(J)
12727 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
12728 XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
12729 XPSAQ(J) = XPSQW
12730 ENDIF
12731 ENDIF
12732*>>>end of chain mass correction
12733
12734 GOTO 260
12735 ENDIF
12736 250 CONTINUE
12737 ENDIF
12738 260 CONTINUE
12739 270 CONTINUE
12740
12741* (6) get valence-sea chains
12742*-----------------------------------------------------------------------
12743
12744 NVS = 0
12745 NVD = 0
12746 DO 300 I=1,NN
12747 IF (INTLO(I)) THEN
12748 IPVAL = ITOVP(INTER1(I))
12749 ITVAL = ITOVT(INTER2(I))
12750 DO 280 J=1,IXTS
12751 IF (ZUOVP(IPVAL).AND.ZUOST(J).AND.
12752 & (IFROST(J).EQ.INTER2(I))) THEN
12753 ZUOST(J) = .FALSE.
12754 ZUOVP(IPVAL) = .FALSE.
12755 INTLO(I) = .FALSE.
12756 IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
12757* sample sea-diquark pair
12758 CALL DT_SAMSDQ(ECM,IPVAL,J,1,IREJ1)
12759 IF (IREJ1.EQ.0) GOTO 290
12760 ENDIF
12761 NVS = NVS + 1
12762 ISKPCH(6,NVS) = 0
12763 INTVS1(NVS) = IPVAL
12764 INTVS2(NVS) = J
12765
12766*>>>correct chain kinematics according to minimum chain masses
12767* the actual chain masses
12768 AMVSQ1 = XPVQ(IPVAL)*XTSAQ(J)*ECM**2
12769 AMVSQ2 = XPVD(IPVAL)*XTSQ(J) *ECM**2
12770* get lower mass cuts
12771 IF (ITSQ(J).EQ.3) THEN
12772* q being s-quark
12773 AMCHK1 = AMIS
12774 AMCHK2 = AMAS
12775 ELSE
12776* q being u/d-quark
12777 AMCHK1 = AMIU
12778 AMCHK2 = AMAU
12779 ENDIF
12780* q-aq chain
12781* chain mass below minimum - reset sea-aq x-value and correct
12782* diquark-x of the same nucleon
12783 IF (AMVSQ1.LT.AMCHK1) THEN
12784 XTSQW = AMCHK1/(XPVQ(IPVAL)*ECM**2)
12785 DXTSQ = XTSQW-XTSAQ(J)
12786 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
12787 XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
12788 XTSAQ(J) = XTSQW
12789 ENDIF
12790 ENDIF
12791* qq-q chain
12792* chain mass above minimum - resampling of sea-q x-value
12793 IF (AMVSQ2.GT.AMCHK2) THEN
12794 XTSQTH = AMCHK2/(XPVD(IPVAL)*ECM**2)
12795**sr 8.4.98 (1/sqrt(x))
12796C XTSQXX = DT_SAMPEX(XTSQTH,XTSQ(J))
12797C XTSQXX = DT_SAMSQX(XTSQTH,XTSQ(J))
12798 XTSQXX = DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
12799**
12800 XTVD(ITVAL) = XTVD(ITVAL)+XTSQ(J)-XTSQXX
12801 XTSQ(J) = XTSQXX
12802* chain mass below minimum - reset sea-q x-value and correct
12803* diquark-x of the same nucleon
12804 ELSEIF (AMVSQ2.LT.AMCHK2) THEN
12805 XTSQW = AMCHK2/(XPVD(IPVAL)*ECM**2)
12806 DXTSQ = XTSQW-XTSQ(J)
12807 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
12808 XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
12809 XTSQ(J) = XTSQW
12810 ENDIF
12811 ENDIF
12812*>>>end of chain mass correction
12813
12814 GOTO 290
12815 ENDIF
12816 280 CONTINUE
12817 ENDIF
12818 290 CONTINUE
12819 300 CONTINUE
12820
12821* (7) get sea-sea chains
12822*-----------------------------------------------------------------------
12823
12824 NSS = 0
12825 NDS = 0
12826 NSD = 0
12827 DO 420 I=1,NN
12828 IF (INTLO(I)) THEN
12829 IPVAL = ITOVP(INTER1(I))
12830 ITVAL = ITOVT(INTER2(I))
12831* loop over target partons not yet matched
12832 DO 400 J=1,IXTS
12833 IF (ZUOST(J).AND.(IFROST(J).EQ.INTER2(I))) THEN
12834* loop over projectile partons not yet matched
12835 DO 390 JJ=1,IXPS
12836 IF (ZUOSP(JJ).AND.(IFROSP(JJ).EQ.INTER1(I))) THEN
12837 ZUOSP(JJ) = .FALSE.
12838 ZUOST(J) = .FALSE.
12839 INTLO(I) = .FALSE.
12840 NSS = NSS+1
12841 ISKPCH(1,NSS) = 0
12842 INTSS1(NSS) = JJ
12843 INTSS2(NSS) = J
12844
12845*---->chain recombination option
12846 VALFRA = DBLE(NVV/(NVV+IXPS+IXTS))
12847 IF (IRECOM.EQ.1.AND.(DT_RNDM(BSQMA).GT.VALFRA))
12848 & THEN
12849* sea-sea chains may recombine with valence-valence chains
12850* only if they have the same projectile or target nucleon
12851 DO 4201 IVV=1,NVV
12852 IF (ISKPCH(8,IVV).NE.99) THEN
12853 IXVPR = INTVV1(IVV)
12854 IXVTA = INTVV2(IVV)
12855 IF ((INTER1(I).EQ.IFROVP(IXVPR)).OR.
12856 & (INTER2(I).EQ.IFROVT(IXVTA))) THEN
12857* recombination possible, drop old v-v and s-s chains
12858 ISKPCH(1,NSS) = 99
12859 ISKPCH(8,IVV) = 99
12860
12861* (a) assign new s-v chains
12862* ~~~~~~~~~~~~~~~~~~~~~~~~~
12863 IF (LSEADI.AND.
12864 & (DT_RNDM(VALFRA).GT.FRCDIQ))
12865 & THEN
12866* sample sea-diquark pair
12867 CALL DT_SAMSDQ(ECM,IXVTA,JJ,2,
12868 & IREJ1)
12869 IF (IREJ1.EQ.0) GOTO 4202
12870 ENDIF
12871 NSV = NSV+1
12872 ISKPCH(4,NSV) = 0
12873 INTSV1(NSV) = JJ
12874 INTSV2(NSV) = IXVTA
12875*>>>>>>>>>>>correct chain kinematics according to minimum chain masses
12876* the actual chain masses
12877 AMSVQ1 = XPSQ(JJ) *XTVD(IXVTA)
12878 & *ECM**2
12879 AMSVQ2 = XPSAQ(JJ)*XTVQ(IXVTA)
12880 & *ECM**2
12881* get lower mass cuts
12882 IF (IPSQ(JJ).EQ.3) THEN
12883* q being s-quark
12884 AMCHK1 = AMAS
12885 AMCHK2 = AMIS
12886 ELSE
12887* q being u/d-quark
12888 AMCHK1 = AMAU
12889 AMCHK2 = AMIU
12890 ENDIF
12891* q-qq chain
12892* chain mass above minimum - resampling of sea-q x-value
12893 IF (AMSVQ1.GT.AMCHK1) THEN
12894 XPSQTH =
12895 & AMCHK1/(XTVD(IXVTA)*ECM**2)
12896**sr 8.4.98 (1/sqrt(x))
12897 XPSQXX =
12898 & DT_SAMPLW(XPSQTH,XPSQ(JJ),PLW)
12899C & DT_SAMSQX(XPSQTH,XPSQ(JJ))
12900C & DT_SAMPEX(XPSQTH,XPSQ(JJ))
12901**
12902 XPVD(IPVAL) =
12903 & XPVD(IPVAL)+XPSQ(JJ)-XPSQXX
12904 XPSQ(JJ) = XPSQXX
12905* chain mass below minimum - reset sea-q x-value and correct
12906* diquark-x of the same nucleon
12907 ELSEIF (AMSVQ1.LT.AMCHK1) THEN
12908 XPSQW =
12909 & AMCHK1/(XTVD(IXVTA)*ECM**2)
12910 DXPSQ = XPSQW-XPSQ(JJ)
12911 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
12912 & THEN
12913 XPVD(IPVAL) =
12914 & XPVD(IPVAL)-DXPSQ
12915 XPSQ(JJ) = XPSQW
12916 ENDIF
12917 ENDIF
12918* aq-q chain
12919* chain mass below minimum - reset sea-aq x-value and correct
12920* diquark-x of the same nucleon
12921 IF (AMSVQ2.LT.AMCHK2) THEN
12922 XPSQW =
12923 & AMCHK2/(XTVQ(IXVTA)*ECM**2)
12924 DXPSQ = XPSQW-XPSAQ(JJ)
12925 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
12926 & THEN
12927 XPVD(IPVAL) =
12928 & XPVD(IPVAL)-DXPSQ
12929 XPSAQ(JJ) = XPSQW
12930 ENDIF
12931 ENDIF
12932*>>>>>>>>>>>end of chain mass correction
12933 4202 CONTINUE
12934
12935* (b) assign new v-s chains
12936* ~~~~~~~~~~~~~~~~~~~~~~~~~
12937 IF (LSEADI.AND.(
12938 & DT_RNDM(AMSVQ2).GT.FRCDIQ))
12939 & THEN
12940* sample sea-diquark pair
12941 CALL DT_SAMSDQ(ECM,IXVPR,J,1,
12942 & IREJ1)
12943 IF (IREJ1.EQ.0) GOTO 4203
12944 ENDIF
12945 NVS = NVS+1
12946 ISKPCH(6,NVS) = 0
12947 INTVS1(NVS) = IXVPR
12948 INTVS2(NVS) = J
12949*>>>>>>>>>>>correct chain kinematics according to minimum chain masses
12950* the actual chain masses
12951 AMVSQ1 = XPVQ(IXVPR)*XTSAQ(J)*ECM**2
12952 AMVSQ2 = XPVD(IXVPR)*XTSQ(J) *ECM**2
12953* get lower mass cuts
12954 IF (ITSQ(J).EQ.3) THEN
12955* q being s-quark
12956 AMCHK1 = AMIS
12957 AMCHK2 = AMAS
12958 ELSE
12959* q being u/d-quark
12960 AMCHK1 = AMIU
12961 AMCHK2 = AMAU
12962 ENDIF
12963* q-aq chain
12964* chain mass below minimum - reset sea-aq x-value and correct
12965* diquark-x of the same nucleon
12966 IF (AMVSQ1.LT.AMCHK1) THEN
12967 XTSQW =
12968 & AMCHK1/(XPVQ(IXVPR)*ECM**2)
12969 DXTSQ = XTSQW-XTSAQ(J)
12970 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
12971 & THEN
12972 XTVD(ITVAL) =
12973 & XTVD(ITVAL)-DXTSQ
12974 XTSAQ(J) = XTSQW
12975 ENDIF
12976 ENDIF
12977 IF (AMVSQ2.GT.AMCHK2) THEN
12978 XTSQTH =
12979 & AMCHK2/(XPVD(IXVPR)*ECM**2)
12980**sr 8.4.98 (1/sqrt(x))
12981 XTSQXX =
12982 & DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
12983C & DT_SAMSQX(XTSQTH,XTSQ(J))
12984C & DT_SAMPEX(XTSQTH,XTSQ(J))
12985**
12986 XTVD(ITVAL) =
12987 & XTVD(ITVAL)+XTSQ(J)-XTSQXX
12988 XTSQ(J) = XTSQXX
12989 ELSEIF (AMVSQ2.LT.AMCHK2) THEN
12990 XTSQW =
12991 & AMCHK2/(XPVD(IXVPR)*ECM**2)
12992 DXTSQ = XTSQW-XTSQ(J)
12993 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
12994 & THEN
12995 XTVD(ITVAL) =
12996 & XTVD(ITVAL)-DXTSQ
12997 XTSQ(J) = XTSQW
12998 ENDIF
12999 ENDIF
13000*>>>>>>>>>end of chain mass correction
13001 4203 CONTINUE
13002* jump out of s-s chain loop
13003 GOTO 420
13004 ENDIF
13005 ENDIF
13006 4201 CONTINUE
13007 ENDIF
13008*---->end of chain recombination option
13009
13010* sample sea-diquark pair (projectile)
13011 IF (LSEADI.AND.(DT_RNDM(BSQMA).GT.FRCDIQ)) THEN
13012 CALL DT_SAMSDQ(ECM,J,JJ,4,IREJ1)
13013 IF (IREJ1.EQ.0) THEN
13014 ISKPCH(1,NSS) = 99
13015 GOTO 410
13016 ENDIF
13017 ENDIF
13018* sample sea-diquark pair (target)
13019 IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
13020 CALL DT_SAMSDQ(ECM,JJ,J,3,IREJ1)
13021 IF (IREJ1.EQ.0) THEN
13022 ISKPCH(1,NSS) = 99
13023 GOTO 410
13024 ENDIF
13025 ENDIF
13026*>>>>>correct chain kinematics according to minimum chain masses
13027* the actual chain masses
13028 SSMA1Q = XPSQ(JJ) *XTSAQ(J)*ECM**2
13029 SSMA2Q = XPSAQ(JJ)*XTSQ(J) *ECM**2
13030* check for lower mass cuts
13031 IF ((SSMA1Q.LT.SSMIMQ).OR.
13032 & (SSMA2Q.LT.SSMIMQ)) THEN
13033 IPVAL = ITOVP(INTER1(I))
13034 ITVAL = ITOVT(INTER2(I))
13035 IF ((XPVD(IPVAL).GT.XDTHR+3.5D0*XSSTHR).AND.
13036 & (XTVD(ITVAL).GT.XDTHR+3.5D0*XSSTHR))THEN
13037* maximum allowed x values for sea quarks
13038 XSPMAX = ONE-XPVQ(IPVAL)-XDTHR-
13039 & 1.2D0*XSSTHR
13040 XSTMAX = ONE-XTVQ(ITVAL)-XDTHR-
13041 & 1.2D0*XSSTHR
13042* resampling of x values not possible - skip sea-sea chains
13043 IF ((XSPMAX.LE.XSSTHR+0.05D0).OR.
13044 & (XSTMAX.LE.XSSTHR+0.05D0)) GOTO 380
13045* resampling of x for projectile sea quark pair
13046 ICOUS = 0
13047 310 CONTINUE
13048 ICOUS = ICOUS+1
13049 IF (XSSTHR.GT.0.05D0) THEN
13050 XPSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13051 & XSPMAX)
13052 XPSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13053 & XSPMAX)
13054 ELSE
13055 320 CONTINUE
13056 XPSQI = DT_DBETAR(XSEACU,UNOSEA)
13057 IF ((XPSQI.LT.XSSTHR).OR.
13058 & (XPSQI.GT.XSPMAX)) GOTO 320
13059 330 CONTINUE
13060 XPSAQI = DT_DBETAR(XSEACU,UNOSEA)
13061 IF ((XPSAQI.LT.XSSTHR).OR.
13062 & (XPSAQI.GT.XSPMAX)) GOTO 330
13063 ENDIF
13064* final test of remaining x for projectile diquark
13065 XPVDCO = XPVD(IPVAL)-XPSQI-XPSAQI
13066 & +XPSQ(JJ)+XPSAQ(JJ)
13067 IF (XPVDCO.LE.XDTHR) THEN
13068*!!!
13069C IF (ICOUS.LT.5) GOTO 310
13070 IF (ICOUS.LT.0.5D0) GOTO 310
13071 GOTO 380
13072 ENDIF
13073* resampling of x for target sea quark pair
13074 ICOUS = 0
13075 350 CONTINUE
13076 ICOUS = ICOUS+1
13077 IF (XSSTHR.GT.0.05D0) THEN
13078 XTSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13079 & XSTMAX)
13080 XTSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13081 & XSTMAX)
13082 ELSE
13083 360 CONTINUE
13084 XTSQI = DT_DBETAR(XSEACU,UNOSEA)
13085 IF ((XTSQI.LT.XSSTHR).OR.
13086 & (XTSQI.GT.XSTMAX)) GOTO 360
13087 370 CONTINUE
13088 XTSAQI = DT_DBETAR(XSEACU,UNOSEA)
13089 IF ((XTSAQI.LT.XSSTHR).OR.
13090 & (XTSAQI.GT.XSTMAX)) GOTO 370
13091 ENDIF
13092* final test of remaining x for target diquark
13093 XTVDCO = XTVD(ITVAL)-XTSQI-XTSAQI
13094 & +XTSQ(J)+XTSAQ(J)
13095 IF (XTVDCO.LT.XDTHR) THEN
13096 IF (ICOUS.LT.5) GOTO 350
13097 GOTO 380
13098 ENDIF
13099 XPVD(IPVAL) = XPVDCO
13100 XTVD(ITVAL) = XTVDCO
13101 XPSQ(JJ) = XPSQI
13102 XPSAQ(JJ) = XPSAQI
13103 XTSQ(J) = XTSQI
13104 XTSAQ(J) = XTSAQI
13105*>>>>>end of chain mass correction
13106 GOTO 410
13107 ENDIF
13108* come here to discard s-s interaction
13109* resampling of x values not allowed or unsuccessful
13110 380 CONTINUE
13111 INTLO(I) = .FALSE.
13112 ZUOST(J) = .TRUE.
13113 ZUOSP(JJ) = .TRUE.
13114 NSS = NSS-1
13115 ENDIF
13116* consider next s-s interaction
13117 GOTO 410
13118 ENDIF
13119 390 CONTINUE
13120 ENDIF
13121 400 CONTINUE
13122 ENDIF
13123 410 CONTINUE
13124 420 CONTINUE
13125
13126* correct x-values of valence quarks for non-matching sea quarks
13127 DO 430 I=1,IXPS
13128 IF (ZUOSP(I)) THEN
13129 IPVAL = ITOVP(IFROSP(I))
13130 XPVQ(IPVAL) = XPVQ(IPVAL)+XPSQ(I)+XPSAQ(I)
13131 XPSQ(I) = ZERO
13132 XPSAQ(I) = ZERO
13133 ZUOSP(I) = .FALSE.
13134 ENDIF
13135 430 CONTINUE
13136 DO 440 I=1,IXTS
13137 IF (ZUOST(I)) THEN
13138 ITVAL = ITOVT(IFROST(I))
13139 XTVQ(ITVAL) = XTVQ(ITVAL)+XTSQ(I)+XTSAQ(I)
13140 XTSQ(I) = ZERO
13141 XTSAQ(I) = ZERO
13142 ZUOST(I) = .FALSE.
13143 ENDIF
13144 440 CONTINUE
13145 DO 450 I=1,IXPV
13146 IF (ZUOVP(I)) ISTHKK(IFROVP(I)) = 13
13147 450 CONTINUE
13148 DO 460 I=1,IXTV
13149 IF (ZUOVT(I)) ISTHKK(IFROVT(I)+IP) = 14
13150 460 CONTINUE
13151
13152 RETURN
13153 END
13154
13155*$ CREATE DT_SAMSDQ.FOR
13156*COPY DT_SAMSDQ
13157*
13158*===samsdq=============================================================*
13159*
13160 SUBROUTINE DT_SAMSDQ(ECM,IDX1,IDX2,MODE,IREJ)
13161
13162************************************************************************
13163* SAMpling of Sea-DiQuarks *
13164* ECM cm-energy of the nucleon-nucleon system *
13165* IDX1,2 indices of x-values of the participating *
13166* partons (IDX2 is always the sea-q-pair to be *
13167* changed to sea-qq-pair) *
13168* MODE = 1 valence-q - sea-diq *
13169* = 2 sea-diq - valence-q *
13170* = 3 sea-q - sea-diq *
13171* = 4 sea-diq - sea-q *
13172* Based on DIQVS, DIQSV, DIQSSD, DIQDSS. *
13173* This version dated 17.10.95 is written by S. Roesler *
13174************************************************************************
13175
13176 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13177 SAVE
13178
13179 PARAMETER (ZERO=0.0D0)
13180
13181* threshold values for x-sampling (DTUNUC 1.x)
13182 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
13183 & SSMIMQ,VVMTHR
13184* various options for treatment of partons (DTUNUC 1.x)
13185* (chain recombination, Cronin,..)
13186 LOGICAL LCO2CR,LINTPT
13187 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
13188 & LCO2CR,LINTPT
13189 PARAMETER ( MAXNCL = 260,
13190 & MAXVQU = MAXNCL,
13191 & MAXSQU = 20*MAXVQU,
13192 & MAXINT = MAXVQU+MAXSQU)
13193* x-values of partons (DTUNUC 1.x)
13194 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
13195 & XTVQ(MAXVQU),XTVD(MAXVQU),
13196 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
13197 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
13198* flavors of partons (DTUNUC 1.x)
13199 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
13200 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
13201 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
13202 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
13203 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
13204 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
13205 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
13206* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13207 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
13208 & IXPV,IXPS,IXTV,IXTS,
13209 & INTVV1(MAXVQU),INTVV2(MAXVQU),
13210 & INTSV1(MAXVQU),INTSV2(MAXVQU),
13211 & INTVS1(MAXVQU),INTVS2(MAXVQU),
13212 & INTSS1(MAXSQU),INTSS2(MAXSQU),
13213 & INTDV1(MAXVQU),INTDV2(MAXVQU),
13214 & INTVD1(MAXVQU),INTVD2(MAXVQU),
13215 & INTDS1(MAXSQU),INTDS2(MAXSQU),
13216 & INTSD1(MAXSQU),INTSD2(MAXSQU)
13217* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13218 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
13219 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
13220* auxiliary common for chain system storage (DTUNUC 1.x)
13221 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
13222
13223 IREJ = 0
13224* threshold-x for valence diquarks
13225 XDTHR = CDQ/ECM
13226
13227 GOTO (1,2,3,4) MODE
13228
13229*---------------------------------------------------------------------
13230* proj. valence partons - targ. sea partons
13231* get x-values and flavors for target sea-diquark pair
13232
13233 1 CONTINUE
13234 IDXVP = IDX1
13235 IDXST = IDX2
13236
13237* index of corr. val-diquark-x in target nucleon
13238 IDXVT = ITOVT(IFROST(IDXST))
13239* available x above diquark thresholds for valence- and sea-diquarks
13240 XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13241
13242 IF (XXD.GE.ZERO) THEN
13243* x-values for the three diquarks of the target nucleon
13244 RR1 = DT_RNDM(XXD)
13245 RR2 = DT_RNDM(RR1)
13246 RR3 = DT_RNDM(RR2)
13247 SR123 = RR1+RR2+RR3
13248 XXTV = XDTHR+RR1*XXD/SR123
13249 XXTSQ = XDTHR+RR2*XXD/SR123
13250 XXTSAQ = XDTHR+RR3*XXD/SR123
13251 ELSE
13252 XXTV = XTVD(IDXVT)
13253 XXTSQ = XTSQ(IDXST)
13254 XXTSAQ = XTSAQ(IDXST)
13255 ENDIF
13256* flavor of the second quarks in the sea-diquark pair
13257 ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13258 ITSAQ2(IDXST) = -ITSQ2(IDXST)
13259* check masses of the new val-q - sea-qq, val-qq - sea-aqaq chains
13260 AM1 = XXTSQ *XPVQ(IDXVP)*ECM**2
13261 AM2 = XXTSAQ*XPVD(IDXVP)*ECM**2
13262 IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13263* ss-asas pair
13264 & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN
13265 IREJ = 1
13266 RETURN
13267 ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13268* at least one strange quark
13269 & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN
13270 IREJ = 1
13271 RETURN
13272 ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13273 IREJ = 1
13274 RETURN
13275 ENDIF
13276* accept the new sea-diquark
13277 XTVD(IDXVT) = XXTV
13278 XTSQ(IDXST) = XXTSQ
13279 XTSAQ(IDXST) = XXTSAQ
13280 NVD = NVD+1
13281 INTVD1(NVD) = IDXVP
13282 INTVD2(NVD) = IDXST
13283 ISKPCH(7,NVD) = 0
13284 RETURN
13285
13286*---------------------------------------------------------------------
13287* proj. sea partons - targ. valence partons
13288* get x-values and flavors for projectile sea-diquark pair
13289
13290 2 CONTINUE
13291 IDXSP = IDX2
13292 IDXVT = IDX1
13293
13294* index of corr. val-diquark-x in projectile nucleon
13295 IDXVP = ITOVP(IFROSP(IDXSP))
13296* available x above diquark thresholds for valence- and sea-diquarks
13297 XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13298
13299 IF (XXD.GE.ZERO) THEN
13300* x-values for the three diquarks of the projectile nucleon
13301 RR1 = DT_RNDM(XXD)
13302 RR2 = DT_RNDM(RR1)
13303 RR3 = DT_RNDM(RR2)
13304 SR123 = RR1+RR2+RR3
13305 XXPV = XDTHR+RR1*XXD/SR123
13306 XXPSQ = XDTHR+RR2*XXD/SR123
13307 XXPSAQ = XDTHR+RR3*XXD/SR123
13308 ELSE
13309 XXPV = XPVD(IDXVP)
13310 XXPSQ = XPSQ(IDXSP)
13311 XXPSAQ = XPSAQ(IDXSP)
13312 ENDIF
13313* flavor of the second quarks in the sea-diquark pair
13314 IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13315 IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13316* check masses of the new sea-qq - val-q, sea-aqaq - val-qq chains
13317 AM1 = XXPSQ *XTVQ(IDXVT)*ECM**2
13318 AM2 = XXPSAQ*XTVD(IDXVT)*ECM**2
13319 IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13320* ss-asas pair
13321 & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN
13322 IREJ = 1
13323 RETURN
13324 ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13325* at least one strange quark
13326 & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN
13327 IREJ = 1
13328 RETURN
13329 ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13330 IREJ = 1
13331 RETURN
13332 ENDIF
13333* accept the new sea-diquark
13334 XPVD(IDXVP) = XXPV
13335 XPSQ(IDXSP) = XXPSQ
13336 XPSAQ(IDXSP) = XXPSAQ
13337 NDV = NDV+1
13338 INTDV1(NDV) = IDXSP
13339 INTDV2(NDV) = IDXVT
13340 ISKPCH(5,NDV) = 0
13341 RETURN
13342
13343*---------------------------------------------------------------------
13344* proj. sea partons - targ. sea partons
13345* get x-values and flavors for target sea-diquark pair
13346
13347 3 CONTINUE
13348 IDXSP = IDX1
13349 IDXST = IDX2
13350
13351* index of corr. val-diquark-x in target nucleon
13352 IDXVT = ITOVT(IFROST(IDXST))
13353* available x above diquark thresholds for valence- and sea-diquarks
13354 XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13355
13356 IF (XXD.GE.ZERO) THEN
13357* x-values for the three diquarks of the target nucleon
13358 RR1 = DT_RNDM(XXD)
13359 RR2 = DT_RNDM(RR1)
13360 RR3 = DT_RNDM(RR2)
13361 SR123 = RR1+RR2+RR3
13362 XXTV = XDTHR+RR1*XXD/SR123
13363 XXTSQ = XDTHR+RR2*XXD/SR123
13364 XXTSAQ = XDTHR+RR3*XXD/SR123
13365 ELSE
13366 XXTV = XTVD(IDXVT)
13367 XXTSQ = XTSQ(IDXST)
13368 XXTSAQ = XTSAQ(IDXST)
13369 ENDIF
13370* flavor of the second quarks in the sea-diquark pair
13371 ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13372 ITSAQ2(IDXST) = -ITSQ2(IDXST)
13373* check masses of the new sea-q - sea-qq, sea-aq - sea-aqaq chains
13374 AM1 = XXTSQ *XPSQ(IDXSP)*ECM**2
13375 AM2 = XXTSAQ*XPSAQ(IDXSP)*ECM**2
13376 IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13377* ss-asas pair
13378 & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN
13379 IREJ = 1
13380 RETURN
13381 ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13382* at least one strange quark
13383 & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN
13384 IREJ = 1
13385 RETURN
13386 ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
13387 IREJ = 1
13388 RETURN
13389 ENDIF
13390* accept the new sea-diquark
13391 XTVD(IDXVT) = XXTV
13392 XTSQ(IDXST) = XXTSQ
13393 XTSAQ(IDXST) = XXTSAQ
13394 NSD = NSD+1
13395 INTSD1(NSD) = IDXSP
13396 INTSD2(NSD) = IDXST
13397 ISKPCH(3,NSD) = 0
13398 RETURN
13399
13400*---------------------------------------------------------------------
13401* proj. sea partons - targ. sea partons
13402* get x-values and flavors for projectile sea-diquark pair
13403
13404 4 CONTINUE
13405 IDXSP = IDX2
13406 IDXST = IDX1
13407
13408* index of corr. val-diquark-x in projectile nucleon
13409 IDXVP = ITOVP(IFROSP(IDXSP))
13410* available x above diquark thresholds for valence- and sea-diquarks
13411 XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13412
13413 IF (XXD.GE.ZERO) THEN
13414* x-values for the three diquarks of the projectile nucleon
13415 RR1 = DT_RNDM(XXD)
13416 RR2 = DT_RNDM(RR1)
13417 RR3 = DT_RNDM(RR2)
13418 SR123 = RR1+RR2+RR3
13419 XXPV = XDTHR+RR1*XXD/SR123
13420 XXPSQ = XDTHR+RR2*XXD/SR123
13421 XXPSAQ = XDTHR+RR3*XXD/SR123
13422 ELSE
13423 XXPV = XPVD(IDXVP)
13424 XXPSQ = XPSQ(IDXSP)
13425 XXPSAQ = XPSAQ(IDXSP)
13426 ENDIF
13427* flavor of the second quarks in the sea-diquark pair
13428 IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13429 IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13430* check masses of the new sea-qq - sea-q, sea-aqaq - sea-qq chains
13431 AM1 = XXPSQ *XTSQ(IDXST)*ECM**2
13432 AM2 = XXPSAQ*XTSAQ(IDXST)*ECM**2
13433 IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13434* ss-asas pair
13435 & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN
13436 IREJ = 1
13437 RETURN
13438 ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13439* at least one strange quark
13440 & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN
13441 IREJ = 1
13442 RETURN
13443 ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
13444 IREJ = 1
13445 RETURN
13446 ENDIF
13447* accept the new sea-diquark
13448 XPVD(IDXVP) = XXPV
13449 XPSQ(IDXSP) = XXPSQ
13450 XPSAQ(IDXSP) = XXPSAQ
13451 NDS = NDS+1
13452 INTDS1(NDS) = IDXSP
13453 INTDS2(NDS) = IDXST
13454 ISKPCH(2,NDS) = 0
13455 RETURN
13456 END
13457
13458*$ CREATE DT_DIFEVT.FOR
13459*COPY DT_DIFEVT
13460*
13461*===difevt=============================================================*
13462*
13463 SUBROUTINE DT_DIFEVT(IFP1,IFP2,PP,MOP,
13464 & IFT1,IFT2,PT,MOT,JDIFF,NCSY,IREJ)
13465
13466************************************************************************
13467* Interface to treatment of diffractive interactions. *
13468* (input) IFP1/2 PDG-indizes of projectile partons *
13469* (baryon: IFP2 - adiquark) *
13470* PP(4) projectile 4-momentum *
13471* IFT1/2 PDG-indizes of target partons *
13472* (baryon: IFT1 - adiquark) *
13473* PT(4) target 4-momentum *
13474* (output) JDIFF = 0 no diffraction *
13475* = 1/-1 LMSD/LMDD *
13476* = 2/-2 HMSD/HMDD *
13477* NCSY counter for two-chain systems *
13478* dumped to DTEVT1 *
13479* This version dated 14.02.95 is written by S. Roesler *
13480************************************************************************
13481
13482 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13483 SAVE
13484 PARAMETER ( LINP = 10 ,
13485 & LOUT = 6 ,
13486 & LDAT = 9 )
13487 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5,
13488 & OHALF=0.5D0)
13489
13490* event history
13491 PARAMETER (NMXHKK=200000)
13492 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
13493 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
13494 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
13495* extended event history
13496 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
13497 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
13498 & IHIST(2,NMXHKK)
13499* flags for diffractive interactions (DTUNUC 1.x)
13500 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
13501
13502 DIMENSION PP(4),PT(4)
13503
13504 LOGICAL LFIRST
13505 DATA LFIRST /.TRUE./
13506
13507 IREJ = 0
13508 JDIFF = 0
13509 IFLAGD = JDIFF
13510
13511* cm. energy
13512 XM = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
13513 & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
13514* identities of projectile hadron / target nucleon
13515 KPROJ = IDT_ICIHAD(IDHKK(MOP))
13516 KTARG = IDT_ICIHAD(IDHKK(MOT))
13517
13518* single diffractive xsections
13519 CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM)
13520* double diffractive xsections
13521**!! no double diff yet
13522C CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM,DDTOT,DDHM)
13523 DDTOT = 0.0D0
13524 DDHM = 0.0D0
13525**!!
13526* total inelastic xsection
13527C SIGIN = DT_SHNTOT(KPROJ,KTARG,XM,ZERO)-DT_SHNELA(KPROJ,KTARG,XM)
13528 DUMZER = ZERO
13529 CALL DT_XSHN(KPROJ,KTARG,DUMZER,XM,SIGTO,SIGEL)
13530 SIGIN = MAX(SIGTO-SIGEL,ZERO)
13531
13532* fraction of diffractive processes
13533 FRADIF = (SDTOT+DDTOT)/SIGIN
13534
13535 IF (LFIRST) THEN
13536 WRITE(LOUT,1000) XM,SDTOT,SIGIN
13537 1000 FORMAT(1X,'DIFEVT: single diffraction requested at E_cm = ',
13538 & F5.1,' GeV',/,9X,'sigma_sd = ',F4.1,' mb, sigma_in = ',
13539 & F5.1,' mb',/)
13540 LFIRST = .FALSE.
13541 ENDIF
13542
13543 IF ((DT_RNDM(DDHM).LE.FRADIF).OR.
13544 & (ISINGD.GT.1).OR.(IDOUBD.GT.1)) THEN
13545* diffractive interaction requested by x-section or by user
13546 FRASD = SDTOT/(SDTOT+DDTOT)
13547 FRASDH = SDHM/SDTOT
13548**sr needs to be specified!!
13549C FRADDH = DDHM/DDTOT
13550 FRADDH = 1.0D0
13551**
13552 IF ((DT_RNDM(FRASD).LE.FRASD).OR.(ISINGD.GT.1)) THEN
13553* single diffraction
13554 KDIFF = 1
13555 IF (DT_RNDM(DDTOT).LE.FRASDH) THEN
13556 KP = 2
13557 KT = 0
13558 IF (((ISINGD.EQ.4).OR.(DT_RNDM(DDTOT).GE.OHALF)).AND.
13559 & ISINGD.NE.3) THEN
13560 KP = 0
13561 KT = 2
13562 ENDIF
13563 ELSE
13564 KP = 1
13565 KT = 0
13566 IF (((ISINGD.EQ.4).OR.(DT_RNDM(FRADDH).GE.OHALF)).AND.
13567 & ISINGD.NE.3) THEN
13568 KP = 0
13569 KT = 1
13570 ENDIF
13571 ENDIF
13572 ELSE
13573* double diffraction
13574 KDIFF = -1
13575 IF (DT_RNDM(FRADDH).LE.FRADDH) THEN
13576 KP = 2
13577 KT = 2
13578 ELSE
13579 KP = 1
13580 KT = 1
13581 ENDIF
13582 ENDIF
13583 CALL DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
13584 & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
13585 IF (IREJ1.EQ.0) THEN
13586 IFLAGD = 2*KDIFF
13587 IF ((KP.EQ.1).OR.(KT.EQ.1)) IFLAGD = KDIFF
13588 ELSE
13589 GOTO 9999
13590 ENDIF
13591 ENDIF
13592 JDIFF = IFLAGD
13593
13594 RETURN
13595
13596 9999 CONTINUE
13597 IREJ = 1
13598 RETURN
13599 END
13600
13601*$ CREATE DT_DIFFKI.FOR
13602*COPY DT_DIFFKI
13603*
13604*===difkin=============================================================*
13605*
13606 SUBROUTINE DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
13607 & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ)
13608
13609************************************************************************
13610* Kinematics of diffractive nucleon-nucleon interaction. *
13611* IFP1/2 PDG-indizes of projectile partons *
13612* (baryon: IFP2 - adiquark) *
13613* PP(4) projectile 4-momentum *
13614* IFT1/2 PDG-indizes of target partons *
13615* (baryon: IFT1 - adiquark) *
13616* PT(4) target 4-momentum *
13617* KP = 0 projectile quasi-elastically scattered *
13618* = 1 excited to low-mass diff. state *
13619* = 2 excited to high-mass diff. state *
13620* KT = 0 target quasi-elastically scattered *
13621* = 1 excited to low-mass diff. state *
13622* = 2 excited to high-mass diff. state *
13623* This version dated 12.02.95 is written by S. Roesler *
13624************************************************************************
13625
13626 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13627 SAVE
13628 PARAMETER ( LINP = 10 ,
13629 & LOUT = 6 ,
13630 & LDAT = 9 )
13631 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5)
13632
13633 LOGICAL LSTART
13634
13635* particle properties (BAMJET index convention)
13636 CHARACTER*8 ANAME
13637 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
13638 & IICH(210),IIBAR(210),K1(210),K2(210)
13639* flags for input different options
13640 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
13641 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
13642 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
13643* rejection counter
13644 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
13645 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
13646 & IREXCI(3),IRDIFF(2),IRINC
13647* kinematics of diffractive interactions (DTUNUC 1.x)
13648 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
13649 & PPF(4),PTF(4),
13650 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
13651 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
13652
13653 DIMENSION PITOT(4),BGTOT(4),PP1(4),PT1(4),PPBLOB(4),PTBLOB(4),
13654 & PP(4),PT(4),PPOM1(4),DEV1(4),DEV2(4)
13655
13656 DATA LSTART /.TRUE./
13657
13658 IF (LSTART) THEN
13659 WRITE(LOUT,2000)
13660 2000 FORMAT(/,1X,'DIFEVT: diffractive interactions treated ')
13661 LSTART = .FALSE.
13662 ENDIF
13663
13664 IREJ = 0
13665
13666* initialize common /DTDIKI/
13667 CALL DT_DIFINI
13668* store momenta of initial incoming particles for emc-check
13669 IF (LEMCCK) THEN
13670 CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM,IDUM)
13671 CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM,IDUM)
13672 ENDIF
13673
13674* masses of initial particles
13675 XMP2 = PP(4)**2-PP(1)**2-PP(2)**2-PP(3)**2
13676 XMT2 = PT(4)**2-PT(1)**2-PT(2)**2-PT(3)**2
13677 IF ((XMP2.LT.ZERO).OR.(XMT2.LT.ZERO)) GOTO 9999
13678 XMP = SQRT(XMP2)
13679 XMT = SQRT(XMT2)
13680* check quark-input (used to adjust coherence cond. for M-selection)
13681 IBP = 0
13682 IF ((ABS(IFP1).GE.1000).OR.(ABS(IFP2).GE.1000)) IBP = 1
13683 IBT = 0
13684 IF ((ABS(IFT1).GE.1000).OR.(ABS(IFT2).GE.1000)) IBT = 1
13685
13686* parameter for Lorentz-transformation into nucleon-nucleon cms
13687 DO 3 K=1,4
13688 PITOT(K) = PP(K)+PT(K)
13689 3 CONTINUE
13690 XMTOT2 = PITOT(4)**2-PITOT(1)**2-PITOT(2)**2-PITOT(3)**2
13691 IF (XMTOT2.LE.ZERO) THEN
13692 WRITE(LOUT,1000) XMTOT2
13693 1000 FORMAT(1X,'DIFEVT: negative cm. energy! ',
13694 & 'XMTOT2 = ',E12.3)
13695 GOTO 9999
13696 ENDIF
13697 XMTOT = SQRT(XMTOT2)
13698 DO 4 K=1,4
13699 BGTOT(K) = PITOT(K)/XMTOT
13700 4 CONTINUE
13701* transformation of nucleons into cms
13702 CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PP(1),PP(2),
13703 & PP(3),PP(4),PPTOT,PP1(1),PP1(2),PP1(3),PP1(4))
13704 CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PT(1),PT(2),
13705 & PT(3),PT(4),PTTOT,PT1(1),PT1(2),PT1(3),PT1(4))
13706* rotation angles
13707 COD = PP1(3)/PPTOT
13708C SID = SQRT((ONE-COD)*(ONE+COD))
13709 PPT = SQRT(PP1(1)**2+PP1(2)**2)
13710 SID = PPT/PPTOT
13711 COF = ONE
13712 SIF = ZERO
13713 IF(PPTOT*SID.GT.TINY10) THEN
13714 COF = PP1(1)/(SID*PPTOT)
13715 SIF = PP1(2)/(SID*PPTOT)
13716 ANORF = SQRT(COF*COF+SIF*SIF)
13717 COF = COF/ANORF
13718 SIF = SIF/ANORF
13719 ENDIF
13720* check consistency
13721 DO 5 K=1,4
13722 DEV1(K) = ABS(PP1(K)+PT1(K))
13723 5 CONTINUE
13724 DEV1(4) = ABS(DEV1(4)-XMTOT)
13725 IF ((DEV1(1).GT.TINY10).OR.(DEV1(2).GT.TINY10).OR.
13726 & (DEV1(3).GT.TINY10).OR.(DEV1(4).GT.TINY10)) THEN
13727 WRITE(LOUT,1001) DEV1
13728 1001 FORMAT(1X,'DIFEVT: inconsitent Lorentz-transformation! ',
13729 & /,8X,4E12.3)
13730 GOTO 9999
13731 ENDIF
13732
13733* select x-fractions in high-mass diff. interactions
13734 IF ((KP.EQ.2).OR.(KT.EQ.2)) CALL DT_XVALHM(KP,KT)
13735
13736* select diffractive masses
13737* - projectile
13738 IF (KP.EQ.1) THEN
13739 XMPF = DT_XMLMD(XMTOT)
13740 CALL DT_LM2RES(IFP1,IFP2,XMPF,IDPR,IDXPR,IREJ1)
13741 IF (IREJ1.GT.0) GOTO 9999
13742 ELSEIF (KP.EQ.2) THEN
13743 XMPF = DT_XMHMD(XMTOT,IBP,1)
13744 ELSE
13745 XMPF = XMP
13746 ENDIF
13747* - target
13748 IF (KT.EQ.1) THEN
13749 XMTF = DT_XMLMD(XMTOT)
13750 CALL DT_LM2RES(IFT1,IFT2,XMTF,IDTR,IDXTR,IREJ1)
13751 IF (IREJ1.GT.0) GOTO 9999
13752 ELSEIF (KT.EQ.2) THEN
13753 XMTF = DT_XMHMD(XMTOT,IBT,2)
13754 ELSE
13755 XMTF = XMT
13756 ENDIF
13757
13758* kinematical treatment of "two-particle" system (masses - XMPF,XMTF)
13759 XMPF2 = XMPF**2
13760 XMTF2 = XMTF**2
13761 PPBLOB(3) = DT_YLAMB(XMTOT2,XMPF2,XMTF2)/(2.D0*XMTOT)
13762 PPBLOB(4) = SQRT(XMPF2+PPBLOB(3)**2)
13763
13764* select momentum transfer (all t-values used here are <0)
13765* minimum absolute value to produce diffractive masses
13766 TMIN = XMP2+XMPF2-2.0D0*(PP1(4)*PPBLOB(4)-PPTOT*PPBLOB(3))
13767 TT = DT_TDIFF(XMTOT,TMIN,XMPF,KP,XMTF,KT,IREJ1)
13768 IF (IREJ1.GT.0) GOTO 9999
13769
13770* longitudinal momentum of excited/elastically scattered projectile
13771 PPBLOB(3) = (TT-XMP2-XMPF2+2.0D0*PP1(4)*PPBLOB(4))/(2.0D0*PPTOT)
13772* total transverse momentum due to t-selection
13773 PPBLT2 = PPBLOB(4)**2-PPBLOB(3)**2-XMPF2
13774 IF (PPBLT2.LT.ZERO) THEN
13775 WRITE(LOUT,1002) PPBLT2,KP,PP1,XMPF,KT,PT1,XMTF,TT
13776 1002 FORMAT(1X,'DIFEVT: inconsistent transverse momentum! ',
13777 & E12.3,2(/,1X,I2,5E12.3),/,1X,E12.3)
13778 GOTO 9999
13779 ENDIF
13780 CALL DT_DSFECF(SINPHI,COSPHI)
13781 PPBLT = SQRT(PPBLT2)
13782 PPBLOB(1) = COSPHI*PPBLT
13783 PPBLOB(2) = SINPHI*PPBLT
13784
13785* rotate excited/elastically scattered projectile into n-n cms.
13786 CALL DT_MYTRAN(1,PPBLOB(1),PPBLOB(2),PPBLOB(3),COD,SID,COF,SIF,
13787 & XX,YY,ZZ)
13788 PPBLOB(1) = XX
13789 PPBLOB(2) = YY
13790 PPBLOB(3) = ZZ
13791
13792* 4-momentum of excited/elastically scattered target and of exchanged
13793* Pomeron
13794 DO 6 K=1,4
13795 IF (K.LT.4) PTBLOB(K) = -PPBLOB(K)
13796 PPOM1(K) = PP1(K)-PPBLOB(K)
13797 6 CONTINUE
13798 PTBLOB(4) = XMTOT-PPBLOB(4)
13799
13800* Lorentz-transformation back into system of initial diff. collision
13801 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13802 & PPBLOB(1),PPBLOB(2),PPBLOB(3),PPBLOB(4),
13803 & PPTOTF,PPF(1),PPF(2),PPF(3),PPF(4))
13804 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13805 & PTBLOB(1),PTBLOB(2),PTBLOB(3),PTBLOB(4),
13806 & PTTOTF,PTF(1),PTF(2),PTF(3),PTF(4))
13807 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13808 & PPOM1(1),PPOM1(2),PPOM1(3),PPOM1(4),
13809 & PPOMTO,PPOM(1),PPOM(2),PPOM(3),PPOM(4))
13810
13811* store 4-momentum of elastically scattered particle (in single diff.
13812* events)
13813 IF (KP.EQ.0) THEN
13814 DO 7 K=1,4
13815 PSC(K) = PPF(K)
13816 7 CONTINUE
13817 ELSEIF (KT.EQ.0) THEN
13818 DO 8 K=1,4
13819 PSC(K) = PTF(K)
13820 8 CONTINUE
13821 ENDIF
13822
13823* check consistency of kinematical treatment so far
13824 IF (LEMCCK) THEN
13825 CALL DT_EVTEMC(-PPF(1),-PPF(2),-PPF(3),-PPF(4),2,IDUM,IDUM)
13826 CALL DT_EVTEMC(-PTF(1),-PTF(2),-PTF(3),-PTF(4),2,IDUM,IDUM)
13827 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,60,IREJ1)
13828 IF (IREJ1.NE.0) GOTO 9999
13829 ENDIF
13830 DO 9 K=1,4
13831 DEV1(K) = ABS(PP(K)-PPF(K)-PPOM(K))
13832 DEV2(K) = ABS(PT(K)-PTF(K)+PPOM(K))
13833 9 CONTINUE
13834 IF ((DEV1(1).GT.TINY5).OR.(DEV1(2).GT.TINY5).OR.
13835 & (DEV1(3).GT.TINY5).OR.(DEV1(4).GT.TINY5).OR.
13836 & (DEV2(1).GT.TINY5).OR.(DEV2(2).GT.TINY5).OR.
13837 & (DEV2(3).GT.TINY5).OR.(DEV2(4).GT.TINY5)) THEN
13838 WRITE(LOUT,1003) DEV1,DEV2
13839 1003 FORMAT(1X,'DIFEVT: inconsitent kinematical treatment! ',
13840 & 2(/,8X,4E12.3))
13841 GOTO 9999
13842 ENDIF
13843
13844* kinematical treatment for low-mass diffraction
13845 CALL DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ1)
13846 IF (IREJ1.NE.0) GOTO 9999
13847
13848* dump diffractive chains into DTEVT1
13849 CALL DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
13850 IF (IREJ1.NE.0) GOTO 9999
13851
13852 RETURN
13853
13854 9999 CONTINUE
13855 IRDIFF(1) = IRDIFF(1)+1
13856 IREJ = 1
13857 RETURN
13858 END
13859
13860*$ CREATE DT_XMHMD.FOR
13861*COPY DT_XMHMD
13862*
13863*===xmhmd==============================================================*
13864*
13865 DOUBLE PRECISION FUNCTION DT_XMHMD(ECM,IB,MODE)
13866
13867************************************************************************
13868* Diffractive mass in high mass single/double diffractive events. *
13869* This version dated 11.02.95 is written by S. Roesler *
13870************************************************************************
13871
13872 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13873 SAVE
13874 PARAMETER ( LINP = 10 ,
13875 & LOUT = 6 ,
13876 & LDAT = 9 )
13877 PARAMETER (OHALF=0.5D0,ONE=1.0D0,ZERO=0.0D0)
13878
13879* kinematics of diffractive interactions (DTUNUC 1.x)
13880 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
13881 & PPF(4),PTF(4),
13882 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
13883 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
13884
13885C DATA XCOLOW /0.05D0/
13886 DATA XCOLOW /0.15D0/
13887
13888 DT_XMHMD = ZERO
13889 XH = XPH(2)
13890 IF (MODE.EQ.2) XH = XTH(2)
13891
13892* minimum Pomeron-x for high-mass diffraction
13893* (adjusted to get a smooth transition between HM and LM component)
13894 R = DT_RNDM(XH)
13895 XDIMIN = (3.0D0+400.0D0*R**2)/(XH*ECM**2)
13896 IF (ECM.LE.300.0D0) THEN
13897 RR = (1.0D0-EXP(-((ECM/140.0D0)**4)))
13898 XDIMIN = (3.0D0+400.0D0*(R**2)*RR)/(XH*ECM**2)
13899 ENDIF
13900* maximum Pomeron-x for high-mass diffraction
13901* (coherence condition, adjusted to fit to experimental data)
13902 IF (IB.NE.0) THEN
13903* baryon-diffraction
13904 XDIMAX = XCOLOW*(1.0D0+EXP(-((ECM/420.0D0)**2)))
13905 ELSE
13906* meson-diffraction
13907 XDIMAX = XCOLOW*(1.0D0+4.0D0*EXP(-((ECM/420.0D0)**2)))
13908 ENDIF
13909* check boundaries
13910 IF (XDIMIN.GE.XDIMAX) THEN
13911 XDIMIN = OHALF*XDIMAX
13912 ENDIF
13913
13914 KLOOP = 0
13915 1 CONTINUE
13916 KLOOP = KLOOP+1
13917 IF (KLOOP.GT.20) RETURN
13918* sample Pomeron-x from 1/x-distribution (critical Pomeron)
13919 XDIFF = DT_SAMPEX(XDIMIN,XDIMAX)
13920* corr. diffr. mass
13921 DT_XMHMD = ECM*SQRT(XDIFF)
13922 IF (DT_XMHMD.LT.2.5D0) GOTO 1
13923
13924 RETURN
13925 END
13926
13927*$ CREATE DT_XMLMD.FOR
13928*COPY DT_XMLMD
13929*
13930*===xmlmd==============================================================*
13931*
13932 DOUBLE PRECISION FUNCTION DT_XMLMD(ECM)
13933
13934************************************************************************
13935* Diffractive mass in high mass single/double diffractive events. *
13936* This version dated 11.02.95 is written by S. Roesler *
13937************************************************************************
13938
13939 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13940 SAVE
13941 PARAMETER ( LINP = 10 ,
13942 & LOUT = 6 ,
13943 & LDAT = 9 )
13944
13945* minimum Pomeron-x for low-mass diffraction
13946C AMO = 1.5D0
13947 AMO = 2.0D0
13948* maximum Pomeron-x for low-mass diffraction
13949* (adjusted to get a smooth transition between HM and LM component)
13950 R = DT_RNDM(AMO)
13951 SAM = 1.0D0
13952 IF (ECM.LE.300.0D0) SAM = 1.0D0-EXP(-((ECM/200.0D0)**4))
13953 R = DT_RNDM(AMO)*SAM
13954 AMAX= (1.0D0-SAM)*SQRT(0.1D0*ECM**2)+SAM*SQRT(400.0D0)
13955 AMU = R*SQRT(100.0D0)+(1.0D0-R)*AMAX
13956
13957* selection of diffractive mass
13958* (adjusted to get a smooth transition between HM and LM component)
13959 R = DT_RNDM(AMU)
13960 IF (ECM.LE.50.0D0) THEN
13961 DT_XMLMD = AMO*(AMU/AMO)**R
13962 ELSE
13963 A = 0.7D0
13964 IF (ECM.LE.300.0D0) A = 0.7D0*(1.0D0-EXP(-((ECM/100.0D0)**2)))
13965 DT_XMLMD = 1.0D0/((R/(AMU**A)+(1.0D0-R)/(AMO**A))**(1.0D0/A))
13966 ENDIF
13967
13968 RETURN
13969 END
13970
13971*$ CREATE DT_TDIFF.FOR
13972*COPY DT_TDIFF
13973*
13974*===tdiff==============================================================*
13975*
13976 DOUBLE PRECISION FUNCTION DT_TDIFF(ECM,TMIN,XM1I,K1,XM2I,K2,IREJ)
13977
13978************************************************************************
13979* t-selection for single/double diffractive interactions. *
13980* ECM cm. energy *
13981* TMIN minimum momentum transfer to produce diff. masses *
13982* XM1/XM2 diffractively produced masses *
13983* (for single diffraction XM2 is obsolete) *
13984* K1/K2= 0 not excited *
13985* = 1 low-mass excitation *
13986* = 2 high-mass excitation *
13987* This version dated 11.02.95 is written by S. Roesler *
13988************************************************************************
13989
13990 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13991 SAVE
13992 PARAMETER ( LINP = 10 ,
13993 & LOUT = 6 ,
13994 & LDAT = 9 )
13995 PARAMETER (ZERO=0.0D0)
13996
13997 PARAMETER ( BTP0 = 3.7D0,
13998 & ALPHAP = 0.24D0 )
13999
14000 IREJ = 0
14001 NCLOOP = 0
14002 DT_TDIFF = ZERO
14003
14004 IF (K1.GT.0) THEN
14005 XM1 = XM1I
14006 XM2 = XM2I
14007 ELSE
14008 XM1 = XM2I
14009 ENDIF
14010 XDI = (XM1/ECM)**2
14011 IF ((K1.EQ.0).OR.(K2.EQ.0)) THEN
14012* slope for single diffraction
14013 SLOPE = BTP0-2.0D0*ALPHAP*LOG(XDI)
14014 ELSE
14015* slope for double diffraction
14016 SLOPE = -2.0D0*ALPHAP*LOG(XDI*XM2**2)
14017 ENDIF
14018
14019 1 CONTINUE
14020 NCLOOP = NCLOOP+1
14021 IF (MOD(NCLOOP,1000).EQ.0) GOTO 9999
14022 Y = DT_RNDM(XDI)
14023 T = -LOG(1.0D0-Y)/SLOPE
14024 IF (ABS(T).LE.ABS(TMIN)) GOTO 1
14025 DT_TDIFF = -ABS(T)
14026
14027 RETURN
14028
14029 9999 CONTINUE
14030 WRITE(LOUT,1000) ECM,TMIN,XM1I,XM2I,K1,K2
14031 1000 FORMAT(1X,'DT_TDIFF: t-selection rejected!',/,
14032 & 1X,'ECM = ',E12.3,' TMIN = ',E12.2,/,1X,'XM1I = ',
14033 & E12.3,' XM2I = ',E12.3,' K1 = ',I2,' K2 = ',I2)
14034 IREJ = 1
14035 RETURN
14036 END
14037
14038*$ CREATE DT_XVALHM.FOR
14039*COPY DT_XVALHM
14040*
14041*===xvalhm=============================================================*
14042*
14043 SUBROUTINE DT_XVALHM(KP,KT)
14044
14045************************************************************************
14046* Sampling of parton x-values in high-mass diffractive interactions. *
14047* This version dated 12.02.95 is written by S. Roesler *
14048************************************************************************
14049
14050 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14051 SAVE
14052 PARAMETER ( LINP = 10 ,
14053 & LOUT = 6 ,
14054 & LDAT = 9 )
14055 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0,TINY2=1.0D-2)
14056
14057* kinematics of diffractive interactions (DTUNUC 1.x)
14058 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14059 & PPF(4),PTF(4),
14060 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14061 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14062* various options for treatment of partons (DTUNUC 1.x)
14063* (chain recombination, Cronin,..)
14064 LOGICAL LCO2CR,LINTPT
14065 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
14066 & LCO2CR,LINTPT
14067
14068 DATA UNON,XVQTHR /2.0D0,0.8D0/
14069
14070 IF (KP.EQ.2) THEN
14071* x-fractions of projectile valence partons
14072 1 CONTINUE
14073 XPH(1) = DT_DBETAR(OHALF,UNON)
14074 IF (XPH(1).GE.XVQTHR) GOTO 1
14075 XPH(2) = ONE-XPH(1)
14076* x-fractions of Pomeron q-aq-pair
14077 XPOLO = TINY2
14078 XPOHI = ONE-TINY2
14079 XPPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14080 XPPO(2) = ONE-XPPO(1)
14081* flavors of Pomeron q-aq-pair
14082 IFLAV = INT(ONE+DT_RNDM(UNON)*(2.0D0+SEASQ))
14083 IFPPO(1) = IFLAV
14084 IFPPO(2) = -IFLAV
14085 IF (DT_RNDM(UNON).GT.OHALF) THEN
14086 IFPPO(1) = -IFLAV
14087 IFPPO(2) = IFLAV
14088 ENDIF
14089 ENDIF
14090
14091 IF (KT.EQ.2) THEN
14092* x-fractions of projectile target partons
14093 2 CONTINUE
14094 XTH(1) = DT_DBETAR(OHALF,UNON)
14095 IF (XTH(1).GE.XVQTHR) GOTO 2
14096 XTH(2) = ONE-XTH(1)
14097* x-fractions of Pomeron q-aq-pair
14098 XPOLO = TINY2
14099 XPOHI = ONE-TINY2
14100 XTPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14101 XTPO(2) = ONE-XTPO(1)
14102* flavors of Pomeron q-aq-pair
14103 IFLAV = INT(ONE+DT_RNDM(XPOLO)*(2.0D0+SEASQ))
14104 IFTPO(1) = IFLAV
14105 IFTPO(2) = -IFLAV
14106 IF (DT_RNDM(XPOLO).GT.OHALF) THEN
14107 IFTPO(1) = -IFLAV
14108 IFTPO(2) = IFLAV
14109 ENDIF
14110 ENDIF
14111
14112 RETURN
14113 END
14114
14115*$ CREATE DT_LM2RES.FOR
14116*COPY DT_LM2RES
14117*
14118*===lm2res=============================================================*
14119*
14120 SUBROUTINE DT_LM2RES(IF1,IF2,XM,IDR,IDXR,IREJ)
14121
14122************************************************************************
14123* Check low-mass diffractive excitation for resonance mass. *
14124* (input) IF1/2 PDG-indizes of valence partons *
14125* (in/out) XM diffractive mass requested/corrected *
14126* (output) IDR/IDXR id./BAMJET-index of resonance *
14127* This version dated 12.02.95 is written by S. Roesler *
14128************************************************************************
14129
14130 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14131 SAVE
14132 PARAMETER ( LINP = 10 ,
14133 & LOUT = 6 ,
14134 & LDAT = 9 )
14135 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14136
14137* kinematics of diffractive interactions (DTUNUC 1.x)
14138 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14139 & PPF(4),PTF(4),
14140 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14141 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14142
14143 IREJ = 0
14144 IF1B = 0
14145 IF2B = 0
14146 XMI = XM
14147
14148* BAMJET indices of partons
14149 IF1A = IDT_IPDG2B(IF1,1,2)
14150 IF (ABS(IF1).GE.1000) IF1B = IDT_IPDG2B(IF1,2,2)
14151 IF2A = IDT_IPDG2B(IF2,1,2)
14152 IF (ABS(IF2).GE.1000) IF2B = IDT_IPDG2B(IF2,2,2)
14153
14154* get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq)
14155 IDCH = 2
14156 IF ((IF1B.EQ.0).AND.(IF2B.EQ.0)) IDCH = 1
14157
14158* check for resonance mass
14159 CALL DT_CH2RES(IF1A,IF1B,IF2A,IF2B,IDR,IDXR,XMI,XMN,IDCH,IREJ1)
14160 IF (IREJ1.NE.0) GOTO 9999
14161
14162 XM = XMN
14163 RETURN
14164
14165 9999 CONTINUE
14166 IREJ = 1
14167 RETURN
14168 END
14169
14170*$ CREATE DT_LMKINE.FOR
14171*COPY DT_LMKINE
14172*
14173*===lmkine=============================================================*
14174*
14175 SUBROUTINE DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ)
14176
14177************************************************************************
14178* Kinematical treatment of low-mass excitations. *
14179* This version dated 12.02.95 is written by S. Roesler *
14180************************************************************************
14181
14182 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14183 SAVE
14184 PARAMETER ( LINP = 10 ,
14185 & LOUT = 6 ,
14186 & LDAT = 9 )
14187 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14188
14189* flags for input different options
14190 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14191 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14192 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14193* kinematics of diffractive interactions (DTUNUC 1.x)
14194 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14195 & PPF(4),PTF(4),
14196 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14197 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14198
14199 DIMENSION P1(4),P2(4)
14200
14201 IREJ = 0
14202
14203 IF (KP.EQ.1) THEN
14204 PABS = SQRT(PPF(1)**2+PPF(2)**2+PPF(3)**2)
14205 POE = PPF(4)/PABS
14206 FAC1 = OHALF*(POE+ONE)
14207 FAC2 = -OHALF*(POE-ONE)
14208 DO 1 K=1,3
14209 PPLM1(K) = FAC1*PPF(K)
14210 PPLM2(K) = FAC2*PPF(K)
14211 1 CONTINUE
14212 PPLM1(4) = FAC1*PABS
14213 PPLM2(4) = -FAC2*PABS
14214 IF (IMSHL.EQ.1) THEN
14215 XM1 = PYMASS(IFP1)
14216 XM2 = PYMASS(IFP2)
14217 CALL DT_MASHEL(PPLM1,PPLM2,XM1,XM2,P1,P2,IREJ1)
14218 IF (IREJ1.NE.0) GOTO 9999
14219 DO 2 K=1,4
14220 PPLM1(K) = P1(K)
14221 PPLM2(K) = P2(K)
14222 2 CONTINUE
14223 ENDIF
14224 ENDIF
14225
14226 IF (KT.EQ.1) THEN
14227 PABS = SQRT(PTF(1)**2+PTF(2)**2+PTF(3)**2)
14228 POE = PTF(4)/PABS
14229 FAC1 = OHALF*(POE+ONE)
14230 FAC2 = -OHALF*(POE-ONE)
14231 DO 3 K=1,3
14232 PTLM2(K) = FAC1*PTF(K)
14233 PTLM1(K) = FAC2*PTF(K)
14234 3 CONTINUE
14235 PTLM2(4) = FAC1*PABS
14236 PTLM1(4) = -FAC2*PABS
14237 IF (IMSHL.EQ.1) THEN
14238 XM1 = PYMASS(IFT1)
14239 XM2 = PYMASS(IFT2)
14240 CALL DT_MASHEL(PTLM1,PTLM2,XM1,XM2,P1,P2,IREJ1)
14241 IF (IREJ1.NE.0) GOTO 9999
14242 DO 4 K=1,4
14243 PTLM1(K) = P1(K)
14244 PTLM2(K) = P2(K)
14245 4 CONTINUE
14246 ENDIF
14247 ENDIF
14248
14249 RETURN
14250
14251 9999 CONTINUE
14252 WRITE(LOUT,'(A)') 'LMKINE: kinematical treatment rejected'
14253 IREJ = 1
14254 RETURN
14255 END
14256
14257*$ CREATE DT_DIFINI.FOR
14258*COPY DT_DIFINI
14259*
14260*===difini=============================================================*
14261*
14262 SUBROUTINE DT_DIFINI
14263
14264************************************************************************
14265* Initialization of common /DTDIKI/ *
14266* This version dated 12.02.95 is written by S. Roesler *
14267************************************************************************
14268
14269 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14270 SAVE
14271 PARAMETER ( LINP = 10 ,
14272 & LOUT = 6 ,
14273 & LDAT = 9 )
14274 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14275
14276* kinematics of diffractive interactions (DTUNUC 1.x)
14277 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14278 & PPF(4),PTF(4),
14279 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14280 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14281
14282 DO 1 K=1,4
14283 PPOM(K) = ZERO
14284 PSC(K) = ZERO
14285 PPF(K) = ZERO
14286 PTF(K) = ZERO
14287 PPLM1(K) = ZERO
14288 PPLM2(K) = ZERO
14289 PTLM1(K) = ZERO
14290 PTLM2(K) = ZERO
14291 1 CONTINUE
14292 DO 2 K=1,2
14293 XPH(K) = ZERO
14294 XPPO(K) = ZERO
14295 XTH(K) = ZERO
14296 XTPO(K) = ZERO
14297 IFPPO(K) = 0
14298 IFTPO(K) = 0
14299 2 CONTINUE
14300 IDPR = 0
14301 IDXPR = 0
14302 IDTR = 0
14303 IDXTR = 0
14304
14305 RETURN
14306 END
14307
14308*$ CREATE DT_DIFPUT.FOR
14309*COPY DT_DIFPUT
14310*
14311*===difput=============================================================*
14312*
14313 SUBROUTINE DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,
14314 & IREJ)
14315
14316************************************************************************
14317* Dump diffractive chains into DTEVT1 *
14318* This version dated 12.02.95 is written by S. Roesler *
14319************************************************************************
14320
14321 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14322 SAVE
14323 PARAMETER ( LINP = 10 ,
14324 & LOUT = 6 ,
14325 & LDAT = 9 )
14326 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14327
14328 LOGICAL LCHK
14329
14330* kinematics of diffractive interactions (DTUNUC 1.x)
14331 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14332 & PPF(4),PTF(4),
14333 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14334 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14335* event history
14336 PARAMETER (NMXHKK=200000)
14337 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14338 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14339 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14340* extended event history
14341 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14342 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14343 & IHIST(2,NMXHKK)
14344* rejection counter
14345 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
14346 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
14347 & IREXCI(3),IRDIFF(2),IRINC
14348
14349 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PCH(4),PP(4),PT(4),
14350 & P1(4),P2(4),P3(4),P4(4)
14351
14352 IREJ = 0
14353
14354 IF (KP.EQ.1) THEN
14355 DO 1 K=1,4
14356 PCH(K) = PPLM1(K)+PPLM2(K)
14357 1 CONTINUE
14358 ID1 = IFP1
14359 ID2 = IFP2
14360 IF (DT_RNDM(PT).GT.OHALF) THEN
14361 ID1 = IFP2
14362 ID2 = IFP1
14363 ENDIF
14364 CALL DT_EVTPUT(21,ID1,MOP,0,PPLM1(1),PPLM1(2),PPLM1(3),
14365 & PPLM1(4),0,0,0)
14366 CALL DT_EVTPUT(21,ID2,MOP,0,PPLM2(1),PPLM2(2),PPLM2(3),
14367 & PPLM2(4),0,0,0)
14368 CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
14369 & IDPR,IDXPR,8)
14370 ELSEIF (KP.EQ.2) THEN
14371 DO 2 K=1,4
14372 PP1(K) = XPH(1)*PP(K)
14373 PP2(K) = XPH(2)*PP(K)
14374 PT1(K) = -XPPO(1)*PPOM(K)
14375 PT2(K) = -XPPO(2)*PPOM(K)
14376 2 CONTINUE
14377 CALL DT_CHKCSY(IFP1,IFPPO(1),LCHK)
14378 XM1 = ZERO
14379 XM2 = ZERO
14380 IF (LCHK) THEN
14381 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
14382 IF (IREJ1.NE.0) GOTO 9999
14383 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
14384 IF (IREJ1.NE.0) GOTO 9999
14385 DO 3 K=1,4
14386 PP1(K) = P1(K)
14387 PT1(K) = P2(K)
14388 PP2(K) = P3(K)
14389 PT2(K) = P4(K)
14390 3 CONTINUE
14391 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
14392 & 0,0,8)
14393 CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
14394 & PT1(4),0,0,8)
14395 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
14396 & 0,0,8)
14397 CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
14398 & PT2(4),0,0,8)
14399 ELSE
14400 CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
14401 IF (IREJ1.NE.0) GOTO 9999
14402 CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
14403 IF (IREJ1.NE.0) GOTO 9999
14404 DO 4 K=1,4
14405 PP1(K) = P1(K)
14406 PT2(K) = P2(K)
14407 PP2(K) = P3(K)
14408 PT1(K) = P4(K)
14409 4 CONTINUE
14410 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
14411 & 0,0,8)
14412 CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
14413 & PT2(4),0,0,8)
14414 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
14415 & 0,0,8)
14416 CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
14417 & PT1(4),0,0,8)
14418 ENDIF
14419 NCSY = NCSY+1
14420 ELSE
14421 CALL DT_EVTPUT(1,IDHKK(MOP),MOP,0,PSC(1),PSC(2),PSC(3),PSC(4),
14422 & 0,0,0)
14423 ENDIF
14424
14425 IF (KT.EQ.1) THEN
14426 DO 5 K=1,4
14427 PCH(K) = PTLM1(K)+PTLM2(K)
14428 5 CONTINUE
14429 ID1 = IFT1
14430 ID2 = IFT2
14431 IF (DT_RNDM(PT).GT.OHALF) THEN
14432 ID1 = IFT2
14433 ID2 = IFT1
14434 ENDIF
14435 CALL DT_EVTPUT(22,ID1,MOT,0,PTLM1(1),PTLM1(2),PTLM1(3),
14436 & PTLM1(4),0,0,0)
14437 CALL DT_EVTPUT(22,ID2,MOT,0,PTLM2(1),PTLM2(2),PTLM2(3),
14438 & PTLM2(4),0,0,0)
14439 CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
14440 & IDTR,IDXTR,8)
14441 ELSEIF (KT.EQ.2) THEN
14442 DO 6 K=1,4
14443 PP1(K) = XTPO(1)*PPOM(K)
14444 PP2(K) = XTPO(2)*PPOM(K)
14445 PT1(K) = XTH(2)*PT(K)
14446 PT2(K) = XTH(1)*PT(K)
14447 6 CONTINUE
14448 CALL DT_CHKCSY(IFTPO(1),IFT1,LCHK)
14449 XM1 = ZERO
14450 XM2 = ZERO
14451 IF (LCHK) THEN
14452 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
14453 IF (IREJ1.NE.0) GOTO 9999
14454 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
14455 IF (IREJ1.NE.0) GOTO 9999
14456 DO 7 K=1,4
14457 PP1(K) = P1(K)
14458 PT1(K) = P2(K)
14459 PP2(K) = P3(K)
14460 PT2(K) = P4(K)
14461 7 CONTINUE
14462 CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
14463 & PP1(4),0,0,8)
14464 CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
14465 & 0,0,8)
14466 CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
14467 & PP2(4),0,0,8)
14468 CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
14469 & 0,0,8)
14470 ELSE
14471 CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
14472 IF (IREJ1.NE.0) GOTO 9999
14473 CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
14474 IF (IREJ1.NE.0) GOTO 9999
14475 DO 8 K=1,4
14476 PP1(K) = P1(K)
14477 PT2(K) = P2(K)
14478 PP2(K) = P3(K)
14479 PT1(K) = P4(K)
14480 8 CONTINUE
14481 CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
14482 & PP1(4),0,0,8)
14483 CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
14484 & 0,0,8)
14485 CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
14486 & PP2(4),0,0,8)
14487 CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
14488 & 0,0,8)
14489 ENDIF
14490 NCSY = NCSY+1
14491 ELSE
14492 CALL DT_EVTPUT(1,IDHKK(MOT),MOT,0,PSC(1),PSC(2),PSC(3),PSC(4),
14493 & 0,0,0)
14494 ENDIF
14495
14496 RETURN
14497
14498 9999 CONTINUE
14499 IRDIFF(2) = IRDIFF(2)+1
14500 IREJ = 1
14501 RETURN
14502 END
14503
14504*$ CREATE DT_EVTFRG.FOR
14505*COPY DT_EVTFRG
14506*
14507*===evtfrg=============================================================*
14508*
14509 SUBROUTINE DT_EVTFRG(KMODE,NFRG,NPYMEM,IREJ)
14510
14511************************************************************************
14512* Hadronization of chains in DTEVT1. *
14513* *
14514* Input: *
14515* KMODE = 1 hadronization of PHOJET-chains (id=77xxx) *
14516* = 2 hadronization of DTUNUC-chains (id=88xxx) *
14517* NFRG if KMODE = 1 : upper index of PHOJET-scatterings to be *
14518* hadronized with one PYEXEC call *
14519* if KMODE = 2 : max. number of DTUNUC-chains to be hadronized *
14520* with one PYEXEC call *
14521* Output: *
14522* NPYMEM number of entries in JETSET-common after hadronization *
14523* IREJ rejection flag *
14524* *
14525* This version dated 17.09.00 is written by S. Roesler *
14526************************************************************************
14527
14528 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14529 SAVE
14530 PARAMETER ( LINP = 10 ,
14531 & LOUT = 6 ,
14532 & LDAT = 9 )
14533 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1)
14534 PARAMETER (ONE=1.0D0,ZERO=0.0D0)
14535
14536 LOGICAL LACCEP
14537
14538 PARAMETER (MXJOIN=200)
14539
14540* event history
14541 PARAMETER (NMXHKK=200000)
14542 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14543 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14544 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14545* extended event history
14546 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14547 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14548 & IHIST(2,NMXHKK)
14549* flags for input different options
14550 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14551 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14552 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14553* statistics
14554 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
14555 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
14556 & ICEVTG(8,0:30)
14557* flags for diffractive interactions (DTUNUC 1.x)
14558 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
14559* nucleon-nucleon event-generator
14560 CHARACTER*8 CMODEL
14561 LOGICAL LPHOIN
14562 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
14563* phojet
14564C model switches and parameters
14565 CHARACTER*8 MDLNA
14566 INTEGER ISWMDL,IPAMDL
14567 DOUBLE PRECISION PARMDL
14568 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14569* jetset
14570 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14571 PARAMETER (MAXLND=4000)
14572 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
14573 INTEGER PYK
14574 DIMENSION IJOIN(MXJOIN),ISJOIN(MXJOIN),IHISMO(8000),IFLG(4000)
14575
14576 MODE = KMODE
14577 ISTSTG = 7
14578 IF (MODE.NE.1) ISTSTG = 8
14579 IREJ = 0
14580
14581 IP = 0
14582 ISH = 0
14583 INIEMC = 1
14584 NEND = NHKK
14585 NACCEP = 0
14586 IFRG = 0
14587 IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
14588 DO 10 I=NPOINT(3),NEND
14589* sr 14.02.00: seems to be not necessary anymore, commented
14590C LACCEP = ((NOBAM(I).EQ.0).AND.(MODE.EQ.1)).OR.
14591C & ((NOBAM(I).NE.0).AND.(MODE.EQ.2))
14592 LACCEP = .TRUE.
14593* pick up chains from dtevt1
14594 IDCHK = IDHKK(I)/10000
14595 IF ((IDCHK.EQ.ISTSTG).AND.LACCEP) THEN
14596 IF (IDCHK.EQ.7) THEN
14597 IPJE = IDHKK(I)-IDCHK*10000
14598 IF (IPJE.NE.IFRG) THEN
14599 IFRG = IPJE
14600 IF (IFRG.GT.NFRG) GOTO 16
14601 ENDIF
14602 ELSE
14603 IPJE = 1
14604 IFRG = IFRG+1
14605 IF (IFRG.GT.NFRG) THEN
14606 NFRG = -1
14607 GOTO 16
14608 ENDIF
14609 ENDIF
14610* statistics counter
14611c IF (IDCH(I).LE.8)
14612c & ICCHAI(2,IDCH(I)) = ICCHAI(2,IDCH(I))+1
14613c IF (IDRES(I).NE.0) ICRES(IDCH(I)) = ICRES(IDCH(I))+1
14614* special treatment for small chains already corrected to hadrons
14615 IF (IDRES(I).NE.0) THEN
14616 IF (IDRES(I).EQ.11) THEN
14617 ID = IDXRES(I)
14618 ELSE
14619 ID = IDT_IPDGHA(IDXRES(I))
14620 ENDIF
14621 IF (LEMCCK) THEN
14622 CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
14623 & PHKK(4,I),INIEMC,IDUM,IDUM)
14624 INIEMC = 2
14625 ENDIF
14626 IP = IP+1
14627 IF (IP.GT.MSTU(4)) STOP ' NEWFRA 1: IP.GT.MSTU(4) !'
14628 P(IP,1) = PHKK(1,I)
14629 P(IP,2) = PHKK(2,I)
14630 P(IP,3) = PHKK(3,I)
14631 P(IP,4) = PHKK(4,I)
14632 P(IP,5) = PHKK(5,I)
14633 K(IP,1) = 1
14634 K(IP,2) = ID
14635 K(IP,3) = 0
14636 K(IP,4) = 0
14637 K(IP,5) = 0
14638 IHIST(2,I) = 10000*IPJE+IP
14639 IF (IHIST(1,I).LE.-100) THEN
14640 ISH = ISH+1
14641 IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
14642 ISJOIN(ISH) = I
14643 ENDIF
14644 N = IP
14645 IHISMO(IP) = I
14646 ELSE
14647 IJ = 0
14648 DO 11 KK=JMOHKK(1,I),JMOHKK(2,I)
14649 IF (LEMCCK) THEN
14650 CALL DT_EVTEMC(PHKK(1,KK),PHKK(2,KK),PHKK(3,KK),
14651 & PHKK(4,KK),INIEMC,IDUM,IDUM)
14652 CALL DT_EVTFLC(IDHKK(KK),1,INIEMC,IDUM,IDUM)
14653 INIEMC = 2
14654 ENDIF
14655 ID = IDHKK(KK)
14656 IF (ID.EQ.0) ID = 21
14657c PTOT = SQRT(PHKK(1,KK)**2+PHKK(2,KK)**2+PHKK(3,KK)**2)
14658c AM0 = SQRT(ABS((PHKK(4,KK)-PTOT)*(PHKK(4,KK)+PTOT)))
14659c AMRQ = PYMASS(ID)
14660c AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
14661c IF ((ABS(AMDIF2).GT.TINY3).AND.(PTOT.GT.ZERO).AND.
14662c & (ABS(IDIFF).EQ.0)) THEN
14663cC WRITE(LOUT,*)'here: ',NEVHKK,AM0,AMRQ
14664c DELTA = -AMDIF2/(2.0D0*(PHKK(4,KK)+PTOT))
14665c PHKK(4,KK) = PHKK(4,KK)+DELTA
14666c PTOT1 = PTOT-DELTA
14667c PHKK(1,KK) = PHKK(1,KK)*PTOT1/PTOT
14668c PHKK(2,KK) = PHKK(2,KK)*PTOT1/PTOT
14669c PHKK(3,KK) = PHKK(3,KK)*PTOT1/PTOT
14670c PHKK(5,KK) = AMRQ
14671c ENDIF
14672 IP = IP+1
14673 IF (IP.GT.MSTU(4)) STOP ' NEWFRA 2: IP.GT.MSTU(4) !'
14674 P(IP,1) = PHKK(1,KK)
14675 P(IP,2) = PHKK(2,KK)
14676 P(IP,3) = PHKK(3,KK)
14677 P(IP,4) = PHKK(4,KK)
14678 P(IP,5) = PHKK(5,KK)
14679 K(IP,1) = 1
14680 K(IP,2) = ID
14681 K(IP,3) = 0
14682 K(IP,4) = 0
14683 K(IP,5) = 0
14684 IHIST(2,KK) = 10000*IPJE+IP
14685 IF (IHIST(1,KK).LE.-100) THEN
14686 ISH = ISH+1
14687 IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
14688 ISJOIN(ISH) = KK
14689 ENDIF
14690 IJ = IJ+1
14691 IF (IJ.GT.MXJOIN) STOP 'IJ > MXJOIN !'
14692 IJOIN(IJ) = IP
14693 IHISMO(IP) = I
14694 11 CONTINUE
14695 N = IP
14696* join the two-parton system
14697 CALL PYJOIN(IJ,IJOIN)
14698 ENDIF
14699 IDHKK(I) = 99999
14700 ENDIF
14701 10 CONTINUE
14702 16 CONTINUE
14703 N = IP
14704
14705 IF (IP.GT.0) THEN
14706
14707* final state parton shower
14708 DO 136 NPJE=1,IPJE
14709 IF ((MCGENE.EQ.2).AND.(ISH.GE.2)) THEN
14710 IF ((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
14711 DO 130 K1=1,ISH
14712 IF (ISJOIN(K1).EQ.0) GOTO 130
14713 I = ISJOIN(K1)
14714 IF ((IPAMDL(102).EQ.1).AND.(IHIST(1,I).NE.-100))
14715 & GOTO 130
14716 IH1 = IHIST(2,I)/10000
14717 IF (IH1.NE.NPJE) GOTO 130
14718 IH1 = IHIST(2,I)-IH1*10000
14719 DO 135 K2=K1+1,ISH
14720 IF (ISJOIN(K2).EQ.0) GOTO 135
14721 II = ISJOIN(K2)
14722 IH2 = IHIST(2,II)/10000
14723 IF (IH2.NE.NPJE) GOTO 135
14724 IH2 = IHIST(2,II)-IH2*10000
14725 IF (IHIST(1,I).EQ.IHIST(1,II)) THEN
14726 PT1 = SQRT(PHKK(1,II)**2+PHKK(2,II)**2)
14727 PT2 = SQRT(PHKK(1, I)**2+PHKK(2, I)**2)
14728 RQLUN = MIN(PT1,PT2)
14729 CALL PYSHOW(IH1,IH2,RQLUN)
14730
14731 ISJOIN(K1) = 0
14732 ISJOIN(K2) = 0
14733 GOTO 130
14734 ENDIF
14735 135 CONTINUE
14736 130 CONTINUE
14737 ENDIF
14738 ENDIF
14739 136 CONTINUE
14740
14741 CALL DT_INITJS(MODE)
14742* hadronization
14743
14744 CALL PYEXEC
14745
14746 IF (MSTU(24).NE.0) THEN
14747 WRITE(LOUT,*) ' JETSET-reject at event',
14748 & NEVHKK,MSTU(24),KMODE
14749C CALL DT_EVTOUT(4)
14750
14751C CALL PYLIST(2)
14752
14753 GOTO 9999
14754 ENDIF
14755
14756* number of entries in LUJETS
14757
14758 NLINES = PYK(0,1)
14759
14760 NPYMEM = NLINES
14761
14762 DO 12 I=1,NLINES
14763 IFLG(I) = 0
14764 12 CONTINUE
14765
14766 DO 13 II=1,NLINES
14767
14768 IF ((PYK(II,7).EQ.1).AND.(IFLG(II).NE.1)) THEN
14769
14770* pick up mother resonance if possible and put it together with
14771* their decay-products into the common
14772 IDXMOR = K(II,3)
14773 IF ((IDXMOR.GE.1).AND.(IDXMOR.LE.MAXLND)) THEN
14774 KFMOR = K(IDXMOR,2)
14775 ISMOR = K(IDXMOR,1)
14776 ELSE
14777 KFMOR = 91
14778 ISMOR = 1
14779 ENDIF
14780 IF ((KFMOR.NE.91).AND.(KFMOR.NE.92).AND.
14781 & (KFMOR.NE.94).AND.(ISMOR.EQ.11)) THEN
14782 ID = K(IDXMOR,2)
14783 MO = IHISMO(PYK(IDXMOR,15))
14784 PX = PYP(IDXMOR,1)
14785 PY = PYP(IDXMOR,2)
14786 PZ = PYP(IDXMOR,3)
14787 PE = PYP(IDXMOR,4)
14788 CALL DT_EVTPUT(2,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14789 IFLG(IDXMOR) = 1
14790 MO = NHKK
14791 DO 15 JDAUG=K(IDXMOR,4),K(IDXMOR,5)
14792 IF (PYK(JDAUG,7).EQ.1) THEN
14793 ID = PYK(JDAUG,8)
14794 PX = PYP(JDAUG,1)
14795 PY = PYP(JDAUG,2)
14796 PZ = PYP(JDAUG,3)
14797 PE = PYP(JDAUG,4)
14798 CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14799 IF (LEMCCK) THEN
14800 PX = -PYP(JDAUG,1)
14801 PY = -PYP(JDAUG,2)
14802 PZ = -PYP(JDAUG,3)
14803 PE = -PYP(JDAUG,4)
14804 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
14805 ENDIF
14806 IFLG(JDAUG) = 1
14807 ENDIF
14808 15 CONTINUE
14809 ELSE
14810* there was no mother resonance
14811 MO = IHISMO(PYK(II,15))
14812 ID = PYK(II,8)
14813 PX = PYP(II,1)
14814 PY = PYP(II,2)
14815 PZ = PYP(II,3)
14816 PE = PYP(II,4)
14817 CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14818 IF (LEMCCK) THEN
14819 PX = -PYP(II,1)
14820 PY = -PYP(II,2)
14821 PZ = -PYP(II,3)
14822 PE = -PYP(II,4)
14823 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
14824 ENDIF
14825 ENDIF
14826 ENDIF
14827 13 CONTINUE
14828 IF (LEMCCK) THEN
14829 CHKLEV = TINY1
14830 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,6,IREJ1)
14831C IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
14832 ENDIF
14833
14834* global energy-momentum & flavor conservation check
14835**sr 16.5. this check is skipped in case of phojet-treatment
14836 IF (MCGENE.EQ.1)
14837 & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,12,IREJ3)
14838
14839* update statistics-counter for diffraction
14840c IF (IFLAGD.NE.0) THEN
14841c ICDIFF(1) = ICDIFF(1)+1
14842c IF (IFLAGD.EQ. 1) ICDIFF(2) = ICDIFF(2)+1
14843c IF (IFLAGD.EQ. 2) ICDIFF(3) = ICDIFF(3)+1
14844c IF (IFLAGD.EQ.-1) ICDIFF(4) = ICDIFF(4)+1
14845c IF (IFLAGD.EQ.-2) ICDIFF(5) = ICDIFF(5)+1
14846c ENDIF
14847
14848 ENDIF
14849
14850 RETURN
14851
14852 9999 CONTINUE
14853 IREJ = 1
14854 RETURN
14855 END
14856
14857*$ CREATE DT_DECAYS.FOR
14858*COPY DT_DECAYS
14859*
14860*===decay==============================================================*
14861*
14862 SUBROUTINE DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
14863
14864************************************************************************
14865* Resonance-decay. *
14866* This subroutine replaces DDECAY/DECHKK. *
14867* PIN(4) 4-momentum of resonance (input) *
14868* IDXIN BAMJET-index of resonance (input) *
14869* POUT(20,4) 4-momenta of decay-products (output) *
14870* IDXOUT(20) BAMJET-indices of decay-products (output) *
14871* NSEC number of secondaries (output) *
14872* Adopted from the original version DECHKK. *
14873* This version dated 09.01.95 is written by S. Roesler *
14874************************************************************************
14875
14876 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14877 SAVE
14878 PARAMETER ( LINP = 10 ,
14879 & LOUT = 6 ,
14880 & LDAT = 9 )
14881 PARAMETER (TINY17=1.0D-17)
14882
14883* HADRIN: decay channel information
14884 PARAMETER (IDMAX9=602)
14885 CHARACTER*8 ZKNAME
14886 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
14887* particle properties (BAMJET index convention)
14888 CHARACTER*8 ANAME
14889 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
14890 & IICH(210),IIBAR(210),K1(210),K2(210)
14891* flags for input different options
14892 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14893 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14894 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14895
14896 DIMENSION PIN(4),PI(20,4),POUT(20,4),IDXOUT(20),
14897 & EF(3),PF(3),PFF(3),IDXSTK(20),IDX(3),
14898 & CODF(3),COFF(3),SIFF(3),DCOS(3),DCOSF(3)
14899
14900* ISTAB = 1 strong and weak decays
14901* = 2 strong decays only
14902* = 3 strong decays, weak decays for charmed particles and tau
14903* leptons only
14904 DATA ISTAB /2/
14905
14906 IREJ = 0
14907 NSEC = 0
14908* put initial resonance to stack
14909 NSTK = 1
14910 IDXSTK(NSTK) = IDXIN
14911 DO 5 I=1,4
14912 PI(NSTK,I) = PIN(I)
14913 5 CONTINUE
14914
14915* store initial configuration for energy-momentum cons. check
14916 IF (LEMCCK) CALL DT_EVTEMC(PI(NSTK,1),PI(NSTK,2),PI(NSTK,3),
14917 & PI(NSTK,4),1,IDUM,IDUM)
14918
14919 100 CONTINUE
14920* get particle from stack
14921 IDXI = IDXSTK(NSTK)
14922* skip stable particles
14923 IF (ISTAB.EQ.1) THEN
14924 IF ((IDXI.EQ.135).OR. (IDXI.EQ.136)) GOTO 10
14925 IF ((IDXI.GE. 1).AND.(IDXI.LE. 7)) GOTO 10
14926 ELSEIF (ISTAB.EQ.2) THEN
14927 IF ((IDXI.GE. 1).AND.(IDXI.LE. 30)) GOTO 10
14928 IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
14929 IF ((IDXI.GE.115).AND.(IDXI.LE.122)) GOTO 10
14930 IF ((IDXI.GE.131).AND.(IDXI.LE.136)) GOTO 10
14931 IF ( IDXI.EQ.109) GOTO 10
14932 IF ((IDXI.GE.137).AND.(IDXI.LE.160)) GOTO 10
14933 ELSEIF (ISTAB.EQ.3) THEN
14934 IF ((IDXI.GE. 1).AND.(IDXI.LE. 23)) GOTO 10
14935 IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
14936 IF ((IDXI.GE.109).AND.(IDXI.LE.115)) GOTO 10
14937 IF ((IDXI.GE.133).AND.(IDXI.LE.136)) GOTO 10
14938 ENDIF
14939
14940* calculate direction cosines and Lorentz-parameter of decaying part.
14941 PTOT = SQRT(PI(NSTK,1)**2+PI(NSTK,2)**2+PI(NSTK,3)**2)
14942 PTOT = MAX(PTOT,TINY17)
14943 DO 1 I=1,3
14944 DCOS(I) = PI(NSTK,I)/PTOT
14945 1 CONTINUE
14946 GAM = PI(NSTK,4)/AAM(IDXI)
14947 BGAM = PTOT/AAM(IDXI)
14948
14949* get decay-channel
14950 KCHAN = K1(IDXI)-1
14951 2 CONTINUE
14952 KCHAN = KCHAN+1
14953 IF ((DT_RNDM(GAM)-TINY17).GT.WT(KCHAN)) GOTO 2
14954
14955* identities of secondaries
14956 IDX(1) = NZK(KCHAN,1)
14957 IDX(2) = NZK(KCHAN,2)
14958 IF (IDX(2).LT.1) GOTO 9999
14959 IDX(3) = NZK(KCHAN,3)
14960
14961* handle decay in rest system of decaying particle
14962 IF (IDX(3).EQ.0) THEN
14963* two-particle decay
14964 NDEC = 2
14965 CALL DT_DTWOPD(AAM(IDXI),EF(1),EF(2),PF(1),PF(2),
14966 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
14967 & AAM(IDX(1)),AAM(IDX(2)))
14968 ELSE
14969* three-particle decay
14970 NDEC = 3
14971 CALL DT_DTHREP(AAM(IDXI),EF(1),EF(2),EF(3),PF(1),PF(2),PF(3),
14972 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
14973 & CODF(3),COFF(3),SIFF(3),
14974 & AAM(IDX(1)),AAM(IDX(2)),AAM(IDX(3)))
14975 ENDIF
14976 NSTK = NSTK-1
14977
14978* transform decay products back
14979 DO 3 I=1,NDEC
14980 NSTK = NSTK+1
14981 CALL DT_DTRAFO(GAM,BGAM,DCOS(1),DCOS(2),DCOS(3),
14982 & CODF(I),COFF(I),SIFF(I),PF(I),EF(I),
14983 & PFF(I),DCOSF(1),DCOSF(2),DCOSF(3),PI(NSTK,4))
14984* add particle to stack
14985 IDXSTK(NSTK) = IDX(I)
14986 DO 4 J=1,3
14987 PI(NSTK,J) = DCOSF(J)*PFF(I)
14988 4 CONTINUE
14989 3 CONTINUE
14990 GOTO 100
14991
14992 10 CONTINUE
14993* stable particle, put to output-arrays
14994 NSEC = NSEC+1
14995 DO 6 I=1,4
14996 POUT(NSEC,I) = PI(NSTK,I)
14997 6 CONTINUE
14998 IDXOUT(NSEC) = IDXSTK(NSTK)
14999* store secondaries for energy-momentum conservation check
15000 IF (LEMCCK)
15001 &CALL DT_EVTEMC(-POUT(NSEC,1),-POUT(NSEC,2),-POUT(NSEC,3),
15002 & -POUT(NSEC,4),2,IDUM,IDUM)
15003 NSTK = NSTK-1
15004 IF (NSTK.GT.0) GOTO 100
15005
15006* check energy-momentum conservation
15007 IF (LEMCCK) THEN
15008 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,5,IREJ1)
15009 IF (IREJ1.NE.0) GOTO 9999
15010 ENDIF
15011
15012 RETURN
15013
15014 9999 CONTINUE
15015 IREJ = 1
15016 RETURN
15017 END
15018
15019*$ CREATE DT_DECAY1.FOR
15020*COPY DT_DECAY1
15021*
15022*===decay1=============================================================*
15023*
15024 SUBROUTINE DT_DECAY1
15025
15026************************************************************************
15027* Decay of resonances stored in DTEVT1. *
15028* This version dated 20.01.95 is written by S. Roesler *
15029************************************************************************
15030
15031 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15032 SAVE
15033 PARAMETER ( LINP = 10 ,
15034 & LOUT = 6 ,
15035 & LDAT = 9 )
15036
15037* event history
15038 PARAMETER (NMXHKK=200000)
15039 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15040 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15041 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15042* extended event history
15043 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15044 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15045 & IHIST(2,NMXHKK)
15046
15047 DIMENSION PIN(4),POUT(20,4),IDXOUT(20)
15048
15049 NEND = NHKK
15050C DO 1 I=NPOINT(5),NEND
15051 DO 1 I=NPOINT(4),NEND
15052 IF (ABS(ISTHKK(I)).EQ.1) THEN
15053 DO 2 K=1,4
15054 PIN(K) = PHKK(K,I)
15055 2 CONTINUE
15056 IDXIN = IDBAM(I)
15057 CALL DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
15058 IF (NSEC.GT.1) THEN
15059 DO 3 N=1,NSEC
15060 IDHAD = IDT_IPDGHA(IDXOUT(N))
15061 CALL DT_EVTPUT(1,IDHAD,I,0,POUT(N,1),POUT(N,2),
15062 & POUT(N,3),POUT(N,4),0,0,0)
15063 3 CONTINUE
15064 ENDIF
15065 ENDIF
15066 1 CONTINUE
15067
15068 RETURN
15069 END
15070
15071*$ CREATE DT_DECPI0.FOR
15072*COPY DT_DECPI0
15073*
15074*===decpi0=============================================================*
15075*
15076 SUBROUTINE DT_DECPI0
15077
15078************************************************************************
15079* Decay of pi0 handled with JETSET. *
15080* This version dated 18.02.96 is written by S. Roesler *
15081************************************************************************
15082
15083 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15084 SAVE
15085 PARAMETER ( LINP = 10 ,
15086 & LOUT = 6 ,
15087 & LDAT = 9 )
15088 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0,ZERO=0.0D0)
15089
15090* event history
15091 PARAMETER (NMXHKK=200000)
15092 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15093 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15094 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15095* extended event history
15096 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15097 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15098 & IHIST(2,NMXHKK)
15099 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
15100 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15101 PARAMETER (MAXLND=4000)
15102 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
15103* flags for input different options
15104 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15105 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15106 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15107
15108 INTEGER PYCOMP,PYK
15109
15110 DIMENSION IHISMO(NMXHKK),P1(4)
15111
15112 TWOPI = 2.0D0*ATAN2(0.0D0,-1.0D0)
15113
15114 CALL DT_INITJS(2)
15115* allow pi0 decay
15116 KC = PYCOMP(111)
15117 MDCY(KC,1) = 1
15118
15119 NN = 0
15120 INI = 0
15121 DO 1 I=1,NHKK
15122 IF ((ISTHKK(I).EQ.1).AND.(IDHKK(I).EQ.111)) THEN
15123 IF (INI.EQ.0) THEN
15124 INI = 1
15125 ELSE
15126 INI = 2
15127 ENDIF
15128 IF (LEMCCK) CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
15129 & PHKK(4,I),INI,IDUM,IDUM)
15130 PT = SQRT(PHKK(1,I)**2+PHKK(2,I)**2)
15131 PTOT = SQRT(PT**2+PHKK(3,I)**2)
15132 COSTH = PHKK(3,I)/(PTOT+TINY10)
15133 IF (COSTH.GT.ONE) THEN
15134 THETA = ZERO
15135 ELSEIF (COSTH.LT.-ONE) THEN
15136 THETA = TWOPI/2.0D0
15137 ELSE
15138 THETA = ACOS(COSTH)
15139 ENDIF
15140 PHI = ASIN(PHKK(2,I)/(PT +TINY10))
15141 IF (PHKK(1,I).LT.0.0D0)
15142 & PHI = SIGN(TWOPI/2.0D0-ABS(PHI),PHI)
15143 ENER = PHKK(4,I)
15144 NN = NN+1
15145 KTEMP = MSTU(10)
15146 MSTU(10)= 1
15147 P(NN,5) = PHKK(5,I)
15148 CALL PY1ENT(NN,111,ENER,THETA,PHI)
15149 MSTU(10) = KTEMP
15150 IHISMO(NN)= I
15151 ENDIF
15152 1 CONTINUE
15153 IF (NN.GT.0) THEN
15154 CALL PYEXEC
15155 NLINES = PYK(0,1)
15156 DO 2 II=1,NLINES
15157 IF (PYK(II,7).EQ.1) THEN
15158 DO 3 KK=1,4
15159 P1(KK) = PYP(II,KK)
15160 3 CONTINUE
15161 ID = PYK(II,8)
15162 MO = IHISMO(PYK(II,15))
15163 CALL DT_EVTPUT(1,ID,MO,0,P1(1),P1(2),P1(3),P1(4),0,0,0)
15164 IF (LEMCCK)
15165 & CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,
15166 & IDUM,IDUM)
15167*sr: flag with neg. sign (for HELIOS p/A-W jobs)
15168 ISTHKK(MO) = -2
15169 ENDIF
15170 2 CONTINUE
15171 IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,7000,IREJ1)
15172 ENDIF
15173 MDCY(KC,1) = 0
15174
15175 RETURN
15176 END
15177
15178*$ CREATE DT_DTWOPD.FOR
15179*COPY DT_DTWOPD
15180*
15181*===dtwopd=============================================================*
15182*
15183 SUBROUTINE DT_DTWOPD(UMO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,COD2,
15184 & COF2,SIF2,AM1,AM2)
15185
15186************************************************************************
15187* Two-particle decay. *
15188* UMO cm-energy of the decaying system (input) *
15189* AM1/AM2 masses of the decay products (input) *
15190* ECM1,ECM2/PCM1,PCM2 cm-energies/momenta of the decay prod. (output) *
15191* COD,COF,SIF direction cosines of the decay prod. (output) *
15192* Revised by S. Roesler, 20.11.95 *
15193************************************************************************
15194
15195 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15196 SAVE
15197 PARAMETER ( LINP = 10 ,
15198 & LOUT = 6 ,
15199 & LDAT = 9 )
15200 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,ZERO=0.0D0)
15201
15202 IF (UMO.LT.(AM1+AM2)) THEN
15203 WRITE(LOUT,1000) UMO,AM1,AM2
15204 1000 FORMAT(1X,'DTWOPD: inconsistent kinematics - UMO,AM1,AM2 ',
15205 & 3E12.3)
15206 STOP
15207 ENDIF
15208
15209 ECM1 = ((UMO-AM2)*(UMO+AM2)+AM1*AM1)/(TWO*UMO)
15210 ECM2 = UMO-ECM1
15211 PCM1 = SQRT((ECM1-AM1)*(ECM1+AM1))
15212 PCM2 = PCM1
15213 CALL DT_DSFECF(SIF1,COF1)
15214 COD1 = TWO*DT_RNDM(PCM2)-ONE
15215 COD2 = -COD1
15216 COF2 = -COF1
15217 SIF2 = -SIF1
15218
15219 RETURN
15220 END
15221
15222*$ CREATE DT_DTHREP.FOR
15223*COPY DT_DTHREP
15224*
15225*===dthrep=============================================================*
15226*
15227 SUBROUTINE DT_DTHREP(UMO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,
15228 & SIF1,COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
15229
15230************************************************************************
15231* Three-particle decay. *
15232* UMO cm-energy of the decaying system (input) *
15233* AM1/2/3 masses of the decay products (input) *
15234* ECM1/2/2,PCM1/2/3 cm-energies/momenta of the decay prod. (output) *
15235* COD,COF,SIF direction cosines of the decay prod. (output) *
15236* *
15237* Threpd89: slight revision by A. Ferrari *
15238* Last change on 11-oct-93 by Alfredo Ferrari, INFN - Milan *
15239* Revised by S. Roesler, 20.11.95 *
15240************************************************************************
15241
15242 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15243 SAVE
15244 PARAMETER ( LINP = 10 ,
15245 & LOUT = 6 ,
15246 & LDAT = 9 )
15247
15248 PARAMETER ( ANGLSQ = 2.5D-31 )
15249 PARAMETER ( AZRZRZ = 1.0D-30 )
15250 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
15251 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
15252 PARAMETER ( ONEONE = 1.D+00 )
15253 PARAMETER ( TWOTWO = 2.D+00 )
15254 PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
15255
15256 COMMON /HNGAMR/ REDU,AMO,AMM(15)
15257* flags for input different options
15258 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15259 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15260 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15261
15262 DIMENSION F(5),XX(5)
15263 DATA EPS /AZRZRZ/
15264
15265 UMOO=UMO+UMO
15266C***S1, S2, S3 ARE THE INVARIANT MASSES OF THE PARTICLES 1, 2, 3
15267C***J. VON NEUMANN - RANDOM - SELECTION OF S2
15268C***CALCULATION OF THE MAXIMUM OF THE S2 - DISTRIBUTION
15269 UUMO=UMO
15270 AAM1=AM1
15271 AAM2=AM2
15272 AAM3=AM3
15273 GU=(AM2+AM3)**2
15274 GO=(UMO-AM1)**2
15275* UFAK=1.0000000000001D0
15276* IF (GU.GT.GO) UFAK=0.9999999999999D0
15277 IF (GU.GT.GO) THEN
15278 UFAK=ONEMNS
15279 ELSE
15280 UFAK=ONEPLS
15281 END IF
15282 OFAK=2.D0-UFAK
15283 GU=GU*UFAK
15284 GO=GO*OFAK
15285 DS2=(GO-GU)/99.D0
15286 AM11=AM1*AM1
15287 AM22=AM2*AM2
15288 AM33=AM3*AM3
15289 UMO2=UMO*UMO
15290 RHO2=0.D0
15291 S22=GU
15292 DO 124 I=1,100
15293 S21=S22
15294 S22=GU+(I-1.D0)*DS2
15295 RHO1=RHO2
15296 RHO2=DT_YLAMB(S22,UMO2,AM11)*DT_YLAMB(S22,AM22,AM33)/
15297 * (S22+EPS)
15298 IF(RHO2.LT.RHO1) GO TO 125
15299 124 CONTINUE
15300 125 S2SUP=(S22-S21)*.5D0+S21
15301 SUPRHO=DT_YLAMB(S2SUP,UMO2,AM11)*DT_YLAMB(S2SUP,AM22,AM33)/
15302 * (S2SUP+EPS)
15303 SUPRHO=SUPRHO*1.05D0
15304 XO=S21-DS2
15305 IF (GU.LT.GO.AND.XO.LT.GU) XO=GU
15306 IF (GU.GT.GO.AND.XO.GT.GU) XO=GU
15307 XX(1)=XO
15308 XX(3)=S22
15309 X1=(XO+S22)*0.5D0
15310 XX(2)=X1
15311 F(3)=RHO2
15312 F(1)=DT_YLAMB(XO,UMO2,AM11)*DT_YLAMB(XO,AM22,AM33)/(XO+EPS)
15313 F(2)=DT_YLAMB(X1,UMO2,AM11)*DT_YLAMB(X1,AM22,AM33)/(X1+EPS)
15314 DO 126 I=1,16
15315 X4=(XX(1)+XX(2))*0.5D0
15316 X5=(XX(2)+XX(3))*0.5D0
15317 F(4)=DT_YLAMB(X4,UMO2,AM11)*DT_YLAMB(X4,AM22,AM33)/
15318 * (X4+EPS)
15319 F(5)=DT_YLAMB(X5,UMO2,AM11)*DT_YLAMB(X5,AM22,AM33)/
15320 * (X5+EPS)
15321 XX(4)=X4
15322 XX(5)=X5
15323 DO 128 II=1,5
15324 IA=II
15325 DO 128 III=IA,5
15326 IF (F (II).GE.F (III)) GO TO 128
15327 FH=F(II)
15328 F(II)=F(III)
15329 F(III)=FH
15330 FH=XX(II)
15331 XX(II)=XX(III)
15332 XX(III)=FH
15333128 CONTINUE
15334 SUPRHO=F(1)
15335 S2SUP=XX(1)
15336 DO 129 II=1,3
15337 IA=II
15338 DO 129 III=IA,3
15339 IF (XX(II).GE.XX(III)) GO TO 129
15340 FH=F(II)
15341 F(II)=F(III)
15342 F(III)=FH
15343 FH=XX(II)
15344 XX(II)=XX(III)
15345 XX(III)=FH
15346129 CONTINUE
15347126 CONTINUE
15348 AM23=(AM2+AM3)**2
15349 ITH=0
15350 REDU=2.D0
15351 1 CONTINUE
15352 ITH=ITH+1
15353 IF (ITH.GT.200) REDU=-9.D0
15354 IF (ITH.GT.200) GO TO 400
15355 C=DT_RNDM(REDU)
15356* S2=AM23+C*((UMO-AM1)**2-AM23)
15357 S2=AM23+C*(UMO-AM1-AM2-AM3)*(UMO-AM1+AM2+AM3)
15358 Y=DT_RNDM(S2)
15359 Y=Y*SUPRHO
15360 RHO=DT_YLAMB(S2,UMO2,AM11)*DT_YLAMB(S2,AM22,AM33)/S2
15361 IF(Y.GT.RHO) GO TO 1
15362C***RANDOM SELECTION OF S3 AND CALCULATION OF S1
15363 S1=DT_RNDM(S2)
15364 S1=S1*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)/(2.D0*S2)-
15365 &RHO*.5D0
15366 S3=UMO2+AM11+AM22+AM33-S1-S2
15367 ECM1=(UMO2+AM11-S2)/UMOO
15368 ECM2=(UMO2+AM22-S3)/UMOO
15369 ECM3=(UMO2+AM33-S1)/UMOO
15370 PCM1=SQRT((ECM1+AM1)*(ECM1-AM1))
15371 PCM2=SQRT((ECM2+AM2)*(ECM2-AM2))
15372 PCM3=SQRT((ECM3+AM3)*(ECM3-AM3))
15373 CALL DT_DSFECF(SFE,CFE)
15374C***TH IS THE ANGLE BETWEEN PARTICLES 1 AND 2
15375C***TH1, TH2 ARE THE ANGLES BETWEEN PARTICLES 1, 2 AND THE DIRECTION OF
15376 PCM12 = PCM1 * PCM2
15377 IF ( PCM12 .LT. ANGLSQ ) GO TO 200
15378 COSTH=(ECM1*ECM2+0.5D+00*(AM11+AM22-S1))/PCM12
15379 GO TO 300
15380 200 CONTINUE
15381 UW=DT_RNDM(S1)
15382 COSTH=(UW-0.5D+00)*2.D+00
15383 300 CONTINUE
15384* IF(ABS(COSTH).GT.0.9999999999999999D0)
15385* &COSTH=SIGN(0.9999999999999999D0,COSTH)
15386 IF(ABS(COSTH).GT.ONEONE)
15387 &COSTH=SIGN(ONEONE,COSTH)
15388 IF (REDU.LT.1.D+00) RETURN
15389 COSTH2=(PCM3*PCM3+PCM2*PCM2-PCM1*PCM1)/(2.D+00*PCM2*PCM3)
15390* IF(ABS(COSTH2).GT.0.9999999999999999D0)
15391* &COSTH2=SIGN(0.9999999999999999D0,COSTH2)
15392 IF(ABS(COSTH2).GT.ONEONE)
15393 &COSTH2=SIGN(ONEONE,COSTH2)
15394 SINTH2=SQRT((ONEONE-COSTH2)*(ONEONE+COSTH2))
15395 SINTH =SQRT((ONEONE-COSTH)*(ONEONE+COSTH))
15396 SINTH1=COSTH2*SINTH-COSTH*SINTH2
15397 COSTH1=COSTH*COSTH2+SINTH2*SINTH
15398C***RANDOM SELECTION OF THE SPHERICAL COORDINATES OF THE DIRECTION OF PA
15399C***CFE, SFE ARE COS AND SIN OF THE ROTATION ANGLE OF THE SYSTEM 1, 2 AR
15400C***THE DIRECTION OF PARTICLE 3
15401C***CALCULATION OF THE SPHERICAL COORDINATES OF PARTICLES 1, 2
15402 CX11=-COSTH1
15403 CY11=SINTH1*CFE
15404 CZ11=SINTH1*SFE
15405 CX22=-COSTH2
15406 CY22=-SINTH2*CFE
15407 CZ22=-SINTH2*SFE
15408 CALL DT_DSFECF(SIF3,COF3)
15409 COD3=TWOTWO*DT_RNDM(CX11)-ONEONE
15410 SID3=SQRT((1.D+00-COD3)*(1.D+00+COD3))
15411 2 FORMAT(5F20.15)
15412 COD1=CX11*COD3+CZ11*SID3
15413 CHLP=(ONEONE-COD1)*(ONEONE+COD1)
15414 IF(CHLP.LT.1.D-14)WRITE(LOUT,2)COD1,COF3,SID3,
15415 &CX11,CZ11
15416 SID1=SQRT(CHLP)
15417 COF1=(CX11*SID3*COF3-CY11*SIF3-CZ11*COD3*COF3)/SID1
15418 SIF1=(CX11*SID3*SIF3+CY11*COF3-CZ11*COD3*SIF3)/SID1
15419 COD2=CX22*COD3+CZ22*SID3
15420 SID2=SQRT((ONEONE-COD2)*(ONEONE+COD2))
15421 COF2=(CX22*SID3*COF3-CY22*SIF3-CZ22*COD3*COF3)/SID2
15422 SIF2=(CX22*SID3*SIF3+CY22*COF3-CZ22*COD3*SIF3)/SID2
15423 400 CONTINUE
15424* === Energy conservation check: === *
15425 EOCHCK = UMO - ECM1 - ECM2 - ECM3
15426* SID1 = SQRT ( ( ONEONE - COD1 ) * ( ONEONE + COD1 ) )
15427* SID2 = SQRT ( ( ONEONE - COD2 ) * ( ONEONE + COD2 ) )
15428* SID3 = SQRT ( ( ONEONE - COD3 ) * ( ONEONE + COD3 ) )
15429 PZCHCK = PCM1 * COD1 + PCM2 * COD2 + PCM3 * COD3
15430 PXCHCK = PCM1 * COF1 * SID1 + PCM2 * COF2 * SID2
15431 & + PCM3 * COF3 * SID3
15432 PYCHCK = PCM1 * SIF1 * SID1 + PCM2 * SIF2 * SID2
15433 & + PCM3 * SIF3 * SID3
15434 EOCMPR = 1.D-12 * UMO
15435 IF ( ABS (EOCHCK) + ABS (PXCHCK) + ABS (PYCHCK) + ABS (PZCHCK)
15436 & .GT. EOCMPR ) THEN
15437**sr 5.5.95 output-unit changed
15438 IF (IOULEV(1).GT.0) THEN
15439 WRITE(LOUT,*)
15440 & ' *** Threpd: energy/momentum conservation failure! ***',
15441 & EOCHCK,PXCHCK,PYCHCK,PZCHCK
15442 WRITE(LOUT,*)' *** SID1,SID2,SID3',SID1,SID2,SID3
15443 ENDIF
15444**
15445 END IF
15446 RETURN
15447 END
15448
15449*$ CREATE DT_DBKLAS.FOR
15450*COPY DT_DBKLAS
15451*
15452*===dbklas=============================================================*
15453*
15454 SUBROUTINE DT_DBKLAS(I,J,K,I8,I10)
15455
15456 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15457 SAVE
15458 PARAMETER ( LINP = 10 ,
15459 & LOUT = 6 ,
15460 & LDAT = 9 )
15461
15462* quark-content to particle index conversion (DTUNUC 1.x)
15463 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
15464 & IA08(6,21),IA10(6,21)
15465
15466 IF (I) 20,20,10
15467* baryons
15468 10 CONTINUE
15469 CALL DT_INDEXD(J,K,IND)
15470 I8 = IB08(I,IND)
15471 I10 = IB10(I,IND)
15472 IF (I8.LE.0) I8 = I10
15473 RETURN
15474* antibaryons
15475 20 CONTINUE
15476 II = IABS(I)
15477 JJ = IABS(J)
15478 KK = IABS(K)
15479 CALL DT_INDEXD(JJ,KK,IND)
15480 I8 = IA08(II,IND)
15481 I10 = IA10(II,IND)
15482 IF (I8.LE.0) I8 = I10
15483
15484 RETURN
15485 END
15486
15487*$ CREATE DT_INDEXD.FOR
15488*COPY DT_INDEXD
15489*
15490*===indexd=============================================================*
15491*
15492 SUBROUTINE DT_INDEXD(KA,KB,IND)
15493
15494 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15495 SAVE
15496 PARAMETER ( LINP = 10 ,
15497 & LOUT = 6 ,
15498 & LDAT = 9 )
15499
15500 KP = KA*KB
15501 KS = KA+KB
15502 IF (KP.EQ.1) IND=1
15503 IF (KP.EQ.2) IND=2
15504 IF (KP.EQ.3) IND=3
15505 IF ((KP.EQ.4).AND.(KS.EQ.5)) IND=4
15506 IF (KP.EQ.5) IND=5
15507 IF ((KP.EQ.6).AND.(KS.EQ.7)) IND=6
15508 IF ((KP.EQ.4).AND.(KS.EQ.4)) IND=7
15509 IF ((KP.EQ.6).AND.(KS.EQ.5)) IND=8
15510 IF (KP.EQ.8) IND=9
15511 IF (KP.EQ.10) IND=10
15512 IF ((KP.EQ.12).AND.(KS.EQ.8)) IND=11
15513 IF (KP.EQ.9) IND=12
15514 IF ((KP.EQ.12).AND.(KS.EQ.7)) IND=13
15515 IF (KP.EQ.15) IND=14
15516 IF (KP.EQ.18) IND=15
15517 IF (KP.EQ.16) IND=16
15518 IF (KP.EQ.20) IND=17
15519 IF (KP.EQ.24) IND=18
15520 IF (KP.EQ.25) IND=19
15521 IF (KP.EQ.30) IND=20
15522 IF (KP.EQ.36) IND=21
15523
15524 RETURN
15525 END
15526
15527*$ CREATE DT_DCHANT.FOR
15528*COPY DT_DCHANT
15529*
15530*===dchant=============================================================*
15531*
15532 SUBROUTINE DT_DCHANT
15533
15534 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15535 SAVE
15536 PARAMETER ( LINP = 10 ,
15537 & LOUT = 6 ,
15538 & LDAT = 9 )
15539 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15540
15541* HADRIN: decay channel information
15542 PARAMETER (IDMAX9=602)
15543 CHARACTER*8 ZKNAME
15544 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
15545* particle properties (BAMJET index convention)
15546 CHARACTER*8 ANAME
15547 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
15548 & IICH(210),IIBAR(210),K1(210),K2(210)
15549
15550 DIMENSION HWT(IDMAX9)
15551
15552* change of weights wt from absolut values into the sum of wt of a dec.
15553 DO 10 J=1,IDMAX9
15554 HWT(J) = ZERO
15555 10 CONTINUE
15556C DO 999 KKK=1,210
15557C WRITE(LOUT,'(A8,F5.2,2E10.3,2I4,2I10)')
15558C & ANAME(KKK),AAM(KKK),GA(KKK),TAU(KKK),IICH(KKK),IIBAR(KKK),
15559C & K1(KKK),K2(KKK)
15560C 999 CONTINUE
15561C STOP
15562 DO 30 I=1,210
15563 IK1 = K1(I)
15564 IK2 = K2(I)
15565 HV = ZERO
15566 DO 20 J=IK1,IK2
15567 HV = HV+WT(J)
15568 HWT(J) = HV
15569**sr 13.1.95
15570 IF (HWT(J).GT.1.0001) WRITE(LOUT,1000) HWT(J),J,I,IK1
15571 1000 FORMAT(2X,15H ERROR IN HWT =,1F10.5,8H J,I,K1=,3I5)
15572 20 CONTINUE
15573 30 CONTINUE
15574 DO 40 J=1,IDMAX9
15575 WT(J) = HWT(J)
15576 40 CONTINUE
15577
15578 RETURN
15579 END
15580
15581*$ CREATE DT_DDATAR.FOR
15582*COPY DT_DDATAR
15583*
15584*===ddatar=============================================================*
15585*
15586 SUBROUTINE DT_DDATAR
15587
15588 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15589 SAVE
15590 PARAMETER ( LINP = 10 ,
15591 & LOUT = 6 ,
15592 & LDAT = 9 )
15593 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15594
15595* quark-content to particle index conversion (DTUNUC 1.x)
15596 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
15597 & IA08(6,21),IA10(6,21)
15598
15599 DIMENSION IV(36),IP(36),IB(126),IBB(126),IA(126),IAA(126)
15600
15601 DATA IV/ 33, 34, 38,123, 0, 0, 32, 33, 39,124,
15602 & 0, 0, 36, 37, 96,127, 0, 0,126,125,
15603 & 128,129,14*0/
15604 DATA IP/ 23, 14, 16,116, 0, 0, 13, 23, 25,117,
15605 & 0, 0, 15, 24, 31,120, 0, 0,119,118,
15606 & 121,122,14*0/
15607 DATA IB/ 0, 1, 21,140, 0, 0, 8, 22,137, 0,
15608 & 0, 97,138, 0, 0,146, 0, 0, 0, 0,
15609 & 0, 1, 8, 22,137, 0, 0, 0, 20,142,
15610 & 0, 0, 98,139, 0, 0,147, 0, 0, 0,
15611 & 0, 0, 21, 22, 97,138, 0, 0, 20, 98,
15612 & 139, 0, 0, 0,145, 0, 0,148, 0, 0,
15613 & 0, 0, 0,140,137,138,146, 0, 0,142,
15614 & 139,147, 0, 0,145,148, 50*0/
15615 DATA IBB/53, 54,104,161, 0, 0, 55,105,162, 0,
15616 & 0,107,164, 0, 0,167, 0, 0, 0, 0,
15617 & 0, 54, 55,105,162, 0, 0, 56,106,163,
15618 & 0, 0,108,165, 0, 0,168, 0, 0, 0,
15619 & 0, 0,104,105,107,164, 0, 0,106,108,
15620 & 165, 0, 0,109,166, 0, 0,169, 0, 0,
15621 & 0, 0, 0,161,162,164,167, 0, 0,163,
15622 & 165,168, 0, 0,166,169, 0, 0,170,47*0/
15623 DATA IA/ 0, 2, 99,152, 0, 0, 9,100,149, 0,
15624 & 0,102,150, 0, 0,158, 0, 0, 0, 0,
15625 & 0, 2, 9,100,149, 0, 0, 0,101,154,
15626 & 0, 0,103,151, 0, 0,159, 0, 0, 0,
15627 & 0, 0, 99,100,102,150, 0, 0,101,103,
15628 & 151, 0, 0, 0,157, 0, 0,160, 0, 0,
15629 & 0, 0, 0,152,149,150,158, 0, 0,154,
15630 & 151,159, 0, 0,157,160, 50*0/
15631 DATA IAA/67, 68,110,171, 0, 0, 69,111,172, 0,
15632 & 0,113,174, 0, 0,177, 0, 0, 0, 0,
15633 & 0, 68, 69,111,172, 0, 0, 70,112,173,
15634 & 0, 0,114,175, 0, 0,178, 0, 0, 0,
15635 & 0, 0,110,111,113,174, 0, 0,112,114,
15636 & 175, 0, 0,115,176, 0, 0,179, 0, 0,
15637 & 0, 0, 0,171,172,174,177, 0, 0,173,
15638 & 175,178, 0, 0,176,179, 0, 0,180,47*0/
15639
15640 L=0
15641 DO 2 I=1,6
15642 DO 1 J=1,6
15643 L = L+1
15644 IMPS(I,J) = IP(L)
15645 IMVE(I,J) = IV(L)
15646 1 CONTINUE
15647 2 CONTINUE
15648 L=0
15649 DO 4 I=1,6
15650 DO 3 J=1,21
15651 L = L+1
15652 IB08(I,J) = IB(L)
15653 IB10(I,J) = IBB(L)
15654 IA08(I,J) = IA(L)
15655 IA10(I,J) = IAA(L)
15656 3 CONTINUE
15657 4 CONTINUE
15658C A1 = 0.88D0
15659C B1 = 3.0D0
15660C B2 = 3.0D0
15661C B3 = 8.0D0
15662C LT = 0
15663C LB = 0
15664C BET = 12.0D0
15665C AS = 0.25D0
15666C B8 = 0.33D0
15667C AME = 0.95D0
15668C DIQ = 0.375D0
15669C ISU = 4
15670
15671 RETURN
15672 END
15673
15674*$ CREATE DT_INITJS.FOR
15675*COPY DT_INITJS
15676*
15677*===initjs=============================================================*
15678*
15679 SUBROUTINE DT_INITJS(MODE)
15680
15681************************************************************************
15682* Initialize JETSET paramters. *
15683* MODE = 0 default settings *
15684* = 1 PHOJET settings *
15685* = 2 DTUNUC settings *
15686* This version dated 16.02.96 is written by S. Roesler *
15687* *
15688* Last change 27.12.2006 by S. Roesler. *
15689************************************************************************
15690
15691 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15692 SAVE
15693 PARAMETER ( LINP = 10 ,
15694 & LOUT = 6 ,
15695 & LDAT = 9 )
15696 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15697
15698 LOGICAL LFIRST,LFIRDT,LFIRPH
15699
15700 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15701 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15702 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
15703* flags for particle decays
15704 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
15705 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
15706 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
15707* flags for input different options
15708 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15709 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15710 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15711
15712 INTEGER PYCOMP
15713
15714 DIMENSION IDXSTA(40)
15715 DATA IDXSTA
15716* K0s pi0 lam alam sig+ asig+ sig- asig- tet0 atet0
15717 & / 310, 111, 3122,-3122, 3222,-3222, 3112,-3112, 3322,-3322,
15718* tet- atet- om- aom- D+ D- D0 aD0 Ds+ aDs+
15719 & 3312,-3312, 3334,-3334, 411, -411, 421, -421, 431, -431,
15720* etac lamc+alamc+sigc++ sigc+ sigc0asigc++asigc+asigc0 Ksic+
15721 & 441, 4122,-4122, 4222, 4212, 4112,-4222,-4212,-4112, 4232,
15722* Ksic0 aKsic+aKsic0 sig0 asig0
15723 & 4132,-4232,-4132, 3212,-3212, 5*0/
15724
15725 DATA LFIRST,LFIRDT,LFIRPH /.TRUE.,.TRUE.,.TRUE./
15726
15727 IF (LFIRST) THEN
15728* save default settings
15729 PDEF1 = PARJ(1)
15730 PDEF2 = PARJ(2)
15731 PDEF3 = PARJ(3)
15732 PDEF5 = PARJ(5)
15733 PDEF6 = PARJ(6)
15734 PDEF7 = PARJ(7)
15735 PDEF18 = PARJ(18)
15736 PDEF19 = PARJ(19)
15737 PDEF21 = PARJ(21)
15738 PDEF42 = PARJ(42)
15739 MDEF12 = MSTJ(12)
15740* LUJETS / PYJETS array-dimensions
15741 MSTU(4) = 4000
15742* increase maximum number of JETSET-error prints
15743 MSTU(22) = 50000
15744* prevent particles decaying
15745 DO 1 I=1,35
15746 IF (I.LT.34) THEN
15747 KC = PYCOMP(IDXSTA(I))
15748 IF (KC.GT.0) THEN
15749 IF (I.EQ.2) THEN
15750* pi0 decay
15751C MDCY(KC,1) = 1
15752 MDCY(KC,1) = 0
15753**cr mode
15754C ELSEIF ((I.EQ.4).OR.(I.EQ. 6).OR.
15755C & (I.EQ.8).OR.(I.EQ.10)) THEN
15756C ELSEIF (I.EQ.4) THEN
15757C MDCY(KC,1) = 1
15758**
15759 ELSE
15760 MDCY(KC,1) = 0
15761 ENDIF
15762 ENDIF
15763 ELSEIF (((I.EQ.34).OR.(I.EQ.35)).AND.(ISIG0.EQ.0)) THEN
15764 KC = PYCOMP(IDXSTA(I))
15765 IF (KC.GT.0) THEN
15766 MDCY(KC,1) = 0
15767 ENDIF
15768 ENDIF
15769 1 CONTINUE
15770*
15771*
15772* popcorn:
15773 IF (PDB.LE.ZERO) THEN
15774* no popcorn-mechanism
15775 MSTJ(12) = 1
15776 ELSE
15777 MSTJ(12) = 3
15778 PARJ(5) = PDB
15779 ENDIF
15780* set JETSET-parameter requested by input cards
15781 IF (NMSTU.GT.0) THEN
15782 DO 2 I=1,NMSTU
15783 MSTU(IMSTU(I)) = MSTUX(I)
15784 2 CONTINUE
15785 ENDIF
15786 IF (NMSTJ.GT.0) THEN
15787 DO 3 I=1,NMSTJ
15788 MSTJ(IMSTJ(I)) = MSTJX(I)
15789 3 CONTINUE
15790 ENDIF
15791 IF (NPARU.GT.0) THEN
15792 DO 4 I=1,NPARU
15793 PARU(IPARU(I)) = PARUX(I)
15794 4 CONTINUE
15795 ENDIF
15796 LFIRST = .FALSE.
15797 ENDIF
15798*
15799* PARJ(1) suppression of qq-aqaq pair prod. compared to
15800* q-aq pair prod. (default: 0.1)
15801* PARJ(2) strangeness suppression (default: 0.3)
15802* PARJ(3) extra suppression of strange diquarks (default: 0.4)
15803* PARJ(6) extra suppression of sas-pair shared by B and
15804* aB in BMaB (default: 0.5)
15805* PARJ(7) extra suppression of strange meson M in BMaB
15806* configuration (default: 0.5)
15807* PARJ(18) spin 3/2 baryon suppression (default: 1.0)
15808* PARJ(21) width sigma in Gaussian p_x, p_y transverse
15809* momentum distrib. for prim. hadrons (default: 0.35)
15810* PARJ(42) b-parameter for symmetric Lund-fragmentation
15811* function (default: 0.9 GeV^-2)
15812*
15813* PHOJET settings
15814 IF (MODE.EQ.1) THEN
15815* JETSET default
15816C PARJ(1) = PDEF1
15817C PARJ(2) = PDEF2
15818C PARJ(3) = PDEF3
15819C PARJ(6) = PDEF6
15820C PARJ(7) = PDEF7
15821C PARJ(18) = PDEF18
15822C PARJ(21) = PDEF21
15823C PARJ(42) = PDEF42
15824**sr 18.11.98 parameter tuning
15825C PARJ(1) = 0.092D0
15826C PARJ(2) = 0.25D0
15827C PARJ(3) = 0.45D0
15828C PARJ(19) = 0.3D0
15829C PARJ(21) = 0.45D0
15830C PARJ(42) = 1.0D0
15831**sr 28.04.99 parameter tuning (May 99 minor modifications)
15832 PARJ(1) = 0.085D0
15833 PARJ(2) = 0.26D0
15834 PARJ(3) = 0.8D0
15835 PARJ(11) = 0.38D0
15836 PARJ(18) = 0.3D0
15837 PARJ(19) = 0.4D0
15838 PARJ(21) = 0.36D0
15839 PARJ(41) = 0.3D0
15840 PARJ(42) = 0.86D0
15841 IF (NPARJ.GT.0) THEN
15842 DO 10 I=1,NPARJ
15843 IF (IPARJ(I).GT.0) PARJ(IPARJ(I)) = PARJX(I)
15844 10 CONTINUE
15845 ENDIF
15846 IF (LFIRPH) THEN
15847 WRITE(LOUT,'(1X,A)')
15848 & 'DT_INITJS: JETSET-parameter for PHOJET'
15849 CALL DT_JSPARA(0)
15850 LFIRPH = .FALSE.
15851 ENDIF
15852* DTUNUC settings
15853 ELSEIF (MODE.EQ.2) THEN
15854 IF (IFRAG(2).EQ.1) THEN
15855**sr parameters before 9.3.96
15856C PARJ(2) = 0.27D0
15857C PARJ(3) = 0.6D0
15858C PARJ(6) = 0.75D0
15859C PARJ(7) = 0.75D0
15860C PARJ(21) = 0.55D0
15861C PARJ(42) = 1.3D0
15862**sr 18.11.98 parameter tuning
15863C PARJ(1) = 0.05D0
15864C PARJ(2) = 0.27D0
15865C PARJ(3) = 0.4D0
15866C PARJ(19) = 0.2D0
15867C PARJ(21) = 0.45D0
15868C PARJ(42) = 1.0D0
15869**sr 28.04.99 parameter tuning
15870 PARJ(1) = 0.11D0
15871 PARJ(2) = 0.36D0
15872 PARJ(3) = 0.8D0
15873 PARJ(19) = 0.2D0
15874 PARJ(21) = 0.3D0
15875 PARJ(41) = 0.3D0
15876 PARJ(42) = 0.58D0
15877 IF (NPARJ.GT.0) THEN
15878 DO 20 I=1,NPARJ
15879 IF (IPARJ(I).LT.0) THEN
15880 IDX = ABS(IPARJ(I))
15881 PARJ(IDX) = PARJX(I)
15882 ENDIF
15883 20 CONTINUE
15884 ENDIF
15885 IF (LFIRDT) THEN
15886 WRITE(LOUT,'(1X,A)')
15887 & 'DT_INITJS: JETSET-parameter for DTUNUC'
15888 CALL DT_JSPARA(0)
15889 LFIRDT = .FALSE.
15890 ENDIF
15891 ELSEIF (IFRAG(2).EQ.2) THEN
15892 PARJ(1) = 0.11D0
15893 PARJ(2) = 0.27D0
15894 PARJ(3) = 0.3D0
15895 PARJ(6) = 0.35D0
15896 PARJ(7) = 0.45D0
15897 PARJ(18) = 0.66D0
15898C PARJ(21) = 0.55D0
15899C PARJ(42) = 1.0D0
15900 PARJ(21) = 0.60D0
15901 PARJ(42) = 1.3D0
15902 ELSE
15903 PARJ(1) = PDEF1
15904 PARJ(2) = PDEF2
15905 PARJ(3) = PDEF3
15906 PARJ(6) = PDEF6
15907 PARJ(7) = PDEF7
15908 PARJ(18) = PDEF18
15909 PARJ(21) = PDEF21
15910 PARJ(42) = PDEF42
15911 ENDIF
15912 ELSE
15913 PARJ(1) = PDEF1
15914 PARJ(2) = PDEF2
15915 PARJ(3) = PDEF3
15916 PARJ(5) = PDEF5
15917 PARJ(6) = PDEF6
15918 PARJ(7) = PDEF7
15919 PARJ(18) = PDEF18
15920 PARJ(19) = PDEF19
15921 PARJ(21) = PDEF21
15922 PARJ(42) = PDEF42
15923 MSTJ(12) = MDEF12
15924 ENDIF
15925
15926 RETURN
15927 END
15928
15929*$ CREATE DT_JSPARA.FOR
15930*COPY DT_JSPARA
15931*
15932*===jspara=============================================================*
15933*
15934 SUBROUTINE DT_JSPARA(MODE)
15935
15936 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15937 SAVE
15938 PARAMETER ( LINP = 10 ,
15939 & LOUT = 6 ,
15940 & LDAT = 9 )
15941 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1,
15942 & ONE=1.0D0,ZERO=0.0D0)
15943
15944 LOGICAL LFIRST
15945
15946 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15947
15948 DIMENSION ISTU(200),QARU(200),ISTJ(200),QARJ(200)
15949
15950 DATA LFIRST /.TRUE./
15951
15952* save the default JETSET-parameter on the first call
15953 IF (LFIRST) THEN
15954 DO 1 I=1,200
15955 ISTU(I) = MSTU(I)
15956 QARU(I) = PARU(I)
15957 ISTJ(I) = MSTJ(I)
15958 QARJ(I) = PARJ(I)
15959 1 CONTINUE
15960 LFIRST = .FALSE.
15961 ENDIF
15962
15963 WRITE(LOUT,1000)
15964 1000 FORMAT(1X,'DT_JSPARA: new value (default value)')
15965
15966* compare the default JETSET-parameter with the present values
15967 DO 2 I=1,200
15968 IF ((MSTU(I).NE.ISTU(I)).AND.(I.NE.31)) THEN
15969 WRITE(LOUT,1002) 'MSTU(',I,MSTU(I),ISTU(I)
15970C ISTU(I) = MSTU(I)
15971 ENDIF
15972 DIFF = ABS(PARU(I)-QARU(I))
15973 IF ((DIFF.GE.1.0D-5).AND.(I.NE.21)) THEN
15974 WRITE(LOUT,1001) 'PARU(',I,PARU(I),QARU(I)
15975C QARU(I) = PARU(I)
15976 ENDIF
15977 IF (MSTJ(I).NE.ISTJ(I)) THEN
15978 WRITE(LOUT,1002) 'MSTJ(',I,MSTJ(I),ISTJ(I)
15979C ISTJ(I) = MSTJ(I)
15980 ENDIF
15981 DIFF = ABS(PARJ(I)-QARJ(I))
15982 IF (DIFF.GE.1.0D-5) THEN
15983 WRITE(LOUT,1001) 'PARJ(',I,PARJ(I),QARJ(I)
15984C QARJ(I) = PARJ(I)
15985 ENDIF
15986 2 CONTINUE
15987 1001 FORMAT(12X,A5,I3,'): ',F6.3,' (',F6.3,')')
15988 1002 FORMAT(12X,A5,I3,'): ',I6,' (',I6,')')
15989
15990 RETURN
15991 END
15992
15993*$ CREATE DT_FOZOCA.FOR
15994*COPY DT_FOZOCA
15995*
15996*===fozoca=============================================================*
15997*
15998 SUBROUTINE DT_FOZOCA(LFZC,IREJ)
15999
16000************************************************************************
16001* This subroutine treats the complete FOrmation ZOne supressed intra- *
16002* nuclear CAscade. *
16003* LFZC = .true. cascade has been treated *
16004* = .false. cascade skipped *
16005* This is a completely revised version of the original FOZOKL. *
16006* This version dated 18.11.95 is written by S. Roesler *
16007************************************************************************
16008
16009 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16010 SAVE
16011 PARAMETER ( LINP = 10 ,
16012 & LOUT = 6 ,
16013 & LDAT = 9 )
16014 PARAMETER (DLARGE=1.0D10,OHALF=0.5D0,ZERO=0.0D0)
16015 PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16016
16017 LOGICAL LSTART,LCAS,LFZC
16018
16019* event history
16020 PARAMETER (NMXHKK=200000)
16021 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16022 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16023 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16024* extended event history
16025 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16026 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16027 & IHIST(2,NMXHKK)
16028* rejection counter
16029 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
16030 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
16031 & IREXCI(3),IRDIFF(2),IRINC
16032* properties of interacting particles
16033 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
16034* Glauber formalism: collision properties
16035 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
16036 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
16037* flags for input different options
16038 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16039 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16040 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16041* final state after intranuclear cascade step
16042 COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16043* parameter for intranuclear cascade
16044 LOGICAL LPAULI
16045 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16046
16047 DIMENSION NCWOUN(2)
16048
16049 DATA LSTART /.TRUE./
16050
16051 LFZC = .TRUE.
16052 IREJ = 0
16053
16054* skip cascade if hadron-hadron interaction or if supressed by user
16055 IF (((IP.EQ.1).AND.(IT.EQ.1)).OR.(KTAUGE.LT.1)) GOTO 9999
16056* skip cascade if not all possible chains systems are hadronized
16057 DO 1 I=1,8
16058 IF (.NOT.LHADRO(I)) GOTO 9999
16059 1 CONTINUE
16060
16061 IF (LSTART) THEN
16062 WRITE(LOUT,1000) KTAUGE,TAUFOR,INCMOD
16063 1000 FORMAT(/,1X,'FOZOCA: intranuclear cascade treated for a ',
16064 & 'maximum of',I4,' generations',/,10X,'formation time ',
16065 & 'parameter:',F5.1,' fm/c',9X,'modus:',I2)
16066 IF (ITAUVE.EQ.1) WRITE(LOUT,1001)
16067 IF (ITAUVE.EQ.2) WRITE(LOUT,1002)
16068 1001 FORMAT(10X,'p_t dependent formation zone',/)
16069 1002 FORMAT(10X,'constant formation zone',/)
16070 LSTART = .FALSE.
16071 ENDIF
16072
16073* in order to avoid wasting of cpu-time the DTEVT1-indices of nucleons
16074* which may interact with final state particles are stored in a seperate
16075* array - here all proj./target nucleon-indices (just for simplicity)
16076 NOINC = 0
16077 DO 9 I=1,NPOINT(1)-1
16078 NOINC = NOINC+1
16079 IDXINC(NOINC) = I
16080 9 CONTINUE
16081
16082* initialize Pauli-principle treatment (find wounded nucleons)
16083 NWOUND(1) = 0
16084 NWOUND(2) = 0
16085 NCWOUN(1) = 0
16086 NCWOUN(2) = 0
16087 DO 2 J=1,NPOINT(1)
16088 DO 3 I=1,2
16089 IF (ISTHKK(J).EQ.10+I) THEN
16090 NWOUND(I) = NWOUND(I)+1
16091 EWOUND(I,NWOUND(I)) = PHKK(4,J)
16092 IF (IDHKK(J).EQ.2212) NCWOUN(I) = NCWOUN(I)+1
16093 ENDIF
16094 3 CONTINUE
16095 2 CONTINUE
16096
16097* modify nuclear potential for wounded nucleons
16098 IPRCL = IP -NWOUND(1)
16099 IPZRCL = IPZ-NCWOUN(1)
16100 ITRCL = IT -NWOUND(2)
16101 ITZRCL = ITZ-NCWOUN(2)
16102 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
16103
16104 NSTART = NPOINT(4)
16105 NEND = NHKK
16106
16107 7 CONTINUE
16108 DO 8 I=NSTART,NEND
16109
16110 IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDCH(I).LT.KTAUGE)) THEN
16111* select nucleus the cascade starts first (proj. - 1, target - -1)
16112 NCAS = 1
16113* projectile/target with probab. 1/2
16114 IF ((INCMOD.EQ.1).OR.(IDCH(I).GT.0)) THEN
16115 IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16116* in the nucleus with highest mass
16117 ELSEIF (INCMOD.EQ.2) THEN
16118 IF (IP.GT.IT) THEN
16119 NCAS = -NCAS
16120 ELSEIF (IP.EQ.IT) THEN
16121 IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16122 ENDIF
16123* the nucleus the cascade starts first is requested to be the one
16124* moving in the direction of the secondary
16125 ELSEIF (INCMOD.EQ.3) THEN
16126 NCAS = INT(SIGN(1.0D0,PHKK(3,I)))
16127 ENDIF
16128* check that the selected "nucleus" is not a hadron
16129 IF (((NCAS.EQ. 1).AND.(IP.LE.1)).OR.
16130 & ((NCAS.EQ.-1).AND.(IT.LE.1))) NCAS = -NCAS
16131
16132* treat intranuclear cascade in the nucleus selected first
16133 LCAS = .FALSE.
16134 CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
16135 IF (IREJ1.NE.0) GOTO 9998
16136* treat intranuclear cascade in the other nucleus if this isn't a had.
16137 NCAS = -NCAS
16138 IF (((NCAS.EQ. 1).AND.(IP.GT.1)).OR.
16139 & ((NCAS.EQ.-1).AND.(IT.GT.1))) THEN
16140 IF (LCAS) CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
16141 IF (IREJ1.NE.0) GOTO 9998
16142 ENDIF
16143
16144 ENDIF
16145
16146 8 CONTINUE
16147 NSTART = NEND+1
16148 NEND = NHKK
16149 IF (NSTART.LE.NEND) GOTO 7
16150
16151 RETURN
16152
16153 9998 CONTINUE
16154* reject this event
16155 IRINC = IRINC+1
16156 IREJ = 1
16157
16158 9999 CONTINUE
16159* intranucl. cascade not treated because of interaction properties or
16160* it is supressed by user or it was rejected or...
16161 LFZC = .FALSE.
16162* reset flag characterizing direction of motion in n-n-cms
16163**sr14-11-95
16164C DO 9990 I=NPOINT(5),NHKK
16165C IF (ISTHKK(I).EQ.-1) ISTHKK(I)=1
16166C9990 CONTINUE
16167
16168 RETURN
16169 END
16170
16171*$ CREATE DT_INUCAS.FOR
16172*COPY DT_INUCAS
16173*
16174*===inucas=============================================================*
16175*
16176 SUBROUTINE DT_INUCAS(IT,IP,IDXCAS,LCAS,NCAS,IREJ)
16177
16178************************************************************************
16179* Formation zone supressed IntraNUclear CAScade for one final state *
16180* particle. *
16181* IT, IP mass numbers of target, projectile nuclei *
16182* IDXCAS index of final state particle in DTEVT1 *
16183* NCAS = 1 intranuclear cascade in projectile *
16184* = -1 intranuclear cascade in target *
16185* This version dated 18.11.95 is written by S. Roesler *
16186************************************************************************
16187
16188 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16189 SAVE
16190 PARAMETER ( LINP = 10 ,
16191 & LOUT = 6 ,
16192 & LDAT = 9 )
16193
16194 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
16195 & OHALF=0.5D0,ONE=1.0D0)
16196 PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16197 PARAMETER (TWOPI=6.283185307179586454D+00)
16198 PARAMETER (PLOWH=0.01D0,PHIH=9.0D0)
16199
16200 LOGICAL LABSOR,LCAS
16201
16202* event history
16203 PARAMETER (NMXHKK=200000)
16204 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16205 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16206 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16207* extended event history
16208 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16209 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16210 & IHIST(2,NMXHKK)
16211* final state after inc step
16212 PARAMETER (MAXFSP=10)
16213 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
16214* flags for input different options
16215 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16216 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16217 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16218* particle properties (BAMJET index convention)
16219 CHARACTER*8 ANAME
16220 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
16221 & IICH(210),IIBAR(210),K1(210),K2(210)
16222* Glauber formalism: collision properties
16223 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
16224 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
16225* nuclear potential
16226 LOGICAL LFERMI
16227 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
16228 & EBINDP(2),EBINDN(2),EPOT(2,210),
16229 & ETACOU(2),ICOUL,LFERMI
16230* parameter for intranuclear cascade
16231 LOGICAL LPAULI
16232 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16233* final state after intranuclear cascade step
16234 COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16235* nucleon-nucleon event-generator
16236 CHARACTER*8 CMODEL
16237 LOGICAL LPHOIN
16238 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
16239* statistics: residual nuclei
16240 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
16241 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
16242 & NINCST(2,4),NINCEV(2),
16243 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
16244 & NRESPB(2),NRESCH(2),NRESEV(4),
16245 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
16246 & NEVAFI(2,2)
16247
16248 DIMENSION PCAS(2,5),PTOCAS(2),COSCAS(2,3),VTXCAS(2,4),VTXCA1(2,4),
16249 & PCAS1(5),PNUC(5),BGTA(4),
16250 & BGCAS(2),GACAS(2),BECAS(2),
16251 & RNUC(2),BIMPC(2),VTXDST(3),IDXSPE(2),IDSPE(2),NWTMP(2)
16252
16253 DATA PDIF /0.545D0/
16254
16255 IREJ = 0
16256
16257* update counter
16258 IF (NINCEV(1).NE.NEVHKK) THEN
16259 NINCEV(1) = NEVHKK
16260 NINCEV(2) = NINCEV(2)+1
16261 ENDIF
16262
16263* "BAMJET-index" of this hadron
16264 IDCAS = IDBAM(IDXCAS)
16265 IF (IDT_MCHAD(IDCAS).EQ.-1) RETURN
16266
16267* skip gammas, electrons, etc..
16268 IF (AAM(IDCAS).LT.TINY2) RETURN
16269
16270* Lorentz-trsf. into projectile rest system
16271 IF (IP.GT.1) THEN
16272 CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
16273 & PHKK(4,IDXCAS),PCAS(1,1),PCAS(1,2),PCAS(1,3),
16274 & PCAS(1,4),IDCAS,-2)
16275 PTOCAS(1) = SQRT(PCAS(1,1)**2+PCAS(1,2)**2+PCAS(1,3)**2)
16276 PCAS(1,5) = (PCAS(1,4)-PTOCAS(1))*(PCAS(1,4)+PTOCAS(1))
16277 IF (PCAS(1,5).GT.ZERO) THEN
16278 PCAS(1,5) = SQRT(PCAS(1,5))
16279 ELSE
16280 PCAS(1,5) = AAM(IDCAS)
16281 ENDIF
16282 DO 20 K=1,3
16283 COSCAS(1,K) = PCAS(1,K)/MAX(PTOCAS(1),TINY10)
16284 20 CONTINUE
16285* Lorentz-parameters
16286* particle rest system --> projectile rest system
16287 BGCAS(1) = PTOCAS(1)/MAX(PCAS(1,5),TINY10)
16288 GACAS(1) = PCAS(1,4)/MAX(PCAS(1,5),TINY10)
16289 BECAS(1) = BGCAS(1)/GACAS(1)
16290 ELSE
16291 DO 21 K=1,5
16292 PCAS(1,K) = ZERO
16293 IF (K.LE.3) COSCAS(1,K) = ZERO
16294 21 CONTINUE
16295 PTOCAS(1) = ZERO
16296 BGCAS(1) = ZERO
16297 GACAS(1) = ZERO
16298 BECAS(1) = ZERO
16299 ENDIF
16300* Lorentz-trsf. into target rest system
16301 IF (IT.GT.1) THEN
16302* LEPTO: final state particles are already in target rest frame
16303C IF (MCGENE.EQ.3) THEN
16304C PCAS(2,1) = PHKK(1,IDXCAS)
16305C PCAS(2,2) = PHKK(2,IDXCAS)
16306C PCAS(2,3) = PHKK(3,IDXCAS)
16307C PCAS(2,4) = PHKK(4,IDXCAS)
16308C ELSE
16309 CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
16310 & PHKK(4,IDXCAS),PCAS(2,1),PCAS(2,2),PCAS(2,3),
16311 & PCAS(2,4),IDCAS,-3)
16312C ENDIF
16313 PTOCAS(2) = SQRT(PCAS(2,1)**2+PCAS(2,2)**2+PCAS(2,3)**2)
16314 PCAS(2,5) = (PCAS(2,4)-PTOCAS(2))*(PCAS(2,4)+PTOCAS(2))
16315 IF (PCAS(2,5).GT.ZERO) THEN
16316 PCAS(2,5) = SQRT(PCAS(2,5))
16317 ELSE
16318 PCAS(2,5) = AAM(IDCAS)
16319 ENDIF
16320 DO 22 K=1,3
16321 COSCAS(2,K) = PCAS(2,K)/MAX(PTOCAS(2),TINY10)
16322 22 CONTINUE
16323* Lorentz-parameters
16324* particle rest system --> target rest system
16325 BGCAS(2) = PTOCAS(2)/MAX(PCAS(2,5),TINY10)
16326 GACAS(2) = PCAS(2,4)/MAX(PCAS(2,5),TINY10)
16327 BECAS(2) = BGCAS(2)/GACAS(2)
16328 ELSE
16329 DO 23 K=1,5
16330 PCAS(2,K) = ZERO
16331 IF (K.LE.3) COSCAS(2,K) = ZERO
16332 23 CONTINUE
16333 PTOCAS(2) = ZERO
16334 BGCAS(2) = ZERO
16335 GACAS(2) = ZERO
16336 BECAS(2) = ZERO
16337 ENDIF
16338
16339* radii of nuclei (mm) modified by the wall-depth of the Woods-Saxon-
16340* potential (see CONUCL)
16341 RNUC(1) = (RPROJ+4.605D0*PDIF)*FM2MM
16342 RNUC(2) = (RTARG+4.605D0*PDIF)*FM2MM
16343* impact parameter (the projectile moving along z)
16344 BIMPC(1) = ZERO
16345 BIMPC(2) = BIMPAC*FM2MM
16346
16347* get position of initial hadron in projectile/target rest-syst.
16348 DO 3 K=1,4
16349 VTXCAS(1,K) = WHKK(K,IDXCAS)
16350 VTXCAS(2,K) = VHKK(K,IDXCAS)
16351 3 CONTINUE
16352
16353 ICAS = 1
16354 I2 = 2
16355 IF (NCAS.EQ.-1) THEN
16356 ICAS = 2
16357 I2 = 1
16358 ENDIF
16359
16360 IF (PTOCAS(ICAS).LT.TINY10) THEN
16361 WRITE(LOUT,1000) PTOCAS
16362 1000 FORMAT(1X,'INUCAS: warning! zero momentum of initial',
16363 & ' hadron ',/,20X,2E12.4)
16364 GOTO 9999
16365 ENDIF
16366
16367* reset spectator flags
16368 NSPE = 0
16369 IDXSPE(1) = 0
16370 IDXSPE(2) = 0
16371 IDSPE(1) = 0
16372 IDSPE(2) = 0
16373
16374* formation length (in fm)
16375C IF (LCAS) THEN
16376C DEL0 = ZERO
16377C ELSE
16378 DEL0 = TAUFOR*BGCAS(ICAS)
16379 IF (ITAUVE.EQ.1) THEN
16380 AMT = PCAS(ICAS,1)**2+PCAS(ICAS,2)**2+PCAS(ICAS,5)**2
16381 DEL0 = DEL0*PCAS(ICAS,5)**2/AMT
16382 ENDIF
16383C ENDIF
16384* sample from exp(-del/del0)
16385 DEL1 = -DEL0*LOG(MAX(DT_RNDM(DEL0),TINY10))
16386* save formation time
16387 TAUSA1 = DEL1/BGCAS(ICAS)
16388 REL1 = TAUSA1*BGCAS(I2)
16389
16390 DEL = DEL1
16391 TAUSAM = DEL/BGCAS(ICAS)
16392 REL = TAUSAM*BGCAS(I2)
16393
16394* special treatment for negative particles unable to escape
16395* nuclear potential (implemented for ap, pi-, K- only)
16396 LABSOR = .FALSE.
16397 IF ((IICH(IDCAS).EQ.-1).AND.(IDCAS.LT.20)) THEN
16398* threshold energy = nuclear potential + Coulomb potential
16399* (nuclear potential for hadron-nucleus interactions only)
16400 ETHR = AAM(IDCAS)+EPOT(ICAS,IDCAS)+ETACOU(ICAS)
16401 IF (PCAS(ICAS,4).LT.ETHR) THEN
16402 DO 4 K=1,5
16403 PCAS1(K) = PCAS(ICAS,K)
16404 4 CONTINUE
16405* "absorb" negative particle in nucleus
16406 CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,0,IREJ1)
16407 IF (IREJ1.NE.0) GOTO 9999
16408 IF (NSPE.GE.1) LABSOR = .TRUE.
16409 ENDIF
16410 ENDIF
16411
16412* if the initial particle has not been absorbed proceed with
16413* "normal" cascade
16414 IF (.NOT.LABSOR) THEN
16415
16416* calculate coordinates of hadron at the end of the formation zone
16417* transport-time and -step in the rest system where this step is
16418* treated
16419 DSTEP = DEL*FM2MM
16420 DTIME = DSTEP/BECAS(ICAS)
16421 RSTEP = REL*FM2MM
16422 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16423 RTIME = RSTEP/BECAS(I2)
16424 ELSE
16425 RTIME = ZERO
16426 ENDIF
16427* save step whithout considering the overlapping region
16428 DSTEP1 = DEL1*FM2MM
16429 DTIME1 = DSTEP1/BECAS(ICAS)
16430 RSTEP1 = REL1*FM2MM
16431 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16432 RTIME1 = RSTEP1/BECAS(I2)
16433 ELSE
16434 RTIME1 = ZERO
16435 ENDIF
16436* transport to the end of the formation zone in this system
16437 DO 5 K=1,3
16438 VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+DSTEP1*COSCAS(ICAS,K)
16439 VTXCA1(I2,K) = VTXCAS(I2,K) +RSTEP1*COSCAS(I2,K)
16440 VTXCAS(ICAS,K) = VTXCAS(ICAS,K)+DSTEP*COSCAS(ICAS,K)
16441 VTXCAS(I2,K) = VTXCAS(I2,K) +RSTEP*COSCAS(I2,K)
16442 5 CONTINUE
16443 VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME1
16444 VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME1
16445 VTXCAS(ICAS,4) = VTXCAS(ICAS,4)+DTIME
16446 VTXCAS(I2,4) = VTXCAS(I2,4) +RTIME
16447
16448 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16449 XCAS = VTXCAS(ICAS,1)
16450 YCAS = VTXCAS(ICAS,2)
16451 XNCLTA = BIMPAC*FM2MM
16452 RNCLPR = (RPROJ+RNUCLE)*FM2MM
16453 RNCLTA = (RTARG+RNUCLE)*FM2MM
16454C RNCLPR = (RPROJ+1.605D0*PDIF)*FM2MM
16455C RNCLTA = (RTARG+1.605D0*PDIF)*FM2MM
16456C RNCLPR = (RPROJ)*FM2MM
16457C RNCLTA = (RTARG)*FM2MM
16458 RCASPR = SQRT( XCAS**2 +YCAS**2)
16459 RCASTA = SQRT((XCAS-XNCLTA)**2+YCAS**2)
16460 IF ((RCASPR.LT.RNCLPR).AND.(RCASTA.LT.RNCLTA)) THEN
16461 IF (IDCH(IDXCAS).EQ.0) NOBAM(IDXCAS) = 3
16462 ENDIF
16463 ENDIF
16464
16465* check if particle is already outside of the corresp. nucleus
16466 RDIST = SQRT((VTXCAS(ICAS,1)-BIMPC(ICAS))**2+
16467 & VTXCAS(ICAS,2)**2+VTXCAS(ICAS,3)**2)
16468 IF (RDIST.GE.RNUC(ICAS)) THEN
16469* here: IDCH is the generation of the final state part. starting
16470* with zero for hadronization products
16471* flag particles of generation 0 being outside the nuclei after
16472* formation time (to be used for excitation energy calculation)
16473 IF ((IDCH(IDXCAS).EQ.0).AND.(NOBAM(IDXCAS).LT.3))
16474 & NOBAM(IDXCAS) = NOBAM(IDXCAS)+ICAS
16475 GOTO 9997
16476 ENDIF
16477 DIST = DLARGE
16478 DISTP = DLARGE
16479 DISTN = DLARGE
16480 IDXP = 0
16481 IDXN = 0
16482
16483* already here: skip particles being outside HADRIN "energy-window"
16484* to avoid wasting of time
16485 NINCHR(ICAS,1) = NINCHR(ICAS,1)+1
16486 IF ((PTOCAS(ICAS).LE.PLOWH).OR.(PTOCAS(ICAS).GE.PHIH)) THEN
16487 NINCHR(ICAS,2) = NINCHR(ICAS,2)+1
16488C WRITE(LOUT,1002) IDXCAS,IDCAS,ICAS,PTOCAS(ICAS),NEVHKK
16489C1002 FORMAT(1X,'INUCAS: warning! momentum of particle with ',
16490C & 'index ',I5,' (id: ',I3,') ',I3,/,11X,'p_tot = ',
16491C & E12.4,', above or below HADRIN-thresholds',I6)
16492 NSPE = 0
16493 GOTO 9997
16494 ENDIF
16495
16496 DO 7 IDXHKK=1,NOINC
16497 I = IDXINC(IDXHKK)
16498* scan DTEVT1 for unwounded or excited nucleons
16499 IF ((ISTHKK(I).EQ.12+ICAS).OR.(ISTHKK(I).EQ.14+ICAS)) THEN
16500 DO 8 K=1,3
16501 IF (ICAS.EQ.1) THEN
16502 VTXDST(K) = WHKK(K,I)-VTXCAS(1,K)
16503 ELSEIF (ICAS.EQ.2) THEN
16504 VTXDST(K) = VHKK(K,I)-VTXCAS(2,K)
16505 ENDIF
16506 8 CONTINUE
16507 POSNUC = VTXDST(1)*COSCAS(ICAS,1)+
16508 & VTXDST(2)*COSCAS(ICAS,2)+
16509 & VTXDST(3)*COSCAS(ICAS,3)
16510* check if nucleon is situated in forward direction
16511 IF (POSNUC.GT.ZERO) THEN
16512* distance between hadron and this nucleon
16513 DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16514 & VTXDST(3)**2)
16515* impact parameter
16516 BIMNU2 = DISTNU**2-POSNUC**2
16517 IF (BIMNU2.LT.ZERO) THEN
16518 WRITE(LOUT,1001) DISTNU,POSNUC,BIMNU2
16519 1001 FORMAT(1X,'INUCAS: warning! inconsistent impact',
16520 & ' parameter ',/,20X,3E12.4)
16521 GOTO 7
16522 ENDIF
16523 BIMNU = SQRT(BIMNU2)
16524* maximum impact parameter to have interaction
16525 IDNUC = IDT_ICIHAD(IDHKK(I))
16526 IDNUC1 = IDT_MCHAD(IDNUC)
16527 IDCAS1 = IDT_MCHAD(IDCAS)
16528 DO 19 K=1,5
16529 PCAS1(K) = PCAS(ICAS,K)
16530 PNUC(K) = PHKK(K,I)
16531 19 CONTINUE
16532* Lorentz-parameter for trafo into rest-system of target
16533 DO 18 K=1,4
16534 BGTA(K) = PNUC(K)/MAX(PNUC(5),TINY10)
16535 18 CONTINUE
16536* transformation of projectile into rest-system of target
16537 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
16538 & PCAS1(1),PCAS1(2),PCAS1(3),PCAS1(4),
16539 & PPTOT,PX,PY,PZ,PE)
16540**
16541C CALL DT_SIHNIN(IDCAS1,IDNUC1,PPTOT,SIGIN)
16542C CALL DT_SIHNEL(IDCAS1,IDNUC1,PPTOT,SIGEL)
16543 DUMZER = ZERO
16544 CALL DT_XSHN(IDCAS1,IDNUC1,PPTOT,DUMZER,SIGTOT,SIGEL)
16545 CALL DT_SIHNAB(IDCAS1,IDNUC1,PPTOT,SIGAB)
16546 IF (((IDCAS1.EQ.13).OR.(IDCAS1.EQ.14)).AND.
16547 & (PPTOT.LT.0.15D0)) SIGEL = SIGEL/2.0D0
16548 SIGIN = SIGTOT-SIGEL-SIGAB
16549C SIGTOT = SIGIN+SIGEL+SIGAB
16550**
16551 BIMMAX = SQRT(SIGTOT/(5.0D0*TWOPI))*FM2MM
16552* check if interaction is possible
16553 IF (BIMNU.LE.BIMMAX) THEN
16554* get nucleon with smallest distance and kind of interaction
16555* (elastic/inelastic)
16556 IF (DISTNU.LT.DIST) THEN
16557 DIST = DISTNU
16558 BINT = BIMNU
16559 IF (IDNUC.NE.IDSPE(1)) THEN
16560 IDSPE(2) = IDSPE(1)
16561 IDXSPE(2) = IDXSPE(1)
16562 IDSPE(1) = IDNUC
16563 ENDIF
16564 IDXSPE(1) = I
16565 NSPE = 1
16566**sr
16567 SELA = SIGEL
16568 SABS = SIGAB
16569 STOT = SIGTOT
16570C IF ((IDCAS.EQ.2).OR.(IDCAS.EQ.9)) THEN
16571C SELA = SIGEL
16572C STOT = SIGIN+SIGEL
16573C ELSE
16574C SELA = SIGEL+0.75D0*SIGIN
16575C STOT = 0.25D0*SIGIN+SELA
16576C ENDIF
16577**
16578 ENDIF
16579 ENDIf
16580 ENDIF
16581 DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16582 & VTXDST(3)**2)
16583 IDNUC = IDT_ICIHAD(IDHKK(I))
16584 IF (IDNUC.EQ.1) THEN
16585 IF (DISTNU.LT.DISTP) THEN
16586 DISTP = DISTNU
16587 IDXP = I
16588 POSP = POSNUC
16589 ENDIF
16590 ELSEIF (IDNUC.EQ.8) THEN
16591 IF (DISTNU.LT.DISTN) THEN
16592 DISTN = DISTNU
16593 IDXN = I
16594 POSN = POSNUC
16595 ENDIF
16596 ENDIF
16597 ENDIF
16598 7 CONTINUE
16599
16600* there is no nucleon for a secondary interaction
16601 IF (NSPE.EQ.0) GOTO 9997
16602
16603C IF ((IDCAS.EQ.13).AND.((PCAS(ICAS,4)-PCAS(ICAS,5)).LT.0.1D0))
16604C & WRITE(LOUT,*) STOT,SELA,SABS,IDXSPE
16605 IF (IDXSPE(2).EQ.0) THEN
16606 IF ((IDSPE(1).EQ.1).AND.(IDXN.GT.0)) THEN
16607C DO 80 K=1,3
16608C IF (ICAS.EQ.1) THEN
16609C VTXDST(K) = WHKK(K,IDXN)-WHKK(K,IDXSPE(1))
16610C ELSEIF (ICAS.EQ.2) THEN
16611C VTXDST(K) = VHKK(K,IDXN)-VHKK(K,IDXSPE(1))
16612C ENDIF
16613C 80 CONTINUE
16614C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16615C & VTXDST(3)**2)
16616C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSN.GT.ZERO)) THEN
16617 IDXSPE(2) = IDXN
16618 IDSPE(2) = 8
16619C ELSE
16620C STOT = STOT-SABS
16621C SABS = ZERO
16622C ENDIF
16623 ELSEIF ((IDSPE(1).EQ.8).AND.(IDXP.GT.0)) THEN
16624C DO 81 K=1,3
16625C IF (ICAS.EQ.1) THEN
16626C VTXDST(K) = WHKK(K,IDXP)-WHKK(K,IDXSPE(1))
16627C ELSEIF (ICAS.EQ.2) THEN
16628C VTXDST(K) = VHKK(K,IDXP)-VHKK(K,IDXSPE(1))
16629C ENDIF
16630C 81 CONTINUE
16631C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16632C & VTXDST(3)**2)
16633C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSP.GT.ZERO)) THEN
16634 IDXSPE(2) = IDXP
16635 IDSPE(2) = 1
16636C ELSE
16637C STOT = STOT-SABS
16638C SABS = ZERO
16639C ENDIF
16640 ELSE
16641 STOT = STOT-SABS
16642 SABS = ZERO
16643 ENDIF
16644 ENDIF
16645 RR = DT_RNDM(DIST)
16646 IF (RR.LT.SELA/STOT) THEN
16647 IPROC = 2
16648 ELSEIF ((RR.GE.SELA/STOT).AND.(RR.LT.(SELA+SABS)/STOT)) THEN
16649 IPROC = 3
16650 ELSE
16651 IPROC = 1
16652 ENDIF
16653
16654 DO 9 K=1,5
16655 PCAS1(K) = PCAS(ICAS,K)
16656 PNUC(K) = PHKK(K,IDXSPE(1))
16657 9 CONTINUE
16658 IF (IPROC.EQ.3) THEN
16659* 2-nucleon absorption of pion
16660 NSPE = 2
16661 CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,1,IREJ1)
16662 IF (IREJ1.NE.0) GOTO 9999
16663 IF (NSPE.GE.1) LABSOR = .TRUE.
16664 ELSE
16665* sample secondary interaction
16666 IDNUC = IDBAM(IDXSPE(1))
16667 CALL DT_HADRIN(IDCAS,PCAS1,IDNUC,PNUC,IPROC,IREJ1)
16668 IF (IREJ1.EQ.1) GOTO 9999
16669 IF (IREJ1.GT.1) GOTO 9998
16670 ENDIF
16671 ENDIF
16672
16673* update arrays to include Pauli-principle
16674 DO 10 I=1,NSPE
16675 IF (NWOUND(ICAS).LE.299) THEN
16676 NWOUND(ICAS) = NWOUND(ICAS)+1
16677 EWOUND(ICAS,NWOUND(ICAS)) = PHKK(4,IDXSPE(I))
16678 ENDIF
16679 10 CONTINUE
16680
16681* dump initial hadron for energy-momentum conservation check
16682 IF (LEMCCK)
16683 & CALL DT_EVTEMC(PCAS(ICAS,1),PCAS(ICAS,2),PCAS(ICAS,3),
16684 & PCAS(ICAS,4),1,IDUM,IDUM)
16685
16686* dump final state particles into DTEVT1
16687
16688* check if Pauli-principle is fulfilled
16689 NPAULI = 0
16690 NWTMP(1) = NWOUND(1)
16691 NWTMP(2) = NWOUND(2)
16692 DO 111 I=1,NFSP
16693 NPAULI = 0
16694 J1 = 2
16695 IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
16696 & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1
16697 DO 117 J=1,J1
16698 IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 117
16699 IF (J.EQ.1) THEN
16700 IDX = ICAS
16701 PE = PFSP(4,I)
16702 ELSE
16703 IDX = I2
16704 MODE = 1
16705 IF (IDX.EQ.1) MODE = -1
16706 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,MODE)
16707 ENDIF
16708* first check if cascade step is forbidden due to Pauli-principle
16709* (in case of absorpion this step is forced)
16710 IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
16711 & (IDFSP(I).EQ.8))) THEN
16712* get nuclear potential barrier
16713 POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
16714 IF (IDFSP(I).EQ.1) THEN
16715 POTLOW = POT-EBINDP(IDX)
16716 ELSE
16717 POTLOW = POT-EBINDN(IDX)
16718 ENDIF
16719* final state particle not able to escape nucleus
16720 IF (PE.LE.POTLOW) THEN
16721* check if there are wounded nucleons
16722 IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
16723 & EWOUND(IDX,NWOUND(IDX)))) THEN
16724 NPAULI = NPAULI+1
16725 NWOUND(IDX) = NWOUND(IDX)-1
16726 ELSE
16727* interaction prohibited by Pauli-principle
16728 NWOUND(1) = NWTMP(1)
16729 NWOUND(2) = NWTMP(2)
16730 GOTO 9997
16731 ENDIF
16732 ENDIF
16733 ENDIF
16734 117 CONTINUE
16735 111 CONTINUE
16736
16737 NPAULI = 0
16738 NWOUND(1) = NWTMP(1)
16739 NWOUND(2) = NWTMP(2)
16740
16741 DO 11 I=1,NFSP
16742
16743 IST = ISTHKK(IDXCAS)
16744
16745 NPAULI = 0
16746 J1 = 2
16747 IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
16748 & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1
16749 DO 17 J=1,J1
16750 IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 17
16751 IDX = ICAS
16752 PE = PFSP(4,I)
16753 IF (J.EQ.2) THEN
16754 IDX = I2
16755 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,NCAS)
16756 ENDIF
16757* first check if cascade step is forbidden due to Pauli-principle
16758* (in case of absorpion this step is forced)
16759 IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
16760 & (IDFSP(I).EQ.8))) THEN
16761* get nuclear potential barrier
16762 POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
16763 IF (IDFSP(I).EQ.1) THEN
16764 POTLOW = POT-EBINDP(IDX)
16765 ELSE
16766 POTLOW = POT-EBINDN(IDX)
16767 ENDIF
16768* final state particle not able to escape nucleus
16769 IF (PE.LE.POTLOW) THEN
16770* check if there are wounded nucleons
16771 IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
16772 & EWOUND(IDX,NWOUND(IDX)))) THEN
16773 NWOUND(IDX) = NWOUND(IDX)-1
16774 NPAULI = NPAULI+1
16775 IST = 14+IDX
16776 ELSE
16777* interaction prohibited by Pauli-principle
16778 NWOUND(1) = NWTMP(1)
16779 NWOUND(2) = NWTMP(2)
16780 GOTO 9997
16781 ENDIF
16782**sr
16783c ELSEIF (PE.LE.POT) THEN
16784cC ELSEIF ((PE.LE.POT).AND.(NWOUND(IDX).GE.1)) THEN
16785cC NWOUND(IDX) = NWOUND(IDX)-1
16786c**
16787c NPAULI = NPAULI+1
16788c IST = 14+IDX
16789 ENDIF
16790 ENDIF
16791 17 CONTINUE
16792
16793* dump final state particles for energy-momentum conservation check
16794 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),-PFSP(3,I),
16795 & -PFSP(4,I),2,IDUM,IDUM)
16796
16797 PX = PFSP(1,I)
16798 PY = PFSP(2,I)
16799 PZ = PFSP(3,I)
16800 PE = PFSP(4,I)
16801 IF (ABS(IST).EQ.1) THEN
16802* transform particles back into n-n cms
16803* LEPTO: leave final state particles in target rest frame
16804C IF (MCGENE.EQ.3) THEN
16805C PFSP(1,I) = PX
16806C PFSP(2,I) = PY
16807C PFSP(3,I) = PZ
16808C PFSP(4,I) = PE
16809C ELSE
16810 IMODE = ICAS+1
16811 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
16812 & PFSP(4,I),IDFSP(I),IMODE)
16813C ENDIF
16814 ELSEIF ((ICAS.EQ.2).AND.(IST.EQ.15)) THEN
16815* target cascade but fsp got stuck in proj. --> transform it into
16816* proj. rest system
16817 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
16818 & PFSP(4,I),IDFSP(I),-1)
16819 ELSEIF ((ICAS.EQ.1).AND.(IST.EQ.16)) THEN
16820* proj. cascade but fsp got stuck in target --> transform it into
16821* target rest system
16822 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
16823 & PFSP(4,I),IDFSP(I),1)
16824 ENDIF
16825
16826* dump final state particles into DTEVT1
16827 IGEN = IDCH(IDXCAS)+1
16828 ID = IDT_IPDGHA(IDFSP(I))
16829 IXR = 0
16830 IF (LABSOR) IXR = 99
16831 CALL DT_EVTPUT(IST,ID,IDXCAS,IDXSPE(1),PFSP(1,I),
16832 & PFSP(2,I),PFSP(3,I),PFSP(4,I),0,IXR,IGEN)
16833
16834* update the counter for particles which got stuck inside the nucleus
16835 IF ((IST.EQ.15).OR.(IST.EQ.16)) THEN
16836 NOINC = NOINC+1
16837 IDXINC(NOINC) = NHKK
16838 ENDIF
16839 IF (LABSOR) THEN
16840* in case of absorption the spatial treatment is an approximate
16841* solution anyway (the positions of the nucleons which "absorb" the
16842* cascade particle are not taken into consideration) therefore the
16843* particles are produced at the position of the cascade particle
16844 DO 12 K=1,4
16845 WHKK(K,NHKK) = WHKK(K,IDXCAS)
16846 VHKK(K,NHKK) = VHKK(K,IDXCAS)
16847 12 CONTINUE
16848 ELSE
16849* DDISTL - distance the cascade particle moves to the intera. point
16850* (the position where impact-parameter = distance to the interacting
16851* nucleon), DIST - distance to the interacting nucleon at the time of
16852* formation of the cascade particle, BINT - impact-parameter of this
16853* cascade-interaction
16854 DDISTL = SQRT(DIST**2-BINT**2)
16855 DTIME = DDISTL/BECAS(ICAS)
16856 DTIMEL = DDISTL/BGCAS(ICAS)
16857 RDISTL = DTIMEL*BGCAS(I2)
16858 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16859 RTIME = RDISTL/BECAS(I2)
16860 ELSE
16861 RTIME = ZERO
16862 ENDIF
16863* RDISTL, RTIME are this step and time in the rest system of the other
16864* nucleus
16865 DO 13 K=1,3
16866 VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+COSCAS(ICAS,K)*DDISTL
16867 VTXCA1(I2,K) = VTXCAS(I2,K) +COSCAS(I2,K) *RDISTL
16868 13 CONTINUE
16869 VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME
16870 VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME
16871* position of particle production is half the impact-parameter to
16872* the interacting nucleon
16873 DO 14 K=1,3
16874 WHKK(K,NHKK) = OHALF*(VTXCA1(1,K)+WHKK(K,IDXSPE(1)))
16875 VHKK(K,NHKK) = OHALF*(VTXCA1(2,K)+VHKK(K,IDXSPE(1)))
16876 14 CONTINUE
16877* time of production of secondary = time of interaction
16878 WHKK(4,NHKK) = VTXCA1(1,4)
16879 VHKK(4,NHKK) = VTXCA1(2,4)
16880 ENDIF
16881
16882 11 CONTINUE
16883
16884* modify status and position of cascade particle (the latter for
16885* statistics reasons only)
16886 ISTHKK(IDXCAS) = 2
16887 IF (LABSOR) ISTHKK(IDXCAS) = 19
16888 IF (.NOT.LABSOR) THEN
16889 DO 15 K=1,4
16890 WHKK(K,IDXCAS) = VTXCA1(1,K)
16891 VHKK(K,IDXCAS) = VTXCA1(2,K)
16892 15 CONTINUE
16893 ENDIF
16894
16895 DO 16 I=1,NSPE
16896 IS = IDXSPE(I)
16897* dump interacting nucleons for energy-momentum conservation check
16898 IF (LEMCCK)
16899 & CALL DT_EVTEMC(PHKK(1,IS),PHKK(2,IS),PHKK(3,IS),PHKK(4,IS),
16900 & 2,IDUM,IDUM)
16901* modify entry for interacting nucleons
16902 IF (ISTHKK(IS).EQ.12+ICAS) ISTHKK(IS)=16+ICAS
16903 IF (ISTHKK(IS).EQ.14+ICAS) ISTHKK(IS)=2
16904 IF (I.GE.2) THEN
16905 JDAHKK(1,IS) = JDAHKK(1,IDXSPE(1))
16906 JDAHKK(2,IS) = JDAHKK(2,IDXSPE(1))
16907 ENDIF
16908 16 CONTINUE
16909
16910* check energy-momentum conservation
16911 IF (LEMCCK) THEN
16912 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,500,IREJ1)
16913 IF (IREJ1.NE.0) GOTO 9999
16914 ENDIF
16915
16916* update counter
16917 IF (LABSOR) THEN
16918 NINCCO(ICAS,1) = NINCCO(ICAS,1)+1
16919 ELSE
16920 IF (IPROC.EQ.1) NINCCO(ICAS,2) = NINCCO(ICAS,2)+1
16921 IF (IPROC.EQ.2) NINCCO(ICAS,3) = NINCCO(ICAS,3)+1
16922 ENDIF
16923
16924 RETURN
16925
16926 9997 CONTINUE
16927 9998 CONTINUE
16928* transport-step but no cascade step due to configuration (i.e. there
16929* is no nucleon for interaction etc.)
16930 IF (LCAS) THEN
16931 DO 100 K=1,4
16932C WHKK(K,IDXCAS) = VTXCAS(1,K)
16933C VHKK(K,IDXCAS) = VTXCAS(2,K)
16934 WHKK(K,IDXCAS) = VTXCA1(1,K)
16935 VHKK(K,IDXCAS) = VTXCA1(2,K)
16936 100 CONTINUE
16937 ENDIF
16938
16939C9998 CONTINUE
16940* no cascade-step because of configuration
16941* (i.e. hadron outside nucleus etc.)
16942 LCAS = .TRUE.
16943 RETURN
16944
16945 9999 CONTINUE
16946* rejection
16947 IREJ = 1
16948 RETURN
16949 END
16950
16951*$ CREATE DT_ABSORP.FOR
16952*COPY DT_ABSORP
16953*
16954*===absorp=============================================================*
16955*
16956 SUBROUTINE DT_ABSORP(IDCAS,PCAS,NCAS,NSPE,IDSPE,IDXSPE,MODE,IREJ)
16957
16958************************************************************************
16959* Two-nucleon absorption of antiprotons, pi-, and K-. *
16960* Antiproton absorption is handled by HADRIN. *
16961* The following channels for meson-absorption are considered: *
16962* pi- + p + p ---> n + p *
16963* pi- + p + n ---> n + n *
16964* K- + p + p ---> sigma+ + n / Lam + p / sigma0 + p *
16965* K- + p + n ---> sigma- + n / Lam + n / sigma0 + n *
16966* K- + p + p ---> sigma- + n *
16967* IDCAS, PCAS identity, momentum of particle to be absorbed *
16968* NCAS = 1 intranuclear cascade in projectile *
16969* = -1 intranuclear cascade in target *
16970* NSPE number of spectator nucleons involved *
16971* IDXSPE(2) DTEVT1-indices of spectator nucleons involved *
16972* Revised version of the original STOPIK written by HJM and J. Ranft. *
16973* This version dated 24.02.95 is written by S. Roesler *
16974************************************************************************
16975
16976 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16977 SAVE
16978 PARAMETER ( LINP = 10 ,
16979 & LOUT = 6 ,
16980 & LDAT = 9 )
16981 PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,ONE=1.0D0,
16982 & ONETHI=0.3333D0,TWOTHI=0.6666D0)
16983
16984* event history
16985 PARAMETER (NMXHKK=200000)
16986 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16987 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16988 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16989* extended event history
16990 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16991 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16992 & IHIST(2,NMXHKK)
16993* flags for input different options
16994 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16995 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16996 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16997* final state after inc step
16998 PARAMETER (MAXFSP=10)
16999 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17000* particle properties (BAMJET index convention)
17001 CHARACTER*8 ANAME
17002 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17003 & IICH(210),IIBAR(210),K1(210),K2(210)
17004
17005 DIMENSION PCAS(5),IDXSPE(2),IDSPE(2),PSPE(2,5),PSPE1(5),
17006 & PTOT3P(4),BG3P(4),
17007 & ECMF(2),PCMF(2),CODF(2),COFF(2),SIFF(2)
17008
17009 IREJ = 0
17010 NFSP = 0
17011
17012* skip particles others than ap, pi-, K- for mode=0
17013 IF ((MODE.EQ.0).AND.
17014 & (IDCAS.NE.2).AND.(IDCAS.NE.14).AND.(IDCAS.NE.16)) RETURN
17015* skip particles others than pions for mode=1
17016* (2-nucleon absorption in intranuclear cascade)
17017 IF ((MODE.EQ.1).AND.
17018 & (IDCAS.NE.13).AND.(IDCAS.NE.14).AND.(IDCAS.NE.23)) RETURN
17019
17020 NUCAS = NCAS
17021 IF (NUCAS.EQ.-1) NUCAS = 2
17022
17023 IF (MODE.EQ.0) THEN
17024* scan spectator nucleons for nucleons being able to "absorb"
17025 NSPE = 0
17026 IDXSPE(1) = 0
17027 IDXSPE(2) = 0
17028 DO 1 I=1,NHKK
17029 IF ((ISTHKK(I).EQ.12+NUCAS).OR.(ISTHKK(I).EQ.14+NUCAS)) THEN
17030 NSPE = NSPE+1
17031 IDXSPE(NSPE) = I
17032 IDSPE(NSPE) = IDBAM(I)
17033 IF ((NSPE.EQ.1).AND.(IDCAS.EQ.2)) GOTO 2
17034 IF (NSPE.EQ.2) THEN
17035 IF ((IDCAS.EQ.14).AND.(IDSPE(1).EQ.8).AND.
17036 & (IDSPE(2).EQ.8)) THEN
17037* there is no pi-+n+n channel
17038 NSPE = 1
17039 GOTO 1
17040 ELSE
17041 GOTO 2
17042 ENDIF
17043 ENDIF
17044 ENDIF
17045 1 CONTINUE
17046
17047 2 CONTINUE
17048 ENDIF
17049* transform excited projectile nucleons (status=15) into proj. rest s.
17050 DO 3 I=1,NSPE
17051 DO 4 K=1,5
17052 PSPE(I,K) = PHKK(K,IDXSPE(I))
17053 4 CONTINUE
17054 3 CONTINUE
17055
17056* antiproton absorption
17057 IF ((IDCAS.EQ.2).AND.(NSPE.GE.1)) THEN
17058 DO 5 K=1,5
17059 PSPE1(K) = PSPE(1,K)
17060 5 CONTINUE
17061 CALL DT_HADRIN(IDCAS,PCAS,IDSPE(1),PSPE1,1,IREJ1)
17062 IF (IREJ1.NE.0) GOTO 9999
17063
17064* meson absorption
17065 ELSEIF (((IDCAS.EQ.13).OR.(IDCAS.EQ.14).OR.(IDCAS.EQ.23)
17066 & .OR.(IDCAS.EQ.16)).AND.(NSPE.GE.2)) THEN
17067 IF (IDCAS.EQ.14) THEN
17068* pi- absorption
17069 IDFSP(1) = 8
17070 IDFSP(2) = 8
17071 IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) IDFSP(2) = 1
17072 ELSEIF (IDCAS.EQ.13) THEN
17073* pi+ absorption
17074 IDFSP(1) = 1
17075 IDFSP(2) = 1
17076 IF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) IDFSP(2) = 8
17077 ELSEIF (IDCAS.EQ.23) THEN
17078* pi0 absorption
17079 IDFSP(1) = IDSPE(1)
17080 IDFSP(2) = IDSPE(2)
17081 ELSEIF (IDCAS.EQ.16) THEN
17082* K- absorption
17083 R = DT_RNDM(PCAS)
17084 IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) THEN
17085 IF (R.LT.ONETHI) THEN
17086 IDFSP(1) = 21
17087 IDFSP(2) = 8
17088 ELSEIF (R.LT.TWOTHI) THEN
17089 IDFSP(1) = 17
17090 IDFSP(2) = 1
17091 ELSE
17092 IDFSP(1) = 22
17093 IDFSP(2) = 1
17094 ENDIF
17095 ELSEIF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) THEN
17096 IDFSP(1) = 20
17097 IDFSP(2) = 8
17098 ELSE
17099 IF (R.LT.ONETHI) THEN
17100 IDFSP(1) = 20
17101 IDFSP(2) = 1
17102 ELSEIF (R.LT.TWOTHI) THEN
17103 IDFSP(1) = 17
17104 IDFSP(2) = 8
17105 ELSE
17106 IDFSP(1) = 22
17107 IDFSP(2) = 8
17108 ENDIF
17109 ENDIF
17110 ENDIF
17111* dump initial particles for energy-momentum cons. check
17112 IF (LEMCCK) THEN
17113 CALL DT_EVTEMC(PCAS(1),PCAS(2),PCAS(3),PCAS(4),1,IDUM,IDUM)
17114 CALL DT_EVTEMC(PSPE(1,1),PSPE(1,2),PSPE(1,3),PSPE(1,4),2,
17115 & IDUM,IDUM)
17116 CALL DT_EVTEMC(PSPE(2,1),PSPE(2,2),PSPE(2,3),PSPE(2,4),2,
17117 & IDUM,IDUM)
17118 ENDIF
17119* get Lorentz-parameter of 3 particle initial state
17120 DO 6 K=1,4
17121 PTOT3P(K) = PCAS(K)+PSPE(1,K)+PSPE(2,K)
17122 6 CONTINUE
17123 P3P = SQRT(PTOT3P(1)**2+PTOT3P(2)**2+PTOT3P(3)**2)
17124 AM3P = SQRT( (PTOT3P(4)-P3P)*(PTOT3P(4)+P3P) )
17125 DO 7 K=1,4
17126 BG3P(K) = PTOT3P(K)/MAX(AM3P,TINY10)
17127 7 CONTINUE
17128* 2-particle decay of the 3-particle compound system
17129 CALL DT_DTWOPD(AM3P,ECMF(1),ECMF(2),PCMF(1),PCMF(2),
17130 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
17131 & AAM(IDFSP(1)),AAM(IDFSP(2)))
17132 DO 8 I=1,2
17133 SDF = SQRT((ONE-CODF(I))*(ONE+CODF(I)))
17134 PX = PCMF(I)*COFF(I)*SDF
17135 PY = PCMF(I)*SIFF(I)*SDF
17136 PZ = PCMF(I)*CODF(I)
17137 CALL DT_DALTRA(BG3P(4),BG3P(1),BG3P(2),BG3P(3),PX,PY,PZ,
17138 & ECMF(I),PTOFSP,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17139 & PFSP(4,I))
17140 PFSP(5,I) = SQRT( (PFSP(4,I)-PTOFSP)*(PFSP(4,I)+PTOFSP) )
17141* check consistency of kinematics
17142 IF (ABS(AAM(IDFSP(I))-PFSP(5,I)).GT.TINY5) THEN
17143 WRITE(LOUT,1001) IDFSP(I),AAM(IDFSP(I)),PFSP(5,I)
17144 1001 FORMAT(1X,'ABSORP: warning! inconsistent',
17145 & ' tree-particle kinematics',/,20X,'id: ',I3,
17146 & ' AAM = ',E10.4,' MFSP = ',E10.4)
17147 ENDIF
17148* dump final state particles for energy-momentum cons. check
17149 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
17150 & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
17151 8 CONTINUE
17152 NFSP = 2
17153 IF (LEMCCK) THEN
17154 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,100,IREJ1)
17155 IF (IREJ1.NE.0) THEN
17156 WRITE(LOUT,*)'ABSORB: EMC ',AAM(IDFSP(1)),AAM(IDFSP(2)),
17157 & AM3P
17158 GOTO 9999
17159 ENDIF
17160 ENDIF
17161 ELSE
17162 IF (IOULEV(3).GT.0) WRITE(LOUT,1000) IDCAS,NSPE
17163 1000 FORMAT(1X,'ABSORP: warning! absorption for particle ',I3,
17164 & ' impossible',/,20X,'too few spectators (',I2,')')
17165 NSPE = 0
17166 ENDIF
17167
17168 RETURN
17169
17170 9999 CONTINUE
17171 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in ABSORP'
17172 IREJ = 1
17173 RETURN
17174 END
17175
17176*$ CREATE DT_HADRIN.FOR
17177*COPY DT_HADRIN
17178*
17179*===hadrin=============================================================*
17180*
17181 SUBROUTINE DT_HADRIN(IDPR,PPR,IDTA,PTA,MODE,IREJ)
17182
17183************************************************************************
17184* Interface to the HADRIN-routines for inelastic and elastic *
17185* scattering. *
17186* IDPR,PPR(5) identity, momentum of projectile *
17187* IDTA,PTA(5) identity, momentum of target *
17188* MODE = 1 inelastic interaction *
17189* = 2 elastic interaction *
17190* Revised version of the original FHAD. *
17191* This version dated 27.10.95 is written by S. Roesler *
17192************************************************************************
17193
17194 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17195 SAVE
17196 PARAMETER ( LINP = 10 ,
17197 & LOUT = 6 ,
17198 & LDAT = 9 )
17199 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,
17200 & TINY2=1.0D-2,TINY1=1.0D-1,ONE=1.0D0)
17201
17202 LOGICAL LCORR,LMSSG
17203
17204* flags for input different options
17205 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17206 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17207 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17208* final state after inc step
17209 PARAMETER (MAXFSP=10)
17210 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17211* particle properties (BAMJET index convention)
17212 CHARACTER*8 ANAME
17213 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17214 & IICH(210),IIBAR(210),K1(210),K2(210)
17215* output-common for DHADRI/ELHAIN
17216* final state from HADRIN interaction
17217 PARAMETER (MAXFIN=10)
17218 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
17219 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
17220
17221 DIMENSION PPR(5),PPR1(5),PTA(5),BGTA(4),
17222 & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4),IMCORR(2)
17223
17224 DATA LMSSG /.TRUE./
17225
17226 IREJ = 0
17227 NFSP = 0
17228 KCORR = 0
17229 IMCORR(1) = 0
17230 IMCORR(2) = 0
17231 LCORR = .FALSE.
17232
17233* dump initial particles for energy-momentum cons. check
17234 IF (LEMCCK) THEN
17235 CALL DT_EVTEMC(PPR(1),PPR(2),PPR(3),PPR(4),1,IDUM,IDUM)
17236 CALL DT_EVTEMC(PTA(1),PTA(2),PTA(3),PTA(4),2,IDUM,IDUM)
17237 ENDIF
17238
17239 AMP2 = PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2
17240 AMT2 = PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2
17241 IF ((AMP2.LT.ZERO).OR.(AMT2.LT.ZERO).OR.
17242 & (ABS(AMP2-AAM(IDPR)**2).GT.TINY5).OR.
17243 & (ABS(AMT2-AAM(IDTA)**2).GT.TINY5)) THEN
17244 IF (LMSSG.AND.(IOULEV(3).GT.0))
17245 & WRITE(LOUT,1000) AMP2,AAM(IDPR)**2,AMT2,AAM(IDTA)**2
17246 1000 FORMAT(1X,'HADRIN: warning! inconsistent projectile/target',
17247 & ' mass',/,20X,'AMP2 = ',E12.4,', AAM(IDPR)**2 = ',
17248 & E12.4,/,20X,'AMT2 = ',E12.4,', AAM(IDTA)**2 = ',E12.4)
17249 LMSSG = .FALSE.
17250 LCORR = .TRUE.
17251 ENDIF
17252
17253* convert initial state particles into particles which can be
17254* handled by HADRIN
17255 IDHPR = IDPR
17256 IDHTA = IDTA
17257 IF ((IDHPR.LE.0).OR.(IDHPR.GE.111).OR.LCORR) THEN
17258 IF ((IDHPR.LE.0).OR.(IDHPR.GE.111)) IDHPR = 1
17259 DO 1 K=1,4
17260 P1IN(K) = PPR(K)
17261 P2IN(K) = PTA(K)
17262 1 CONTINUE
17263 XM1 = AAM(IDHPR)
17264 XM2 = AAM(IDHTA)
17265 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
17266 IF (IREJ1.GT.0) THEN
17267 WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.'
17268 GOTO 9999
17269 ENDIF
17270 DO 2 K=1,4
17271 PPR(K) = P1OUT(K)
17272 PTA(K) = P2OUT(K)
17273 2 CONTINUE
17274 PPR(5) = SQRT(PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2)
17275 PTA(5) = SQRT(PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2)
17276 ENDIF
17277
17278* Lorentz-parameter for trafo into rest-system of target
17279 DO 3 K=1,4
17280 BGTA(K) = PTA(K)/PTA(5)
17281 3 CONTINUE
17282* transformation of projectile into rest-system of target
17283 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),PPR(1),PPR(2),
17284 & PPR(3),PPR(4),PPRTO1,PPR1(1),PPR1(2),PPR1(3),
17285 & PPR1(4))
17286
17287* direction cosines of projectile in target rest system
17288 CX = PPR1(1)/PPRTO1
17289 CY = PPR1(2)/PPRTO1
17290 CZ = PPR1(3)/PPRTO1
17291
17292* sample inelastic interaction
17293 IF (MODE.EQ.1) THEN
17294 CALL DT_DHADRI(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA)
17295 IF (IRH.EQ.1) GOTO 9998
17296* sample elastic interaction
17297 ELSEIF (MODE.EQ.2) THEN
17298 CALL DT_ELHAIN(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA,IREJ1)
17299 IF (IREJ1.NE.0) THEN
17300 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in HADRIN'
17301 GOTO 9999
17302 ENDIF
17303 IF (IRH.EQ.1) GOTO 9998
17304 ELSE
17305 WRITE(LOUT,1001) MODE,INTHAD
17306 1001 FORMAT(1X,'HADRIN: warning! inconsistent interaction mode',
17307 & I4,' (INTHAD =',I4,')')
17308 GOTO 9999
17309 ENDIF
17310
17311* transform final state particles back into Lab.
17312 DO 4 I=1,IRH
17313 NFSP = NFSP+1
17314 PX = CXRH(I)*PLRH(I)
17315 PY = CYRH(I)*PLRH(I)
17316 PZ = CZRH(I)*PLRH(I)
17317 CALL DT_DALTRA(BGTA(4),BGTA(1),BGTA(2),BGTA(3),
17318 & PX,PY,PZ,ELRH(I),PTOFSP,PFSP(1,NFSP),
17319 & PFSP(2,NFSP),PFSP(3,NFSP),PFSP(4,NFSP))
17320 IDFSP(NFSP) = ITRH(I)
17321 AMFSP2 = PFSP(4,NFSP)**2-PFSP(1,NFSP)**2-PFSP(2,NFSP)**2-
17322 & PFSP(3,NFSP)**2
17323 IF (AMFSP2.LT.-TINY3) THEN
17324 WRITE(LOUT,1002) IDFSP(NFSP),PFSP(1,NFSP),PFSP(2,NFSP),
17325 & PFSP(3,NFSP),PFSP(4,NFSP),AMFSP2
17326 1002 FORMAT(1X,'HADRIN: warning! final state particle (id = ',
17327 & I2,') with negative mass^2',/,1X,5E12.4)
17328 GOTO 9999
17329 ELSE
17330 PFSP(5,NFSP) = SQRT(ABS(AMFSP2))
17331 IF (ABS(PFSP(5,NFSP)-AAM(IDFSP(NFSP))).GT.TINY1) THEN
17332 WRITE(LOUT,1003) IDFSP(NFSP),AAM(IDFSP(NFSP)),
17333 & PFSP(5,NFSP)
17334 1003 FORMAT(1X,'HADRIN: warning! final state particle',
17335 & ' (id = ',I2,') with inconsistent mass',/,1X,
17336 & 2E12.4)
17337 KCORR = KCORR+1
17338 IF (KCORR.GT.2) GOTO 9999
17339 IMCORR(KCORR) = NFSP
17340 ENDIF
17341 ENDIF
17342* dump final state particles for energy-momentum cons. check
17343 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
17344 & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
17345 4 CONTINUE
17346
17347* transform momenta on mass shell in case of inconsistencies in
17348* HADRIN
17349 IF (KCORR.GT.0) THEN
17350 IF (KCORR.EQ.2) THEN
17351 I1 = IMCORR(1)
17352 I2 = IMCORR(2)
17353 ELSE
17354 IF (IMCORR(1).EQ.1) THEN
17355 I1 = 1
17356 I2 = 2
17357 ELSE
17358 I1 = 1
17359 I2 = IMCORR(1)
17360 ENDIF
17361 ENDIF
17362 IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I1),PFSP(2,I1),
17363 & PFSP(3,I1),PFSP(4,I1),2,IDUM,IDUM)
17364 IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I2),PFSP(2,I2),
17365 & PFSP(3,I2),PFSP(4,I2),2,IDUM,IDUM)
17366 DO 5 K=1,4
17367 P1IN(K) = PFSP(K,I1)
17368 P2IN(K) = PFSP(K,I2)
17369 5 CONTINUE
17370 XM1 = AAM(IDFSP(I1))
17371 XM2 = AAM(IDFSP(I2))
17372 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
17373 IF (IREJ1.GT.0) THEN
17374 WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.'
17375C GOTO 9999
17376 ENDIF
17377 DO 6 K=1,4
17378 PFSP(K,I1) = P1OUT(K)
17379 PFSP(K,I2) = P2OUT(K)
17380 6 CONTINUE
17381 PFSP(5,I1) = SQRT(PFSP(4,I1)**2-PFSP(1,I1)**2
17382 & -PFSP(2,I1)**2-PFSP(3,I1)**2)
17383 PFSP(5,I2) = SQRT(PFSP(4,I2)**2-PFSP(1,I2)**2
17384 & -PFSP(2,I2)**2-PFSP(3,I2)**2)
17385* dump final state particles for energy-momentum cons. check
17386 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I1),-PFSP(2,I1),
17387 & -PFSP(3,I1),-PFSP(4,I1),2,IDUM,IDUM)
17388 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I2),-PFSP(2,I2),
17389 & -PFSP(3,I2),-PFSP(4,I2),2,IDUM,IDUM)
17390 ENDIF
17391
17392* check energy-momentum conservation
17393 IF (LEMCCK) THEN
17394 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,102,IREJ1)
17395 IF (IREJ1.NE.0) GOTO 9999
17396 ENDIF
17397
17398 RETURN
17399
17400 9998 CONTINUE
17401 IREJ = 2
17402 RETURN
17403
17404 9999 CONTINUE
17405 IREJ = 1
17406 RETURN
17407 END
17408
17409*$ CREATE DT_HADCOL.FOR
17410*COPY DT_HADCOL
17411*
17412*===hadcol=============================================================*
17413*
17414 SUBROUTINE DT_HADCOL(IDPROJ,PPN,IDXTAR,IREJ)
17415
17416************************************************************************
17417* Interface to the HADRIN-routines for inelastic and elastic *
17418* scattering. This subroutine samples hadron-nucleus interactions *
17419* below DPM-threshold. *
17420* IDPROJ BAMJET-index of projectile hadron *
17421* PPN projectile momentum in target rest frame *
17422* IDXTAR DTEVT1-index of target nucleon undergoing *
17423* interaction with projectile hadron *
17424* This subroutine replaces HADHAD. *
17425* This version dated 5.5.95 is written by S. Roesler *
17426************************************************************************
17427
17428 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17429 SAVE
17430 PARAMETER ( LINP = 10 ,
17431 & LOUT = 6 ,
17432 & LDAT = 9 )
17433 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0)
17434
17435 LOGICAL LSTART
17436
17437* event history
17438 PARAMETER (NMXHKK=200000)
17439 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17440 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17441 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17442* extended event history
17443 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17444 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17445 & IHIST(2,NMXHKK)
17446* nuclear potential
17447 LOGICAL LFERMI
17448 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17449 & EBINDP(2),EBINDN(2),EPOT(2,210),
17450 & ETACOU(2),ICOUL,LFERMI
17451* interface HADRIN-DPM
17452 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
17453* parameter for intranuclear cascade
17454 LOGICAL LPAULI
17455 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
17456* final state after inc step
17457 PARAMETER (MAXFSP=10)
17458 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17459* particle properties (BAMJET index convention)
17460 CHARACTER*8 ANAME
17461 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17462 & IICH(210),IIBAR(210),K1(210),K2(210)
17463
17464 DIMENSION PPROJ(5),PNUC(5)
17465
17466 DATA LSTART /.TRUE./
17467
17468 IREJ = 0
17469
17470 NPOINT(1) = NHKK+1
17471
17472 TAUSAV = TAUFOR
17473**sr 6/9/01 commented
17474C TAUFOR = TAUFOR/2.0D0
17475**
17476 IF (LSTART) THEN
17477 WRITE(LOUT,1000)
17478 1000 FORMAT(/,1X,'HADCOL: Scattering handled by HADRIN')
17479 WRITE(LOUT,1001) TAUFOR
17480 1001 FORMAT(/,1X,'HADCOL: Formation zone parameter set to ',
17481 & F5.1,' fm/c')
17482 LSTART = .FALSE.
17483 ENDIF
17484
17485 IDNUC = IDBAM(IDXTAR)
17486 IDNUC1 = IDT_MCHAD(IDNUC)
17487 IDPRO1 = IDT_MCHAD(IDPROJ)
17488
17489 IF ((INTHAD.EQ.1).OR.(INTHAD.EQ.2)) THEN
17490 IPROC = INTHAD
17491 ELSE
17492**
17493C CALL DT_SIHNIN(IDPRO1,IDNUC1,PPN,SIGIN)
17494C CALL DT_SIHNEL(IDPRO1,IDNUC1,PPN,SIGEL)
17495 DUMZER = ZERO
17496 CALL DT_XSHN(IDPRO1,IDNUC1,PPN,DUMZER,SIGTOT,SIGEL)
17497 SIGIN = SIGTOT-SIGEL
17498C SIGTOT = SIGIN+SIGEL
17499**
17500 IPROC = 1
17501 IF (DT_RNDM(SIGIN).LT.SIGEL/SIGTOT) IPROC = 2
17502 ENDIF
17503
17504 PPROJ(1) = ZERO
17505 PPROJ(2) = ZERO
17506 PPROJ(3) = PPN
17507 PPROJ(5) = AAM(IDPROJ)
17508 PPROJ(4) = SQRT(PPROJ(5)**2+PPROJ(3)**2)
17509 DO 1 K=1,5
17510 PNUC(K) = PHKK(K,IDXTAR)
17511 1 CONTINUE
17512
17513 ILOOP = 0
17514 2 CONTINUE
17515 ILOOP = ILOOP+1
17516 IF (ILOOP.GT.100) GOTO 9999
17517
17518 CALL DT_HADRIN(IDPROJ,PPROJ,IDNUC,PNUC,IPROC,IREJ1)
17519 IF (IREJ1.EQ.1) GOTO 9999
17520
17521 IF (IREJ1.GT.1) THEN
17522* no interaction possible
17523* require Pauli blocking
17524 IF ((IDPROJ.EQ.1).AND.(PPROJ(4).LE.PFERMP(2)+PPROJ(5))) GOTO 2
17525 IF ((IDPROJ.EQ.8).AND.(PPROJ(4).LE.PFERMN(2)+PPROJ(5))) GOTO 2
17526 IF ((IIBAR(IDPROJ).NE.1).AND.
17527 & (PPROJ(4).LE.EPOT(2,IDPROJ)+PPROJ(5))) GOTO 2
17528* store incoming particle as final state particle
17529 CALL DT_LTNUC(PPROJ(3),PPROJ(4),PCMS,ECMS,3)
17530 CALL DT_EVTPUT(1,IDPROJ,1,0,PPROJ(1),PPROJ(2),PCMS,ECMS,0,0,0)
17531 NPOINT(4) = NHKK
17532 ELSE
17533* require Pauli blocking for final state nucleons
17534 DO 4 I=1,NFSP
17535 IF ((IDFSP(I).EQ.1).AND.
17536 & (PFSP(4,I).LE.PFERMP(2)+AAM(IDFSP(I)))) GOTO 2
17537 IF ((IDFSP(I).EQ.8).AND.
17538 & (PFSP(4,I).LE.PFERMN(2)+AAM(IDFSP(I)))) GOTO 2
17539 IF ((IIBAR(IDFSP(I)).NE.1).AND.
17540 & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I))))GOTO 2
17541 4 CONTINUE
17542* store final state particles
17543 DO 5 I=1,NFSP
17544 IST = 1
17545 IF ((IIBAR(IDFSP(I)).EQ.1).AND.
17546 & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I)))) IST = 16
17547 IDHAD = IDT_IPDGHA(IDFSP(I))
17548 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PCMS,ECMS,3)
17549 CALL DT_EVTPUT(IST,IDHAD,1,IDXTAR,PFSP(1,I),PFSP(2,I),
17550 & PCMS,ECMS,0,0,0)
17551 IF (I.EQ.1) NPOINT(4) = NHKK
17552 VHKK(1,NHKK) = 0.5D0*(VHKK(1,1)+VHKK(1,IDXTAR))
17553 VHKK(2,NHKK) = 0.5D0*(VHKK(2,1)+VHKK(2,IDXTAR))
17554 VHKK(3,NHKK) = VHKK(3,IDXTAR)
17555 VHKK(4,NHKK) = VHKK(4,IDXTAR)
17556 WHKK(1,NHKK) = 0.5D0*(WHKK(1,1)+WHKK(1,IDXTAR))
17557 WHKK(2,NHKK) = 0.5D0*(WHKK(2,1)+WHKK(2,IDXTAR))
17558 WHKK(3,NHKK) = WHKK(3,1)
17559 WHKK(4,NHKK) = WHKK(4,1)
17560 5 CONTINUE
17561 ENDIF
17562 TAUFOR = TAUSAV
17563 RETURN
17564
17565 9999 CONTINUE
17566 IREJ = 1
17567 TAUFOR = TAUSAV
17568 RETURN
17569 END
17570
17571*$ CREATE DT_GETEMU.FOR
17572*COPY DT_GETEMU
17573*
17574*===getemu=============================================================*
17575*
17576 SUBROUTINE DT_GETEMU(IT,ITZ,KKMAT,MODE)
17577
17578************************************************************************
17579* Sampling of emulsion component to be considered as target-nucleus. *
17580* This version dated 6.5.95 is written by S. Roesler. *
17581************************************************************************
17582
17583 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17584 SAVE
17585 PARAMETER ( LINP = 10 ,
17586 & LOUT = 6 ,
17587 & LDAT = 9 )
17588 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
17589
17590 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
17591* emulsion treatment
17592 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
17593 & NCOMPO,IEMUL
17594* Glauber formalism: flags and parameters for statistics
17595 LOGICAL LPROD
17596 CHARACTER*8 CGLB
17597 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
17598
17599 IF (MODE.EQ.0) THEN
17600 SUMFRA = ZERO
17601 RR = DT_RNDM(SUMFRA)
17602 IT = 0
17603 ITZ = 0
17604 DO 1 ICOMP=1,NCOMPO
17605 SUMFRA = SUMFRA+EMUFRA(ICOMP)
17606 IF (SUMFRA.GT.RR) THEN
17607 IT = IEMUMA(ICOMP)
17608 ITZ = IEMUCH(ICOMP)
17609 KKMAT = ICOMP
17610 GOTO 2
17611 ENDIF
17612 1 CONTINUE
17613 2 CONTINUE
17614 IF (IT.LE.0) THEN
17615 WRITE(LOUT,'(1X,A,E12.3)')
17616 & 'Warning! norm. failure within emulsion fractions',
17617 & SUMFRA
17618 STOP
17619 ENDIF
17620 ELSEIF (MODE.EQ.1) THEN
17621 NDIFF = 10000
17622 DO 3 I=1,NCOMPO
17623 IDIFF = ABS(IT-IEMUMA(I))
17624 IF (IDIFF.LT.NDIFF) THEN
17625 KKMAT = I
17626 NDIFF = IDIFF
17627 ENDIF
17628 3 CONTINUE
17629 ELSE
17630 STOP 'DT_GETEMU'
17631 ENDIF
17632
17633* bypass for variable projectile/target/energy runs: the correct
17634* Glauber data will be always loaded on kkmat=1
17635 IF (IOGLB.EQ.100) THEN
17636 KKMAT = 1
17637 ENDIF
17638
17639 RETURN
17640 END
17641
17642*$ CREATE DT_NCLPOT.FOR
17643*COPY DT_NCLPOT
17644*
17645*===nclpot=============================================================*
17646*
17647 SUBROUTINE DT_NCLPOT(IPZ,IP,ITZ,IT,AFERP,AFERT,MODE)
17648
17649************************************************************************
17650* Calculation of Coulomb and nuclear potential for a given configurat. *
17651* IPZ, IP charge/mass number of proj. *
17652* ITZ, IT charge/mass number of targ. *
17653* AFERP,AFERT factors modifying proj./target pot. *
17654* if =0, FERMOD is used *
17655* MODE = 0 calculation of binding energy *
17656* = 1 pre-calculated binding energy is used *
17657* This version dated 16.11.95 is written by S. Roesler. *
17658* *
17659* Last change 28.12.2006 by S. Roesler. *
17660************************************************************************
17661
17662 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17663 SAVE
17664 PARAMETER ( LINP = 10 ,
17665 & LOUT = 6 ,
17666 & LDAT = 9 )
17667 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
17668 & TINY10=1.0D-10)
17669
17670 LOGICAL LSTART
17671
17672* particle properties (BAMJET index convention)
17673 CHARACTER*8 ANAME
17674 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17675 & IICH(210),IIBAR(210),K1(210),K2(210)
17676* nuclear potential
17677 LOGICAL LFERMI
17678 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17679 & EBINDP(2),EBINDN(2),EPOT(2,210),
17680 & ETACOU(2),ICOUL,LFERMI
17681
17682 DIMENSION IDXPOT(14)
17683* ap an lam alam sig- sig+ sig0 tet0 tet- asig-
17684 DATA IDXPOT / 2, 9, 17, 18, 20, 21, 22, 97, 98, 99,
17685* asig0 asig+ atet0 atet+
17686 & 100, 101, 102, 103/
17687
17688 DATA AN /0.4D0/
17689 DATA LSTART /.TRUE./
17690
17691 IF (MODE.EQ.0) THEN
17692 EBINDP(1) = ZERO
17693 EBINDN(1) = ZERO
17694 EBINDP(2) = ZERO
17695 EBINDN(2) = ZERO
17696 ENDIF
17697 AIP = DBLE(IP)
17698 AIPZ = DBLE(IPZ)
17699 AIT = DBLE(IT)
17700 AITZ = DBLE(ITZ)
17701
17702 FERMIP = AFERP
17703 IF (AFERP.LE.ZERO) FERMIP = FERMOD
17704 FERMIT = AFERT
17705 IF (AFERT.LE.ZERO) FERMIT = FERMOD
17706
17707* Fermi momenta and binding energy for projectile
17708 IF ((IP.GT.1).AND.LFERMI) THEN
17709 IF (MODE.EQ.0) THEN
17710C EBINDP(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ-1)
17711C EBINDN(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ)
17712 BIP = AIP -ONE
17713 BIPZ = AIPZ-ONE
17714 EBINDP(1) = 1.0D-3*(DT_ENERGY(ONE,ONE)+DT_ENERGY(BIP,BIPZ)
17715 & -DT_ENERGY(AIP,AIPZ))
17716 IF (AIP.LE.AIPZ) THEN
17717 EBINDN(1) = EBINDP(1)
17718 WRITE(LOUT,*) ' DT_NCLPOT: AIP.LE.AIPZ (',AIP,AIPZ,')'
17719 ELSE
17720 EBINDN(1) = 1.0D-3*(DT_ENERGY(ONE,ZERO)
17721 & +DT_ENERGY(BIP,AIPZ)-DT_ENERGY(AIP,AIPZ))
17722 ENDIF
17723 ENDIF
17724 PFERMP(1) = FERMIP*AN*(AIPZ/AIP)**0.333333D0
17725 PFERMN(1) = FERMIP*AN*((AIP-AIPZ)/AIP)**0.33333D0
17726 ELSE
17727 PFERMP(1) = ZERO
17728 PFERMN(1) = ZERO
17729 ENDIF
17730* effective nuclear potential for projectile
17731C EPOT(1,1) = PFERMP(1)**2/(2.0D0*AAM(1)) + EBINDP(1)
17732C EPOT(1,8) = PFERMN(1)**2/(2.0D0*AAM(8)) + EBINDN(1)
17733 EPOT(1,1) = SQRT(PFERMP(1)**2+AAM(1)**2) -AAM(1) + EBINDP(1)
17734 EPOT(1,8) = SQRT(PFERMN(1)**2+AAM(8)**2) -AAM(8) + EBINDN(1)
17735
17736* Fermi momenta and binding energy for target
17737 IF ((IT.GT.1).AND.LFERMI) THEN
17738 IF (MODE.EQ.0) THEN
17739C EBINDP(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ-1)
17740C EBINDN(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ)
17741 BIT = AIT -ONE
17742 BITZ = AITZ-ONE
17743
17744 EBINDP(2) = 1.0D-3*(DT_ENERGY(ONE,ONE)+DT_ENERGY(BIT,BITZ)
17745 & -DT_ENERGY(AIT,AITZ))
17746
17747 IF (AIT.LE.AITZ) THEN
17748 EBINDN(2) = EBINDP(2)
17749 WRITE(LOUT,*) ' DT_NCLPOT: AIT.LE.AIPT (',AIT,AIPT,')'
17750 ELSE
17751
17752 EBINDN(2) = 1.0D-3*(DT_ENERGY(ONE,ZERO)
17753 & +DT_ENERGY(BIT,AITZ)-DT_ENERGY(AIT,AITZ))
17754
17755 ENDIF
17756 ENDIF
17757 PFERMP(2) = FERMIT*AN*(AITZ/AIT)**0.333333D0
17758 PFERMN(2) = FERMIT*AN*((AIT-AITZ)/AIT)**0.33333D0
17759 ELSE
17760 PFERMP(2) = ZERO
17761 PFERMN(2) = ZERO
17762 ENDIF
17763* effective nuclear potential for target
17764C EPOT(2,1) = PFERMP(2)**2/(2.0D0*AAM(1)) + EBINDP(2)
17765C EPOT(2,8) = PFERMN(2)**2/(2.0D0*AAM(8)) + EBINDN(2)
17766 EPOT(2,1) = SQRT(PFERMP(2)**2+AAM(1)**2) -AAM(1) + EBINDP(2)
17767 EPOT(2,8) = SQRT(PFERMN(2)**2+AAM(8)**2) -AAM(8) + EBINDN(2)
17768
17769 DO 2 I=1,14
17770 EPOT(1,IDXPOT(I)) = EPOT(1,8)
17771 EPOT(2,IDXPOT(I)) = EPOT(2,8)
17772 2 CONTINUE
17773
17774* Coulomb energy
17775 ETACOU(1) = ZERO
17776 ETACOU(2) = ZERO
17777 IF (ICOUL.EQ.1) THEN
17778 IF (IP.GT.1)
17779 & ETACOU(1) = 0.001116D0*AIPZ/(1.0D0+AIP**0.333D0)
17780 IF (IT.GT.1)
17781 & ETACOU(2) = 0.001116D0*AITZ/(1.0D0+AIT**0.333D0)
17782 ENDIF
17783
17784 IF (LSTART) THEN
17785 WRITE(LOUT,1000) IP,IPZ,IT,ITZ,EBINDP,EBINDN,
17786 & EPOT(1,1)-EBINDP(1),EPOT(2,1)-EBINDP(2),
17787 & EPOT(1,8)-EBINDN(1),EPOT(2,8)-EBINDN(2),
17788 & FERMOD,ETACOU
17789 1000 FORMAT(/,/,1X,'NCLPOT: quantities for inclusion of nuclear'
17790 & ,' effects',/,12X,'---------------------------',
17791 & '----------------',/,/,38X,'projectile',
17792 & ' target',/,/,1X,'Mass number / charge',
17793 & 17X,I3,' /',I3,6X,I3,' /',I3,/,1X,'Binding energy -',
17794 & ' proton (GeV) ',2E14.4,/,17X,'- neutron (GeV)'
17795 & ,1X,2E14.4,/,1X,'Fermi-potential - proton (GeV)',
17796 & 1X,2E14.4,/,17X,'- neutron (GeV) ',2E14.4,/,/,
17797 & 1X,'Scale factor for Fermi-momentum ',F4.2,/,
17798 & /,1X,'Coulomb-energy ',2(E14.4,' GeV '),/,/)
17799 LSTART = .FALSE.
17800 ENDIF
17801
17802 RETURN
17803 END
17804
17805*$ CREATE DT_RESNCL.FOR
17806*COPY DT_RESNCL
17807*
17808*===resncl=============================================================*
17809*
17810 SUBROUTINE DT_RESNCL(EPN,NLOOP,MODE)
17811
17812************************************************************************
17813* Treatment of residual nuclei and nuclear effects. *
17814* MODE = 1 initializations *
17815* = 2 treatment of final state *
17816* This version dated 16.11.95 is written by S. Roesler. *
17817* *
17818* Last change 05.01.2007 by S. Roesler. *
17819************************************************************************
17820
17821 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17822 SAVE
17823 PARAMETER ( LINP = 10 ,
17824 & LOUT = 6 ,
17825 & LDAT = 9 )
17826 PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,THREE=3.D0,TINY3=1.0D-3,
17827 & TINY2=1.0D-2,TINY1=1.0D-1,TINY4=1.0D-4,TINY10=1.0D-10,
17828 & ONETHI=ONE/THREE)
17829 PARAMETER (AMUAMU = 0.93149432D0,
17830 & FM2MM = 1.0D-12,
17831 & RNUCLE = 1.12D0)
17832 PARAMETER ( EMVGEV = 1.0 D-03 )
17833 PARAMETER ( AMUGEV = 0.93149432 D+00 )
17834 PARAMETER ( AMPRTN = 0.93827231 D+00 )
17835 PARAMETER ( AMNTRN = 0.93956563 D+00 )
17836 PARAMETER ( AMELCT = 0.51099906 D-03 )
17837 PARAMETER ( HLFHLF = 0.5D+00 )
17838 PARAMETER ( FERTHO = 14.33 D-09 )
17839 PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
17840 PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
17841 PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
17842
17843* event history
17844 PARAMETER (NMXHKK=200000)
17845 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17846 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17847 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17848* extended event history
17849 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17850 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17851 & IHIST(2,NMXHKK)
17852* particle properties (BAMJET index convention)
17853 CHARACTER*8 ANAME
17854 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17855 & IICH(210),IIBAR(210),K1(210),K2(210)
17856* flags for input different options
17857 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17858 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17859 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17860* nuclear potential
17861 LOGICAL LFERMI
17862 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17863 & EBINDP(2),EBINDN(2),EPOT(2,210),
17864 & ETACOU(2),ICOUL,LFERMI
17865* properties of interacting particles
17866 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
17867* properties of photon/lepton projectiles
17868 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
17869* Lorentz-parameters of the current interaction
17870 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
17871 & UMO,PPCM,EPROJ,PPROJ
17872* treatment of residual nuclei: wounded nucleons
17873 COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
17874* treatment of residual nuclei: 4-momenta
17875 LOGICAL LRCLPR,LRCLTA
17876 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
17877 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
17878
17879 DIMENSION PFSP(4),PSEC(4),PSEC0(4)
17880 DIMENSION PMOMB(5000),IDXB(5000),PMOMM(10000),IDXM(10000),
17881 & IDXCOR(15000),IDXOTH(NMXHKK)
17882
17883 GOTO (1,2) MODE
17884
17885*------- initializations
17886 1 CONTINUE
17887
17888* initialize arrays for residual nuclei
17889 DO 10 K=1,5
17890 IF (K.LE.4) THEN
17891 PFSP(K) = ZERO
17892 ENDIF
17893 PINIPR(K) = ZERO
17894 PINITA(K) = ZERO
17895 PRCLPR(K) = ZERO
17896 PRCLTA(K) = ZERO
17897 TRCLPR(K) = ZERO
17898 TRCLTA(K) = ZERO
17899 10 CONTINUE
17900 SCPOT = ONE
17901 NLOOP = 0
17902
17903* correction of projectile 4-momentum for effective target pot.
17904* and Coulomb-energy (in case of hadron-nucleus interaction only)
17905 IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
17906 EPNI = EPN
17907* Coulomb-energy:
17908* positively charged hadron - check energy for Coloumb pot.
17909 IF (IICH(IJPROJ).EQ.1) THEN
17910 THRESH = ETACOU(2)+AAM(IJPROJ)
17911 IF (EPNI.LE.THRESH) THEN
17912 WRITE(LOUT,1000)
17913 1000 FORMAT(/,1X,'KKINC: WARNING! projectile energy',
17914 & ' below Coulomb threshold - event rejected',/)
17915 ISTHKK(1) = 1
17916 RETURN
17917 ENDIF
17918* negatively charged hadron - increase energy by Coulomb energy
17919 ELSEIF (IICH(IJPROJ).EQ.-1) THEN
17920 EPNI = EPNI+ETACOU(2)
17921 ENDIF
17922 IF ((IJPROJ.EQ.1).OR.(IJPROJ.EQ.8)) THEN
17923* Effective target potential
17924*sr 6.6. binding energy only (to avoid negative exc. energies)
17925C EPNI = EPNI+EPOT(2,IJPROJ)
17926 EBIPOT = EBINDP(2)
17927 IF ((IJPROJ.NE.1).AND.(ABS(EPOT(2,IJPROJ)).GT.5.0D-3))
17928 & EBIPOT = EBINDN(2)
17929 EPNI = EPNI+ABS(EBIPOT)
17930* re-initialization of DTLTRA
17931 DUM1 = ZERO
17932 DUM2 = ZERO
17933 CALL DT_LTINI(IJPROJ,IJTARG,EPNI,DUM1,DUM2,0)
17934 ENDIF
17935 ENDIF
17936
17937* projectile in n-n cms
17938 IF ((IP.LE.1).AND.(IT.GT.1)) THEN
17939 PMASS1 = AAM(IJPROJ)
17940C* VDM assumption
17941C IF (IJPROJ.EQ.7) PMASS1 = AAM(33)
17942 IF (IJPROJ.EQ.7) PMASS1 = AAM(IJPROJ)-SQRT(VIRT)
17943 PMASS2 = AAM(1)
17944 PM1 = SIGN(PMASS1**2,PMASS1)
17945 PM2 = SIGN(PMASS2**2,PMASS2)
17946 PINIPR(4) = (UMO**2-PM2+PM1)/(TWO*UMO)
17947 PINIPR(5) = PMASS1
17948 IF (PMASS1.GT.ZERO) THEN
17949 PINIPR(3) = SQRT((PINIPR(4)-PINIPR(5))
17950 & *(PINIPR(4)+PINIPR(5)))
17951 ELSE
17952 PINIPR(3) = SQRT(PINIPR(4)**2-PM1)
17953 ENDIF
17954 AIT = DBLE(IT)
17955 AITZ = DBLE(ITZ)
17956 PINITA(5) = AIT*AMUAMU+1.0D-3*DT_ENERGY(AIT,AITZ)
17957 CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
17958 ELSEIF ((IP.GT.1).AND.(IT.LE.1)) THEN
17959 PMASS1 = AAM(1)
17960 PMASS2 = AAM(IJTARG)
17961 PM1 = SIGN(PMASS1**2,PMASS1)
17962 PM2 = SIGN(PMASS2**2,PMASS2)
17963 PINITA(4) = (UMO**2-PM1+PM2)/(TWO*UMO)
17964 PINITA(5) = PMASS2
17965 PINITA(3) = -SQRT((PINITA(4)-PINITA(5))
17966 & *(PINITA(4)+PINITA(5)))
17967 AIP = DBLE(IP)
17968 AIPZ = DBLE(IPZ)
17969 PINIPR(5) = AIP*AMUAMU+1.0D-3*DT_ENERGY(AIP,AIPZ)
17970 CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
17971 ELSEIF ((IP.GT.1).AND.(IT.GT.1)) THEN
17972 AIP = DBLE(IP)
17973 AIPZ = DBLE(IPZ)
17974 PINIPR(5) = AIP*AMUAMU+1.0D-3*DT_ENERGY(AIP,AIPZ)
17975 CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
17976 AIT = DBLE(IT)
17977 AITZ = DBLE(ITZ)
17978 PINITA(5) = AIT*AMUAMU+1.0D-3*DT_ENERGY(AIT,AITZ)
17979 CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
17980 ENDIF
17981
17982 RETURN
17983
17984*------- treatment of final state
17985 2 CONTINUE
17986
17987 NLOOP = NLOOP+1
17988 IF (NLOOP.GT.1) SCPOT = 0.10D0
17989C WRITE(LOUT,*) 'event ',NEVHKK,NLOOP,SCPOT
17990
17991 JPW = NPW
17992 JPCW = NPCW
17993 JTW = NTW
17994 JTCW = NTCW
17995 DO 40 K=1,4
17996 PFSP(K) = ZERO
17997 40 CONTINUE
17998
17999 NOB = 0
18000 NOM = 0
18001 DO 900 I=NPOINT(4),NHKK
18002 IDXOTH(I) = -1
18003 IF (ISTHKK(I).EQ.1) THEN
18004 IF (IDBAM(I).EQ.7) GOTO 900
18005 IPOT = 0
18006 IOTHER = 0
18007* particle moving into forward direction
18008 IF (PHKK(3,I).GE.ZERO) THEN
18009* most likely to be effected by projectile potential
18010 IPOT = 1
18011* there is no projectile nucleus, try target
18012 IF ((IP.LE.1).OR.((IP-NPW).LE.1)) THEN
18013 IPOT = 2
18014 IF (IP.GT.1) IOTHER = 1
18015* there is no target nucleus --> skip
18016 IF ((IT.LE.1).OR.((IT-NTW).LE.1)) GOTO 900
18017 ENDIF
18018* particle moving into backward direction
18019 ELSE
18020* most likely to be effected by target potential
18021 IPOT = 2
18022* there is no target nucleus, try projectile
18023 IF ((IT.LE.1).OR.((IT-NTW).LE.1)) THEN
18024 IPOT = 1
18025 IF (IT.GT.1) IOTHER = 1
18026* there is no projectile nucleus --> skip
18027 IF ((IP.LE.1).OR.((IP-NPW).LE.1)) GOTO 900
18028 ENDIF
18029 ENDIF
18030 IFLG = -IPOT
18031* nobam=3: particle is in overlap-region or neither inside proj. nor target
18032* =1: particle is not in overlap-region AND is inside target (2)
18033* =2: particle is not in overlap-region AND is inside projectile (1)
18034* flag particles which are inside the nucleus ipot but not in its
18035* overlap region
18036 IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) IFLG = IPOT
18037 IF (IDBAM(I).NE.0) THEN
18038* baryons: keep all nucleons and all others where flag is set
18039 IF (IIBAR(IDBAM(I)).NE.0) THEN
18040 IF ((IDBAM(I).EQ.1).OR.(IDBAM(I).EQ.8).OR.(IFLG.GT.0))
18041 & THEN
18042 NOB = NOB+1
18043 PMOMB(NOB) = PHKK(3,I)
18044 IDXB(NOB) = SIGN(10000000*IABS(IFLG)
18045 & +1000000*IOTHER+I,IFLG)
18046 ENDIF
18047* mesons: keep only those mesons where flag is set
18048 ELSE
18049 IF (IFLG.GT.0) THEN
18050 NOM = NOM+1
18051 PMOMM(NOM) = PHKK(3,I)
18052 IDXM(NOM) = 10000000*IFLG+1000000*IOTHER+I
18053 ENDIF
18054 ENDIF
18055 ENDIF
18056 ENDIF
18057 900 CONTINUE
18058*
18059* sort particles in the arrays according to increasing long. momentum
18060 CALL DT_SORT1(PMOMB,IDXB,NOB,1,NOB,1)
18061 CALL DT_SORT1(PMOMM,IDXM,NOM,1,NOM,1)
18062*
18063* shuffle indices into one and the same array according to the later
18064* sequence of correction
18065 NCOR = 0
18066 IF (IT.GT.1) THEN
18067 DO 910 I=1,NOB
18068 IF (PMOMB(I).GT.ZERO) GOTO 911
18069 NCOR = NCOR+1
18070 IDXCOR(NCOR) = IDXB(I)
18071 910 CONTINUE
18072 911 CONTINUE
18073 IF (IP.GT.1) THEN
18074 DO 912 J=1,NOB
18075 I = NOB+1-J
18076 IF (PMOMB(I).LT.ZERO) GOTO 913
18077 NCOR = NCOR+1
18078 IDXCOR(NCOR) = IDXB(I)
18079 912 CONTINUE
18080 913 CONTINUE
18081 ELSE
18082 DO 914 I=1,NOB
18083 IF (PMOMB(I).GT.ZERO) THEN
18084 NCOR = NCOR+1
18085 IDXCOR(NCOR) = IDXB(I)
18086 ENDIF
18087 914 CONTINUE
18088 ENDIF
18089 ELSE
18090 DO 915 J=1,NOB
18091 I = NOB+1-J
18092 NCOR = NCOR+1
18093 IDXCOR(NCOR) = IDXB(I)
18094 915 CONTINUE
18095 ENDIF
18096 DO 925 I=1,NOM
18097 IF (PMOMM(I).GT.ZERO) GOTO 926
18098 NCOR = NCOR+1
18099 IDXCOR(NCOR) = IDXM(I)
18100 925 CONTINUE
18101 926 CONTINUE
18102 DO 927 J=1,NOM
18103 I = NOM+1-J
18104 IF (PMOMM(I).LT.ZERO) GOTO 928
18105 NCOR = NCOR+1
18106 IDXCOR(NCOR) = IDXM(I)
18107 927 CONTINUE
18108 928 CONTINUE
18109*
18110C IF (NEVHKK.EQ.484) THEN
18111C WRITE(LOUT,9000) JPCW,JPW-JPCW,JTCW,JTW-JTCW
18112C 9000 FORMAT(1X,'wounded nucleons (proj.-p,n targ.-p,n)',/,4I10)
18113C WRITE(LOUT,9001) NOB,NOM,NCOR
18114C 9001 FORMAT(1X,'produced particles (baryons,mesons,all)',3I10)
18115C WRITE(LOUT,'(/,A)') ' baryons '
18116C DO 950 I=1,NOB
18117CC J = IABS(IDXB(I))
18118CC INDEX = J-IABS(J/10000000)*10000000
18119C IPOT = IABS(IDXB(I))/10000000
18120C IOTHER = IABS(IDXB(I))/1000000-IPOT*10
18121C INDEX = IABS(IDXB(I))-IPOT*10000000-IOTHER*1000000
18122C WRITE(LOUT,9002) I,INDEX,IDXB(I),IDBAM(INDEX),PMOMB(I)
18123C 950 CONTINUE
18124C WRITE(LOUT,'(/,A)') ' mesons '
18125C DO 951 I=1,NOM
18126CC INDEX = IDXM(I)-IABS(IDXM(I)/10000000)*10000000
18127C IPOT = IABS(IDXM(I))/10000000
18128C IOTHER = IABS(IDXM(I))/1000000-IPOT*10
18129C INDEX = IABS(IDXM(I))-IPOT*10000000-IOTHER*1000000
18130C WRITE(LOUT,9002) I,INDEX,IDXM(I),IDBAM(INDEX),PMOMM(I)
18131C 951 CONTINUE
18132C 9002 FORMAT(1X,4I14,E14.5)
18133C WRITE(LOUT,'(/,A)') ' all '
18134C DO 952 I=1,NCOR
18135CC J = IABS(IDXCOR(I))
18136CC INDEX = J-IABS(J/10000000)*10000000
18137CC IPOT = IABS(IDXCOR(I))/10000000
18138C IOTHER = IABS(IDXCOR(I))/1000000-IPOT*10
18139C INDEX = IABS(IDXCOR(I))-IPOT*10000000-IOTHER*1000000
18140C WRITE(LOUT,9003) I,INDEX,IDXCOR(I),IDBAM(INDEX)
18141C 952 CONTINUE
18142C 9003 FORMAT(1X,4I14)
18143C ENDIF
18144*
18145 DO 20 ICOR=1,NCOR
18146 IPOT = IABS(IDXCOR(ICOR))/10000000
18147 IOTHER = IABS(IDXCOR(ICOR))/1000000-IPOT*10
18148 I = IABS(IDXCOR(ICOR))-IPOT*10000000-IOTHER*1000000
18149 IDXOTH(I) = 1
18150
18151 IDSEC = IDBAM(I)
18152
18153* reduction of particle momentum by corresponding nuclear potential
18154* (this applies only if Fermi-momenta are requested)
18155
18156 IF (LFERMI) THEN
18157
18158* Lorentz-transformation into the rest system of the selected nucleus
18159 IMODE = -IPOT-1
18160 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
18161 & PSEC(1),PSEC(2),PSEC(3),PSEC(4),IDSEC,IMODE)
18162 PSECO = SQRT(PSEC(1)**2+PSEC(2)**2+PSEC(3)**2)
18163 AMSEC = SQRT(ABS((PSEC(4)-PSECO)*(PSEC(4)+PSECO)))
18164 JPMOD = 0
18165
18166 CHKLEV = TINY3
18167 IF ((EPROJ.GE.1.0D4).AND.(IDSEC.EQ.7)) CHKLEV = TINY1
18168 IF (EPROJ.GE.2.0D6) CHKLEV = 1.0D0
18169 IF (ABS(AMSEC-AAM(IDSEC)).GT.CHKLEV) THEN
18170 IF (IOULEV(3).GT.0)
18171 & WRITE(LOUT,2000) I,NEVHKK,IDSEC,AMSEC,AAM(IDSEC)
18172 2000 FORMAT(1X,'RESNCL: inconsistent mass of particle',
18173 & ' at entry ',I5,' (evt.',I8,')',/,' IDSEC: ',
18174 & I4,' AMSEC: ',E12.3,' AAM(IDSEC): ',E12.3,/)
18175 GOTO 23
18176 ENDIF
18177
18178 DO 21 K=1,4
18179 PSEC0(K) = PSEC(K)
18180 21 CONTINUE
18181
18182* the correction for nuclear potential effects is applied to as many
18183* p/n as many nucleons were wounded; the momenta of other final state
18184* particles are corrected only if they materialize inside the corresp.
18185* nucleus (here: NOBAM = 1 part. outside proj., = 2 part. outside targ
18186* = 3 part. outside proj. and targ., >=10 in overlapping region)
18187 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) THEN
18188 IF (IPOT.EQ.1) THEN
18189 IF ((JPW.GT.0).AND.(IOTHER.EQ.0)) THEN
18190* this is most likely a wounded nucleon
18191**test
18192C RDIST = SQRT((VHKK(1,IPW(JPW))/FM2MM)**2
18193C & +(VHKK(2,IPW(JPW))/FM2MM)**2
18194C & +(VHKK(3,IPW(JPW))/FM2MM)**2)
18195C RAD = RNUCLE*DBLE(IP)**ONETHI
18196C FDEN = 1.4D0*DT_DENSIT(IP,RDIST,RAD)
18197C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
18198**
18199 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18200 JPW = JPW-1
18201 JPMOD = 1
18202 ELSE
18203* correct only if part. was materialized inside nucleus
18204* and if it is ouside the overlapping region
18205 IF ((NOBAM(I).NE.1).AND.(NOBAM(I).LT.3)) THEN
18206 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18207 JPMOD = 1
18208 ENDIF
18209 ENDIF
18210 ELSEIF (IPOT.EQ.2) THEN
18211 IF ((JTW.GT.0).AND.(IOTHER.EQ.0)) THEN
18212* this is most likely a wounded nucleon
18213**test
18214C RDIST = SQRT((VHKK(1,ITW(JTW))/FM2MM)**2
18215C & +(VHKK(2,ITW(JTW))/FM2MM)**2
18216C & +(VHKK(3,ITW(JTW))/FM2MM)**2)
18217C RAD = RNUCLE*DBLE(IT)**ONETHI
18218C FDEN = 1.4D0*DT_DENSIT(IT,RDIST,RAD)
18219C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
18220**
18221 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18222 JTW = JTW-1
18223 JPMOD = 1
18224 ELSE
18225* correct only if part. was materialized inside nucleus
18226 IF ((NOBAM(I).NE.2).AND.(NOBAM(I).LT.3)) THEN
18227 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18228 JPMOD = 1
18229 ENDIF
18230 ENDIF
18231 ENDIF
18232 ELSE
18233 IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) THEN
18234 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18235 JPMOD = 1
18236 ENDIF
18237 ENDIF
18238
18239 IF (NLOOP.EQ.1) THEN
18240* Coulomb energy correction:
18241* the treatment of Coulomb potential correction is similar to the
18242* one for nuclear potential
18243 IF (IDSEC.EQ.1) THEN
18244 IF ((IPOT.EQ.1).AND.(JPCW.GT.0)) THEN
18245 JPCW = JPCW-1
18246 ELSEIF ((IPOT.EQ.2).AND.(JTCW.GT.0)) THEN
18247 JTCW = JTCW-1
18248 ELSE
18249 IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
18250 ENDIF
18251 ELSE
18252 IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
18253 ENDIF
18254 IF (IICH(IDSEC).EQ.1) THEN
18255* pos. particles: check if they are able to escape Coulomb potential
18256 IF (PSEC(4).LT.AMSEC+ETACOU(IPOT)) THEN
18257 ISTHKK(I) = 14+IPOT
18258 IF (ISTHKK(I).EQ.15) THEN
18259 DO 26 K=1,4
18260 PHKK(K,I) = PSEC0(K)
18261 TRCLPR(K) = TRCLPR(K)+PSEC0(K)
18262 26 CONTINUE
18263 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
18264 IF (IDSEC.EQ.1) NPCW = NPCW-1
18265 ELSEIF (ISTHKK(I).EQ.16) THEN
18266 DO 27 K=1,4
18267 PHKK(K,I) = PSEC0(K)
18268 TRCLTA(K) = TRCLTA(K)+PSEC0(K)
18269 27 CONTINUE
18270 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
18271 IF (IDSEC.EQ.1) NTCW = NTCW-1
18272 ENDIF
18273 GOTO 20
18274 ENDIF
18275 ELSEIF (IICH(IDSEC).EQ.-1) THEN
18276* neg. particles: decrease energy by Coulomb-potential
18277 PSEC(4) = PSEC(4)-ETACOU(IPOT)
18278 JPMOD = 1
18279 ENDIF
18280 ENDIF
18281
18282 25 CONTINUE
18283
18284 IF (PSEC(4).LT.AMSEC) THEN
18285 IF (IOULEV(6).GT.0)
18286 & WRITE(LOUT,2001) I,IDSEC,PSEC(4),AMSEC
18287 2001 FORMAT(1X,'KKINC: particle at DTEVT1-pos. ',I5,
18288 & ' is not allowed to escape nucleus',/,
18289 & 8X,'id : ',I3,' reduced energy: ',E15.4,
18290 & ' mass: ',E12.3)
18291 ISTHKK(I) = 14+IPOT
18292 IF (ISTHKK(I).EQ.15) THEN
18293 DO 28 K=1,4
18294 PHKK(K,I) = PSEC0(K)
18295 TRCLPR(K) = TRCLPR(K)+PSEC0(K)
18296 28 CONTINUE
18297 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
18298 IF (IDSEC.EQ.1) NPCW = NPCW-1
18299 ELSEIF (ISTHKK(I).EQ.16) THEN
18300 DO 29 K=1,4
18301 PHKK(K,I) = PSEC0(K)
18302 TRCLTA(K) = TRCLTA(K)+PSEC0(K)
18303 29 CONTINUE
18304 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
18305 IF (IDSEC.EQ.1) NTCW = NTCW-1
18306 ENDIF
18307 GOTO 20
18308 ENDIF
18309
18310 IF (JPMOD.EQ.1) THEN
18311 PSECN = SQRT( (PSEC(4)-AMSEC)*(PSEC(4)+AMSEC) )
18312* 4-momentum after correction for nuclear potential
18313 DO 22 K=1,3
18314 PSEC(K) = PSEC(K)*PSECN/PSECO
18315 22 CONTINUE
18316
18317* store recoil momentum from particles escaping the nuclear potentials
18318 DO 30 K=1,4
18319 IF (IPOT.EQ.1) THEN
18320 TRCLPR(K) = TRCLPR(K)+PSEC0(K)-PSEC(K)
18321 ELSEIF (IPOT.EQ.2) THEN
18322 TRCLTA(K) = TRCLTA(K)+PSEC0(K)-PSEC(K)
18323 ENDIF
18324 30 CONTINUE
18325
18326* transform momentum back into n-n cms
18327 IMODE = IPOT+1
18328 CALL DT_LTRANS(PSEC(1),PSEC(2),PSEC(3),PSEC(4),
18329 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
18330 & IDSEC,IMODE)
18331 ENDIF
18332
18333 ENDIF
18334
18335 23 CONTINUE
18336 DO 31 K=1,4
18337 PFSP(K) = PFSP(K)+PHKK(K,I)
18338 31 CONTINUE
18339
18340 20 CONTINUE
18341
18342 DO 33 I=NPOINT(4),NHKK
18343 IF ((ISTHKK(I).EQ.1).AND.(IDXOTH(I).LT.0)) THEN
18344 PFSP(1) = PFSP(1)+PHKK(1,I)
18345 PFSP(2) = PFSP(2)+PHKK(2,I)
18346 PFSP(3) = PFSP(3)+PHKK(3,I)
18347 PFSP(4) = PFSP(4)+PHKK(4,I)
18348 ENDIF
18349 33 CONTINUE
18350
18351 DO 34 K=1,5
18352 PRCLPR(K) = TRCLPR(K)
18353 PRCLTA(K) = TRCLTA(K)
18354 34 CONTINUE
18355
18356 IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
18357* hadron-nucleus interactions: get residual momentum from energy-
18358* momentum conservation
18359 DO 32 K=1,4
18360 PRCLPR(K) = ZERO
18361 PRCLTA(K) = PINIPR(K)+PINITA(K)-PFSP(K)
18362 32 CONTINUE
18363 ELSE
18364* nucleus-hadron, nucleus-nucleus: get residual momentum from
18365* accumulated recoil momenta of particles leaving the spectators
18366* transform accumulated recoil momenta of residual nuclei into
18367* n-n cms
18368 PZI = PRCLPR(3)
18369 PEI = PRCLPR(4)
18370 CALL DT_LTNUC(PZI,PEI,PRCLPR(3),PRCLPR(4),2)
18371 PZI = PRCLTA(3)
18372 PEI = PRCLTA(4)
18373 CALL DT_LTNUC(PZI,PEI,PRCLTA(3),PRCLTA(4),3)
18374C IF (IP.GT.1) THEN
18375 PRCLPR(3) = PRCLPR(3)+PINIPR(3)
18376 PRCLPR(4) = PRCLPR(4)+PINIPR(4)
18377C ENDIF
18378 IF (IT.GT.1) THEN
18379 PRCLTA(3) = PRCLTA(3)+PINITA(3)
18380 PRCLTA(4) = PRCLTA(4)+PINITA(4)
18381 ENDIF
18382 ENDIF
18383
18384* check momenta of residual nuclei
18385 IF (LEMCCK) THEN
18386 CALL DT_EVTEMC(-PINIPR(1),-PINIPR(2),-PINIPR(3),-PINIPR(4),
18387 & 1,IDUM,IDUM)
18388 CALL DT_EVTEMC(-PINITA(1),-PINITA(2),-PINITA(3),-PINITA(4),
18389 & 2,IDUM,IDUM)
18390 CALL DT_EVTEMC(PRCLPR(1),PRCLPR(2),PRCLPR(3),PRCLPR(4),
18391 & 2,IDUM,IDUM)
18392 CALL DT_EVTEMC(PRCLTA(1),PRCLTA(2),PRCLTA(3),PRCLTA(4),
18393 & 2,IDUM,IDUM)
18394 CALL DT_EVTEMC(PFSP(1),PFSP(2),PFSP(3),PFSP(4),2,IDUM,IDUM)
18395**sr 19.12. changed to avoid output when used with phojet
18396C CHKLEV = TINY3
18397 CHKLEV = TINY1
18398 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,501,IREJ1)
18399C IF ((NEVHKK.EQ.409).OR.(NEVHKK.EQ.460).OR.(NEVHKK.EQ.765))
18400C & CALL DT_EVTOUT(4)
18401 IF (IREJ1.GT.0) RETURN
18402 ENDIF
18403
18404 RETURN
18405 END
18406
18407*$ CREATE DT_SCN4BA.FOR
18408*COPY DT_SCN4BA
18409*
18410*===scn4ba=============================================================*
18411*
18412 SUBROUTINE DT_SCN4BA
18413
18414************************************************************************
18415* SCan /DTEVT1/ 4 BAryons which are not able to escape nuclear pot. *
18416* This version dated 12.12.95 is written by S. Roesler. *
18417************************************************************************
18418
18419 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18420 SAVE
18421 PARAMETER ( LINP = 10 ,
18422 & LOUT = 6 ,
18423 & LDAT = 9 )
18424 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
18425 & TINY10=1.0D-10)
18426
18427* event history
18428 PARAMETER (NMXHKK=200000)
18429 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18430 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18431 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18432* extended event history
18433 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18434 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18435 & IHIST(2,NMXHKK)
18436* particle properties (BAMJET index convention)
18437 CHARACTER*8 ANAME
18438 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18439 & IICH(210),IIBAR(210),K1(210),K2(210)
18440* properties of interacting particles
18441 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
18442* nuclear potential
18443 LOGICAL LFERMI
18444 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18445 & EBINDP(2),EBINDN(2),EPOT(2,210),
18446 & ETACOU(2),ICOUL,LFERMI
18447* treatment of residual nuclei: wounded nucleons
18448 COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
18449* treatment of residual nuclei: 4-momenta
18450 LOGICAL LRCLPR,LRCLTA
18451 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18452 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18453
18454 DIMENSION PLAB(2,5),PCMS(4)
18455
18456 IREJ = 0
18457
18458* get number of wounded nucleons
18459 NPW = 0
18460 NPW0 = 0
18461 NPCW = 0
18462 NPSTCK = 0
18463 NTW = 0
18464 NTW0 = 0
18465 NTCW = 0
18466 NTSTCK = 0
18467
18468 ISGLPR = 0
18469 ISGLTA = 0
18470 LRCLPR = .FALSE.
18471 LRCLTA = .FALSE.
18472
18473C DO 2 I=1,NHKK
18474 DO 2 I=1,NPOINT(1)
18475* projectile nucleons wounded in primary interaction and in fzc
18476 IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.17)) THEN
18477 NPW = NPW+1
18478 IPW(NPW) = I
18479 NPSTCK = NPSTCK+1
18480 IF (IDHKK(I).EQ.2212) NPCW = NPCW+1
18481 IF (ISTHKK(I).EQ.11) NPW0 = NPW0+1
18482C IF (IP.GT.1) THEN
18483 DO 5 K=1,4
18484 TRCLPR(K) = TRCLPR(K)-PHKK(K,I)
18485 5 CONTINUE
18486C ENDIF
18487* target nucleons wounded in primary interaction and in fzc
18488 ELSEIF ((ISTHKK(I).EQ.12).OR.(ISTHKK(I).EQ.18)) THEN
18489 NTW = NTW+1
18490 ITW(NTW) = I
18491 NTSTCK = NTSTCK+1
18492 IF (IDHKK(I).EQ.2212) NTCW = NTCW+1
18493 IF (ISTHKK(I).EQ.12) NTW0 = NTW0+1
18494 IF (IT.GT.1) THEN
18495 DO 6 K=1,4
18496 TRCLTA(K) = TRCLTA(K)-PHKK(K,I)
18497 6 CONTINUE
18498 ENDIF
18499 ELSEIF (ISTHKK(I).EQ.13) THEN
18500 ISGLPR = I
18501 ELSEIF (ISTHKK(I).EQ.14) THEN
18502 ISGLTA = I
18503 ENDIF
18504 2 CONTINUE
18505
18506 DO 11 I=NPOINT(4),NHKK
18507* baryons which are unable to escape the nuclear potential of proj.
18508 IF (ISTHKK(I).EQ.15) THEN
18509 ISGLPR = I
18510 NPSTCK = NPSTCK-1
18511 IF (IIBAR(IDBAM(I)).NE.0) THEN
18512 NPW = NPW-1
18513 IF (IICH(IDBAM(I)).GT.0) NPCW = NPCW-1
18514 ENDIF
18515 DO 7 K=1,4
18516 TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
18517 7 CONTINUE
18518* baryons which are unable to escape the nuclear potential of targ.
18519 ELSEIF (ISTHKK(I).EQ.16) THEN
18520 ISGLTA = I
18521 NTSTCK = NTSTCK-1
18522 IF (IIBAR(IDBAM(I)).NE.0) THEN
18523 NTW = NTW-1
18524 IF (IICH(IDBAM(I)).GT.0) NTCW = NTCW-1
18525 ENDIF
18526 DO 8 K=1,4
18527 TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
18528 8 CONTINUE
18529 ENDIF
18530 11 CONTINUE
18531
18532* residual nuclei so far
18533 IRESP = IP-NPSTCK
18534 IREST = IT-NTSTCK
18535
18536* ckeck for "residual nuclei" consisting of one nucleon only
18537* treat it as final state particle
18538 IF (IRESP.EQ.1) THEN
18539 ID = IDBAM(ISGLPR)
18540 IST = ISTHKK(ISGLPR)
18541 CALL DT_LTRANS(PHKK(1,ISGLPR),PHKK(2,ISGLPR),
18542 & PHKK(3,ISGLPR),PHKK(4,ISGLPR),
18543 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,2)
18544 IF (IST.EQ.13) THEN
18545 ISTHKK(ISGLPR) = 11
18546 ELSE
18547 ISTHKK(ISGLPR) = 2
18548 ENDIF
18549 CALL DT_EVTPUT(1,IDHKK(ISGLPR),ISGLPR,0,
18550 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),
18551 & IDRES(ISGLPR),IDXRES(ISGLPR),IDCH(ISGLPR))
18552 NOBAM(NHKK) = NOBAM(ISGLPR)
18553 JDAHKK(1,ISGLPR) = NHKK
18554 DO 21 K=1,4
18555 TRCLPR(K) = TRCLPR(K)-PHKK(K,ISGLPR)
18556 21 CONTINUE
18557 ENDIF
18558 IF (IREST.EQ.1) THEN
18559 ID = IDBAM(ISGLTA)
18560 IST = ISTHKK(ISGLTA)
18561 CALL DT_LTRANS(PHKK(1,ISGLTA),PHKK(2,ISGLTA),
18562 & PHKK(3,ISGLTA),PHKK(4,ISGLTA),
18563 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,3)
18564 IF (IST.EQ.14) THEN
18565 ISTHKK(ISGLTA) = 12
18566 ELSE
18567 ISTHKK(ISGLTA) = 2
18568 ENDIF
18569 CALL DT_EVTPUT(1,IDHKK(ISGLTA),ISGLTA,0,
18570 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),
18571 & IDRES(ISGLTA),IDXRES(ISGLTA),IDCH(ISGLTA))
18572 NOBAM(NHKK) = NOBAM(ISGLTA)
18573 JDAHKK(1,ISGLTA) = NHKK
18574 DO 22 K=1,4
18575 TRCLTA(K) = TRCLTA(K)-PHKK(K,ISGLTA)
18576 22 CONTINUE
18577 ENDIF
18578
18579* get nuclear potential corresp. to the residual nucleus
18580 IPRCL = IP -NPW
18581 IPZRCL = IPZ-NPCW
18582 ITRCL = IT -NTW
18583 ITZRCL = ITZ-NTCW
18584 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
18585
18586* baryons unable to escape the nuclear potential are treated as
18587* excited nucleons (ISTHKK=15,16)
18588 DO 3 I=NPOINT(4),NHKK
18589 IF (ISTHKK(I).EQ.1) THEN
18590 ID = IDBAM(I)
18591 IF ( ((ID.EQ.1).OR.(ID.EQ.8)).AND.(NOBAM(I).NE.3) ) THEN
18592* final state n and p not being outside of both nuclei are considered
18593 NPOTP = 1
18594 NPOTT = 1
18595 IF ( (IP.GT.1) .AND.(IRESP.GT.1).AND.
18596 & (NOBAM(I).NE.1).AND.(NPW.GT.0) ) THEN
18597* Lorentz-trsf. into proj. rest sys. for those being inside proj.
18598 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
18599 & PHKK(4,I),PLAB(1,1),PLAB(1,2),PLAB(1,3),
18600 & PLAB(1,4),ID,-2)
18601 PLABT = SQRT(PLAB(1,1)**2+PLAB(1,2)**2+PLAB(1,3)**2)
18602 PLAB(1,5) = SQRT(ABS( (PLAB(1,4)-PLABT)*
18603 & (PLAB(1,4)+PLABT) ))
18604 EKIN = PLAB(1,4)-PLAB(1,5)
18605 IF (EKIN.LE.EPOT(1,ID)) NPOTP = 15
18606 IF ((ID.EQ.1).AND.(NPCW.LE.0)) NPOTP = 1
18607 ENDIF
18608 IF ( (IT.GT.1) .AND.(IREST.GT.1).AND.
18609 & (NOBAM(I).NE.2).AND.(NTW.GT.0) ) THEN
18610* Lorentz-trsf. into targ. rest sys. for those being inside targ.
18611 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
18612 & PHKK(4,I),PLAB(2,1),PLAB(2,2),PLAB(2,3),
18613 & PLAB(2,4),ID,-3)
18614 PLABT = SQRT(PLAB(2,1)**2+PLAB(2,2)**2+PLAB(2,3)**2)
18615 PLAB(2,5) = SQRT(ABS( (PLAB(2,4)-PLABT)*
18616 & (PLAB(2,4)+PLABT) ))
18617 EKIN = PLAB(2,4)-PLAB(2,5)
18618 IF (EKIN.LE.EPOT(2,ID)) NPOTT = 16
18619 IF ((ID.EQ.1).AND.(NTCW.LE.0)) NPOTT = 1
18620 ENDIF
18621 IF (PHKK(3,I).GE.ZERO) THEN
18622 ISTHKK(I) = NPOTT
18623 IF (NPOTP.NE.1) ISTHKK(I) = NPOTP
18624 ELSE
18625 ISTHKK(I) = NPOTP
18626 IF (NPOTT.NE.1) ISTHKK(I) = NPOTT
18627 ENDIF
18628 IF (ISTHKK(I).NE.1) THEN
18629 J = ISTHKK(I)-14
18630 DO 4 K=1,5
18631 PHKK(K,I) = PLAB(J,K)
18632 4 CONTINUE
18633 IF (ISTHKK(I).EQ.15) THEN
18634 NPW = NPW-1
18635 IF (ID.EQ.1) NPCW = NPCW-1
18636 DO 9 K=1,4
18637 TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
18638 9 CONTINUE
18639 ELSEIF (ISTHKK(I).EQ.16) THEN
18640 NTW = NTW-1
18641 IF (ID.EQ.1) NTCW = NTCW-1
18642 DO 10 K=1,4
18643 TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
18644 10 CONTINUE
18645 ENDIF
18646 ENDIF
18647 ENDIF
18648 ENDIF
18649 3 CONTINUE
18650
18651* again: get nuclear potential corresp. to the residual nucleus
18652 IPRCL = IP -NPW
18653 IPZRCL = IPZ-NPCW
18654 ITRCL = IT -NTW
18655 ITZRCL = ITZ-NTCW
18656c AFERP = 1.2D0*FERMOD*(ONE+(DBLE(IP+10-NPW0)/DBLE(IP+10))**1.1D0)
18657cC AFERP = 1.21D0*FERMOD*(ONE+(DBLE(IP+40-NPW0)/DBLE(IP+40))**1.1D0)
18658c & *(0.94D0+0.3D0*EXP(-DBLE(NPW0)/5.0D0)) /2.0D0
18659C AFERP = 0.0D0
18660c AFERT = 1.2D0*FERMOD*(ONE+(DBLE(IT+10-NTW0)/DBLE(IT+10))**1.1D0)
18661cC AFERT = 1.21D0*FERMOD*(ONE+(DBLE(IT+40-NTW0)/DBLE(IT+40))**1.1D0)
18662c & *(0.94D0+0.3D0*EXP(-DBLE(NTW0)/5.0D0)) /2.0D0
18663C AFERT = 0.0D0
18664C IF (AFERP.LT.FERMOD) AFERP = FERMOD+0.1
18665C IF (AFERT.LT.FERMOD) AFERT = FERMOD+0.1
18666C IF (AFERP.GT.0.85D0) AFERP = 0.85D0
18667C IF (AFERT.GT.0.85D0) AFERT = 0.85D0
18668 AFERP = FERMOD+0.1D0
18669 AFERT = FERMOD+0.1D0
18670
18671 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,AFERP,AFERT,1)
18672
18673 RETURN
18674 END
18675
18676*$ CREATE DT_FICONF.FOR
18677*COPY DT_FICONF
18678*
18679*===ficonf=============================================================*
18680*
18681 SUBROUTINE DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ)
18682
18683************************************************************************
18684* Treatment of FInal CONFiguration including evaporation, fission and *
18685* Fermi-break-up (for light nuclei only). *
18686* Adopted from the original routine FINALE and extended to residual *
18687* projectile nuclei. *
18688* This version dated 12.12.95 is written by S. Roesler. *
18689* *
18690* Last change 27.12.2006 by S. Roesler. *
18691************************************************************************
18692
18693 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18694 SAVE
18695 PARAMETER ( LINP = 10 ,
18696 & LOUT = 6 ,
18697 & LDAT = 9 )
18698 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
18699 PARAMETER (ANGLGB=5.0D-16)
18700 PARAMETER (AMUAMU=0.93149432D0,AMELEC=0.51099906D-3)
18701
18702* event history
18703 PARAMETER (NMXHKK=200000)
18704 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18705 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18706 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18707* extended event history
18708 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18709 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18710 & IHIST(2,NMXHKK)
18711* rejection counter
18712 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
18713 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
18714 & IREXCI(3),IRDIFF(2),IRINC
18715* central particle production, impact parameter biasing
18716 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
18717* particle properties (BAMJET index convention)
18718 CHARACTER*8 ANAME
18719 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18720 & IICH(210),IIBAR(210),K1(210),K2(210)
18721* treatment of residual nuclei: 4-momenta
18722 LOGICAL LRCLPR,LRCLTA
18723 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18724 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18725* treatment of residual nuclei: properties of residual nuclei
18726 COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
18727 & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
18728 & NTOTFI(2),NPROFI(2)
18729* statistics: residual nuclei
18730 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
18731 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
18732 & NINCST(2,4),NINCEV(2),
18733 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
18734 & NRESPB(2),NRESCH(2),NRESEV(4),
18735 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
18736 & NEVAFI(2,2)
18737* flags for input different options
18738 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18739 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18740 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18741* (original name: FINUC)
18742 PARAMETER (MXP=999)
18743 COMMON /FKFINU/ CXR (MXP), CYR (MXP), CZR (MXP),
18744 & CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP),
18745 & TKI (MXP), PLR (MXP), WEI (MXP),
18746 & TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP,
18747 & KPART (MXP)
18748* (original name: RESNUC)
18749 LOGICAL LRNFSS, LFRAGM
18750 COMMON /FKRESN/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
18751 & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
18752 & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES,
18753 & PYRES, PZRES, PTRES2, KTARP, KTARN, IGREYP,
18754 & IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,
18755 & ICRES, IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU,
18756 & IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG,
18757 & IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS,
18758 & LFRAGM
18759 COMMON /FKNDAT/ AV0WEL, APFRMX, AEFRMX, AEFRMA,
18760 & RDSNUC, V0WELL (2), PFRMMX (2), EFRMMX (2),
18761 & EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2),
18762 & VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2),
18763 & PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2),
18764 & EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2),
18765 & ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV ,
18766 & AMRCSQ , ATO1O3 , ZTO1O3 , ELBNDE (0:100)
18767* (original name: PAREVT)
18768 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
18769 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
18770 PARAMETER ( NALLWP = 39 )
18771 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
18772 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
18773 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
18774 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
18775* event flag
18776 COMMON /DTEVNO/ NEVENT,ICASCA
18777
18778 DIMENSION INUC(2),IDXPAR(2),IDPAR(2),AIF(2),AIZF(2),AMRCL(2),
18779 & PRCL(2,4),MO1(2),MO2(2),VRCL(2,4),WRCL(2,4),
18780 & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4)
18781
18782 DIMENSION EXPNUC(2),EXC(2,260),NEXC(2,260)
18783 LOGICAL LLCPOT
18784 DATA EXC,NEXC /520*ZERO,520*0/
18785 DATA EXPNUC /4.0D-3,4.0D-3/
18786
18787 IREJ = 0
18788 LRCLPR = .FALSE.
18789 LRCLTA = .FALSE.
18790
18791* skip residual nucleus treatment if not requested or in case
18792* of central collisions
18793 IF ((.NOT.LEVPRT).OR.(ICENTR.GT.0).OR.(ICENTR.EQ.-1)) RETURN
18794
18795 DO 1 K=1,2
18796 IDPAR(K) = 0
18797 IDXPAR(K)= 0
18798 NTOT(K) = 0
18799 NTOTFI(K)= 0
18800 NPRO(K) = 0
18801 NPROFI(K)= 0
18802 NN(K) = 0
18803 NH(K) = 0
18804 NHPOS(K) = 0
18805 NQ(K) = 0
18806 EEXC(K) = ZERO
18807 MO1(K) = 0
18808 MO2(K) = 0
18809 DO 2 I=1,4
18810 VRCL(K,I) = ZERO
18811 WRCL(K,I) = ZERO
18812 2 CONTINUE
18813 1 CONTINUE
18814 NFSP = 0
18815 INUC(1) = IP
18816 INUC(2) = IT
18817
18818 DO 3 I=1,NHKK
18819
18820* number of final state particles
18821 IF (ABS(ISTHKK(I)).EQ.1) THEN
18822 NFSP = NFSP+1
18823 IDFSP = IDBAM(I)
18824 ENDIF
18825
18826* properties of remaining nucleon configurations
18827 KF = 0
18828 IF ((ISTHKK(I).EQ.13).OR.(ISTHKK(I).EQ.15)) KF = 1
18829 IF ((ISTHKK(I).EQ.14).OR.(ISTHKK(I).EQ.16)) KF = 2
18830 IF (KF.GT.0) THEN
18831 IF (MO1(KF).EQ.0) MO1(KF) = I
18832 MO2(KF) = I
18833* position of residual nucleus = average position of nucleons
18834 DO 4 K=1,4
18835 VRCL(KF,K) = VRCL(KF,K)+VHKK(K,I)
18836 WRCL(KF,K) = WRCL(KF,K)+WHKK(K,I)
18837 4 CONTINUE
18838* total number of particles contributing to each residual nucleus
18839 NTOT(KF) = NTOT(KF)+1
18840 IDTMP = IDBAM(I)
18841 IDXTMP = I
18842* total charge of residual nuclei
18843 NQ(KF) = NQ(KF)+IICH(IDTMP)
18844* number of protons
18845 IF (IDHKK(I).EQ.2212) THEN
18846 NPRO(KF) = NPRO(KF)+1
18847* number of neutrons
18848 ELSEIF (IDHKK(I).EQ.2112) THEN
18849 NN(KF) = NN(KF)+1
18850 ELSE
18851* number of baryons other than n, p
18852 IF (IIBAR(IDTMP).EQ.1) THEN
18853 NH(KF) = NH(KF)+1
18854 IF (IICH(IDTMP).EQ.1) NHPOS(KF) = NHPOS(KF)+1
18855 ELSE
18856* any other mesons (status set to 1)
18857C WRITE(LOUT,1002) KF,IDTMP
18858C1002 FORMAT(1X,'FICONF: residual nucleus ',I2,
18859C & ' containing meson ',I4,', status set to 1')
18860 ISTHKK(I) = 1
18861 IDTMP = IDPAR(KF)
18862 IDXTMP = IDXPAR(KF)
18863 NTOT(KF) = NTOT(KF)-1
18864 ENDIF
18865 ENDIF
18866 IDPAR(KF) = IDTMP
18867 IDXPAR(KF) = IDXTMP
18868 ENDIF
18869 3 CONTINUE
18870
18871* reject elastic events (def: one final state particle = projectile)
18872 IF ((IP.EQ.1).AND.(NFSP.EQ.1).AND.(IDFSP.EQ.IJPROJ)) THEN
18873 IREXCI(3) = IREXCI(3)+1
18874 GOTO 9999
18875C RETURN
18876 ENDIF
18877
18878* check if one nucleus disappeared..
18879C IF ((IP.GT.1).AND.(NTOT(1).EQ.0).AND.(NTOT(2).NE.0)) THEN
18880C DO 5 K=1,4
18881C PRCLTA(K) = PRCLTA(K)+PRCLPR(K)
18882C PRCLPR(K) = ZERO
18883C 5 CONTINUE
18884C ELSEIF ((IT.GT.1).AND.(NTOT(2).EQ.0).AND.(NTOT(1).NE.0)) THEN
18885C DO 6 K=1,4
18886C PRCLPR(K) = PRCLPR(K)+PRCLTA(K)
18887C PRCLTA(K) = ZERO
18888C 6 CONTINUE
18889C ENDIF
18890
18891 ICOR = 0
18892 INORCL = 0
18893 DO 7 I=1,2
18894 DO 8 K=1,4
18895* get the average of the nucleon positions
18896 VRCL(I,K) = VRCL(I,K)/MAX(NTOT(I),1)
18897 WRCL(I,K) = WRCL(I,K)/MAX(NTOT(I),1)
18898 IF (I.EQ.1) PRCL(1,K) = PRCLPR(K)
18899 IF (I.EQ.2) PRCL(2,K) = PRCLTA(K)
18900 8 CONTINUE
18901* mass number and charge of residual nuclei
18902 AIF(I) = DBLE(NTOT(I))
18903 AIZF(I) = DBLE(NPRO(I)+NHPOS(I))
18904 IF (NTOT(I).GT.1) THEN
18905* masses of residual nuclei in ground state
18906 AMRCL0(I) = AIF(I)*AMUAMU+1.0D-3*DT_ENERGY(AIF(I),AIZF(I))
18907* masses of residual nuclei
18908 PTORCL = SQRT(PRCL(I,1)**2+PRCL(I,2)**2+PRCL(I,3)**2)
18909 AMRCL(I) = (PRCL(I,4)-PTORCL)*(PRCL(I,4)+PTORCL)
18910 IF (AMRCL(I).GT.ZERO) AMRCL(I) = SQRT(AMRCL(I))
18911*
18912* M_res^2 < 0 : configuration not allowed
18913*
18914* a) re-calculate E_exc with scaled nuclear potential
18915* (conditional jump to label 9998)
18916* b) or reject event if N_loop(max) is exceeded
18917* (conditional jump to label 9999)
18918*
18919 IF (AMRCL(I).LE.ZERO) THEN
18920 IF (IOULEV(3).GT.0)
18921 & WRITE(LOUT,1000) I,PRCL(I,1),PRCL(I,2),PRCL(I,3),
18922 & PRCL(I,4),NTOT
18923 1000 FORMAT(1X,'warning! negative excitation energy',/,
18924 & I4,4E15.4,2I4)
18925 AMRCL(I) = ZERO
18926 EEXC(I) = ZERO
18927 IF (NLOOP.LE.500) THEN
18928 GOTO 9998
18929 ELSE
18930 IREXCI(2) = IREXCI(2)+1
18931 GOTO 9999
18932 ENDIF
18933*
18934* 0 < M_res < M_res0 : mass below ground-state mass
18935*
18936* a) we had residual nuclei with mass N_tot and reasonable E_exc
18937* before- assign average E_exc of those configurations to this
18938* one ( Nexc(i,N_tot) > 0 )
18939* b) or (and this applies always if run in transport codes) go up
18940* one mass number and
18941* i) if mass now larger than proj/targ mass or if run in
18942* transport codes assign average E_exc per wounded nucleon
18943* x number of wounded nucleons (Inuc-Ntot)
18944* ii) or assign average E_exc of those configurations to this
18945* one ( Nexc(i,m) > 0 )
18946*
18947 ELSEIF ((AMRCL(I).GT.ZERO).AND.(AMRCL(I).LT.AMRCL0(I)))
18948 & THEN
18949 M = MIN(NTOT(I),260)
18950 IF (NEXC(I,M).GT.0) THEN
18951 AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
18952 ELSE
18953 70 CONTINUE
18954 M = M+1
18955**sr corrected 27.12.06
18956* IF (M.GE.INUC(I)) THEN
18957* AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I))
18958 IF ((M.GE.INUC(I)).OR.(ICASCA.GT.0)) THEN
18959 IF ( INUC (I) .GT. NTOT (I) ) THEN
18960 AMRCL(I) = AMRCL0(I)
18961 & + EXPNUC(I)*DBLE(MAX(INUC(I)-NTOT(I),0))
18962 ELSE
18963 AMRCL(I) = AMRCL0(I) + 0.5D+00 * EXPNUC(I)
18964 END IF
18965**
18966 ELSE
18967 IF (NEXC(I,M).GT.0) THEN
18968 AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
18969 ELSE
18970 GOTO 70
18971 ENDIF
18972 ENDIF
18973 ENDIF
18974 EEXC(I) = AMRCL(I)-AMRCL0(I)
18975 ICOR = ICOR+I
18976*
18977* M_res > 2.5 x M_res0 : unreasonably(?) high E_exc
18978*
18979* a) re-calculate E_exc with scaled nuclear potential
18980* (conditional jump to label 9998)
18981* b) or reject event if N_loop(max) is exceeded
18982* (conditional jump to label 9999)
18983*
18984*
18985 ELSEIF (AMRCL(I).GE.2.5D0*AMRCL0(I)) THEN
18986 IF (IOULEV(3).GT.0)
18987 & WRITE(LOUT,1004) I,AMRCL(I),AMRCL0(I),NTOT,NEVHKK
18988 1004 FORMAT(1X,'warning! too high excitation energy',/,
18989 & I4,1P,2E15.4,3I5)
18990 AMRCL(I) = ZERO
18991 EEXC(I) = ZERO
18992 IF (NLOOP.LE.500) THEN
18993 GOTO 9998
18994 ELSE
18995 IREXCI(2) = IREXCI(2)+1
18996 GOTO 9999
18997 ENDIF
18998*
18999* Otherwise (reasonable E_exc) :
19000* E_exc = M_res - M_res0
19001* in addition: calculate and save E_exc per wounded nucleon as
19002* well as E_exc in <E_exc> counter
19003*
19004 ELSE
19005* excitation energies of residual nuclei
19006 EEXC(I) = AMRCL(I)-AMRCL0(I)
19007**sr 27.12.06 new excitation energy correction by A.F.
19008*
19009* all parts with Ilcopt<3 commented since not used
19010*
19011* still to be done/decided:
19012* Increase Icor and put back both residual nuclei on mass shell
19013* with the exciting correction further below.
19014* For the moment the modification in the excitation energy is simply
19015* corrected by scaling the energy of the residual nucleus.
19016*
19017 LLCPOT = .TRUE.
19018 ILCOPT = 3
19019 IF ( LLCPOT ) THEN
19020 NNCHIT = MAX ( INUC (I) - NTOT (I), 0 )
19021 IF ( ILCOPT .LE. 2 ) THEN
19022C* Patch for Fermi momentum reduction correlated with impact parameter:
19023C FRMRDC = MIN ( (PFRMAV(INUC(I))/APFRMX)**3, ONE )
19024C DLKPRH = 0.1D+00 + 0.5D+00 / SQRT(DBLE(INUC(I)))
19025C AKPRHO = ONE - DLKPRH
19026C* f x K rho_cen + (1-f) x 0.5 x K rho_cen = frmrdc x rho_cen
19027C FRCFLL = MAX ( 2.D+00 * FRMRDC / AKPRHO - ONE,
19028C & 0.05D+00 )
19029C* REDORI = 0.75D+00
19030C* REDORI = ONE
19031C REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
19032 ELSE
19033 DLKPRH = ZERO
19034 RDCORE = 1.14D+00 * DBLE(INUC(I))**(ONE/3.D+00)
19035* Take out roughly one/half of the skin:
19036 RDCORE = RDCORE - 0.5D+00
19037 FRCFLL = RDCORE**3
19038 PRSKIN = (RDCORE+2.4D+00)**3 - FRCFLL
19039 PRSKIN = 0.5D+00 * PRSKIN / ( PRSKIN + FRCFLL )
19040 FRCFLL = ONE - PRSKIN
19041 FRMRDC = FRCFLL + 0.5D+00 * PRSKIN
19042 REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
19043 END IF
19044 IF ( NNCHIT .GT. 0 ) THEN
19045C IF ( ILCOPT .EQ. 1 ) THEN
19046C SKINRH = ONE - FRCFLL / (DBLE(INUC(I))-ONE)
19047C DO 1220 NCH = 1, 10
19048C ETAETA = ( ONE - SKINRH**INUC(I)
19049C & - DBLE(INUC(I))* ( ONE - FRCFLL )
19050C & * ( ONE - SKINRH ) )
19051C & / ( SKINRH**INUC(I) - DBLE (INUC(I))
19052C & * ( ONE - FRCFLL) * SKINRH )
19053C SKINRH = SKINRH * ( ONE + ETAETA )
19054C 1220 CONTINUE
19055C PRSKIN = SKINRH**(NNCHIT-1)
19056C ELSE IF ( ILCOPT .EQ. 2 ) THEN
19057C PRSKIN = ONE - FRCFLL
19058C END IF
19059 REDCTN = ZERO
19060 DO 1230 NCH = 1, NNCHIT
19061 IF (DT_RNDM(PRFRMI) .LT. PRSKIN) THEN
19062 PRFRMI = (( ONE - 2.D+00 * DLKPRH )
19063 & * DT_RNDM(PRFRMI))**0.333333333333D+00
19064 ELSE
19065 PRFRMI = ( ONE - 2.D+00 * DLKPRH
19066 & * DT_RNDM(PRFRMI))**0.333333333333D+00
19067 END IF
19068 REDCTN = REDCTN + PRFRMI**2
19069 1230 CONTINUE
19070 REDCTN = REDCTN / DBLE (NNCHIT)
19071 ELSE
19072 REDCTN = 0.5D+00
19073 END IF
19074 EEXC (I) = EEXC (I) * REDCTN / REDORI
19075 AMRCL (I) = AMRCL0 (I) + EEXC (I)
19076 PRCL(I,4) = SQRT ( PTORCL**2 + AMRCL(I)**2 )
19077 END IF
19078**
19079 IF (ICASCA.EQ.0) THEN
19080 EXPNUC(I) = EEXC(I)/MAX(1,INUC(I)-NTOT(I))
19081 M = MIN(NTOT(I),260)
19082 EXC(I,M) = EXC(I,M)+EEXC(I)
19083 NEXC(I,M) = NEXC(I,M)+1
19084 ENDIF
19085 ENDIF
19086 ELSEIF (NTOT(I).EQ.1) THEN
19087 WRITE(LOUT,1003) I
19088 1003 FORMAT(1X,'FICONF: warning! NTOT(I)=1? (I=',I3,')')
19089 GOTO 9999
19090 ELSE
19091 AMRCL0(I) = ZERO
19092 AMRCL(I) = ZERO
19093 EEXC(I) = ZERO
19094 INORCL = INORCL+I
19095 ENDIF
19096 7 CONTINUE
19097
19098 PRCLPR(5) = AMRCL(1)
19099 PRCLTA(5) = AMRCL(2)
19100
19101 IF (ICOR.GT.0) THEN
19102 IF (INORCL.EQ.0) THEN
19103* one or both residual nuclei consist of one nucleon only, transform
19104* this nucleon on mass shell
19105 DO 9 K=1,4
19106 P1IN(K) = PRCL(1,K)
19107 P2IN(K) = PRCL(2,K)
19108 9 CONTINUE
19109 XM1 = AMRCL(1)
19110 XM2 = AMRCL(2)
19111 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
19112 IF (IREJ1.GT.0) THEN
19113 WRITE(LOUT,*) 'ficonf-mashel rejection'
19114 GOTO 9999
19115 ENDIF
19116 DO 10 K=1,4
19117 PRCL(1,K) = P1OUT(K)
19118 PRCL(2,K) = P2OUT(K)
19119 PRCLPR(K) = P1OUT(K)
19120 PRCLTA(K) = P2OUT(K)
19121 10 CONTINUE
19122 PRCLPR(5) = AMRCL(1)
19123 PRCLTA(5) = AMRCL(2)
19124 ELSE
19125 IF (IOULEV(3).GT.0)
19126 & WRITE(LOUT,1001) NEVHKK,INT(AIF(1)),INT(AIZF(1)),
19127 & INT(AIF(2)),INT(AIZF(2)),AMRCL0(1),
19128 & AMRCL(1),AMRCL(1)-AMRCL0(1),AMRCL0(2),
19129 & AMRCL(2),AMRCL(2)-AMRCL0(2)
19130 1001 FORMAT(1X,'FICONF: warning! no residual nucleus for',
19131 & ' correction',/,11X,'at event',I8,
19132 & ', nucleon config. 1:',2I4,' 2:',2I4,
19133 & 2(/,11X,3E12.3))
19134 IF (NLOOP.LE.500) THEN
19135 GOTO 9998
19136 ELSE
19137 IREXCI(1) = IREXCI(1)+1
19138 ENDIF
19139 ENDIF
19140 ENDIF
19141
19142* update counter
19143C IF (NRESEV(1).NE.NEVHKK) THEN
19144C NRESEV(1) = NEVHKK
19145C NRESEV(2) = NRESEV(2)+1
19146C ENDIF
19147 NRESEV(2) = NRESEV(2)+1
19148 DO 15 I=1,2
19149 EXCDPM(I) = EXCDPM(I)+EEXC(I)
19150 EXCDPM(I+2) = EXCDPM(I+2)+(EEXC(I)/MAX(NTOT(I),1))
19151 NRESTO(I) = NRESTO(I)+NTOT(I)
19152 NRESPR(I) = NRESPR(I)+NPRO(I)
19153 NRESNU(I) = NRESNU(I)+NN(I)
19154 NRESBA(I) = NRESBA(I)+NH(I)
19155 NRESPB(I) = NRESPB(I)+NHPOS(I)
19156 NRESCH(I) = NRESCH(I)+NQ(I)
19157 15 CONTINUE
19158
19159* evaporation
19160 IF (LEVPRT) THEN
19161 DO 13 I=1,2
19162* initialize evaporation counter
19163 EEXCFI(I) = ZERO
19164 IF ((INUC(I).GT.1).AND.(AIF(I).GT.ONE).AND.
19165 & (EEXC(I).GT.ZERO)) THEN
19166* put residual nuclei into DTEVT1
19167 IDRCL = 80000
19168 JMASS = INT( AIF(I))
19169 JCHAR = INT(AIZF(I))
19170* the following patch is required to transmit the correct excitation
19171* energy to Eventd
19172 IF (ITRSPT.EQ.1) THEN
19173 IF ((ABS(AMRCL(I)-AMRCL0(I)-EEXC(I)).GT.1.D-04).AND.
19174 & (IOULEV(3).GT.0))
19175 & WRITE(LOUT,*)
19176 & ' DT_FICONF:AMRCL(I),AMRCL0(I),EEXC(I)',
19177 & AMRCL(I),AMRCL0(I),EEXC(I)
19178 PRCL0 = PRCL(I,4)
19179 PRCL(I,4) =SQRT(AMRCL(I)**2+PRCL(I,1)**2+PRCL(I,2)**2
19180 & +PRCL(I,3)**2)
19181 IF (ABS(PRCL0-PRCL(I,4)).GT.0.1D0) THEN
19182 WRITE(LOUT,*)
19183 & ' PRCL(I,4) recalculated :',PRCL0,PRCL(I,4)
19184 ENDIF
19185 ENDIF
19186 CALL DT_EVTPUT(1000,IDRCL,MO1(I),MO2(I),PRCL(I,1),
19187 & PRCL(I,2),PRCL(I,3),PRCL(I,4),JMASS,JCHAR,0)
19188**sr 22.6.97
19189 NOBAM(NHKK) = I
19190**
19191 DO 14 J=1,4
19192 VHKK(J,NHKK) = VRCL(I,J)
19193 WHKK(J,NHKK) = WRCL(I,J)
19194 14 CONTINUE
19195* interface to evaporation module - fill final residual nucleus into
19196* common FKRESN
19197* fill resnuc only if code is not used as event generator in Fluka
19198 IF (ITRSPT.NE.1) THEN
19199 PXRES = PRCL(I,1)
19200 PYRES = PRCL(I,2)
19201 PZRES = PRCL(I,3)
19202 IBRES = NPRO(I)+NN(I)+NH(I)
19203 ICRES = NPRO(I)+NHPOS(I)
19204 ANOW = DBLE(IBRES)
19205 ZNOW = DBLE(ICRES)
19206 PTRES = SQRT(PXRES**2+PYRES**2+PZRES**2)
19207* ground state mass of the residual nucleus (should be equal to AM0T)
19208 AMMRES = AMRCL0(I)
19209 AMNRES = AMMRES-ZNOW*AMELEC+ELBNDE(ICRES)
19210* common FKFINU
19211 TV = ZERO
19212* kinetic energy of residual nucleus
19213 TVRECL = PRCL(I,4)-AMRCL(I)
19214* excitation energy of residual nucleus
19215 TVCMS = EEXC(I)
19216 PTOLD = PTRES
19217 PTRES = SQRT(ABS(TVRECL*(TVRECL+
19218 & 2.0D0*(AMMRES+TVCMS))))
19219 IF (PTOLD.LT.ANGLGB) THEN
19220 CALL DT_RACO(PXRES,PYRES,PZRES)
19221 PTOLD = ONE
19222 ENDIF
19223 PXRES = PXRES*PTRES/PTOLD
19224 PYRES = PYRES*PTRES/PTOLD
19225 PZRES = PZRES*PTRES/PTOLD
19226* zero counter of secondaries from evaporation
19227 NP = 0
19228* evaporation
19229 WE = ONE
19230 CALL DT_EVEVAP(WE)
19231* put evaporated particles and residual nuclei to DTEVT1
19232 MO = NHKK
19233 CALL DT_EVA2HE(MO,EXCITF,I,IREJ1)
19234 ENDIF
19235 EEXCFI(I) = EXCITF
19236 EXCEVA(I) = EXCEVA(I)+EXCITF
19237 ENDIF
19238 13 CONTINUE
19239 ENDIF
19240
19241 RETURN
19242
19243C9998 IREXCI(1) = IREXCI(1)+1
19244 9998 IREJ = IREJ+1
19245 9999 CONTINUE
19246 LRCLPR = .TRUE.
19247 LRCLTA = .TRUE.
19248 IREJ = IREJ+1
19249 RETURN
19250 END
19251
19252*$ CREATE DT_EVA2HE.FOR
19253*COPY DT_EVA2HE
19254* *
19255*====eva2he============================================================*
19256* *
19257 SUBROUTINE DT_EVA2HE(MO,EEXCF,IRCL,IREJ)
19258
19259************************************************************************
19260* Interface between common's of evaporation module (FKFINU,FKFHVY) *
19261* and DTEVT1. *
19262* MO DTEVT1-index of "mother" (residual) nucleus before evap. *
19263* EEXCF exitation energy of residual nucleus after evaporation *
19264* IRCL = 1 projectile residual nucleus *
19265* = 2 target residual nucleus *
19266* This version dated 19.04.95 is written by S. Roesler. *
19267* *
19268* Last change 27.12.2006 by S. Roesler. *
19269************************************************************************
19270
19271 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19272 SAVE
19273 PARAMETER ( LINP = 10 ,
19274 & LOUT = 6 ,
19275 & LDAT = 9 )
19276 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3)
19277
19278* event history
19279 PARAMETER (NMXHKK=200000)
19280 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
19281 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
19282 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
19283* Note: DTEVT2 - special use for heavy fragments !
19284* (IDRES(I) = mass number, IDXRES(I) = charge)
19285* extended event history
19286 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
19287 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
19288 & IHIST(2,NMXHKK)
19289* particle properties (BAMJET index convention)
19290 CHARACTER*8 ANAME
19291 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19292 & IICH(210),IIBAR(210),K1(210),K2(210)
19293* flags for input different options
19294 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
19295 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
19296 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
19297* statistics: residual nuclei
19298 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
19299 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
19300 & NINCST(2,4),NINCEV(2),
19301 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
19302 & NRESPB(2),NRESCH(2),NRESEV(4),
19303 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
19304 & NEVAFI(2,2)
19305* treatment of residual nuclei: properties of residual nuclei
19306 COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
19307 & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
19308 & NTOTFI(2),NPROFI(2)
19309* (original name: FINUC)
19310 PARAMETER (MXP=999)
19311 COMMON /FKFINU/ CXR (MXP), CYR (MXP), CZR (MXP),
19312 & CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP),
19313 & TKI (MXP), PLR (MXP), WEI (MXP),
19314 & TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP,
19315 & KPART (MXP)
19316* (original name: FHEAVY,FHEAVC)
19317 PARAMETER ( MXHEAV = 100 )
19318 CHARACTER*8 ANHEAV
19319 COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV),
19320 & CZHEAV (MXHEAV), TKHEAV (MXHEAV),
19321 & PHEAVY (MXHEAV), WHEAVY (MXHEAV),
19322 & AMHEAV ( 12 ) , AMNHEA ( 12 ) ,
19323 & KHEAVY (MXHEAV), ICHEAV ( 12 ) ,
19324 & IBHEAV ( 12 ) , NPHEAV
19325 COMMON /FKFHVC/ ANHEAV ( 12 )
19326* (original name: RESNUC)
19327 LOGICAL LRNFSS, LFRAGM
19328 COMMON /FKRESN/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
19329 & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
19330 & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES,
19331 & PYRES, PZRES, PTRES2, KTARP, KTARN, IGREYP,
19332 & IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,
19333 & ICRES, IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU,
19334 & IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG,
19335 & IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS,
19336 & LFRAGM
19337
19338 DIMENSION IPTOKP(39)
19339 DATA IPTOKP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
19340 & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 99,
19341 & 100, 101, 97, 102, 98, 103, 109, 115 /
19342
19343 IREJ = 0
19344
19345* skip if evaporation package is not included
19346 IF (.NOT.LEVAPO) RETURN
19347
19348* update counter
19349 IF (NRESEV(3).NE.NEVHKK) THEN
19350 NRESEV(3) = NEVHKK
19351 NRESEV(4) = NRESEV(4)+1
19352 ENDIF
19353
19354 IF (LEMCCK)
19355 & CALL DT_EVTEMC(PHKK(1,MO),PHKK(2,MO),PHKK(3,MO),PHKK(4,MO),1,
19356 & IDUM,IDUM)
19357* mass number/charge of residual nucleus before evaporation
19358 IBTOT = IDRES(MO)
19359 IZTOT = IDXRES(MO)
19360
19361* protons/neutrons/gammas
19362 DO 1 I=1,NP
19363 PX = CXR(I)*PLR(I)
19364 PY = CYR(I)*PLR(I)
19365 PZ = CZR(I)*PLR(I)
19366 ID = IPTOKP(KPART(I))
19367 IDPDG = IDT_IPDGHA(ID)
19368 AM = ((PLR(I)+TKI(I))*(PLR(I)-TKI(I)))/
19369 & (2.0D0*MAX(TKI(I),TINY10))
19370 IF (ABS(AM-AAM(ID)).GT.TINY3) THEN
19371 WRITE(LOUT,1000) ID,AM,AAM(ID)
19372 1000 FORMAT(1X,'EVA2HE: inconsistent mass of evap. ',
19373 & 'particle',I3,2E10.3)
19374 ENDIF
19375 PE = TKI(I)+AM
19376 CALL DT_EVTPUT(-1,IDPDG,MO,0,PX,PY,PZ,PE,0,0,0)
19377 NOBAM(NHKK) = IRCL
19378 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
19379 IBTOT = IBTOT-IIBAR(ID)
19380 IZTOT = IZTOT-IICH(ID)
19381 1 CONTINUE
19382
19383* heavy fragments
19384 DO 2 I=1,NPHEAV
19385 PX = CXHEAV(I)*PHEAVY(I)
19386 PY = CYHEAV(I)*PHEAVY(I)
19387 PZ = CZHEAV(I)*PHEAVY(I)
19388 IDHEAV = 80000
19389 AM = ((PHEAVY(I)+TKHEAV(I))*(PHEAVY(I)-TKHEAV(I)))/
19390 & (2.0D0*MAX(TKHEAV(I),TINY10))
19391 PE = TKHEAV(I)+AM
19392 CALL DT_EVTPUT(-1,IDHEAV,MO,0,PX,PY,PZ,PE,
19393 & IBHEAV(KHEAVY(I)),ICHEAV(KHEAVY(I)),0)
19394 NOBAM(NHKK) = IRCL
19395 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
19396 IBTOT = IBTOT-IBHEAV(KHEAVY(I))
19397 IZTOT = IZTOT-ICHEAV(KHEAVY(I))
19398 2 CONTINUE
19399
19400 IF (IBRES.GT.0) THEN
19401* residual nucleus after evaporation
19402 IDNUC = 80000
19403 CALL DT_EVTPUT(1001,IDNUC,MO,0,PXRES,PYRES,PZRES,ERES,
19404 & IBRES,ICRES,0)
19405 NOBAM(NHKK) = IRCL
19406 ENDIF
19407 EEXCF = TVCMS
19408 NTOTFI(IRCL) = IBRES
19409 NPROFI(IRCL) = ICRES
19410 IF (LEMCCK) CALL DT_EVTEMC(-PXRES,-PYRES,-PZRES,-ERES,2,IDUM,IDUM)
19411 IBTOT = IBTOT-IBRES
19412 IZTOT = IZTOT-ICRES
19413
19414* count events with fission
19415 NEVAFI(1,IRCL) = NEVAFI(1,IRCL)+1
19416 IF (LRNFSS) NEVAFI(2,IRCL) = NEVAFI(2,IRCL)+1
19417
19418* energy-momentum conservation check
19419 IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,40,IREJ)
19420C IF (IREJ.GT.0) THEN
19421C CALL DT_EVTOUT(4)
19422C WRITE(*,*) EEXC(2),EEXCFI(2),NP,NPHEAV
19423C ENDIF
19424* baryon-number/charge conservation check
19425 IF (IBTOT+IZTOT.NE.0) THEN
19426 WRITE(LOUT,1001) NEVHKK,IBTOT,IZTOT
19427 1001 FORMAT(1X,'EVA2HE: baryon-number/charge conservation ',
19428 & 'failure at event ',I8,' : IBTOT,IZTOT = ',2I3)
19429 ENDIF
19430
19431 RETURN
19432 END
19433
19434*$ CREATE DT_EBIND.FOR
19435*COPY DT_EBIND
19436*
19437*===ebind==============================================================*
19438*
19439 DOUBLE PRECISION FUNCTION DT_EBIND(IA,IZ)
19440
19441************************************************************************
19442* Binding energy for nuclei. *
19443* (Shirokov & Yudin, Yad. Fizika, Nauka, Moskva 1972) *
19444* IA mass number *
19445* IZ atomic number *
19446* This version dated 5.5.95 is updated by S. Roesler. *
19447************************************************************************
19448
19449 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19450 SAVE
19451 PARAMETER ( LINP = 10 ,
19452 & LOUT = 6 ,
19453 & LDAT = 9 )
19454 PARAMETER (ZERO=0.0D0)
19455
19456 DATA A1, A2, A3, A4, A5
19457 & / 0.01575D0, 0.0178D0, 0.000710D0, 0.0237D0, 0.034D0/
19458
19459 IF ((IA.LE.1).OR.(IZ.EQ.0)) THEN
19460 WRITE(LOUT,'(1X,A,2I5)') 'DT_EBIND IA,IZ set EBIND=0. ',IA,IZ
19461 DT_EBIND = ZERO
19462 RETURN
19463 ENDIF
19464 AA = IA
19465 DT_EBIND = A1*AA - A2*AA**0.666667D0-A3*IZ*IZ*AA**(-0.333333D0)
19466 & -A4*(IA-2*IZ)**2/AA
19467 IF (MOD(IA,2).EQ.1) THEN
19468 IA5 = 0
19469 ELSEIF (MOD(IZ,2).EQ.1) THEN
19470 IA5 = 1
19471 ELSE
19472 IA5 = -1
19473 ENDIF
19474 DT_EBIND = DT_EBIND - IA5*A5*AA**(-0.75D0)
19475
19476 RETURN
19477 END
19478
19479**sr 30.6. routine replaced completely
19480*$ CREATE DT_ENERGY.FOR
19481*COPY DT_ENERGY
19482* *
19483*=== energy ===========================================================*
19484* *
19485 DOUBLE PRECISION FUNCTION DT_ENERGY( A, Z )
19486
19487C INCLUDE '(DBLPRC)'
19488* DBLPRC.ADD
19489 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19490 SAVE
19491* (original name: GLOBAL)
19492 PARAMETER ( KALGNM = 2 )
19493 PARAMETER ( ANGLGB = 5.0D-16 )
19494 PARAMETER ( ANGLSQ = 2.5D-31 )
19495 PARAMETER ( AXCSSV = 0.2D+16 )
19496 PARAMETER ( ANDRFL = 1.0D-38 )
19497 PARAMETER ( AVRFLW = 1.0D+38 )
19498 PARAMETER ( AINFNT = 1.0D+30 )
19499 PARAMETER ( AZRZRZ = 1.0D-30 )
19500 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
19501 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
19502 PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
19503 PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
19504 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
19505 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
19506 PARAMETER ( CSNNRM = 2.0D-15 )
19507 PARAMETER ( DMXTRN = 1.0D+08 )
19508 PARAMETER ( ZERZER = 0.D+00 )
19509 PARAMETER ( ONEONE = 1.D+00 )
19510 PARAMETER ( TWOTWO = 2.D+00 )
19511 PARAMETER ( THRTHR = 3.D+00 )
19512 PARAMETER ( FOUFOU = 4.D+00 )
19513 PARAMETER ( FIVFIV = 5.D+00 )
19514 PARAMETER ( SIXSIX = 6.D+00 )
19515 PARAMETER ( SEVSEV = 7.D+00 )
19516 PARAMETER ( EIGEIG = 8.D+00 )
19517 PARAMETER ( ANINEN = 9.D+00 )
19518 PARAMETER ( TENTEN = 10.D+00 )
19519 PARAMETER ( HLFHLF = 0.5D+00 )
19520 PARAMETER ( ONETHI = ONEONE / THRTHR )
19521 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
19522 PARAMETER ( ONEFOU = ONEONE / FOUFOU )
19523 PARAMETER ( THRTWO = THRTHR / TWOTWO )
19524 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
19525 PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
19526 PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
19527 PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
19528 PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
19529 PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
19530 PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
19531 PARAMETER ( EULERO = 0.577215664901532860606512 D+00 )
19532 PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 )
19533 PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 )
19534 PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 )
19535 PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
19536 PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
19537 PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
19538 PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
19539 PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
19540 PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
19541 PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
19542 PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
19543 PARAMETER ( CLIGHT = 2.99792458 D+10 )
19544 PARAMETER ( AVOGAD = 6.0221367 D+23 )
19545 PARAMETER ( BOLTZM = 1.380658 D-23 )
19546 PARAMETER ( AMELGR = 9.1093897 D-28 )
19547 PARAMETER ( PLCKBR = 1.05457266 D-27 )
19548 PARAMETER ( ELCCGS = 4.8032068 D-10 )
19549 PARAMETER ( ELCMKS = 1.60217733 D-19 )
19550 PARAMETER ( AMUGRM = 1.6605402 D-24 )
19551 PARAMETER ( AMMUMU = 0.113428913 D+00 )
19552 PARAMETER ( AMPRMU = 1.007276470 D+00 )
19553 PARAMETER ( AMNEMU = 1.008664904 D+00 )
19554 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
19555 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
19556 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
19557 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
19558 PARAMETER ( PLABRC = 0.197327053 D+00 )
19559 PARAMETER ( AMELCT = 0.51099906 D-03 )
19560 PARAMETER ( AMUGEV = 0.93149432 D+00 )
19561 PARAMETER ( AMMUON = 0.105658389 D+00 )
19562 PARAMETER ( AMPRTN = 0.93827231 D+00 )
19563 PARAMETER ( AMNTRN = 0.93956563 D+00 )
19564 PARAMETER ( AMDEUT = 1.87561339 D+00 )
19565 PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
19566 & * 1.D-09 )
19567 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
19568 PARAMETER ( BLTZMN = 8.617385 D-14 )
19569 PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
19570 PARAMETER ( GFOHB3 = 1.16639 D-05 )
19571 PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
19572 PARAMETER ( SIN2TW = 0.2319 D+00 )
19573 PARAMETER ( GEVMEV = 1.0 D+03 )
19574 PARAMETER ( EMVGEV = 1.0 D-03 )
19575 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
19576 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
19577 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
19578 LOGICAL LGBIAS, LGBANA
19579 COMMON /FKGLOB/ LGBIAS, LGBANA
19580C INCLUDE '(DIMPAR)'
19581* DIMPAR.ADD
19582 PARAMETER ( MXXRGN = 5000 )
19583 PARAMETER ( MXXMDF = 82 )
19584 PARAMETER ( MXXMDE = 54 )
19585 PARAMETER ( MFSTCK = 1000 )
19586 PARAMETER ( MESTCK = 100 )
19587 PARAMETER ( NALLWP = 39 )
19588 PARAMETER ( NELEMX = 80 )
19589 PARAMETER ( MPDPDX = 8 )
19590 PARAMETER ( ICOMAX = 180 )
19591 PARAMETER ( NSTBIS = 304 )
19592 PARAMETER ( IDMAXP = 220 )
19593 PARAMETER ( IDMXDC = 640 )
19594 PARAMETER ( MKBMX1 = 1 )
19595 PARAMETER ( MKBMX2 = 1 )
19596C INCLUDE '(IOUNIT)'
19597* IOUNIT.ADD
19598 PARAMETER ( LUNIN = 5 )
19599 PARAMETER ( LUNOUT = 6 )
19600**sr 19.5. set error output-unit from 15 to 6
19601 PARAMETER ( LUNERR = 6 )
19602 PARAMETER ( LUNBER = 14 )
19603 PARAMETER ( LUNECH = 8 )
19604 PARAMETER ( LUNFLU = 13 )
19605 PARAMETER ( LUNGEO = 16 )
19606 PARAMETER ( LUNPMF = 12 )
19607 PARAMETER ( LUNRAN = 2 )
19608 PARAMETER ( LUNXSC = 9 )
19609 PARAMETER ( LUNDET = 17 )
19610 PARAMETER ( LUNRAY = 10 )
19611 PARAMETER ( LUNRDB = 1 )
19612 PARAMETER ( LUNPGO = 7 )
19613 PARAMETER ( LUNPGS = 4 )
19614 PARAMETER ( LUNSCR = 3 )
19615*
19616*----------------------------------------------------------------------*
19617* *
19618* Revised version of the original routine from EVAP: *
19619* *
19620* Created on 15 may 1990 by Alfredo Ferrari & Paola Sala *
19621* Infn - Milan *
19622* *
19623* Last change on 19-sep-95 by Alfredo Ferrari *
19624* *
19625* !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
19626* !!! It is supposed to be used with the updated atomic !!! *
19627* !!! mass data file !!! *
19628* !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
19629* *
19630*----------------------------------------------------------------------*
19631*
19632* Mass number below which "unknown" isotopes out of the Z-interval
19633* reported in the mass tabulations are completely unstable and made
19634* up by Z proton masses + N neutron masses:
19635 PARAMETER ( KAFREE = 4 )
19636* Mass number below which "unknown" isotopes out of the Z-interval
19637* reported in the mass tabulations are supposed to be particle unstable
19638 PARAMETER ( KAPUNS = 12 )
19639* Minimum energy required for particle unstable isotopes
19640 PARAMETER ( DEPUNS = 0.5D+00 )
19641*
19642* (original name: EVA0)
19643 COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
19644 * FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
19645 * CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
19646 * T (4,7), RMASS (297), ALPH (297), BET (297),
19647 * APRIME (250), IA (6), IZ (6)
19648* (original name: ISOTOP)
19649 PARAMETER ( NAMSMX = 270 )
19650 PARAMETER ( NZGVAX = 15 )
19651 PARAMETER ( NISMMX = 574 )
19652 COMMON /FKISOT/ WAPS (NAMSMX,NZGVAX), T12NUC (NAMSMX,NZGVAX),
19653 & WAPISM (NISMMX), T12ISM (NISMMX),
19654 & ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260),
19655 & AMSSST (100) , ISOMNM (NSTBIS), ISONDX (2,100),
19656 & JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX),
19657 & INWAPS (NAMSMX), JSPISM (NISMMX),
19658 & JPTISM (NISMMX), IZWISM (NISMMX),
19659 & INWISM (0:NAMSMX)
19660*
454792a9 19661CPH SAVE KA0, KZ0, IZ0
9aaba0d6 19662 DATA KA0, KZ0, IZ0 / -1, -1, -1 /
19663*
19664 IFLAG = 1
19665 GO TO 10
19666*======================================================================*
19667* *
19668* Entry ENergy - KNOWn *
19669* *
19670*======================================================================*
19671 ENTRY DT_ENKNOW ( A, Z, IZZ0 )
19672 IZZ0 =-1
19673 IFLAG = 2
19674 10 CONTINUE
19675*
19676 KA0 = NINT ( A )
19677 KZ0 = NINT ( Z )
19678 N = KA0 - KZ0
19679* +-------------------------------------------------------------------*
19680* | Null residual nucleus:
19681 IF ( KA0 .EQ. 0 .AND. KZ0 .LE. 0 ) THEN
19682 IF ( IFLAG .EQ. 1 ) THEN
19683 DT_ENERGY = ZERZER
19684 ELSE
19685 DT_ENKNOW = ZERZER
19686 IZZ0 = -1
19687 END IF
19688 RETURN
19689* |
19690* +-------------------------------------------------------------------*
19691* | Only protons:
19692 ELSE IF ( N .LE. 0 ) THEN
19693 IF ( N .LT. 0 ) THEN
19694 WRITE ( LUNOUT, * )
19695 & ' DPMJET stopped in energy: mass number =< atomic number !!',
19696 & KA0, KZ0
19697 WRITE ( LUNOUT, * )
19698 & ' DPMJET stopped in energy: mass number =< atomic number !!',
19699 & KA0, KZ0
19700 WRITE ( 77, * )
19701 & ' ^^^DPMJET stopped in energy: mass number =< atomic number !!',
19702 & KA0, KZ0
19703 STOP 'DT_ENERGY:KA0-KZ0'
19704 END IF
19705 IZ0 = -1
19706 IF ( IFLAG .EQ. 1 ) THEN
19707 DT_ENERGY = Z * WAPS ( 1, 2 )
19708 ELSE
19709 DT_ENKNOW = Z * WAPS ( 1, 2 )
19710 IZZ0 = -1
19711 END IF
19712 RETURN
19713* |
19714* +-------------------------------------------------------------------*
19715* | Only neutrons:
19716 ELSE IF ( KZ0 .LE. 0 ) THEN
19717 IF ( KZ0 .LT. 0 ) THEN
19718 WRITE ( LUNOUT, * )
19719 & ' DPMJET stopped in energy: negative atomic number !!',KA0,KZ0
19720 WRITE ( LUNOUT, * )
19721 & ' DPMJET stopped in energy: negative atomic number !!',KA0,KZ0
19722 WRITE ( 77, * )
19723 &' ^^^DPMJET stopped in energy: negative atomic number !!',KA0,KZ0
19724 STOP 'DT_ENERGY:KZ0<0'
19725 END IF
19726 IZ0 = -1
19727 IF ( IFLAG .EQ. 1 ) THEN
19728 DT_ENERGY = A * WAPS ( 1, 1 )
19729 ELSE
19730 DT_ENKNOW = A * WAPS ( 1, 1 )
19731 IZZ0 = -1
19732 END IF
19733 RETURN
19734 END IF
19735* |
19736* +-------------------------------------------------------------------*
19737* +-------------------------------------------------------------------*
19738* | No actual nucleus
19739* |
19740* +-------------------------------------------------------------------*
19741* +-------------------------------------------------------------------*
19742* | A larger than maximum allowed:
19743 IF ( KA0 .GT. NAMSMX ) THEN
19744 IZ0 = -1
19745 IF ( IFLAG .EQ. 1 ) THEN
19746 DT_ENERGY = DT_ENRG( A, Z )
19747 ELSE
19748 DT_ENKNOW = DT_ENRG( A, Z )
19749 IZZ0 = -1
19750 END IF
19751 RETURN
19752 END IF
19753* |
19754* +-------------------------------------------------------------------*
19755 IZZ = INWAPS ( KA0 )
19756* +-------------------------------------------------------------------*
19757* | Too much neutron rich with respect to the stability line:
19758 IF ( KZ0 .LT. IZZ ) THEN
19759* | +----------------------------------------------------------------*
19760* | | Up to A=Kafree all "bound" masses are known, set it unbound:
19761 IF ( KA0 .LE. KAFREE ) THEN
19762 DT_ENERGY = AINFNT
19763* | |
19764* | +----------------------------------------------------------------*
19765* | | Up to Kapuns: be sure it is particle unstable
19766 ELSE IF ( KA0 .LE. KAPUNS ) THEN
19767* | | Exp. excess mass for A,IZZ
19768 ENEEXP = WAPS ( KA0, 1 )
19769* | | Cameron excess mass for A, IZZ
19770 ENECA1 = DT_ENRG( A, DBLE (IZZ) )
19771* | | Cameron excess mass for A, Z
19772 DT_ENERGY = DT_ENRG( A, Z )
19773* | | Use just the difference according to Cameron!!!
19774 DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19775 JZZ = INWAPS ( KA0 - 1 )
19776 LZZ = INWAPS ( KA0 - 2 )
19777* | | +-------------------------------------------------------------*
19778* | | | Residual mass for n-decay known:
19779 IF ( KZ0 .GE. JZZ .AND. KZ0 .LE. JZZ + NZGVAX - 1 ) THEN
19780 IZ0 = KZ0 - JZZ + 1
19781 DT_ENERGY = MAX(DT_ENERGY,WAPS (KA0-1,IZ0) + WAPS (1,1)
19782 & + DEPUNS )
19783* | | |
19784* | | +-------------------------------------------------------------*
19785* | | | Residual mass for 2n-decay known:
19786 ELSE IF ( KZ0 .GE. LZZ .AND. KZ0 .LE. LZZ + NZGVAX - 1 )THEN
19787 IZ0 = KZ0 - LZZ + 1
19788 DT_ENERGY = MAX ( DT_ENERGY, WAPS (KA0-2,IZ0) + TWOTWO *
19789 & ( WAPS (1,1) + DEPUNS ) )
19790* | | |
19791* | | +-------------------------------------------------------------*
19792* | | | Set it unbound:
19793 ELSE
19794 DT_ENERGY = AINFNT
19795 END IF
19796* | | |
19797* | | +-------------------------------------------------------------*
19798* | |
19799* | +----------------------------------------------------------------*
19800* | | Proceed as usual:
19801 ELSE
19802* | | Exp. excess mass for A,IZZ
19803 ENEEXP = WAPS ( KA0, 1 )
19804* | | Cameron excess mass for A, IZZ
19805 ENECA1 = DT_ENRG( A, DBLE (IZZ) )
19806* | | Cameron excess mass for A, Z
19807 DT_ENERGY = DT_ENRG( A, Z )
19808* | | Use just the difference according to Cameron!!!
19809 DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19810 END IF
19811* | |
19812* | +----------------------------------------------------------------*
19813* | Be sure not to have a positive energy state:
19814 DT_ENERGY = MIN(DT_ENERGY,(A-Z) * WAPS (1,1) + Z * WAPS (1,2) )
19815 IZ0 = -1
19816 IF ( IFLAG .EQ. 2 ) THEN
19817 DT_ENKNOW = DT_ENERGY
19818 IZZ0 = -1
19819 END IF
19820 RETURN
19821* |
19822* +-------------------------------------------------------------------*
19823* | Too much proton rich with respect to the stability line:
19824 ELSE IF ( KZ0 .GT. IZZ + NZGVAX - 1 ) THEN
19825* | +----------------------------------------------------------------*
19826* | | Up to A=Kafree all "bound" masses are known, set it unbound:
19827 IF ( KA0 .LE. KAFREE ) THEN
19828 DT_ENERGY = AINFNT
19829* | |
19830* | +----------------------------------------------------------------*
19831* | | Up to Kapuns: be sure it is particle unstable
19832 ELSE IF ( KA0 .LE. KAPUNS ) THEN
19833* | | Exp. excess mass for A,IZZ+NZGVAX-1
19834 ENEEXP = WAPS ( KA0, NZGVAX )
19835* | | Cameron excess mass for A, IZZ+NZGVAX-1
19836 ENECA1 = DT_ENRG( A, DBLE (IZZ+NZGVAX-1) )
19837* | | Cameron excess mass for A, Z
19838 DT_ENERGY = DT_ENRG( A, Z )
19839* | | Use just the difference according to Cameron!!!
19840 DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19841 JZZ = INWAPS ( KA0 - 1 )
19842 LZZ = INWAPS ( KA0 - 2 )
19843* | | +-------------------------------------------------------------*
19844* | | | Residual mass for p-decay known:
19845 IF ( KZ0-1 .GE. JZZ .AND. KZ0-1 .LE. JZZ + NZGVAX - 1 ) THEN
19846 IZ0 = KZ0 - 1 - JZZ + 1
19847 DT_ENERGY = MAX (DT_ENERGY, WAPS (KA0-1,IZ0) + WAPS (1,2)
19848 & + DEPUNS )
19849* | | |
19850* | | +-------------------------------------------------------------*
19851* | | | Residual mass for 2p-decay known:
19852 ELSE IF ( KZ0-2 .GE. LZZ .AND. KZ0-2 .LE. LZZ + NZGVAX - 1 )
19853 & THEN
19854 IZ0 = KZ0 - 2 - LZZ + 1
19855 DT_ENERGY = MAX ( DT_ENERGY, WAPS (KA0-2,IZ0) + TWOTWO *
19856 & ( WAPS (1,2) + DEPUNS ) )
19857* | | |
19858* | | +-------------------------------------------------------------*
19859* | | | Set it unbound:
19860 ELSE
19861 DT_ENERGY = AINFNT
19862 END IF
19863* | | |
19864* | | +-------------------------------------------------------------*
19865* | |
19866* | +----------------------------------------------------------------*
19867* | | Proceed as usual:
19868 ELSE
19869* | | Exp. excess mass for A,IZZ+NZGVAX-1
19870 ENEEXP = WAPS ( KA0, NZGVAX )
19871* | | Cameron excess mass for A, IZZ+NZGVAX-1
19872 ENECA1 = DT_ENRG( A, DBLE (IZZ+NZGVAX-1) )
19873* | | Cameron excess mass for A, Z
19874 DT_ENERGY = DT_ENRG( A, Z )
19875* | | Use just the difference according to Cameron!!!
19876 DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19877 END IF
19878* | |
19879* | +----------------------------------------------------------------*
19880* | Be sure not to have a positive energy state:
19881 DT_ENERGY = MIN(DT_ENERGY,(A-Z) * WAPS (1,1) + Z * WAPS (1,2) )
19882 IZ0 = -1
19883 IF ( IFLAG .EQ. 2 ) THEN
19884 DT_ENKNOW = DT_ENERGY
19885 IZZ0 = -1
19886 END IF
19887 RETURN
19888* |
19889* +-------------------------------------------------------------------*
19890* | Known isotope or anyway isotope "inside" the stability zone
19891 ELSE
19892 IZ0 = KZ0 - IZZ + 1
19893 DT_ENERGY = WAPS ( KA0, IZ0 )
19894 IF ( IFLAG .EQ. 2 ) IZZ0 = IZ0
19895* | +----------------------------------------------------------------*
19896* | | Mass not known
19897 IF ( ABS (DT_ENERGY) .LT. ANGLGB .AND. (KA0 .NE. 12 .OR. KZ0
19898 & .NE. 6) ) THEN
19899 IF ( IFLAG .EQ. 2 ) IZZ0 = -1
19900* | | +-------------------------------------------------------------*
19901* | | | Set it unbound:
19902 IF ( KA0 .LE. KAFREE ) THEN
19903 DT_ENERGY = AINFNT
19904* | | |
19905* | | +-------------------------------------------------------------*
19906* | | | Try to get a reasonable excess mass:
19907 ELSE
19908 JZ0 = -100
19909* | | | +----------------------------------------------------------*
19910* | | | | Check the closest one known:
19911 DO 500 JZZ = 1, NZGVAX
19912 IF ( ABS ( WAPS (KA0,JZZ) ) .GT. ANGLGB .AND.
19913 & ABS (JZZ-IZ0) .LT. ABS (JZ0-IZ0) ) JZ0 = JZZ
19914 IF ( ABS (JZ0-IZ0) .EQ. 1 ) GO TO 550
19915 500 CONTINUE
19916* | | | |
19917* | | | +----------------------------------------------------------*
19918 550 CONTINUE
19919* | | | Exp. excess mass for A,IZZ+JZ0-1
19920 ENEEXP = WAPS ( KA0, JZ0 )
19921* | | | Cameron excess mass for A, IZZ+JZ0-1
19922 ENECA1 = DT_ENRG( A, DBLE (IZZ+JZ0-1) )
19923* | | | Cameron excess mass for A, Z
19924 DT_ENERGY = DT_ENRG( A, Z )
19925* | | | Use just the difference according to Cameron!!!
19926 DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19927 IZ0 = -1
19928 END IF
19929* | | |
19930* | | +-------------------------------------------------------------*
19931* | | Be sure not to have a positive energy state:
19932 DT_ENERGY = MIN(DT_ENERGY,(A-Z)*WAPS(1,1)+Z*WAPS (1,2) )
19933 END IF
19934* | |
19935* | +----------------------------------------------------------------*
19936 IF ( IFLAG .EQ. 2 ) DT_ENKNOW = DT_ENERGY
19937 RETURN
19938 END IF
19939* |
19940* +-------------------------------------------------------------------*
19941*=== End of Function Energy ===========================================*
19942* RETURN
19943 END
19944**
19945
19946*$ CREATE DT_ENRG.FOR
19947*COPY DT_ENRG
19948* *
19949*=== enrg =============================================================*
19950* *
19951 DOUBLE PRECISION FUNCTION DT_ENRG(A,Z)
19952
19953 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19954 SAVE
19955
19956 PARAMETER ( ZERZER = 0.D+00 )
19957 PARAMETER ( ONEONE = 1.D+00 )
19958 PARAMETER ( LUNIN = 5 )
19959 PARAMETER ( LUNOUT = 6 )
19960*
19961*----------------------------------------------------------------------*
19962* *
19963* Revised version of the original routine from EVAP: *
19964* *
19965* Created on 15 may 1990 by Alfredo Ferrari & Paola Sala *
19966* Infn - Milan *
19967* *
19968* Last change on 01-oct-94 by Alfredo Ferrari *
19969* *
19970* !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
19971* !!! It is supposed to be used with the updated atomic !!! *
19972* !!! mass data file !!! *
19973* !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
19974* *
19975*----------------------------------------------------------------------*
19976*
19977 PARAMETER ( O16OLD = 931.145 D+00 )
19978 PARAMETER ( O16NEW = 931.19826D+00 )
19979 PARAMETER ( O16RAT = O16NEW / O16OLD )
19980 PARAMETER ( C12NEW = 931.49432D+00 )
19981 PARAMETER ( ADJUST = -8.322737768178909D-02 )
19982 PARAMETER ( AINFNT = 1.0D+30 )
19983* (original name: EVA0)
19984 COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
19985 * FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
19986 * CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
19987 * T (4,7), RMASS (297), ALPH (297), BET (297),
19988 * APRIME (250), IA (6), IZ (6)
19989 LOGICAL LFIRST
454792a9 19990CPH SAVE LFIRST, EXHYDR, EXNEUT
9aaba0d6 19991 DATA LFIRST / .TRUE. /
19992*
19993 IF ( LFIRST ) THEN
19994 LFIRST = .FALSE.
19995**sr 30.6.
19996C EXHYDR = DT_ENERGY( ONEONE, ONEONE )
19997C EXNEUT = DT_ENERGY( ONEONE, ZERZER )
19998 EXHYDR = A
19999 EXNEUT = Z
20000 DT_ENRG = -AINFNT
20001 RETURN
20002**
20003 END IF
20004 IZ0 = NINT (Z)
20005 IF ( IZ0 .LE. 0 ) THEN
20006 DT_ENRG = A * EXNEUT
20007 RETURN
20008 END IF
20009 N = NINT (A-Z)
20010 IF ( N .LE. 0 ) THEN
20011 DT_ENRG = Z * EXHYDR
20012 RETURN
20013 END IF
20014 AM2ZOA= (A-Z-Z)/A
20015 AM2ZOA=AM2ZOA*AM2ZOA
20016 A13 = RMASS(NINT(A))
20017* A13 = A**.3333333333333333D+00
20018 AM13 = 1.D+00/A13
20019 EV=-17.0354D+00*(1.D+00 -1.84619 D+00*AM2ZOA)*A
20020 ES= 25.8357D+00*(1.D+00 -1.712185D+00*AM2ZOA)*
20021 & (1.D+00 -0.62025D+00*AM13*AM13)*
20022 & (A13*A13 -.62025D+00)
20023 EC= 0.799D+00*Z*(Z-1.D+00)*AM13*(((1.5772D+00*AM13 +1.2273D+00)*
20024 & AM13-1.5849D+00)*
20025 & AM13*AM13 +1.D+00)
20026 EEX= -0.4323D+00*AM13*Z**1.3333333D+00*
20027 & (((0.49597D+00*AM13 -0.14518D+00)*AM13 -0.57811D+00) * AM13
20028 & + 1.D+00)
20029 DT_ENRG=8.367D+00*A-0.783D+00*Z +EV +ES +EC +EEX+CAM2(IZ0)+CAM3(N)
20030 DT_ENRG=(DT_ENRG + A * O16OLD ) * O16RAT - A * ( C12NEW - ADJUST )
20031 DT_ENRG = MIN ( DT_ENRG, Z * EXHYDR + ( A - Z ) * EXNEUT )
20032 RETURN
20033*=== End of function Enrg =============================================*
20034 END
20035
20036*$ CREATE DT_INCINI.FOR
20037*COPY DT_INCINI
20038* *
20039*=== incini ===========================================================*
20040* *
20041 SUBROUTINE DT_INCINI
20042
20043 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20044 SAVE
20045
20046 PARAMETER ( ZERZER = 0.D+00 )
20047 PARAMETER ( ONEONE = 1.D+00 )
20048 PARAMETER ( TWOTWO = 2.D+00 )
20049 PARAMETER ( THRTHR = 3.D+00 )
20050 PARAMETER ( FOUFOU = 4.D+00 )
20051 PARAMETER ( EIGEIG = 8.D+00 )
20052 PARAMETER ( ANINEN = 9.D+00 )
20053 PARAMETER ( HLFHLF = 0.5D+00 )
20054 PARAMETER ( ONETHI = ONEONE / THRTHR )
20055 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
20056 PARAMETER ( PLABRC = 0.197327053 D+00 )
20057 PARAMETER ( AMELCT = 0.51099906 D-03 )
20058 PARAMETER ( AMUGEV = 0.93149432 D+00 )
20059 PARAMETER ( AMPRTN = 0.93827231 D+00 )
20060 PARAMETER ( AMNTRN = 0.93956563 D+00 )
20061 PARAMETER ( AMDEUT = 1.87561339 D+00 )
20062 PARAMETER ( EMVGEV = 1.0 D-03 )
20063
20064 PARAMETER ( LUNOUT = 6 )
20065*
20066*----------------------------------------------------------------------*
20067* *
20068* Created on 10 june 1990 by Alfredo Ferrari & Paola Sala *
20069* Infn - Milan *
20070* *
20071* Last change on 02-may-95 by Alfredo Ferrari *
20072* *
20073* *
20074*----------------------------------------------------------------------*
20075*
20076* (original name: FHEAVY,FHEAVC)
20077 PARAMETER ( MXHEAV = 100 )
20078 CHARACTER*8 ANHEAV
20079 COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV),
20080 & CZHEAV (MXHEAV), TKHEAV (MXHEAV),
20081 & PHEAVY (MXHEAV), WHEAVY (MXHEAV),
20082 & AMHEAV ( 12 ) , AMNHEA ( 12 ) ,
20083 & KHEAVY (MXHEAV), ICHEAV ( 12 ) ,
20084 & IBHEAV ( 12 ) , NPHEAV
20085 COMMON /FKFHVC/ ANHEAV ( 12 )
20086* (original name: INPFLG)
20087 COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
20088* (original name: FRBKCM)
20089 PARAMETER ( MXFFBK = 6 )
20090 PARAMETER ( MXZFBK = 9 )
20091 PARAMETER ( MXNFBK = 10 )
20092 PARAMETER ( MXAFBK = 16 )
20093 PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
20094 PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
20095 PARAMETER ( NXAFBK = MXAFBK + 1 )
20096 PARAMETER ( MXPSST = 300 )
20097 PARAMETER ( MXPSFB = 41000 )
20098 LOGICAL LFRMBK, LNCMSS
20099 COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
20100 & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
20101 & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
20102 & IFRBKN (MXPSST), IFRBKZ (MXPSST),
20103 & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
20104 & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
20105 & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
20106 & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
20107 & IFBFRB, NBUFBK, LFRMBK, LNCMSS
20108* (original name: NUCDAT)
20109 PARAMETER ( AMUAMU = AMUGEV )
20110 PARAMETER ( AMPROT = AMPRTN )
20111 PARAMETER ( AMNEUT = AMNTRN )
20112 PARAMETER ( AMELEC = AMELCT )
20113 PARAMETER ( R0NUCL = 1.12 D+00 )
20114 PARAMETER ( RCCOUL = 1.7 D+00 )
20115 PARAMETER ( FERTHO = 14.33 D-09 )
20116 PARAMETER ( EXPEBN = 2.39 D+00 )
20117 PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
20118 PARAMETER ( AMUC12 = AMUGEV - HLFHLF * AMELCT + BEXC12 / 12.D+00 )
20119 PARAMETER ( AMHYDR = AMPRTN + AMELCT )
20120 PARAMETER ( AMHTON = AMHYDR - AMNTRN )
20121 PARAMETER ( AMNTOU = AMNTRN - AMUC12 )
20122 PARAMETER ( AMUCSQ = AMUC12 * AMUC12 )
20123 PARAMETER ( EBNDAV = HLFHLF * (AMPRTN + AMNTRN) - AMUC12 )
20124 PARAMETER ( GAMMIN = 1.0D-06 )
20125 PARAMETER ( GAMNSQ = 2.0D+00 * GAMMIN * GAMMIN )
20126 PARAMETER ( TVEPSI = GAMMIN / 100.D+00 )
20127 COMMON /FKNDAT/ AV0WEL, APFRMX, AEFRMX, AEFRMA,
20128 & RDSNUC, V0WELL (2), PFRMMX (2), EFRMMX (2),
20129 & EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2),
20130 & VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2),
20131 & PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2),
20132 & EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2),
20133 & ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV ,
20134 & AMRCSQ , ATO1O3 , ZTO1O3 , ELBNDE (0:100)
20135* (original name: PAREVT)
20136 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
20137 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
20138 PARAMETER ( NALLWP = 39 )
20139 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
20140 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
20141 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
20142 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
20143* (original name: NUCOLD)
20144 COMMON /FKNOLD/ HELP (2), HHLP (2), FTVTH (2), FINCX (2),
20145 & EKPOLD (2), BBOLD, ZZOLD, SQROLD, ASEASQ,
20146 & FSPRED, FEX0RD
20147*
20148 BBOLD = - 1.D+10
20149 ZZOLD = - 1.D+10
20150 SQROLD = - 1.D+10
20151 APFRMX = PLABRC * ( ANINEN * PIPIPI / EIGEIG )**ONETHI / R0NUCL
20152 AMNUCL (1) = AMPROT
20153 AMNUCL (2) = AMNEUT
20154 AMNUSQ (1) = AMPROT * AMPROT
20155 AMNUSQ (2) = AMNEUT * AMNEUT
20156 AMNHLP = HLFHLF * ( AMNUCL (1) + AMNUCL (2) )
20157 ASQHLP = AMNHLP**2
20158* ASQHLP = HLFHLF * ( AMNUSQ (1) + AMNUSQ (2) )
20159 AEFRMX = SQRT ( ASQHLP + APFRMX**2 ) - AMNHLP
20160 AEFRMA = 0.3D+00 * APFRMX**2 / AMNHLP * ( ONEONE - APFRMX**2 /
20161 & ( 5.6D+00 * ASQHLP ) )
20162 AV0WEL = AEFRMX + EBNDAV
20163 EBNDNG (1) = EBNDAV
20164 EBNDNG (2) = EBNDAV
20165 AEXC12 = EMVGEV * DT_ENERGY( 12.D+00, 6.D+00 )
20166 CEXC12 = EMVGEV * DT_ENRG( 12.D+00, 6.D+00 )
20167 AMMC12 = 12.D+00 * AMUGEV + AEXC12
20168 AMNC12 = AMMC12 - 6.D+00 * AMELCT + FERTHO * 6.D+00**EXPEBN
20169 AEXO16 = EMVGEV * DT_ENERGY( 16.D+00, 8.D+00 )
20170 CEXO16 = EMVGEV * DT_ENRG( 16.D+00, 8.D+00 )
20171 AMMO16 = 16.D+00 * AMUGEV + AEXO16
20172 AMNO16 = AMMO16 - 8.D+00 * AMELCT + FERTHO * 8.D+00**EXPEBN
20173 AEXS28 = EMVGEV * DT_ENERGY( 28.D+00, 14.D+00 )
20174 CEXS28 = EMVGEV * DT_ENRG( 28.D+00, 14.D+00 )
20175 AMMS28 = 28.D+00 * AMUGEV + AEXS28
20176 AMNS28 = AMMS28 - 14.D+00 * AMELCT + FERTHO * 14.D+00**EXPEBN
20177 AEXC40 = EMVGEV * DT_ENERGY( 40.D+00, 20.D+00 )
20178 CEXC40 = EMVGEV * DT_ENRG( 40.D+00, 20.D+00 )
20179 AMMC40 = 40.D+00 * AMUGEV + AEXC40
20180 AMNC40 = AMMC40 - 20.D+00 * AMELCT + FERTHO * 20.D+00**EXPEBN
20181 AEXF56 = EMVGEV * DT_ENERGY( 56.D+00, 26.D+00 )
20182 CEXF56 = EMVGEV * DT_ENRG( 56.D+00, 26.D+00 )
20183 AMMF56 = 56.D+00 * AMUGEV + AEXF56
20184 AMNF56 = AMMF56 - 26.D+00 * AMELCT + FERTHO * 26.D+00**EXPEBN
20185 AEX107 = EMVGEV * DT_ENERGY( 107.D+00, 47.D+00 )
20186 CEX107 = EMVGEV * DT_ENRG( 107.D+00, 47.D+00 )
20187 AMM107 = 107.D+00 * AMUGEV + AEX107
20188 AMN107 = AMM107 - 47.D+00 * AMELCT + FERTHO * 47.D+00**EXPEBN
20189 AEX132 = EMVGEV * DT_ENERGY( 132.D+00, 54.D+00 )
20190 CEX132 = EMVGEV * DT_ENRG( 132.D+00, 54.D+00 )
20191 AMM132 = 132.D+00 * AMUGEV + AEX132
20192 AMN132 = AMM132 - 54.D+00 * AMELCT + FERTHO * 54.D+00**EXPEBN
20193 AEX181 = EMVGEV * DT_ENERGY( 181.D+00, 73.D+00 )
20194 CEX181 = EMVGEV * DT_ENRG( 181.D+00, 73.D+00 )
20195 AMM181 = 181.D+00 * AMUGEV + AEX181
20196 AMN181 = AMM181 - 73.D+00 * AMELCT + FERTHO * 73.D+00**EXPEBN
20197 AEX208 = EMVGEV * DT_ENERGY( 208.D+00, 82.D+00 )
20198 CEX208 = EMVGEV * DT_ENRG( 208.D+00, 82.D+00 )
20199 AMM208 = 208.D+00 * AMUGEV + AEX208
20200 AMN208 = AMM208 - 82.D+00 * AMELCT + FERTHO * 82.D+00**EXPEBN
20201 AEX238 = EMVGEV * DT_ENERGY( 238.D+00, 92.D+00 )
20202 CEX238 = EMVGEV * DT_ENRG( 238.D+00, 92.D+00 )
20203 AMM238 = 238.D+00 * AMUGEV + AEX238
20204 AMN238 = AMM238 - 92.D+00 * AMELCT + FERTHO * 92.D+00**EXPEBN
20205
20206 AMHEAV (1) = AMUGEV + EMVGEV * DT_ENERGY( ONEONE, ZERZER )
20207 AMHEAV (2) = AMUGEV + EMVGEV * DT_ENERGY( ONEONE, ONEONE )
20208 AMHEAV (3) = TWOTWO * AMUGEV
20209 & + EMVGEV * DT_ENERGY( TWOTWO, ONEONE )
20210 AMHEAV (4) = THRTHR * AMUGEV
20211 & + EMVGEV * DT_ENERGY( THRTHR, ONEONE )
20212 AMHEAV (5) = THRTHR * AMUGEV
20213 & + EMVGEV * DT_ENERGY( THRTHR, TWOTWO )
20214 AMHEAV (6) = FOUFOU * AMUGEV
20215 & + EMVGEV * DT_ENERGY( FOUFOU, TWOTWO )
20216 ELBNDE (0) = ZERZER
20217 ELBNDE (1) = 13.6D-09
20218 DO 2000 IZ = 2, 100
20219 ELBNDE ( IZ ) = FERTHO * DBLE ( IZ )**EXPEBN
202202000 CONTINUE
20221 AMNHEA (1) = AMHEAV (1) + ELBNDE (0)
20222 AMNHEA (2) = AMHEAV (2) - AMELCT + ELBNDE (1)
20223 AMNHEA (3) = AMHEAV (3) - AMELCT + ELBNDE (1)
20224 AMNHEA (4) = AMHEAV (4) - AMELCT + ELBNDE (1)
20225 AMNHEA (5) = AMHEAV (5) - TWOTWO * AMELCT + ELBNDE (2)
20226 AMNHEA (6) = AMHEAV (6) - TWOTWO * AMELCT + ELBNDE (2)
20227 IF ( LEVPRT ) THEN
20228 WRITE ( LUNOUT, * )' **** Evaporation from residual nucleus',
20229 & ' activated **** '
20230 IF ( LDEEXG ) WRITE ( LUNOUT, * )' **** Deexcitation gamma',
20231 & ' production activated **** '
20232**sr 18.5.95
20233* commented, since obsolete
20234C IF ( LHEAVY ) WRITE ( LUNOUT, * )' **** Evaporated "heavies"',
20235C & ' transport activated **** '
20236 IF ( IFISS .GT. 0 )
20237 & WRITE ( LUNOUT, * )' **** High Energy fission ',
20238 & ' requested & activated **** '
20239 IF ( LFRMBK )
20240 & WRITE ( LUNOUT, * )' **** Fermi Break Up ',
20241 & ' requested & activated **** '
20242 IF ( LFRMBK ) CALL DT_FRBKIN(.FALSE.,.FALSE.)
20243 ELSE
20244 LDEEXG = .FALSE.
20245 LHEAVY = .FALSE.
20246 LFRMBK = .FALSE.
20247 IFISS = 0
20248 END IF
20249 RETURN
20250*=== End of subroutine incini =========================================*
20251 END
20252
20253*$ CREATE DT_STALIN.FOR
20254*COPY DT_STALIN
20255* *
20256*=== stalin ===========================================================*
20257* *
20258 SUBROUTINE DT_STALIN
20259
20260 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20261 SAVE
20262 PARAMETER ( ANGLGB = 5.0D-16 )
20263 PARAMETER ( ZERZER = 0.D+00 )
20264 PARAMETER ( ONEONE = 1.D+00 )
20265 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
20266 PARAMETER ( AMUGEV = 0.93149432 D+00 )
20267 PARAMETER ( EMVGEV = 1.0 D-03 )
20268 PARAMETER ( NSTBIS = 304 )
20269 PARAMETER ( LUNIN = 5 )
20270 PARAMETER ( LUNOUT = 6 )
20271*
20272*----------------------------------------------------------------------*
20273* *
20274* STAbility LINe calculation: *
20275* *
20276* Created on 04 december 1992 by Alfredo Ferrari & Paola Sala *
20277* Infn - Milan *
20278* *
20279* Last change on 04-dec-92 by Alfredo Ferrari *
20280* *
20281* *
20282*----------------------------------------------------------------------*
20283*
20284* (original name: ISOTOP)
20285 PARAMETER ( NAMSMX = 270 )
20286 PARAMETER ( NZGVAX = 15 )
20287 PARAMETER ( NISMMX = 574 )
20288 COMMON /FKISOT/ WAPS (NAMSMX,NZGVAX), T12NUC (NAMSMX,NZGVAX),
20289 & WAPISM (NISMMX), T12ISM (NISMMX),
20290 & ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260),
20291 & AMSSST (100) , ISOMNM (NSTBIS), ISONDX (2,100),
20292 & JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX),
20293 & INWAPS (NAMSMX), JSPISM (NISMMX),
20294 & JPTISM (NISMMX), IZWISM (NISMMX),
20295 & INWISM (0:NAMSMX)
20296*
20297 DIMENSION ZNORM (260)
20298* +-------------------------------------------------------------------*
20299* |
20300 DO 1000 IZ=1,100
20301 DO 500 J=1,2
20302 ASTLIN (J,IZ) = ZERZER
20303 500 CONTINUE
20304 1000 CONTINUE
20305* |
20306* +-------------------------------------------------------------------*
20307* +-------------------------------------------------------------------*
20308* |
20309 DO 2000 IA=1,260
20310 ZNORM (IA) = ZERZER
20311 DO 1500 J=1,2
20312 ZSTLIN (J,IA) = ZERZER
20313 1500 CONTINUE
20314 2000 CONTINUE
20315* |
20316* +-------------------------------------------------------------------*
20317* +-------------------------------------------------------------------*
20318* | Loop on the Atomic Number
20319 DO 3000 IZ=1,100
20320 AMSSST (IZ) = ZERZER
20321 ANORM = ONEONE
20322 ZTAR = IZ
20323* | +----------------------------------------------------------------*
20324* | | Loop on the stable isotopes
20325 DO 2500 IS = ISONDX (1,IZ), ISONDX (2,IZ)
20326 IA = ISOMNM (IS)
20327 ASTLIN (1,IZ) = ASTLIN (1,IZ) + ABUISO (IS) * IA
20328 ASTLIN (2,IZ) = ASTLIN (2,IZ) + ABUISO (IS) * IA**2
20329 ZNORM (IA) = ZNORM (IA) + ABUISO (IS)
20330 ZSTLIN (1,IA) = ZSTLIN (1,IA) + ABUISO (IS) * IZ
20331 ZSTLIN (2,IA) = ZSTLIN (2,IA) + ABUISO (IS) * IZ**2
20332 AHELP = IA
20333 IF ( AHELP .LE. 1.00001D+00 ) THEN
20334 ANORM = ONEONE / ( ONEONE - ABUISO (IS) )
20335 GO TO 2500
20336 END IF
20337 AMSSST (IZ) = ABUISO (IS) * ( AHELP * AMUGEV
20338 & + EMVGEV * DT_ENERGY(AHELP,ZTAR) ) + AMSSST (IZ)
20339 2500 CONTINUE
20340* | |
20341* | +----------------------------------------------------------------*
20342 AMSSST (IZ) = ANORM * AMSSST (IZ) / AMUGEV
20343* | Normalize and print A_stab versus Z data:
20344 ASTLIN (2,IZ) = MAX ( SQRT (ASTLIN(2,IZ)-ASTLIN(1,IZ)**2),
20345 & 0.5D+00 )
20346* WRITE (LUNOUT,*)' Z:',IZ,' A_stab:',SNGL(ASTLIN(1,IZ)),
20347* & ' Sigma_st',SNGL(ASTLIN(2,IZ))
20348 3000 CONTINUE
20349* |
20350* +-------------------------------------------------------------------*
20351* +-------------------------------------------------------------------*
20352* | Normalize and print Z_stab versus A data:
20353 DO 4000 IA=1,260
20354 ZSTLIN (1,IA) = ZSTLIN (1,IA) / MAX ( ZNORM (IA), 1.D-10 )
20355 ZSTLIN (2,IA) = ZSTLIN (2,IA) / MAX ( ZNORM (IA), 1.D-10 )
20356 ZSTLIN (2,IA) = MAX ( ZSTLIN (2,IA), ZSTLIN (1,IA)**2 )
20357 IF ( ZNORM (IA) .GT. ANGLGB )
20358**sr 2.11. avoid underflows at Pentium
20359 & ZSTLIN (2,IA) =
20360 & MAX ( SQRT ( ABS(ZSTLIN(2,IA)-ZSTLIN(1,IA)**2) ),
20361C & ZSTLIN (2,IA) = MAX ( SQRT (ZSTLIN(2,IA)-ZSTLIN(1,IA)**2),
20362 & 0.3D+00 )
20363 4000 CONTINUE
20364* |
20365* +-------------------------------------------------------------------*
20366* +-------------------------------------------------------------------*
20367* | Normalize and print Z_stab versus A data:
20368 DO 5000 IA=1,260
20369 IF ( ZNORM (IA) .LE. ANGLGB ) THEN
20370 DO 4200 JA = IA-1,1,-1
20371 IF ( ZNORM (JA) .GT. ANGLGB ) THEN
20372 IA1 = JA
20373 GO TO 4300
20374 END IF
20375 4200 CONTINUE
20376 4300 CONTINUE
20377 DO 4400 JA = IA+1,260
20378 IF ( ZNORM (JA) .GT. ANGLGB ) THEN
20379 IA2 = JA
20380 GO TO 4500
20381 END IF
20382 4400 CONTINUE
20383 IA2 = IA1
20384 IA1 = IA1 - 1
20385 4500 CONTINUE
20386 ZSTLIN (1,IA) = DBLE (IA-IA1) / DBLE (IA2-IA1)
20387 & * ( ZSTLIN (1,IA2) - ZSTLIN (1,IA1) )
20388 & + ZSTLIN (1,IA1)
20389 ZSTLIN (2,IA) = DBLE (IA-IA1) / DBLE (IA2-IA1)
20390 & * ( ZSTLIN (2,IA2) - ZSTLIN (2,IA1) )
20391 & + ZSTLIN (2,IA1)
20392 END IF
20393 IZ = MIN ( 100, NINT (ZSTLIN(1,IA)) )
20394 ATOZ = IZ / ASTLIN (1,IZ)
20395 ZSTLIN (2,IA) = MAX ( ZSTLIN (2,IA), ATOZ * ASTLIN (2,IZ) )
20396* WRITE (LUNOUT,*)' A:',IA,' Z_stab:',SNGL(ZSTLIN(1,IA)),
20397* & ' Sigma_st',SNGL(ZSTLIN(2,IA))
20398 5000 CONTINUE
20399* |
20400* +-------------------------------------------------------------------*
20401 RETURN
20402 END
20403
20404*$ CREATE DT_BERTTP.FOR
20405*COPY DT_BERTTP
20406*
20407*=== berttp ===========================================================*
20408* *
20409 SUBROUTINE DT_BERTTP
20410
20411 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20412 SAVE
20413
20414 PARAMETER ( CSNNRM = 2.0D-15 )
20415 PARAMETER ( ZERZER = 0.D+00 )
20416 PARAMETER ( ONEONE = 1.D+00 )
20417 PARAMETER ( THRTHR = 3.D+00 )
20418 PARAMETER ( SIXSIX = 6.D+00 )
20419 PARAMETER ( ONETHI = ONEONE / THRTHR )
20420 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
20421 PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
20422 PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
20423 PARAMETER ( EMVGEV = 1.0 D-03 )
20424
20425 PARAMETER ( NSTBIS = 304 )
20426
20427 PARAMETER ( LUNIN = 5 )
20428 PARAMETER ( LUNOUT = 6 )
20429**sr 19.5. set error output-unit from 15 to 6
20430 PARAMETER ( LUNERR = 6 )
20431C---------------------------------------------------------------------
20432C SUBNAME = DT_BERTTP --- READ BERTINI DATA
20433C---------------------------------------------------------------------
20434C ---------------------------------- I-N-C DATA
20435C COMMON R8(2127),R4(64),CRSC(600,4),R8B(336),CS(29849)
20436C REAL*8 R8,R8B,CRSC,CS
20437C REAL*4 R4
20438C --------------------------------- EVAPORATION DATA
20439* (original name: COOKCM)
20440 PARAMETER ( ASMTOG = SIXSIX / PIPIPI**2 )
20441 LOGICAL LDEFOZ, LDEFON
20442 PARAMETER ( INCOOK = 150, IZCOOK = 98 )
20443 COMMON /FKCOOK/ ALPIGN, BETIGN, GAMIGN, POWIGN,
20444 & SZCOOK (IZCOOK), SNCOOK (INCOOK), PZCOOK (IZCOOK),
20445 & PNCOOK (INCOOK), LDEFOZ (IZCOOK), LDEFON (INCOOK)
20446* (original name: EVA0)
20447 COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
20448 * FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
20449 * CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
20450 * T (4,7), RMASS (297), ALPH (297), BET (297),
20451 * APRIME (250), IA (6), IZ (6)
20452* (original name: FRBKCM)
20453 PARAMETER ( MXFFBK = 6 )
20454 PARAMETER ( MXZFBK = 9 )
20455 PARAMETER ( MXNFBK = 10 )
20456 PARAMETER ( MXAFBK = 16 )
20457 PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
20458 PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
20459 PARAMETER ( NXAFBK = MXAFBK + 1 )
20460 PARAMETER ( MXPSST = 300 )
20461 PARAMETER ( MXPSFB = 41000 )
20462 LOGICAL LFRMBK, LNCMSS
20463 COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
20464 & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
20465 & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
20466 & IFRBKN (MXPSST), IFRBKZ (MXPSST),
20467 & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
20468 & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
20469 & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
20470 & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
20471 & IFBFRB, NBUFBK, LFRMBK, LNCMSS
20472* (original name: HETTP)
20473 COMMON /FKHETP/ NHSTP,NBERTP,IOSUB,INSRS
20474* (original name: INPFLG)
20475 COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
20476* (original name: ISOTOP)
20477 PARAMETER ( NAMSMX = 270 )
20478 PARAMETER ( NZGVAX = 15 )
20479 PARAMETER ( NISMMX = 574 )
20480 COMMON /FKISOT/ WAPS (NAMSMX,NZGVAX), T12NUC (NAMSMX,NZGVAX),
20481 & WAPISM (NISMMX), T12ISM (NISMMX),
20482 & ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260),
20483 & AMSSST (100) , ISOMNM (NSTBIS), ISONDX (2,100),
20484 & JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX),
20485 & INWAPS (NAMSMX), JSPISM (NISMMX),
20486 & JPTISM (NISMMX), IZWISM (NISMMX),
20487 & INWISM (0:NAMSMX)
20488* (original name: NUCGID,NUCGEO,NUCGE2,NUCPWI,NUCGII)
20489 PARAMETER ( PI = PIPIPI )
20490 PARAMETER ( PISQ = PIPISQ )
20491 PARAMETER ( SKTOHL = 0.5456645846610345D+00 )
20492 PARAMETER ( RZNUCL = 1.12 D+00 )
20493 PARAMETER ( RMSPRO = 0.8 D+00 )
20494 PARAMETER ( R0PROT = RMSPRO / SQRT12 )
20495 PARAMETER ( ARHPRO = 1.D+00 / 8.D+00 / PI / R0PROT / R0PROT
20496 & / R0PROT )
20497 PARAMETER ( RLLE04 = RZNUCL )
20498 PARAMETER ( RLLE16 = RZNUCL )
20499 PARAMETER ( RLGT16 = RZNUCL )
20500 PARAMETER ( RCLE04 = 0.75D+00 / PI / RLLE04 / RLLE04 / RLLE04 )
20501 PARAMETER ( RCLE16 = 0.75D+00 / PI / RLLE16 / RLLE16 / RLLE16 )
20502 PARAMETER ( RCGT16 = 0.75D+00 / PI / RLGT16 / RLGT16 / RLGT16 )
20503 PARAMETER ( SKLE04 = 1.4D+00 )
20504 PARAMETER ( SKLE16 = 1.9D+00 )
20505 PARAMETER ( SKGT16 = 2.4D+00 )
20506 PARAMETER ( HLLE04 = SKTOHL * SKLE04 )
20507 PARAMETER ( HLLE16 = SKTOHL * SKLE16 )
20508 PARAMETER ( HLGT16 = SKTOHL * SKGT16 )
20509 PARAMETER ( ALPHA0 = 0.1D+00 )
20510 PARAMETER ( OMALH0 = 1.D+00 - ALPHA0 )
20511 PARAMETER ( GAMSK0 = 0.9D+00 )
20512 PARAMETER ( OMGAS0 = 1.D+00 - GAMSK0 )
20513 PARAMETER ( POTME0 = 0.6666666666666667D+00 )
20514 PARAMETER ( POTBA0 = 1.D+00 )
20515 PARAMETER ( PNFRAT = 1.533D+00 )
20516 PARAMETER ( RADPIM = 0.035D+00 )
20517 PARAMETER ( RDPMHL = 14.D+00 )
20518 PARAMETER ( APMRST = 4.D+00 / 44.D+00 )
20519 PARAMETER ( APMPRO = 1.D+00 / 6.D+00 )
20520 PARAMETER ( APPPRO = 5.D+00 / 6.D+00 )
20521 PARAMETER ( AP0PFS = 0.5D+00 )
20522 PARAMETER ( AP0PFP = 1.D+00 / 3.D+00 )
20523 PARAMETER ( AP0NFP = 2.D+00 / 3.D+00 )
20524 PARAMETER ( XPAUCO = 1.88495407241652 D+00 )
20525 PARAMETER ( MXSCIN = 50 )
20526 LOGICAL LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH, LNCDCY,
20527 & LNUSCT, LPREEQ, LNPHTC, LNWRAD, LPNRHO, LFTCMP, LFTCAC
20528 COMMON /FKNGID/ RHOTAB (2:260), RHATAB (2:260), ALPTAB (2:260),
20529 & RADTAB (2:260), SKITAB (2:260), HALTAB (2:260),
20530 & SK3TAB (2:260), SK4TAB (2:260), HABTAB (2:260),
20531 & CWSTAB (2:260), EKATAB (2:260), PFATAB (2:260),
20532 & PFRTAB (2:260)
20533 COMMON /FKNGEO/ RADTOT, RADIU1, RADIU0, RAD1O2, SKINDP, HALODP,
20534 & ALPHAL, OMALHL, RADSKN, SKNEFF, CPARWS, RADPRO,
20535 & RADCOR, RADCO2, RADMAX, BIMPTR, RIMPTR, XIMPTR,
20536 & YIMPTR, ZIMPTR, RHOIMT, EKFPRO, PFRPRO, RHOCEN,
20537 & RHOCOR, RHOSKN, EKFCEN (2), PFRCEN (2), EKFBIM,
20538 & PFRBIM, RHOIMP, EKFIMP, PFRIMP, RHOIM2, EKFIM2,
20539 & PFRIM2, RHOIM3, EKFIM3, PFRIM3, VPRWLL, RIMPCT,
20540 & BIMPCT, XIMPCT, YIMPCT, ZIMPCT, RIMPC2, XIMPC2,
20541 & YIMPC2, ZIMPC2, RIMPC3, XIMPC3, YIMPC3, ZIMPC3,
20542 & XBIMPC, YBIMPC, ZBIMPC, CXIMPC, CYIMPC, CZIMPC,
20543 & SQRIMP, SIGMAP, SIGMAN, SIGMAA, RHORED, R0TRAJ,
20544 & R1TRAJ, SBUSED, SBTOT , SBRES , RHOAVE, EKFAVE,
20545 & PFRAVE, AVEBIN, ACOLL , ZCOLL , RADSIG, OPACTY,
20546 & EKECON, PNUCCO, EKEWLL, PPRWLL, PXPROJ, PYPROJ,
20547 & PZPROJ, EKFERM, PNFRMI, PXFERM, PYFERM, PZFERM,
20548 & EKFER2, PNFRM2, PXFER2, PYFER2, PZFER2, EKFER3,
20549 & PNFRM3, PXFER3, PYFER3, PZFER3, RHOMEM, EKFMEM,
20550 & BIMMEM, WLLRED, VPRBIM, POTINC, POTOUT, EEXMIN
20551 COMMON /FKNGE2/ RDTTNC (2), RHONCP (2), RHONC2 (2), RHONC3 (2),
20552 & RHONCT (2), AMOTHR, EKOTHR, AMCREA, EKNCLN,
20553 & EEXDEL, EEXANY, CLMBBR, RDCLMB, BFCLMB, BFCEFF,
20554 & BNPROJ, BNDNUC, DEBRLM, SK4PAR, UBIMPC, VBIMPC,
20555 & WBIMPC, BNDPOT, SIGMAT, SIGABP, SIGABN, WLLRES,
20556 & POTBAR, POTMES, AGEPRI, OPNOPA, ETHRND,
20557 & BNENRG (3), DEFNUC (2), SIGMPR (4), SIGMNU (4),
20558 & SIGPAB (3), SIGNAB (3), HHLP (2), FORTOT (2),
20559 & FPNBLC, DPNBLC, FFTFLG, IFTFLG,
20560 & IPWELL, ITNCMX, KPRIN , NTARGT, KNUCIM, KNUCI2,
20561 & KNUCI3, IEVPRE, ISFCOL, ISFTAR, ISFTA2, ISFTA3,
20562 & NPOTHR, ICOTHR, IBOTHR, NPUMFN, ISTNCL, ITAUCM,
20563 & IABCOU, IADFLG, IGSFLG, IALFLG, ICBFLG, LPREEQ,
20564 & LNPHTC, LPNRHO, LNWRAD, LFTCMP, LFTCAC
20565 COMMON /FKNPWI/ ALMBAR, BIMMAX, SIGGEO, LLLMAX, LLLACT
20566 COMMON /FKNGII/ HOLEXP (2*MXSCIN), XEXPIN (3,0:MXSCIN),
20567 & YEXPIN (3,0:MXSCIN), ZEXPIN (3,0:MXSCIN),
20568 & AGEXIN (0:MXSCIN), RHOEXP (2), EKFEXP, EHLFIX,
20569 & NHLEXP, NHLFIX, IPRTYP, NNCEXI (0:MXSCIN),
20570 & NCEXPI (3,0:MXSCIN), ISEXIN (3,0:MXSCIN),
20571 & ISCTYP (0:MXSCIN), NUSCIN, NEXPEM,
20572 & LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH,
20573 & LNCDCY, LNUSCT
20574 DIMENSION AWSTAB (2:260), SIGMAB (3)
20575 EQUIVALENCE ( DEFPRO, DEFNUC (1) )
20576 EQUIVALENCE ( DEFNEU, DEFNUC (2) )
20577 EQUIVALENCE ( RHOIPP, RHONCP (1) )
20578 EQUIVALENCE ( RHOINP, RHONCP (2) )
20579 EQUIVALENCE ( RHOIP2, RHONC2 (1) )
20580 EQUIVALENCE ( RHOIN2, RHONC2 (2) )
20581 EQUIVALENCE ( RHOIP3, RHONC3 (1) )
20582 EQUIVALENCE ( RHOIN3, RHONC3 (2) )
20583 EQUIVALENCE ( RHOIPT, RHONCT (1) )
20584 EQUIVALENCE ( RHOINT, RHONCT (2) )
20585 EQUIVALENCE ( OMALHL, SK3PAR )
20586 EQUIVALENCE ( ALPHAL, HABPAR )
20587 EQUIVALENCE ( ALPTAB (2), AWSTAB (2) )
20588 EQUIVALENCE ( SIGMPE, SIGMPR (1) )
20589 EQUIVALENCE ( SIGMPC, SIGMPR (2) )
20590 EQUIVALENCE ( SIGMPI, SIGMPR (3) )
20591 EQUIVALENCE ( SIGMPA, SIGMPR (4) )
20592 EQUIVALENCE ( SIGMNE, SIGMNU (1) )
20593 EQUIVALENCE ( SIGMNC, SIGMNU (2) )
20594 EQUIVALENCE ( SIGMNI, SIGMNU (3) )
20595 EQUIVALENCE ( SIGMNA, SIGMNU (4) )
20596 EQUIVALENCE ( SIGMA2, SIGPAB (1) )
20597 EQUIVALENCE ( SIGMA3, SIGPAB (2) )
20598 EQUIVALENCE ( SIGMAS, SIGPAB (3) )
20599 EQUIVALENCE ( SIGPAB (1), SIGMAB (1) )
20600* (original name: NUCLEV)
20601 LOGICAL LCLVSL, LFLVSL, LRLVSL, LEQSBL
20602 COMMON /FKNLEV/ PAENUC (200,2), SHENUC (200,2), DEFRMI (2),
20603 & DEFMAG (2), ENNCLV (160,2), RANCLV (160,2),
20604 & CUMRAD (0:160,2), RUSNUC (2),
20605 & ENPLVL (114), ENNLVL(164), JUSNUC (160,2),
20606 & NTANUC (2), NAVNUC (2), NLSNUC (2), NCONUC (2),
20607 & NSKNUC (2), NHANUC (2), NUSNUC (2), NACNUC (2),
20608 & JMXNUC (2), IPRNUC (3), JPRNUC (3), MAGNUM (8),
20609 & MAGNUC (2), MGSNUC (8,2), MGSSNC (25,2),
20610 & NSBSHL (2), NMNSBS (2), NPRNUC, INUCLV, LCLVSL,
20611 & LFLVSL, LRLVSL, LEQSBL
20612 DIMENSION JUSPRO (160), JUSNEU (160), MGSPRO (8), MGSNEU (8),
20613 & MGSSPR (19) , MGSSNE (25)
20614 EQUIVALENCE ( RUSNUC (1), RUSPRO )
20615 EQUIVALENCE ( RUSNUC (2), RUSNEU )
20616 EQUIVALENCE ( JUSNUC (1,1), JUSPRO (1) )
20617 EQUIVALENCE ( JUSNUC (1,2), JUSNEU (1) )
20618 EQUIVALENCE ( MGSNUC (1,1), MGSPRO (1) )
20619 EQUIVALENCE ( MGSNUC (1,2), MGSNEU (1) )
20620 EQUIVALENCE ( MGSSNC (1,1), MGSSPR (1) )
20621 EQUIVALENCE ( MGSSNC (1,2), MGSSNE (1) )
20622 EQUIVALENCE ( NTANUC (1), NTAPRO )
20623 EQUIVALENCE ( NTANUC (2), NTANEU )
20624 EQUIVALENCE ( NAVNUC (1), NAVPRO )
20625 EQUIVALENCE ( NAVNUC (2), NAVNEU )
20626 EQUIVALENCE ( NLSNUC (1), NLSPRO )
20627 EQUIVALENCE ( NLSNUC (2), NLSNEU )
20628 EQUIVALENCE ( NCONUC (1), NCOPRO )
20629 EQUIVALENCE ( NCONUC (2), NCONEU )
20630 EQUIVALENCE ( NSKNUC (1), NSKPRO )
20631 EQUIVALENCE ( NSKNUC (2), NSKNEU )
20632 EQUIVALENCE ( NHANUC (1), NHAPRO )
20633 EQUIVALENCE ( NHANUC (2), NHANEU )
20634 EQUIVALENCE ( NUSNUC (1), NUSPRO )
20635 EQUIVALENCE ( NUSNUC (2), NUSNEU )
20636 EQUIVALENCE ( NACNUC (1), NACPRO )
20637 EQUIVALENCE ( NACNUC (2), NACNEU )
20638 EQUIVALENCE ( JMXNUC (1), JMXPRO )
20639 EQUIVALENCE ( JMXNUC (2), JMXNEU )
20640 EQUIVALENCE ( MAGNUC (1), MAGPRO )
20641 EQUIVALENCE ( MAGNUC (2), MAGNEU )
20642* (original name: PAREVT)
20643 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
20644 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
20645 PARAMETER ( NALLWP = 39 )
20646 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
20647 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
20648 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
20649 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
20650* (original name: XSEPAR)
20651 COMMON /FKXSEP/ AANXSE (100), BBNXSE (100), CCNXSE (100),
20652 & DDNXSE (100), EENXSE (100), ZZNXSE (100),
20653 & EMNXSE (100), XMNXSE (100),
20654 & AAPXSE (100), BBPXSE (100), CCPXSE (100),
20655 & DDPXSE (100), EEPXSE (100), FFPXSE (100),
20656 & ZZPXSE (100), EMPXSE (100), XMPXSE (100)
20657
20658C---------------------------------------------------------------------
20659**sr 17.5.95
20660* modified for use in DPMJET
20661C WRITE( LUNOUT,'(A,I2)')
20662C & ' *** Reading evaporation and nuclear data from unit: ', NBERTP
20663C REWIND NBERTP
20664 IF (LEVPRT) WRITE(LUNOUT,1000)
20665 1000 FORMAT(/,1X,'BERTTP:',4X,'Initialization of evaporation module',
20666 & /,12X,'------------------------------------',/)
20667 NBERNW = 23
f87dab60 20668CPH OPEN (UNIT=NBERNW,FILE='dpmjet.dat',STATUS='UNKNOWN')
9aaba0d6 20669
20670**sr 17.5.
20671*!!!! changed to be able to read the ASCII !!!!
20672**
20673C A. Ferrari: first of all read isotopic data
20674 READ (NBERNW,*) ISONDX
20675 READ (NBERNW,*) ISOMNM
20676 READ (NBERNW,*) ABUISO
20677C READ (NBERTP) ISONDX
20678C READ (NBERTP) ISOMNM
20679C READ (NBERTP) ABUISO
20680 DO 1 I=1,4
20681C READ (NBERTP) (CRSC(J,I),J=1,600)
20682C A. Ferrari: commented also the dummy read to save disk space
20683C READ (NBERTP)
20684 1 CONTINUE
20685C READ (NBERTP) CS
20686C A. Ferrari: commented also the dummy read to save disk space
20687C READ (NBERTP)
20688C---------------------------------------------------------------------
20689 READ (NBERNW,*) (P0(I),P1(I),P2(I),I=1,1001)
20690 READ (NBERNW,*) IA,IZ
20691 DO 2 I=1,6
20692 FLA(I)=IA(I)
20693 FLZ(I)=IZ(I)
20694 2 CONTINUE
20695 READ (NBERNW,*) RHO,OMEGA
20696 READ (NBERNW,*) EXMASS
20697 READ (NBERNW,*) CAM2
20698 READ (NBERNW,*) CAM3
20699 READ (NBERNW,*) CAM4
20700 READ (NBERNW,*) CAM5
20701 READ (NBERNW,*) ((T(I,J),J=1,7),I=1,3)
20702 DO 3 I=1,7
20703 T(4,I) = ZERZER
20704 3 CONTINUE
20705 READ (NBERNW,*) RMASS
20706 READ (NBERNW,*) ALPH
20707 READ (NBERNW,*) BET
20708 READ (NBERNW,*) INWAPS
20709 READ (NBERNW,*) WAPS
20710 READ (NBERNW,*) T12NUC
20711 READ (NBERNW,*) JSPNUC
20712 READ (NBERNW,*) JPTNUC
20713 READ (NBERNW,*) INWISM
20714 READ (NBERNW,*) IZWISM
20715 READ (NBERNW,*) WAPISM
20716 READ (NBERNW,*) T12ISM
20717 READ (NBERNW,*) JSPISM
20718 READ (NBERNW,*) JPTISM
20719 READ (NBERNW,*) APRIME
20720 IF (LEVPRT)
20721 &WRITE( LUNOUT,'(A)' ) ' *** Evaporation: using 1977 Waps data ***'
20722 READ (NBERNW,*) AHELP , BHELP , LRMSCH, LRD1O2, LTRASP
20723 IF ( ABS (AHELP-ALPHA0) .GT. CSNNRM * ALPHA0 .OR.
20724 & ABS (BHELP-GAMSK0) .GT. CSNNRM * GAMSK0 ) THEN
20725 WRITE (LUNOUT,*)
20726 & ' *** Inconsistent Nuclear Geometry data on file ***'
20727 STOP
20728 END IF
20729 READ (NBERNW,*) RHOTAB, RHATAB, ALPTAB, RADTAB, SKITAB, HALTAB,
20730 & EKATAB, PFATAB, PFRTAB
20731 READ (NBERNW,*) AANXSE, BBNXSE, CCNXSE, DDNXSE, EENXSE, ZZNXSE,
20732 & EMNXSE, XMNXSE
20733 READ (NBERNW,*) AAPXSE, BBPXSE, CCPXSE, DDPXSE, EEPXSE, FFPXSE,
20734 & ZZPXSE, EMPXSE, XMPXSE
20735* Data about Fermi-breakup:
20736 READ (NBERNW,*) IPOSST, MXPDUM, MXADUM, MXNDUM, MXZDUM, IFBSTF
20737 IF ( MXADUM .NE. MXAFBK .OR. MXNDUM .NE. MXNFBK .OR. MXZDUM .NE.
20738 & MXZFBK .OR. MXPDUM .NE. MXPSST ) THEN
20739 WRITE (LUNOUT,*)' *** Inconsistent Fermi BreakUp data',
20740 & ' in the Nuclear Data file ***'
20741 STOP 'STOP:BERTTP-INCONS-FERMI-BREAKUP-DATA'
20742 END IF
20743 READ (NBERNW,*) IFRBKN
20744 READ (NBERNW,*) IFRBKZ
20745 READ (NBERNW,*) IFBKSP
20746 READ (NBERNW,*) IFBKST
20747 READ (NBERNW,*) EEXFBK
20748
20749 CLOSE (UNIT=NBERNW)
20750
20751C READ (NBERTP) (P0(I),P1(I),P2(I),I=1,1001)
20752C READ (NBERTP) IA,IZ
20753C DO 2 I=1,6
20754C FLA(I)=IA(I)
20755C FLZ(I)=IZ(I)
20756C 2 CONTINUE
20757C READ (NBERTP) RHO,OMEGA
20758C READ (NBERTP) EXMASS
20759C READ (NBERTP) CAM2
20760C READ (NBERTP) CAM3
20761C READ (NBERTP) CAM4
20762C READ (NBERTP) CAM5
20763C READ (NBERTP) ((T(I,J),J=1,7),I=1,3)
20764C DO 3 I=1,7
20765C T(4,I) = ZERZER
20766C 3 CONTINUE
20767C READ (NBERTP) RMASS
20768C READ (NBERTP) ALPH
20769C READ (NBERTP) BET
20770C READ (NBERTP) INWAPS
20771C READ (NBERTP) WAPS
20772C READ (NBERTP) T12NUC
20773C READ (NBERTP) JSPNUC
20774C READ (NBERTP) JPTNUC
20775C READ (NBERTP) INWISM
20776C READ (NBERTP) IZWISM
20777C READ (NBERTP) WAPISM
20778C READ (NBERTP) T12ISM
20779C READ (NBERTP) JSPISM
20780C READ (NBERTP) JPTISM
20781C READ (NBERTP) APRIME
20782C WRITE( LUNOUT,'(A)' ) ' *** Evaporation: using 1977 Waps data ***'
20783C READ (NBERTP) AHELP , BHELP , LRMSCH, LRD1O2, LTRASP
20784C IF ( ABS (AHELP-ALPHA0) .GT. CSNNRM * ALPHA0 .OR.
20785C & ABS (BHELP-GAMSK0) .GT. CSNNRM * GAMSK0 ) THEN
20786C WRITE (LUNOUT,*)
20787C & ' *** Inconsistent Nuclear Geometry data on file ***'
20788C STOP
20789C END IF
20790C READ (NBERTP) RHOTAB, RHATAB, ALPTAB, RADTAB, SKITAB, HALTAB,
20791C & EKATAB, PFATAB, PFRTAB
20792C READ (NBERTP) AANXSE, BBNXSE, CCNXSE, DDNXSE, EENXSE, ZZNXSE,
20793C & EMNXSE, XMNXSE
20794C READ (NBERTP) AAPXSE, BBPXSE, CCPXSE, DDPXSE, EEPXSE, FFPXSE,
20795C & ZZPXSE, EMPXSE, XMPXSE
20796* Data about Fermi-breakup:
20797C READ (NBERTP) IPOSST, MXPDUM, MXADUM, MXNDUM, MXZDUM, IFBSTF
20798C IF ( MXADUM .NE. MXAFBK .OR. MXNDUM .NE. MXNFBK .OR. MXZDUM .NE.
20799C & MXZFBK .OR. MXPDUM .NE. MXPSST ) THEN
20800C WRITE (LUNOUT,*)' *** Inconsistent Fermi BreakUp data',
20801C & ' in the Nuclear Data file ***'
20802C STOP 'STOP:BERTTP-INCONS-FERMI-BREAKUP-DATA'
20803C END IF
20804C READ (NBERTP) IFRBKN
20805C READ (NBERTP) IFRBKZ
20806C READ (NBERTP) IFBKSP
20807C READ (NBERTP) IFBKST
20808C READ (NBERTP) EEXFBK
20809C CLOSE (UNIT=NBERTP)
20810 DO 100 JZ = 1, 130
20811 SHENUC ( JZ, 1 ) = EMVGEV * ( CAM2 (JZ) + CAM4 (JZ) )
20812 100 CONTINUE
20813 DO 200 JA = 1, 200
20814 SHENUC ( JA, 2 ) = EMVGEV * ( CAM3 (JA) + CAM5 (JA) )
20815 200 CONTINUE
20816 CALL DT_STALIN
20817 IF ( ILVMOD .LE. 0 ) THEN
20818 ILVMOD = IB0
20819 ELSE
20820 IB0 = ILVMOD
20821 END IF
20822 IF ( LLVMOD ) THEN
20823 DO 300 JZ = 1, IZCOOK
20824 CAM4 (JZ) = PZCOOK (JZ)
20825 300 CONTINUE
20826 DO 400 JN = 1, INCOOK
20827 CAM5 (JN) = PNCOOK (JZ)
20828 400 CONTINUE
20829 END IF
20830**sr
20831 IF (LEVPRT) THEN
20832 WRITE (LUNOUT,*)
20833 IF ( ILVMOD .EQ. 1 ) THEN
20834 WRITE (LUNOUT,*)
20835 & ' **** Standard EVAP T=0 level density used ****'
20836 ELSE IF ( ILVMOD .EQ. 2 ) THEN
20837 WRITE (LUNOUT,*)
20838 & ' **** Gilbert & Cameron T=0 N,Z-dep. level density used ****'
20839 ELSE IF ( ILVMOD .EQ. 3 ) THEN
20840 WRITE (LUNOUT,*)
20841 & ' **** Julich A-dependent level density used ****'
20842 ELSE IF ( ILVMOD .EQ. 4 ) THEN
20843 WRITE (LUNOUT,*)
20844 & ' **** Brancazio & Cameron T=0 N,Z-dep. level density used',
20845 & ' ****'
20846 ELSE
20847 WRITE (LUNOUT,*)
20848 & ' **** Unknown T=0 level density option requested ****'
20849 STOP 'BERTTP-ILVMOD'
20850 END IF
20851 IF ( JLVMOD .LE. 0 ) THEN
20852 GAMIGN = ZERZER
20853 WRITE (LUNOUT,*)
20854 & ' **** No Excitation en. dependence for level densities ****'
20855 ELSE IF ( JLVMOD .EQ. 1 ) THEN
20856 WRITE (LUNOUT,*)
20857 & ' **** Ignyatuk (1975, 1st) level density en. dep. used ****'
20858 WRITE (LUNOUT,*)
20859 & ' **** with Ignyatuk (1975, 1st) set of parameters for T=oo',
20860 & ' ****'
20861 GAMIGN = 0.054D+00
20862 BETIGN = -6.3 D-05
20863 ALPIGN = 0.154D+00
20864 POWIGN = ZERZER
20865 ELSE IF ( JLVMOD .EQ. 2 ) THEN
20866 WRITE (LUNOUT,*)
20867 & ' **** Ignyatuk (1975, 1st) level density en. dep. used ****'
20868 WRITE (LUNOUT,*)
20869 & ' **** with UNKNOWN set of parameters for T=oo ****'
20870 STOP 'BERTTP-JLVMOD'
20871 ELSE IF ( JLVMOD .EQ. 3 ) THEN
20872 WRITE (LUNOUT,*)
20873 & ' **** Ignyatuk (1975, 1st) level density en. dep. used ****'
20874 WRITE (LUNOUT,*)
20875 & ' **** with UNKNOWN set of parameters for T=oo ****'
20876 STOP 'BERTTP-JLVMOD'
20877 ELSE IF ( JLVMOD .EQ. 4 ) THEN
20878 WRITE (LUNOUT,*)
20879 & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****'
20880 WRITE (LUNOUT,*)
20881 & ' **** with Ignyatuk (1975, 2nd) set of parameters for T=oo',
20882 & ' ****'
20883 GAMIGN = 0.054D+00
20884 BETIGN = 0.162D+00
20885 ALPIGN = 0.114D+00
20886 POWIGN = -ONETHI
20887 ELSE IF ( JLVMOD .EQ. 5 ) THEN
20888 WRITE (LUNOUT,*)
20889 & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****'
20890 WRITE (LUNOUT,*)
20891 & ' **** with Iljinov & Mebel 1st set of parameters for T=oo****'
20892 GAMIGN = 0.051D+00
20893 BETIGN = 0.098D+00
20894 ALPIGN = 0.114D+00
20895 POWIGN = -ONETHI
20896 ELSE IF ( JLVMOD .EQ. 6 ) THEN
20897 WRITE (LUNOUT,*)
20898 & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****'
20899 WRITE (LUNOUT,*)
20900 & ' **** with Iljinov & Mebel 2nd set of parameters for T=oo****'
20901 GAMIGN = -0.46D+00
20902 BETIGN = 0.107D+00
20903 ALPIGN = 0.111D+00
20904 POWIGN = -ONETHI
20905 ELSE IF ( JLVMOD .EQ. 7 ) THEN
20906 WRITE (LUNOUT,*)
20907 & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****'
20908 WRITE (LUNOUT,*)
20909 & ' **** with Iljinov & Mebel 3rd set of parameters for T=oo****'
20910 GAMIGN = 0.059D+00
20911 BETIGN = 0.257D+00
20912 ALPIGN = 0.072D+00
20913 POWIGN = -ONETHI
20914 ELSE IF ( JLVMOD .EQ. 8 ) THEN
20915 WRITE (LUNOUT,*)
20916 & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****'
20917 WRITE (LUNOUT,*)
20918 & ' **** with Iljinov & Mebel 4th set of parameters for T=oo****'
20919 GAMIGN = -0.37D+00
20920 BETIGN = 0.229D+00
20921 ALPIGN = 0.077D+00
20922 POWIGN = -ONETHI
20923 ELSE
20924 WRITE (LUNOUT,*)
20925 & ' **** Unknown T=oo level density option requested ****'
20926 STOP 'BERTTP-JLVMOD'
20927 END IF
20928 IF ( LLVMOD ) THEN
20929 WRITE (LUNOUT,*)
20930 & ' **** Cook''s modified pairing energy used ****'
20931 ELSE
20932 WRITE (LUNOUT,*)
20933 & ' **** Original Gilbert/Cameron pairing energy used ****'
20934 END IF
20935 ENDIF
20936**
20937
20938 ILVMOD = IB0
20939 DO 500 JZ = 1, 130
20940 PAENUC ( JZ, 1 ) = EMVGEV * CAM4 (JZ)
20941 500 CONTINUE
20942 DO 600 JA = 1, 200
20943 PAENUC ( JA, 2 ) = EMVGEV * CAM5 (JA)
20944 600 CONTINUE
20945 RETURN
20946 END
20947
20948*$ CREATE DT_EVEVAP.FOR
20949*COPY DT_EVEVAP
20950*
20951*====evevap============================================================*
20952*
20953 SUBROUTINE DT_EVEVAP(WE)
20954
20955 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20956 SAVE
20957 PARAMETER ( LINP = 10 ,
20958 & LOUT = 6 ,
20959 & LDAT = 9 )
20960
20961* flags for input different options
20962 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
20963 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
20964 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
20965
20966 LEVAPO = .FALSE.
20967
20968 RETURN
20969 END
20970
20971*$ CREATE DT_FRBKIN.FOR
20972*COPY DT_FRBKIN
20973*
20974*====frbkin============================================================*
20975*
20976 SUBROUTINE DT_FRBKIN(LDUM1,LDUM2)
20977
20978 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20979 SAVE
20980 PARAMETER ( LINP = 10 ,
20981 & LOUT = 6 ,
20982 & LDAT = 9 )
20983
20984 LOGICAL LDUM1,LDUM2
20985
20986 RETURN
20987 END
20988
20989*$ CREATE DT_EXPLOD.FOR
20990*COPY DT_EXPLOD
20991*
20992*=== explod ===========================================================*
20993*
20994 SUBROUTINE DT_EXPLOD( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
20995 & PYEXPL, PZEXPL )
20996
20997 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20998 SAVE
20999
21000 DIMENSION PXEXPL (NPEXPL), PYEXPL (NPEXPL), PZEXPL (NPEXPL),
21001 & ETEXPL (NPEXPL), AMEXPL (NPEXPL)
21002
21003 RETURN
21004 END
21005
21006************************************************************************
21007* *
21008* DPMJET 3.0: cross section routines *
21009* *
21010************************************************************************
21011*
21012*
21013* SUBROUTINE DT_SHNDIF
21014* diffractive cross sections (all energies)
21015* SUBROUTINE DT_PHOXS
21016* total and inel. cross sections from PHOJET interpol. tables
21017* SUBROUTINE DT_XSHN
21018* total and el. cross sections for all energies
21019* SUBROUTINE DT_SIHNAB
21020* pion 2-nucleon absorption cross sections
21021* SUBROUTINE DT_SIGEMU
21022* cross section for target "compounds"
21023* SUBROUTINE DT_SIGGA
21024* photon nucleus cross sections
21025* SUBROUTINE DT_SIGGAT
21026* photon nucleus cross sections from tables
21027* SUBROUTINE DT_SANO
21028* anomalous hard photon-nucleon cross sections from tables
21029* SUBROUTINE DT_SIGGP
21030* photon nucleon cross sections
21031* SUBROUTINE DT_SIGVEL
21032* quasi-elastic vector meson prod. cross sections
21033* DOUBLE PRECISION FUNCTION DT_SIGVP
21034* sigma_VN(tilde)
21035* DOUBLE PRECISION FUNCTION DT_RRM2
21036* DOUBLE PRECISION FUNCTION DT_RM2
21037* DOUBLE PRECISION FUNCTION DT_SAM2
21038* SUBROUTINE DT_CKMT
21039* SUBROUTINE DT_CKMTX
21040* SUBROUTINE DT_PDF0
21041* SUBROUTINE DT_CKMTQ0
21042* SUBROUTINE DT_CKMTDE
21043* SUBROUTINE DT_CKMTPR
21044* FUNCTION DT_CKMTFF
21045*
21046* SUBROUTINE DT_FLUINI
21047* total nucleon cross section fluctuation treatment
21048*
21049* SUBROUTINE DT_SIGTBL
21050* pre-tabulation of low-energy elastic x-sec. using SIHNEL
21051* SUBROUTINE DT_XSTABL
21052* service routines
21053*
21054*
21055*$ CREATE DT_SHNDIF.FOR
21056*COPY DT_SHNDIF
21057*
21058*===shndif===============================================================*
21059*
21060 SUBROUTINE DT_SHNDIF(ECM,KPROJ,KTARG,SIGDIF,SIGDIH)
21061
21062**********************************************************************
21063* Single diffractive hadron-nucleon cross sections *
21064* S.Roesler 14/1/93 *
21065* *
21066* The cross sections are calculated from extrapolated single *
21067* diffractive antiproton-proton cross sections (DTUJET92) using *
21068* scaling relations between total and single diffractive cross *
21069* sections. *
21070**********************************************************************
21071
21072 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21073 SAVE
21074 PARAMETER (ZERO=0.0D0)
21075
21076* particle properties (BAMJET index convention)
21077 CHARACTER*8 ANAME
21078 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21079 & IICH(210),IIBAR(210),K1(210),K2(210)
21080*
21081 CSD1 = 4.201483727D0
21082 CSD4 = -0.4763103556D-02
21083 CSD5 = 0.4324148297D0
21084*
21085 CHMSD1 = 0.8519297242D0
21086 CHMSD4 = -0.1443076599D-01
21087 CHMSD5 = 0.4014954567D0
21088*
21089 EPN = (ECM**2 -AAM(KPROJ)**2 -AAM(KTARG)**2)/(2.0D0*AAM(KTARG))
21090 PPN = SQRT((EPN-AAM(KPROJ))*(EPN+AAM(KPROJ)))
21091*
21092 SDIAPP = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
21093 SHMSD = CHMSD1+CHMSD4*LOG(PPN)**2+CHMSD5*LOG(PPN)
21094 FRAC = SHMSD/SDIAPP
21095*
21096 GOTO( 10, 20,999,999,999,999,999, 10, 20,999,
21097 & 999, 20, 20, 20, 20, 20, 10, 20, 20, 10,
21098 & 10, 10, 20, 20, 20) KPROJ
21099*
21100 10 CONTINUE
21101*---------------------------- p - p , n - p , sigma0+- - p ,
21102* Lambda - p
21103 CSD1 = 6.004476070D0
21104 CSD4 = -0.1257784606D-03
21105 CSD5 = 0.2447335720D0
21106 SIGDIF = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
21107 SIGDIH = FRAC*SIGDIF
21108 RETURN
21109*
21110 20 CONTINUE
21111*
21112 KPSCAL = 2
21113 KTSCAL = 1
21114C F = SDIAPP/DT_SHNTOT(KPSCAL,KTSCAL,ECM,ZERO)
21115 DUMZER = ZERO
21116 CALL DT_XSHN(KPSCAL,KTSCAL,DUMZER,ECM,SIGTO,SIGEL)
21117 F = SDIAPP/SIGTO
21118 KT = 1
21119C SIGDIF = DT_SHNTOT(KPROJ,KT,ECM,ZERO)*F
21120 CALL DT_XSHN(KPROJ,KT,DUMZER,ECM,SIGTO,SIGEL)
21121 SIGDIF = SIGTO*F
21122 SIGDIH = FRAC*SIGDIF
21123 RETURN
21124*
21125 999 CONTINUE
21126*-------------------------- leptons..
21127 SIGDIF = 1.D-10
21128 SIGDIH = 1.D-10
21129 RETURN
21130 END
21131
21132*$ CREATE DT_PHOXS.FOR
21133*COPY DT_PHOXS
21134*
21135*===phoxs================================================================*
21136*
21137 SUBROUTINE DT_PHOXS(KPROJ,KTARG,ECM,PLAB,STOT,SINE,SDIF1,BEL,MODE)
21138
21139************************************************************************
21140* Total/inelastic proton-nucleon cross sections taken from PHOJET- *
21141* interpolation tables. *
21142* This version dated 05.11.97 is written by S. Roesler *
21143************************************************************************
21144
21145 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21146 SAVE
21147
21148 PARAMETER ( LINP = 10 ,
21149 & LOUT = 6 ,
21150 & LDAT = 9 )
21151 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21152 PARAMETER (TWOPI = 6.283185307179586454D+00,
21153 & PI = TWOPI/TWO,
21154 & GEV2MB = 0.38938D0)
21155
21156 LOGICAL LFIRST
21157 DATA LFIRST /.TRUE./
21158
21159* nucleon-nucleon event-generator
21160 CHARACTER*8 CMODEL
21161 LOGICAL LPHOIN
21162 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21163* particle properties (BAMJET index convention)
21164 CHARACTER*8 ANAME
21165 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21166 & IICH(210),IIBAR(210),K1(210),K2(210)
21167
21168**PHOJET105a
21169C PARAMETER (IEETAB=10)
21170C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
21171**PHOJET110
21172C energy-interpolation table
21173 INTEGER IEETA2
21174 PARAMETER ( IEETA2 = 20 )
21175 INTEGER ISIMAX
21176 DOUBLE PRECISION SIGTAB,SIGECM
21177 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
21178**
21179
21180 IF ((MCGENE.NE.2).AND.(MODE.NE.1)) THEN
21181 WRITE(LOUT,*) MCGENE
21182 1000 FORMAT(1X,'PHOXS: warning! PHOJET not initialized (',I2,')')
21183 STOP
21184 ENDIF
21185
21186 IF (ECM.LE.ZERO) THEN
21187 EPN = SQRT(AAM(KPROJ)**2+PLAB**2)
21188 ECM = SQRT(AAM(KPROJ)**2+AAM(KTARG)**2+2.0D0*EPN*AAM(KTARG))
21189 ENDIF
21190
21191 IF (MODE.EQ.1) THEN
21192* DL
21193 DELDL = 0.0808D0
21194 EPSDL = -0.4525D0
21195 S = ECM*ECM
21196 STOT = 21.7D0*S**DELDL+56.08D0*S**EPSDL
21197 ALPHAP= 0.25D0
21198 BEL = 8.5D0+2.D0*ALPHAP*LOG(S)
21199 SIGEL = STOT**2/(16.D0*PI*BEL*GEV2MB)
21200 SINE = STOT-SIGEL
21201 SDIF1 = ZERO
21202 ELSE
21203* Phojet
21204 IP = 1
21205 IF(ECM.LE.SIGECM(IP,1)) THEN
21206 I1 = 1
21207 I2 = 1
21208 ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
21209 DO 1 I=2,ISIMAX
21210 IF (ECM.LE.SIGECM(IP,I)) GOTO 2
21211 1 CONTINUE
21212 2 CONTINUE
21213 I1 = I-1
21214 I2 = I
21215 ELSE
21216 IF (LFIRST) THEN
21217 WRITE(LOUT,'(/1X,A,2E12.3)')
21218 & 'PHOXS: warning! energy above initialization limit (',
21219 & ECM,SIGECM(IP,ISIMAX)
21220 LFIRST = .FALSE.
21221 ENDIF
21222 I1 = ISIMAX
21223 I2 = ISIMAX
21224 ENDIF
21225 FAC2 = ZERO
21226 IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
21227 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
21228 FAC1 = ONE-FAC2
21229 STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
21230 SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
21231 SDIF1 = FAC2*(SIGTAB(IP,30,I2)+SIGTAB(IP,32,I2))+
21232 & FAC1*(SIGTAB(IP,30,I1)+SIGTAB(IP,32,I1))
21233 BEL = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
21234 ENDIF
21235
21236 RETURN
21237 END
21238
21239*$ CREATE DT_XSHN.FOR
21240*COPY DT_XSHN
21241*
21242*===xshn===============================================================*
21243*
21244 SUBROUTINE DT_XSHN(IP,IT,PL,ECM,STOT,SELA)
21245
21246************************************************************************
21247* Total and elastic hadron-nucleon cross section. *
21248* Below 500GeV cross sections are based on the '98 data compilation *
21249* of the PDG. At higher energies PHOJET results are used (patched to *
21250* the low energy data at 500GeV). *
21251* IP projectile index (BAMJET numbering scheme) *
21252* (should be in the range 1..25) *
21253* IT target index (BAMJET numbering scheme) *
21254* (1 = proton, 8 = neutron) *
21255* PL laboratory momentum *
21256* ECM cm. energy (ignored if PL>0) *
21257* STOT total cross section *
21258* SELA elastic cross section *
21259* Last change: 24.4.99 by S. Roesler *
21260************************************************************************
21261
21262 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21263 SAVE
21264
21265 PARAMETER ( LINP = 10 ,
21266 & LOUT = 6 ,
21267 & LDAT = 9 )
21268 PARAMETER (ZERO=0.0D0,ONE=1.0D0)
21269
21270 PARAMETER (NPOIN1 = 54, NPOIN2 = 8,
21271 & PLABLO = 0.1D0, PTHRE = 5.0D0, PLABHI = 500.0D0)
21272 PARAMETER (NPOINT = NPOIN1+NPOIN2+1)
21273
21274 LOGICAL LFIRST
21275* particle properties (BAMJET index convention)
21276 CHARACTER*8 ANAME
21277 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21278 & IICH(210),IIBAR(210),K1(210),K2(210)
21279* nucleon-nucleon event-generator
21280 CHARACTER*8 CMODEL
21281 LOGICAL LPHOIN
21282 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21283**PHOJET105a
21284C PARAMETER (IEETAB=10)
21285C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
21286**PHOJET110
21287C energy-interpolation table
21288 INTEGER IEETA2
21289 PARAMETER ( IEETA2 = 20 )
21290 INTEGER ISIMAX
21291 DOUBLE PRECISION SIGTAB,SIGECM
21292 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
21293
21294 DIMENSION APL(NPOINT),ASIGTO(10,NPOINT),ASIGEL(10,NPOINT)
21295 DIMENSION IDXDAT(25,2)
21296*
21297 DATA APL /
21298 &-1.000,-0.969,-0.937,-0.906,-0.874,-0.843,-0.811,-0.780,-0.748,
21299 &-0.717,-0.685,-0.654,-0.622,-0.591,-0.560,-0.528,-0.497,-0.465,
21300 &-0.434,-0.402,-0.371,-0.339,-0.308,-0.276,-0.245,-0.213,-0.182,
21301 &-0.151,-0.119,-0.088,-0.056,-0.025, 0.007, 0.038, 0.070, 0.101,
21302 & 0.133, 0.164, 0.196, 0.227, 0.258, 0.290, 0.321, 0.353, 0.384,
21303 & 0.416, 0.447, 0.479, 0.510, 0.542, 0.573, 0.605, 0.636, 0.668,
21304 & 0.699, 0.949, 1.199, 1.449, 1.699, 1.949, 2.199, 2.449, 2.699/
21305*
21306* total cross sections:
21307* p p
21308 DATA (ASIGTO(1,K),K=1,NPOINT) /
21309 & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
21310 & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
21311 & 1.577, 1.518, 1.462, 1.420, 1.393, 1.375, 1.363, 1.356, 1.352,
21312 & 1.350, 1.351, 1.359, 1.381, 1.410, 1.444, 1.487, 1.544, 1.596,
21313 & 1.650, 1.672, 1.676, 1.677, 1.677, 1.675, 1.675, 1.669, 1.664,
21314 & 1.658, 1.653, 1.645, 1.640, 1.634, 1.630, 1.625, 1.620, 1.617,
21315 & 1.614, 1.602, 1.594, 1.589, 1.581, 1.583, 1.588, 1.596, 1.603/
21316* pbar p
21317 DATA (ASIGTO(2,K),K=1,NPOINT) /
21318 & 2.778, 2.759, 2.739, 2.718, 2.697, 2.675, 2.651, 2.626, 2.598,
21319 & 2.569, 2.537, 2.502, 2.471, 2.443, 2.420, 2.389, 2.361, 2.329,
21320 & 2.313, 2.304, 2.268, 2.244, 2.222, 2.212, 2.178, 2.162, 2.151,
21321 & 2.132, 2.109, 2.097, 2.089, 2.078, 2.063, 2.049, 2.035, 2.024,
21322 & 2.014, 2.004, 1.993, 1.981, 1.970, 1.958, 1.946, 1.933, 1.921,
21323 & 1.909, 1.894, 1.885, 1.871, 1.854, 1.836, 1.825, 1.816, 1.802,
21324 & 1.790, 1.744, 1.694, 1.663, 1.642, 1.614, 1.623, 1.623, 1.630/
21325* n p
21326 DATA (ASIGTO(3,K),K=1,NPOINT) /
21327 & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
21328 & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
21329 & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
21330 & 1.547, 1.534, 1.526, 1.522, 1.520, 1.525, 1.536, 1.550, 1.566,
21331 & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
21332 & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
21333 & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
21334* pi+ p
21335 DATA (ASIGTO(4,K),K=1,NPOINT) /
21336 & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
21337 & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
21338 & 2.001, 1.875, 1.801, 1.665, 1.609, 1.484, 1.412, 1.334, 1.195,
21339 & 1.160, 1.166, 1.208, 1.309, 1.356, 1.394, 1.406, 1.419, 1.473,
21340 & 1.540, 1.596, 1.570, 1.533, 1.516, 1.484, 1.471, 1.478, 1.492,
21341 & 1.497, 1.491, 1.479, 1.465, 1.453, 1.449, 1.450, 1.444, 1.428,
21342 & 1.422, 1.406, 1.384, 1.369, 1.364, 1.369, 1.374, 1.388, 1.395/
21343* pi- p
21344 DATA (ASIGTO(5,K),K=1,NPOINT) /
21345 & 0.458, 0.540, 0.626, 0.718, 0.819, 0.933, 1.063, 1.208, 1.226,
21346 & 1.436, 1.470, 1.594, 1.708, 1.786, 1.852, 1.836, 1.763, 1.679,
21347 & 1.590, 1.492, 1.445, 1.426, 1.423, 1.433, 1.473, 1.506, 1.547,
21348 & 1.660, 1.671, 1.545, 1.591, 1.687, 1.808, 1.656, 1.582, 1.543,
21349 & 1.562, 1.560, 1.537, 1.540, 1.549, 1.557, 1.557, 1.551, 1.535,
21350 & 1.527, 1.511, 1.510, 1.507, 1.500, 1.491, 1.483, 1.478, 1.468,
21351 & 1.463, 1.435, 1.408, 1.394, 1.384, 1.380, 1.383, 1.393, 1.411/
21352* K+ p
21353 DATA (ASIGTO(6,K),K=1,NPOINT) /
21354 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
21355 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
21356 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.096, 1.095,
21357 & 1.098, 1.105, 1.111, 1.139, 1.169, 1.209, 1.248, 1.259, 1.268,
21358 & 1.262, 1.257, 1.254, 1.252, 1.250, 1.249, 1.246, 1.244, 1.244,
21359 & 1.243, 1.240, 1.238, 1.237, 1.236, 1.235, 1.235, 1.236, 1.236,
21360 & 1.236, 1.233, 1.238, 1.248, 1.257, 1.272, 1.292, 1.311, 1.336/
21361* K- p
21362 DATA (ASIGTO(7,K),K=1,NPOINT) /
21363 & 2.003, 2.002, 2.001, 2.000, 1.999, 1.998, 1.998, 1.997, 1.997,
21364 & 1.996, 1.995, 1.993, 1.990, 1.992, 1.974, 1.912, 1.865, 1.847,
21365 & 1.896, 1.950, 1.827, 1.681, 1.637, 1.616, 1.589, 1.545, 1.543,
21366 & 1.532, 1.603, 1.604, 1.616, 1.658, 1.700, 1.658, 1.595, 1.508,
21367 & 1.493, 1.514, 1.531, 1.523, 1.501, 1.479, 1.474, 1.467, 1.463,
21368 & 1.450, 1.444, 1.435, 1.426, 1.424, 1.423, 1.415, 1.401, 1.396,
21369 & 1.384, 1.364, 1.330, 1.313, 1.310, 1.309, 1.317, 1.329, 1.338/
21370* K+ n
21371 DATA (ASIGTO(8,K),K=1,NPOINT) /
21372 & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21373 & 0.631, 0.675, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21374 & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.102, 1.125, 1.147,
21375 & 1.168, 1.187, 1.205, 1.224, 1.248, 1.279, 1.315, 1.324, 1.301,
21376 & 1.285, 1.279, 1.274, 1.273, 1.272, 1.271, 1.267, 1.263, 1.261,
21377 & 1.259, 1.256, 1.252, 1.247, 1.244, 1.241, 1.240, 1.240, 1.240,
21378 & 1.241, 1.243, 1.245, 1.253, 1.265, 1.275, 1.293, 1.314, 1.342/
21379* K- n
21380 DATA (ASIGTO(9,K),K=1,NPOINT) /
21381 & 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778,
21382 & 1.778, 1.778, 1.778, 1.778, 1.778, 1.779, 1.779, 1.778, 1.773,
21383 & 1.765, 1.746, 1.703, 1.646, 1.561, 1.488, 1.454, 1.437, 1.437,
21384 & 1.458, 1.505, 1.561, 1.588, 1.593, 1.581, 1.551, 1.500, 1.454,
21385 & 1.427, 1.408, 1.390, 1.372, 1.361, 1.356, 1.351, 1.347, 1.343,
21386 & 1.341, 1.340, 1.338, 1.337, 1.335, 1.334, 1.332, 1.331, 1.330,
21387 & 1.330, 1.313, 1.303, 1.288, 1.288, 1.297, 1.305, 1.320, 1.342/
21388* Lambda p
21389 DATA (ASIGTO(10,K),K=1,NPOINT) /
21390 & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21391 & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.629,
21392 & 1.599, 1.576, 1.558, 1.543, 1.530, 1.520, 1.512, 1.505, 1.499,
21393 & 1.495, 1.495, 1.497, 1.504, 1.514, 1.525, 1.536, 1.550, 1.567,
21394 & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
21395 & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
21396 & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
21397*
21398* elastic cross sections:
21399* p p
21400 DATA (ASIGEL(1,K),K=1,NPOINT) /
21401 & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
21402 & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
21403 & 1.577, 1.518, 1.462, 1.420, 1.393, 1.374, 1.360, 1.353, 1.350,
21404 & 1.351, 1.356, 1.362, 1.369, 1.376, 1.384, 1.385, 1.399, 1.397,
21405 & 1.389, 1.385, 1.379, 1.366, 1.358, 1.344, 1.320, 1.294, 1.275,
21406 & 1.260, 1.248, 1.235, 1.219, 1.199, 1.172, 1.144, 1.126, 1.115,
21407 & 1.104, 1.013, 0.962, 0.905, 0.869, 0.845, 0.846, 0.850, 0.868/
21408* pbar p
21409 DATA (ASIGEL(2,K),K=1,NPOINT) /
21410 & 1.987, 1.985, 1.983, 1.980, 1.978, 1.975, 1.971, 1.968, 1.963,
21411 & 1.958, 1.951, 1.944, 1.935, 1.925, 1.914, 1.902, 1.889, 1.875,
21412 & 1.859, 1.845, 1.834, 1.817, 1.792, 1.769, 1.754, 1.738, 1.720,
21413 & 1.702, 1.688, 1.676, 1.667, 1.659, 1.652, 1.645, 1.640, 1.636,
21414 & 1.620, 1.591, 1.562, 1.546, 1.540, 1.524, 1.496, 1.475, 1.457,
21415 & 1.429, 1.402, 1.373, 1.344, 1.330, 1.306, 1.294, 1.265, 1.228,
21416 & 1.204, 1.086, 0.977, 0.933, 0.914, 0.850, 0.862, 0.848, 0.845/
21417* n p
21418 DATA (ASIGEL(3,K),K=1,NPOINT) /
21419 & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
21420 & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
21421 & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
21422 & 1.544, 1.527, 1.514, 1.504, 1.495, 1.486, 1.476, 1.466, 1.454,
21423 & 1.440, 1.425, 1.409, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21424 & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21425 & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21426* pi+ p
21427 DATA (ASIGEL(4,K),K=1,NPOINT) /
21428 & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
21429 & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
21430 & 2.001, 1.875, 1.801, 1.664, 1.610, 1.479, 1.423, 1.299, 1.166,
21431 & 1.097, 1.020, 0.958, 0.914, 1.013, 1.088, 1.153, 1.167, 1.235,
21432 & 1.240, 1.237, 1.202, 1.135, 1.090, 1.026, 0.975, 0.941, 0.904,
21433 & 0.894, 0.884, 0.862, 0.850, 0.845, 0.827, 0.805, 0.789, 0.776,
21434 & 0.763, 0.686, 0.626, 0.562, 0.505, 0.518, 0.525, 0.528, 0.528/
21435* pi- p
21436 DATA (ASIGEL(5,K),K=1,NPOINT) /
21437 & 0.266, 0.278, 0.294, 0.320, 0.360, 0.419, 0.503, 0.608, 0.727,
21438 & 0.850, 0.968, 1.071, 1.167, 1.305, 1.369, 1.404, 1.446, 1.217,
21439 & 1.112, 1.071, 1.014, 1.002, 0.996, 1.008, 1.070, 1.126, 1.209,
21440 & 1.300, 1.281, 1.188, 1.156, 1.341, 1.423, 1.314, 1.171, 1.140,
21441 & 1.106, 1.071, 1.011, 1.037, 1.026, 1.024, 0.988, 0.953, 0.895,
21442 & 0.894, 0.880, 0.871, 0.864, 0.853, 0.837, 0.820, 0.809, 0.800,
21443 & 0.782, 0.674, 0.612, 0.530, 0.521, 0.528, 0.524, 0.542, 0.569/
21444* K+ p
21445 DATA (ASIGEL(6,K),K=1,NPOINT) /
21446 & 1.064, 1.065, 1.065, 1.066, 1.066, 1.066, 1.066, 1.066, 1.066,
21447 & 1.065, 1.064, 1.063, 1.062, 1.062, 1.062, 1.064, 1.066, 1.070,
21448 & 1.076, 1.082, 1.088, 1.096, 1.103, 1.104, 1.104, 1.102, 1.093,
21449 & 1.087, 1.084, 1.079, 1.075, 1.067, 1.058, 1.040, 1.029, 1.012,
21450 & 1.003, 0.985, 0.935, 0.909, 0.880, 0.846, 0.790, 0.771, 0.759,
21451 & 0.743, 0.718, 0.681, 0.666, 0.645, 0.622, 0.606, 0.594, 0.584,
21452 & 0.575, 0.513, 0.453, 0.403, 0.356, 0.365, 0.389, 0.430, 0.477/
21453* K- p
21454 DATA (ASIGEL(7,K),K=1,NPOINT) /
21455 & 1.941, 1.936, 1.931, 1.926, 1.919, 1.912, 1.903, 1.892, 1.878,
21456 & 1.863, 1.844, 1.821, 1.791, 1.755, 1.713, 1.666, 1.615, 1.561,
21457 & 1.533, 1.531, 1.518, 1.511, 1.452, 1.339, 1.265, 1.233, 1.188,
21458 & 1.184, 1.236, 1.316, 1.333, 1.336, 1.333, 1.277, 1.216, 1.077,
21459 & 1.018, 0.912, 0.926, 0.920, 0.910, 0.894, 0.830, 0.825, 0.800,
21460 & 0.788, 0.747, 0.703, 0.707, 0.689, 0.643, 0.633, 0.635, 0.618,
21461 & 0.584, 0.579, 0.461, 0.403, 0.405, 0.399, 0.408, 0.418, 0.413/
21462* K+ n
21463 DATA (ASIGEL(8,K),K=1,NPOINT) /
21464 & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21465 & 0.631, 0.676, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21466 & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.103, 1.126, 1.148,
21467 & 1.168, 1.187, 1.205, 1.223, 1.248, 1.282, 1.269, 1.185, 1.111,
21468 & 1.063, 1.031, 0.998, 0.964, 0.928, 0.889, 0.849, 0.814, 0.785,
21469 & 0.760, 0.738, 0.720, 0.703, 0.688, 0.674, 0.660, 0.648, 0.635,
21470 & 0.624, 0.536, 0.473, 0.442, 0.428, 0.428, 0.436, 0.453, 0.477/
21471* K- n
21472 DATA (ASIGEL(9,K),K=1,NPOINT) /
21473 & 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613,
21474 & 1.613, 1.613, 1.613, 1.612, 1.613, 1.614, 1.614, 1.612, 1.606,
21475 & 1.593, 1.564, 1.498, 1.402, 1.240, 1.071, 0.977, 0.922, 0.914,
21476 & 0.961, 1.077, 1.214, 1.271, 1.290, 1.281, 1.217, 1.096, 0.979,
21477 & 0.896, 0.822, 0.736, 0.655, 0.608, 0.591, 0.580, 0.569, 0.559,
21478 & 0.550, 0.540, 0.531, 0.522, 0.514, 0.507, 0.500, 0.494, 0.489,
21479 & 0.485, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477/
21480* Lambda p
21481 DATA (ASIGEL(10,K),K=1,NPOINT) /
21482 & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21483 & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.630,
21484 & 1.600, 1.577, 1.558, 1.542, 1.528, 1.518, 1.510, 1.505, 1.502,
21485 & 1.501, 1.500, 1.499, 1.496, 1.491, 1.485, 1.477, 1.466, 1.454,
21486 & 1.440, 1.425, 1.408, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21487 & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21488 & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21489
21490 DATA (IDXDAT(K,1),K=1,25) /
21491 & 1, 2, 0, 0, 0, 0, 0, 3, 2, 0, 0,67, 4, 5, 6, 7,10, 2,67, 3,
21492 & 1, 3,45, 8, 9/
21493 DATA (IDXDAT(K,2),K=1,25) /
21494 & 3, 2, 0, 0, 0, 0, 0, 1, 2, 0, 0,89, 5, 4, 8, 9, 1, 2,89, 1,
21495 & 3, 1,45, 6, 7/
21496
21497 DATA LFIRST /.TRUE./
21498
21499 IF (LFIRST) THEN
21500 APLABL = LOG10(PLABLO)
21501 APLABH = LOG10(PLABHI)
21502 APTHRE = LOG10(PTHRE)
21503 ADP1 = (APTHRE-APLABL)/DBLE(NPOIN1)
21504 ADP2 = (APLABH-APTHRE)/DBLE(NPOIN2)
21505 DUM0 = ZERO
21506 PHOPLA = PLABHI
21507 PHOELA = SQRT(AAM(1)**2+PHOPLA**2)
21508 ECMS = SQRT(2.0D0*AAM(1)**2+2.0D0*AAM(1)*PHOELA)
21509 IF (MCGENE.EQ.2) THEN
21510 IF (ECMS.LE.SIGECM(1,ISIMAX)) THEN
21511 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,0)
21512 ELSE
21513 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21514 ENDIF
21515 ELSE
21516 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21517 ENDIF
21518 PHOSEL = PHOSTO-PHOSIN
21519 APHOST = LOG10(PHOSTO)
21520 APHOSE = LOG10(PHOSEL)
21521 LFIRST = .FALSE.
21522 ENDIF
21523 STOT = ZERO
21524 SELA = ZERO
21525 PLAB = PL
21526 ECMS = ECM
21527 IF ( (IP.LT.1).OR.((IT.NE.1).AND.(IT.NE.8)) ) THEN
21528 WRITE(LOUT,1000) IP,IT
21529 1000 FORMAT(1X,'DT_XSHN: cross sections not implemented for ',
21530 & 'proj/target',2I4)
21531 STOP
21532 ENDIF
21533
21534 IF ((PLAB.LE.ZERO).AND.(ECMS.GT.ZERO)) THEN
21535 ELAB = (ECMS**2-AAM(IP)**2-AAM(IT)**2)/(2.0D0*AAM(IT))
21536 PLAB = SQRT((ELAB-AAM(IP))*(ELAB+AAM(IP)))
21537 ELSEIF ((PLAB.LE.ZERO).AND.(ECMS.LE.ZERO)) THEN
21538 WRITE(LOUT,1001) PLAB,ECMS
21539 1001 FORMAT(1X,'DT_XSHN: invalid momentum/cm-energy ',2E15.5)
21540 STOP
21541 ENDIF
21542
21543* index of spectrum
21544 IDXP = IP
21545 IF (IP.GT.25) THEN
21546 IF (AAM(IP).GT.ZERO) THEN
21547 IF (ABS(IIBAR(IP)).GT.0) THEN
21548 IDXP = 1
21549 ELSE
21550 IDXP = 13
21551 ENDIF
21552 ELSE
21553 IDXP = 7
21554 ENDIF
21555 ENDIF
21556 IDXT = 1
21557 IF (IT.EQ.8) IDXT = 2
21558 IDXS = IDXDAT(IDXP,IDXT)
21559 IF (IDXS.EQ.0) RETURN
21560
21561* compute momentum bin indices
21562 IF (PLAB.LT.PLABLO) THEN
21563 IDX0 = 1
21564 IDX1 = 1
21565 ELSEIF (PLAB.GE.PLABHI) THEN
21566 IDX0 = NPOINT
21567 IDX1 = NPOINT
21568 ELSE
21569 APLAB = LOG10(PLAB)
21570 IF ((PLAB.GE.PLABLO).AND.(PLAB.LT.PTHRE )) THEN
21571 IDX0 = INT((APLAB-APLABL)/ADP1)+1
21572 ELSEIF ((PLAB.GE.PTHRE ).AND.(PLAB.LT.PLABHI)) THEN
21573 IDX0 = INT((APLAB-APTHRE)/ADP2)+NPOIN1+1
21574 ENDIF
21575 IDX1 = IDX0+1
21576 ENDIF
21577
21578* interpolate cross section
21579 IF (IDXS.GT.10) THEN
21580 IDXS1 = IDXS/10
21581 IDXS2 = IDXS-10*IDXS1
21582 IF (IDX0.EQ.IDX1) THEN
21583 IF (IDX0.EQ.1) THEN
21584 ASTOT = 0.5D0*(ASIGTO(IDXS1,IDX0)+ASIGTO(IDXS2,IDX0))
21585 ASELA = 0.5D0*(ASIGEL(IDXS1,IDX0)+ASIGEL(IDXS2,IDX0))
21586 ELSE
21587 DUM0 = ZERO
21588 CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21589 PHOSEL = PHOSTO-PHOSIN
21590 ASTOT1 = ASIGTO(IDXS1,NPOINT)-APHOST+LOG10(PHOSTO)
21591 ASELA1 = ASIGEL(IDXS1,NPOINT)-APHOSE+LOG10(PHOSEL)
21592 ASTOT2 = ASIGTO(IDXS2,NPOINT)-APHOST+LOG10(PHOSTO)
21593 ASELA2 = ASIGEL(IDXS2,NPOINT)-APHOSE+LOG10(PHOSEL)
21594 ASTOT = 0.5D0*(ASTOT1+ASTOT2)
21595 ASELA = 0.5D0*(ASELA1+ASELA2)
21596 ENDIF
21597 ELSE
21598 FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21599 ASTOT1 = ASIGTO(IDXS1,IDX0)+
21600 & FAC*(ASIGTO(IDXS1,IDX1)-ASIGTO(IDXS1,IDX0))
21601 ASTOT2 = ASIGTO(IDXS2,IDX0)+
21602 & FAC*(ASIGTO(IDXS2,IDX1)-ASIGTO(IDXS2,IDX0))
21603 ASTOT = 0.5D0*(ASTOT1+ASTOT2)
21604 ASELA1 = ASIGEL(IDXS1,IDX0)+
21605 & FAC*(ASIGEL(IDXS1,IDX1)-ASIGEL(IDXS1,IDX0))
21606 ASELA2 = ASIGEL(IDXS2,IDX0)+
21607 & FAC*(ASIGEL(IDXS2,IDX1)-ASIGEL(IDXS2,IDX0))
21608 ASELA = 0.5D0*(ASELA1+ASELA2)
21609 ENDIF
21610 ELSE
21611 IF (IDX0.EQ.IDX1) THEN
21612 IF (IDX0.EQ.1) THEN
21613 ASTOT = ASIGTO(IDXS,IDX0)
21614 ASELA = ASIGEL(IDXS,IDX0)
21615 ELSE
21616 DUM0 = ZERO
21617 CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21618 PHOSEL = PHOSTO-PHOSIN
21619 ASTOT = ASIGTO(IDXS,NPOINT)-APHOST+LOG10(PHOSTO)
21620 ASELA = ASIGEL(IDXS,NPOINT)-APHOSE+LOG10(PHOSEL)
21621 ENDIF
21622 ELSE
21623 FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21624 ASTOT = ASIGTO(IDXS,IDX0)+
21625 & FAC*(ASIGTO(IDXS,IDX1)-ASIGTO(IDXS,IDX0))
21626 ASELA = ASIGEL(IDXS,IDX0)+
21627 & FAC*(ASIGEL(IDXS,IDX1)-ASIGEL(IDXS,IDX0))
21628 ENDIF
21629 ENDIF
21630 STOT = 10.0D0**ASTOT
21631 SELA = 10.0D0**ASELA
21632
21633 RETURN
21634 END
21635
21636*$ CREATE DT_SIHNAB.FOR
21637*COPY DT_SIHNAB
21638*
21639*===sihnab===============================================================*
21640*
21641 SUBROUTINE DT_SIHNAB(IDP,IDT,PLAB,SIGABS)
21642
21643**********************************************************************
21644* Pion 2-nucleon absorption cross sections. *
21645* (sigma_tot for pi+ d --> p p, pi- d --> n n *
21646* taken from Ritchie PRC 28 (1983) 926 ) *
21647* This version dated 18.05.96 is written by S. Roesler *
21648**********************************************************************
21649
21650 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21651 SAVE
21652 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY3=1.0D-3)
21653 PARAMETER (AMPR = 938.0D0,
21654 & AMPI = 140.0D0,
21655 & AMDE = TWO*AMPR,
21656 & A = -1.2D0,
21657 & B = 3.5D0,
21658 & C = 7.4D0,
21659 & D = 5600.0D0,
21660 & ER = 2136.0D0)
21661
21662 SIGABS = ZERO
21663 IF ( ((IDP.NE.13).AND.(IDP.NE.14).AND.(IDP.NE.23))
21664 & .OR.((IDT.NE.1).AND.(IDT.NE.8)) ) RETURN
21665 PTOT = PLAB*1.0D3
21666 EKIN = SQRT(AMPI**2+PTOT**2)-AMPI
21667 IF ((EKIN.LT.TINY3).OR.(EKIN.GT.400.0D0)) RETURN
21668 ECM = SQRT( (AMPI+AMDE)**2+TWO*EKIN*AMDE )
21669 SIGABS = A+B/SQRT(EKIN)+C*1.0D4/((ECM-ER)**2+D)
21670* approximate 3N-abs., I=1-abs. etc.
21671 SIGABS = SIGABS/0.40D0
21672* pi0-absorption (rough approximation!!)
21673 IF (IDP.EQ.23) SIGABS = 0.5D0*SIGABS
21674
21675 RETURN
21676 END
21677
21678*$ CREATE DT_SIGEMU.FOR
21679*COPY DT_SIGEMU
21680*
21681*===sigemu=============================================================*
21682*
21683 SUBROUTINE DT_SIGEMU
21684
21685************************************************************************
21686* Combined cross section for target compounds. *
21687* This version dated 6.4.98 is written by S. Roesler *
21688************************************************************************
21689
21690 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21691 SAVE
21692 PARAMETER ( LINP = 10 ,
21693 & LOUT = 6 ,
21694 & LDAT = 9 )
21695 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21696 & OHALF=0.5D0,ONE=1.0D0)
21697
21698 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21699* Glauber formalism: cross sections
21700 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21701 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21702 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21703 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21704 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21705 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21706 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21707 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21708 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21709 & BSLOPE,NEBINI,NQBINI
21710* emulsion treatment
21711 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
21712 & NCOMPO,IEMUL
21713* nucleon-nucleon event-generator
21714 CHARACTER*8 CMODEL
21715 LOGICAL LPHOIN
21716 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21717
21718 IF (MCGENE.NE.4) THEN
21719 WRITE(LOUT,'(A)') ' DT_SIGEMU: Combined cross sections'
21720 WRITE(LOUT,'(15X,A)') '-----------------------'
21721 ENDIF
21722 DO 1 IE=1,NEBINI
21723 DO 2 IQ=1,NQBINI
21724 SIGTOT = ZERO
21725 SIGELA = ZERO
21726 SIGQEP = ZERO
21727 SIGQET = ZERO
21728 SIGQE2 = ZERO
21729 SIGPRO = ZERO
21730 SIGDEL = ZERO
21731 SIGDQE = ZERO
21732 ERRTOT = ZERO
21733 ERRELA = ZERO
21734 ERRQEP = ZERO
21735 ERRQET = ZERO
21736 ERRQE2 = ZERO
21737 ERRPRO = ZERO
21738 ERRDEL = ZERO
21739 ERRDQE = ZERO
21740 IF (NCOMPO.GT.0) THEN
21741 DO 3 IC=1,NCOMPO
21742 SIGTOT = SIGTOT+EMUFRA(IC)*XSTOT(IE,IQ,IC)
21743 SIGELA = SIGELA+EMUFRA(IC)*XSELA(IE,IQ,IC)
21744 SIGQEP = SIGQEP+EMUFRA(IC)*XSQEP(IE,IQ,IC)
21745 SIGQET = SIGQET+EMUFRA(IC)*XSQET(IE,IQ,IC)
21746 SIGQE2 = SIGQE2+EMUFRA(IC)*XSQE2(IE,IQ,IC)
21747 SIGPRO = SIGPRO+EMUFRA(IC)*XSPRO(IE,IQ,IC)
21748 SIGDEL = SIGDEL+EMUFRA(IC)*XSDEL(IE,IQ,IC)
21749 SIGDQE = SIGDQE+EMUFRA(IC)*XSDQE(IE,IQ,IC)
21750 ERRTOT = ERRTOT+XETOT(IE,IQ,IC)**2
21751 ERRELA = ERRELA+XEELA(IE,IQ,IC)**2
21752 ERRQEP = ERRQEP+XEQEP(IE,IQ,IC)**2
21753 ERRQET = ERRQET+XEQET(IE,IQ,IC)**2
21754 ERRQE2 = ERRQE2+XEQE2(IE,IQ,IC)**2
21755 ERRPRO = ERRPRO+XEPRO(IE,IQ,IC)**2
21756 ERRDEL = ERRDEL+XEDEL(IE,IQ,IC)**2
21757 ERRDQE = ERRDQE+XEDQE(IE,IQ,IC)**2
21758 3 CONTINUE
21759 ERRTOT = SQRT(ERRTOT)
21760 ERRELA = SQRT(ERRELA)
21761 ERRQEP = SQRT(ERRQEP)
21762 ERRQET = SQRT(ERRQET)
21763 ERRQE2 = SQRT(ERRQE2)
21764 ERRPRO = SQRT(ERRPRO)
21765 ERRDEL = SQRT(ERRDEL)
21766 ERRDQE = SQRT(ERRDQE)
21767 ELSE
21768 SIGTOT = XSTOT(IE,IQ,1)
21769 SIGELA = XSELA(IE,IQ,1)
21770 SIGQEP = XSQEP(IE,IQ,1)
21771 SIGQET = XSQET(IE,IQ,1)
21772 SIGQE2 = XSQE2(IE,IQ,1)
21773 SIGPRO = XSPRO(IE,IQ,1)
21774 SIGDEL = XSDEL(IE,IQ,1)
21775 SIGDQE = XSDQE(IE,IQ,1)
21776 ERRTOT = XETOT(IE,IQ,1)
21777 ERRELA = XEELA(IE,IQ,1)
21778 ERRQEP = XEQEP(IE,IQ,1)
21779 ERRQET = XEQET(IE,IQ,1)
21780 ERRQE2 = XEQE2(IE,IQ,1)
21781 ERRPRO = XEPRO(IE,IQ,1)
21782 ERRDEL = XEDEL(IE,IQ,1)
21783 ERRDQE = XEDQE(IE,IQ,1)
21784 ENDIF
21785 IF (MCGENE.NE.4) THEN
21786 WRITE(LOUT,1000) ECMNN(IE),Q2G(IQ)
21787 1000 FORMAT(/,1X,'E_cm =',F9.1,' GeV Q^2 =',F6.1,' GeV^2 :',/)
21788 WRITE(LOUT,1001) SIGTOT,ERRTOT
21789 1001 FORMAT(1X,'total',32X,F10.4,' +-',F11.5,' mb')
21790 WRITE(LOUT,1002) SIGELA,ERRELA
21791 1002 FORMAT(1X,'elastic',30X,F10.4,' +-',F11.5,' mb')
21792 WRITE(LOUT,1003) SIGQEP,ERRQEP
21793 1003 FORMAT(1X,'quasi-elastic (A+B-->A+X)',12X,F10.4,' +-',
21794 & F11.5,' mb')
21795 WRITE(LOUT,1004) SIGQET,ERRQET
21796 1004 FORMAT(1X,'quasi-elastic (A+B-->X+B)',12X,F10.4,' +-',
21797 & F11.5,' mb')
21798 WRITE(LOUT,1005) SIGQE2,ERRQE2
21799 1005 FORMAT(1X,'quasi-elastic (A+B-->X, excl. 2-4)',3X,F10.4,
21800 & ' +-',F11.5,' mb')
21801 WRITE(LOUT,1006) SIGPRO,ERRPRO
21802 1006 FORMAT(1X,'production',27X,F10.4,' +-',F11.5,' mb')
21803 WRITE(LOUT,1007) SIGDEL,ERRDEL
21804 1007 FORMAT(1X,'diff-el ',27X,F10.4,' +-',F11.5,' mb')
21805 WRITE(LOUT,1008) SIGDQE,ERRDQE
21806 1008 FORMAT(1X,'diff-qel ',27X,F10.4,' +-',F11.5,' mb')
21807 ENDIF
21808
21809 2 CONTINUE
21810 1 CONTINUE
21811
21812 RETURN
21813 END
21814
21815*$ CREATE DT_SIGGA.FOR
21816*COPY DT_SIGGA
21817*
21818*===sigga==============================================================*
21819*
21820 SUBROUTINE DT_SIGGA(NTI,XI,Q2I,ECMI,XNUI,STOT,ETOT,SIN,EIN,STOT0)
21821
21822************************************************************************
21823* Total/inelastic photon-nucleus cross sections. *
21824* !!!! Overwrites SHMAKI-initialization. Do not use it during *
21825* production runs !!!! *
21826* This version dated 27.03.96 is written by S. Roesler *
21827************************************************************************
21828
21829 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21830 SAVE
21831 PARAMETER ( LINP = 10 ,
21832 & LOUT = 6 ,
21833 & LDAT = 9 )
21834 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21835 & OHALF=0.5D0,ONE=1.0D0)
21836 PARAMETER (AMPROT = 0.938D0)
21837
21838 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21839* Glauber formalism: cross sections
21840 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21841 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21842 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21843 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21844 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21845 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21846 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21847 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21848 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21849 & BSLOPE,NEBINI,NQBINI
21850
21851 NT = NTI
21852 X = XI
21853 Q2 = Q2I
21854 ECM = ECMI
21855 XNU = XNUI
21856 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21857 & ECM = SQRT(AMPROT**2-Q2+2.0D0*XNUI*AMPROT)
21858 CALL DT_XSGLAU(1,NT,7,X,Q2,ECM,1,1,-1)
21859 STOT = XSTOT(1,1,1)
21860 ETOT = XETOT(1,1,1)
21861 SIN = XSPRO(1,1,1)
21862 EIN = XEPRO(1,1,1)
21863
21864 RETURN
21865 END
21866
21867*$ CREATE DT_SIGGAT.FOR
21868*COPY DT_SIGGAT
21869*
21870*===siggat=============================================================*
21871*
21872 SUBROUTINE DT_SIGGAT(Q2I,ECMI,STOT,NT)
21873
21874************************************************************************
21875* Total/inelastic photon-nucleus cross sections. *
21876* Uses pre-tabulated cross section. *
21877* This version dated 29.07.96 is written by S. Roesler *
21878************************************************************************
21879
21880 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21881 SAVE
21882 PARAMETER ( LINP = 10 ,
21883 & LOUT = 6 ,
21884 & LDAT = 9 )
21885 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21886 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21887
21888 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21889* Glauber formalism: cross sections
21890 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21891 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21892 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21893 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21894 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21895 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21896 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21897 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21898 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21899 & BSLOPE,NEBINI,NQBINI
21900
21901 NTARG = ABS(NT)
21902 I1 = 1
21903 I2 = 1
21904 RATE = ONE
21905 IF (NEBINI.GT.1) THEN
21906 IF (ECMI.GE.ECMNN(NEBINI)) THEN
21907 I1 = NEBINI
21908 I2 = NEBINI
21909 RATE = ONE
21910 ELSEIF (ECMI.GT.ECMNN(1)) THEN
21911 DO 1 I=2,NEBINI
21912 IF (ECMI.LT.ECMNN(I)) THEN
21913 I1 = I-1
21914 I2 = I
21915 RATE = (ECMI-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
21916 GOTO 2
21917 ENDIF
21918 1 CONTINUE
21919 2 CONTINUE
21920 ENDIF
21921 ENDIF
21922 J1 = 1
21923 J2 = 1
21924 RATQ = ONE
21925 IF (NQBINI.GT.1) THEN
21926 IF (Q2I.GE.Q2G(NQBINI)) THEN
21927 J1 = NQBINI
21928 J2 = NQBINI
21929 RATQ = ONE
21930 ELSEIF (Q2I.GT.Q2G(1)) THEN
21931 DO 3 I=2,NQBINI
21932 IF (Q2I.LT.Q2G(I)) THEN
21933 J1 = I-1
21934 J2 = I
21935 RATQ = LOG10( Q2I/MAX(Q2G(J1),TINY14))/
21936 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
21937C RATQ = (Q2I-Q2G(J1))/(Q2G(J2)-Q2G(J1))
21938 GOTO 4
21939 ENDIF
21940 3 CONTINUE
21941 4 CONTINUE
21942 ENDIF
21943 ENDIF
21944
21945 STOT = XSTOT(I1,J1,NTARG)+
21946 & RATE*(XSTOT(I2,J1,NTARG)-XSTOT(I1,J1,NTARG))+
21947 & RATQ*(XSTOT(I1,J2,NTARG)-XSTOT(I1,J1,NTARG))+
21948 & RATE*RATQ*(XSTOT(I2,J2,NTARG)-XSTOT(I1,J2,NTARG)+
21949 & XSTOT(I1,J1,NTARG)-XSTOT(I2,J1,NTARG))
21950
21951 RETURN
21952 END
21953
21954*$ CREATE DT_SANO.FOR
21955*COPY DT_SANO
21956*
21957*===sigano=============================================================*
21958*
21959 DOUBLE PRECISION FUNCTION DT_SANO(ECM)
21960
21961************************************************************************
21962* This version dated 31.07.96 is written by S. Roesler *
21963************************************************************************
21964
21965 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21966 SAVE
21967 PARAMETER ( LINP = 10 ,
21968 & LOUT = 6 ,
21969 & LDAT = 9 )
21970 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21971 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21972 PARAMETER (NE = 8)
21973
21974* VDM parameter for photon-nucleus interactions
21975 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21976* properties of interacting particles
21977 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
21978
21979 DIMENSION ECMANO(NE),FRAANO(NE),SIGHRD(NE)
21980 DATA ECMANO /
21981 & 0.200D+02,0.500D+02,0.100D+03,0.200D+03,0.500D+03,
21982 & 0.100D+04,0.200D+04,0.500D+04
21983 & /
21984* fixed cut (3 GeV/c)
21985 DATA FRAANO /
21986 & 0.085D+00,0.114D+00,0.105D+00,0.091D+00,0.073D+00,
21987 & 0.062D+00,0.054D+00,0.042D+00
21988 & /
21989 DATA SIGHRD /
21990 & 4.0099D-04,3.3104D-03,1.1905D-02,3.6435D-02,1.3493D-01,
21991 & 3.3086D-01,7.6255D-01,2.1319D+00
21992 & /
21993* running cut (based on obsolete Phojet-caluclations, bugs..)
21994C DATA FRAANO /
21995C & 0.251E+00,0.313E+00,0.279E+00,0.239E+00,0.186E+00,
21996C & 0.167E+00,0.150E+00,0.131E+00
21997C & /
21998C DATA SIGHRD /
21999C & 6.6569E-04,4.4949E-03,1.4837E-02,4.1466E-02,1.5071E-01,
22000C & 2.5736E-01,4.5593E-01,8.2550E-01
22001C & /
22002
22003 DT_SANO = ZERO
22004 IF ((ISHAD(2).NE.1).OR.(IJPROJ.NE.7)) RETURN
22005 J1 = 0
22006 J2 = 0
22007 RATE = ONE
22008 IF (ECM.GE.ECMANO(NE)) THEN
22009 J1 = NE
22010 J2 = NE
22011 ELSEIF (ECM.GT.ECMANO(1)) THEN
22012 DO 1 IE=2,NE
22013 IF (ECM.LT.ECMANO(IE)) THEN
22014 J1 = IE-1
22015 J2 = IE
22016 RATE = LOG10(ECM/ECMANO(J1))/LOG10(ECMANO(J2)/ECMANO(J1))
22017 GOTO 2
22018 ENDIF
22019 1 CONTINUE
22020 2 CONTINUE
22021 ENDIF
22022 IF ((J1.GT.0).AND.(J2.GT.0)) THEN
22023 AFRA1 = LOG10(MAX(FRAANO(J1)*SIGHRD(J1),TINY14))
22024 AFRA2 = LOG10(MAX(FRAANO(J2)*SIGHRD(J2),TINY14))
22025 DT_SANO = 10.0D0**(AFRA1+RATE*(AFRA2-AFRA1))
22026 ENDIF
22027
22028 RETURN
22029 END
22030
22031*$ CREATE DT_SIGGP.FOR
22032*COPY DT_SIGGP
22033*
22034*===siggp==============================================================*
22035*
22036 SUBROUTINE DT_SIGGP(XI,Q2I,ECMI,XNUI,STOT,SINE,SDIR)
22037
22038************************************************************************
22039* Total/inelastic photon-nucleon cross sections. *
22040* This version dated 30.04.96 is written by S. Roesler *
22041************************************************************************
22042
22043 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22044 SAVE
22045 PARAMETER ( LINP = 10 ,
22046 & LOUT = 6 ,
22047 & LDAT = 9 )
22048 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22049 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22050 & PI = TWOPI/TWO,
22051 & GEV2MB = 0.38938D0,
22052 & ALPHEM = ONE/137.0D0)
22053
22054* particle properties (BAMJET index convention)
22055 CHARACTER*8 ANAME
22056 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22057 & IICH(210),IIBAR(210),K1(210),K2(210)
22058* VDM parameter for photon-nucleus interactions
22059 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22060
22061**PHOJET105a
22062C CHARACTER*8 MDLNA
22063C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
22064C PARAMETER (IEETAB=10)
22065C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
22066**PHOJET110
22067C model switches and parameters
22068 CHARACTER*8 MDLNA
22069 INTEGER ISWMDL,IPAMDL
22070 DOUBLE PRECISION PARMDL
22071 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
22072C energy-interpolation table
22073 INTEGER IEETA2
22074 PARAMETER ( IEETA2 = 20 )
22075 INTEGER ISIMAX
22076 DOUBLE PRECISION SIGTAB,SIGECM
22077 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
22078**
22079
22080C PARAMETER (NPOINT=80)
22081 PARAMETER (NPOINT=16)
22082 DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
22083
22084 STOT = ZERO
22085 SINE = ZERO
22086 SDIR = ZERO
22087
22088 W2 = ECMI**2
22089 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
22090 & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
22091 Q2 = Q2I
22092 X = XI
22093* photoprod.
22094 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22095 Q2 = 0.0001D0
22096 X = Q2/(W2+Q2-AAM(1)**2)
22097* DIS
22098 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
22099 X = Q2/(W2+Q2-AAM(1)**2)
22100 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22101 Q2 = (W2-AAM(1)**2)*X/(ONE-X)
22102 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
22103 W2 = Q2*(ONE-X)/X+AAM(1)**2
22104 ELSE
22105 WRITE(LOUT,*) 'SIGGP: inconsistent input ',W2,Q2,X
22106 STOP
22107 ENDIF
22108 ECM = SQRT(W2)
22109
22110 IF (MODEGA.EQ.1) THEN
22111 SCALE = SQRT(Q2)
22112 CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
22113 & IDPDF)
22114C W = SQRT(W2)
22115C ALLMF2 = PHO_ALLM97(Q2,W)
22116C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
22117 STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
22118 SINE = ZERO
22119 SDIR = ZERO
22120 ELSEIF (MODEGA.EQ.2) THEN
22121 IF (INTRGE(1).EQ.1) THEN
22122 AMLO2 = (3.0D0*AAM(13))**2
22123 ELSEIF (INTRGE(1).EQ.2) THEN
22124 AMLO2 = AAM(33)**2
22125 ELSE
22126 AMLO2 = AAM(96)**2
22127 ENDIF
22128 IF (INTRGE(2).EQ.1) THEN
22129 AMHI2 = W2/TWO
22130 ELSEIF (INTRGE(2).EQ.2) THEN
22131 AMHI2 = W2/4.0D0
22132 ELSE
22133 AMHI2 = W2
22134 ENDIF
22135 AMHI20 = (ECM-AAM(1))**2
22136 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22137 XAMLO = LOG( AMLO2+Q2 )
22138 XAMHI = LOG( AMHI2+Q2 )
22139**PHOJET105a
22140C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
22141**PHOJET112
22142 CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
22143**
22144 SUM = ZERO
22145 DO 1 J=1,NPOINT
22146 AM2 = EXP(ABSZX(J))-Q2
22147 IF (AM2.LT.16.0D0) THEN
22148 R = TWO
22149 ELSEIF ((AM2.GE.16.0D0).AND.(AM2.LT.121.0D0)) THEN
22150 R = 10.0D0/3.0D0
22151 ELSE
22152 R = 11.0D0/3.0D0
22153 ENDIF
22154C FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
22155 FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
22156 & * (ONE+EPSPOL*Q2/AM2)
22157 SUM = SUM+WEIGHT(J)*FAC
22158 1 CONTINUE
22159 SINE = SUM
22160 SDIR = DT_SIGVP(X,Q2)
22161 STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*SDIR
22162 SDIR = SDIR/(0.588D0+RL2+Q2)
22163C STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*DT_SIGVP(X,Q2)
22164 ELSEIF (MODEGA.EQ.3) THEN
22165 CALL DT_SIGGA(1,XI,Q2I,ECMI,ZERO,STOT,ETOT,SINE,EINE,DUM)
22166 ELSEIF (MODEGA.EQ.4) THEN
22167* load cross sections from PHOJET interpolation table
22168 IP = 1
22169 IF(ECM.LE.SIGECM(IP,1)) THEN
22170 I1 = 1
22171 I2 = 1
22172 ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
22173 DO 2 I=2,ISIMAX
22174 IF (ECM.LE.SIGECM(IP,I)) GOTO 3
22175 2 CONTINUE
22176 3 CONTINUE
22177 I1 = I-1
22178 I2 = I
22179 ELSE
22180 WRITE(LOUT,'(/1X,A,2E12.3)')
22181 & 'SIGGP:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
22182 I1 = ISIMAX
22183 I2 = ISIMAX
22184 ENDIF
22185 FAC2 = ZERO
22186 IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
22187 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
22188 FAC1 = ONE-FAC2
22189* cross section dependence on photon virtuality
22190 FSUP1 = ZERO
22191 DO 4 I=1,3
22192 FSUP1 = FSUP1+PARMDL(26+I)*(1.D0+Q2/(4.D0*PARMDL(30+I)))
22193 & /(1.D0+Q2/PARMDL(30+I))**2
22194 4 CONTINUE
22195 FSUP1 = FSUP1+PARMDL(30)/(1.D0+Q2/PARMDL(34))
22196 FAC1 = FAC1*FSUP1
22197 FAC2 = FAC2*FSUP1
22198 FSUP2 = 1.0D0
22199 STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
22200 SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
22201 SDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
22202**re:
22203 STOT = STOT-SDIR
22204**
22205 SDIR = SDIR/(FSUP1*FSUP2)
22206**re:
22207 STOT = STOT+SDIR
22208**
22209 ENDIF
22210
22211 RETURN
22212 END
22213
22214*$ CREATE DT_SIGVEL.FOR
22215*COPY DT_SIGVEL
22216*
22217*===sigvel=============================================================*
22218*
22219 SUBROUTINE DT_SIGVEL(XI,Q2I,ECMI,XNUI,IDXV,SVEL,SIG1,SIG2)
22220
22221************************************************************************
22222* Cross section for elastic vector meson production *
22223* This version dated 10.05.96 is written by S. Roesler *
22224************************************************************************
22225
22226 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22227 SAVE
22228 PARAMETER ( LINP = 10 ,
22229 & LOUT = 6 ,
22230 & LDAT = 9 )
22231 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22232 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22233 & PI = TWOPI/TWO,
22234 & GEV2MB = 0.38938D0,
22235 & ALPHEM = ONE/137.0D0)
22236
22237* particle properties (BAMJET index convention)
22238 CHARACTER*8 ANAME
22239 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22240 & IICH(210),IIBAR(210),K1(210),K2(210)
22241* VDM parameter for photon-nucleus interactions
22242 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22243
22244 W2 = ECMI**2
22245 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
22246 & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
22247 Q2 = Q2I
22248 X = XI
22249* photoprod.
22250 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22251 Q2 = 0.0001D0
22252 X = Q2/(W2+Q2-AAM(1)**2)
22253* DIS
22254 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
22255 X = Q2/(W2+Q2-AAM(1)**2)
22256 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22257 Q2 = (W2-AAM(1)**2)*X/(ONE-X)
22258 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
22259 W2 = Q2*(ONE-X)/X+AAM(1)**2
22260 ELSE
22261 WRITE(LOUT,*) 'SIGVEL: inconsistent input ',W2,Q2,X
22262 STOP
22263 ENDIF
22264 ECM = SQRT(W2)
22265
22266 AMV = AAM(IDXV)
22267 AMV2 = AMV**2
22268
22269 BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
22270 & +0.25D0*LOG(W2/(AMV2+Q2)))*GEV2MB
22271 ROSH = 0.1D0
22272 STOVP = DT_SIGVP(X,Q2)/(AMV2+Q2+RL2)
22273 SELVP = STOVP**2*(ONE+ROSH**2)/(8.0D0*TWOPI*BSLOPE)
22274
22275 IF (IDXV.EQ.33) THEN
22276 COUPL = 0.00365D0
22277 ELSE
22278 STOP
22279 ENDIF
22280 SIG1 = (AMV2/(AMV2+Q2))**2 * (ONE+EPSPOL*Q2/AMV2)
22281 SIG2 = SELVP
22282 SVEL = COUPL * (AMV2/(AMV2+Q2))**2
22283 & * (ONE+EPSPOL*Q2/AMV2) * SELVP
22284
22285 RETURN
22286 END
22287
22288*$ CREATE DT_SIGVP.FOR
22289*COPY DT_SIGVP
22290*
22291*===sigvp==============================================================*
22292*
22293 DOUBLE PRECISION FUNCTION DT_SIGVP(XI,Q2I)
22294
22295************************************************************************
22296* sigma_Vp *
22297************************************************************************
22298
22299 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22300 SAVE
22301
22302 PARAMETER ( LINP = 10 ,
22303 & LOUT = 6 ,
22304 & LDAT = 9 )
22305 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22306 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22307 & PI = TWOPI/TWO,
22308 & GEV2MB = 0.38938D0,
22309 & AMPROT = 0.938D0,
22310 & ALPHEM = ONE/137.0D0)
22311* VDM parameter for photon-nucleus interactions
22312 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22313
22314 X = XI
22315 Q2 = Q2I
22316 IF (XI.LE.ZERO) X = 0.0001D0
22317 IF (Q2I.LE.ZERO) Q2 = 0.0001D0
22318
22319 ECM = SQRT( Q2*(ONE-X)/X+AMPROT**2 )
22320
22321 SCALE = SQRT(Q2)
22322 IF (MODEGA.EQ.1) THEN
22323 CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
22324 & IDPDF)
22325C W = ECM
22326C ALLMF2 = PHO_ALLM97(Q2,W)
22327C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
22328C STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
22329C DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))
22330 DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))*GEV2MB
22331 ELSEIF (MODEGA.EQ.4) THEN
22332 CALL DT_SIGGP(X,Q2,ECM,DUM1,STOT,DUM2,DUM3)
22333C F2 = Q2*(ONE-X)/(TWOPI**2*ALPHEM*GEV2MB) * STOT
22334 DT_SIGVP = 3.0D0*PI/(ALPHEM*DT_RRM2(X,Q2)) * STOT
22335 ELSE
22336 STOP ' DT_SIGVP: F2 not defined for this MODEGA !'
22337 ENDIF
22338
22339 RETURN
22340
22341 END
22342
22343*$ CREATE DT_RRM2.FOR
22344*COPY DT_RRM2
22345*
22346*===RRM2===============================================================*
22347*
22348 DOUBLE PRECISION FUNCTION DT_RRM2(X,Q2)
22349
22350 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22351 SAVE
22352 PARAMETER ( LINP = 10 ,
22353 & LOUT = 6 ,
22354 & LDAT = 9 )
22355 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22356 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22357 & PI = TWOPI/TWO,
22358 & GEV2MB = 0.38938D0)
22359
22360* particle properties (BAMJET index convention)
22361 CHARACTER*8 ANAME
22362 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22363 & IICH(210),IIBAR(210),K1(210),K2(210)
22364* VDM parameter for photon-nucleus interactions
22365 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22366
22367 S = Q2*(ONE-X)/X+AAM(1)**2
22368 ECM = SQRT(S)
22369
22370 IF (INTRGE(1).EQ.1) THEN
22371 AMLO2 = (3.0D0*AAM(13))**2
22372 ELSEIF (INTRGE(1).EQ.2) THEN
22373 AMLO2 = AAM(33)**2
22374 ELSE
22375 AMLO2 = AAM(96)**2
22376 ENDIF
22377 IF (INTRGE(2).EQ.1) THEN
22378 AMHI2 = S/TWO
22379 ELSEIF (INTRGE(2).EQ.2) THEN
22380 AMHI2 = S/4.0D0
22381 ELSE
22382 AMHI2 = S
22383 ENDIF
22384 AMHI20 = (ECM-AAM(1))**2
22385 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22386
22387 AM1C2 = 16.0D0
22388 AM2C2 = 121.0D0
22389 IF (AMHI2.LE.AM1C2) THEN
22390 DT_RRM2 = TWO*DT_RM2(AMLO2,AMHI2,Q2)
22391 ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22392 DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22393 & 10.0D0/3.0D0*DT_RM2(AM1C2,AMHI2,Q2)
22394 ELSE
22395 DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22396 & 10.0D0/3.0D0*DT_RM2(AM1C2,AM2C2,Q2)+
22397 & 11.0D0/3.0D0*DT_RM2(AM2C2,AMHI2,Q2)
22398 ENDIF
22399
22400 RETURN
22401 END
22402
22403*$ CREATE DT_RM2.FOR
22404*COPY DT_RM2
22405*
22406*===RM2================================================================*
22407*
22408 DOUBLE PRECISION FUNCTION DT_RM2(AMLO2,AMHI2,Q2)
22409
22410 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22411 SAVE
22412 PARAMETER ( LINP = 10 ,
22413 & LOUT = 6 ,
22414 & LDAT = 9 )
22415 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22416 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22417 & PI = TWOPI/TWO,
22418 & GEV2MB = 0.38938D0)
22419* VDM parameter for photon-nucleus interactions
22420 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22421
22422 IF (RL2.LE.ZERO) THEN
22423 DT_RM2 = -ONE/(AMHI2+Q2)+Q2/(TWO*(AMHI2+Q2)**2) -
22424 & (-ONE/(AMLO2+Q2)+Q2/(TWO*(AMLO2+Q2)**2))
22425 & +EPSPOL*(-Q2/(TWO*(AMHI2+Q2)**2)+Q2/(TWO*(AMLO2+Q2)**2))
22426 ELSE
22427 TMPMLO = LOG(ONE+RL2/(AMLO2+Q2))
22428 TMPMHI = LOG(ONE+RL2/(AMHI2+Q2))
22429 DT_RM2 = Q2/(RL2*(AMHI2+Q2))-(Q2+RL2)/RL2**2*TMPMHI
22430 & -(Q2/(RL2*(AMLO2+Q2))-(Q2+RL2)/RL2**2*TMPMLO)
22431 & +EPSPOL*(
22432 & -Q2/(RL2*(AMHI2+Q2))+Q2/RL2**2*TMPMHI
22433 & -(-Q2/(RL2*(AMLO2+Q2))+Q2/RL2**2*TMPMLO))
22434 ENDIF
22435
22436 RETURN
22437 END
22438
22439*$ CREATE DT_SAM2.FOR
22440*COPY DT_SAM2
22441*
22442*===SAM2===============================================================*
22443*
22444 DOUBLE PRECISION FUNCTION DT_SAM2(Q2,ECM)
22445
22446 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22447 SAVE
22448 PARAMETER ( LINP = 10 ,
22449 & LOUT = 6 ,
22450 & LDAT = 9 )
22451 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
22452 & TENTRD=10.0D0/3.0D0,ELVTRD=11.0D0/3.0D0)
22453 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22454 & PI = TWOPI/TWO,
22455 & GEV2MB = 0.38938D0)
22456
22457* particle properties (BAMJET index convention)
22458 CHARACTER*8 ANAME
22459 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22460 & IICH(210),IIBAR(210),K1(210),K2(210)
22461* VDM parameter for photon-nucleus interactions
22462 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22463
22464 S = ECM**2
22465 IF (INTRGE(1).EQ.1) THEN
22466 AMLO2 = (3.0D0*AAM(13))**2
22467 ELSEIF (INTRGE(1).EQ.2) THEN
22468 AMLO2 = AAM(33)**2
22469 ELSE
22470 AMLO2 = AAM(96)**2
22471 ENDIF
22472 IF (INTRGE(2).EQ.1) THEN
22473 AMHI2 = S/TWO
22474 ELSEIF (INTRGE(2).EQ.2) THEN
22475 AMHI2 = S/4.0D0
22476 ELSE
22477 AMHI2 = S
22478 ENDIF
22479 AMHI20 = (ECM-AAM(1))**2
22480 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22481
22482 AM1C2 = 16.0D0
22483 AM2C2 = 121.0D0
22484 YLO = LOG(AMLO2+Q2)
22485 YC1 = LOG(AM1C2+Q2)
22486 YC2 = LOG(AM2C2+Q2)
22487 YHI = LOG(AMHI2+Q2)
22488 IF (AMHI2.LE.AM1C2) THEN
22489 FACHI = TWO
22490 ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22491 FACHI = TENTRD
22492 ELSE
22493 FACHI = ELVTRD
22494 ENDIF
22495
22496 1 CONTINUE
22497 YSAM2 = YLO+(YHI-YLO)*DT_RNDM(AM1C2)
22498 IF (YSAM2.LE.YC1) THEN
22499 FAC = TWO
22500 ELSEIF ((YSAM2.GT.YC1).AND.(YSAM2.LE.YC2)) THEN
22501 FAC = TENTRD
22502 ELSE
22503 FAC = ELVTRD
22504 ENDIF
22505 WEIGMX = FACHI*(ONE-Q2*EXP( -YHI))
22506 XSAM2 = FAC *(ONE-Q2*EXP(-YSAM2))
22507 IF (DT_RNDM(YSAM2)*WEIGMX.GT.XSAM2) GOTO 1
22508
22509 DT_SAM2 = EXP(YSAM2)-Q2
22510
22511 RETURN
22512 END
22513
22514*$ CREATE DT_CKMT.FOR
22515*COPY DT_CKMT
22516*
22517*===ckmt===============================================================*
22518*
22519 SUBROUTINE DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,
22520 & F2,IPAR)
22521
22522************************************************************************
22523* This version dated 31.01.96 is written by S. Roesler *
22524************************************************************************
22525
22526 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22527 SAVE
22528 PARAMETER ( LINP = 10 ,
22529 & LOUT = 6 ,
22530 & LDAT = 9 )
22531 PARAMETER (ZERO=0.0D0,TWO=2.0D0,TINY10=1.0D-10)
22532
22533 PARAMETER (Q02 = 2.0D0,
22534 & DQ2 = 10.05D0,
22535 & Q12 = Q02+DQ2)
22536
22537 DIMENSION PD(-6:6),SEA(3),VAL(2)
22538
22539 CALL DT_PDF0(Q02,X,F2Q0,VAL,SEA,GLU,IPAR)
22540 CALL DT_PDF0(Q12,X,F2Q1,VAL,SEA,GLU,IPAR)
22541 ADQ2 = LOG10(Q12)-LOG10(Q02)
22542 F2P = (F2Q1-F2Q0)/ADQ2
22543 CALL DT_CKMTX(IPAR,X,Q02,PD,F2PQ0)
22544 CALL DT_CKMTX(IPAR,X,Q12,PD,F2PQ1)
22545 F2PP = (F2PQ1-F2PQ0)/ADQ2
22546 FX = (F2P-F2PP)/(F2PP+LOG(DQ2)*F2PQ0+TINY10)*Q02
22547
22548 Q2 = MAX(SCALE**2.0D0,TINY10)
22549 SMOOTH = 1.0D0+FX*(Q2-Q02)/Q2**2
22550 IF (Q2.LT.Q02) THEN
22551 CALL DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22552 UPV = VAL(1)
22553 DNV = VAL(2)
22554 USEA = SEA(1)
22555 DSEA = SEA(2)
22556 STR = SEA(3)
22557 CHM = 0.0D0
22558 BOT = 0.0D0
22559 TOP = 0.0D0
22560 GL = GLU
22561 ELSE
22562 CALL DT_CKMTX(IPAR,X,Q2,PD,F2)
22563 F2 = F2*SMOOTH
22564 UPV = PD(2)-PD(3)
22565 DNV = PD(1)-PD(3)
22566 USEA = PD(3)
22567 DSEA = PD(3)
22568 STR = PD(3)
22569 CHM = PD(4)
22570 BOT = PD(5)
22571 TOP = PD(6)
22572 GL = PD(0)
22573C UPV = UPV*SMOOTH
22574C DNV = DNV*SMOOTH
22575C USEA = USEA*SMOOTH
22576C DSEA = DSEA*SMOOTH
22577C STR = STR*SMOOTH
22578C CHM = CHM*SMOOTH
22579C GL = GL*SMOOTH
22580 ENDIF
22581
22582 RETURN
22583 END
22584C
22585
22586*$ CREATE DT_CKMTX.FOR
22587*COPY DT_CKMTX
22588 SUBROUTINE DT_CKMTX(IPAR,X,SCALE2,PD,F2)
22589C**********************************************************************
22590C
22591C PDF based on Regge theory, evolved with .... by ....
22592C
22593C input: IPAR 2212 proton (not installed)
22594C 45 Pomeron
22595C 100 Deuteron
22596C
22597C output: PD(-6:6) x*f(x) parton distribution functions
22598C (PDFLIB convention: d = PD(1), u = PD(2) )
22599C
22600C**********************************************************************
22601
22602 SAVE
22603 DOUBLE PRECISION X,SCALE2,PD(-6:6),CDN,CUP,F2
22604 PARAMETER ( LINP = 10 ,
22605 & LOUT = 6 ,
22606 & LDAT = 9 )
22607 DIMENSION QQ(7)
22608C
22609 Q2=SNGL(SCALE2)
22610 Q1S=Q2
22611 XX=SNGL(X)
22612C QCD lambda for evolution
22613 OWLAM = 0.23D0
22614 OWLAM2=OWLAM**2
22615C Q0**2 for evolution
22616 Q02 = 2.D0
22617C
22618C
22619C the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
22620C q(6)=x*charm, q(7)=x*gluon
22621C
22622 SB=0.
22623 IF(Q2-Q02) 1,1,2
22624 2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
22625 1 CONTINUE
22626 IF(IPAR.EQ.2212) THEN
22627 CALL DT_CKMTPR(1,0,XX,SB,QQ(1))
22628 CALL DT_CKMTPR(2,0,XX,SB,QQ(2))
22629 CALL DT_CKMTPR(3,0,XX,SB,QQ(3))
22630 CALL DT_CKMTPR(4,0,XX,SB,QQ(4))
22631 CALL DT_CKMTPR(5,0,XX,SB,QQ(5))
22632 CALL DT_CKMTPR(8,0,XX,SB,QQ(6))
22633 CALL DT_CKMTPR(7,0,XX,SB,QQ(7))
22634C ELSEIF (IPAR.EQ.45) THEN
22635C CALL CKMTPO(1,0,XX,SB,QQ(1))
22636C CALL CKMTPO(2,0,XX,SB,QQ(2))
22637C CALL CKMTPO(3,0,XX,SB,QQ(3))
22638C CALL CKMTPO(4,0,XX,SB,QQ(4))
22639C CALL CKMTPO(5,0,XX,SB,QQ(5))
22640C CALL CKMTPO(8,0,XX,SB,QQ(6))
22641C CALL CKMTPO(7,0,XX,SB,QQ(7))
22642 ELSEIF (IPAR.EQ.100) THEN
22643 CALL DT_CKMTDE(1,0,XX,SB,QQ(1))
22644 CALL DT_CKMTDE(2,0,XX,SB,QQ(2))
22645 CALL DT_CKMTDE(3,0,XX,SB,QQ(3))
22646 CALL DT_CKMTDE(4,0,XX,SB,QQ(4))
22647 CALL DT_CKMTDE(5,0,XX,SB,QQ(5))
22648 CALL DT_CKMTDE(8,0,XX,SB,QQ(6))
22649 CALL DT_CKMTDE(7,0,XX,SB,QQ(7))
22650 ELSE
22651 WRITE(LOUT,'(1X,A,I4,A)')
22652 & 'CKMTX: IPAR =',IPAR,' not implemented!'
22653 STOP
22654 ENDIF
22655C
22656 PD(-6) = 0.D0
22657 PD(-5) = 0.D0
22658 PD(-4) = DBLE(QQ(6))
22659 PD(-3) = DBLE(QQ(3))
22660 PD(-2) = DBLE(QQ(4))
22661 PD(-1) = DBLE(QQ(5))
22662 PD(0) = DBLE(QQ(7))
22663 PD(1) = DBLE(QQ(2))
22664 PD(2) = DBLE(QQ(1))
22665 PD(3) = DBLE(QQ(3))
22666 PD(4) = DBLE(QQ(6))
22667 PD(5) = 0.D0
22668 PD(6) = 0.D0
22669 IF(IPAR.EQ.45) THEN
22670 CDN = (PD(1)-PD(-1))/2.D0
22671 CUP = (PD(2)-PD(-2))/2.D0
22672 PD(-1) = PD(-1) + CDN
22673 PD(-2) = PD(-2) + CUP
22674 PD(1) = PD(-1)
22675 PD(2) = PD(-2)
22676 ENDIF
22677 F2 = 4.0D0/9.0D0*(PD(2)-PD(3)+2.0D0*PD(3))+
22678 & 1.0D0/9.0D0*(PD(1)-PD(3)+2.0D0*PD(3))+
22679 & 1.0D0/9.0D0*(2.0D0*PD(3))+4.0D0/9.0D0*(2.0D0*PD(4))
22680 END
22681C
22682
22683*$ CREATE DT_PDF0.FOR
22684*COPY DT_PDF0
22685*
22686*===pdf0===============================================================*
22687*
22688 SUBROUTINE DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22689
22690************************************************************************
22691* This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 *
22692* an F_2-ansatz given in Capella et al. PLB 337(1994)358. *
22693* IPAR = 2212 proton *
22694* = 100 deuteron *
22695* This version dated 31.01.96 is written by S. Roesler *
22696************************************************************************
22697
22698 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22699 SAVE
22700 PARAMETER ( LINP = 10 ,
22701 & LOUT = 6 ,
22702 & LDAT = 9 )
22703 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22704
22705 PARAMETER (
22706 & AA = 0.1502D0,
22707 & BBDEU = 1.2D0,
22708 & BUD = 0.754D0,
22709 & BDD = 0.4495D0,
22710 & BUP = 1.2064D0,
22711 & BDP = 0.1798D0,
22712 & DELTA0 = 0.07684D0,
22713 & D = 1.117D0,
22714 & C = 3.5489D0,
22715 & A = 0.2631D0,
22716 & B = 0.6452D0,
22717 & ALPHAR = 0.415D0,
22718 & E = 0.1D0
22719 & )
22720
22721 PARAMETER (NPOINT=16)
22722C DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
22723 DIMENSION SEA(3),VAL(2)
22724
22725 DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22726 AN = 1.5D0*(1.0D0+Q2/(Q2+C))
22727* proton, deuteron
22728 IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22729 CALL DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22730 SEA(1) = 0.75D0*SEA0
22731 SEA(2) = SEA(1)
22732 SEA(3) = SEA(1)
22733 VAL(1) = 9.0D0/4.0D0*VALU0
22734 VAL(2) = 9.0D0*VALD0
22735 GLU0 = SEA(1)/(1.0D0-X)
22736 F2 = SEA0+VALU0+VALD0
22737 F2PDF = 4.0D0/9.0D0*(VAL(1)+2.0D0*SEA(1))+
22738 & 1.0D0/9.0D0*(VAL(2)+2.0D0*SEA(2))+
22739 & 1.0D0/9.0D0*(2.0D0*SEA(3))
22740 IF (ABS(F2-F2PDF).GT.TINY9) THEN
22741 WRITE(LOUT,'(1X,A,2E15.5)') 'inconsistent PDF! ',F2,F2PDF
22742 STOP
22743 ENDIF
22744**PHOJET105a
22745C CALL GSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22746**PHOJET112
22747C CALL PHO_GAUSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22748**
22749C SUMQ = ZERO
22750C SUMG = ZERO
22751C DO 1 J=1,NPOINT
22752C CALL DT_CKMTQ0(Q2,ABSZX(J),IPAR,VALU0,VALD0,SEA0)
22753C VALU0 = 9.0D0/4.0D0*VALU0
22754C VALD0 = 9.0D0*VALD0
22755C SEA0 = 0.75D0*SEA0
22756C SUMQ = SUMQ+ (VALU0+VALD0+6.0D0*SEA0) *WEIGHT(J)
22757C SUMG = SUMG+ (SEA0/(1.0D0-ABSZX(J))) *WEIGHT(J)
22758C 1 CONTINUE
22759C GLU = GLU0*(1.0D0-SUMQ)/SUMG
22760 ELSE
22761 WRITE(LOUT,'(1X,A,I4,A)')
22762 & 'PDF0: IPAR =',IPAR,' not implemented!'
22763 STOP
22764 ENDIF
22765
22766 RETURN
22767 END
22768
22769*$ CREATE DT_CKMTQ0.FOR
22770*COPY DT_CKMTQ0
22771*
22772*===ckmtq0=============================================================*
22773*
22774 SUBROUTINE DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22775
22776************************************************************************
22777* This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 *
22778* an F_2-ansatz given in Capella et al. PLB 337(1994)358. *
22779* IPAR = 2212 proton *
22780* = 100 deuteron *
22781* This version dated 31.01.96 is written by S. Roesler *
22782************************************************************************
22783
22784 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22785 SAVE
22786 PARAMETER ( LINP = 10 ,
22787 & LOUT = 6 ,
22788 & LDAT = 9 )
22789 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22790
22791 PARAMETER (
22792 & AA = 0.1502D0,
22793 & BBDEU = 1.2D0,
22794 & BUD = 0.754D0,
22795 & BDD = 0.4495D0,
22796 & BUP = 1.2064D0,
22797 & BDP = 0.1798D0,
22798 & DELTA0 = 0.07684D0,
22799 & D = 1.117D0,
22800 & C = 3.5489D0,
22801 & A = 0.2631D0,
22802 & B = 0.6452D0,
22803 & ALPHAR = 0.415D0,
22804 & E = 0.1D0
22805 & )
22806
22807 DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22808 AN = 1.5D0*(1.0D0+Q2/(Q2+C))
22809* proton, deuteron
22810 IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22811 IF (IPAR.EQ.2212) THEN
22812 BU = BUP
22813 BD = BDP
22814 ELSE
22815 BU = BUD
22816 BD = BDD
22817 ENDIF
22818 SEA0 = AA*X**(-DELTA)*(1.0D0-X)**(AN+4.0D0)*
22819 & (Q2/(Q2+A))**(1.0D0+DELTA)
22820 VALU0 = BU*X**(1.0D0-ALPHAR)*(1.0D0-X)**AN*
22821 & (Q2/(Q2+B))**(ALPHAR)
22822 VALD0 = BD*X**(1.0D0-ALPHAR)*(1.0D0-X)**(AN+1.0D0)*
22823 & (Q2/(Q2+B))**(ALPHAR)
22824 ELSE
22825 WRITE(LOUT,'(1X,A,I4,A)')
22826 & 'CKMTQ0: IPAR =',IPAR,' not implemented!'
22827 STOP
22828 ENDIF
22829 RETURN
22830 END
22831C
22832C
22833
22834*$ CREATE DT_CKMTDE.FOR
22835*COPY DT_CKMTDE
22836 SUBROUTINE DT_CKMTDE(I,NDRV,X,S,ANS)
22837C
22838C**********************************************************************
22839C Deuteron - PDFs
22840C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
22841C ANS = PDF(I)
22842C This version by S. Roesler, 30.01.96
22843C**********************************************************************
22844
22845 SAVE
22846 DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
22847 EQUIVALENCE (GF(1,1,1),DL(1))
22848 DATA DELTA/.13/
22849C
22850 DATA (DL(K),K= 1, 85) /
22851 &0.351858E+00,0.388489E+00,0.325356E+00,0.325356E+00,0.325356E+00,
22852 &0.325356E+00,0.445218E+01,0.000000E+00,0.419818E+00,0.459249E+00,
22853 &0.391167E+00,0.391143E+00,0.391125E+00,0.391167E+00,0.628186E+01,
22854 &0.703797E-01,0.498333E+00,0.540626E+00,0.467466E+00,0.467423E+00,
22855 &0.467393E+00,0.467466E+00,0.837368E+01,0.151191E+00,0.587839E+00,
22856 &0.633058E+00,0.554689E+00,0.554630E+00,0.554595E+00,0.554689E+00,
22857 &0.107170E+02,0.242877E+00,0.688652E+00,0.736861E+00,0.653150E+00,
22858 &0.653080E+00,0.653046E+00,0.653150E+00,0.132960E+02,0.345760E+00,
22859 &0.800961E+00,0.852226E+00,0.763038E+00,0.762961E+00,0.762933E+00,
22860 &0.763038E+00,0.160884E+02,0.460033E+00,0.924829E+00,0.979213E+00,
22861 &0.884414E+00,0.884335E+00,0.884319E+00,0.884414E+00,0.190679E+02,
22862 &0.585764E+00,0.106016E+01,0.111773E+01,0.101719E+01,0.101711E+01,
22863 &0.101711E+01,0.101719E+01,0.222033E+02,0.722864E+00,0.120670E+01,
22864 &0.126752E+01,0.116110E+01,0.116102E+01,0.116105E+01,0.116110E+01,
22865 &0.254603E+02,0.871079E+00,0.136402E+01,0.142815E+01,0.131571E+01,
22866 &0.131565E+01,0.131570E+01,0.131571E+01,0.288020E+02,0.102998E+01,
22867 &0.153151E+01,0.159900E+01,0.148043E+01,0.148038E+01,0.148046E+01/
22868 DATA (DL(K),K= 86, 170) /
22869 &0.148043E+01,0.321898E+02,0.119897E+01,0.170838E+01,0.177930E+01,
22870 &0.165447E+01,0.165444E+01,0.165455E+01,0.165447E+01,0.355845E+02,
22871 &0.137726E+01,0.189369E+01,0.196807E+01,0.183687E+01,0.183686E+01,
22872 &0.183701E+01,0.183687E+01,0.389473E+02,0.156390E+01,0.208631E+01,
22873 &0.216422E+01,0.202653E+01,0.202654E+01,0.202673E+01,0.202653E+01,
22874 &0.422402E+02,0.175779E+01,0.228501E+01,0.236648E+01,0.222220E+01,
22875 &0.222224E+01,0.222248E+01,0.222220E+01,0.454277E+02,0.195768E+01,
22876 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22877 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22878 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22879 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22880 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22881 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22882 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22883 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22884 &0.326035E+00,0.380777E+00,0.286363E+00,0.286363E+00,0.286363E+00,
22885 &0.286363E+00,0.392252E+01,-.138778E-16,0.380092E+00,0.438587E+00/
22886 DATA (DL(K),K= 171, 255) /
22887 &0.337452E+00,0.337430E+00,0.337424E+00,0.337452E+00,0.532193E+01,
22888 &0.553645E-01,0.440879E+00,0.503177E+00,0.395208E+00,0.395169E+00,
22889 &0.395165E+00,0.395208E+00,0.686454E+01,0.117354E+00,0.508415E+00,
22890 &0.574566E+00,0.459649E+00,0.459600E+00,0.459604E+00,0.459649E+00,
22891 &0.853316E+01,0.185994E+00,0.582647E+00,0.652699E+00,0.530722E+00,
22892 &0.530667E+00,0.530687E+00,0.530722E+00,0.103093E+02,0.261237E+00,
22893 &0.663404E+00,0.737405E+00,0.608254E+00,0.608199E+00,0.608241E+00,
22894 &0.608254E+00,0.121710E+02,0.342917E+00,0.750429E+00,0.828423E+00,
22895 &0.691990E+00,0.691941E+00,0.692009E+00,0.691990E+00,0.140946E+02,
22896 &0.430783E+00,0.843361E+00,0.925391E+00,0.781571E+00,0.781533E+00,
22897 &0.781632E+00,0.781571E+00,0.160553E+02,0.524479E+00,0.941741E+00,
22898 &0.102784E+01,0.876538E+00,0.876515E+00,0.876650E+00,0.876538E+00,
22899 &0.180277E+02,0.623549E+00,0.104501E+01,0.113521E+01,0.976335E+00,
22900 &0.976332E+00,0.976506E+00,0.976335E+00,0.199863E+02,0.727439E+00,
22901 &0.115251E+01,0.124685E+01,0.108031E+01,0.108034E+01,0.108055E+01,
22902 &0.108031E+01,0.219066E+02,0.835506E+00,0.126352E+01,0.136201E+01,
22903 &0.118775E+01,0.118780E+01,0.118806E+01,0.118775E+01,0.237652E+02/
22904 DATA (DL(K),K= 256, 340) /
22905 &0.947020E+00,0.137724E+01,0.147989E+01,0.129783E+01,0.129791E+01,
22906 &0.129822E+01,0.129783E+01,0.255406E+02,0.106119E+01,0.149279E+01,
22907 &0.159961E+01,0.140972E+01,0.140984E+01,0.141019E+01,0.140972E+01,
22908 &0.272135E+02,0.117715E+01,0.160929E+01,0.172028E+01,0.152252E+01,
22909 &0.152267E+01,0.152308E+01,0.152252E+01,0.287669E+02,0.129402E+01,
22910 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22911 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22912 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22913 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22914 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22915 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22916 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22917 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22918 &0.309785E+00,0.391282E+00,0.250518E+00,0.250518E+00,0.250518E+00,
22919 &0.250518E+00,0.343842E+01,-.138778E-16,0.352113E+00,0.438463E+00,
22920 &0.288877E+00,0.288863E+00,0.288878E+00,0.288877E+00,0.446765E+01,
22921 &0.424850E-01,0.398382E+00,0.489596E+00,0.331132E+00,0.331111E+00/
22922 DATA (DL(K),K= 341, 425) /
22923 &0.331148E+00,0.331132E+00,0.555902E+01,0.888369E-01,0.448375E+00,
22924 &0.544458E+00,0.377064E+00,0.377043E+00,0.377108E+00,0.377064E+00,
22925 &0.669490E+01,0.138845E+00,0.501854E+00,0.602811E+00,0.426440E+00,
22926 &0.426425E+00,0.426523E+00,0.426440E+00,0.785892E+01,0.192281E+00,
22927 &0.558506E+00,0.664331E+00,0.478946E+00,0.478944E+00,0.479079E+00,
22928 &0.478946E+00,0.903368E+01,0.248834E+00,0.617972E+00,0.728657E+00,
22929 &0.534229E+00,0.534244E+00,0.534421E+00,0.534229E+00,0.102022E+02,
22930 &0.308155E+00,0.679844E+00,0.795370E+00,0.591883E+00,0.591921E+00,
22931 &0.592141E+00,0.591883E+00,0.113479E+02,0.369841E+00,0.743667E+00,
22932 &0.864009E+00,0.651460E+00,0.651525E+00,0.651792E+00,0.651460E+00,
22933 &0.124553E+02,0.433447E+00,0.808951E+00,0.934073E+00,0.712474E+00,
22934 &0.712571E+00,0.712885E+00,0.712474E+00,0.135102E+02,0.498486E+00,
22935 &0.875171E+00,0.100503E+01,0.774408E+00,0.774541E+00,0.774902E+00,
22936 &0.774408E+00,0.144999E+02,0.564446E+00,0.941784E+00,0.107632E+01,
22937 &0.836726E+00,0.836897E+00,0.837307E+00,0.836726E+00,0.154136E+02,
22938 &0.630788E+00,0.100823E+01,0.114738E+01,0.898879E+00,0.899092E+00,
22939 &0.899551E+00,0.898879E+00,0.162423E+02,0.696967E+00,0.107396E+01/
22940 DATA (DL(K),K= 426, 510) /
22941 &0.121764E+01,0.960319E+00,0.960577E+00,0.961084E+00,0.960319E+00,
22942 &0.169791E+02,0.762433E+00,0.113843E+01,0.128655E+01,0.102051E+01,
22943 &0.102081E+01,0.102137E+01,0.102051E+01,0.176190E+02,0.826647E+00,
22944 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22945 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22946 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22947 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22948 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22949 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22950 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22951 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22952 &0.304680E+00,0.425088E+00,0.216504E+00,0.216504E+00,0.216504E+00,
22953 &0.216504E+00,0.298356E+01,0.000000E+00,0.337300E+00,0.463627E+00,
22954 &0.244023E+00,0.244024E+00,0.244063E+00,0.244023E+00,0.370271E+01,
22955 &0.316585E-01,0.371787E+00,0.503942E+00,0.273415E+00,0.273423E+00,
22956 &0.273505E+00,0.273415E+00,0.443039E+01,0.651685E-01,0.407853E+00,
22957 &0.545739E+00,0.304395E+00,0.304418E+00,0.304545E+00,0.304395E+00/
22958 DATA (DL(K),K= 511, 595) /
22959 &0.515321E+01,0.100252E+00,0.445229E+00,0.588741E+00,0.336700E+00,
22960 &0.336744E+00,0.336918E+00,0.336700E+00,0.586004E+01,0.136648E+00,
22961 &0.483606E+00,0.632629E+00,0.370026E+00,0.370095E+00,0.370318E+00,
22962 &0.370026E+00,0.654027E+01,0.174056E+00,0.522666E+00,0.677074E+00,
22963 &0.404062E+00,0.404162E+00,0.404433E+00,0.404062E+00,0.718442E+01,
22964 &0.212167E+00,0.562075E+00,0.721735E+00,0.438483E+00,0.438618E+00,
22965 &0.438938E+00,0.438483E+00,0.778423E+01,0.250658E+00,0.601494E+00,
22966 &0.766258E+00,0.472959E+00,0.473131E+00,0.473500E+00,0.472959E+00,
22967 &0.833276E+01,0.289199E+00,0.640580E+00,0.810290E+00,0.507156E+00,
22968 &0.507369E+00,0.507784E+00,0.507156E+00,0.882448E+01,0.327457E+00,
22969 &0.678993E+00,0.853479E+00,0.540747E+00,0.541003E+00,0.541463E+00,
22970 &0.540747E+00,0.925529E+01,0.365104E+00,0.716405E+00,0.895483E+00,
22971 &0.573411E+00,0.573714E+00,0.574216E+00,0.573411E+00,0.962250E+01,
22972 &0.401821E+00,0.752501E+00,0.935975E+00,0.604848E+00,0.605197E+00,
22973 &0.605740E+00,0.604848E+00,0.992478E+01,0.437304E+00,0.786987E+00,
22974 &0.974647E+00,0.634775E+00,0.635173E+00,0.635752E+00,0.634775E+00,
22975 &0.101620E+02,0.471269E+00,0.819594E+00,0.101122E+01,0.662936E+00/
22976 DATA (DL(K),K= 596, 680) /
22977 &0.663382E+00,0.663995E+00,0.662936E+00,0.103354E+02,0.503459E+00,
22978 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22979 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22980 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22981 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22982 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22983 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22984 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22985 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22986 &0.312661E+00,0.487836E+00,0.182562E+00,0.182562E+00,0.182562E+00,
22987 &0.182562E+00,0.253626E+01,0.000000E+00,0.336910E+00,0.518440E+00,
22988 &0.200702E+00,0.200721E+00,0.200779E+00,0.200702E+00,0.299460E+01,
22989 &0.224425E-01,0.361554E+00,0.549164E+00,0.219359E+00,0.219402E+00,
22990 &0.219517E+00,0.219359E+00,0.343183E+01,0.453742E-01,0.386348E+00,
22991 &0.579759E+00,0.238296E+00,0.238367E+00,0.238536E+00,0.238296E+00,
22992 &0.384076E+01,0.685610E-01,0.411080E+00,0.610003E+00,0.257305E+00,
22993 &0.257408E+00,0.257630E+00,0.257305E+00,0.421619E+01,0.917987E-01/
22994 DATA (DL(K),K= 681, 765) /
22995 &0.435528E+00,0.639668E+00,0.276174E+00,0.276313E+00,0.276583E+00,
22996 &0.276174E+00,0.455400E+01,0.114876E+00,0.459476E+00,0.668531E+00,
22997 &0.294698E+00,0.294875E+00,0.295191E+00,0.294698E+00,0.485107E+01,
22998 &0.137589E+00,0.482719E+00,0.696375E+00,0.312682E+00,0.312900E+00,
22999 &0.313258E+00,0.312682E+00,0.510539E+01,0.159742E+00,0.505060E+00,
23000 &0.722995E+00,0.329941E+00,0.330200E+00,0.330596E+00,0.329941E+00,
23001 &0.531589E+01,0.181149E+00,0.526315E+00,0.748199E+00,0.346303E+00,
23002 &0.346604E+00,0.347034E+00,0.346303E+00,0.548250E+01,0.201638E+00,
23003 &0.546317E+00,0.771808E+00,0.361613E+00,0.361957E+00,0.362418E+00,
23004 &0.361613E+00,0.560595E+01,0.221052E+00,0.564917E+00,0.793667E+00,
23005 &0.375735E+00,0.376122E+00,0.376609E+00,0.375735E+00,0.568772E+01,
23006 &0.239253E+00,0.581987E+00,0.813638E+00,0.388553E+00,0.388982E+00,
23007 &0.389491E+00,0.388553E+00,0.572992E+01,0.256122E+00,0.597419E+00,
23008 &0.831608E+00,0.399972E+00,0.400443E+00,0.400970E+00,0.399972E+00,
23009 &0.573516E+01,0.271562E+00,0.611129E+00,0.847487E+00,0.409919E+00,
23010 &0.410430E+00,0.410972E+00,0.409919E+00,0.570642E+01,0.285497E+00,
23011 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23012 DATA (DL(K),K= 766, 850) /
23013 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23014 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23015 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23016 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23017 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23018 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23019 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23020 &0.335149E+00,0.582072E+00,0.146415E+00,0.146415E+00,0.146415E+00,
23021 &0.146415E+00,0.206772E+01,0.000000E+00,0.351552E+00,0.603437E+00,
23022 &0.156515E+00,0.156542E+00,0.156595E+00,0.156515E+00,0.231143E+01,
23023 &0.146091E-01,0.367407E+00,0.623737E+00,0.166387E+00,0.166442E+00,
23024 &0.166542E+00,0.166387E+00,0.252488E+01,0.289315E-01,0.382571E+00,
23025 &0.642832E+00,0.175891E+00,0.175976E+00,0.176118E+00,0.175891E+00,
23026 &0.270658E+01,0.428312E-01,0.396926E+00,0.660609E+00,0.184917E+00,
23027 &0.185034E+00,0.185212E+00,0.184917E+00,0.285608E+01,0.561981E-01,
23028 &0.410365E+00,0.676962E+00,0.193365E+00,0.193513E+00,0.193722E+00,
23029 &0.193365E+00,0.297375E+01,0.689319E-01,0.422792E+00,0.691796E+00/
23030 DATA (DL(K),K= 851, 935) /
23031 &0.201144E+00,0.201324E+00,0.201560E+00,0.201144E+00,0.306050E+01,
23032 &0.809434E-01,0.434123E+00,0.705030E+00,0.208181E+00,0.208393E+00,
23033 &0.208650E+00,0.208181E+00,0.311775E+01,0.921567E-01,0.444287E+00,
23034 &0.716596E+00,0.214413E+00,0.214656E+00,0.214931E+00,0.214413E+00,
23035 &0.314738E+01,0.102508E+00,0.453228E+00,0.726441E+00,0.219792E+00,
23036 &0.220066E+00,0.220354E+00,0.219792E+00,0.315156E+01,0.111949E+00,
23037 &0.460906E+00,0.734527E+00,0.224285E+00,0.224589E+00,0.224886E+00,
23038 &0.224285E+00,0.313271E+01,0.120441E+00,0.467291E+00,0.740835E+00,
23039 &0.227870E+00,0.228203E+00,0.228506E+00,0.227870E+00,0.309338E+01,
23040 &0.127963E+00,0.472372E+00,0.745357E+00,0.230541E+00,0.230902E+00,
23041 &0.231208E+00,0.230541E+00,0.303621E+01,0.134506E+00,0.476148E+00,
23042 &0.748105E+00,0.232304E+00,0.232690E+00,0.232996E+00,0.232304E+00,
23043 &0.296381E+01,0.140070E+00,0.478635E+00,0.749103E+00,0.233176E+00,
23044 &0.233586E+00,0.233889E+00,0.233176E+00,0.287874E+01,0.144672E+00,
23045 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23046 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23047 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23048 DATA (DL(K),K= 936, 1020) /
23049 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23050 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23051 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23052 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23053 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23054 &0.370162E+00,0.695827E+00,0.105823E+00,0.105823E+00,0.105823E+00,
23055 &0.105823E+00,0.154556E+01,0.208167E-16,0.378214E+00,0.703794E+00,
23056 &0.109539E+00,0.109554E+00,0.109571E+00,0.109539E+00,0.162770E+01,
23057 &0.818783E-02,0.385258E+00,0.710067E+00,0.112818E+00,0.112847E+00,
23058 &0.112879E+00,0.112818E+00,0.168578E+01,0.158212E-01,0.391264E+00,
23059 &0.714648E+00,0.115620E+00,0.115666E+00,0.115709E+00,0.115620E+00,
23060 &0.172175E+01,0.228667E-01,0.396214E+00,0.717539E+00,0.117923E+00,
23061 &0.117985E+00,0.118037E+00,0.117923E+00,0.173756E+01,0.293009E-01,
23062 &0.400098E+00,0.718759E+00,0.119711E+00,0.119790E+00,0.119848E+00,
23063 &0.119711E+00,0.173541E+01,0.351123E-01,0.402915E+00,0.718332E+00,
23064 &0.120979E+00,0.121074E+00,0.121137E+00,0.120979E+00,0.171755E+01,
23065 &0.402951E-01,0.404672E+00,0.716292E+00,0.121728E+00,0.121840E+00/
23066 DATA (DL(K),K= 1021, 1105) /
23067 &0.121905E+00,0.121728E+00,0.168619E+01,0.448514E-01,0.405385E+00,
23068 &0.712681E+00,0.121967E+00,0.122095E+00,0.122161E+00,0.121967E+00,
23069 &0.164352E+01,0.487902E-01,0.405077E+00,0.707551E+00,0.121712E+00,
23070 &0.121855E+00,0.121920E+00,0.121712E+00,0.159162E+01,0.521265E-01,
23071 &0.403778E+00,0.700963E+00,0.120984E+00,0.121141E+00,0.121204E+00,
23072 &0.120984E+00,0.153245E+01,0.548814E-01,0.401525E+00,0.692984E+00,
23073 &0.119809E+00,0.119980E+00,0.120040E+00,0.119809E+00,0.146780E+01,
23074 &0.570807E-01,0.398361E+00,0.683691E+00,0.118218E+00,0.118402E+00,
23075 &0.118457E+00,0.118218E+00,0.139928E+01,0.587542E-01,0.394333E+00,
23076 &0.673166E+00,0.116244E+00,0.116440E+00,0.116490E+00,0.116244E+00,
23077 &0.132834E+01,0.599355E-01,0.389495E+00,0.661496E+00,0.113924E+00,
23078 &0.114131E+00,0.114175E+00,0.113924E+00,0.125620E+01,0.606602E-01,
23079 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23080 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23081 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23082 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23083 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23084 DATA (DL(K),K= 1106, 1190) /
23085 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23086 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23087 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23088 &0.394012E+00,0.757115E+00,0.772117E-01,0.772117E-01,0.772117E-01,
23089 &0.772117E-01,0.117279E+01,0.346945E-17,0.395841E+00,0.752988E+00,
23090 &0.780501E-01,0.780655E-01,0.780723E-01,0.780501E-01,0.118528E+01,
23091 &0.491697E-02,0.396627E+00,0.747223E+00,0.785386E-01,0.785692E-01,
23092 &0.785806E-01,0.785386E-01,0.118242E+01,0.932754E-02,0.396401E+00,
23093 &0.739901E+00,0.786820E-01,0.787273E-01,0.787413E-01,0.786820E-01,
23094 &0.116673E+01,0.132427E-01,0.395190E+00,0.731092E+00,0.784870E-01,
23095 &0.785464E-01,0.785613E-01,0.784870E-01,0.114033E+01,0.166738E-01,
23096 &0.393030E+00,0.720878E+00,0.779683E-01,0.780410E-01,0.780555E-01,
23097 &0.779683E-01,0.110528E+01,0.196392E-01,0.389962E+00,0.709342E+00,
23098 &0.771427E-01,0.772280E-01,0.772409E-01,0.771427E-01,0.106344E+01,
23099 &0.221591E-01,0.386027E+00,0.696571E+00,0.760304E-01,0.761276E-01,
23100 &0.761378E-01,0.760304E-01,0.101653E+01,0.242567E-01,0.381274E+00,
23101 &0.682657E+00,0.746543E-01,0.747623E-01,0.747692E-01,0.746543E-01/
23102 DATA (DL(K),K= 1191, 1275) /
23103 &0.966057E+00,0.259571E-01,0.375752E+00,0.667695E+00,0.730389E-01,
23104 &0.731569E-01,0.731598E-01,0.730389E-01,0.913345E+00,0.272876E-01,
23105 &0.369514E+00,0.651782E+00,0.712104E-01,0.713374E-01,0.713358E-01,
23106 &0.712104E-01,0.859530E+00,0.282763E-01,0.362616E+00,0.635021E+00,
23107 &0.691957E-01,0.693307E-01,0.693243E-01,0.691957E-01,0.805566E+00,
23108 &0.289524E-01,0.355116E+00,0.617511E+00,0.670220E-01,0.671640E-01,
23109 &0.671526E-01,0.670220E-01,0.752235E+00,0.293453E-01,0.347072E+00,
23110 &0.599357E+00,0.647162E-01,0.648642E-01,0.648478E-01,0.647162E-01,
23111 &0.700161E+00,0.294844E-01,0.338543E+00,0.580659E+00,0.623046E-01,
23112 &0.624578E-01,0.624363E-01,0.623046E-01,0.649828E+00,0.293983E-01,
23113 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23114 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23115 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23116 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23117 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23118 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23119 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23120 DATA (DL(K),K= 1276, 1360) /
23121 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23122 &0.408305E+00,0.775318E+00,0.509141E-01,0.509141E-01,0.509141E-01,
23123 &0.509141E-01,0.818839E+00,-.867362E-17,0.403619E+00,0.758058E+00,
23124 &0.502245E-01,0.502351E-01,0.502337E-01,0.502245E-01,0.795347E+00,
23125 &0.264045E-02,0.398068E+00,0.739709E+00,0.493454E-01,0.493661E-01,
23126 &0.493626E-01,0.493454E-01,0.764942E+00,0.491508E-02,0.391719E+00,
23127 &0.720394E+00,0.482952E-01,0.483253E-01,0.483192E-01,0.482952E-01,
23128 &0.729624E+00,0.685202E-02,0.384627E+00,0.700222E+00,0.470896E-01,
23129 &0.471285E-01,0.471194E-01,0.470896E-01,0.690906E+00,0.847433E-02,
23130 &0.376851E+00,0.679300E+00,0.457475E-01,0.457946E-01,0.457822E-01,
23131 &0.457475E-01,0.650078E+00,0.980774E-02,0.368452E+00,0.657739E+00,
23132 &0.442875E-01,0.443419E-01,0.443261E-01,0.442875E-01,0.608239E+00,
23133 &0.108769E-01,0.359490E+00,0.635646E+00,0.427281E-01,0.427892E-01,
23134 &0.427698E-01,0.427281E-01,0.566280E+00,0.117061E-01,0.350026E+00,
23135 &0.613128E+00,0.410878E-01,0.411549E-01,0.411320E-01,0.410878E-01,
23136 &0.524918E+00,0.123191E-01,0.340122E+00,0.590292E+00,0.393848E-01,
23137 &0.394571E-01,0.394308E-01,0.393848E-01,0.484713E+00,0.127393E-01/
23138 DATA (DL(K),K= 1361, 1445) /
23139 &0.329838E+00,0.567240E+00,0.376363E-01,0.377132E-01,0.376836E-01,
23140 &0.376363E-01,0.446084E+00,0.129888E-01,0.319236E+00,0.544074E+00,
23141 &0.358589E-01,0.359396E-01,0.359068E-01,0.358589E-01,0.409328E+00,
23142 &0.130888E-01,0.308374E+00,0.520890E+00,0.340678E-01,0.341517E-01,
23143 &0.341160E-01,0.340678E-01,0.374641E+00,0.130594E-01,0.297312E+00,
23144 &0.497781E+00,0.322772E-01,0.323636E-01,0.323253E-01,0.322772E-01,
23145 &0.342135E+00,0.129195E-01,0.286106E+00,0.474837E+00,0.304999E-01,
23146 &0.305882E-01,0.305474E-01,0.304999E-01,0.311854E+00,0.126863E-01,
23147 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23148 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23149 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23150 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23151 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23152 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23153 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23154 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23155 &0.407248E+00,0.746438E+00,0.335640E-01,0.335640E-01,0.335640E-01/
23156 DATA (DL(K),K= 1446, 1530) /
23157 &0.335640E-01,0.573540E+00,0.173472E-16,0.397516E+00,0.719825E+00,
23158 &0.324649E-01,0.324735E-01,0.324698E-01,0.324649E-01,0.540770E+00,
23159 &0.147177E-02,0.387197E+00,0.692869E+00,0.312911E-01,0.313075E-01,
23160 &0.313000E-01,0.312911E-01,0.505972E+00,0.269995E-02,0.376365E+00,
23161 &0.665689E+00,0.300576E-01,0.300811E-01,0.300699E-01,0.300576E-01,
23162 &0.470389E+00,0.371147E-02,0.365085E+00,0.638387E+00,0.287770E-01,
23163 &0.288070E-01,0.287922E-01,0.287770E-01,0.434885E+00,0.452768E-02,
23164 &0.353423E+00,0.611066E+00,0.274623E-01,0.274980E-01,0.274797E-01,
23165 &0.274623E-01,0.400103E+00,0.516996E-02,0.341442E+00,0.583823E+00,
23166 &0.261256E-01,0.261663E-01,0.261448E-01,0.261256E-01,0.366541E+00,
23167 &0.565807E-02,0.329207E+00,0.556753E+00,0.247782E-01,0.248234E-01,
23168 &0.247989E-01,0.247782E-01,0.334555E+00,0.601048E-02,0.316777E+00,
23169 &0.529946E+00,0.234308E-01,0.234798E-01,0.234525E-01,0.234308E-01,
23170 &0.304384E+00,0.624451E-02,0.304214E+00,0.503489E+00,0.220932E-01,
23171 &0.221452E-01,0.221155E-01,0.220932E-01,0.276170E+00,0.637618E-02,
23172 &0.291575E+00,0.477462E+00,0.207739E-01,0.208286E-01,0.207966E-01,
23173 &0.207739E-01,0.249976E+00,0.642028E-02,0.278917E+00,0.451941E+00/
23174 DATA (DL(K),K= 1531, 1615) /
23175 &0.194809E-01,0.195376E-01,0.195037E-01,0.194809E-01,0.225809E+00,
23176 &0.639038E-02,0.266293E+00,0.426995E+00,0.182209E-01,0.182791E-01,
23177 &0.182436E-01,0.182209E-01,0.203629E+00,0.629880E-02,0.253754E+00,
23178 &0.402686E+00,0.169996E-01,0.170587E-01,0.170219E-01,0.169996E-01,
23179 &0.183361E+00,0.615665E-02,0.241347E+00,0.379071E+00,0.158217E-01,
23180 &0.158814E-01,0.158436E-01,0.158217E-01,0.164907E+00,0.597385E-02,
23181 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23182 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23183 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23184 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23185 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23186 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23187 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23188 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23189 &0.395106E+00,0.689399E+00,0.218554E-01,0.218554E-01,0.218554E-01,
23190 &0.218554E-01,0.398362E+00,-.173472E-17,0.381441E+00,0.656777E+00,
23191 &0.207816E-01,0.207886E-01,0.207844E-01,0.207816E-01,0.366703E+00/
23192 DATA (DL(K),K= 1616, 1700) /
23193 &0.826643E-03,0.367505E+00,0.624578E+00,0.197001E-01,0.197133E-01,
23194 &0.197053E-01,0.197001E-01,0.335573E+00,0.149886E-02,0.353373E+00,
23195 &0.592889E+00,0.186195E-01,0.186383E-01,0.186266E-01,0.186195E-01,
23196 &0.305590E+00,0.203730E-02,0.339106E+00,0.561783E+00,0.175468E-01,
23197 &0.175705E-01,0.175555E-01,0.175468E-01,0.277136E+00,0.245817E-02,
23198 &0.324766E+00,0.531331E+00,0.164887E-01,0.165166E-01,0.164986E-01,
23199 &0.164887E-01,0.250424E+00,0.277666E-02,0.310411E+00,0.501599E+00,
23200 &0.154510E-01,0.154825E-01,0.154618E-01,0.154510E-01,0.225588E+00,
23201 &0.300658E-02,0.296100E+00,0.472648E+00,0.144390E-01,0.144735E-01,
23202 &0.144504E-01,0.144390E-01,0.202681E+00,0.316040E-02,0.281885E+00,
23203 &0.444535E+00,0.134570E-01,0.134940E-01,0.134689E-01,0.134570E-01,
23204 &0.181693E+00,0.324944E-02,0.267820E+00,0.417309E+00,0.125091E-01,
23205 &0.125481E-01,0.125212E-01,0.125091E-01,0.162572E+00,0.328396E-02,
23206 &0.253953E+00,0.391017E+00,0.115984E-01,0.116389E-01,0.116106E-01,
23207 &0.115984E-01,0.145235E+00,0.327313E-02,0.240328E+00,0.365695E+00,
23208 &0.107275E-01,0.107690E-01,0.107396E-01,0.107275E-01,0.129575E+00,
23209 &0.322510E-02,0.226989E+00,0.341375E+00,0.989805E-02,0.994030E-02/
23210 DATA (DL(K),K= 1701, 1785) /
23211 &0.990998E-02,0.989805E-02,0.115477E+00,0.314713E-02,0.213972E+00,
23212 &0.318081E+00,0.911149E-02,0.915408E-02,0.912316E-02,0.911149E-02,
23213 &0.102820E+00,0.304556E-02,0.201311E+00,0.295830E+00,0.836852E-02,
23214 &0.841111E-02,0.837984E-02,0.836852E-02,0.914804E-01,0.292596E-02,
23215 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23216 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23217 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23218 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23219 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23220 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23221 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23222 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23223 &0.374678E+00,0.616087E+00,0.139531E-01,0.139531E-01,0.139531E-01,
23224 &0.139531E-01,0.272491E+00,-.693889E-17,0.358052E+00,0.580345E+00,
23225 &0.130624E-01,0.130680E-01,0.130641E-01,0.130624E-01,0.245861E+00,
23226 &0.460255E-03,0.341487E+00,0.545719E+00,0.121971E-01,0.122076E-01,
23227 &0.122002E-01,0.121971E-01,0.220877E+00,0.826785E-03,0.325046E+00/
23228 DATA (DL(K),K= 1786, 1870) /
23229 &0.512244E+00,0.113599E-01,0.113748E-01,0.113641E-01,0.113599E-01,
23230 &0.197730E+00,0.111366E-02,0.308783E+00,0.479952E+00,0.105534E-01,
23231 &0.105720E-01,0.105585E-01,0.105534E-01,0.176497E+00,0.133192E-02,
23232 &0.292747E+00,0.448868E+00,0.977938E-02,0.980112E-02,0.978518E-02,
23233 &0.977938E-02,0.157150E+00,0.149139E-02,0.276986E+00,0.419015E+00,
23234 &0.903955E-02,0.906394E-02,0.904584E-02,0.903955E-02,0.139631E+00,
23235 &0.160093E-02,0.261546E+00,0.390412E+00,0.833509E-02,0.836165E-02,
23236 &0.834171E-02,0.833509E-02,0.123850E+00,0.166838E-02,0.246467E+00,
23237 &0.363074E+00,0.766687E-02,0.769516E-02,0.767369E-02,0.766687E-02,
23238 &0.109695E+00,0.170073E-02,0.231787E+00,0.337008E+00,0.703540E-02,
23239 &0.706500E-02,0.704230E-02,0.703540E-02,0.970428E-01,0.170416E-02,
23240 &0.217542E+00,0.312218E+00,0.644083E-02,0.647137E-02,0.644772E-02,
23241 &0.644083E-02,0.857658E-01,0.168409E-02,0.203759E+00,0.288701E+00,
23242 &0.588300E-02,0.591415E-02,0.588981E-02,0.588300E-02,0.757385E-01,
23243 &0.164528E-02,0.190467E+00,0.266449E+00,0.536147E-02,0.539292E-02,
23244 &0.536812E-02,0.536147E-02,0.668383E-01,0.159185E-02,0.177686E+00,
23245 &0.245447E+00,0.487551E-02,0.490698E-02,0.488195E-02,0.487551E-02/
23246 DATA (DL(K),K= 1871, 1955) /
23247 &0.589492E-01,0.152735E-02,0.165434E+00,0.225677E+00,0.442416E-02,
23248 &0.445543E-02,0.443037E-02,0.442416E-02,0.519652E-01,0.145483E-02,
23249 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23250 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23251 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23252 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23253 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23254 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23255 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23256 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23257 &0.348042E+00,0.534691E+00,0.867977E-02,0.867977E-02,0.867977E-02,
23258 &0.867977E-02,0.182547E+00,-.693889E-17,0.329349E+00,0.498248E+00,
23259 &0.800724E-02,0.801198E-02,0.800836E-02,0.800724E-02,0.161948E+00,
23260 &0.250949E-03,0.311047E+00,0.463485E+00,0.737155E-02,0.738040E-02,
23261 &0.737356E-02,0.737155E-02,0.143267E+00,0.447662E-03,0.293181E+00,
23262 &0.430377E+00,0.677169E-02,0.678409E-02,0.677441E-02,0.677169E-02,
23263 &0.126447E+00,0.598803E-03,0.275787E+00,0.398907E+00,0.620726E-02/
23264 DATA (DL(K),K= 1956, 2040) /
23265 &0.622265E-02,0.621051E-02,0.620726E-02,0.111401E+00,0.711280E-03,
23266 &0.258900E+00,0.369051E+00,0.567741E-02,0.569532E-02,0.568106E-02,
23267 &0.567741E-02,0.979944E-01,0.790986E-03,0.242550E+00,0.340785E+00,
23268 &0.518138E-02,0.520134E-02,0.518531E-02,0.518138E-02,0.860936E-01,
23269 &0.843227E-03,0.226765E+00,0.314083E+00,0.471828E-02,0.473987E-02,
23270 &0.472238E-02,0.471828E-02,0.755615E-01,0.872644E-03,0.211568E+00,
23271 &0.288916E+00,0.428714E-02,0.430998E-02,0.429133E-02,0.428714E-02,
23272 &0.662627E-01,0.883319E-03,0.196981E+00,0.265252E+00,0.388691E-02,
23273 &0.391065E-02,0.389112E-02,0.388691E-02,0.580684E-01,0.878818E-03,
23274 &0.183020E+00,0.243053E+00,0.351645E-02,0.354077E-02,0.352060E-02,
23275 &0.351645E-02,0.508578E-01,0.862228E-03,0.169696E+00,0.222280E+00,
23276 &0.317451E-02,0.319914E-02,0.317858E-02,0.317451E-02,0.445190E-01,
23277 &0.836224E-03,0.157017E+00,0.202888E+00,0.285982E-02,0.288450E-02,
23278 &0.286376E-02,0.285982E-02,0.389523E-01,0.803096E-03,0.144987E+00,
23279 &0.184832E+00,0.257101E-02,0.259553E-02,0.257480E-02,0.257101E-02,
23280 &0.340677E-01,0.764787E-03,0.133605E+00,0.168060E+00,0.230670E-02,
23281 &0.233087E-02,0.231031E-02,0.230670E-02,0.297820E-01,0.722929E-03/
23282 DATA (DL(K),K= 2041, 2125) /
23283 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23284 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23285 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23286 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23287 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23288 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23289 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23290 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23291 &0.316867E+00,0.451111E+00,0.522815E-02,0.522815E-02,0.522815E-02,
23292 &0.522815E-02,0.119118E+00,0.889046E-17,0.296950E+00,0.415915E+00,
23293 &0.475497E-02,0.475914E-02,0.475574E-02,0.475497E-02,0.104204E+00,
23294 &0.132513E-03,0.277735E+00,0.382805E+00,0.431809E-02,0.432582E-02,
23295 &0.431944E-02,0.431809E-02,0.910279E-01,0.235347E-03,0.259241E+00,
23296 &0.351694E+00,0.391455E-02,0.392531E-02,0.391637E-02,0.391455E-02,
23297 &0.794222E-01,0.313322E-03,0.241485E+00,0.322517E+00,0.354249E-02,
23298 &0.355575E-02,0.354464E-02,0.354249E-02,0.692354E-01,0.370408E-03,
23299 &0.224480E+00,0.295202E+00,0.319987E-02,0.321518E-02,0.320226E-02/
23300 DATA (DL(K),K= 2126, 2210) /
23301 &0.319987E-02,0.603106E-01,0.409866E-03,0.208235E+00,0.269681E+00,
23302 &0.288490E-02,0.290184E-02,0.288744E-02,0.288490E-02,0.525034E-01,
23303 &0.434663E-03,0.192759E+00,0.245887E+00,0.259589E-02,0.261407E-02,
23304 &0.259852E-02,0.259589E-02,0.456838E-01,0.447393E-03,0.178054E+00,
23305 &0.223752E+00,0.233123E-02,0.235033E-02,0.233390E-02,0.233123E-02,
23306 &0.397318E-01,0.450314E-03,0.164120E+00,0.203207E+00,0.208941E-02,
23307 &0.210910E-02,0.209206E-02,0.208941E-02,0.345396E-01,0.445394E-03,
23308 &0.150954E+00,0.184182E+00,0.186896E-02,0.188897E-02,0.187155E-02,
23309 &0.186896E-02,0.300131E-01,0.434333E-03,0.138548E+00,0.166608E+00,
23310 &0.166844E-02,0.168854E-02,0.167096E-02,0.166844E-02,0.260692E-01,
23311 &0.418584E-03,0.126892E+00,0.150412E+00,0.148650E-02,0.150648E-02,
23312 &0.148891E-02,0.148650E-02,0.226325E-01,0.399380E-03,0.115971E+00,
23313 &0.135523E+00,0.132180E-02,0.134148E-02,0.132409E-02,0.132180E-02,
23314 &0.196374E-01,0.377764E-03,0.105767E+00,0.121870E+00,0.117308E-02,
23315 &0.119231E-02,0.117524E-02,0.117308E-02,0.170312E-01,0.354610E-03,
23316 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23317 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23318 DATA (DL(K),K= 2211, 2295) /
23319 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23320 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23321 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23322 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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.282579E+00,0.369670E+00,0.302765E-02,0.302765E-02,0.302765E-02,
23326 &0.302765E-02,0.752529E-01,-.455365E-17,0.262229E+00,0.337209E+00,
23327 &0.271512E-02,0.271883E-02,0.271564E-02,0.271512E-02,0.651086E-01,
23328 &0.669321E-04,0.242857E+00,0.307069E+00,0.243269E-02,0.243953E-02,
23329 &0.243360E-02,0.243269E-02,0.563252E-01,0.118744E-03,0.224455E+00,
23330 &0.279111E+00,0.217687E-02,0.218631E-02,0.217808E-02,0.217687E-02,
23331 &0.487143E-01,0.157767E-03,0.207014E+00,0.253223E+00,0.194534E-02,
23332 &0.195689E-02,0.194675E-02,0.194534E-02,0.421227E-01,0.186063E-03,
23333 &0.190523E+00,0.229293E+00,0.173585E-02,0.174909E-02,0.173741E-02,
23334 &0.173585E-02,0.364156E-01,0.205286E-03,0.174969E+00,0.207218E+00,
23335 &0.154647E-02,0.156100E-02,0.154811E-02,0.154647E-02,0.314732E-01/
23336 DATA (DL(K),K= 2296, 2380) /
23337 &0.216964E-03,0.160335E+00,0.186895E+00,0.137545E-02,0.139092E-02,
23338 &0.137713E-02,0.137545E-02,0.271927E-01,0.222455E-03,0.146604E+00,
23339 &0.168227E+00,0.122121E-02,0.123733E-02,0.122290E-02,0.122121E-02,
23340 &0.234852E-01,0.222947E-03,0.133756E+00,0.151116E+00,0.108234E-02,
23341 &0.109881E-02,0.108400E-02,0.108234E-02,0.202747E-01,0.219474E-03,
23342 &0.121765E+00,0.135471E+00,0.957502E-03,0.974107E-03,0.959112E-03,
23343 &0.957502E-03,0.174932E-01,0.212928E-03,0.110606E+00,0.121198E+00,
23344 &0.845493E-03,0.862024E-03,0.847037E-03,0.845493E-03,0.150824E-01,
23345 &0.204075E-03,0.100250E+00,0.108210E+00,0.745196E-03,0.761482E-03,
23346 &0.746662E-03,0.745196E-03,0.129965E-01,0.193573E-03,0.906661E-01,
23347 &0.964191E-01,0.655569E-03,0.671466E-03,0.656948E-03,0.655569E-03,
23348 &0.111930E-01,0.181962E-03,0.818218E-01,0.857412E-01,0.575637E-03,
23349 &0.591030E-03,0.576925E-03,0.575637E-03,0.962922E-02,0.169687E-03,
23350 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23351 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23352 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23353 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23354 DATA (DL(K),K= 2381, 2465) /
23355 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23356 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23357 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23358 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23359 &0.246444E+00,0.293515E+00,0.167124E-02,0.167124E-02,0.167124E-02,
23360 &0.167124E-02,0.456929E-01,-.260209E-17,0.226393E+00,0.264836E+00,
23361 &0.147748E-02,0.148085E-02,0.147783E-02,0.147748E-02,0.392393E-01,
23362 &0.318190E-04,0.207552E+00,0.238550E+00,0.130596E-02,0.131212E-02,
23363 &0.130656E-02,0.130596E-02,0.337276E-01,0.566426E-04,0.189877E+00,
23364 &0.214470E+00,0.115347E-02,0.116190E-02,0.115427E-02,0.115347E-02,
23365 &0.290012E-01,0.753776E-04,0.173336E+00,0.192452E+00,0.101789E-02,
23366 &0.102811E-02,0.101881E-02,0.101789E-02,0.249381E-01,0.889466E-04,
23367 &0.157889E+00,0.172355E+00,0.897268E-03,0.908872E-03,0.898270E-03,
23368 &0.897268E-03,0.214419E-01,0.980950E-04,0.143501E+00,0.154046E+00,
23369 &0.789951E-03,0.802565E-03,0.790996E-03,0.789951E-03,0.184296E-01,
23370 &0.103536E-03,0.130132E+00,0.137402E+00,0.694510E-03,0.707811E-03,
23371 &0.695568E-03,0.694510E-03,0.158331E-01,0.105929E-03,0.117743E+00/
23372 DATA (DL(K),K= 2466, 2550) /
23373 &0.122303E+00,0.609684E-03,0.623394E-03,0.610733E-03,0.609684E-03,
23374 &0.135929E-01,0.105853E-03,0.106293E+00,0.108637E+00,0.534365E-03,
23375 &0.548244E-03,0.535386E-03,0.534365E-03,0.116583E-01,0.103825E-03,
23376 &0.957386E-01,0.962976E-01,0.467572E-03,0.481416E-03,0.468551E-03,
23377 &0.467572E-03,0.999103E-02,0.100301E-03,0.860376E-01,0.851820E-01,
23378 &0.408422E-03,0.422062E-03,0.409350E-03,0.408422E-03,0.855563E-02,
23379 &0.956675E-04,0.771455E-01,0.751930E-01,0.356117E-03,0.369416E-03,
23380 &0.356989E-03,0.356117E-03,0.731542E-02,0.902499E-04,0.690178E-01,
23381 &0.662386E-01,0.309950E-03,0.322797E-03,0.310761E-03,0.309950E-03,
23382 &0.624633E-02,0.843305E-04,0.616096E-01,0.582312E-01,0.269281E-03,
23383 &0.281590E-03,0.270030E-03,0.269281E-03,0.533230E-02,0.781441E-04,
23384 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23385 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23386 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23387 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23388 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23389 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23390 DATA (DL(K),K= 2551, 2635) /
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.209608E+00,0.224862E+00,0.869706E-03,0.869706E-03,0.869706E-03,
23394 &0.869706E-03,0.264204E-01,-.138236E-17,0.190523E+00,0.200603E+00,
23395 &0.757542E-03,0.760626E-03,0.757768E-03,0.757542E-03,0.226261E-01,
23396 &0.138827E-04,0.172819E+00,0.178656E+00,0.660281E-03,0.665837E-03,
23397 &0.660670E-03,0.660281E-03,0.194018E-01,0.249832E-04,0.156420E+00,
23398 &0.158805E+00,0.575414E-03,0.582918E-03,0.575917E-03,0.575414E-03,
23399 &0.166434E-01,0.334851E-04,0.141265E+00,0.140883E+00,0.501258E-03,
23400 &0.510252E-03,0.501836E-03,0.501258E-03,0.142710E-01,0.397017E-04,
23401 &0.127291E+00,0.124732E+00,0.436386E-03,0.446473E-03,0.437008E-03,
23402 &0.436386E-03,0.122297E-01,0.439154E-04,0.114437E+00,0.110205E+00,
23403 &0.379575E-03,0.390415E-03,0.380217E-03,0.379575E-03,0.104701E-01,
23404 &0.464110E-04,0.102644E+00,0.971655E-01,0.329805E-03,0.341109E-03,
23405 &0.330448E-03,0.329805E-03,0.895086E-02,0.474758E-04,0.918521E-01,
23406 &0.854876E-01,0.286206E-03,0.297729E-03,0.286836E-03,0.286206E-03,
23407 &0.764249E-02,0.473771E-04,0.820032E-01,0.750529E-01,0.248027E-03/
23408 DATA (DL(K),K= 2636, 2720) /
23409 &0.259564E-03,0.248633E-03,0.248027E-03,0.651744E-02,0.463561E-04,
23410 &0.730394E-01,0.657510E-01,0.214611E-03,0.225995E-03,0.215186E-03,
23411 &0.214611E-03,0.554573E-02,0.446239E-04,0.649040E-01,0.574789E-01,
23412 &0.185396E-03,0.196491E-03,0.185935E-03,0.185396E-03,0.470938E-02,
23413 &0.423722E-04,0.575411E-01,0.501405E-01,0.159891E-03,0.170590E-03,
23414 &0.160391E-03,0.159891E-03,0.399752E-02,0.397689E-04,0.508960E-01,
23415 &0.436466E-01,0.137650E-03,0.147874E-03,0.138111E-03,0.137650E-03,
23416 &0.338807E-02,0.369434E-04,0.449157E-01,0.379141E-01,0.118285E-03,
23417 &0.127973E-03,0.118705E-03,0.118285E-03,0.286125E-02,0.340035E-04,
23418 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23419 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23420 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23421 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23422 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23423 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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 DATA (DL(K),K= 2721, 2805) /
23427 &0.173133E+00,0.165162E+00,0.420483E-03,0.420483E-03,0.420483E-03,
23428 &0.420483E-03,0.143704E-01,0.418773E-17,0.155600E+00,0.145586E+00,
23429 &0.360490E-03,0.363140E-03,0.360629E-03,0.360490E-03,0.123560E-01,
23430 &0.533279E-05,0.139551E+00,0.128113E+00,0.309555E-03,0.314310E-03,
23431 &0.309792E-03,0.309555E-03,0.106262E-01,0.982612E-05,0.124876E+00,
23432 &0.112516E+00,0.265952E-03,0.272344E-03,0.266256E-03,0.265952E-03,
23433 &0.913151E-02,0.133834E-04,0.111490E+00,0.986188E-01,0.228522E-03,
23434 &0.236138E-03,0.228869E-03,0.228522E-03,0.783135E-02,0.160429E-04,
23435 &0.993081E-01,0.862590E-01,0.196336E-03,0.204821E-03,0.196706E-03,
23436 &0.196336E-03,0.670031E-02,0.178799E-04,0.882484E-01,0.752883E-01,
23437 &0.168604E-03,0.177655E-03,0.168981E-03,0.168604E-03,0.572016E-02,
23438 &0.189837E-04,0.782334E-01,0.655714E-01,0.144684E-03,0.154047E-03,
23439 &0.145058E-03,0.144684E-03,0.487276E-02,0.194655E-04,0.691885E-01,
23440 &0.569841E-01,0.124035E-03,0.133497E-03,0.124397E-03,0.124035E-03,
23441 &0.413648E-02,0.194296E-04,0.610420E-01,0.494128E-01,0.106203E-03,
23442 &0.115592E-03,0.106548E-03,0.106203E-03,0.350042E-02,0.189800E-04,
23443 &0.537249E-01,0.427533E-01,0.908141E-04,0.999895E-04,0.911377E-04/
23444 DATA (DL(K),K= 2806, 2890) /
23445 &0.908141E-04,0.295961E-02,0.182192E-04,0.471713E-01,0.369100E-01,
23446 &0.775359E-04,0.863895E-04,0.778360E-04,0.775359E-04,0.249629E-02,
23447 &0.172287E-04,0.413182E-01,0.317957E-01,0.660857E-04,0.745356E-04,
23448 &0.663611E-04,0.660857E-04,0.209482E-02,0.160791E-04,0.361056E-01,
23449 &0.273306E-01,0.562298E-04,0.642173E-04,0.564804E-04,0.562298E-04,
23450 &0.175588E-02,0.148407E-04,0.314766E-01,0.234421E-01,0.477598E-04,
23451 &0.552457E-04,0.479859E-04,0.477598E-04,0.147398E-02,0.135653E-04,
23452 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23453 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23454 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23455 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23456 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23457 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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.138007E+00,0.115214E+00,0.185072E-03,0.185072E-03,0.185072E-03,
23461 &0.185072E-03,0.722856E-02,-.380826E-17,0.122517E+00,0.100251E+00/
23462 DATA (DL(K),K= 2891, 2975) /
23463 &0.155814E-03,0.158287E-03,0.155901E-03,0.155814E-03,0.630580E-02,
23464 &0.155371E-05,0.108535E+00,0.870870E-01,0.131535E-03,0.135909E-03,
23465 &0.131680E-03,0.131535E-03,0.547867E-02,0.304952E-05,0.959260E-01,
23466 &0.754985E-01,0.111183E-03,0.116980E-03,0.111366E-03,0.111183E-03,
23467 &0.473794E-02,0.433106E-05,0.845828E-01,0.653163E-01,0.940433E-04,
23468 &0.100851E-03,0.942493E-04,0.940433E-04,0.407647E-02,0.533613E-05,
23469 &0.744017E-01,0.563870E-01,0.795843E-04,0.870596E-04,0.798007E-04,
23470 &0.795843E-04,0.349165E-02,0.606691E-05,0.652864E-01,0.485720E-01,
23471 &0.673476E-04,0.752069E-04,0.675656E-04,0.673476E-04,0.297273E-02,
23472 &0.652898E-05,0.571466E-01,0.417472E-01,0.569700E-04,0.649812E-04,
23473 &0.571831E-04,0.569700E-04,0.251732E-02,0.675028E-05,0.498975E-01,
23474 &0.358008E-01,0.481618E-04,0.561391E-04,0.483654E-04,0.481618E-04,
23475 &0.212754E-02,0.677236E-05,0.434594E-01,0.306320E-01,0.406746E-04,
23476 &0.484724E-04,0.408657E-04,0.406746E-04,0.179059E-02,0.662814E-05,
23477 &0.377578E-01,0.261500E-01,0.343050E-04,0.418123E-04,0.344818E-04,
23478 &0.343050E-04,0.149563E-02,0.635273E-05,0.327229E-01,0.222734E-01,
23479 &0.288923E-04,0.360279E-04,0.290540E-04,0.288923E-04,0.124695E-02/
23480 DATA (DL(K),K= 2976, 3060) /
23481 &0.598767E-05,0.282894E-01,0.189287E-01,0.242960E-04,0.310036E-04,
23482 &0.244423E-04,0.242960E-04,0.104112E-02,0.556344E-05,0.243968E-01,
23483 &0.160504E-01,0.203920E-04,0.266363E-04,0.205232E-04,0.203920E-04,
23484 &0.863677E-03,0.510070E-05,0.209890E-01,0.135797E-01,0.170822E-04,
23485 &0.228449E-04,0.171989E-04,0.170822E-04,0.711641E-03,0.462338E-05,
23486 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23487 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23488 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23489 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23490 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23491 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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.105155E+00,0.752467E-01,0.719932E-04,0.719932E-04,0.719932E-04,
23495 &0.719932E-04,0.328057E-02,-.758942E-18,0.920856E-01,0.645455E-01,
23496 &0.592305E-04,0.615087E-04,0.592802E-04,0.592305E-04,0.295327E-02,
23497 &0.945234E-07,0.804695E-01,0.552770E-01,0.489125E-04,0.528632E-04/
23498 DATA (DL(K),K= 3061, 3145) /
23499 &0.489946E-04,0.489125E-04,0.261804E-02,0.365139E-06,0.701499E-01,
23500 &0.472409E-01,0.404786E-04,0.456186E-04,0.405807E-04,0.404786E-04,
23501 &0.229460E-02,0.686912E-06,0.610049E-01,0.402864E-01,0.335367E-04,
23502 &0.394631E-04,0.336495E-04,0.335367E-04,0.198445E-02,0.981070E-06,
23503 &0.529201E-01,0.342803E-01,0.278134E-04,0.342044E-04,0.279301E-04,
23504 &0.278134E-04,0.169772E-02,0.122521E-05,0.457907E-01,0.291037E-01,
23505 &0.230821E-04,0.296833E-04,0.231978E-04,0.230821E-04,0.144575E-02,
23506 &0.140819E-05,0.395205E-01,0.246522E-01,0.191553E-04,0.257661E-04,
23507 &0.192666E-04,0.191553E-04,0.122125E-02,0.152152E-05,0.340212E-01,
23508 &0.208330E-01,0.158874E-04,0.223546E-04,0.159921E-04,0.158874E-04,
23509 &0.101912E-02,0.156880E-05,0.292116E-01,0.175644E-01,0.131678E-04,
23510 &0.193783E-04,0.132645E-04,0.131678E-04,0.847586E-03,0.156432E-05,
23511 &0.250173E-01,0.147740E-01,0.109029E-04,0.167762E-04,0.109910E-04,
23512 &0.109029E-04,0.705515E-03,0.151845E-05,0.213702E-01,0.123979E-01,
23513 &0.901273E-05,0.144953E-04,0.909200E-05,0.901273E-05,0.581767E-03,
23514 &0.143817E-05,0.182083E-01,0.103797E-01,0.743733E-05,0.124978E-04,
23515 &0.750792E-05,0.743733E-05,0.475483E-03,0.133574E-05,0.154751E-01/
23516 DATA (DL(K),K= 3146, 3230) /
23517 &0.867011E-02,0.612722E-05,0.107517E-04,0.618950E-05,0.612722E-05,
23518 &0.390116E-03,0.122183E-05,0.131193E-01,0.722560E-02,0.503734E-05,
23519 &0.922584E-05,0.509185E-05,0.503734E-05,0.319980E-03,0.110130E-05,
23520 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23521 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23522 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23523 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23524 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23525 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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.754424E-01,0.449848E-01,0.236444E-04,0.236444E-04,0.236444E-04,
23529 &0.236444E-04,0.129291E-02,0.113079E-17,0.650429E-01,0.379660E-01,
23530 &0.187739E-04,0.207130E-04,0.187990E-04,0.187739E-04,0.124038E-02,
23531 &-.327995E-06,0.559588E-01,0.319936E-01,0.149625E-04,0.182671E-04,
23532 &0.150033E-04,0.149625E-04,0.113497E-02,-.464337E-06,0.480234E-01,
23533 &0.269030E-01,0.119484E-04,0.161746E-04,0.119982E-04,0.119484E-04/
23534 DATA (DL(K),K= 3231, 3315) /
23535 &0.100877E-02,-.490618E-06,0.411091E-01,0.225716E-01,0.954833E-05,
23536 &0.143391E-04,0.960250E-05,0.954833E-05,0.883852E-03,-.461770E-06,
23537 &0.350995E-01,0.188947E-01,0.763738E-05,0.127129E-04,0.769248E-05,
23538 &0.763738E-05,0.760077E-03,-.403363E-06,0.298897E-01,0.157798E-01,
23539 &0.611070E-05,0.112548E-04,0.616439E-05,0.611070E-05,0.639505E-03,
23540 &-.335607E-06,0.253856E-01,0.131470E-01,0.488993E-05,0.994021E-05,
23541 &0.494070E-05,0.488993E-05,0.534131E-03,-.267652E-06,0.215026E-01,
23542 &0.109271E-01,0.391276E-05,0.875190E-05,0.395967E-05,0.391276E-05,
23543 &0.445478E-03,-.205292E-06,0.181648E-01,0.906007E-02,0.312720E-05,
23544 &0.767418E-05,0.316978E-05,0.312720E-05,0.366232E-03,-.154024E-06,
23545 &0.153041E-01,0.749382E-02,0.249633E-05,0.670002E-05,0.253440E-05,
23546 &0.249633E-05,0.297435E-03,-.112673E-06,0.128596E-01,0.618334E-02,
23547 &0.199074E-05,0.582360E-05,0.202435E-05,0.199074E-05,0.242305E-03,
23548 &-.794410E-07,0.107770E-01,0.508977E-02,0.158457E-05,0.503733E-05,
23549 &0.161393E-05,0.158457E-05,0.196927E-03,-.546702E-07,0.900806E-02,
23550 &0.417964E-02,0.125888E-05,0.433619E-05,0.128428E-05,0.125888E-05,
23551 &0.158171E-03,-.364714E-07,0.751006E-02,0.342418E-02,0.998674E-06/
23552 DATA (DL(K),K= 3316, 3400) /
23553 &0.371518E-05,0.102046E-05,0.998674E-06,0.126865E-03,-.228706E-07,
23554 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23555 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23556 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23557 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23558 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23559 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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.496787E-01,0.236961E-01,0.607312E-05,0.607312E-05,0.607312E-05,
23563 &0.607312E-05,0.415108E-03,-.140523E-17,0.420445E-01,0.196196E-01,
23564 &0.443589E-05,0.603481E-05,0.444683E-05,0.443589E-05,0.444425E-03,
23565 &-.375397E-06,0.355108E-01,0.162223E-01,0.321766E-05,0.587645E-05,
23566 &0.323504E-05,0.321766E-05,0.432635E-03,-.593989E-06,0.299148E-01,
23567 &0.133836E-01,0.231504E-05,0.562250E-05,0.233581E-05,0.231504E-05,
23568 &0.395801E-03,-.699904E-06,0.251339E-01,0.110157E-01,0.164651E-05,
23569 &0.526880E-05,0.166853E-05,0.164651E-05,0.344925E-03,-.733095E-06/
23570 DATA (DL(K),K= 3401, 3485) /
23571 &0.210605E-01,0.904539E-02,0.115940E-05,0.485739E-05,0.118122E-05,
23572 &0.115940E-05,0.294439E-03,-.715193E-06,0.175989E-01,0.740944E-02,
23573 &0.808365E-06,0.441709E-05,0.829075E-06,0.808365E-06,0.249093E-03,
23574 &-.665420E-06,0.146656E-01,0.605433E-02,0.555563E-06,0.396078E-05,
23575 &0.574607E-06,0.555563E-06,0.205675E-03,-.600648E-06,0.121872E-01,
23576 &0.493466E-02,0.375914E-06,0.350822E-05,0.393011E-06,0.375914E-06,
23577 &0.166757E-03,-.529210E-06,0.100993E-01,0.401191E-02,0.250032E-06,
23578 &0.307359E-05,0.265094E-06,0.250032E-06,0.135196E-03,-.456996E-06,
23579 &0.834582E-02,0.325348E-02,0.162261E-06,0.266488E-05,0.175325E-06,
23580 &0.162261E-06,0.108862E-03,-.388821E-06,0.687767E-02,0.263179E-02,
23581 &0.102273E-06,0.228913E-05,0.113453E-06,0.102273E-06,0.865539E-04,
23582 &-.326325E-06,0.565221E-02,0.212357E-02,0.620694E-07,0.194975E-05,
23583 &0.715290E-07,0.620694E-07,0.687156E-04,-.270547E-06,0.463248E-02,
23584 &0.170926E-02,0.351992E-07,0.164711E-05,0.431226E-07,0.351992E-07,
23585 &0.543744E-04,-.222379E-06,0.378655E-02,0.137242E-02,0.178902E-07,
23586 &0.138124E-05,0.244675E-07,0.178902E-07,0.426626E-04,-.181158E-06,
23587 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23588 DATA (DL(K),K= 3486, 3570) /
23589 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23590 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23591 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23592 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23593 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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.286141E-01,0.102357E-01,0.105702E-05,0.105702E-05,0.105702E-05,
23597 &0.105702E-05,0.963318E-04,0.591070E-18,0.236608E-01,0.827483E-02,
23598 &0.548552E-06,0.163293E-05,0.551993E-06,0.548552E-06,0.133058E-03,
23599 &-.268677E-06,0.195282E-01,0.668247E-02,0.238780E-06,0.183459E-05,
23600 &0.243802E-06,0.238780E-06,0.135119E-03,-.393414E-06,0.160742E-01,
23601 &0.538444E-02,0.599864E-07,0.183277E-05,0.655085E-07,0.599864E-07,
23602 &0.124554E-03,-.428349E-06,0.131940E-01,0.432750E-02,-.392825E-07,
23603 &0.172071E-05,-.338391E-07,-.392825E-07,0.111121E-03,-.415550E-06,
23604 &0.107996E-01,0.346954E-02,-.875089E-07,0.154604E-05,-.824926E-07,
23605 &-.875089E-07,0.941854E-04,-.376855E-06,0.881435E-02,0.277463E-02/
23606 DATA (DL(K),K= 3571, 3655) /
23607 &-.103962E-06,0.135013E-05,-.995446E-07,-.103962E-06,0.772195E-04,
23608 &-.326008E-06,0.717317E-02,0.221313E-02,-.102844E-06,0.115335E-05,
23609 &-.990733E-07,-.102844E-06,0.626565E-04,-.272858E-06,0.582050E-02,
23610 &0.176061E-02,-.929503E-07,0.967229E-06,-.898064E-07,-.929503E-07,
23611 &0.499930E-04,-.222828E-06,0.470908E-02,0.139692E-02,-.791495E-07,
23612 &0.800414E-06,-.765797E-07,-.791495E-07,0.394181E-04,-.178141E-06,
23613 &0.379875E-02,0.110542E-02,-.647230E-07,0.655119E-06,-.626567E-07,
23614 &-.647230E-07,0.309999E-04,-.140000E-06,0.305549E-02,0.872447E-03,
23615 &-.515215E-07,0.530834E-06,-.498829E-07,-.515215E-07,0.240354E-04,
23616 &-.108633E-06,0.245058E-02,0.686769E-03,-.400234E-07,0.426835E-06,
23617 &-.387401E-07,-.400234E-07,0.184613E-04,-.832544E-07,0.195984E-02,
23618 &0.539209E-03,-.304312E-07,0.341169E-06,-.294373E-07,-.304312E-07,
23619 &0.143512E-04,-.630818E-07,0.156297E-02,0.422273E-03,-.228633E-07,
23620 &0.271199E-06,-.221014E-07,-.228633E-07,0.110898E-04,-.474683E-07,
23621 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23622 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23623 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23624 DATA (DL(K),K= 3656, 3740) /
23625 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23626 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23627 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23628 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23629 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23630 &0.129345E-01,0.308444E-02,0.903693E-07,0.903693E-07,0.903693E-07,
23631 &0.903693E-07,0.123538E-04,-.166230E-18,0.103598E-01,0.241354E-02,
23632 &0.155648E-06,-.205296E-06,0.154889E-06,0.155648E-06,0.267249E-04,
23633 &0.880707E-07,0.828507E-02,0.188764E-02,0.176333E-06,-.341498E-06,
23634 &0.175220E-06,0.176333E-06,0.306432E-04,0.125718E-06,0.660736E-02,
23635 &0.147304E-02,0.173444E-06,-.383695E-06,0.172215E-06,0.173444E-06,
23636 &0.280787E-04,0.135578E-06,0.525320E-02,0.114618E-02,0.158651E-06,
23637 &-.373371E-06,0.157437E-06,0.158651E-06,0.243526E-04,0.130412E-06,
23638 &0.416429E-02,0.889584E-03,0.137131E-06,-.333468E-06,0.136012E-06,
23639 &0.137131E-06,0.203463E-04,0.116115E-06,0.329102E-02,0.688580E-03,
23640 &0.113839E-06,-.280874E-06,0.112853E-06,0.113839E-06,0.161038E-04,
23641 &0.982305E-07,0.259282E-02,0.531508E-03,0.914374E-07,-.225427E-06/
23642 DATA (DL(K),K= 3741, 3825) /
23643 &0.905971E-07,0.914374E-07,0.125639E-04,0.798741E-07,0.203641E-02,
23644 &0.409120E-03,0.709595E-07,-.173123E-06,0.702607E-07,0.709595E-07,
23645 &0.979247E-05,0.624138E-07,0.159441E-02,0.314027E-03,0.532256E-07,
23646 &-.127272E-06,0.526566E-07,0.532256E-07,0.741899E-05,0.469253E-07,
23647 &0.124447E-02,0.240357E-03,0.385509E-07,-.888851E-07,0.380956E-07,
23648 &0.385509E-07,0.554070E-05,0.339174E-07,0.968328E-03,0.183454E-03,
23649 &0.267272E-07,-.580277E-07,0.263687E-07,0.267272E-07,0.420032E-05,
23650 &0.233280E-07,0.751159E-03,0.139632E-03,0.174605E-07,-.342016E-07,
23651 &0.171822E-07,0.174605E-07,0.315522E-05,0.149727E-07,0.580936E-03,
23652 &0.105986E-03,0.104515E-07,-.164567E-07,0.102383E-07,0.104515E-07,
23653 &0.230829E-05,0.863527E-08,0.447955E-03,0.802293E-04,0.531954E-08,
23654 &-.376312E-08,0.515829E-08,0.531954E-08,0.170771E-05,0.399662E-08,
23655 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23656 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23657 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23658 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23659 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23660 DATA (DL(K),K= 3826, 3910) /
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 &0.324478E-02,0.386879E-03,0.135983E-08,0.135983E-08,0.135983E-08,
23665 &0.135983E-08,0.371787E-06,-.274599E-19,0.246219E-02,0.286505E-03,
23666 &-.106852E-06,0.327611E-06,-.106589E-06,-.106852E-06,0.231631E-05,
23667 &-.107814E-06,0.186777E-02,0.212413E-03,-.161566E-06,0.492001E-06,
23668 &-.161179E-06,-.161566E-06,0.311589E-05,-.162249E-06,0.141322E-02,
23669 &0.157212E-03,-.183398E-06,0.557106E-06,-.182972E-06,-.183398E-06,
23670 &0.267943E-05,-.183884E-06,0.106518E-02,0.115892E-03,-.185231E-06,
23671 &0.562185E-06,-.184809E-06,-.185231E-06,0.203027E-05,-.185573E-06,
23672 &0.800350E-03,0.851995E-04,-.174680E-06,0.530096E-06,-.174290E-06,
23673 &-.174680E-06,0.165870E-05,-.174922E-06,0.599444E-03,0.624676E-04,
23674 &-.157644E-06,0.478420E-06,-.157300E-06,-.157644E-06,0.130112E-05,
23675 &-.157815E-06,0.447433E-03,0.456556E-04,-.137838E-06,0.418429E-06,
23676 &-.137543E-06,-.137838E-06,0.903220E-06,-.137958E-06,0.332836E-03,
23677 &0.332643E-04,-.117616E-06,0.357179E-06,-.117368E-06,-.117616E-06/
23678 DATA (DL(K),K= 3911, 3995) /
23679 &0.636187E-06,-.117699E-06,0.246754E-03,0.241622E-04,-.984560E-07,
23680 &0.299077E-06,-.982529E-07,-.984560E-07,0.481221E-06,-.985144E-07,
23681 &0.182315E-03,0.174961E-04,-.811089E-07,0.246465E-06,-.809446E-07,
23682 &-.811089E-07,0.342859E-06,-.811495E-07,0.134250E-03,0.126299E-04,
23683 &-.659052E-07,0.200354E-06,-.657742E-07,-.659052E-07,0.227840E-06,
23684 &-.659334E-07,0.985288E-04,0.908931E-05,-.529252E-07,0.160947E-06,
23685 &-.528218E-07,-.529252E-07,0.161641E-06,-.529447E-07,0.720750E-04,
23686 &0.652153E-05,-.420621E-07,0.127943E-06,-.419814E-07,-.420621E-07,
23687 &0.119540E-06,-.420756E-07,0.525538E-04,0.466527E-05,-.331141E-07,
23688 &0.100758E-06,-.330516E-07,-.331141E-07,0.808991E-07,-.331233E-07,
23689 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23690 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23691 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23692 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23693 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23694 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23695 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23696 DATA (DL(K),K= 3996, 4000) /
23697 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23698C
23699 ANS = 0.
23700 IF (X.GT.0.9985) RETURN
23701 IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
23702C
23703 IS = S/DELTA+1
23704 IS1 = IS+1
23705 DO 1 L=1,25
23706 KL = L+NDRV*25
23707 F1(L) = GF(I,IS,KL)
23708 F2(L) = GF(I,IS1,KL)
23709 1 CONTINUE
23710 A1 = DT_CKMTFF(X,F1)
23711 A2 = DT_CKMTFF(X,F2)
23712C A1=ALOG(A1)
23713C A2=ALOG(A2)
23714 S1 = (IS-1)*DELTA
23715 S2 = S1+DELTA
23716 ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
23717C ANS=EXP(ANS)
23718 RETURN
23719 END
23720C
23721C
23722
23723*$ CREATE DT_CKMTPR.FOR
23724*COPY DT_CKMTPR
23725 SUBROUTINE DT_CKMTPR(I,NDRV,X,S,ANS)
23726C
23727C**********************************************************************
23728C Proton - PDFs
23729C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
23730C ANS = PDF(I)
23731C This version by S. Roesler, 31.01.96
23732C**********************************************************************
23733
23734 SAVE
23735 DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
23736 EQUIVALENCE (GF(1,1,1),DL(1))
23737 DATA DELTA/.10/
23738C
23739 DATA (DL(K),K= 1, 85) /
23740 &0.367759E+00,0.350609E+00,0.325356E+00,0.325356E+00,0.325356E+00,
23741 &0.325356E+00,0.533117E+01,0.138778E-16,0.427988E+00,0.409718E+00,
23742 &0.382948E+00,0.382920E+00,0.382933E+00,0.382948E+00,0.686279E+01,
23743 &0.611113E-01,0.494752E+00,0.475328E+00,0.447011E+00,0.446959E+00,
23744 &0.446984E+00,0.447011E+00,0.855688E+01,0.128659E+00,0.568248E+00,
23745 &0.547637E+00,0.517743E+00,0.517671E+00,0.517705E+00,0.517743E+00,
23746 &0.104074E+02,0.202846E+00,0.648622E+00,0.626792E+00,0.595289E+00,
23747 &0.595201E+00,0.595244E+00,0.595289E+00,0.124065E+02,0.283819E+00,
23748 &0.735974E+00,0.712890E+00,0.679748E+00,0.679648E+00,0.679696E+00,
23749 &0.679748E+00,0.145441E+02,0.371679E+00,0.830359E+00,0.805987E+00,
23750 &0.771173E+00,0.771066E+00,0.771119E+00,0.771173E+00,0.168081E+02,
23751 &0.466485E+00,0.931778E+00,0.906084E+00,0.869566E+00,0.869456E+00,
23752 &0.869511E+00,0.869566E+00,0.191850E+02,0.568240E+00,0.104018E+01,
23753 &0.101313E+01,0.974873E+00,0.974763E+00,0.974819E+00,0.974873E+00,
23754 &0.216593E+02,0.676890E+00,0.115544E+01,0.112700E+01,0.108698E+01,
23755 &0.108687E+01,0.108693E+01,0.108698E+01,0.242146E+02,0.792321E+00,
23756 &0.127738E+01,0.124751E+01,0.120570E+01,0.120560E+01,0.120565E+01/
23757 DATA (DL(K),K= 86, 170) /
23758 &0.120570E+01,0.268333E+02,0.914356E+00,0.140577E+01,0.137444E+01,
23759 &0.133079E+01,0.133070E+01,0.133075E+01,0.133079E+01,0.294970E+02,
23760 &0.104275E+01,0.154028E+01,0.150745E+01,0.146194E+01,0.146187E+01,
23761 &0.146192E+01,0.146194E+01,0.321867E+02,0.117720E+01,0.168054E+01,
23762 &0.164619E+01,0.159879E+01,0.159874E+01,0.159877E+01,0.159879E+01,
23763 &0.348836E+02,0.131732E+01,0.182613E+01,0.179020E+01,0.174088E+01,
23764 &0.174086E+01,0.174088E+01,0.174088E+01,0.375685E+02,0.146269E+01,
23765 &0.197653E+01,0.193901E+01,0.188774E+01,0.188774E+01,0.188775E+01,
23766 &0.188774E+01,0.402228E+02,0.161282E+01,0.213121E+01,0.209205E+01,
23767 &0.203880E+01,0.203884E+01,0.203884E+01,0.203880E+01,0.428285E+02,
23768 &0.176714E+01,0.228955E+01,0.224873E+01,0.219348E+01,0.219355E+01,
23769 &0.219353E+01,0.219348E+01,0.453682E+02,0.192507E+01,0.245093E+01,
23770 &0.240840E+01,0.235113E+01,0.235123E+01,0.235120E+01,0.235113E+01,
23771 &0.478258E+02,0.208597E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23772 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23773 &0.349839E+00,0.324128E+00,0.286363E+00,0.286363E+00,0.286363E+00,
23774 &0.286363E+00,0.469694E+01,0.000000E+00,0.398361E+00,0.371065E+00/
23775 DATA (DL(K),K= 171, 255) /
23776 &0.331239E+00,0.331213E+00,0.331227E+00,0.331239E+00,0.586152E+01,
23777 &0.481683E-01,0.451010E+00,0.422096E+00,0.380182E+00,0.380137E+00,
23778 &0.380161E+00,0.380182E+00,0.711349E+01,0.100378E+00,0.507782E+00,
23779 &0.477215E+00,0.433187E+00,0.433128E+00,0.433160E+00,0.433187E+00,
23780 &0.844371E+01,0.156627E+00,0.568644E+00,0.536390E+00,0.490220E+00,
23781 &0.490152E+00,0.490190E+00,0.490220E+00,0.984291E+01,0.216886E+00,
23782 &0.633517E+00,0.599543E+00,0.551204E+00,0.551133E+00,0.551174E+00,
23783 &0.551204E+00,0.113005E+02,0.281079E+00,0.702295E+00,0.666565E+00,
23784 &0.616031E+00,0.615963E+00,0.616004E+00,0.616031E+00,0.128050E+02,
23785 &0.349101E+00,0.774832E+00,0.737311E+00,0.684556E+00,0.684495E+00,
23786 &0.684535E+00,0.684556E+00,0.143447E+02,0.420809E+00,0.850945E+00,
23787 &0.811598E+00,0.756596E+00,0.756547E+00,0.756583E+00,0.756596E+00,
23788 &0.159073E+02,0.496022E+00,0.930413E+00,0.889207E+00,0.831933E+00,
23789 &0.831901E+00,0.831931E+00,0.831933E+00,0.174801E+02,0.574524E+00,
23790 &0.101298E+01,0.969882E+00,0.910312E+00,0.910301E+00,0.910324E+00,
23791 &0.910312E+00,0.190508E+02,0.656061E+00,0.109836E+01,0.105333E+01,
23792 &0.991445E+00,0.991459E+00,0.991471E+00,0.991445E+00,0.206070E+02/
23793 DATA (DL(K),K= 256, 340) /
23794 &0.740345E+00,0.118622E+01,0.113923E+01,0.107501E+01,0.107505E+01,
23795 &0.107505E+01,0.107501E+01,0.221368E+02,0.827056E+00,0.127622E+01,
23796 &0.122724E+01,0.116065E+01,0.116073E+01,0.116072E+01,0.116065E+01,
23797 &0.236287E+02,0.915845E+00,0.136797E+01,0.131696E+01,0.124800E+01,
23798 &0.124812E+01,0.124809E+01,0.124800E+01,0.250721E+02,0.100634E+01,
23799 &0.146107E+01,0.140801E+01,0.133666E+01,0.133681E+01,0.133677E+01,
23800 &0.133666E+01,0.264571E+02,0.109813E+01,0.155511E+01,0.149996E+01,
23801 &0.142621E+01,0.142641E+01,0.142634E+01,0.142621E+01,0.277747E+02,
23802 &0.119081E+01,0.164964E+01,0.159239E+01,0.151622E+01,0.151646E+01,
23803 &0.151638E+01,0.151622E+01,0.290168E+02,0.128396E+01,0.174424E+01,
23804 &0.168485E+01,0.160626E+01,0.160655E+01,0.160645E+01,0.160626E+01,
23805 &0.301765E+02,0.137713E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23806 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23807 &0.345345E+00,0.306823E+00,0.250518E+00,0.250518E+00,0.250518E+00,
23808 &0.250518E+00,0.411726E+01,-.138778E-16,0.384210E+00,0.343514E+00,
23809 &0.284500E+00,0.284487E+00,0.284496E+00,0.284500E+00,0.496835E+01,
23810 &0.371582E-01,0.425419E+00,0.382518E+00,0.320782E+00,0.320762E+00/
23811 DATA (DL(K),K= 341, 425) /
23812 &0.320777E+00,0.320782E+00,0.585504E+01,0.765988E-01,0.468853E+00,
23813 &0.423717E+00,0.359246E+00,0.359226E+00,0.359243E+00,0.359246E+00,
23814 &0.676824E+01,0.118207E+00,0.514392E+00,0.466990E+00,0.399771E+00,
23815 &0.399758E+00,0.399775E+00,0.399771E+00,0.769967E+01,0.161865E+00,
23816 &0.561883E+00,0.512186E+00,0.442209E+00,0.442208E+00,0.442222E+00,
23817 &0.442209E+00,0.864071E+01,0.207426E+00,0.611162E+00,0.559140E+00,
23818 &0.486395E+00,0.486411E+00,0.486420E+00,0.486395E+00,0.958280E+01,
23819 &0.254727E+00,0.662044E+00,0.607667E+00,0.532145E+00,0.532185E+00,
23820 &0.532185E+00,0.532145E+00,0.105176E+02,0.303587E+00,0.714325E+00,
23821 &0.657566E+00,0.579261E+00,0.579328E+00,0.579318E+00,0.579261E+00,
23822 &0.114370E+02,0.353808E+00,0.767786E+00,0.708618E+00,0.627526E+00,
23823 &0.627625E+00,0.627603E+00,0.627526E+00,0.123333E+02,0.405174E+00,
23824 &0.822195E+00,0.760591E+00,0.676711E+00,0.676846E+00,0.676810E+00,
23825 &0.676711E+00,0.131994E+02,0.457458E+00,0.877307E+00,0.813242E+00,
23826 &0.726575E+00,0.726750E+00,0.726697E+00,0.726575E+00,0.140286E+02,
23827 &0.510420E+00,0.932865E+00,0.866317E+00,0.776867E+00,0.777085E+00,
23828 &0.777015E+00,0.776867E+00,0.148150E+02,0.563809E+00,0.988608E+00/
23829 DATA (DL(K),K= 426, 510) /
23830 &0.919556E+00,0.827330E+00,0.827594E+00,0.827505E+00,0.827330E+00,
23831 &0.155533E+02,0.617368E+00,0.104427E+01,0.972694E+00,0.877703E+00,
23832 &0.878016E+00,0.877907E+00,0.877703E+00,0.162391E+02,0.670837E+00,
23833 &0.109958E+01,0.102547E+01,0.927723E+00,0.928088E+00,0.927957E+00,
23834 &0.927723E+00,0.168687E+02,0.723954E+00,0.115428E+01,0.107761E+01,
23835 &0.977132E+00,0.977550E+00,0.977397E+00,0.977132E+00,0.174391E+02,
23836 &0.776458E+00,0.120809E+01,0.112886E+01,0.102567E+01,0.102615E+01,
23837 &0.102597E+01,0.102567E+01,0.179481E+02,0.828097E+00,0.126078E+01,
23838 &0.117898E+01,0.107310E+01,0.107363E+01,0.107343E+01,0.107310E+01,
23839 &0.183942E+02,0.878621E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23840 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23841 &0.357586E+00,0.299938E+00,0.216504E+00,0.216504E+00,0.216504E+00,
23842 &0.216504E+00,0.357260E+01,-.277556E-16,0.388529E+00,0.327984E+00,
23843 &0.241161E+00,0.241168E+00,0.241168E+00,0.241161E+00,0.415893E+01,
23844 &0.278429E-01,0.420472E+00,0.357015E+00,0.266823E+00,0.266844E+00,
23845 &0.266842E+00,0.266823E+00,0.474689E+01,0.566783E-01,0.453271E+00,
23846 &0.386886E+00,0.293349E+00,0.293389E+00,0.293381E+00,0.293349E+00/
23847 DATA (DL(K),K= 511, 595) /
23848 &0.532982E+01,0.863668E-01,0.486793E+00,0.417464E+00,0.320608E+00,
23849 &0.320673E+00,0.320657E+00,0.320608E+00,0.590219E+01,0.116779E+00,
23850 &0.520887E+00,0.448601E+00,0.348454E+00,0.348549E+00,0.348523E+00,
23851 &0.348454E+00,0.645868E+01,0.147773E+00,0.555403E+00,0.480149E+00,
23852 &0.376740E+00,0.376870E+00,0.376831E+00,0.376740E+00,0.699440E+01,
23853 &0.179201E+00,0.590183E+00,0.511950E+00,0.405314E+00,0.405482E+00,
23854 &0.405429E+00,0.405314E+00,0.750493E+01,0.210912E+00,0.625064E+00,
23855 &0.543845E+00,0.434019E+00,0.434229E+00,0.434159E+00,0.434019E+00,
23856 &0.798636E+01,0.242750E+00,0.659882E+00,0.575673E+00,0.462696E+00,
23857 &0.462952E+00,0.462864E+00,0.462696E+00,0.843528E+01,0.274558E+00,
23858 &0.694472E+00,0.607271E+00,0.491188E+00,0.491492E+00,0.491385E+00,
23859 &0.491188E+00,0.884885E+01,0.306178E+00,0.728669E+00,0.638478E+00,
23860 &0.519337E+00,0.519690E+00,0.519563E+00,0.519337E+00,0.922480E+01,
23861 &0.337451E+00,0.762311E+00,0.669133E+00,0.546987E+00,0.547392E+00,
23862 &0.547244E+00,0.546987E+00,0.956139E+01,0.368224E+00,0.795240E+00,
23863 &0.699084E+00,0.573988E+00,0.574447E+00,0.574277E+00,0.573988E+00,
23864 &0.985744E+01,0.398346E+00,0.827302E+00,0.728181E+00,0.600196E+00/
23865 DATA (DL(K),K= 596, 680) /
23866 &0.600710E+00,0.600518E+00,0.600196E+00,0.101123E+02,0.427671E+00,
23867 &0.858354E+00,0.756282E+00,0.625475E+00,0.626044E+00,0.625829E+00,
23868 &0.625475E+00,0.103258E+02,0.456064E+00,0.888257E+00,0.783256E+00,
23869 &0.649696E+00,0.650321E+00,0.650083E+00,0.649696E+00,0.104982E+02,
23870 &0.483395E+00,0.916887E+00,0.808981E+00,0.672742E+00,0.673422E+00,
23871 &0.673161E+00,0.672742E+00,0.106303E+02,0.509546E+00,0.944126E+00,
23872 &0.833345E+00,0.694506E+00,0.695243E+00,0.694958E+00,0.694506E+00,
23873 &0.107231E+02,0.534410E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23874 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23875 &0.390721E+00,0.304671E+00,0.182562E+00,0.182562E+00,0.182562E+00,
23876 &0.182562E+00,0.303699E+01,0.693889E-17,0.414806E+00,0.325059E+00,
23877 &0.199103E+00,0.199133E+00,0.199124E+00,0.199103E+00,0.339971E+01,
23878 &0.198528E-01,0.438929E+00,0.345508E+00,0.215797E+00,0.215862E+00,
23879 &0.215842E+00,0.215797E+00,0.374624E+01,0.398420E-01,0.462973E+00,
23880 &0.365903E+00,0.232531E+00,0.232635E+00,0.232601E+00,0.232531E+00,
23881 &0.407322E+01,0.598565E-01,0.486835E+00,0.386142E+00,0.249208E+00,
23882 &0.249352E+00,0.249304E+00,0.249208E+00,0.437817E+01,0.797987E-01/
23883 DATA (DL(K),K= 681, 765) /
23884 &0.510407E+00,0.406123E+00,0.265725E+00,0.265913E+00,0.265849E+00,
23885 &0.265725E+00,0.465901E+01,0.995694E-01,0.533588E+00,0.425746E+00,
23886 &0.281986E+00,0.282220E+00,0.282139E+00,0.281986E+00,0.491410E+01,
23887 &0.119072E+00,0.556274E+00,0.444912E+00,0.297897E+00,0.298178E+00,
23888 &0.298079E+00,0.297897E+00,0.514220E+01,0.138212E+00,0.578369E+00,
23889 &0.463528E+00,0.313366E+00,0.313696E+00,0.313578E+00,0.313366E+00,
23890 &0.534249E+01,0.156900E+00,0.599777E+00,0.481503E+00,0.328308E+00,
23891 &0.328688E+00,0.328549E+00,0.328308E+00,0.551456E+01,0.175048E+00,
23892 &0.620409E+00,0.498752E+00,0.342642E+00,0.343071E+00,0.342913E+00,
23893 &0.342642E+00,0.565833E+01,0.192575E+00,0.640181E+00,0.515196E+00,
23894 &0.356292E+00,0.356770E+00,0.356592E+00,0.356292E+00,0.577410E+01,
23895 &0.209407E+00,0.659017E+00,0.530764E+00,0.369190E+00,0.369718E+00,
23896 &0.369519E+00,0.369190E+00,0.586243E+01,0.225474E+00,0.676845E+00,
23897 &0.545389E+00,0.381275E+00,0.381852E+00,0.381633E+00,0.381275E+00,
23898 &0.592421E+01,0.240714E+00,0.693604E+00,0.559015E+00,0.392493E+00,
23899 &0.393118E+00,0.392880E+00,0.392493E+00,0.596052E+01,0.255072E+00,
23900 &0.709239E+00,0.571593E+00,0.402799E+00,0.403472E+00,0.403213E+00/
23901 DATA (DL(K),K= 766, 850) /
23902 &0.402799E+00,0.597267E+01,0.268502E+00,0.723703E+00,0.583081E+00,
23903 &0.412157E+00,0.412875E+00,0.412597E+00,0.412157E+00,0.596211E+01,
23904 &0.280966E+00,0.736960E+00,0.593447E+00,0.420536E+00,0.421299E+00,
23905 &0.421002E+00,0.420536E+00,0.593045E+01,0.292434E+00,0.748980E+00,
23906 &0.602669E+00,0.427918E+00,0.428723E+00,0.428408E+00,0.427918E+00,
23907 &0.587934E+01,0.302884E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23908 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23909 &0.448390E+00,0.320678E+00,0.146415E+00,0.146415E+00,0.146415E+00,
23910 &0.146415E+00,0.247594E+01,0.000000E+00,0.465760E+00,0.333734E+00,
23911 &0.155974E+00,0.156013E+00,0.156000E+00,0.155974E+00,0.265633E+01,
23912 &0.130329E-01,0.482525E+00,0.346293E+00,0.165233E+00,0.165311E+00,
23913 &0.165285E+00,0.165233E+00,0.281612E+01,0.257304E-01,0.498626E+00,
23914 &0.358294E+00,0.174131E+00,0.174249E+00,0.174209E+00,0.174131E+00,
23915 &0.295484E+01,0.380345E-01,0.514008E+00,0.369688E+00,0.182622E+00,
23916 &0.182779E+00,0.182724E+00,0.182622E+00,0.307242E+01,0.498976E-01,
23917 &0.528624E+00,0.380432E+00,0.190660E+00,0.190856E+00,0.190786E+00,
23918 &0.190660E+00,0.316911E+01,0.612760E-01,0.542428E+00,0.390485E+00/
23919 DATA (DL(K),K= 851, 935) /
23920 &0.198205E+00,0.198441E+00,0.198356E+00,0.198205E+00,0.324538E+01,
23921 &0.721303E-01,0.555382E+00,0.399810E+00,0.205224E+00,0.205498E+00,
23922 &0.205398E+00,0.205224E+00,0.330192E+01,0.824256E-01,0.567448E+00,
23923 &0.408377E+00,0.211687E+00,0.211997E+00,0.211882E+00,0.211687E+00,
23924 &0.333960E+01,0.921319E-01,0.578597E+00,0.416159E+00,0.217568E+00,
23925 &0.217915E+00,0.217784E+00,0.217568E+00,0.335945E+01,0.101224E+00,
23926 &0.588802E+00,0.423136E+00,0.222847E+00,0.223229E+00,0.223084E+00,
23927 &0.222847E+00,0.336262E+01,0.109681E+00,0.598043E+00,0.429293E+00,
23928 &0.227512E+00,0.227928E+00,0.227768E+00,0.227512E+00,0.335036E+01,
23929 &0.117489E+00,0.606305E+00,0.434619E+00,0.231551E+00,0.232000E+00,
23930 &0.231826E+00,0.231551E+00,0.332398E+01,0.124636E+00,0.613579E+00,
23931 &0.439110E+00,0.234962E+00,0.235442E+00,0.235254E+00,0.234962E+00,
23932 &0.328483E+01,0.131119E+00,0.619860E+00,0.442766E+00,0.237745E+00,
23933 &0.238254E+00,0.238053E+00,0.237745E+00,0.323429E+01,0.136936E+00,
23934 &0.625150E+00,0.445594E+00,0.239905E+00,0.240441E+00,0.240228E+00,
23935 &0.239905E+00,0.317371E+01,0.142091E+00,0.629453E+00,0.447603E+00,
23936 &0.241452E+00,0.242014E+00,0.241788E+00,0.241452E+00,0.310443E+01/
23937 DATA (DL(K),K= 936, 1020) /
23938 &0.146594E+00,0.632782E+00,0.448808E+00,0.242400E+00,0.242987E+00,
23939 &0.242749E+00,0.242400E+00,0.302775E+01,0.150456E+00,0.635151E+00,
23940 &0.449228E+00,0.242767E+00,0.243376E+00,0.243127E+00,0.242767E+00,
23941 &0.294491E+01,0.153694E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23942 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23943 &0.528765E+00,0.341825E+00,0.105823E+00,0.105823E+00,0.105823E+00,
23944 &0.105823E+00,0.185069E+01,-.138778E-16,0.538124E+00,0.347118E+00,
23945 &0.109762E+00,0.109780E+00,0.109774E+00,0.109762E+00,0.189644E+01,
23946 &0.738880E-02,0.546541E+00,0.351712E+00,0.113300E+00,0.113336E+00,
23947 &0.113324E+00,0.113300E+00,0.192700E+01,0.143076E-01,0.554014E+00,
23948 &0.355607E+00,0.116431E+00,0.116485E+00,0.116466E+00,0.116431E+00,
23949 &0.194356E+01,0.207515E-01,0.560546E+00,0.358805E+00,0.119150E+00,
23950 &0.119222E+00,0.119196E+00,0.119150E+00,0.194722E+01,0.267179E-01,
23951 &0.566139E+00,0.361311E+00,0.121459E+00,0.121549E+00,0.121515E+00,
23952 &0.121459E+00,0.193921E+01,0.322084E-01,0.570802E+00,0.363134E+00,
23953 &0.123359E+00,0.123467E+00,0.123426E+00,0.123359E+00,0.192071E+01,
23954 &0.372262E-01,0.574542E+00,0.364286E+00,0.124858E+00,0.124983E+00/
23955 DATA (DL(K),K= 1021, 1105) /
23956 &0.124933E+00,0.124858E+00,0.189295E+01,0.417774E-01,0.577372E+00,
23957 &0.364779E+00,0.125961E+00,0.126103E+00,0.126046E+00,0.125961E+00,
23958 &0.185710E+01,0.458703E-01,0.579307E+00,0.364629E+00,0.126681E+00,
23959 &0.126839E+00,0.126774E+00,0.126681E+00,0.181432E+01,0.495154E-01,
23960 &0.580363E+00,0.363857E+00,0.127029E+00,0.127202E+00,0.127130E+00,
23961 &0.127029E+00,0.176571E+01,0.527252E-01,0.580561E+00,0.362483E+00,
23962 &0.127020E+00,0.127208E+00,0.127128E+00,0.127020E+00,0.171231E+01,
23963 &0.555142E-01,0.579923E+00,0.360529E+00,0.126670E+00,0.126872E+00,
23964 &0.126785E+00,0.126670E+00,0.165511E+01,0.578985E-01,0.578474E+00,
23965 &0.358021E+00,0.125998E+00,0.126213E+00,0.126119E+00,0.125998E+00,
23966 &0.159501E+01,0.598958E-01,0.576241E+00,0.354987E+00,0.125022E+00,
23967 &0.125249E+00,0.125148E+00,0.125022E+00,0.153284E+01,0.615248E-01,
23968 &0.573252E+00,0.351453E+00,0.123762E+00,0.124000E+00,0.123893E+00,
23969 &0.123762E+00,0.146934E+01,0.628056E-01,0.569539E+00,0.347450E+00,
23970 &0.122240E+00,0.122488E+00,0.122375E+00,0.122240E+00,0.140517E+01,
23971 &0.637587E-01,0.565134E+00,0.343008E+00,0.120476E+00,0.120733E+00,
23972 &0.120615E+00,0.120476E+00,0.134093E+01,0.644054E-01,0.560071E+00/
23973 DATA (DL(K),K= 1106, 1190) /
23974 &0.338158E+00,0.118493E+00,0.118758E+00,0.118635E+00,0.118493E+00,
23975 &0.127712E+01,0.647671E-01,0.000000E+00,0.000000E+00,0.000000E+00,
23976 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23977 &0.584093E+00,0.349173E+00,0.772117E-01,0.772117E-01,0.772117E-01,
23978 &0.772117E-01,0.140433E+01,0.346945E-17,0.586736E+00,0.349017E+00,
23979 &0.785355E-01,0.785519E-01,0.785448E-01,0.785355E-01,0.139434E+01,
23980 &0.447504E-02,0.588402E+00,0.348237E+00,0.795437E-01,0.795759E-01,
23981 &0.795617E-01,0.795437E-01,0.137550E+01,0.854114E-02,0.589124E+00,
23982 &0.346861E+00,0.802498E-01,0.802970E-01,0.802758E-01,0.802498E-01,
23983 &0.134918E+01,0.122148E-01,0.588930E+00,0.344912E+00,0.806656E-01,
23984 &0.807271E-01,0.806990E-01,0.806656E-01,0.131652E+01,0.155101E-01,
23985 &0.587849E+00,0.342417E+00,0.808055E-01,0.808805E-01,0.808457E-01,
23986 &0.808055E-01,0.127862E+01,0.184435E-01,0.585912E+00,0.339402E+00,
23987 &0.806843E-01,0.807718E-01,0.807306E-01,0.806843E-01,0.123648E+01,
23988 &0.210315E-01,0.583151E+00,0.335894E+00,0.803173E-01,0.804166E-01,
23989 &0.803692E-01,0.803173E-01,0.119104E+01,0.232909E-01,0.579599E+00,
23990 &0.331923E+00,0.797205E-01,0.798308E-01,0.797775E-01,0.797205E-01/
23991 DATA (DL(K),K= 1191, 1275) /
23992 &0.114317E+01,0.252394E-01,0.575288E+00,0.327516E+00,0.789107E-01,
23993 &0.790310E-01,0.789721E-01,0.789107E-01,0.109362E+01,0.268946E-01,
23994 &0.570253E+00,0.322704E+00,0.779045E-01,0.780341E-01,0.779698E-01,
23995 &0.779045E-01,0.104307E+01,0.282745E-01,0.564530E+00,0.317515E+00,
23996 &0.767190E-01,0.768570E-01,0.767878E-01,0.767190E-01,0.992143E+00,
23997 &0.293974E-01,0.558155E+00,0.311981E+00,0.753713E-01,0.755169E-01,
23998 &0.754432E-01,0.753713E-01,0.941341E+00,0.302812E-01,0.551166E+00,
23999 &0.306131E+00,0.738784E-01,0.740308E-01,0.739528E-01,0.738784E-01,
24000 &0.891113E+00,0.309441E-01,0.543599E+00,0.299995E+00,0.722571E-01,
24001 &0.724154E-01,0.723336E-01,0.722571E-01,0.841829E+00,0.314037E-01,
24002 &0.535494E+00,0.293603E+00,0.705237E-01,0.706871E-01,0.706019E-01,
24003 &0.705237E-01,0.793794E+00,0.316774E-01,0.526888E+00,0.286986E+00,
24004 &0.686941E-01,0.688619E-01,0.687736E-01,0.686941E-01,0.747249E+00,
24005 &0.317823E-01,0.517822E+00,0.280172E+00,0.667836E-01,0.669551E-01,
24006 &0.668640E-01,0.667836E-01,0.702381E+00,0.317346E-01,0.508333E+00,
24007 &0.273189E+00,0.648068E-01,0.649814E-01,0.648879E-01,0.648068E-01,
24008 &0.659330E+00,0.315501E-01,0.000000E+00,0.000000E+00,0.000000E+00/
24009 DATA (DL(K),K= 1276, 1360) /
24010 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24011 &0.622739E+00,0.340676E+00,0.509141E-01,0.509141E-01,0.509141E-01,
24012 &0.509141E-01,0.980502E+00,-.173472E-17,0.617764E+00,0.335457E+00,
24013 &0.507607E-01,0.507701E-01,0.507651E-01,0.507607E-01,0.944375E+00,
24014 &0.242386E-02,0.611957E+00,0.329837E+00,0.504236E-01,0.504417E-01,
24015 &0.504321E-01,0.504236E-01,0.905225E+00,0.455851E-02,0.605372E+00,
24016 &0.323853E+00,0.499207E-01,0.499471E-01,0.499328E-01,0.499207E-01,
24017 &0.864035E+00,0.642656E-02,0.598052E+00,0.317537E+00,0.492668E-01,
24018 &0.493008E-01,0.492822E-01,0.492668E-01,0.821557E+00,0.804638E-02,
24019 &0.590044E+00,0.310919E+00,0.484772E-01,0.485183E-01,0.484955E-01,
24020 &0.484772E-01,0.778444E+00,0.943663E-02,0.581391E+00,0.304033E+00,
24021 &0.475665E-01,0.476142E-01,0.475874E-01,0.475665E-01,0.735263E+00,
24022 &0.106150E-01,0.572137E+00,0.296908E+00,0.465487E-01,0.466024E-01,
24023 &0.465720E-01,0.465487E-01,0.692487E+00,0.115984E-01,0.562326E+00,
24024 &0.289573E+00,0.454376E-01,0.454968E-01,0.454629E-01,0.454376E-01,
24025 &0.650510E+00,0.124032E-01,0.552003E+00,0.282060E+00,0.442463E-01,
24026 &0.443103E-01,0.442733E-01,0.442463E-01,0.609652E+00,0.130451E-01/
24027 DATA (DL(K),K= 1361, 1445) /
24028 &0.541210E+00,0.274395E+00,0.429871E-01,0.430555E-01,0.430156E-01,
24029 &0.429871E-01,0.570164E+00,0.135389E-01,0.529991E+00,0.266608E+00,
24030 &0.416720E-01,0.417443E-01,0.417018E-01,0.416720E-01,0.532237E+00,
24031 &0.138989E-01,0.518389E+00,0.258725E+00,0.403123E-01,0.403879E-01,
24032 &0.403431E-01,0.403123E-01,0.496010E+00,0.141386E-01,0.506446E+00,
24033 &0.250772E+00,0.389186E-01,0.389971E-01,0.389501E-01,0.389186E-01,
24034 &0.461573E+00,0.142708E-01,0.494204E+00,0.242775E+00,0.375006E-01,
24035 &0.375815E-01,0.375327E-01,0.375006E-01,0.428979E+00,0.143074E-01,
24036 &0.481705E+00,0.234757E+00,0.360674E-01,0.361503E-01,0.361000E-01,
24037 &0.360674E-01,0.398246E+00,0.142598E-01,0.468990E+00,0.226741E+00,
24038 &0.346276E-01,0.347120E-01,0.346605E-01,0.346276E-01,0.369363E+00,
24039 &0.141385E-01,0.456098E+00,0.218750E+00,0.331887E-01,0.332743E-01,
24040 &0.332216E-01,0.331887E-01,0.342300E+00,0.139532E-01,0.443068E+00,
24041 &0.210804E+00,0.317576E-01,0.318440E-01,0.317905E-01,0.317576E-01,
24042 &0.317005E+00,0.137130E-01,0.000000E+00,0.000000E+00,0.000000E+00,
24043 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24044 &0.631458E+00,0.318714E+00,0.335640E-01,0.335640E-01,0.335640E-01/
24045 DATA (DL(K),K= 1446, 1530) /
24046 &0.335640E-01,0.686773E+00,0.346945E-17,0.620274E+00,0.310241E+00,
24047 &0.329311E-01,0.329377E-01,0.329337E-01,0.329311E-01,0.646559E+00,
24048 &0.135960E-02,0.608504E+00,0.301610E+00,0.322083E-01,0.322210E-01,
24049 &0.322133E-01,0.322083E-01,0.606503E+00,0.252820E-02,0.596205E+00,
24050 &0.292854E+00,0.314099E-01,0.314281E-01,0.314169E-01,0.314099E-01,
24051 &0.567134E+00,0.352543E-02,0.583429E+00,0.284002E+00,0.305470E-01,
24052 &0.305704E-01,0.305558E-01,0.305470E-01,0.528824E+00,0.436693E-02,
24053 &0.570223E+00,0.275080E+00,0.296307E-01,0.296586E-01,0.296411E-01,
24054 &0.296307E-01,0.491848E+00,0.506768E-02,0.556637E+00,0.266115E+00,
24055 &0.286709E-01,0.287030E-01,0.286827E-01,0.286709E-01,0.456422E+00,
24056 &0.564157E-02,0.542717E+00,0.257131E+00,0.276770E-01,0.277128E-01,
24057 &0.276900E-01,0.276770E-01,0.422697E+00,0.610148E-02,0.528511E+00,
24058 &0.248154E+00,0.266578E-01,0.266968E-01,0.266718E-01,0.266578E-01,
24059 &0.390771E+00,0.645942E-02,0.514062E+00,0.239205E+00,0.256210E-01,
24060 &0.256629E-01,0.256359E-01,0.256210E-01,0.360700E+00,0.672653E-02,
24061 &0.499417E+00,0.230307E+00,0.245741E-01,0.246185E-01,0.245896E-01,
24062 &0.245741E-01,0.332498E+00,0.691312E-02,0.484617E+00,0.221480E+00/
24063 DATA (DL(K),K= 1531, 1615) /
24064 &0.235237E-01,0.235701E-01,0.235397E-01,0.235237E-01,0.306153E+00,
24065 &0.702875E-02,0.469706E+00,0.212745E+00,0.224757E-01,0.225238E-01,
24066 &0.224921E-01,0.224757E-01,0.281624E+00,0.708222E-02,0.454725E+00,
24067 &0.204118E+00,0.214355E-01,0.214850E-01,0.214522E-01,0.214355E-01,
24068 &0.258855E+00,0.708159E-02,0.439713E+00,0.195618E+00,0.204079E-01,
24069 &0.204586E-01,0.204249E-01,0.204079E-01,0.237774E+00,0.703428E-02,
24070 &0.424709E+00,0.187259E+00,0.193972E-01,0.194486E-01,0.194142E-01,
24071 &0.193972E-01,0.218298E+00,0.694702E-02,0.409750E+00,0.179057E+00,
24072 &0.184069E-01,0.184588E-01,0.184239E-01,0.184069E-01,0.200339E+00,
24073 &0.682594E-02,0.394870E+00,0.171023E+00,0.174402E-01,0.174924E-01,
24074 &0.174571E-01,0.174402E-01,0.183804E+00,0.667657E-02,0.380104E+00,
24075 &0.163171E+00,0.164997E-01,0.165519E-01,0.165164E-01,0.164997E-01,
24076 &0.168600E+00,0.650389E-02,0.000000E+00,0.000000E+00,0.000000E+00,
24077 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24078 &0.619056E+00,0.288873E+00,0.218554E-01,0.218554E-01,0.218554E-01,
24079 &0.218554E-01,0.477010E+00,-.867362E-17,0.602890E+00,0.278444E+00,
24080 &0.211480E-01,0.211530E-01,0.211497E-01,0.211480E-01,0.440877E+00/
24081 DATA (DL(K),K= 1616, 1700) /
24082 &0.767466E-03,0.586431E+00,0.268081E+00,0.204081E-01,0.204175E-01,
24083 &0.204113E-01,0.204081E-01,0.406417E+00,0.141432E-02,0.569736E+00,
24084 &0.257807E+00,0.196446E-01,0.196581E-01,0.196491E-01,0.196446E-01,
24085 &0.373808E+00,0.195508E-02,0.552853E+00,0.247642E+00,0.188646E-01,
24086 &0.188816E-01,0.188701E-01,0.188646E-01,0.343145E+00,0.240123E-02,
24087 &0.535829E+00,0.237603E+00,0.180743E-01,0.180945E-01,0.180808E-01,
24088 &0.180743E-01,0.314460E+00,0.276332E-02,0.518710E+00,0.227710E+00,
24089 &0.172796E-01,0.173025E-01,0.172868E-01,0.172796E-01,0.287750E+00,
24090 &0.305100E-02,0.501539E+00,0.217977E+00,0.164854E-01,0.165108E-01,
24091 &0.164933E-01,0.164854E-01,0.262983E+00,0.327305E-02,0.484360E+00,
24092 &0.208420E+00,0.156964E-01,0.157239E-01,0.157049E-01,0.156964E-01,
24093 &0.240098E+00,0.343744E-02,0.467213E+00,0.199053E+00,0.149165E-01,
24094 &0.149457E-01,0.149254E-01,0.149165E-01,0.219021E+00,0.355144E-02,
24095 &0.450140E+00,0.189889E+00,0.141493E-01,0.141800E-01,0.141586E-01,
24096 &0.141493E-01,0.199660E+00,0.362164E-02,0.433177E+00,0.180939E+00,
24097 &0.133978E-01,0.134297E-01,0.134073E-01,0.133978E-01,0.181918E+00,
24098 &0.365401E-02,0.416362E+00,0.172214E+00,0.126646E-01,0.126974E-01/
24099 DATA (DL(K),K= 1701, 1785) /
24100 &0.126742E-01,0.126646E-01,0.165692E+00,0.365394E-02,0.399729E+00,
24101 &0.163725E+00,0.119518E-01,0.119853E-01,0.119615E-01,0.119518E-01,
24102 &0.150875E+00,0.362628E-02,0.383310E+00,0.155477E+00,0.112613E-01,
24103 &0.112952E-01,0.112711E-01,0.112613E-01,0.137364E+00,0.357539E-02,
24104 &0.367138E+00,0.147479E+00,0.105945E-01,0.106287E-01,0.106042E-01,
24105 &0.105945E-01,0.125056E+00,0.350515E-02,0.351239E+00,0.139737E+00,
24106 &0.995250E-02,0.998673E-02,0.996211E-02,0.995250E-02,0.113852E+00,
24107 &0.341903E-02,0.335641E+00,0.132253E+00,0.933610E-02,0.937024E-02,
24108 &0.934557E-02,0.933610E-02,0.103659E+00,0.332009E-02,0.320367E+00,
24109 &0.125033E+00,0.874584E-02,0.877973E-02,0.875514E-02,0.874584E-02,
24110 &0.943886E-01,0.321106E-02,0.000000E+00,0.000000E+00,0.000000E+00,
24111 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24112 &0.591114E+00,0.254807E+00,0.139531E-01,0.139531E-01,0.139531E-01,
24113 &0.139531E-01,0.326288E+00,0.000000E+00,0.571121E+00,0.243424E+00,
24114 &0.133325E-01,0.133362E-01,0.133336E-01,0.133325E-01,0.296956E+00,
24115 &0.429082E-03,0.551151E+00,0.232297E+00,0.127105E-01,0.127175E-01,
24116 &0.127126E-01,0.127105E-01,0.269811E+00,0.785137E-03,0.531253E+00/
24117 DATA (DL(K),K= 1786, 1870) /
24118 &0.221436E+00,0.120916E-01,0.121015E-01,0.120945E-01,0.120916E-01,
24119 &0.244803E+00,0.107790E-02,0.511467E+00,0.210850E+00,0.114794E-01,
24120 &0.114918E-01,0.114829E-01,0.114794E-01,0.221863E+00,0.131504E-02,
24121 &0.491833E+00,0.200545E+00,0.108767E-01,0.108913E-01,0.108808E-01,
24122 &0.108767E-01,0.200886E+00,0.150337E-02,0.472388E+00,0.190531E+00,
24123 &0.102861E-01,0.103027E-01,0.102907E-01,0.102861E-01,0.181762E+00,
24124 &0.164910E-02,0.453170E+00,0.180812E+00,0.970979E-02,0.972799E-02,
24125 &0.971477E-02,0.970979E-02,0.164371E+00,0.175777E-02,0.434213E+00,
24126 &0.171394E+00,0.914959E-02,0.916916E-02,0.915488E-02,0.914959E-02,
24127 &0.148589E+00,0.183434E-02,0.415548E+00,0.162282E+00,0.860700E-02,
24128 &0.862770E-02,0.861252E-02,0.860700E-02,0.134293E+00,0.188328E-02,
24129 &0.397208E+00,0.153479E+00,0.808323E-02,0.810484E-02,0.808891E-02,
24130 &0.808323E-02,0.121361E+00,0.190856E-02,0.379220E+00,0.144989E+00,
24131 &0.757922E-02,0.760152E-02,0.758501E-02,0.757922E-02,0.109676E+00,
24132 &0.191374E-02,0.361611E+00,0.136811E+00,0.709565E-02,0.711846E-02,
24133 &0.710150E-02,0.709565E-02,0.991261E-01,0.190199E-02,0.344406E+00,
24134 &0.128948E+00,0.663300E-02,0.665614E-02,0.663885E-02,0.663300E-02/
24135 DATA (DL(K),K= 1871, 1955) /
24136 &0.896059E-01,0.187610E-02,0.327627E+00,0.121398E+00,0.619152E-02,
24137 &0.621484E-02,0.619734E-02,0.619152E-02,0.810177E-01,0.183856E-02,
24138 &0.311292E+00,0.114161E+00,0.577130E-02,0.579466E-02,0.577706E-02,
24139 &0.577130E-02,0.732709E-01,0.179155E-02,0.295421E+00,0.107235E+00,
24140 &0.537228E-02,0.539554E-02,0.537794E-02,0.537228E-02,0.662824E-01,
24141 &0.173700E-02,0.280026E+00,0.100616E+00,0.499423E-02,0.501728E-02,
24142 &0.499977E-02,0.499423E-02,0.599766E-01,0.167658E-02,0.265121E+00,
24143 &0.943000E-01,0.463683E-02,0.465958E-02,0.464223E-02,0.463683E-02,
24144 &0.542848E-01,0.161174E-02,0.000000E+00,0.000000E+00,0.000000E+00,
24145 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24146 &0.551659E+00,0.219084E+00,0.867977E-02,0.867977E-02,0.867977E-02,
24147 &0.867977E-02,0.218587E+00,-.173472E-16,0.528947E+00,0.207536E+00,
24148 &0.819621E-02,0.819909E-02,0.819696E-02,0.819621E-02,0.196367E+00,
24149 &0.234843E-03,0.506575E+00,0.196391E+00,0.772540E-02,0.773082E-02,
24150 &0.772680E-02,0.772540E-02,0.176280E+00,0.427503E-03,0.484579E+00,
24151 &0.185646E+00,0.726876E-02,0.727639E-02,0.727069E-02,0.726876E-02,
24152 &0.158158E+00,0.583933E-03,0.462988E+00,0.175298E+00,0.682746E-02/
24153 DATA (DL(K),K= 1956, 2040) /
24154 &0.683702E-02,0.682985E-02,0.682746E-02,0.141851E+00,0.708874E-03,
24155 &0.441830E+00,0.165345E+00,0.640226E-02,0.641347E-02,0.640502E-02,
24156 &0.640226E-02,0.127203E+00,0.806409E-03,0.421129E+00,0.155783E+00,
24157 &0.599380E-02,0.600641E-02,0.599686E-02,0.599380E-02,0.114065E+00,
24158 &0.880249E-03,0.400912E+00,0.146609E+00,0.560252E-02,0.561629E-02,
24159 &0.560581E-02,0.560252E-02,0.102296E+00,0.933676E-03,0.381199E+00,
24160 &0.137819E+00,0.522870E-02,0.524342E-02,0.523217E-02,0.522870E-02,
24161 &0.917608E-01,0.969607E-03,0.362011E+00,0.129407E+00,0.487247E-02,
24162 &0.488796E-02,0.487607E-02,0.487247E-02,0.823356E-01,0.990632E-03,
24163 &0.343367E+00,0.121370E+00,0.453385E-02,0.454992E-02,0.453753E-02,
24164 &0.453385E-02,0.739054E-01,0.999042E-03,0.325282E+00,0.113700E+00,
24165 &0.421272E-02,0.422921E-02,0.421644E-02,0.421272E-02,0.663651E-01,
24166 &0.996863E-03,0.307770E+00,0.106393E+00,0.390887E-02,0.392563E-02,
24167 &0.391260E-02,0.390887E-02,0.596195E-01,0.985881E-03,0.290841E+00,
24168 &0.994399E-01,0.362199E-02,0.363889E-02,0.362570E-02,0.362199E-02,
24169 &0.535826E-01,0.967664E-03,0.274506E+00,0.928343E-01,0.335170E-02,
24170 &0.336862E-02,0.335536E-02,0.335170E-02,0.481769E-01,0.943587E-03/
24171 DATA (DL(K),K= 2041, 2125) /
24172 &0.258771E+00,0.865679E-01,0.309756E-02,0.311439E-02,0.310114E-02,
24173 &0.309756E-02,0.433336E-01,0.914850E-03,0.243639E+00,0.806321E-01,
24174 &0.285905E-02,0.287571E-02,0.286255E-02,0.285905E-02,0.389912E-01,
24175 &0.882497E-03,0.229113E+00,0.750177E-01,0.263565E-02,0.265205E-02,
24176 &0.263905E-02,0.263565E-02,0.350948E-01,0.847432E-03,0.215193E+00,
24177 &0.697152E-01,0.242677E-02,0.244285E-02,0.243005E-02,0.242677E-02,
24178 &0.315960E-01,0.810432E-03,0.000000E+00,0.000000E+00,0.000000E+00,
24179 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24180 &0.503850E+00,0.183581E+00,0.522815E-02,0.522815E-02,0.522815E-02,
24181 &0.522815E-02,0.142635E+00,0.123599E-16,0.479478E+00,0.172477E+00,
24182 &0.488093E-02,0.488328E-02,0.488147E-02,0.488093E-02,0.126767E+00,
24183 &0.124505E-03,0.455750E+00,0.161879E+00,0.455054E-02,0.455493E-02,
24184 &0.455153E-02,0.455054E-02,0.112695E+00,0.225968E-03,0.432681E+00,
24185 &0.151771E+00,0.423664E-02,0.424278E-02,0.423800E-02,0.423664E-02,
24186 &0.100212E+00,0.307702E-03,0.410286E+00,0.142140E+00,0.393907E-02,
24187 &0.394671E-02,0.394073E-02,0.393907E-02,0.891488E-01,0.372395E-03,
24188 &0.388577E+00,0.132974E+00,0.365743E-02,0.366634E-02,0.365934E-02/
24189 DATA (DL(K),K= 2126, 2210) /
24190 &0.365743E-02,0.793490E-01,0.422302E-03,0.367563E+00,0.124259E+00,
24191 &0.339138E-02,0.340133E-02,0.339347E-02,0.339138E-02,0.706688E-01,
24192 &0.459484E-03,0.347256E+00,0.115984E+00,0.314049E-02,0.315129E-02,
24193 &0.314273E-02,0.314049E-02,0.629792E-01,0.485762E-03,0.327660E+00,
24194 &0.108136E+00,0.290433E-02,0.291580E-02,0.290667E-02,0.290433E-02,
24195 &0.561642E-01,0.502744E-03,0.308782E+00,0.100701E+00,0.268243E-02,
24196 &0.269440E-02,0.268483E-02,0.268243E-02,0.501207E-01,0.511853E-03,
24197 &0.290625E+00,0.936693E-01,0.247429E-02,0.248663E-02,0.247672E-02,
24198 &0.247429E-02,0.447569E-01,0.514346E-03,0.273189E+00,0.870261E-01,
24199 &0.227939E-02,0.229197E-02,0.228184E-02,0.227939E-02,0.399920E-01,
24200 &0.511328E-03,0.256475E+00,0.807592E-01,0.209722E-02,0.210991E-02,
24201 &0.209965E-02,0.209722E-02,0.357547E-01,0.503769E-03,0.240478E+00,
24202 &0.748555E-01,0.192721E-02,0.193992E-02,0.192961E-02,0.192721E-02,
24203 &0.319825E-01,0.492518E-03,0.225194E+00,0.693019E-01,0.176883E-02,
24204 &0.178147E-02,0.177117E-02,0.176883E-02,0.286209E-01,0.478318E-03,
24205 &0.210615E+00,0.640851E-01,0.162151E-02,0.163400E-02,0.162379E-02,
24206 &0.162151E-02,0.256219E-01,0.461813E-03,0.196733E+00,0.591917E-01/
24207 DATA (DL(K),K= 2211, 2295) /
24208 &0.148471E-02,0.149698E-02,0.148691E-02,0.148471E-02,0.229436E-01,
24209 &0.443561E-03,0.183536E+00,0.546085E-01,0.135786E-02,0.136986E-02,
24210 &0.135998E-02,0.135786E-02,0.205496E-01,0.424043E-03,0.171011E+00,
24211 &0.503219E-01,0.124042E-02,0.125211E-02,0.124246E-02,0.124042E-02,
24212 &0.184079E-01,0.403672E-03,0.000000E+00,0.000000E+00,0.000000E+00,
24213 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24214 &0.450310E+00,0.149685E+00,0.302765E-02,0.302765E-02,0.302765E-02,
24215 &0.302765E-02,0.901099E-01,-.108420E-17,0.425282E+00,0.139479E+00,
24216 &0.279499E-02,0.279691E-02,0.279537E-02,0.279499E-02,0.794239E-01,
24217 &0.632140E-04,0.401169E+00,0.129837E+00,0.257801E-02,0.258157E-02,
24218 &0.257870E-02,0.257801E-02,0.700941E-01,0.114711E-03,0.377966E+00,
24219 &0.120733E+00,0.237556E-02,0.238052E-02,0.237650E-02,0.237556E-02,
24220 &0.619270E-01,0.156107E-03,0.355668E+00,0.112145E+00,0.218688E-02,
24221 &0.219301E-02,0.218802E-02,0.218688E-02,0.547717E-01,0.188777E-03,
24222 &0.334269E+00,0.104052E+00,0.201113E-02,0.201823E-02,0.201243E-02,
24223 &0.201113E-02,0.484974E-01,0.213848E-03,0.313762E+00,0.964335E-01,
24224 &0.184758E-02,0.185546E-02,0.184900E-02,0.184758E-02,0.429879E-01/
24225 DATA (DL(K),K= 2296, 2380) /
24226 &0.232367E-03,0.294139E+00,0.892696E-01,0.169553E-02,0.170402E-02,
24227 &0.169703E-02,0.169553E-02,0.381432E-01,0.245270E-03,0.275389E+00,
24228 &0.825414E-01,0.155431E-02,0.156326E-02,0.155586E-02,0.155431E-02,
24229 &0.338762E-01,0.253383E-03,0.257502E+00,0.762303E-01,0.142329E-02,
24230 &0.143258E-02,0.142487E-02,0.142329E-02,0.301119E-01,0.257441E-03,
24231 &0.240464E+00,0.703180E-01,0.130188E-02,0.131138E-02,0.130347E-02,
24232 &0.130188E-02,0.267853E-01,0.258098E-03,0.224262E+00,0.647867E-01,
24233 &0.118950E-02,0.119912E-02,0.119108E-02,0.118950E-02,0.238409E-01,
24234 &0.255929E-03,0.208879E+00,0.596190E-01,0.108562E-02,0.109526E-02,
24235 &0.108717E-02,0.108562E-02,0.212308E-01,0.251442E-03,0.194298E+00,
24236 &0.547975E-01,0.989698E-03,0.999283E-03,0.991221E-03,0.989698E-03,
24237 &0.189136E-01,0.245082E-03,0.180499E+00,0.503054E-01,0.901248E-03,
24238 &0.910711E-03,0.902726E-03,0.901248E-03,0.168537E-01,0.237238E-03,
24239 &0.167463E+00,0.461263E-01,0.819789E-03,0.829074E-03,0.821215E-03,
24240 &0.819789E-03,0.150206E-01,0.228250E-03,0.155167E+00,0.422438E-01,
24241 &0.744866E-03,0.753925E-03,0.746234E-03,0.744866E-03,0.133878E-01,
24242 &0.218412E-03,0.143590E+00,0.386421E-01,0.676043E-03,0.684836E-03/
24243 DATA (DL(K),K= 2381, 2465) /
24244 &0.677349E-03,0.676043E-03,0.119320E-01,0.207976E-03,0.132706E+00,
24245 &0.353058E-01,0.612907E-03,0.621403E-03,0.614147E-03,0.612907E-03,
24246 &0.106334E-01,0.197159E-03,0.000000E+00,0.000000E+00,0.000000E+00,
24247 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24248 &0.393307E+00,0.118409E+00,0.167124E-02,0.167124E-02,0.167124E-02,
24249 &0.167124E-02,0.547140E-01,0.433681E-17,0.368555E+00,0.109414E+00,
24250 &0.152547E-02,0.152705E-02,0.152573E-02,0.152547E-02,0.479708E-01,
24251 &0.303147E-04,0.344946E+00,0.101001E+00,0.139202E-02,0.139494E-02,
24252 &0.139249E-02,0.139202E-02,0.421517E-01,0.552185E-04,0.322450E+00,
24253 &0.931345E-01,0.126960E-02,0.127363E-02,0.127024E-02,0.126960E-02,
24254 &0.371043E-01,0.753524E-04,0.301043E+00,0.857854E-01,0.115731E-02,
24255 &0.116225E-02,0.115808E-02,0.115731E-02,0.327131E-01,0.913172E-04,
24256 &0.280698E+00,0.789267E-01,0.105427E-02,0.105995E-02,0.105514E-02,
24257 &0.105427E-02,0.288844E-01,0.103605E-03,0.261390E+00,0.725323E-01,
24258 &0.959726E-03,0.965979E-03,0.960659E-03,0.959726E-03,0.255366E-01,
24259 &0.112688E-03,0.243091E+00,0.665774E-01,0.872987E-03,0.879676E-03,
24260 &0.873966E-03,0.872987E-03,0.226017E-01,0.119000E-03,0.225775E+00/
24261 DATA (DL(K),K= 2466, 2550) /
24262 &0.610385E-01,0.793435E-03,0.800438E-03,0.794441E-03,0.793435E-03,
24263 &0.200219E-01,0.122931E-03,0.209414E+00,0.558928E-01,0.720508E-03,
24264 &0.727716E-03,0.721524E-03,0.720508E-03,0.177490E-01,0.124835E-03,
24265 &0.193979E+00,0.511187E-01,0.653691E-03,0.661011E-03,0.654703E-03,
24266 &0.653691E-03,0.157425E-01,0.125031E-03,0.179441E+00,0.466950E-01,
24267 &0.592513E-03,0.599863E-03,0.593511E-03,0.592513E-03,0.139674E-01,
24268 &0.123805E-03,0.165770E+00,0.426018E-01,0.536539E-03,0.543850E-03,
24269 &0.537513E-03,0.536539E-03,0.123945E-01,0.121411E-03,0.152935E+00,
24270 &0.388195E-01,0.485370E-03,0.492584E-03,0.486314E-03,0.485370E-03,
24271 &0.109993E-01,0.118076E-03,0.140905E+00,0.353295E-01,0.438636E-03,
24272 &0.445702E-03,0.439543E-03,0.438636E-03,0.976027E-02,0.113999E-03,
24273 &0.129648E+00,0.321137E-01,0.395992E-03,0.402871E-03,0.396859E-03,
24274 &0.395992E-03,0.865895E-02,0.109353E-03,0.119131E+00,0.291550E-01,
24275 &0.357120E-03,0.363779E-03,0.357945E-03,0.357120E-03,0.767960E-02,
24276 &0.104292E-03,0.109323E+00,0.264366E-01,0.321725E-03,0.328139E-03,
24277 &0.322505E-03,0.321725E-03,0.680866E-02,0.989468E-04,0.100191E+00,
24278 &0.239428E-01,0.289531E-03,0.295679E-03,0.290266E-03,0.289531E-03/
24279 DATA (DL(K),K= 2551, 2635) /
24280 &0.603390E-02,0.934295E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24281 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24282 &0.334851E+00,0.904666E-01,0.869706E-03,0.869706E-03,0.869706E-03,
24283 &0.869706E-03,0.316365E-01,-.311708E-17,0.311223E+00,0.828706E-01,
24284 &0.784673E-03,0.785968E-03,0.784847E-03,0.784673E-03,0.277037E-01,
24285 &0.134749E-04,0.288910E+00,0.758361E-01,0.708234E-03,0.710597E-03,
24286 &0.708543E-03,0.708234E-03,0.243298E-01,0.247881E-04,0.267855E+00,
24287 &0.693222E-01,0.639256E-03,0.642491E-03,0.639671E-03,0.639256E-03,
24288 &0.214125E-01,0.340882E-04,0.248015E+00,0.632964E-01,0.576953E-03,
24289 &0.580887E-03,0.577448E-03,0.576953E-03,0.188764E-01,0.415701E-04,
24290 &0.229343E+00,0.577274E-01,0.520615E-03,0.525096E-03,0.521167E-03,
24291 &0.520615E-03,0.166642E-01,0.474027E-04,0.211794E+00,0.525860E-01,
24292 &0.469624E-03,0.474520E-03,0.470215E-03,0.469624E-03,0.147265E-01,
24293 &0.517615E-04,0.195325E+00,0.478447E-01,0.423445E-03,0.428640E-03,
24294 &0.424060E-03,0.423445E-03,0.130234E-01,0.548213E-04,0.179891E+00,
24295 &0.434776E-01,0.381606E-03,0.387001E-03,0.382232E-03,0.381606E-03,
24296 &0.115226E-01,0.567474E-04,0.165449E+00,0.394601E-01,0.343691E-03/
24297 DATA (DL(K),K= 2636, 2720) /
24298 &0.349200E-03,0.344317E-03,0.343691E-03,0.101965E-01,0.576952E-04,
24299 &0.151958E+00,0.357691E-01,0.309329E-03,0.314879E-03,0.309948E-03,
24300 &0.309329E-03,0.902217E-02,0.578101E-04,0.139374E+00,0.323826E-01,
24301 &0.278192E-03,0.283721E-03,0.278796E-03,0.278192E-03,0.798131E-02,
24302 &0.572266E-04,0.127655E+00,0.292797E-01,0.249984E-03,0.255440E-03,
24303 &0.250569E-03,0.249984E-03,0.705796E-02,0.560672E-04,0.116760E+00,
24304 &0.264406E-01,0.224440E-03,0.229782E-03,0.225002E-03,0.224440E-03,
24305 &0.623793E-02,0.544420E-04,0.106647E+00,0.238467E-01,0.201321E-03,
24306 &0.206513E-03,0.201856E-03,0.201321E-03,0.550962E-02,0.524504E-04,
24307 &0.972762E-01,0.214802E-01,0.180411E-03,0.185425E-03,0.180918E-03,
24308 &0.180411E-03,0.486321E-02,0.501804E-04,0.886073E-01,0.193242E-01,
24309 &0.161512E-03,0.166328E-03,0.161990E-03,0.161512E-03,0.428946E-02,
24310 &0.477087E-04,0.806013E-01,0.173629E-01,0.144446E-03,0.149048E-03,
24311 &0.144894E-03,0.144446E-03,0.378030E-02,0.451020E-04,0.732197E-01,
24312 &0.155814E-01,0.129049E-03,0.133425E-03,0.129467E-03,0.129049E-03,
24313 &0.332897E-02,0.424179E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24314 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24315 DATA (DL(K),K= 2721, 2805) /
24316 &0.276761E+00,0.663170E-01,0.420483E-03,0.420483E-03,0.420483E-03,
24317 &0.420483E-03,0.172075E-01,0.418773E-17,0.255003E+00,0.601925E-01,
24318 &0.374768E-03,0.375776E-03,0.374876E-03,0.374768E-03,0.151410E-01,
24319 &0.540038E-05,0.234664E+00,0.545789E-01,0.334420E-03,0.336252E-03,
24320 &0.334612E-03,0.334420E-03,0.133594E-01,0.101360E-04,0.215665E+00,
24321 &0.494328E-01,0.298611E-03,0.301108E-03,0.298867E-03,0.298611E-03,
24322 &0.118079E-01,0.141555E-04,0.197941E+00,0.447203E-01,0.266766E-03,
24323 &0.269787E-03,0.267068E-03,0.266766E-03,0.104461E-01,0.174750E-04,
24324 &0.181428E+00,0.404089E-01,0.238391E-03,0.241815E-03,0.238726E-03,
24325 &0.238391E-03,0.924609E-02,0.201244E-04,0.166064E+00,0.364687E-01,
24326 &0.213061E-03,0.216782E-03,0.213417E-03,0.213061E-03,0.818507E-02,
24327 &0.221467E-04,0.151790E+00,0.328719E-01,0.190418E-03,0.194343E-03,
24328 &0.190785E-03,0.190418E-03,0.724366E-02,0.235974E-04,0.138548E+00,
24329 &0.295925E-01,0.170150E-03,0.174202E-03,0.170521E-03,0.170150E-03,
24330 &0.640614E-02,0.245354E-04,0.126282E+00,0.266063E-01,0.151991E-03,
24331 &0.156104E-03,0.152359E-03,0.151991E-03,0.566089E-02,0.250221E-04,
24332 &0.114939E+00,0.238907E-01,0.135710E-03,0.139827E-03,0.136071E-03/
24333 DATA (DL(K),K= 2806, 2890) /
24334 &0.135710E-03,0.499773E-02,0.251191E-04,0.104465E+00,0.214245E-01,
24335 &0.121106E-03,0.125180E-03,0.121455E-03,0.121106E-03,0.440691E-02,
24336 &0.248850E-04,0.948101E-01,0.191879E-01,0.108002E-03,0.111994E-03,
24337 &0.108337E-03,0.108002E-03,0.388094E-02,0.243760E-04,0.859247E-01,
24338 &0.171625E-01,0.962435E-04,0.100124E-03,0.965624E-04,0.962435E-04,
24339 &0.341379E-02,0.236445E-04,0.777613E-01,0.153309E-01,0.856948E-04,
24340 &0.894394E-04,0.859960E-04,0.856948E-04,0.299910E-02,0.227378E-04,
24341 &0.702736E-01,0.136770E-01,0.762337E-04,0.798235E-04,0.765166E-04,
24342 &0.762337E-04,0.263116E-02,0.216984E-04,0.634174E-01,0.121859E-01,
24343 &0.677528E-04,0.711742E-04,0.680169E-04,0.677528E-04,0.230551E-02,
24344 &0.205642E-04,0.571500E-01,0.108434E-01,0.601554E-04,0.633990E-04,
24345 &0.604008E-04,0.601554E-04,0.201791E-02,0.193681E-04,0.514305E-01,
24346 &0.963651E-02,0.533545E-04,0.564148E-04,0.535814E-04,0.533545E-04,
24347 &0.176404E-02,0.181381E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24348 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24349 &0.220700E+00,0.461964E-01,0.185072E-03,0.185072E-03,0.185072E-03,
24350 &0.185072E-03,0.865568E-02,-.294090E-17,0.201438E+00,0.415162E-01/
24351 DATA (DL(K),K= 2891, 2975) /
24352 &0.162774E-03,0.163610E-03,0.162842E-03,0.162774E-03,0.772611E-02,
24353 &0.184134E-05,0.183625E+00,0.372730E-01,0.143469E-03,0.144974E-03,
24354 &0.143588E-03,0.143469E-03,0.690038E-02,0.359959E-05,0.167162E+00,
24355 &0.334245E-01,0.126634E-03,0.128666E-03,0.126791E-03,0.126634E-03,
24356 &0.616000E-02,0.518075E-05,0.151966E+00,0.299378E-01,0.111904E-03,
24357 &0.114340E-03,0.112088E-03,0.111904E-03,0.549219E-02,0.654232E-05,
24358 &0.137959E+00,0.267821E-01,0.989836E-04,0.101716E-03,0.991845E-04,
24359 &0.989836E-04,0.488896E-02,0.767008E-05,0.125065E+00,0.239289E-01,
24360 &0.876157E-04,0.905559E-04,0.878269E-04,0.876157E-04,0.434253E-02,
24361 &0.855860E-05,0.113213E+00,0.213524E-01,0.775899E-04,0.806611E-04,
24362 &0.778055E-04,0.775899E-04,0.384886E-02,0.921640E-05,0.102335E+00,
24363 &0.190285E-01,0.687292E-04,0.718676E-04,0.689446E-04,0.687292E-04,
24364 &0.340422E-02,0.965961E-05,0.923671E-01,0.169353E-01,0.608829E-04,
24365 &0.640353E-04,0.610944E-04,0.608829E-04,0.300332E-02,0.990752E-05,
24366 &0.832476E-01,0.150523E-01,0.539242E-04,0.570473E-04,0.541291E-04,
24367 &0.539242E-04,0.264288E-02,0.998320E-05,0.749179E-01,0.133608E-01,
24368 &0.477459E-04,0.508046E-04,0.479422E-04,0.477459E-04,0.232088E-02/
24369 DATA (DL(K),K= 2976, 3060) /
24370 &0.991147E-05,0.673221E-01,0.118435E-01,0.422554E-04,0.452220E-04,
24371 &0.424417E-04,0.422554E-04,0.203376E-02,0.971603E-05,0.604073E-01,
24372 &0.104845E-01,0.373730E-04,0.402263E-04,0.375483E-04,0.373730E-04,
24373 &0.177791E-02,0.941959E-05,0.541231E-01,0.926900E-02,0.330304E-04,
24374 &0.357544E-04,0.331943E-04,0.330304E-04,0.155117E-02,0.904408E-05,
24375 &0.484216E-01,0.818347E-02,0.291681E-04,0.317517E-04,0.293202E-04,
24376 &0.291681E-04,0.135108E-02,0.860921E-05,0.432578E-01,0.721549E-02,
24377 &0.257333E-04,0.281694E-04,0.258738E-04,0.257333E-04,0.117463E-02,
24378 &0.813214E-05,0.385889E-01,0.635362E-02,0.226802E-04,0.249648E-04,
24379 &0.228093E-04,0.226802E-04,0.101941E-02,0.762814E-05,0.343746E-01,
24380 &0.558739E-02,0.199682E-04,0.221003E-04,0.200863E-04,0.199682E-04,
24381 &0.883469E-03,0.711035E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24382 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24383 &0.168205E+00,0.301419E-01,0.719932E-04,0.719932E-04,0.719932E-04,
24384 &0.719932E-04,0.392825E-02,-.205998E-17,0.151922E+00,0.267932E-01,
24385 &0.623634E-04,0.630456E-04,0.624028E-04,0.623634E-04,0.361412E-02,
24386 &0.457084E-06,0.137042E+00,0.237932E-01,0.541981E-04,0.554098E-04/
24387 DATA (DL(K),K= 3061, 3145) /
24388 &0.542663E-04,0.541981E-04,0.330342E-02,0.989813E-06,0.123446E+00,
24389 &0.211038E-01,0.472163E-04,0.488314E-04,0.473050E-04,0.472163E-04,
24390 &0.300140E-02,0.152631E-05,0.111042E+00,0.186954E-01,0.412159E-04,
24391 &0.431273E-04,0.413184E-04,0.412159E-04,0.270826E-02,0.202092E-05,
24392 &0.997395E-01,0.165410E-01,0.360433E-04,0.381615E-04,0.361542E-04,
24393 &0.360433E-04,0.242968E-02,0.245400E-05,0.894558E-01,0.146159E-01,
24394 &0.315670E-04,0.338178E-04,0.316822E-04,0.315670E-04,0.216928E-02,
24395 &0.281218E-05,0.801130E-01,0.128978E-01,0.276779E-04,0.300002E-04,
24396 &0.277940E-04,0.276779E-04,0.192603E-02,0.308878E-05,0.716379E-01,
24397 &0.113663E-01,0.242878E-04,0.266317E-04,0.244024E-04,0.242878E-04,
24398 &0.170100E-02,0.328451E-05,0.639623E-01,0.100031E-01,0.213246E-04,
24399 &0.236502E-04,0.214357E-04,0.213246E-04,0.149649E-02,0.340483E-05,
24400 &0.570222E-01,0.879131E-02,0.187277E-04,0.210033E-04,0.188341E-04,
24401 &0.187277E-04,0.131163E-02,0.345656E-05,0.507574E-01,0.771565E-02,
24402 &0.164465E-04,0.186476E-04,0.165471E-04,0.164465E-04,0.114469E-02,
24403 &0.344782E-05,0.451118E-01,0.676223E-02,0.144396E-04,0.165480E-04,
24404 &0.145339E-04,0.144396E-04,0.995649E-03,0.338831E-05,0.400330E-01/
24405 DATA (DL(K),K= 3146, 3230) /
24406 &0.591841E-02,0.126720E-04,0.146744E-04,0.127597E-04,0.126720E-04,
24407 &0.863829E-03,0.328754E-05,0.354720E-01,0.517273E-02,0.111137E-04,
24408 &0.130013E-04,0.111946E-04,0.111137E-04,0.747293E-03,0.315403E-05,
24409 &0.313830E-01,0.451477E-02,0.973915E-05,0.115067E-04,0.981339E-05,
24410 &0.973915E-05,0.644664E-03,0.299600E-05,0.277237E-01,0.393511E-02,
24411 &0.852687E-05,0.101721E-04,0.859457E-05,0.852687E-05,0.555034E-03,
24412 &0.282099E-05,0.244545E-01,0.342521E-02,0.745784E-05,0.898076E-05,
24413 &0.751926E-05,0.745784E-05,0.476998E-03,0.263530E-05,0.215390E-01,
24414 &0.297737E-02,0.651555E-05,0.791817E-05,0.657100E-05,0.651555E-05,
24415 &0.409096E-03,0.244427E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24416 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24417 &0.120694E+00,0.180081E-01,0.236444E-04,0.236444E-04,0.236444E-04,
24418 &0.236444E-04,0.154817E-02,0.416656E-17,0.107713E+00,0.158098E-01,
24419 &0.200945E-04,0.206098E-04,0.201146E-04,0.200945E-04,0.151249E-02,
24420 &0.192118E-07,0.960063E-01,0.138667E-01,0.171552E-04,0.180593E-04,
24421 &0.171894E-04,0.171552E-04,0.143574E-02,0.116516E-06,0.854477E-01,
24422 &0.121473E-01,0.146986E-04,0.158894E-04,0.147425E-04,0.146986E-04/
24423 DATA (DL(K),K= 3231, 3315) /
24424 &0.133744E-02,0.251060E-06,0.759386E-01,0.106275E-01,0.126329E-04,
24425 &0.140252E-04,0.126830E-04,0.126329E-04,0.122900E-02,0.395272E-06,
24426 &0.673865E-01,0.928577E-02,0.108901E-04,0.124142E-04,0.109436E-04,
24427 &0.108901E-04,0.111367E-02,0.535145E-06,0.597062E-01,0.810254E-02,
24428 &0.941160E-05,0.110108E-04,0.946648E-05,0.941160E-05,0.996785E-03,
24429 &0.659421E-06,0.528194E-01,0.706039E-02,0.815165E-05,0.978016E-05,
24430 &0.820627E-05,0.815165E-05,0.885152E-03,0.762600E-06,0.466540E-01,
24431 &0.614371E-02,0.707299E-05,0.869464E-05,0.712616E-05,0.707299E-05,
24432 &0.780484E-03,0.842072E-06,0.411433E-01,0.533850E-02,0.614470E-05,
24433 &0.773135E-05,0.619559E-05,0.614470E-05,0.682563E-03,0.896683E-06,
24434 &0.362261E-01,0.463223E-02,0.534297E-05,0.687330E-05,0.539102E-05,
24435 &0.534297E-05,0.593317E-03,0.928176E-06,0.318459E-01,0.401364E-02,
24436 &0.464848E-05,0.610690E-05,0.469333E-05,0.464848E-05,0.513720E-03,
24437 &0.939174E-06,0.279510E-01,0.347266E-02,0.404483E-05,0.542054E-05,
24438 &0.408628E-05,0.404483E-05,0.442713E-03,0.932117E-06,0.244935E-01,
24439 &0.300029E-02,0.351893E-05,0.480507E-05,0.355692E-05,0.351893E-05,
24440 &0.379744E-03,0.910085E-06,0.214299E-01,0.258845E-02,0.306021E-05/
24441 DATA (DL(K),K= 3316, 3400) /
24442 &0.425313E-05,0.309476E-05,0.306021E-05,0.324785E-03,0.876365E-06,
24443 &0.187200E-01,0.222996E-02,0.265958E-05,0.375823E-05,0.269081E-05,
24444 &0.265958E-05,0.277080E-03,0.833755E-06,0.163273E-01,0.191840E-02,
24445 &0.230942E-05,0.331477E-05,0.233747E-05,0.230942E-05,0.235661E-03,
24446 &0.784780E-06,0.142185E-01,0.164805E-02,0.200337E-05,0.291797E-05,
24447 &0.202844E-05,0.200337E-05,0.199949E-03,0.731774E-06,0.123631E-01,
24448 &0.141382E-02,0.173596E-05,0.256351E-05,0.175824E-05,0.173596E-05,
24449 &0.169376E-03,0.676674E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24450 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24451 &0.794823E-01,0.948208E-02,0.607312E-05,0.607312E-05,0.607312E-05,
24452 &0.607312E-05,0.497062E-03,-.140523E-17,0.699344E-01,0.820355E-02,
24453 &0.500852E-05,0.538347E-05,0.501731E-05,0.500852E-05,0.542262E-03,
24454 &-.714686E-07,0.614560E-01,0.709106E-02,0.415227E-05,0.479898E-05,
24455 &0.416702E-05,0.415227E-05,0.549985E-03,-.960102E-07,0.539240E-01,
24456 &0.612155E-02,0.345977E-05,0.429563E-05,0.347839E-05,0.345977E-05,
24457 &0.531288E-03,-.894946E-07,0.472426E-01,0.527757E-02,0.289508E-05,
24458 &0.385164E-05,0.291595E-05,0.289508E-05,0.495120E-03,-.668594E-07/
24459 DATA (DL(K),K= 3401, 3485) /
24460 &0.413245E-01,0.454380E-02,0.243524E-05,0.345851E-05,0.245713E-05,
24461 &0.243524E-05,0.452156E-03,-.338861E-07,0.360903E-01,0.390658E-02,
24462 &0.205923E-05,0.310726E-05,0.208123E-05,0.205923E-05,0.406686E-03,
24463 &0.329349E-08,0.314681E-01,0.335393E-02,0.174861E-05,0.278918E-05,
24464 &0.177007E-05,0.174861E-05,0.359402E-03,0.387747E-07,0.273932E-01,
24465 &0.287528E-02,0.149082E-05,0.250013E-05,0.151127E-05,0.149082E-05,
24466 &0.313779E-03,0.705560E-07,0.238068E-01,0.246132E-02,0.127582E-05,
24467 &0.223699E-05,0.129498E-05,0.127582E-05,0.272195E-03,0.975744E-07,
24468 &0.206558E-01,0.210383E-02,0.109488E-05,0.199657E-05,0.111257E-05,
24469 &0.109488E-05,0.234227E-03,0.118651E-06,0.178921E-01,0.179558E-02,
24470 &0.941584E-06,0.177694E-05,0.957733E-06,0.941584E-06,0.199907E-03,
24471 &0.133780E-06,0.154726E-01,0.153020E-02,0.811157E-06,0.157680E-05,
24472 &0.825743E-06,0.811157E-06,0.169849E-03,0.143581E-06,0.133582E-01,
24473 &0.130209E-02,0.699567E-06,0.139481E-05,0.712624E-06,0.699567E-06,
24474 &0.143794E-03,0.148591E-06,0.115137E-01,0.110634E-02,0.603631E-06,
24475 &0.122977E-05,0.615228E-06,0.603631E-06,0.121163E-03,0.149477E-06,
24476 &0.990774E-02,0.938615E-03,0.520920E-06,0.108072E-05,0.531148E-06/
24477 DATA (DL(K),K= 3486, 3570) /
24478 &0.520920E-06,0.101725E-03,0.147055E-06,0.851194E-02,0.795146E-03,
24479 &0.449441E-06,0.946634E-06,0.458405E-06,0.449441E-06,0.852238E-04,
24480 &0.142064E-06,0.730103E-02,0.672622E-03,0.387542E-06,0.826497E-06,
24481 &0.395353E-06,0.387542E-06,0.712290E-04,0.135149E-06,0.625244E-02,
24482 &0.568155E-03,0.333888E-06,0.719316E-06,0.340658E-06,0.333888E-06,
24483 &0.593824E-04,0.126902E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24484 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24485 &0.457819E-01,0.409492E-02,0.105702E-05,0.105702E-05,0.105702E-05,
24486 &0.105702E-05,0.115350E-03,0.265810E-18,0.395724E-01,0.347873E-02,
24487 &0.812397E-06,0.103880E-05,0.815187E-06,0.812397E-06,0.160406E-03,
24488 &-.555147E-07,0.341639E-01,0.295295E-02,0.627904E-06,0.987449E-06,
24489 &0.632305E-06,0.627904E-06,0.174490E-03,-.847266E-07,0.294481E-01,
24490 &0.250329E-02,0.490075E-06,0.920197E-06,0.495305E-06,0.490075E-06,
24491 &0.174490E-03,-.944763E-07,0.253423E-01,0.211912E-02,0.387225E-06,
24492 &0.845257E-06,0.392760E-06,0.387225E-06,0.167111E-03,-.916775E-07,
24493 &0.217735E-01,0.179138E-02,0.309989E-06,0.766697E-06,0.315473E-06,
24494 &0.309989E-06,0.152540E-03,-.819158E-07,0.186760E-01,0.151211E-02/
24495 DATA (DL(K),K= 3571, 3655) /
24496 &0.252109E-06,0.688927E-06,0.257316E-06,0.252109E-06,0.135295E-03,
24497 &-.682145E-07,0.159921E-01,0.127447E-02,0.208612E-06,0.614302E-06,
24498 &0.213410E-06,0.208612E-06,0.118648E-03,-.528734E-07,0.136704E-01,
24499 &0.107254E-02,0.175203E-06,0.543807E-06,0.179526E-06,0.175203E-06,
24500 &0.102484E-03,-.379748E-07,0.116656E-01,0.901214E-03,0.149064E-06,
24501 &0.478363E-06,0.152890E-06,0.149064E-06,0.871530E-04,-.245007E-07,
24502 &0.993760E-02,0.756074E-03,0.128274E-06,0.418496E-06,0.131610E-06,
24503 &0.128274E-06,0.735682E-04,-.128491E-07,0.845081E-02,0.633315E-03,
24504 &0.111313E-06,0.364260E-06,0.114187E-06,0.111313E-06,0.617706E-04,
24505 &-.327698E-08,0.717398E-02,0.529654E-03,0.971373E-07,0.315568E-06,
24506 &0.995871E-07,0.971373E-07,0.514764E-04,0.421954E-08,0.607950E-02,
24507 &0.442265E-03,0.850687E-07,0.272228E-06,0.871375E-07,0.850687E-07,
24508 &0.426580E-04,0.982709E-08,0.514311E-02,0.368716E-03,0.746164E-07,
24509 &0.233927E-06,0.763489E-07,0.746164E-07,0.352463E-04,0.137715E-07,
24510 &0.434349E-02,0.306920E-03,0.654439E-07,0.200291E-06,0.668838E-07,
24511 &0.654439E-07,0.290260E-04,0.163078E-07,0.366196E-02,0.255085E-03,
24512 &0.573307E-07,0.170932E-06,0.585192E-07,0.573307E-07,0.238196E-04/
24513 DATA (DL(K),K= 3656, 3740) /
24514 &0.177037E-07,0.308217E-02,0.211681E-03,0.501185E-07,0.145441E-06,
24515 &0.510931E-07,0.501185E-07,0.195033E-04,0.182028E-07,0.258987E-02,
24516 &0.175396E-03,0.436915E-07,0.123415E-06,0.444860E-07,0.436915E-07,
24517 &0.159423E-04,0.180204E-07,0.000000E+00,0.000000E+00,0.000000E+00,
24518 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24519 &0.206951E-01,0.123383E-02,0.903693E-07,0.903693E-07,0.903693E-07,
24520 &0.903693E-07,0.147928E-04,0.131925E-18,0.174566E-01,0.102241E-02,
24521 &0.892028E-07,0.129792E-07,0.885875E-07,0.892028E-07,0.328931E-04,
24522 &0.168541E-07,0.147092E-01,0.846741E-03,0.841992E-07,-.346085E-07,
24523 &0.832249E-07,0.841992E-07,0.410825E-04,0.262547E-07,0.123736E-01,
24524 &0.700287E-03,0.769173E-07,-.620958E-07,0.757563E-07,0.769173E-07,
24525 &0.418512E-04,0.305542E-07,0.103910E-01,0.578275E-03,0.688622E-07,
24526 &-.753692E-07,0.676306E-07,0.688622E-07,0.392599E-04,0.318183E-07,
24527 &0.871109E-02,0.476815E-03,0.611778E-07,-.782788E-07,0.599557E-07,
24528 &0.611778E-07,0.356221E-04,0.316149E-07,0.728984E-02,0.392546E-03,
24529 &0.537256E-07,-.749101E-07,0.525642E-07,0.537256E-07,0.312295E-04,
24530 &0.301630E-07,0.608951E-02,0.322656E-03,0.466227E-07,-.678673E-07/
24531 DATA (DL(K),K= 3741, 3825) /
24532 &0.455521E-07,0.466227E-07,0.265816E-04,0.278681E-07,0.507758E-02,
24533 &0.264779E-03,0.400790E-07,-.588670E-07,0.391148E-07,0.400790E-07,
24534 &0.223044E-04,0.251720E-07,0.422604E-02,0.216927E-03,0.341205E-07,
24535 &-.492124E-07,0.332680E-07,0.341205E-07,0.185283E-04,0.222885E-07,
24536 &0.351082E-02,0.177427E-03,0.287480E-07,-.397442E-07,0.280058E-07,
24537 &0.287480E-07,0.152122E-04,0.193702E-07,0.291126E-02,0.144878E-03,
24538 &0.239699E-07,-.309608E-07,0.233320E-07,0.239699E-07,0.123840E-04,
24539 &0.165481E-07,0.240962E-02,0.118102E-03,0.197695E-07,-.231453E-07,
24540 &0.192276E-07,0.197695E-07,0.100316E-04,0.139043E-07,0.199075E-02,
24541 &0.961132E-04,0.161186E-07,-.164194E-07,0.156628E-07,0.161186E-07,
24542 &0.808648E-05,0.114903E-07,0.164168E-02,0.780880E-04,0.129826E-07,
24543 &-.107955E-07,0.126029E-07,0.129826E-07,0.648861E-05,0.933575E-08,
24544 &0.135135E-02,0.633381E-04,0.103192E-07,-.622051E-08,0.100055E-07,
24545 &0.103192E-07,0.519042E-05,0.744979E-08,0.111036E-02,0.512898E-04,
24546 &0.808255E-08,-.260101E-08,0.782557E-08,0.808255E-08,0.414192E-05,
24547 &0.582811E-08,0.910718E-03,0.414657E-04,0.622640E-08,0.177583E-09,
24548 &0.601750E-08,0.622640E-08,0.329729E-05,0.445766E-08,0.745657E-03/
24549 DATA (DL(K),K= 3826, 3910) /
24550 &0.334694E-04,0.470431E-08,0.223586E-08,0.453577E-08,0.470431E-08,
24551 &0.261981E-05,0.331859E-08,0.000000E+00,0.000000E+00,0.000000E+00,
24552 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24553 &0.519165E-02,0.154752E-03,0.135983E-08,0.135983E-08,0.135983E-08,
24554 &0.135983E-08,0.445189E-06,0.165858E-19,0.420352E-02,0.123002E-03,
24555 &-.202651E-07,0.730203E-07,-.200511E-07,-.202651E-07,0.358557E-05,
24556 &-.213089E-07,0.340143E-02,0.977718E-04,-.356451E-07,0.114908E-06,
24557 &-.353066E-07,-.356451E-07,0.384652E-05,-.364475E-07,0.274771E-02,
24558 &0.776124E-04,-.435588E-07,0.139200E-06,-.431556E-07,-.435588E-07,
24559 &0.404834E-05,-.441752E-07,0.221524E-02,0.614950E-04,-.471629E-07,
24560 &0.150069E-06,-.467352E-07,-.471629E-07,0.391615E-05,-.476355E-07,
24561 &0.178268E-02,0.486476E-04,-.477545E-07,0.151420E-06,-.473296E-07,
24562 &-.477545E-07,0.334100E-05,-.481163E-07,0.143185E-02,0.384202E-04,
24563 &-.462359E-07,0.146515E-06,-.458316E-07,-.462359E-07,0.275426E-05,
24564 &-.465126E-07,0.114781E-02,0.302894E-04,-.434031E-07,0.137587E-06,
24565 &-.430295E-07,-.434031E-07,0.226010E-05,-.436143E-07,0.918288E-03,
24566 &0.238367E-04,-.398089E-07,0.126321E-06,-.394715E-07,-.398089E-07/
24567 DATA (DL(K),K= 3911, 3995) /
24568 &0.180947E-05,-.399700E-07,0.733193E-03,0.187249E-04,-.358525E-07,
24569 &0.113940E-06,-.355529E-07,-.358525E-07,0.142045E-05,-.359751E-07,
24570 &0.584227E-03,0.146823E-04,-.318183E-07,0.101291E-06,-.315563E-07,
24571 &-.318183E-07,0.110919E-05,-.319115E-07,0.464586E-03,0.114914E-04,
24572 &-.278936E-07,0.889550E-07,-.276671E-07,-.278936E-07,0.860964E-06,
24573 &-.279643E-07,0.368700E-03,0.897731E-05,-.241972E-07,0.773096E-07,
24574 &-.240033E-07,-.241972E-07,0.662825E-06,-.242508E-07,0.292013E-03,
24575 &0.700034E-05,-.208001E-07,0.665779E-07,-.206356E-07,-.208001E-07,
24576 &0.508061E-06,-.208406E-07,0.230814E-03,0.544870E-05,-.177366E-07,
24577 &0.568734E-07,-.175982E-07,-.177366E-07,0.388493E-06,-.177672E-07,
24578 &0.182078E-03,0.423324E-05,-.150157E-07,0.482316E-07,-.149000E-07,
24579 &-.150157E-07,0.296111E-06,-.150387E-07,0.143349E-03,0.328297E-05,
24580 &-.126295E-07,0.406343E-07,-.125335E-07,-.126295E-07,0.225104E-06,
24581 &-.126468E-07,0.112639E-03,0.254145E-05,-.105595E-07,0.340280E-07,
24582 &-.104803E-07,-.105595E-07,0.170871E-06,-.105726E-07,0.883377E-04,
24583 &0.196395E-05,-.878062E-08,0.283380E-07,-.871555E-08,-.878062E-08,
24584 &0.129517E-06,-.879039E-08,0.000000E+00,0.000000E+00,0.000000E+00/
24585 DATA (DL(K),K= 3996, 4000) /
24586 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24587C
24588 ANS = 0.
24589 IF (X.GT.0.9985) RETURN
24590 IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
24591C
24592 IS = S/DELTA+1
24593 IS1 = IS+1
24594 DO 1 L=1,25
24595 KL = L+NDRV*25
24596 F1(L) = GF(I,IS,KL)
24597 F2(L) = GF(I,IS1,KL)
24598 1 CONTINUE
24599 A1 = DT_CKMTFF(X,F1)
24600 A2 = DT_CKMTFF(X,F2)
24601C A1=ALOG(A1)
24602C A2=ALOG(A2)
24603 S1 = (IS-1)*DELTA
24604 S2 = S1+DELTA
24605 ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
24606C ANS=EXP(ANS)
24607 RETURN
24608 END
24609C
24610
24611*$ CREATE DT_CKMTFF.FOR
24612*COPY DT_CKMTFF
24613 FUNCTION DT_CKMTFF(X,FVL)
24614C**********************************************************************
24615C
24616C LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
24617C FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
24618C NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
24619C IN MAIN ROUTINE.
24620C
24621C**********************************************************************
24622
24623 SAVE
24624 DIMENSION FVL(25),XGRID(25)
24625 DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
24626 *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
24627C
24628 DT_CKMTFF=0.
24629 DO 1 I=1,NX
24630 IF(X.LT.XGRID(I)) GO TO 2
24631 1 CONTINUE
24632 2 I=I-1
24633 IF(I.EQ.0) THEN
24634 I=I+1
24635 ELSE IF(I.GT.23) THEN
24636 I=23
24637 ENDIF
24638 J=I+1
24639 K=J+1
24640 AXI=LOG(XGRID(I))
24641 BXI=LOG(1.-XGRID(I))
24642 AXJ=LOG(XGRID(J))
24643 BXJ=LOG(1.-XGRID(J))
24644 AXK=LOG(XGRID(K))
24645 BXK=LOG(1.-XGRID(K))
24646 FI=LOG(ABS(FVL(I)) +1.E-15)
24647 FJ=LOG(ABS(FVL(J)) +1.E-16)
24648 FK=LOG(ABS(FVL(K)) +1.E-17)
24649 DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
24650 ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
24651 $ BXI))/DET
24652 ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
24653 BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
24654 IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
24655 1RETURN
24656C IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
24657C WRITE(6,2001) X,FVL
24658C 2001 FORMAT(8E12.4)
24659C WRITE(6,2001) ALPHA,BETA,ALOGA,DET
24660C ENDIF
24661 DT_CKMTFF=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
24662 RETURN
24663 END
24664
24665*$ CREATE DT_FLUINI.FOR
24666*COPY DT_FLUINI
24667*
24668*===fluini=============================================================*
24669*
24670 SUBROUTINE DT_FLUINI
24671
24672************************************************************************
24673* Initialisation of the nucleon-nucleon cross section fluctuation *
24674* treatment. The original version by J. Ranft. *
24675* This version dated 21.04.95 is revised by S. Roesler. *
24676************************************************************************
24677
24678 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24679 SAVE
24680 PARAMETER ( LINP = 10 ,
24681 & LOUT = 6 ,
24682 & LDAT = 9 )
24683 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
24684
24685 PARAMETER ( A = 0.1D0,
24686 & B = 0.893D0,
24687 & OM = 1.1D0,
24688 & N = 6,
24689 & DX = 0.003D0)
24690
24691* n-n cross section fluctuations
24692 PARAMETER (NBINS = 1000)
24693 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
24694 DIMENSION FLUSI(NBINS),FLUIX(NBINS)
24695
24696 WRITE(LOUT,1000)
24697 1000 FORMAT(/,1X,'FLUINI: hadronic cross section fluctuations ',
24698 & 'treated')
24699
24700 FLUSU = ZERO
24701 FLUSUU = ZERO
24702
24703 DO 1 I=1,NBINS
24704 X = DBLE(I)*DX
24705 FLUIX(I) = X
24706 FLUS = ((X-B)/(OM*B))**N
24707 IF (FLUS.LE.20.0D0) THEN
24708 FLUSI(I) = (X/B)*EXP(-FLUS)/(X/B+A)
24709 ELSE
24710 FLUSI(I) = ZERO
24711 ENDIF
24712 FLUSU = FLUSU+FLUSI(I)
24713 1 CONTINUE
24714 DO 2 I=1,NBINS
24715 FLUSUU = FLUSUU+FLUSI(I)/FLUSU
24716 FLUSI(I) = FLUSUU
24717 2 CONTINUE
24718
24719C WRITE(LOUT,1001)
24720C1001 FORMAT(1X,'FLUCTUATIONS')
24721C CALL PLOT(FLUIX,FLUSI,1000,1,1000,0.0D0,0.06D0,0.0D0,0.01D0)
24722
24723 DO 3 I=1,NBINS
24724 AF = DBLE(I)*0.001D0
24725 DO 4 J=1,NBINS
24726 IF (AF.LE.FLUSI(J)) THEN
24727 FLUIXX(I) = FLUIX(J)
24728 GOTO 5
24729 ENDIF
24730 4 CONTINUE
24731 5 CONTINUE
24732 3 CONTINUE
24733 FLUIXX(1) = FLUIX(1)
24734 FLUIXX(NBINS) = FLUIX(NBINS)
24735
24736 RETURN
24737 END
24738
24739*$ CREATE DT_SIGTBL.FOR
24740*COPY DT_SIGTBL
24741*
24742*===sigtab=============================================================*
24743*
24744 SUBROUTINE DT_SIGTBL(JP,JT,PTOT,SIGE,MODE)
24745
24746************************************************************************
24747* This version dated 18.11.95 is written by S. Roesler *
24748************************************************************************
24749
24750 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24751 SAVE
24752 PARAMETER ( LINP = 10 ,
24753 & LOUT = 6 ,
24754 & LDAT = 9 )
24755
24756 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24757 & OHALF=0.5D0,ONE=1.0D0)
24758 PARAMETER (PLO=0.01D0,PHI=20.0D0,NBINS=150)
24759
24760 LOGICAL LINIT
24761
24762* particle properties (BAMJET index convention)
24763 CHARACTER*8 ANAME
24764 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24765 & IICH(210),IIBAR(210),K1(210),K2(210)
24766
24767 DIMENSION SIGEP(5,NBINS+1),SIGEN(5,NBINS+1),IDSIG(23)
24768 DATA IDSIG / 1, 0, 0, 0, 0, 0, 0, 2, 0, 0,
24769 & 0, 0, 3, 4, 0, 0, 0, 0, 0, 0,
24770 & 0, 0, 5/
24771 DATA LINIT /.FALSE./
24772
24773* precalculation and tabulation of elastic cross sections
24774 IF (ABS(MODE).EQ.1) THEN
24775 IF (MODE.EQ.1)
24776 & OPEN(LDAT,FILE='outdata0/sigtab.out',STATUS='UNKNOWN')
24777 PLABLX = LOG10(PLO)
24778 PLABHX = LOG10(PHI)
24779 DPLAB = (PLABHX-PLABLX)/DBLE(NBINS)
24780 DO 1 I=1,NBINS+1
24781 PLAB = PLABLX+DBLE(I-1)*DPLAB
24782 PLAB = 10**PLAB
24783 DO 2 IPROJ=1,23
24784 IDX = IDSIG(IPROJ)
24785 IF (IDX.GT.0) THEN
24786C CALL DT_SIHNEL(IPROJ,1,PLAB,SIGEP(IDX,I))
24787C CALL DT_SIHNEL(IPROJ,8,PLAB,SIGEN(IDX,I))
24788 DUMZER = ZERO
24789 CALL DT_XSHN(IPROJ,1,PLAB,DUMZER,SIGTOT,SIGEP(IDX,I))
24790 CALL DT_XSHN(IPROJ,8,PLAB,DUMZER,SIGTOT,SIGEN(IDX,I))
24791 ENDIF
24792 2 CONTINUE
24793 IF (MODE.EQ.1) THEN
24794 WRITE(LDAT,1000) PLAB,(SIGEP(IDX,I),IDX=1,5),
24795 & (SIGEN(IDX,I),IDX=1,5)
24796 1000 FORMAT(F5.1,10F7.2)
24797 ENDIF
24798 1 CONTINUE
24799 IF (MODE.EQ.1) CLOSE(LDAT)
24800 LINIT = .TRUE.
24801 ELSE
24802 SIGE = -ONE
24803 IF (LINIT.AND.(JP.LE.23).AND.(PTOT.GE.PLO)
24804 & .AND.(PTOT.LE.PHI) ) THEN
24805 IDX = IDSIG(JP)
24806 IF ( (IDX.GT.0).AND.((JT.EQ.1).OR.(JT.EQ.8)) ) THEN
24807 PLABX = LOG10(PTOT)
24808 IF (PLABX.LE.PLABLX) THEN
24809 I1 = 1
24810 I2 = 1
24811 ELSEIF (PLABX.GE.PLABHX) THEN
24812 I1 = NBINS+1
24813 I2 = NBINS+1
24814 ELSE
24815 I1 = INT((PLABX-PLABLX)/DPLAB)+1
24816 I2 = I1+1
24817 ENDIF
24818 PLAB1X = PLABLX+DBLE(I1-1)*DPLAB
24819 PLAB2X = PLABLX+DBLE(I2-1)*DPLAB
24820 PBIN = PLAB2X-PLAB1X
24821 IF (PBIN.GT.TINY10) THEN
24822 RATX = (PLABX-PLAB1X)/(PLAB2X-PLAB1X)
24823 ELSE
24824 RATX = ZERO
24825 ENDIF
24826 IF (JT.EQ.1) THEN
24827 SIG1 = SIGEP(IDX,I1)
24828 SIG2 = SIGEP(IDX,I2)
24829 ELSE
24830 SIG1 = SIGEN(IDX,I1)
24831 SIG2 = SIGEN(IDX,I2)
24832 ENDIF
24833 SIGE = SIG1+RATX*(SIG2-SIG1)
24834 ENDIF
24835 ENDIF
24836 ENDIF
24837
24838 RETURN
24839 END
24840
24841*$ CREATE DT_XSTABL.FOR
24842*COPY DT_XSTABL
24843*
24844*===xstabl=============================================================*
24845*
24846 SUBROUTINE DT_XSTABL(WHAT,IXSQEL,IRATIO)
24847
24848 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24849 SAVE
24850 PARAMETER ( LINP = 10 ,
24851 & LOUT = 6 ,
24852 & LDAT = 9 )
24853 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24854 & OHALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
24855 LOGICAL LLAB,LELOG,LQLOG
24856
24857* particle properties (BAMJET index convention)
24858 CHARACTER*8 ANAME
24859 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24860 & IICH(210),IIBAR(210),K1(210),K2(210)
24861* properties of interacting particles
24862 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
24863 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
24864* Glauber formalism: cross sections
24865 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
24866 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
24867 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
24868 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
24869 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
24870 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
24871 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
24872 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
24873 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
24874 & BSLOPE,NEBINI,NQBINI
24875* emulsion treatment
24876 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
24877 & NCOMPO,IEMUL
24878
24879 DIMENSION WHAT(6)
24880
24881 LLAB = (WHAT(1).GT.ZERO).OR.(WHAT(2).GT.ZERO)
24882 ELO = ABS(WHAT(1))
24883 EHI = ABS(WHAT(2))
24884 IF (ELO.GT.EHI) ELO = EHI
24885 LELOG = WHAT(3).LT.ZERO
24886 NEBINS = MAX(INT(ABS(WHAT(3))),1)
24887 DEBINS = (EHI-ELO)/DBLE(NEBINS)
24888 IF (LELOG) THEN
24889 AELO = LOG10(ELO)
24890 AEHI = LOG10(EHI)
24891 ADEBIN = (AEHI-AELO)/DBLE(NEBINS)
24892 ENDIF
24893 Q2LO = WHAT(4)
24894 Q2HI = WHAT(5)
24895 IF (Q2LO.GT.Q2HI) Q2LO = Q2HI
24896 LQLOG = WHAT(6).LT.ZERO
24897 NQBINS = MAX(INT(ABS(WHAT(6))),1)
24898 DQBINS = (Q2HI-Q2LO)/DBLE(NQBINS)
24899 IF (LQLOG) THEN
24900 AQ2LO = LOG10(Q2LO)
24901 AQ2HI = LOG10(Q2HI)
24902 ADQBIN = (AQ2HI-AQ2LO)/DBLE(NQBINS)
24903 ENDIF
24904
24905 IF ( ELO.EQ. EHI) NEBINS = 0
24906 IF (Q2LO.EQ.Q2HI) NQBINS = 0
24907
24908 WRITE(LOUT,1000) ELO,EHI,LLAB,IXSQEL,Q2LO,Q2HI,IJPROJ,IP,IT
24909 1000 FORMAT(/,1X,'XSTABL: E_lo =',E10.3,' GeV E_hi =',E10.3,
24910 & ' GeV Lab = ',L1,' qel: ',I2,/,10X,'Q2_lo =',F10.5,
24911 & ' GeV^2 Q2_hi =',F10.5,' GeV^2',/,10X,'id_p = ',I2,
24912 & ' A_p = ',I3,' A_t = ',I3,/)
24913
24914C IF (IJPROJ.NE.7) THEN
24915 WRITE(LOUT,'(1X,A,/)')'(E,STOT,SELA,SQEP,SQET,SQE2,SINE,SPROD)'
24916* normalize fractions of emulsion components
24917 IF (NCOMPO.GT.0) THEN
24918 SUMFRA = ZERO
24919 DO 10 I=1,NCOMPO
24920 SUMFRA = SUMFRA+EMUFRA(I)
24921 10 CONTINUE
24922 IF (SUMFRA.GT.ZERO) THEN
24923 DO 11 I=1,NCOMPO
24924 EMUFRA(I) = EMUFRA(I)/SUMFRA
24925 11 CONTINUE
24926 ENDIF
24927 ENDIF
24928C ELSE
24929C WRITE(LOUT,'(1X,A,/)') '(Q2,E,STOT,ETOT,SIN,EIN,STOT0)'
24930C ENDIF
24931 DO 1 I=1,NEBINS+1
24932 IF (LELOG) THEN
24933 E = 10**(AELO+DBLE(I-1)*ADEBIN)
24934 ELSE
24935 E = ELO+DBLE(I-1)*DEBINS
24936 ENDIF
24937 DO 2 J=1,NQBINS+1
24938 IF (LQLOG) THEN
24939 Q2 = 10**(AQ2LO+DBLE(J-1)*ADQBIN)
24940 ELSE
24941 Q2 = Q2LO+DBLE(J-1)*DQBINS
24942 ENDIF
24943c IF (IJPROJ.NE.7) THEN
24944 IF (LLAB) THEN
24945 PLAB = ZERO
24946 ECM = ZERO
24947 CALL DT_LTINI(IJPROJ,1,E,PPN0,ECM,0)
24948 ELSE
24949 ECM = E
24950 ENDIF
24951 XI = ZERO
24952 Q2I = ZERO
24953 IF (IJPROJ.EQ.7) Q2I = Q2
24954 IF (NCOMPO.GT.0) THEN
24955 DO 20 IC=1,NCOMPO
24956 IIT = IEMUMA(IC)
24957 CALL DT_XSGLAU(IP,IIT,IJPROJ,XI,Q2I,ECM,1,1,-IC)
24958 20 CONTINUE
24959 ELSE
24960 CALL DT_XSGLAU(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,-1)
24961C CALL AMPLIT(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,1)
24962 ENDIF
24963 IF (NCOMPO.GT.0) THEN
24964 XTOT = ZERO
24965 ETOT = ZERO
24966 XELA = ZERO
24967 EELA = ZERO
24968 XQEP = ZERO
24969 EQEP = ZERO
24970 XQET = ZERO
24971 EQET = ZERO
24972 XQE2 = ZERO
24973 EQE2 = ZERO
24974 XPRO = ZERO
24975 EPRO = ZERO
24976 XPRO1= ZERO
24977 XDEL = ZERO
24978 EDEL = ZERO
24979 XDQE = ZERO
24980 EDQE = ZERO
24981 DO 21 IC=1,NCOMPO
24982 XTOT = XTOT+EMUFRA(IC)*XSTOT(1,1,IC)
24983 ETOT = ETOT+EMUFRA(IC)*XETOT(1,1,IC)**2
24984 XELA = XELA+EMUFRA(IC)*XSELA(1,1,IC)
24985 EELA = EELA+EMUFRA(IC)*XEELA(1,1,IC)**2
24986 XQEP = XQEP+EMUFRA(IC)*XSQEP(1,1,IC)
24987 EQEP = EQEP+EMUFRA(IC)*XEQEP(1,1,IC)**2
24988 XQET = XQET+EMUFRA(IC)*XSQET(1,1,IC)
24989 EQET = EQET+EMUFRA(IC)*XEQET(1,1,IC)**2
24990 XQE2 = XQE2+EMUFRA(IC)*XSQE2(1,1,IC)
24991 EQE2 = EQE2+EMUFRA(IC)*XEQE2(1,1,IC)**2
24992 XPRO = XPRO+EMUFRA(IC)*XSPRO(1,1,IC)
24993 EPRO = EPRO+EMUFRA(IC)*XEPRO(1,1,IC)**2
24994 XDEL = XDEL+EMUFRA(IC)*XSDEL(1,1,IC)
24995 EDEL = EDEL+EMUFRA(IC)*XEDEL(1,1,IC)**2
24996 XDQE = XDQE+EMUFRA(IC)*XSDQE(1,1,IC)
24997 EDQE = EDQE+EMUFRA(IC)*XEDQE(1,1,IC)**2
24998 YPRO = XSTOT(1,1,IC)-XSELA(1,1,IC)
24999 & -XSQEP(1,1,IC)-XSQET(1,1,IC)
25000 & -XSQE2(1,1,IC)
25001 XPRO1= XPRO1+EMUFRA(IC)*YPRO
25002 21 CONTINUE
25003 ETOT = SQRT(ETOT)
25004 EELA = SQRT(EELA)
25005 EQEP = SQRT(EQEP)
25006 EQET = SQRT(EQET)
25007 EQE2 = SQRT(EQE2)
25008 EPRO = SQRT(EPRO)
25009 EDEL = SQRT(EDEL)
25010 EDQE = SQRT(EDQE)
25011 WRITE(LOUT,'(8E9.3)')
25012 & E,XTOT,XELA,XQEP,XQET,XQE2,XPRO,XPRO1
25013C WRITE(LOUT,'(4E9.3)')
25014C & E,XDEL,XDQE,XDEL+XDQE
25015 ELSE
25016 WRITE(LOUT,'(11E10.3)')
25017 & E,
25018 & XSTOT(1,1,1),XSELA(1,1,1),XSQEP(1,1,1),XSQET(1,1,1),
25019 & XSQE2(1,1,1),XSPRO(1,1,1),
25020 & XSTOT(1,1,1)-XSELA(1,1,1)-XSQEP(1,1,1)-XSQET(1,1,1)
25021 & -XSQE2(1,1,1),XSDEL(1,1,1),XSDQE(1,1,1),
25022 & XSDEL(1,1,1)+XSDQE(1,1,1)
25023C WRITE(LOUT,'(4E9.3)') E,XSDEL(1,1,1),XSDQE(1,1,1),
25024C & XSDEL(1,1,1)+XSDQE(1,1,1)
25025 ENDIF
25026c ELSE
25027c IF (LLAB) THEN
25028c IF (IT.GT.1) THEN
25029c IF (IXSQEL.EQ.0) THEN
25030cC CALL DT_SIGGA(IT, Q2, E,ZERO,ZERO,
25031cC CALL DT_SIGGA(IT, E,Q2,ZERO,ZERO,
25032c CALL DT_SIGGA(IT,ZERO,Q2,ZERO,E,
25033c & STOT,ETOT,SIN,EIN,STOT0)
25034c IF (IRATIO.EQ.1) THEN
25035c CALL DT_SIGGP( Q2, E,ZERO,ZERO,STGP,SIGP,SDGP)
25036cC CALL DT_SIGGP( E,Q2,ZERO,ZERO,STGP,SIGP,SDGP)
25037cC CALL DT_SIGGP(ZERO,Q2,ZERO,E,STGP,SIGP,SDGP)
25038c*!! save cross sections
25039c STOTA = STOT
25040c ETOTA = ETOT
25041c STOTP = STGP
25042c*!!
25043c STOT = STOT/(DBLE(IT)*STGP)
25044c SIN = SIN/(DBLE(IT)*SIGP)
25045c STOT0 = STGP
25046c ETOT = ZERO
25047c EIN = ZERO
25048c ENDIF
25049c ELSE
25050c WRITE(LOUT,*)
25051c & ' XSTABL: qel. xs. not implemented for nuclei'
25052c STOP
25053c ENDIF
25054c ELSE
25055c ETOT = ZERO
25056c EIN = ZERO
25057c STOT0= ZERO
25058c IF (IXSQEL.EQ.0) THEN
25059c CALL DT_SIGGP(ZERO,Q2,ZERO,E,STOT,SIN,SDIR)
25060c ELSE
25061c SIN = ZERO
25062c CALL DT_SIGVEL(ZERO,Q2,ZERO,E,IXSQEL,STOT,SIN,STOT0)
25063c ENDIF
25064c ENDIF
25065c ELSE
25066c IF (IT.GT.1) THEN
25067c IF (IXSQEL.EQ.0) THEN
25068c CALL DT_SIGGA(IT,ZERO,Q2,E,ZERO,
25069c & STOT,ETOT,SIN,EIN,STOT0)
25070c IF (IRATIO.EQ.1) THEN
25071c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STGP,SIGP,SDGP)
25072c*!! save cross sections
25073c STOTA = STOT
25074c ETOTA = ETOT
25075c STOTP = STGP
25076c*!!
25077c STOT = STOT/(DBLE(IT)*STGP)
25078c SIN = SIN/(DBLE(IT)*SIGP)
25079c STOT0 = STGP
25080c ETOT = ZERO
25081c EIN = ZERO
25082c ENDIF
25083c ELSE
25084c WRITE(LOUT,*)
25085c & ' XSTABL: qel. xs. not implemented for nuclei'
25086c STOP
25087c ENDIF
25088c ELSE
25089c ETOT = ZERO
25090c EIN = ZERO
25091c STOT0= ZERO
25092c IF (IXSQEL.EQ.0) THEN
25093c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STOT,SIN,SDIR)
25094c ELSE
25095c SIN = ZERO
25096c CALL DT_SIGVEL(ZERO,Q2,E,ZERO,IXSQEL,STOT,SIN,STOT0)
25097c ENDIF
25098c ENDIF
25099c ENDIF
25100cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,STOTA,ETOTA,STOTP,ZERO
25101cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,SDIR
25102cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,STOT0
25103c WRITE(LOUT,'(1X,6E10.3)')Q2,E,STOT,ETOT,SIN,EIN
25104c ENDIF
25105 2 CONTINUE
25106 1 CONTINUE
25107
25108 RETURN
25109 END
25110
25111*$ CREATE DT_TESTXS.FOR
25112*COPY DT_TESTXS
25113*
25114*===testxs=============================================================*
25115*
25116 SUBROUTINE DT_TESTXS
25117
25118 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25119 SAVE
25120
25121 DIMENSION XSTOT(26,2),XSELA(26,2)
25122
25123 OPEN(10,FILE='testxs_ptot.out',STATUS='UNKNOWN')
25124 OPEN(11,FILE='testxs_pela.out',STATUS='UNKNOWN')
25125 OPEN(12,FILE='testxs_ntot.out',STATUS='UNKNOWN')
25126 OPEN(13,FILE='testxs_nela.out',STATUS='UNKNOWN')
25127 DUMECM = 0.0D0
25128 PLABL = 0.01D0
25129 PLABH = 10000.0D0
25130 NBINS = 120
25131 APLABL = LOG10(PLABL)
25132 APLABH = LOG10(PLABH)
25133 ADPLAB = (APLABH-APLABL)/DBLE(NBINS)
25134 DO 1 I=1,NBINS+1
25135 ADP = APLABL+DBLE(I-1)*ADPLAB
25136 P = 10.0D0**ADP
25137 DO 2 J=1,26
25138 CALL DT_XSHN(J,1,P,DUMECM,XSTOT(J,1),XSELA(J,1))
25139 CALL DT_XSHN(J,8,P,DUMECM,XSTOT(J,2),XSELA(J,2))
25140 2 CONTINUE
25141 WRITE(10,1000) P,(XSTOT(K,1),K=1,26)
25142 WRITE(11,1000) P,(XSELA(K,1),K=1,26)
25143 WRITE(12,1000) P,(XSTOT(K,2),K=1,26)
25144 WRITE(13,1000) P,(XSELA(K,2),K=1,26)
25145 1 CONTINUE
25146 1000 FORMAT(F8.3,26F9.3)
25147
25148 RETURN
25149 END
25150
25151************************************************************************
25152* *
25153* DTUNUC 2.0: library routines *
25154* processed by S. Roesler, 6.5.95 *
25155* *
25156************************************************************************
25157*
25158* 1) Handling of parton momenta
25159* SUBROUTINE MASHEL
25160* SUBROUTINE DFERMI
25161*
25162* 2) Handling of parton flavors and particle indices
25163* INTEGER FUNCTION IPDG2B
25164* INTEGER FUNCTION IB2PDG
25165* INTEGER FUNCTION IQUARK
25166* INTEGER FUNCTION IBJQUA
25167* INTEGER FUNCTION ICIHAD
25168* INTEGER FUNCTION IPDGHA
25169* INTEGER FUNCTION MCHAD
25170* SUBROUTINE FLAHAD
25171*
25172* 3) Energy-momentum and quantum number conservation check routines
25173* SUBROUTINE EMC1
25174* SUBROUTINE EMC2
25175* SUBROUTINE EVTEMC
25176* SUBROUTINE EVTFLC
25177* SUBROUTINE EVTCHG
25178*
25179* 4) Transformations
25180* SUBROUTINE LTINI
25181* SUBROUTINE LTRANS
25182* SUBROUTINE LTNUC
25183* SUBROUTINE DALTRA
25184* SUBROUTINE DTRAFO
25185* SUBROUTINE STTRAN
25186* SUBROUTINE MYTRAN
25187* SUBROUTINE LT2LAO
25188* SUBROUTINE LT2LAB
25189*
25190* 5) Sampling from distributions
25191* INTEGER FUNCTION NPOISS
25192* DOUBLE PRECISION FUNCTION SAMPXB
25193* DOUBLE PRECISION FUNCTION SAMPEX
25194* DOUBLE PRECISION FUNCTION SAMSQX
25195* DOUBLE PRECISION FUNCTION BETREJ
25196* DOUBLE PRECISION FUNCTION DGAMRN
25197* DOUBLE PRECISION FUNCTION DBETAR
25198* SUBROUTINE RANNOR
25199* SUBROUTINE DPOLI
25200* SUBROUTINE DSFECF
25201* SUBROUTINE RACO
25202*
25203* 6) Special functions, algorithms and service routines
25204* DOUBLE PRECISION FUNCTION YLAMB
25205* SUBROUTINE SORT
25206* SUBROUTINE SORT1
25207* SUBROUTINE DT_XTIME
25208*
25209* 7) Random number generator package
25210* DOUBLE PRECISION FUNCTION DT_RNDM
25211* SUBROUTINE DT_RNDMST
25212* SUBROUTINE DT_RNDMIN
25213* SUBROUTINE DT_RNDMOU
25214* SUBROUTINE DT_RNDMTE
25215*
25216************************************************************************
25217* *
25218* 1) Handling of parton momenta *
25219* *
25220************************************************************************
25221*$ CREATE DT_MASHEL.FOR
25222*COPY DT_MASHEL
25223*
25224*===mashel=============================================================*
25225*
25226 SUBROUTINE DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
25227
25228************************************************************************
25229* *
25230* rescaling of momenta of two partons to put both *
25231* on mass shell *
25232* *
25233* input: PA1,PA2 input momentum vectors *
25234* XM1,2 desired masses of particles afterwards *
25235* P1,P2 changed momentum vectors *
25236* *
25237* The original version is written by R. Engel. *
25238* This version dated 12.12.94 is modified by S. Roesler. *
25239************************************************************************
25240
25241 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25242 SAVE
25243 PARAMETER ( LINP = 10 ,
25244 & LOUT = 6 ,
25245 & LDAT = 9 )
25246 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
25247
25248 DIMENSION PA1(4),PA2(4),P1(4),P2(4)
25249
25250 IREJ = 0
25251
25252* Lorentz transformation into system CMS
25253 PX = PA1(1)+PA2(1)
25254 PY = PA1(2)+PA2(2)
25255 PZ = PA1(3)+PA2(3)
25256 EE = PA1(4)+PA2(4)
25257 XPTOT = SQRT(PX**2+PY**2+PZ**2)
25258 XMS = (EE-XPTOT)*(EE+XPTOT)
25259 IF(XMS.LT.(XM1+XM2)**2) THEN
25260C WRITE(LOUT,'(3E12.4)')XMS,XM1,XM2
25261 GOTO 9999
25262 ENDIF
25263 XMS = SQRT(XMS)
25264 BGX = PX/XMS
25265 BGY = PY/XMS
25266 BGZ = PZ/XMS
25267 GAM = EE/XMS
25268 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
25269 & PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
25270* rotation angles
25271 COD = P1(3)/PTOT1
25272C SID = SQRT((ONE-COD)*(ONE+COD))
25273 PPT = SQRT(P1(1)**2+P1(2)**2)
25274 SID = PPT/PTOT1
25275 COF = ONE
25276 SIF = ZERO
25277 IF(PTOT1*SID.GT.TINY10) THEN
25278 COF = P1(1)/(SID*PTOT1)
25279 SIF = P1(2)/(SID*PTOT1)
25280 ANORF = SQRT(COF*COF+SIF*SIF)
25281 COF = COF/ANORF
25282 SIF = SIF/ANORF
25283 ENDIF
25284* new CM momentum and energies (for masses XM1,XM2)
25285 XM12 = SIGN(XM1**2,XM1)
25286 XM22 = SIGN(XM2**2,XM2)
25287 SS = XMS**2
25288 PCMP = DT_YLAMB(SS,XM12,XM22)/(2.D0*XMS)
25289 EE1 = SQRT(XM12+PCMP**2)
25290 EE2 = XMS-EE1
25291* back rotation
25292 MODE = 1
25293 CALL DT_MYTRAN(MODE,ZERO,ZERO,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
25294 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
25295 & PTOT1,P1(1),P1(2),P1(3),P1(4))
25296 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
25297 & PTOT2,P2(1),P2(2),P2(3),P2(4))
25298* check consistency
25299 DEL = XMS*0.0001D0
25300 IF (ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
25301 IDEV = 1
25302 ELSEIF (ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
25303 IDEV = 2
25304 ELSEIF (ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
25305 IDEV = 3
25306 ELSEIF (ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
25307 IDEV = 4
25308 ELSE
25309 IDEV = 0
25310 ENDIF
25311 IF (IDEV.NE.0) THEN
25312 WRITE(LOUT,'(/1X,A,I3)')
25313 & 'MASHEL: inconsistent transformation',IDEV
25314 WRITE(LOUT,'(1X,A)') 'MASHEL: input momenta/masses:'
25315 WRITE(LOUT,'(1X,5E12.5)') (PA1(K),K=1,4),XM1
25316 WRITE(LOUT,'(1X,5E12.5)') (PA2(K),K=1,4),XM2
25317 WRITE(LOUT,'(1X,A)') 'MASHEL: output momenta:'
25318 WRITE(LOUT,'(5X,4E12.5)') (P1(K),K=1,4)
25319 WRITE(LOUT,'(5X,4E12.5)') (P2(K),K=1,4)
25320 ENDIF
25321 RETURN
25322
25323 9999 CONTINUE
25324 IREJ = 1
25325 RETURN
25326 END
25327
25328*$ CREATE DT_DFERMI.FOR
25329*COPY DT_DFERMI
25330*
25331*===dfermi=============================================================*
25332*
25333 SUBROUTINE DT_DFERMI(GPART)
25334
25335************************************************************************
25336* Find largest of three random numbers. *
25337************************************************************************
25338
25339 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25340 SAVE
25341
25342 DIMENSION G(3)
25343
25344 DO 10 I=1,3
25345 G(I)=DT_RNDM(GPART)
25346 10 CONTINUE
25347 IF (G(3).LT.G(2)) GOTO 40
25348 IF (G(3).LT.G(1)) GOTO 30
25349 GPART = G(3)
25350 20 RETURN
25351 30 GPART = G(1)
25352 GOTO 20
25353 40 IF (G(2).LT.G(1)) GOTO 30
25354 GPART = G(2)
25355 GOTO 20
25356
25357 END
25358
25359************************************************************************
25360* *
25361* 2) Handling of parton flavors and particle indices *
25362* *
25363************************************************************************
25364*$ CREATE IDT_IPDG2B.FOR
25365*COPY IDT_IPDG2B
25366*
25367*===ipdg2b=============================================================*
25368*
25369 INTEGER FUNCTION IDT_IPDG2B(ID,NN,MODE)
25370
25371************************************************************************
25372* *
25373* conversion of quark numbering scheme *
25374* *
25375* input: PDG parton numbering *
25376* for diquarks: NN number of the constituent quark *
25377* (e.g. ID=2301,NN=1 -> ICONV2=1) *
25378* *
25379* output: BAMJET particle codes *
25380* 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) *
25381* 2 d 8 a-d -2 a-d *
25382* 3 s 9 a-s -3 a-s *
25383* 4 c 10 a-c -4 a-c *
25384* *
25385* This is a modified version of ICONV2 written by R. Engel. *
25386* This version dated 13.12.94 is written by S. Roesler. *
25387************************************************************************
25388
25389 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25390 SAVE
25391 PARAMETER ( LINP = 10 ,
25392 & LOUT = 6 ,
25393 & LDAT = 9 )
25394
25395 IDA = ABS(ID)
25396* diquarks
25397 IF (IDA.GT.6) THEN
25398 KF = 3
25399 IF (IDA.GE.1000) KF = 4
25400 IDA = IDA/(10**(KF-NN))
25401 IDA = MOD(IDA,10)
25402 ENDIF
25403* exchange up and dn quarks
25404 IF (IDA.EQ.1) THEN
25405 IDA = 2
25406 ELSEIF (IDA.EQ.2) THEN
25407 IDA = 1
25408 ENDIF
25409* antiquarks
25410 IF (ID.LT.0) THEN
25411 IF (MODE.EQ.1) THEN
25412 IDA = IDA+6
25413 ELSE
25414 IDA = -IDA
25415 ENDIF
25416 ENDIF
25417 IDT_IPDG2B = IDA
25418
25419 RETURN
25420 END
25421
25422*$ CREATE IDT_IB2PDG.FOR
25423*COPY IDT_IB2PDG
25424*
25425*===ib2pdg=============================================================*
25426*
25427 INTEGER FUNCTION IDT_IB2PDG(ID1,ID2,MODE)
25428
25429************************************************************************
25430* *
25431* conversion of quark numbering scheme *
25432* *
25433* input: BAMJET particle codes *
25434* 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) *
25435* 2 d 8 a-d -2 a-d *
25436* 3 s 9 a-s -3 a-s *
25437* 4 c 10 a-c -4 a-c *
25438* *
25439* output: PDG parton numbering *
25440* *
25441* This version dated 13.12.94 is written by S. Roesler. *
25442************************************************************************
25443
25444 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25445 SAVE
25446 PARAMETER ( LINP = 10 ,
25447 & LOUT = 6 ,
25448 & LDAT = 9 )
25449
25450 DIMENSION IHKKQ(-6:6),IHKKQQ(-3:3,-3:3)
25451 DATA IHKKQ/-6,-5,-4,-3,-1,-2,0,2,1,3,4,5,6/
25452 DATA IHKKQQ/-3303,-3103,-3203,0,0,0,0, -3103,-1103,-2103,0,0,0,0,
25453 &-3203,-2103,-2203,0,0,0,0, 0,0,0,0,0,0,0, 0,0,0,0,2203,2103,3203,
25454 &0,0,0,0,2103,1103,3103, 0,0,0,0,3203,3103,3303/
25455
25456 IDA = ID1
25457 IDB = ID2
25458 IF (MODE.EQ.1) THEN
25459 IF (ID1.GT.6) IDA = -(ID1-6)
25460 IF (ID2.GT.6) IDB = -(ID2-6)
25461 ENDIF
25462 IF (ID2.EQ.0) THEN
25463 IDT_IB2PDG = IHKKQ(IDA)
25464 ELSE
25465 IDT_IB2PDG = IHKKQQ(IDA,IDB)
25466 ENDIF
25467
25468 RETURN
25469 END
25470
25471*$ CREATE IDT_IQUARK.FOR
25472*COPY IDT_IQUARK
25473*
25474*===ipdgqu=============================================================*
25475*
25476 INTEGER FUNCTION IDT_IQUARK(K,IDBAMJ)
25477
25478************************************************************************
25479* *
25480* quark contents according to PDG conventions *
25481* (random selection in case of quark mixing) *
25482* *
25483* input: IDBAMJ BAMJET particle code *
25484* K 1..3 quark number *
25485* *
25486* output: 1 d (anti --> neg.) *
25487* 2 u *
25488* 3 s *
25489* 4 c *
25490* *
25491* This version written by R. Engel. *
25492************************************************************************
25493
25494 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25495 SAVE
25496
25497 IQ = IDT_IBJQUA(K,IDBAMJ)
25498* quark-antiquark
25499 IF (IQ.GT.6) THEN
25500 IQ = 6-IQ
25501 ENDIF
25502* exchange of up and down
25503 IF (ABS(IQ).EQ.1) THEN
25504 IQ = SIGN(2,IQ)
25505 ELSEIF (ABS(IQ).EQ.2) THEN
25506 IQ = SIGN(1,IQ)
25507 ENDIF
25508 IDT_IQUARK = IQ
25509
25510 RETURN
25511 END
25512
25513*$ CREATE IDT_IBJQUA.FOR
25514*COPY IDT_IBJQUA
25515*
25516*===ibamq==============================================================*
25517*
25518 INTEGER FUNCTION IDT_IBJQUA(K,IDBAMJ)
25519
25520************************************************************************
25521* *
25522* quark contents according to BAMJET conventions *
25523* (random selection in case of quark mixing) *
25524* *
25525* input: IDBAMJ BAMJET particle code *
25526* K 1..3 quark number *
25527* *
25528* output: 1 u 7 u bar *
25529* 2 d 8 d bar *
25530* 3 s 9 s bar *
25531* 4 c 10 c bar *
25532* *
25533* This version written by R. Engel. *
25534************************************************************************
25535
25536 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25537 SAVE
25538
25539 DIMENSION ITAB(3,210)
25540 DATA ((ITAB(I,K),I=1,3),K=1,30) /
25541 & 1, 1, 2, 7, 7, 8, 0, 0, 0,
25542 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25543 & 0, 0, 0, 1, 2, 2, 7, 8, 8,
25544*sr 10.1.94
25545C & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25546 & 0, 0, 0, 0, 0, 0, 3, 8, 0,
25547*
25548 & 1, 8, 0, 2, 7, 0, 1, 9, 0,
25549*sr 10.1.94
25550C & 3, 7, 0, 0, 0, 0, 0, 0, 0,
25551 & 3, 7, 0, 3, 1, 2, 9, 7, 8,
25552*sr 10.1.94
25553C & 0, 0, 0, 2, 2, 3, 1, 1, 3,
25554 & 2, 9, 0, 2, 2, 3, 1, 1, 3,
25555*
25556 & 1, 2, 3, 201,202, 0, 2, 9, 0,
25557 & 3, 8, 0, 0, 0, 0, 0, 0, 0,
25558 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25559 DATA ((ITAB(I,K),I=1,3),K=31,60) /
25560 & 3, 9, 0, 1, 8, 0, 203,204, 0,
25561 & 2, 7, 0, 0, 0, 0, 1, 9, 0,
25562 & 2, 9, 0, 3, 7, 0, 3, 8, 0,
25563 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25564 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25565 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25566 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25567 & 0, 0, 0, 1, 1, 1, 1, 1, 2,
25568 & 1, 2, 2, 2, 2, 2, 0, 0, 0,
25569 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25570 DATA ((ITAB(I,K),I=1,3),K=61,90) /
25571 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25572 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25573 & 7, 7, 7, 7, 7, 8, 7, 8, 8,
25574 & 8, 8, 8, 0, 0, 0, 0, 0, 0,
25575 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25576 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25577 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25578 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25579 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25580 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25581 DATA ((ITAB(I,K),I=1,3),K=91,120) /
25582 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25583 & 0, 0, 0, 0, 0, 0, 3, 9, 0,
25584 & 1, 3, 3, 2, 3, 3, 7, 7, 9,
25585 & 7, 8, 9, 8, 8, 9, 7, 9, 9,
25586 & 8, 9, 9, 1, 1, 3, 1, 2, 3,
25587 & 2, 2, 3, 1, 3, 3, 2, 3, 3,
25588 & 3, 3, 3, 7, 7, 9, 7, 8, 9,
25589 & 8, 8, 9, 7, 9, 9, 8, 9, 9,
25590 & 9, 9, 9, 4, 7, 0, 4, 8, 0,
25591 & 2, 10, 0, 1, 10, 0, 4, 9, 0 /
25592 DATA ((ITAB(I,K),I=1,3),K=121,150) /
25593 & 3, 10, 0, 4, 10, 0, 4, 7, 0,
25594 & 4, 8, 0, 2, 10, 0, 1, 10, 0,
25595 & 4, 9, 0, 3, 10, 0, 4, 10, 0,
25596 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25597 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25598 & 0, 0, 0, 1, 2, 4, 1, 3, 4,
25599 & 2, 3, 4, 1, 1, 4, 0, 0, 0,
25600 & 2, 2, 4, 0, 0, 0, 0, 0, 0,
25601 & 3, 3, 4, 1, 4, 4, 2, 4, 4,
25602 & 3, 4, 4, 7, 8, 10, 7, 9, 10 /
25603 DATA ((ITAB(I,K),I=1,3),K=151,180) /
25604 & 8, 9, 10, 7, 7, 10, 0, 0, 0,
25605 & 8, 8, 10, 0, 0, 0, 0, 0, 0,
25606 & 9, 9, 10, 7, 10, 10, 8, 10, 10,
25607 & 9, 10, 10, 1, 1, 4, 1, 2, 4,
25608 & 2, 2, 4, 1, 3, 4, 2, 3, 4,
25609 & 3, 3, 4, 1, 4, 4, 2, 4, 4,
25610 & 3, 4, 4, 4, 4, 4, 7, 7, 10,
25611 & 7, 8, 10, 8, 8, 10, 7, 9, 10,
25612 & 8, 9, 10, 9, 9, 10, 7, 10, 10,
25613 & 8, 10, 10, 9, 10, 10, 10, 10, 10 /
25614 DATA ((ITAB(I,K),I=1,3),K=181,210) /
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 & 0, 0, 0, 0, 0, 0, 1, 7, 0,
25622 & 2, 8, 0, 1, 7, 0, 2, 8, 0,
25623 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25624 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25625 DATA IDOLD /0/
25626
25627 ONE = 1.0D0
25628 IF (ITAB(1,IDBAMJ).LE.200) THEN
25629 ID = ITAB(K,IDBAMJ)
25630 ELSE
25631 IF(IDOLD.NE.IDBAMJ) THEN
25632 IT = AINT((ITAB(2,IDBAMJ)-ITAB(1,IDBAMJ)+0.999999D0)*
25633 & DT_RNDM(ONE)+ITAB(1,IDBAMJ))
25634 ELSE
25635 IDOLD = 0
25636 ENDIF
25637 ID = ITAB(K,IT)
25638 ENDIF
25639 IDOLD = IDBAMJ
25640 IDT_IBJQUA = ID
25641
25642 RETURN
25643 END
25644
25645*$ CREATE IDT_ICIHAD.FOR
25646*COPY IDT_ICIHAD
25647*
25648*===icihad=============================================================*
25649*
25650 INTEGER FUNCTION IDT_ICIHAD(MCIND)
25651
25652************************************************************************
25653* Conversion of particle index PDG proposal --> BAMJET-index scheme *
25654* This is a completely new version dated 25.10.95. *
25655* Renamed to be not in conflict with the modified PHOJET-version *
25656************************************************************************
25657
25658 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25659 SAVE
25660
25661* hadron index conversion (BAMJET <--> PDG)
25662 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25663 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25664 & IAMCIN(210)
25665
25666 IDT_ICIHAD = 0
25667 KPDG = ABS(MCIND)
25668 IF ((KPDG.EQ.0).OR.(KPDG.GT.70000)) RETURN
25669 IF (MCIND.LT.0) THEN
25670 JSIGN = 1
25671 ELSE
25672 JSIGN = 2
25673 ENDIF
25674 IF (KPDG.GE.10000) THEN
25675 DO 1 I=1,19
25676 IDT_ICIHAD = IBAM5(JSIGN,I)
25677 IF (IPDG5(JSIGN,I).EQ.MCIND) GOTO 5
25678 IDT_ICIHAD = 0
25679 1 CONTINUE
25680 ELSEIF (KPDG.GE.1000) THEN
25681 DO 2 I=1,29
25682 IDT_ICIHAD = IBAM4(JSIGN,I)
25683 IF (IPDG4(JSIGN,I).EQ.MCIND) GOTO 5
25684 IDT_ICIHAD = 0
25685 2 CONTINUE
25686 ELSEIF (KPDG.GE.100) THEN
25687 DO 3 I=1,22
25688 IDT_ICIHAD = IBAM3(JSIGN,I)
25689 IF (IPDG3(JSIGN,I).EQ.MCIND) GOTO 5
25690 IDT_ICIHAD = 0
25691 3 CONTINUE
25692 ELSEIF (KPDG.GE.10) THEN
25693 DO 4 I=1,7
25694 IDT_ICIHAD = IBAM2(JSIGN,I)
25695 IF (IPDG2(JSIGN,I).EQ.MCIND) GOTO 5
25696 IDT_ICIHAD = 0
25697 4 CONTINUE
25698 ENDIF
25699 5 CONTINUE
25700
25701 RETURN
25702 END
25703
25704*$ CREATE IDT_IPDGHA.FOR
25705*COPY IDT_IPDGHA
25706*
25707*===ipdgha=============================================================*
25708*
25709 INTEGER FUNCTION IDT_IPDGHA(MCIND)
25710
25711************************************************************************
25712* Conversion of particle index BAMJET-index scheme --> PDG proposal *
25713* Adopted from the original by S. Roesler. This version dated 12.5.95 *
25714* Renamed to be not in conflict with the modified PHOJET-version *
25715************************************************************************
25716
25717 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25718 SAVE
25719
25720* hadron index conversion (BAMJET <--> PDG)
25721 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25722 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25723 & IAMCIN(210)
25724
25725 IDT_IPDGHA = IAMCIN(MCIND)
25726
25727 RETURN
25728 END
25729
25730*$ CREATE DT_FLAHAD.FOR
25731*COPY DT_FLAHAD
25732*
25733*===flahad=============================================================*
25734*
25735 SUBROUTINE DT_FLAHAD(ID,IF1,IF2,IF3)
25736
25737************************************************************************
25738* sampling of FLAvor composition for HADrons/photons *
25739* ID BAMJET-id of hadron *
25740* IF1,2,3 flavor content *
25741* (u,d,s: 1,2,3; au,ad,as: -1,-1,-3) *
25742* Note: - u,d numbering as in BAMJET *
25743* - ID .le. 30 !! *
25744* This version dated 12.03.96 is written by S. Roesler *
25745************************************************************************
25746
25747 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25748 SAVE
25749
25750* auxiliary common for reggeon exchange (DTUNUC 1.x)
25751 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
25752 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
25753 & IQTCHR(-6:6),MQUARK(3,39)
25754
25755 DIMENSION JSEL(3,6)
25756 DATA JSEL/ 1,2,3, 2,3,1, 3,1,2, 1,3,2, 2,1,3, 3,2,1/
25757
25758 ONE = 1.0D0
25759 IF (ID.EQ.7) THEN
25760* photon (charge dependent flavour sampling)
25761 K = INT(DT_RNDM(ONE)*6.D0+1.D0)
25762 IF (K.LE.4) THEN
25763 IF1 = 2
25764 IF2 = -2
25765 ELSE IF(K.EQ.5) THEN
25766 IF1 = 1
25767 IF2 = -1
25768 ELSE
25769 IF1 = 3
25770 IF2 = -3
25771 ENDIF
25772 IF(DT_RNDM(ONE).LT.0.5D0) THEN
25773 K = IF1
25774 IF1 = IF2
25775 IF2 = K
25776 ENDIF
25777 IF3 = 0
25778 ELSE
25779* hadron
25780 IX = INT(1.0D0+5.99999D0*DT_RNDM(ONE))
25781 IF1 = MQUARK(JSEL(1,IX),ID)
25782 IF2 = MQUARK(JSEL(2,IX),ID)
25783 IF3 = MQUARK(JSEL(3,IX),ID)
25784 IF ((IF1.EQ.0).AND.(IF3.NE.0)) THEN
25785 IF1 = IF3
25786 IF3 = 0
25787 ELSEIF ((IF2.EQ.0).AND.(IF3.NE.0)) THEN
25788 IF2 = IF3
25789 IF3 = 0
25790 ENDIF
25791 ENDIF
25792
25793 RETURN
25794 END
25795
25796*$ CREATE IDT_MCHAD.FOR
25797*COPY IDT_MCHAD
25798*
25799*===mchad==============================================================*
25800*
25801 INTEGER FUNCTION IDT_MCHAD(ITDTU)
25802
25803************************************************************************
25804* Conversion of particle index BAMJET-index scheme --> HADRIN index s. *
25805* Adopted from the original by S. Roesler. This version dated 6.5.95 *
25806* *
25807* Last change 28.12.2006 by S. Roesler. *
25808************************************************************************
25809
25810 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25811 SAVE
25812
25813 DIMENSION ITRANS(210)
25814 DATA ITRANS / 1, 2, -1, -1, -1, -1, -1, 8, 9, -1, -1, 24, 13, 14,
25815 &15, 16, 8, 9, 25, 8, 1, 8, 23, 24, 25, -1, -1, -1, -1, -1, 23, 13,
25816 &23, 14, 23, 15, 24, 16, 25, 15, 24, 16, 25, 15, 24, 16, 25, 1, 8,
25817 &8, 8, 1, 1, 1, 8, 8, 1, 1, 8, 8, 1, 8, 1, 8, 1, 8, 2, 2, 9, 9, 2,
25818 &2, 9, 9, 2, 9, 1, 13, 23, 14, 1, 1, 8, 8, 1, 1, 23, 14, 1, 8, 1,
25819 &8, 1, 8, 23, 23, 8, 8, 2, 9, 9, 9, 9, 1, 8, 8, 8, 8, 8, 2, 9, 9,
25820 &9, 9, 9, 85*- 1,7*-1,1,8,-1/
25821
25822 IF ( ITDTU .GT. 0 ) THEN
25823 IDT_MCHAD = ITRANS(ITDTU)
25824 ELSE
25825 IDT_MCHAD = -1
25826 END IF
25827
25828 RETURN
25829 END
25830
25831************************************************************************
25832* *
25833* 3) Energy-momentum and quantum number conservation check routines *
25834* *
25835************************************************************************
25836*$ CREATE DT_EMC1.FOR
25837*COPY DT_EMC1
25838*
25839*===emc1===============================================================*
25840*
25841 SUBROUTINE DT_EMC1(PP1,PP2,PT1,PT2,MODE,IPOS,IREJ)
25842
25843************************************************************************
25844* This version dated 15.12.94 is written by S. Roesler *
25845************************************************************************
25846
25847 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25848 SAVE
25849 PARAMETER ( LINP = 10 ,
25850 & LOUT = 6 ,
25851 & LDAT = 9 )
25852 PARAMETER (TINY10=1.0D-10)
25853
25854 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
25855
25856 IREJ = 0
25857
25858 IF ((MODE.EQ.0).OR.(ABS(MODE).GT.3))
25859 & WRITE(LOUT,'(1X,A,I6)')'EMC1: not supported MODE ',MODE
25860
25861 IF ((MODE.GT.0).AND.(MODE.LT.3)) THEN
25862 IF (MODE.EQ.1) THEN
25863 CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),1,IDUM,IDUM)
25864 ELSEIF (MODE.EQ.2) THEN
25865 CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),2,IDUM,IDUM)
25866 ENDIF
25867 CALL DT_EVTEMC(PP2(1),PP2(2),PP2(3),PP2(4),2,IDUM,IDUM)
25868 CALL DT_EVTEMC(PT1(1),PT1(2),PT1(3),PT1(4),2,IDUM,IDUM)
25869 CALL DT_EVTEMC(PT2(1),PT2(2),PT2(3),PT2(4),2,IDUM,IDUM)
25870 ELSEIF (MODE.LT.0) THEN
25871 IF (MODE.EQ.-1) THEN
25872 CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),1,IDUM,IDUM)
25873 ELSEIF (MODE.EQ.-2) THEN
25874 CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),2,IDUM,IDUM)
25875 ENDIF
25876 CALL DT_EVTEMC(-PP2(1),-PP2(2),-PP2(3),-PP2(4),2,IDUM,IDUM)
25877 CALL DT_EVTEMC(-PT1(1),-PT1(2),-PT1(3),-PT1(4),2,IDUM,IDUM)
25878 CALL DT_EVTEMC(-PT2(1),-PT2(2),-PT2(3),-PT2(4),2,IDUM,IDUM)
25879 ENDIF
25880
25881 IF (ABS(MODE).EQ.3) THEN
25882 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,IPOS,IREJ1)
25883 IF (IREJ1.NE.0) GOTO 9999
25884 ENDIF
25885 RETURN
25886
25887 9999 CONTINUE
25888 IREJ = 1
25889 RETURN
25890 END
25891
25892*$ CREATE DT_EMC2.FOR
25893*COPY DT_EMC2
25894*
25895*===emc2===============================================================*
25896*
25897 SUBROUTINE DT_EMC2(IP1,IP2,IP3,IP4,IP5,MP,IN1,IN2,IN3,IN4,IN5,MN,
25898 & MODE,IPOS,IREJ)
25899
25900************************************************************************
25901* MODE = 1 energy-momentum cons. check *
25902* = 2 flavor-cons. check *
25903* = 3 energy-momentum & flavor cons. check *
25904* = 4 energy-momentum & charge cons. check *
25905* = 5 energy-momentum & flavor & charge cons. check *
25906* This version dated 16.01.95 is written by S. Roesler *
25907************************************************************************
25908
25909 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25910 SAVE
25911 PARAMETER ( LINP = 10 ,
25912 & LOUT = 6 ,
25913 & LDAT = 9 )
25914 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
25915
25916* event history
25917 PARAMETER (NMXHKK=200000)
25918 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25919 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25920 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25921* extended event history
25922 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
25923 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
25924 & IHIST(2,NMXHKK)
25925
25926 IREJ = 0
25927 IREJ1 = 0
25928 IREJ2 = 0
25929 IREJ3 = 0
25930
25931 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25932 & CALL DT_EVTEMC(ZERO,ZERO,ZERO,ZERO,1,IDUM,IDUM)
25933 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25934 & CALL DT_EVTFLC(0,IDUM,1,IDUM,IDUM)
25935 IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,1,IDUM,IDUM)
25936 DO 1 I=1,NHKK
25937 IF ((ISTHKK(I).EQ.IP1).OR.(ISTHKK(I).EQ.IP2).OR.
25938 & (ISTHKK(I).EQ.IP3).OR.(ISTHKK(I).EQ.IP4).OR.
25939 & (ISTHKK(I).EQ.IP5)) THEN
25940 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25941 & .OR.(MODE.EQ.5))
25942 & CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
25943 & 2,IDUM,IDUM)
25944 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25945 & CALL DT_EVTFLC(IDHKK(I),MP,2,IDUM,IDUM)
25946 IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25947 & CALL DT_EVTCHG(IDHKK(I),2,IDUM,IDUM)
25948 ENDIF
25949 IF ((ISTHKK(I).EQ.IN1).OR.(ISTHKK(I).EQ.IN2).OR.
25950 & (ISTHKK(I).EQ.IN3).OR.(ISTHKK(I).EQ.IN4).OR.
25951 & (ISTHKK(I).EQ.IN5)) THEN
25952 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25953 & .OR.(MODE.EQ.5))
25954 & CALL DT_EVTEMC(-PHKK(1,I),-PHKK(2,I),-PHKK(3,I),-PHKK(4,I),
25955 & 2,IDUM,IDUM)
25956 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25957 & CALL DT_EVTFLC(IDHKK(I),MN,-2,IDUM,IDUM)
25958 IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25959 & CALL DT_EVTCHG(IDHKK(I),-2,IDUM,IDUM)
25960 ENDIF
25961 1 CONTINUE
25962 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25963 & CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,IPOS,IREJ1)
25964 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25965 & CALL DT_EVTFLC(0,IDUM,3,IPOS,IREJ2)
25966 IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,3,IPOS,IREJ3)
25967 IF ((IREJ1.NE.0).OR.(IREJ2.NE.0).OR.(IREJ3.NE.0)) GOTO 9999
25968
25969 RETURN
25970
25971 9999 CONTINUE
25972 IREJ = 1
25973 RETURN
25974 END
25975
25976*$ CREATE DT_EVTEMC.FOR
25977*COPY DT_EVTEMC
25978*
25979*===evtemc=============================================================*
25980*
25981 SUBROUTINE DT_EVTEMC(PXIO,PYIO,PZIO,EIO,IMODE,IPOS,IREJ)
25982
25983************************************************************************
25984* This version dated 13.12.94 is written by S. Roesler *
25985************************************************************************
25986
25987 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25988 SAVE
25989 PARAMETER ( LINP = 10 ,
25990 & LOUT = 6 ,
25991 & LDAT = 9 )
25992 PARAMETER (TINY1=1.0D-1,TINY2=1.0D-2,TINY4=1.0D-4,TINY10=1.0D-10,
25993 & ZERO=0.0D0)
25994
25995* event history
25996 PARAMETER (NMXHKK=200000)
25997 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25998 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25999 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26000* flags for input different options
26001 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
26002 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
26003 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
26004
26005 IREJ = 0
26006
26007 MODE = IMODE
26008 CHKLEV = TINY10
26009 IF (MODE.EQ.4) THEN
26010 CHKLEV = TINY2
26011 MODE = 3
26012 ELSEIF (MODE.EQ.5) THEN
26013 CHKLEV = TINY1
26014 MODE = 3
26015 ELSEIF (MODE.EQ.-1) THEN
26016 CHKLEV = EIO
26017 MODE = 3
26018 ENDIF
26019
26020 IF (ABS(MODE).EQ.3) THEN
26021 PXDEV = PX
26022 PYDEV = PY
26023 PZDEV = PZ
26024 EDEV = E
26025 IF ((IFRAG(1).EQ.2).AND.(CHKLEV.LT.TINY4)) CHKLEV = TINY4
26026 IF ((ABS(PXDEV).GT.CHKLEV).OR.(ABS(PYDEV).GT.CHKLEV).OR.
26027 & (ABS(PZDEV).GT.CHKLEV).OR.(ABS(EDEV).GT.CHKLEV)) THEN
26028 IF (IOULEV(2).GT.0) WRITE(LOUT,'(1X,A,I4,A,I8,A,/,4G10.3)')
26029 & 'EVTEMC: energy-momentum cons. failure at pos. ',IPOS,
26030 & ' event ',NEVHKK,
26031 & ' ! ',PXDEV,PYDEV,PZDEV,EDEV
26032 PX = 0.0D0
26033 PY = 0.0D0
26034 PZ = 0.0D0
26035 E = 0.0D0
26036 GOTO 9999
26037 ENDIF
26038 PX = 0.0D0
26039 PY = 0.0D0
26040 PZ = 0.0D0
26041 E = 0.0D0
26042 RETURN
26043 ENDIF
26044
26045 IF (MODE.EQ.1) THEN
26046 PX = 0.0D0
26047 PY = 0.0D0
26048 PZ = 0.0D0
26049 E = 0.0D0
26050 ENDIF
26051
26052 PX = PX+PXIO
26053 PY = PY+PYIO
26054 PZ = PZ+PZIO
26055 E = E+EIO
26056
26057 RETURN
26058
26059 9999 CONTINUE
26060 IREJ = 1
26061 RETURN
26062 END
26063
26064*$ CREATE DT_EVTFLC.FOR
26065*COPY DT_EVTFLC
26066*
26067*===evtflc=============================================================*
26068*
26069 SUBROUTINE DT_EVTFLC(ID,ID1,MODE,IPOS,IREJ)
26070
26071************************************************************************
26072* Flavor conservation check. *
26073* ID identity of particle *
26074* ID1 = 1 ID for q,aq,qq,aqaq in PDG-numbering scheme *
26075* = 2 ID for particle/resonance in BAMJET numbering scheme *
26076* = 3 ID for particle/resonance in PDG numbering scheme *
26077* MODE = 1 initialization and add ID *
26078* =-1 initialization and subtract ID *
26079* = 2 add ID *
26080* =-2 subtract ID *
26081* = 3 check flavor cons. *
26082* IPOS flag to give position of call of EVTFLC to output *
26083* unit in case of violation *
26084* This version dated 10.01.95 is written by S. Roesler *
26085************************************************************************
26086
26087 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26088 SAVE
26089 PARAMETER ( LINP = 10 ,
26090 & LOUT = 6 ,
26091 & LDAT = 9 )
26092 PARAMETER (TINY10=1.0D-10)
26093
26094 IREJ = 0
26095
26096 IF (MODE.EQ.3) THEN
26097 IF (IFL.NE.0) THEN
26098 WRITE(LOUT,'(1X,A,I3,A,I3)')
26099 & 'EVTFLC: flavor-conservation failure at pos. ',IPOS,
26100 & ' ! IFL = ',IFL
26101 IFL = 0
26102 GOTO 9999
26103 ENDIF
26104 IFL = 0
26105 RETURN
26106 ENDIF
26107
26108 IF (MODE.EQ.1) IFL = 0
26109 IF (ID.EQ.0) RETURN
26110
26111 IF (ID1.EQ.1) THEN
26112 IDD = ABS(ID)
26113 NQ = 1
26114 IF ((IDD.GE.100).AND.(IDD.LT.1000)) NQ = 2
26115 IF (IDD.GE.1000) NQ = 3
26116 DO 1 I=1,NQ
26117 IFBAM = IDT_IPDG2B(ID,I,2)
26118 IF (ABS(IFBAM).EQ.1) THEN
26119 IFBAM = SIGN(2,IFBAM)
26120 ELSEIF (ABS(IFBAM).EQ.2) THEN
26121 IFBAM = SIGN(1,IFBAM)
26122 ENDIF
26123 IF (MODE.GT.0) THEN
26124 IFL = IFL+IFBAM
26125 ELSE
26126 IFL = IFL-IFBAM
26127 ENDIF
26128 1 CONTINUE
26129 RETURN
26130 ENDIF
26131
26132 IDD = ID
26133 IF (ID1.EQ.3) IDD = IDT_ICIHAD(ID)
26134 IF ((ID1.EQ.2).OR.(ID1.EQ.3)) THEN
26135 DO 2 I=1,3
26136 IF (MODE.GT.0) THEN
26137 IFL = IFL+IDT_IQUARK(I,IDD)
26138 ELSE
26139 IFL = IFL-IDT_IQUARK(I,IDD)
26140 ENDIF
26141 2 CONTINUE
26142 ENDIF
26143 RETURN
26144
26145 9999 CONTINUE
26146 IREJ = 1
26147 RETURN
26148 END
26149
26150*$ CREATE DT_EVTCHG.FOR
26151*COPY DT_EVTCHG
26152*
26153*===evtchg=============================================================*
26154*
26155 SUBROUTINE DT_EVTCHG(ID,MODE,IPOS,IREJ)
26156
26157************************************************************************
26158* Charge conservation check. *
26159* ID identity of particle (PDG-numbering scheme) *
26160* MODE = 1 initialization *
26161* =-2 subtract ID-charge *
26162* = 2 add ID-charge *
26163* = 3 check charge cons. *
26164* IPOS flag to give position of call of EVTCHG to output *
26165* unit in case of violation *
26166* This version dated 10.01.95 is written by S. Roesler *
26167* Last change: s.r. 21.01.01 *
26168************************************************************************
26169
26170 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26171 SAVE
26172 PARAMETER ( LINP = 10 ,
26173 & LOUT = 6 ,
26174 & LDAT = 9 )
26175
26176* event history
26177 PARAMETER (NMXHKK=200000)
26178 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26179 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26180 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26181* particle properties (BAMJET index convention)
26182 CHARACTER*8 ANAME
26183 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26184 & IICH(210),IIBAR(210),K1(210),K2(210)
26185
26186 IREJ = 0
26187
26188 IF (MODE.EQ.1) THEN
26189 ICH = 0
26190 IBAR = 0
26191 RETURN
26192 ENDIF
26193
26194 IF (MODE.EQ.3) THEN
26195 IF ((ICH.NE.0).OR.(IBAR.NE.0)) THEN
26196 WRITE(LOUT,'(1X,A,I3,A,2I3,A,I8)')
26197 & 'EVTCHG: charge/baryo.-cons. failure at pos. ',IPOS,
26198 & '! ICH/IBAR= ',ICH,IBAR,' event ',NEVHKK
26199 ICH = 0
26200 IBAR = 0
26201 GOTO 9999
26202 ENDIF
26203 ICH = 0
26204 IBAR = 0
26205 RETURN
26206 ENDIF
26207
26208 IF (ID.EQ.0) RETURN
26209
26210 IDD = IDT_ICIHAD(ID)
26211* modification 21.1.01: use intrinsic phojet-functions to determine charge
26212* and baryon number
26213C IF (IDD.GT.0) THEN
26214C IF (MODE.EQ.2) THEN
26215C ICH = ICH+IICH(IDD)
26216C IBAR = IBAR+IIBAR(IDD)
26217C ELSEIF (MODE.EQ.-2) THEN
26218C ICH = ICH-IICH(IDD)
26219C IBAR = IBAR-IIBAR(IDD)
26220C ENDIF
26221C ELSE
26222C WRITE(LOUT,'(1X,A,3I6)') 'EVTCHG: (IDD = 0 !), IDD,ID=',IDD,ID
26223C CALL DT_EVTOUT(4)
26224C STOP
26225C ENDIF
26226 IF (MODE.EQ.2) THEN
26227 ICH = ICH+IPHO_CHR3(ID,1)/3
26228 IBAR = IBAR+IPHO_BAR3(ID,1)/3
26229 ELSEIF (MODE.EQ.-2) THEN
26230 ICH = ICH-IPHO_CHR3(ID,1)/3
26231 IBAR = IBAR-IPHO_BAR3(ID,1)/3
26232 ENDIF
26233
26234 RETURN
26235
26236 9999 CONTINUE
26237 IREJ = 1
26238 RETURN
26239 END
26240
26241************************************************************************
26242* *
26243* 4) Transformations *
26244* *
26245************************************************************************
26246*$ CREATE DT_LTINI.FOR
26247*COPY DT_LTINI
26248*
26249*===ltini==============================================================*
26250*
26251 SUBROUTINE DT_LTINI(IDPR,IDTA,EPN0,PPN0,ECM0,MODE)
26252
26253************************************************************************
26254* Initializations of Lorentz-transformations, calculation of Lorentz- *
26255* parameters. *
26256* This version dated 13.11.95 is written by S. Roesler. *
26257************************************************************************
26258
26259 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26260 SAVE
26261 PARAMETER ( LINP = 10 ,
26262 & LOUT = 6 ,
26263 & LDAT = 9 )
26264 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,
26265 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
26266
26267* Lorentz-parameters of the current interaction
26268 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26269 & UMO,PPCM,EPROJ,PPROJ
26270* properties of photon/lepton projectiles
26271 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
26272* particle properties (BAMJET index convention)
26273 CHARACTER*8 ANAME
26274 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26275 & IICH(210),IIBAR(210),K1(210),K2(210)
26276* nucleon-nucleon event-generator
26277 CHARACTER*8 CMODEL
26278 LOGICAL LPHOIN
26279 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
26280
26281 Q2 = VIRT
26282 IDP = IDPR
26283 IF (MCGENE.NE.3) THEN
26284* lepton-projectiles and PHOJET: initialize real photon instead
26285 IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26286 & (IDPR.EQ.10).OR.(IDPR.EQ.11).OR.
26287 & (IDPR.EQ. 5).OR.(IDPR.EQ. 6)) THEN
26288 IDP = 7
26289 Q2 = ZERO
26290 ENDIF
26291 ENDIF
26292 IDT = IDTA
26293 EPN = EPN0
26294 PPN = PPN0
26295 ECM = ECM0
26296 AMP = AAM(IDP)-SQRT(ABS(Q2))
26297 AMT = AAM(IDT)
26298 AMP2 = SIGN(AMP**2,AMP)
26299 AMT2 = AMT**2
26300 IF (ECM0.GT.ZERO) THEN
26301 EPN = (ECM**2-AMP2-AMT2)/(TWO*AMT)
26302 IF (AMP2.GT.ZERO) THEN
26303 PPN = SQRT((EPN+AMP)*(EPN-AMP))
26304 ELSE
26305 PPN = SQRT(EPN**2-AMP2)
26306 ENDIF
26307 ELSE
26308 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26309 IF (IDP.EQ.7) EPN = ABS(EPN)
26310 IF (EPN.LT.ZERO) EPN = ABS(EPN)+AMP
26311 IF (AMP2.GT.ZERO) THEN
26312 PPN = SQRT((EPN+AMP)*(EPN-AMP))
26313 ELSE
26314 PPN = SQRT(EPN**2-AMP2)
26315 ENDIF
26316 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26317 IF (AMP2.GT.ZERO) THEN
26318 EPN = PPN*SQRT(ONE+(AMP/PPN)**2)
26319 ELSE
26320 EPN = SQRT(PPN**2+AMP2)
26321 ENDIF
26322 ENDIF
26323 ECM = SQRT(AMP2+AMT2+TWO*AMT*EPN)
26324 ENDIF
26325 UMO = ECM
26326 EPROJ = EPN
26327 PPROJ = PPN
26328 IF (AMP2.GT.ZERO) THEN
26329 ETARG = (ECM**2-AMP2-AMT2)/(TWO*AMP)
26330 PTARG = -SQRT((ETARG+AMT)*(ETARG-AMT))
26331 ELSE
26332 ETARG = TINY10
26333 PTARG = TINY10
26334 ENDIF
26335* photon-projectiles (get momentum in cm-frame for virtuality Q^2)
26336 IF (IDP.EQ.7) THEN
26337 PGAMM(1) = ZERO
26338 PGAMM(2) = ZERO
26339 AMGAM = AMP
26340 AMGAM2 = AMP2
26341 IF (ECM0.GT.ZERO) THEN
26342 S = ECM0**2
26343 ELSE
26344 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26345 S = AMGAM2+AMT2+TWO*AMT*ABS(EPN0)
26346 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26347 S = AMGAM2+AMT2+TWO*AMT*SQRT(PPN0**2+AMGAM2)
26348 ENDIF
26349 ENDIF
26350 PGAMM(3) = SQRT( (S**2-TWO*AMGAM2*S-TWO*AMT2*S-TWO*AMGAM2*AMT2
26351 & +AMGAM2**2+AMT2**2)/(4.0D0*S) )
26352 PGAMM(4) = SQRT(AMGAM2+PGAMM(3)**2)
26353 IF (MODE.EQ.1) THEN
26354 PNUCL(1) = ZERO
26355 PNUCL(2) = ZERO
26356 PNUCL(3) = -PGAMM(3)
26357 PNUCL(4) = SQRT(S)-PGAMM(4)
26358 ENDIF
26359 ENDIF
26360 IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26361 & (IDPR.EQ.10).OR.(IDPR.EQ.11)) THEN
26362 PLEPT0(1) = ZERO
26363 PLEPT0(2) = ZERO
26364* neglect lepton masses
26365C AMLPT2 = AAM(IDPR)**2
26366 AMLPT2 = ZERO
26367*
26368 IF (ECM0.GT.ZERO) THEN
26369 S = ECM0**2
26370 ELSE
26371 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26372 S = AMLPT2+AMT2+TWO*AMT*ABS(EPN0)
26373 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26374 S = AMLPT2+AMT2+TWO*AMT*SQRT(PPN0**2+AMLPT2)
26375 ENDIF
26376 ENDIF
26377 PLEPT0(3) = SQRT( (S**2-TWO*AMLPT2*S-TWO*AMT2*S-TWO*AMLPT2*AMT2
26378 & +AMLPT2**2+AMT2**2)/(4.0D0*S) )
26379 PLEPT0(4) = SQRT(AMLPT2+PLEPT0(3)**2)
26380 PNUCL(1) = ZERO
26381 PNUCL(2) = ZERO
26382 PNUCL(3) = -PLEPT0(3)
26383 PNUCL(4) = SQRT(S)-PLEPT0(4)
26384 ENDIF
26385* Lorentz-parameter for transformation Lab. - projectile rest system
26386 IF ((IDP.EQ.7).OR.(AMP.LT.TINY10)) THEN
26387 GALAB = TINY10
26388 BGLAB = TINY10
26389 BLAB = TINY10
26390 ELSE
26391 GALAB = EPROJ/AMP
26392 BGLAB = PPROJ/AMP
26393 BLAB = BGLAB/GALAB
26394 ENDIF
26395* Lorentz-parameter for transf. proj. rest sys. - nucl.-nucl. cms.
26396 IF (IDP.EQ.7) THEN
26397 GACMS(1) = TINY10
26398 BGCMS(1) = TINY10
26399 ELSE
26400 GACMS(1) = (ETARG+AMP)/UMO
26401 BGCMS(1) = PTARG/UMO
26402 ENDIF
26403* Lorentz-parameter for transformation Lab. - nucl.-nucl. cms.
26404 GACMS(2) = (EPROJ+AMT)/UMO
26405 BGCMS(2) = PPROJ/UMO
26406 PPCM = GACMS(2)*PPROJ-BGCMS(2)*EPROJ
26407
26408 EPN0 = EPN
26409 PPN0 = PPN
26410 ECM0 = ECM
26411
26412 RETURN
26413 END
26414
26415*$ CREATE DT_LTRANS.FOR
26416*COPY DT_LTRANS
26417*
26418*===ltrans=============================================================*
26419*
26420 SUBROUTINE DT_LTRANS(PXI,PYI,PZI,PEI,PXO,PYO,PZO,PEO,ID,MODE)
26421
26422************************************************************************
26423* Lorentz-transformations. *
26424* MODE = 1(-1) projectile rest syst. --> Lab (back) *
26425* = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) *
26426* = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) *
26427* This version dated 01.11.95 is written by S. Roesler. *
26428************************************************************************
26429
26430 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26431 SAVE
26432 PARAMETER ( LINP = 10 ,
26433 & LOUT = 6 ,
26434 & LDAT = 9 )
26435 PARAMETER (TINY3=1.0D-3,ZERO=0.0D0,TWO=2.0D0)
26436
26437 PARAMETER (SQTINF=1.0D+15)
26438
26439* particle properties (BAMJET index convention)
26440 CHARACTER*8 ANAME
26441 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26442 & IICH(210),IIBAR(210),K1(210),K2(210)
26443
26444 PXO = PXI
26445 PYO = PYI
26446 CALL DT_LTNUC(PZI,PEI,PZO,PEO,MODE)
26447
26448* check particle mass for consistency (numerical rounding errors)
26449 PO = SQRT(PXO*PXO+PYO*PYO+PZO*PZO)
26450 AMO2 = (PEO-PO)*(PEO+PO)
26451 AMORQ2 = AAM(ID)**2
26452 AMDIF2 = ABS(AMO2-AMORQ2)
26453 IF ((AMDIF2.GT.TINY3).AND.(PEO.LT.SQTINF).AND.(PO.GT.ZERO)) THEN
26454 DELTA = (AMORQ2-AMO2)/(TWO*(PEO+PO))
26455 PEO = PEO+DELTA
26456 PO1 = PO -DELTA
26457 PXO = PXO*PO1/PO
26458 PYO = PYO*PO1/PO
26459 PZO = PZO*PO1/PO
26460C WRITE(6,*) 'LTRANS corrected', AMDIF2,PZI,PEI,PZO,PEO,MODE,ID
26461 ENDIF
26462
26463 RETURN
26464 END
26465
26466*$ CREATE DT_LTNUC.FOR
26467*COPY DT_LTNUC
26468*
26469*===ltnuc==============================================================*
26470*
26471 SUBROUTINE DT_LTNUC(PIN,EIN,POUT,EOUT,MODE)
26472
26473************************************************************************
26474* Lorentz-transformations. *
26475* PIN longitudnal momentum (input) *
26476* EIN energy (input) *
26477* POUT transformed long. momentum (output) *
26478* EOUT transformed energy (output) *
26479* MODE = 1(-1) projectile rest syst. --> Lab (back) *
26480* = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) *
26481* = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) *
26482* This version dated 01.11.95 is written by S. Roesler. *
26483************************************************************************
26484
26485 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26486 SAVE
26487 PARAMETER ( LINP = 10 ,
26488 & LOUT = 6 ,
26489 & LDAT = 9 )
26490 PARAMETER (ZERO=0.0D0)
26491
26492* Lorentz-parameters of the current interaction
26493 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26494 & UMO,PPCM,EPROJ,PPROJ
26495
26496 BDUM1 = ZERO
26497 BDUM2 = ZERO
26498 PDUM1 = ZERO
26499 PDUM2 = ZERO
26500 IF (ABS(MODE).EQ.1) THEN
26501 BG = -SIGN(BGLAB,DBLE(MODE))
26502 CALL DT_DALTRA(GALAB,BDUM1,BDUM2,-BG,PDUM1,PDUM2,PIN,EIN,
26503 & DUM1,DUM2,DUM3,POUT,EOUT)
26504 ELSEIF (ABS(MODE).EQ.2) THEN
26505 BG = SIGN(BGCMS(1),DBLE(MODE))
26506 CALL DT_DALTRA(GACMS(1),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26507 & DUM1,DUM2,DUM3,POUT,EOUT)
26508 ELSEIF (ABS(MODE).EQ.3) THEN
26509 BG = -SIGN(BGCMS(2),DBLE(MODE))
26510 CALL DT_DALTRA(GACMS(2),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26511 & DUM1,DUM2,DUM3,POUT,EOUT)
26512 ELSE
26513 WRITE(LOUT,1000) MODE
26514 1000 FORMAT(1X,'LTNUC: not supported mode (MODE = ',I3,')')
26515 EOUT = EIN
26516 POUT = PIN
26517 ENDIF
26518
26519 RETURN
26520 END
26521
26522*$ CREATE DT_DALTRA.FOR
26523*COPY DT_DALTRA
26524*
26525*===daltra=============================================================*
26526*
26527 SUBROUTINE DT_DALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
26528
26529************************************************************************
26530* Arbitrary Lorentz-transformation. *
26531* Adopted from the original by S. Roesler. This version dated 15.01.95 *
26532************************************************************************
26533
26534 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26535 SAVE
26536 PARAMETER (ONE=1.0D0)
26537
26538 EP = PCX*BGX+PCY*BGY+PCZ*BGZ
26539 PE = EP/(GA+ONE)+EC
26540 PX = PCX+BGX*PE
26541 PY = PCY+BGY*PE
26542 PZ = PCZ+BGZ*PE
26543 P = SQRT(PX*PX+PY*PY+PZ*PZ)
26544 E = GA*EC+EP
26545
26546 RETURN
26547 END
26548
26549*$ CREATE DT_DTRAFO.FOR
26550*COPY DT_DTRAFO
26551*
26552*====dtrafo============================================================*
26553*
26554 SUBROUTINE DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
26555 & PL,CXL,CYL,CZL,EL)
26556
26557C LORENTZ TRANSFORMATION INTO THE LAB - SYSTEM
26558
26559 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26560 SAVE
26561
26562 IF (ABS(COD).GT.1.0D0) COD = SIGN(1.0D0,COD)
26563 SID = SQRT(1.D0-COD*COD)
26564 PLX = P*SID*COF
26565 PLY = P*SID*SIF
26566 PCMZ = P*COD
26567 PLZ = GAM*PCMZ+BGAM*ECM
26568 PL = SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
26569 EL = GAM*ECM+BGAM*PCMZ
26570C ROTATION INTO THE ORIGINAL DIRECTION
26571 COZ = PLZ/PL
26572 SIZ = SQRT(1.D0-COZ**2)
26573 CALL DT_STTRAN(CX,CY,CZ,COZ,SIZ,SIF,COF,CXL,CYL,CZL)
26574
26575 RETURN
26576 END
26577
26578*$ CREATE DT_STTRAN.FOR
26579*COPY DT_STTRAN
26580*
26581*====sttran============================================================*
26582*
26583 SUBROUTINE DT_STTRAN(XO,YO,ZO,CDE,SDE,SFE,CFE,X,Y,Z)
26584
26585 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26586 SAVE
26587 DATA ANGLSQ/1.D-30/
26588************************************************************************
26589* VERSION BY J. RANFT *
26590* LEIPZIG *
26591* *
26592* THIS IS A SUBROUTINE OF FLUKA TO GIVE NEW DIRECTION COSINES *
26593* *
26594* INPUT VARIABLES: *
26595* XO,YO,ZO = ORIGINAL DIRECTION COSINES *
26596* CDE,SDE = COSINE AND SINE OF THE POLAR (THETA) *
26597* ANGLE OF "SCATTERING" *
26598* SDE = SINE OF THE POLAR (THETA) ANGLE OF "SCATTERING" *
26599* SFE,CFE = SINE AND COSINE OF THE AZIMUTHAL (PHI) ANGLE *
26600* OF "SCATTERING" *
26601* *
26602* OUTPUT VARIABLES: *
26603* X,Y,Z = NEW DIRECTION COSINES *
26604* *
26605* ROTATION OF COORDINATE SYSTEM (SEE CERN 64-47 ) *
26606************************************************************************
26607*
26608*
26609* Changed by A. Ferrari
26610*
26611* IF (ABS(XO)-0.0001D0) 1,1,2
26612* 1 IF (ABS(YO)-0.0001D0) 3,3,2
26613* 3 CONTINUE
26614 A = XO**2 + YO**2
26615 IF ( A .LT. ANGLSQ ) THEN
26616 X=SDE*CFE
26617 Y=SDE*SFE
26618 Z=CDE*ZO
26619 ELSE
26620 XI=SDE*CFE
26621 YI=SDE*SFE
26622 ZI=CDE
26623 A=SQRT(A)
26624 X=-YO*XI/A-ZO*XO*YI/A+XO*ZI
26625 Y=XO*XI/A-ZO*YO*YI/A+YO*ZI
26626 Z=A*YI+ZO*ZI
26627 ENDIF
26628
26629 RETURN
26630 END
26631
26632*$ CREATE DT_MYTRAN.FOR
26633*COPY DT_MYTRAN
26634*
26635*===mytran=============================================================*
26636*
26637 SUBROUTINE DT_MYTRAN(IMODE,XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
26638
26639************************************************************************
26640* This subroutine rotates the coordinate frame *
26641* a) theta around y *
26642* b) phi around z if IMODE = 1 *
26643* *
26644* x' cos(ph) -sin(ph) 0 cos(th) 0 sin(th) x *
26645* y' = A B = sin(ph) cos(ph) 0 . 0 1 0 y *
26646* z' 0 0 1 -sin(th) 0 cos(th) z *
26647* *
26648* and vice versa if IMODE = 0. *
26649* This version dated 5.4.94 is based on the original version DTRAN *
26650* by J. Ranft and is written by S. Roesler. *
26651************************************************************************
26652
26653 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26654 SAVE
26655 PARAMETER ( LINP = 10 ,
26656 & LOUT = 6 ,
26657 & LDAT = 9 )
26658
26659 IF (IMODE.EQ.1) THEN
26660 X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
26661 Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
26662 Z=-SDE *XO +CDE *ZO
26663 ELSE
26664 X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
26665 Y= -SFE*XO+CFE*YO
26666 Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
26667 ENDIF
26668 RETURN
26669 END
26670
26671*$ CREATE DT_LT2LAO.FOR
26672*COPY DT_LT2LAO
26673*
26674*===lt2lab=============================================================*
26675*
26676 SUBROUTINE DT_LT2LAO
26677
26678************************************************************************
26679* Lorentz-transformation to lab-system. This subroutine scans DTEVT1 *
26680* for final state particles/fragments defined in nucleon-nucleon-cms *
26681* and transforms them back to the lab. *
26682* This version dated 16.11.95 is written by S. Roesler *
26683************************************************************************
26684
26685 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26686 SAVE
26687 PARAMETER ( LINP = 10 ,
26688 & LOUT = 6 ,
26689 & LDAT = 9 )
26690
26691* event history
26692 PARAMETER (NMXHKK=200000)
26693 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26694 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26695 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26696* extended event history
26697 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26698 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26699 & IHIST(2,NMXHKK)
26700
26701 NEND = NHKK
26702 NPOINT(5) = NHKK+1
26703 IF ( (NPOINT(4).EQ.0).OR.(NEND.LT.NPOINT(4)) ) RETURN
26704 DO 1 I=NPOINT(4),NEND
26705C DO 1 I=1,NEND
26706 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26707 & (ISTHKK(I).EQ.1001)) THEN
26708 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26709 NOB = NOBAM(I)
26710 CALL DT_EVTPUT(ISTHKK(I),IDHKK(I),I,0,PHKK(1,I),PHKK(2,I),
26711 & PZ,PE,IDRES(I),IDXRES(I),IDCH(I))
26712 IF ((ISTHKK(I).EQ.1000).OR.(ISTHKK(I).EQ.1001)) THEN
26713 ISTHKK(I) = 3*ISTHKK(I)
26714 NOBAM(NHKK) = NOB
26715 ELSE
26716 IF (ISTHKK(I).EQ.-1) NOBAM(NHKK) = NOB
26717 ISTHKK(I) = SIGN(3,ISTHKK(I))
26718 ENDIF
26719 JDAHKK(1,I) = NHKK
26720 ENDIF
26721 1 CONTINUE
26722
26723 RETURN
26724 END
26725
26726*$ CREATE DT_LT2LAB.FOR
26727*COPY DT_LT2LAB
26728*
26729*===lt2lab=============================================================*
26730*
26731 SUBROUTINE DT_LT2LAB
26732
26733************************************************************************
26734* Lorentz-transformation to lab-system. This subroutine scans DTEVT1 *
26735* for final state particles/fragments defined in nucleon-nucleon-cms *
26736* and transforms them to the lab. *
26737* This version dated 07.01.96 is written by S. Roesler *
26738************************************************************************
26739
26740 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26741 SAVE
26742 PARAMETER ( LINP = 10 ,
26743 & LOUT = 6 ,
26744 & LDAT = 9 )
26745
26746* event history
26747 PARAMETER (NMXHKK=200000)
26748 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26749 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26750 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26751* extended event history
26752 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26753 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26754 & IHIST(2,NMXHKK)
26755
26756 IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
26757 DO 1 I=NPOINT(4),NHKK
26758 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26759 & (ISTHKK(I).EQ.1001)) THEN
26760 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26761 PHKK(3,I) = PZ
26762 PHKK(4,I) = PE
26763 ENDIF
26764 1 CONTINUE
26765
26766 RETURN
26767 END
26768
26769************************************************************************
26770* *
26771* 5) Sampling from distributions *
26772* *
26773************************************************************************
26774*$ CREATE IDT_NPOISS.FOR
26775*COPY IDT_NPOISS
26776*
26777*===npoiss=============================================================*
26778*
26779 INTEGER FUNCTION IDT_NPOISS(AVN)
26780
26781************************************************************************
26782* Sample according to Poisson distribution with Poisson parameter AVN. *
26783* The original version written by J. Ranft. *
26784* This version dated 11.1.95 is written by S. Roesler. *
26785************************************************************************
26786
26787 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26788 SAVE
26789 PARAMETER ( LINP = 10 ,
26790 & LOUT = 6 ,
26791 & LDAT = 9 )
26792
26793 EXPAVN = EXP(-AVN)
26794 K = 1
26795 A = 1.0D0
26796
26797 10 CONTINUE
26798 A = DT_RNDM(A)*A
26799 IF (A.GE.EXPAVN) THEN
26800 K = K+1
26801 GOTO 10
26802 ENDIF
26803 IDT_NPOISS = K-1
26804
26805 RETURN
26806 END
26807
26808*$ CREATE DT_SAMPXB.FOR
26809*COPY DT_SAMPXB
26810*
26811*===sampxb=============================================================*
26812*
26813 DOUBLE PRECISION FUNCTION DT_SAMPXB(X1,X2,B)
26814
26815************************************************************************
26816* Sampling from f(x)=1./SQRT(X**2+B**2) between x1 and x2. *
26817* Processed by S. Roesler, 6.5.95 *
26818************************************************************************
26819
26820 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26821 SAVE
26822 PARAMETER (TWO=2.0D0)
26823
26824 A1 = LOG(X1+SQRT(X1**2+B**2))
26825 A2 = LOG(X2+SQRT(X2**2+B**2))
26826 AN = A2-A1
26827 A = AN*DT_RNDM(A1)+A1
26828 BB = EXP(A)
26829 DT_SAMPXB = (BB**2-B**2)/(TWO*BB)
26830
26831 RETURN
26832 END
26833
26834*$ CREATE DT_SAMPEX.FOR
26835*COPY DT_SAMPEX
26836*
26837*===sampex=============================================================*
26838*
26839 DOUBLE PRECISION FUNCTION DT_SAMPEX(X1,X2)
26840
26841************************************************************************
26842* Sampling from f(x)=1./x between x1 and x2. *
26843* Processed by S. Roesler, 6.5.95 *
26844************************************************************************
26845
26846 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26847 SAVE
26848 PARAMETER (ONE=1.0D0)
26849
26850 R = DT_RNDM(X1)
26851 AL1 = LOG(X1)
26852 AL2 = LOG(X2)
26853 DT_SAMPEX = EXP((ONE-R)*AL1+R*AL2)
26854
26855 RETURN
26856 END
26857
26858*$ CREATE DT_SAMSQX.FOR
26859*COPY DT_SAMSQX
26860*
26861*===samsqx=============================================================*
26862*
26863 DOUBLE PRECISION FUNCTION DT_SAMSQX(X1,X2)
26864
26865************************************************************************
26866* Sampling from f(x)=1./x^0.5 between x1 and x2. *
26867* Processed by S. Roesler, 6.5.95 *
26868************************************************************************
26869
26870 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26871 SAVE
26872 PARAMETER (ONE=1.0D0)
26873
26874 R = DT_RNDM(X1)
26875 DT_SAMSQX = (R*SQRT(X2)+(ONE-R)*SQRT(X1))**2
26876
26877 RETURN
26878 END
26879
26880*$ CREATE DT_SAMPLW.FOR
26881*COPY DT_SAMPLW
26882*
26883*===samplw=============================================================*
26884*
26885 DOUBLE PRECISION FUNCTION DT_SAMPLW(XMIN,XMAX,B)
26886
26887************************************************************************
26888* Sampling from f(x)=1/x^b between x_min and x_max. *
26889* S. Roesler, 18.4.98 *
26890************************************************************************
26891
26892 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26893 SAVE
26894 PARAMETER (ONE=1.0D0)
26895
26896 R = DT_RNDM(B)
26897 IF (B.EQ.ONE) THEN
26898 DT_SAMPLW = EXP(R*LOG(XMAX)+(ONE-R)*LOG(XMIN))
26899 ELSE
26900 ONEMB = ONE-B
26901 DT_SAMPLW = (R*XMAX**ONEMB+(ONE-R)*XMIN**ONEMB)**(ONE/ONEMB)
26902 ENDIF
26903
26904 RETURN
26905 END
26906
26907*$ CREATE DT_BETREJ.FOR
26908*COPY DT_BETREJ
26909*
26910*===betrej=============================================================*
26911*
26912 DOUBLE PRECISION FUNCTION DT_BETREJ(GAM,ETA,XMIN,XMAX)
26913
26914 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26915 SAVE
26916
26917 PARAMETER ( LINP = 10 ,
26918 & LOUT = 6 ,
26919 & LDAT = 9 )
26920 PARAMETER (ONE=1.0D0)
26921
26922 IF (XMIN.GE.XMAX)THEN
26923 WRITE (LOUT,500) XMIN,XMAX
26924 500 FORMAT(1X,'DT_BETREJ: XMIN<XMAX execution stopped ',2F10.5)
26925 STOP
26926 ENDIF
26927
26928 10 CONTINUE
26929 XX = XMIN+(XMAX-XMIN)*DT_RNDM(ETA)
26930 BETMAX = XMIN**(GAM-ONE)*(ONE-XMIN)**(ETA-ONE)
26931 YY = BETMAX*DT_RNDM(XX)
26932 BETXX = XX**(GAM-ONE)*(ONE-XX)**(ETA-ONE)
26933 IF (YY.GT.BETXX) GOTO 10
26934 DT_BETREJ = XX
26935
26936 RETURN
26937 END
26938
26939*$ CREATE DT_DGAMRN.FOR
26940*COPY DT_DGAMRN
26941*
26942*===dgamrn=============================================================*
26943*
26944 DOUBLE PRECISION FUNCTION DT_DGAMRN(ALAM,ETA)
26945
26946************************************************************************
26947* Sampling from Gamma-distribution. *
26948* F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA) *
26949* Processed by S. Roesler, 6.5.95 *
26950************************************************************************
26951
26952 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26953 SAVE
26954 PARAMETER (ZERO=0.0D0,TINY9=1.0D-9,ONE=1.0D0)
26955
26956 NCOU = 0
26957 N = INT(ETA)
26958 F = ETA-DBLE(N)
26959 IF (F.EQ.ZERO) GOTO 20
26960 10 R = DT_RNDM(F)
26961 NCOU = NCOU+1
26962 IF (NCOU.GE.11) GOTO 20
26963 IF (R.LT.F/(F+2.71828D0)) GOTO 30
26964 YYY = LOG(DT_RNDM(R)+TINY9)/F
26965 IF (ABS(YYY).GT.50.0D0) GOTO 20
26966 Y = EXP(YYY)
26967 IF (LOG(DT_RNDM(Y)+TINY9).GT.-Y) GOTO 10
26968 GOTO 40
26969 20 Y = 0.0D0
26970 GOTO 50
26971 30 Y = ONE-LOG(DT_RNDM(Y)+TINY9)
26972 IF (DT_RNDM(R).GT.Y**(F-ONE)) GOTO 10
26973 40 IF (N.EQ.0) GOTO 70
26974 50 Z = 1.0D0
26975 DO 60 I = 1,N
26976 60 Z = Z*DT_RNDM(Z)
26977 Y = Y-LOG(Z+TINY9)
26978 70 DT_DGAMRN = Y/ALAM
26979
26980 RETURN
26981 END
26982
26983*$ CREATE DT_DBETAR.FOR
26984*COPY DT_DBETAR
26985*
26986*===dbetar=============================================================*
26987*
26988 DOUBLE PRECISION FUNCTION DT_DBETAR(GAM,ETA)
26989
26990************************************************************************
26991* Sampling from Beta -distribution between 0.0 and 1.0 *
26992* F(X)=X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM)/(GAMM(GAM)*GAMM(ETA))*
26993* Processed by S. Roesler, 6.5.95 *
26994************************************************************************
26995
26996 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26997 SAVE
26998
26999 Y = DT_DGAMRN(1.0D0,GAM)
27000 Z = DT_DGAMRN(1.0D0,ETA)
27001 DT_DBETAR = Y/(Y+Z)
27002
27003 RETURN
27004 END
27005
27006*$ CREATE DT_RANNOR.FOR
27007*COPY DT_RANNOR
27008*
27009*===rannor=============================================================*
27010*
27011 SUBROUTINE DT_RANNOR(X,Y)
27012
27013************************************************************************
27014* Sampling from Gaussian distribution. *
27015* Processed by S. Roesler, 6.5.95 *
27016************************************************************************
27017
27018 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27019 SAVE
27020 PARAMETER (TINY10=1.0D-10)
27021
27022 CALL DT_DSFECF(SFE,CFE)
27023 V = MAX(TINY10,DT_RNDM(X))
27024 A = SQRT(-2.D0*LOG(V))
27025 X = A*SFE
27026 Y = A*CFE
27027
27028 RETURN
27029 END
27030
27031*$ CREATE DT_DPOLI.FOR
27032*COPY DT_DPOLI
27033*
27034*===dpoli==============================================================*
27035*
27036 SUBROUTINE DT_DPOLI(CS,SI)
27037
27038 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27039 SAVE
27040
27041 U = DT_RNDM(CS)
27042 CS = DT_RNDM(U)
27043 IF (U.LT.0.5D0) CS=-CS
27044 SI = SQRT(1.0D0-CS*CS+1.0D-10)
27045
27046 RETURN
27047 END
27048
27049*$ CREATE DT_DSFECF.FOR
27050*COPY DT_DSFECF
27051*
27052*===dsfecf=============================================================*
27053*
27054 SUBROUTINE DT_DSFECF(SFE,CFE)
27055
27056 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27057 SAVE
27058 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
27059
27060 1 CONTINUE
27061 X = DT_RNDM(SFE)
27062 Y = DT_RNDM(X)
27063 XX = X*X
27064 YY = Y*Y
27065 XY = XX+YY
27066 IF (XY.GT.ONE) GOTO 1
27067 CFE = (XX-YY)/XY
27068 SFE = TWO*X*Y/XY
27069 IF (DT_RNDM(X).LT.OHALF) SFE = -SFE
27070 RETURN
27071 END
27072
27073*$ CREATE DT_RACO.FOR
27074*COPY DT_RACO
27075*
27076*===raco===============================================================*
27077*
27078 SUBROUTINE DT_RACO(WX,WY,WZ)
27079
27080************************************************************************
27081* Direction cosines of random uniform (isotropic) direction in three *
27082* dimensional space *
27083* Processed by S. Roesler, 20.11.95 *
27084************************************************************************
27085
27086 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27087 SAVE
27088 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
27089
27090 10 CONTINUE
27091 X = TWO*DT_RNDM(WX)-ONE
27092 Y = DT_RNDM(X)
27093 X2 = X*X
27094 Y2 = Y*Y
27095 IF (X2+Y2.GT.ONE) GOTO 10
27096
27097 CFE = (X2-Y2)/(X2+Y2)
27098 SFE = TWO*X*Y/(X2+Y2)
27099* z = 1/2 [ 1 + cos (theta) ]
27100 Z = DT_RNDM(X)
27101* 1/2 sin (theta)
27102 WZ = SQRT(Z*(ONE-Z))
27103 WX = TWO*WZ*CFE
27104 WY = TWO*WZ*SFE
27105 WZ = TWO*Z-ONE
27106
27107 RETURN
27108 END
27109
27110************************************************************************
27111* *
27112* 6) Special functions, algorithms and service routines *
27113* *
27114************************************************************************
27115*$ CREATE DT_YLAMB.FOR
27116*COPY DT_YLAMB
27117*
27118*===ylamb==============================================================*
27119*
27120 DOUBLE PRECISION FUNCTION DT_YLAMB(X,Y,Z)
27121
27122************************************************************************
27123* *
27124* auxiliary function for three particle decay mode *
27125* (standard LAMBDA**(1/2) function) *
27126* *
27127* Adopted from an original version written by R. Engel. *
27128* This version dated 12.12.94 is written by S. Roesler. *
27129************************************************************************
27130
27131 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27132 SAVE
27133
27134 YZ = Y-Z
27135 XLAM = X*X-2.D0*X*(Y+Z)+YZ*YZ
27136 IF (XLAM.LE.0.D0) XLAM = ABS(XLAM)
27137 DT_YLAMB = SQRT(XLAM)
27138
27139 RETURN
27140 END
27141
27142*$ CREATE DT_SORT.FOR
27143*COPY DT_SORT
27144*
27145*===sort1==============================================================*
27146*
27147 SUBROUTINE DT_SORT(A,N,I0,I1,MODE)
27148
27149************************************************************************
27150* This subroutine sorts entries in A in increasing/decreasing order *
27151* of A(3,i). *
27152* MODE = 1 increasing in A(3,i=1..N) *
27153* = 2 decreasing in A(3,i=1..N) *
27154* This version dated 21.04.95 is revised by S. Roesler *
27155************************************************************************
27156
27157 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27158 SAVE
27159
27160 DIMENSION A(3,N)
27161
27162 M = I1
27163 10 CONTINUE
27164 M = I1-1
27165 IF (M.LE.0) RETURN
27166 L = 0
27167 DO 20 I=I0,M
27168 J = I+1
27169 IF (MODE.EQ.1) THEN
27170 IF (A(3,I).LE.A(3,J)) GOTO 20
27171 ELSE
27172 IF (A(3,I).GE.A(3,J)) GOTO 20
27173 ENDIF
27174 B = A(3,I)
27175 C = A(1,I)
27176 D = A(2,I)
27177 A(3,I) = A(3,J)
27178 A(2,I) = A(2,J)
27179 A(1,I) = A(1,J)
27180 A(3,J) = B
27181 A(1,J) = C
27182 A(2,J) = D
27183 L = 1
27184 20 CONTINUE
27185 IF (L.EQ.1) GOTO 10
27186
27187 RETURN
27188 END
27189
27190*$ CREATE DT_SORT1.FOR
27191*COPY DT_SORT1
27192*
27193*===sort1==============================================================*
27194*
27195 SUBROUTINE DT_SORT1(A,IDX,N,I0,I1,MODE)
27196
27197************************************************************************
27198* This subroutine sorts entries in A in increasing/decreasing order *
27199* of A(i). *
27200* MODE = 1 increasing in A(i=1..N) *
27201* = 2 decreasing in A(i=1..N) *
27202* This version dated 21.04.95 is revised by S. Roesler *
27203************************************************************************
27204
27205 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27206 SAVE
27207
27208 DIMENSION A(N),IDX(N)
27209
27210 M = I1
27211 10 CONTINUE
27212 M = I1-1
27213 IF (M.LE.0) RETURN
27214 L = 0
27215 DO 20 I=I0,M
27216 J = I+1
27217 IF (MODE.EQ.1) THEN
27218 IF (A(I).LE.A(J)) GOTO 20
27219 ELSE
27220 IF (A(I).GE.A(J)) GOTO 20
27221 ENDIF
27222 B = A(I)
27223 A(I) = A(J)
27224 A(J) = B
27225 IX = IDX(I)
27226 IDX(I) = IDX(J)
27227 IDX(J) = IX
27228 L = 1
27229 20 CONTINUE
27230 IF (L.EQ.1) GOTO 10
27231
27232 RETURN
27233 END
27234
27235*$ CREATE DT_XTIME.FOR
27236*COPY DT_XTIME
27237*
27238*===xtime==============================================================*
27239*
27240 SUBROUTINE DT_XTIME
27241
27242 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27243 SAVE
27244 PARAMETER ( LINP = 10 ,
27245 & LOUT = 6 ,
27246 & LDAT = 9 )
27247
27248 CHARACTER DAT*9,TIM*11
27249
27250 DAT = ' '
27251 TIM = ' '
27252C CALL GETDAT(IYEAR,IMONTH,IDAY)
27253C CALL GETTIM(IHOUR,IMINUT,ISECND,IHSCND)
27254
27255C CALL DATE(DAT)
27256C CALL TIME(TIM)
27257C WRITE(LOUT,1000) DAT,TIM
27258 1000 FORMAT(/,2X,'Date: ',A9,3X,'Time: ',A11,/)
27259
27260 RETURN
27261 END
27262
27263************************************************************************
27264* *
27265* 7) Random number generator package *
27266* *
27267* THIS IS A PACKAGE CONTAINING A RANDOM NUMBER GENERATOR AND *
27268* SERVICE ROUTINES. *
27269* THE ALGORITHM IS FROM *
27270* 'TOWARD A UNVERSAL RANDOM NUMBER GENERATOR' *
27271* G.MARSAGLIA, A.ZAMAN ; FSU-SCRI-87-50 *
27272* IMPLEMENTATION BY K. HAHN DEC. 88, *
27273* THIS GENERATOR SHOULD NOT DEPEND ON THE HARD WARE ( IF A REAL HAS *
27274* AT LEAST 24 SIGNIFICANT BITS IN INTERNAL REPRESENTATION ), *
27275* THE PERIOD IS ABOUT 2**144, *
27276* TIME FOR ONE CALL AT IBM-XT IS ABOUT 0.7 MILLISECONDS, *
27277* THE PACKAGE CONTAINS *
27278* FUNCTION DT_RNDM(I) : GENERATOR *
27279* SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB4): INITIALIZATION *
27280* SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) : PUT SEED TO GENERATOR *
27281* SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) : TAKE SEED FROM GENERATOR *
27282* SUBROUTINE DT_RNDMTE(IO) : TEST OF GENERATOR *
27283*--- *
27284* FUNCTION DT_RNDM(I) *
27285* GIVES UNIFORMLY DISTRIBUTED RANDOM NUMBERS IN (0..1) *
27286* I - DUMMY VARIABLE, NOT USED *
27287* SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1) *
27288* INITIALIZES THE GENERATOR, MUST BE CALLED BEFORE USING DT_RNDM *
27289* NA1,NA2,NA3,NB1 - VALUES FOR INITIALIZING THE GENERATOR *
27290* NA? MUST BE IN 1..178 AND NOT ALL 1 *
27291* 12,34,56 ARE THE STANDARD VALUES *
27292* NB1 MUST BE IN 1..168 *
27293* 78 IS THE STANDARD VALUE *
27294* SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) *
27295* PUTS SEED TO GENERATOR ( BRINGS GENERATOR IN THE SAME STATUS *
27296* AS AFTER THE LAST DT_RNDMOU CALL ) *
27297* U(97),C,CD,CM,I,J - SEED VALUES AS TAKEN FROM DT_RNDMOU *
27298* SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) *
27299* TAKES SEED FROM GENERATOR *
27300* U(97),C,CD,CM,I,J - SEED VALUES *
27301* SUBROUTINE DT_RNDMTE(IO) *
27302* TEST OF THE GENERATOR *
27303* IO - DEFINES OUTPUT *
27304* = 0 OUTPUT ONLY IF AN ERROR IS DETECTED *
27305* = 1 OUTPUT INDEPENDEND ON AN ERROR *
27306* DT_RNDMTE USES DT_RNDMIN AND DT_RNDMOU TO BRING GENERATOR TO *
27307* SAME STATUS *
27308* AS BEFORE CALL OF DT_RNDMTE *
27309************************************************************************
27310*$ CREATE DT_RNDM.FOR
27311*COPY DT_RNDM
27312*
839efe5b 27313c$$$*===rndm===============================================================*
27314c$$$*
27315c$$$ DOUBLE PRECISION FUNCTION DT_RNDM(VDUMMY)
27316c$$$
27317c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27318c$$$ SAVE
27319c$$$
27320c$$$* random number generator
27321c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27322c$$$
27323c$$$* counter of calls to random number generator
27324c$$$* uncomment if needed
27325c$$$C COMMON /DTRNCT/ IRNCT0,IRNCT1
27326c$$$C LOGICAL LFIRST
27327c$$$C DATA LFIRST /.TRUE./
27328c$$$
27329c$$$* counter of calls to random number generator
27330c$$$* uncomment if needed
27331c$$$C IF (LFIRST) THEN
27332c$$$C IRNCT0 = 0
27333c$$$C IRNCT1 = 0
27334c$$$C LFIRST = .FALSE.
27335c$$$C ENDIF
27336c$$$ 100 CONTINUE
27337c$$$ DT_RNDM = U(I)-U(J)
27338c$$$ IF ( DT_RNDM.LT.0.0D0 ) DT_RNDM = DT_RNDM+1.0D0
27339c$$$ U(I) = DT_RNDM
27340c$$$ I = I-1
27341c$$$ IF ( I.EQ.0 ) I = 97
27342c$$$ J = J-1
27343c$$$ IF ( J.EQ.0 ) J = 97
27344c$$$ C = C-CD
27345c$$$ IF ( C.LT.0.0D0 ) C = C+CM
27346c$$$ DT_RNDM = DT_RNDM-C
27347c$$$ IF ( DT_RNDM.LT.0.0D0 ) DT_RNDM = DT_RNDM+1.0D0
27348c$$$
27349c$$$ IF ((DT_RNDM.EQ.0.D0).OR.(DT_RNDM.EQ.1.D0)) GOTO 100
27350c$$$
27351c$$$* counter of calls to random number generator
27352c$$$* uncomment if needed
27353c$$$C IRNCT0 = IRNCT0+1
27354c$$$
27355c$$$ RETURN
27356c$$$ END
27357c$$$
27358c$$$*$ CREATE DT_RNDMST.FOR
27359c$$$*COPY DT_RNDMST
27360c$$$*
27361c$$$*===rndmst=============================================================*
27362c$$$*
27363c$$$ SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)
27364c$$$
27365c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27366c$$$ SAVE
27367c$$$
27368c$$$* random number generator
27369c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27370c$$$
27371c$$$ MA1 = NA1
27372c$$$ MA2 = NA2
27373c$$$ MA3 = NA3
27374c$$$ MB1 = NB1
27375c$$$ I = 97
27376c$$$ J = 33
27377c$$$ DO 20 II2 = 1,97
27378c$$$ S = 0
27379c$$$ T = 0.5D0
27380c$$$ DO 10 II1 = 1,24
27381c$$$ MAT = MOD(MOD(MA1*MA2,179)*MA3,179)
27382c$$$ MA1 = MA2
27383c$$$ MA2 = MA3
27384c$$$ MA3 = MAT
27385c$$$ MB1 = MOD(53*MB1+1,169)
27386c$$$ IF ( MOD(MB1*MAT,64).GE.32 ) S = S+T
27387c$$$ 10 T = 0.5D0*T
27388c$$$ 20 U(II2) = S
27389c$$$ C = 362436.0D0/16777216.0D0
27390c$$$ CD = 7654321.0D0/16777216.0D0
27391c$$$ CM = 16777213.0D0/16777216.0D0
27392c$$$ RETURN
27393c$$$ END
27394c$$$
27395c$$$*$ CREATE DT_RNDMIN.FOR
27396c$$$*COPY DT_RNDMIN
27397c$$$*
27398c$$$*===rndmin=============================================================*
27399c$$$*
27400c$$$ SUBROUTINE DT_RNDMIN(UIN,CIN,CDIN,CMIN,IIN,JIN)
27401c$$$
27402c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27403c$$$ SAVE
27404c$$$
27405c$$$* random number generator
27406c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27407c$$$
27408c$$$ DIMENSION UIN(97)
27409c$$$
27410c$$$ DO 10 KKK = 1,97
27411c$$$ 10 U(KKK) = UIN(KKK)
27412c$$$ C = CIN
27413c$$$ CD = CDIN
27414c$$$ CM = CMIN
27415c$$$ I = IIN
27416c$$$ J = JIN
27417c$$$
27418c$$$ RETURN
27419c$$$ END
27420c$$$
27421c$$$*$ CREATE DT_RNDMOU.FOR
27422c$$$*COPY DT_RNDMOU
27423c$$$*
27424c$$$*===rndmou=============================================================*
27425c$$$*
27426c$$$ SUBROUTINE DT_RNDMOU(UOUT,COUT,CDOUT,CMOUT,IOUT,JOUT)
27427c$$$
27428c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27429c$$$ SAVE
27430c$$$
27431c$$$* random number generator
27432c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27433c$$$
27434c$$$ DIMENSION UOUT(97)
27435c$$$
27436c$$$ DO 10 KKK = 1,97
27437c$$$ 10 UOUT(KKK) = U(KKK)
27438c$$$ COUT = C
27439c$$$ CDOUT = CD
27440c$$$ CMOUT = CM
27441c$$$ IOUT = I
27442c$$$ JOUT = J
27443c$$$
27444c$$$ RETURN
27445c$$$ END
27446c$$$
27447c$$$*$ CREATE DT_RNDMTE.FOR
27448c$$$*COPY DT_RNDMTE
27449c$$$*
27450c$$$*===rndmte=============================================================*
27451c$$$*
27452c$$$ SUBROUTINE DT_RNDMTE(IO)
27453c$$$
27454c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27455c$$$ SAVE
27456c$$$
27457c$$$ DIMENSION UU(97),U(6),X(6),D(6)
27458c$$$ DATA U / 6533892.D0, 14220222.D0, 7275067.D0, 6172232.D0,
27459c$$$ +8354498.D0, 10633180.D0/
27460c$$$
27461c$$$ CALL DT_RNDMOU(UU,CC,CCD,CCM,II,JJ)
27462c$$$ CALL DT_RNDMST(12,34,56,78)
27463c$$$ DO 10 II1 = 1,20000
27464c$$$ 10 XX = DT_RNDM(XX)
27465c$$$ SD = 0.0D0
27466c$$$ DO 20 II2 = 1,6
27467c$$$ X(II2) = 4096.D0*(4096.D0*DT_RNDM(SD))
27468c$$$ D(II2) = X(II2)-U(II2)
27469c$$$ 20 SD = SD+D(II2)
27470c$$$ CALL DT_RNDMIN(UU,CC,CCD,CCM,II,JJ)
27471c$$$**sr 24.01.95
27472c$$$C IF ( IO.EQ. 1.OR. SD.NE.0. 0) WRITE(6,500) (U(I),X(I),D(I),I=1,6)
27473c$$$ IF ((IO.EQ.1).OR.(SD.NE.0.0)) THEN
27474c$$$C WRITE(6,1000)
27475c$$$ 1000 FORMAT(/,/,1X,'DT_RNDMTE: Test of random-number generator...',
27476c$$$ & ' passed')
27477c$$$ ENDIF
27478c$$$**
27479c$$$ RETURN
27480c$$$ 500 FORMAT(' === TEST OF THE RANDOM-GENERATOR ===',/,
27481c$$$ &' EXPECTED VALUE CALCULATED VALUE DIFFERENCE',/, 6(F17.
27482c$$$ &1,F20.1,F15.3,/), ' === END OF TEST ;',
27483c$$$ &' GENERATOR HAS THE SAME STATUS AS BEFORE CALLING DT_RNDMTE')
27484c$$$ END
9aaba0d6 27485*
27486*$ CREATE PHO_RNDM.FOR
27487*COPY PHO_RNDM
27488*
27489*===pho_rndm===========================================================*
27490*
27491 DOUBLE PRECISION FUNCTION PHO_RNDM(DUMMY)
27492
27493 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27494 SAVE
27495
27496 PHO_RNDM = DT_RNDM(DUMMY)
27497
27498 RETURN
27499 END
27500
27501*$ CREATE PYR.FOR
27502*COPY PYR
27503*
27504*===pyr================================================================*
27505*
27506 DOUBLE PRECISION FUNCTION PYR(IDUMMY)
27507
27508 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27509 SAVE
27510
27511 DUMMY = DBLE(IDUMMY)
27512 PYR = DT_RNDM(DUMMY)
27513
27514 RETURN
27515 END
27516
27517*$ CREATE DT_TITLE.FOR
27518*COPY DT_TITLE
27519*
27520*===title==============================================================*
27521*
27522 SUBROUTINE DT_TITLE
27523
27524 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27525 SAVE
27526 PARAMETER ( LINP = 10 ,
27527 & LOUT = 6 ,
27528 & LDAT = 9 )
27529
27530 CHARACTER*6 CVERSI
27531 CHARACTER*11 CCHANG
27532 DATA CVERSI,CCHANG /'3.0-5 ','08 Jan 2007'/
27533
27534 CALL DT_XTIME
27535 WRITE(LOUT,1000) CVERSI,CCHANG
27536 1000 FORMAT(1X,'+-------------------------------------------------',
27537 & '----------------------+',/,
27538 & 1X,'|',71X,'|',/,
27539 & 1X,'|',26X,'DPMJET version ',A6,24X,'|',/,
27540 & 1X,'|',71X,'|',/,
27541 & 1X,'|',22X,'(Last change: ',A11,')',23X,'|',/,
27542 & 1X,'|',71X,'|',/,
27543 & 1X,'|',12X,'Authors: Stefan Roesler (CERN)',27X,'|',/,
27544 & 1X,'|',21X,'Ralph Engel (FZ Karlsruhe)',19X,'|',/,
27545 & 1X,'|',21X,'Johannes Ranft (Siegen Univ.)',19X,'|',/,
27546 & 1X,'|',71X,'|',/,
27547 & 1X,'|',12X,'http://home.cern.ch/~sroesler/dpmjet3.html',
27548 & 17X,'|',/,
27549 & 1X,'|',71X,'|',/,
27550 & 1X,'+-------------------------------------------------',
27551 & '----------------------+',/,
27552 & 1X,'| Please send suggestions, bug reports, etc. to: ',
27553 & 'Stefan.Roesler@cern.ch |',/,
27554 & 1X,'+-------------------------------------------------',
27555 & '----------------------+',/)
27556
27557 RETURN
27558 END
27559
27560*$ CREATE DT_EVTINI.FOR
27561*COPY DT_EVTINI
27562*
27563*===evtini=============================================================*
27564*
27565 SUBROUTINE DT_EVTINI
27566
27567************************************************************************
27568* Initialization of DTEVT1. *
27569* This version dated 15.01.94 is written by S. Roesler *
27570************************************************************************
27571
27572 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27573 SAVE
27574 PARAMETER ( LINP = 10 ,
27575 & LOUT = 6 ,
27576 & LDAT = 9 )
27577
27578* event history
27579 PARAMETER (NMXHKK=200000)
27580 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27581 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27582 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27583* extended event history
27584 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27585 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27586 & IHIST(2,NMXHKK)
27587* event flag
27588 COMMON /DTEVNO/ NEVENT,ICASCA
27589 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
27590* emulsion treatment
27591 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
27592 & NCOMPO,IEMUL
27593
27594* initialization of DTEVT1/DTEVT2
27595 NEND = NHKK
27596 IF (NEVENT.EQ.1) NEND = NMXHKK
27597 NHKK = 0
27598 NEVHKK = NEVENT
27599 DO 1 I=1,NEND
27600 ISTHKK(I) = 0
27601 IDHKK(I) = 0
27602 JMOHKK(1,I) = 0
27603 JMOHKK(2,I) = 0
27604 JDAHKK(1,I) = 0
27605 JDAHKK(2,I) = 0
27606 IDRES(I) = 0
27607 IDXRES(I) = 0
27608 NOBAM(I) = 0
27609 IDCH(I) = 0
27610 IHIST(1,I) = 0
27611 IHIST(2,I) = 0
27612 DO 2 J=1,4
27613 PHKK(J,I) = 0.0D0
27614 VHKK(J,I) = 0.0D0
27615 WHKK(J,I) = 0.0D0
27616 2 CONTINUE
27617 PHKK(5,I) = 0.0D0
27618 1 CONTINUE
27619 DO 3 I=1,10
27620 NPOINT(I) = 0
27621 3 CONTINUE
27622 CALL DT_CHASTA(-1)
27623
27624C* initialization of DTLTRA
27625C IF (NCOMPO.GT.0) CALL DT_LTINI(ID,EPN,PPN,ECM)
27626
27627 RETURN
27628 END
27629
27630*$ CREATE DT_STATIS.FOR
27631*COPY DT_STATIS
27632*
27633*===statis=============================================================*
27634*
27635 SUBROUTINE DT_STATIS(MODE)
27636
27637************************************************************************
27638* Initialization and output of run-statistics. *
27639* MODE = 1 initialization *
27640* = 2 output *
27641* This version dated 23.01.94 is written by S. Roesler *
27642************************************************************************
27643
27644 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27645 SAVE
27646 PARAMETER ( LINP = 10 ,
27647 & LOUT = 6 ,
27648 & LDAT = 9 )
27649 PARAMETER (TINY3=1.0D-3)
27650
27651* statistics
27652 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
27653 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
27654 & ICEVTG(8,0:30)
27655* rejection counter
27656 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27657 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27658 & IREXCI(3),IRDIFF(2),IRINC
27659* central particle production, impact parameter biasing
27660 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
27661* various options for treatment of partons (DTUNUC 1.x)
27662* (chain recombination, Cronin,..)
27663 LOGICAL LCO2CR,LINTPT
27664 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
27665 & LCO2CR,LINTPT
27666* nucleon-nucleon event-generator
27667 CHARACTER*8 CMODEL
27668 LOGICAL LPHOIN
27669 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
27670* flags for particle decays
27671 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
27672 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
27673 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
27674* diquark-breaking mechanism
27675 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
27676
27677 DIMENSION PP(4),PT(4)
27678
27679 GOTO (1,2) MODE
27680
27681* initialization
27682 1 CONTINUE
27683
27684* initialize statistics counter
27685 ICREQU = 0
27686 ICSAMP = 0
27687 ICCPRO = 0
27688 ICDPR = 0
27689 ICDTA = 0
27690 ICRJSS = 0
27691 ICVV2S = 0
27692 DO 10 I=1,9
27693 ICRES(I) = 0
27694 ICCHAI(1,I) = 0
27695 ICCHAI(2,I) = 0
27696 10 CONTINUE
27697* initialize rejection counter
27698 IRPT = 0
27699 IRHHA = 0
27700 LOMRES = 0
27701 LOBRES = 0
27702 IRFRAG = 0
27703 IREVT = 0
27704 IRRES(1) = 0
27705 IRRES(2) = 0
27706 IRCHKI(1) = 0
27707 IRCHKI(2) = 0
27708 IRCRON(1) = 0
27709 IRCRON(2) = 0
27710 IRCRON(3) = 0
27711 IRDIFF(1) = 0
27712 IRDIFF(2) = 0
27713 IRINC = 0
27714 DO 11 I=1,5
27715 ICDIFF(I) = 0
27716 11 CONTINUE
27717 DO 12 I=1,8
27718 DO 13 J=0,30
27719 ICEVTG(I,J) = 0
27720 13 CONTINUE
27721 12 CONTINUE
27722
27723 RETURN
27724
27725* output
27726 2 CONTINUE
27727
27728* statistics counter
27729 WRITE(LOUT,1000)
27730 1000 FORMAT(/,/,1X,'STATIS:',20X,'statistics of the run',/,
27731 & 28X,'---------------------')
27732 WRITE(LOUT,1001) ICREQU,ICSAMP,DBLE(ICSAMP)/DBLE(ICREQU)
27733 1001 FORMAT(/,1X,'number of events requested / sampled',13X,
27734 & I8,' / ',I8,/,1X,'number of samp. evts per requested ',
27735 & 'event',11X,F9.1)
27736 IF (ICDIFF(1).NE.0) THEN
27737 WRITE(LOUT,1009) ICDIFF
27738 1009 FORMAT(/,1X,'diffractive events: total ',I8,/,49X,
27739 & 'low mass high mass',/,24X,'single diffraction',
27740 & 7X,I8,4X,I8,/,24X,'double diffraction',7X,I8,4X,I8)
27741 ENDIF
27742 IF (ICENTR.GT.0) THEN
27743 WRITE(LOUT,1002) DBLE(ICCPRO)/DBLE(ICSAMP),
27744 & DBLE(ICSAMP)/DBLE(ICCPRO)
27745 1002 FORMAT(/,1X,'central production:',/,2X,'mean number',
27746 & ' of sampled Glauber-events per event',9X,F9.1,/,
27747 & 2X,'fraction of production cross section',21X,F10.6)
27748 ENDIF
27749 WRITE(LOUT,1003) DBLE(ICDPR)/DBLE(ICSAMP),
27750 & DBLE(ICDTA)/DBLE(ICSAMP)
27751 1003 FORMAT(/,54X,'proj. targ.',/,1X,'average number of wounded',
27752 & ' nucleons after x-sampling',2(4X,F6.2))
27753
27754 IF (MCGENE.EQ.1) THEN
27755 WRITE(LOUT,1004) DBLE(ICRJSS)/DBLE(ICSAMP)
27756 1004 FORMAT(/,1X,'mean number of sea-sea chain rejections per',
27757 & ' event',3X,F9.1)
27758 IF (ISICHA.EQ.1) THEN
27759 WRITE(LOUT,1005) DBLE(ICVV2S)/DBLE(ICSAMP)
27760 1005 FORMAT(/,1X,'Reggeon contribution:',/,1X,'mean number ',
27761 & 'of single chains per event',13X,F9.1)
27762 ENDIF
27763 WRITE(LOUT,1006)
27764 1006 FORMAT(/,1X,'chain system statistics: (per event)',/,
27765 & 23X,'mean number of chains mean number of chains',/,
27766 & 23X,'sampled hadronized having mass of a reso.')
27767 WRITE(LOUT,1007) (DBLE(ICCHAI(1,J))/(2.0D0*DBLE(ICSAMP)),
27768 & DBLE(ICCHAI(2,J))/(2.0D0*DBLE(ICREQU)),
27769 & DBLE(ICRES(J))/(2.0D0*DBLE(ICREQU)),J=1,8),
27770 & DBLE(ICCHAI(2,9))/MAX(DBLE(ICCHAI(1,9)),TINY3)
27771 1007 FORMAT(1X,'sea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27772 & 1X,'disea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27773 & 1X,'sea - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27774 & 1X,'sea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27775 & 1X,'disea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27776 & 1X,'valence - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27777 & 1X,'valence - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27778 & 1X,'valence - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27779 & 1X,'fused chains ',18X,F4.1,17X,F4.1,/)
27780 WRITE(LOUT,1008)
27781 & (DBLE(IRCRON(I))/MAX(DBLE(IRCRON(1)),TINY3),I=2,3),
27782 & DBLE(IRPT)/DBLE(ICREQU),(DBLE(IRRES(I))/DBLE(ICREQU),I=1,2),
27783 & DBLE(LOMRES)/DBLE(ICREQU),DBLE(LOBRES)/DBLE(ICREQU),
27784 & (DBLE(IRCHKI(I))/DBLE(ICREQU),I=1,2),
27785 & (DBLE(IRDIFF(I))/DBLE(ICREQU),I=1,2),
27786 & DBLE(IRHHA)/DBLE(ICREQU),
27787 & DBLE(IRFRAG)/DBLE(ICREQU),DBLE(IREVT)/DBLE(ICREQU),
27788 & (DBLE(IREXCI(I))/DBLE(ICREQU),I=1,2),IREXCI(3)
27789 1008 FORMAT(/,1X,'Rejection counter: (NEVT = no. of events)',/,/,
27790 & 1X,'Cronin-effect (CRONIN)',15X,'IRCRON(2)/IRCRON(1) = ',
27791 & F7.2,/,38X,'IRCRON(3)/IRCRON(1) = ',F7.2,/,1X,
27792 & 'Intrins. p_t (GETSPT)',21X,'IRPT /NEVT = ',F7.2,/,
27793 & 1X,'Chain mass corr. for resonances (EVTRES)',2X,
27794 & 'IRRES(1) /NEVT = ',F7.2,/,33X,'(CH2RES) IRRES(2) /',
27795 & 'NEVT = ',F7.2,/,43X,'LOMRES /NEVT = ',F7.2,/,
27796 & 43X,'LOBRES /NEVT = ',F7.2,/,1X,'Kinem. corr. of',
27797 & ' 2-chain systems (CHKINE) IRCHKI(1)/NEVT = ',F7.2,/,
27798 & 43X,'IRCHKI(2)/NEVT = ',F7.2,/,1X,'Diffraction',31X,
27799 & 'IRDIFF(1)/NEVT = ',F7.2,/,43X,'IRDIFF(2)/NEVT = ',
27800 & F7.2,/,1X,'Total no. of rej.',
27801 & ' in chain-systems treatment (GETCSY)',/,43X,
27802 & 'IRHHA /NEVT = ',F7.2,/,1X,'Fragmentation (EVTFRA)',
27803 & ' (not yet used!)',4X,'IRFRAG /NEVT = ',F7.2,/,
27804 & 1X,'Total no. of rej. in DPM-treatment of one event',
27805 & ' (EVENTA)',/,43X,'IREVT /NEVT = ',F7.2,/,1X,
27806 & 'Treatment of final nucleon conf.',10X,'IREXCI(1)/NEVT = '
27807 & ,F7.2,/,43X,'IREXCI(2)/NEVT = ',F7.2,/,48X,
27808 & 'IREXCI(3) = ',I5,/)
27809 ELSEIF (MCGENE.EQ.2) THEN
27810 WRITE(LOUT,1010) ELOJET
27811 1010 FORMAT(/,/,1X,'PHOJET-treatment of chain systems above ',
27812 & F4.1,' GeV')
27813 WRITE(LOUT,1011)
27814 1011 FORMAT(/,1X,'1. chain system statistics - total numbers:',/,
27815 & 30X,'--------------',/,/,12X,'s-s',5X,'d-s',5X,'s-d',
27816 & 5X,'s-v',5X,'d-v',5X,'v-s',5X,'v-d',5X,'v-v')
27817 WRITE(LOUT,1012) ((ICEVTG(I,J),I=1,8),J=0,1),
27818 & (INT(ICCHAI(2,I)/2.0D0),I=1,8),
27819 & (ICEVTG(I,2),I=1,8),(ICEVTG(I,29),I=1,8),
27820 & ((ICEVTG(I,J),I=1,8),J=3,7),
27821 & ((ICEVTG(I,J),I=1,8),J=19,21),
27822 & (ICEVTG(I,8),I=1,8),
27823 & ((ICEVTG(I,J),I=1,8),J=22,24),
27824 & (ICEVTG(I,9),I=1,8),
27825 & ((ICEVTG(I,J),I=1,8),J=25,28),
27826 & ((ICEVTG(I,J),I=1,8),J=10,18)
27827 1012 FORMAT(/,1X,'req.to.',8I8,/,/,1X,'low rq.',8I8,/,1X,'low ac.',
27828 & 8I8,/,/,1X,'PHOJET ',8I8,/,' sngl ',8I8,/,/,
27829 & ' no-dif.',8I8,/,
27830 & ' el-sca.',8I8,/,' qel-sc.',8I8,/,' dbl-Po.',8I8,/,
27831 & ' diff-1 ',8I8,/,' low ',8I8,/,' high ',8I8,/,
27832 & ' h-diff',8I8,/,' diff-2 ',8I8,/,' low ',8I8,/,
27833 & ' high ',8I8,/,' h-diff',8I8,/,' dbl-di.',8I8,/,
27834 & ' lo-lo ',8I8,/,' hi-hi ',8I8,/,' lo-hi ',8I8,/,
27835 & ' hi-lo ',8I8,/,
27836 & ' dir-ga.',8I8,/,/,' dir-1 ',8I8,/,' dir-2 ',8I8,/,
27837 & ' dbl-dir',8I8,/,' s-Pom. ',8I8,/,' h-Pom. ',8I8,/,
27838 & ' s-Reg. ',8I8,/,' enh-trg',8I8,/,' enh-log',8I8)
27839 WRITE(LOUT,1013)
27840 1013 FORMAT(/,1X,'2. chain system statistics -',
27841 & ' mean numbers per evt:',/,30X,'---------------------',
27842 & /,/,16X,'s-s',7X,'d-s',7X,'s-d')
27843 WRITE(LOUT,1014)
27844 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=0,1),
27845 & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=1,3),
27846 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=2,18)
27847 1014 FORMAT(/,1X,'req.to. ',3E10.2,/,/,1X,'low rq. ',3E10.2,/,
27848 & 1X,'low ac. ',3E10.2,/,/,1X,'PHOJET ',3E10.2,/,/,
27849 & ' no-dif. ',3E10.2,/,' el-sca. ',3E10.2,/,
27850 & ' qel-sc. ',3E10.2,/,' dbl-Po. ',3E10.2,/,
27851 & ' diff-1 ',3E10.2,/,' diff-2 ',3E10.2,/,
27852 & ' dbl-di. ',3E10.2,/,' dir-ga. ',3E10.2,/,/,
27853 & ' dir-1 ',3E10.2,/,' dir-2 ',3E10.2,/,
27854 & ' dbl-dir ',3E10.2,/,' s-Pom. ',3E10.2,/,
27855 & ' h-Pom. ',3E10.2,/,' s-Reg. ',3E10.2,/,
27856 & ' enh-trg ',3E10.2,/,' enh-log ',3E10.2)
27857 WRITE(LOUT,1015)
27858 1015 FORMAT(/,16X,'s-v',7X,'d-v',7X,'v-s',7X,'v-d',7X,'v-v')
27859 WRITE(LOUT,1016)
27860 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=0,1),
27861 & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=4,8),
27862 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=2,18)
27863 1016 FORMAT(/,1X,'req.to. ',5E10.2,/,/,1X,'low rq. ',5E10.2,/,
27864 & 1X,'low ac. ',5E10.2,/,/,1X,'PHOJET ',5E10.2,/,/,
27865 & ' no-dif. ',5E10.2,/,' el-sca. ',5E10.2,/,
27866 & ' qel-sc. ',5E10.2,/,' dbl-Po. ',5E10.2,/,
27867 & ' diff-1 ',5E10.2,/,' diff-2 ',5E10.2,/,
27868 & ' dbl-di. ',5E10.2,/,' dir-ga. ',5E10.2,/,/,
27869 & ' dir-1 ',5E10.2,/,' dir-2 ',5E10.2,/,
27870 & ' dbl-dir ',5E10.2,/,' s-Pom. ',5E10.2,/,
27871 & ' h-Pom. ',5E10.2,/,' s-Reg. ',5E10.2,/,
27872 & ' enh-trg ',5E10.2,/,' enh-log ',5E10.2)
27873
27874 ENDIF
27875 CALL DT_CHASTA(1)
27876
27877 IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
27878 & .OR.(PDBSEA(3).GT.0.0D0)) THEN
27879 WRITE(LOUT,*)'YGS1S,YGS2S,YUS1S,YUS2S',
27880 & DBRKA(1,1)+DBRKA(2,1),DBRKA(1,2)+DBRKA(2,2),
27881 & DBRKA(1,3)+DBRKA(2,3),DBRKA(1,4)+DBRKA(2,4)
27882 WRITE(LOUT,*)'YGS1R,YGS2R,YUS1R,YUS2R',
27883 & DBRKR(1,1)+DBRKR(2,1),DBRKR(1,2)+DBRKR(2,2),
27884 & DBRKR(1,3)+DBRKR(2,3),DBRKR(1,4)+DBRKR(2,4)
27885 WRITE(LOUT,*)'YGSA1S,YGSA2S,YUSA1S,YUSA2S',
27886 & DBRKA(1,5)+DBRKA(2,5),DBRKA(1,6)+DBRKA(2,6),
27887 & DBRKA(1,7)+DBRKA(2,7),DBRKA(1,8)+DBRKA(2,8)
27888 WRITE(LOUT,*)'YGSA1R,YGSA2R,YUSA1R,YUSA2R',
27889 & DBRKR(1,5)+DBRKR(2,5),DBRKR(1,6)+DBRKR(2,6),
27890 & DBRKR(1,7)+DBRKR(2,7),DBRKR(1,8)+DBRKR(2,8)
27891 WRITE(LOUT,*)'YG31S,YG32S,YU31S,YU32S',
27892 & DBRKA(3,1),DBRKA(3,2),
27893 & DBRKA(3,3),DBRKA(3,4)
27894 WRITE(LOUT,*)'YG31R,YG32R,YU31R,YU32R',
27895 & DBRKR(3,1),DBRKR(3,2),
27896 & DBRKR(3,3),DBRKR(3,4)
27897 WRITE(LOUT,*)'YG3A1S,YG3A2S,YU3A1S,YU3A2S',
27898 & DBRKA(3,5),DBRKA(3,6),
27899 & DBRKA(3,7),DBRKA(3,8)
27900 WRITE(LOUT,*)'YG3A1R,YG3A2R,YU3A1R,YU3A2R',
27901 & DBRKR(3,5),DBRKR(3,6),
27902 & DBRKR(3,7),DBRKR(3,8)
27903 ENDIF
27904
27905 FAC = 1.0D0
27906 IF (MCGENE.EQ.2) THEN
27907C CALL PHO_PHIST(-2,SIGMAX)
27908 CALL PHO_EVENT(-2,PP,PT,FAC,IREJ1)
27909 ENDIF
27910
27911 CALL DT_XTIME
27912
27913 RETURN
27914 END
27915
27916*$ CREATE DT_EVTOUT.FOR
27917*COPY DT_EVTOUT
27918*
27919*===evtout=============================================================*
27920*
27921 SUBROUTINE DT_EVTOUT(MODE)
27922
27923************************************************************************
27924* MODE = 1 plot content of complete DTEVT1 to out. unit *
27925* 3 plot entries of extended DTEVT1 (DTEVT2) *
27926* 4 plot entries of DTEVT1 and DTEVT2 *
27927* This version dated 11.12.94 is written by S. Roesler *
27928************************************************************************
27929
27930 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27931 SAVE
27932 PARAMETER ( LINP = 10 ,
27933 & LOUT = 6 ,
27934 & LDAT = 9 )
27935* event history
27936 PARAMETER (NMXHKK=200000)
27937 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27938 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27939 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27940
27941 DIMENSION IRANGE(NMXHKK)
27942
27943 IF (MODE.EQ.2) RETURN
27944
27945 CALL DT_EVTPLO(IRANGE,MODE)
27946
27947 RETURN
27948 END
27949
27950*$ CREATE DT_EVTPLO.FOR
27951*COPY DT_EVTPLO
27952*
27953*===evtplo=============================================================*
27954*
27955 SUBROUTINE DT_EVTPLO(IRANGE,MODE)
27956
27957************************************************************************
27958* MODE = 1 plot content of complete DTEVT1 to out. unit *
27959* 2 plot entries of DTEVT1 given by IRANGE *
27960* 3 plot entries of extended DTEVT1 (DTEVT2) *
27961* 4 plot entries of DTEVT1 and DTEVT2 *
27962* 5 plot rejection counter *
27963* This version dated 11.12.94 is written by S. Roesler *
27964************************************************************************
27965
27966 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27967 SAVE
27968 PARAMETER ( LINP = 10 ,
27969 & LOUT = 6 ,
27970 & LDAT = 9 )
27971
27972 CHARACTER*16 CHAU
27973
27974* event history
27975 PARAMETER (NMXHKK=200000)
27976 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27977 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27978 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27979* extended event history
27980 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27981 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27982 & IHIST(2,NMXHKK)
27983* rejection counter
27984 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27985 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27986 & IREXCI(3),IRDIFF(2),IRINC
27987
27988 DIMENSION IRANGE(NMXHKK)
27989
27990 IF ((MODE.EQ.1).OR.(MODE.EQ.4)) THEN
27991 WRITE(LOUT,1000)
27992 1000 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTEVT1/',/,
27993 & 15X,' --------------------------',/,/,
27994 & ' ST ID M1 M2 D1 D2 PX PY',
27995 & ' PZ E M',/)
27996 DO 1 I=1,NHKK
27997 WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27998 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27999 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
28000 & PHKK(5,I)
28001C WRITE(LOUT,1011) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28002C & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28003C & PHKK(3,I),PHKK(4,I)
28004C WRITE(LOUT,'(4E15.4)')
28005C & VHKK(1,I),VHKK(2,I),VHKK(3,I),VHKK(4,I)
28006 1001 FORMAT(I5,I5,I6,4I5,3F7.3,F8.3,F8.4)
28007 1011 FORMAT(I5,I5,I6,4I5,2E15.5)
28008 1 CONTINUE
28009 WRITE(LOUT,*)
28010C DO 4 I=1,NHKK
28011C WRITE(LOUT,1006) I,ISTHKK(I),
28012C & VHKK(1,I),VHKK(2,I),VHKK(3,I),WHKK(1,I),
28013C & WHKK(2,I),WHKK(3,I)
28014C1006 FORMAT(1X,I4,I6,6E10.3)
28015C 4 CONTINUE
28016 ENDIF
28017
28018 IF (MODE.EQ.2) THEN
28019 WRITE(LOUT,1000)
28020 NC = 0
28021 2 CONTINUE
28022 NC = NC+1
28023 IF (IRANGE(NC).EQ.-100) GOTO 9999
28024 I = IRANGE(NC)
28025 WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28026 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28027 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
28028 & PHKK(5,I)
28029 GOTO 2
28030 ENDIF
28031
28032 IF ((MODE.EQ.3).OR.(MODE.EQ.4)) THEN
28033 WRITE(LOUT,1002)
28034 1002 FORMAT(/,1X,'EVTPLO:',14X,
28035 & ' content of COMMON /DTEVT1/,/DTEVT2/',/,
28036 & 15X,' -----------------------------------',/,/,
28037 & ' ST ID M1 M2 D1 D2 IDR IDXR',
28038 & ' NOBAM IDCH M',/)
28039 DO 3 I=1,NHKK
28040C IF ((ISTHKK(I).GT.10).OR.(ISTHKK(I).EQ.1)) THEN
28041 KF = IDHKK(I)
28042 IDCHK = KF/10000
28043 IF ((((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
28044 & (KF.NE.80000)).OR.(IDHKK(I).EQ.99999)) KF = 92
28045 CALL PYNAME(KF,CHAU)
28046 WRITE(LOUT,1003) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28047 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28048 & IDRES(I),IDXRES(I),NOBAM(I),IDCH(I),
28049 & PHKK(5,I),CHAU
28050 1003 FORMAT(I5,I5,I6,4I5,4I4,F8.4,2X,A)
28051C ENDIF
28052 3 CONTINUE
28053 ENDIF
28054
28055 IF (MODE.EQ.5) THEN
28056 WRITE(LOUT,1004)
28057 1004 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTREJC/',/,
28058 & 15X,' --------------------------',/)
28059 WRITE(LOUT,1005) IRPT,IRHHA,IRRES,LOMRES,LOBRES,IREMC,IRFRAG,
28060 & IRSEA,IRCRON
28061 1005 FORMAT(1X,'IRPT = ',I5,' IRHHA = ',I5,/,
28062 & 1X,'IRRES = ',2I5,' LOMRES = ',I5,' LOBRES = ',I5,/,
28063 & 1X,'IREMC = ',10I5,/,
28064 & 1X,'IRFRAG = ',I5,' IRSEA = ',I5,' IRCRON = ',I5,/)
28065 ENDIF
28066
28067 9999 RETURN
28068 END
28069
28070*$ CREATE DT_EVTPUT.FOR
28071*COPY DT_EVTPUT
28072*
28073*===evtput=============================================================*
28074*
28075 SUBROUTINE DT_EVTPUT(IST,ID,M1,M2,PX,PY,PZ,E,IDR,IDXR,IDC)
28076
28077 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28078 SAVE
28079 PARAMETER ( LINP = 10 ,
28080 & LOUT = 6 ,
28081 & LDAT = 9 )
28082 PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,TINY3=1.0D-3,
28083 & TINY2=1.0D-2,SQTINF=1.0D+15,ZERO=0.0D0)
28084
28085* event history
28086 PARAMETER (NMXHKK=200000)
28087 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28088 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28089 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28090* extended event history
28091 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28092 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28093 & IHIST(2,NMXHKK)
28094* Lorentz-parameters of the current interaction
28095 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28096 & UMO,PPCM,EPROJ,PPROJ
28097* particle properties (BAMJET index convention)
28098 CHARACTER*8 ANAME
28099 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28100 & IICH(210),IIBAR(210),K1(210),K2(210)
28101
28102C IF (MODE.GT.100) THEN
28103C WRITE(LOUT,'(1X,A,I5,A,I5)')
28104C & 'EVTPUT: reset NHKK = ',NHKK,' to NHKK =',NHKK-MODE+100
28105C NHKK = NHKK-MODE+100
28106C RETURN
28107C ENDIF
28108 MO1 = M1
28109 MO2 = M2
28110 NHKK = NHKK+1
28111
28112 IF (NHKK.GT.NMXHKK) THEN
28113 WRITE(LOUT,1000) NHKK
28114 1000 FORMAT(1X,'EVTPUT: NHKK exeeds NMXHKK = ',I7,
28115 & '! program execution stopped..')
28116 STOP
28117 ENDIF
28118 IF (M1.LT.0) MO1 = NHKK+M1
28119 IF (M2.LT.0) MO2 = NHKK+M2
28120 ISTHKK(NHKK) = IST
28121 IDHKK(NHKK) = ID
28122 JMOHKK(1,NHKK) = MO1
28123 JMOHKK(2,NHKK) = MO2
28124 JDAHKK(1,NHKK) = 0
28125 JDAHKK(2,NHKK) = 0
28126 IDRES(NHKK) = IDR
28127 IDXRES(NHKK) = IDXR
28128 IDCH(NHKK) = IDC
28129** here we need to do something..
28130 IF (ID.EQ.88888) THEN
28131 IDMO1 = ABS(IDHKK(MO1))
28132 IDMO2 = ABS(IDHKK(MO2))
28133 IF ((IDMO1.LT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 3
28134 IF ((IDMO1.LT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 4
28135 IF ((IDMO1.GT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 5
28136 IF ((IDMO1.GT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 6
28137 ELSE
28138 NOBAM(NHKK) = 0
28139 ENDIF
28140 IDBAM(NHKK) = IDT_ICIHAD(ID)
28141 IF (MO1.GT.0) THEN
28142 IF (JDAHKK(1,MO1).NE.0) THEN
28143 JDAHKK(2,MO1) = NHKK
28144 ELSE
28145 JDAHKK(1,MO1) = NHKK
28146 ENDIF
28147 ENDIF
28148 IF (MO2.GT.0) THEN
28149 IF (JDAHKK(1,MO2).NE.0) THEN
28150 JDAHKK(2,MO2) = NHKK
28151 ELSE
28152 JDAHKK(1,MO2) = NHKK
28153 ENDIF
28154 ENDIF
28155C IF ((IDBAM(NHKK).GT.0).AND.(IDBAM(NHKK).NE.7)) THEN
28156C PTOT = SQRT(PX**2+PY**2+PZ**2)
28157C AM0 = SQRT(ABS( (E-PTOT)*(E+PTOT) ))
28158C AMRQ = AAM(IDBAM(NHKK))
28159C AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
28160C IF ((ABS(AMDIF2).GT.TINY3).AND.(E.LT.SQTINF).AND.
28161C & (PTOT.GT.ZERO)) THEN
28162C DELTA = -AMDIF2/(2.0D0*(E+PTOT))
28163CC DELTA = (AMRQ2-AM2)/(2.0D0*(E+PTOT))
28164C E = E+DELTA
28165C PTOT1 = PTOT-DELTA
28166C PX = PX*PTOT1/PTOT
28167C PY = PY*PTOT1/PTOT
28168C PZ = PZ*PTOT1/PTOT
28169C ENDIF
28170C ENDIF
28171 PHKK(1,NHKK) = PX
28172 PHKK(2,NHKK) = PY
28173 PHKK(3,NHKK) = PZ
28174 PHKK(4,NHKK) = E
28175 PTOT = SQRT( PX**2+PY**2+PZ**2 )
28176 IF ((IDHKK(NHKK).GE.22).AND.(IDHKK(NHKK).LE.24)) THEN
28177 PHKK(5,NHKK) = PHKK(4,NHKK)**2-PTOT**2
28178 PHKK(5,NHKK) = SIGN(SQRT(ABS(PHKK(5,NHKK))),PHKK(5,NHKK))
28179 ELSE
28180 PHKK(5,NHKK) = (PHKK(4,NHKK)-PTOT)*(PHKK(4,NHKK)+PTOT)
28181C IF ((PHKK(5,NHKK).LT.0.0D0).AND.(ABS(PHKK(5,NHKK)).GT.TINY4))
28182C & WRITE(LOUT,'(1X,A,G10.3)')
28183C & 'EVTPUT: negative mass**2 ',PHKK(5,NHKK)
28184 PHKK(5,NHKK) = SQRT(ABS(PHKK(5,NHKK)))
28185 ENDIF
28186 IDCHK = ID/10000
28187 IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.(ID.NE.80000)) THEN
28188* special treatment for chains:
28189* z coordinate of chain in Lab = pos. of target nucleon
28190* time of chain-creation in Lab = time of passage of projectile
28191* nucleus at pos. of taget nucleus
28192C VHKK(1,NHKK) = 0.5D0*(VHKK(1,MO1)+VHKK(1,MO2))
28193C VHKK(2,NHKK) = 0.5D0*(VHKK(2,MO1)+VHKK(2,MO2))
28194 VHKK(1,NHKK) = VHKK(1,MO2)
28195 VHKK(2,NHKK) = VHKK(2,MO2)
28196 VHKK(3,NHKK) = VHKK(3,MO2)
28197 VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
28198C WHKK(1,NHKK) = 0.5D0*(WHKK(1,MO1)+WHKK(1,MO2))
28199C WHKK(2,NHKK) = 0.5D0*(WHKK(2,MO1)+WHKK(2,MO2))
28200 WHKK(1,NHKK) = WHKK(1,MO1)
28201 WHKK(2,NHKK) = WHKK(2,MO1)
28202 WHKK(3,NHKK) = WHKK(3,MO1)
28203 WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
28204 ELSE
28205 IF (MO1.GT.0) THEN
28206 DO 1 I=1,4
28207 VHKK(I,NHKK) = VHKK(I,MO1)
28208 WHKK(I,NHKK) = WHKK(I,MO1)
28209 1 CONTINUE
28210 ELSE
28211 DO 2 I=1,4
28212 VHKK(I,NHKK) = ZERO
28213 WHKK(I,NHKK) = ZERO
28214 2 CONTINUE
28215 ENDIF
28216 ENDIF
28217
28218 RETURN
28219 END
28220
28221*$ CREATE DT_CHASTA.FOR
28222*COPY DT_CHASTA
28223*
28224*===chasta=============================================================*
28225*
28226 SUBROUTINE DT_CHASTA(MODE)
28227
28228************************************************************************
28229* This subroutine performs CHAin STAtistics and checks sequence of *
28230* partons in dtevt1 and sorts them with projectile partons coming *
28231* first if necessary. *
28232* *
28233* This version dated 8.5.00 is written by S. Roesler. *
28234************************************************************************
28235
28236 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28237 SAVE
28238 PARAMETER ( LINP = 10 ,
28239 & LOUT = 6 ,
28240 & LDAT = 9 )
28241
28242 CHARACTER*5 CCHTYP
28243
28244* event history
28245 PARAMETER (NMXHKK=200000)
28246 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28247 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28248 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28249* extended event history
28250 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28251 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28252 & IHIST(2,NMXHKK)
28253* pointer to chains in hkkevt common (used by qq-breaking mechanisms)
28254 PARAMETER (MAXCHN=10000)
28255 COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
28256
28257 DIMENSION ICHCFG(10,10,9,2),ICHTYP(5,5),
28258 & CCHTYP(9),ICHSTA(10),ITOT(10)
28259 DATA ICHCFG /1800*0/
28260 DATA (ICHTYP(1,K),K=1,5) / 0, 1, 3, 0, 0/
28261 DATA (ICHTYP(2,K),K=1,5) / 2, 0, 0, 5, 0/
28262 DATA (ICHTYP(3,K),K=1,5) / 4, 0, 0, 7, 0/
28263 DATA (ICHTYP(4,K),K=1,5) / 0, 6, 8, 0, 0/
28264 DATA (ICHTYP(5,K),K=1,5) / 0, 0, 0, 0, 9/
28265 DATA ICHSTA / 21, 22, 31, 32, 41, 42, 51, 52, 61, 62/
28266 DATA CCHTYP / ' q aq','aq q ',' q d ',' d q ','aq ad',
28267 & 'ad aq',' d ad','ad d ',' g g '/
28268*
28269* initialization
28270*
28271 IF (MODE.EQ.-1) THEN
28272 NCHAIN = 0
28273*
28274* loop over DTEVT1 and analyse chain configurations
28275*
28276 ELSEIF (MODE.EQ.0) THEN
28277 DO 21 IDX=NPOINT(3),NHKK
28278 IDCHK = IDHKK(IDX)/10000
28279 IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
28280 & (IDHKK(IDX).NE.80000).AND.
28281 & (ISTHKK(IDX).NE.2).AND.(IDRES(IDX).EQ.0)) THEN
28282 IF (JMOHKK(1,IDX).GT.JMOHKK(2,IDX)) THEN
28283 WRITE(LOUT,*) ' CHASTA: JMOHKK(1,x) > JMOHKK(2,x) ',
28284 & ' at entry ',IDX
28285 GOTO 21
28286 ENDIF
28287*
28288 IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28289 IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28290 IMO1 = IST1/10
28291 IMO1 = IST1-10*IMO1
28292 IMO2 = IST2/10
28293 IMO2 = IST2-10*IMO2
28294* swop parton entries if necessary since we need projectile partons
28295* to come first in the common
28296 IF (IMO1.GT.IMO2) THEN
28297 NPTN = JMOHKK(2,IDX)-JMOHKK(1,IDX)+1
28298 DO 22 K=1,NPTN/2
28299 I0 = JMOHKK(1,IDX)-1+K
28300 I1 = JMOHKK(2,IDX)+1-K
28301 ITMP = ISTHKK(I0)
28302 ISTHKK(I0) = ISTHKK(I1)
28303 ISTHKK(I1) = ITMP
28304 ITMP = IDHKK(I0)
28305 IDHKK(I0) = IDHKK(I1)
28306 IDHKK(I1) = ITMP
28307 IF (JDAHKK(1,JMOHKK(1,I0)).EQ.I0)
28308 & JDAHKK(1,JMOHKK(1,I0)) = I1
28309 IF (JDAHKK(2,JMOHKK(1,I0)).EQ.I0)
28310 & JDAHKK(2,JMOHKK(1,I0)) = I1
28311 IF (JDAHKK(1,JMOHKK(2,I0)).EQ.I0)
28312 & JDAHKK(1,JMOHKK(2,I0)) = I1
28313 IF (JDAHKK(2,JMOHKK(2,I0)).EQ.I0)
28314 & JDAHKK(2,JMOHKK(2,I0)) = I1
28315 IF (JDAHKK(1,JMOHKK(1,I1)).EQ.I1)
28316 & JDAHKK(1,JMOHKK(1,I1)) = I0
28317 IF (JDAHKK(2,JMOHKK(1,I1)).EQ.I1)
28318 & JDAHKK(2,JMOHKK(1,I1)) = I0
28319 IF (JDAHKK(1,JMOHKK(2,I1)).EQ.I1)
28320 & JDAHKK(1,JMOHKK(2,I1)) = I0
28321 IF (JDAHKK(2,JMOHKK(2,I1)).EQ.I1)
28322 & JDAHKK(2,JMOHKK(2,I1)) = I0
28323 ITMP = JMOHKK(1,I0)
28324 JMOHKK(1,I0) = JMOHKK(1,I1)
28325 JMOHKK(1,I1) = ITMP
28326 ITMP = JMOHKK(2,I0)
28327 JMOHKK(2,I0) = JMOHKK(2,I1)
28328 JMOHKK(2,I1) = ITMP
28329 ITMP = JDAHKK(1,I0)
28330 JDAHKK(1,I0) = JDAHKK(1,I1)
28331 JDAHKK(1,I1) = ITMP
28332 ITMP = JDAHKK(2,I0)
28333 JDAHKK(2,I0) = JDAHKK(2,I1)
28334 JDAHKK(2,I1) = ITMP
28335 DO 23 J=1,4
28336 RTMP1 = PHKK(J,I0)
28337 RTMP2 = VHKK(J,I0)
28338 RTMP3 = WHKK(J,I0)
28339 PHKK(J,I0) = PHKK(J,I1)
28340 VHKK(J,I0) = VHKK(J,I1)
28341 WHKK(J,I0) = WHKK(J,I1)
28342 PHKK(J,I1) = RTMP1
28343 VHKK(J,I1) = RTMP2
28344 WHKK(J,I1) = RTMP3
28345 23 CONTINUE
28346 RTMP1 = PHKK(5,I0)
28347 PHKK(5,I0) = PHKK(5,I1)
28348 PHKK(5,I1) = RTMP1
28349 ITMP = IDRES(I0)
28350 IDRES(I0) = IDRES(I1)
28351 IDRES(I1) = ITMP
28352 ITMP = IDXRES(I0)
28353 IDXRES(I0) = IDXRES(I1)
28354 IDXRES(I1) = ITMP
28355 ITMP = NOBAM(I0)
28356 NOBAM(I0) = NOBAM(I1)
28357 NOBAM(I1) = ITMP
28358 ITMP = IDBAM(I0)
28359 IDBAM(I0) = IDBAM(I1)
28360 IDBAM(I1) = ITMP
28361 ITMP = IDCH(I0)
28362 IDCH(I0) = IDCH(I1)
28363 IDCH(I1) = ITMP
28364 ITMP = IHIST(1,I0)
28365 IHIST(1,I0) = IHIST(1,I1)
28366 IHIST(1,I1) = ITMP
28367 ITMP = IHIST(2,I0)
28368 IHIST(2,I0) = IHIST(2,I1)
28369 IHIST(2,I1) = ITMP
28370 22 CONTINUE
28371 ENDIF
28372 IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28373 IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28374*
28375* parton 1 (projectile side)
28376 IF (IST1.EQ.21) THEN
28377 IDX1 = 1
28378 ELSEIF (IST1.EQ.22) THEN
28379 IDX1 = 2
28380 ELSEIF (IST1.EQ.31) THEN
28381 IDX1 = 3
28382 ELSEIF (IST1.EQ.32) THEN
28383 IDX1 = 4
28384 ELSEIF (IST1.EQ.41) THEN
28385 IDX1 = 5
28386 ELSEIF (IST1.EQ.42) THEN
28387 IDX1 = 6
28388 ELSEIF (IST1.EQ.51) THEN
28389 IDX1 = 7
28390 ELSEIF (IST1.EQ.52) THEN
28391 IDX1 = 8
28392 ELSEIF (IST1.EQ.61) THEN
28393 IDX1 = 9
28394 ELSEIF (IST1.EQ.62) THEN
28395 IDX1 = 10
28396 ELSE
28397c WRITE(LOUT,*)
28398c & ' CHASTA: unknown parton status flag (',
28399c & IST1,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28400 GOTO 21
28401 ENDIF
28402 ID = IDHKK(JMOHKK(1,IDX))
28403 IF (ABS(ID).LE.4) THEN
28404 IF (ID.GT.0) THEN
28405 ITYP1 = 1
28406 ELSE
28407 ITYP1 = 2
28408 ENDIF
28409 ELSEIF (ABS(ID).GE.1000) THEN
28410 IF (ID.GT.0) THEN
28411 ITYP1 = 3
28412 ELSE
28413 ITYP1 = 4
28414 ENDIF
28415 ELSEIF (ID.EQ.21) THEN
28416 ITYP1 = 5
28417 ELSE
28418 WRITE(LOUT,*)
28419 & ' CHASTA: inconsistent parton identity (',
28420 & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28421 GOTO 21
28422 ENDIF
28423*
28424* parton 2 (target side)
28425 IF (IST2.EQ.21) THEN
28426 IDX2 = 1
28427 ELSEIF (IST2.EQ.22) THEN
28428 IDX2 = 2
28429 ELSEIF (IST2.EQ.31) THEN
28430 IDX2 = 3
28431 ELSEIF (IST2.EQ.32) THEN
28432 IDX2 = 4
28433 ELSEIF (IST2.EQ.41) THEN
28434 IDX2 = 5
28435 ELSEIF (IST2.EQ.42) THEN
28436 IDX2 = 6
28437 ELSEIF (IST2.EQ.51) THEN
28438 IDX2 = 7
28439 ELSEIF (IST2.EQ.52) THEN
28440 IDX2 = 8
28441 ELSEIF (IST2.EQ.61) THEN
28442 IDX2 = 9
28443 ELSEIF (IST2.EQ.62) THEN
28444 IDX2 = 10
28445 ELSE
28446c WRITE(LOUT,*)
28447c & ' CHASTA: unknown parton status flag (',
28448c & IST2,') at entry ',JMOHKK(2,IDX),'(',IDX,')'
28449 GOTO 21
28450 ENDIF
28451 ID = IDHKK(JMOHKK(2,IDX))
28452 IF (ABS(ID).LE.4) THEN
28453 IF (ID.GT.0) THEN
28454 ITYP2 = 1
28455 ELSE
28456 ITYP2 = 2
28457 ENDIF
28458 ELSEIF (ABS(ID).GE.1000) THEN
28459 IF (ID.GT.0) THEN
28460 ITYP2 = 3
28461 ELSE
28462 ITYP2 = 4
28463 ENDIF
28464 ELSEIF (ID.EQ.21) THEN
28465 ITYP2 = 5
28466 ELSE
28467 WRITE(LOUT,*)
28468 & ' CHASTA: inconsistent parton identity (',
28469 & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28470 GOTO 21
28471 ENDIF
28472*
28473* fill counter
28474 ITYPE = ICHTYP(ITYP1,ITYP2)
28475 IF (ITYPE.NE.0) THEN
28476 ICHCFG(IDX1,IDX2,ITYPE,1) =ICHCFG(IDX1,IDX2,ITYPE,1)+1
28477 NGLUON = JMOHKK(2,IDX)-JMOHKK(1,IDX)-1
28478 ICHCFG(IDX1,IDX2,ITYPE,2) =
28479 & ICHCFG(IDX1,IDX2,ITYPE,2)+NGLUON
28480
28481 NCHAIN = NCHAIN+1
28482 IF (NCHAIN.GT.MAXCHN) THEN
28483 WRITE(LOUT,*) ' CHASTA: NCHAIN > MAXCHN ! ',
28484 & NCHAIN,MAXCHN
28485 STOP
28486 ENDIF
28487 IDXCHN(1,NCHAIN) = IDX
28488 IDXCHN(2,NCHAIN) = ITYPE
28489 ELSE
28490 WRITE(LOUT,*)
28491 & ' CHASTA: inconsistent chain at entry ',IDX
28492 GOTO 21
28493 ENDIF
28494 ENDIF
28495 21 CONTINUE
28496*
28497* write statistics to output unit
28498*
28499 ELSEIF (MODE.EQ.1) THEN
28500 WRITE(LOUT,'(/,A)') ' CHASTA: generated chain configurations'
28501 DO 31 I=1,10
28502 WRITE(LOUT,'(/,2A)')
28503 & ' -----------------------------------------',
28504 & '------------------------------------'
28505 WRITE(LOUT,'(2A)')
28506 & ' p\\t 21 22 31 32 41',
28507 & ' 42 51 52 61 62'
28508 WRITE(LOUT,'(2A)')
28509 & ' -----------------------------------------',
28510 & '------------------------------------'
28511 DO 32 J=1,10
28512 ITOT(J) = 0
28513 DO 33 K=1,9
28514 ITOT(J) = ITOT(J)+ICHCFG(I,J,K,1)
28515 33 CONTINUE
28516 32 CONTINUE
28517 WRITE(LOUT,'(1X,I2,5X,10I7,/)') ICHSTA(I),(ITOT(J),J=1,10)
28518 DO 34 K=1,9
28519 ISUM = 0
28520 DO 35 J=1,10
28521 ISUM = ISUM+ICHCFG(I,J,K,1)
28522 35 CONTINUE
28523 IF (ISUM.GT.0)
28524 & WRITE(LOUT,'(1X,A5,2X,10I7)')
28525 & CCHTYP(K),(ICHCFG(I,J,K,1),J=1,10)
28526 34 CONTINUE
28527C WRITE(LOUT,'(2A)')
28528C & ' -----------------------------------------',
28529C & '-------------------------------'
28530 31 CONTINUE
28531*
28532 ELSE
28533 WRITE(LOUT,*) ' CHASTA: MODE ',MODE,' not supported !'
28534 STOP
28535 ENDIF
28536
28537 RETURN
28538 END
28539*$ CREATE PHO_PHIST.FOR
28540*COPY PHO_PHIST
28541*
28542*===pohist=============================================================*
28543*
28544 SUBROUTINE PHO_PHIST(IMODE,WEIGHT)
28545
28546 IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28547 SAVE
28548
28549 PARAMETER ( LINP = 10 ,
28550 & LOUT = 6 ,
28551 & LDAT = 9 )
28552 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
28553* Glauber formalism: cross sections
28554 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
28555 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
28556 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
28557 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
28558 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
28559 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
28560 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
28561 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
28562 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
28563 & BSLOPE,NEBINI,NQBINI
28564
28565 ILAB = 0
28566 IF (IMODE.EQ.10) THEN
28567 IMODE = 1
28568 ILAB = 1
28569 ENDIF
28570 IF (ABS(IMODE).LT.1000) THEN
28571* PHOJET-statistics
28572C CALL POHISX(IMODE,WEIGHT)
28573 IF (IMODE.EQ.-1) THEN
28574 MODE = 1
28575 XSTOT(1,1,1) = WEIGHT
28576 ENDIF
28577 IF (IMODE.EQ. 1) MODE = 2
28578 IF (IMODE.EQ.-2) MODE = 3
28579 IF (MODE.EQ.2) CALL DT_SWPPHO(ILAB)
28580C IF (MODE.EQ.3) WRITE(LOUT,*)
28581C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization'
28582 CALL DT_HISTOG(MODE)
28583 CALL DT_USRHIS(MODE)
28584 ELSE
28585* DTUNUC-statistics
28586 MODE = IMODE/1000
28587C IF (MODE.EQ.3) WRITE(LOUT,*)
28588C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization'
28589 CALL DT_HISTOG(MODE)
28590 CALL DT_USRHIS(MODE)
28591 ENDIF
28592
28593 RETURN
28594 END
28595
28596*$ CREATE DT_SWPPHO.FOR
28597*COPY DT_SWPPHO
28598*
28599*===swppho=============================================================*
28600*
28601 SUBROUTINE DT_SWPPHO(ILAB)
28602
28603 IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28604 SAVE
28605 PARAMETER ( LINP = 10 ,
28606 & LOUT = 6 ,
28607 & LDAT = 9 )
28608 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28609
28610 LOGICAL LSTART
28611
28612* event history
28613 PARAMETER (NMXHKK=200000)
28614 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28615 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28616 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28617* extended event history
28618 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28619 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28620 & IHIST(2,NMXHKK)
28621* flags for input different options
28622 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28623 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28624 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28625* properties of photon/lepton projectiles
28626 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
28627
28628**PHOJET105a
28629C PARAMETER (NMXHEP=2000)
28630C COMMON/HEPEVS/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28631C &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
28632C COMMON /GLOCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28633C COMMON /PLASAV/ PLAB
28634**PHOJET110
28635C standard particle data interface
28636 INTEGER NMXHEP
28637 PARAMETER (NMXHEP=4000)
28638 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28639 DOUBLE PRECISION PHEP,VHEP
28640 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28641 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28642 & VHEP(4,NMXHEP)
28643C extension to standard particle data interface (PHOJET specific)
28644 INTEGER IMPART,IPHIST,ICOLOR
28645 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28646C global event kinematics and particle IDs
28647 INTEGER IFPAP,IFPAB
28648 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
28649 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28650**
28651 DATA ICOUNT/0/
28652
28653 DATA LSTART /.TRUE./
28654
28655C IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0).AND.LSTART) THEN
28656 IF ((IFRAME.EQ.1).AND.LSTART) THEN
28657 UMO = ECM
28658 ELA = ZERO
28659 PLA = ZERO
28660 IDP = IDT_ICIHAD(IFPAP(1))
28661 IDT = IDT_ICIHAD(IFPAP(2))
28662 VIRT = PVIRT(1)
28663 CALL DT_LTINI(IDP,IDT,ELA,PLA,UMO,0)
28664 PLAB = PLA
28665 LSTART = .FALSE.
28666 ENDIF
28667
28668 NHKK = 0
28669 ICOUNT = ICOUNT+1
28670C NEVHKK = NEVHEP
28671 NEVHKK = ICOUNT
28672 IF (MOD(ICOUNT,500).EQ.0) WRITE(LOUT,*)' SWPPHO: event # ',ICOUNT
28673 DO 1 I=3,NHEP
28674 IF (ISTHEP(I).EQ.1) THEN
28675 NHKK = NHKK+1
28676 ISTHKK(NHKK) = 1
28677 IDHKK(NHKK) = IDHEP(I)
28678 JMOHKK(1,NHKK) = 0
28679 JMOHKK(2,NHKK) = 0
28680 JDAHKK(1,NHKK) = 0
28681 JDAHKK(2,NHKK) = 0
28682 DO 2 K=1,4
28683 PHKK(K,NHKK) = PHEP(K,I)
28684 VHKK(K,NHKK) = ZERO
28685 WHKK(K,NHKK) = ZERO
28686 2 CONTINUE
28687 IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0))
28688 & CALL DT_LTNUC(PHEP(3,I),PHEP(4,I),
28689 & PHKK(3,NHKK),PHKK(4,NHKK),-3)
28690 PHKK(5,NHKK) = PHEP(5,I)
28691 IDRES(NHKK) = 0
28692 IDXRES(NHKK) = 0
28693 NOBAM(NHKK) = 0
28694 IDBAM(NHKK) = IDT_ICIHAD(IDHEP(I))
28695 IDCH(NHKK) = 0
28696 ENDIF
28697 1 CONTINUE
28698
28699 RETURN
28700 END
28701
28702*$ CREATE DT_HISTOG.FOR
28703*COPY DT_HISTOG
28704*
28705*===histog=============================================================*
28706*
28707 SUBROUTINE DT_HISTOG(MODE)
28708
28709************************************************************************
28710* This version dated 25.03.96 is written by S. Roesler *
28711************************************************************************
28712
28713 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28714 SAVE
28715 PARAMETER ( LINP = 10 ,
28716 & LOUT = 6 ,
28717 & LDAT = 9 )
28718
28719 LOGICAL LFSP,LRNL
28720
28721* event history
28722 PARAMETER (NMXHKK=200000)
28723 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28724 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28725 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28726* extended event history
28727 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28728 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28729 & IHIST(2,NMXHKK)
28730* event flag used for histograms
28731 COMMON /DTNORM/ ICEVT,IEVHKK
28732* flags for activated histograms
28733 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
28734
28735 IEVHKK = NEVHKK
28736 GOTO (1,2,3) MODE
28737
28738*------------------------------------------------------------------
28739* initialization
28740 1 CONTINUE
28741 ICEVT = 0
28742 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,1)
28743 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(1)
28744
28745 RETURN
28746*------------------------------------------------------------------
28747* filling of histogram with event-record
28748 2 CONTINUE
28749 ICEVT = ICEVT+1
28750
28751 DO 20 I=1,NHKK
28752 CALL DT_SWPFSP(I,LFSP,LRNL)
28753 IF (LFSP) THEN
28754 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,2)
28755 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(2)
28756 ENDIF
28757 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,5)
28758 20 CONTINUE
28759 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,4)
28760
28761 RETURN
28762*------------------------------------------------------------------
28763* output
28764 3 CONTINUE
28765 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,3)
28766 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(3)
28767
28768 RETURN
28769 END
28770
28771*$ CREATE DT_SWPFSP.FOR
28772*COPY DT_SWPFSP
28773*
28774*===swpfsp=============================================================*
28775*
28776 SUBROUTINE DT_SWPFSP(IDX,LFSP,LRNL)
28777
28778 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28779 SAVE
28780 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28781 PARAMETER (TWOPI=6.283185307179586476925286766559D+00,
28782 & PI =TWOPI/TWO,
28783 & BOG =TWOPI/360.0D0)
28784
28785* event history
28786 PARAMETER (NMXHKK=200000)
28787 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28788 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28789 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28790* extended event history
28791 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28792 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28793 & IHIST(2,NMXHKK)
28794* particle properties (BAMJET index convention)
28795 CHARACTER*8 ANAME
28796 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28797 & IICH(210),IIBAR(210),K1(210),K2(210)
28798* Lorentz-parameters of the current interaction
28799 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28800 & UMO,PPCM,EPROJ,PPROJ
28801* flags for input different options
28802 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28803 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28804 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28805* (original name: PAREVT)
28806 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
28807 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
28808 PARAMETER ( NALLWP = 39 )
28809 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
28810 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
28811 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
28812 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
28813* temporary storage for one final state particle
28814 LOGICAL LFRAG,LGREY,LBLACK
28815 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
28816 & SINTHE,COSTHE,THETA,THECMS,
28817 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
28818 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
28819 & LFRAG,LGREY,LBLACK
28820
28821 LOGICAL LFSP,LRNL
28822
28823 LFSP = .FALSE.
28824 LRNL = .FALSE.
28825 ISTRNL = 1000
28826 MULDEF = 1
28827 IF (LEVPRT) ISTRNL = 1001
28828
28829 IF (ABS(ISTHKK(IDX)).EQ.1) THEN
28830 IST = ISTHKK(IDX)
28831 IDPDG = IDHKK(IDX)
28832 LFRAG = .FALSE.
28833 IF (IDHKK(IDX).LT.80000) THEN
28834 IDBJT = IDBAM(IDX)
28835 IBARY = IIBAR(IDBJT)
28836 ICHAR = IICH(IDBJT)
28837 AMASS = AAM(IDBJT)
28838 ELSEIF (IDHKK(IDX).EQ.80000) THEN
28839 IDBJT = 0
28840 IBARY = IDRES(IDX)
28841 ICHAR = IDXRES(IDX)
28842 AMASS = PHKK(5,IDX)
28843 INUT = IBARY-ICHAR
28844 IF ((ICHAR.EQ.1).AND.(INUT.EQ.1)) IDBJT = 116
28845 IF ((ICHAR.EQ.1).AND.(INUT.EQ.2)) IDBJT = 117
28846 IF ((ICHAR.EQ.2).AND.(INUT.EQ.1)) IDBJT = 118
28847 IF ((ICHAR.EQ.2).AND.(INUT.EQ.2)) IDBJT = 119
28848 IF (IDBJT.EQ.0) LFRAG = .TRUE.
28849 ELSE
28850 GOTO 9999
28851 ENDIF
28852 PE = PHKK(4,IDX)
28853 PX = PHKK(1,IDX)
28854 PY = PHKK(2,IDX)
28855 PZ = PHKK(3,IDX)
28856 PT2 = PX**2+PY**2
28857 PT = SQRT(PT2)
28858 PTOT = SQRT(PT2+PZ**2)
28859 SINTHE = PT/MAX(PTOT,TINY14)
28860 COSTHE = PZ/MAX(PTOT,TINY14)
28861 IF (COSTHE.GT.ONE) THEN
28862 THETA = ZERO
28863 ELSEIF (COSTHE.LT.-ONE) THEN
28864 THETA = TWOPI/2.0D0
28865 ELSE
28866 THETA = ACOS(COSTHE)
28867 ENDIF
28868 EKIN = PE-AMASS
28869**sr 15.4.96 new E_t-definition
28870 IF (IBARY.GT.0) THEN
28871 ET = EKIN*SINTHE
28872 ELSEIF (IBARY.LT.0) THEN
28873 ET = (EKIN+TWO*AMASS)*SINTHE
28874 ELSE
28875 ET = PE*SINTHE
28876 ENDIF
28877**
28878 XLAB = PZ/MAX(PPROJ,TINY14)
28879C XLAB = PE/MAX(EPROJ,TINY14)
28880 BETA = SQRT(ABS( (ONE-AMASS/MAX(PE,TINY14))
28881 & *(ONE+AMASS/MAX(PE,TINY14)) ))
28882 PPLUS = PE+PZ
28883 PMINUS = PE-PZ
28884 IF (PMINUS.GT.TINY14) THEN
28885 YY = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28886 ELSE
28887 YY = 100.0D0
28888 ENDIF
28889 IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
28890 ETA = -LOG(TAN(THETA/TWO))
28891 ELSE
28892 ETA = 100.0D0
28893 ENDIF
28894 IF (IFRAME.EQ.1) THEN
28895 CALL DT_LTNUC(PZ,PE,PZCMS,EECMS,3)
28896 PPLUS = EECMS+PZCMS
28897 PMINUS = EECMS-PZCMS
28898 IF ((PPLUS*PMINUS).GT.TINY14) THEN
28899 YYCMS = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28900 ELSE
28901 YYCMS = 100.0D0
28902 ENDIF
28903 PTOTCM = SQRT(PT2+PZCMS**2)
28904 COSTH = PZCMS/MAX(PTOTCM,TINY14)
28905 IF (COSTH.GT.ONE) THEN
28906 THECMS = ZERO
28907 ELSEIF (COSTH.LT.-ONE) THEN
28908 THECMS = TWOPI/2.0D0
28909 ELSE
28910 THECMS = ACOS(COSTH)
28911 ENDIF
28912 IF ((THECMS.GT.TINY14).AND.((PI-THECMS).GT.TINY14)) THEN
28913 ETACMS = -LOG(TAN(THECMS/TWO))
28914 ELSE
28915 ETACMS = 100.0D0
28916 ENDIF
28917 XF = PZCMS/MAX(PPCM,TINY14)
28918 THECMS = THECMS/BOG
28919 ELSE
28920 PZCMS = PZ
28921 EECMS = PE
28922 YYCMS = YY
28923 ETACMS = ETA
28924 XF = XLAB
28925 THECMS = THETA/BOG
28926 ENDIF
28927 THETA = THETA/BOG
28928
28929* set flag for "grey/black"
28930 LGREY = .FALSE.
28931 LBLACK = .FALSE.
28932 EK = EKIN
28933 IF (IDHKK(IDX).EQ.80000) EK = EKIN/DBLE(IBARY)
28934 IF (MULDEF.EQ.1) THEN
28935* EMU01-Def.
28936 IF ( ( (IDBJT.EQ. 1).AND.(EK.GT. 26.0D-3).AND.
28937 & (EK.LE.375.0D-3) ).OR.
28938 & ( (IDBJT.EQ.13).AND.(EK.GT. 12.0D-3).AND.
28939 & (EK.LE. 56.0D-3) ).OR.
28940 & ( (IDBJT.EQ.14).AND.(EK.GT. 12.0D-3).AND.
28941 & (EK.LE. 56.0D-3) ).OR.
28942 & ( (IDBJT.EQ.15).AND.(EK.GT. 20.0D-3).AND.
28943 & (EK.LE.198.0D-3) ).OR.
28944 & ( (IDBJT.EQ.16).AND.(EK.GT. 20.0D-3).AND.
28945 & (EK.LE.198.0D-3) ).OR.
28946 & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28947 & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28948 & (IDBJT.NE.16).AND.
28949 & (BETA.GT.0.23D0).AND.(BETA.LE.0.70D0) ) )
28950 & LGREY = .TRUE.
28951 IF ( ( (IDBJT.EQ. 1).AND.(EK.LE. 26.0D-3) ).OR.
28952 & ( (IDBJT.EQ.13).AND.(EK.LE. 12.0D-3) ).OR.
28953 & ( (IDBJT.EQ.14).AND.(EK.LE. 12.0D-3) ).OR.
28954 & ( (IDBJT.EQ.15).AND.(EK.LE. 20.0D-3) ).OR.
28955 & ( (IDBJT.EQ.16).AND.(EK.LE. 20.0D-3) ).OR.
28956 & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28957 & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28958 & (IDBJT.NE.16).AND.(BETA.LE.0.23D0) ) )
28959 & LBLACK = .TRUE.
28960 ELSE
28961* common Def.
28962 IF ((BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)) LGREY=.TRUE.
28963 IF (BETA.LE.0.23D0) LBLACK=.TRUE.
28964 ENDIF
28965 LFSP = .TRUE.
28966 ELSEIF (ABS(ISTHKK(IDX)).EQ.ISTRNL) THEN
28967 IST = ISTHKK(IDX)
28968 IDPDG = IDHKK(IDX)
28969 LFRAG = .TRUE.
28970 IDBJT = 0
28971 IBARY = IDRES(IDX)
28972 ICHAR = IDXRES(IDX)
28973 AMASS = PHKK(5,IDX)
28974 PE = PHKK(4,IDX)
28975 PX = PHKK(1,IDX)
28976 PY = PHKK(2,IDX)
28977 PZ = PHKK(3,IDX)
28978 PT2 = PX**2+PY**2
28979 PT = SQRT(PT2)
28980 PTOT = SQRT(PT2+PZ**2)
28981 SINTHE = PT/MAX(PTOT,TINY14)
28982 COSTHE = PZ/MAX(PTOT,TINY14)
28983 IF (COSTHE.GT.ONE) THEN
28984 THETA = ZERO
28985 ELSEIF (COSTHE.LT.-ONE) THEN
28986 THETA = TWOPI/2.0D0
28987 ELSE
28988 THETA = ACOS(COSTHE)
28989 ENDIF
28990 EKIN = PE-AMASS
28991**sr 15.4.96 new E_t-definition
28992C ET = PE*SINTHE
28993 ET = EKIN*SINTHE
28994**
28995 IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
28996 ETA = -LOG(TAN(THETA/TWO))
28997 ELSE
28998 ETA = 100.0D0
28999 ENDIF
29000 THETA = THETA/BOG
29001 LRNL = .TRUE.
29002 ENDIF
29003
29004 9999 CONTINUE
29005 RETURN
29006 END
29007
29008*$ CREATE DT_HIMULT.FOR
29009*COPY DT_HIMULT
29010*
29011*===himult=============================================================*
29012*
29013 SUBROUTINE DT_HIMULT(MODE)
29014
29015************************************************************************
29016* Tables of average energies/multiplicities. *
29017* This version dated 30.08.2000 is written by S. Roesler *
29018************************************************************************
29019
29020 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29021 SAVE
29022 PARAMETER ( LINP = 10 ,
29023 & LOUT = 6 ,
29024 & LDAT = 9 )
29025 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
29026
29027 PARAMETER (SWMEXP=1.7D0)
29028
29029 CHARACTER*8 ANAMEH(4)
29030
29031* particle properties (BAMJET index convention)
29032 CHARACTER*8 ANAME
29033 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29034 & IICH(210),IIBAR(210),K1(210),K2(210)
29035* temporary storage for one final state particle
29036 LOGICAL LFRAG,LGREY,LBLACK
29037 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
29038 & SINTHE,COSTHE,THETA,THECMS,
29039 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
29040 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
29041 & LFRAG,LGREY,LBLACK
29042* event flag used for histograms
29043 COMMON /DTNORM/ ICEVT,IEVHKK
29044* Lorentz-parameters of the current interaction
29045 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
29046 & UMO,PPCM,EPROJ,PPROJ
29047
29048 PARAMETER (NOPART=210)
29049 DIMENSION AVMULT(4,NOPART),AVE(4,NOPART),AVSWM(4,NOPART),
29050 & AVPT(4,NOPART),IAVPT(4,NOPART)
29051 DATA ANAMEH /'DEUTERON','3-H ','3-HE ','4-HE '/
29052
29053 GOTO (1,2,3) MODE
29054
29055*------------------------------------------------------------------
29056* initialization
29057 1 CONTINUE
29058 DO 10 I=1,NOPART
29059 DO 11 J=1,4
29060 AVMULT(J,I) = ZERO
29061 AVE(J,I) = ZERO
29062 AVSWM(J,I) = ZERO
29063 AVPT(J,I) = ZERO
29064 IAVPT(J,I) = 0
29065 11 CONTINUE
29066 10 CONTINUE
29067
29068 RETURN
29069
29070*------------------------------------------------------------------
29071* filling of histogram with event-record
29072 2 CONTINUE
29073 IF (PE.LT.0.0D0) THEN
29074 WRITE(LOUT,*) ' HIMULT: PE < 0 ! ',PE
29075 RETURN
29076 ENDIF
29077 IF (.NOT.LFRAG) THEN
29078 IVEL = 2
29079 IF (LGREY) IVEL = 3
29080 IF (LBLACK) IVEL = 4
29081 AVE(1,IDBJT) = AVE(1,IDBJT) +PE
29082 AVE(IVEL,IDBJT) = AVE(IVEL,IDBJT)+PE
29083 AVPT(1,IDBJT) = AVPT(1,IDBJT) +PT
29084 AVPT(IVEL,IDBJT) = AVPT(IVEL,IDBJT)+PT
29085 IAVPT(1,IDBJT) = IAVPT(1,IDBJT) +1
29086 IAVPT(IVEL,IDBJT) = IAVPT(IVEL,IDBJT)+1
29087 AVSWM(1,IDBJT) = AVSWM(1,IDBJT) +PE**SWMEXP
29088 AVSWM(IVEL,IDBJT) = AVSWM(IVEL,IDBJT)+PE**SWMEXP
29089 AVMULT(1,IDBJT) = AVMULT(1,IDBJT) +ONE
29090 AVMULT(IVEL,IDBJT) = AVMULT(IVEL,IDBJT)+ONE
29091 IF (IDBJT.LT.116) THEN
29092* total energy, multiplicity
29093 AVE(1,30) = AVE(1,30) +PE
29094 AVE(IVEL,30) = AVE(IVEL,30)+PE
29095 AVPT(1,30) = AVPT(1,30) +PT
29096 AVPT(IVEL,30) = AVPT(IVEL,30)+PT
29097 IAVPT(1,30) = IAVPT(1,30) +1
29098 IAVPT(IVEL,30) = IAVPT(IVEL,30)+1
29099 AVSWM(1,30) = AVSWM(1,30)+PE**SWMEXP
29100 AVSWM(IVEL,30) = AVSWM(IVEL,30)+PE**SWMEXP
29101 AVMULT(1,30) = AVMULT(1,30) +ONE
29102 AVMULT(IVEL,30) = AVMULT(IVEL,30)+ONE
29103* charged energy, multiplicity
29104 IF (ICHAR.LT.0) THEN
29105 AVE(1,26) = AVE(1,26) +PE
29106 AVE(IVEL,26) = AVE(IVEL,26)+PE
29107 AVPT(1,26) = AVPT(1,26) +PT
29108 AVPT(IVEL,26) = AVPT(IVEL,26)+PT
29109 IAVPT(1,26) = IAVPT(1,26) +1
29110 IAVPT(IVEL,26) = IAVPT(IVEL,26)+1
29111 AVSWM(1,26) = AVSWM(1,26) +PE**SWMEXP
29112 AVSWM(IVEL,26) = AVSWM(IVEL,26)+PE**SWMEXP
29113 AVMULT(1,26) = AVMULT(1,26) +ONE
29114 AVMULT(IVEL,26) = AVMULT(IVEL,26)+ONE
29115 ENDIF
29116 IF (ICHAR.NE.0) THEN
29117 AVE(1,27) = AVE(1,27) +PE
29118 AVE(IVEL,27) = AVE(IVEL,27)+PE
29119 AVPT(1,27) = AVPT(1,27) +PT
29120 AVPT(IVEL,27) = AVPT(IVEL,27)+PT
29121 IAVPT(1,27) = IAVPT(1,27) +1
29122 IAVPT(IVEL,27) = IAVPT(IVEL,27)+1
29123 AVSWM(1,27) = AVSWM(1,27) +PE**SWMEXP
29124 AVSWM(IVEL,27) = AVSWM(IVEL,27)+PE**SWMEXP
29125 AVMULT(1,27) = AVMULT(1,27) +ONE
29126 AVMULT(IVEL,27) = AVMULT(IVEL,27)+ONE
29127 ENDIF
29128 ENDIF
29129 ENDIF
29130
29131 RETURN
29132
29133*------------------------------------------------------------------
29134* output
29135 3 CONTINUE
29136 WRITE(LOUT,3000)
29137 3000 FORMAT(/,1X,'HIMULT:',21X,'particle - statistics',/,
29138 & 29X,'---------------------',/)
29139 IF (MULDEF.EQ.1) THEN
29140 WRITE(LOUT,'(1X,A,/)') 'fast/grey/black: EMU-def.'
29141 ELSE
29142 BETGRE = 0.7D0
29143 BETBLC = 0.23D0
29144 WRITE(LOUT,3002) BETGRE,BETGRE,BETBLC,BETBLC
29145 3002 FORMAT(1X,'fast: beta > ',F4.2,' grey: ',F4.2,' > beta > '
29146 & ,F4.2,' black: beta < ',F4.2,/)
29147 ENDIF
29148 WRITE(LOUT,3003) SWMEXP
29149 3003 FORMAT(1X,'particle |',12X,'average multiplicity',/,
29150 & 13X,'| total fast',
29151C & ' grey black K f(',F3.1,')',/,1X,
29152 & ' grey black <pt> f(',F3.1,')',/,1X,
29153 & '------------+--------------',
29154 & '-------------------------------------------------')
29155 DO 30 I=1,NOPART
29156 DO 31 J=1,4
29157 AVMULT(J,I) = AVMULT(J,I)/DBLE(MAX(ICEVT,1))
29158 AVE(J,I) = AVE(J,I)/DBLE(MAX(ICEVT,1))/EPROJ
29159 AVPT(J,I) = AVPT(J,I)/DBLE(MAX(IAVPT(J,I),1))
29160 AVSWM(J,I) = AVSWM(J,I)/DBLE(MAX(ICEVT,1))/EPROJ**SWMEXP
29161 31 CONTINUE
29162 IF (I.LE.115) THEN
29163 WRITE(LOUT,3004) ANAME(I),I,
29164 & AVMULT(1,I),AVMULT(2,I),
29165 & AVMULT(3,I),AVMULT(4,I),
29166C & AVE(1,I),AVSWM(1,I)
29167 & AVPT(1,I),AVSWM(1,I)
29168 ELSEIF (I.LE.119) THEN
29169 WRITE(LOUT,3004) ANAMEH(I-115),I,
29170 & AVMULT(1,I),AVMULT(2,I),
29171 & AVMULT(3,I),AVMULT(4,I),
29172C & AVE(1,I),AVSWM(1,I)
29173 & AVPT(1,I),AVSWM(1,I)
29174 ENDIF
29175 3004 FORMAT(1X,A8,I4,'| ',2F13.6,2F9.5,2F9.5)
29176 30 CONTINUE
29177**temporary
29178C WRITE(LOUT,'(A,F7.3)') ' number of charged heavy particles: ',
29179C & AVMULT(3,27)+AVMULT(4,27)
29180**
29181
29182 RETURN
29183 END
29184
29185*$ CREATE DT_HISTAT.FOR
29186*COPY DT_HISTAT
29187*
29188*===histat=============================================================*
29189*
29190 SUBROUTINE DT_HISTAT(IDX,MODE)
29191
29192************************************************************************
29193* This version dated 26.02.96 is written by S. Roesler *
29194* *
29195* Last change 27.12.2006 by S. Roesler. *
29196************************************************************************
29197
29198 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29199 SAVE
29200 PARAMETER ( LINP = 10 ,
29201 & LOUT = 6 ,
29202 & LDAT = 9 )
29203 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
29204 PARAMETER (NDIM=199)
29205
29206* event history
29207 PARAMETER (NMXHKK=200000)
29208 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
29209 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
29210 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
29211* extended event history
29212 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
29213 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
29214 & IHIST(2,NMXHKK)
29215* particle properties (BAMJET index convention)
29216 CHARACTER*8 ANAME
29217 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29218 & IICH(210),IIBAR(210),K1(210),K2(210)
29219 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
29220* Glauber formalism: cross sections
29221 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
29222 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
29223 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
29224 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
29225 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
29226 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
29227 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
29228 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
29229 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
29230 & BSLOPE,NEBINI,NQBINI
29231* emulsion treatment
29232 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
29233 & NCOMPO,IEMUL
29234* properties of interacting particles
29235 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
29236* rejection counter
29237 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
29238 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
29239 & IREXCI(3),IRDIFF(2),IRINC
29240* statistics: residual nuclei
29241 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
29242 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
29243 & NINCST(2,4),NINCEV(2),
29244 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
29245 & NRESPB(2),NRESCH(2),NRESEV(4),
29246 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
29247 & NEVAFI(2,2)
29248* parameter for intranuclear cascade
29249 LOGICAL LPAULI
29250 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
29251* (original name: PAREVT)
29252 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
29253 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
29254 PARAMETER ( NALLWP = 39 )
29255 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
29256 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
29257 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
29258 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
29259* (original name: FRBKCM)
29260 PARAMETER ( MXFFBK = 6 )
29261 PARAMETER ( MXZFBK = 9 )
29262 PARAMETER ( MXNFBK = 10 )
29263 PARAMETER ( MXAFBK = 16 )
29264 PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
29265 PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
29266 PARAMETER ( NXAFBK = MXAFBK + 1 )
29267 PARAMETER ( MXPSST = 300 )
29268 PARAMETER ( MXPSFB = 41000 )
29269 LOGICAL LFRMBK, LNCMSS
29270 COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
29271 & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
29272 & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
29273 & IFRBKN (MXPSST), IFRBKZ (MXPSST),
29274 & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
29275 & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
29276 & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
29277 & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
29278 & IFBFRB, NBUFBK, LFRMBK, LNCMSS
29279* (original name: INPFLG)
29280 COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
29281* temporary storage for one final state particle
29282 LOGICAL LFRAG,LGREY,LBLACK
29283 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
29284 & SINTHE,COSTHE,THETA,THECMS,
29285 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
29286 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
29287 & LFRAG,LGREY,LBLACK
29288* event flag used for histograms
29289 COMMON /DTNORM/ ICEVT,IEVHKK
29290* statistics: double-Pomeron exchange
29291 COMMON /DTFLG2/ INTFLG,IPOPO
29292
29293 DIMENSION EMUSAM(NCOMPX)
29294
29295 CHARACTER*13 CMSG(3)
29296 DATA CMSG /'not requested','not requested','not requested'/
29297
29298 GOTO (1,2,3,4,5) MODE
29299
29300*------------------------------------------------------------------
29301* initialization
29302 1 CONTINUE
29303* emulsion treatment
29304 IF (NCOMPO.GT.0) THEN
29305 DO 10 I=1,NCOMPX
29306 EMUSAM(I) = ZERO
29307 10 CONTINUE
29308 ENDIF
29309* common /DTSTA2/, statistics on i.n.c., residual nuclei, evap.
29310 NINCGE = 0
29311 DO 11 I=1,2
29312 EXCDPM(I) = ZERO
29313 EXCDPM(I+2) = ZERO
29314 EXCEVA(I) = ZERO
29315 NINCWO(I) = 0
29316 NINCEV(I) = 0
29317 NRESTO(I) = 0
29318 NRESPR(I) = 0
29319 NRESNU(I) = 0
29320 NRESBA(I) = 0
29321 NRESPB(I) = 0
29322 NRESCH(I) = 0
29323 NRESEV(I) = 0
29324 NRESEV(I+2) = 0
29325 NEVAGA(I) = 0
29326 NEVAHT(I) = 0
29327 NEVAFI(1,I) = 0
29328 NEVAFI(2,I) = 0
29329 DO 12 J=1,6
29330 IF (J.LE.2) NINCHR(I,J) = 0
29331 IF (J.LE.3) NINCCO(I,J) = 0
29332 IF (J.LE.4) NINCST(I,J) = 0
29333 NEVA(I,J) = 0
29334 12 CONTINUE
29335 DO 13 J=1,210
29336 NEVAHY(1,I,J) = 0
29337 NEVAHY(2,I,J) = 0
29338 13 CONTINUE
29339 11 CONTINUE
29340 MAXGEN = 0
29341**dble Po statistics.
29342 KPOPO = 0
29343
29344 RETURN
29345*------------------------------------------------------------------
29346* filling of histogram with event-record
29347 2 CONTINUE
29348 IF (IST.EQ.-1) THEN
29349 IF (.NOT.LFRAG) THEN
29350 IF (IDPDG.EQ.2212) THEN
29351 NEVA(NOBAM(IDX),1) = NEVA(NOBAM(IDX),1)+1
29352 ELSEIF (IDPDG.EQ.2112) THEN
29353 NEVA(NOBAM(IDX),2) = NEVA(NOBAM(IDX),2)+1
29354 ELSEIF (IDPDG.EQ.22) THEN
29355 NEVAGA(NOBAM(IDX)) = NEVAGA(NOBAM(IDX))+1
29356 ELSEIF (IDPDG.EQ.80000) THEN
29357 IF (IDBJT.EQ.116) THEN
29358 NEVA(NOBAM(IDX),3) = NEVA(NOBAM(IDX),3)+1
29359 ELSEIF (IDBJT.EQ.117) THEN
29360 NEVA(NOBAM(IDX),4) = NEVA(NOBAM(IDX),4)+1
29361 ELSEIF (IDBJT.EQ.118) THEN
29362 NEVA(NOBAM(IDX),5) = NEVA(NOBAM(IDX),5)+1
29363 ELSEIF (IDBJT.EQ.119) THEN
29364 NEVA(NOBAM(IDX),6) = NEVA(NOBAM(IDX),6)+1
29365 ENDIF
29366 ENDIF
29367 ELSE
29368* heavy fragments (here: fission products only)
29369 NEVAHY(NOBAM(IDX),1,IBARY) = NEVAHY(NOBAM(IDX),1,IBARY)+1
29370 NEVAHY(NOBAM(IDX),2,ICHAR) = NEVAHY(NOBAM(IDX),2,ICHAR)+1
29371 NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29372 ENDIF
29373 ELSEIF ((IST.EQ.1).AND.(.NOT.LFRAG)) THEN
29374 IF (IDCH(IDX).GT.MAXGEN) MAXGEN = IDCH(IDX)
29375 ENDIF
29376
29377 RETURN
29378*------------------------------------------------------------------
29379* output
29380 3 CONTINUE
29381
29382**dble Po statistics.
29383C WRITE(LOUT,'(1X,A,2I7,2E12.4)')
29384C & '# evts. / # dble-Po. evts / s_in / s_popo :',
29385C & ICEVT,KPOPO,XSPRO(1,1,1),XSPRO(1,1,1)*DBLE(KPOPO)/DBLE(ICEVT)
29386
29387* emulsion treatment
29388 IF (NCOMPO.GT.0) THEN
29389 WRITE(LOUT,3000)
29390 3000 FORMAT(/,1X,'HISTAT:',14X,'statistics - target emulsion',/,
29391 & 22X,'----------------------------',/,/,19X,
29392 & 'mass charge fraction',/,39X,
29393 & 'input treated',/)
29394 DO 30 I=1,NCOMPO
29395 WRITE(LOUT,3013) I,IEMUMA(I),IEMUCH(I),EMUFRA(I),
29396 & EMUSAM(I)/DBLE(ICEVT)
29397 3013 FORMAT(12X,I2,1X,2I8,6X,F7.3,5X,F7.3)
29398 30 CONTINUE
29399 ENDIF
29400
29401* i.n.c. statistics: output
29402 WRITE(LOUT,3001) ICEVT,NRESEV(2),IRINC
29403 3001 FORMAT(/,1X,'HISTAT:',14X,'statistics - intranuclear cascade',/,
29404 & 22X,'---------------------------------',/,/,1X,
29405 & 'no. of events for normalization: (accepted final events,',
29406 & ' evt)',4X,I6,/,34X,'(events before evap.-step, evt1)',I6,
29407 & /,1X,'no. of rejected events due to intranuclear',
29408 & ' cascade',15X,I6,/)
29409 ICEV = MAX(ICEVT,1)
29410 ICEV1 = ICEV
29411 IF (LEVPRT) ICEV1 = MAX(NRESEV(2),1)
29412 WRITE(LOUT,3002)
29413 & (DBLE(NINCWO(I))/DBLE(ICEV),I=1,2),
29414 & ((DBLE(NINCST(I,J))/DBLE(ICEV),I=1,2),J=1,4),
29415 & KTAUGE,DBLE(NINCGE)/DBLE(ICEV),
29416 & (DBLE(NINCCO(I,1)+NINCCO(I,2)+NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29417 & (DBLE(NINCCO(I,2))/DBLE(ICEV1),I=1,2),
29418 & (DBLE(NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29419 & (DBLE(NINCCO(I,1))/DBLE(ICEV1),I=1,2)
29420 3002 FORMAT(1X,'no. of wounded nucl. in proj./ target (mean per evt)',
29421 & 5X,F6.2,' /',F6.2,/,1X,'no. of particles unable to escape',
29422 & ' proj./ target (mean per evt)',/,8X,'baryons: pos. ',
29423 & F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3,/,8X,
29424 & 'mesons: pos. ',F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3,
29425 & /,1X,'maximum no. of generations treated (maximum allowed:'
29426 & ,I4,')',/,43X,'(mean per evt)',5X,F6.2,/,1X,'no. of sec.',
29427 & ' interactions in proj./ target (mean per evt1)',
29428 & F7.3,' /',F7.3,/,8X,'out of which by inelastic',
29429 & ' interactions',12X,F7.3,' /',F7.3,/,21X,'by elastic ',
29430 & 'interactions',14X,F7.3,' /',F7.3,/,21X,'by absorption ',
29431 & '(ap, K-, pi- only) ',F7.3,' /',F7.3,/)
29432 WRITE(LOUT,3003) NRESEV(2),NRESEV(4),IREXCI,
29433 & IREXCI(1)+IREXCI(2)+IREXCI(3)
29434 3003 FORMAT(/,1X,'HISTAT:',14X,'statistics - residual nuclei, ',
29435 & 'evaporation',/,22X,'-----------------------------',
29436 & '------------',/,/,1X,'no. of events for normal.: ',
29437 & '(events handled by FICONF, evt)',7X,I6,/,28X,'(events',
29438 & ' passing the evap.-step, evt1) ',I6,/,1X,'no. of',
29439 & ' rejected events (',I4,',',I4,',',I4,')',22X,I6,/)
29440
29441 WRITE(LOUT,3004)
29442 3004 FORMAT(/,22X,'1) before evaporation-step:',/)
29443 ICEV = MAX(NRESEV(2),1)
29444 WRITE(LOUT,3005)
29445 & (DBLE(NRESTO(I))/DBLE(ICEV),I=1,2),
29446 & (DBLE(NRESPR(I))/DBLE(ICEV),I=1,2),
29447 & (DBLE(NRESNU(I))/DBLE(ICEV),I=1,2),
29448 & (DBLE(NRESBA(I))/DBLE(ICEV),I=1,2),
29449 & (DBLE(NRESPB(I))/DBLE(ICEV),I=1,2),
29450 & (DBLE(NRESCH(I))/DBLE(ICEV),I=1,2),
29451 & (EXCDPM(I)/DBLE(ICEV),I=1,2),
29452 & (EXCDPM(I+2)/DBLE(ICEV),I=1,2)
29453 3005 FORMAT(1X,'residual nuclei: (mean values per evt)',12X,
29454 & 'proj. / target',/,/,8X,'total number of particles',15X,
29455 & 2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29456 & 'neutrons',18X,2F9.3,/,22X,'baryons',19X,2F9.3,/,22X,
29457 & 'pos. baryons',14X,2F9.3,/,8X,'total charge',28X,2F9.3,/,
29458 & /,8X,'excitation energy (bef. evap.-step) ',2E11.3,/,
29459 & 8X,'excitation energy per nucleon ',2E11.3,/,/)
29460
29461* evaporation / fission / fragmentation statistics: output
29462 ICEV = MAX(NRESEV(2),1)
29463 ICEV1 = MAX(NRESEV(4),1)
29464 NTEVA1 =
29465 & NEVA(1,1)+NEVA(1,2)+NEVA(1,3)+NEVA(1,4)+NEVA(1,5)+NEVA(1,6)
29466 NTEVA2 =
29467 & NEVA(2,1)+NEVA(2,2)+NEVA(2,3)+NEVA(2,4)+NEVA(2,5)+NEVA(2,6)
29468 IF (LEVPRT) THEN
29469 IF (IFISS.EQ.1) CMSG(1) = 'requested '
29470 IF (LFRMBK) CMSG(2) = 'requested '
29471 IF (LDEEXG) CMSG(3) = 'requested '
29472 WRITE(LOUT,3006)
29473 & CMSG,
29474 & DBLE(NTEVA1)/DBLE(ICEV1),DBLE(NTEVA2)/DBLE(ICEV1),
29475 & (DBLE(NEVA(I,1))/DBLE(ICEV1),I=1,2),
29476 & (DBLE(NEVA(I,2))/DBLE(ICEV1),I=1,2),
29477 & (DBLE(NEVA(I,3))/DBLE(ICEV1),I=1,2),
29478 & (DBLE(NEVA(I,4))/DBLE(ICEV1),I=1,2),
29479 & (DBLE(NEVA(I,5))/DBLE(ICEV1),I=1,2),
29480 & (DBLE(NEVA(I,6))/DBLE(ICEV1),I=1,2),
29481 & (DBLE(NEVAGA(I))/DBLE(ICEV1),I=1,2),
29482 & (DBLE(NEVAHT(I))/DBLE(ICEV1),I=1,2)
29483 3006 FORMAT(22X,'2) after evaporation-step:',/,/,1X,'Fission:',
29484 & 13X,A13,/,1X,'Fermi-Break-up:',6X,A13,/,1X,'Gamma-',
29485 & 'deexcitation:',2X,A13,/,/,
29486 & 1X,'evaporation/deexcitation: (mean values per evt1) ',
29487 & 'proj. / target',/,/,8X,'total number of evap. particles',
29488 & 9X,2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29489 & 'neutrons',18X,2F9.3,/,22X,'deuterons',17X,2F9.3,/,22X,
29490 & '3-H',23X,2F9.3,/,22X,'3-He',22X,2F9.3,/,22X,'4-He',22X,
29491 & 2F9.3,/,8X,'nucl. deexcit. gammas',19X,2F9.3,/,8X,
29492 & 'heavy fragments',25X,2F9.3,/)
29493 IF (IFISS.EQ.1) THEN
29494 WRITE(LOUT,3007) NEVAFI(1,1),NEVAFI(1,2),
29495 & NEVAFI(2,1),NEVAFI(2,2),
29496 & DBLE(NEVAFI(2,1))/DBLE(MAX(NEVAFI(1,1),1))*100.0D0,
29497 & DBLE(NEVAFI(2,2))/DBLE(MAX(NEVAFI(1,2),1))*100.0D0
29498 3007 FORMAT(1X,'Fission: total number of events',14X,2I9,/
29499 & 12X,'out of which fission occured',8X,2I9,/,
29500 & 50X,'(',F5.2,'%) (',F5.2,'%)',/)
29501 ENDIF
29502C IF ((LFRMBK).OR.(IFISS.EQ.1)) THEN
29503C WRITE(LOUT,3008)
29504C3008 FORMAT(1X,'heavy fragments - statistics:',7X,'charge',
29505C & ' proj. / target',/)
29506C DO 31 I=1,210
29507C IF ((NEVAHY(1,2,I).NE.0).OR.(NEVAHY(2,2,I).NE.0)) THEN
29508C WRITE(LOUT,3009) I,
29509C & (DBLE(NEVAHY(K,2,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29510C3009 FORMAT(38X,I3,3X,2E12.3)
29511C ENDIF
29512C 31 CONTINUE
29513C WRITE(LOUT,3010)
29514C3010 FORMAT(1X,'heavy fragments - statistics:',7X,'mass ',
29515C & ' proj. / target',/)
29516C DO 32 I=1,210
29517C IF ((NEVAHY(1,1,I).NE.0).OR.(NEVAHY(2,1,I).NE.0)) THEN
29518C WRITE(LOUT,3011) I,
29519C & (DBLE(NEVAHY(K,1,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29520C3011 FORMAT(38X,I3,3X,2E12.3)
29521C ENDIF
29522C 32 CONTINUE
29523C WRITE(LOUT,*)
29524C ENDIF
29525 ELSE
29526 WRITE(LOUT,3012)
29527 3012 FORMAT(22X,'2) after evaporation-step:',/,/,1X,
29528 & 'Evaporation: not requested',/)
29529 ENDIF
29530
29531 RETURN
29532*------------------------------------------------------------------
29533* filling of histogram with event-record
29534 4 CONTINUE
29535* emulsion treatment
29536 IF (NCOMPO.GT.0) THEN
29537 DO 40 I=1,NCOMPO
29538 IF (IT.EQ.IEMUMA(I)) THEN
29539 EMUSAM(I) = EMUSAM(I)+ONE
29540 ENDIF
29541 40 CONTINUE
29542 ENDIF
29543 NINCGE = NINCGE+MAXGEN
29544 MAXGEN = 0
29545**dble Po statistics.
29546 IF (IPOPO.EQ.1) KPOPO = KPOPO+1
29547
29548 RETURN
29549*------------------------------------------------------------------
29550* filling of histogram with event-record
29551 5 CONTINUE
29552 IF ((ISTHKK(IDX).EQ.15).OR.(ISTHKK(IDX).EQ.16)) THEN
29553 IB = IIBAR(IDBAM(IDX))
29554 IC = IICH(IDBAM(IDX))
29555 J = ISTHKK(IDX)-14
29556 IF ( ((ABS(IB).EQ.1).AND.(IC.EQ.1)).OR.(IC.EQ.0) ) THEN
29557 NINCST(J,1) = NINCST(J,1)+1
29558 ELSEIF ((ABS(IB).EQ.1).AND.(IC.EQ.-1)) THEN
29559 NINCST(J,2) = NINCST(J,2)+1
29560 ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ. 1)) THEN
29561 NINCST(J,3) = NINCST(J,3)+1
29562 ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ.-1)) THEN
29563 NINCST(J,4) = NINCST(J,4)+1
29564 ENDIF
29565 ELSEIF (ISTHKK(IDX).EQ.17) THEN
29566 NINCWO(1) = NINCWO(1)+1
29567 ELSEIF (ISTHKK(IDX).EQ.18) THEN
29568 NINCWO(2) = NINCWO(2)+1
29569 ELSEIF (ISTHKK(IDX).EQ.1001) THEN
29570 IB = IDRES(IDX)
29571 IC = IDXRES(IDX)
29572 IF (IC.GT.0) THEN
29573 NEVAHY(NOBAM(IDX),1,IB) = NEVAHY(NOBAM(IDX),1,IB)+1
29574 NEVAHY(NOBAM(IDX),2,IC) = NEVAHY(NOBAM(IDX),2,IC)+1
29575 ENDIF
29576 NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29577 ENDIF
29578
29579 RETURN
29580 END
29581
29582*$ CREATE DT_NEWHGR.FOR
29583*COPY DT_NEWHGR
29584*
29585*===newhgr=============================================================*
29586*
29587 SUBROUTINE DT_NEWHGR(XLIM1,XLIM2,XLIM3,XLIMB,IBIN,IREFN)
29588
29589************************************************************************
29590* *
29591* Histogram initialization. *
29592* *
29593* input: XLIM1/XLIM2 lower/upper edge of histogram-window *
29594* XLIM3 bin size *
29595* IBIN > 0 number of bins in equidistant lin. binning *
29596* = -1 reset histograms *
29597* < -1 |IBIN| number of bins in equidistant log. *
29598* binning or log. binning in user def. struc. *
29599* XLIMB(*) user defined bin structure *
29600* *
29601* The bin structure is sensitive to *
29602* XLIM1, XLIM3, IBIN if XLIM3 > 0 (lin.) *
29603* XLIM1, XLIM2, IBIN if XLIM3 = 0 (lin. & log.) *
29604* XLIMB, IBIN if XLIM3 < 0 *
29605* *
29606* *
29607* output: IREFN histogram index *
29608* (= -1 for inconsistent histogr. request) *
29609* *
29610* This subroutine is based on a original version by R. Engel. *
29611* This version dated 22.4.95 is written by S. Roesler. *
29612************************************************************************
29613
29614 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29615 SAVE
29616 PARAMETER ( LINP = 10 ,
29617 & LOUT = 6 ,
29618 & LDAT = 9 )
29619
29620 LOGICAL LSTART
29621
29622 PARAMETER (ZERO = 0.0D0,
29623 & TINY = 1.0D-10)
29624
29625 DIMENSION XLIMB(*)
29626
29627* histograms
29628 PARAMETER (NHIS=150, NDIM=250)
29629 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29630 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29631* auxiliary common for histograms
29632 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29633
29634 DATA LSTART /.TRUE./
29635
29636* reset histogram counter
29637 IF (LSTART.OR.(IBIN.EQ.-1)) THEN
29638 IHISL = 0
29639 IF (IBIN.EQ.-1) RETURN
29640 LSTART = .FALSE.
29641 ENDIF
29642
29643 IHIS = IHISL+1
29644* check for maximum number of allowed histograms
29645 IF (IHIS.GT.NHIS) THEN
29646 WRITE(LOUT,1003) IHIS,NHIS,IHIS
29647 1003 FORMAT(1X,'NEWHGR: warning! number of histograms (',
29648 & I4,') exceeds array size (',I4,')',/,21X,
29649 & 'histogram',I3,' skipped!')
29650 GOTO 9999
29651 ENDIF
29652
29653 IREFN = IHIS
29654 IBINS(IHIS) = ABS(IBIN)
29655* check requested number of bins
29656 IF (IBINS(IHIS).GE.NDIM) THEN
29657 WRITE(LOUT,1000) IBIN,NDIM,NDIM
29658 1000 FORMAT(1X,'NEWHGR: warning! number of bins (',
29659 & I3,') exceeds array size (',I3,')',/,21X,
29660 & 'and will be reset to ',I3)
29661 IBINS(IHIS) = NDIM
29662 ENDIF
29663 IF (IBINS(IHIS).EQ.0) THEN
29664 WRITE(LOUT,1001) IBIN,IHIS
29665 1001 FORMAT(1X,'NEWHGR: warning! inconsistent number of',
29666 & ' bins (',I3,')',/,21X,'histogram',I3,' skipped!')
29667 GOTO 9999
29668 ENDIF
29669
29670* initialize arrays
29671 DO 1 I=1,NDIM
29672 DO 2 K=1,3
29673 HIST(K,IHIS,I) = ZERO
29674 HIST(K+3,IHIS,I) = ZERO
29675 TMPHIS(K,IHIS,I) = ZERO
29676 2 CONTINUE
29677 HIST(7,IHIS,I) = ZERO
29678 1 CONTINUE
29679 DENTRY(1,IHIS)= ZERO
29680 DENTRY(2,IHIS)= ZERO
29681 OVERF(IHIS) = ZERO
29682 UNDERF(IHIS) = ZERO
29683 TMPUFL(IHIS) = ZERO
29684 TMPOFL(IHIS) = ZERO
29685
29686* bin str. sensitive to lower edge, bin size, and numb. of bins
29687 IF (XLIM3.GT.ZERO) THEN
29688 DO 3 K=1,IBINS(IHIS)+1
29689 HIST(1,IHIS,K) = XLIM1+DBLE(K-1)*XLIM3
29690 3 CONTINUE
29691 ISWI(IHIS) = 1
29692* bin str. sensitive to lower/upper edge and numb. of bins
29693 ELSEIF (XLIM3.EQ.ZERO) THEN
29694* linear binning
29695 IF (IBIN.GT.0) THEN
29696 XLOW = XLIM1
29697 XHI = XLIM2
29698 IF (XLIM2.LE.XLIM1) THEN
29699 WRITE(LOUT,1002) XLIM1,XLIM2
29700 1002 FORMAT(1X,'NEWHGR: warning! inconsistent x-range',
29701 & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29702 GOTO 9999
29703 ENDIF
29704 ISWI(IHIS) = 1
29705 ELSEIF (IBIN.LT.-1) THEN
29706* logarithmic binning
29707 IF ((XLIM1.LE.ZERO).OR.(XLIM2.LE.ZERO)) THEN
29708 WRITE(LOUT,1004) XLIM1,XLIM2
29709 1004 FORMAT(1X,'NEWHGR: warning! inconsistent log. ',
29710 & 'binning',/,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29711 GOTO 9999
29712 ENDIF
29713 IF (XLIM2.LE.XLIM1) THEN
29714 WRITE(LOUT,1005) XLIM1,XLIM2
29715 1005 FORMAT(1X,'NEWHGR: warning! inconsistent x-range',
29716 & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29717 GOTO 9999
29718 ENDIF
29719 XLOW = LOG10(XLIM1)
29720 XHI = LOG10(XLIM2)
29721 ISWI(IHIS) = 3
29722 ENDIF
29723 DX = ABS(XHI-XLOW)/DBLE(MAX(IBINS(IHIS),1))
29724 DO 4 K=1,IBINS(IHIS)+1
29725 HIST(1,IHIS,K) = XLOW+DBLE(K-1)*DX
29726 4 CONTINUE
29727 ELSE
29728* user defined bin structure
29729 DO 5 K=1,IBINS(IHIS)+1
29730 IF (IBIN.GT.0) THEN
29731 HIST(1,IHIS,K) = XLIMB(K)
29732 ISWI(IHIS) = 2
29733 ELSEIF (IBIN.LT.-1) THEN
29734 HIST(1,IHIS,K) = LOG10(XLIMB(K))
29735 ISWI(IHIS) = 4
29736 ENDIF
29737 5 CONTINUE
29738 ENDIF
29739
29740* histogram accepted
29741 IHISL = IHIS
29742
29743 RETURN
29744
29745 9999 CONTINUE
29746 IREFN = -1
29747 RETURN
29748 END
29749
29750*$ CREATE DT_FILHGR.FOR
29751*COPY DT_FILHGR
29752*
29753*===filhgr=============================================================*
29754*
29755 SUBROUTINE DT_FILHGR(XI,YI,IHIS,NEVT)
29756
29757************************************************************************
29758* *
29759* Scoring for histogram IHIS. *
29760* *
29761* This subroutine is based on a original version by R. Engel. *
29762* This version dated 23.4.95 is written by S. Roesler. *
29763************************************************************************
29764
29765 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29766 SAVE
29767 PARAMETER ( LINP = 10 ,
29768 & LOUT = 6 ,
29769 & LDAT = 9 )
29770
29771 PARAMETER (ZERO = 0.0D0,
29772 & ONE = 1.0D0,
29773 & TINY = 1.0D-10)
29774
29775* histograms
29776 PARAMETER (NHIS=150, NDIM=250)
29777 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29778 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29779* auxiliary common for histograms
29780 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29781
29782 DATA NCEVT /1/
29783
29784 X = XI
29785 Y = YI
29786
29787* dump content of temorary arrays into histograms
29788 IF ((NEVT.NE.NCEVT).OR.(NEVT.LT.0)) THEN
29789 CALL DT_EVTHIS(IDUM)
29790 NCEVT = NEVT
29791 ENDIF
29792
29793* check histogram index
29794 IF (IHIS.EQ.-1) RETURN
29795 IF ((IHIS.LT.1).OR.(IHIS.GT.IHISL)) THEN
29796C WRITE(LOUT,1000) IHIS,IHISL
29797 1000 FORMAT(1X,'FILHGR: warning! histogram index',I4,
29798 & ' out of range (1..',I3,')')
29799 RETURN
29800 ENDIF
29801
29802 IF ((ISWI(IHIS).EQ.1).OR.(ISWI(IHIS).EQ.3)) THEN
29803* bin structure not explicitly given
29804 IF ((ISWI(IHIS).EQ.3).AND.(X.GT.ZERO)) X = LOG10(X)
29805 DX = ABS(HIST(1,IHIS,2)-HIST(1,IHIS,1))
29806 IF (X.LT.HIST(1,IHIS,1)) THEN
29807 I1 = 0
29808 ELSE
29809 I1 = INT( (X-HIST(1,IHIS,1))/MAX(DX,TINY) )+1
29810 ENDIF
29811
29812 ELSEIF ((ISWI(IHIS).EQ.2).OR.(ISWI(IHIS).EQ.4)) THEN
29813* user defined bin structure
29814 IF ((ISWI(IHIS).EQ.4).AND.(X.GT.ZERO)) X = LOG10(X)
29815 IF (X.LT.HIST(1,IHIS,1)) THEN
29816 I1 = 0
29817 ELSE IF (X.GT.HIST(1,IHIS,IBINS(IHIS)+1)) THEN
29818 I1 = IBINS(IHIS)+1
29819 ELSE
29820* binary sort algorithm
29821 KMIN = 0
29822 KMAX = IBINS(IHIS)+1
29823 1 CONTINUE
29824 IF ((KMAX-KMIN).EQ.1) GOTO 2
29825 KK = (KMAX+KMIN)/2
29826 IF (X.LE.HIST(1,IHIS,KK)) THEN
29827 KMAX=KK
29828 ELSE
29829 KMIN=KK
29830 ENDIF
29831 GOTO 1
29832 2 CONTINUE
29833 I1 = KMIN
29834 ENDIF
29835
29836 ELSE
29837 WRITE(LOUT,1001)
29838 1001 FORMAT(1X,'FILHGR: warning! histogram not initialized')
29839 RETURN
29840 ENDIF
29841
29842* scoring
29843 IF (I1.LE.0) THEN
29844 TMPUFL(IHIS) = TMPUFL(IHIS)+ONE
29845 ELSEIF (I1.LE.IBINS(IHIS)) THEN
29846 TMPHIS(1,IHIS,I1) = TMPHIS(1,IHIS,I1)+ONE
29847 IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
29848 TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+10**X
29849 ELSE
29850 TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+X
29851 ENDIF
29852 TMPHIS(3,IHIS,I1) = TMPHIS(3,IHIS,I1)+Y
29853 ELSE
29854 TMPOFL(IHIS) = TMPOFL(IHIS)+ONE
29855 ENDIF
29856
29857 RETURN
29858 END
29859
29860*$ CREATE DT_EVTHIS.FOR
29861*COPY DT_EVTHIS
29862*
29863*===evthis=============================================================*
29864*
29865 SUBROUTINE DT_EVTHIS(NEVT)
29866
29867************************************************************************
29868* Dump content of temorary histograms into /DTHIS1/. This subroutine *
29869* is called after each event and for the last event before any call *
29870* to OUTHGR. *
29871* NEVT number of events dumped, this is only needed to *
29872* get the normalization after the last event *
29873* This version dated 23.4.95 is written by S. Roesler. *
29874************************************************************************
29875
29876 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29877 SAVE
29878 PARAMETER ( LINP = 10 ,
29879 & LOUT = 6 ,
29880 & LDAT = 9 )
29881
29882 LOGICAL LNOETY
29883
29884 PARAMETER (ZERO = 0.0D0,
29885 & ONE = 1.0D0,
29886 & TINY = 1.0D-10)
29887
29888* histograms
29889 PARAMETER (NHIS=150, NDIM=250)
29890 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29891 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29892* auxiliary common for histograms
29893 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29894
29895 DATA NCEVT /0/
29896
29897 NCEVT = NCEVT+1
29898 NEVT = NCEVT
29899
29900 DO 1 I=1,IHISL
29901 LNOETY = .TRUE.
29902 DO 2 J=1,IBINS(I)
29903 IF (TMPHIS(1,I,J).GT.ZERO) THEN
29904 LNOETY = .FALSE.
29905 HIST(2,I,J) = HIST(2,I,J)+ONE
29906 HIST(7,I,J) = HIST(7,I,J)+TMPHIS(1,I,J)
29907 DENTRY(2,I) = DENTRY(2,I)+TMPHIS(1,I,J)
29908 AVX = TMPHIS(2,I,J)/TMPHIS(1,I,J)
29909 HIST(3,I,J) = HIST(3,I,J)+TMPHIS(3,I,J)*AVX
29910 HIST(4,I,J) = HIST(4,I,J)+TMPHIS(3,I,J)*AVX**2
29911 HIST(5,I,J) = HIST(5,I,J)+TMPHIS(3,I,J)
29912 HIST(6,I,J) = HIST(6,I,J)+TMPHIS(3,I,J)**2
29913 TMPHIS(1,I,J) = ZERO
29914 TMPHIS(2,I,J) = ZERO
29915 TMPHIS(3,I,J) = ZERO
29916 ENDIF
29917 2 CONTINUE
29918 IF (LNOETY) THEN
29919 IF (TMPUFL(I).GT.ZERO) THEN
29920 UNDERF(I) = UNDERF(I)+ONE
29921 TMPUFL(I) = ZERO
29922 ELSEIF (TMPOFL(I).GT.ZERO) THEN
29923 OVERF(I) = OVERF(I)+ONE
29924 TMPOFL(I) = ZERO
29925 ENDIF
29926 ELSE
29927 DENTRY(1,I) = DENTRY(1,I)+ONE
29928 ENDIF
29929 1 CONTINUE
29930
29931 RETURN
29932 END
29933
29934*$ CREATE DT_OUTHGR.FOR
29935*COPY DT_OUTHGR
29936*
29937*===outhgr=============================================================*
29938*
29939 SUBROUTINE DT_OUTHGR(I1,I2,I3,I4,I5,I6,CHEAD,IHEAD,NEVTS,FAC,
29940 & ILOGY,INORM,NMODE)
29941
29942************************************************************************
29943* *
29944* Plot histogram(s) to standard output unit *
29945* *
29946* I1..6 indices of histograms to be plotted *
29947* CHEAD,IHEAD header string,integer *
29948* NEVTS number of events *
29949* FAC scaling factor *
29950* ILOGY = 1 logarithmic y-axis *
29951* INORM normalization *
29952* = 0 no further normalization (FAC is obsolete) *
29953* = 1 per event and bin width *
29954* = 2 per entry and bin width *
29955* = 3 per bin entry *
29956* = 4 per event and "bin width" x1^2...x2^2 *
29957* = 5 per event and "log. bin width" ln x1..ln x2 *
29958* = 6 per event *
29959* MODE = 0 no output but normalization applied *
29960* = 1 all valid histograms separately (small frame) *
29961* all valid histograms separately (small frame) *
29962* = -1 and tables as histograms *
29963* = 2 all valid histograms (one plot, wide frame) *
29964* all valid histograms (one plot, wide frame) *
29965* = -2 and tables as histograms *
29966* *
29967* *
29968* Note: All histograms to be plotted with one call to this *
29969* subroutine and |MODE|=2 must have the same bin structure! *
29970* There is no test included ensuring this fact. *
29971* *
29972* This version dated 23.4.95 is written by S. Roesler. *
29973************************************************************************
29974
29975 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29976 SAVE
29977 PARAMETER ( LINP = 10 ,
29978 & LOUT = 6 ,
29979 & LDAT = 9 )
29980
29981 CHARACTER*72 CHEAD
29982
29983 PARAMETER (ZERO = 0.0D0,
29984 & IZERO = 0,
29985 & ONE = 1.0D0,
29986 & TWO = 2.0D0,
29987 & OHALF = 0.5D0,
29988 & EPS = 1.0D-5,
29989 & TINY = 1.0D-8,
29990 & SMALL = -1.0D8,
29991 & RLARGE = 1.0D8 )
29992
29993* histograms
29994 PARAMETER (NHIS=150, NDIM=250)
29995 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29996 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29997
29998 PARAMETER (NDIM2 = 2*NDIM)
29999 DIMENSION XX(NDIM2),YY(NDIM2)
30000
30001 PARAMETER (NHISTO = 6)
30002 DIMENSION YY1(NDIM,NHISTO),XX1(NDIM,NHISTO),IDX1(NHISTO),
30003 & IDX(NHISTO)
30004
30005 CHARACTER*43 CNORM(0:8)
30006 DATA CNORM /'no further normalization ',
30007 & 'per event and bin width ',
30008 & 'per entry1 and bin width ',
30009 & 'per bin entry ',
30010 & 'per event and "bin width" x1^2...x2^2 ',
30011 & 'per event and "log. bin width" ln x1..ln x2',
30012 & 'per event ',
30013 & 'per bin entry1 ',
30014 & 'per entry2 and bin width '/
30015
30016 IDX1(1) = I1
30017 IDX1(2) = I2
30018 IDX1(3) = I3
30019 IDX1(4) = I4
30020 IDX1(5) = I5
30021 IDX1(6) = I6
30022
30023 MODE = NMODE
30024
30025* initialization if "wide frame" is requested
30026 IF (ABS(MODE).EQ.2) THEN
30027 DO 1 I=1,NHISTO
30028 DO 2 J=1,NDIM
30029 XX1(J,I) = ZERO
30030 YY1(J,I) = ZERO
30031 2 CONTINUE
30032 1 CONTINUE
30033 ENDIF
30034
30035* plot header
30036 WRITE(LOUT,'(/1X,A,I3,/,1X,70A1)') CHEAD,IHEAD,('=',II=1,70)
30037
30038* check histogram indices
30039 NHI = 0
30040 DO 3 I=1,NHISTO
30041 IF ((IDX1(I).GE.1).AND.(IDX1(I).LE.IHISL)) THEN
30042 IF (ISWI(IDX1(I)).NE.0) THEN
30043 IF (DENTRY(1,IDX1(I)).LT.ONE) THEN
30044 WRITE(LOUT,1000)
30045 & IDX1(I),UNDERF(IDX1(I)),OVERF(IDX1(I))
30046 1000 FORMAT(/,1X,'OUTHGR: warning! no entries in',
30047 & ' histogram ',I3,/,21X,'underflows:',F10.0,
30048 & ' overflows: ',F10.0)
30049 ELSE
30050 NHI = NHI+1
30051 IDX(NHI) = IDX1(I)
30052 ENDIF
30053 ENDIF
30054 ENDIF
30055 3 CONTINUE
30056 IF (NHI.EQ.0) THEN
30057 WRITE(LOUT,1001)
30058 1001 FORMAT(/,1X,'OUTHGR: warning! histogram indices not valid')
30059 RETURN
30060 ENDIF
30061
30062* check normalization request
30063 IF ( ((FAC.EQ.ZERO).AND.(INORM.NE.0)).OR.
30064 & ((NEVTS.LT.1).AND.((INORM.EQ.1).OR.(INORM.EQ.4).OR.
30065 & (INORM.EQ.5).OR.(INORM.EQ.6))).OR.
30066 & (INORM.LT.0).OR.(INORM.GT.8) ) THEN
30067 WRITE(LOUT,1002) NEVTS,INORM,FAC
30068 1002 FORMAT(/,1X,'OUTHGR: warning! normalization request not ',
30069 & 'valid',/,21X,'NEVTS = ',I7,4X,'INORM = ',I2,4X,
30070 & 'FAC = ',E11.4)
30071 RETURN
30072 ENDIF
30073
30074 WRITE(LOUT,'(/,1X,A,I8)') 'number of events:',NEVTS
30075
30076* apply normalization
30077 DO 4 N=1,NHI
30078
30079 I = IDX(N)
30080
30081 IF (ISWI(I).EQ.1) THEN
30082 WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30083 1003 FORMAT(/,1X,'histo.',I4,', linear binning from',2X,E10.4,
30084 & ' to',2X,E10.4,',',2X,I3,' bins')
30085 ELSEIF (ISWI(I).EQ.2) THEN
30086 WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30087 WRITE(LOUT,1007)
30088 1007 FORMAT(1X,'user defined bin structure')
30089 ELSEIF (ISWI(I).EQ.3) THEN
30090 WRITE(LOUT,1004)
30091 & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30092 1004 FORMAT(/,1X,'histo.',I4,', logar. binning from',2X,E10.4,
30093 & ' to',2X,E10.4,',',2X,I3,' bins')
30094 ELSEIF (ISWI(I).EQ.4) THEN
30095 WRITE(LOUT,1004)
30096 & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30097 WRITE(LOUT,1007)
30098 ELSE
30099 WRITE(LOUT,1008) ISWI(I)
30100 1008 FORMAT(/,1X,'warning! inconsistent bin structure flag ',I4)
30101 ENDIF
30102 WRITE(LOUT,1005) DENTRY(1,I),DENTRY(2,I),UNDERF(I),OVERF(I)
30103 1005 FORMAT(13X,'entries:',2F9.0,' underfl.:',F8.0,
30104 & ' overfl.:',F8.0)
30105 WRITE(LOUT,1009) CNORM(INORM)
30106 1009 FORMAT(1X,'normalization: ',A,/)
30107
30108 DO 5 K=1,IBINS(I)
30109 CALL DT_GETBIN(I,K,NEVTS,INORM,XLOW,XHI,XMEAN,YMEAN,YERR)
30110 YMEAN = FAC*YMEAN
30111 YERR = FAC*YERR
30112 WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,YERR,HIST(2,I,K)
30113 WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,YERR,HIST(2,I,K)
30114 1006 FORMAT(1X,5E11.3)
30115* small frame
30116 II = 2*K
30117 XX(II-1) = HIST(1,I,K)
30118 XX(II) = HIST(1,I,K+1)
30119 YY(II-1) = YMEAN
30120 YY(II) = YMEAN
30121* wide frame
30122 XX1(K,N) = XMEAN
30123 IF ((ISWI(I).EQ.3).OR.(ISWI(I).EQ.4))
30124 & XX1(K,N) = LOG10(XMEAN)
30125 YY1(K,N) = YMEAN
30126 5 CONTINUE
30127
30128* plot small frame
30129 IF (ABS(MODE).EQ.1) THEN
30130 IBIN2 = 2*IBINS(I)
30131 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30132 IF(ILOGY.EQ.1) THEN
30133 CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30134 ELSE
30135 CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30136 ENDIF
30137 ENDIF
30138
30139 4 CONTINUE
30140
30141* plot wide frame
30142 IF (ABS(MODE).EQ.2) THEN
30143 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30144 NSIZE = NDIM*NHISTO
30145 DXLOW = HIST(1,IDX(1),1)
30146 DDX = ABS(HIST(1,IDX(1),2)-HIST(1,IDX(1),1))
30147 YLOW = RLARGE
30148 YHI = SMALL
30149 DO 6 I=1,NHISTO
30150 DO 7 J=1,NDIM
30151 IF (YY1(J,I).LT.YLOW) THEN
30152 IF (ILOGY.EQ.1) THEN
30153 IF (YY1(J,I).GT.ZERO) YLOW = YY1(J,I)
30154 ELSE
30155 YLOW = YY1(J,I)
30156 ENDIF
30157 ENDIF
30158 IF (YY1(J,I).GT.YHI) YHI = YY1(J,I)
30159 7 CONTINUE
30160 6 CONTINUE
30161 DY = (YHI-YLOW)/DBLE(NDIM)
30162 IF (DY.LE.ZERO) THEN
30163 WRITE(LOUT,'(1X,A,6I4,A,2E12.4)')
30164 & 'OUTHGR: warning! zero bin width for histograms ',
30165 & IDX,': ',YLOW,YHI
30166 RETURN
30167 ENDIF
30168 IF (ILOGY.EQ.1) THEN
30169 YLOW = LOG10(YLOW)
30170 DY = (LOG10(YHI)-YLOW)/100.0D0
30171 DO 8 I=1,NHISTO
30172 DO 9 J=1,NDIM
30173 IF (YY1(J,I).LE.ZERO) THEN
30174 YY1(J,I) = YLOW
30175 ELSE
30176 YY1(J,I) = LOG10(YY1(J,I))
30177 ENDIF
30178 9 CONTINUE
30179 8 CONTINUE
30180 ENDIF
30181 CALL DT_SRPLOT(XX1,YY1,NSIZE,NHISTO,NDIM,DXLOW,DDX,YLOW,DY)
30182 ENDIF
30183
30184 RETURN
30185 END
30186
30187*$ CREATE DT_GETBIN.FOR
30188*COPY DT_GETBIN
30189*
30190*===getbin=============================================================*
30191*
30192 SUBROUTINE DT_GETBIN(IHIS,IBIN,KEVT,NORM,XLOW,XHI,
30193 & XMEAN,YMEAN,YERR)
30194
30195************************************************************************
30196* This version dated 23.4.95 is written by S. Roesler. *
30197************************************************************************
30198
30199 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30200 SAVE
30201 PARAMETER ( LINP = 10 ,
30202 & LOUT = 6 ,
30203 & LDAT = 9 )
30204
30205 PARAMETER (ZERO = 0.0D0,
30206 & ONE = 1.0D0,
30207 & TINY35 = 1.0D-35)
30208
30209* histograms
30210 PARAMETER (NHIS=150, NDIM=250)
30211 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30212 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30213
30214 XLOW = HIST(1,IHIS,IBIN)
30215 XHI = HIST(1,IHIS,IBIN+1)
30216 IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
30217 XLOW = 10**XLOW
30218 XHI = 10**XHI
30219 ENDIF
30220 IF (NORM.EQ.2) THEN
30221 DX = XHI-XLOW
30222 NEVT = INT(DENTRY(1,IHIS))
30223 ELSEIF (NORM.EQ.3) THEN
30224 DX = ONE
30225 NEVT = INT(HIST(2,IHIS,IBIN))
30226 ELSEIF (NORM.EQ.4) THEN
30227 DX = XHI**2-XLOW**2
30228 NEVT = KEVT
30229 ELSEIF (NORM.EQ.5) THEN
30230 DX = LOG(ABS(XHI))-LOG(ABS(XLOW))
30231 NEVT = KEVT
30232 ELSEIF (NORM.EQ.6) THEN
30233 DX = ONE
30234 NEVT = KEVT
30235 ELSEIF (NORM.EQ.7) THEN
30236 DX = ONE
30237 NEVT = INT(HIST(7,IHIS,IBIN))
30238 ELSEIF (NORM.EQ.8) THEN
30239 DX = XHI-XLOW
30240 NEVT = INT(DENTRY(2,IHIS))
30241 ELSE
30242 DX = ABS(XHI-XLOW)
30243 NEVT = KEVT
30244 ENDIF
30245 IF (ABS(DX).LT.TINY35) DX = ONE
30246 NEVT = MAX(NEVT,1)
30247 YMEAN = HIST(5,IHIS,IBIN)/DX/DBLE(NEVT)
30248 YMEAN2 = HIST(6,IHIS,IBIN)/DX**2/DBLE(NEVT)
30249 YERR = SQRT(ABS(YMEAN2-YMEAN**2))/SQRT(DBLE(NEVT))
30250 YSUM = HIST(5,IHIS,IBIN)
30251 IF (ABS(YSUM).LT.TINY35) YSUM = ONE
30252C XMEAN = HIST(3,IHIS,IBIN)/YSUM/MAX(HIST(2,IHIS,IBIN),ONE)
30253 XMEAN = HIST(3,IHIS,IBIN)/YSUM
30254 IF (XMEAN.EQ.ZERO) XMEAN = XLOW
30255
30256 RETURN
30257 END
30258
30259*$ CREATE DT_JOIHIS.FOR
30260*COPY DT_JOIHIS
30261*
30262*===joihis=============================================================*
30263*
30264 SUBROUTINE DT_JOIHIS(IH1,IH2,COPER,FAC1,FAC2,KEVT,NORM,ILOGY,MODE)
30265
30266************************************************************************
30267* *
30268* Operation on histograms. *
30269* *
30270* input: IH1,IH2 histogram indices to be joined *
30271* COPER character defining the requested operation, *
30272* i.e. '+', '-', '*', '/' *
30273* FAC1,FAC2 factors for joining, i.e. *
30274* FAC1*histo1 COPER FAC2*histo2 *
30275* *
30276* This version dated 23.4.95 is written by S. Roesler. *
30277************************************************************************
30278
30279 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30280 SAVE
30281 PARAMETER ( LINP = 10 ,
30282 & LOUT = 6 ,
30283 & LDAT = 9 )
30284
30285 CHARACTER COPER*1
30286
30287 PARAMETER (ZERO = 0.0D0,
30288 & ONE = 1.0D0,
30289 & OHALF = 0.5D0,
30290 & TINY8 = 1.0D-8,
30291 & SMALL = -1.0D8,
30292 & RLARGE = 1.0D8 )
30293
30294* histograms
30295 PARAMETER (NHIS=150, NDIM=250)
30296 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30297 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30298
30299 PARAMETER (NDIM2 = 2*NDIM)
30300 DIMENSION XX(NDIM2),YY(NDIM2),YY1(NDIM),XX1(NDIM)
30301
30302 CHARACTER*43 CNORM(0:6)
30303 DATA CNORM /'no further normalization ',
30304 & 'per event and bin width ',
30305 & 'per entry and bin width ',
30306 & 'per bin entry ',
30307 & 'per event and "bin width" x1^2...x2^2 ',
30308 & 'per event and "log. bin width" ln x1..ln x2',
30309 & 'per event '/
30310
30311* check histogram indices
30312 IF ((IH1.LT. 1).OR.(IH2.LT. 1).OR.
30313 & (IH1.GT.IHISL).OR.(IH2.GT.IHISL)) THEN
30314 WRITE(LOUT,1000) IH1,IH2,IHISL
30315 1000 FORMAT(1X,'JOIHIS: warning! inconsistent histogram ',
30316 & 'indices (',I3,',',I3,'),',/,21X,'valid range: 1,',I3)
30317 GOTO 9999
30318 ENDIF
30319
30320* check bin structure of histograms to be joined
30321 IF (IBINS(IH1).NE.IBINS(IH2)) THEN
30322 WRITE(LOUT,1001) IH1,IH2,IBINS(IH1),IBINS(IH2)
30323 1001 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3,
30324 & ' and ',I3,' failed',/,21X,
30325 & 'due to different numbers of bins (',I3,',',I3,')')
30326 GOTO 9999
30327 ENDIF
30328 DO 1 K=1,IBINS(IH1)+1
30329 IF (ABS(HIST(1,IH1,K)-HIST(1,IH2,K)).GT.TINY8) THEN
30330 WRITE(LOUT,1002) IH1,IH2,K,HIST(1,IH1,K),HIST(1,IH2,K)
30331 1002 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3,
30332 & ' and ',I3,' failed at bin edge ',I3,/,21X,
30333 & 'X1,X2 = ',2E11.4)
30334 GOTO 9999
30335 ENDIF
30336 1 CONTINUE
30337
30338 WRITE(LOUT,1003) IH1,IH2,COPER,FAC1,FAC2
30339 1003 FORMAT(1X,'JOIHIS: joining histograms ',I3,',',I3,' with ',
30340 & 'operation ',A,/,11X,'and factors ',2E11.4)
30341 WRITE(LOUT,1004) CNORM(NORM)
30342 1004 FORMAT(1X,'normalization: ',A,/)
30343
30344 DO 2 K=1,IBINS(IH1)
30345 CALL DT_GETBIN(IH1,K,KEVT,NORM,XLOW1,XHI1,XMEAN1,YMEAN1,YERR1)
30346 CALL DT_GETBIN(IH2,K,KEVT,NORM,XLOW2,XHI2,XMEAN2,YMEAN2,YERR2)
30347 XLOW = XLOW1
30348 XHI = XHI1
30349 XMEAN = OHALF*(XMEAN1+XMEAN2)
30350 IF (COPER.EQ.'+') THEN
30351 YMEAN = FAC1*YMEAN1+FAC2*YMEAN2
30352 ELSEIF (COPER.EQ.'*') THEN
30353 YMEAN = FAC1*YMEAN1*FAC2*YMEAN2
30354 ELSEIF (COPER.EQ.'/') THEN
30355 IF (YMEAN2.EQ.ZERO) THEN
30356 YMEAN = ZERO
30357 ELSE
30358 IF (FAC2.EQ.ZERO) FAC2 = ONE
30359 YMEAN = FAC1*YMEAN1/(FAC2*YMEAN2)
30360 ENDIF
30361 ELSE
30362 GOTO 9998
30363 ENDIF
30364 WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30365 WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30366 1006 FORMAT(1X,5E11.3)
30367* small frame
30368 II = 2*K
30369 XX(II-1) = HIST(1,IH1,K)
30370 XX(II) = HIST(1,IH1,K+1)
30371 YY(II-1) = YMEAN
30372 YY(II) = YMEAN
30373* wide frame
30374 XX1(K) = XMEAN
30375 IF ((ISWI(IH1).EQ.3).OR.(ISWI(IH1).EQ.4)) XX1(K) = LOG10(XMEAN)
30376 YY1(K) = YMEAN
30377 2 CONTINUE
30378
30379* plot small frame
30380 IF (ABS(MODE).EQ.1) THEN
30381 IBIN2 = 2*IBINS(IH1)
30382 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30383 IF(ILOGY.EQ.1) THEN
30384 CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30385 ELSE
30386 CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30387 ENDIF
30388 ENDIF
30389
30390* plot wide frame
30391 IF (ABS(MODE).EQ.2) THEN
30392 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30393 NSIZE = NDIM
30394 DXLOW = HIST(1,IH1,1)
30395 DDX = ABS(HIST(1,IH1,2)-HIST(1,IH1,1))
30396 YLOW = RLARGE
30397 YHI = SMALL
30398 DO 3 I=1,NDIM
30399 IF (YY1(I).LT.YLOW) THEN
30400 IF (ILOGY.EQ.1) THEN
30401 IF (YY1(I).GT.ZERO) YLOW = YY1(I)
30402 ELSE
30403 YLOW = YY1(I)
30404 ENDIF
30405 ENDIF
30406 IF (YY1(I).GT.YHI) YHI = YY1(I)
30407 3 CONTINUE
30408 DY = (YHI-YLOW)/DBLE(NDIM)
30409 IF (DY.LE.ZERO) THEN
30410 WRITE(LOUT,'(1X,A,2I4,A,2E12.4)')
30411 & 'JOIHIS: warning! zero bin width for histograms ',
30412 & IH1,IH2,': ',YLOW,YHI
30413 RETURN
30414 ENDIF
30415 IF (ILOGY.EQ.1) THEN
30416 YLOW = LOG10(YLOW)
30417 DY = (LOG10(YHI)-YLOW)/100.0D0
30418 DO 4 I=1,NDIM
30419 IF (YY1(I).LE.ZERO) THEN
30420 YY1(I) = YLOW
30421 ELSE
30422 YY1(I) = LOG10(YY1(I))
30423 ENDIF
30424 4 CONTINUE
30425 ENDIF
30426 CALL DT_SRPLOT(XX1,YY1,NSIZE,1,NDIM,DXLOW,DDX,YLOW,DY)
30427 ENDIF
30428
30429 RETURN
30430
30431 9998 CONTINUE
30432 WRITE(LOUT,1005) COPER
30433 1005 FORMAT(1X,'JOIHIS: unknown operation ',A)
30434
30435 9999 CONTINUE
30436 RETURN
30437 END
30438
30439*$ CREATE DT_XGRAPH.FOR
30440*COPY DT_XGRAPH
30441*
30442*===qgraph=============================================================*
30443*
30444 SUBROUTINE DT_XGRAPH(N,IARG,X,Y1,Y2)
30445C***********************************************************************
30446C
30447C calculate quasi graphic picture with 25 lines and 79 columns
30448C ranges will be chosen automatically
30449C
30450C input N dimension of input fields
30451C IARG number of curves (fields) to plot
30452C X field of X
30453C Y1 field of Y1
30454C Y2 field of Y2
30455C
30456C This subroutine is written by R. Engel.
30457C***********************************************************************
30458 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30459 SAVE
30460
30461 PARAMETER ( LINP = 10 ,
30462 & LOUT = 6 ,
30463 & LDAT = 9 )
30464C
30465 DIMENSION X(N),Y1(N),Y2(N)
30466 PARAMETER (EPS=1.D-30)
30467 PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30468 CHARACTER SYMB(5)
30469 CHARACTER COL(0:149,0:49)
30470C
30471 DATA SYMB /'0','e','z','#','x'/
30472C
30473 ISPALT=IBREIT-10
30474C
30475C*** automatic range fitting
30476C
30477 XMAX=X(1)
30478 XMIN=X(1)
30479 DO 600 I=1,N
30480 XMAX=MAX(X(I),XMAX)
30481 XMIN=MIN(X(I),XMIN)
30482 600 CONTINUE
30483 XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30484C
30485 ITEST=0
30486 DO 1100 K=0,IZEIL-1
30487 ITEST=ITEST+1
30488 IF (ITEST.EQ.IYRAST) THEN
30489 DO 1010 L=1,ISPALT-1
30490 COL(L,K)='-'
304911010 CONTINUE
30492 COL(ISPALT,K)='+'
30493 ITEST=0
30494 DO 1020 L=0,ISPALT-1,IXRAST
30495 COL(L,K)='+'
304961020 CONTINUE
30497 ELSE
30498 DO 1030 L=1,ISPALT-1
30499 COL(L,K)=' '
305001030 CONTINUE
30501 DO 1040 L=0,ISPALT-1,IXRAST
30502 COL(L,K)='|'
305031040 CONTINUE
30504 COL(ISPALT,K)='|'
30505 ENDIF
305061100 CONTINUE
30507C
30508C*** plot curve Y1
30509C
30510 YMAX=Y1(1)
30511 YMIN=Y1(1)
30512 DO 500 I=1,N
30513 YMAX=MAX(Y1(I),YMAX)
30514 YMIN=MIN(Y1(I),YMIN)
30515500 CONTINUE
30516 IF(IARG.GT.1) THEN
30517 DO 550 I=1,N
30518 YMAX=MAX(Y2(I),YMAX)
30519 YMIN=MIN(Y2(I),YMIN)
30520550 CONTINUE
30521 ENDIF
30522 YMAX=(YMAX-YMIN)/40.0D0+YMAX
30523 YMIN=YMIN-(YMAX-YMIN)/40.0D0
30524 YZOOM=(YMAX-YMIN)/DBLE(IZEIL)
30525 IF(YZOOM.LT.EPS) THEN
30526 WRITE(LOUT,'(1X,A)')
30527 & 'XGRAPH:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30528 RETURN
30529 ENDIF
30530C
30531C*** plot curve Y1
30532C
30533 ILAST=-1
30534 LLAST=-1
30535 DO 1200 K=1,N
30536 L=NINT((X(K)-XMIN)/XZOOM)
30537 I=NINT((YMAX-Y1(K))/YZOOM)
30538 IF(ILAST.GE.0) THEN
30539 LD = L-LLAST
30540 ID = I-ILAST
30541 DO 55 II=0,LD,SIGN(1,LD)
30542 DO 66 KK=0,ID,SIGN(1,ID)
30543 COL(II+LLAST,KK+ILAST)=SYMB(1)
30544 66 CONTINUE
30545 55 CONTINUE
30546 ELSE
30547 COL(L,I)=SYMB(1)
30548 ENDIF
30549 ILAST = I
30550 LLAST = L
305511200 CONTINUE
30552C
30553 IF(IARG.GT.1) THEN
30554C
30555C*** plot curve Y2
30556C
30557 DO 1250 K=1,N
30558 L=NINT((X(K)-XMIN)/XZOOM)
30559 I=NINT((YMAX-Y2(K))/YZOOM)
30560 COL(L,I)=SYMB(2)
305611250 CONTINUE
30562 ENDIF
30563C
30564C*** write it
30565C
30566 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30567C
30568C*** write range of X
30569C
30570 XZOOM = (XMAX-XMIN)/DBLE(7)
30571 WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30572C
30573 DO 1300 K=0,IZEIL-1
30574 YPOS=YMAX-((DBLE(K)+0.5D0)*YZOOM)
30575 WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30576 110 FORMAT(1X,1PE9.2,70A1)
305771300 CONTINUE
30578C
30579C*** write range of X
30580C
30581 XZOOM = (XMAX-XMIN)/DBLE(7)
30582 WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30583 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30584 120 FORMAT(6X,7(1PE10.3))
30585 END
30586
30587*$ CREATE DT_XGLOGY.FOR
30588*COPY DT_XGLOGY
30589*
30590*===qglogy=============================================================*
30591*
30592 SUBROUTINE DT_XGLOGY(N,IARG,X,Y1,Y2)
30593C***********************************************************************
30594C
30595C calculate quasi graphic picture with 25 lines and 79 columns
30596C logarithmic y axis
30597C ranges will be chosen automatically
30598C
30599C input N dimension of input fields
30600C IARG number of curves (fields) to plot
30601C X field of X
30602C Y1 field of Y1
30603C Y2 field of Y2
30604C
30605C This subroutine is written by R. Engel.
30606C***********************************************************************
30607C
30608 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30609 SAVE
30610
30611 PARAMETER ( LINP = 10 ,
30612 & LOUT = 6 ,
30613 & LDAT = 9 )
30614 DIMENSION X(N),Y1(N),Y2(N)
30615 PARAMETER (EPS=1.D-30)
30616 PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30617 CHARACTER SYMB(5)
30618 CHARACTER COL(0:149,0:49)
30619 PARAMETER (DEPS = 1.D-10)
30620C
30621 DATA SYMB /'0','e','z','#','x'/
30622C
30623 ISPALT=IBREIT-10
30624C
30625C*** automatic range fitting
30626C
30627 XMAX=X(1)
30628 XMIN=X(1)
30629 DO 600 I=1,N
30630 XMAX=MAX(X(I),XMAX)
30631 XMIN=MIN(X(I),XMIN)
30632 600 CONTINUE
30633 XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30634C
30635 ITEST=0
30636 DO 1100 K=0,IZEIL-1
30637 ITEST=ITEST+1
30638 IF (ITEST.EQ.IYRAST) THEN
30639 DO 1010 L=1,ISPALT-1
30640 COL(L,K)='-'
306411010 CONTINUE
30642 COL(ISPALT,K)='+'
30643 ITEST=0
30644 DO 1020 L=0,ISPALT-1,IXRAST
30645 COL(L,K)='+'
306461020 CONTINUE
30647 ELSE
30648 DO 1030 L=1,ISPALT-1
30649 COL(L,K)=' '
306501030 CONTINUE
30651 DO 1040 L=0,ISPALT-1,IXRAST
30652 COL(L,K)='|'
306531040 CONTINUE
30654 COL(ISPALT,K)='|'
30655 ENDIF
306561100 CONTINUE
30657C
30658C*** plot curve Y1
30659C
30660 YMAX=Y1(1)
30661 YMIN=MAX(Y1(1),EPS)
30662 DO 500 I=1,N
30663 YMAX =MAX(Y1(I),YMAX)
30664 IF(Y1(I).GT.EPS) THEN
30665 IF(YMIN.EQ.EPS) THEN
30666 YMIN = Y1(I)/10.D0
30667 ELSE
30668 YMIN = MIN(Y1(I),YMIN)
30669 ENDIF
30670 ENDIF
30671500 CONTINUE
30672 IF(IARG.GT.1) THEN
30673 DO 550 I=1,N
30674 YMAX=MAX(Y2(I),YMAX)
30675 IF(Y2(I).GT.EPS) THEN
30676 IF(YMIN.EQ.EPS) THEN
30677 YMIN = Y2(I)
30678 ELSE
30679 YMIN = MIN(Y2(I),YMIN)
30680 ENDIF
30681 ENDIF
30682550 CONTINUE
30683 ENDIF
30684C
30685 DO 560 I=1,N
30686 Y1(I) = MAX(Y1(I),YMIN)
30687 560 CONTINUE
30688 IF(IARG.GT.1) THEN
30689 DO 570 I=1,N
30690 Y2(I) = MAX(Y2(I),YMIN)
30691 570 CONTINUE
30692 ENDIF
30693C
30694 IF(YMAX.LE.YMIN) THEN
30695 WRITE(LOUT,'(/1X,A,2E12.3,/)')
30696 & 'XGLOGY:ERROR:YMIN,YMAX ',YMIN,YMAX
30697 WRITE(LOUT,'(1X,A)') 'MIN = MAX, OUTPUT SUPPRESSED'
30698 RETURN
30699 ENDIF
30700C
30701 YMA=(LOG10(YMAX)-LOG10(YMIN))/20.0D0+LOG10(YMAX)
30702 YMI=LOG10(YMIN)-(LOG10(YMAX)-LOG10(YMIN))/20.0D0
30703 YZOOM=(YMA-YMI)/DBLE(IZEIL)
30704 IF(YZOOM.LT.EPS) THEN
30705 WRITE(LOUT,'(1X,A)')
30706 & 'XGLOGY:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30707 RETURN
30708 ENDIF
30709C
30710C*** plot curve Y1
30711C
30712 ILAST=-1
30713 LLAST=-1
30714 DO 1200 K=1,N
30715 L=NINT((X(K)-XMIN)/XZOOM)
30716 I=NINT((YMA-LOG10(Y1(K)))/YZOOM)
30717 IF(ILAST.GE.0) THEN
30718 LD = L-LLAST
30719 ID = I-ILAST
30720 DO 55 II=0,LD,SIGN(1,LD)
30721 DO 66 KK=0,ID,SIGN(1,ID)
30722 COL(II+LLAST,KK+ILAST)=SYMB(1)
30723 66 CONTINUE
30724 55 CONTINUE
30725 ELSE
30726 COL(L,I)=SYMB(1)
30727 ENDIF
30728 ILAST = I
30729 LLAST = L
307301200 CONTINUE
30731C
30732 IF(IARG.GT.1) THEN
30733C
30734C*** plot curve Y2
30735C
30736 DO 1250 K=1,N
30737 L=NINT((X(K)-XMIN)/XZOOM)
30738 I=NINT((YMA-LOG10(Y2(K)))/YZOOM)
30739 COL(L,I)=SYMB(2)
307401250 CONTINUE
30741 ENDIF
30742C
30743C*** write it
30744C
30745 WRITE(LOUT,'(2X,A)') '(LOGARITHMIC Y AXIS)'
30746 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30747C
30748C*** write range of X
30749C
30750 XZOOM1 = (XMAX-XMIN)/DBLE(7)
30751 WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30752C
30753 DO 1300 K=0,IZEIL-1
30754 YPOS=10.D0**(YMA-((DBLE(K)+0.5D0)*YZOOM))
30755 WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30756 110 FORMAT(1X,1PE9.2,70A1)
307571300 CONTINUE
30758C
30759C*** write range of X
30760C
30761 WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30762 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30763 120 FORMAT(6X,7(1PE10.3))
30764C
30765 END
30766
30767*$ CREATE DT_SRPLOT.FOR
30768*COPY DT_SRPLOT
30769*
30770*===plot===============================================================*
30771*
30772 SUBROUTINE DT_SRPLOT(X,Y,N,M,MM,XO,DX,YO,DY)
30773
30774 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30775 SAVE
30776
30777 PARAMETER ( LINP = 10 ,
30778 & LOUT = 6 ,
30779 & LDAT = 9 )
30780*
30781* initial version
30782* J. Ranft, (FORTRAN-Programmierung,J.R.,Teubner, Leipzig, 72)
30783* This is a subroutine of fluka to plot Y across the page
30784* as a function of X down the page. Up to 37 curves can be
30785* plotted in the same picture with different plotting characters.
30786* Output of first 10 overprinted characters addad by FB 88
30787* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
30788*
30789* Input Variables:
30790* X = array containing the values of X
30791* Y = array containing the values of Y
30792* N = number of values in X and in Y
30793* can exceed the fixed number of lines
30794* M = number of different curves X,Y are containing
30795* MM = number of points in each curve i.e. N=M*MM
30796* XO = smallest value of X to be plotted
30797* DX = increment of X between subsequent lines
30798* YO = smallest value of Y to be plotted
30799* DY = increment of Y between subsequent character spaces
30800*
30801* other variables used inside:
30802* XX = numbers along the X-coordinate axis
30803* YY = numbers along the Y-coordinate axis
30804* LL = ten lines temporary storage for the plot
30805* L = character set used to plot different curves
30806* LOV = memorizes overprinted symbols
30807* the first 10 overprinted symbols are printed on
30808* the end of the line to avoid ambiguities
30809* (added by FB as considered quite helpful)
30810*
30811*********************************************************************
30812*
30813 DIMENSION XX(61),YY(61),LL(101,10)
30814 DIMENSION X(N),Y(N),L(40),LOV(40,10)
333481d6 30815 INTEGER*4 LL, L, LOV
9aaba0d6 30816 DATA L/
30817 11H*,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HZ,
30818 21H+,1HA,1HO,1HB,1HC,1HD,1HE,1HF,1HG,1HH,
30819 31HI,1HJ,1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,
30820 41HS,1HT,1HU,1HV,1HW,1HX,1HY,1H1,1H-,1H /
30821*
30822*
30823 MN=51
30824 DO 10 I=1,MN
30825 AI=I-1
30826 10 XX(I)=XO+AI*DX
30827 DO 20 I=1,11
30828 AI=I-1
30829 20 YY(I)=YO+10.0D0*AI*DY
30830 WRITE(LOUT, 500) (YY(I),I=1,11)
30831 MMN=MN-1
30832*
30833*
30834 DO 90 JJ=1,MMN,10
30835 JJJ=JJ-1
30836 DO 30 I=1,101
30837 DO 30 J=1,10
30838 30 LL(I,J)=L(40)
30839 DO 40 I=1,101
30840 40 LL(I,1)=L(39)
30841 DO 50 I=1,101,10
30842 DO 50 J=1,10
30843 50 LL(I,J)=L(38)
30844 DO 60 I=1,40
30845 DO 60 J=1,10
30846 60 LOV(I,J)=L(40)
30847*
30848*
30849 DO 70 I=1,M
30850 DO 70 J=1,MM
30851 II=J+(I-1)*MM
30852 AIX=(X(II)-(XO-DX/2.0D0))/DX+1.0D0
30853 AIY=(Y(II)-(YO-DY/2.0D0))/DY+1.0D0
30854 AIX=AIX-DBLE(JJJ)
30855* changed Sept.88 by FB to avoid INTEGER OVERFLOW
30856 IF( AIX .GT. 1.D0.AND. AIX .LT. 11.D0.AND. AIY .GT. 1.D0.AND
30857 + . AIY .LT. 102.D0) THEN
30858 IX=INT(AIX)
30859 IY=INT(AIY)
30860 IF( IX.GT. 0.AND. IX.LE. 10.AND. IY.GT. 0.AND. IY.LE. 101)
30861 + THEN
30862 IF(LL(IY,IX).NE.L(38).AND.LL(IY,IX).NE.L(39)) LOV(I,IX)
30863 + =LL(IY,IX)
30864 LL(IY,IX)=L(I)
30865 ENDIF
30866 ENDIF
30867 70 CONTINUE
30868*
30869*
30870 DO 80 I=1,10
30871 II=I+JJJ
30872 III=II+1
30873 WRITE(LOUT,510) XX(II),XX(III) , (LL(J,I),J=1,101) ,
30874 & (LOV(J,I),J=1,10)
30875 80 CONTINUE
30876 90 CONTINUE
30877*
30878*
30879 WRITE(LOUT, 520)
30880 WRITE(LOUT, 500) (YY(I),I=1,11)
30881 RETURN
30882*
30883 500 FORMAT(11X,11(1PE10.2),11HOVERPRINTED)
30884 510 FORMAT(1X,2(1PE10.2),101A1,1H ,10A1)
30885 520 FORMAT(20X,10('1---------'),'1')
30886 END
30887
30888*$ CREATE DT_DEFSET.FOR
30889*COPY DT_DEFSET
30890*
30891*===defset=============================================================*
30892*
30893 BLOCK DATA DT_DEFSET
30894
30895 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30896 SAVE
30897
30898* flags for input different options
30899 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
30900 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
30901 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
30902 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
30903* emulsion treatment
30904 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
30905 & NCOMPO,IEMUL
30906
30907* / DTFLG1 /
30908 DATA IFRAG / 2, 1 /
30909 DATA IRESCO / 1 /
30910 DATA IMSHL / 1 /
30911 DATA IRESRJ / 0 /
30912 DATA IOULEV / -1, -1, -1, -1, -1, -1 /
30913 DATA LEMCCK / .FALSE. /
30914 DATA LHADRO / .FALSE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,
30915 & .TRUE.,.TRUE.,.TRUE./
30916 DATA LSEADI / .TRUE. /
30917 DATA LEVAPO / .TRUE. /
30918 DATA IFRAME / 1 /
30919 DATA ITRSPT / 0 /
30920
30921* / DTCOMP /
30922 DATA EMUFRA / NCOMPX*0.0D0 /
30923 DATA IEMUMA / NCOMPX*1 /
30924 DATA IEMUCH / NCOMPX*1 /
30925 DATA NCOMPO / 0 /
30926 DATA IEMUL / 0 /
30927
30928 END
30929
30930*$ CREATE DT_HADPRP.FOR
30931*COPY DT_HADPRP
30932*
30933*===hadprp=============================================================*
30934*
30935 BLOCK DATA DT_HADPRP
30936
30937 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30938 SAVE
30939
30940* auxiliary common for reggeon exchange (DTUNUC 1.x)
30941 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
30942 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
30943 & IQTCHR(-6:6),MQUARK(3,39)
30944* hadron index conversion (BAMJET <--> PDG)
30945 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
30946 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
30947 & IAMCIN(210)
30948* names of hadrons used in input-cards
30949 CHARACTER*8 BTYPE
30950 COMMON /DTPAIN/ BTYPE(30)
30951
30952* / DTQUAR /
30953*----------------------------------------------------------------------*
30954* *
30955* Quark content of particles: *
30956* index quark el. charge bar. charge isospin isospin3 *
30957* 1 = u 2/3 1/3 1/2 1/2 *
30958* -1 = ubar -2/3 -1/3 1/2 -1/2 *
30959* 2 = d -1/3 1/3 1/2 -1/2 *
30960* -2 = dbar 1/3 -1/3 1/2 1/2 *
30961* 3 = s -1/3 1/3 0 0 *
30962* -3 = sbar 1/3 -1/3 0 0 *
30963* 4 = c 2/3 1/3 0 0 *
30964* -4 = cbar -2/3 -1/3 0 0 *
30965* 5 = b -1/3 1/3 0 0 *
30966* -5 = bbar 1/3 -1/3 0 0 *
30967* 6 = t 2/3 1/3 0 0 *
30968* -6 = tbar -2/3 -1/3 0 0 *
30969* *
30970* Mquark = particle quark composition (Paprop numbering) *
30971* Iqechr = electric charge ( in 1/3 unit ) *
30972* Iqbchr = baryonic charge ( in 1/3 unit ) *
30973* Iqichr = isospin ( in 1/2 unit ), z component *
30974* Iqschr = strangeness *
30975* Iqcchr = charm *
30976* Iquchr = beauty *
30977* Iqtchr = ...... *
30978* *
30979*----------------------------------------------------------------------*
30980 DATA IQECHR / -2, 1, -2, 1, 1, -2, 0, 2, -1, -1, 2, -1, 2 /
30981 DATA IQBCHR / 6*-1, 0, 6*1 /
30982 DATA IQICHR / 4*0, 1, -1, 0, 1, -1, 4*0 /
30983 DATA IQSCHR / 3*0, 1, 5*0, -1, 3*0 /
30984 DATA IQCCHR / 2*0, -1, 7*0, 1, 2*0 /
30985 DATA IQUCHR / 0, 1, 9*0, -1, 0 /
30986 DATA IQTCHR / -1, 11*0, 1 /
30987 DATA MQUARK /
30988 & 2, 1, 1, -2,-1,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
30989 & 0, 0, 0, 0, 0, 0, 2, 2, 1, -2,-2,-1, 0, 0, 0,
30990 & 0, 0, 0, 0, 0, 0, 1,-2, 0, 2,-1, 0, 1,-3, 0,
30991 & 3,-1, 0, 1, 2, 3, -1,-2,-3, 0, 0, 0, 2, 2, 3,
30992 & 1, 1, 3, 1, 2, 3, 1,-1, 0, 2,-3, 0, 3,-2, 0,
30993 & 2,-2, 0, 3,-3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
30994 & -1,-1,-3, -1,-2,-3, -2,-2,-3, 1, 3, 3, -1,-3,-3,
30995 & 2, 3, 3, -2,-3,-3, 3, 3, 3, -3,-3,-3 /
30996
30997* / DTHAIC /
30998* (renamed) (HAdron InDex COnversion)
30999* translation table version filled up by r.e. 25.01.94 *
31000 DATA IAMCIN /
31001 &2212,-2212,11,-11,12, -12,22,2112,-2112,-13,
31002 &13,130,211,-211,321, -321,3122,-3122,310,3112,
31003 &3222,3212,111,311,-311, 0,0,0,0,0,
31004 &221,213,113,-213,223, 323,313,-323,-313,10323,
31005 &10313,-10323,-10313,30323,30313, -30323,-30313,3224,3214,3114,
31006 &3216,3218,2224,2214,2114, 1114,12224,12214,12114,11114,
31007 &99999,99999,22212,22112,32124, 31214,-2224,-2214,-2114,-1114,
31008 &-12224,-12214,-12114,-11114,-2124, -1214,4*99999,
31009 &5*99999, 5*99999,
31010 &4*99999,331, 333,3322,3312,-3222,-3212,
31011 &-3112,-3322,-3312,3224,3214, 3114,3324,3314,3334,-3224,
31012 &-3214,-3114,-3324,-3314,-3334, 421,411,-411,-421,431,
31013 &-431,441,423,413,-413, -423,433,-433,20443,443,
31014 &-15,15,16,-16,14, -14,4122,4232,4132,4222,
31015 &4212,4112,3*99999, 3*99999,-4122,-4232,
31016 &-4132,-4222,-4212,-4112,99999, 5*99999,
31017 &5*99999, 5*99999,
31018 &10*99999,
31019 &5*99999 , 20211,20111,-20211,99999,20321,
31020 &-20321,20311,-20311,7*99999 ,
31021 &7*99999,12212,12112,99999/
31022
31023* / DTHAIC /
31024* (HAdron InDex COnversion)
31025 DATA (IPDG2(1,K),K=1,7)
31026 & / -11, -12, -13, -15, -16, -14, 0/
31027 DATA (IBAM2(1,K),K=1,7)
31028 & / 4, 6, 10, 131, 134, 136, 0/
31029 DATA (IPDG2(2,K),K=1,7)
31030 & / 11, 12, 22, 13, 15, 16, 14/
31031 DATA (IBAM2(2,K),K=1,7)
31032 & / 3, 5, 7, 11, 132, 133, 135/
31033 DATA (IPDG3(1,K),K=1,22)
31034 & / -211, -321, -311, -213, -323, -313, -411, -421,
31035 & -431, -413, -423, -433, 0, 0, 0, 0,
31036 & 0, 0, 0, 0, 0, 0/
31037 DATA (IBAM3(1,K),K=1,22)
31038 & / 14, 16, 25, 34, 38, 39, 118, 119,
31039 & 121, 125, 126, 128, 0, 0, 0, 0,
31040 & 0, 0, 0, 0, 0, 0/
31041 DATA (IPDG3(2,K),K=1,22)
31042 & / 130, 211, 321, 310, 111, 311, 221, 213,
31043 & 113, 223, 323, 313, 331, 333, 421, 411,
31044 & 431, 441, 423, 413, 433, 443/
31045 DATA (IBAM3(2,K),K=1,22)
31046 & / 12, 13, 15, 19, 23, 24, 31, 32,
31047 & 33, 35, 36, 37, 95, 96, 116, 117,
31048 & 120, 122, 123, 124, 127, 130/
31049 DATA (IPDG4(1,K),K=1,29)
31050 & / -2212, -2112, -3122, -2224, -2214, -2114, -1114, -2124,
31051 & -1214, -3222, -3212, -3112, -3322, -3312, -3224, -3214,
31052 & -3114, -3324, -3314, -3334, -4122, -4232, -4132, -4222,
31053 & -4212, -4112, 0, 0, 0/
31054 DATA (IBAM4(1,K),K=1,29)
31055 & / 2, 9, 18, 67, 68, 69, 70, 75,
31056 & 76, 99, 100, 101, 102, 103, 110, 111,
31057 & 112, 113, 114, 115, 149, 150, 151, 152,
31058 & 153, 154, 0, 0, 0/
31059 DATA (IPDG4(2,K),K=1,29)
31060 & / 2212, 2112, 3122, 3112, 3222, 3212, 3224, 3214,
31061 & 3114, 3216, 3218, 2224, 2214, 2114, 1114, 3322,
31062 & 3312, 3224, 3214, 3114, 3324, 3314, 3334, 4122,
31063 & 4232, 4132, 4222, 4212, 4112/
31064 DATA (IBAM4(2,K),K=1,29)
31065 & / 1, 8, 17, 20, 21, 22, 48, 49,
31066 & 50, 51, 52, 53, 54, 55, 56, 97,
31067 & 98, 104, 105, 106, 107, 108, 109, 137,
31068 & 138, 139, 140, 141, 142/
31069 DATA (IPDG5(1,K),K=1,19)
31070 & /-10323,-10313,-30323,-30313,-12224,-12214,-12114,-11114,
31071 & -20211,-20321,-20311, 0, 0, 0, 0, 0,
31072 & 0, 0, 0/
31073 DATA (IBAM5(1,K),K=1,19)
31074 & / 42, 43, 46, 47, 71, 72, 73, 74,
31075 & 188, 191, 193, 0, 0, 0, 0, 0,
31076 & 0, 0, 0/
31077 DATA (IPDG5(2,K),K=1,19)
31078 & / 10323, 10313, 30323, 30313, 12224, 12214, 12114, 11114,
31079 & 22212, 22112, 32124, 31214, 20443, 20211, 20111, 20321,
31080 & 20311, 12212, 12112/
31081 DATA (IBAM5(2,K),K=1,19)
31082 & / 40, 41, 44, 45, 57, 58, 59, 60,
31083 & 63, 64, 65, 66, 129, 186, 187, 190,
31084 & 192, 208, 209/
31085
31086* / DTPAIN /
31087* internal particle names
31088 DATA BTYPE / 'PROTON ' , 'APROTON ' , 'ELECTRON' , 'POSITRON' ,
31089 &'NEUTRIE ' , 'ANEUTRIE' , 'PHOTON ' , 'NEUTRON ' , 'ANEUTRON' ,
31090 &'MUON+ ' , 'MUON- ' , 'KAONLONG' , 'PION+ ' , 'PION- ' ,
31091 &'KAON+ ' , 'KAON- ' , 'LAMBDA ' , 'ALAMBDA ' , 'KAONSHRT' ,
31092 &'SIGMA- ' , 'SIGMA+ ' , 'SIGMAZER' , 'PIZERO ' , 'KAONZERO' ,
31093 &'AKAONZER' , 'NEUTRIM ' , 'ANEUTRIM' , 'NEUTRIT ' , 'ANEUTRIT' ,
31094 &'BLANK ' /
31095
31096 END
31097
31098*$ CREATE DT_BLKD46.FOR
31099*COPY DT_BLKD46
31100*
31101*===blkd46=============================================================*
31102*
31103 BLOCK DATA DT_BLKD46
31104
31105 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31106 SAVE
31107
31108 PARAMETER ( AMELCT = 0.51099906 D-03 )
31109 PARAMETER ( AMMUON = 0.105658389 D+00 )
31110
31111* particle properties (BAMJET index convention)
31112 CHARACTER*8 ANAME
31113 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
31114 & IICH(210),IIBAR(210),K1(210),K2(210)
31115
31116* / DTPART /
31117* Particle masses Engel version JETSET compatible
31118C DATA (AAM(K),K=1,85) /
31119C & .9383D+00, .9383D+00, AMELCT , AMELCT , .0000D+00,
31120C & .0000D+00, .0000D+00, .9396D+00, .9396D+00, AMMUON ,
31121C & AMMUON , .4977D+00, .1396D+00, .1396D+00, .4936D+00,
31122C & .4936D+00, .1116D+01, .1116D+01, .4977D+00, .1197D+01,
31123C & .1189D+01, .1193D+01, .1350D+00, .4977D+00, .4977D+00,
31124C & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31125C & .5488D+00, .7669D+00, .7700D+00, .7669D+00, .7820D+00,
31126C & .8921D+00, .8962D+00, .8921D+00, .8962D+00, .1300D+01,
31127C & .1300D+01, .1300D+01, .1300D+01, .1421D+01, .1421D+01,
31128C & .1421D+01, .1421D+01, .1383D+01, .1384D+01, .1387D+01,
31129C & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
31130C & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
31131C & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
31132C & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
31133C & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
31134C & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
31135C & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 /
31136C DATA (AAM(K),K=86,183) /
31137C & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
31138C & .1700D+01, .1700D+01, .1820D+01, .2030D+01, .9575D+00,
31139C & .1019D+01, .1315D+01, .1321D+01, .1189D+01, .1193D+01,
31140C & .1197D+01, .1315D+01, .1321D+01, .1383D+01, .1384D+01,
31141C & .1387D+01, .1532D+01, .1535D+01, .1672D+01, .1383D+01,
31142C & .1384D+01, .1387D+01, .1532D+01, .1535D+01, .1672D+01,
31143C & .1865D+01, .1869D+01, .1869D+01, .1865D+01, .1969D+01,
31144C & .1969D+01, .2980D+01, .2007D+01, .2010D+01, .2010D+01,
31145C & .2007D+01, .2113D+01, .2113D+01, .3686D+01, .3097D+01,
31146C & .1784D+01, .1784D+01, .0000D+00, .0000D+00, .0000D+00,
31147C & .0000D+00, .2285D+01, .2460D+01, .2460D+01, .2452D+01,
31148C & .2453D+01, .2454D+01, .2560D+01, .2560D+01, .2730D+01,
31149C & .3610D+01, .3610D+01, .3790D+01, .2285D+01, .2460D+01,
31150C & .2460D+01, .2452D+01, .2453D+01, .2454D+01, .2560D+01,
31151C & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
31152C & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31153C & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31154C & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31155C & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31156C & .1250D+01, .1250D+01, .1250D+01 /
31157C DATA (AAM ( I ), I = 184,210 ) /
31158C & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31159C & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31160C & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31161C & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31162C & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31163C & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31164C & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31165C & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31166C & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31167* sr 25.1.06: particle masses adjusted to Pythia
31168 DATA (AAM(K),K=1,85) /
31169 & .938270E+00,.938270E+00, AMELCT , AMELCT ,.000000E+00,
31170 & .000000E+00,.000000E+00,.939570E+00,.939570E+00, AMMUON ,
31171 & AMMUON ,.497670E+00,.139570E+00,.139570E+00,.493600E+00,
31172 & .493600E+00,.111568E+01,.111568E+01,.497670E+00,.119744E+01,
31173 & .118937E+01,.119255E+01,.134980E+00,.497670E+00,.497670E+00,
31174 & .0000D+00, .0000D+00, .0000D+00 , .0000D+00, .0000D+00,
31175 & .547450E+00,.766900E+00,.768500E+00,.766900E+00,.781940E+00,
31176 & .891600E+00,.896100E+00,.891600E+00,.896100E+00,.129000E+01,
31177 & .129000E+01,.129000E+01,.129000E+01, .1421D+01, .1421D+01,
31178 & .1421D+01, .1421D+01,.138280E+01,.138370E+01,.138720E+01,
31179 & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
31180 & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
31181 & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
31182 & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
31183 & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
31184 & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
31185 & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 /
31186 DATA (AAM(K),K=86,183) /
31187 & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
31188 & .1700D+01, .1700D+01, .1820D+01, .2030D+01,.957770E+00,
31189 & .101940E+01,.131490E+01,.132130E+01,.118937E+01,.119255E+01,
31190 & .119744E+01,.131490E+01,.132130E+01,.138280E+01,.138370E+01,
31191 & .138720E+01,.153180E+01, .1535D+01,.167245E+01,.138280E+01,
31192 & .138370E+01,.138720E+01,.153180E+01, .1535D+01,.167245E+01,
31193 & .186450E+01,.186930E+01,.186930E+01,.186450E+01,.196850E+01,
31194 & .196850E+01,.297980E+01,.200670E+01, .2010D+01, .2010D+01,
31195 & .200670E+01,.211240E+01,.211240E+01, .3686D+01,.309688E+01,
31196 & .177700E+01,.177700E+01, .0000D+00, .0000D+00, .0000D+00,
31197 & .0000D+00,.228490E+01,.246560E+01,.247030E+01,.245290E+01,
31198 & .245350E+01,.245210E+01, .2560D+01, .2560D+01, .2730D+01,
31199 & .3610D+01, .3610D+01, .3790D+01,.228490E+01,.246560E+01,
31200 & .2460D+01,.245290E+01,.245350E+01,.245210E+01, .2560D+01,
31201 & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
31202 & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31203 & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31204 & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31205 & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31206 & .1250D+01, .1250D+01, .1250D+01 /
31207 DATA (AAM ( I ), I = 184,210 ) /
31208 & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31209 & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31210 & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31211 & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31212 & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31213 & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31214 & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31215 & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31216 & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31217* Particle mean lives
31218 DATA (TAU(K),K=1,183) /
31219 & .1000D+19, .1000D+19, .1000D+19, .1000D+19, .1000D+19,
31220 & .1000D+19, .1000D+19, .9180D+03, .9180D+03, .2200D-05,
31221 & .2200D-05, .5200D-07, .2600D-07, .2600D-07, .1200D-07,
31222 & .1200D-07, .2600D-09, .2600D-09, .9000D-10, .1500D-09,
31223 & .8000D-10, .5000D-14, .8000D-16, .0000D+00, .0000D+00,
31224 & 70*.0000D+00,
31225 & .0000D+00, .3000D-09, .1700D-09, .8000D-10, .1000D-13,
31226 & .1500D-09, .3000D-09, .1700D-09, .0000D+00, .0000D+00,
31227 & .0000D+00, .0000D+00, .0000D+00, .1000D-09, .0000D+00,
31228 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .1000D-09,
31229 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31230 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31231 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31232 & .9000D-11, .9000D-11, .9000D-11, .9000D-11, .1000D+19,
31233 & .1000D+19, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31234 & 40*.0000D+00,
31235 & .0000D+00, .0000D+00, .0000D+00 /
31236 DATA ( TAU ( I ), I = 184,210 ) /
31237 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31238 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31239 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31240 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31241 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31242 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31243 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31244 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31245 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00/
31246* Resonance width Gamma in GeV
31247 DATA (GA(K),K= 1,85) /
31248 & 30*.0000D+00,
31249 & .8500D-06, .1520D+00, .1520D+00, .1520D+00, .1000D-01,
31250 & .7900D-01, .7900D-01, .7900D-01, .7900D-01, .4500D+00,
31251 & .4500D+00, .4500D+00, .4500D+00, .1080D+00, .1080D+00,
31252 & .1080D+00, .1080D+00, .5000D-01, .5000D-01, .5000D-01,
31253 & .8500D-01, .1800D+00, .1150D+00, .1150D+00, .1150D+00,
31254 & .1150D+00, .2000D+00, .2000D+00, .2000D+00, .2000D+00,
31255 & .2000D+00, .2000D+00, .1000D+00, .1000D+00, .2000D+00,
31256 & .2000D+00, .1150D+00, .1150D+00, .1150D+00, .1150D+00,
31257 & .2000D+00, .2000D+00, .2000D+00, .2000D+00, .1000D+00,
31258 & .1000D+00, .2000D+00, .1000D+00, .1000D+00, .1000D+00,
31259 & .1000D+00, .1000D+00, .1000D+00, .1000D+00, .2000D+00 /
31260 DATA (GA(K),K= 86,183) /
31261 & .2000D+00, .2000D+00, .2000D+00, .1500D+00, .1500D+00,
31262 & .1500D+00, .1500D+00, .8500D-01, .1800D+00, .2000D-02,
31263 & .4000D-02, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31264 & .0000D+00, .0000D+00, .0000D+00, .3400D-01, .3400D-01,
31265 & .3600D-01, .9000D-02, .9000D-02, .0000D+00, .3400D-01,
31266 & .3400D-01, .3600D-01, .9000D-02, .9000D-02, .0000D+00,
31267 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31268 & .0000D+00, .0000D+00, .5000D-02, .2000D-02, .2000D-02,
31269 & .5000D-02, .2000D-02, .2000D-02, .2000D-03, .7000D-03,
31270 & 50*.0000D+00,
31271 & .3000D+00, .3000D+00, .3000D+00 /
31272 DATA ( GA ( I ), I = 184,210 ) /
31273 & 2.00000000000000D-01, 2.00000000000000D-01, 3.00000000000000D-01,
31274 & 3.00000000000000D-01, 3.00000000000000D-01, 2.70000000000000D-01,
31275 & 2.50000000000000D-01, 2.50000000000000D-01, 2.50000000000000D-01,
31276 & 2.50000000000000D-01, 1.50000000000000D-01, 1.50000000000000D-01,
31277 & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31278 & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31279 & 6.00000000000000D-02, 6.00000000000000D-02, 6.00000000000000D-02,
31280 & 6.00000000000000D-02, 5.50000000000000D-02, 5.50000000000000D-02,
31281 & 2.00000000000000D-01, 2.00000000000000D-01, 0.00000000000000D+00/
31282* Particle names
31283* S+1385+Sigma+(1385) L02030+Lambda0(2030)
31284* Rho77=Rho(770) Om783=Omega(783) K*14=K*(1420) and so on
31285* designation N*@@ means N*@1(@2)
31286 DATA (ANAME(K),K=1,85) /
31287 & 'P ','AP ','E- ','E+ ','NUE ',
31288 & 'ANUE ','GAM ','NEU ','ANEU ','MUE+ ',
31289 & 'MUE- ','K0L ','PI+ ','PI- ','K+ ',
31290 & 'K- ','LAM ','ALAM ','K0S ','SIGM- ',
31291 & 'SIGM+ ','SIGM0 ','PI0 ','K0 ','AK0 ',
31292 & 'BLANK ','BLANK ','BLANK ','BLANK ','BLANK ',
31293 & 'ETA550 ','RHO+77 ','RHO077 ','RHO-77 ','OM0783 ',
31294 & 'K*+892 ','K*0892 ','K*-892 ','AK*089 ','KA+125 ',
31295 & 'KA0125 ','KA-125 ','AKA012 ','K*+142 ','K*0142 ',
31296 & 'K*-142 ','AK*014 ','S+1385 ','S01385 ','S-1385 ',
31297 & 'L01820 ','L02030 ','N*++12 ','N*+ 12 ','N*012 ',
31298 & 'N*-12 ','N*++16 ','N*+16 ','N*016 ','N*-16 ',
31299 & 'N*+14 ','N*014 ','N*+15 ','N*015 ','N*+18 ',
31300 & 'N*018 ','AN--12 ','AN*-12 ','AN*012 ','AN*+12 ',
31301 & 'AN--16 ','AN*-16 ','AN*016 ','AN*+16 ','AN*-15 ',
31302 & 'AN*015 ','DE*=24 ','RPI+49 ','RPI049 ','RPI-49 ',
31303 & 'PIN++ ','PIN+0 ','PIN+- ','PIN-0 ','PPPI ' /
31304 DATA (ANAME(K),K=86,183) /
31305 & 'PNPI ','APPPI ','APNPI ','K+PPI ','K-PPI ',
31306 & 'K+NPI ','K-NPI ','S+1820 ','S-2030 ','ETA* ',
31307 & 'PHI ','TETA0 ','TETA- ','ASIG- ','ASIG0 ',
31308 & 'ASIG+ ','ATETA0 ','ATETA+ ','SIG*+ ','SIG*0 ',
31309 & 'SIG*- ','TETA*0 ','TETA* ','OMEGA- ','ASIG*- ',
31310 & 'ASIG*0 ','ASIG*+ ','ATET*0 ','ATET*+ ','OMEGA+ ',
31311 & 'D0 ','D+ ','D- ','AD0 ','F+ ',
31312 & 'F- ','ETAC ','D*0 ','D*+ ','D*- ',
31313 & 'AD*0 ','F*+ ','F*- ','PSI ','JPSI ',
31314 & 'TAU+ ','TAU- ','NUET ','ANUET ','NUEM ',
31315 & 'ANUEM ','C0+ ','A+ ','A0 ','C1++ ',
31316 & 'C1+ ','C10 ','S+ ','S0 ','T0 ',
31317 & 'XU++ ','XD+ ','XS+ ','AC0- ','AA- ',
31318 & 'AA0 ','AC1-- ','AC1- ','AC10 ','AS- ',
31319 & 'AS0 ','AT0 ','AXU-- ','AXD- ','AXS ',
31320 & 'C1*++ ','C1*+ ','C1*0 ','S*+ ','S*0 ',
31321 & 'T*0 ','XU*++ ','XD*+ ','XS*+ ','TETA++ ',
31322 & 'AC1*-- ','AC1*- ','AC1*0 ','AS*- ','AS*0 ',
31323 & 'AT*0 ','AXU*-- ','AXD*- ','AXS*- ','ATET-- ',
31324 & 'RO ','R+ ','R- ' /
31325 DATA ( ANAME ( I ), I = 184,210 ) /
31326 &'AN*-14 ','AN*014 ','PI+130 ','PI0130 ','PI-130 ','F01400 ',
31327 &'K*+146 ','K*-146 ','K*0146 ','AK0146 ','L01600 ','AL0160 ',
31328 &'S+1660 ','S01660 ','S-1660 ','AS-166 ','AS0166 ','AS+166 ',
31329 &'X01950 ','X-1950 ','AX0195 ','AX+195 ','OM-225 ','AOM+22 ',
31330 &'N*+14 ','N*014 ','BLANK '/
31331* Charge of particles and resonances
31332 DATA (IICH ( I ), I = 1,210 ) /
31333 & 1, -1, -1, 1, 0, 0, 0, 0, 0, 1, -1, 0, 1, -1, 1,
31334 & -1, 0, 0, 0, -1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31335 & 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0,
31336 & -1, 0, 1, 0, -1, 0, 0, 2, 1, 0, -1, 2, 1, 0, -1,
31337 & 1, 0, 1, 0, 1, 0, -2, -1, 0, 1, -2, -1, 0, 1, -1,
31338 & 0, 1, 1, 0, -1, 2, 1, 0, -1, 2, 1, 0, -1, 2, 0,
31339 & 1, -1, 1, -1, 0, 0, 0, -1, -1, 0, 1, 0, 1, 1, 0,
31340 & -1, 0, -1, -1, -1, 0, 1, 0, 1, 1, 0, 1, -1, 0, 1,
31341 & -1, 0, 0, 1, -1, 0, 1, -1, 0, 0, 1, -1, 0, 0, 0,
31342 & 0, 1, 1, 0, 2, 1, 0, 1, 0, 0, 2, 1, 1, -1, -1,
31343 & 0, -2, -1, 0, -1, 0, 0, -2, -1, -1, 2, 1, 0, 1, 0,
31344 & 0, 2, 1, 1, 2, -2, -1, 0, -1, 0, 0, -2, -1, -1, -2,
31345 & 0, 1, -1, -1, 0, 1, 0, -1, 0, 1, -1, 0, 0, 0, 0,
31346 & 1, 0, -1, -1, 0, 1, 0, -1, 0, 1, -1, 1, 1, 0, 0/
31347* Particle baryonic charges
31348 DATA (IIBAR ( I ), I = 1,210 ) /
31349 & 1, -1, 0, 0, 0, 0, 0, 1, -1, 0, 0, 0, 0, 0, 0,
31350 & 0, 1, -1, 0, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0,
31351 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31352 & 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
31353 & 1, 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31354 & -1, 2, 0, 0, 0, 1, 1, 1, 1, 2, 2, 0, 0, 1, 1,
31355 & 1, 1, 1, 1, 0, 0, 1, 1, -1, -1, -1, -1, -1, 1, 1,
31356 & 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, 0, 0, 0, 0, 0,
31357 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31358 & 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, -1, -1,
31359 & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 1, 1, 1, 1, 1,
31360 & 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31361 & 0, 0, 0, -1, -1, 0, 0, 0, 0, 0, 0, 0, 0, 1, -1,
31362 & 1, 1, 1, -1, -1, -1, 1, 1, -1, -1, 1, -1, 1, 1, 0/
31363* First number of decay channels used for resonances
31364* and decaying particles
31365 DATA K1/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 16, 17,
31366 & 18, 24, 30, 34, 38, 40, 41, 43, 44, 136, 138, 330, 327, 328,
31367 & 2*330, 46, 51, 52, 54, 55, 58,
31368* 50
31369 & 60, 62, 64, 66, 68, 70, 72, 74, 82, 90, 98, 106, 109, 112, 114,
31370 & 123, 140, 141, 143, 145, 146, 150, 157, 164, 168, 174, 180, 187,
31371 & 194, 202, 210, 211, 213, 215, 216, 220, 227, 234, 238, 245, 252,
31372* 85
31373 & 254, 255, 256, 257, 259, 262, 265, 267, 269, 272, 276, 279, 282,
31374 & 286, 290, 293, 299, 331, 335, 339, 340, 341, 343, 344, 345, 346,
31375 & 347, 350, 353, 356, 358, 360, 363, 366, 369, 372, 374, 376, 379,
31376 & 383, 385, 387, 391, 394, 397, 400, 402, 405, 408, 410, 412, 414,
31377 & 417, 420, 425, 430, 431, 432, 433, 434, 448, 452, 457, 458, 459,
31378 & 460, 461, 462, 466, 468, 470, 472, 486, 490, 495, 496, 497, 498,
31379 & 499, 500, 504, 506, 508, 510, 511, 512, 513, 514, 515, 516, 517,
31380 & 518, 519, 522, 523, 524, 525, 526, 527, 528, 529, 530, 531, 534,
31381 & 537, 539, 541, 547, 553, 558, 563, 568, 572, 573, 574, 575, 576,
31382 & 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, 589,
31383 & 590, 596, 602 /
31384* Last number of decay channels used for resonances
31385* and decaying particles
31386 DATA K2/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 15, 16, 17,
31387 & 23, 29, 31, 35, 39, 40, 42, 43, 45, 137, 139, 330, 327, 328,
31388 & 2* 330, 50, 51, 53, 54, 57,
31389* 50
31390 & 59, 61, 63, 65, 67, 69, 71, 73, 81, 89, 97, 105, 108, 111, 113,
31391 & 122, 135, 140, 142, 144, 145, 149, 156, 163, 167, 173, 179, 186,
31392 & 193, 201, 209, 210, 212, 214, 215, 219, 226, 233, 237, 244, 251,
31393* 85
31394 & 253, 254, 255, 256, 258, 261, 264, 266, 268, 271, 275, 278, 281,
31395 & 285, 289, 292, 298, 307, 334, 338, 339, 340, 342, 343, 344, 345,
31396 & 346, 349, 352, 355, 357, 359, 362, 365, 368, 371, 373, 375, 378,
31397 & 382, 384, 386, 390, 393, 396, 399, 401, 404, 407, 409, 411, 413,
31398 & 416, 419, 424, 429, 430, 431, 432, 433, 447, 451, 456, 457, 458,
31399 & 459, 460, 461, 465, 467, 469, 471, 485, 489, 494, 495, 496, 497,
31400 & 498, 499, 503, 505, 507, 509, 510, 511, 512, 513, 514, 515, 516,
31401 & 517, 518, 521, 522, 523, 524, 525, 526, 527, 528, 529, 530, 533,
31402 & 536, 538, 540, 546, 552, 557, 562, 567, 571, 572, 573, 574, 575,
31403 & 576, 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588,
31404 & 589, 595, 601, 602 /
31405
31406 END
31407
31408*$ CREATE DT_BLKD47.FOR
31409*COPY DT_BLKD47
31410*
31411*===blkd47=============================================================*
31412*
31413 BLOCK DATA DT_BLKD47
31414
31415 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31416 SAVE
31417
31418* HADRIN: decay channel information
31419 PARAMETER (IDMAX9=602)
31420 CHARACTER*8 ZKNAME
31421 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
31422
31423* Name of decay channel
31424* Designation N*@ means N*@1(1236)
31425* @1=# means ++, @1 = = means --
31426* Designation P+/0/- means Pi+/Pi0/Pi- , respectively
31427 DATA (ZKNAME(K),K= 1, 85) /
31428 & 'P ','AP ','E- ','E+ ','NUE ',
31429 & 'ANUE ','GAM ','PE-NUE ','APEANU ','EANUNU ',
31430 & 'E-NUAN ','3PI0 ','PI+-0 ','PIMUNU ','PIE-NU ',
31431 & 'MU+NUE ','MU-NUE ','MU+NUE ','PI+PI0 ','PI++- ',
31432 & 'PI+00 ','M+P0NU ','E+P0NU ','MU-NU ','PI-0 ',
31433 & 'PI+-- ','PI-00 ','M-P0NU ','E-P0NU ','PPI- ',
31434 & 'NPI0 ','PD-NUE ','PM-NUE ','APPI+ ','ANPI0 ',
31435 & 'APE+NU ','APM+NU ','PI+PI- ','PI0PI0 ','NPI- ',
31436 & 'PPI0 ','NPI+ ','LAGA ','GAGA ','GAE+E- ',
31437 & 'GAGA ','GAGAP0 ','PI000 ','PI+-0 ','PI+-GA ',
31438 & 'PI+0 ','PI+- ','PI00 ','PI-0 ','PI+-0 ',
31439 & 'PI+- ','PI0GA ','K+PI0 ','K0PI+ ','KOPI0 ',
31440 & 'K+PI- ','K-PI0 ','AK0PI- ','AK0PI0 ','K-PI+ ',
31441 & 'K+PI0 ','K0PI+ ','K0PI0 ','K+PI- ','K-PI0 ',
31442 & 'K0PI- ','AK0PI0 ','K-PI+ ','K+PI0 ','K0PI+ ',
31443 & 'K+89P0 ','K08PI+ ','K+RO77 ','K0RO+7 ','K+OM07 ',
31444 & 'K+E055 ','K0PI0 ','K+PI+ ','K089P0 ','K+8PI- ' /
31445 DATA (ZKNAME(K),K= 86,170) /
31446 & 'K0R077 ','K+R-77 ','K+R-77 ','K0OM07 ','K0E055 ',
31447 & 'K-PI0 ','K0PI- ','K-89P0 ','AK08P- ','K-R077 ',
31448 & 'AK0R-7 ','K-OM07 ','K-E055 ','AK0PI0 ','K-PI+ ',
31449 & 'AK08P0 ','K-8PI+ ','AK0R07 ','AK0OM7 ','AK0E05 ',
31450 & 'LA0PI+ ','SI0PI+ ','SI+PI0 ','LA0PI0 ','SI+PI- ',
31451 & 'SI-PI+ ','LA0PI- ','SI0PI- ','NEUAK0 ','PK- ',
31452 & 'SI+PI- ','SI0PI0 ','SI-PI+ ','LA0ET0 ','S+1PI- ',
31453 & 'S-1PI+ ','SO1PI0 ','NEUAK0 ','PK- ','LA0PI0 ',
31454 & 'LA0OM0 ','LA0RO0 ','SI+RO- ','SI-RO+ ','SI0RO0 ',
31455 & 'LA0ET0 ','SI0ET0 ','SI+PI- ','SI-PI+ ','SI0PI0 ',
31456 & 'K0S ','K0L ','K0S ','K0L ','P PI+ ',
31457 & 'P PI0 ','N PI+ ','P PI- ','N PI0 ','N PI- ',
31458 & 'P PI+ ','N*#PI0 ','N*+PI+ ','PRHO+ ','P PI0 ',
31459 & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ',
31460 & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ',
31461 & 'N*-PI+ ','PRHO- ','NRHO0 ','N PI- ','N*0PI- ',
31462 & 'N*-PI0 ','NRHO- ','PETA0 ','N*#PI- ','N*+PI0 ' /
31463 DATA (ZKNAME(K),K=171,255) /
31464 & 'N*0PI+ ','PRHO0 ','NRHO+ ','NETA0 ','N*+PI- ',
31465 & 'N*0PI0 ','N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ',
31466 & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ',
31467 & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ',
31468 & 'N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ','N PI+ ',
31469 & 'PRHO0 ','NRHO+ ','LAMK+ ','S+ K0 ','S0 K+ ',
31470 & 'PETA0 ','P PI- ','N PI0 ','PRHO- ','NRHO0 ',
31471 & 'LAMK0 ','S0 K0 ','S- K+ ','NETA/ ','APPI- ',
31472 & 'APPI0 ','ANPI- ','APPI+ ','ANPI0 ','ANPI+ ',
31473 & 'APPI- ','AN*=P0 ','AN*-P- ','APRHO- ','APPI0 ',
31474 & 'ANPI- ','AN*=P+ ','AN*-P0 ','AN*0P- ','APRHO0 ',
31475 & 'ANRHO- ','APPI+ ','ANPI0 ','AN*-P+ ','AN*0P0 ',
31476 & 'AN*+P- ','APRHO+ ','ANRHO0 ','ANPI+ ','AN*0P+ ',
31477 & 'AN*+P0 ','ANRHO+ ','APPI0 ','ANPI- ','AN*=P+ ',
31478 & 'AN*-P0 ','AN*0P- ','APRHO0 ','ANRHO- ','APPI+, ',
31479 & 'ANPI0 ','AN*-P+ ','AN*0P0 ','AN*+P- ','APRHO+ ',
31480 & 'ANRHO0 ','PN*014 ','NN*=14 ','PI+0 ','PI+- ' /
31481 DATA (ZKNAME(K),K=256,340) /
31482 & 'PI-0 ','P+0 ','N++ ','P+- ','P00 ',
31483 & 'N+0 ','N+- ','N00 ','P-0 ','N-0 ',
31484 & 'P-- ','PPPI0 ','PNPI+ ','PNPI0 ','PPPI- ',
31485 & 'NNPI+ ','APPPI0 ','APNPI+ ','ANNPI0 ','ANPPI- ',
31486 & 'APNPI0 ','APPPI- ','ANNPI- ','K+PPI0 ','K+NPI+ ',
31487 & 'K0PPI0 ','K-PPI0 ','K-NPI+ ','AKPPI- ','AKNPI0 ',
31488 & 'K+NPI0 ','K+PPI- ','K0PPI0 ','K0NPI+ ','K-NPI0 ',
31489 & 'K-PPI- ','AKNPI- ','PAK0 ','SI+PI0 ','SI0PI+ ',
31490 & 'SI+ETA ','S+1PI0 ','S01PI+ ','NEUK- ','LA0PI- ',
31491 & 'SI-OM0 ','LA0RO- ','SI0RO- ','SI-RO0 ','SI-ET0 ',
31492 & 'SI0PI- ','SI-0 ','BLANC ','BLANC ','BLANC ',
31493 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31494 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31495 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31496 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31497 & 'EPI+- ','EPI00 ','GAPI+- ','GAGA* ','K+- ',
31498 & 'KLKS ','PI+-0 ','EGA ','LPI0 ','LPI ' /
31499 DATA (ZKNAME(K),K=341,425) /
31500 & 'APPI0 ','ANPI- ','ALAGA ','ANPI ','ALPI0 ',
31501 & 'ALPI+ ','LAPI+ ','SI+PI0 ','SI0PI+ ','LAPI0 ',
31502 & 'SI+PI- ','SI-PI+ ','LAPI- ','SI-PI0 ','SI0PI- ',
31503 & 'TE0PI0 ','TE-PI+ ','TE0PI- ','TE-PI0 ','TE0PI ',
31504 & 'TE-PI ','LAK- ','ALPI- ','AS-PI0 ','AS0PI- ',
31505 & 'ALPI0 ','AS+PI- ','AS-PI+ ','ALPI+ ','AS+PI0 ',
31506 & 'AS0PI+ ','AT0PI0 ','AT+PI- ','AT0PI+ ','AT+PI0 ',
31507 & 'AT0PI ','AT+PI ','ALK+ ','K-PI+ ','K-PI+0 ',
31508 & 'K0PI+- ','K0PI0 ','K-PI++ ','AK0PI+ ','K+PI-- ',
31509 & 'K0PI- ','K+PI- ','K+PI-0 ','AKPI-+ ','AK0PI0 ',
31510 & 'ETAPIF ','K++- ','K+AK0 ','ETAPI- ','K--+ ',
31511 & 'K-K0 ','PI00 ','PI+- ','GAGA ','D0PI0 ',
31512 & 'D0GA ','D0PI+ ','D+PI0 ','DFGA ','AD0PI- ',
31513 & 'D-PI0 ','D-GA ','AD0PI0 ','AD0GA ','F+GA ',
31514 & 'F+GA ','F-GA ','F-GA ','PSPI+- ','PSPI00 ',
31515 & 'PSETA ','E+E- ','MUE+- ','PI+-0 ','M+NN ',
31516 & 'E+NN ','RHO+NT ','PI+ANT ','K*+ANT ','M-NN ' /
31517 DATA (ZKNAME(K),K=426,510) /
31518 & 'E-NN ','RHO-NT ','PI-NT ','K*-NT ','NUET ',
31519 & 'ANUET ','NUEM ','ANUEM ','SI+ETA ','SI+ET* ',
31520 & 'PAK0 ','TET0K+ ','SI*+ET ','N*+AK0 ','N*++K- ',
31521 & 'LAMRO+ ','SI0RO+ ','SI+RO0 ','SI+OME ','PAK*0 ',
31522 & 'N*+AK* ','N*++K* ','SI+AK0 ','TET0PI ','SI+AK* ',
31523 & 'TET0RO ','SI0AK* ','SI+K*- ','TET0OM ','TET-RO ',
31524 & 'SI*0AK ','C0+PI+ ','C0+PI0 ','C0+PI- ','A+GAM ',
31525 & 'A0GAM ','TET0AK ','TET0K* ','OM-RO+ ','OM-PI+ ',
31526 & 'C1++AK ','A+PI+ ','C0+AK0 ','A0PI+ ','A+AK0 ',
31527 & 'T0PI+ ','ASI-ET ','ASI-E* ','APK0 ','ATET0K ',
31528 & 'ASI*-E ','AN*-K0 ','AN*--K ','ALAMRO ','ASI0RO ',
31529 & 'ASI-RO ','ASI-OM ','APK*0 ','AN*-K* ','AN*--K ',
31530 & 'ASI-K0 ','ATETPI ','ASI-K* ','ATETRO ','ASI0K* ',
31531 & 'ASI-K* ','ATE0OM ','ATE+RO ','ASI*0K ','AC-PI- ',
31532 & 'AC-PI0 ','AC-PI+ ','AA-GAM ','AA0GAM ','ATET0K ',
31533 & 'ATE0K* ','AOM+RO ','AOM+PI ','AC1--K ','AA-PI- ',
31534 & 'AC0-K0 ','AA0PI- ','AA-K0 ','AT0PI- ','C1++GA ' /
31535 DATA (ZKNAME(K),K=511,540) /
31536 & 'C1++GA ','C10GAM ','S+GAM ','S0GAM ','T0GAM ',
31537 & 'XU++GA ','XD+GAM ','XS+GAM ','A+AKPI ','T02PI+ ',
31538 & 'C1++2K ','AC1--G ','AC1-GA ','AC10GA ','AS-GAM ',
31539 & 'AS0GAM ','AT0GAM ','AXU--G ','AXD-GA ','AXS-GA ',
31540 & 'AA-KPI ','AT02PI ','AC1--K ','RH-PI+ ','RH+PI- ',
31541 & 'RH3PI0 ','RH0PI+ ','RH+PI0 ','RH0PI- ','RH-PI0 ' /
31542 DATA (ZKNAME(I),I=541,602)/
31543 & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHO0','ANRHO-','ANETA ',
31544 & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0','RH0PI+','RH+PI0',
31545 & '3PI+00','3PI-++','F0PI+ ','RH+PI-','RH0PI0','3PI000','3PI0+-',
31546 & 'F0PI0 ','RH0PI-','RH-PI0','3PI-00','3PI--+','F0PI- ','PI0PI0',
31547 & 'PI+PI-','K+K- ','K0AK0 ','L01600','AL0160','K*+146','K*-146',
31548 & 'K*0146','AK0146','S+1660','S01660','S-1660','AS-166','AS0166',
31549 & 'AS+166','X01690','X-1690','AX0169','AX+169','OM-225','AOM+22',
31550 & 'N*PPI0','N*NPI+','N*P2P0','N*PP+-','N*D+P0','N*D0P+','N*NPI0',
31551 & 'N*PPI-','N*N2P0','N*NP+-','N*D+P-','N*D0P0','BLANK '/
31552* Weight of decay channel
31553 DATA (WT(K),K= 1, 85) /
31554 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31555 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31556 & .1000D+01, .2100D+00, .1200D+00, .2700D+00, .4000D+00,
31557 & .1000D+01, .1000D+01, .6400D+00, .2100D+00, .6000D-01,
31558 & .2000D-01, .3000D-01, .4000D-01, .6400D+00, .2100D+00,
31559 & .6000D-01, .2000D-01, .3000D-01, .4000D-01, .6400D+00,
31560 & .3600D+00, .0000D+00, .0000D+00, .6400D+00, .3600D+00,
31561 & .0000D+00, .0000D+00, .6900D+00, .3100D+00, .1000D+01,
31562 & .5200D+00, .4800D+00, .1000D+01, .9900D+00, .1000D-01,
31563 & .3800D+00, .3000D-01, .3000D+00, .2400D+00, .5000D-01,
31564 & .1000D+01, .1000D+01, .0000D+00, .1000D+01, .9000D+00,
31565 & .1000D-01, .9000D-01, .3300D+00, .6700D+00, .3300D+00,
31566 & .6700D+00, .3300D+00, .6700D+00, .3300D+00, .6700D+00,
31567 & .3300D+00, .6700D+00, .3300D+00, .6700D+00, .3300D+00,
31568 & .6700D+00, .3300D+00, .6700D+00, .1900D+00, .3800D+00,
31569 & .9000D-01, .2000D+00, .3000D-01, .4000D-01, .5000D-01,
31570 & .2000D-01, .1900D+00, .3800D+00, .9000D-01, .2000D+00 /
31571 DATA (WT(K),K= 86,170) /
31572 & .3000D-01, .4000D-01, .5000D-01, .2000D-01, .1900D+00,
31573 & .3800D+00, .9000D-01, .2000D+00, .3000D-01, .4000D-01,
31574 & .5000D-01, .2000D-01, .1900D+00, .3800D+00, .9000D-01,
31575 & .2000D+00, .3000D-01, .4000D-01, .5000D-01, .2000D-01,
31576 & .8800D+00, .6000D-01, .6000D-01, .8800D+00, .6000D-01,
31577 & .6000D-01, .8800D+00, .1200D+00, .1900D+00, .1900D+00,
31578 & .1600D+00, .1600D+00, .1700D+00, .3000D-01, .3000D-01,
31579 & .3000D-01, .4000D-01, .1000D+00, .1000D+00, .2000D+00,
31580 & .1200D+00, .1000D+00, .4000D-01, .4000D-01, .5000D-01,
31581 & .7500D-01, .7500D-01, .3000D-01, .3000D-01, .4000D-01,
31582 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01,
31583 & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31584 & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31585 & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31586 & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31587 & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31588 & .2700D+00, .3000D+00, .4000D+00, .2000D+00, .1250D+00 /
31589 DATA (WT(K),K=171,255) /
31590 & .7500D-01, .7500D-01, .1250D+00, .4000D+00, .7500D-01,
31591 & .1250D+00, .2000D+00, .1250D+00, .7500D-01, .1800D+00,
31592 & .3700D+00, .1300D+00, .8000D-01, .4000D-01, .7000D-01,
31593 & .1300D+00, .3700D+00, .1800D+00, .4000D-01, .8000D-01,
31594 & .1300D+00, .1300D+00, .7000D-01, .7000D-01, .1300D+00,
31595 & .2300D+00, .4700D+00, .5000D-01, .2000D-01, .1000D-01,
31596 & .2000D-01, .1300D+00, .7000D-01, .4700D+00, .2300D+00,
31597 & .5000D-01, .1000D-01, .2000D-01, .2000D-01, .1000D+01,
31598 & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31599 & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31600 & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31601 & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31602 & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31603 & .2700D+00, .3000D+00, .1800D+00, .3700D+00, .1300D+00,
31604 & .8000D-01, .4000D-01, .7000D-01, .1300D+00, .3700D+00,
31605 & .1800D+00, .4000D-01, .8000D-01, .1300D+00, .1300D+00,
31606 & .7000D-01, .5000D+00, .5000D+00, .1000D+01, .1000D+01 /
31607 DATA (WT(K),K=256,340) /
31608 & .1000D+01, .8000D+00, .2000D+00, .6000D+00, .3000D+00,
31609 & .1000D+00, .6000D+00, .3000D+00, .1000D+00, .8000D+00,
31610 & .2000D+00, .3300D+00, .6700D+00, .6600D+00, .1700D+00,
31611 & .1700D+00, .3200D+00, .1700D+00, .3200D+00, .1900D+00,
31612 & .3300D+00, .3300D+00, .3400D+00, .3000D+00, .5000D-01,
31613 & .6500D+00, .3800D+00, .1200D+00, .3800D+00, .1200D+00,
31614 & .3800D+00, .1200D+00, .3800D+00, .1200D+00, .3000D+00,
31615 & .5000D-01, .6500D+00, .3800D+00, .2500D+00, .2500D+00,
31616 & .2000D-01, .5000D-01, .5000D-01, .2000D+00, .2000D+00,
31617 & .1200D+00, .1000D+00, .7000D-01, .7000D-01, .1400D+00,
31618 & .5000D-01, .5000D-01, .1000D+01, .1000D+01, .1000D+01,
31619 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31620 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31621 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31622 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31623 & .4800D+00, .2400D+00, .2600D+00, .2000D-01, .4700D+00,
31624 & .3500D+00, .1500D+00, .3000D-01, .1000D+01, .1000D+01 /
31625 DATA (WT(K),K=341,425) /
31626 & .5200D+00, .4800D+00, .1000D+01, .1000D+01, .1000D+01,
31627 & .1000D+01, .9000D+00, .5000D-01, .5000D-01, .9000D+00,
31628 & .5000D-01, .5000D-01, .9000D+00, .5000D-01, .5000D-01,
31629 & .3300D+00, .6700D+00, .6700D+00, .3300D+00, .2500D+00,
31630 & .2500D+00, .5000D+00, .9000D+00, .5000D-01, .5000D-01,
31631 & .9000D+00, .5000D-01, .5000D-01, .9000D+00, .5000D-01,
31632 & .5000D-01, .3300D+00, .6700D+00, .6700D+00, .3300D+00,
31633 & .2500D+00, .2500D+00, .5000D+00, .1000D+00, .5000D+00,
31634 & .1600D+00, .2400D+00, .7000D+00, .3000D+00, .7000D+00,
31635 & .3000D+00, .1000D+00, .5000D+00, .1600D+00, .2400D+00,
31636 & .3000D+00, .4000D+00, .3000D+00, .3000D+00, .4000D+00,
31637 & .3000D+00, .4900D+00, .4900D+00, .2000D-01, .5500D+00,
31638 & .4500D+00, .6800D+00, .3000D+00, .2000D-01, .6800D+00,
31639 & .3000D+00, .2000D-01, .5500D+00, .4500D+00, .9000D+00,
31640 & .1000D+00, .9000D+00, .1000D+00, .6000D+00, .3000D+00,
31641 & .1000D+00, .1000D+00, .1000D+00, .8000D+00, .2800D+00,
31642 & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .2800D+00 /
31643 DATA (WT(K),K=426,510) /
31644 & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .1000D+01,
31645 & .1000D+01, .1000D+01, .1000D+01, .2000D-01, .3000D-01,
31646 & .7000D-01, .2000D-01, .2000D-01, .4000D-01, .1300D+00,
31647 & .7000D-01, .6000D-01, .6000D-01, .2000D+00, .1400D+00,
31648 & .4000D-01, .1000D+00, .2500D+00, .3000D-01, .3000D+00,
31649 & .4200D+00, .2200D+00, .3500D+00, .1900D+00, .1600D+00,
31650 & .8000D-01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31651 & .1000D+01, .3700D+00, .2000D+00, .3600D+00, .7000D-01,
31652 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00,
31653 & .5000D+00, .2000D-01, .3000D-01, .7000D-01, .2000D-01,
31654 & .2000D-01, .4000D-01, .1300D+00, .7000D-01, .6000D-01,
31655 & .6000D-01, .2000D+00, .1400D+00, .4000D-01, .1000D+00,
31656 & .2500D+00, .3000D-01, .3000D+00, .4200D+00, .2200D+00,
31657 & .3500D+00, .1900D+00, .1600D+00, .8000D-01, .1000D+01,
31658 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .3700D+00,
31659 & .2000D+00, .3600D+00, .7000D-01, .5000D+00, .5000D+00,
31660 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01 /
31661 DATA (WT(K),K=511,540) /
31662 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31663 & .1000D+01, .1000D+01, .1000D+01, .3000D+00, .3000D+00,
31664 & .4000D+00, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31665 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31666 & .3000D+00, .3000D+00, .4000D+00, .3300D+00, .3300D+00,
31667 & .3400D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00 /
31668C
31669 DATA (WT(I),I=541,602) / .0D+00, .3334D+00, .2083D+00, 2*.125D+00,
31670 & .2083D+00, .0D+00, .125D+00, .2083D+00, .3334D+00, .2083D+00,
31671 & .125D+00, 0.2D+00, 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00,
31672 & 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, 0.2D+00, 0.3D+00,
31673 & 0.3D+00, 0.0D+00, 0.31D+00, 0.62D+00, 0.035D+00, 0.035D+00,
31674 & 18*1.D+00, 0.5D+00, 0.16D+00, 2*0.12D+00, 2*0.05D+00, 0.5D+00,
31675 & 0.16D+00, 2*0.12D+00, 2*0.05D+00, 1.D+00 /
31676* Particle numbers in decay channel
31677 DATA (NZK(K,1),K= 1,170) /
31678 & 1, 2, 3, 4, 5, 6, 7, 1, 2, 4,
31679 & 3, 23, 13, 13, 13, 10, 11, 10, 13, 13,
31680 & 13, 10, 4, 11, 14, 14, 14, 11, 3, 1,
31681 & 8, 1, 1, 2, 9, 2, 2, 13, 23, 8,
31682 & 1, 8, 17, 7, 7, 7, 23, 23, 13, 13,
31683 & 13, 13, 23, 14, 13, 13, 23, 15, 24, 24,
31684 & 15, 16, 25, 25, 16, 15, 24, 24, 15, 16,
31685 & 24, 25, 16, 15, 24, 36, 37, 15, 24, 15,
31686 & 15, 24, 15, 37, 36, 24, 15, 24, 24, 16,
31687 & 24, 38, 39, 16, 25, 16, 16, 25, 16, 39,
31688 & 38, 25, 16, 25, 25, 17, 22, 21, 17, 21,
31689 & 20, 17, 22, 8, 1, 21, 22, 20, 17, 48,
31690 & 50, 49, 8, 1, 17, 17, 17, 21, 20, 22,
31691 & 17, 22, 21, 20, 22, 19, 12, 19, 12, 1,
31692 & 1, 8, 1, 8, 8, 1, 53, 54, 1, 1,
31693 & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55,
31694 & 56, 1, 8, 8, 55, 56, 8, 1, 53, 54 /
31695 DATA (NZK(K,1),K=171,340) /
31696 & 55, 1, 8, 8, 54, 55, 56, 1, 8, 1,
31697 & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55,
31698 & 56, 1, 8, 1, 8, 1, 8, 17, 21, 22,
31699 & 1, 1, 8, 1, 8, 17, 22, 20, 8, 2,
31700 & 2, 9, 2, 9, 9, 2, 67, 68, 2, 2,
31701 & 9, 67, 68, 69, 2, 9, 2, 9, 68, 69,
31702 & 70, 2, 9, 9, 69, 70, 9, 2, 9, 67,
31703 & 68, 69, 2, 9, 2, 9, 68, 69, 70, 2,
31704 & 9, 1, 8, 13, 13, 14, 1, 8, 1, 1,
31705 & 8, 8, 8, 1, 8, 1, 1, 1, 1, 1,
31706 & 8, 2, 2, 9, 9, 2, 2, 9, 15, 15,
31707 & 24, 16, 16, 25, 25, 15, 15, 24, 24, 16,
31708 & 16, 25, 1, 21, 22, 21, 48, 49, 8, 17,
31709 & 20, 17, 22, 20, 20, 22, 20, 0, 0, 0,
31710 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31711 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31712 & 31, 31, 13, 7, 15, 12, 13, 31, 17, 17 /
31713 DATA (NZK(K,1),K=341,510) /
31714 & 2, 9, 18, 9, 18, 18, 17, 21, 22, 17,
31715 & 21, 20, 17, 20, 22, 97, 98, 97, 98, 97,
31716 & 98, 17, 18, 99, 100, 18, 101, 99, 18, 101,
31717 & 100, 102, 103, 102, 103, 102, 103, 18, 16, 16,
31718 & 24, 24, 16, 25, 15, 24, 15, 15, 25, 25,
31719 & 31, 15, 15, 31, 16, 16, 23, 13, 7, 116,
31720 & 116, 116, 117, 117, 119, 118, 118, 119, 119, 120,
31721 & 120, 121, 121, 130, 130, 130, 4, 10, 13, 10,
31722 & 4, 32, 13, 36, 11, 3, 34, 14, 38, 133,
31723 & 134, 135, 136, 21, 21, 1, 97, 104, 54, 53,
31724 & 17, 22, 21, 21, 1, 54, 53, 21, 97, 21,
31725 & 97, 22, 21, 97, 98, 105, 137, 137, 137, 138,
31726 & 139, 97, 97, 109, 109, 140, 138, 137, 139, 138,
31727 & 145, 99, 99, 2, 102, 110, 68, 67, 18, 100,
31728 & 99, 99, 2, 68, 67, 99, 102, 99, 102, 100,
31729 & 99, 102, 103, 111, 149, 149, 149, 150, 151, 113,
31730 & 113, 115, 115, 152, 150, 149, 151, 150, 157, 140 /
31731 DATA (NZK(K,1),K=511,540) /
31732 & 141, 142, 143, 144, 145, 146, 147, 148, 138, 145,
31733 & 140, 152, 153, 154, 155, 156, 157, 158, 159, 160,
31734 & 150, 157, 152, 34, 32, 33, 33, 32, 33, 34 /
31735 DATA (NZK(I,1),I=541,602) / 2, 67, 68, 69, 2, 9, 9, 68, 69,
31736 & 70, 2, 9, 33, 32, 13, 14, 189, 32, 34, 23, 23, 189, 33, 34, 14,
31737 & 14, 189, 23, 13, 15, 24, 36, 38, 37, 39, 194, 195, 196, 197,
31738 & 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 1, 8, 1, 1, 54,
31739 & 55, 8, 1, 8, 8, 54, 55, 210/
31740 DATA (NZK(K,2),K= 1,170) /
31741 & 0, 0, 0, 0, 0, 0, 0, 3, 4, 6,
31742 & 5, 23, 14, 11, 3, 5, 5, 5, 23, 13,
31743 & 23, 23, 23, 5, 23, 13, 23, 23, 23, 14,
31744 & 23, 3, 11, 13, 23, 4, 10, 14, 23, 14,
31745 & 23, 13, 7, 7, 4, 7, 7, 23, 14, 14,
31746 & 23, 14, 23, 23, 14, 14, 7, 23, 13, 23,
31747 & 14, 23, 14, 23, 13, 23, 13, 23, 14, 23,
31748 & 14, 23, 13, 23, 13, 23, 13, 33, 32, 35,
31749 & 31, 23, 14, 23, 14, 33, 34, 35, 31, 23,
31750 & 14, 23, 14, 33, 34, 35, 31, 23, 13, 23,
31751 & 13, 33, 32, 35, 31, 13, 13, 23, 23, 14,
31752 & 13, 14, 14, 25, 16, 14, 23, 13, 31, 14,
31753 & 13, 23, 25, 16, 23, 35, 33, 34, 32, 33,
31754 & 31, 31, 14, 13, 23, 0, 0, 0, 0, 13,
31755 & 23, 13, 14, 23, 14, 13, 23, 13, 78, 23,
31756 & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23,
31757 & 13, 80, 79, 14, 14, 23, 80, 31, 14, 23 /
31758 DATA (NZK(K,2),K=171,340) /
31759 & 13, 79, 78, 31, 14, 23, 13, 80, 79, 23,
31760 & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23,
31761 & 13, 80, 79, 23, 13, 33, 32, 15, 24, 15,
31762 & 31, 14, 23, 34, 33, 24, 24, 15, 31, 14,
31763 & 23, 14, 13, 23, 13, 14, 23, 14, 80, 23,
31764 & 14, 13, 23, 14, 79, 80, 13, 23, 13, 23,
31765 & 14, 78, 79, 13, 13, 23, 78, 23, 14, 13,
31766 & 23, 14, 79, 80, 13, 23, 13, 23, 14, 78,
31767 & 79, 62, 61, 23, 14, 23, 13, 13, 13, 23,
31768 & 13, 13, 23, 14, 14, 14, 1, 8, 8, 1,
31769 & 8, 1, 8, 8, 1, 8, 1, 8, 1, 8,
31770 & 1, 1, 8, 1, 8, 8, 1, 1, 8, 8,
31771 & 1, 8, 25, 23, 13, 31, 23, 13, 16, 14,
31772 & 35, 34, 34, 33, 31, 14, 23, 0, 0, 0,
31773 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31774 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31775 & 13, 23, 14, 7, 16, 19, 14, 7, 23, 14 /
31776 DATA (NZK(K,2),K=341,510) /
31777 & 23, 14, 7, 13, 23, 13, 13, 23, 13, 23,
31778 & 14, 13, 14, 23, 14, 23, 13, 14, 23, 14,
31779 & 23, 16, 14, 23, 14, 23, 14, 13, 13, 23,
31780 & 13, 23, 14, 13, 23, 13, 23, 15, 13, 13,
31781 & 13, 23, 13, 13, 14, 14, 14, 14, 14, 23,
31782 & 13, 16, 25, 14, 15, 24, 23, 14, 7, 23,
31783 & 7, 13, 23, 7, 14, 23, 7, 23, 7, 7,
31784 & 7, 7, 7, 13, 23, 31, 3, 11, 14, 135,
31785 & 5, 134, 134, 134, 136, 6, 133, 133, 133, 0,
31786 & 0, 0, 0, 31, 95, 25, 15, 31, 95, 16,
31787 & 32, 32, 33, 35, 39, 39, 38, 25, 13, 39,
31788 & 32, 39, 38, 35, 32, 39, 13, 23, 14, 7,
31789 & 7, 25, 37, 32, 13, 25, 13, 25, 13, 25,
31790 & 13, 31, 95, 24, 16, 31, 24, 15, 34, 34,
31791 & 33, 35, 37, 37, 36, 24, 14, 37, 34, 37,
31792 & 36, 35, 34, 37, 14, 23, 13, 7, 7, 24,
31793 & 39, 34, 14, 24, 14, 24, 14, 24, 14, 7 /
31794 DATA (NZK(K,2),K=511,540) /
31795 & 7, 7, 7, 7, 7, 7, 7, 7, 25, 13,
31796 & 25, 7, 7, 7, 7, 7, 7, 7, 7, 7,
31797 & 24, 14, 24, 13, 14, 23, 13, 23, 14, 23 /
31798 DATA (NZK(I,2),I=541,602) / 31, 13, 23, 14, 79, 80, 31, 13, 23,
31799 & 14, 78, 79, 13, 23, 23, 13, 13, 14, 13, 23, 13, 23, 14, 23, 23,
31800 & 14, 14, 23, 14, 16, 25,
31801 & 4*23, 14*0, 23, 13, 23, 13, 23, 13, 23, 14,
31802 & 23, 13, 14, 23, 0 /
31803 DATA (NZK(K,3),K= 1,170) /
31804 & 0, 0, 0, 0, 0, 0, 0, 5, 6, 5,
31805 & 6, 23, 23, 5, 5, 0, 0, 0, 0, 14,
31806 & 23, 5, 5, 0, 0, 14, 23, 5, 5, 0,
31807 & 0, 5, 5, 0, 0, 5, 5, 0, 0, 0,
31808 & 0, 0, 0, 0, 3, 0, 7, 23, 23, 7,
31809 & 0, 0, 0, 0, 23, 0, 0, 0, 0, 0,
31810 & 110*0 /
31811 DATA (NZK(K,3),K=171,340) /
31812 & 80*0,
31813 & 0, 0, 0, 0, 0, 0, 23, 13, 14, 23,
31814 & 23, 14, 23, 23, 23, 14, 23, 13, 23, 14,
31815 & 13, 23, 13, 23, 14, 23, 14, 14, 23, 13,
31816 & 13, 23, 13, 14, 23, 23, 14, 23, 13, 23,
31817 & 14, 14, 0, 0, 0, 0, 0, 0, 0, 0,
31818 & 30*0,
31819 & 14, 23, 7, 0, 0, 0, 23, 0, 0, 0 /
31820 DATA (NZK(K,3),K=341,510) /
31821 & 30*0,
31822 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 23,
31823 & 14, 0, 13, 0, 14, 0, 0, 23, 13, 0,
31824 & 0, 15, 0, 0, 16, 0, 0, 0, 0, 0,
31825 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31826 & 0, 0, 0, 14, 23, 0, 0, 0, 23, 134,
31827 & 134, 0, 0, 0, 133, 133, 0, 0, 0, 0,
31828 & 80*0 /
31829 DATA (NZK(K,3),K=511,540) /
31830 & 0, 0, 0, 0, 0, 0, 0, 0, 13, 13,
31831 & 25, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31832 & 14, 14, 24, 0, 0, 0, 0, 0, 0, 0 /
31833 DATA (NZK(I,3),I=541,602) / 12*0, 2*0, 23, 13, 0, 2*0, 23, 14, 0,
31834 & 2*0, 23, 13, 0, 4*0, 18*0, 2*0, 23, 14, 2*0, 2*0, 23, 14, 2*0, 0/
31835
31836 END
31837
31838*$ CREATE DT_BDEVAP.FOR
31839*COPY DT_BDEVAP
31840*
31841*=== bdevap ===========================================================*
31842*
31843 BLOCK DATA DT_BDEVAP
31844
31845C INCLUDE '(DBLPRC)'
31846* DBLPRC.ADD
31847 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31848 SAVE
31849* (original name: GLOBAL)
31850 PARAMETER ( KALGNM = 2 )
31851 PARAMETER ( ANGLGB = 5.0D-16 )
31852 PARAMETER ( ANGLSQ = 2.5D-31 )
31853 PARAMETER ( AXCSSV = 0.2D+16 )
31854 PARAMETER ( ANDRFL = 1.0D-38 )
31855 PARAMETER ( AVRFLW = 1.0D+38 )
31856 PARAMETER ( AINFNT = 1.0D+30 )
31857 PARAMETER ( AZRZRZ = 1.0D-30 )
31858 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
31859 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
31860 PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
31861 PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
31862 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
31863 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
31864 PARAMETER ( CSNNRM = 2.0D-15 )
31865 PARAMETER ( DMXTRN = 1.0D+08 )
31866 PARAMETER ( ZERZER = 0.D+00 )
31867 PARAMETER ( ONEONE = 1.D+00 )
31868 PARAMETER ( TWOTWO = 2.D+00 )
31869 PARAMETER ( THRTHR = 3.D+00 )
31870 PARAMETER ( FOUFOU = 4.D+00 )
31871 PARAMETER ( FIVFIV = 5.D+00 )
31872 PARAMETER ( SIXSIX = 6.D+00 )
31873 PARAMETER ( SEVSEV = 7.D+00 )
31874 PARAMETER ( EIGEIG = 8.D+00 )
31875 PARAMETER ( ANINEN = 9.D+00 )
31876 PARAMETER ( TENTEN = 10.D+00 )
31877 PARAMETER ( HLFHLF = 0.5D+00 )
31878 PARAMETER ( ONETHI = ONEONE / THRTHR )
31879 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
31880 PARAMETER ( ONEFOU = ONEONE / FOUFOU )
31881 PARAMETER ( THRTWO = THRTHR / TWOTWO )
31882 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
31883 PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
31884 PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
31885 PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
31886 PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
31887 PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
31888 PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
31889 PARAMETER ( EULERO = 0.577215664901532860606512 D+00 )
31890 PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 )
31891 PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 )
31892 PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 )
31893 PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
31894 PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
31895 PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
31896 PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
31897 PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
31898 PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
31899 PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
31900 PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
31901 PARAMETER ( CLIGHT = 2.99792458 D+10 )
31902 PARAMETER ( AVOGAD = 6.0221367 D+23 )
31903 PARAMETER ( BOLTZM = 1.380658 D-23 )
31904 PARAMETER ( AMELGR = 9.1093897 D-28 )
31905 PARAMETER ( PLCKBR = 1.05457266 D-27 )
31906 PARAMETER ( ELCCGS = 4.8032068 D-10 )
31907 PARAMETER ( ELCMKS = 1.60217733 D-19 )
31908 PARAMETER ( AMUGRM = 1.6605402 D-24 )
31909 PARAMETER ( AMMUMU = 0.113428913 D+00 )
31910 PARAMETER ( AMPRMU = 1.007276470 D+00 )
31911 PARAMETER ( AMNEMU = 1.008664904 D+00 )
31912 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
31913 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
31914 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
31915 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
31916 PARAMETER ( PLABRC = 0.197327053 D+00 )
31917 PARAMETER ( AMELCT = 0.51099906 D-03 )
31918 PARAMETER ( AMUGEV = 0.93149432 D+00 )
31919 PARAMETER ( AMMUON = 0.105658389 D+00 )
31920 PARAMETER ( AMPRTN = 0.93827231 D+00 )
31921 PARAMETER ( AMNTRN = 0.93956563 D+00 )
31922 PARAMETER ( AMDEUT = 1.87561339 D+00 )
31923 PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
31924 & * 1.D-09 )
31925 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
31926 PARAMETER ( BLTZMN = 8.617385 D-14 )
31927 PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
31928 PARAMETER ( GFOHB3 = 1.16639 D-05 )
31929 PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
31930 PARAMETER ( SIN2TW = 0.2319 D+00 )
31931 PARAMETER ( GEVMEV = 1.0 D+03 )
31932 PARAMETER ( EMVGEV = 1.0 D-03 )
31933 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
31934 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
31935 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
31936 LOGICAL LGBIAS, LGBANA
31937 COMMON /FKGLOB/ LGBIAS, LGBANA
31938C INCLUDE '(DIMPAR)'
31939* DIMPAR.ADD
31940 PARAMETER ( MXXRGN = 5000 )
31941 PARAMETER ( MXXMDF = 82 )
31942 PARAMETER ( MXXMDE = 54 )
31943 PARAMETER ( MFSTCK = 1000 )
31944 PARAMETER ( MESTCK = 100 )
31945 PARAMETER ( NELEMX = 80 )
31946 PARAMETER ( MPDPDX = 8 )
31947 PARAMETER ( ICOMAX = 180 )
31948 PARAMETER ( NSTBIS = 304 )
31949 PARAMETER ( IDMAXP = 220 )
31950 PARAMETER ( IDMXDC = 640 )
31951 PARAMETER ( MKBMX1 = 1 )
31952 PARAMETER ( MKBMX2 = 1 )
31953C INCLUDE '(IOUNIT)'
31954* IOUNIT.ADD
31955 PARAMETER ( LUNIN = 5 )
31956 PARAMETER ( LUNOUT = 6 )
31957**sr 19.5. set error output-unit from 15 to 6
31958 PARAMETER ( LUNERR = 6 )
31959 PARAMETER ( LUNBER = 14 )
31960 PARAMETER ( LUNECH = 8 )
31961 PARAMETER ( LUNFLU = 13 )
31962 PARAMETER ( LUNGEO = 16 )
31963 PARAMETER ( LUNPMF = 12 )
31964 PARAMETER ( LUNRAN = 2 )
31965 PARAMETER ( LUNXSC = 9 )
31966 PARAMETER ( LUNDET = 17 )
31967 PARAMETER ( LUNRAY = 10 )
31968 PARAMETER ( LUNRDB = 1 )
31969 PARAMETER ( LUNPGO = 7 )
31970 PARAMETER ( LUNPGS = 4 )
31971 PARAMETER ( LUNSCR = 3 )
31972*
31973*----------------------------------------------------------------------*
31974* *
31975* Block Data for the EVAPoration routines: *
31976* *
31977* Created on 20 may 1990 by Alfredo Ferrari & Paola Sala *
31978* Infn - Milan *
31979* *
31980* Modified from the original version of J.M.Zazula *
31981* and, for cookcm, from a LAHET block data kindly provided by *
31982* R.E.Prael-LANL *
31983* *
31984* Last change on 20-feb-95 by Alfredo Ferrari *
31985* *
31986* *
31987*----------------------------------------------------------------------*
31988*
31989* (original name: COOKCM)
31990 PARAMETER ( ASMTOG = SIXSIX / PIPIPI**2 )
31991 LOGICAL LDEFOZ, LDEFON
31992 PARAMETER ( INCOOK = 150, IZCOOK = 98 )
31993 COMMON /FKCOOK/ ALPIGN, BETIGN, GAMIGN, POWIGN,
31994 & SZCOOK (IZCOOK), SNCOOK (INCOOK), PZCOOK (IZCOOK),
31995 & PNCOOK (INCOOK), LDEFOZ (IZCOOK), LDEFON (INCOOK)
31996* (original name: EVA0)
31997 COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
31998 * FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
31999 * CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
32000 * T (4,7), RMASS (297), ALPH (297), BET (297),
32001 * APRIME (250), IA (6), IZ (6)
32002* (original name: HETTP)
32003 COMMON /FKHETP/ NHSTP,NBERTP,IOSUB,INSRS
32004* (original name: HETC7)
32005 COMMON /FKHET7/ COSKS,SINKS, COSTH,SINTH, COSPHI,SINPHI
32006* (original name: INPFLG)
32007 COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
32008*
32009 DATA B0 / 8.D+00 /, Y0 / 1.5D+00 /
32010 DATA IANG / 1 /, IFISS / 1 /, IB0 / 2 /, IGEOM / 0 /
32011 DATA ISTRAG /0/, KEYDK /0/
32012 DATA NBERTP /LUNBER/
32013 DATA COSTH /ONEONE/, SINTH /ZERZER/, COSPHI /ONEONE/,
32014 & SINPHI/ZERZER/
32015* /cookcm/
32016 DATA ( PZCOOK(I),I = 1, IZCOOK ) /
32017 & 0.000D+00, 5.440D+00, 0.000D+00, 2.760D+00, 0.000D+00, 3.340D+00,
32018 & 0.000D+00, 2.700D+00, 0.000D+00, 2.500D+00, 0.000D+00, 2.460D+00,
32019 & 0.000D+00, 2.090D+00, 0.000D+00, 1.620D+00, 0.000D+00, 1.620D+00,
32020 & 0.000D+00, 1.830D+00, 0.000D+00, 1.730D+00, 0.000D+00, 1.350D+00,
32021 & 0.000D+00, 1.540D+00, 0.000D+00, 1.280D+00, 2.600D-01, 8.800D-01,
32022 & 1.900D-01, 1.350D+00,-5.000D-02, 1.520D+00,-9.000D-02, 1.170D+00,
32023 & 4.000D-02, 1.240D+00, 2.900D-01, 1.090D+00, 2.600D-01, 1.170D+00,
32024 & 2.300D-01, 1.150D+00,-8.000D-02, 1.350D+00, 3.400D-01, 1.050D+00,
32025 & 2.800D-01, 1.270D+00, 0.000D+00, 1.050D+00, 0.000D+00, 1.000D+00,
32026 & 9.000D-02, 1.200D+00, 2.000D-01, 1.400D+00, 9.300D-01, 1.000D+00,
32027 &-2.000D-01, 1.190D+00, 9.000D-02, 9.700D-01, 0.000D+00, 9.200D-01,
32028 & 1.100D-01, 6.800D-01, 5.000D-02, 6.800D-01,-2.200D-01, 7.900D-01,
32029 & 9.000D-02, 6.900D-01, 1.000D-02, 7.200D-01, 0.000D+00, 4.000D-01,
32030 & 1.600D-01, 7.300D-01, 0.000D+00, 4.600D-01, 1.700D-01, 8.900D-01,
32031 & 0.000D+00, 7.900D-01, 0.000D+00, 8.900D-01, 0.000D+00, 8.100D-01,
32032 &-6.000D-02, 6.900D-01,-2.000D-01, 7.100D-01,-1.200D-01, 7.200D-01,
32033 & 0.000D+00, 7.700D-01/
32034 DATA ( PNCOOK(I),I = 1, 90 ) /
32035 & 0.000D+00, 5.980D+00, 0.000D+00, 2.770D+00, 0.000D+00, 3.160D+00,
32036 & 0.000D+00, 3.010D+00, 0.000D+00, 2.500D+00, 0.000D+00, 2.670D+00,
32037 & 0.000D+00, 1.800D+00, 0.000D+00, 1.670D+00, 0.000D+00, 1.860D+00,
32038 & 0.000D+00, 2.040D+00, 0.000D+00, 1.640D+00, 0.000D+00, 1.440D+00,
32039 & 0.000D+00, 1.540D+00, 0.000D+00, 1.300D+00, 0.000D+00, 1.270D+00,
32040 & 0.000D+00, 1.290D+00, 8.000D-02, 1.410D+00,-8.000D-02, 1.500D+00,
32041 &-5.000D-02, 2.240D+00,-4.700D-01, 1.430D+00,-1.500D-01, 1.440D+00,
32042 & 6.000D-02, 1.560D+00, 2.500D-01, 1.570D+00,-1.600D-01, 1.460D+00,
32043 & 0.000D+00, 9.300D-01, 1.000D-02, 6.200D-01,-5.000D-01, 1.420D+00,
32044 & 1.300D-01, 1.520D+00,-6.500D-01, 8.000D-01,-8.000D-02, 1.290D+00,
32045 &-4.700D-01, 1.250D+00,-4.400D-01, 9.700D-01, 8.000D-02, 1.650D+00,
32046 &-1.100D-01, 1.260D+00,-4.600D-01, 1.060D+00, 2.200D-01, 1.550D+00,
32047 &-7.000D-02, 1.370D+00, 1.000D-01, 1.200D+00,-2.700D-01, 9.200D-01,
32048 &-3.500D-01, 1.190D+00, 0.000D+00, 1.050D+00,-2.500D-01, 1.610D+00,
32049 &-2.100D-01, 9.000D-01,-2.100D-01, 7.400D-01,-3.800D-01, 7.200D-01/
32050 DATA ( PNCOOK(I),I = 91, INCOOK ) /
32051 &-3.400D-01, 9.200D-01,-2.600D-01, 9.400D-01, 1.000D-02, 6.500D-01,
32052 &-3.600D-01, 8.300D-01, 1.100D-01, 6.700D-01, 5.000D-02, 1.000D+00,
32053 & 5.100D-01, 1.040D+00, 3.300D-01, 6.800D-01,-2.700D-01, 8.100D-01,
32054 & 9.000D-02, 7.500D-01, 1.700D-01, 8.600D-01, 1.400D-01, 1.100D+00,
32055 &-2.200D-01, 8.400D-01,-4.700D-01, 4.800D-01, 2.000D-02, 8.800D-01,
32056 & 2.400D-01, 5.200D-01, 2.700D-01, 4.100D-01,-5.000D-02, 3.800D-01,
32057 & 1.500D-01, 6.700D-01, 0.000D+00, 6.100D-01, 0.000D+00, 7.800D-01,
32058 & 0.000D+00, 6.700D-01, 0.000D+00, 6.700D-01, 0.000D+00, 7.900D-01,
32059 & 0.000D+00, 6.000D-01, 4.000D-02, 6.400D-01,-6.000D-02, 4.500D-01,
32060 & 5.000D-02, 2.600D-01,-2.200D-01, 3.900D-01, 0.000D+00, 3.900D-01/
32061 DATA ( SZCOOK(I),I = 1, 98) /
32062 & 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
32063 & 0.000D+00, 0.000D+00,-1.100D-01,-8.100D-01,-2.910D+00,-4.170D+00,
32064 &-5.720D+00,-7.800D+00,-8.970D+00,-9.700D+00,-1.010D+01,-1.070D+01,
32065 &-1.138D+01,-1.207D+01,-1.255D+01,-1.324D+01,-1.393D+01,-1.471D+01,
32066 &-1.553D+01,-1.637D+01,-1.736D+01,-1.860D+01,-1.870D+01,-1.801D+01,
32067 &-1.787D+01,-1.708D+01,-1.660D+01,-1.675D+01,-1.650D+01,-1.635D+01,
32068 &-1.622D+01,-1.641D+01,-1.689D+01,-1.643D+01,-1.668D+01,-1.673D+01,
32069 &-1.745D+01,-1.729D+01,-1.744D+01,-1.782D+01,-1.862D+01,-1.827D+01,
32070 &-1.939D+01,-1.991D+01,-1.914D+01,-1.826D+01,-1.740D+01,-1.642D+01,
32071 &-1.577D+01,-1.437D+01,-1.391D+01,-1.310D+01,-1.311D+01,-1.143D+01,
32072 &-1.089D+01,-1.075D+01,-1.062D+01,-1.041D+01,-1.021D+01,-9.850D+00,
32073 &-9.470D+00,-9.030D+00,-8.610D+00,-8.130D+00,-7.460D+00,-7.480D+00,
32074 &-7.200D+00,-7.130D+00,-7.060D+00,-6.780D+00,-6.640D+00,-6.640D+00,
32075 &-7.680D+00,-7.890D+00,-8.410D+00,-8.490D+00,-7.880D+00,-6.300D+00,
32076 &-5.470D+00,-4.780D+00,-4.370D+00,-4.170D+00,-4.130D+00,-4.320D+00,
32077 &-4.550D+00,-5.040D+00,-5.280D+00,-6.060D+00,-6.280D+00,-6.870D+00,
32078 &-7.200D+00,-7.740D+00/
32079 DATA ( SNCOOK(I),I = 1, 90 ) /
32080 & 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
32081 & 0.000D+00, 0.000D+00, 1.030D+01, 5.660D+00, 6.800D+00, 7.530D+00,
32082 & 7.550D+00, 7.210D+00, 7.440D+00, 8.070D+00, 8.940D+00, 9.810D+00,
32083 & 1.060D+01, 1.139D+01, 1.254D+01, 1.368D+01, 1.434D+01, 1.419D+01,
32084 & 1.383D+01, 1.350D+01, 1.300D+01, 1.213D+01, 1.260D+01, 1.326D+01,
32085 & 1.413D+01, 1.492D+01, 1.552D+01, 1.638D+01, 1.716D+01, 1.755D+01,
32086 & 1.803D+01, 1.759D+01, 1.903D+01, 1.871D+01, 1.880D+01, 1.899D+01,
32087 & 1.846D+01, 1.825D+01, 1.776D+01, 1.738D+01, 1.672D+01, 1.562D+01,
32088 & 1.438D+01, 1.288D+01, 1.323D+01, 1.381D+01, 1.490D+01, 1.486D+01,
32089 & 1.576D+01, 1.620D+01, 1.762D+01, 1.773D+01, 1.816D+01, 1.867D+01,
32090 & 1.969D+01, 1.951D+01, 2.017D+01, 1.948D+01, 1.998D+01, 1.983D+01,
32091 & 2.020D+01, 1.972D+01, 1.987D+01, 1.924D+01, 1.844D+01, 1.761D+01,
32092 & 1.710D+01, 1.616D+01, 1.590D+01, 1.533D+01, 1.476D+01, 1.354D+01,
32093 & 1.263D+01, 1.065D+01, 1.010D+01, 8.890D+00, 1.025D+01, 9.790D+00,
32094 & 1.139D+01, 1.172D+01, 1.243D+01, 1.296D+01, 1.343D+01, 1.337D+01/
32095 DATA ( SNCOOK(I),I = 91, INCOOK ) /
32096 & 1.296D+01, 1.211D+01, 1.192D+01, 1.100D+01, 1.080D+01, 1.042D+01,
32097 & 1.039D+01, 9.690D+00, 9.270D+00, 8.930D+00, 8.570D+00, 8.020D+00,
32098 & 7.590D+00, 7.330D+00, 7.230D+00, 7.050D+00, 7.420D+00, 6.750D+00,
32099 & 6.600D+00, 6.380D+00, 6.360D+00, 6.490D+00, 6.250D+00, 5.850D+00,
32100 & 5.480D+00, 4.530D+00, 4.300D+00, 3.390D+00, 2.350D+00, 1.660D+00,
32101 & 8.100D-01, 4.600D-01,-9.600D-01,-1.690D+00,-2.530D+00,-3.160D+00,
32102 &-1.870D+00,-4.100D-01, 7.100D-01, 1.660D+00, 2.620D+00, 3.220D+00,
32103 & 3.760D+00, 4.100D+00, 4.460D+00, 4.830D+00, 5.090D+00, 5.180D+00,
32104 & 5.170D+00, 5.100D+00, 5.010D+00, 4.970D+00, 5.090D+00, 5.030D+00,
32105 & 4.930D+00, 5.280D+00, 5.490D+00, 5.500D+00, 5.370D+00, 5.300D+00/
32106 DATA LDEFOZ / 53*.FALSE.,25*.TRUE.,7*.FALSE.,13*.TRUE. /
32107 DATA LDEFON / 85*.FALSE.,37*.TRUE.,7*.FALSE.,21*.TRUE. /
32108*=== End of Block Data Bdevap =========================================*
32109 END
32110
32111*$ CREATE DT_BDNOPT.FOR
32112*COPY DT_BDNOPT
32113*
32114*=== bdnopt ===========================================================*
32115*== *
32116 BLOCK DATA DT_BDNOPT
32117
32118C INCLUDE '(DBLPRC)'
32119* DBLPRC.ADD
32120 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32121 SAVE
32122* (original name: GLOBAL)
32123 PARAMETER ( KALGNM = 2 )
32124 PARAMETER ( ANGLGB = 5.0D-16 )
32125 PARAMETER ( ANGLSQ = 2.5D-31 )
32126 PARAMETER ( AXCSSV = 0.2D+16 )
32127 PARAMETER ( ANDRFL = 1.0D-38 )
32128 PARAMETER ( AVRFLW = 1.0D+38 )
32129 PARAMETER ( AINFNT = 1.0D+30 )
32130 PARAMETER ( AZRZRZ = 1.0D-30 )
32131 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
32132 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
32133 PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
32134 PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
32135 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
32136 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
32137 PARAMETER ( CSNNRM = 2.0D-15 )
32138 PARAMETER ( DMXTRN = 1.0D+08 )
32139 PARAMETER ( ZERZER = 0.D+00 )
32140 PARAMETER ( ONEONE = 1.D+00 )
32141 PARAMETER ( TWOTWO = 2.D+00 )
32142 PARAMETER ( THRTHR = 3.D+00 )
32143 PARAMETER ( FOUFOU = 4.D+00 )
32144 PARAMETER ( FIVFIV = 5.D+00 )
32145 PARAMETER ( SIXSIX = 6.D+00 )
32146 PARAMETER ( SEVSEV = 7.D+00 )
32147 PARAMETER ( EIGEIG = 8.D+00 )
32148 PARAMETER ( ANINEN = 9.D+00 )
32149 PARAMETER ( TENTEN = 10.D+00 )
32150 PARAMETER ( HLFHLF = 0.5D+00 )
32151 PARAMETER ( ONETHI = ONEONE / THRTHR )
32152 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
32153 PARAMETER ( ONEFOU = ONEONE / FOUFOU )
32154 PARAMETER ( THRTWO = THRTHR / TWOTWO )
32155 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
32156 PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
32157 PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
32158 PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
32159 PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
32160 PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
32161 PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
32162 PARAMETER ( EULERO = 0.577215664901532860606512 D+00 )
32163 PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 )
32164 PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 )
32165 PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 )
32166 PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
32167 PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
32168 PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
32169 PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
32170 PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
32171 PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
32172 PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
32173 PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
32174 PARAMETER ( CLIGHT = 2.99792458 D+10 )
32175 PARAMETER ( AVOGAD = 6.0221367 D+23 )
32176 PARAMETER ( BOLTZM = 1.380658 D-23 )
32177 PARAMETER ( AMELGR = 9.1093897 D-28 )
32178 PARAMETER ( PLCKBR = 1.05457266 D-27 )
32179 PARAMETER ( ELCCGS = 4.8032068 D-10 )
32180 PARAMETER ( ELCMKS = 1.60217733 D-19 )
32181 PARAMETER ( AMUGRM = 1.6605402 D-24 )
32182 PARAMETER ( AMMUMU = 0.113428913 D+00 )
32183 PARAMETER ( AMPRMU = 1.007276470 D+00 )
32184 PARAMETER ( AMNEMU = 1.008664904 D+00 )
32185 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
32186 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
32187 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
32188 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
32189 PARAMETER ( PLABRC = 0.197327053 D+00 )
32190 PARAMETER ( AMELCT = 0.51099906 D-03 )
32191 PARAMETER ( AMUGEV = 0.93149432 D+00 )
32192 PARAMETER ( AMMUON = 0.105658389 D+00 )
32193 PARAMETER ( AMPRTN = 0.93827231 D+00 )
32194 PARAMETER ( AMNTRN = 0.93956563 D+00 )
32195 PARAMETER ( AMDEUT = 1.87561339 D+00 )
32196 PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
32197 & * 1.D-09 )
32198 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
32199 PARAMETER ( BLTZMN = 8.617385 D-14 )
32200 PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
32201 PARAMETER ( GFOHB3 = 1.16639 D-05 )
32202 PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
32203 PARAMETER ( SIN2TW = 0.2319 D+00 )
32204 PARAMETER ( GEVMEV = 1.0 D+03 )
32205 PARAMETER ( EMVGEV = 1.0 D-03 )
32206 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
32207 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
32208 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
32209 LOGICAL LGBIAS, LGBANA
32210 COMMON /FKGLOB/ LGBIAS, LGBANA
32211C INCLUDE '(DIMPAR)'
32212* DIMPAR.ADD
32213 PARAMETER ( MXXRGN = 5000 )
32214 PARAMETER ( MXXMDF = 82 )
32215 PARAMETER ( MXXMDE = 54 )
32216 PARAMETER ( MFSTCK = 1000 )
32217 PARAMETER ( MESTCK = 100 )
32218 PARAMETER ( NELEMX = 80 )
32219 PARAMETER ( MPDPDX = 8 )
32220 PARAMETER ( ICOMAX = 180 )
32221 PARAMETER ( NSTBIS = 304 )
32222 PARAMETER ( IDMAXP = 220 )
32223 PARAMETER ( IDMXDC = 640 )
32224 PARAMETER ( MKBMX1 = 1 )
32225 PARAMETER ( MKBMX2 = 1 )
32226C INCLUDE '(IOUNIT)'
32227* IOUNIT.ADD
32228 PARAMETER ( LUNIN = 5 )
32229 PARAMETER ( LUNOUT = 6 )
32230**sr 19.5. set error output-unit from 15 to 6
32231 PARAMETER ( LUNERR = 6 )
32232 PARAMETER ( LUNBER = 14 )
32233 PARAMETER ( LUNECH = 8 )
32234 PARAMETER ( LUNFLU = 13 )
32235 PARAMETER ( LUNGEO = 16 )
32236 PARAMETER ( LUNPMF = 12 )
32237 PARAMETER ( LUNRAN = 2 )
32238 PARAMETER ( LUNXSC = 9 )
32239 PARAMETER ( LUNDET = 17 )
32240 PARAMETER ( LUNRAY = 10 )
32241 PARAMETER ( LUNRDB = 1 )
32242 PARAMETER ( LUNPGO = 7 )
32243 PARAMETER ( LUNPGS = 4 )
32244 PARAMETER ( LUNSCR = 3 )
32245*
32246*----------------------------------------------------------------------*
32247* *
32248* Created on 20 september 1989 by Alfredo Ferrari - Infn Milan *
32249* *
32250* Last change on 20-apr-95 by Alfredo Ferrari *
32251* *
32252*----------------------------------------------------------------------*
32253*
32254C INCLUDE '(BLNKCM)'
32255* BLNKCM.ADD
32256**sr 17.5. commented since not used here
32257C PARAMETER ( NBLNMX = 1100000 )
32258C DIMENSION GMSTOR ( NBLNMX ), BRMBRR ( NBLNMX ), BRMEXP ( NBLNMX ),
32259C & BRMSIG ( NBLNMX ), SIGGTT ( KALGNM*NBLNMX ),
32260C & COMSCO ( NBLNMX ), LBSTOR ( KALGNM*NBLNMX )
32261C REAL SIGGTT
32262C LOGICAL LBSTOR
32263C COMMON NSTOR ( KALGNM*NBLNMX )
32264**
32265**sr 18.5. commented since not used for evap.
32266C COMMON / ADDRCM / MBLNMX, KBLNKL, KGMBGN, KGMLST, KCMBGN, KCMLST,
32267C & KISBGN, KISLST, KDTBGN, KDTLST, KUBBGN, KUBLST,
32268C & KUXBGN, KUXLST, KTCBGN, KTCLST, KRNBGN, KRNLST,
32269C & KYLBGN, KYLLST, KXSBGN, KXSLST, KIHBGN, KIHLST,
32270C & KINBGN, KINLST, KIEBGN, KIELST, KETBGN, KETLST,
32271C & KRRBGN, KRRLST, KGLBGN, KGLLST, KNABGN, KNALST,
32272C & KGDBGN, KGDLST, KDWBGN, KDWLST, KGCBGN, KGCLST,
32273C & KWLBGN, KWLLST, KWHBGN, KWHLST, KWMBGN, KWMLST,
32274C & KWSBGN, KWSLST, KNDBGN, KNDLST, KDPBGN, KDPLST,
32275C & KRGBGN, KRGLST, KSGBGN, KSGLST, KBRBGN, KBRLST,
32276C & KTMBGN
32277**
32278
32279C EQUIVALENCE ( NSTOR (1), GMSTOR (1) )
32280C EQUIVALENCE ( NSTOR (1), BRMBRR (1) )
32281C EQUIVALENCE ( NSTOR (1), BRMEXP (1) )
32282C EQUIVALENCE ( NSTOR (1), BRMSIG (1) )
32283C EQUIVALENCE ( NSTOR (1), COMSCO (1) )
32284C EQUIVALENCE ( NSTOR (1), SIGGTT (1) )
32285C EQUIVALENCE ( NSTOR (1), LBSTOR (1) )
32286C INCLUDE '(BLNTMP)'
32287* BLNTMP.ADD
32288**sr 18.5. commented since not used for evap.
32289C COMMON / BLNTMP / KIHBTM, KINBTM, KIEBTM, KRRBTM, KGLBTM, KNABTM,
32290C & KGCBTM, KGDWTM, KBDWTM, KWLOTM, KWHITM, KWMUTM,
32291C & KWSHTM, KEXTTM, KSTXTM, KSTNTM, KECTTM, KPCTTM,
32292C & KLPBTM, NXXRGN
32293**
32294C INCLUDE '(CMMDNR)'
32295* CMMDNR.ADD
32296**sr 18.5. commented since not used for evap.
32297C LOGICAL LFLDNR
32298C COMMON / CMMDNR / DDNEAR, LFLDNR
32299**
32300C INCLUDE '(CTITLE)'
32301* CTITLE.ADD
32302**sr 18.5. commented since not used for evap.
32303C CHARACTER RUNTIT*80, RUNTIM*32, RUNKEY*10
32304C COMMON / CTITLE / RUNTIT, RUNTIM, RUNKEY
32305C COMMON / CEXPCK / ITEXPI, ITEXMX
32306**
32307C INCLUDE '(DETECT)'
32308* DETECT.ADD
32309**sr 18.5. commented since not used for evap.
32310C PARAMETER (NRGNMX = 10)
32311C PARAMETER (NDTCMX = 10)
32312C PARAMETER (NSCRMX = 10)
32313C PARAMETER (NDTBIN = 1024)
32314C CHARACTER*10 TITDET,TITSCO
32315C LOGICAL LDTCTR
32316C COMMON /DETCT/ EDTMIN(NDTCMX), EDTBIN(NDTCMX), EDTCUT(NDTCMX),
32317C & KDTREG(NRGNMX,NDTCMX), KDTDET(NDTCMX,NSCRMX),
32318C & NDTSCO, NDTDET, LDTCTR, IDTREG(MXXRGN),
32319C & KDTSCD(NSCRMX)
32320C COMMON /DETCH/ TITDET(NDTCMX), TITSCO(NSCRMX)
32321**
32322C INCLUDE '(DETLOC)'
32323* DETLOC.ADD
32324**sr 18.5. commented since not used for evap.
32325C PARAMETER (NDTCM2 = 10)
32326C COMMON /DETLOC/ ACCUMP (NDTCM2), ACCUMN (NDTCM2),
32327C & ICOINC(NDTCM2), NCLAS
32328**
32329C INCLUDE '(EMGTRN)'
32330* EMGTRN.ADD
32331**sr 18.5. commented since not used for evap.
32332C LOGICAL LMCSMG
32333C COMMON / EMGTRN / UMCSMG, VMCSMG, WMCSMG, LMCSMG
32334**
32335C INCLUDE '(EMSHO)'
32336* EMSHO.ADD
32337**sr 18.5. commented since not used for evap.
32338C LOGICAL EMFLO, EMFHLO, EMFELO, LIMPRE, LEXPTE
32339C COMMON /EMSHO/ EMFETH, EMFPTH, EMFHET, EMFHPT, EMFBIA, EMFLO,
32340C & EMFHLO, EMFELO, LIMPRE, LEXPTE
32341**
32342C INCLUDE '(EPISOR)'
32343* EPISOR.ADD
32344**sr 18.5. commented since not used for evap.
32345C LOGICAL LUSSRC
32346C COMMON/EPISOR/TKESUM,LUSSRC
32347**
32348* (original name: FHEAVY,FHEAVC)
32349 PARAMETER ( MXHEAV = 100 )
32350 CHARACTER*8 ANHEAV
32351 COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV),
32352 & CZHEAV (MXHEAV), TKHEAV (MXHEAV),
32353 & PHEAVY (MXHEAV), WHEAVY (MXHEAV),
32354 & AMHEAV ( 12 ) , AMNHEA ( 12 ) ,
32355 & KHEAVY (MXHEAV), ICHEAV ( 12 ) ,
32356 & IBHEAV ( 12 ) , NPHEAV
32357 COMMON /FKFHVC/ ANHEAV ( 12 )
32358* (original name: FINUC)
32359 PARAMETER (MXP=999)
32360 COMMON /FKFINU/ CXR (MXP), CYR (MXP), CZR (MXP),
32361 & CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP),
32362 & TKI (MXP), PLR (MXP), WEI (MXP),
32363 & TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP,
32364 & KPART (MXP)
32365C INCLUDE '(GENTHR)'
32366* GENTHR.ADD
32367**sr 18.5. commented since not used for evap.
32368C COMMON / GENTHR / PEANCT, PEAPIT, PLDNCT, PTHRSH (NALLWP),
32369C & PTHDFF (NALLWP), IJNUCR (NALLWP)
32370**
32371C INCLUDE '(LOWNEU)'
32372* LOWNEU.ADD
32373**sr 18.5. commented since not used for evap.
32374C PARAMETER ( MXGTHN = 15 )
32375C PARAMETER ( MXGLWN = 200 )
32376C PARAMETER ( MXSHPP = 5 )
32377C LOGICAL LCOMPN, LIMPRN, LBIASN, LDOWNN, LRECPR, LLOWWW, LLOWET
32378C CHARACTER*10 TITLOW
32379C COMMON / LOWNEU / ATOLOW (MXXMDF), WSHPLN (MXGLWN,MXSHPP), EXTWWL,
32380C & SHPIMP (MXGLWN), EXTETL (MXGLWN), WWAMFL,
32381C & VLLNTH (MXGTHN,MXXMDF), ABLNTH (MXGTHN,MXXMDF),
32382C & STLNTH (MXGTHN,MXXMDF), TMRTLN (MXXMDF),
32383C & TMNMLN (MXXMDF), ICHCPT (MXXMDF),
32384C & IGTMRT (MXXMDF), NEUMED (MXXMDF),
32385C & ID1MED (MXXMDF), ID2MED (MXXMDF),
32386C & ID3MED (MXXMDF), MGTMED (MXXMDF),
32387C & LCOMPN (MXXMDF), LRECPR (MXXMDF), KPRLOW, NMGP,
32388C & NMTG , IGRTHN, LIMPRN, LBIASN, LDOWNN, LLOWWW,
32389C & LLOWET, ICLMED, IKRBGN, INABGN, IDWBGN, IETBGN,
32390C & I0XSEC, IDXSEC, ISENAV, ISVELN, ISPNAV, IWWLWB,
32391C & IWWLWT, IPXBGN, NPXSEC
32392C COMMON / CHLWNT / TITLOW (MXXMDF)
32393**
32394C INCLUDE '(LTCLCM)'
32395* LTCLCM.ADD
32396**sr 18.5. commented since not used for evap.
32397C COMMON / LTCLCM / MLATTC, NEWLAT, MLATLD, MLATM1, MLTSEN, MLTSM1
32398**
32399C INCLUDE '(MULBOU)'
32400* MULBOU.ADD
32401**sr 18.5. commented since not used for evap.
32402C LOGICAL LLDA , LAGAIN, LSTNEW, LARTEF, LNORML, LSENSE, LMGNOR
32403C COMMON / MULBOU / UOLD , VOLD , WOLD , UMAG , VMAG , WMAG ,
32404C & UNORML, VNORML, WNORML, USENSE, VSENSE, WSENSE,
32405C & TSENSE, DDSENS, DSMALL, NSSENS, LLDA , LAGAIN,
32406C & LSTNEW, LARTEF, LNORML, LSENSE, LMGNOR
32407**
32408C INCLUDE '(MULHD)'
32409* MULHD.ADD
32410**sr 18.5. commented since not used for evap.
32411C PARAMETER ( MXXPT1 = 1 )
32412C PARAMETER ( TIMESS = 2.00D+00 )
32413C PARAMETER ( TMSRLX = 1.50D+00 )
32414C PARAMETER ( EPSINS = 0.15D+00 )
32415C PARAMETER ( EPSRLX = 0.50D+00 )
32416C PARAMETER ( SQEPSN = 0.3872983346207417 D+00 )
32417C PARAMETER ( SQEPSR = 0.7071067811865475 D+00 )
32418C PARAMETER ( PARNSI = 1.732050807568877 D+00 * SQEPSN )
32419C PARAMETER ( PRNSR0 = 1.732050807568877 D+00 * SQEPSR )
32420C PARAMETER ( R0NCMS = 1.20 D+00 )
32421C LOGICAL LTOPT, LSRCRH, LNSCRH
32422C COMMON / MULHD / BLCC ( MXXMDF ), BLCCRA ( MXXMDF ),
32423C & XCC ( MXXMDF ), ZTILDE ( MXXMDF, 0:MXXPT1 ),
32424C & ALPZTL ( MXXMDF, 0:MXXPT1 ), RLDU ( MXXMDF ),
32425C & ALPZT2 ( MXXMDF, 0:MXXPT1 ), TEFF0 ( MXXMDF ),
32426C & XR0 ( MXXMDF ), ECUTM ( MXXMDF, 39, 2 ),
32427C & ESTEPF ( MXXMDF ), HTHNSZ ( MXXMDF, 39 ),
32428C & AE1O3 ( MXXMDF ), PARNSR ( MXXMDF ),
32429C & HEESLI ( MXXMDF ), THMSPR, THMSSC, HMSAMP,
32430C & HMREJE, LSRCRH ( MXXMDF ), LNSCRH ( MXXMDF ),
32431C & LTOPT ( MXXMDF ), NFSCAT
32432**
32433* (original name: PAREVT)
32434 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
32435 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
32436 PARAMETER ( NALLWP = 39 )
32437 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
32438 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
32439 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
32440 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
32441* (original name: RESNUC)
32442 LOGICAL LRNFSS, LFRAGM
32443 COMMON /FKRESN/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
32444 & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
32445 & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES,
32446 & PYRES, PZRES, PTRES2, KTARP, KTARN, IGREYP,
32447 & IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,
32448 & ICRES, IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU,
32449 & IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG,
32450 & IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS,
32451 & LFRAGM
32452C INCLUDE '(SCOHLP)'
32453* SCOHLP.ADD
32454**sr 18.5. commented since not used for evap.
32455C LOGICAL LSCZER
32456C COMMON / SCOHLP / ISCRNG, JSCRNG, LSCZER
32457**
32458C INCLUDE '(TRACKR)'
32459* TRACKR.ADD
32460**sr 18.5. commented since not used for evap.
32461C PARAMETER ( MXTRCK = 2500 )
32462C LOGICAL LFSSSC
32463C COMMON / TRACKR / XTRACK ( 0:MXTRCK ), YTRACK ( 0:MXTRCK ),
32464C & ZTRACK ( 0:MXTRCK ), TTRACK ( MXTRCK ),
32465C & DTRACK ( MXTRCK ), ETRACK, PTRACK, WTRACK,
32466C & ATRACK, CTRACK, AKSHRT, AKLONG, WSCRNG,
32467C & NTRACK, MTRACK, JTRACK, KTRACK, MMTRCK,
32468C & LT1TRK, LT2TRK, LTRACK, LLOUSE, LFSSSC
32469**
32470C INCLUDE '(USRBDX)'
32471* USRBDX.ADD
32472**sr 18.5. commented since not used for evap.
32473C PARAMETER ( MXUSBX = 600 )
32474C LOGICAL LUSBDX, LFUSBX, LWUSBX, LLNUSX
32475C CHARACTER*10 TITUSX
32476C COMMON /USRBX/ EBXLOW(MXUSBX), EBXHGH(MXUSBX), ABXLOW(MXUSBX),
32477C & ABXHGH(MXUSBX), DEBXBN(MXUSBX), DABXBN(MXUSBX),
32478C & AUSBDX(MXUSBX),
32479C & NEBXBN(MXUSBX), NABXBN(MXUSBX), NR1USX(MXUSBX),
32480C & NR2USX(MXUSBX), ITUSBX(MXUSBX), IDUSBX(MXUSBX),
32481C & KBUSBX(MXUSBX), IPUSBX(MXUSBX), IGMUSX(MXUSBX),
32482C & LFUSBX(MXUSBX), LWUSBX(MXUSBX), LLNUSX(MXUSBX),
32483C & NUSRBX, LUSBDX
32484C COMMON /USXCH/ TITUSX(MXUSBX)
32485**
32486C INCLUDE '(USRBIN)'
32487* USRBIN.ADD
32488**sr 18.5. commented since not used for evap.
32489C PARAMETER ( MXUSBN = 100 )
32490C LOGICAL LUSBIN, LEVTBN, LNTZER, LUSEVT, LUSTKB, LTRKBN
32491C CHARACTER*10 TITUSB
32492C COMMON /USRBN/ XLOW (MXUSBN), XHIGH (MXUSBN), YLOW (MXUSBN),
32493C & YHIGH (MXUSBN), ZLOW (MXUSBN), ZHIGH (MXUSBN),
32494C & DXUSBN(MXUSBN), DYUSBN(MXUSBN), DZUSBN(MXUSBN),
32495C & TCUSBN(MXUSBN), BKUSBN(MXUSBN), B2USBN(MXUSBN),
32496C & NXBIN (MXUSBN), NYBIN (MXUSBN), NZBIN (MXUSBN),
32497C & ITUSBN(MXUSBN), IDUSBN(MXUSBN), KBUSBN(MXUSBN),
32498C & IPUSBN(MXUSBN), LEVTBN(MXUSBN), LNTZER(MXUSBN),
32499C & LTRKBN(MXUSBN), NUSRBN, LUSBIN, LUSEVT, LUSTKB
32500C COMMON /USRCH/ TITUSB(MXUSBN)
32501**
32502C INCLUDE '(USRSNC)'
32503* USRSNC.ADD
32504**sr 18.5. commented since not used for evap.
32505C PARAMETER ( MXRSNC = 400 )
32506C PARAMETER ( NMZMIN = -5 )
32507C LOGICAL LURSNC
32508C CHARACTER*10 TIURSN
32509C COMMON /USRSNC/ VURSNC(MXRSNC), IZRHGH(MXRSNC), IMRHGH(MXRSNC),
32510C & NRURSN(MXRSNC), ITURSN(MXRSNC), KBURSN(MXRSNC),
32511C & IPURSN(MXRSNC), NURSNC, LURSNC
32512C COMMON /USRSCH/ TIURSN(MXRSNC)
32513C INCLUDE '(USRTRC)'
32514* USRTRC.ADD
32515**sr 18.5. commented since not used for evap.
32516C PARAMETER ( MXUSTC = 400 )
32517C LOGICAL LUSRTC, LUSTRK, LUSCLL, LLNUTC
32518C CHARACTER*10 TITUTC
32519C COMMON /USRTC/ ETCLOW(MXUSTC), ETCHGH(MXUSTC), DETCBN(MXUSTC),
32520C & VUSRTC(MXUSTC),
32521C & IUSTRK(MXUSTC), IUSCLL(MXUSTC), NETCBN(MXUSTC),
32522C & NRUSTC(MXUSTC), ITUSTC(MXUSTC), IDUSTC(MXUSTC),
32523C & KBUSTC(MXUSTC), IPUSTC(MXUSTC), IGMUTC(MXUSTC),
32524C & LLNUTC(MXUSTC), NUSRTC, NUSTRK, NUSCLL, LUSRTC,
32525C & LUSTRK, LUSCLL
32526C COMMON /USTCH/ TITUTC(MXUSTC)
32527**
32528C INCLUDE '(USRYLD)'
32529* USRYLD.ADD
32530**sr 18.5. commented since not used for evap.
32531C PARAMETER ( MXUSYL = 500 )
32532C LOGICAL LUSRYL, LLNUYL, LSCUYL
32533C CHARACTER*10 TITUYL
32534C COMMON /USRYL/ EYLLOW(MXUSYL), EYLHGH(MXUSYL), DEYLBN(MXUSYL),
32535C & USNRYL(MXUSYL), SGUSYL(MXUSYL), AYLLOW(MXUSYL),
32536C & AYLHGH(MXUSYL), PUSRYL, UUSRYL, VUSRYL, WUSRYL,
32537C & ETXUYL, ETYUYL, ETZUYL, GAMUYL, SQSUYL, UCMUYL,
32538C & VCMUYL, WCMUYL, IJUSYL, JTUSYL,
32539C & NEYLBN(MXUSYL), NR1UYL(MXUSYL), NR2UYL(MXUSYL),
32540C & IXUSYL(MXUSYL), ITUSYL(MXUSYL), IDUSYL(MXUSYL),
32541C & KBUSYL(MXUSYL), IPUSYL(MXUSYL), IGMUYL(MXUSYL),
32542C & IEUSYL(MXUSYL), IAUSYL(MXUSYL), LLNUYL(MXUSYL),
32543C & NUSRYL, LUSRYL, LSCUYL
32544C COMMON /USYCH/ TITUYL(MXUSYL)
32545**
32546C INCLUDE '(WWINDW)'
32547* WWINDW.ADD
32548**sr 18.5. commented since not used for evap.
32549C PARAMETER ( MXWWSP = 3 )
32550C PARAMETER ( WWSPMX = 50.D+00 )
32551C LOGICAL LWWNDW, LWWPRM
32552C COMMON / WWINDW / ETHWW1 (NALLWP), ETHWW2 (NALLWP),
32553C & WWEXWD (NALLWP), EXTWWN (NALLWP),
32554C & IWLBGN, IWHBGN, IWMBGN, LWWNDW, LWWPRM
32555**
32556
32557* /blnkcm/
32558* *** If blank common dimension has to be superseded substitute in the
32559* *** following two lines the new dimension in real*8 units to Nblnmx
32560**sr 18.5. commented since not used for evap.
32561C PARAMETER (MXDUMM = KALGNM * NBLNMX)
32562C DATA KTMBGN / NBLNMX /
32563C DATA MBLNMX / MXDUMM /
32564C DATA KBLNKL, KGMBGN, KGMLST, KCMBGN, KCMLST, KISBGN, KISLST,
32565C & KDTBGN, KDTLST, KUBBGN, KUBLST, KUXBGN, KUXLST, KTCBGN,
32566C & KTCLST, KRNBGN, KRNLST, KYLBGN, KYLLST, KXSBGN, KXSLST,
32567C & KIHBGN, KIHLST, KINBGN, KINLST, KIEBGN, KIELST, KETBGN,
32568C & KETLST, KRRBGN, KRRLST, KGLBGN, KGLLST, KNABGN, KNALST,
32569C & KGDBGN, KGDLST, KDWBGN, KDWLST, KGCBGN, KGCLST, KWLBGN,
32570C & KWLLST, KWHBGN, KWHLST, KWMBGN, KWMLST, KWSBGN, KWSLST,
32571C & KDPBGN, KDPLST, KRGBGN, KRGLST, KSGBGN, KSGLST, KBRBGN,
32572C & KBRLST / 57*0 /
32573
32574* /blntmp/
32575**sr 18.5. commented since not used for evap.
32576C DATA KIHBTM, KINBTM, KIEBTM, KRRBTM, KGLBTM, KNABTM, KGDWTM,
32577C & KBDWTM, KGCBTM, KWLOTM, KWHITM, KWMUTM, KWSHTM, KEXTTM,
32578C & KSTXTM, KSTNTM, KECTTM, KPCTTM, KLPBTM / 19*0 /
32579
32580* /cmmdnr/
32581**sr 18.5. commented since not used for evap.
32582C DATA DDNEAR / 0.D+00 /, LFLDNR / .FALSE. /
32583
32584* /ctitle/
32585**sr 18.5. commented since not used for evap.
32586C DATA RUNTIT (1:40) / '****************************************' /
32587C DATA RUNTIT(41:80) / '****************************************' /
32588C DATA ITEXPI, ITEXMX / 100000000, 150 /
32589* /detect/
32590**sr 18.5. commented since not used for evap.
32591C PARAMETER (NNN1 = NRGNMX*NDTCMX)
32592C PARAMETER (NNN2 = NSCRMX*NDTCMX)
32593C DATA LDTCTR /.FALSE./, NDTSCO /0/, NDTDET /0/
32594C DATA EDTMIN/NDTCMX*0.D0/, EDTBIN/NDTCMX*0.D0/, EDTCUT/NDTCMX*0.D0/
32595C DATA KDTREG/NNN1*0/, KDTDET/NNN2*0/, KDTSCD/NSCRMX*0/
32596C DATA TITDET/NDTCMX*' '/, TITSCO/NSCRMX*' '/
32597
32598* /detloc/
32599**sr 18.5. commented since not used for evap.
32600C DATA ACCUMP /NDTCM2*0.D0/, ACCUMN /NDTCM2*0.D0/, ICOINC /NDTCM2*0/
32601C DATA NCLAS /0/
32602
32603* /emgtrn/
32604**sr 18.5. commented since not used for evap.
32605C DATA LMCSMG / .FALSE. /
32606
32607* /emsho/
32608**sr 18.5. commented since not used for evap.
32609C DATA LIMPRE, LEXPTE / 2 * .FALSE. /
32610
32611* /episor/
32612**sr 18.5. commented since not used for evap.
32613C DATA TKESUM / 0.D+00 /, LUSSRC / .FALSE. /
32614
32615* /fheavy/
32616 DATA AMHEAV / 12 * 0.D+00 /
32617 DATA ANHEAV / 'NEUTRON ', 'PROTON ', 'DEUTERON', '3-H ',
32618 & '3-He ', '4-He ', 'H-FRAG-1', 'H-FRAG-2',
32619 & 'H-FRAG-3', 'H-FRAG-4', 'H-FRAG-5', 'H-FRAG-6'/
32620 DATA ICHEAV / 0, 1, 1, 1, 2, 2, 6*0 /,
32621 & IBHEAV / 1, 1, 2, 3, 3, 4, 6*0 /
32622 DATA NPHEAV / 0 /
32623
32624* /finuc/
32625 DATA NP / 0 /, TV / 0.D+00 /, TVCMS / 0.D+00 /, TVRECL / 0.D+00/,
32626 & TVHEAV / 0.D+00 /, TVBIND / 0.D+00 /
32627
32628* /genthr/
32629* Up to 20-apr-'95
32630* DATA PEANCT, PEAPIT / 2*1.D+00 /
32631* DATA PTHRSH / 16*5.D+00,2*2.5D+00,5.D+00,3*2.5D+00,8*5.D+00,
32632* & 9*2.5D+00 /
32633* DATA PTHDFF / 39*5.D+00 /
32634* & 9*2.5D+00 /
32635* New values:
32636**sr 18.5. commented since not used for evap.
32637C DATA PEANCT, PEAPIT / 1.3D+00, 1.1D+00 /
32638C DATA PTHRSH / 12*5.D+00, 2*3.5D+00, 2*5.D+00, 2*2.5D+00, 5.D+00,
32639C & 3*2.5D+00, 3.5D+00, 2*5.D+00, 3.5D+00, 4*5.D+00,
32640C & 9*2.5D+00 /
32641C DATA PTHDFF / 12*5.D+00, 2*3.5D+00, 8*5.D+00, 3.5D+00, 2*5.D+00,
32642C & 3.5D+00, 13*5.D+00 /
32643C DATA PLDNCT / 0.26D+00 /
32644C DATA IJNUCR / 16*1, 2*0, 1, 3*0, 8*1, 9*0 /
32645
32646* /lowneu/
32647**sr 18.5. commented since not used for evap.
32648C DATA WWAMFL / 10.D+00 /, EXTWWL / 1.D+00 /
32649C DATA IWWLWB, IWWLWT / 2 * 100000000 /
32650C DATA ICLMED, INABGN, IDWBGN, IETBGN / 4*0 /
32651C DATA IGRTHN / 1 /
32652C DATA LIMPRN / .FALSE. /, LBIASN / .FALSE. /, LDOWNN / .FALSE. /,
32653C & LLOWWW / .FALSE. /, LLOWET / .FALSE. /
32654
32655* /ltclcm/
32656**sr 18.5. commented since not used for evap.
32657C DATA MLATTC, NEWLAT, MLATLD, MLATM1, MLTSEN, MLTSM1 / 6*0 /
32658
32659* /mulbou/
32660**sr 18.5. commented since not used for evap.
32661C DATA LLDA, LAGAIN, LSTNEW, LARTEF, LSENSE, LNORML, LMGNOR
32662C & / 7 * .FALSE. /
32663C DATA TSENSE / AINFNT /, NSSENS / -1 /
32664C DATA DSMALL / ANGLGB /
32665
32666* /mulhd/
32667**sr 18.5. commented since not used for evap.
32668C DATA LTOPT / MXXMDF * .FALSE. /, NFSCAT / 0 /
32669C DATA ESTEPF / MXXMDF * 0.1D+00 /
32670C DATA LSRCRH / MXXMDF * .FALSE. /, LNSCRH / MXXMDF * .FALSE. /
32671C DATA THMSPR / 0.02D+00 /, THMSSC / 1.D+00 /
32672
32673* /parevt/
32674 DATA DPOWER /-13.D+00 /, FSPRD0 / 0.6D+00 /, FSHPFN / 0.0D+00 /,
32675 & RN1GSC /-1.0D+00 /, RN2GSC /-1.0D+00 /
32676 DATA LDIFFR / .TRUE., .TRUE., 6 * .TRUE., .TRUE., 8 * .TRUE.,
32677 & .TRUE., 4 * .TRUE., .TRUE., 3 * .TRUE.,
32678 & 4 * .FALSE., 9 * .TRUE./
32679**sr 17.5.95
32680* default value for LEVPRT changed (reset sr 25.7.97)
32681* default value for LHEAVY changed 25.7.97
32682C DATA LPOWER / .TRUE. /, LINCTV / .TRUE. /, LEVPRT / .TRUE. /,
32683C & LHEAVY / .FALSE. /, LDEEXG / .TRUE. /, LGDHPR / .TRUE. /,
32684C & LPREEX / .TRUE. /, LHLFIX / .FALSE. /, LPRFIX / .FALSE. /,
32685C & LPARWV / .TRUE. /, LSNGCH / .TRUE. /, LSCHDF / .TRUE. /
32686 DATA LPOWER / .TRUE. /, LINCTV / .TRUE. /, LEVPRT / .TRUE. /,
32687 & LHEAVY / .TRUE. /, LDEEXG / .TRUE. /, LGDHPR / .TRUE. /,
32688 & LPREEX / .TRUE. /, LHLFIX / .FALSE. /, LPRFIX / .FALSE. /,
32689 & LPARWV / .TRUE. /, LSNGCH / .TRUE. /, LSCHDF / .TRUE. /
32690**
32691**sr 27.5.97
32692* default value for ILVMOD changed
32693C DATA ILVMOD / 0 /, JLVMOD / 1 /, LLVMOD / .TRUE. /
32694 DATA ILVMOD / 1 /, JLVMOD / 1 /, LLVMOD / .TRUE. /
32695**
32696
32697* /resnuc/
32698 DATA IPREEH / 0 /, IPRTRI / 0 /, IPRDEU / 0 /, IPR3HE / 0 /,
32699 & IPR4HE / 0 /
32700 DATA IEVAPL / 0 /, IEVAPH / 0 /, IEVNEU / 0 /, IEVPRO / 0 /,
32701 & IEVTRI / 0 /, IEVDEU / 0 /, IEV3HE / 0 /, IEV4HE / 0 /,
32702 & IDEEXG / 0 /
32703 DATA LRNFSS / .FALSE. /
32704
32705* /scohlp/
32706**sr 18.5. commented since not used for evap.
32707C DATA ISCRNG, JSCRNG / 2*0 /, LSCZER / .FALSE. /
32708
32709* /trackr/
32710**sr 18.5. commented since not used for evap.
32711C DATA ETRACK /0.D+00/, WTRACK /0.D+00/, ATRACK /0.D+00/,
32712C & CTRACK /0.D+00/, NTRACK /0/, MTRACK /0/, JTRACK /0/
32713
32714* /usrbin/
32715**sr 18.5. commented since not used for evap.
32716C DATA LUSBIN, LUSEVT, LUSTKB /3*.FALSE./, NUSRBN /0/
32717
32718* /usrbdx/
32719**sr 18.5. commented since not used for evap.
32720C DATA LUSBDX /.FALSE./, NUSRBX /0/
32721
32722* /usrsnc/
32723**sr 18.5. commented since not used for evap.
32724C DATA LURSNC /.FALSE./, NURSNC /0/
32725
32726* /usrtrc/
32727**sr 18.5. commented since not used for evap.
32728C DATA LUSRTC, LUSTRK, LUSCLL / 3*.FALSE. /
32729C DATA NUSRTC, NUSTRK, NUSCLL / 3*0 /
32730
32731* /usryld/
32732**sr 18.5. commented since not used for evap.
32733C DATA LUSRYL / .FALSE./, LSCUYL / .FALSE. /, NUSRYL /0/,
32734C & IJUSYL /0/, JTUSYL /0/
32735C DATA PUSRYL, UUSRYL, VUSRYL, WUSRYL / 4*ZERZER /
32736
32737* /wwindw/
32738**sr 18.5. commented since not used for evap.
32739C DATA IWLBGN, IWHBGN, IWMBGN / 3*0 /
32740C DATA LWWPRM / .TRUE. /
32741
32742*= end*block.bdnopt *
32743 END
32744
32745*$ CREATE DT_BDPREE.FOR
32746*COPY DT_BDPREE
32747*
32748*=== bdpree ===========================================================*
32749*
32750 BLOCK DATA DT_BDPREE
32751
32752C INCLUDE '(DBLPRC)'
32753* DBLPRC.ADD
32754 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32755 SAVE
32756* (original name: GLOBAL)
32757 PARAMETER ( KALGNM = 2 )
32758 PARAMETER ( ANGLGB = 5.0D-16 )
32759 PARAMETER ( ANGLSQ = 2.5D-31 )
32760 PARAMETER ( AXCSSV = 0.2D+16 )
32761 PARAMETER ( ANDRFL = 1.0D-38 )
32762 PARAMETER ( AVRFLW = 1.0D+38 )
32763 PARAMETER ( AINFNT = 1.0D+30 )
32764 PARAMETER ( AZRZRZ = 1.0D-30 )
32765 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
32766 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
32767 PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
32768 PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
32769 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
32770 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
32771 PARAMETER ( CSNNRM = 2.0D-15 )
32772 PARAMETER ( DMXTRN = 1.0D+08 )
32773 PARAMETER ( ZERZER = 0.D+00 )
32774 PARAMETER ( ONEONE = 1.D+00 )
32775 PARAMETER ( TWOTWO = 2.D+00 )
32776 PARAMETER ( THRTHR = 3.D+00 )
32777 PARAMETER ( FOUFOU = 4.D+00 )
32778 PARAMETER ( FIVFIV = 5.D+00 )
32779 PARAMETER ( SIXSIX = 6.D+00 )
32780 PARAMETER ( SEVSEV = 7.D+00 )
32781 PARAMETER ( EIGEIG = 8.D+00 )
32782 PARAMETER ( ANINEN = 9.D+00 )
32783 PARAMETER ( TENTEN = 10.D+00 )
32784 PARAMETER ( HLFHLF = 0.5D+00 )
32785 PARAMETER ( ONETHI = ONEONE / THRTHR )
32786 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
32787 PARAMETER ( ONEFOU = ONEONE / FOUFOU )
32788 PARAMETER ( THRTWO = THRTHR / TWOTWO )
32789 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
32790 PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
32791 PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
32792 PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
32793 PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
32794 PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
32795 PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
32796 PARAMETER ( EULERO = 0.577215664901532860606512 D+00 )
32797 PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 )
32798 PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 )
32799 PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 )
32800 PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
32801 PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
32802 PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
32803 PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
32804 PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
32805 PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
32806 PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
32807 PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
32808 PARAMETER ( CLIGHT = 2.99792458 D+10 )
32809 PARAMETER ( AVOGAD = 6.0221367 D+23 )
32810 PARAMETER ( BOLTZM = 1.380658 D-23 )
32811 PARAMETER ( AMELGR = 9.1093897 D-28 )
32812 PARAMETER ( PLCKBR = 1.05457266 D-27 )
32813 PARAMETER ( ELCCGS = 4.8032068 D-10 )
32814 PARAMETER ( ELCMKS = 1.60217733 D-19 )
32815 PARAMETER ( AMUGRM = 1.6605402 D-24 )
32816 PARAMETER ( AMMUMU = 0.113428913 D+00 )
32817 PARAMETER ( AMPRMU = 1.007276470 D+00 )
32818 PARAMETER ( AMNEMU = 1.008664904 D+00 )
32819 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
32820 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
32821 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
32822 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
32823 PARAMETER ( PLABRC = 0.197327053 D+00 )
32824 PARAMETER ( AMELCT = 0.51099906 D-03 )
32825 PARAMETER ( AMUGEV = 0.93149432 D+00 )
32826 PARAMETER ( AMMUON = 0.105658389 D+00 )
32827 PARAMETER ( AMPRTN = 0.93827231 D+00 )
32828 PARAMETER ( AMNTRN = 0.93956563 D+00 )
32829 PARAMETER ( AMDEUT = 1.87561339 D+00 )
32830 PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
32831 & * 1.D-09 )
32832 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
32833 PARAMETER ( BLTZMN = 8.617385 D-14 )
32834 PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
32835 PARAMETER ( GFOHB3 = 1.16639 D-05 )
32836 PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
32837 PARAMETER ( SIN2TW = 0.2319 D+00 )
32838 PARAMETER ( GEVMEV = 1.0 D+03 )
32839 PARAMETER ( EMVGEV = 1.0 D-03 )
32840 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
32841 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
32842 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
32843 LOGICAL LGBIAS, LGBANA
32844 COMMON /FKGLOB/ LGBIAS, LGBANA
32845C INCLUDE '(DIMPAR)'
32846* DIMPAR.ADD
32847 PARAMETER ( MXXRGN = 5000 )
32848 PARAMETER ( MXXMDF = 82 )
32849 PARAMETER ( MXXMDE = 54 )
32850 PARAMETER ( MFSTCK = 1000 )
32851 PARAMETER ( MESTCK = 100 )
32852 PARAMETER ( NALLWP = 39 )
32853 PARAMETER ( NELEMX = 80 )
32854 PARAMETER ( MPDPDX = 8 )
32855 PARAMETER ( ICOMAX = 180 )
32856 PARAMETER ( NSTBIS = 304 )
32857 PARAMETER ( IDMAXP = 220 )
32858 PARAMETER ( IDMXDC = 640 )
32859 PARAMETER ( MKBMX1 = 1 )
32860 PARAMETER ( MKBMX2 = 1 )
32861C INCLUDE '(IOUNIT)'
32862* IOUNIT.ADD
32863 PARAMETER ( LUNIN = 5 )
32864 PARAMETER ( LUNOUT = 6 )
32865**sr 19.5. set error output-unit from 15 to 6
32866 PARAMETER ( LUNERR = 6 )
32867 PARAMETER ( LUNBER = 14 )
32868 PARAMETER ( LUNECH = 8 )
32869 PARAMETER ( LUNFLU = 13 )
32870 PARAMETER ( LUNGEO = 16 )
32871 PARAMETER ( LUNPMF = 12 )
32872 PARAMETER ( LUNRAN = 2 )
32873 PARAMETER ( LUNXSC = 9 )
32874 PARAMETER ( LUNDET = 17 )
32875 PARAMETER ( LUNRAY = 10 )
32876 PARAMETER ( LUNRDB = 1 )
32877 PARAMETER ( LUNPGO = 7 )
32878 PARAMETER ( LUNPGS = 4 )
32879 PARAMETER ( LUNSCR = 3 )
32880*
32881*----------------------------------------------------------------------*
32882* *
32883* Created on 16 september 1991 by Alfredo Ferrari & Paola Sala *
32884* Infn - Milan *
32885* *
32886* Last change on 03-feb-94 by Alfredo Ferrari *
32887* *
32888* *
32889*----------------------------------------------------------------------*
32890*
32891* (original name: CMPISG,CHPISG)
32892 PARAMETER ( TPPPI0 = 0.279656044337515D+00 )
32893 PARAMETER ( TNNPI0 = 0.279642680857450D+00 )
32894 PARAMETER ( TPPPIP = 0.292295207182790D+00 )
32895 PARAMETER ( TPPDEP = 0.287514778898469D+00 )
32896 PARAMETER ( TNNPIM = 0.286723140900975D+00 )
32897 PARAMETER ( TNNDEM = 0.281949292916434D+00 )
32898 PARAMETER ( TPNPI0 = 0.279456888147740D+00 )
32899 PARAMETER ( TPNDE0 = 0.274693916135245D+00 )
32900 PARAMETER ( TPNPIP = 0.292086756473890D+00 )
32901 PARAMETER ( TNPPI0 = 0.279842093144975D+00 )
32902 PARAMETER ( TNPDE0 = 0.275072555824202D+00 )
32903 PARAMETER ( TNPPIP = 0.292489370554958D+00 )
32904 PARAMETER ( PIRSMX = 1.2D+00 )
32905 PARAMETER ( NPIREA = 10 )
32906 PARAMETER ( NPIRTA = 68 )
32907 PARAMETER ( NPIRLN = 21 )
32908 PARAMETER ( NPIRLG = NPIRTA - NPIRLN )
32909 PARAMETER ( NPISIS = NPIRLN + 20 )
32910 PARAMETER ( NPISEX = NPIRLN + 21 )
32911 PARAMETER ( NPIIMN = 14 )
32912 PARAMETER ( NPIIRC = 6 )
32913 PARAMETER ( DELWLL = 0.035D+00 )
32914 CHARACTER CHPIRE*8
32915 LOGICAL LDLRES
32916 COMMON /FKCMPI/ PMNPIS, PMMPIS, PISPIS, PEXPIS, PMXPIS, DPPISG,
32917 & RTPISG, AMNPIS, AMMPIS, AISPIS, AEXPIS, AMXPIS,
32918 & ARPISG, BPISLO (NPIRLN:NPIRTA,NPIREA),
32919 & CPISLO (NPIRLN:NPIRTA,NPIREA), PPITHR (NPIREA),
32920 & SPISLO (NPIRLN:NPIRTA,NPIREA), APITHR (NPIREA),
32921 & SGPIIN (NPIIMN:NPIRTA,NPIIRC), RHPICR (1:5) ,
32922 & SGPICU (0:20,NPIRTA,NPIREA) , SGRTRS (NPIREA),
32923 & SGPIDF (0:20,NPIRTA,NPIREA) , BRREIN (NPIREA),
32924 & SGPIIS (NPIRTA,NPIREA) , BRREOU (NPIREA),
32925 & BRD3OU (2,2,-1:2), BRDEOU (2,-1:2),
32926 & SGABSR (2,2,4) , PRRSDL,
32927 & IPIREA (2,2,3:5) , IPIINE (2,3:5) , NPIRVR ,
32928 & KPIIRE (2,NPIREA), KPIORE (2,NPIREA) ,
32929 & JSTOKP (5), KPTOJS (23), ITTRRS (3:5), LDLRES
32930 COMMON /FKCHPI/ CHPIRE (NPIREA)
32931 DIMENSION SG2BRS (2,2), SGABSW (2,2), SG3BRS (2,2,2)
32932 EQUIVALENCE ( SG2BRS (1,1), SGABSR (1,1,1) )
32933 EQUIVALENCE ( SGABSW (1,1), SGABSR (1,1,2) )
32934 EQUIVALENCE ( SG3BRS (1,1,1), SGABSR (1,1,3) )
32935* (original name: FRBKCM)
32936 PARAMETER ( MXFFBK = 6 )
32937 PARAMETER ( MXZFBK = 9 )
32938 PARAMETER ( MXNFBK = 10 )
32939 PARAMETER ( MXAFBK = 16 )
32940 PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
32941 PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
32942 PARAMETER ( NXAFBK = MXAFBK + 1 )
32943 PARAMETER ( MXPSST = 300 )
32944 PARAMETER ( MXPSFB = 41000 )
32945 LOGICAL LFRMBK, LNCMSS
32946 COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
32947 & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
32948 & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
32949 & IFRBKN (MXPSST), IFRBKZ (MXPSST),
32950 & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
32951 & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
32952 & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
32953 & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
32954 & IFBFRB, NBUFBK, LFRMBK, LNCMSS
32955* (original name: NUCGID,NUCGEO,NUCGE2,NUCPWI,NUCGII)
32956 PARAMETER ( PI = PIPIPI )
32957 PARAMETER ( PISQ = PIPISQ )
32958 PARAMETER ( SKTOHL = 0.5456645846610345D+00 )
32959 PARAMETER ( RZNUCL = 1.12 D+00 )
32960 PARAMETER ( RMSPRO = 0.8 D+00 )
32961 PARAMETER ( R0PROT = RMSPRO / SQRT12 )
32962 PARAMETER ( ARHPRO = 1.D+00 / 8.D+00 / PI / R0PROT / R0PROT
32963 & / R0PROT )
32964 PARAMETER ( RLLE04 = RZNUCL )
32965 PARAMETER ( RLLE16 = RZNUCL )
32966 PARAMETER ( RLGT16 = RZNUCL )
32967 PARAMETER ( RCLE04 = 0.75D+00 / PI / RLLE04 / RLLE04 / RLLE04 )
32968 PARAMETER ( RCLE16 = 0.75D+00 / PI / RLLE16 / RLLE16 / RLLE16 )
32969 PARAMETER ( RCGT16 = 0.75D+00 / PI / RLGT16 / RLGT16 / RLGT16 )
32970 PARAMETER ( SKLE04 = 1.4D+00 )
32971 PARAMETER ( SKLE16 = 1.9D+00 )
32972 PARAMETER ( SKGT16 = 2.4D+00 )
32973 PARAMETER ( HLLE04 = SKTOHL * SKLE04 )
32974 PARAMETER ( HLLE16 = SKTOHL * SKLE16 )
32975 PARAMETER ( HLGT16 = SKTOHL * SKGT16 )
32976 PARAMETER ( ALPHA0 = 0.1D+00 )
32977 PARAMETER ( OMALH0 = 1.D+00 - ALPHA0 )
32978 PARAMETER ( GAMSK0 = 0.9D+00 )
32979 PARAMETER ( OMGAS0 = 1.D+00 - GAMSK0 )
32980 PARAMETER ( POTME0 = 0.6666666666666667D+00 )
32981 PARAMETER ( POTBA0 = 1.D+00 )
32982 PARAMETER ( PNFRAT = 1.533D+00 )
32983 PARAMETER ( RADPIM = 0.035D+00 )
32984 PARAMETER ( RDPMHL = 14.D+00 )
32985 PARAMETER ( APMRST = 4.D+00 / 44.D+00 )
32986 PARAMETER ( APMPRO = 1.D+00 / 6.D+00 )
32987 PARAMETER ( APPPRO = 5.D+00 / 6.D+00 )
32988 PARAMETER ( AP0PFS = 0.5D+00 )
32989 PARAMETER ( AP0PFP = 1.D+00 / 3.D+00 )
32990 PARAMETER ( AP0NFP = 2.D+00 / 3.D+00 )
32991 PARAMETER ( XPAUCO = 1.88495407241652 D+00 )
32992 PARAMETER ( MXSCIN = 50 )
32993 LOGICAL LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH, LNCDCY,
32994 & LNUSCT, LPREEQ, LNPHTC, LNWRAD, LPNRHO, LFTCMP, LFTCAC
32995 COMMON /FKNGID/ RHOTAB (2:260), RHATAB (2:260), ALPTAB (2:260),
32996 & RADTAB (2:260), SKITAB (2:260), HALTAB (2:260),
32997 & SK3TAB (2:260), SK4TAB (2:260), HABTAB (2:260),
32998 & CWSTAB (2:260), EKATAB (2:260), PFATAB (2:260),
32999 & PFRTAB (2:260)
33000 COMMON /FKNGEO/ RADTOT, RADIU1, RADIU0, RAD1O2, SKINDP, HALODP,
33001 & ALPHAL, OMALHL, RADSKN, SKNEFF, CPARWS, RADPRO,
33002 & RADCOR, RADCO2, RADMAX, BIMPTR, RIMPTR, XIMPTR,
33003 & YIMPTR, ZIMPTR, RHOIMT, EKFPRO, PFRPRO, RHOCEN,
33004 & RHOCOR, RHOSKN, EKFCEN (2), PFRCEN (2), EKFBIM,
33005 & PFRBIM, RHOIMP, EKFIMP, PFRIMP, RHOIM2, EKFIM2,
33006 & PFRIM2, RHOIM3, EKFIM3, PFRIM3, VPRWLL, RIMPCT,
33007 & BIMPCT, XIMPCT, YIMPCT, ZIMPCT, RIMPC2, XIMPC2,
33008 & YIMPC2, ZIMPC2, RIMPC3, XIMPC3, YIMPC3, ZIMPC3,
33009 & XBIMPC, YBIMPC, ZBIMPC, CXIMPC, CYIMPC, CZIMPC,
33010 & SQRIMP, SIGMAP, SIGMAN, SIGMAA, RHORED, R0TRAJ,
33011 & R1TRAJ, SBUSED, SBTOT , SBRES , RHOAVE, EKFAVE,
33012 & PFRAVE, AVEBIN, ACOLL , ZCOLL , RADSIG, OPACTY,
33013 & EKECON, PNUCCO, EKEWLL, PPRWLL, PXPROJ, PYPROJ,
33014 & PZPROJ, EKFERM, PNFRMI, PXFERM, PYFERM, PZFERM,
33015 & EKFER2, PNFRM2, PXFER2, PYFER2, PZFER2, EKFER3,
33016 & PNFRM3, PXFER3, PYFER3, PZFER3, RHOMEM, EKFMEM,
33017 & BIMMEM, WLLRED, VPRBIM, POTINC, POTOUT, EEXMIN
33018 COMMON /FKNGE2/ RDTTNC (2), RHONCP (2), RHONC2 (2), RHONC3 (2),
33019 & RHONCT (2), AMOTHR, EKOTHR, AMCREA, EKNCLN,
33020 & EEXDEL, EEXANY, CLMBBR, RDCLMB, BFCLMB, BFCEFF,
33021 & BNPROJ, BNDNUC, DEBRLM, SK4PAR, UBIMPC, VBIMPC,
33022 & WBIMPC, BNDPOT, SIGMAT, SIGABP, SIGABN, WLLRES,
33023 & POTBAR, POTMES, AGEPRI, OPNOPA, ETHRND,
33024 & BNENRG (3), DEFNUC (2), SIGMPR (4), SIGMNU (4),
33025 & SIGPAB (3), SIGNAB (3), HHLP (2), FORTOT (2),
33026 & FPNBLC, DPNBLC, FFTFLG, IFTFLG,
33027 & IPWELL, ITNCMX, KPRIN , NTARGT, KNUCIM, KNUCI2,
33028 & KNUCI3, IEVPRE, ISFCOL, ISFTAR, ISFTA2, ISFTA3,
33029 & NPOTHR, ICOTHR, IBOTHR, NPUMFN, ISTNCL, ITAUCM,
33030 & IABCOU, IADFLG, IGSFLG, IALFLG, ICBFLG, LPREEQ,
33031 & LNPHTC, LPNRHO, LNWRAD, LFTCMP, LFTCAC
33032 COMMON /FKNPWI/ ALMBAR, BIMMAX, SIGGEO, LLLMAX, LLLACT
33033 COMMON /FKNGII/ HOLEXP (2*MXSCIN), XEXPIN (3,0:MXSCIN),
33034 & YEXPIN (3,0:MXSCIN), ZEXPIN (3,0:MXSCIN),
33035 & AGEXIN (0:MXSCIN), RHOEXP (2), EKFEXP, EHLFIX,
33036 & NHLEXP, NHLFIX, IPRTYP, NNCEXI (0:MXSCIN),
33037 & NCEXPI (3,0:MXSCIN), ISEXIN (3,0:MXSCIN),
33038 & ISCTYP (0:MXSCIN), NUSCIN, NEXPEM,
33039 & LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH,
33040 & LNCDCY, LNUSCT
33041 DIMENSION AWSTAB (2:260), SIGMAB (3)
33042 EQUIVALENCE ( DEFPRO, DEFNUC (1) )
33043 EQUIVALENCE ( DEFNEU, DEFNUC (2) )
33044 EQUIVALENCE ( RHOIPP, RHONCP (1) )
33045 EQUIVALENCE ( RHOINP, RHONCP (2) )
33046 EQUIVALENCE ( RHOIP2, RHONC2 (1) )
33047 EQUIVALENCE ( RHOIN2, RHONC2 (2) )
33048 EQUIVALENCE ( RHOIP3, RHONC3 (1) )
33049 EQUIVALENCE ( RHOIN3, RHONC3 (2) )
33050 EQUIVALENCE ( RHOIPT, RHONCT (1) )
33051 EQUIVALENCE ( RHOINT, RHONCT (2) )
33052 EQUIVALENCE ( OMALHL, SK3PAR )
33053 EQUIVALENCE ( ALPHAL, HABPAR )
33054 EQUIVALENCE ( ALPTAB (2), AWSTAB (2) )
33055 EQUIVALENCE ( SIGMPE, SIGMPR (1) )
33056 EQUIVALENCE ( SIGMPC, SIGMPR (2) )
33057 EQUIVALENCE ( SIGMPI, SIGMPR (3) )
33058 EQUIVALENCE ( SIGMPA, SIGMPR (4) )
33059 EQUIVALENCE ( SIGMNE, SIGMNU (1) )
33060 EQUIVALENCE ( SIGMNC, SIGMNU (2) )
33061 EQUIVALENCE ( SIGMNI, SIGMNU (3) )
33062 EQUIVALENCE ( SIGMNA, SIGMNU (4) )
33063 EQUIVALENCE ( SIGMA2, SIGPAB (1) )
33064 EQUIVALENCE ( SIGMA3, SIGPAB (2) )
33065 EQUIVALENCE ( SIGMAS, SIGPAB (3) )
33066 EQUIVALENCE ( SIGPAB (1), SIGMAB (1) )
33067* (original name: NUCLEV)
33068 LOGICAL LCLVSL, LFLVSL, LRLVSL, LEQSBL
33069 COMMON /FKNLEV/ PAENUC (200,2), SHENUC (200,2), DEFRMI (2),
33070 & DEFMAG (2), ENNCLV (160,2), RANCLV (160,2),
33071 & CUMRAD (0:160,2), RUSNUC (2),
33072 & ENPLVL (114), ENNLVL(164), JUSNUC (160,2),
33073 & NTANUC (2), NAVNUC (2), NLSNUC (2), NCONUC (2),
33074 & NSKNUC (2), NHANUC (2), NUSNUC (2), NACNUC (2),
33075 & JMXNUC (2), IPRNUC (3), JPRNUC (3), MAGNUM (8),
33076 & MAGNUC (2), MGSNUC (8,2), MGSSNC (25,2),
33077 & NSBSHL (2), NMNSBS (2), NPRNUC, INUCLV, LCLVSL,
33078 & LFLVSL, LRLVSL, LEQSBL
33079 DIMENSION JUSPRO (160), JUSNEU (160), MGSPRO (8), MGSNEU (8),
33080 & MGSSPR (19) , MGSSNE (25)
33081 EQUIVALENCE ( RUSNUC (1), RUSPRO )
33082 EQUIVALENCE ( RUSNUC (2), RUSNEU )
33083 EQUIVALENCE ( JUSNUC (1,1), JUSPRO (1) )
33084 EQUIVALENCE ( JUSNUC (1,2), JUSNEU (1) )
33085 EQUIVALENCE ( MGSNUC (1,1), MGSPRO (1) )
33086 EQUIVALENCE ( MGSNUC (1,2), MGSNEU (1) )
33087 EQUIVALENCE ( MGSSNC (1,1), MGSSPR (1) )
33088 EQUIVALENCE ( MGSSNC (1,2), MGSSNE (1) )
33089 EQUIVALENCE ( NTANUC (1), NTAPRO )
33090 EQUIVALENCE ( NTANUC (2), NTANEU )
33091 EQUIVALENCE ( NAVNUC (1), NAVPRO )
33092 EQUIVALENCE ( NAVNUC (2), NAVNEU )
33093 EQUIVALENCE ( NLSNUC (1), NLSPRO )
33094 EQUIVALENCE ( NLSNUC (2), NLSNEU )
33095 EQUIVALENCE ( NCONUC (1), NCOPRO )
33096 EQUIVALENCE ( NCONUC (2), NCONEU )
33097 EQUIVALENCE ( NSKNUC (1), NSKPRO )
33098 EQUIVALENCE ( NSKNUC (2), NSKNEU )
33099 EQUIVALENCE ( NHANUC (1), NHAPRO )
33100 EQUIVALENCE ( NHANUC (2), NHANEU )
33101 EQUIVALENCE ( NUSNUC (1), NUSPRO )
33102 EQUIVALENCE ( NUSNUC (2), NUSNEU )
33103 EQUIVALENCE ( NACNUC (1), NACPRO )
33104 EQUIVALENCE ( NACNUC (2), NACNEU )
33105 EQUIVALENCE ( JMXNUC (1), JMXPRO )
33106 EQUIVALENCE ( JMXNUC (2), JMXNEU )
33107 EQUIVALENCE ( MAGNUC (1), MAGPRO )
33108 EQUIVALENCE ( MAGNUC (2), MAGNEU )
33109* (original name: PARNUC)
33110 PARAMETER ( PIGRK = PIPIPI )
33111 PARAMETER ( ALEVEL = 8.D-03 )
33112 PARAMETER ( RCNUCL = 1.12D+00 )
33113 PARAMETER ( R0SIG = 1.3D+00 )
33114 PARAMETER ( R0SIGK = 1.5D+00 )
33115 PARAMETER ( RCOULB = 1.5D+00 )
33116 PARAMETER ( COULBH = 0.88235D-03 )
33117 PARAMETER ( RHONU0 = 0.75D+00 / PIGRK / RCNUCL / RCNUCL / RCNUCL )
33118 PARAMETER ( TAUFO0 = 10.0D+00 )
33119 PARAMETER ( EKEEXP = 0.03D+00 )
33120 PARAMETER ( EKREXP = 0.05D+00 )
33121 PARAMETER ( EKEMNM = 0.01D+00 )
33122 PARAMETER ( NCPMX = 120 )
33123 COMMON /FKPARN/ EKORI , PXORI , PYORI , PZORI , PTORI , TAUFOR,
33124 & ENNUC (NCPMX), PNUCL (NCPMX), EKFNUC (NCPMX),
33125 & XSTNUC (NCPMX), YSTNUC (NCPMX), ZSTNUC (NCPMX),
33126 & PXNUCL (NCPMX), PYNUCL (NCPMX), PZNUCL (NCPMX),
33127 & RSTNUC (NCPMX), FREEPA (NCPMX), CRRPAN (NCPMX),
33128 & CRRPAP (NCPMX), BSTNUC (NCPMX), AGENUC (NCPMX),
33129 & TAUFPA (NCPMX), RHNUCL(NCPMX,2), BNDGAV, DEFMIN,
33130 & KPNUCL (NCPMX), KRFNUC (NCPMX), ILINUC (NCPMX),
33131 & INUCTS (NCPMX), ISFNUC (NCPMX), KPORI , IBORI ,
33132 & IBNUCL, NPNUC , NNUCTS
33133*
33134 DATA LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH / 6*.FALSE. /
33135 DATA POTBAR / POTBA0 /, POTMES / POTME0 /, WLLRES / 0.D+00 /
33136 DATA JUSNUC / 320 * 0 /, INUCLV / 1 /, IEVPRE / 0 /
33137 DATA MAGNUM / 2, 8, 20, 28, 50, 82, 126, 160 /
33138 DATA LPREEQ / .FALSE. /
33139* /cmpisg/
33140 DATA JSTOKP / 1, 8, 13, 14, 23 /
33141 DATA KPTOJS / 1, 6*0, 2, 4*0, 3, 4, 8*0, 5 /
33142 DATA CHPIRE / 'PI+PPI+P','PI-PPI-P','PI-PPI0N','PI0PPI0P',
33143 & 'PI0PPI+N','PI-NPI-N','PI+NPI+N','PI+NPI0P',
33144 & 'PI0NPI0N','PI0NPI-P' /
33145 DATA KPIIRE / 13, 1, 14, 1, 14, 1, 23, 1, 23, 1, 14, 8,
33146 & 13, 8, 13, 8, 23, 8, 23, 8 /
33147 DATA KPIORE / 13, 1, 14, 1, 23, 8, 23, 1, 13, 8, 14, 8,
33148 & 13, 8, 23, 1, 23, 8, 14, 1 /
33149 DATA IPIREA / 1, 0, 7, 8, 2, 3, 6, 0, 4, 5, 9, 10 /
33150 DATA IPIINE / 1, 2, 3, 4, 5, 6 /
33151* /frbkcm/
33152 DATA LFRMBK / .FALSE. /
33153 DATA NBUFBK / 500 /
33154 DATA EXMXFB / 80.0 D+00 /
33155 DATA R0FRBK / 1.18 D+00 /
33156 DATA R0CFBK / 2.173D+00 /
33157 DATA C1CFBK / 6.103D-03 /
33158 DATA C2CFBK / 9.443D-03 /
33159* /parnuc/
33160 DATA TAUFOR / TAUFO0 /
33161*=== End of Block Data Bdpree =========================================*
33162 END
33163
33164*$ CREATE DT_XHOINI.FOR
33165*COPY DT_XHOINI
33166*
33167*====phoini============================================================*
33168*
33169 SUBROUTINE DT_XHOINI
33170C SUBROUTINE DT_PHOINI
33171
33172 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33173 SAVE
33174 PARAMETER ( LINP = 10 ,
33175 & LOUT = 6 ,
33176 & LDAT = 9 )
33177
33178 RETURN
33179 END
33180
33181*$ CREATE DT_XVENTB.FOR
33182*COPY DT_XVENTB
33183*
33184*====eventb============================================================*
33185*
33186 SUBROUTINE DT_XVENTB(NCSY,IREJ)
33187C SUBROUTINE DT_EVENTB(NCSY,IREJ)
33188
33189 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33190 SAVE
33191 PARAMETER ( LINP = 10 ,
33192 & LOUT = 6 ,
33193 & LDAT = 9 )
33194
33195 WRITE(LOUT,1000)
33196 1000 FORMAT(1X,'EVENTB: PHOJET-package requested but not linked!')
33197 STOP
33198
33199 END
33200
33201*$ CREATE DT_XVENT.FOR
33202*COPY DT_XVENT
33203*
33204*===event==============================================================*
33205*
33206 SUBROUTINE DT_XVENT(IDUM,PP,PT,DUM,IREJ)
33207C SUBROUTINE EVENT(IDUM,PP,PT,DUM,IREJ)
33208
33209 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33210 SAVE
33211
33212 DIMENSION PP(4),PT(4)
33213
33214 RETURN
33215 END
33216
33217*$ CREATE DT_XOHISX.FOR
33218*COPY DT_XOHISX
33219*
33220*===pohisx=============================================================*
33221*
33222 SUBROUTINE DT_XOHISX(I,X)
33223C SUBROUTINE POHISX(I,X)
33224
33225 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33226 SAVE
33227
33228 RETURN
33229 END
33230
33231*$ CREATE PHO_LHIST.FOR
33232*COPY PHO_LHIST
33233*
33234*===poluhi=============================================================*
33235*
33236 SUBROUTINE PHO_LHIST(I,X)
33237**
33238
33239 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33240 SAVE
33241
33242 RETURN
33243 END
33244
33245*$ CREATE PDFSET.FOR
33246*COPY PDFSET
33247*
33248C**********************************************************************
33249C
33250C dummy subroutines, remove to link PDFLIB
33251C
33252C**********************************************************************
33253 SUBROUTINE PDFSET(PARAM,VALUE)
33254 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33255 DIMENSION PARAM(20),VALUE(20)
33256 CHARACTER*20 PARAM
33257 END
33258
33259*$ CREATE STRUCTM.FOR
33260*COPY STRUCTM
33261*
33262 SUBROUTINE STRUCTM(XI,SCALE2,UV,DV,US,DS,SS,CS,BS,TS,GL)
33263 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33264 END
33265
33266*$ CREATE STRUCTP.FOR
33267*COPY STRUCTP
33268*
33269 SUBROUTINE STRUCTP(XI,SCALE2,P2,IP2,UV,DV,US,DS,SS,CS,BS,TS,GL)
33270 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33271 END
33272
33273*$ CREATE DT_DIQBRK.FOR
33274*COPY DT_DIQBRK
33275*
33276*===diqbrk=============================================================*
33277*
33278 SUBROUTINE DT_XIQBRK
33279C SUBROUTINE DT_DIQBRK
33280
33281 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33282 SAVE
33283
33284 STOP 'diquark-breaking not implemeted !'
33285
33286 RETURN
33287 END
33288
33289*$ CREATE DT_ELHAIN.FOR
33290*COPY DT_ELHAIN
33291*
33292*===elhain=============================================================*
33293*
33294 SUBROUTINE DT_ELHAIN(IP,PLA,ELAB,CX,CY,CZ,IT,IREJ)
33295
33296************************************************************************
33297* Elastic hadron-hadron scattering. *
33298* This is a revised version of the original. *
33299* This version dated 03.04.98 is written by S. Roesler *
33300************************************************************************
33301
33302 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33303 SAVE
33304 PARAMETER ( LINP = 10 ,
33305 & LOUT = 6 ,
33306 & LDAT = 9 )
33307 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
33308 & TINY10=1.0D-10)
33309
33310 PARAMETER (ENNTHR = 3.5D0)
33311 PARAMETER (PLOWH=0.01D0,PHIH=9.0D0,
33312 & BLOWB=0.05D0,BHIB=0.2D0,
33313 & BLOWM=0.1D0, BHIM=2.0D0)
33314
33315* particle properties (BAMJET index convention)
33316 CHARACTER*8 ANAME
33317 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
33318 & IICH(210),IIBAR(210),K1(210),K2(210)
33319* final state from HADRIN interaction
33320 PARAMETER (MAXFIN=10)
33321 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
33322 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
33323
33324C DATA TSLOPE /10.0D0/
33325
33326 IREJ = 0
33327
33328 1 CONTINUE
33329
33330 PLAB = SQRT( (ELAB-AAM(IP))*(ELAB+AAM(IP)) )
33331 EKIN = ELAB-AAM(IP)
33332* kinematical quantities in cms of the hadrons
33333 AMP2 = AAM(IP)**2
33334 AMT2 = AAM(IT)**2
33335 S = AMP2+AMT2+TWO*ELAB*AAM(IT)
33336 ECM = SQRT(S)
33337 ECMP = OHALF*ECM+(AMP2-AMT2)/(TWO*ECM)
33338 PCM = SQRT( (ECMP-AAM(IP))*(ECMP+AAM(IP)) )
33339
33340* nucleon-nucleon scattering at E_kin<3.5: use DT_TSAMCS(HETC-KFA)
33341 IF ( ((IP.EQ.1).OR.(IP.EQ.8)).AND.
33342 & ((IT.EQ.1).OR.(IT.EQ.8)).AND.(EKIN.LT.ENNTHR) ) THEN
33343* TSAMCS treats pp and np only, therefore change pn into np and
33344* nn into pp
33345 IF (IT.EQ.1) THEN
33346 KPROJ = IP
33347 ELSE
33348 KPROJ = 8
33349 IF (IP.EQ.8) KPROJ = 1
33350 ENDIF
33351 CALL DT_TSAMCS(KPROJ,EKIN,CTCMS)
33352 T = TWO*PCM**2*(CTCMS-ONE)
33353
33354* very crude treatment otherwise: sample t from exponential dist.
33355 ELSE
33356* momentum transfer t
33357 TMAX = TWO*TWO*PCM**2
33358 RR = (PLAB-PLOWH)/(PHIH-PLOWH)
33359 IF (IIBAR(IP).NE.0) THEN
33360 TSLOPE = BLOWB+RR*(BHIB-BLOWB)
33361 ELSE
33362 TSLOPE = BLOWM+RR*(BHIM-BLOWM)
33363 ENDIF
33364 FMAX = EXP(-TSLOPE*TMAX)-ONE
33365 R = DT_RNDM(RR)
33366 T = LOG(ONE+R*FMAX+TINY10)/TSLOPE
33367 IF (T.GT.ZERO) T = LOG(ONE+R*FMAX)/TSLOPE
33368 ENDIF
33369
33370* target hadron in Lab after scattering
33371 ELRH(2) = (TWO*AMT2-T)/(TWO*AAM(IT))
33372 PLRH(2) = SQRT( ABS(ELRH(2)-AAM(IT))*(ELRH(2)+AAM(IT)) )
33373 IF (PLRH(2).LE.TINY10) THEN
33374C WRITE(*,*)'ELHAIN: T,PLRH(2) ',T,PLRH(2)
33375 GOTO 1
33376 ENDIF
33377* projectile hadron in Lab after scattering
33378 ELRH(1) = ELAB+AAM(IT)-ELRH(2)
33379 PLRH(1) = SQRT( ABS(ELRH(1)-AAM(IP))*(ELRH(1)+AAM(IP)) )
33380* scattering angle of projectile in Lab
33381 CTLABP = (T-TWO*AMP2+TWO*ELAB*ELRH(1))/(TWO*PLAB*PLRH(1))
33382 STLABP = SQRT( (ONE-CTLABP)*(ONE+CTLABP) )
33383 CALL DT_DSFECF(SPLABP,CPLABP)
33384* direction cosines of projectile in Lab
33385 CALL DT_STTRAN(CX,CY,CZ,CTLABP,STLABP,SPLABP,CPLABP,
33386 & CXRH(1),CYRH(1),CZRH(1))
33387* scattering angle of target in Lab
33388 PLLABT = PLAB-CTLABP*PLRH(1)
33389 CTLABT = PLLABT/PLRH(2)
33390 STLABT = SQRT( (ONE-CTLABT)*(ONE+CTLABT) )
33391* direction cosines of target in Lab
33392 CALL DT_STTRAN(CX,CY,CZ,CTLABT,STLABT,-SPLABP,-CPLABP,
33393 & CXRH(2),CYRH(2),CZRH(2))
33394* fill /HNFSPA/
33395 IRH = 2
33396 ITRH(1) = IP
33397 ITRH(2) = IT
33398
33399 RETURN
33400 END
33401
33402*$ CREATE DT_TSAMCS.FOR
33403*COPY DT_TSAMCS
33404*
33405*===tsamcs=============================================================*
33406*
33407 SUBROUTINE DT_TSAMCS(KPROJ,EKIN,CST)
33408
33409************************************************************************
33410* Sampling of cos(theta) for nucleon-proton scattering according to *
33411* hetkfa2/bertini parametrization. *
33412* This is a revised version of the original (HJM 24/10/88) *
33413* This version dated 28.10.95 is written by S. Roesler *
33414************************************************************************
33415
33416 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33417 SAVE
33418 PARAMETER ( LINP = 10 ,
33419 & LOUT = 6 ,
33420 & LDAT = 9 )
33421 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
33422 & TINY10=1.0D-10)
33423
33424 DIMENSION DCLIN(195),DCHN(143),DCHNA(36),DCHNB(60)
33425 DIMENSION PDCI(60),PDCH(55)
33426
33427 DATA (DCLIN(I),I=1,80) /
33428 & 5.000D-01, 1.000D+00, 0.000D+00, 1.000D+00, 0.000D+00,
33429 & 4.993D-01, 9.881D-01, 5.963D-02, 9.851D-01, 5.945D-02,
33430 & 4.936D-01, 8.955D-01, 5.224D-01, 8.727D-01, 5.091D-01,
33431 & 4.889D-01, 8.228D-01, 8.859D-01, 7.871D-01, 8.518D-01,
33432 & 4.874D-01, 7.580D-01, 1.210D+00, 7.207D-01, 1.117D+00,
33433 & 4.912D-01, 6.969D-01, 1.516D+00, 6.728D-01, 1.309D+00,
33434 & 5.075D-01, 6.471D-01, 1.765D+00, 6.667D-01, 1.333D+00,
33435 & 5.383D-01, 6.054D-01, 1.973D+00, 7.059D-01, 1.176D+00,
33436 & 5.397D-01, 5.990D-01, 2.005D+00, 7.023D-01, 1.191D+00,
33437 & 5.336D-01, 6.083D-01, 1.958D+00, 6.959D-01, 1.216D+00,
33438 & 5.317D-01, 6.075D-01, 1.962D+00, 6.897D-01, 1.241D+00,
33439 & 5.300D-01, 6.016D-01, 1.992D+00, 6.786D-01, 1.286D+00,
33440 & 5.281D-01, 6.063D-01, 1.969D+00, 6.786D-01, 1.286D+00,
33441 & 5.280D-01, 5.960D-01, 2.020D+00, 6.667D-01, 1.333D+00,
33442 & 5.273D-01, 5.920D-01, 2.040D+00, 6.604D-01, 1.358D+00,
33443 & 5.273D-01, 5.862D-01, 2.069D+00, 6.538D-01, 1.385D+00/
33444 DATA (DCLIN(I),I=81,160) /
33445 & 5.223D-01, 5.980D-01, 2.814D+00, 6.538D-01, 1.385D+00,
33446 & 5.202D-01, 5.969D-01, 2.822D+00, 6.471D-01, 1.412D+00,
33447 & 5.183D-01, 5.881D-01, 2.883D+00, 6.327D-01, 1.469D+00,
33448 & 5.159D-01, 5.866D-01, 2.894D+00, 6.250D-01, 1.500D+00,
33449 & 5.133D-01, 5.850D-01, 2.905D+00, 6.170D-01, 1.532D+00,
33450 & 5.106D-01, 5.833D-01, 2.917D+00, 6.087D-01, 1.565D+00,
33451 & 5.084D-01, 5.801D-01, 2.939D+00, 6.000D-01, 1.600D+00,
33452 & 5.063D-01, 5.763D-01, 2.966D+00, 5.909D-01, 1.636D+00,
33453 & 5.036D-01, 5.730D-01, 2.989D+00, 5.814D-01, 1.674D+00,
33454 & 5.014D-01, 5.683D-01, 3.022D+00, 5.714D-01, 1.714D+00,
33455 & 4.986D-01, 5.641D-01, 3.051D+00, 5.610D-01, 1.756D+00,
33456 & 4.964D-01, 5.580D-01, 3.094D+00, 5.500D-01, 1.800D+00,
33457 & 4.936D-01, 5.573D-01, 3.099D+00, 5.431D-01, 1.827D+00,
33458 & 4.909D-01, 5.509D-01, 3.144D+00, 5.313D-01, 1.875D+00,
33459 & 4.885D-01, 5.512D-01, 3.142D+00, 5.263D-01, 1.895D+00,
33460 & 4.857D-01, 5.437D-01, 3.194D+00, 5.135D-01, 1.946D+00/
33461 DATA (DCLIN(I),I=161,195) /
33462 & 4.830D-01, 5.353D-01, 3.253D+00, 5.000D-01, 2.000D+00,
33463 & 4.801D-01, 5.323D-01, 3.274D+00, 4.915D-01, 2.034D+00,
33464 & 4.770D-01, 5.228D-01, 3.341D+00, 4.767D-01, 2.093D+00,
33465 & 4.738D-01, 5.156D-01, 3.391D+00, 4.643D-01, 2.143D+00,
33466 & 4.701D-01, 5.010D-01, 3.493D+00, 4.444D-01, 2.222D+00,
33467 & 4.672D-01, 4.990D-01, 3.507D+00, 4.375D-01, 2.250D+00,
33468 & 4.634D-01, 4.856D-01, 3.601D+00, 4.194D-01, 2.323D+00/
33469
33470 DATA PDCI /
33471 & 4.400D+02, 1.896D-01, 1.931D-01, 1.982D-01, 1.015D-01,
33472 & 1.029D-01, 4.180D-02, 4.228D-02, 4.282D-02, 4.350D-02,
33473 & 2.204D-02, 2.236D-02, 5.900D+02, 1.433D-01, 1.555D-01,
33474 & 1.774D-01, 1.000D-01, 1.128D-01, 5.132D-02, 5.600D-02,
33475 & 6.158D-02, 6.796D-02, 3.660D-02, 3.820D-02, 6.500D+02,
33476 & 1.192D-01, 1.334D-01, 1.620D-01, 9.527D-02, 1.141D-01,
33477 & 5.283D-02, 5.952D-02, 6.765D-02, 7.878D-02, 4.796D-02,
33478 & 6.957D-02, 8.000D+02, 4.872D-02, 6.694D-02, 1.152D-01,
33479 & 9.348D-02, 1.368D-01, 6.912D-02, 7.953D-02, 9.577D-02,
33480 & 1.222D-01, 7.755D-02, 9.525D-02, 1.000D+03, 3.997D-02,
33481 & 5.456D-02, 9.804D-02, 8.084D-02, 1.208D-01, 6.520D-02,
33482 & 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02, 1.093D-01/
33483
33484 DATA PDCH /
33485 & 1.000D+03, 9.453D-02, 9.804D-02, 8.084D-02, 1.208D-01,
33486 & 6.520D-02, 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02,
33487 & 1.093D-01, 1.400D+03, 1.072D-01, 7.450D-02, 6.645D-02,
33488 & 1.136D-01, 6.750D-02, 8.580D-02, 1.110D-01, 1.530D-01,
33489 & 1.010D-01, 1.350D-01, 2.170D+03, 4.004D-02, 3.013D-02,
33490 & 2.664D-02, 5.511D-02, 4.240D-02, 7.660D-02, 1.364D-01,
33491 & 2.300D-01, 1.670D-01, 2.010D-01, 2.900D+03, 1.870D-02,
33492 & 1.804D-02, 1.320D-02, 2.970D-02, 2.860D-02, 5.160D-02,
33493 & 1.020D-01, 2.400D-01, 2.250D-01, 3.370D-01, 4.400D+03,
33494 & 1.196D-03, 8.784D-03, 1.517D-02, 2.874D-02, 2.488D-02,
33495 & 4.464D-02, 8.330D-02, 2.008D-01, 2.360D-01, 3.567D-01/
33496
33497 DATA (DCHN(I),I=1,90) /
33498 & 4.770D-01, 4.750D-01, 4.715D-01, 4.685D-01, 4.650D-01,
33499 & 4.610D-01, 4.570D-01, 4.550D-01, 4.500D-01, 4.450D-01,
33500 & 4.405D-01, 4.350D-01, 4.300D-01, 4.250D-01, 4.200D-01,
33501 & 4.130D-01, 4.060D-01, 4.000D-01, 3.915D-01, 3.840D-01,
33502 & 3.760D-01, 3.675D-01, 3.580D-01, 3.500D-01, 3.400D-01,
33503 & 3.300D-01, 3.200D-01, 3.100D-01, 3.000D-01, 2.900D-01,
33504 & 2.800D-01, 2.700D-01, 2.600D-01, 2.500D-01, 2.400D-01,
33505 & 2.315D-01, 2.240D-01, 2.150D-01, 2.060D-01, 2.000D-01,
33506 & 1.915D-01, 1.850D-01, 1.780D-01, 1.720D-01, 1.660D-01,
33507 & 1.600D-01, 1.550D-01, 1.500D-01, 1.450D-01, 1.400D-01,
33508 & 1.360D-01, 1.320D-01, 1.280D-01, 1.250D-01, 1.210D-01,
33509 & 1.180D-01, 1.150D-01, 1.120D-01, 1.100D-01, 1.070D-01,
33510 & 1.050D-01, 1.030D-01, 1.010D-01, 9.900D-02, 9.700D-02,
33511 & 9.550D-02, 9.480D-02, 9.400D-02, 9.200D-02, 9.150D-02,
33512 & 9.100D-02, 9.000D-02, 8.990D-02, 8.900D-02, 8.850D-02,
33513 & 8.750D-02, 8.700D-02, 8.650D-02, 8.550D-02, 8.500D-02,
33514 & 8.499D-02, 8.450D-02, 8.350D-02, 8.300D-02, 8.250D-02,
33515 & 8.150D-02, 8.100D-02, 8.030D-02, 8.000D-02, 7.990D-02/
33516 DATA (DCHN(I),I=91,143) /
33517 & 7.980D-02, 7.950D-02, 7.900D-02, 7.860D-02, 7.800D-02,
33518 & 7.750D-02, 7.650D-02, 7.620D-02, 7.600D-02, 7.550D-02,
33519 & 7.530D-02, 7.500D-02, 7.499D-02, 7.498D-02, 7.480D-02,
33520 & 7.450D-02, 7.400D-02, 7.350D-02, 7.300D-02, 7.250D-02,
33521 & 7.230D-02, 7.200D-02, 7.100D-02, 7.050D-02, 7.020D-02,
33522 & 7.000D-02, 6.999D-02, 6.995D-02, 6.993D-02, 6.991D-02,
33523 & 6.990D-02, 6.870D-02, 6.850D-02, 6.800D-02, 6.780D-02,
33524 & 6.750D-02, 6.700D-02, 6.650D-02, 6.630D-02, 6.600D-02,
33525 & 6.550D-02, 6.525D-02, 6.510D-02, 6.500D-02, 6.499D-02,
33526 & 6.498D-02, 6.496D-02, 6.494D-02, 6.493D-02, 6.490D-02,
33527 & 6.488D-02, 6.485D-02, 6.480D-02/
33528
33529 DATA DCHNA /
33530 & 6.300D+02, 7.810D-02, 1.421D-01, 1.979D-01, 2.479D-01,
33531 & 3.360D-01, 5.400D-01, 7.236D-01, 1.000D+00, 1.540D+03,
33532 & 2.225D-01, 3.950D-01, 5.279D-01, 6.298D-01, 7.718D-01,
33533 & 9.405D-01, 9.835D-01, 1.000D+00, 2.560D+03, 2.625D-01,
33534 & 4.550D-01, 5.963D-01, 7.020D-01, 8.380D-01, 9.603D-01,
33535 & 9.903D-01, 1.000D+00, 3.520D+03, 4.250D-01, 6.875D-01,
33536 & 8.363D-01, 9.163D-01, 9.828D-01, 1.000D+00, 1.000D+00,
33537 & 1.000D+00/
33538
33539 DATA DCHNB /
33540 & 6.300D+02, 3.800D-02, 7.164D-02, 1.275D-01, 2.171D-01,
33541 & 3.227D-01, 4.091D-01, 5.051D-01, 6.061D-01, 7.074D-01,
33542 & 8.434D-01, 1.000D+00, 2.040D+03, 1.200D-01, 2.115D-01,
33543 & 3.395D-01, 5.295D-01, 7.251D-01, 8.511D-01, 9.487D-01,
33544 & 9.987D-01, 1.000D+00, 1.000D+00, 1.000D+00, 2.200D+03,
33545 & 1.344D-01, 2.324D-01, 3.754D-01, 5.674D-01, 7.624D-01,
33546 & 8.896D-01, 9.808D-01, 1.000D+00, 1.000D+00, 1.000D+00,
33547 & 1.000D+00, 2.850D+03, 2.330D-01, 4.130D-01, 6.610D-01,
33548 & 9.010D-01, 9.970D-01, 1.000D+00, 1.000D+00, 1.000D+00,
33549 & 1.000D+00, 1.000D+00, 1.000D+00, 3.500D+03, 3.300D-01,
33550 & 5.450D-01, 7.950D-01, 1.000D+00, 1.000D+00, 1.000D+00,
33551 & 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00/
33552
33553 CST = ONE
33554 IF (EKIN.GT.3.5D0) RETURN
33555C
33556 IF(KPROJ.EQ.8) GOTO 101
33557 IF(KPROJ.EQ.1) GOTO 102
33558C* INVALID REACTION
33559 WRITE(LOUT,'(A,I5/A)')
33560 & ' INVALID PARTICLE TYPE IN DNUPRE - KPROJ=',KPROJ,
33561 & ' COS(THETA) = 1D0 RETURNED'
33562 RETURN
33563C-------------------------------- NP ELASTIC SCATTERING----------
33564101 CONTINUE
33565 IF (EKIN.GT.0.740D0)GOTO 1000
33566 IF (EKIN.LT.0.300D0)THEN
33567C EKIN .LT. 300 MEV
33568 IDAT=1
33569 ELSE
33570C 300 MEV < EKIN < 740 MEV
33571 IDAT=6
33572 END IF
33573C
33574 ENER=EKIN
33575 IE=INT(ABS(ENER/0.020D0))
33576 UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
33577C FORWARD/BACKWARD DECISION
33578 K=IDAT+5*IE
33579 BWFW=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
33580 IF (DT_RNDM(CST).LT.BWFW)THEN
33581 VALUE2=-1D0
33582 K=K+1
33583 ELSE
33584 VALUE2=1D0
33585 K=K+3
33586 END IF
33587C
33588 COEF=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
33589 RND=DT_RNDM(COEF)
33590C
33591 IF(RND.LT.COEF)THEN
33592 CST=DT_RNDM(RND)
33593 CST=CST*VALUE2
33594 ELSE
33595 R1=DT_RNDM(CST)
33596 R2=DT_RNDM(R1)
33597 R3=DT_RNDM(R2)
33598 R4=DT_RNDM(R3)
33599C
33600 IF(VALUE2.GT.0.0)THEN
33601 CST=MAX(R1,R2,R3,R4)
33602 GOTO 1500
33603 ELSE
33604 R5=DT_RNDM(R4)
33605C
33606 IF (IDAT.EQ.1)THEN
33607 CST=-MAX(R1,R2,R3,R4,R5)
33608 ELSE
33609 R6=DT_RNDM(R5)
33610 R7=DT_RNDM(R6)
33611 CST=-MAX(R1,R2,R3,R4,R5,R6,R7)
33612 END IF
33613C
33614 END IF
33615C
33616 END IF
33617C
33618 GOTO 1500
33619C
33620C******** EKIN .GT. 0.74 GEV
33621C
336221000 ENER=EKIN - 0.66D0
33623C IE=ABS(ENER/0.02)
33624 IE=INT(ENER/0.02D0)
33625 EMEV=EKIN*1D3
33626C
33627 UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
33628 K=IE
33629 BWFW=(DCHN(K+1)-DCHN(K))*UNIV + DCHN(K)
33630 RND=DT_RNDM(BWFW)
33631C FORWARD NEUTRON
33632 IF (RND.GE.BWFW)THEN
33633 DO 1200 K=10,36,9
33634 IF (DCHNA(K).GT.EMEV) THEN
33635 UNIVE=(EMEV-DCHNA(K-9))/(DCHNA(K)-DCHNA(K-9))
33636 UNIV=DT_RNDM(UNIVE)
33637 DO 1100 I=1,8
33638 II=K+I
33639 P=(DCHNA(II)-DCHNA(II-9))*UNIVE + DCHNA(II-9)
33640C
33641 IF (P.GT.UNIV)THEN
33642 UNIV=DT_RNDM(UNIVE)
33643 FLTI=DBLE(I)-UNIV
33644 GOTO(290,290,290,290,330,340,350,360) I
33645 END IF
33646 1100 CONTINUE
33647 END IF
33648 1200 CONTINUE
33649C
33650 ELSE
33651C BACKWARD NEUTRON
33652 DO 1400 K=13,60,12
33653 IF (DCHNB(K).GT.EMEV) THEN
33654 UNIVE=(EMEV-DCHNB(K-12))/(DCHNB(K)-DCHNB(K-12))
33655 UNIV=DT_RNDM(UNIVE)
33656 DO 1300 I=1,11
33657 II=K+I
33658 P=(DCHNB(II)-DCHNB(II-12))*UNIVE + DCHNB(II-12)
33659C
33660 IF (P.GT.UNIV)THEN
33661 UNIV=DT_RNDM(P)
33662 FLTI=DBLE(I)-UNIV
33663 GOTO(120,120,140,150,160,160,180,190,200,210,220) I
33664 END IF
33665 1300 CONTINUE
33666 END IF
33667 1400 CONTINUE
33668 END IF
33669C
33670120 CST=1.0D-2*FLTI-1.0D0
33671 GOTO 1500
33672140 CST=2.0D-2*UNIV-0.98D0
33673 GOTO 1500
33674150 CST=4.0D-2*UNIV-0.96D0
33675 GOTO 1500
33676160 CST=6.0D-2*FLTI-1.16D0
33677 GOTO 1500
33678180 CST=8.0D-2*UNIV-0.80D0
33679 GOTO 1500
33680190 CST=1.0D-1*UNIV-0.72D0
33681 GOTO 1500
33682200 CST=1.2D-1*UNIV-0.62D0
33683 GOTO 1500
33684210 CST=2.0D-1*UNIV-0.50D0
33685 GOTO 1500
33686220 CST=3.0D-1*(UNIV-1.0D0)
33687 GOTO 1500
33688C
33689290 CST=1.0D0-2.5d-2*FLTI
33690 GOTO 1500
33691330 CST=0.85D0+0.5D-1*UNIV
33692 GOTO 1500
33693340 CST=0.70D0+1.5D-1*UNIV
33694 GOTO 1500
33695350 CST=0.50D0+2.0D-1*UNIV
33696 GOTO 1500
33697360 CST=0.50D0*UNIV
33698C
336991500 RETURN
33700C
33701C----------------------------------- PP ELASTIC SCATTERING -------
33702C
33703 102 CONTINUE
33704 EMEV=EKIN*1D3
33705C
33706 IF (EKIN.LE.0.500D0) THEN
33707 RND=DT_RNDM(EMEV)
33708 CST=2.0D0*RND-1.0D0
33709 RETURN
33710C
33711 ELSEIF (EKIN.LT.1.0D0) THEN
33712 DO 2200 K=13,60,12
33713 IF (PDCI(K).GT.EMEV) THEN
33714 UNIVE=(EMEV-PDCI(K-12))/(PDCI(K)-PDCI(K-12))
33715 UNIV=DT_RNDM(UNIVE)
33716 SUM=0
33717 DO 2100 I=1,11
33718 II=K+I
33719 SUM=SUM + (PDCI(II)-PDCI(II-12))*UNIVE + PDCI(II-12)
33720C
33721 IF (UNIV.LT.SUM)THEN
33722 UNIV=DT_RNDM(SUM)
33723 FLTI=DBLE(I)-UNIV
33724 GOTO(55,55,55,60,60,65,65,65,65,70,70) I
33725 END IF
33726 2100 CONTINUE
33727 END IF
33728 2200 CONTINUE
33729 ELSE
33730 DO 2400 K=12,55,11
33731 IF (PDCH(K).GT.EMEV) THEN
33732 UNIVE=(EMEV-PDCH(K-11))/(PDCH(K)-PDCH(K-11))
33733 UNIV=DT_RNDM(UNIVE)
33734 SUM=0.0D0
33735 DO 2300 I=1,10
33736 II=K+I
33737 SUM=SUM + (PDCH(II)-PDCH(II-11))*UNIVE + PDCH(II-11)
33738C
33739 IF (UNIV.LT.SUM)THEN
33740 UNIV=DT_RNDM(SUM)
33741 FLTI=UNIV+DBLE(I)
33742 GOTO(50,55,60,60,65,65,65,65,70,70) I
33743 END IF
33744 2300 CONTINUE
33745 END IF
33746 2400 CONTINUE
33747 END IF
33748C
3374950 CST=0.4D0*UNIV
33750 GOTO 2500
3375155 CST=0.2D0*FLTI
33752 GOTO 2500
3375360 CST=0.3D0+0.1D0*FLTI
33754 GOTO 2500
3375565 CST=0.6D0+0.04D0*FLTI
33756 GOTO 2500
3375770 CST=0.78D0+0.02D0*FLTI
33758C
337592500 CONTINUE
33760 IF (DT_RNDM(CST).GT.0.5D0) CST=-CST
33761C
33762 RETURN
33763 END
33764
33765*$ CREATE DT_DHADRI.FOR
33766*COPY DT_DHADRI
33767*
33768*===dhadri=============================================================*
33769*
33770 SUBROUTINE DT_DHADRI(N,PLAB,ELAB,CX,CY,CZ,ITTA)
33771
33772 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33773 SAVE
33774
33775 PARAMETER ( LINP = 10 ,
33776 & LOUT = 6 ,
33777 & LDAT = 9 )
33778C
33779C-----------------------------
33780C*** INPUT VARIABLES LIST:
33781C*** SAMPLING OF HADRON NUCLEON INTERACTION FOR (ABOUT) 0.1 LE PLAB LE 6
33782C*** GEV/C LABORATORY MOMENTUM REGION
33783C*** N - PROJECTILE HADRON INDEX
33784C*** PLAB - LABORATORY MOMENTUM OF N (GEV/C)
33785C*** ELAB - LABORATORY ENERGY OF N (GEV)
33786C*** CX,CY,CZ - DIRECTION COSINES OF N IN THE LABORATORY SYSTEM
33787C*** ITTA - TARGET NUCLEON INDEX
33788C*** OUTPUT VARIABLES LIST OF PARTICLE CHARACTERISTICS IN /FINLSP/
33789C IR COUNTS THE NUMBER OF PRODUCED PARTICLES
33790C*** ITR - PARTICLE INDEX, CXR,CYR,CZR - DIRECTION COSINES (LAB. SYST.)
33791C*** ELR,PLR LAB. ENERGY AND LAB. MOMENTUM OF THE SAMPLED PARTICLE
33792C*** RESPECT., UNITS (GEV/C AND GEV)
33793C----------------------------
33794
33795 COMMON /HNGAMR/ REDU,AMO,AMM(15)
33796 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33797 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33798 & NRK(2,268),NURE(30,2)
33799* particle properties (BAMJET index convention),
33800* (dublicate of DTPART for HADRIN)
33801 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33802 & K1H(110),K2H(110)
33803 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
33804 COMMON /HNMETL/ CXS(149),CYS(149),CZS(149),ELS(149),PLS(149),
33805 & ITS(149),IS
33806 COMMON /HNDRUN/ RUNTES,EFTES
33807* particle properties (BAMJET index convention)
33808 CHARACTER*8 ANAME
33809 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
33810 & IICH(210),IIBAR(210),K1(210),K2(210)
33811* final state from HADRIN interaction
33812 PARAMETER (MAXFIN=10)
33813 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
33814 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
33815
33816 DIMENSION ITPRF(110)
33817 DATA NNN/0/
33818 DATA UMODA/0./
33819 DATA ITPRF/-1,-1,5*1,-1,-1,1,1,1,-1,-1,-1,-1,6*1,-1,-1,-1,85*1/
33820 LOWP=0
33821 IF (N.LE.0.OR.N.GE.111)N=1
33822 IF (ITPRF( N ).GT.0 .OR. ITTA.GT.8) THEN
33823 GOTO 280
33824* WRITE (6,1000)
33825* + ' FALSE USE OF THE PARTICLE TYPE INDEX: N, ITTA', N, ITTA
33826* STOP
33827*1000 FORMAT (3(5H ****/),A,2I4,3(5H ****/))
33828* + 45H FALSE USE OF THE PARTICLE TYPE INDEX, N,LUE ,I4,3(5H ****/))
33829 ENDIF
33830 IATMPT=0
33831 IF (ABS(PLAB-5.0D0).LT.4.99999D0) GO TO 20
33832C IF(IPRI.GE.1) WRITE (6,1010) PLAB
33833C STOP
33834 1010 FORMAT ( ' PROJECTILE HADRON MOMENTUM OUTSIDE OF THE
33835 + ALLOWED REGION, PLAB=',1E15.5)
33836
33837 20 CONTINUE
33838 UMODAT=N*1.11111D0+ITTA*2.19291D0
33839 IF(UMODAT.NE.UMODA) CALL DT_DCALUM(N,ITTA)
33840 UMODA=UMODAT
33841 30 IATMPT=0
33842 LOWP=LOWP+1
33843 40 CONTINUE
33844 IMACH=0
33845 REDU=2.0D0
33846 IF (LOWP.GT.20) THEN
33847C WRITE(LOUT,*) ' jump 1'
33848 GO TO 280
33849 ENDIF
33850 NNN=N
33851 IF (NNN.EQ.N) GO TO 50
33852 RUNTES=0.0D0
33853 EFTES=0.0D0
33854 50 CONTINUE
33855 IS=1
33856 IRH=0
33857 IST=1
33858 NSTAB=23
33859 IRE=NURE(N,1)
33860 IF(ITTA.GT.1) IRE=NURE(N,2)
33861C
33862C-----------------------------
33863C*** IE,AMT,ECM,SI DETERMINATION
33864C----------------------------
33865 CALL DT_DSIGIN(IRE,PLAB,N,IE,AMT ,AMN,ECM,SI,ITTA)
33866 IANTH=-1
33867**sr
33868C IF (AMH(1).NE.0.93828D0) IANTH=1
33869 IF (AMH(1).NE.0.9383D0) IANTH=1
33870**
33871 IF (IANTH.GE.0) SI=1.0D0
33872 ECMMH=ECM
33873C
33874C-----------------------------
33875C ENERGY INDEX
33876C IRE CHARACTERIZES THE REACTION
33877C IE IS THE ENERGY INDEX
33878C----------------------------
33879 IF (SI.LT.1.D-6) THEN
33880C WRITE(LOUT,*) ' jump 2'
33881 GO TO 280
33882 ENDIF
33883 IF (N.LE.NSTAB) GO TO 60
33884 RUNTES=RUNTES+1.0D0
33885 IF (RUNTES.LT.20.D0) WRITE(LOUT,1020)N
33886 1020 FORMAT(3H N=,I10,30H THE PROEKTILE IS A RESONANCE )
33887 IF(IBARH(N).EQ.1) N=8
33888 IF(IBARH(N).EQ.-1) N=9
33889 60 CONTINUE
33890 IMACH=IMACH+1
33891**sr 19.2.97: loop for direct channel suppression
33892C IF (IMACH.GT.10) THEN
33893 IF (IMACH.GT.1000) THEN
33894**
33895C WRITE(LOUT,*) ' jump 3'
33896 GO TO 280
33897 ENDIF
33898 ECM =ECMMH
33899 AMN2=AMN**2
33900 AMT2=AMT**2
33901 ECMN=(ECM**2+AMN2-AMT2)/(2.0D0*ECM )
33902 IF(ECMN.LE.AMN) ECMN=AMN
33903 PCMN=SQRT(ECMN**2-AMN2)
33904 GAM=(ELAB+AMT)/ECM
33905 BGAM=PLAB/ECM
33906 IF (IANTH.GE.0) ECM=2.1D0
33907C
33908C-----------------------------
33909C*** RANDOM CHOICE OF REACTION CHANNEL
33910C----------------------------
33911 IST=0
33912 VV=DT_RNDM(AMN2)
33913 VV=VV-1.D-17
33914C
33915C-----------------------------
33916C*** PLACE REDUCED VERSION
33917C----------------------------
33918 IIEI=IEII(IRE)
33919 IDWK=IEII(IRE+1)-IIEI
33920 IIWK=IRII(IRE)
33921 IIKI=IKII(IRE)
33922C
33923C-----------------------------
33924C*** SHRINKAGE TO THE CONSIDERED ENERGY REGION FOR THE USE OF WEIGHTS
33925C----------------------------
33926 HECM=ECM
33927 HUMO=2.0D0*UMO(IIEI+IDWK)-UMO(IIEI+IDWK-1)
33928 IF (HUMO.LT.ECM) ECM=HUMO
33929C
33930C-----------------------------
33931C*** INTERPOLATION PREPARATION
33932C----------------------------
33933 ECMO=UMO(IE)
33934 ECM1=UMO(IE-1)
33935 DECM=ECMO-ECM1
33936 DEC=ECMO-ECM
33937C
33938C-----------------------------
33939C*** RANDOM LOOP
33940C----------------------------
33941 IK=0
33942 WKK=0.0D0
33943 WICOR=0.0D0
33944 70 IK=IK+1
33945 IWK=IIWK+(IK-1)*IDWK+IE-IIEI
33946 WOK=WK(IWK)
33947 WDK=WOK-WK(IWK-1)
33948C
33949C-----------------------------
33950C*** TESTVARIABLE WICO/WICOR: IF CHANNEL IK HAS THE SAME WEIGHTS LIKE IK
33951C GO TO NEXT CHANNEL, BECAUSE WKK((IK))-WKK((IK-1))=0, IK CAN NOT
33952C CONTRIBUTE
33953C----------------------------
33954 IF (PLAB.LT.PLABF(IIEI+2)) WDK=0.0D0
33955 WICO=WOK*1.23459876D0+WDK*1.735218469D0
33956 IF (WICO.EQ.WICOR) GO TO 70
33957 IF (UMO(IIEI+IDWK).LT.HECM) WDK=0.0D0
33958 WICOR=WICO
33959C
33960C-----------------------------
33961C*** INTERPOLATION IN CHANNEL WEIGHTS
33962C----------------------------
33963 EKLIM=-THRESH(IIKI+IK)
33964 IELIM=IDT_IEFUND(EKLIM,IRE)
33965 DELIM=UMO(IELIM)+EKLIM
33966 *+1.D-16
33967 DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
33968 IF (DELIM*DELIM-DETE*DETE) 90,90,80
33969 80 DECC=DELIM
33970 GO TO 100
33971 90 DECC=DECM
33972 100 CONTINUE
33973 WKK=WOK-WDK*DEC/(DECC+1.D-9)
33974C
33975C-----------------------------
33976C*** RANDOM CHOICE
33977C----------------------------
33978C
33979 IF (VV.GT.WKK) GO TO 70
33980C
33981C***IK IS THE REACTION CHANNEL
33982C----------------------------
33983 INRK=IKII(IRE)+IK
33984 ECM=HECM
33985 I1001 =0
33986C
33987 110 CONTINUE
33988 IT1=NRK(1,INRK)
33989 AM1=DT_DAMG(IT1)
33990 IT2=NRK(2,INRK)
33991 AM2=DT_DAMG(IT2)
33992 AMS=AM1+AM2
33993 I1001=I1001+1
33994 IF (I1001.GT.50) GO TO 60
33995C
33996 IF (IT2*AMS.GT.IT2*ECM) GO TO 110
33997 IT11=IT1
33998 IT22=IT2
33999 IF (IANTH.GE.0) ECM=ELAB+AMT+0.00001D0
34000 AM11=AM1
34001 AM22=AM2
34002 IF (IT2.GT.0) GO TO 120
34003**sr 19.2.97: supress direct channel for pp-collisions
34004 IF ((N.EQ.1).AND.(ITTA.EQ.1).AND.(IT2.LE.0)) THEN
34005 RR = DT_RNDM(AM11)
34006 IF (RR.LE.0.75D0) GOTO 60
34007 ENDIF
34008**
34009C
34010C-----------------------------
34011C INCLUSION OF DIRECT RESONANCES
34012C RANDOM CHOICE OF DECAY CHANNELS OF THE DIRECT RESONANCE IT1
34013C------------------------
34014 KZ1=K1H(IT1)
34015 IST=IST+1
34016 IECO=0
34017 ECO=ECM
34018 GAM=(ELAB+AMT)/ECO
34019 BGAM=PLAB/ECO
34020 CXS(1)=CX
34021 CYS(1)=CY
34022 CZS(1)=CZ
34023 GO TO 170
34024 120 CONTINUE
34025 WW=DT_RNDM(ECO)
34026 IF(WW.LT. 0.5D0) GO TO 130
34027 IT1=IT22
34028 IT2=IT11
34029 AM1=AM22
34030 AM2=AM11
34031 130 CONTINUE
34032C
34033C-----------------------------
34034C THE FIRST PARTICLE IS DEFINED TO BE THE FORWARD GOING ONE AT SMALL T
34035 IBN=IBARH(N)
34036 IB1=IBARH(IT1)
34037 IT11=IT1
34038 IT22=IT2
34039 AM11=AM1
34040 AM22=AM2
34041 IF(IB1.EQ.IBN) GO TO 140
34042 IT1=IT22
34043 IT2=IT11
34044 AM1=AM22
34045 AM2=AM11
34046 140 CONTINUE
34047C-----------------------------
34048C***IT1,IT2 ARE THE CREATED PARTICLES
34049C***MOMENTA AND DIRECTION COSINA IN THE CM - SYSTEM
34050C------------------------
34051 CALL DT_DTWOPA(ECM1,ECM2,PCM1,PCM2,COD1,COD2,COF1,COF2,SIF1,SIF2,
34052 *IT1,IT2,ECM,ECMN,PCMN,N,AM1,AM2)
34053 IST=IST+1
34054 ITS(IST)=IT1
34055 AMM(IST)=AM1
34056C
34057C-----------------------------
34058C***TRANSFORMATION INTO LAB SYSTEM AND ROTATION
34059C----------------------------
34060 CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD1,COF1,SIF1,
34061 &PCM1,ECM1,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34062 IST=IST+1
34063 ITS(IST)=IT2
34064 AMM(IST)=AM2
34065 CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD2,COF2,SIF2,
34066 *PCM2,ECM2,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34067 150 CONTINUE
34068C
34069C-----------------------------
34070C***TEST STABLE OR UNSTABLE
34071C----------------------------
34072 IF(ITS(IST).GT.NSTAB) GO TO 160
34073 IRH=IRH+1
34074C
34075C-----------------------------
34076C***IRH IS THE NUMBER OF THE FINAL STABLE PARTICLE
34077C----------------------------
34078C* IF (REDU.LT.0.D0) GO TO 1009
34079 ITRH(IRH)=ITS(IST)
34080 PLRH(IRH)=PLS(IST)
34081 CXRH(IRH)=CXS(IST)
34082 CYRH(IRH)=CYS(IST)
34083 CZRH(IRH)=CZS(IST)
34084 ELRH(IRH)=ELS(IST)
34085 IST=IST-1
34086 IF(IST.GE.1) GO TO 150
34087 GO TO 260
34088 160 CONTINUE
34089C
34090C RANDOM CHOICE OF DECAY CHANNELS
34091C----------------------------
34092C
34093 IT=ITS(IST)
34094 ECO=AMM(IST)
34095 GAM=ELS(IST)/ECO
34096 BGAM=PLS(IST)/ECO
34097 IECO=0
34098 KZ1=K1H(IT)
34099 170 CONTINUE
34100 IECO=IECO+1
34101 VV=DT_RNDM(GAM)
34102 VV=VV-1.D-17
34103 IIK=KZ1-1
34104 180 IIK=IIK+1
34105 IF (VV.GT.WTI(IIK)) GO TO 180
34106C
34107C IIK IS THE DECAY CHANNEL
34108C----------------------------
34109 IT1=NZKI(IIK,1)
34110 I310=0
34111 190 CONTINUE
34112 I310=I310+1
34113 AM1=DT_DAMG(IT1)
34114 IT2=NZKI(IIK,2)
34115 AM2=DT_DAMG(IT2)
34116 IF (IT2-1.LT.0) GO TO 240
34117 IT3=NZKI(IIK,3)
34118 AM3=DT_DAMG(IT3)
34119 AMS=AM1+AM2+AM3
34120C
34121C IF IIK-KIN.LIM.GT.ACTUAL TOTAL CM-ENERGY, DO AGAIN RANDOM IIK-CHOICE
34122C----------------------------
34123 IF (IECO.LE.10) GO TO 200
34124 IATMPT=IATMPT+1
34125 IF(IATMPT.GT.3) THEN
34126C WRITE(LOUT,*) ' jump 4'
34127 GO TO 280
34128 ENDIF
34129 GO TO 40
34130 200 CONTINUE
34131 IF (I310.GT.50) GO TO 170
34132 IF (AMS.GT.ECO) GO TO 190
34133C
34134C FOR THE DECAY CHANNEL
34135C IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM IT
34136C----------------------------
34137 IF (REDU.LT.0.D0) GO TO 30
34138 ITWTHC=0
34139 REDU=2.0D0
34140 IF(IT3.EQ.0) GO TO 220
34141 210 CONTINUE
34142 ITWTH=1
34143 CALL DT_DTHREP(ECO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,SIF1,
34144 *COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
34145 GO TO 230
34146 220 CALL DT_DTWOPD(ECO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,
34147 &COD2,COF2,SIF2,AM1,AM2)
34148 ITWTH=-1
34149 IT3=0
34150 230 CONTINUE
34151 ITWTHC=ITWTHC+1
34152 IF (REDU.GT.0.D0) GO TO 240
34153 REDU=2.0D0
34154 IF (ITWTHC.GT.100) GO TO 30
34155 IF (ITWTH) 220,220,210
34156 240 CONTINUE
34157 ITS(IST )=IT1
34158 IF (IT2-1.LT.0) GO TO 250
34159 ITS(IST+1) =IT2
34160 ITS(IST+2)=IT3
34161 RX=CXS(IST)
34162 RY=CYS(IST)
34163 RZ=CZS(IST)
34164 AMM(IST)=AM1
34165 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD1,COF1,SIF1,PCM1,ECM1,
34166 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34167 IST=IST+1
34168 AMM(IST)=AM2
34169 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD2,COF2,SIF2,PCM2,ECM2,
34170 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34171 IF (IT3.LE.0) GO TO 250
34172 IST=IST+1
34173 AMM(IST)=AM3
34174 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD3,COF3,SIF3,PCM3,ECM3,
34175 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34176 250 CONTINUE
34177 GO TO 150
34178 260 CONTINUE
34179 270 CONTINUE
34180 RETURN
34181 280 CONTINUE
34182C
34183C----------------------------
34184C
34185C ZERO CROSS SECTION CASE
34186C----------------------------
34187C
34188 IRH=1
34189 ITRH(1)=N
34190 CXRH(1)=CX
34191 CYRH(1)=CY
34192 CZRH(1)=CZ
34193 ELRH(1)=ELAB
34194 PLRH(1)=PLAB
34195 RETURN
34196 END
34197
34198*$ CREATE DT_RUNTT.FOR
34199*COPY DT_RUNTT
34200*
34201*===runtt==============================================================*
34202*
34203 BLOCK DATA DT_RUNTT
34204
34205 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34206 SAVE
34207
34208 COMMON /HNDRUN/ RUNTES,EFTES
34209
34210 DATA RUNTES,EFTES /100.D0,100.D0/
34211
34212 END
34213
34214*$ CREATE DT_NONAME.FOR
34215*COPY DT_NONAME
34216*
34217*===noname=============================================================*
34218*
34219 BLOCK DATA DT_NONAME
34220
34221 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34222 SAVE
34223
34224* slope parameters for HADRIN interactions
34225 COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
34226 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34227
34228C DATAS DATAS DATAS DATAS DATAS
34229C****** *********
34230 DATA IKII/ 0, 15, 41, 67, 82, 93, 110, 133, 148, 159, 172, 183,
34231 & 207, 224, 241, 252, 268 /
34232 DATA IEII/ 0, 21, 46, 71, 92, 109, 126, 143, 160, 173, 186, 199,
34233 & 220, 241, 262, 279, 296 /
34234 DATA IRII/ 0, 315, 965, 1615, 1930, 2117, 2406, 2797, 3052, 3195,
34235 & 3364, 3507, 4011, 4368, 4725, 4912, 5184/
34236
34237C
34238C MASSES FOR THE SLOPE B(M) IN GEV
34239C SLOPE B(M) FOR AN MESONIC SYSTEM
34240C SLOPE B(M) FOR A BARYONIC SYSTEM
34241
34242*
34243 DATA SM,BBM,BBB/ 0.8D0, 0.85D0, 0.9D0, 0.95D0, 1.D0,
34244 & 1.05D0, 1.1D0, 1.15D0, 1.2D0, 1.25D0,
34245 & 1.3D0, 1.35D0, 1.4D0, 1.45D0, 1.5D0,
34246 & 1.55D0, 1.6D0, 1.65D0, 1.7D0, 1.75D0,
34247 & 1.8D0, 1.85D0, 1.9D0, 1.95D0, 2.D0,
34248 & 15.6D0, 14.95D0, 14.3D0, 13.65D0, 13.D0,
34249 & 12.35D0, 11.7D0, 10.85D0, 10.D0, 9.15D0,
34250 & 8.3D0, 7.8D0, 7.3D0, 7.25D0, 7.2D0,
34251 & 6.95D0, 6.7D0, 6.6D0, 6.5D0, 6.3D0,
34252 & 6.1D0, 5.85D0, 5.6D0, 5.35D0, 5.1D0,
34253 & 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0,
34254 & 14.2D0, 13.4D0, 12.6D0,
34255 & 11.8D0, 11.2D0, 10.6D0, 9.8D0, 9.D0,
34256 & 8.25D0, 7.5D0, 6.25D0, 5.D0, 4.5D0, 5*4.D0 /
34257*
34258 END
34259
34260*$ CREATE DT_DAMG.FOR
34261*COPY DT_DAMG
34262*
34263*===damg===============================================================*
34264*
34265 DOUBLE PRECISION FUNCTION DT_DAMG(IT)
34266
34267 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34268 SAVE
34269
34270* particle properties (BAMJET index convention),
34271* (dublicate of DTPART for HADRIN)
34272 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34273 & K1H(110),K2H(110)
34274
34275 DIMENSION GASUNI(14)
34276 DATA GASUNI/
34277 *-1.D0,-.98D0,-.95D0,-.87D0,-.72D0,-.48D0,
34278 *-.17D0,.17D0,.48D0,.72D0,.87D0,.95D0,.98D0,1.D0/
34279 DATA GAUNO/2.352D0/
34280 DATA GAUNON/2.4D0/
34281 DATA IO/14/
34282 DATA NSTAB/23/
34283
34284 I=1
34285 IF (IT.LE.0) GO TO 30
34286 IF (IT.LE.NSTAB) GO TO 20
34287 DGAUNI=GAUNO*GAUNON/DBLE(IO-1)
34288 VV=DT_RNDM(DGAUNI)
34289 VV=VV*2.0D0-1.0D0+1.D-16
34290 10 CONTINUE
34291 VO=GASUNI(I)
34292 I=I+1
34293 V1=GASUNI(I)
34294 IF (VV.GT.V1) GO TO 10
34295 UNIGA=DGAUNI*(DBLE(I)-2.0D0+(VV-VO+1.D-16)/
34296 & (V1-VO)-(DBLE(IO)-1.0D0)*0.5D0)
34297 DAM=GAH(IT)*UNIGA/GAUNO
34298 AAM=AMH(IT)+DAM
34299 DT_DAMG=AAM
34300 RETURN
34301 20 CONTINUE
34302 DT_DAMG=AMH(IT)
34303 RETURN
34304 30 CONTINUE
34305 DT_DAMG=0.0D0
34306 RETURN
34307 END
34308
34309*$ CREATE DT_DCALUM.FOR
34310*COPY DT_DCALUM
34311*
34312*===dcalum=============================================================*
34313*
34314 SUBROUTINE DT_DCALUM(N,ITTA)
34315
34316 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34317 SAVE
34318
34319C*** C.M.S.-ENERGY AND REACTION CHANNEL THRESHOLD CALCULATION
34320
34321* particle properties (BAMJET index convention),
34322* (dublicate of DTPART for HADRIN)
34323 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34324 & K1H(110),K2H(110)
34325 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34326 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
34327 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34328 & NRK(2,268),NURE(30,2)
34329
34330 IRE=NURE(N,ITTA/8+1)
34331 IEO=IEII(IRE)+1
34332 IEE=IEII(IRE +1)
34333 AM1=AMH(N )
34334 AM12=AM1**2
34335 AM2=AMH(ITTA)
34336 AM22=AM2**2
34337 DO 10 IE=IEO,IEE
34338 PLAB2=PLABF(IE)**2
34339 ELAB=SQRT(AM12+AM22+2.0D0*SQRT(PLAB2+AM12)*AM2)
34340 UMO(IE)=ELAB
34341 10 CONTINUE
34342 IKO=IKII(IRE)+1
34343 IKE=IKII(IRE +1)
34344 UMOO=UMO(IEO)
34345 DO 30 IK=IKO,IKE
34346 IF(NRK(2,IK).GT.0) GO TO 30
34347 IKI=NRK(1,IK)
34348 AMSS=5.0D0
34349 K11=K1H(IKI)
34350 K22=K2H(IKI)
34351 DO 20 IK1=K11,K22
34352 IN=NZKI(IK1,1)
34353 AMS=AMH(IN)
34354 IN=NZKI(IK1,2)
34355 IF(IN.GT.0)AMS=AMS+AMH(IN)
34356 IN=NZKI(IK1,3)
34357 IF(IN.GT.0) AMS=AMS+AMH(IN)
34358 IF (AMS.LT.AMSS) AMSS=AMS
34359 20 CONTINUE
34360 IF(UMOO.LT.AMSS) UMOO=AMSS
34361 THRESH(IK)=UMOO
34362 30 CONTINUE
34363 RETURN
34364 END
34365
34366*$ CREATE DT_DCHANH.FOR
34367*COPY DT_DCHANH
34368*
34369*===dchanh=============================================================*
34370*
34371 SUBROUTINE DT_DCHANH
34372
34373 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34374 SAVE
34375
34376 PARAMETER ( LINP = 10 ,
34377 & LOUT = 6 ,
34378 & LDAT = 9 )
34379* particle properties (BAMJET index convention),
34380* (dublicate of DTPART for HADRIN)
34381 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34382 & K1H(110),K2H(110)
34383 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
34384 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34385 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34386 & NRK(2,268),NURE(30,2)
34387
34388 DIMENSION HWT(460),HWK(40),SI(5184)
34389 EQUIVALENCE (WK(1),SI(1))
34390C--------------------
34391C*** USE ONLY FOR DATAPREPARATION OF PURE HADRIN
34392C*** CALCULATION OF REACTION- AND DECAY-CHANNEL-WEIGHTS,
34393C*** THRESHOLD ENERGIES+MOMENTA OF REACTION CHNLS.
34394C*** CHANGE OF WT- AND WK-INPUTDATA INTO WEIGHTS FOR THE M.-C.-PROCEDURE
34395C*** (ADDED ONE TO EACH OTHER FOR CORRESPONDING CHANNELS)
34396C--------------------------
34397 IREG=16
34398 DO 90 IRE=1,IREG
34399 IWKO=IRII(IRE)
34400 IEE=IEII(IRE+1)-IEII(IRE)
34401 IKE=IKII(IRE+1)-IKII(IRE)
34402 IEO=IEII(IRE)+1
34403 IIKA=IKII(IRE)
34404* modifications to suppress elestic scattering 24/07/91
34405 DO 80 IE=1,IEE
34406 SIS=1.D-14
34407 SINORC=0.0D0
34408 DO 10 IK=1,IKE
34409 IWK=IWKO+IEE*(IK-1)+IE
34410 IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
34411 SIS=SIS+SI(IWK)*SINORC
34412 10 CONTINUE
34413 SIIN(IEO+IE-1)=SIS
34414 SIO=0.D0
34415 IF (SIS.GE.1.D-12) GO TO 20
34416 SIS=1.D0
34417 SIO=1.D0
34418 20 CONTINUE
34419 SINORC=0.0D0
34420 DO 30 IK=1,IKE
34421 IWK=IWKO+IEE*(IK-1)+IE
34422 IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
34423 SIO=SIO+SI(IWK)*SINORC/SIS
34424 HWK(IK)=SIO
34425 30 CONTINUE
34426 DO 40 IK=1,IKE
34427 IWK=IWKO+IEE*(IK-1)+IE
34428 40 WK(IWK)=HWK(IK)
34429 IIKI=IKII(IRE)
34430 DO 70 IK=1,IKE
34431 AM111=0.D0
34432 INRK1=NRK(1,IIKI+IK)
34433 IF (INRK1.GT.0) AM111=AMH(INRK1)
34434 AM222=0.D0
34435 INRK2=NRK(2,IIKI+IK)
34436 IF (INRK2.GT.0) AM222=AMH(INRK2)
34437 THRESH(IIKI+IK)=AM111 +AM222
34438 IF (INRK2-1.GE.0) GO TO 60
34439 INRKK=K1H(INRK1)
34440 AMSS=5.D0
34441 INRKO=K2H(INRK1)
34442 DO 50 INRK1=INRKK,INRKO
34443 INZK1=NZKI(INRK1,1)
34444 INZK2=NZKI(INRK1,2)
34445 INZK3=NZKI(INRK1,3)
34446 IF (INZK1.LE.0.OR.INZK1.GT.110) GO TO 50
34447 IF (INZK2.LE.0.OR.INZK2.GT.110) GO TO 50
34448 IF (INZK3.LE.0.OR.INZK3.GT.110) GO TO 50
34449C WRITE (6,310)INRK1,INZK1,INZK2,INZK3
34450 1000 FORMAT (4I10)
34451 AMS=AMH(INZK1)+AMH(INZK2)
34452 IF (INZK3-1.GE.0) AMS=AMS+AMH(INZK3)
34453 IF (AMSS.GT.AMS) AMSS=AMS
34454 50 CONTINUE
34455 AMS=AMSS
34456 IF (AMS.LT.UMO(IEO)) AMS=UMO(IEO)
34457 THRESH(IIKI+IK)=AMS
34458 60 CONTINUE
34459 70 CONTINUE
34460 80 CONTINUE
34461 90 CONTINUE
34462 DO 100 J=1,460
34463 100 HWT(J)=0.D0
34464 DO 120 I=1,110
34465 IK1=K1H(I)
34466 IK2=K2H(I)
34467 HV=0.D0
34468 IF (IK2.GT.460)IK2=460
34469 IF (IK1.LE.0)IK1=1
34470 DO 110 J=IK1,IK2
34471 HV=HV+WTI(J)
34472 HWT(J)=HV
34473 JI=J
34474 110 CONTINUE
34475 IF (ABS(HV-1.0D0).GT.1.D-4) WRITE(LOUT,1010)I,JI,HV
34476 1010 FORMAT (35H ERROR IN HWT, FALSE USE OF CHANWH ,2I6,F10.2)
34477 120 CONTINUE
34478 DO 130 J=1,460
34479 130 WTI(J)=HWT(J)
34480 RETURN
34481 END
34482
34483*$ CREATE DT_DHADDE.FOR
34484*COPY DT_DHADDE
34485*
34486*===dhadde=============================================================*
34487*
34488 SUBROUTINE DT_DHADDE
34489
34490 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34491 SAVE
34492
34493* particle properties (BAMJET index convention)
34494 CHARACTER*8 ANAME
34495 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
34496 & IICH(210),IIBAR(210),K1(210),K2(210)
34497* HADRIN: decay channel information
34498 PARAMETER (IDMAX9=602)
34499 CHARACTER*8 ZKNAME
34500 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
34501* particle properties (BAMJET index convention),
34502* (dublicate of DTPART for HADRIN)
34503 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34504 & K1H(110),K2H(110)
34505 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
34506* decay channel information for HADRIN
34507 COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
34508 & K1Z(16),K2Z(16),WTZ(153),II22,
34509 & NZK1(153),NZK2(153),NZK3(153)
34510
34511 DATA IRETUR/0/
34512
34513 IRETUR=IRETUR+1
34514 AMH(31)=0.48D0
34515 IF (IRETUR.GT.1) RETURN
34516 DO 10 I=1,94
34517 AMH(I) = AAM(I)
34518 GAH(I) = GA(I)
34519 TAUH(I) = TAU(I)
34520 ICHH(I) = IICH(I)
34521 IBARH(I) = IIBAR(I)
34522 K1H(I) = K1(I)
34523 K2H(I) = K2(I)
34524 10 CONTINUE
34525**sr
34526C AMH(1)=0.93828D0
34527 AMH(1)=0.9383D0
34528**
34529 AMH(2)=AMH(1)
34530 DO 20 I=26,30
34531 K1H(I)=452
34532 K2H(I)=452
34533 20 CONTINUE
34534 DO 30 I=1,307
34535 WTI(I) = WT(I)
34536 NZKI(I,1) = NZK(I,1)
34537 NZKI(I,2) = NZK(I,2)
34538 NZKI(I,3) = NZK(I,3)
34539 30 CONTINUE
34540 DO 40 I=1,16
34541 L=I+94
34542 AMH(L)=AMZ(I)
34543 GAH( L)=GAZ(I)
34544 TAUH( L)=TAUZ(I)
34545 ICHH( L)=ICHZ(I)
34546 IBARH( L)=IBARZ(I)
34547 K1H( L)=K1Z(I)
34548 K2H( L)=K2Z(I)
34549 40 CONTINUE
34550 DO 50 I=1,153
34551 L=I+307
34552 WTI(L) = WTZ(I)
34553 NZKI(L,3) = NZK3(I)
34554 NZKI(L,2) = NZK2(I)
34555 NZKI(L,1) = NZK1(I)
34556 50 CONTINUE
34557 RETURN
34558 END
34559
34560*$ CREATE IDT_IEFUND.FOR
34561*COPY IDT_IEFUND
34562*
34563*===iefund=============================================================*
34564*
34565 INTEGER FUNCTION IDT_IEFUND(PL,IRE)
34566
34567 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34568 SAVE
34569
34570C*****IEFUN CALCULATES A MOMENTUM INDEX
34571
34572 PARAMETER ( LINP = 10 ,
34573 & LOUT = 6 ,
34574 & LDAT = 9 )
34575 COMMON /HNDRUN/ RUNTES,EFTES
34576 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34577 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34578 & NRK(2,268),NURE(30,2)
34579
34580 IPLA=IEII(IRE)+1
34581 *+1
34582 IPLE=IEII(IRE+1)
34583 IF (PL.LT.0.) GO TO 30
34584 DO 10 I=IPLA,IPLE
34585 J=I-IPLA+1
34586 IF (PL.LE.PLABF(I)) GO TO 60
34587 10 CONTINUE
34588 I=IPLE
34589 IF ( EFTES.GT.40.D0) GO TO 20
34590 EFTES=EFTES+1.0D0
34591 WRITE(LOUT,1000)PL,J
34592 20 CONTINUE
34593 GO TO 70
34594 30 CONTINUE
34595 DO 40 I=IPLA,IPLE
34596 J=I-IPLA+1
34597 IF (-PL.LE.UMO(I)) GO TO 60
34598 40 CONTINUE
34599 I=IPLE
34600 IF ( EFTES.GT.40.D0) GO TO 50
34601 EFTES=EFTES+1.0D0
34602 WRITE(LOUT,1000)PL,I
34603 50 CONTINUE
34604 60 CONTINUE
34605 70 CONTINUE
34606 IDT_IEFUND=I
34607 RETURN
34608 1000 FORMAT(14H PLAB OR -ECM=,E12.4,27H IS OUT OF CONSIDERED RANGE ,
34609 +7H IEFUN=,I5)
34610 END
34611
34612*$ CREATE DT_DSIGIN.FOR
34613*COPY DT_DSIGIN
34614*
34615*===dsigin=============================================================*
34616*
34617 SUBROUTINE DT_DSIGIN(IRE ,PLAB,N,IE ,AMT ,AMN,ECM ,SI ,ITAR)
34618
34619 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34620 SAVE
34621
34622* particle properties (BAMJET index convention),
34623* (dublicate of DTPART for HADRIN)
34624 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34625 & K1H(110),K2H(110)
34626 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34627 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34628 & NRK(2,268),NURE(30,2)
34629
34630 IE=IDT_IEFUND(PLAB,IRE)
34631 IF (IE.LE.IEII(IRE)) IE=IE+1
34632 AMT=AMH(ITAR)
34633 AMN=AMH(N)
34634 AMN2=AMN*AMN
34635 AMT2=AMT*AMT
34636 ECM=SQRT(AMN2+AMT2+2.0D0*AMT*SQRT(AMN2+PLAB**2))
34637C*** INTERPOLATION PREPARATION
34638 ECMO=UMO(IE)
34639 ECM1=UMO(IE-1)
34640 DECM=ECMO-ECM1
34641 DEC=ECMO-ECM
34642 IIKI=IKII(IRE)+1
34643 EKLIM=-THRESH(IIKI)
34644 WOK=SIIN(IE)
34645 WDK=WOK-SIIN(IE-1)
34646 IF (ECM.GT.ECMO) WDK=0.0D0
34647C*** INTERPOLATION IN CHANNEL WEIGHTS
34648 IELIM=IDT_IEFUND(EKLIM,IRE)
34649 DELIM=UMO(IELIM)+EKLIM
34650 *+1.D-16
34651 DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
34652 IF (DELIM*DELIM-DETE*DETE) 20,20,10
34653 10 DECC=DELIM
34654 GO TO 30
34655 20 DECC=DECM
34656 30 CONTINUE
34657 WKK=WOK-WDK*DEC/(DECC+1.D-9)
34658 IF (WKK.LT.0.0D0) WKK=0.0D0
34659 SI=WKK+1.D-12
34660 IF (-EKLIM.GT.ECM) SI=1.D-14
34661 RETURN
34662 END
34663
34664*$ CREATE DT_DTCHOI.FOR
34665*COPY DT_DTCHOI
34666*
34667*===dtchoi=============================================================*
34668*
34669 SUBROUTINE DT_DTCHOI(T,P,PP,E,EE,I,II,N,AM1,AM2)
34670
34671 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34672 SAVE
34673
34674C ****************************
34675C TCHOIC CALCULATES A RANDOM VALUE
34676C FOR THE FOUR-MOMENTUM-TRANSFER T
34677C ****************************
34678
34679* particle properties (BAMJET index convention),
34680* (dublicate of DTPART for HADRIN)
34681 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34682 & K1H(110),K2H(110)
34683* slope parameters for HADRIN interactions
34684 COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
34685
34686 AMA=AM1
34687 AMB=AM2
34688 IF (I.GT.30.AND.II.GT.30) GO TO 20
34689 III=II
34690 AM3=AM2
34691 IF (I.LE.30) GO TO 10
34692 III=I
34693 AM3=AM1
34694 10 CONTINUE
34695 GO TO 30
34696 20 CONTINUE
34697 III=II
34698 AM3=AM2
34699 IF (AMA.LE.AMB) GO TO 30
34700 III=I
34701 AM3=AM1
34702 30 CONTINUE
34703 IB=IBARH(III)
34704 AMA=AM3
34705 K=INT((AMA-0.75D0)/0.05D0)
34706 IF (K-2.LT.0) K=1
34707 IF (K-26.GE.0) K=25
34708 IF (IB)50,40,50
34709 40 BM=BBM(K)
34710 GO TO 60
34711 50 BM=BBB(K)
34712 60 CONTINUE
34713C NORMALIZATION
34714 TMIN=-2.0D0*(E*EE-P*PP)+AMH(N)**2+AM1 **2
34715 TMAX=-2.0D0*(E*EE+P*PP)+AMH(N)**2+AM1 **2
34716 VB=DT_RNDM(TMIN)
34717**sr test
34718C IF (VB.LT.0.2D0) BM=BM*0.1
34719C **0.5
34720 BM = BM*5.05D0
34721**
34722 TMI=BM*TMIN
34723 TMA=BM*TMAX
34724 ETMA=0.D0
34725 IF (ABS(TMA).GT.120.D0) GO TO 70
34726 ETMA=EXP(TMA)
34727 70 CONTINUE
34728 AN=(1.0D0/BM)*(EXP(TMI)-ETMA)
34729C*** RANDOM CHOICE OF THE T - VALUE
34730 R=DT_RNDM(TMI)
34731 T=(1.0D0/BM)*LOG(ETMA+R*AN*BM)
34732 RETURN
34733 END
34734
34735*$ CREATE DT_DTWOPA.FOR
34736*COPY DT_DTWOPA
34737*
34738*===dtwopa=============================================================*
34739*
34740 SUBROUTINE DT_DTWOPA(E1,E2,P1,P2,COD1,COD2,COF1,COF2,SIF1,SIF2,
34741 &IT1,IT2,UMOO,ECM,P,N,AM1,AM2)
34742
34743 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34744 SAVE
34745
34746C ******************************************************
34747C QUASI TWO PARTICLE PRODUCTION
34748C TWOPAR CALCULATES THE ENERGYS AND THE MOMENTA
34749C FOR THE CREATED PARTICLES OR RESONANCES IT1 AND IT2
34750C IN THE CM - SYSTEM
34751C COD1,COD2,COF1,COF2,SIF1,SIF2 ARE THE ANGLES FOR
34752C SPHERICAL COORDINATES
34753C ******************************************************
34754
34755* particle properties (BAMJET index convention),
34756* (dublicate of DTPART for HADRIN)
34757 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34758 & K1H(110),K2H(110)
34759
34760 AMA=AM1
34761 AMB=AM2
34762 AMA2=AMA*AMA
34763 E1=((UMOO-AMB)*(UMOO+AMB) + AMA2)/(2.0D0*UMOO)
34764 E2=UMOO - E1
34765 IF (E1.LT.AMA*1.00001D0) E1=AMA*1.00001D0
34766 AMTE=(E1-AMA)*(E1+AMA)
34767 AMTE=AMTE+1.D-18
34768 P1=SQRT(AMTE)
34769 P2=P1
34770C / P2 / = / P1 / BUT OPPOSITE DIRECTIONS
34771C DETERMINATION OF THE ANGLES
34772C COS(THETA1)=COD1 COS(THETA2)=COD2
34773C SIN(PHI1)=SIF1 SIN(PHI2)=SIF2
34774C COS(PHI1)=COF1 COS(PHI2)=COF2
34775C PHI IS UNIFORMLY DISTRIBUTED IN ( 0,2*PI )
34776 CALL DT_DSFECF(COF1,SIF1)
34777 COF2=-COF1
34778 SIF2=-SIF1
34779C CALCULATION OF THETA1
34780 CALL DT_DTCHOI(TR,P,P1,ECM,E1,IT1,IT2,N,AM1,AM2)
34781 COD1=(TR-AMA2-AMH(N)*AMH(N)+2.0D0*ECM*E1)/(2.0D0*P*P1+1.D-18)
34782 IF (COD1.GT.0.9999999D0) COD1=0.9999999D0
34783 COD2=-COD1
34784 RETURN
34785 END
34786
34787*$ CREATE DT_ZK.FOR
34788*COPY DT_ZK
34789*
34790*===zk=================================================================*
34791*
34792 BLOCK DATA DT_ZK
34793
34794 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34795 SAVE
34796
34797* decay channel information for HADRIN
34798 COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
34799 & K1Z(16),K2Z(16),WTZ(153),II22,
34800 & NZK1(153),NZK2(153),NZK3(153)
34801* decay channel information for HADRIN
34802 CHARACTER*8 ANAMZ,ZKNAM4,ZKNAM5,ZKNAM6
34803 COMMON /HNADDN/ ANAMZ(16),ZKNAM4(9),ZKNAM5(90),ZKNAM6(54)
34804
34805* Particle masses in GeV *
34806 DATA AMZ/ 3*2.2D0, 0.9576D0, 3*1.887D0, 2.4D0, 2.03D0, 2*1.44D0,
34807 & 2*1.7D0, 3*0.D0/
34808* Resonance width Gamma in GeV *
34809 DATA GAZ/ 3*.2D0, .1D0, 4*.2D0, .18D0, 2*.2D0, 2*.15D0, 3*0.D0 /
34810* Mean life time in seconds *
34811 DATA TAUZ / 16*0.D0 /
34812* Charge of particles and resonances *
34813 DATA ICHZ/ 0, 1, 3*0, 1, -1, 0, 1, -1, 0, 0, 1 , 3*0 /
34814* Baryonic charge *
34815 DATA IBARZ/ 2, 7*0, 1, -1, -1, 1, 1, 3*0 /
34816* First number of decay channels used for resonances *
34817* and decaying particles *
34818 DATA K1Z/ 308,310,313,317,322,365,393,421,425,434,440,446,449,
34819 & 3*460/
34820* Last number of decay channels used for resonances *
34821* and decaying particles *
34822 DATA K2Z/ 309,312,316,321,364,392,420,424,433,439,445,448,451,
34823 & 3*460/
34824* Weight of decay channel *
34825 DATA WTZ/ .17D0, .83D0, 2*.33D0, .34D0, .17D0, 2*.33D0, .17D0,
34826 & .01D0, .13D0, .36D0, .27D0, .23D0, .0014D0, .0029D0, .0014D0,
34827 & .0029D0, 4*.0007D0, .0517D0, .0718D0, .0144D0, .0431D0, .0359D0,
34828 & .0718D0, .0014D0, .0273D0, .0014D0, .0431D0, 2*.0129D0, .0259D0,
34829 & .0517D0, .0359D0, .0014D0, 2*.0144D0, .0129D0, .0014D0, .0259D0,
34830 & .0359D0, .0072D0, .0474D0, .0948D0, .0259D0, .0072D0, .0144D0,
34831 & .0287D0, .0431D0, .0144D0, .0287D0, .0474D0, .0144D0, .0075D0,
34832 & .0057D0, .0019D0, .0038D0, .0095D0, 2*.0014D0, .0191D0, .0572D0,
34833 & .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0, .0686D0,.0172D0,
34834 & .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, .0190D0,
34835 & .0057D0, .0019D0, .0038D0, .0095D0, .0014D0, .0014D0, .0191D0,
34836 & .0572D0, .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0,.0686D0,
34837 & .0172D0, .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0,
34838 & .0190D0, 4*.25D0, 2*.2D0, .12D0, .1D0, .07D0, .07D0, .14D0,
34839 & 2*.05D0, .0D0, .3334D0, .2083D0, 2*.125D0, .2083D0, .0D0, .125D0,
34840 & .2083D0, .3334D0, .2083D0, .125D0, .3D0, .05D0, .65D0, .3D0,
34841 & .05D0, .65D0, 9*1.D0 /
34842* Particle numbers in decay channel *
34843 DATA NZK1/ 8, 1, 2, 9, 1, 2, 9, 2, 9, 7, 13, 31, 15, 24, 23, 13,
34844 & 23, 13, 2*23, 14, 13, 23, 31, 98, 2*33, 32, 23, 14, 13, 35, 2*23,
34845 & 14, 13, 33, 23, 98, 31, 23, 14, 13, 35, 2*33, 32, 23, 35, 33, 32,
34846 & 98, 5*35, 4*13, 23, 13, 98, 32, 33, 23, 13, 23, 13, 14, 13, 32,
34847 & 13, 98, 23, 13, 2*32, 13, 33, 32, 98, 2*35, 4*14, 23, 14, 98,
34848 & 2*34, 23, 14, 23, 2*14, 13, 34, 14, 98, 23, 14, 2*34, 14, 33, 32,
34849 & 98, 2*35, 104, 61, 105, 62, 1, 17, 21, 17, 22, 2*21, 22, 21, 2,
34850 & 67, 68, 69, 2, 2*9, 68, 69, 70, 2, 9, 2*24, 15, 2*25, 16, 9*0/
34851 DATA NZK2/ 2*8, 1, 8, 9, 2*8, 2*1, 7, 14, 13, 16, 25, 23, 14, 23,
34852 & 14, 31, 33, 32, 34, 35, 31, 23, 31, 33, 34, 31, 32, 34, 31, 33,
34853 & 32, 2*33, 35, 31, 33, 31, 33, 32, 34, 35, 31, 33, 34, 35, 31,
34854 & 4*33, 32, 3*35, 2*23, 13, 31, 32, 33, 13, 31, 32, 2*31, 32, 33,
34855 & 32, 32, 35, 31, 2*32, 33, 31, 33, 35, 33, 3*32, 35, 2*23, 14,
34856 & 31, 34, 33, 14, 31, 33, 2*31, 34, 32, 33, 34, 35, 31, 2*34, 33,
34857 & 31, 33, 35, 33, 2*34, 33, 35, 1, 2, 8, 9, 25, 13, 35, 2*32, 33,
34858 & 31, 13, 23, 31, 13, 23, 14, 79, 80, 31, 13, 23, 14, 78, 79, 8,
34859 & 1, 8, 1, 8, 1, 9*0 /
34860 DATA NZK3/ 23, 14, 2*13, 23, 13, 2*23, 14, 0, 7, 14, 4*0, 2*23,
34861 & 10*0, 33, 2*31, 0, 33, 34, 32, 34, 0, 35, 0, 31, 3*35, 0, 3*31,
34862 & 35, 31, 33, 34, 31, 33, 34, 31, 33, 35, 0, 23, 14, 6*0, 32, 3*33,
34863 & 32, 34, 0, 35, 0, 2*35, 2*31, 35, 32, 34, 31, 33, 32, 0, 23, 13,
34864 & 6*0, 34, 2*33, 34, 33, 34, 0, 35, 0,2*35, 2*31, 35, 2*34, 31,
34865 & 2*34, 25*0, 23, 2*14, 23, 2*13, 9*0 /
34866* Particle names *
34867 DATA ANAMZ / 'NNPI', 'ANPPI', 'ANNPI', ' ETS ',' PAP ',' PAN ',
34868 & 'APN', 'DEO ', 'S+2030', 'AN*-14', 'AN*014','KONPI ','AKOPPI',
34869 & 3*'BLANK' /
34870* Name of decay channel *
34871 DATA ZKNAM4/'NNPI0','PNPI-','APPPI+','ANNPI+','ANPPI0','APNPI+',
34872 & 'ANNPI0','APPPI0','ANPPI-'/
34873 DATA ZKNAM5/' GAGA ','P+P-GA','ETP+P-','K+K- ','K0AK0 ',
34874 & ' POPO ',' P+P- ','POPOPO','P+P0P-','P0ET ','&0R0 ','P-R+ ',
34875 & 'P+R- ','POOM ',' ETET ','ETSP0 ','R0ET ',' R0R0 ','R+R- ',
34876 & 'P0ETR0','P-ETR+','P+ETR-',' OMET ','P0R0R0','P0R+R-','P-R+R0',
34877 & 'P+R-R0','R0OM ','P0ETOM','ETSR0 ','ETETET','P0R0OM','P-R+OM',
34878 & 'P+R-OM','OMOM ','R0ETET','R0R0ET','R+R-ET','P0OMOM','OMETET',
34879 & 'R0R0R0','R+R0R-','ETSRET','OMR0R0','OMR+R-','OMOMET','OMOMR0',
34880 & 'OMOMOM',
34881 & ' P+PO ','P+POPO','P+P+P-','P+ET ','P0R+ ','P+R0 ','ETSP+ ',
34882 & 'R+ET ',' R0R+ ','POETR+','P+ETR0','POR+R-','P+R0R0','P-R+R+',
34883 & 'P+R-R+','R+OM ','P+ETOM','ETSR+ ','POR+OM','P+R0OM','R+ETET',
34884 & 'R+R0ET','P+OMOM','R0R0R+','R+R+R-','ETSR+E','OMR+R0','OMOMR+',
34885 & 'P-PO ','P-POPO','P-P-P+','P-ET ','POR- ','P-R0 ','ETSP- ',
34886 & 'R-ET ','R-R0 ','POETR-','P-ETR0','POR-R0','P-R+R-','P-R0R0'/
34887 DATA ZKNAM6/'P+R-R-','R-OM ','P-ETOM','ETSR- ','POR-OM','P-R0OM',
34888 & 'R-ETET','R-R0ET','P-OMOM','R0R0R-','R+R-R-','ETSR-E','OMR0R-',
34889 & 'OMOMR-', 'PAN-14','APN+14','NAN014','ANN014','PAKO ','LPI+ ',
34890 & 'SI+OM','LAMRO+','SI0RO+','SI+RO0','SI+ETA','SI0PI+','SI+PI0',
34891 & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHOO','ANRHO-','ANETA ',
34892 & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0',
34893 & 'KONPIO','KOPPI-','K+NPI-','AKOPPO','AKONP+','K-PPI+',
34894 & 9*'BLANK'/
34895*= end*block.zk *
34896 END
34897
34898*$ CREATE DT_BLKD43.FOR
34899*COPY DT_BLKD43
34900*
34901*===blkd43=============================================================*
34902*
34903 BLOCK DATA DT_BLKD43
34904
34905 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34906 SAVE
34907
34908*
34909*=== reac =============================================================*
34910*
34911*----------------------------------------------------------------------*
34912* *
34913* Created on 10 december 1991 by Alfredo Ferrari & Paola Sala *
34914* Infn - Milan *
34915* *
34916* Last change on 10-dec-91 by Alfredo Ferrari *
34917* *
34918* This is the original common reac of Hadrin *
34919* *
34920*----------------------------------------------------------------------*
34921*
34922 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34923 & NRK(2,268),NURE(30,2)
34924
34925 DIMENSION
34926 & UMOPI(92), UMOKC(68), UMOP(39), UMON(63), UMOK0(34),
34927 & PLAPI(92), PLAKC(68), PLAP(39), PLAN(63), PLAK0(34),
34928 & SPIKP1(315), SPIKPU(278), SPIKPV(372),
34929 & SPIKPW(278), SPIKPX(372), SPIKP4(315),
34930 & SPIKP5(187), SPIKP6(289),
34931 & SKMPEL(102), SPIKP7(289), SKMNEL(68), SPIKP8(187),
34932 & SPIKP9(143), SPIKP0(169), SPKPV(143),
34933 & SAPPEL(105), SPIKPE(399), SAPNEL(84), SPIKPZ(273),
34934 & SANPEL(84) , SPIKPF(273),
34935 & SPKP15(187), SPKP16(272),
34936 & NRKPI(164), NRKKC(132), NRKP(70), NRKN(116), NRKK0(54),
34937 & NURELN(60)
34938*
34939 DIMENSION NRKLIN(532)
34940 EQUIVALENCE (NRK(1,1), NRKLIN(1))
34941 EQUIVALENCE ( UMO( 1), UMOPI(1)), ( UMO( 93), UMOKC(1))
34942 EQUIVALENCE ( UMO(161), UMOP(1)), ( UMO(200), UMON(1))
34943 EQUIVALENCE ( UMO(263), UMOK0(1))
34944 EQUIVALENCE ( PLABF( 1), PLAPI(1)), ( PLABF( 93), PLAKC(1))
34945 EQUIVALENCE ( PLABF(161), PLAP(1)), ( PLABF(200), PLAN(1))
34946 EQUIVALENCE ( PLABF(263), PLAK0(1))
34947 EQUIVALENCE ( WK( 1), SPIKP1(1)), ( WK( 316), SPIKPU(1))
34948 EQUIVALENCE ( WK( 594), SPIKPV(1)), ( WK( 966), SPIKPW(1))
34949 EQUIVALENCE ( WK(1244), SPIKPX(1)), ( WK(1616), SPIKP4(1))
34950 EQUIVALENCE ( WK(1931), SPIKP5(1)), ( WK(2118), SPIKP6(1))
34951 EQUIVALENCE ( WK(2407), SKMPEL(1)), ( WK(2509), SPIKP7(1))
34952 EQUIVALENCE ( WK(2798), SKMNEL(1)), ( WK(2866), SPIKP8(1))
34953 EQUIVALENCE ( WK(3053), SPIKP9(1)), ( WK(3196), SPIKP0(1))
34954 EQUIVALENCE ( WK(3365), SPKPV(1)), ( WK(3508), SAPPEL(1))
34955 EQUIVALENCE ( WK(3613), SPIKPE(1)), ( WK(4012), SAPNEL(1))
34956 EQUIVALENCE ( WK(4096), SPIKPZ(1)), ( WK(4369), SANPEL(1))
34957 EQUIVALENCE ( WK(4453), SPIKPF(1)), ( WK(4726), SPKP15(1))
34958 EQUIVALENCE ( WK(4913), SPKP16(1))
34959 EQUIVALENCE (NRK(1,1), NRKLIN(1))
34960 EQUIVALENCE (NRKLIN( 1), NRKPI(1)), (NRKLIN( 165), NRKKC(1))
34961 EQUIVALENCE (NRKLIN( 297), NRKP(1)), (NRKLIN( 367), NRKN(1))
34962 EQUIVALENCE (NRKLIN( 483), NRKK0(1))
34963 EQUIVALENCE (NURE(1,1), NURELN(1))
34964*
34965**** pi- p data *
34966**** pi+ n data *
34967 DATA PLAPI / 0.D0, .3D0, .5D0, .6D0, .7D0, .8D0, .9D0, .95D0,1.D0,
34968 & 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0,
34969 & 3.D0, 3.5D0, 4.D0, 0.D0, .285D0, .4D0, .45D0, .5D0, .6D0, .7D0,
34970 & .75D0, .8D0, .85D0, .9D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0,
34971 & 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0,
34972 & .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, .75D0, .8D0, .85D0, .9D0,
34973 & 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0,
34974 & 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, .3D0, .5D0, .6D0, .7D0,
34975 & .8D0, .9D0, .95D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0,
34976 & 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0 /
34977 DATA PLAKC /
34978 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
34979 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
34980 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
34981 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
34982 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
34983 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
34984 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
34985 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
34986 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
34987 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
34988 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
34989 & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
34990 DATA PLAK0 /
34991 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
34992 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
34993 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
34994 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
34995 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
34996 & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
34997* pp pn np nn *
34998 DATA PLAP /
34999 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35000 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35001 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35002 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35003 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35004 & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
35005* app apn anp ann *
35006 DATA PLAN /
35007 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
35008 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35009 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35010 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
35011 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35012 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35013 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
35014 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35015 & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
35016 DATA SIIN / 296*0.D0 /
35017 DATA UMOPI/ 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
35018 & 1.557D0,1.615D0,1.6435D0,
35019 & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
35020 & 2.286D0,2.366D0,2.482D0,2.56D0,
35021 & 2.735D0,2.90D0,
35022 & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
35023 & 1.496D0,1.527D0,1.557D0,
35024 & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
35025 & 2.071D0,2.159D0,2.286D0,2.366D0,
35026 & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
35027 & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
35028 & 1.496D0,1.527D0,1.557D0,
35029 & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
35030 & 2.071D0,2.159D0,2.286D0,2.366D0,
35031 & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
35032 & 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
35033 & 1.557D0,1.615D0,1.6435D0,
35034 & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
35035 & 2.286D0,2.366D0,2.482D0,2.56D0,
35036 & 2.735D0, 2.90D0/
35037 DATA UMOKC/ 1.44D0,
35038 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35039 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35040 & 3.1D0,1.44D0,
35041 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35042 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35043 & 3.1D0,1.44D0,
35044 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35045 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35046 & 3.1D0,1.44D0,
35047 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35048 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35049 & 3.1D0/
35050 DATA UMOK0/ 1.44D0,
35051 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35052 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35053 & 3.1D0,1.44D0,
35054 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35055 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35056 & 3.1D0/
35057* pp pn np nn *
35058 DATA UMOP/
35059 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35060 & 3.D0,3.1D0,3.2D0,
35061 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35062 & 3.D0,3.1D0,3.2D0,
35063 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35064 & 3.D0,3.1D0,3.2D0/
35065* app apn anp ann *
35066 DATA UMON /
35067 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
35068 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35069 & 3.D0,3.1D0,3.2D0,
35070 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
35071 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35072 & 3.D0,3.1D0,3.2D0,
35073 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
35074 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35075 & 3.D0,3.1D0,3.2D0/
35076**** reaction channel state particles *
35077 DATA NRKPI / 13, 1, 15, 21, 81, 0, 13, 54, 23, 53, 13, 63, 13, 58,
35078 & 23, 57, 13, 65, 1, 32, 53, 31, 54, 32, 53, 33, 53, 35, 63, 32,
35079 & 13, 8, 23, 1, 17, 15, 21, 24, 22, 15, 82, 0, 61, 0, 13, 55, 23,
35080 & 54, 14, 53, 13, 64, 23, 63, 13, 59, 23, 58, 14, 57, 13, 66, 23,
35081 & 65, 1, 31, 8, 32, 1, 33, 1, 35, 54, 31, 55, 32, 54, 33, 53, 34,
35082 & 54, 35, 14, 1, 23, 8, 17, 24, 20, 15, 22, 24, 83, 0, 62, 0, 14,
35083 & 54, 23, 55, 13, 56, 14, 63, 23, 64, 14, 58, 23, 59, 13, 60, 14,
35084 & 65, 23, 66, 8, 31, 1, 34, 8, 33, 8, 35, 55, 31, 54, 34, 55, 33,
35085 & 56, 32, 55, 35, 14, 8, 24, 20, 84, 0, 14, 55, 23, 56, 14, 64, 14,
35086 & 59, 23, 60, 14, 66, 8, 34, 56, 31, 55, 34, 56, 33, 56, 35, 64,34/
35087 DATA NRKKC/ 15, 1, 89, 0, 24, 53, 15, 54, 1, 36, 1, 40, 1, 44, 36,
35088 & 63, 15, 63, 45, 53, 44, 54, 15, 8, 24, 1, 91, 0, 24, 54, 15, 55,
35089 & 8, 36, 1, 37, 8, 40, 1, 41, 8, 44, 1, 45, 36, 64, 37, 63, 15, 64,
35090 & 24, 63, 45, 54, 44, 55, 16, 1, 25, 8, 17, 23, 21, 14, 20,
35091 & 13, 22, 23, 90, 0, 38, 1, 39, 8, 16, 54, 25, 55, 1, 42, 8, 43,
35092 & 16, 63, 25, 64, 39, 64, 38, 63, 46, 54, 47, 55, 8, 47, 1, 46, 52,
35093 & 0, 51, 0, 16, 8, 17, 14, 20, 23, 22, 14, 92, 0, 8, 38, 16, 55,
35094 & 25, 56, 8, 42, 16, 64, 38, 64, 46, 55, 47, 56, 8, 46, 94, 0 /
35095* *
35096* k0 p k0 n ak0 p ak/ n *
35097* *
35098 DATA NRKK0 / 24, 8, 106, 0, 15, 56, 24, 55, 37, 8, 41, 8, 45, 8,
35099 & 37, 64, 24, 64, 44, 56, 45, 55, 25, 1, 17, 13, 22, 13, 21, 23,
35100 & 107, 0, 39, 1, 25, 54, 16, 53, 43, 1, 25, 63, 39, 63, 47, 54, 46,
35101 & 53, 47, 1, 103, 0, 93, 0/
35102* pp pn np nn *
35103 DATA NRKP / 1, 1, 85, 0, 8, 53, 1, 54, 1, 63, 8, 57, 1, 58, 2*54,
35104 & 53, 55, 63, 54, 64, 53, 1, 8, 86, 0, 8, 54, 1, 55, 8, 63, 1, 64,
35105 & 8, 58, 1, 59, 64, 54, 63, 55, 54, 55, 53, 56, 77, 0, 2*8, 95, 0,
35106 & 8, 55, 1, 56, 8, 64, 8, 59, 1, 60, 2*55, 54, 56, 64, 55, 63, 56 /
35107* app apn anp ann *
35108 DATA NRKN/ 1, 2, 17, 18, 15, 16, 8, 9, 13, 14, 99, 0, 87, 0, 1,
35109 & 68, 8, 69, 2, 54, 9, 55, 102, 0, 2, 63, 9, 64, 1, 75, 8, 76, 53,
35110 & 67, 54, 68, 55, 69, 56, 70, 63, 68, 64, 69, 75, 54, 76, 55, 2, 8,
35111 & 18, 20, 16, 24, 14, 23, 101, 0, 88, 0, 2, 55, 9, 56, 1, 67, 8,
35112 & 68, 2, 64, 8, 75, 2, 59, 8, 72, 68, 55, 67, 54, 69, 56, 1, 9, 18,
35113 & 21, 15, 25, 13, 23, 100, 0, 96, 0, 2, 53, 9, 54, 1, 69, 8, 70, 1,
35114 & 76, 9, 63, 1, 73, 9, 58, 55, 70, 53, 68, 54, 69 /
35115**** channel cross section *
35116 DATA SPIKP1/ 0.D0, 300.D0, 40.D0, 20.D0, 13.D0,8.5D0,8.D0, 9.5D0,
35117 & 12.D0,14.D0,15.5D0,20.D0,17.D0,13.D0,10.D0,9.D0,8.5D0,8.D0,7.8D0,
35118 & 7.3D0, 6.7D0, 9*0.D0,.23D0,.35D0,.7D0,.52D0,.4D0,.3D0,.2D0,.15D0,
35119 & .13D0, .11D0, .09D0, .07D0, 0.D0, .033D0,.8D0,1.35D0,1.35D0,.5D0,
35120 & 15*0.D0, 3*0.D0,.00D0,0.80D0,2.2D0,3.6D0,4.6D0,4.7D0,3.5D0,2.4D0,
35121 &1.8D0,1.4D0,.75D0,.47D0,.25D0,.13D0,.08D0,6*0.D0,0.D0,1.2D0,3.3D0,
35122 & 5.4D0,6.9D0,7.3D0,5.3D0,3.6D0,2.7D0,2.2D0,1.1D0,.73D0,.4D0,.22D0,
35123 & .12D0,9*0.D0,.0D0,0.D0,2.0D0,4.4D0,6.8D0,9.9D0,7.9D0,6.0D0,3.8D0,
35124 &2.5D0,2.D0,1.4D0,1.D0,.6D0,.35D0,10*0.D0,.25D0,.55D0,.75D0,1.25D0,
35125 & 1.9D0,2.D0,1.8D0,1.5D0,1.25D0,1.D0,.8D0,6*0.D0,4*0.D0,.4D0,.85D0,
35126 & 1.1D0, 1.85D0, 2.8D0, 3.D0,2.7D0,2.2D0,1.85D0,1.5D0,1.2D0,6*0.D0,
35127 & 6*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, 5.6D0,
35128 & 5.2D0, 6*0.D0, 2*0.D0, .0D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0,
35129 & 2.75D0, 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 6*0.D0, 3*0.D0,
35130 & .0D0, .45D0, 1.4D0, 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0,
35131 & 8*0.D0, 5*0.D0, .0D0, .0D0, .6D0, .8D0, .95D0, .8D0, .7D0, .6D0,
35132 & .5D0, .4D0, 6*0.D0, 5*0.D0, .0D0, .00D0, .85D0, 1.2D0, 1.4D0,
35133 & 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 6*0.D0, 5*0.D0, .0D0, .00D0,
35134 & 1.D0, 1.5D0, 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 6*0.D0,
35135 & 10*0.D0, .5D0, 2.0D0, 3.3D0, 5.4D0, 7.D0 /
35136**** pi+ n data *
35137 DATA SPIKPU/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 20.D0,
35138 & 20.D0, 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
35139 & 10.D0, 10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
35140 & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
35141 & 4.2D0, 7.5D0, 3.4D0, 2.5D0, 2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0,
35142 & .6D0, .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0,
35143 & .48D0, .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0,
35144 & .065D0, .05D0, .04D0, 12*0.D0, .2D0, .25D0, .25D0, .2D0, .1D0,
35145 & .08D0, .06D0, .045D0, .03D0, .02D0, .01D0, .005D0, .003D0,
35146 & 12*0.D0, .3D0, .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0,
35147 & .09D0, .08D0, .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0,
35148 & 3.1D0, 4.5D0, 2.D0, 18*0.D0, 3*.0D0, 0.D0, 0.D0, 4.0D0, 11.D0,
35149 & 11.4D0, 10.3D0, 7.5D0, 6.8D0, 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0,
35150 & .35D0, 13*0.D0, .1D0, .34D0, .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0,
35151 & 2.3D0, 1.6D0, .95D0, .45D0, .28D0, .15D0, 10*0.D0, 2*0.D0, .17D0,
35152 & .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0, 6.2D0, 4.4D0, 3.D0, 1.8D0,
35153 & .9D0, .53D0, .28D0, 10*0.D0, 2*0.D0, .25D0, .82D0,
35154 & 1.3D0, 1.9D0, 2.8D0, 5.5D0 , 8.D0, 5.7D0, 3.9D0, 2.35D0, 1.15D0,
35155 & .69D0, .37D0, 10*0.D0, 7*0.D0, .0D0, .34D0, 1.5D0, 3.47D0,
35156 & 5.87D0, 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
35157*
35158 DATA SPIKPV/ 7*0.D0, .00D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
35159 & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 6*0.D0, 10*0.D0, .2D0,
35160 & .6D0, .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0,
35161 & 1.D0, .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0,
35162 & 3.5D0, 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0,
35163 & .31D0, .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0,
35164 & .23D0, 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0,
35165 & 5.D0, 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0,
35166 & 2.5D0, 3*0.D0, 3*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0,
35167 & 1.5D0, 1.1D0, .8D0, .7D0, .55D0, .3D0, 10*0.D0, 9*0.D0, .1D0,
35168 & .4D0, 1.D0, 1.4D0, 2.2D0, 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0,
35169 & .8D0, .6D0, .4D0, 12*0.D0, .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0,
35170 & 3.8D0, 3.3D0, 2.45D0, 2.05D0, 1.65D0, 1.2D0, .9D0, .6D0, 3*0.D0,
35171 & 9*0.D0, .10D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0,
35172 & 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, 13*0.D0, .2D0, .5D0, .7D0,
35173 & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
35174 & 17*0.D0, .2D0, .5D0, .85D0, 2.D0, 2.15D0, 2.05D0, 1.75D0, 1.D0,
35175 & 17*0.D0, .13D0, .33D0, .57D0, 1.33D0, 1.43D0, 1.36D0, 1.17D0,
35176 & .67D0, 17*0.D0, .07D0, .17D0, .28D0, .67D0, .72D0, .69D0, .58D0,
35177 & .33D0,17*0.D0,.4D0, .7D0, 1.D0, 1.6D0, 1.8D0, 2.3D0,1.9D0,1.7D0 /
35178**** pi- p data *
35179 DATA SPIKPW/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 2*20.D0,
35180 & 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
35181 & 2*10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
35182 & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
35183 & 4.2D0, 7.5D0, 3.4D0, 2*2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, .6D0,
35184 & .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, .48D0,
35185 & .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, .065D0,
35186 & .05D0, .04D0, 12*0.D0, .2D0, 2*.25D0, .2D0, .1D0, .08D0, .06D0,
35187 & .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, 12*0.D0, .3D0,
35188 & .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, .09D0, .08D0,
35189 & .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, 3.1D0, 4.5D0,
35190 & 2.D0, 23*0.D0, 4.0D0, 11.D0, 11.4D0, 10.3D0, 7.5D0, 6.8D0,
35191 & 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, .35D0, 13*0.D0, .1D0, .34D0,
35192 & .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, 2.3D0, 1.6D0, .95D0, .45D0,
35193 & .28D0, .15D0, 12*0.D0, .17D0, .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0,
35194 & 6.2D0, 4.4D0, 3.D0, 1.8D0, .9D0, .53D0, .28D0, 12*0.D0, .25D0,
35195 & .82D0, 1.3D0, 1.9D0, 2.8D0, 5.5D0, 8.D0, 5.7D0, 3.9D0, 2.35D0,
35196 & 1.15D0, .69D0, .37D0, 18*0.D0, .34D0, 1.5D0, 3.47D0, 5.87D0,
35197 & 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
35198*
35199 DATA SPIKPX/ 8*0.D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
35200 & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 16*0.D0, .2D0, .6D0,
35201 & .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, 1.D0,
35202 & .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, 3.5D0,
35203 & 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, .31D0,
35204 & .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, .23D0,
35205 & 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, 5.D0,
35206 & 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, 2.5D0,
35207 & 6*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, 1.5D0, 1.1D0,
35208 & .8D0, .7D0, .55D0, .3D0, 19*0.D0, .1D0, .4D0, 1.D0, 1.4D0, 2.2D0,
35209 & 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, .8D0, .6D0, .4D0, 12*0.D0,
35210 & .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, 3.8D0, 3.3D0, 2.45D0, 2.05D0,
35211 & 1.65D0, 1.2D0, .9D0, .6D0, 12*0.D0, .10D0, .2D0, .5D0, .7D0,
35212 & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
35213 & 13*0.D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0,
35214 & 1.35D0, 1.15D0, .95D0, .7D0, 17*0.D0, .2D0, .5D0, .85D0, 2.D0,
35215 & 2.15D0, 2.05D0, 1.75D0, 1.D0, 17*0.D0, .13D0, .33D0, .57D0,
35216 & 1.33D0, 1.43D0, 1.36D0, 1.17D0, .67D0, 17*0.D0, .07D0, .17D0,
35217 & .28D0, .67D0, .72D0, .69D0, .58D0, .33D0, 17*0.D0, .4D0, .7D0,
35218 & 1.D0, 1.6D0, 1.8D0, 2.3D0, 1.9D0, 1.7D0 /
35219**** pi- n data *
35220 DATA SPIKP4 / 0.D0, 300.D0, 40.D0, 20.D0, 13.D0, 8.5D0, 8.D0,
35221 & 9.5D0, 12.D0, 14.D0, 15.5D0, 20.D0, 17.D0, 13.D0, 10.D0, 9.D0,
35222 & 8.5D0, 8.D0, 7.8D0, 7.3D0, 6.7D0, 9*0.D0, .23D0, .35D0, .7D0,
35223 & .52D0, .4D0, .3D0, .2D0, .15D0, .13D0, .11D0, .09D0, .07D0, 0.D0,
35224 & .033D0, .8D0, 2*1.35D0, .5D0, 19*0.D0, 0.8D0, 2.2D0, 3.6D0,
35225 & 4.6D0, 4.7D0, 3.5D0, 2.4D0, 1.8D0, 1.4D0, .75D0, .47D0, .25D0,
35226 & .13D0, .08D0, 7*0.D0, 1.2D0, 3.3D0, 5.4D0, 6.9D0, 7.3D0, 5.3D0,
35227 & 3.6D0, 2.7D0, 2.2D0, 1.1D0, .73D0, .4D0, .22D0, .12D0, 11*0.D0,
35228 & 2.0D0, 4.4D0, 6.8D0, 9.9D0, 7.9D0, 6.0D0, 3.8D0, 2.5D0, 2.D0,
35229 & 1.4D0, 1.D0, .6D0, .35D0, 10*0.D0, .25D0, .55D0, .75D0, 1.25D0,
35230 & 1.9D0, 2.D0, 1.8D0, 1.5D0, 1.25D0, 1.D0, .8D0, 10*0.D0, .4D0,
35231 & .85D0, 1.1D0, 1.85D0, 2.8D0, 3.D0, 2.7D0, 2.2D0, 1.85D0, 1.5D0,
35232 & 1.2D0, 12*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0,
35233 & 5.6D0, 5.2D0, 9*0.D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, 2.75D0,
35234 & 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 10*0.D0, .45D0, 1.4D0,
35235 & 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, 15*0.D0, .6D0,
35236 & .8D0, .95D0, .8D0, .7D0, .6D0, .5D0, .4D0, 13*0.D0, .85D0, 1.2D0,
35237 & 1.4D0, 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 13*0.D0, 1.D0, 1.5D0,
35238 & 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 16*0.D0, .5D0, 2.0D0,
35239 & 3.3D0, 5.4D0, 7.D0 /
35240**** k+ p data *
35241 DATA SPIKP5/ 0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0,
35242 & 7.D0, 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
35243 & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 13*0.D0, 0.9D0,
35244 & 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0,
35245 & .45D0, .21D0, .2D0, 3*0.D0, .9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
35246 & 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
35247 & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, 1.4D0,
35248 & 1.2D0, 1.05D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, 2*1.D0, .9D0,
35249 & .7D0, .4D0, .3D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.2D0,
35250 & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
35251 & 1.71D0, 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0,
35252 & 3.5D0, 2.85D0, 2.35D0, 2.01D0, 1.8D0, 12*0.D0, .1D0, .8D0,2.05D0,
35253 & 3.31D0, 3.5D0, 12*0.D0, .034D0, .2D0, .75D0, 1.04D0, 1.24D0 /
35254**** k+ n data *
35255 DATA SPIKP6/ 0.D0, 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0,
35256 & 1.5D0, 1.2D0, 1.D0, .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0,
35257 & 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, 1.5D0, 1.2D0, 1.D0,
35258 & .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, .5D0, 1.3D0, 2.8D0,
35259 & 2.3D0, 1.6D0, .9D0, 13*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
35260 & 2.D0, 1.7D0, 1.5D0,1.2D0,.9D0,.6D0,.45D0,.21D0,.2D0,3*0.D0,0.9D0,
35261 & 2.5D0, 3.D0, 2.5D0, 2.3D0,2.D0,1.7D0,1.5D0,1.2D0,.9D0,.6D0,.45D0,
35262 & .21D0, .2D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.D0,1.8D0,1.7D0,1.4D0,
35263 & 1.2D0,1.15D0,.9D0,.66D0,.5D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.1D0,
35264 & 1.8D0,1.7D0,1.4D0,1.2D0, 1.15D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0,
35265 & 2*1.D0, .9D0, .7D0, .4D0, .35D0, .2D0, 9*0.D0, .3D0, 2*1.D0,.9D0,
35266 & .7D0, .4D0, .35D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.4D0,3.5D0,4.25D0,
35267 & 4.55D0, 4.85D0, 4.9D0, 9*0.D0, .1D0, 1.D0, 2.4D0, 3.5D0, 4.25D0,
35268 & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
35269 & 1.71D0, 1.6D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0,
35270 & 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0,4.4D0,4.D0,3.5D0,2.85D0,
35271 & 2.35D0, 2.01D0, 1.8D0, 6*0.D0, 1.4D0,3.8D0,5.D0,4.7D0,4.4D0,4.D0,
35272 & 3.5D0,2.85D0,2.35D0,2.01D0,1.8D0,12*0.D0,.1D0,.8D0,2.05D0,3.31D0,
35273 & 3.5D0, 12*0.D0, .034D0,.2D0,.75D0,1.04D0,1.24D0 /
35274**** k- p data *
35275 DATA SKMPEL/ 0.D0, 35.D0, 22.D0, 25.D0, 17.D0, 9.D0, 9.5D0, 8.D0,
35276 & 7.D0, 6.5D0, 6.1D0, 5.D0, 4.8D0, 4.6D0, 4.45D0, 4.3D0, 4.2D0,
35277 & 0.D0, 8.D0, 3.5D0, 8.D0, 3.D0, 1.9D0, 1.7D0, 1.D0, .9D0, .8D0,
35278 & .75D0, .5D0, .42D0, .38D0, .34D0, .25D0, .2D0,
35279 & 0.D0, 3.D0, 3.2D0, 3.5D0, 1.5D0, 1.4D0, 1.1D0, .6D0, .5D0,
35280 & .35D0, .28D0, .25D0, .18D0, .12D0, .1D0, .08D0, .04D0,
35281 & 0.D0, 8.5D0, 2.4D0, 1.7D0, 1.3D0, 1.3D0, 1.1D0, .5D0,
35282 & .4D0, .4D0, .35D0, .3D0, .28D0, .2D0, .16D0, .13D0, .11D0,
35283 & 0.D0, 7.D0, 4.8D0, 1.4D0, 1.9D0, .9D0, .4D0, .2D0, .13D0,
35284 & .1D0, .08D0, .06D0, .04D0, .02D0, .015D0, .01D0, .01D0,
35285 & 0.D0, 5.5D0, 1.D0, .8D0, .75D0, .32D0, .2D0, .1D0, .09D0,
35286 & .08D0, .065D0, .05D0, .04D0, .022D0, .017D0, 2*.01D0/
35287 DATA SPIKP7 / 0.D0, .56D0, 1.46D0, 3.16D0, 2.01D0, 1.28D0, .74D0,
35288 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
35289 & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 4*0.D0,
35290 & 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, 1.57D0,
35291 & 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0, 3.03D0,
35292 & 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0,
35293 & .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, 2.8D0,
35294 & 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0,
35295 & .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
35296 & .45D0, .39D0, .22D0, .07D0, 0.D0, 7*0.D0, .34D0, 1.12D0, 1.12D0,
35297 & 1.01D0, .78D0, .45D0, .39D0, .22D0, .07D0, 0.D0, 6*0.D0, 1.71D0,
35298 & 4.26D0, 5.6D0, 5.57D0, 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0,
35299 & 2.25D0, 2.D0, 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
35300 & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, .22D0,
35301 & .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 10*0.D0, .22D0, .8D0,
35302 & .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, .3D0, .7D0,1.D0,
35303 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, 1.72D0, 2.69D0,
35304 & 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 9*0.D0, .11D0, 1.72D0,
35305 & 2.69D0, 3.92D0, 4.76D0, 5.1D0, 5.44D0, 5.3D0, 5*0.D0,9.2D0,4.7D0,
35306 & 1.9D0, 10*0.D0, 2.5D0, 15.D0, 21.5D0, 15.3D0, 3.D0, 1.5D0,
35307 & 10*0.D0/
35308***** k- n data *
35309 DATA SKMNEL/0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
35310 & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0,
35311 & 0.D0, 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0,
35312 & 1.9D0, .9D0, .5D0, .3D0, .24D0, .2D0, .18D0, .1D0, .09D0,
35313 & 0.D0, 1.8D0, 2.D0, 1.1D0, .9D0, .5D0, .5D0, .4D0, .4D0,
35314 & .2D0, .1D0, .06D0, .05D0, .04D0, .03D0, .02D0, .02D0,
35315 & 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, .7D0, .65D0,
35316 & .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, .03D0/
35317 DATA SPIKP8/0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
35318 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
35319 & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,
35320 & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
35321 & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
35322 & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
35323 & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
35324 & 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, .45D0,
35325 & .39D0, .22D0, .07D0, 0.D0,
35326 & 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
35327 & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0,
35328 & 10*0.D0, .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0,
35329 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0,
35330 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0,
35331 & 9*0.D0, .11D0, 1.72D0, 2.69D0, 3.92D0, 4.76D0,
35332 & 5.10D0, 5.44D0, 5.3D0,
35333 & 4*0.D0, 0.00D0, 9.2D0, 4.7D0, 1.9D0, 9*0.D0/
35334***** p p data *
35335 DATA SPIKP9/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
35336 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
35337 & 0.D0, 3.6D0, 1.7D0, 10*0.D0,
35338 & .0D0, 0.D0, 8.7D0, 17.7D0, 18.8D0, 15.9D0,
35339 & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
35340 & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
35341 & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
35342 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
35343 & 16.9D0, 16.5D0, 11.D0, 5.5D0, 3.5D0,
35344 & 10*0.D0, 4.3D0, 7.6D0, 9.D0,
35345 & 10*0.D0, 1.7D0, 2.6D0, 3.D0,
35346 & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
35347 & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
35348 & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
35349 & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/
35350***** p n data *
35351 DATA SPIKP0/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
35352 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
35353 & 0.D0, 1.8D0, .2D0, 12*0.D0,
35354 & 3.2D0, 6.05D0, 9.9D0, 5.1D0,
35355 & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
35356 & 2*.0D0, 3.2D0, 6.05D0, 9.9D0, 5.1D0,
35357 & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
35358 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
35359 & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
35360 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
35361 & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
35362 & 10*0.D0, .7D0, 5.1D0, 8.D0,
35363 & 10*0.D0, .7D0, 5.1D0, 8.D0,
35364 & 10*.0D0, .3D0, 2.8D0, 4.7D0,
35365 & 10*.0D0, .3D0, 2.8D0, 4.7D0,
35366 & 7*0.D0, 1.2D0, 2.5D0, 3.5D0, 6.D0, 5.3D0, 2.9D0,
35367 & 7*0.D0, 1.7D0, 3.6D0, 5.4D0, 9.D0, 7.6D0, 4.2D0,
35368 & 5*0.D0, 7.7D0, 6.1D0, 2.9D0, 5*0.D0/
35369* nn - data *
35370* *
35371 DATA SPKPV/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
35372 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
35373 & 0.D0, 3.6D0, 1.7D0, 12*0.D0,
35374 & 8.7D0, 17.7D0, 18.8D0, 15.9D0,
35375 & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
35376 & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
35377 & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
35378 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0, 16.9D0, 16.5D0,
35379 & 11.D0, 5.5D0, 3.5D0,
35380 & 10*0.D0, 4.3D0, 7.6D0, 9.D0,
35381 & 10*0.D0, 1.7D0, 2.6D0, 3.D0,
35382 & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
35383 & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
35384 & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
35385 & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/
35386**************** ap - p - data *
35387 DATA SAPPEL/ 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
35388 & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
35389 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0,
35390 & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
35391 & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
35392 & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
35393 & 0.D0, 55.D0, 50.D0, 25.D0, 15.D0, 15.D0, 14.D0, 12.D0,
35394 & 10.D0, 7.D0, 6.D0, 4.D0, 3.3D0, 2.8D0, 2.4D0, 2.D0, 1.8D0,
35395 & 1.55D0, 1.3D0, .95D0, .75D0,
35396 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
35397 & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
35398 & .01D0, .008D0, .006D0, .005D0/
35399 DATA SPIKPE/0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
35400 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
35401 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0,
35402 & 9*0.D0, 2.D0, 2.5D0, .2D0, 19*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0,
35403 & 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, .3D0, 1.4D0,
35404 & 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0,
35405 & .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0,
35406 & .3D0, 10*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0,
35407 & .6D0, .5D0, .4D0, .3D0, 9*0.D0, .6D0, 2.5D0, 5.D0, 5.2D0, 5.1D0,
35408 & 5.4D0, 5.8D0, 2.8D0, 2.1D0, 1.8D0, 1.6D0, 1.2D0, 13*0.D0, 1.3D0,
35409 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
35410 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
35411 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
35412 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 14*0.D0, .2D0,
35413 & .5D0, 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0,
35414 & 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0,
35415 & 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, 1.6D0,
35416 & 1.4D0, 1.1D0, .9D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0,
35417 & .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0,
35418 & 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0 /
35419**************** ap - n - data *
35420 DATA SAPNEL/
35421 & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
35422 & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
35423 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0,
35424 & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0,
35425 & .85D0, 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0,
35426 & .14D0, .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
35427 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
35428 & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
35429 & .01D0, .008D0, .006D0, .005D0 /
35430 DATA SPIKPZ/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
35431 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
35432 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
35433 & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35434 & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
35435 & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
35436 & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
35437 & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35438 & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35439 & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35440 & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
35441 & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
35442 & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
35443 & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
35444* *
35445* *
35446**************** an - p - data *
35447* *
35448 DATA SANPEL/
35449 & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, 50.D0,
35450 & 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
35451 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0, .05D0,
35452 & .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
35453 & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
35454 & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
35455 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, .25D0,
35456 & .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
35457 & .01D0, .008D0, .006D0, .005D0 /
35458 DATA SPIKPF/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
35459 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
35460 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
35461 & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35462 & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
35463 & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
35464 & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
35465 & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35466 & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35467 & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35468 & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
35469 & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
35470 & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
35471 & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
35472**** ko - n - data *
35473 DATA SPKP15/0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, 7.D0,
35474 & 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
35475 & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 10*0.D0,
35476 & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
35477 & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
35478 & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
35479 & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
35480 & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0,
35481 & 1.4D0, 1.2D0, 1.05D0, .9D0, .66D0, .5D0,
35482 & 7*0.D0, .3D0, 1.D0, 1.D0, .9D0, .7D0, .4D0, .30D0, .2D0,
35483 & 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.20D0, 4.55D0,
35484 & 4.85D0, 4.9D0,
35485 & 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, 1.6D0,
35486 & 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, 3.5D0,
35487 & 2.85D0, 2.35D0, 2.01D0, 1.8D0,
35488 & 12*0.D0, .1D0, .8D0, 2.05D0, 3.31D0, 3.5D0,
35489 & 12*0.D0, .034D0, .20D0, .75D0, 1.04D0, 1.24D0 /
35490**** ako - p - data *
35491 DATA SPKP16/ 0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
35492 & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, 0.D0,
35493 & 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, 1.9D0, .9D0, .5D0,
35494 & .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, 0.D0, 1.8D0, 2.D0, 1.1D0,
35495 & .9D0, .5D0, .5D0, .4D0, .4D0, .2D0, .1D0, .06D0, .05D0, .04D0,
35496 & .03D0, .02D0, .02D0, 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0,
35497 & .7D0, .65D0, .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0,
35498 & .03D0, 0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
35499 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0,
35500 & 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0,
35501 & 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0,
35502 & 1.01D0, .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0,
35503 & 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0,
35504 & .5D0, .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
35505 & .45D0, .39D0, .22D0, .07D0, 7*0.D0, 1.71D0, 4.26D0, 5.6D0,5.57D0,
35506 & 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0,
35507 & .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0,
35508 & .3D0, .7D0, 1.D0, 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0,
35509 & 1.72D0, 2.69D0, 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 5*0.D0,
35510 & 9.2D0, 4.7D0, 1.9D0, 9*0.D0, .0D0,2.5D0,15.D0,
35511 & 21.5D0, 15.3D0, 3.D0, 1.5D0, 10*0.D0 /
35512 DATA NURELN/9, 12, 5*0, 10, 14, 3*0, 1, 3, 5, 7, 6*0, 2, 6, 16,
35513 & 5*0, 10, 13, 5*0, 11, 12, 3*0, 2, 4, 6, 8, 6*0, 3, 15, 7, 5*0 /
35514*= end*block.blkdt3 *
35515 END
35516
35517*$ CREATE DT_QEL_POL.FOR
35518*COPY DT_QEL_POL
35519*
35520*===qel_pol============================================================*
35521*
35522 SUBROUTINE DT_QEL_POL(ENU,LTYP,P21,P22,P23,P24,P25)
35523
35524 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35525 SAVE
35526
35527 CALL DT_MASS_INI
35528 CALL DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
35529
35530 RETURN
35531 END
35532
35533*$ CREATE DT_GEN_QEL.FOR
35534*COPY DT_GEN_QEL
35535C==================================================================
35536C Generation of a Quasi-Elastic neutrino scattering
35537C==================================================================
35538*
35539*===gen_qel============================================================*
35540*
35541 SUBROUTINE DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
35542
35543C...Generate a quasi-elastic neutrino/antineutrino
35544C. Interaction on a nuclear target
35545C. INPUT : LTYP = neutrino type (1,...,6)
35546C. ENU (GeV) = neutrino energy
35547C----------------------------------------------------
35548
35549 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35550 SAVE
35551
35552 PARAMETER ( LINP = 10 ,
35553 & LOUT = 6 ,
35554 & LDAT = 9 )
35555 PARAMETER (MAXLND=4000)
35556 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
35557* nuclear potential
35558 LOGICAL LFERMI
35559 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
35560 & EBINDP(2),EBINDN(2),EPOT(2,210),
35561 & ETACOU(2),ICOUL,LFERMI
35562* steering flags for qel neutrino scattering modules
35563 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
35564**sr - removed (not needed)
35565C COMMON /CBAD/ LBAD, NBAD
35566C COMMON /CNUC/ XMN,XMN2,PFERMI,EFERMI,EBIND,EB2,C0
35567**
35568
35569 DIMENSION PI(3),PO(3)
35570CJR+
35571 DATA ININU/0/
35572CJR-
35573C REAL*8 DBETA(3)
35574C REAL*8 MN(2), ML0(6), ML, ML2, MI, MI2, MF, MF2
35575 DIMENSION DBETA(3),DBETB(3),AMN(2),AML0(6)
35576 DATA AMN /0.93827231D0, 0.93956563D0/
35577 DATA AML0 /2*0.51100D-03,2*0.105659D0, 2*1.777D0/
35578 DATA INIPRI/0/
35579
35580C DATA PFERMI/0.22D0/
35581CGB+...Binding Energy
35582 DATA EBIND/0.008D0/
35583CGB-...
35584
35585 ININU=ININU+1
35586 IF(ININU.EQ.1)NDSIG=0
35587 LBAD = 0
35588 enu0=enu
35589c write(*,*) enu0
35590C...Lepton mass
35591 AML = AML0(LTYP) ! massa leptoni
35592 AML2 = AML**2 ! massa leptoni **2
35593C...Particle labels (LUND)
35594 N = 5
35595 K(1,1) = 21
35596 K(2,1) = 21
35597 K(3,1) = 21
35598 K(3,3) = 1
35599 K(4,1) = 1
35600 K(4,3) = 1
35601 K(5,1) = 1
35602 K(5,3) = 2
35603 K0 = (LTYP-1)/2 ! 2
35604 K1 = LTYP/2 ! 2
35605 KA = 12 + 2*K0 ! 16
35606 IS = -1 + 2*LTYP - 4*K1 ! -1 +10 -8 = 1
35607 K(1,2) = IS*KA
35608 K(4,2) = IS*(KA-1)
35609 K(3,2) = IS*24
35610 LNU = 2 - LTYP + 2*K1 ! 2 - 5 + 2 = - 1
35611 IF (LNU .EQ. 2) THEN
35612 K(2,2) = 2212
35613 K(5,2) = 2112
35614 AMI = AMN(1)
35615 AMF = AMN(2)
35616CJR+
35617 PFERMI=PFERMN(2)
35618CJR-
35619 ELSE
35620 K(2,2) = 2112
35621 K(5,2) = 2212
35622 AMI = AMN(2)
35623 AMF = AMN(1)
35624CJR+
35625 PFERMI=PFERMP(2)
35626CJR-
35627 ENDIF
35628 AMI2 = AMI**2
35629 AMF2 = AMF**2
35630
35631 DO IGB=1,5
35632 P(3,IGB) = 0.
35633 P(4,IGB) = 0.
35634 P(5,IGB) = 0.
35635 END DO
35636
35637 NTRY = 0
35638CGB+...
35639 EFMAX = SQRT(PFERMI**2 + AMI2) -AMI ! max. Fermi Energy
35640 ENWELL = EFMAX + EBIND ! depth of nuclear potential well
35641CGB-...
35642
35643 100 CONTINUE
35644
35645C...4-momentum initial lepton
35646 P(1,5) = 0. ! massa
35647 P(1,4) = ENU0 ! energia
35648 P(1,1) = 0. ! px
35649 P(1,2) = 0. ! py
35650 P(1,3) = ENU0 ! pz
35651
35652C PF = PFERMI*PYR(0)**(1./3.)
35653c write(23,*) PYR(0)
35654c write(*,*) 'Pfermi=',PF
35655c PF = 0.
35656 NTRY=NTRY+1
35657C IF(ntry.GT.2) WRITE(*,*) ntry,enu0,k2
35658 IF (NTRY .GT. 500) THEN
35659 LBAD = 1
35660 WRITE (LOUT,1001) NBAD, ENU
35661 RETURN
35662 ENDIF
35663C CT = -1. + 2.*PYR(0)
35664c CT = -1.
35665C ST = SQRT(1.-CT*CT)
35666C F = 2.*3.1415926*PYR(0)
35667c F = 0.
35668
35669C P(2,4) = SQRT(PF*PF + MI2) - EBIND ! energia
35670C P(2,1) = PF*ST*COS(F) ! px
35671C P(2,2) = PF*ST*SIN(F) ! py
35672C P(2,3) = PF*CT ! pz
35673C P(2,5) = SQRT(P(2,4)**2-PF*PF) ! massa
35674 P(2,1) = P21
35675 P(2,2) = P22
35676 P(2,3) = P23
35677 P(2,4) = P24
35678 P(2,5) = P25
35679 beta1=-p(2,1)/p(2,4)
35680 beta2=-p(2,2)/p(2,4)
35681 beta3=-p(2,3)/p(2,4)
35682 N=2
35683C WRITE(6,*)' before transforming into target rest frame'
35684 CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
35685C print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
35686 N=5
35687
35688 phi11=atan(p(1,2)/p(1,3))
35689 pi(1)=p(1,1)
35690 pi(2)=p(1,2)
35691 pi(3)=p(1,3)
35692
35693 CALL DT_TESTROT(PI,Po,PHI11,1)
35694 DO ll=1,3
35695 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35696 END DO
35697c WRITE(*,*) po
35698 p(1,1)=po(1)
35699 p(1,2)=po(2)
35700 p(1,3)=po(3)
35701 phi12=atan(p(1,1)/p(1,3))
35702
35703 pi(1)=p(1,1)
35704 pi(2)=p(1,2)
35705 pi(3)=p(1,3)
35706 CALL DT_TESTROT(Pi,Po,PHI12,2)
35707 DO ll=1,3
35708 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35709 END DO
35710c WRITE(*,*) po
35711 p(1,1)=po(1)
35712 p(1,2)=po(2)
35713 p(1,3)=po(3)
35714
35715 enu=p(1,4)
35716
35717C...Kinematical limits in Q**2
35718c S = P(2,5)**2 + 2.*ENU*(P(2,4)-P(2,3)) ! ????
35719 S = P(2,5)**2 + 2.*ENU*P(2,5)
35720 SQS = SQRT(S) ! E centro massa
35721 IF (SQS .LT. (AML + AMF + 3.E-03)) GOTO 100
35722 ELF = (S-AMF2+AML2)/(2.*SQS) ! energia leptone finale p
35723 PSTAR = (S-P(2,5)**2)/(2.*SQS) ! p* neutrino nel c.m.
35724 PLF = SQRT(ELF**2-AML2) ! 3-momento leptone finale
35725 Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF) ! + o -
35726 Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF) ! according con cos(theta)
35727 IF (Q2MIN .LT. 0.) Q2MIN = 0. ! ??? non fisico
35728
35729C...Generate Q**2
35730 DSIGMAX = DT_DSQEL_Q2 (LTYP,ENU, Q2MIN)
35731 200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
35732 DSIG = DT_DSQEL_Q2 (LTYP,ENU, Q2)
35733 IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200
35734 CALL DT_QGAUS(Q2MIN,Q2MAX,DSIGEV,ENU,LTYP)
35735 NDSIG=NDSIG+1
35736C WRITE(6,*)' Q2,Q2min,Q2MAX,DSIGEV',
35737C &Q2,Q2min,Q2MAX,DSIGEV
35738
35739C...c.m. frame. Neutrino along z axis
35740 DETOT = (P(1,4)) + (P(2,4)) ! e totale
35741 DBETA(1) = ((P(1,1)) + (P(2,1)))/DETOT ! px1+px2/etot = beta_x
35742 DBETA(2) = ((P(1,2)) + (P(2,2)))/DETOT !
35743 DBETA(3) = ((P(1,3)) + (P(2,3)))/DETOT !
35744c WRITE(*,*)
35745c WRITE(*,*)
35746C WRITE(*,*) 'Input values laboratory frame'
35747 N=2
35748
35749 CALL PYROBO(0,0,0.0D0,0.0D0,-DBETA(1),-DBETA(2),-DBETA(3))
35750
35751 N=5
35752c STHETA = ULANGL(P(1,3),P(1,1))
35753c write(*,*) 'stheta' ,stheta
35754c stheta=0.
35755c CALL PYROBO (0,0,-STHETA,0.,0.D0,0.D0,0.D0)
35756c WRITE(*,*)
35757c WRITE(*,*)
35758C WRITE(*,*) 'Output values cm frame'
35759C...Kinematic in c.m. frame
35760 CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) ! cos(theta) cm
35761 STSTAR = SQRT(1.-CTSTAR**2)
35762 PHI = 6.28319*PYR(0) ! random phi tra 0 e 2*pi
35763 P(4,5) = AML ! massa leptone
35764 P(4,4) = ELF ! e leptone
35765 P(4,3) = PLF*CTSTAR ! px
35766 P(4,1) = PLF*STSTAR*COS(PHI) ! py
35767 P(4,2) = PLF*STSTAR*SIN(PHI) ! pz
35768
35769 P(5,5) = AMF ! barione
35770 P(5,4) = (S+AMF2-AML2)/(2.*SQS)! e barione
35771 P(5,3) = -P(4,3) ! px
35772 P(5,1) = -P(4,1) ! py
35773 P(5,2) = -P(4,2) ! pz
35774
35775 P(3,5) = -Q2
35776 P(3,1) = P(1,1)-P(4,1)
35777 P(3,2) = P(1,2)-P(4,2)
35778 P(3,3) = P(1,3)-P(4,3)
35779 P(3,4) = P(1,4)-P(4,4)
35780
35781C...Transform back to laboratory frame
35782C WRITE(*,*) 'before going back to nucl rest frame'
35783c CALL PYROBO (0,0,STHETA,0.,0.D0,0.D0,0.D0)
35784 N=5
35785
35786 CALL PYROBO(0,0,0.0D0,0.0D0,DBETA(1),DBETA(2),DBETA(3))
35787
35788C WRITE(*,*) 'Now back in nucl rest frame'
35789 IF(LTYP.GE.3) CALL DT_PREPOLA(Q2,LTYP,ENU)
35790
35791c********************************************
35792
35793 DO kw=1,5
35794 pi(1)=p(kw,1)
35795 pi(2)=p(kw,2)
35796 pi(3)=p(kw,3)
35797 CALL DT_TESTROT(Pi,Po,PHI12,3)
35798 DO ll=1,3
35799 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35800 END DO
35801 p(kw,1)=po(1)
35802 p(kw,2)=po(2)
35803 p(kw,3)=po(3)
35804 END DO
35805c********************************************
35806
35807 DO kw=1,5
35808 pi(1)=p(kw,1)
35809 pi(2)=p(kw,2)
35810 pi(3)=p(kw,3)
35811 CALL DT_TESTROT(Pi,Po,PHI11,4)
35812 DO ll=1,3
35813 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35814 END DO
35815 p(kw,1)=po(1)
35816 p(kw,2)=po(2)
35817 p(kw,3)=po(3)
35818 END DO
35819
35820c********************************************
35821
35822C WRITE(*,*) 'Now back in lab frame'
35823
35824 CALL PYROBO(1,5,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
35825
35826CGB+...
35827C...test (on final momentum of nucleon) if Fermi-blocking
35828C...is operating
35829 ENUCL = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2 + P(5,5)**2)
35830 & - P(5,5)
35831 IF (ENUCL.LT. EFMAX) THEN
35832 IF(INIPRI.LT.10)THEN
35833 INIPRI=INIPRI+1
35834C WRITE(6,*)' qel: Pauli ENUCL.LT.EFMAX ', ENUCL,EFMAX
35835C...the interaction is not possible due to Pauli-Blocking and
35836C...it must be resampled
35837 ENDIF
35838 GOTO 100
35839 ELSE IF (ENUCL.LT.ENWELL.and.ENUCL.GE.EFMAX) THEN
35840 IF(INIPRI.LT.10)THEN
35841 INIPRI=INIPRI+1
35842C WRITE(6,*)' qel: inside ENUCL.LT.ENWELL ', ENUCL,ENWELL
35843 ENDIF
35844C Reject (J:R) here all these events
35845C are otherwise rejected in dpmjet
35846 GOTO 100
35847C...the interaction is possible, but the nucleon remains inside
35848C...the nucleus. The nucleus is therefore left excited.
35849C...We treat this case as a nucleon with 0 kinetic energy.
35850C P(5,5) = AMF
35851C P(5,4) = AMF
35852C P(5,1) = 0.
35853C P(5,2) = 0.
35854C P(5,3) = 0.
35855 ELSE IF (ENUCL.GE.ENWELL) THEN
35856C WRITE(6,*)' qel ENUCL.GE.ENWELL ',ENUCL,ENWELL
35857C...the interaction is possible, the nucleon can exit the nucleus
35858C...but the nuclear well depth must be subtracted. The nucleus could be
35859C...left in an excited state.
35860 Pstart = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2)
35861C P(5,4) = ENUCL-ENWELL + AMF
35862 Pnucl = SQRT(P(5,4)**2-AMF**2)
35863C...The 3-momentum is scaled assuming that the direction remains
35864C...unaffected
35865 P(5,1) = P(5,1) * Pnucl/Pstart
35866 P(5,2) = P(5,2) * Pnucl/Pstart
35867 P(5,3) = P(5,3) * Pnucl/Pstart
35868C WRITE(6,*)' qel new P(5,4) ',P(5,4)
35869 ENDIF
35870CGB-...
35871 DSIGSU=DSIGSU+DSIGEV
35872
35873 GA=P(4,4)/P(4,5)
35874 BGX=P(4,1)/P(4,5)
35875 BGY=P(4,2)/P(4,5)
35876 BGZ=P(4,3)/P(4,5)
35877*
35878 DBETB(1)=BGX/GA
35879 DBETB(2)=BGY/GA
35880 DBETB(3)=BGZ/GA
35881 IF(NEUDEC.EQ.1.OR.NEUDEC.EQ.2) THEN
35882
35883 CALL PYROBO(6,8,0.0D0,0.0D0,DBETB(1),DBETB(2),DBETB(3))
35884
35885 ENDIF
35886c
35887C PRINT*,' FINE EVENTO '
35888 enu=enu0
35889 RETURN
35890
35891 1001 FORMAT(2X, 'DT_GEN_QEL : event rejected ', I5, G10.3)
35892 END
35893
35894*$ CREATE DT_MASS_INI.FOR
35895*COPY DT_MASS_INI
35896C====================================================================
35897C. Masses
35898C====================================================================
35899*
35900*===mass_ini===========================================================*
35901*
35902 SUBROUTINE DT_MASS_INI
35903C...Initialize the kinematics for the quasi-elastic cross section
35904
35905 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35906 SAVE
35907
35908* particle masses used in qel neutrino scattering modules
35909 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
35910 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
35911 & EMPROTSQ,EMNEUTSQ,EMNSQ
35912
35913 EML(1) = 0.51100D-03 ! e-
35914 EML(2) = EML(1) ! e+
35915 EML(3) = 0.105659D0 ! mu-
35916 EML(4) = EML(3) ! mu+
35917 EML(5) = 1.7777D0 ! tau-
35918 EML(6) = EML(5) ! tau+
35919 EMPROT = 0.93827231D0 ! p
35920 EMNEUT = 0.93956563D0 ! n
35921 EMPROTSQ = EMPROT**2
35922 EMNEUTSQ = EMNEUT**2
35923 EMN = (EMPROT + EMNEUT)/2.
35924 EMNSQ = EMN**2
35925 DO J=1,3
35926 J0 = 2*(J-1)
35927 EMN1(J0+1) = EMNEUT
35928 EMN1(J0+2) = EMPROT
35929 EMN2(J0+1) = EMPROT
35930 EMN2(J0+2) = EMNEUT
35931 ENDDO
35932 DO J=1,6
35933 EMLSQ(J) = EML(J)**2
35934 ETQE(J) = ((EMN2(J)+ EML(J))**2-EMN1(J)**2)/(2.*EMN1(J))
35935 ENDDO
35936 RETURN
35937 END
35938
35939*$ CREATE DT_DSQEL_Q2.FOR
35940*COPY DT_DSQEL_Q2
35941*
35942*===dsqel_q2===========================================================*
35943*
35944 DOUBLE PRECISION FUNCTION DT_DSQEL_Q2 (JTYP,ENU, Q2)
35945
35946C...differential cross section for Quasi-Elastic scattering
35947C. nu + N -> l + N'
35948C. From Llewellin Smith Phys.Rep. 3C, 261, (1971).
35949C.
35950C. INPUT : JTYP = 1,...,6 nu_e, ...., nubar_tau
35951C. ENU (GeV) = Neutrino energy
35952C. Q2 (GeV**2) = (Transfer momentum)**2
35953C.
35954C. OUTPUT : DSQEL_Q2 = differential cross section :
35955C. dsigma/dq**2 (10**-38 cm+2/GeV**2)
35956C------------------------------------------------------------------
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**sr - removed (not needed)
35966C COMMON /CAXIAL/ FA0, AXIAL2
35967**
35968
35969 DIMENSION SS(6)
35970 DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
35971 DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
35972 DATA AXIAL2 /1.03D0/ ! to be checked
35973
35974 FA0=-1.253D0
35975 CSI = 3.71D0 ! ???
35976 GVE = 1.D0/ (1.D0 + Q2/0.84D0**2)**2 ! G_e(q**2)
35977 GVM = (1.D0+CSI)*GVE ! G_m (q**2)
35978 X = Q2/(EMN*EMN) ! emn=massa barione
35979 XA = X/4.D0
35980 FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
35981 FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
35982 FA = FA0/(1.D0 + Q2/AXIAL2)**2
35983 FFA = FA*FA
35984 FFV1 = FV1*FV1
35985 FFV2 = FV2*FV2
35986 RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp)
35987 A1 = (4.D0+X)*FFA - (4.D0-X)*FFV1 + X*FFV2*(1.D0-XA)+4*X*FV1*FV2
35988 A2 = -RM * ((FV1 + FV2)**2 + FFA)
35989 AA = (XA+0.25D0*RM)*(A1 + A2)
35990 BB = -X*FA*(FV1 + FV2)
35991 CC = 0.25D0*(FFA + FFV1 + XA*FFV2)
35992 SU = (4.D0*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
35993 DT_DSQEL_Q2 = C0*(AA + SS(JTYP)*BB*SU + CC*SU*SU) / (ENU*ENU) !
35994 IF(DT_DSQEL_Q2 .LT. 0.D0) DT_DSQEL_Q2 = 0.D0
35995
35996 RETURN
35997 END
35998
35999*$ CREATE DT_PREPOLA.FOR
36000*COPY DT_PREPOLA
36001*
36002*===prepola============================================================*
36003*
36004 SUBROUTINE DT_PREPOLA(Q2,JTYP,ENU)
36005
36006 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36007 SAVE
36008c
36009c By G. Battistoni and E. Scapparone (sept. 1997)
36010c According to:
36011c Albright & Jarlskog, Nucl Phys B84 (1975) 467
36012c
36013c
36014 PARAMETER (MAXLND=4000)
36015 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
36016 COMMON /QNPOL/ POLARX(4),PMODUL
36017* particle masses used in qel neutrino scattering modules
36018 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
36019 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
36020 & EMPROTSQ,EMNEUTSQ,EMNSQ
36021* steering flags for qel neutrino scattering modules
36022 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
36023**sr - removed (not needed)
36024C COMMON /CAXIAL/ FA0, AXIAL2
36025C COMMON /TAUTAU/Q(4,5),ETL,PXL,PYL,PZL,
36026C & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN
36027**
36028 REAL*8 POL(4,4),BB2(3)
36029 DIMENSION SS(6)
36030C DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
36031 DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
36032**sr uncommented since common block CAXIAL is now commented
36033 DATA AXIAL2 /1.03D0/ ! to be checked
36034**
36035
36036 RML=P(4,5)
36037 RMM=0.93960D+00
36038 FM2 = RMM**2
36039 MPI = 0.135D+00
36040 OLDQ2=Q2
36041 FA0=-1.253D+00
36042 CSI = 3.71D+00 !
36043 GVE = 1.D0/ (1.D0 + Q2/(0.84D+00)**2)**2 ! G_e(q**2)
36044 GVM = (1.D0+CSI)*GVE ! G_m (q**2)
36045 X = Q2/(EMN*EMN) ! emn=massa barione
36046 XA = X/4.D0
36047 FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
36048 FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
36049 FA = FA0/(1.D0 + Q2/AXIAL2**2)**2
36050 FFA = FA*FA
36051 FFV1 = FV1*FV1
36052 FFV2 = FV2*FV2
36053 FP=2.D0*FA*RMM/(MPI**2 + Q2)
36054 RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp)
36055 A1 = (4.D0+X)*FFA-(4.D0-X)*FFV1+X*FFV2*(1.D0-XA)+4.D0*X*FV1*FV2
36056 A2 = -RM * ((FV1 + FV2)**2 + FFA)
36057 AA = (XA+0.25D+00*RM)*(A1 + A2)
36058 BB = -X*FA*(FV1 + FV2)
36059 CC = 0.25D+00*(FFA + FFV1 + XA*FFV2)
36060 SU = (4.D+00*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
36061
36062 OMEGA1=FFA+XA*(FFA+(FV1+FV2)**2 ) ! articolo di ll...-smith
36063 OMEGA2=4.D+00*CC
36064 OMEGA3=2.D+00*FA*(FV1+FV2)
36065 OMEGA4P=(-(FV1+FV2)**2-(FA+2*FP)**2+(4.0D+00+
36066 1 (Q2/FM2))*FP**2)
36067 OMEGA5=OMEGA2
36068 OMEGA4=(OMEGA4P-OMEGA2+2*OMEGA5)/4.D+00
36069 WW1=2.D+00*OMEGA1*EMN**2
36070 WW2=2.D+00*OMEGA2*EMN**2
36071 WW3=2.D+00*OMEGA3*EMN**2
36072 WW4=2.D+00*OMEGA4*EMN**2
36073 WW5=2.D+00*OMEGA5*EMN**2
36074
36075 DO I=1,3
36076 BB2(I)=-P(4,I)/P(4,4)
36077 END DO
36078c WRITE(*,*)
36079c WRITE(*,*)
36080c WRITE(*,*) 'Prepola: ready to transform to lepton rest frame'
36081 N=5
36082 CALL PYROBO(0,0,0.0D0,0.0D0,BB2(1),BB2(2),BB2(3))
36083* NOW PARTICLES ARE IN THE SCATTERED LEPTON REST FRAME
36084c WRITE(*,*)
36085c WRITE(*,*)
36086c WRITE(*,*) 'Prepola: now in lepton rest frame'
36087 EE=ENU
36088 QM2=Q2+RML**2
36089 U=Q2/(2.*RMM)
36090 FRAC=QM2*WW1 + (2.D+00*EE*(EE-U) - 0.5D+00*QM2)*WW2 - SS(JTYP)*
36091 + (0.5D+00/(RMM**2))*(2.D+00*RMM*EE*Q2 - U*QM2)*WW3 +
36092 + ((RML**2)/(2.D+00*FM2))*(QM2*WW4-2.D+00*RMM*EE*WW5) !<=FM2 inv di RMM!!
36093
36094 FACTK=2.D+00*WW1 -WW2 -SS(JTYP)*(EE/RMM)*WW3 +((EE-U)/RMM)*WW5
36095 + - ((RML**2)/FM2)*WW4 !<=FM2 inv di RMM!!
36096
36097 FACTP=2.D+00*EE/RMM*WW2 - (QM2/(2.D+00*RMM**2))*(SS(JTYP)*WW3+WW5)
36098
36099 DO I=1,3
36100 POL(4,I)=RML*SS(JTYP)*(FACTK*P(1,I)+FACTP*P(2,I))/FRAC
36101 POLARX(I)=POL(4,I)
36102 END DO
36103
36104 PMODUL=0.D0
36105 DO I=1,3
36106 PMODUL=PMODUL+POL(4,I)**2
36107 END DO
36108
36109 IF(JTYP.GT.4.AND.NEUDEC.GT.0) THEN
36110 IF(NEUDEC.EQ.1) THEN
36111 CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-2),POLARX(3),
36112 + ETL,PXL,PYL,PZL,
36113 + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
36114c
36115c Tau has decayed in muon
36116c
36117 ENDIF
36118 IF(NEUDEC.EQ.2) THEN
36119 CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-4),POLARX(3),
36120 + ETL,PXL,PYL,PZL,
36121 + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
36122c
36123c Tau has decayed in electron
36124c
36125 ENDIF
36126 K(4,1)=15
36127 K(4,4) = 6
36128 K(4,5) = 8
36129 N=N+3
36130c
36131c fill common for muon(electron)
36132c
36133 P(6,1)=PXL
36134 P(6,2)=PYL
36135 P(6,3)=PZL
36136 P(6,4)=ETL
36137 K(6,1)=1
36138 IF(JTYP.EQ.5) THEN
36139 IF(NEUDEC.EQ.1) THEN
36140 P(6,5)=EML(JTYP-2)
36141 K(6,2)=13
36142 ELSEIF(NEUDEC.EQ.2) THEN
36143 P(6,5)=EML(JTYP-4)
36144 K(6,2)=11
36145 ENDIF
36146 ELSEIF(JTYP.EQ.6) THEN
36147 IF(NEUDEC.EQ.1) THEN
36148 K(6,2)=-13
36149 ELSEIF(NEUDEC.EQ.2) THEN
36150 K(6,2)=-11
36151 ENDIF
36152 END IF
36153 K(6,3)=4
36154 K(6,4)=0
36155 K(6,5)=0
36156c
36157c fill common for tau_(anti)neutrino
36158c
36159 P(7,1)=PXB
36160 P(7,2)=PYB
36161 P(7,3)=PZB
36162 P(7,4)=ETB
36163 P(7,5)=0.
36164 K(7,1)=1
36165 IF(JTYP.EQ.5) THEN
36166 K(7,2)=16
36167 ELSEIF(JTYP.EQ.6) THEN
36168 K(7,2)=-16
36169 END IF
36170 K(7,3)=4
36171 K(7,4)=0
36172 K(7,5)=0
36173c
36174c Fill common for muon(electron)_(anti)neutrino
36175c
36176 P(8,1)=PXN
36177 P(8,2)=PYN
36178 P(8,3)=PZN
36179 P(8,4)=ETN
36180 P(8,5)=0.
36181 K(8,1)=1
36182 IF(JTYP.EQ.5) THEN
36183 IF(NEUDEC.EQ.1) THEN
36184 K(8,2)=-14
36185 ELSEIF(NEUDEC.EQ.2) THEN
36186 K(8,2)=-12
36187 ENDIF
36188 ELSEIF(JTYP.EQ.6) THEN
36189 IF(NEUDEC.EQ.1) THEN
36190 K(8,2)=14
36191 ELSEIF(NEUDEC.EQ.2) THEN
36192 K(8,2)=12
36193 ENDIF
36194 END IF
36195 K(8,3)=4
36196 K(8,4)=0
36197 K(8,5)=0
36198 ENDIF
36199c WRITE(*,*)
36200c WRITE(*,*)
36201
36202c IF(PMODUL.GE.1.D+00) THEN
36203c WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
36204c write(*,*) pmodul
36205c DO I=1,3
36206c POL(4,I)=POL(4,I)/PMODUL
36207c POLARX(I)=POL(4,I)
36208c END DO
36209c PMODUL=0.
36210c DO I=1,3
36211c PMODUL=PMODUL+POL(4,I)**2
36212c END DO
36213c WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
36214c
36215c ENDIF
36216
36217c WRITE(*,*) 'PMODUL = ',PMODUL
36218
36219c WRITE(*,*)
36220c WRITE(*,*)
36221c WRITE(*,*) 'prepola: Now back to nucl rest frame'
36222 CALL PYROBO(1,5,0.0D0,0.0D0,-BB2(1),-BB2(2),-BB2(3))
36223
36224 XDC = V(4,1)+V(4,5)*P(4,1)/P(4,5)
36225 YDC = V(4,2)+V(4,5)*P(4,2)/P(4,5)
36226 ZDC = V(4,3)+V(4,5)*P(4,3)/P(4,5)
36227 DO NDC =6,8
36228 V(NDC,1) = XDC
36229 V(NDC,2) = YDC
36230 V(NDC,3) = ZDC
36231 END DO
36232
36233 RETURN
36234 END
36235
36236*$ CREATE DT_TESTROT.FOR
36237*COPY DT_TESTROT
36238*
36239*===testrot============================================================*
36240*
36241 SUBROUTINE DT_TESTROT(PI,PO,PHI,MODE)
36242
36243 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36244 SAVE
36245
36246 DIMENSION ROT(3,3),PI(3),PO(3)
36247
36248 IF (MODE.EQ.1) THEN
36249 ROT(1,1) = 1.D0
36250 ROT(1,2) = 0.D0
36251 ROT(1,3) = 0.D0
36252 ROT(2,1) = 0.D0
36253 ROT(2,2) = COS(PHI)
36254 ROT(2,3) = -SIN(PHI)
36255 ROT(3,1) = 0.D0
36256 ROT(3,2) = SIN(PHI)
36257 ROT(3,3) = COS(PHI)
36258 ELSEIF (MODE.EQ.2) THEN
36259 ROT(1,1) = 0.D0
36260 ROT(1,2) = 1.D0
36261 ROT(1,3) = 0.D0
36262 ROT(2,1) = COS(PHI)
36263 ROT(2,2) = 0.D0
36264 ROT(2,3) = -SIN(PHI)
36265 ROT(3,1) = SIN(PHI)
36266 ROT(3,2) = 0.D0
36267 ROT(3,3) = COS(PHI)
36268 ELSEIF (MODE.EQ.3) THEN
36269 ROT(1,1) = 0.D0
36270 ROT(2,1) = 1.D0
36271 ROT(3,1) = 0.D0
36272 ROT(1,2) = COS(PHI)
36273 ROT(2,2) = 0.D0
36274 ROT(3,2) = -SIN(PHI)
36275 ROT(1,3) = SIN(PHI)
36276 ROT(2,3) = 0.D0
36277 ROT(3,3) = COS(PHI)
36278 ELSEIF (MODE.EQ.4) THEN
36279 ROT(1,1) = 1.D0
36280 ROT(2,1) = 0.D0
36281 ROT(3,1) = 0.D0
36282 ROT(1,2) = 0.D0
36283 ROT(2,2) = COS(PHI)
36284 ROT(3,2) = -SIN(PHI)
36285 ROT(1,3) = 0.D0
36286 ROT(2,3) = SIN(PHI)
36287 ROT(3,3) = COS(PHI)
36288 ELSE
36289 STOP ' TESTROT: mode not supported!'
36290 ENDIF
36291 DO 1 J=1,3
36292 PO(J) = ROT(J,1)*PI(1)+ROT(J,2)*PI(2)+ROT(J,3)*PI(3)
36293 1 CONTINUE
36294
36295 RETURN
36296 END
36297
36298*$ CREATE DT_LEPDCYP.FOR
36299*COPY DT_LEPDCYP
36300*
36301*===lepdcyp============================================================*
36302*
36303 SUBROUTINE DT_LEPDCYP(AMA,AML,POL,ETL,PXL,PYL,PZL,
36304 & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
36305C
36306C-----------------------------------------------------------------
36307C
36308C Author :- G. Battistoni 10-NOV-1995
36309C
36310C=================================================================
36311C
36312C Purpose : performs decay of polarized lepton in
36313C its rest frame: a => b + l + anti-nu
36314C (Example: mu- => nu-mu + e- + anti-nu-e)
36315C Polarization is assumed along Z-axis
36316C WARNING:
36317C 1) b AND anti-nu ARE ASSUMED TO BE NEUTRINOS
36318C OF NEGLIGIBLE MASS
36319C 2) RADIATIVE CORRECTIONS ARE NOT CONSIDERED
36320C IN THIS VERSION
36321C
36322C Method : modifies phase space distribution obtained
36323C by routine EXPLOD using a rejection against the
36324C matrix element for unpolarized lepton decay
36325C
36326C Inputs : Mass of a : AMA
36327C Mass of l : AML
36328C Polar. of a: POL
36329C (Example: fully polar. mu- decay: AMA=AMMUON, AML=AMELCT,
36330C POL = -1)
36331C
36332C Outputs : kinematic variables in the rest frame of decaying lepton
36333C ETL,PXL,PYL,PZL 4-moment of l
36334C ETB,PXB,PYB,PZB 4-moment of b
36335C ETN,PXN,PYN,PZN 4-moment of anti-nu
36336C
36337C============================================================
36338C +
36339C Declarations.
36340C -
36341 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36342 SAVE
36343
36344 PARAMETER ( LINP = 10 ,
36345 & LOUT = 6 ,
36346 & LDAT = 9 )
36347 PARAMETER ( KALGNM = 2 )
36348 PARAMETER ( ANGLGB = 5.0D-16 )
36349 PARAMETER ( ANGLSQ = 2.5D-31 )
36350 PARAMETER ( AXCSSV = 0.2D+16 )
36351 PARAMETER ( ANDRFL = 1.0D-38 )
36352 PARAMETER ( AVRFLW = 1.0D+38 )
36353 PARAMETER ( AINFNT = 1.0D+30 )
36354 PARAMETER ( AZRZRZ = 1.0D-30 )
36355 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
36356 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
36357 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
36358 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
36359 PARAMETER ( CSNNRM = 2.0D-15 )
36360 PARAMETER ( DMXTRN = 1.0D+08 )
36361 PARAMETER ( ZERZER = 0.D+00 )
36362 PARAMETER ( ONEONE = 1.D+00 )
36363 PARAMETER ( TWOTWO = 2.D+00 )
36364 PARAMETER ( THRTHR = 3.D+00 )
36365 PARAMETER ( FOUFOU = 4.D+00 )
36366 PARAMETER ( FIVFIV = 5.D+00 )
36367 PARAMETER ( SIXSIX = 6.D+00 )
36368 PARAMETER ( SEVSEV = 7.D+00 )
36369 PARAMETER ( EIGEIG = 8.D+00 )
36370 PARAMETER ( ANINEN = 9.D+00 )
36371 PARAMETER ( TENTEN = 10.D+00 )
36372 PARAMETER ( HLFHLF = 0.5D+00 )
36373 PARAMETER ( ONETHI = ONEONE / THRTHR )
36374 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
36375 PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
36376 PARAMETER ( ENEPER = 2.7182818284590452354 D+00 )
36377 PARAMETER ( SQRENT = 1.6487212707001281468 D+00 )
36378 PARAMETER ( CLIGHT = 2.99792458 D+10 )
36379 PARAMETER ( AVOGAD = 6.0221367 D+23 )
36380 PARAMETER ( AMELGR = 9.1093897 D-28 )
36381 PARAMETER ( PLCKBR = 1.05457266 D-27 )
36382 PARAMETER ( ELCCGS = 4.8032068 D-10 )
36383 PARAMETER ( ELCMKS = 1.60217733 D-19 )
36384 PARAMETER ( AMUGRM = 1.6605402 D-24 )
36385 PARAMETER ( AMMUMU = 0.113428913 D+00 )
36386 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
36387 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
36388 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
36389 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
36390 PARAMETER ( PLABRC = 0.197327053 D+00 )
36391 PARAMETER ( AMELCT = 0.51099906 D-03 )
36392 PARAMETER ( AMUGEV = 0.93149432 D+00 )
36393 PARAMETER ( AMMUON = 0.105658389 D+00 )
36394 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
36395 PARAMETER ( GEVMEV = 1.0 D+03 )
36396 PARAMETER ( EMVGEV = 1.0 D-03 )
36397 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
36398 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
36399 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
36400C +
36401C variables for EXPLOD
36402C -
36403 PARAMETER ( KPMX = 10 )
36404 DIMENSION AMEXPL (KPMX), PXEXPL (KPMX), PYEXPL (KPMX),
36405 & PZEXPL (KPMX), ETEXPL (KPMX)
36406C +
36407C test variables
36408C -
36409**sr - removed (not needed)
36410C COMMON /GBATNU/ ELERAT,NTRY
36411**
36412C +
36413C Initializes test variables
36414C -
36415 NTRY = 0
36416 ELERAT = 0.D+00
36417C +
36418C Maximum value for matrix element
36419C -
36420 ELEMAX = ( AMA**2 + AML**2 )**2 / AMA**2 * ( AMA**2 - AML**2 +
36421 & SQRT( AMA**4 + AML**4 - 3.D+00 * AMA**2 * AML**2 ) )
36422C + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
36423C Inputs for EXPLOD
36424C part. no. 1 is l (e- in mu- decay)
36425C part. no. 2 is b (nu-mu in mu- decay)
36426C part. no. 3 is anti-nu (anti-nu-e in mu- decay)
36427C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
36428 NPEXPL = 3
36429 ETOTEX = AMA
36430 AMEXPL(1) = AML
36431 AMEXPL(2) = 0.D+00
36432 AMEXPL(3) = 0.D+00
36433C +
36434C phase space distribution
36435C -
36436 100 CONTINUE
36437 NTRY = NTRY + 1
36438
36439 CALL DT_EXPLOD ( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
36440 & PYEXPL, PZEXPL )
36441
36442C +
36443C Calculates matrix element:
36444C 64*GF**2{[P(a)-ama*S(a)]*P(anti-nu)}{P(l)*P(b)}
36445C Here CTH is the cosine of the angle between anti-nu and Z axis
36446C -
36447 CTH = PZEXPL(3) / SQRT ( PXEXPL(3)**2 + PYEXPL(3)**2 +
36448 & PZEXPL(3)**2 )
36449 PROD1 = ETEXPL(3) * AMA * (1.D+00 - POL * CTH)
36450 PROD2 = ETEXPL(1) * ETEXPL(2) - PXEXPL(1)*PXEXPL(2) -
36451 & PYEXPL(1)*PYEXPL(2) - PZEXPL(1)*PZEXPL(2)
36452 ELEMAT = 16.D+00 * PROD1 * PROD2
36453 IF(ELEMAT.GT.ELEMAX) THEN
36454 WRITE(LOUT,*) 'Problems in LEPDCY',ELEMAX,ELEMAT
36455 STOP
36456 ENDIF
36457C +
36458C Here performs the rejection
36459C -
36460 TEST = DT_RNDM(ETOTEX) * ELEMAX
36461 IF ( TEST .GT. ELEMAT ) GO TO 100
36462C +
36463C final assignment of variables
36464C -
36465 ELERAT = ELEMAT/ELEMAX
36466 ETL = ETEXPL(1)
36467 PXL = PXEXPL(1)
36468 PYL = PYEXPL(1)
36469 PZL = PZEXPL(1)
36470 ETB = ETEXPL(2)
36471 PXB = PXEXPL(2)
36472 PYB = PYEXPL(2)
36473 PZB = PZEXPL(2)
36474 ETN = ETEXPL(3)
36475 PXN = PXEXPL(3)
36476 PYN = PYEXPL(3)
36477 PZN = PZEXPL(3)
36478 999 RETURN
36479 END
36480
36481*$ CREATE DT_GEN_DELTA.FOR
36482*COPY DT_GEN_DELTA
36483C==================================================================
36484C. Generation of Delta resonance events
36485C==================================================================
36486*
36487*===gen_delta==========================================================*
36488*
36489 SUBROUTINE DT_GEN_DELTA(ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25)
36490
36491 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36492 SAVE
36493
36494 PARAMETER ( LINP = 10 ,
36495 & LOUT = 6 ,
36496 & LDAT = 9 )
36497C...Generate a Delta-production neutrino/antineutrino
36498C. CC-interaction on a nucleon
36499C
36500C. INPUT ENU (GeV) = Neutrino Energy
36501C. LLEP = neutrino type
36502C. LTARG = nucleon target type 1=p, 2=n.
36503C. JINT = 1:CC, 2::NC
36504C.
36505C. OUTPUT PPL(4) 4-monentum of final lepton
36506C----------------------------------------------------
36507 PARAMETER (MAXLND=4000)
36508 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
36509**sr - removed (not needed)
36510C COMMON /CBAD/ LBAD, NBAD
36511**
36512
36513 DIMENSION PI(3),PO(3)
36514C REAL*4 AMD0, AMD, AMN(2), AML0(6), AML, AML2, AMDMIN
36515 DIMENSION AML0(6),AMN(2)
36516 DATA AMD0 /1.231/, GAMD /0.12/, DELD/0.169/, AMDMIN/1.084/
36517 DATA AMN /0.93827231, 0.93956563/
36518 DATA AML0 /2*0.51100E-03,2*0.105659, 2*1.777/
36519
36520c WRITE(6,*)' GEN_DEL',ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25
36521 LBAD = 0
36522C...Final lepton mass
36523 IF (JINT.EQ.1) THEN
36524 AML = AML0(LLEP)
36525 ELSE
36526 AML = 0.
36527 ENDIF
36528 AML2 = AML**2
36529
36530C...Particle labels (LUND)
36531 N = 5
36532 K(1,1) = 21
36533 K(2,1) = 21
36534 K(3,1) = 21
36535 K(4,1) = 1
36536 K(3,3) = 1
36537 K(4,3) = 1
36538 IF (LTARG .EQ. 1) THEN
36539 K(2,2) = 2212
36540 ELSE
36541 K(2,2) = 2112
36542 ENDIF
36543 K0 = (LLEP-1)/2
36544 K1 = LLEP/2
36545 KA = 12 + 2*K0
36546 IS = -1 + 2*LLEP - 4*K1
36547 LNU = 2 - LLEP + 2*K1
36548 K(1,2) = IS*KA
36549 K(5,1) = 1
36550 K(5,3) = 2
36551 IF (JINT .EQ. 1) THEN ! CC interactions
36552 K(3,2) = IS*24
36553 K(4,2) = IS*(KA-1)
36554 IF(LNU.EQ.1) THEN
36555 IF (LTARG .EQ. 1) THEN
36556 K(5,2) = 2224
36557 ELSE
36558 K(5,2) = 2214
36559 ENDIF
36560 ELSE
36561 IF (LTARG .EQ. 1) THEN
36562 K(5,2) = 2114
36563 ELSE
36564 K(5,2) = 1114
36565 ENDIF
36566 ENDIF
36567 ELSE
36568 K(3,2) = 23 ! NC (Z0) interactions
36569 K(4,2) = K(1,2)
36570**sr 7.5.00: swop Delta's (bug), Delta+ for proton (LTARG=1),
36571* Delta0 for neutron (LTARG=2)
36572C IF (LTARG .EQ. 1) THEN
36573C K(5,2) = 2114
36574C ELSE
36575C K(5,2) = 2214
36576C ENDIF
36577 IF (LTARG .EQ. 1) THEN
36578 K(5,2) = 2214
36579 ELSE
36580 K(5,2) = 2114
36581 ENDIF
36582**
36583 ENDIF
36584
36585C...4-momentum initial lepton
36586 P(1,5) = 0.
36587 P(1,4) = ENU
36588 P(1,1) = 0.
36589 P(1,2) = 0.
36590 P(1,3) = ENU
36591C...4-momentum initial nucleon
36592 P(2,5) = AMN(LTARG)
36593C P(2,4) = P(2,5)
36594C P(2,1) = 0.
36595C P(2,2) = 0.
36596C P(2,3) = 0.
36597 P(2,1) = P21
36598 P(2,2) = P22
36599 P(2,3) = P23
36600 P(2,4) = P24
36601 P(2,5) = P25
36602 N=2
36603 beta1=-p(2,1)/p(2,4)
36604 beta2=-p(2,2)/p(2,4)
36605 beta3=-p(2,3)/p(2,4)
36606 N=2
36607
36608 CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
36609
36610C print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
36611
36612 phi11=atan(p(1,2)/p(1,3))
36613 pi(1)=p(1,1)
36614 pi(2)=p(1,2)
36615 pi(3)=p(1,3)
36616
36617 CALL DT_TESTROT(PI,Po,PHI11,1)
36618 DO ll=1,3
36619 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36620 END DO
36621 p(1,1)=po(1)
36622 p(1,2)=po(2)
36623 p(1,3)=po(3)
36624 phi12=atan(p(1,1)/p(1,3))
36625
36626 pi(1)=p(1,1)
36627 pi(2)=p(1,2)
36628 pi(3)=p(1,3)
36629 CALL DT_TESTROT(Pi,Po,PHI12,2)
36630 DO ll=1,3
36631 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36632 END DO
36633 p(1,1)=po(1)
36634 p(1,2)=po(2)
36635 p(1,3)=po(3)
36636
36637 ENUU=P(1,4)
36638
36639C...Generate the Mass of the Delta
36640 NTRY = 0
36641100 R = PYR(0)
36642 AMD=AMD0+0.5*GAMD*TAN((2.*R-1.)*ATAN(2.*DELD/GAMD))
36643 NTRY = NTRY + 1
36644 IF (NTRY .GT. 1000) THEN
36645 LBAD = 1
36646 WRITE (LOUT,1001) NBAD, ENUU,AMD,AMDMIN,AMD0,GAMD,ET
36647 RETURN
36648 ENDIF
36649 IF (AMD .LT. AMDMIN) GOTO 100
36650 ET = ((AMD+AML)**2 - AMN(LTARG)**2)/(2.*AMN(LTARG))
36651 IF (ENUU .LT. ET) GOTO 100
36652
36653C...Kinematical limits in Q**2
36654 S = AMN(LTARG)**2 + 2.*AMN(LTARG)*ENUU
36655 SQS = SQRT(S)
36656 PSTAR = (S - AMN(LTARG)**2)/(2.*SQS)
36657 ELF = (S - AMD**2 + AML2)/(2.*SQS)
36658 PLF = SQRT(ELF**2 - AML2)
36659 Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)
36660 Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)
36661 IF (Q2MIN .LT. 0.) Q2MIN = 0.
36662
36663 DSIGMAX = DT_DSIGMA_DELTA(LNU,-Q2MIN, S, AML, AMD)
36664200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
36665 DSIG = DT_DSIGMA_DELTA(LNU,-Q2, S, AML, AMD)
36666 IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200
36667
36668C...Generate the kinematics of the final particles
36669 EISTAR = (S + AMN(LTARG)**2)/(2.*SQS)
36670 GAM = EISTAR/AMN(LTARG)
36671 BET = PSTAR/EISTAR
36672 CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF)
36673 EL = GAM*(ELF + BET*PLF*CTSTAR)
36674 PLZ = GAM*(PLF*CTSTAR + BET*ELF)
36675 PL = SQRT(EL**2 - AML2)
36676 PLT = SQRT(MAX(1.D-06,(PL*PL - PLZ*PLZ)))
36677 PHI = 6.28319*PYR(0)
36678 P(4,1) = PLT*COS(PHI)
36679 P(4,2) = PLT*SIN(PHI)
36680 P(4,3) = PLZ
36681 P(4,4) = EL
36682 P(4,5) = AML
36683
36684C...4-momentum of Delta
36685 P(5,1) = -P(4,1)
36686 P(5,2) = -P(4,2)
36687 P(5,3) = ENUU-P(4,3)
36688 P(5,4) = ENUU+AMN(LTARG)-P(4,4)
36689 P(5,5) = AMD
36690
36691C...4-momentum of intermediate boson
36692 P(3,5) = -Q2
36693 P(3,4) = P(1,4)-P(4,4)
36694 P(3,1) = P(1,1)-P(4,1)
36695 P(3,2) = P(1,2)-P(4,2)
36696 P(3,3) = P(1,3)-P(4,3)
36697 N=5
36698
36699 DO kw=1,5
36700 pi(1)=p(kw,1)
36701 pi(2)=p(kw,2)
36702 pi(3)=p(kw,3)
36703 CALL DT_TESTROT(Pi,Po,PHI12,3)
36704 DO ll=1,3
36705 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36706 END DO
36707 p(kw,1)=po(1)
36708 p(kw,2)=po(2)
36709 p(kw,3)=po(3)
36710 END DO
36711
36712c********************************************
36713
36714 DO kw=1,5
36715 pi(1)=p(kw,1)
36716 pi(2)=p(kw,2)
36717 pi(3)=p(kw,3)
36718 CALL DT_TESTROT(Pi,Po,PHI11,4)
36719 DO ll=1,3
36720 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36721 END DO
36722 p(kw,1)=po(1)
36723 p(kw,2)=po(2)
36724 p(kw,3)=po(3)
36725 END DO
36726c********************************************
36727C transform back into Lab.
36728
36729 CALL PYROBO(0,0,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
36730
36731C WRITE(6,*)' Lab fram ( fermi incl.) '
36732 N=5
36733 CALL PYEXEC
36734
36735 RETURN
367361001 FORMAT(2X, 'DT_GEN_DELTA : event rejected ', I5, 6G10.3)
36737 END
36738
36739*$ CREATE DT_DSIGMA_DELTA.FOR
36740*COPY DT_DSIGMA_DELTA
36741*
36742*===dsigma_delta=======================================================*
36743*
36744 DOUBLE PRECISION FUNCTION DT_DSIGMA_DELTA (LNU, QQ, S, AML, MD)
36745
36746 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36747 SAVE
36748
36749C...Reaction nu + N -> lepton + Delta
36750C. returns the cross section
36751C. dsigma/dt
36752C. INPUT LNU = 1, 2 (neutrino-antineutrino)
36753C. QQ = t (always negative) GeV**2
36754C. S = (c.m energy)**2 GeV**2
36755C. OUTPUT = 10**-38 cm+2/GeV**2
36756C-----------------------------------------------------
36757 REAL*8 MN, MN2, MN4, MD,MD2, MD4
36758 DATA MN /0.938/
36759 DATA PI /3.1415926/
36760
36761 GF = (1.1664 * 1.97)
36762 GF2 = GF*GF
36763 MN2 = MN*MN
36764 MN4 = MN2*MN2
36765 MD2 = MD*MD
36766 MD4 = MD2*MD2
36767 AML2 = AML*AML
36768 AML4 = AML2*AML2
36769 VQ = (MN2 - MD2 - QQ)/2.
36770 VPI = (MN2 + MD2 - QQ)/2.
36771 VK = (S + QQ - MN2 - AML2)/2.
36772 PIK = (S - MN2)/2.
36773 QK = (AML2 - QQ)/2.
36774 PIQ = (QQ + MN2 - MD2)/2.
36775 Q = SQRT(-QQ)
36776 C3V = 2.07*SQRT(EXP(-6.3*Q)*(1.+9*Q))
36777 C3 = SQRT(3.)*C3V/MN
36778 C4 = -C3/MD ! attenzione al segno
36779 C5A = 1.18/(1.-QQ/0.4225)**2
36780 C32 = C3**2
36781 C42 = C4**2
36782 C5A2 = C5A**2
36783
36784 IF (LNU .EQ. 1) THEN
36785 ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
36786 . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
36787 . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
36788 . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
36789 ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
36790 . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
36791 . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
36792 . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
36793 . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
36794 . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ-
36795 . 4.*MN*C3*C5A*MD2*VK*QQ+4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
36796 . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
36797 . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
36798 . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
36799 . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK-MD*
36800 . C3*C5A*MD2*PIK*QQ+MD*C3*C5A*MD2*QK*PIQ-3.*MD*C3*C5A
36801 . *VK*VPI*QQ+MD*C3*C5A*VK*VQ*PIQ+3.*MD*C3*C5A*VPI*VQ*
36802 . QK-MD*C3*C5A*VQ**2*PIK+C4*C5A*MD2*VK*VPI*QQ+C4*C5A*
36803 . MD2*VK*VQ*PIQ-C4*C5A*MD2*VPI*VQ*QK-C4*C5A*MD2*VQ**2
36804 . *PIK-C4*C5A*MD4*PIK*QQ+C4*C5A*MD4*QK*PIQ-2.*MD2*VK
36805 . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
36806 . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
36807 . *C42-2.*MD2*VPI*QK**2*C32+ANS3
36808 ELSE
36809 ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
36810 . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
36811 . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
36812 . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
36813 ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
36814 . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
36815 . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
36816 . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
36817 . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
36818 . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ+
36819 . 4.*MN*C3*C5A*MD2*VK*QQ-4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
36820 . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
36821 . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
36822 . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
36823 . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK+MD*
36824 . C3*C5A*MD2*PIK*QQ-MD*C3*C5A*MD2*QK*PIQ+3.*MD*C3*C5A
36825 . *VK*VPI*QQ-MD*C3*C5A*VK*VQ*PIQ-3.*MD*C3*C5A*VPI*VQ*
36826 . QK+MD*C3*C5A*VQ**2*PIK-C4*C5A*MD2*VK*VPI*QQ-C4*C5A*
36827 . MD2*VK*VQ*PIQ+C4*C5A*MD2*VPI*VQ*QK+C4*C5A*MD2*VQ**2
36828 . *PIK+C4*C5A*MD4*PIK*QQ-C4*C5A*MD4*QK*PIQ-2.*MD2*VK
36829 . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
36830 . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
36831 . *C42-2.*MD2*VPI*QK**2*C32+ANS3
36832 ENDIF
36833 ANS1=32.*ANS2
36834 ANS=ANS1/(3.*MD2)
36835 P1CM = (S-MN2)/(2.*SQRT(S))
36836 DT_DSIGMA_DELTA = GF2/2. * ANS/(64.*PI*S*P1CM**2)
36837
36838 RETURN
36839 END
36840
36841*$ CREATE DT_QGAUS.FOR
36842*COPY DT_QGAUS
36843*
36844*===qgaus==============================================================*
36845*
36846 SUBROUTINE DT_QGAUS(A,B,SS,ENU,LTYP)
36847
36848 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36849 SAVE
36850
36851 DIMENSION X(5),W(5)
36852 DATA X/.1488743389D0,.4333953941D0,
36853 & .6794095682D0,.8650633666D0,.9739065285D0
36854 */
36855 DATA W/.2955242247D0,.2692667193D0,
36856 & .2190863625D0,.1494513491D0,.0666713443D0
36857 */
36858 XM=0.5D0*(B+A)
36859 XR=0.5D0*(B-A)
36860 SS=0
36861 DO 11 J=1,5
36862 DX=XR*X(J)
36863 SS=SS+W(J)*(DT_DSQEL_Q2(LTYP,ENU,XM+DX)+
36864 * DT_DSQEL_Q2(LTYP,ENU,XM-DX))
3686511 CONTINUE
36866 SS=XR*SS
36867
36868 RETURN
36869 END
36870
36871*$ CREATE DT_DIQBRK.FOR
36872*COPY DT_DIQBRK
36873*
36874*===diqbrk=============================================================*
36875*
36876 SUBROUTINE DT_DIQBRK
36877
36878 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36879 SAVE
36880
36881* event history
36882 PARAMETER (NMXHKK=200000)
36883 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36884 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36885 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36886* extended event history
36887 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36888 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36889 & IHIST(2,NMXHKK)
36890* event flag
36891 COMMON /DTEVNO/ NEVENT,ICASCA
36892
36893C IF(DT_RNDM(VV).LE.0.5D0)THEN
36894C CALL GSQBS1(NHKK)
36895C CALL GSQBS2(NHKK)
36896C CALL USQBS1(NHKK)
36897C CALL USQBS2(NHKK)
36898C CALL GSABS1(NHKK)
36899C CALL GSABS2(NHKK)
36900C CALL USABS1(NHKK)
36901C CALL USABS2(NHKK)
36902C ELSE
36903C CALL GSQBS2(NHKK)
36904C CALL GSQBS1(NHKK)
36905C CALL USQBS2(NHKK)
36906C CALL USQBS1(NHKK)
36907C CALL GSABS2(NHKK)
36908C CALL GSABS1(NHKK)
36909C CALL USABS2(NHKK)
36910C CALL USABS1(NHKK)
36911C ENDIF
36912
36913 IF(DT_RNDM(VV).LE.0.5D0) THEN
36914 CALL DT_DBREAK(1)
36915 CALL DT_DBREAK(2)
36916 CALL DT_DBREAK(3)
36917 CALL DT_DBREAK(4)
36918 CALL DT_DBREAK(5)
36919 CALL DT_DBREAK(6)
36920 CALL DT_DBREAK(7)
36921 CALL DT_DBREAK(8)
36922 ELSE
36923 CALL DT_DBREAK(2)
36924 CALL DT_DBREAK(1)
36925 CALL DT_DBREAK(4)
36926 CALL DT_DBREAK(3)
36927 CALL DT_DBREAK(6)
36928 CALL DT_DBREAK(5)
36929 CALL DT_DBREAK(8)
36930 CALL DT_DBREAK(7)
36931 ENDIF
36932
36933 RETURN
36934 END
36935
36936*$ CREATE MUSQBS2.FOR
36937*COPY MUSQBS2
36938C
36939C
36940C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
36941 SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36942 * IP1,IP21,IP22,IPP1,IPP2,IPIP,ISQ,IGCOUN)
36943C
36944C USQBS-2 diagram (split target diquark)
36945C
36946 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36947 SAVE
36948
36949 PARAMETER ( LINP = 10 ,
36950 & LOUT = 6 ,
36951 & LDAT = 9 )
36952* event history
36953 PARAMETER (NMXHKK=200000)
36954 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36955 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36956 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36957* extended event history
36958 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36959 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36960 & IHIST(2,NMXHKK)
36961* Lorentz-parameters of the current interaction
36962 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
36963 & UMO,PPCM,EPROJ,PPROJ
36964* diquark-breaking mechanism
36965 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
36966
36967C
36968 PARAMETER (NTMHKK= 300)
36969 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
36970 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
36971 +(4,NTMHKK)
36972*KEEP,XSEADI.
36973 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
36974 +SSMIMQ,VVMTHR
36975*KEEP,DPRIN.
36976 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
36977 COMMON /EVFLAG/ NUMEV
36978C
36979C USQBS-2 diagram (split target diquark)
36980C
36981C
36982C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
36983C Input chain 2(NC2) sea-antiquark(NC2P)-sea-quark(NC2T)
36984C
36985C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
36986C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
36987C
36988C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
36989C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36990C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
36991C
36992C
36993C Put new chains into COMMON /HKKTMP/
36994C
36995 IIGLU1=NC1T-NC1P-1
36996 IIGLU2=NC2T-NC2P-1
36997 IGCOUN=0
36998C WRITE(LOUT,*)'MUSQBS2: IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
36999 CVQ=1.D0
37000 IREJ=0
37001 IF(IPIP.EQ.2)THEN
37002C IF(NUMEV.EQ.-324)THEN
37003C WRITE(LOUT,*)' MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37004C * 'IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN)',
37005C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37006C * IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN
37007 ENDIF
37008C
37009C
37010C
37011C determine x-values of NC1T diquark
37012 XDIQT=PHKK(4,NC1T)*2.D0/UMO
37013 XVQP=PHKK(4,NC1P)*2.D0/UMO
37014C
37015C determine x-values of sea quark pair
37016C
37017 IPCO=1
37018 ICOU=0
37019 2234 CONTINUE
37020 ICOU=ICOU+1
37021 IF(ICOU.GE.500)THEN
37022 IREJ=1
37023 IF(ISQ.EQ.3)IREJ=3
37024 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 2234 ICOU. GT.500'
37025 IPCO=0
37026 RETURN
37027 ENDIF
37028 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS2 call XSEAPA: UMO,XDIQT,XVQP ',
37029 * UMO, XDIQT,XVQP
37030 XSQ=0.D0
37031 XSAQ=0.D0
37032**NEW
37033C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37034 IF (IPIP.EQ.1) THEN
37035 XQMAX = XDIQT/2.0D0
37036 XAQMAX = 2.D0*XVQP/3.0D0
37037 ELSE
37038 XQMAX = 2.D0*XVQP/3.0D0
37039 XAQMAX = XDIQT/2.0D0
37040 ENDIF
37041 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37042 ISAQ = 6+ISQ
37043C write(*,*) 'MUSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
37044**
37045 IF(IPCO.GE.3)
37046 & WRITE(LOUT,*)'MUSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37047 IF(IREJ.GE.1)THEN
37048 IF(IPCO.GE.3)
37049 & WRITE(LOUT,*)'MUSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37050 IPCO=0
37051 RETURN
37052 ENDIF
37053 IF(IPIP.EQ.1)THEN
37054 IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37055 ELSEIF(IPIP.EQ.2)THEN
37056 IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37057 ENDIF
37058 IF(IPCO.GE.3)THEN
37059 WRITE(LOUT,'(A,4E12.4)')' MUSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
37060 * XDIQT,XVQP,XSQ,XSAQ
37061 ENDIF
37062C
37063C subtract xsq,xsaq from NC1T diquark and NC1P quark
37064C
37065C XSQ=0.D0
37066 IF(IPIP.EQ.1)THEN
37067 XDIQT=XDIQT-XSQ
37068 XVQP =XVQP -XSAQ
37069 ELSEIF(IPIP.EQ.2)THEN
37070 XDIQT=XDIQT-XSAQ
37071 XVQP =XVQP -XSQ
37072 ENDIF
37073 IF(IPCO.GE.3)
37074 & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
37075C
37076C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37077C
37078 XVTHRO=CVQ/UMO
37079 IVTHR=0
37080 3466 CONTINUE
37081 IF(IVTHR.EQ.10)THEN
37082 IREJ=1
37083 IF(ISQ.EQ.3)IREJ=3
37084 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 3466 reject IVTHR 10'
37085 IPCO=0
37086 RETURN
37087 ENDIF
37088 IVTHR=IVTHR+1
37089 XVTHR=XVTHRO/(201-IVTHR)
37090 UNOPRV=UNON
37091 380 CONTINUE
37092 IF(XVTHR.GT.0.66D0*XDIQT)THEN
37093 IREJ=1
37094 IF(ISQ.EQ.3)IREJ=3
37095 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 380 XVTHR large ',
37096 * XVTHR
37097 IPCO=0
37098 RETURN
37099 ENDIF
37100 IF(DT_RNDM(V).LT.0.5D0)THEN
37101 XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37102 XVTQII=XDIQT-XVTQI
37103 ELSE
37104 XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37105 XVTQI=XDIQT-XVTQII
37106 ENDIF
37107 IF(IPCO.GE.3)THEN
37108 WRITE(LOUT,'(A,2E12.4)')' MUSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
37109 ENDIF
37110C
37111C Prepare 4 momenta of new chains and chain ends
37112C
37113C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37114C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37115C +(4,NTMHKK)
37116C
37117C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
37118C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37119C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37120C
37121C SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37122C * IP1,IP21,IP22,IPP1,IPP2)
37123C
37124 IF(IPIP.EQ.1)THEN
37125 XSQ1=XSQ
37126 XSAQ1=XSAQ
37127 ISQ1=ISQ
37128 ISAQ1=ISAQ
37129 ELSEIF(IPIP.EQ.2)THEN
37130 XSQ1=XSAQ
37131 XSAQ1=XSQ
37132 ISQ1=ISAQ
37133 ISAQ1=ISQ
37134 ENDIF
37135 IDHKT(1) =IPP1
37136 ISTHKT(1) =951
37137 JMOHKT(1,1)=NC2P
37138 JMOHKT(2,1)=0
37139 JDAHKT(1,1)=3+IIGLU1
37140 JDAHKT(2,1)=0
37141C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
37142 PHKT(1,1) =PHKK(1,NC2P)
37143 PHKT(2,1) =PHKK(2,NC2P)
37144 PHKT(3,1) =PHKK(3,NC2P)
37145 PHKT(4,1) =PHKK(4,NC2P)
37146C PHKT(5,1) =PHKK(5,NC2P)
37147 XMIST =(PHKT(4,1)**2-
37148 * PHKT(3,1)**2-PHKT(2,1)**2-
37149 *PHKT(1,1)**2)
37150 IF(XMIST.GT.0.D0)THEN
37151 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
37152 *PHKT(1,1)**2)
37153 ELSE
37154C WRITE(LOUT,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
37155 PHKT(5,1)=0.D0
37156 ENDIF
37157 VHKT(1,1) =VHKK(1,NC2P)
37158 VHKT(2,1) =VHKK(2,NC2P)
37159 VHKT(3,1) =VHKK(3,NC2P)
37160 VHKT(4,1) =VHKK(4,NC2P)
37161 WHKT(1,1) =WHKK(1,NC2P)
37162 WHKT(2,1) =WHKK(2,NC2P)
37163 WHKT(3,1) =WHKK(3,NC2P)
37164 WHKT(4,1) =WHKK(4,NC2P)
37165C Add here IIGLU1 gluons to this chaina
37166 PG1=0.D0
37167 PG2=0.D0
37168 PG3=0.D0
37169 PG4=0.D0
37170 IF(IIGLU1.GE.1)THEN
37171 JJG=NC1P
37172 DO 61 IIG=2,2+IIGLU1-1
37173 KKG=JJG+IIG-1
37174 IDHKT(IIG) =IDHKK(KKG)
37175 ISTHKT(IIG) =921
37176 JMOHKT(1,IIG)=KKG
37177 JMOHKT(2,IIG)=0
37178 JDAHKT(1,IIG)=3+IIGLU1
37179 JDAHKT(2,IIG)=0
37180 PHKT(1,IIG)=PHKK(1,KKG)
37181 PG1=PG1+ PHKT(1,IIG)
37182 PHKT(2,IIG)=PHKK(2,KKG)
37183 PG2=PG2+ PHKT(2,IIG)
37184 PHKT(3,IIG)=PHKK(3,KKG)
37185 PG3=PG3+ PHKT(3,IIG)
37186 PHKT(4,IIG)=PHKK(4,KKG)
37187 PG4=PG4+ PHKT(4,IIG)
37188 PHKT(5,IIG)=PHKK(5,KKG)
37189 VHKT(1,IIG) =VHKK(1,KKG)
37190 VHKT(2,IIG) =VHKK(2,KKG)
37191 VHKT(3,IIG) =VHKK(3,KKG)
37192 VHKT(4,IIG) =VHKK(4,KKG)
37193 WHKT(1,IIG) =WHKK(1,KKG)
37194 WHKT(2,IIG) =WHKK(2,KKG)
37195 WHKT(3,IIG) =WHKK(3,KKG)
37196 WHKT(4,IIG) =WHKK(4,KKG)
37197 61 CONTINUE
37198 ENDIF
37199 IDHKT(2+IIGLU1) =IP21
37200 ISTHKT(2+IIGLU1) =952
37201 JMOHKT(1,2+IIGLU1)=NC1T
37202 JMOHKT(2,2+IIGLU1)=0
37203 JDAHKT(1,2+IIGLU1)=3+IIGLU1
37204 JDAHKT(2,2+IIGLU1)=0
37205 PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
37206 PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
37207 PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
37208 PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
37209C PHKT(5,2) =PHKK(5,NC1T)
37210 XMIST =(PHKT(4,2+IIGLU1)**2-
37211 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37212 *PHKT(1,2+IIGLU1)**2)
37213 IF(XMIST.GT.0.D0)THEN
37214 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
37215 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37216 *PHKT(1,2+IIGLU1)**2)
37217 ELSE
37218C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
37219 PHKT(5,5+IIGLU1)=0.D0
37220 ENDIF
37221 VHKT(1,2+IIGLU1) =VHKK(1,NC1T)
37222 VHKT(2,2+IIGLU1) =VHKK(2,NC1T)
37223 VHKT(3,2+IIGLU1) =VHKK(3,NC1T)
37224 VHKT(4,2+IIGLU1) =VHKK(4,NC1T)
37225 WHKT(1,2+IIGLU1) =WHKK(1,NC1T)
37226 WHKT(2,2+IIGLU1) =WHKK(2,NC1T)
37227 WHKT(3,2+IIGLU1) =WHKK(3,NC1T)
37228 WHKT(4,2+IIGLU1) =WHKK(4,NC1T)
37229 IDHKT(3+IIGLU1) =88888
37230 ISTHKT(3+IIGLU1) =95
37231 JMOHKT(1,3+IIGLU1)=1
37232 JMOHKT(2,3+IIGLU1)=2+IIGLU1
37233 JDAHKT(1,3+IIGLU1)=0
37234 JDAHKT(2,3+IIGLU1)=0
37235 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
37236 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
37237 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
37238 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
37239 XMIST
37240 * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37241 * -PHKT(3,3+IIGLU1)**2)
37242 IF(XMIST.GT.0.D0)THEN
37243 PHKT(5,3+IIGLU1)
37244 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37245 * -PHKT(3,3+IIGLU1)**2)
37246 ELSE
37247C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
37248 PHKT(5,5+IIGLU1)=0.D0
37249 ENDIF
37250 IF(IPIP.GE.2)THEN
37251C IF(NUMEV.EQ.-324)THEN
37252C WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
37253C * JDAHKT(1,1),
37254C *JDAHKT(2,1),(PHKT(III,1),III=1,5)
37255 DO 71 IIG=2,2+IIGLU1-1
37256C WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
37257C & JMOHKT(1,IIG),JMOHKT(2,IIG),
37258C * JDAHKT(1,IIG),
37259C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37260 71 CONTINUE
37261C WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
37262C * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
37263C *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
37264C WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
37265C * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
37266C *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
37267 ENDIF
37268 CHAMAL=CHAM1
37269 IF(IPIP.EQ.1)THEN
37270 IF(IPP1.LE.-3.OR.IP21.GE.3)CHAMAL=CHAM3
37271 ELSEIF(IPIP.EQ.2)THEN
37272 IF(IPP1.GE.3.OR.IP21.LE.-3)CHAMAL=CHAM3
37273 ENDIF
37274 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
37275C IREJ=1
37276 IPCO=0
37277C RETURN
37278C WRITE(LOUT,*)' MUSQBS1 jump back from chain 3'
37279 GO TO 3466
37280 ENDIF
37281 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
37282 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
37283 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
37284 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
37285 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
37286 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
37287 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
37288 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
37289 IF(IPIP.EQ.1)THEN
37290 IDHKT(4+IIGLU1) =-(ISAQ1-6)
37291 ELSEIF(IPIP.EQ.2)THEN
37292 IDHKT(4+IIGLU1) =ISAQ1
37293 ENDIF
37294 ISTHKT(4+IIGLU1) =951
37295 JMOHKT(1,4+IIGLU1)=NC1P
37296 JMOHKT(2,4+IIGLU1)=0
37297 JDAHKT(1,4+IIGLU1)=6+IIGLU1
37298 JDAHKT(2,4+IIGLU1)=0
37299C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37300 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
37301 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
37302 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
37303 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
37304C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
37305 XMIST =(PHKT(4,4+IIGLU1)**2-
37306 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37307 *PHKT(1,4+IIGLU1)**2)
37308 IF(XMIST.GT.0.D0)THEN
37309 PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2-
37310 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37311 *PHKT(1,4+IIGLU1)**2)
37312 ELSE
37313C WRITE(LOUT,*)'MUSQBS2 parton 4 mass square LT.0 ',XMIST
37314 PHKT(5,4+IIGLU1)=0.D0
37315 ENDIF
37316 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
37317 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
37318 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
37319 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
37320 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
37321 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
37322 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
37323 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
37324 IDHKT(5+IIGLU1) =IP22
37325 ISTHKT(5+IIGLU1) =952
37326 JMOHKT(1,5+IIGLU1)=NC1T
37327 JMOHKT(2,5+IIGLU1)=0
37328 JDAHKT(1,5+IIGLU1)=6+IIGLU1
37329 JDAHKT(2,5+IIGLU1)=0
37330 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
37331 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
37332 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
37333 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
37334C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
37335 XMIST =(PHKT(4,5+IIGLU1)**2-
37336 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37337 *PHKT(1,5+IIGLU1)**2)
37338 IF(XMIST.GT.0.D0)THEN
37339 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
37340 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37341 *PHKT(1,5+IIGLU1)**2)
37342 ELSE
37343C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37344 PHKT(5,5+IIGLU1)=0.D0
37345 ENDIF
37346 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
37347 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
37348 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
37349 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
37350 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
37351 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
37352 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
37353 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
37354 IDHKT(6+IIGLU1) =88888
37355 ISTHKT(6+IIGLU1) =95
37356 JMOHKT(1,6+IIGLU1)=4+IIGLU1
37357 JMOHKT(2,6+IIGLU1)=5+IIGLU1
37358 JDAHKT(1,6+IIGLU1)=0
37359 JDAHKT(2,6+IIGLU1)=0
37360 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37361 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37362 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37363 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37364 XMIST
37365 * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37366 * -PHKT(3,6+IIGLU1)**2)
37367 IF(XMIST.GT.0.D0)THEN
37368 PHKT(5,6+IIGLU1)
37369 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37370 * -PHKT(3,6+IIGLU1)**2)
37371 ELSE
37372C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37373 PHKT(5,5+IIGLU1)=0.D0
37374 ENDIF
37375C IF(IPIP.GE.2)THEN
37376C IF(NUMEV.EQ.-324)THEN
37377C WRITE(6,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
37378C * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
37379C *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
37380C WRITE(6,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
37381C * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
37382C *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
37383C WRITE(6,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
37384C * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
37385C *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
37386C ENDIF
37387 CHAMAL=CHAM1
37388 IF(IPIP.EQ.1)THEN
37389 IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
37390 ELSEIF(IPIP.EQ.2)THEN
37391 IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
37392 ENDIF
37393 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37394C IREJ=1
37395 IPCO=0
37396C RETURN
37397C WRITE(6,*)' MUSQBS1 jump back from chain 6',
37398C * CHAMAL,PHKT(5,6+IIGLU1)
37399 GO TO 3466
37400 ENDIF
37401 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
37402 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
37403 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
37404 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
37405 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
37406 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
37407 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
37408 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
37409C IDHKT(7) =1000*IPP1+100*ISQ+1
37410 IDHKT(7+IIGLU1) =IP1
37411 ISTHKT(7+IIGLU1) =951
37412 JMOHKT(1,7+IIGLU1)=NC1P
37413 JMOHKT(2,7+IIGLU1)=0
37414**NEW
37415C JDAHKT(1,7+IIGLU1)=9+IIGLU1
37416 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
37417**
37418 JDAHKT(2,7+IIGLU1)=0
37419 PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
37420 PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
37421 PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
37422 PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
37423C PHKT(5,7+IIGLU1) =PHKK(5,NC1P)
37424 XMIST =(PHKT(4,7+IIGLU1)**2-
37425 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
37426 *PHKT(1,7+IIGLU1)**2)
37427 IF(XMIST.GT.0.D0)THEN
37428 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
37429 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
37430 *PHKT(1,7+IIGLU1)**2)
37431 ELSE
37432C WRITE(6,*)'MUSQBS2 parton 7 mass square LT.0 ',XMIST
37433 PHKT(5,7+IIGLU1)=0.D0
37434 ENDIF
37435 VHKT(1,7+IIGLU1) =VHKK(1,NC1P)
37436 VHKT(2,7+IIGLU1) =VHKK(2,NC1P)
37437 VHKT(3,7+IIGLU1) =VHKK(3,NC1P)
37438 VHKT(4,7+IIGLU1) =VHKK(4,NC1P)
37439 WHKT(1,7+IIGLU1) =WHKK(1,NC1P)
37440 WHKT(2,7+IIGLU1) =WHKK(2,NC1P)
37441 WHKT(3,7+IIGLU1) =WHKK(3,NC1P)
37442 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
37443C Insert here the IIGLU2 gluons
37444 PG1=0.D0
37445 PG2=0.D0
37446 PG3=0.D0
37447 PG4=0.D0
37448 IF(IIGLU2.GE.1)THEN
37449 JJG=NC2P
37450 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37451 KKG=JJG+IIG-7-IIGLU1
37452 IDHKT(IIG) =IDHKK(KKG)
37453 ISTHKT(IIG) =921
37454 JMOHKT(1,IIG)=KKG
37455 JMOHKT(2,IIG)=0
37456 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
37457 JDAHKT(2,IIG)=0
37458 PHKT(1,IIG)=PHKK(1,KKG)
37459 PG1=PG1+ PHKT(1,IIG)
37460 PHKT(2,IIG)=PHKK(2,KKG)
37461 PG2=PG2+ PHKT(2,IIG)
37462 PHKT(3,IIG)=PHKK(3,KKG)
37463 PG3=PG3+ PHKT(3,IIG)
37464 PHKT(4,IIG)=PHKK(4,KKG)
37465 PG4=PG4+ PHKT(4,IIG)
37466 PHKT(5,IIG)=PHKK(5,KKG)
37467 VHKT(1,IIG) =VHKK(1,KKG)
37468 VHKT(2,IIG) =VHKK(2,KKG)
37469 VHKT(3,IIG) =VHKK(3,KKG)
37470 VHKT(4,IIG) =VHKK(4,KKG)
37471 WHKT(1,IIG) =WHKK(1,KKG)
37472 WHKT(2,IIG) =WHKK(2,KKG)
37473 WHKT(3,IIG) =WHKK(3,KKG)
37474 WHKT(4,IIG) =WHKK(4,KKG)
37475 81 CONTINUE
37476 ENDIF
37477 IF(IPIP.EQ.1)THEN
37478 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3
37479 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
37480 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
37481 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
37482 ELSEIF(IPIP.EQ.2)THEN
37483 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3
37484 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
37485 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
37486 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
37487 ENDIF
37488 ISTHKT(8+IIGLU1+IIGLU2) =952
37489 JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
37490 JMOHKT(2,8+IIGLU1+IIGLU2)=0
37491 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
37492 JDAHKT(2,8+IIGLU1+IIGLU2)=0
37493 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC2T)+
37494 * PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
37495 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC2T)+
37496 * PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
37497 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC2T)+
37498 * PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
37499 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC2T)+
37500 * PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
37501C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
37502C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
37503 IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
37504C IREJ=1
37505C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
37506C * ,PHKT(4,8+IIGLU1+IIGLU2), PHKK(4,NC2T),NC2T
37507 IPCO=0
37508C RETURN
37509 GO TO 3466
37510 ENDIF
37511C PHKT(5,8) =PHKK(5,NC2T)
37512 XMIST =(PHKT(4,8+IIGLU1+IIGLU2)**2-
37513 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37514 *PHKT(1,8+IIGLU1+IIGLU2)**2)
37515 IF(XMIST.GT.0.D0)THEN
37516 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
37517 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37518 *PHKT(1,8+IIGLU1+IIGLU2)**2)
37519 ELSE
37520C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37521 PHKT(5,5+IIGLU1)=0.D0
37522 ENDIF
37523 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T)
37524 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T)
37525 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T)
37526 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T)
37527 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T)
37528 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T)
37529 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T)
37530 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T)
37531 IDHKT(9+IIGLU1+IIGLU2) =88888
37532 ISTHKT(9+IIGLU1+IIGLU2) =95
37533 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
37534 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
37535 JDAHKT(1,9+IIGLU1+IIGLU2)=0
37536 JDAHKT(2,9+IIGLU1+IIGLU2)=0
37537**NEW
37538C PHKT(1,9+IIGLU1+IIGLU2)
37539C * =PHKT(1,7+IIGLU1+IIGLU2)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
37540C PHKT(2,9+IIGLU1+IIGLU2)
37541C * =PHKT(2,7+IIGLU1+IIGLU2)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
37542C PHKT(3,9+IIGLU1+IIGLU2)
37543C * =PHKT(3,7+IIGLU1+IIGLU2)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
37544C PHKT(4,9+IIGLU1+IIGLU2)
37545C * =PHKT(4,7+IIGLU1+IIGLU2)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
37546 PHKT(1,9+IIGLU1+IIGLU2)
37547 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
37548 PHKT(2,9+IIGLU1+IIGLU2)
37549 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
37550 PHKT(3,9+IIGLU1+IIGLU2)
37551 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
37552 PHKT(4,9+IIGLU1+IIGLU2)
37553 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
37554**
37555 XMIST
37556 * =(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37557 * -PHKT(2,9+IIGLU1+IIGLU2)**2
37558 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
37559 IF(XMIST.GT.0.D0)THEN
37560 PHKT(5,9+IIGLU1+IIGLU2)
37561 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37562 * -PHKT(2,9+IIGLU1+IIGLU2)**2
37563 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
37564 ELSE
37565C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37566 PHKT(5,5+IIGLU1)=0.D0
37567 ENDIF
37568 IF(IPIP.GE.2)THEN
37569C IF(NUMEV.EQ.-324)THEN
37570C WRITE(6,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
37571C * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
37572C *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
37573C DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37574C WRITE(6,*)IIG,ISTHKT(IIG),IDHKT(IIG),JMOHKT(1,IIG),JMOHKT(2,IIG),
37575C * JDAHKT(1,IIG),
37576C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37577C 91 CONTINUE
37578C WRITE(6,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
37579C * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
37580C *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
37581C *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
37582C WRITE(6,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
37583C * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
37584C *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
37585C *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
37586 ENDIF
37587 CHAMAL=CHAB1
37588 IF(IPIP.EQ.1)THEN
37589 IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
37590 ELSEIF(IPIP.EQ.2)THEN
37591 IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
37592 ENDIF
37593 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
37594C IREJ=1
37595 IPCO=0
37596C RETURN
37597C WRITE(6,*)' MUSQBS1 jump back from chain 9',
37598C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
37599 GO TO 3466
37600 ENDIF
37601 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
37602 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
37603 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
37604 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
37605 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
37606 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
37607 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
37608 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
37609C
37610 IPCO=0
37611 IGCOUN=9+IIGLU1+IIGLU2
37612 RETURN
37613 END
37614
37615*$ CREATE MGSQBS2.FOR
37616*COPY MGSQBS2
37617C
37618C
37619C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
37620 SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37621 * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,ISQ,IGCOUN)
37622C
37623C GSQBS-2 diagram (split target diquark)
37624C
37625 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37626 SAVE
37627
37628 PARAMETER ( LINP = 10 ,
37629 & LOUT = 6 ,
37630 & LDAT = 9 )
37631* event history
37632 PARAMETER (NMXHKK=200000)
37633 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
37634 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
37635 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
37636* extended event history
37637 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
37638 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37639 & IHIST(2,NMXHKK)
37640* Lorentz-parameters of the current interaction
37641 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37642 & UMO,PPCM,EPROJ,PPROJ
37643* diquark-breaking mechanism
37644 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37645
37646C
37647 PARAMETER (NTMHKK= 300)
37648 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37649 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37650 +(4,NTMHKK)
37651
37652*KEEP,XSEADI.
37653 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37654 +SSMIMQ,VVMTHR
37655*KEEP,DPRIN.
37656 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37657C
37658C GSQBS-2 diagram (split target diquark)
37659C
37660C
37661C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
37662C Input chain 2(NC2) valence-diquark(NC2P)-sea-quark(NC2T)
37663C
37664C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
37665C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37666C
37667C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
37668C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37669C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37670C
37671C
37672C
37673C Put new chains into COMMON /HKKTMP/
37674C
37675 IIGLU1=NC1T-NC1P-1
37676 IIGLU2=NC2T-NC2P-1
37677 IGCOUN=0
37678C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
37679 CVQ=1.D0
37680 IREJ=0
37681C IF(IPIP.EQ.2)THEN
37682C WRITE(6,*)' MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37683C * 'IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN)',
37684C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37685C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN
37686C ENDIF
37687C
37688C
37689C
37690C determine x-values of NC1T diquark
37691 XDIQT=PHKK(4,NC1T)*2.D0/UMO
37692 XVQP=PHKK(4,NC1P)*2.D0/UMO
37693C
37694C determine x-values of sea quark pair
37695C
37696 IPCO=1
37697 ICOU=0
37698 2234 CONTINUE
37699 ICOU=ICOU+1
37700 IF(ICOU.GE.500)THEN
37701 IREJ=1
37702 IF(ISQ.EQ.3)IREJ=3
37703 IF(IPCO.GE.3)
37704 & WRITE(LOUT,*)' MGSQBS2 Rejection 2234 ICOU. GT.500'
37705 IPCO=0
37706 RETURN
37707 ENDIF
37708 IF(IPCO.GE.3)
37709 & WRITE(LOUT,*)'MGSQBS2 call XSEAPA: UMO,XDIQT,XVQP ',
37710 * UMO, XDIQT,XVQP
37711 XSQ=0.D0
37712 XSAQ=0.D0
37713**NEW
37714C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37715 IF (IPIP.EQ.1) THEN
37716 XQMAX = XDIQT/2.0D0
37717 XAQMAX = 2.D0*XVQP/3.0D0
37718 ELSE
37719 XQMAX = 2.D0*XVQP/3.0D0
37720 XAQMAX = XDIQT/2.0D0
37721 ENDIF
37722 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37723 ISAQ = 6+ISQ
37724C write(*,*) 'MGSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
37725**
37726 IF(IPCO.GE.3)
37727 & WRITE(LOUT,*)'MGSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37728 IF(IREJ.GE.1)THEN
37729 IF(IPCO.GE.3)
37730 & WRITE(LOUT,*)'MGSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37731 IPCO=0
37732 RETURN
37733 ENDIF
37734 IF(IPIP.EQ.1)THEN
37735 IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37736 ELSEIF(IPIP.EQ.2)THEN
37737 IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37738 ENDIF
37739 IF(IPCO.GE.3)THEN
37740 WRITE(LOUT,'(A,4E12.4)')' MGSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
37741 * XDIQT,XVQP,XSQ,XSAQ
37742 ENDIF
37743C
37744C subtract xsq,xsaq from NC1T diquark and NC1P quark
37745C
37746C XSQ=0.D0
37747 IF(IPIP.EQ.1)THEN
37748 XDIQT=XDIQT-XSQ
37749 XVQP =XVQP -XSAQ
37750 ELSEIF(IPIP.EQ.2)THEN
37751 XDIQT=XDIQT-XSAQ
37752 XVQP =XVQP -XSQ
37753 ENDIF
37754 IF(IPCO.GE.3)
37755 & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
37756C
37757C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37758C
37759 XVTHRO=CVQ/UMO
37760 IVTHR=0
37761 3466 CONTINUE
37762 IF(IVTHR.EQ.10)THEN
37763 IREJ=1
37764 IF(ISQ.EQ.3)IREJ=3
37765 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 3466 reject IVTHR 10'
37766 IPCO=0
37767 RETURN
37768 ENDIF
37769 IVTHR=IVTHR+1
37770 XVTHR=XVTHRO/(201-IVTHR)
37771 UNOPRV=UNON
37772 380 CONTINUE
37773 IF(XVTHR.GT.0.66D0*XDIQT)THEN
37774 IREJ=1
37775 IF(ISQ.EQ.3)IREJ=3
37776 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 Rejection 380 XVTHR large ',
37777 * XVTHR
37778 IPCO=0
37779 RETURN
37780 ENDIF
37781 IF(DT_RNDM(V).LT.0.5D0)THEN
37782 XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37783 XVTQII=XDIQT-XVTQI
37784 ELSE
37785 XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37786 XVTQI=XDIQT-XVTQII
37787 ENDIF
37788 IF(IPCO.GE.3)THEN
37789 WRITE(LOUT,'(A,2E12.4)')' MGSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
37790 ENDIF
37791C
37792C Prepare 4 momenta of new chains and chain ends
37793C
37794C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37795C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37796C +(4,NTMHKK)
37797C
37798C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
37799C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37800C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37801C
37802C SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37803C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IGCOUN)
37804C
37805 IF(IPIP.EQ.1)THEN
37806 XSQ1=XSQ
37807 XSAQ1=XSAQ
37808 ISQ1=ISQ
37809 ISAQ1=ISAQ
37810 ELSEIF(IPIP.EQ.2)THEN
37811 XSQ1=XSAQ
37812 XSAQ1=XSQ
37813 ISQ1=ISAQ
37814 ISAQ1=ISQ
37815 ENDIF
37816 KK11=IP21
37817C IDHKT(1) =1000*IPP11+100*IPP12+1
37818 KK21=IPP11
37819 KK22=IPP12
37820 XGIVE=0.D0
37821 IF(IPIP.EQ.1)THEN
37822 IDHKT(4+IIGLU1) =-(ISAQ1-6)
37823 ELSEIF(IPIP.EQ.2)THEN
37824 IDHKT(4+IIGLU1) =ISAQ1
37825 ENDIF
37826 ISTHKT(4+IIGLU1) =961
37827 JMOHKT(1,4+IIGLU1)=NC1P
37828 JMOHKT(2,4+IIGLU1)=0
37829 JDAHKT(1,4+IIGLU1)=6+IIGLU1
37830 JDAHKT(2,4+IIGLU1)=0
37831C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37832 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
37833 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
37834 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
37835 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
37836C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
37837 XXMIST=(PHKT(4,4+IIGLU1)**2-
37838 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37839 *PHKT(1,4+IIGLU1)**2)
37840 IF(XXMIST.GT.0.D0)THEN
37841 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
37842 ELSE
37843 WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
37844 XXMIST=ABS(XXMIST)
37845 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
37846 ENDIF
37847 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
37848 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
37849 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
37850 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
37851 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
37852 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
37853 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
37854 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
37855 IDHKT(5+IIGLU1) =IP22
37856 ISTHKT(5+IIGLU1) =962
37857 JMOHKT(1,5+IIGLU1)=NC1T
37858 JMOHKT(2,5+IIGLU1)=0
37859 JDAHKT(1,5+IIGLU1)=6+IIGLU1
37860 JDAHKT(2,5+IIGLU1)=0
37861 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
37862 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
37863 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
37864 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
37865C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
37866 XXMIST=(PHKT(4,5+IIGLU1)**2-
37867 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37868 *PHKT(1,5+IIGLU1)**2)
37869 IF(XXMIST.GT.0.D0)THEN
37870 PHKT(5,5+IIGLU1) =SQRT(XXMIST)
37871 ELSE
37872 WRITE(LOUT,*)' MGSQBS2 XXMIST', XXMIST
37873 XXMIST=ABS(XXMIST)
37874 PHKT(5,5+IIGLU1) =SQRT(XXMIST)
37875 ENDIF
37876 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
37877 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
37878 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
37879 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
37880 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
37881 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
37882 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
37883 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
37884 IDHKT(6+IIGLU1) =88888
37885 ISTHKT(6+IIGLU1) =96
37886 JMOHKT(1,6+IIGLU1)=4+IIGLU1
37887 JMOHKT(2,6+IIGLU1)=5+IIGLU1
37888 JDAHKT(1,6+IIGLU1)=0
37889 JDAHKT(2,6+IIGLU1)=0
37890 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37891 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37892 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37893 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37894 PHKT(5,6+IIGLU1)
37895 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37896 * -PHKT(3,6+IIGLU1)**2)
37897 CHAMAL=CHAM1
37898 IF(IPIP.EQ.1)THEN
37899 IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
37900 ELSEIF(IPIP.EQ.2)THEN
37901 IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
37902 ENDIF
37903C---------------------------------------------------
37904 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37905 IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
37906C we drop chain 6 and give the energy to chain 3
37907 IDHKT(6+IIGLU1)=22888
37908 XGIVE=1.D0
37909C WRITE(6,*)' drop chain 6 xgive=1'
37910 GO TO 7788
37911 ELSEIF(IDHKT(4+IIGLU1).EQ.-IP21)THEN
37912C we drop chain 6 and give the energy to chain 3
37913C and change KK11 to IDHKT(5)
37914 IDHKT(6+IIGLU1)=22888
37915 XGIVE=1.D0
37916C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(5)'
37917 KK11=IDHKT(5+IIGLU1)
37918 GO TO 7788
37919 ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP11)THEN
37920C we drop chain 6 and give the energy to chain 3
37921C and change KK21 to IDHKT(5+IIGLU1)
37922C IDHKT(1) =1000*IPP11+100*IPP12+1
37923 IDHKT(6+IIGLU1)=22888
37924 XGIVE=1.D0
37925C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(5+IIGLU1)'
37926 KK21=IDHKT(5+IIGLU1)
37927 GO TO 7788
37928 ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP12)THEN
37929C we drop chain 6 and give the energy to chain 3
37930C and change KK22 to IDHKT(5)
37931C IDHKT(1) =1000*IPP11+100*IPP12+1
37932 IDHKT(6+IIGLU1)=22888
37933 XGIVE=1.D0
37934C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(5+IIGLU1)'
37935 KK22=IDHKT(5+IIGLU1)
37936 GO TO 7788
37937 ENDIF
37938C IREJ=1
37939 IPCO=0
37940C RETURN
37941 GO TO 3466
37942 ENDIF
37943 7788 CONTINUE
37944C---------------------------------------------------
37945 IF(IPIP.GE.3)THEN
37946 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
37947 * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
37948 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
37949 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
37950 * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
37951 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
37952 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
37953 * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
37954 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
37955 ENDIF
37956 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
37957 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
37958 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
37959 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
37960 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
37961 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
37962 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
37963 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
37964C IDHKT(1) =1000*IPP11+100*IPP12+1
37965 IF(IPIP.EQ.1)THEN
37966 IDHKT(1) =1000*KK21+100*KK22+3
37967 IF(IDHKT(1).EQ.1203)IDHKT(1)=2103
37968 IF(IDHKT(1).EQ.1303)IDHKT(1)=3103
37969 IF(IDHKT(1).EQ.2303)IDHKT(1)=3203
37970 ELSEIF(IPIP.EQ.2)THEN
37971 IDHKT(1) =1000*KK21+100*KK22-3
37972 IF(IDHKT(1).EQ.-1203)IDHKT(1)=-2103
37973 IF(IDHKT(1).EQ.-1303)IDHKT(1)=-3103
37974 IF(IDHKT(1).EQ.-2303)IDHKT(1)=-3203
37975 ENDIF
37976 ISTHKT(1) =961
37977 JMOHKT(1,1)=NC2P
37978 JMOHKT(2,1)=0
37979 JDAHKT(1,1)=3+IIGLU1
37980 JDAHKT(2,1)=0
37981C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
37982 PHKT(1,1) =PHKK(1,NC2P)
37983 *+XGIVE*PHKT(1,4+IIGLU1)
37984 PHKT(2,1) =PHKK(2,NC2P)
37985 *+XGIVE*PHKT(2,4+IIGLU1)
37986 PHKT(3,1) =PHKK(3,NC2P)
37987 *+XGIVE*PHKT(3,4+IIGLU1)
37988 PHKT(4,1) =PHKK(4,NC2P)
37989 *+XGIVE*PHKT(4,4+IIGLU1)
37990C PHKT(5,1) =PHKK(5,NC2P)
37991 XXMIST=PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
37992 *PHKT(1,1)**2
37993 IF(XXMIST.GT.0.D0)THEN
37994 PHKT(5,1) =SQRT(XXMIST)
37995 ELSE
37996 WRITE(LOUT,*)'MGSQBS2',XXMIST
37997 XXMIST=ABS(XXMIST)
37998 PHKT(5,1) =SQRT(XXMIST)
37999 ENDIF
38000 VHKT(1,1) =VHKK(1,NC2P)
38001 VHKT(2,1) =VHKK(2,NC2P)
38002 VHKT(3,1) =VHKK(3,NC2P)
38003 VHKT(4,1) =VHKK(4,NC2P)
38004 WHKT(1,1) =WHKK(1,NC2P)
38005 WHKT(2,1) =WHKK(2,NC2P)
38006 WHKT(3,1) =WHKK(3,NC2P)
38007 WHKT(4,1) =WHKK(4,NC2P)
38008C Add here IIGLU1 gluons to this chaina
38009 PG1=0.D0
38010 PG2=0.D0
38011 PG3=0.D0
38012 PG4=0.D0
38013 IF(IIGLU1.GE.1)THEN
38014 JJG=NC1P
38015 DO 61 IIG=2,2+IIGLU1-1
38016 KKG=JJG+IIG-1
38017 IDHKT(IIG) =IDHKK(KKG)
38018 ISTHKT(IIG) =921
38019 JMOHKT(1,IIG)=KKG
38020 JMOHKT(2,IIG)=0
38021 JDAHKT(1,IIG)=3+IIGLU1
38022 JDAHKT(2,IIG)=0
38023 PHKT(1,IIG)=PHKK(1,KKG)
38024 PG1=PG1+ PHKT(1,IIG)
38025 PHKT(2,IIG)=PHKK(2,KKG)
38026 PG2=PG2+ PHKT(2,IIG)
38027 PHKT(3,IIG)=PHKK(3,KKG)
38028 PG3=PG3+ PHKT(3,IIG)
38029 PHKT(4,IIG)=PHKK(4,KKG)
38030 PG4=PG4+ PHKT(4,IIG)
38031 PHKT(5,IIG)=PHKK(5,KKG)
38032 VHKT(1,IIG) =VHKK(1,KKG)
38033 VHKT(2,IIG) =VHKK(2,KKG)
38034 VHKT(3,IIG) =VHKK(3,KKG)
38035 VHKT(4,IIG) =VHKK(4,KKG)
38036 WHKT(1,IIG) =WHKK(1,KKG)
38037 WHKT(2,IIG) =WHKK(2,KKG)
38038 WHKT(3,IIG) =WHKK(3,KKG)
38039 WHKT(4,IIG) =WHKK(4,KKG)
38040 61 CONTINUE
38041 ENDIF
38042C IDHKT(2) =IP21
38043 IDHKT(2+IIGLU1) =KK11
38044 ISTHKT(2+IIGLU1) =962
38045 JMOHKT(1,2+IIGLU1)=NC1T
38046 JMOHKT(2,2+IIGLU1)=0
38047 JDAHKT(1,2+IIGLU1)=3+IIGLU1
38048 JDAHKT(2,2+IIGLU1)=0
38049 PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
38050C * +0.5D0*PHKK(1,NC2T)
38051 *+XGIVE*PHKT(1,5+IIGLU1)
38052 PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
38053C *+0.5D0*PHKK(2,NC2T)
38054 *+XGIVE*PHKT(2,5+IIGLU1)
38055 PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
38056C *+0.5D0*PHKK(3,NC2T)
38057 *+XGIVE*PHKT(3,5+IIGLU1)
38058 PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
38059C *+0.5D0*PHKK(4,NC2T)
38060 *+XGIVE*PHKT(4,5+IIGLU1)
38061C PHKT(5,2) =PHKK(5,NC1T)
38062 XXMIST=(PHKT(4,2+IIGLU1)**2-
38063 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38064 *PHKT(1,2+IIGLU1)**2)
38065 IF(XXMIST.GT.0.D0)THEN
38066 PHKT(5,2+IIGLU1) =SQRT(XXMIST)
38067 ELSE
38068 WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
38069 XXMIST=ABS(XXMIST)
38070 PHKT(5,2+IIGLU1) =SQRT(XXMIST)
38071 ENDIF
38072 VHKT(1,2+IIGLU1) =VHKK(1,NC1T)
38073 VHKT(2,2+IIGLU1) =VHKK(2,NC1T)
38074 VHKT(3,2+IIGLU1) =VHKK(3,NC1T)
38075 VHKT(4,2+IIGLU1) =VHKK(4,NC1T)
38076 WHKT(1,2+IIGLU1) =WHKK(1,NC1T)
38077 WHKT(2,2+IIGLU1) =WHKK(2,NC1T)
38078 WHKT(3,2+IIGLU1) =WHKK(3,NC1T)
38079 WHKT(4,2+IIGLU1) =WHKK(4,NC1T)
38080 IDHKT(3+IIGLU1) =88888
38081 ISTHKT(3+IIGLU1) =96
38082 JMOHKT(1,3+IIGLU1)=1
38083 JMOHKT(2,3+IIGLU1)=2+IIGLU1
38084 JDAHKT(1,3+IIGLU1)=0
38085 JDAHKT(2,3+IIGLU1)=0
38086 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
38087 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
38088 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
38089 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
38090 PHKT(5,3+IIGLU1)
38091 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38092 * -PHKT(3,3+IIGLU1)**2)
38093 IF(IPIP.EQ.3)THEN
38094 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
38095 * JDAHKT(1,1),
38096 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
38097 DO 71 IIG=2,2+IIGLU1-1
38098 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38099 & JMOHKT(1,IIG),JMOHKT(2,IIG),
38100 * JDAHKT(1,IIG),
38101 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38102 71 CONTINUE
38103 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
38104 * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
38105 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
38106 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
38107 * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
38108 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
38109 ENDIF
38110 CHAMAL=CHAB1
38111 IF(IPIP.EQ.1)THEN
38112 IF(IPP11.GE.3.OR.IPP12.GE.3.OR.IP21.GE.3)CHAMAL=CHAB3
38113 ELSEIF(IPIP.EQ.2)THEN
38114 IF(IPP11.LE.-3.OR.IPP12.LE.-3.OR.IP21.LE.-3)CHAMAL=CHAB3
38115 ENDIF
38116 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
38117C IREJ=1
38118 IPCO=0
38119C RETURN
38120 GO TO 3466
38121 ENDIF
38122 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
38123 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
38124 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
38125 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
38126 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
38127 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
38128 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
38129 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
38130C IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+1
38131 IDHKT(7+IIGLU1) =IP1
38132 ISTHKT(7+IIGLU1) =961
38133 JMOHKT(1,7+IIGLU1)=NC1P
38134 JMOHKT(2,7+IIGLU1)=0
38135 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
38136 JDAHKT(2,7+IIGLU1)=0
38137 PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
38138 PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
38139 PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
38140 PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
38141C PHKT(5,7+IIGLU1) =PHKK(5,NC1P)
38142 XXMIST=(PHKT(4,7+IIGLU1)**2-
38143 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
38144 *PHKT(1,7+IIGLU1)**2)
38145 IF(XXMIST.GT.0.D0)THEN
38146 PHKT(5,7+IIGLU1) =SQRT(XXMIST)
38147 ELSE
38148 WRITE(LOUT,*)' MGSQBS2, XXMIST',XXMIST
38149 XXMIST=ABS(XXMIST)
38150 PHKT(5,7+IIGLU1) =SQRT(XXMIST)
38151 ENDIF
38152 VHKT(1,7+IIGLU1) =VHKK(1,NC1P)
38153 VHKT(2,7+IIGLU1) =VHKK(2,NC1P)
38154 VHKT(3,7+IIGLU1) =VHKK(3,NC1P)
38155 VHKT(4,7+IIGLU1) =VHKK(4,NC1P)
38156 WHKT(1,7+IIGLU1) =WHKK(1,NC1P)
38157 WHKT(2,7+IIGLU1) =WHKK(2,NC1P)
38158 WHKT(3,7+IIGLU1) =WHKK(3,NC1P)
38159 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
38160C IDHKT(7) =1000*IPP1+100*ISQ+1
38161C Insert here the IIGLU2 gluons
38162 PG1=0.D0
38163 PG2=0.D0
38164 PG3=0.D0
38165 PG4=0.D0
38166 IF(IIGLU2.GE.1)THEN
38167 JJG=NC2P
38168 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38169 KKG=JJG+IIG-7-IIGLU1
38170 IDHKT(IIG) =IDHKK(KKG)
38171 ISTHKT(IIG) =921
38172 JMOHKT(1,IIG)=KKG
38173 JMOHKT(2,IIG)=0
38174 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
38175 JDAHKT(2,IIG)=0
38176 PHKT(1,IIG)=PHKK(1,KKG)
38177 PG1=PG1+ PHKT(1,IIG)
38178 PHKT(2,IIG)=PHKK(2,KKG)
38179 PG2=PG2+ PHKT(2,IIG)
38180 PHKT(3,IIG)=PHKK(3,KKG)
38181 PG3=PG3+ PHKT(3,IIG)
38182 PHKT(4,IIG)=PHKK(4,KKG)
38183 PG4=PG4+ PHKT(4,IIG)
38184 PHKT(5,IIG)=PHKK(5,KKG)
38185 VHKT(1,IIG) =VHKK(1,KKG)
38186 VHKT(2,IIG) =VHKK(2,KKG)
38187 VHKT(3,IIG) =VHKK(3,KKG)
38188 VHKT(4,IIG) =VHKK(4,KKG)
38189 WHKT(1,IIG) =WHKK(1,KKG)
38190 WHKT(2,IIG) =WHKK(2,KKG)
38191 WHKT(3,IIG) =WHKK(3,KKG)
38192 WHKT(4,IIG) =WHKK(4,KKG)
38193 81 CONTINUE
38194 ENDIF
38195 IF(IPIP.EQ.1)THEN
38196 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3
38197 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
38198 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
38199 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
38200 ELSEIF(IPIP.EQ.2)THEN
38201**NEW
38202C IDHKT(8) =1000*IPP2+100*(-ISQ1+6)-3
38203 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3
38204**
38205 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
38206 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
38207 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
38208 ENDIF
38209 ISTHKT(8+IIGLU1+IIGLU2) =962
38210 JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
38211 JMOHKT(2,8+IIGLU1+IIGLU2)=0
38212 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
38213 JDAHKT(2,8+IIGLU1+IIGLU2)=0
38214C PHKT(1,8) =0.5D0*PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ/(XDIQT+XSQ)
38215C PHKT(2,8) =0.5D0*PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ/(XDIQT+XSQ)
38216C PHKT(3,8) =0.5D0*PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ/(XDIQT+XSQ)
38217C PHKT(4,8) =0.5D0*PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ/(XDIQT+XSQ)
38218 PHKT(1,8+IIGLU1+IIGLU2) =
38219 * PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
38220 PHKT(2,8+IIGLU1+IIGLU2) =
38221 * PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
38222 PHKT(3,8+IIGLU1+IIGLU2) =
38223 * PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
38224 PHKT(4,8+IIGLU1+IIGLU2) =
38225 * PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
38226C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
38227C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
38228 IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
38229C IREJ=1
38230C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
38231 IPCO=0
38232C RETURN
38233 GO TO 3466
38234 ENDIF
38235C PHKT(5,8) =PHKK(5,NC2T)
38236 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
38237 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38238 *PHKT(1,8+IIGLU1+IIGLU2)**2)
38239 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T)
38240 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T)
38241 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T)
38242 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T)
38243 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T)
38244 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T)
38245 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T)
38246 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T)
38247 IDHKT(9+IIGLU1+IIGLU2) =88888
38248 ISTHKT(9+IIGLU1+IIGLU2) =96
38249 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
38250 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
38251 JDAHKT(1,9+IIGLU1+IIGLU2)=0
38252 JDAHKT(2,9+IIGLU1+IIGLU2)=0
38253 PHKT(1,9+IIGLU1+IIGLU2)
38254 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
38255 PHKT(2,9+IIGLU1+IIGLU2)
38256 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
38257 PHKT(3,9+IIGLU1+IIGLU2)
38258 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
38259 PHKT(4,9+IIGLU1+IIGLU2)
38260 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
38261 PHKT(5,9+IIGLU1+IIGLU2)
38262 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
38263 * PHKT(2,9+IIGLU1+IIGLU2)**2
38264 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
38265 IF(IPIP.GE.3)THEN
38266 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
38267 * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
38268 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
38269 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38270 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38271 & JMOHKT(1,IIG),JMOHKT(2,IIG),
38272 * JDAHKT(1,IIG),
38273 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38274 91 CONTINUE
38275 WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
38276 * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
38277 *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
38278 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
38279 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
38280 * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
38281 *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
38282 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
38283 ENDIF
38284 CHAMAL=CHAB1
38285 IF(IPIP.EQ.1)THEN
38286 IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
38287 ELSEIF(IPIP.EQ.2)THEN
38288 IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
38289 ENDIF
38290 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
38291C IREJ=1
38292 IPCO=0
38293C RETURN
38294 GO TO 3466
38295 ENDIF
38296 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
38297 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
38298 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
38299 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
38300 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
38301 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
38302 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
38303 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
38304C
38305 IPCO=0
38306 IGCOUN=9+IIGLU1+IIGLU2
38307 RETURN
38308 END
38309
38310*$ CREATE MUSQBS1.FOR
38311*COPY MUSQBS1
38312C
38313C
38314C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
38315 SUBROUTINE MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
38316 * IP11,IP12,IP2,IPP1,IPP2,IPIP,ISQ,IGCOUN)
38317C
38318C USQBS-1 diagram (split projectile diquark)
38319C
38320 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38321 SAVE
38322
38323 PARAMETER ( LINP = 10 ,
38324 & LOUT = 6 ,
38325 & LDAT = 9 )
38326* event history
38327 PARAMETER (NMXHKK=200000)
38328 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38329 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38330 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38331* extended event history
38332 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38333 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38334 & IHIST(2,NMXHKK)
38335* Lorentz-parameters of the current interaction
38336 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
38337 & UMO,PPCM,EPROJ,PPROJ
38338* diquark-breaking mechanism
38339 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
38340
38341C
38342 PARAMETER (NTMHKK= 300)
38343 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38344 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38345 +(4,NTMHKK)
38346*KEEP,XSEADI.
38347 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
38348 +SSMIMQ,VVMTHR
38349*KEEP,DPRIN.
38350 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
38351 COMMON /EVFLAG/ NUMEV
38352C
38353C USQBS-1 diagram (split projectile diquark)
38354C
38355C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
38356C Input chain 2(NC2) sea-quark(NC2P)-sea-antiquark(NC2T)
38357C
38358C Create quark(qsP)-antiquark(aqsT) pair, energy from NC1P and NC1T
38359C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
38360C
38361C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
38362C 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
38363C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
38364C
38365C Put new chains into COMMON /HKKTMP/
38366C
38367 IIGLU1=NC1T-NC1P-1
38368 IIGLU2=NC2T-NC2P-1
38369 IGCOUN=0
38370C WRITE(6,*)'MUSQBS1: IIGLU1,IIGLU2,IPIP ',IIGLU1,IIGLU2,IPIP
38371 CVQ=1.D0
38372 IREJ=0
38373 IF(IPIP.EQ.3)THEN
38374C IF(NUMEV.EQ.-324)THEN
38375 WRITE(LOUT,*)' MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
38376 * ' IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN)',
38377 *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
38378 * IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN
38379 ENDIF
38380C
38381C
38382C
38383C determine x-values of NC1P diquark
38384 XDIQP=PHKK(4,NC1P)*2.D0/UMO
38385 XVQT=PHKK(4,NC1T)*2.D0/UMO
38386C
38387C determine x-values of sea quark pair
38388C
38389 IPCO=1
38390 ICOU=0
38391 2234 CONTINUE
38392 ICOU=ICOU+1
38393 IF(ICOU.GE.500)THEN
38394 IREJ=1
38395 IF(ISQ.EQ.3)IREJ=3
38396 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 2234 ICOU. GT.100'
38397 IPCO=0
38398 RETURN
38399 ENDIF
38400 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 call XSEAPA: UMO,XDIQP,XVQT ',
38401 * UMO, XDIQP,XVQT
38402 XSQ=0.D0
38403 XSAQ=0.D0
38404**NEW
38405C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
38406 IF (IPIP.EQ.1) THEN
38407 XQMAX = XDIQP/2.0D0
38408 XAQMAX = 2.D0*XVQT/3.0D0
38409 ELSE
38410 XQMAX = 2.D0*XVQT/3.0D0
38411 XAQMAX = XDIQP/2.0D0
38412 ENDIF
38413 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
38414 ISAQ = 6+ISQ
38415C write(*,*) 'MUSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
38416**
38417 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
38418 IF(IREJ.GE.1)THEN
38419 IF(IPCO.GE.3)
38420 & WRITE(LOUT,*)'MUSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
38421 IPCO=0
38422 RETURN
38423 ENDIF
38424 IF(IPIP.EQ.1)THEN
38425 IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
38426 ELSEIF(IPIP.EQ.2)THEN
38427 IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
38428 ENDIF
38429 IF(IPCO.GE.3)THEN
38430 WRITE(LOUT,'(A,4E12.4)')' MUSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
38431 * XDIQP,XVQT,XSQ,XSAQ
38432 ENDIF
38433C
38434C subtract xsq,xsaq from NC1P diquark and NC1T quark
38435C
38436C XSQ=0.D0
38437 IF(IPIP.EQ.1)THEN
38438 XDIQP=XDIQP-XSQ
38439 XVQT =XVQT -XSAQ
38440 ELSEIF(IPIP.EQ.2)THEN
38441 XDIQP=XDIQP-XSAQ
38442 XVQT =XVQT -XSQ
38443 ENDIF
38444 IF(IPCO.GE.3)
38445 & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
38446C
38447C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
38448C
38449 XVTHRO=CVQ/UMO
38450 IVTHR=0
38451 3466 CONTINUE
38452 IF(IVTHR.EQ.10)THEN
38453 IREJ=1
38454 IF(ISQ.EQ.3)IREJ=3
38455 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 3466 reject IVTHR 10'
38456 IPCO=0
38457 RETURN
38458 ENDIF
38459 IVTHR=IVTHR+1
38460 XVTHR=XVTHRO/(201-IVTHR)
38461 UNOPRV=UNON
38462 380 CONTINUE
38463 IF(XVTHR.GT.0.66D0*XDIQP)THEN
38464 IREJ=1
38465 IF(ISQ.EQ.3)IREJ=3
38466 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 380 XVTHR large ',
38467 * XVTHR
38468 IPCO=0
38469 RETURN
38470 ENDIF
38471 IF(DT_RNDM(V).LT.0.5D0)THEN
38472 XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
38473 XVPQII=XDIQP-XVPQI
38474 ELSE
38475 XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
38476 XVPQI=XDIQP-XVPQII
38477 ENDIF
38478 IF(IPCO.GE.3)THEN
38479 WRITE(LOUT,'(A,2E12.4)')' MUSQBS1:XVPQI,XVPQII ',XVPQI,XVPQII
38480 ENDIF
38481C
38482C Prepare 4 momenta of new chains and chain ends
38483C
38484C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38485C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38486C +(4,NTMHKK)
38487C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
38488C 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
38489C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
38490 IF(IPIP.EQ.1)THEN
38491 XSQ1=XSQ
38492 XSAQ1=XSAQ
38493 ISQ1=ISQ
38494 ISAQ1=ISAQ
38495 ELSEIF(IPIP.EQ.2)THEN
38496 XSQ1=XSAQ
38497 XSAQ1=XSQ
38498 ISQ1=ISAQ
38499 ISAQ1=ISQ
38500 ENDIF
38501 IDHKT(1) =IP11
38502 ISTHKT(1) =931
38503 JMOHKT(1,1)=NC1P
38504 JMOHKT(2,1)=0
38505 JDAHKT(1,1)=3+IIGLU1
38506 JDAHKT(2,1)=0
38507C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
38508 PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
38509 PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
38510 PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
38511 PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
38512C PHKT(5,1) =PHKK(5,NC1P)
38513 XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38514 *PHKT(1,1)**2)
38515 IF(XMIST.GE.0.D0)THEN
38516 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38517 *PHKT(1,1)**2)
38518 ELSE
38519C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38520 PHKT(5,1)=0.D0
38521 ENDIF
38522 VHKT(1,1) =VHKK(1,NC1P)
38523 VHKT(2,1) =VHKK(2,NC1P)
38524 VHKT(3,1) =VHKK(3,NC1P)
38525 VHKT(4,1) =VHKK(4,NC1P)
38526 WHKT(1,1) =WHKK(1,NC1P)
38527 WHKT(2,1) =WHKK(2,NC1P)
38528 WHKT(3,1) =WHKK(3,NC1P)
38529 WHKT(4,1) =WHKK(4,NC1P)
38530C Add here IIGLU1 gluons to this chaina
38531 PG1=0.D0
38532 PG2=0.D0
38533 PG3=0.D0
38534 PG4=0.D0
38535 IF(IIGLU1.GE.1)THEN
38536 JJG=NC1P
38537 DO 61 IIG=2,2+IIGLU1-1
38538 KKG=JJG+IIG-1
38539 IDHKT(IIG) =IDHKK(KKG)
38540 ISTHKT(IIG) =921
38541 JMOHKT(1,IIG)=KKG
38542 JMOHKT(2,IIG)=0
38543 JDAHKT(1,IIG)=3+IIGLU1
38544 JDAHKT(2,IIG)=0
38545 PHKT(1,IIG)=PHKK(1,KKG)
38546 PG1=PG1+ PHKT(1,IIG)
38547 PHKT(2,IIG)=PHKK(2,KKG)
38548 PG2=PG2+ PHKT(2,IIG)
38549 PHKT(3,IIG)=PHKK(3,KKG)
38550 PG3=PG3+ PHKT(3,IIG)
38551 PHKT(4,IIG)=PHKK(4,KKG)
38552 PG4=PG4+ PHKT(4,IIG)
38553 PHKT(5,IIG)=PHKK(5,KKG)
38554 VHKT(1,IIG) =VHKK(1,KKG)
38555 VHKT(2,IIG) =VHKK(2,KKG)
38556 VHKT(3,IIG) =VHKK(3,KKG)
38557 VHKT(4,IIG) =VHKK(4,KKG)
38558 WHKT(1,IIG) =WHKK(1,KKG)
38559 WHKT(2,IIG) =WHKK(2,KKG)
38560 WHKT(3,IIG) =WHKK(3,KKG)
38561 WHKT(4,IIG) =WHKK(4,KKG)
38562 61 CONTINUE
38563 ENDIF
38564 IDHKT(2+IIGLU1) =IPP2
38565 ISTHKT(2+IIGLU1) =932
38566 JMOHKT(1,2+IIGLU1)=NC2T
38567 JMOHKT(2,2+IIGLU1)=0
38568 JDAHKT(1,2+IIGLU1)=3+IIGLU1
38569 JDAHKT(2,2+IIGLU1)=0
38570 PHKT(1,2+IIGLU1) =PHKK(1,NC2T)
38571 PHKT(2,2+IIGLU1) =PHKK(2,NC2T)
38572 PHKT(3,2+IIGLU1) =PHKK(3,NC2T)
38573 PHKT(4,2+IIGLU1) =PHKK(4,NC2T)
38574C PHKT(5,2+IIGLU1) =PHKK(5,NC2T)
38575 XMIST=(PHKT(4,2+IIGLU1)**2-
38576 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38577 *PHKT(1,2+IIGLU1)**2)
38578 IF(XMIST.GT.0.D0)THEN
38579 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
38580 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38581 *PHKT(1,2+IIGLU1)**2)
38582 ELSE
38583C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38584 PHKT(5,2+IIGLU1)=0.D0
38585 ENDIF
38586 VHKT(1,2+IIGLU1) =VHKK(1,NC2T)
38587 VHKT(2,2+IIGLU1) =VHKK(2,NC2T)
38588 VHKT(3,2+IIGLU1) =VHKK(3,NC2T)
38589 VHKT(4,2+IIGLU1) =VHKK(4,NC2T)
38590 WHKT(1,2+IIGLU1) =WHKK(1,NC2T)
38591 WHKT(2,2+IIGLU1) =WHKK(2,NC2T)
38592 WHKT(3,2+IIGLU1) =WHKK(3,NC2T)
38593 WHKT(4,2+IIGLU1) =WHKK(4,NC2T)
38594 IDHKT(3+IIGLU1) =88888
38595 ISTHKT(3+IIGLU1) =94
38596 JMOHKT(1,3+IIGLU1)=1
38597 JMOHKT(2,3+IIGLU1)=2+IIGLU1
38598 JDAHKT(1,3+IIGLU1)=0
38599 JDAHKT(2,3+IIGLU1)=0
38600 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
38601 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
38602 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
38603 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
38604 XMIST
38605 * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38606 * -PHKT(3,3+IIGLU1)**2)
38607 IF(XMIST.GE.0.D0)THEN
38608 PHKT(5,3+IIGLU1)
38609 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38610 * -PHKT(3,3+IIGLU1)**2)
38611 ELSE
38612C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38613 PHKT(5,1)=0.D0
38614 ENDIF
38615 IF(IPIP.GE.3)THEN
38616C IF(NUMEV.EQ.-324)THEN
38617 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),
38618 * JMOHKT(2,1),JDAHKT(1,1),
38619 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
38620 DO 71 IIG=2,2+IIGLU1-1
38621 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38622 & JMOHKT(1,IIG),JMOHKT(2,IIG),
38623 * JDAHKT(1,IIG),
38624 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38625 71 CONTINUE
38626 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
38627 * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
38628 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
38629 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
38630 * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
38631 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
38632 ENDIF
38633 CHAMAL=CHAM1
38634 IF(IPIP.EQ.1)THEN
38635 IF(IP11.GE.3.OR.IPP2.GE.3)CHAMAL=CHAM3
38636 ELSEIF(IPIP.EQ.2)THEN
38637 IF(IP11.LE.-3.OR.IPP2.LE.-3)CHAMAL=CHAM3
38638 ENDIF
38639 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
38640C IREJ=1
38641 IPCO=0
38642C RETURN
38643C WRITE(6,*)' MUSQBS1 jump back from chain 3'
38644 GO TO 3466
38645 ENDIF
38646 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
38647 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
38648 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
38649 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
38650 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
38651 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
38652 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
38653 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
38654 IDHKT(4+IIGLU1) =IP12
38655 ISTHKT(4+IIGLU1) =931
38656 JMOHKT(1,4+IIGLU1)=NC1P
38657 JMOHKT(2,4+IIGLU1)=0
38658 JDAHKT(1,4+IIGLU1)=6+IIGLU1
38659 JDAHKT(2,4+IIGLU1)=0
38660C create chain 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
38661 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
38662 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
38663 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
38664 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
38665C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
38666 XMIST =(PHKT(4,4+IIGLU1)**2-
38667 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
38668 *PHKT(1,4+IIGLU1)**2)
38669 IF(XMIST.GT.0.D0)THEN
38670 PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2-
38671 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
38672 *PHKT(1,4+IIGLU1)**2)
38673 ELSE
38674C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38675 PHKT(5,4+IIGLU1)=0.D0
38676 ENDIF
38677 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
38678 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
38679 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
38680 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
38681 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
38682 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
38683 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
38684 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
38685 IF(IPIP.EQ.1)THEN
38686 IDHKT(5+IIGLU1) =-(ISAQ1-6)
38687 ELSEIF(IPIP.EQ.2)THEN
38688 IDHKT(5+IIGLU1) =ISAQ1
38689 ENDIF
38690 ISTHKT(5+IIGLU1) =932
38691 JMOHKT(1,5+IIGLU1)=NC1T
38692 JMOHKT(2,5+IIGLU1)=0
38693 JDAHKT(1,5+IIGLU1)=6+IIGLU1
38694 JDAHKT(2,5+IIGLU1)=0
38695 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
38696 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
38697 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
38698 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
38699C IF( PHKT(4,5).EQ.0.D0)THEN
38700C IREJ=1
38701CIPCO=0
38702CRETURN
38703C ENDIF
38704C PHKT(5,5) =PHKK(5,NC1T)
38705 XMIST=(PHKT(4,5+IIGLU1)**2-
38706 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
38707 *PHKT(1,5+IIGLU1)**2)
38708 IF(XMIST.GT.0.D0)THEN
38709 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
38710 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
38711 *PHKT(1,5+IIGLU1)**2)
38712 ELSE
38713C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38714 PHKT(5,5+IIGLU1)=0.D0
38715 ENDIF
38716 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
38717 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
38718 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
38719 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
38720 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
38721 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
38722 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
38723 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
38724 IDHKT(6+IIGLU1) =88888
38725 ISTHKT(6+IIGLU1) =94
38726 JMOHKT(1,6+IIGLU1)=4+IIGLU1
38727 JMOHKT(2,6+IIGLU1)=5+IIGLU1
38728 JDAHKT(1,6+IIGLU1)=0
38729 JDAHKT(2,6+IIGLU1)=0
38730 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
38731 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
38732 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
38733 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
38734 XMIST
38735 * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
38736 * -PHKT(3,6+IIGLU1)**2)
38737 IF(XMIST.GE.0.D0)THEN
38738 PHKT(5,6+IIGLU1)
38739 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
38740 * -PHKT(3,6+IIGLU1)**2)
38741 ELSE
38742C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38743 PHKT(5,1)=0.D0
38744 ENDIF
38745C IF(IPIP.EQ.3)THEN
38746 CHAMAL=CHAM1
38747 IF(IPIP.EQ.1)THEN
38748 IF(IP12.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
38749 ELSEIF(IPIP.EQ.2)THEN
38750 IF(IP12.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
38751 ENDIF
38752 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
38753C IREJ=1
38754 IPCO=0
38755C RETURN
38756C WRITE(6,*)' MGSQBS1 jump back from chain 6',
38757C * CHAMAL,PHKT(5,6+IIGLU1)
38758 GO TO 3466
38759 ENDIF
38760 IF(IPIP.GE.3)THEN
38761C IF(NUMEV.EQ.-324)THEN
38762 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
38763 * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
38764 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
38765 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
38766 * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
38767 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
38768 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
38769 * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
38770 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
38771 ENDIF
38772 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
38773 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
38774 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
38775 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
38776 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
38777 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
38778 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
38779 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
38780 IF(IPIP.EQ.1)THEN
38781 IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+3
38782 IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
38783 IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
38784 IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
38785 ELSEIF(IPIP.EQ.2)THEN
38786 IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3
38787 IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
38788 IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
38789 IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
38790C WRITE(6,*)'IDHKT(7+IIGLU1),IPP1,ISQ1',IDHKT(7+IIGLU1),IPP1,ISQ1
38791 ENDIF
38792 ISTHKT(7+IIGLU1) =931
38793 JMOHKT(1,7+IIGLU1)=NC2P
38794 JMOHKT(2,7+IIGLU1)=0
38795 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
38796 JDAHKT(2,7+IIGLU1)=0
38797C create chain 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
38798 PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
38799 PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
38800 PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
38801 PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
38802C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
38803C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
38804 IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
38805C IREJ=1
38806C WRITE(6,*)'reject PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P)'
38807 IPCO=0
38808C RETURN
38809 GO TO 3466
38810 ENDIF
38811C PHKT(5,7) =PHKK(5,NC2P)
38812 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
38813 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
38814 *PHKT(1,7+IIGLU1)**2)
38815 VHKT(1,7+IIGLU1) =VHKK(1,NC2P)
38816 VHKT(2,7+IIGLU1) =VHKK(2,NC2P)
38817 VHKT(3,7+IIGLU1) =VHKK(3,NC2P)
38818 VHKT(4,7+IIGLU1) =VHKK(4,NC2P)
38819 WHKT(1,7+IIGLU1) =WHKK(1,NC2P)
38820 WHKT(2,7+IIGLU1) =WHKK(2,NC2P)
38821 WHKT(3,7+IIGLU1) =WHKK(3,NC2P)
38822 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
38823C Insert here the IIGLU2 gluons
38824 PG1=0.D0
38825 PG2=0.D0
38826 PG3=0.D0
38827 PG4=0.D0
38828 IF(IIGLU2.GE.1)THEN
38829 JJG=NC2P
38830 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38831 KKG=JJG+IIG-7-IIGLU1
38832 IDHKT(IIG) =IDHKK(KKG)
38833 ISTHKT(IIG) =921
38834 JMOHKT(1,IIG)=KKG
38835 JMOHKT(2,IIG)=0
38836 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
38837 JDAHKT(2,IIG)=0
38838 PHKT(1,IIG)=PHKK(1,KKG)
38839 PG1=PG1+ PHKT(1,IIG)
38840 PHKT(2,IIG)=PHKK(2,KKG)
38841 PG2=PG2+ PHKT(2,IIG)
38842 PHKT(3,IIG)=PHKK(3,KKG)
38843 PG3=PG3+ PHKT(3,IIG)
38844 PHKT(4,IIG)=PHKK(4,KKG)
38845 PG4=PG4+ PHKT(4,IIG)
38846 PHKT(5,IIG)=PHKK(5,KKG)
38847 VHKT(1,IIG) =VHKK(1,KKG)
38848 VHKT(2,IIG) =VHKK(2,KKG)
38849 VHKT(3,IIG) =VHKK(3,KKG)
38850 VHKT(4,IIG) =VHKK(4,KKG)
38851 WHKT(1,IIG) =WHKK(1,KKG)
38852 WHKT(2,IIG) =WHKK(2,KKG)
38853 WHKT(3,IIG) =WHKK(3,KKG)
38854 WHKT(4,IIG) =WHKK(4,KKG)
38855 81 CONTINUE
38856 ENDIF
38857 IDHKT(8+IIGLU1+IIGLU2) =IP2
38858 ISTHKT(8+IIGLU1+IIGLU2) =932
38859 JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
38860 JMOHKT(2,8+IIGLU1+IIGLU2)=0
38861 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
38862 JDAHKT(2,8+IIGLU1+IIGLU2)=0
38863 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
38864 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
38865 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
38866 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
38867C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T)
38868 XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
38869 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38870 *PHKT(1,8+IIGLU1+IIGLU2)**2)
38871 IF(XMIST.GT.0.D0)THEN
38872 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
38873 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38874 *PHKT(1,8+IIGLU1+IIGLU2)**2)
38875 ELSE
38876C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38877 PHKT(5,8+IIGLU1+IIGLU2)=0.D0
38878 ENDIF
38879 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T)
38880 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T)
38881 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T)
38882 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T)
38883 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T)
38884 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T)
38885 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T)
38886 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T)
38887 IDHKT(9+IIGLU1+IIGLU2) =88888
38888 ISTHKT(9+IIGLU1+IIGLU2) =94
38889 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
38890 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
38891 JDAHKT(1,9+IIGLU1+IIGLU2)=0
38892 JDAHKT(2,9+IIGLU1+IIGLU2)=0
38893 PHKT(1,9+IIGLU1+IIGLU2)
38894 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
38895 PHKT(2,9+IIGLU1+IIGLU2)
38896 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
38897 PHKT(3,9+IIGLU1+IIGLU2)
38898 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
38899 PHKT(4,9+IIGLU1+IIGLU2)
38900 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
38901 XMIST
38902 *=(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
38903 * -PHKT(2,9+IIGLU1+IIGLU2)**2
38904 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
38905 IF(XMIST.GE.0.D0)THEN
38906 PHKT(5,9+IIGLU1+IIGLU2)
38907 *=SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
38908 * -PHKT(2,9+IIGLU1+IIGLU2)**2
38909 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
38910 ELSE
38911C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38912 PHKT(5,1)=0.D0
38913 ENDIF
38914 IF(IPIP.GE.3)THEN
38915C IF(NUMEV.EQ.-324)THEN
38916 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
38917 * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
38918 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
38919 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38920 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38921 & JMOHKT(1,IIG),JMOHKT(2,IIG),
38922 * JDAHKT(1,IIG),
38923 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38924 91 CONTINUE
38925 WRITE(LOUT,*)8+IIGLU1+IIGLU2,
38926 * ISTHKT(8+IIGLU1+IIGLU2),IDHKT(8+IIGLU1+IIGLU2),
38927 * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
38928 *JDAHKT(1,8+IIGLU1+IIGLU2),
38929 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
38930 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
38931 * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
38932 *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
38933 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
38934 ENDIF
38935 CHAMAL=CHAB1
38936 IF(IPIP.EQ.1)THEN
38937 IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
38938 ELSEIF(IPIP.EQ.2)THEN
38939 IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
38940 ENDIF
38941 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
38942C IREJ=1
38943 IPCO=0
38944C RETURN
38945C WRITE(6,*)' MGSQBS1 jump back from chain 9',
38946C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
38947 GO TO 3466
38948 ENDIF
38949 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
38950 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
38951 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
38952 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
38953 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
38954 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
38955 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
38956 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
38957C
38958 IPCO=0
38959 IGCOUN=9+IIGLU1+IIGLU2
38960 RETURN
38961 END
38962
38963*$ CREATE MGSQBS1.FOR
38964*COPY MGSQBS1
38965C
38966C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
38967 SUBROUTINE MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
38968 * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,ISQ,IGCOUN)
38969C
38970C GSQBS-1 diagram (split projectile diquark)
38971C
38972 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38973 SAVE
38974
38975 PARAMETER ( LINP = 10 ,
38976 & LOUT = 6 ,
38977 & LDAT = 9 )
38978* event history
38979 PARAMETER (NMXHKK=200000)
38980 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38981 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38982 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38983* extended event history
38984 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38985 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38986 & IHIST(2,NMXHKK)
38987* Lorentz-parameters of the current interaction
38988 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
38989 & UMO,PPCM,EPROJ,PPROJ
38990* diquark-breaking mechanism
38991 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
38992
38993C
38994 PARAMETER (NTMHKK= 300)
38995 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38996 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38997 +(4,NTMHKK)
38998*KEEP,XSEADI.
38999 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
39000 +SSMIMQ,VVMTHR
39001*KEEP,DPRIN.
39002 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
39003C
39004C GSQBS-1 diagram (split projectile diquark)
39005C
39006C
39007C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
39008C Input chain 2(NC2) sea-quark(NC2P)-valence-diquark(NC2T)
39009C
39010C Create quark(qs)-antiquark(aqs) pair energy from NC1P and NC1T
39011C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
39012C
39013C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
39014C 6 valence quark(vq2P 4)-sea-quark(aqsP 5)
39015C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
39016C
39017C Put new chains into COMMON /HKKTMP/
39018C
39019 IIGLU1=NC1T-NC1P-1
39020 IIGLU2=NC2T-NC2P-1
39021 IGCOUN=0
39022C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
39023 CVQ=1.D0
39024 NNNC1=IDHKK(NC1)/1000
39025 MMMC1=IDHKK(NC1)-NNNC1*1000
39026 KKKC1=ISTHKK(NC1)
39027 NNNC2=IDHKK(NC2)/1000
39028 MMMC2=IDHKK(NC2)-NNNC2*1000
39029 KKKC2=ISTHKK(NC2)
39030 IREJ=0
39031 IF(IPIP.EQ.3)THEN
39032 WRITE(LOUT,*)' MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
39033 * ' IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN)',
39034 *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
39035 * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN
39036 ENDIF
39037C
39038C
39039C
39040C determine x-values of NC1P diquark
39041 XDIQP=PHKK(4,NC1P)*2.D0/UMO
39042 XVQT=PHKK(4,NC1T)*2.D0/UMO
39043C
39044C determine x-values of sea quark pair
39045C
39046 IPCO=1
39047 ICOU=0
39048 2234 CONTINUE
39049 ICOU=ICOU+1
39050 IF(ICOU.GE.500)THEN
39051 IREJ=1
39052 IF(ISQ.EQ.3)IREJ=3
39053 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 Rejection 2234 ICOU. GT.100'
39054 IPCO=0
39055 RETURN
39056 ENDIF
39057 IF(IPCO.GE.3)WRITE(LOUT,*)'MGSQBS1 call XSEAPA: UMO,XDIQP,XVQT ',
39058 * UMO, XDIQP,XVQT
39059 XSQ=0.D0
39060 XSAQ=0.D0
39061**NEW
39062C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
39063 IF (IPIP.EQ.1) THEN
39064 XQMAX = XDIQP/2.0D0
39065 XAQMAX = 2.D0*XVQT/3.0D0
39066 ELSE
39067 XQMAX = 2.D0*XVQT/3.0D0
39068 XAQMAX = XDIQP/2.0D0
39069 ENDIF
39070 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
39071 ISAQ = 6+ISQ
39072C write(*,*) 'MGSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
39073**
39074 IF(IPCO.GE.3)
39075 & WRITE(LOUT,*)'MGSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
39076 IF(IREJ.GE.1)THEN
39077 IF(IPCO.GE.3)
39078 & WRITE(LOUT,*)'MGSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
39079 IPCO=0
39080 RETURN
39081 ENDIF
39082 IF(IPIP.EQ.1)THEN
39083 IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
39084 ELSEIF(IPIP.EQ.2)THEN
39085 IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
39086 ENDIF
39087 IF(IPCO.GE.3)THEN
39088 WRITE(LOUT,'(A,4E12.4)')' MGSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
39089 * XDIQP,XVQT,XSQ,XSAQ
39090 ENDIF
39091C
39092C subtract xsq,xsaq from NC1P diquark and NC1T quark
39093C
39094C XSQ=0.D0
39095 IF(IPIP.EQ.1)THEN
39096 XDIQP=XDIQP-XSQ
39097**NEW
39098C IF (XDIQP.LT.0.0D0) WRITE(*,*) ' mgsqbs1: XDIQP<0!!',XDIQP
39099**
39100 XVQT =XVQT -XSAQ
39101 ELSEIF(IPIP.EQ.2)THEN
39102 XDIQP=XDIQP-XSAQ
39103 XVQT =XVQT -XSQ
39104 ENDIF
39105 IF(IPCO.GE.3)
39106 & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
39107C
39108C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
39109C
39110 XVTHRO=CVQ/UMO
39111 IVTHR=0
39112 3466 CONTINUE
39113 IF(IVTHR.EQ.10)THEN
39114 IREJ=1
39115 IF(ISQ.EQ.3)IREJ=3
39116 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 3466 reject IVTHR 10'
39117 IPCO=0
39118 RETURN
39119 ENDIF
39120 IVTHR=IVTHR+1
39121 XVTHR=XVTHRO/(201-IVTHR)
39122 UNOPRV=UNON
39123 380 CONTINUE
39124 IF(XVTHR.GT.0.66D0*XDIQP)THEN
39125 IREJ=1
39126 IF(ISQ.EQ.3)IREJ=3
39127 IF(IPCO.GE.3)
39128 & WRITE(LOUT,*)' MGSQBS1 Rejection 380 XVTHR large ',
39129 * XVTHR
39130 IPCO=0
39131 RETURN
39132 ENDIF
39133 IF(DT_RNDM(V).LT.0.5D0)THEN
39134 XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
39135 XVPQII=XDIQP-XVPQI
39136 ELSE
39137 XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
39138 XVPQI=XDIQP-XVPQII
39139 ENDIF
39140 IF(IPCO.GE.3)THEN
39141 WRITE(LOUT,'(A,4E12.4)')' MGSQBS1:XVTHR,XDIQP,XVPQI,XVPQII ',
39142 * XVTHR,XDIQP,XVPQI,XVPQII
39143 ENDIF
39144C
39145C Prepare 4 momenta of new chains and chain ends
39146C
39147C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
39148C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
39149C +(4,NTMHKK)
39150C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
39151C 6 valence quark(vq2P 4)-sea-quark(aqsP 5)
39152C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
39153 IF(IPIP.EQ.1)THEN
39154 XSQ1=XSQ
39155 XSAQ1=XSAQ
39156 ISQ1=ISQ
39157 ISAQ1=ISAQ
39158 ELSEIF(IPIP.EQ.2)THEN
39159 XSQ1=XSAQ
39160 XSAQ1=XSQ
39161 ISQ1=ISAQ
39162 ISAQ1=ISQ
39163 ENDIF
39164 KK11=IP11
39165C IDHKT(2) =1000*IPP21+100*IPP22+1
39166 KK21= IPP21
39167 KK22= IPP22
39168 XGIVE=0.D0
39169 IDHKT(4+IIGLU1) =IP12
39170 ISTHKT(4+IIGLU1) =921
39171 JMOHKT(1,4+IIGLU1)=NC1P
39172 JMOHKT(2,4+IIGLU1)=0
39173 JDAHKT(1,4+IIGLU1)=6+IIGLU1
39174 JDAHKT(2,4+IIGLU1)=0
39175**NEW
39176 IF ((XDIQP.LT.0.0D0).OR.(XVPQII.LT.0.0D0).OR.
39177 & (XSQ1.LT.0.0D0)) WRITE(LOUT,*) ' mgsqbs1: ',XDIQP,XVPQII,XSQ1
39178**
39179 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
39180 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
39181 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
39182 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
39183C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
39184 XXMIST=(PHKT(4,4+IIGLU1)**2-
39185 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
39186 * PHKT(1,4+IIGLU1)**2)
39187 IF(XXMIST.GT.0.D0)THEN
39188 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
39189 ELSE
39190 WRITE(LOUT,*)'MGSQBS1 XXMIST',XXMIST
39191 XXMIST=ABS(XXMIST)
39192 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
39193 ENDIF
39194 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
39195 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
39196 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
39197 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
39198 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
39199 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
39200 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
39201 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
39202 IF(IPIP.EQ.1)THEN
39203 IDHKT(5+IIGLU1) =-(ISAQ1-6)
39204 ELSEIF(IPIP.EQ.2)THEN
39205 IDHKT(5+IIGLU1) =ISAQ1
39206 ENDIF
39207 ISTHKT(5+IIGLU1) =922
39208 JMOHKT(1,5+IIGLU1)=NC1T
39209 JMOHKT(2,5+IIGLU1)=0
39210 JDAHKT(1,5+IIGLU1)=6+IIGLU1
39211 JDAHKT(2,5+IIGLU1)=0
39212**NEW
39213 IF ((XSAQ1.LT.0.0D0).OR.(XVQT .LT.0.0D0))
39214 & WRITE(LOUT,*) ' mgsqbs2: ',XSAQ1,XVQT
39215**
39216 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
39217 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
39218 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
39219 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
39220C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
39221 XMIST=(PHKT(4,5+IIGLU1)**2-
39222 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
39223 *PHKT(1,5+IIGLU1)**2)
39224 IF(XMIST.GT.0.D0)THEN
39225 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
39226 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
39227 *PHKT(1,5+IIGLU1)**2)
39228 ELSE
39229C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
39230 PHKT(5,5+IIGLU1)=0.D0
39231 ENDIF
39232 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
39233 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
39234 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
39235 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
39236 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
39237 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
39238 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
39239 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
39240 IDHKT(6+IIGLU1) =88888
39241C IDHKT(6) =1000*NNNC1+MMMC1
39242 ISTHKT(6+IIGLU1) =93
39243C ISTHKT(6) =KKKC1
39244 JMOHKT(1,6+IIGLU1)=4+IIGLU1
39245 JMOHKT(2,6+IIGLU1)=5+IIGLU1
39246 JDAHKT(1,6+IIGLU1)=0
39247 JDAHKT(2,6+IIGLU1)=0
39248 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
39249 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
39250 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
39251 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
39252 PHKT(5,6+IIGLU1)
39253 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
39254 * -PHKT(3,6+IIGLU1)**2)
39255 CHAMAL=CHAM1
39256 IF(IPIP.EQ.1)THEN
39257 IF(IP12.GE.3.OR.ISAQ.GE.9)CHAMAL=CHAM3
39258 ELSEIF(IPIP.EQ.2)THEN
39259 IF(IP12.LE.-3.OR.ISAQ.GE.3)CHAMAL=CHAM3
39260 ENDIF
39261 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
39262 IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
39263C we drop chain 6 and give the energy to chain 3
39264 IDHKT(6+IIGLU1)=33888
39265 XGIVE=1.D0
39266C WRITE(6,*)' drop chain 6 xgive=1'
39267 GO TO 7788
39268 ELSEIF(IDHKT(5+IIGLU1).EQ.-IP11)THEN
39269C we drop chain 6 and give the energy to chain 3
39270C and change KK11 to IDHKT(4)
39271 IDHKT(6+IIGLU1)=33888
39272 XGIVE=1.D0
39273C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(4+IIGLU1)'
39274 KK11=IDHKT(4+IIGLU1)
39275 GO TO 7788
39276 ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP21)THEN
39277C we drop chain 6 and give the energy to chain 3
39278C and change KK21 to IDHKT(4)
39279C IDHKT(2) =1000*IPP21+100*IPP22+1
39280 IDHKT(6+IIGLU1)=33888
39281 XGIVE=1.D0
39282C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(4+IIGLU1)'
39283 KK21=IDHKT(4+IIGLU1)
39284 GO TO 7788
39285 ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP22)THEN
39286C we drop chain 6 and give the energy to chain 3
39287C and change KK22 to IDHKT(4)
39288C IDHKT(2) =1000*IPP21+100*IPP22+1
39289 IDHKT(6+IIGLU1)=33888
39290 XGIVE=1.D0
39291C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(4+IIGLU1)'
39292 KK22=IDHKT(4+IIGLU1)
39293 GO TO 7788
39294 ENDIF
39295C IREJ=1
39296 IPCO=0
39297C RETURN
39298C WRITE(6,*)' MGSQBS1 jump back from chain 6'
39299 GO TO 3466
39300 ENDIF
39301 7788 CONTINUE
39302 IF(IPIP.GE.3)THEN
39303 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
39304 * JMOHKT(1,4+IIGLU1),
39305 * JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
39306 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
39307 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
39308 * JMOHKT(1,5+IIGLU1),
39309 * JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
39310 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
39311 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
39312 * JMOHKT(1,6+IIGLU1),
39313 * JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
39314 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
39315 ENDIF
39316 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
39317 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
39318 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
39319 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
39320 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
39321 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
39322 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
39323 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
39324C IDHKT(1) =IP11
39325 IDHKT(1) =KK11
39326 ISTHKT(1) =921
39327 JMOHKT(1,1)=NC1P
39328 JMOHKT(2,1)=0
39329 JDAHKT(1,1)=3+IIGLU1
39330 JDAHKT(2,1)=0
39331 PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
39332C * +0.5D0*PHKK(1,NC2P)
39333 *+XGIVE*PHKT(1,4+IIGLU1)
39334 PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
39335C * +0.5D0*PHKK(2,NC2P)
39336 *+XGIVE*PHKT(2,4+IIGLU1)
39337 PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
39338C * +0.5D0*PHKK(3,NC2P)
39339 *+XGIVE*PHKT(3,4+IIGLU1)
39340 PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
39341C * +0.5D0*PHKK(4,NC2P)
39342 *+XGIVE*PHKT(4,4+IIGLU1)
39343C PHKT(5,1) =PHKK(5,NC1P)
39344 XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
39345 *PHKT(1,1)**2)
39346 IF(XMIST.GE.0.D0)THEN
39347 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
39348 *PHKT(1,1)**2)
39349 ELSE
39350C WRITE(6,*)'MGSQBS1 parton 1 mass square LT.0 ',XMIST
39351 PHKT(5,1)=0.D0
39352 ENDIF
39353 VHKT(1,1) =VHKK(1,NC1P)
39354 VHKT(2,1) =VHKK(2,NC1P)
39355 VHKT(3,1) =VHKK(3,NC1P)
39356 VHKT(4,1) =VHKK(4,NC1P)
39357 WHKT(1,1) =WHKK(1,NC1P)
39358 WHKT(2,1) =WHKK(2,NC1P)
39359 WHKT(3,1) =WHKK(3,NC1P)
39360 WHKT(4,1) =WHKK(4,NC1P)
39361C Add here IIGLU1 gluons to this chaina
39362 PG1=0.D0
39363 PG2=0.D0
39364 PG3=0.D0
39365 PG4=0.D0
39366 IF(IIGLU1.GE.1)THEN
39367 JJG=NC1P
39368 DO 61 IIG=2,2+IIGLU1-1
39369 KKG=JJG+IIG-1
39370 IDHKT(IIG) =IDHKK(KKG)
39371 ISTHKT(IIG) =921
39372 JMOHKT(1,IIG)=KKG
39373 JMOHKT(2,IIG)=0
39374 JDAHKT(1,IIG)=3+IIGLU1
39375 JDAHKT(2,IIG)=0
39376 PHKT(1,IIG)=PHKK(1,KKG)
39377 PG1=PG1+ PHKT(1,IIG)
39378 PHKT(2,IIG)=PHKK(2,KKG)
39379 PG2=PG2+ PHKT(2,IIG)
39380 PHKT(3,IIG)=PHKK(3,KKG)
39381 PG3=PG3+ PHKT(3,IIG)
39382 PHKT(4,IIG)=PHKK(4,KKG)
39383 PG4=PG4+ PHKT(4,IIG)
39384 PHKT(5,IIG)=PHKK(5,KKG)
39385 VHKT(1,IIG) =VHKK(1,KKG)
39386 VHKT(2,IIG) =VHKK(2,KKG)
39387 VHKT(3,IIG) =VHKK(3,KKG)
39388 VHKT(4,IIG) =VHKK(4,KKG)
39389 WHKT(1,IIG) =WHKK(1,KKG)
39390 WHKT(2,IIG) =WHKK(2,KKG)
39391 WHKT(3,IIG) =WHKK(3,KKG)
39392 WHKT(4,IIG) =WHKK(4,KKG)
39393 61 CONTINUE
39394 ENDIF
39395C IDHKT(2) =1000*IPP21+100*IPP22+1
39396 IF(IPIP.EQ.1)THEN
39397 IDHKT(2+IIGLU1) =1000*KK21+100*KK22+3
39398 IF(IDHKT(2+IIGLU1).EQ.1203)IDHKT(2+IIGLU1)=2103
39399 IF(IDHKT(2+IIGLU1).EQ.1303)IDHKT(2+IIGLU1)=3103
39400 IF(IDHKT(2+IIGLU1).EQ.2303)IDHKT(2+IIGLU1)=3203
39401 ELSEIF(IPIP.EQ.2)THEN
39402 IDHKT(2+IIGLU1) =1000*KK21+100*KK22-3
39403 IF(IDHKT(2+IIGLU1).EQ.-1203)IDHKT(2+IIGLU1)=-2103
39404 IF(IDHKT(2+IIGLU1).EQ.-1303)IDHKT(2+IIGLU1)=-3103
39405 IF(IDHKT(2+IIGLU1).EQ.-2303)IDHKT(2+IIGLU1)=-3203
39406 ENDIF
39407 ISTHKT(2+IIGLU1) =922
39408 JMOHKT(1,2+IIGLU1)=NC2T
39409 JMOHKT(2,2+IIGLU1)=0
39410 JDAHKT(1,2+IIGLU1)=3+IIGLU1
39411 JDAHKT(2,2+IIGLU1)=0
39412 PHKT(1,2+IIGLU1) =PHKK(1,NC2T)
39413 *+XGIVE*PHKT(1,5+IIGLU1)
39414 PHKT(2,2+IIGLU1) =PHKK(2,NC2T)
39415 *+XGIVE*PHKT(2,5+IIGLU1)
39416 PHKT(3,2+IIGLU1) =PHKK(3,NC2T)
39417 *+XGIVE*PHKT(3,5+IIGLU1)
39418 PHKT(4,2+IIGLU1) =PHKK(4,NC2T)
39419 *+XGIVE*PHKT(4,5+IIGLU1)
39420C PHKT(5,2) =PHKK(5,NC2T)
39421 XMIST=(PHKT(4,2+IIGLU1)**2-
39422 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
39423 *PHKT(1,2+IIGLU1)**2)
39424 IF(XMIST.GT.0.D0)THEN
39425 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
39426 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
39427 *PHKT(1,2+IIGLU1)**2)
39428 ELSE
39429C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
39430 PHKT(5,2+IIGLU1)=0.D0
39431 ENDIF
39432 VHKT(1,2+IIGLU1) =VHKK(1,NC2T)
39433 VHKT(2,2+IIGLU1) =VHKK(2,NC2T)
39434 VHKT(3,2+IIGLU1) =VHKK(3,NC2T)
39435 VHKT(4,2+IIGLU1) =VHKK(4,NC2T)
39436 WHKT(1,2+IIGLU1) =WHKK(1,NC2T)
39437 WHKT(2,2+IIGLU1) =WHKK(2,NC2T)
39438 WHKT(3,2+IIGLU1) =WHKK(3,NC2T)
39439 WHKT(4,2+IIGLU1) =WHKK(4,NC2T)
39440 IDHKT(3+IIGLU1) =88888
39441C IDHKT(3) =1000*NNNC1+MMMC1+10
39442 ISTHKT(3+IIGLU1) =93
39443C ISTHKT(3) =KKKC1
39444 JMOHKT(1,3+IIGLU1)=1
39445 JMOHKT(2,3+IIGLU1)=2+IIGLU1
39446 JDAHKT(1,3+IIGLU1)=0
39447 JDAHKT(2,3+IIGLU1)=0
39448 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
39449 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
39450 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
39451 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
39452 PHKT(5,3+IIGLU1)
39453 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
39454 * -PHKT(3,3+IIGLU1)**2)
39455 IF(IPIP.GE.3)THEN
39456 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
39457 * JDAHKT(1,1),
39458 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
39459 DO 71 IIG=2,2+IIGLU1-1
39460 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
39461 & JMOHKT(1,IIG),JMOHKT(2,IIG),
39462 * JDAHKT(1,IIG),
39463 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
39464 71 CONTINUE
39465 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),
39466 & IDHKT(2),JMOHKT(1,2+IIGLU1),
39467 * JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
39468 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
39469 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
39470 * JMOHKT(1,3+IIGLU1),
39471 * JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
39472 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
39473 ENDIF
39474 CHAMAL=CHAB1
39475**NEW
39476C IF(IPIP.EQ.1)THEN
39477C IF(IPP21.GE.3.OR.IPP22.GE.3.OR.IP11.GE.3)CHAMAL=CHAB3
39478C ELSEIF(IPIP.EQ.2)THEN
39479C IF(IPP21.LE.-3.OR.IPP22.LE.-3.OR.IP11.LE.-3)CHAMAL=CHAB3
39480C ENDIF
39481 IF(IPIP.EQ.1)THEN
39482 IF(KK21.GE.3.OR.KK22.GE.3.OR.KK11.GE.3)CHAMAL=CHAB3
39483 ELSEIF(IPIP.EQ.2)THEN
39484 IF(KK21.LE.-3.OR.KK22.LE.-3.OR.KK11.LE.-3)CHAMAL=CHAB3
39485 ENDIF
39486**
39487 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
39488C IREJ=1
39489 IPCO=0
39490C RETURN
39491C WRITE(6,*)' MGSQBS1 jump back from chain 3'
39492 GO TO 3466
39493 ENDIF
39494 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
39495 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
39496 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
39497 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
39498 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
39499 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
39500 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
39501 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
39502 IF(IPIP.EQ.1)THEN
39503 IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ1+3
39504 IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
39505 IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
39506 IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
39507 ELSEIF(IPIP.EQ.2)THEN
39508 IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3
39509 IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
39510 IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
39511 IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
39512C WRITE(6,*)'IDHKT(7),IPP1,ISQ1',IDHKT(7),IPP1,ISQ1
39513 ENDIF
39514 ISTHKT(7+IIGLU1) =921
39515 JMOHKT(1,7+IIGLU1)=NC2P
39516 JMOHKT(2,7+IIGLU1)=0
39517 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
39518 JDAHKT(2,7+IIGLU1)=0
39519C PHKT(1,7) =0.5D0*PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ/(XDIQP+XSQ)
39520C PHKT(2,7) =0.5D0*PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ/(XDIQP+XSQ)
39521C PHKT(3,7) =0.5D0*PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ/(XDIQP+XSQ)
39522C PHKT(4,7+IIGLU1) =0.5D0*PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ/(XDIQP+XSQ)
39523**NEW
39524 IF ((XSQ1 .LT.0.0D0).OR.(XDIQP .LT.0.0D0))
39525 & WRITE(LOUT,*) ' mgsqbs3: ',XSQ1,XDIQP
39526**
39527 PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
39528 PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
39529 PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
39530 PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
39531C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
39532C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
39533 IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
39534C IREJ=1
39535C WRITE(6,*)'reject PHKT(4,7).GE. PHKK(4,NC1P)'
39536 IPCO=0
39537C RETURN
39538 GO TO 3466
39539 ENDIF
39540C PHKT(5,7) =PHKK(5,NC2P)
39541 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
39542 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
39543 *PHKT(1,7+IIGLU1)**2)
39544 VHKT(1,7+IIGLU1) =VHKK(1,NC2P)
39545 VHKT(2,7+IIGLU1) =VHKK(2,NC2P)
39546 VHKT(3,7+IIGLU1) =VHKK(3,NC2P)
39547 VHKT(4,7+IIGLU1) =VHKK(4,NC2P)
39548 WHKT(1,7+IIGLU1) =WHKK(1,NC2P)
39549 WHKT(2,7+IIGLU1) =WHKK(2,NC2P)
39550 WHKT(3,7+IIGLU1) =WHKK(3,NC2P)
39551 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
39552C Insert here the IIGLU2 gluons
39553 PG1=0.D0
39554 PG2=0.D0
39555 PG3=0.D0
39556 PG4=0.D0
39557 IF(IIGLU2.GE.1)THEN
39558 JJG=NC2P
39559 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
39560 KKG=JJG+IIG-7-IIGLU1
39561 IDHKT(IIG) =IDHKK(KKG)
39562 ISTHKT(IIG) =921
39563 JMOHKT(1,IIG)=KKG
39564 JMOHKT(2,IIG)=0
39565 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
39566 JDAHKT(2,IIG)=0
39567 PHKT(1,IIG)=PHKK(1,KKG)
39568 PG1=PG1+ PHKT(1,IIG)
39569 PHKT(2,IIG)=PHKK(2,KKG)
39570 PG2=PG2+ PHKT(2,IIG)
39571 PHKT(3,IIG)=PHKK(3,KKG)
39572 PG3=PG3+ PHKT(3,IIG)
39573 PHKT(4,IIG)=PHKK(4,KKG)
39574 PG4=PG4+ PHKT(4,IIG)
39575 PHKT(5,IIG)=PHKK(5,KKG)
39576 VHKT(1,IIG) =VHKK(1,KKG)
39577 VHKT(2,IIG) =VHKK(2,KKG)
39578 VHKT(3,IIG) =VHKK(3,KKG)
39579 VHKT(4,IIG) =VHKK(4,KKG)
39580 WHKT(1,IIG) =WHKK(1,KKG)
39581 WHKT(2,IIG) =WHKK(2,KKG)
39582 WHKT(3,IIG) =WHKK(3,KKG)
39583 WHKT(4,IIG) =WHKK(4,KKG)
39584 81 CONTINUE
39585 ENDIF
39586 IDHKT(8+IIGLU1+IIGLU2) =IP2
39587 ISTHKT(8+IIGLU1+IIGLU2) =922
39588 JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
39589 JMOHKT(2,8+IIGLU1+IIGLU2)=0
39590 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
39591 JDAHKT(2,8+IIGLU1+IIGLU2)=0
39592**NEW
39593 IF ((XVQT.LT.0.0D0).OR.(XSAQ1 .LT.0.0D0))
39594 & WRITE(LOUT,*) ' mgsqbs4: ',XVQT,XSAQ1
39595**
39596 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
39597 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
39598 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
39599 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
39600C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T)
39601 XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
39602 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
39603 *PHKT(1,8+IIGLU1+IIGLU2)**2)
39604 IF(XMIST.GT.0.D0)THEN
39605 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
39606 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
39607 *PHKT(1,8+IIGLU1+IIGLU2)**2)
39608 ELSE
39609C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
39610 PHKT(5,8+IIGLU1+IIGLU2)=0.D0
39611 ENDIF
39612 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T)
39613 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T)
39614 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T)
39615 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T)
39616 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T)
39617 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T)
39618 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T)
39619 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T)
39620 IDHKT(9+IIGLU1+IIGLU2) =88888
39621C IDHKT(9) =1000*NNNC2+MMMC2+10
39622 ISTHKT(9+IIGLU1+IIGLU2) =93
39623C ISTHKT(9) =KKKC2
39624 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
39625 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
39626 JDAHKT(1,9+IIGLU1+IIGLU2)=0
39627 JDAHKT(2,9+IIGLU1+IIGLU2)=0
39628 PHKT(1,9+IIGLU1+IIGLU2) =PHKT(1,7+IIGLU1)
39629 * +PHKT(1,8+IIGLU1+IIGLU2)+PG1
39630 PHKT(2,9+IIGLU1+IIGLU2) =PHKT(2,7+IIGLU1)
39631 * +PHKT(2,8+IIGLU1+IIGLU2)+PG2
39632 PHKT(3,9+IIGLU1+IIGLU2) =PHKT(3,7+IIGLU1)
39633 * +PHKT(3,8+IIGLU1+IIGLU2)+PG3
39634 PHKT(4,9+IIGLU1+IIGLU2) =PHKT(4,7+IIGLU1)
39635 * +PHKT(4,8+IIGLU1+IIGLU2)+PG4
39636 PHKT(5,9+IIGLU1+IIGLU2)
39637 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
39638 * PHKT(2,9+IIGLU1+IIGLU2)**2
39639 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
39640 IF(IPIP.GE.3)THEN
39641 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
39642 * JMOHKT(1,7+IIGLU1),
39643 * JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
39644 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
39645 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
39646 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
39647 & JMOHKT(1,IIG),JMOHKT(2,IIG),
39648 * JDAHKT(1,IIG),
39649 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
39650 91 CONTINUE
39651 WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
39652 * IDHKT(8+IIGLU1+IIGLU2),
39653 * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
39654 * JDAHKT(1,8+IIGLU1+IIGLU2),
39655 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
39656 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
39657 * IDHKT(9+IIGLU1+IIGLU2),
39658 * JMOHKT(1,9+IIGLU1+IIGLU2),JMOHKT(2,9+IIGLU1+IIGLU2),
39659 * JDAHKT(1,9+IIGLU1+IIGLU2),
39660 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
39661 ENDIF
39662 CHAMAL=CHAB1
39663 IF(IPIP.EQ.1)THEN
39664 IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
39665 ELSEIF(IPIP.EQ.2)THEN
39666 IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
39667 ENDIF
39668 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
39669C IREJ=1
39670 IPCO=0
39671C RETURN
39672C WRITE(6,*)' MGSQBS1 jump back from chain 9',
39673C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
39674 GO TO 3466
39675 ENDIF
39676 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
39677 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
39678 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
39679 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
39680 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
39681 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
39682 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
39683 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
39684C
39685 IGCOUN=9+IIGLU1+IIGLU2
39686 IPCO=0
39687 RETURN
39688 END
39689
39690*$ CREATE HKKHKT.FOR
39691*COPY HKKHKT
39692C
39693C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
39694C
39695 SUBROUTINE HKKHKT(I,J)
39696 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39697 SAVE
39698
39699* event history
39700 PARAMETER (NMXHKK=200000)
39701 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
39702 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
39703 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
39704* extended event history
39705 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
39706 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
39707 & IHIST(2,NMXHKK)
39708
39709 PARAMETER (NTMHKK= 300)
39710 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
39711 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
39712 +(4,NTMHKK)
39713C
39714 ISTHKK(I) =ISTHKT(J)
39715 IDHKK(I) =IDHKT(J)
39716C IF(J.EQ.3.OR.J.EQ.6.OR.J.EQ.9)THEN
39717 IF(IDHKK(I).EQ.88888)THEN
39718C JMOHKK(1,I)=I-2
39719C JMOHKK(2,I)=I-1
39720 JMOHKK(1,I)=I-(J-JMOHKT(1,J))
39721 JMOHKK(2,I)=I-(J-JMOHKT(2,J))
39722 ELSE
39723 JMOHKK(1,I)=JMOHKT(1,J)
39724 JMOHKK(2,I)=JMOHKT(2,J)
39725 ENDIF
39726 JDAHKK(1,I)=JDAHKT(1,J)
39727 JDAHKK(2,I)=JDAHKT(2,J)
39728C IF(J.EQ.1.OR.J.EQ.4.OR.J.EQ.7)THEN
39729C JDAHKK(1,I)=I+2
39730C ELSEIF(J.EQ.2.OR.J.EQ.5.OR.J.EQ.8)THEN
39731C JDAHKK(1,I)=I+1
39732C ENDIF
39733 IF(JDAHKT(1,J).GT.0)THEN
39734 JDAHKK(1,I)=I+(JDAHKT(1,J)-J)
39735 ENDIF
39736 PHKK(1,I) =PHKT(1,J)
39737 PHKK(2,I) =PHKT(2,J)
39738 PHKK(3,I) =PHKT(3,J)
39739 PHKK(4,I) =PHKT(4,J)
39740 PHKK(5,I) =PHKT(5,J)
39741 VHKK(1,I) =VHKT(1,J)
39742 VHKK(2,I) =VHKT(2,J)
39743 VHKK(3,I) =VHKT(3,J)
39744 VHKK(4,I) =VHKT(4,J)
39745 WHKK(1,I) =WHKT(1,J)
39746 WHKK(2,I) =WHKT(2,J)
39747 WHKK(3,I) =WHKT(3,J)
39748 WHKK(4,I) =WHKT(4,J)
39749 RETURN
39750 END
39751
39752*$ CREATE DT_DBREAK.FOR
39753*COPY DT_DBREAK
39754*
39755*===dbreak=============================================================*
39756*
39757 SUBROUTINE DT_DBREAK(MODE)
39758
39759************************************************************************
39760* This is the steering subroutine for the different diquark breaking *
39761* mechanisms. *
39762* *
39763* MODE = 1 breaking of projectile diquark in qq-q chain using *
39764* a sea quark (q-qq chain) of the same projectile *
39765* = 2 breaking of target diquark in q-qq chain using *
39766* a sea quark (qq-q chain) of the same target *
39767* = 3 breaking of projectile diquark in qq-q chain using *
39768* a sea quark (q-aq chain) of the same projectile *
39769* = 4 breaking of target diquark in q-qq chain using *
39770* a sea quark (aq-q chain) of the same target *
39771* = 5 breaking of projectile anti-diquark in aqaq-aq chain using *
39772* a sea anti-quark (aq-aqaq chain) of the same projectile *
39773* = 6 breaking of target anti-diquark in aq-aqaq chain using *
39774* a sea anti-quark (aqaq-aq chain) of the same target *
39775* = 7 breaking of projectile anti-diquark in aqaq-aq chain using *
39776* a sea anti-quark (aq-q chain) of the same projectile *
39777* = 8 breaking of target anti-diquark in aq-aqaq chain using *
39778* a sea anti-quark (q-aq chain) of the same target *
39779* *
39780* Original version by J. Ranft. *
39781* This version dated 17.5.00 is written by S. Roesler. *
39782************************************************************************
39783
39784 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39785 SAVE
39786 PARAMETER ( LINP = 10 ,
39787 & LOUT = 6 ,
39788 & LDAT = 9 )
39789
39790* event history
39791 PARAMETER (NMXHKK=200000)
39792 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
39793 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
39794 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
39795* extended event history
39796 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
39797 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
39798 & IHIST(2,NMXHKK)
39799* flags for input different options
39800 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
39801 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
39802 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
39803* pointer to chains in hkkevt common (used by qq-breaking mechanisms)
39804 PARAMETER (MAXCHN=10000)
39805 COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
39806* diquark-breaking mechanism
39807 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
39808* flags for particle decays
39809 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
39810 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
39811 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
39812
39813*
39814* chain identifiers
39815* ( 1 = q-aq, 2 = aq-q, 3 = q-qq, 4 = qq-q,
39816* 5 = aq-adq, 6 = adq-aq, 7 = dq-adq, 8 = adq-dq )
39817 DIMENSION IDCHN1(8),IDCHN2(8)
39818 DATA IDCHN1 / 4, 3, 4, 3, 6, 5, 6, 5/
39819 DATA IDCHN2 / 3, 4, 1, 2, 5, 6, 2, 1/
39820*
39821* parton identifiers
39822* ( +-21/22 = valence, +-31/32 = Glauber-sea, +-41/42 = Pomeron (diff),
39823* +-51/52 = unitarity-sea, +-61/62 = gluons )
39824 DIMENSION ISP1P(8,3),ISP1T(8,3),ISP2P(8,3),ISP2T(8,3)
39825 DATA ISP1P / 21, 21, 21, 21, 21, 21, 21, 21,
39826 & 31, 31, 31, 31, 31, 31, 31, 31,
39827 & 41, 41, 41, 41, 51, 51, 51, 51/
39828 DATA ISP1T / 22, 22, 22, 22, 22, 22, 22, 22,
39829 & 32, 32, 32, 32, 32, 32, 32, 32,
39830 & 42, 42, 42, 42, 52, 52, 52, 52/
39831 DATA ISP2P / 31, 21, 31, 31, 21, 21, 21, 21,
39832 & 51, 31, 41, 41, 31, 31, 31, 31,
39833 & 0, 41, 51, 51, 51, 51, 51, 51/
39834 DATA ISP2T / 22, 32, 32, 32, 22, 22, 22, 22,
39835 & 32, 52, 42, 42, 32, 32, 32, 32,
39836 & 42, 0, 52, 52, 52, 52, 52, 52/
39837
39838 IF (NCHAIN.LE.0) RETURN
39839 DO 1 I=1,NCHAIN
39840 IDX1 = IDXCHN(1,I)
39841 IS1P = ABS(ISTHKK(JMOHKK(1,IDX1)))
39842 IS1T = ABS(ISTHKK(JMOHKK(2,IDX1)))
39843 IF ( (IDXCHN(2,I).EQ.IDCHN1(MODE))
39844 & .AND.
39845 & ((IS1P.EQ.ISP1P(MODE,1)).OR.(IS1P.EQ.ISP1P(MODE,2)).OR.
39846 & (IS1P.EQ.ISP1P(MODE,3)))
39847 & .AND.
39848 & ((IS1T.EQ.ISP1T(MODE,1)).OR.(IS1T.EQ.ISP1T(MODE,2)).OR.
39849 & (IS1T.EQ.ISP1T(MODE,3)))
39850 & ) THEN
39851 DO 2 J=1,NCHAIN
39852 IDX2 = IDXCHN(1,J)
39853 IS2P = ABS(ISTHKK(JMOHKK(1,IDX2)))
39854 IS2T = ABS(ISTHKK(JMOHKK(2,IDX2)))
39855 IF ( (IDXCHN(2,J).EQ.IDCHN2(MODE))
39856 & .AND.
39857 & ((IS2P.EQ.ISP2P(MODE,1)).OR.(IS2P.EQ.ISP2P(MODE,2))
39858 & .OR.(IS2P.EQ.ISP2P(MODE,3)))
39859 & .AND.
39860 & ((IS2T.EQ.ISP2T(MODE,1)).OR.(IS2T.EQ.ISP2T(MODE,2))
39861 & .OR.(IS2T.EQ.ISP2T(MODE,3)))
39862 & ) THEN
39863* find mother nucleons of the diquark to be splitted and of the
39864* sea-quark and reject this combination if it is not the same
39865 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.
39866 & (MODE.EQ.5).OR.(MODE.EQ.7)) THEN
39867 IANCES = 1
39868 ELSE
39869 IANCES = 2
39870 ENDIF
39871 IDXMO1 = JMOHKK(IANCES,IDX1)
39872 4 CONTINUE
39873 IF ((JMOHKK(1,IDXMO1).NE.0).AND.
39874 & (JMOHKK(2,IDXMO1).NE.0)) THEN
39875 IANC = IANCES
39876 ELSE
39877 IANC = 1
39878 ENDIF
39879 IF (JMOHKK(IANC,IDXMO1).NE.0) THEN
39880 IDXMO1 = JMOHKK(IANC,IDXMO1)
39881 GOTO 4
39882 ENDIF
39883 IDXMO2 = JMOHKK(IANCES,IDX2)
39884 5 CONTINUE
39885 IF ((JMOHKK(1,IDXMO2).NE.0).AND.
39886 & (JMOHKK(2,IDXMO2).NE.0)) THEN
39887 IANC = IANCES
39888 ELSE
39889 IANC = 1
39890 ENDIF
39891 IF (JMOHKK(IANC,IDXMO2).NE.0) THEN
39892 IDXMO2 = JMOHKK(IANC,IDXMO2)
39893 GOTO 5
39894 ENDIF
39895 IF (IDXMO1.NE.IDXMO2) GOTO 2
39896* quark content of projectile parton
39897 IP1 = IDHKK(JMOHKK(1,IDX1))
39898 IP11 = IP1/1000
39899 IP12 = (IP1-1000*IP11)/100
39900 IP2 = IDHKK(JMOHKK(2,IDX1))
39901 IP21 = IP2/1000
39902 IP22 = (IP2-1000*IP21)/100
39903* quark content of target parton
39904 IT1 = IDHKK(JMOHKK(1,IDX2))
39905 IT11 = IT1/1000
39906 IT12 = (IT1-1000*IT11)/100
39907 IT2 = IDHKK(JMOHKK(2,IDX2))
39908 IT21 = IT2/1000
39909 IT22 = (IT2-1000*IT21)/100
39910* split diquark and form new chains
39911 IF (MODE.EQ.1) THEN
39912 IF (IT1.EQ.4) GOTO 2
39913 CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39914 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39915 & IP11,IP12,IP2,IT1,IT21,IT22,1,IPQ,IGCOUN)
39916 ELSEIF (MODE.EQ.2) THEN
39917 IF (IT2.EQ.4) GOTO 2
39918 CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39919 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39920 & IP1,IP21,IP22,IT11,IT12,IT2,1,IPQ,IGCOUN)
39921 ELSEIF (MODE.EQ.3) THEN
39922 IF (IT1.EQ.4) GOTO 2
39923 CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39924 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39925 & IP11,IP12,IP2,IT1,IT2,1,IPQ,IGCOUN)
39926 ELSEIF (MODE.EQ.4) THEN
39927 IF (IT2.EQ.4) GOTO 2
39928 CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39929 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39930 & IP1,IP21,IP22,IT1,IT2,1,IPQ,IGCOUN)
39931 ELSEIF (MODE.EQ.5) THEN
39932 CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39933 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39934 & IP11,IP12,IP2,IT1,IT21,IT22,2,IPQ,IGCOUN)
39935 ELSEIF (MODE.EQ.6) THEN
39936 CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39937 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39938 & IP1,IP21,IP22,IT11,IT12,IT2,2,IPQ,IGCOUN)
39939 ELSEIF (MODE.EQ.7) THEN
39940 CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39941 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39942 & IP11,IP12,IP2,IT1,IT2,2,IPQ,IGCOUN)
39943 ELSEIF (MODE.EQ.8) THEN
39944 CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39945 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39946 & IP1,IP21,IP22,IT1,IT2,2,IPQ,IGCOUN)
39947 ENDIF
39948 IF (IREJ.GE.1) THEN
39949 if ((ipq.lt.0).or.(ipq.ge.4))
39950 & write(LOUT,*) 'ipq !!!',ipq,mode
39951 DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
39952* accept or reject new chains corresponding to PDBSEA
39953 ELSE
39954 IF ((IPQ.EQ.1).OR.(IPQ.EQ.2)) THEN
39955 ACC = DBRKA(1,MODE)+DBRKA(2,MODE)
39956 REJ = DBRKR(1,MODE)+DBRKR(2,MODE)
39957 ELSEIF (IPQ.EQ.3) THEN
39958 ACC = DBRKA(3,MODE)
39959 REJ = DBRKR(3,MODE)
39960 ELSE
39961 WRITE(LOUT,*) ' inconsistent IPQ ! ',IPQ
39962 STOP
39963 ENDIF
39964 IF (ACC/(ACC+REJ).LE.PDBSEA(IPQ)) THEN
39965 DBRKA(IPQ,MODE) = DBRKA(IPQ,MODE)+1.0D0
39966 IACC = 1
39967 ELSE
39968 DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
39969 IACC = 0
39970 ENDIF
39971* new chains have been accepted and are now copied into HKKEVT
39972 IF (IACC.EQ.1) THEN
39973 IF (LEMCCK) THEN
39974 CALL DT_EVTEMC(PHKK(1,IDX1),PHKK(2,IDX1),
39975 & PHKK(3,IDX1),PHKK(4,IDX1),
39976 & 1,IDUM1,IDUM2)
39977 CALL DT_EVTEMC(PHKK(1,IDX2),PHKK(2,IDX2),
39978 & PHKK(3,IDX2),PHKK(4,IDX2),
39979 & 2,IDUM1,IDUM2)
39980 ENDIF
39981 IDHKK(IDX1) = 99888
39982 IDHKK(IDX2) = 99888
39983 IDXCHN(2,I) = -1
39984 IDXCHN(2,J) = -1
39985 DO 3 K=1,IGCOUN
39986 NHKK = NHKK+1
39987 CALL HKKHKT(NHKK,K)
39988 IF ((LEMCCK).AND.(IDHKK(NHKK).EQ.88888))THEN
39989 PX = -PHKK(1,NHKK)
39990 PY = -PHKK(2,NHKK)
39991 PZ = -PHKK(3,NHKK)
39992 PE = -PHKK(4,NHKK)
39993 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
39994 ENDIF
39995 3 CONTINUE
39996 IF (LEMCCK) THEN
39997 CHKLEV = 0.1D0
39998 CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,9000,
39999 & IREJ)
40000 IF (IREJ.NE.0) CALL DT_EVTOUT(4)
40001 ENDIF
40002 GOTO 1
40003 ENDIF
40004 ENDIF
40005 ENDIF
40006 2 CONTINUE
40007 ENDIF
40008 1 CONTINUE
40009 RETURN
40010 END
40011
40012*$ CREATE DT_CQPAIR.FOR
40013*COPY DT_CQPAIR
40014*
40015*===cqpair=============================================================*
40016*
40017 SUBROUTINE DT_CQPAIR(XQMAX,XAQMAX,XQ,XAQ,IFLV,IREJ)
40018
40019************************************************************************
40020* This subroutine Creates a Quark-antiquark PAIR from the sea. *
40021* *
40022* XQMAX maxium energy fraction of quark (input) *
40023* XAQMAX maxium energy fraction of antiquark (input) *
40024* XQ energy fraction of quark (output) *
40025* XAQ energy fraction of antiquark (output) *
40026* IFLV quark flavour (- antiquark flavor) (output) *
40027* *
40028* This version dated 14.5.00 is written by S. Roesler. *
40029************************************************************************
40030
40031 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
40032 SAVE
40033 PARAMETER ( LINP = 10 ,
40034 & LOUT = 6 ,
40035 & LDAT = 9 )
40036
40037* Lorentz-parameters of the current interaction
40038 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
40039 & UMO,PPCM,EPROJ,PPROJ
40040
40041*
40042 IREJ = 0
40043 XQ = 0.0D0
40044 XAQ = 0.0D0
40045*
40046* sample quark flavour
40047*
40048* set seasq here (the one from DTCHAI should be used in the future)
40049 SEASQ = 0.5D0
40050 IFLV = INT(1.0D0+DT_RNDM(XQMAX)*(2.0D0+SEASQ))
40051*
40052* sample energy fractions of sea pair
40053* we first sample the energy fraction of a gluon and then split the gluon
40054*
40055* maximum energy fraction of the gluon forced via input
40056 XGMAXI = XQMAX+XAQMAX
40057* minimum energy fraction of the gluon
40058 XTHR1 = 4.0D0 /UMO**2
40059 XTHR2 = 0.54D0/UMO**1.5D0
40060 XGMIN = MAX(XTHR1,XTHR2)
40061* maximum energy fraction of the gluon
40062 XGMAX = 0.3D0
40063 XGMAX = MIN(XGMAXI,XGMAX)
40064 IF (XGMIN.GE.XGMAX) THEN
40065 IREJ = 1
40066 RETURN
40067 ENDIF
40068*
40069* sample energy fraction of the gluon
40070 NLOOP = 0
40071 1 CONTINUE
40072 NLOOP = NLOOP+1
40073 IF (NLOOP.GE.50) THEN
40074 IREJ = 1
40075 RETURN
40076 ENDIF
40077 XGLUON = DT_SAMSQX(XGMIN,XGMAX)
40078 EGLUON = XGLUON*UMO/2.0D0
40079*
40080* split gluon into q-aq pair (we follow PHOJET's subroutine PHO_GLU2QU)
40081 ZMIN = MIN(0.1D0,0.5D0/EGLUON)
40082 ZMAX = 1.0D0-ZMIN
40083 RZ = DT_RNDM(ZMAX)
40084 XHLP = ((1.0D0-RZ)*ZMIN**3+RZ*ZMAX**3)**0.33333
40085 RQ = DT_RNDM(ZMAX)
40086 IF (RQ.LT.0.5D0) THEN
40087 XQ = XGLUON*XHLP
40088 XAQ = XGLUON-XQ
40089 ELSE
40090 XAQ = XGLUON*XHLP
40091 XQ = XGLUON-XAQ
40092 ENDIF
40093 IF ((XQ.GT.XQMAX).OR.(XAQ.GT.XAQMAX)) GOTO 1
40094
40095 RETURN
40096 END