4 * +-------------------------------------------------------------+
10 * | S. Roesler+), R. Engel#), J. Ranft*) |
13 * | CH-1211 Geneva 23, Switzerland |
14 * | Email: Stefan.Roesler@cern.ch |
16 * | #) Institut fuer Kernphysik |
17 * | Forschungszentrum Karlsruhe |
18 * | D-76021 Karlsruhe, Germany |
20 * | *) University of Siegen, Dept. of Physics |
21 * | D-57068 Siegen, Germany |
24 * | http://home.cern.ch/sroesler/dpmjet3.html |
27 * | Monte Carlo models used for event generation: |
28 * | PHOJET 1.12, JETSET 7.4 and LEPTO 6.5.1 |
30 * +-------------------------------------------------------------+
33 *===init===============================================================*
35 SUBROUTINE DT_INIT(NCASES,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
38 ************************************************************************
39 * Initialization of event generation *
40 * This version dated 7.4.98 is written by S. Roesler. *
42 * Last change 27.12.2006 by S. Roesler. *
43 ************************************************************************
45 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
48 PARAMETER ( LINP = 10 ,
51 PARAMETER (ZERO=0.0D0,ONE=1.0D0)
53 * particle properties (BAMJET index convention)
55 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
56 & IICH(210),IIBAR(210),K1(210),K2(210)
58 * names of hadrons used in input-cards
60 COMMON /DTPAIN/ BTYPE(30)
63 * DIMPAR taken from FLUKA
64 PARAMETER ( MXXRGN =20000 )
65 PARAMETER ( MXXMDF = 710 )
66 PARAMETER ( MXXMDE = 702 )
67 PARAMETER ( MFSTCK =40000 )
68 PARAMETER ( MESTCK = 100 )
69 PARAMETER ( MOSTCK = 2000 )
70 PARAMETER ( MXPRSN = 100 )
71 PARAMETER ( MXPDPM = 800 )
72 PARAMETER ( MXPSCS =30000 )
73 PARAMETER ( MXGLWN = 300 )
74 PARAMETER ( MXOUTU = 50 )
75 PARAMETER ( NALLWP = 64 )
76 PARAMETER ( NELEMX = 80 )
77 PARAMETER ( MPDPDX = 18 )
78 PARAMETER ( MXHTTR = 260 )
79 PARAMETER ( MXSEAX = 20 )
80 PARAMETER ( MXHTNC = MXSEAX + 1 )
81 PARAMETER ( ICOMAX = 2400 )
82 PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
83 PARAMETER ( NSTBIS = 304 )
84 PARAMETER ( NQSTIS = 46 )
85 PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
86 PARAMETER ( MXPABL = 120 )
87 PARAMETER ( IDMAXP = 450 )
88 PARAMETER ( IDMXDC = 2000 )
89 PARAMETER ( MXMCIN = 410 )
90 PARAMETER ( IHYPMX = 4 )
91 PARAMETER ( MKBMX1 = 11 )
92 PARAMETER ( MKBMX2 = 11 )
93 PARAMETER ( MXIRRD = 2500 )
94 PARAMETER ( MXTRDC = 1500 )
95 PARAMETER ( NKTL = 17 )
96 PARAMETER ( NBLNMX = 40000000 )
99 * PAREVT taken from FLUKA
100 PARAMETER ( FRDIFF = 0.2D+00 )
101 PARAMETER ( ETHSEA = 1.0D+00 )
103 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
104 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
105 & LNUCRI, LPEANU, LEVBME, LPHDRC, LATMSS, LISMRS, LCHDCY,
106 & LCHDCR, LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
107 COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
108 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
109 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
110 & LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LEVBME,
111 & LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR,
112 & LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
115 * EVAFLG taken from FLUKA
116 LOGICAL LOLDEV, LUFULL, LNWLOW, LASMEN, LGMCMP, LGDRFT, LDSCLV,
117 & LDSCGM, LNDSLD, LMNJPR, LBRPEN, LNWBRP, LIFKEY, LOLDSM,
118 & LNAIPR, LGUSPR, LFLKCO, LLVMOD, LHVEVP, LHVECN, LHVCAL,
119 & LHVRAL, LHVSGF, LTMCRR, LBZZCR, LQCSKP, LEEXLV, LGEXLV
120 COMMON / EVAFLG / BRPNFR (0:2), EBRPFR (0:2), EMVBRP (0:2),
122 & ILVMOD, JLVMOD, JSIPFL, IMSSFR, JMSSFR, IEVFSS, MXAHEV,
123 & MXZHEV, IFHVFL, IFKYMX, IGMCMP, MPMODE, MSMODE, MUMODE,
124 & MFMODE, MEMODE, MRMODE, ITMCRR, IASYCR, IFSBCR, IFSSBR,
125 & LOLDEV, LUFULL, LNWLOW, LASMEN, LGMCMP, LGDRFT, LDSCLV,
126 & LDSCGM, LNDSLD, LMNJPR, LBRPEN, LNWBRP, LIFKEY, LOLDSM,
127 & LNAIPR, LGUSPR, LFLKCO, LLVMOD, LHVEVP, LHVECN, LHVCAL,
128 & LHVRAL, LHVSGF, LTMCRR, LBZZCR, LQCSKP, LEEXLV, LGEXLV
131 * FRBKCM taken from FLUKA
132 * Maximum number of fragments to be emitted:
133 PARAMETER ( MXFFBK = 6 )
134 PARAMETER ( MXZFBK = 10 )
135 PARAMETER ( MXNFBK = 12 )
136 PARAMETER ( MXAFBK = 16 )
137 PARAMETER ( MXASST = 25 )
138 PARAMETER ( NXAFBK = MXAFBK + 1 )
139 PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 + MXASST - NXAFBK )
140 PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 + MXASST - NXAFBK )
141 PARAMETER ( MXPSST = 700 )
142 * Maximum number of pre-computed break-up combinations
143 PARAMETER ( MXPPFB = 42500 )
144 * Maximum number of break-up combinations, including special
146 PARAMETER ( MXPSFB = 43000 )
147 * Base for J multiplicity encoding:
148 PARAMETER ( IBFRBK = 73 )
149 * Maximum Ibfrbk exponent to avoid overflow of I*4(roughly at 2.1x10^9)
150 * it must be (Ibfrbk-1) + (Ibfrbk-1)*Ibfrbk + (Ibfrbk-1)*Ibfrbk^2 + ...
151 * ... + (Ibfrbk-1)*Ibfrbk^Jpwfbx < 2100000000,
152 * --> Ibfrbk^(Jpwfbx+1) < 2100000000
153 PARAMETER ( JPWFBX = 4 )
154 LOGICAL LFRMBK, LNCMSS
155 COMMON / FRBKCM / AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
156 & WEIFBK (MXPSST), GAMFBK (MXPSST), EXFRBK (MXPSFB),
157 & SDMFBK (MXPSFB), COUFBK (MXPSFB), CENFBK (MXPSFB),
158 & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK, FRBKLS,
159 & IFRBKN (MXPSST), IFRBKZ (MXPSST),
160 & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
161 & IPSIND (0:NXNFBK,0:NXZFBK,2), JPSIND (0:MXASST),
162 & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
163 & IFBCHA (9,MXPSFB), IPOSST, IPOSFB, IFBSTF, IFBPSF,
164 & IFBFRB, IFBCHN, IFBNC1, IFBNC2, NBUFBK, LFRMBK, LNCMSS
165 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
168 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
171 * Glauber formalism: parameters
172 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
173 & BMAX(NCOMPX),BSTEP(NCOMPX),
174 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
177 * Glauber formalism: cross sections
178 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
179 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
180 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
181 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
182 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
183 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
184 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
185 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
186 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
187 & BSLOPE,NEBINI,NQBINI
189 * interface HADRIN-DPM
190 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
192 * central particle production, impact parameter biasing
193 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
195 * parameter for intranuclear cascade
197 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
199 * various options for treatment of partons (DTUNUC 1.x)
200 * (chain recombination, Cronin,..)
201 LOGICAL LCO2CR,LINTPT
202 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
205 * threshold values for x-sampling (DTUNUC 1.x)
206 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
209 * flags for input different options
210 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
211 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
212 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
216 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
217 & EBINDP(2),EBINDN(2),EPOT(2,210),
218 & ETACOU(2),ICOUL,LFERMI
220 * n-n cross section fluctuations
221 PARAMETER (NBINS = 1000)
222 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
224 * flags for particle decays
225 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
226 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
227 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
229 * diquark-breaking mechanism
230 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
232 * nucleon-nucleon event-generator
235 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
237 * properties of interacting particles
238 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
240 * properties of photon/lepton projectiles
241 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
243 * flags for diffractive interactions (DTUNUC 1.x)
244 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
246 * parameters for hA-diffraction
247 COMMON /DTDIHA/ DIBETA,DIALPH
249 * Lorentz-parameters of the current interaction
250 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
251 & UMO,PPCM,EPROJ,PPROJ
253 * kinematical cuts for lepton-nucleus interactions
254 COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
255 & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
257 * VDM parameter for photon-nucleus interactions
258 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
260 * Glauber formalism: flags and parameters for statistics
263 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
265 * cuts for variable energy runs
266 COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
268 * flags for activated histograms
269 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
271 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
272 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
275 **LUND single / double precision
276 REAL CUT,PARL,TMPX,TMPY,TMPW2,TMPQ2,TMPU
277 COMMON /LEPTOU/ CUT(14),LST(40),PARL(30),
278 & TMPX,TMPY,TMPW2,TMPQ2,TMPU
282 COMMON /LEPTOI/ RPPN,LEPIN,INTER
284 * steering flags for qel neutrino scattering modules
285 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
288 COMMON /DTEVNO/ NEVENT,ICASCA
293 DIMENSION XDUMB(40),IPRANG(5)
295 PARAMETER (MXCARD=58)
296 CHARACTER*78 CLINE,CTITLE
298 CHARACTER*8 BLANK,SDUM
299 CHARACTER*10 CODE,CODEWD
301 LOGICAL LSTART,LEINP,LXSTAB
302 DIMENSION WHAT(6),CODE(MXCARD)
304 & 'TITLE ','PROJPAR ','TARPAR ','ENERGY ',
305 & 'MOMENTUM ','CMENERGY ','EMULSION ','FERMI ',
306 & 'TAUFOR ','PAULI ','COULOMB ','HADRIN ',
307 & 'EVAP ','EMCCHECK ','MODEL ','PHOINPUT ',
308 & 'GLAUBERI ','FLUCTUAT ','CENTRAL ','RECOMBIN ',
309 & 'COMBIJET ','XCUTS ','INTPT ','CRONINPT ',
310 & 'SEADISTR ','SEASU3 ','DIQUARKS ','RESONANC ',
311 & 'DIFFRACT ','SINGLECH ','NOFRAGME ','HADRONIZE ',
312 & 'POPCORN ','PARDECAY ','BEAM ','LUND-MSTU ',
313 & 'LUND-MSTJ ','LUND-MDCY ','LUND-PARJ ','LUND-PARU ',
314 & 'OUTLEVEL ','FRAME ','L-TAG ','L-ETAG ',
315 & 'ECMS-CUT ','VDM-PAR1 ','HISTOGRAM ','XS-TABLE ',
316 & 'GLAUB-PAR ','GLAUB-INI ','VDM-PAR2 ','XS-QELPRO ',
317 & 'RNDMINIT ','LEPTO-CUT ','LEPTO-LST ','LEPTO-PARL',
321 DATA LSTART,LXSTAB,IFIRST /.TRUE.,.FALSE.,1/
324 *---------------------------------------------------------------------
325 * at the first call of INIT: initialize event generation
329 * initialization and test of the random number generator
330 IF (ITRSPT.NE.1) THEN
336 CALL RNINIT (INSEED,IJKLIN,ISEED1,ISEED2)
339 * initialization of BAMJET, DECAY and HADRIN
344 * set default values for input variables
345 CALL DT_DEFAUL(EPN,PPN)
348 * flag for collision energy input
353 *---------------------------------------------------------------------
356 * bypass reading input cards (e.g. for use with Fluka)
357 * in this case Epn is expected to carry the beam momentum
358 IF (NCASES.EQ.-1) THEN
372 * read control card from input-unit LINP
373 READ(LINP,'(A78)',END=9999) CLINE
374 IF (CLINE(1:1).EQ.'*') THEN
376 WRITE(LOUT,'(A78)') CLINE
379 C READ(CLINE,1000,END=9999) CODEWD,(WHAT(I),I=1,6),SDUM
380 C1000 FORMAT(A10,6E10.0,A8)
384 READ(CLINE,1006,END=9999) CODEWD,CWHAT,SDUM
385 1006 FORMAT(A10,A60,A8)
386 READ(CWHAT,*,END=1007) (WHAT(I),I=1,6)
388 WRITE(LOUT,1001) CODEWD,(WHAT(I),I=1,6),SDUM
389 1001 FORMAT(A10,6G10.3,A8)
393 * check for valid control card and get card index
396 IF (CODEWD.EQ.CODE(I)) ICW = I
399 WRITE(LOUT,1002) CODEWD
400 1002 FORMAT(/,1X,'---> ',A10,': invalid control-card !',/)
405 *------------------------------------------------------------
406 * TITLE , PROJPAR , TARPAR , ENERGY , MOMENTUM,
407 & 100 , 110 , 120 , 130 , 140 ,
409 *------------------------------------------------------------
410 * CMENERGY, EMULSION, FERMI , TAUFOR , PAULI ,
411 & 150 , 160 , 170 , 180 , 190 ,
413 *------------------------------------------------------------
414 * COULOMB , HADRIN , EVAP , EMCCHECK, MODEL ,
415 & 200 , 210 , 220 , 230 , 240 ,
417 *------------------------------------------------------------
418 * PHOINPUT, GLAUBERI, FLUCTUAT, CENTRAL , RECOMBIN,
419 & 250 , 260 , 270 , 280 , 290 ,
421 *------------------------------------------------------------
422 * COMBIJET, XCUTS , INTPT , CRONINPT, SEADISTR,
423 & 300 , 310 , 320 , 330 , 340 ,
425 *------------------------------------------------------------
426 * SEASU3 , DIQUARKS, RESONANC, DIFFRACT, SINGLECH,
427 & 350 , 360 , 370 , 380 , 390 ,
429 *------------------------------------------------------------
430 * NOFRAGME, HADRONIZE, POPCORN , PARDECAY, BEAM ,
431 & 400 , 410 , 420 , 430 , 440 ,
433 *------------------------------------------------------------
434 * LUND-MSTU, LUND-MSTJ, LUND-MDCY, LUND-PARJ, LUND-PARU,
435 & 450 , 451 , 452 , 460 , 470 ,
437 *------------------------------------------------------------
438 * OUTLEVEL, FRAME , L-TAG , L-ETAG , ECMS-CUT,
439 & 480 , 490 , 500 , 510 , 520 ,
441 *------------------------------------------------------------
442 * VDM-PAR1, HISTOGRAM, XS-TABLE , GLAUB-PAR, GLAUB-INI,
443 & 530 , 540 , 550 , 560 , 565 ,
445 *------------------------------------------------------------
446 * , , VDM-PAR2, XS-QELPRO, RNDMINIT ,
449 *------------------------------------------------------------
450 * LEPTO-CUT, LEPTO-LST,LEPTO-PARL, START , STOP )
451 & 600 , 610 , 620 , 630 , 640 ) , ICW
453 *------------------------------------------------------------
457 *********************************************************************
459 * control card: codewd = TITLE *
461 * what (1..6), sdum no meaning *
463 * Note: The control-card following this must consist of *
464 * a string of characters usually giving the title of *
467 *********************************************************************
470 READ(LINP,'(A78)') CTITLE
471 WRITE(LOUT,'(//,5X,A78,//)') CTITLE
474 *********************************************************************
476 * control card: codewd = PROJPAR *
478 * what (1) = mass number of projectile nucleus default: 1 *
479 * what (2) = charge of projectile nucleus default: 1 *
480 * what (3..6) no meaning *
481 * sdum projectile particle code word *
483 * Note: If sdum is defined what (1..2) have no meaning. *
485 *********************************************************************
488 IF (SDUM.EQ.BLANK) THEN
496 IF (SDUM.EQ.BTYPE(II)) THEN
501 ELSEIF (II.EQ.27) THEN
503 ELSEIF (II.EQ.28) THEN
505 ELSEIF (II.EQ.29) THEN
510 IBPROJ = IIBAR(IJPROJ)
512 IF ((IJPROJ.EQ.7).AND.(WHAT(1).GT.ZERO)) VIRT = WHAT(1)
514 IF (((IJPROJ.EQ. 3).OR.(IJPROJ.EQ. 4).OR.
515 & (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11)).AND.
516 & (WHAT(1).GT.ZERO)) Q2HI = WHAT(1)
519 IF (IJPROJ.EQ.0) THEN
521 1110 FORMAT(/,1X,'invalid PROJPAR card !',/)
527 *********************************************************************
529 * control card: codewd = TARPAR *
531 * what (1) = mass number of target nucleus default: 1 *
532 * what (2) = charge of target nucleus default: 1 *
533 * what (3..6) no meaning *
534 * sdum target particle code word *
536 * Note: If sdum is defined what (1..2) have no meaning. *
538 *********************************************************************
541 IF (SDUM.EQ.BLANK) THEN
549 IF (SDUM.EQ.BTYPE(II)) THEN
553 IBTARG = IIBAR(IJTARG)
556 IF (IJTARG.EQ.0) THEN
558 1120 FORMAT(/,1X,'invalid TARPAR card !',/)
564 *********************************************************************
566 * control card: codewd = ENERGY *
568 * what (1) = energy (GeV) of projectile in Lab. *
569 * if what(1) < 0: |what(1)| = kinetic energy *
571 * if |what(2)| > 0: min. energy for variable *
573 * what (2) = max. energy for variable energy runs *
574 * if what(2) < 0: |what(2)| = kinetic energy *
576 *********************************************************************
582 IF ((ABS(WHAT(2)).GT.ZERO).AND.
583 & (ABS(WHAT(2)).GT.ABS(WHAT(1)))) THEN
591 *********************************************************************
593 * control card: codewd = MOMENTUM *
595 * what (1) = momentum (GeV/c) of projectile in Lab. *
596 * default: 200 GeV/c *
597 * what (2..6), sdum no meaning *
599 *********************************************************************
608 *********************************************************************
610 * control card: codewd = CMENERGY *
612 * what (1) = energy in nucleon-nucleon cms. *
614 * what (2..6), sdum no meaning *
616 *********************************************************************
625 *********************************************************************
627 * control card: codewd = EMULSION *
629 * definition of nuclear emulsions *
631 * what(1) mass number of emulsion component *
632 * what(2) charge of emulsion component *
633 * what(3) fraction of events in which a scattering on a *
634 * nucleus of this properties is performed *
635 * what(4,5,6) as what(1,2,3) but for another component *
636 * default: no emulsion *
639 * Note: If this input-card is once used with valid parameters *
640 * TARPAR is obsolete. *
641 * Not the absolute values of the fractions are important *
642 * but only the ratios of fractions of different comp. *
643 * This control card can be repeatedly used to define *
644 * emulsions consisting of up to 10 elements. *
646 *********************************************************************
649 IF ((WHAT(1).GT.ZERO).AND.(WHAT(2).GT.ZERO)
650 & .AND.(ABS(WHAT(3)).GT.ZERO)) THEN
652 IF (NCOMPO.GT.NCOMPX) THEN
656 IEMUMA(NCOMPO) = INT(WHAT(1))
657 IEMUCH(NCOMPO) = INT(WHAT(2))
658 EMUFRA(NCOMPO) = WHAT(3)
660 C CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO))
662 IF ((WHAT(4).GT.ZERO).AND.(WHAT(5).GT.ZERO)
663 & .AND.(ABS(WHAT(6)).GT.ZERO)) THEN
665 IF (NCOMPO.GT.NCOMPX) THEN
669 IEMUMA(NCOMPO) = INT(WHAT(4))
670 IEMUCH(NCOMPO) = INT(WHAT(5))
671 EMUFRA(NCOMPO) = WHAT(6)
672 C CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO))
674 1600 FORMAT(1X,'too many emulsion components - program stopped')
677 *********************************************************************
679 * control card: codewd = FERMI *
681 * what (1) = -1 Fermi-motion of nucleons not treated *
683 * what (2) = scale factor for Fermi-momentum *
685 * what (3..6), sdum no meaning *
687 *********************************************************************
690 IF (WHAT(1).EQ.-1.0D0) THEN
696 IF (XMOD.GE.ZERO) FERMOD = XMOD
699 *********************************************************************
701 * control card: codewd = TAUFOR *
703 * formation time supressed intranuclear cascade *
705 * what (1) formation time (in fm/c) *
706 * note: what(1)=10. corresponds roughly to an *
707 * average formation time of 1 fm/c *
709 * what (2) number of generations followed *
711 * what (3) = 1. p_t-dependent formation zone *
712 * = 2. constant formation zone *
714 * what (4) modus of selection of nucleus where the *
715 * cascade if followed first *
716 * = 1. proj./target-nucleus with probab. 1/2 *
717 * = 2. nucleus with highest mass *
718 * = 3. proj. nucleus if particle is moving in pos. z *
719 * targ. nucleus if particle is moving in neg. z *
721 * what (5..6), sdum no meaning *
723 *********************************************************************
727 KTAUGE = INT(WHAT(2))
729 IF ((WHAT(3).GE.1.0D0).AND.(WHAT(3).LE.2.0D0))
730 & ITAUVE = INT(WHAT(3))
731 IF ((WHAT(4).GE.1.0D0).AND.(WHAT(4).LE.3.0D0))
732 & INCMOD = INT(WHAT(4))
735 *********************************************************************
737 * control card: codewd = PAULI *
739 * what (1) = -1 Pauli's principle for secondary *
740 * interactions not treated *
742 * what (2..6), sdum no meaning *
744 *********************************************************************
747 IF (WHAT(1).EQ.-1.0D0) THEN
754 *********************************************************************
756 * control card: codewd = COULOMB *
758 * what (1) = -1. Coulomb-energy treatment switched off *
760 * what (2..6), sdum no meaning *
762 *********************************************************************
766 IF (WHAT(1).EQ.-1.0D0) THEN
773 *********************************************************************
775 * control card: codewd = HADRIN *
779 * what (1) = 0. elastic/inelastic interactions with probab. *
780 * as defined by cross-sections *
781 * = 1. inelastic interactions forced *
782 * = 2. elastic interactions forced *
784 * what (2) upper threshold in total energy (GeV) below *
785 * which interactions are sampled by HADRIN *
787 * what (3..6), sdum no meaning *
789 *********************************************************************
793 IF ((IWHAT.GE.0).AND.(IWHAT.LE.2)) INTHAD = IWHAT
794 IF ((WHAT(2).GT.ZERO).AND.(WHAT(2).LT.15.0D0)) EHADTH = WHAT(2)
797 *********************************************************************
799 * control card: codewd = EVAP *
801 * evaporation module *
803 * what (1) =< -1 ==> evaporation is switched off *
804 * >= 1 ==> evaporation is performed *
806 * what (1) = i1 + i2*10 + i3*100 + i4*10000 *
807 * (i1, i2, i3, i4 >= 0 ) *
809 * i1 is the flag for selecting the T=0 level density option used *
810 * = 1: standard EVAP level densities with Cook pairing *
812 * = 2: Z,N-dependent Gilbert & Cameron level densities *
814 * = 3: Julich A-dependent level densities *
815 * = 4: Z,N-dependent Brancazio & Cameron level densities *
817 * i2 >= 1: high energy fission activated *
818 * (default high energy fission activated) *
820 * i3 = 0: No energy dependence for level densities *
821 * = 1: Standard Ignyatuk (1975, 1st) energy dependence *
822 * for level densities (default) *
823 * = 2: Standard Ignyatuk (1975, 1st) energy dependence *
824 * for level densities with NOT used set of parameters *
825 * = 3: Standard Ignyatuk (1975, 1st) energy dependence *
826 * for level densities with NOT used set of parameters *
827 * = 4: Second Ignyatuk (1975, 2nd) energy dependence *
828 * for level densities *
829 * = 5: Second Ignyatuk (1975, 2nd) energy dependence *
830 * for level densities with fit 1 Iljinov & Mebel set of *
832 * = 6: Second Ignyatuk (1975, 2nd) energy dependence *
833 * for level densities with fit 2 Iljinov & Mebel set of *
835 * = 7: Second Ignyatuk (1975, 2nd) energy dependence *
836 * for level densities with fit 3 Iljinov & Mebel set of *
838 * = 8: Second Ignyatuk (1975, 2nd) energy dependence *
839 * for level densities with fit 4 Iljinov & Mebel set of *
842 * i4 >= 1: Original Gilbert and Cameron pairing energies used *
843 * (default Cook's modified pairing energies) *
845 * what (2) = ig + 10 * if (ig and if must have the same sign) *
847 * ig =< -1 ==> deexcitation gammas are not produced *
848 * (if the evaporation step is not performed *
849 * they are never produced) *
850 * if =< -1 ==> Fermi Break Up is not invoked *
851 * (if the evaporation step is not performed *
852 * it is never invoked) *
853 * The default is: deexcitation gamma produced and Fermi break up *
854 * activated for the new preequilibrium, not *
855 * activated otherwise. *
856 * what (3..6), sdum no meaning *
858 *********************************************************************
861 IF (WHAT(1).LE.-1.0D0) THEN
868 IF ( NINT (WHAT (1)) .GE. 10000 ) THEN
870 JLVHLP = NINT (WHAT (1)) / 10000
871 WHAT (1) = WHAT (1) - 10000.D+00 * JLVHLP
873 IF ( NINT (WHAT (1)) .GE. 100 ) THEN
874 JLVMOD = NINT (WHAT (1)) / 100
875 WHAT (1) = WHAT (1) - 100.D+00 * JLVMOD
877 IF ( NINT (WHAT (1)) .GE. 10 ) THEN
881 JLVHLP = NINT (WHAT (1)) / 10
882 WHAT (1) = WHAT (1) - 10.D+00 * JLVHLP
883 ELSE IF ( NINT (WHTSAV) .NE. 0 ) THEN
888 IF ( NINT (WHAT (1)) .GE. 0 ) THEN
890 ILVMOD = NINT (WHAT(1))
891 IF ( ABS (NINT (WHAT (2))) .GE. 10 ) THEN
893 JLVHLP = NINT (WHAT (2)) / 10
894 WHAT (2) = WHAT (2) - 10.D+00 * JLVHLP
895 ELSE IF ( NINT (WHAT (2)) .NE. 0 ) THEN
898 IF ( NINT (WHAT (2)) .GE. 0 ) THEN
903 **sr heavies are always put to /FKFHVY/
904 C IF ( NINT (WHAT(3)) .GE. 1 ) THEN
920 *********************************************************************
922 * control card: codewd = EMCCHECK *
924 * extended energy-momentum / quantum-number conservation check *
926 * what (1) = -1 extended check not performed *
928 * what (2..6), sdum no meaning *
930 *********************************************************************
933 IF (WHAT(1).EQ.-1) THEN
940 *********************************************************************
942 * control card: codewd = MODEL *
944 * Model to be used to treat nucleon-nucleon interactions *
946 * sdum = DTUNUC two-chain model *
947 * = PHOJET multiple chains including minijets *
949 * = QNEUTRIN quasi-elastic neutrino scattering *
953 * what (1) (variable INTER) *
954 * = 1 gamma exchange *
957 * = 4 gamma/Z0 exchange *
959 * if sdum = QNEUTRIN: *
960 * what (1) = 0 elastic scattering on nucleon and *
961 * tau does not decay (default) *
962 * = 1 decay of tau into mu.. *
963 * = 2 decay of tau into e.. *
964 * = 10 CC events on p and n *
965 * = 11 NC events on p and n *
967 * what (2..6) no meaning *
969 *********************************************************************
972 IF (SDUM.EQ.CMODEL(1)) THEN
974 ELSEIF (SDUM.EQ.CMODEL(2)) THEN
976 ELSEIF (SDUM.EQ.CMODEL(3)) THEN
978 IF ((WHAT(1).GE.1.0D0).AND.(WHAT(1).LE.4.0D0))
979 & INTER = INT(WHAT(1))
980 ELSEIF (SDUM.EQ.CMODEL(4)) THEN
983 IF ((IWHAT.EQ.1 ).OR.(IWHAT.EQ.2 ).OR.
984 & (IWHAT.EQ.10).OR.(IWHAT.EQ.11))
987 STOP ' Unknown model !'
991 *********************************************************************
993 * control card: codewd = PHOINPUT *
995 * Start of input-section for PHOJET-specific input-cards *
996 * Note: This section will not be finished before giving *
998 * what (1..6), sdum no meaning *
1000 *********************************************************************
1005 CALL PHO_INIT(LINP,LOUT,IREJ1)
1007 IF (IREJ1.NE.0) THEN
1008 WRITE(LOUT,'(1X,A)')'INIT: reading PHOJET-input failed'
1015 *********************************************************************
1017 * control card: codewd = GLAUBERI *
1019 * Pre-initialization of impact parameter selection *
1021 * what (1..6), sdum no meaning *
1023 *********************************************************************
1026 IF (IFIRST.NE.99) THEN
1027 CALL DT_RNDMST(12,34,56,78)
1029 OPEN(40,FILE='outdata0/shm.out',STATUS='UNKNOWN')
1030 C OPEN(11,FILE='outdata0/shm.dbg',STATUS='UNKNOWN')
1041 ADP = (APHI-APLOW)/DBLE(IPPN)
1062 IT = ITLOW+(NCIT-1)*IDIT
1065 C IIP = (IPHI-IPLOW)/IDIP
1066 C IF (IIP.EQ.0) IIP = 1
1067 C IF (IT.EQ.IPLOW) IIP = 0
1071 CC IF (NCIP.LE.IIP) THEN
1072 C IP = IPLOW+(NCIP-1)*IDIP
1076 IF (IP.GT.IT) GOTO 472
1079 APPN = APLOW+DBLE(NCP-1)*ADP
1082 OPEN(12,FILE='outdata0/shm.sta',STATUS='UNKNOWN')
1083 WRITE(12,'(1X,2I5,E15.3)') IP,IT,PPN
1090 CALL DT_NEWHGR(XDUM,XDUM,XDUM,XDUMB,-1,IHDUM)
1091 CALL DT_NEWHGR(XLIM1,XLIM2,XLIM3,XDUMB,IBIN,IHSHMA)
1094 C IF ((IP.GT.10).OR.(IT.GT.10)) THEN
1102 CALL DT_SHMAKI(IP,IDUM1,IT,IDUM1,IJPROJ,PPN,99)
1103 SIGAV = SIGAV+XSPRO(1,1,1)
1106 CALL DT_FILHGR(XC,BSITE(1,1,1,J),IHSHMA,I)
1110 CALL DT_EVTHIS(IDUM)
1112 C CALL OUTGEN(IHSHMA,0,0,0,0,0,HEADER,0,NEVFIT,ONE,0,1,-1)
1114 C CALL GENFIT(XPARA)
1115 C WRITE(40,'(2I4,E11.3,F6.0,5E11.3)')
1116 C & IP,IT,PPN,SIGAV/DBLE(NEVFIT),XPARA
1126 *********************************************************************
1128 * control card: codewd = FLUCTUAT *
1130 * Treatment of cross section fluctuations *
1132 * what (1) = 1 treat cross section fluctuations *
1134 * what (1..6), sdum no meaning *
1136 *********************************************************************
1140 IF (WHAT(1).EQ.ONE) THEN
1146 *********************************************************************
1148 * control card: codewd = CENTRAL *
1150 * what (1) = 1. central production forced default: 0 *
1151 * if what (1) < 0 and > -100 *
1152 * what (2) = min. impact parameter default: 0 *
1153 * what (3) = max. impact parameter default: b_max *
1154 * if what (1) < -99 *
1155 * what (2) = fraction of cross section default: 1 *
1156 * if what (1) = -1 : evaporation/fzc suppressed *
1157 * if what (1) < -1 : evaporation/fzc allowed *
1159 * what (4..6), sdum no meaning *
1161 *********************************************************************
1164 ICENTR = INT(WHAT(1))
1165 IF (ICENTR.LT.0) THEN
1166 IF (ICENTR.GT.-100) THEN
1175 *********************************************************************
1177 * control card: codewd = RECOMBIN *
1179 * Chain recombination *
1180 * (recombine S-S and V-V chains to V-S chains) *
1182 * what (1) = -1. recombination switched off default: 1 *
1183 * what (2..6), sdum no meaning *
1185 *********************************************************************
1189 IF (WHAT(1).EQ.-1.0D0) IRECOM = 0
1192 *********************************************************************
1194 * control card: codewd = COMBIJET *
1196 * chain fusion (2 q-aq --> qq-aqaq) *
1198 * what (1) = 1 fusion treated *
1200 * what (2) minimum number of uncombined chains from *
1201 * single projectile or target nucleons *
1203 * what (3..6), sdum no meaning *
1205 *********************************************************************
1209 IF (INT(WHAT(1)).EQ.1) LCO2CR = .TRUE.
1210 IF (WHAT(2).GE.ZERO) CUTOF = WHAT(2)
1213 *********************************************************************
1215 * control card: codewd = XCUTS *
1217 * thresholds for x-sampling *
1219 * what (1) defines lower threshold for val.-q x-value (CVQ) *
1221 * what (2) defines lower threshold for val.-qq x-value (CDQ) *
1223 * what (3) defines lower threshold for sea-q x-value (CSEA) *
1225 * what (4) sea-q x-values in S-S chains (SSMIMA) *
1227 * what (5) not used *
1229 * what (6), sdum no meaning *
1231 * Note: Lower thresholds (what(1..3)) are def. as x_thr=CXXX/ECM *
1233 *********************************************************************
1236 IF (WHAT(1).GE.0.5D0) CVQ = WHAT(1)
1237 IF (WHAT(2).GE.ONE) CDQ = WHAT(2)
1238 IF (WHAT(3).GE.0.1D0) CSEA = WHAT(3)
1239 IF (WHAT(4).GE.ZERO) THEN
1243 IF (WHAT(5).GT.2.0D0) VVMTHR = WHAT(5)
1246 *********************************************************************
1248 * control card: codewd = INTPT *
1250 * what (1) = -1 intrinsic transverse momenta of partons *
1251 * not treated default: 1 *
1252 * what (2..6), sdum no meaning *
1254 *********************************************************************
1257 IF (WHAT(1).EQ.-1.0D0) THEN
1264 *********************************************************************
1266 * control card: codewd = CRONINPT *
1268 * Cronin effect (multiple scattering of partons at chain ends) *
1270 * what (1) = -1 Cronin effect not treated default: 1 *
1271 * what (2) = 0 scattering parameter default: 0.64 *
1272 * what (3..6), sdum no meaning *
1274 *********************************************************************
1277 IF (WHAT(1).EQ.-1.0D0) THEN
1285 *********************************************************************
1287 * control card: codewd = SEADISTR *
1289 * what (1) (XSEACO) sea(x) prop. 1/x**what (1) default: 1. *
1290 * what (2) (UNON) default: 2. *
1291 * what (3) (UNOM) default: 1.5 *
1292 * what (4) (UNOSEA) default: 5. *
1293 * qdis(x) prop. (1-x)**what (1) etc. *
1294 * what (5..6), sdum no meaning *
1296 *********************************************************************
1300 XSEACU = 1.05D0-XSEACO
1302 IF (UNON.LT.0.1D0) UNON = 2.0D0
1304 IF (UNOM.LT.0.1D0) UNOM = 1.5D0
1306 IF (UNOSEA.LT.0.1D0) UNOSEA = 5.0D0
1309 *********************************************************************
1311 * control card: codewd = SEASU3 *
1313 * Treatment of strange-quarks at chain ends *
1315 * what (1) (SEASQ) strange-quark supression factor *
1316 * iflav = 1.+rndm*(2.+SEASQ) *
1318 * what (2..6), sdum no meaning *
1320 *********************************************************************
1326 *********************************************************************
1328 * control card: codewd = DIQUARKS *
1330 * what (1) = -1. sea-diquark/antidiquark-pairs not treated *
1332 * what (2..6), sdum no meaning *
1334 *********************************************************************
1337 IF (WHAT(1).EQ.-1.0D0) THEN
1344 *********************************************************************
1346 * control card: codewd = RESONANC *
1348 * treatment of low mass chains *
1350 * what (1) = -1 low chain masses are not corrected for resonance *
1351 * masses (obsolete for BAMJET-fragmentation) *
1353 * what (2) = -1 massless partons default: 1. (massive) *
1354 * default: 1. (massive) *
1355 * what (3) = -1 chain-system containing chain of too small *
1356 * mass is rejected (note: this does not fully *
1357 * apply to S-S chains) default: 0. *
1358 * what (4..6), sdum no meaning *
1360 *********************************************************************
1366 IF (WHAT(1).EQ.-ONE) IRESCO = 0
1367 IF (WHAT(2).EQ.-ONE) IMSHL = 0
1368 IF (WHAT(3).EQ.-ONE) IRESRJ = 1
1371 *********************************************************************
1373 * control card: codewd = DIFFRACT *
1375 * Treatment of diffractive events *
1377 * what (1) = (ISINGD) 0 no single diffraction *
1378 * 1 single diffraction included *
1379 * +-2 single diffractive events only *
1380 * +-3 projectile single diffraction only *
1381 * +-4 target single diffraction only *
1382 * -5 double pomeron exchange only *
1383 * (neg. sign applies to PHOJET events) *
1386 * what (2) = (IDOUBD) 0 no double diffraction *
1387 * 1 double diffraction included *
1388 * 2 double diffractive events only *
1390 * what (3) = 1 projectile diffraction treated (2-channel form.) *
1392 * what (4) = alpha-parameter in projectile diffraction *
1394 * what (5..6), sdum no meaning *
1396 *********************************************************************
1399 IF (ABS(WHAT(1)).GT.ZERO) ISINGD = INT(WHAT(1))
1400 IF (ABS(WHAT(2)).GT.ZERO) IDOUBD = INT(WHAT(2))
1401 IF ((ISINGD.GT.1).AND.(IDOUBD.GT.1)) THEN
1403 1380 FORMAT(1X,'INIT: inconsistent DIFFRACT - input !',/,
1404 & 11X,'IDOUBD is reset to zero')
1407 IF (WHAT(3).GT.ZERO) DIBETA = WHAT(3)
1408 IF (WHAT(4).GT.ZERO) DIALPH = WHAT(4)
1411 *********************************************************************
1413 * control card: codewd = SINGLECH *
1415 * what (1) = 1. Regge contribution (one chain) included *
1417 * what (2..6), sdum no meaning *
1419 *********************************************************************
1423 IF (WHAT(1).EQ.ONE) ISICHA = 1
1426 *********************************************************************
1428 * control card: codewd = NOFRAGME *
1430 * biased chain hadronization *
1432 * what (1..6) = -1 no of hadronizsation of S-S chains *
1433 * = -2 no of hadronizsation of D-S chains *
1434 * = -3 no of hadronizsation of S-D chains *
1435 * = -4 no of hadronizsation of S-V chains *
1436 * = -5 no of hadronizsation of D-V chains *
1437 * = -6 no of hadronizsation of V-S chains *
1438 * = -7 no of hadronizsation of V-D chains *
1439 * = -8 no of hadronizsation of V-V chains *
1440 * = -9 no of hadronizsation of comb. chains *
1441 * default: complete hadronization *
1444 *********************************************************************
1448 ICHAIN = INT(WHAT(I))
1449 IF ((ICHAIN.LE.-1).AND.(ICHAIN.GE.-9))
1450 & LHADRO(ABS(ICHAIN)) = .FALSE.
1454 *********************************************************************
1456 * control card: codewd = HADRONIZE *
1458 * hadronization model and parameter switch *
1460 * what (1) = 1 hadronization via BAMJET *
1461 * = 2 hadronization via JETSET *
1463 * what (2) = 1..3 parameter set to be used *
1464 * JETSET: 3 sets available *
1465 * ( = 3 default JETSET-parameters) *
1466 * BAMJET: 1 set available *
1468 * what (3..6), sdum no meaning *
1470 *********************************************************************
1473 IWHAT1 = INT(WHAT(1))
1474 IWHAT2 = INT(WHAT(2))
1475 IF ((IWHAT1.EQ.1).OR.(IWHAT1.EQ.2)) IFRAG(1) = IWHAT1
1476 IF ((IWHAT1.EQ.2).AND.(IWHAT2.GE.1).AND.(IWHAT2.LE.3))
1480 *********************************************************************
1482 * control card: codewd = POPCORN *
1484 * "Popcorn-effect" in fragmentation and diquark breaking diagrams *
1486 * what (1) = (PDB) frac. of diquark fragmenting directly into *
1487 * baryons (PYTHIA/JETSET fragmentation) *
1488 * (JETSET: = 0. Popcorn mechanism switched off) *
1490 * what (2) = probability for accepting a diquark breaking *
1491 * diagram involving the generation of a u/d quark- *
1492 * antiquark pair default: 0.0 *
1493 * what (3) = same a what (2), here for s quark-antiquark pair *
1495 * what (4..6), sdum no meaning *
1497 *********************************************************************
1500 IF (WHAT(1).GE.0.0D0) PDB = WHAT(1)
1501 IF (WHAT(2).GE.0.0D0) THEN
1505 IF (WHAT(3).GE.0.0D0) PDBSEA(3) = WHAT(3)
1507 DBRKA(1,I) = DBRKR(1,I)*PDBSEA(1)/(1.D0-PDBSEA(1))
1508 DBRKA(2,I) = DBRKR(2,I)*PDBSEA(2)/(1.D0-PDBSEA(2))
1509 DBRKA(3,I) = DBRKR(3,I)*PDBSEA(3)/(1.D0-PDBSEA(3))
1513 *********************************************************************
1515 * control card: codewd = PARDECAY *
1517 * what (1) = 1. Sigma0/Asigma0 are decaying within JETSET *
1518 * = 2. pion^0 decay after intranucl. cascade *
1519 * default: no decay *
1520 * what (2..6), sdum no meaning *
1522 *********************************************************************
1525 IF (WHAT(1).EQ.ONE) ISIG0 = 1
1526 IF (WHAT(1).EQ.2.0D0) IPI0 = 1
1529 *********************************************************************
1531 * control card: codewd = BEAM *
1533 * definition of beam parameters *
1535 * what (1/2) > 0 : energy of beam 1/2 (GeV) *
1536 * < 0 : abs(what(1/2)) energy per charge of *
1538 * (beam 1 is directed into positive z-direction) *
1539 * what (3) beam crossing angle, defined as 2x angle between *
1540 * one beam and the z-axis (micro rad) *
1541 * what (4) angle with x-axis defining the collision plane *
1542 * what (5..6), sdum no meaning *
1544 * Note: this card requires previously defined projectile and *
1545 * target identities (PROJPAR, TARPAR) *
1547 *********************************************************************
1550 CALL DT_BEAMPR(WHAT,PPN,1)
1556 *********************************************************************
1558 * control card: codewd = LUND-MSTU *
1560 * set parameter MSTU in JETSET-common /LUDAT1/ *
1562 * what (1) = index according to LUND-common block *
1563 * what (2) = new value of MSTU( int(what(1)) ) *
1564 * what (3), what(4) and what (5), what(6) further *
1565 * parameter in the same way as what (1) and *
1567 * default: default-Lund or corresponding to *
1568 * the set given in HADRONIZE *
1570 *********************************************************************
1573 IF (WHAT(1).GT.ZERO) THEN
1575 IMSTU(NMSTU) = INT(WHAT(1))
1576 MSTUX(NMSTU) = INT(WHAT(2))
1578 IF (WHAT(3).GT.ZERO) THEN
1580 IMSTU(NMSTU) = INT(WHAT(3))
1581 MSTUX(NMSTU) = INT(WHAT(4))
1583 IF (WHAT(5).GT.ZERO) THEN
1585 IMSTU(NMSTU) = INT(WHAT(5))
1586 MSTUX(NMSTU) = INT(WHAT(6))
1590 *********************************************************************
1592 * control card: codewd = LUND-MSTJ *
1594 * set parameter MSTJ in JETSET-common /LUDAT1/ *
1596 * what (1) = index according to LUND-common block *
1597 * what (2) = new value of MSTJ( int(what(1)) ) *
1598 * what (3), what(4) and what (5), what(6) further *
1599 * parameter in the same way as what (1) and *
1601 * default: default-Lund or corresponding to *
1602 * the set given in HADRONIZE *
1604 *********************************************************************
1607 IF (WHAT(1).GT.ZERO) THEN
1609 IMSTJ(NMSTJ) = INT(WHAT(1))
1610 MSTJX(NMSTJ) = INT(WHAT(2))
1612 IF (WHAT(3).GT.ZERO) THEN
1614 IMSTJ(NMSTJ) = INT(WHAT(3))
1615 MSTJX(NMSTJ) = INT(WHAT(4))
1617 IF (WHAT(5).GT.ZERO) THEN
1619 IMSTJ(NMSTJ) = INT(WHAT(5))
1620 MSTJX(NMSTJ) = INT(WHAT(6))
1624 *********************************************************************
1626 * control card: codewd = LUND-MDCY *
1628 * set parameter MDCY(I,1) for particle decays in JETSET-common *
1631 * what (1-6) = PDG particle index of particle which should *
1633 * default: default-Lund or forced in *
1636 *********************************************************************
1640 IF (WHAT(I).NE.ZERO) THEN
1642 KC = PYCOMP(INT(WHAT(I)))
1649 *********************************************************************
1651 * control card: codewd = LUND-PARJ *
1653 * set parameter PARJ in JETSET-common /LUDAT1/ *
1655 * what (1) = index according to LUND-common block *
1656 * what (2) = new value of PARJ( int(what(1)) ) *
1657 * what (3), what(4) and what (5), what(6) further *
1658 * parameter in the same way as what (1) and *
1660 * default: default-Lund or corresponding to *
1661 * the set given in HADRONIZE *
1663 *********************************************************************
1666 IF (WHAT(1).NE.ZERO) THEN
1668 IPARJ(NPARJ) = INT(WHAT(1))
1669 PARJX(NPARJ) = WHAT(2)
1671 IF (WHAT(3).NE.ZERO) THEN
1673 IPARJ(NPARJ) = INT(WHAT(3))
1674 PARJX(NPARJ) = WHAT(4)
1676 IF (WHAT(5).NE.ZERO) THEN
1678 IPARJ(NPARJ) = INT(WHAT(5))
1679 PARJX(NPARJ) = WHAT(6)
1683 *********************************************************************
1685 * control card: codewd = LUND-PARU *
1687 * set parameter PARJ in JETSET-common /LUDAT1/ *
1689 * what (1) = index according to LUND-common block *
1690 * what (2) = new value of PARU( int(what(1)) ) *
1691 * what (3), what(4) and what (5), what(6) further *
1692 * parameter in the same way as what (1) and *
1694 * default: default-Lund or corresponding to *
1695 * the set given in HADRONIZE *
1697 *********************************************************************
1700 IF (WHAT(1).GT.ZERO) THEN
1702 IPARU(NPARU) = INT(WHAT(1))
1703 PARUX(NPARU) = WHAT(2)
1705 IF (WHAT(3).GT.ZERO) THEN
1707 IPARU(NPARU) = INT(WHAT(3))
1708 PARUX(NPARU) = WHAT(4)
1710 IF (WHAT(5).GT.ZERO) THEN
1712 IPARU(NPARU) = INT(WHAT(5))
1713 PARUX(NPARU) = WHAT(6)
1717 *********************************************************************
1719 * control card: codewd = OUTLEVEL *
1721 * output control switches *
1723 * what (1) = internal rejection informations default: 0 *
1724 * what (2) = energy-momentum conservation check output *
1726 * what (3) = internal warning messages default: 0 *
1727 * what (4..6), sdum not yet used *
1729 *********************************************************************
1733 IOULEV(K) = INT(WHAT(K))
1737 *********************************************************************
1739 * control card: codewd = FRAME *
1741 * frame in which final state is given in DTEVT1 *
1743 * what (1) = 1 target rest frame (laboratory) *
1744 * = 2 nucleon-nucleon cms *
1747 *********************************************************************
1750 KFRAME = INT(WHAT(1))
1751 IF ((KFRAME.GE.1).AND.(KFRAME.LE.2)) IFRAME = KFRAME
1754 *********************************************************************
1756 * control card: codewd = L-TAG *
1759 * definition of kinematical cuts for radiated photon and *
1760 * outgoing lepton detection in lepton-nucleus interactions *
1762 * what (1) = y_min *
1763 * what (2) = y_max *
1764 * what (3) = Q^2_min *
1765 * what (4) = Q^2_max *
1766 * what (5) = theta_min (Lab) *
1767 * what (6) = theta_max (Lab) *
1768 * default: no cuts *
1771 *********************************************************************
1782 *********************************************************************
1784 * control card: codewd = L-ETAG *
1787 * what (1) = min. outgoing lepton energy (in Lab) *
1788 * what (2) = min. photon energy (in Lab) *
1789 * what (3) = max. photon energy (in Lab) *
1790 * default: no cuts *
1791 * what (2..6), sdum no meaning *
1793 *********************************************************************
1796 ELMIN = MAX(WHAT(1),ZERO)
1797 EGMIN = MAX(WHAT(2),ZERO)
1798 EGMAX = MAX(WHAT(3),ZERO)
1801 *********************************************************************
1803 * control card: codewd = ECMS-CUT *
1805 * what (1) = min. c.m. energy to be sampled *
1806 * what (2) = max. c.m. energy to be sampled *
1807 * what (3) = min x_Bj to be sampled *
1808 * default: no cuts *
1809 * what (3..6), sdum no meaning *
1811 *********************************************************************
1816 IF (ECMIN.GT.ECMAX) ECMIN = ECMAX
1817 XBJMIN = MAX(WHAT(3),ZERO)
1820 *********************************************************************
1822 * control card: codewd = VDM-PAR1 *
1824 * parameters in gamma-nucleus cross section calculation *
1826 * what (1) = Lambda^2 default: 2. *
1827 * what (2) lower limit in M^2 integration *
1830 * = 3 (m_phi)^2 default: 1 *
1831 * what (3) upper limit in M^2 integration *
1834 * = 3 s default: 3 *
1835 * what (4) CKMT F_2 structure function *
1837 * = 100 deuteron default: 2212 *
1838 * what (5) calculation of gamma-nucleon xsections *
1839 * = 1 according to CKMT-parametrization of F_2 *
1840 * = 2 integrating SIGVP over M^2 *
1842 * = 4 PHOJET cross sections default: 4 *
1844 * what (6), sdum no meaning *
1846 *********************************************************************
1849 IF (WHAT(1).GE.ZERO) RL2 = WHAT(1)
1850 IF ((WHAT(2).GE.1).AND.(WHAT(2).LE.3)) INTRGE(1) = INT(WHAT(2))
1851 IF ((WHAT(3).GE.1).AND.(WHAT(3).LE.3)) INTRGE(2) = INT(WHAT(3))
1852 IF ((WHAT(4).EQ.2212).OR.(WHAT(4).EQ.100)) IDPDF = INT(WHAT(4))
1853 IF ((WHAT(5).GE.1).AND.(WHAT(5).LE.4)) MODEGA = INT(WHAT(5))
1856 *********************************************************************
1858 * control card: codewd = HISTOGRAM *
1860 * activate different classes of histograms *
1862 * default: no histograms *
1864 *********************************************************************
1868 IF ((WHAT(J).GE.100).AND.(WHAT(J).LE.150)) THEN
1869 IHISPP(INT(WHAT(J))-100) = 1
1870 ELSEIF ((ABS(WHAT(J)).GE.200).AND.(ABS(WHAT(J)).LE.250)) THEN
1871 IHISXS(INT(ABS(WHAT(J)))-200) = 1
1872 IF (WHAT(J).LT.ZERO) IXSTBL = 1
1877 *********************************************************************
1879 * control card: codewd = XS-TABLE *
1881 * output of cross section table for requested interaction *
1882 * - particle production deactivated ! - *
1884 * what (1) lower energy limit for tabulation *
1886 * < 0 nucleon-nucleon cms *
1887 * what (2) upper energy limit for tabulation *
1889 * < 0 nucleon-nucleon cms *
1890 * what (3) > 0 # of equidistant lin. bins in E *
1891 * < 0 # of equidistant log. bins in E *
1892 * what (4) lower limit of particle virtuality (photons) *
1893 * what (5) upper limit of particle virtuality (photons) *
1894 * what (6) > 0 # of equidistant lin. bins in Q^2 *
1895 * < 0 # of equidistant log. bins in Q^2 *
1897 *********************************************************************
1900 IF (WHAT(1).EQ.99999.0D0) THEN
1901 IRATIO = INT(WHAT(2))
1904 CMENER = ABS(WHAT(2))
1905 IF (.NOT.LXSTAB) THEN
1911 IF ((.NOT.LXSTAB).OR.(CMENER.NE.CMEOLD)) THEN
1913 IF (WHAT(2).GT.ZERO)
1914 & CMENER = SQRT(2.0D0*AAM(1)**2+2.0D0*WHAT(2)*AAM(1))
1917 C WRITE(LOUT,*) 'CMENER = ',CMENER
1918 CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,CMENER,1)
1921 CALL DT_XSTABL(WHAT,IXSQEL,IRATIO)
1926 *********************************************************************
1928 * control card: codewd = GLAUB-PAR *
1930 * parameters in Glauber-formalism *
1932 * what (1) # of nucleon configurations sampled in integration *
1933 * over nuclear desity default: 1000 *
1934 * what (2) # of bins for integration over impact-parameter and *
1935 * for profile-function calculation default: 49 *
1936 * what (3) = 1 calculation of tot., el. and qel. cross sections *
1938 * what (4) = 1 read pre-calculated impact-parameter distrib. *
1940 * =-1 dump pre-calculated impact-parameter distrib. *
1942 * = 100 read pre-calculated impact-parameter distrib. *
1943 * for variable projectile/target/energy runs *
1946 * what (5..6) no meaning *
1947 * sdum if |what (4)| = 1 name of in/output-file (sdum.glb) *
1949 *********************************************************************
1952 IF (WHAT(1).GT.ZERO) JSTATB = INT(WHAT(1))
1953 IF (WHAT(2).GT.ZERO) JBINSB = INT(WHAT(2))
1954 IF (WHAT(3).EQ.ONE) LPROD = .FALSE.
1955 IF ((ABS(WHAT(4)).EQ.ONE).OR.(WHAT(4).EQ.100)) THEN
1956 IOGLB = INT(WHAT(4))
1961 *********************************************************************
1963 * control card: codewd = GLAUB-INI *
1965 * pre-initialization of profile function *
1967 * what (1) lower energy limit for initialization *
1969 * < 0 nucleon-nucleon cms *
1970 * what (2) upper energy limit for initialization *
1972 * < 0 nucleon-nucleon cms *
1973 * what (3) > 0 # of equidistant lin. bins in E *
1974 * < 0 # of equidistant log. bins in E *
1975 * what (4) maximum projectile mass number for which the *
1976 * Glauber data are initialized for each *
1977 * projectile mass number *
1978 * (if <= mass given with the PROJPAR-card) *
1980 * what (5) steps in mass number starting from what (4) *
1981 * up to mass number defined with PROJPAR-card *
1982 * for which Glauber data are initialized *
1984 * what (6) no meaning *
1987 *********************************************************************
1991 CALL DT_GLBINI(WHAT)
1994 *********************************************************************
1996 * control card: codewd = VDM-PAR2 *
1998 * parameters in gamma-nucleus cross section calculation *
2000 * what (1) = 0 no suppression of shadowing by direct photon *
2002 * = 1 suppression .. default: 1 *
2003 * what (2) = 0 no suppression of shadowing by anomalous *
2004 * component if photon-F_2 *
2005 * = 1 suppression .. default: 1 *
2006 * what (3) = 0 no suppression of shadowing by coherence *
2007 * length of the photon *
2008 * = 1 suppression .. default: 1 *
2009 * what (4) = 1 longitudinal polarized photons are taken into *
2011 * eps*R*Q^2/M^2 = what(4)*Q^2/M^2 default: 0 *
2012 * what (5..6), sdum no meaning *
2014 *********************************************************************
2017 IF ((WHAT(1).EQ.ZERO).OR.(WHAT(1).EQ.ONE)) ISHAD(1) = INT(WHAT(1))
2018 IF ((WHAT(2).EQ.ZERO).OR.(WHAT(2).EQ.ONE)) ISHAD(2) = INT(WHAT(2))
2019 IF ((WHAT(3).EQ.ZERO).OR.(WHAT(3).EQ.ONE)) ISHAD(3) = INT(WHAT(3))
2023 *********************************************************************
2025 * control card: XS-QELPRO *
2027 * what (1..6), sdum no meaning *
2029 *********************************************************************
2032 IXSQEL = ABS(WHAT(1))
2035 *********************************************************************
2037 * control card: RNDMINIT *
2039 * initialization of random number generator *
2041 * what (1..4) values for initialization (= 1..168) *
2042 * what (5..6), sdum no meaning *
2044 *********************************************************************
2047 IF ((WHAT(1).LT.1.0D0).OR.(WHAT(1).GT.168.0D0)) THEN
2052 IF ((WHAT(2).LT.1.0D0).OR.(WHAT(2).GT.168.0D0)) THEN
2057 IF ((WHAT(3).LT.1.0D0).OR.(WHAT(3).GT.168.0D0)) THEN
2062 IF ((WHAT(4).LT.1.0D0).OR.(WHAT(4).GT.168.0D0)) THEN
2067 CALL DT_RNDMST(NA1,NA2,NA3,NA4)
2070 *********************************************************************
2072 * control card: codewd = LEPTO-CUT *
2074 * set parameter CUT in LEPTO-common /LEPTOU/ *
2076 * what (1) = index in CUT-array *
2077 * what (2) = new value of CUT( int(what(1)) ) *
2078 * what (3), what(4) and what (5), what(6) further *
2079 * parameter in the same way as what (1) and *
2081 * default: default-LEPTO parameters *
2083 *********************************************************************
2086 IF (WHAT(1).GT.ZERO) CUT(INT(WHAT(1))) = WHAT(2)
2087 IF (WHAT(3).GT.ZERO) CUT(INT(WHAT(3))) = WHAT(4)
2088 IF (WHAT(5).GT.ZERO) CUT(INT(WHAT(5))) = WHAT(6)
2091 *********************************************************************
2093 * control card: codewd = LEPTO-LST *
2095 * set parameter LST in LEPTO-common /LEPTOU/ *
2097 * what (1) = index in LST-array *
2098 * what (2) = new value of LST( int(what(1)) ) *
2099 * what (3), what(4) and what (5), what(6) further *
2100 * parameter in the same way as what (1) and *
2102 * default: default-LEPTO parameters *
2104 *********************************************************************
2107 IF (WHAT(1).GT.ZERO) LST(INT(WHAT(1))) = INT(WHAT(2))
2108 IF (WHAT(3).GT.ZERO) LST(INT(WHAT(3))) = INT(WHAT(4))
2109 IF (WHAT(5).GT.ZERO) LST(INT(WHAT(5))) = INT(WHAT(6))
2112 *********************************************************************
2114 * control card: codewd = LEPTO-PARL *
2116 * set parameter PARL in LEPTO-common /LEPTOU/ *
2118 * what (1) = index in PARL-array *
2119 * what (2) = new value of PARL( int(what(1)) ) *
2120 * what (3), what(4) and what (5), what(6) further *
2121 * parameter in the same way as what (1) and *
2123 * default: default-LEPTO parameters *
2125 *********************************************************************
2128 IF (WHAT(1).GT.ZERO) PARL(INT(WHAT(1))) = WHAT(2)
2129 IF (WHAT(3).GT.ZERO) PARL(INT(WHAT(3))) = WHAT(4)
2130 IF (WHAT(5).GT.ZERO) PARL(INT(WHAT(5))) = WHAT(6)
2133 *********************************************************************
2135 * control card: codewd = START *
2137 * what (1) = number of events default: 100. *
2138 * what (2) = 0 Glauber initialization follows *
2139 * = 1 Glauber initialization supressed, fitted *
2140 * results are used instead *
2141 * (this does not apply if emulsion-treatment *
2143 * = 2 Glauber initialization is written to *
2144 * output-file shmakov.out *
2145 * = 3 Glauber initialization is read from input-file *
2146 * shmakov.out default: 0 *
2147 * what (3..6) no meaning *
2148 * what (3..6) no meaning *
2150 *********************************************************************
2154 * check for cross-section table output only
2157 NCASES = INT(WHAT(1))
2158 IF (NCASES.LE.0) NCASES = 100
2159 IGLAU = INT(WHAT(2))
2160 IF ((IGLAU.NE.1).AND.(IGLAU.NE.2).AND.(IGLAU.NE.3))
2169 IF (IDP.LE.0) IDP = 1
2170 * muon neutrinos: temporary (missing index)
2171 * (new patch in projpar: therefore the following this is probably not
2172 * necessary anymore..)
2173 C IF (IDP.EQ.26) IDP = 5
2174 C IF (IDP.EQ.27) IDP = 6
2176 * redefine collision energy
2178 IF (ABS(VAREHI).GT.ZERO) THEN
2180 IF (VARELO.LT.EHADLO) VARELO = EHADLO
2181 CALL DT_LTINI(IDP,IDT,VARELO,PDUM,VARCLO,1)
2183 CALL DT_LTINI(IDP,IDT,VAREHI,PDUM,VARCHI,1)
2185 CALL DT_LTINI(IDP,IDT,EPN,PPN,CMENER,1)
2188 1003 FORMAT(1X,'INIT: collision energy not defined!',/,
2189 & 1X,' -program stopped- ')
2193 * switch off evaporation (even if requested) if central coll. requ.
2194 IF ((ICENTR.EQ.-1).OR.(ICENTR.GT.0).OR.(XSFRAC.LT.0.5D0)) THEN
2197 1004 FORMAT(1X,/,'Warning! Evaporation request rejected since',
2198 & ' central collisions forced.')
2205 * initialization of evaporation-module
2207 * initialize evaporation if the code is not used as Fluka event generator
2208 WRITE(LOUT,*) ' ITRSPT = ', ITRSPT
2209 IF (ITRSPT.NE.1) THEN
2213 WRITE(LOUT,*) ' LEVPRT = ',LEVPRT
2214 IF (LEVPRT) LHEAVY = .TRUE.
2215 * save the default JETSET-parameter
2218 WRITE(LOUT,*) ' IDP = ',IDP,' MCGENE = ',MCGENE
2219 * force use of phojet for g-A
2220 IF ((IDP.EQ.7).AND.(MCGENE.NE.3)) MCGENE = 2
2221 * initialization of nucleon-nucleon event generator
2222 IF (MCGENE.EQ.2) CALL DT_PHOINI
2223 * initialization of LEPTO event generator
2224 IF (MCGENE.EQ.3) THEN
2226 STOP ' This version does not contain LEPTO !'
2230 * initialization of quasi-elastic neutrino scattering
2231 IF (MCGENE.EQ.4) THEN
2232 IF (IJPROJ.EQ.5) THEN
2234 ELSEIF (IJPROJ.EQ.6) THEN
2236 ELSEIF (IJPROJ.EQ.135) THEN
2238 ELSEIF (IJPROJ.EQ.136) THEN
2240 ELSEIF (IJPROJ.EQ.133) THEN
2242 ELSEIF (IJPROJ.EQ.134) THEN
2247 * normalize fractions of emulsion components
2248 IF (NCOMPO.GT.0) THEN
2251 SUMFRA = SUMFRA+EMUFRA(I)
2253 IF (SUMFRA.GT.ZERO) THEN
2255 EMUFRA(I) = EMUFRA(I)/SUMFRA
2260 * disallow Cronin's multiple scattering for nucleus-nucleus interactions
2261 IF ((IP.GT.1).AND.(MKCRON.GT.0)) THEN
2263 1005 FORMAT(/,1X,'INIT: multiple scattering disallowed',/)
2267 * initialization of Glauber-formalism (moved to xAEVT, sr 26.3.96)
2268 C IF (NCOMPO.LE.0) THEN
2269 C CALL DT_SHMAKI(IP,IPZ,IT,ITZ,IDP,PPN,IGLAU)
2272 C CALL DT_SHMAKI(IP,IPZ,IEMUMA(I),IEMUCH(I),IDP,PPN,0)
2276 * pre-tabulation of elastic cross-sections
2277 CALL DT_SIGTBL(JDUM,JDUM,DUM,DUM,-1)
2283 *********************************************************************
2285 * control card: codewd = STOP *
2287 * stop of the event generation *
2289 * what (1..6) no meaning *
2291 *********************************************************************
2295 9000 FORMAT(1X,'---> unexpected end of input !')
2302 *$ CREATE DT_KKINC.FOR
2305 *===kkinc==============================================================*
2307 SUBROUTINE DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,
2310 ************************************************************************
2311 * Treatment of complete nucleus-nucleus or hadron-nucleus scattering *
2312 * This subroutine is an update of the previous version written *
2313 * by J. Ranft/ H.-J. Moehring. *
2314 * This version dated 19.11.95 is written by S. Roesler *
2315 ************************************************************************
2317 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2320 PARAMETER ( LINP = 10 ,
2324 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY5=1.0D-5,
2325 & TINY2=1.0D-2,TINY3=1.0D-3)
2331 PARAMETER (NMXHKK=200000)
2333 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
2334 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
2335 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
2337 * extended event history
2338 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
2339 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
2342 * particle properties (BAMJET index convention)
2344 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2345 & IICH(210),IIBAR(210),K1(210),K2(210)
2347 * properties of interacting particles
2348 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2350 * Lorentz-parameters of the current interaction
2351 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
2352 & UMO,PPCM,EPROJ,PPROJ
2354 * flags for input different options
2355 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2356 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2357 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2359 * flags for particle decays
2360 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
2361 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
2362 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
2364 * cuts for variable energy runs
2365 COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
2367 * Glauber formalism: flags and parameters for statistics
2370 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
2377 IF (ILOOP.EQ.4) THEN
2378 WRITE(LOUT,1000) NEVHKK
2379 1000 FORMAT(1X,'KKINC: event ',I8,' rejected!')
2384 * variable energy-runs, recalculate parameters for LT's
2385 IF ((ABS(VAREHI).GT.ZERO).OR.(IOGLB.EQ.100)) THEN
2388 CALL DT_LTINI(IDP,1,EPN,PDUM,CDUM,1)
2390 IF (EPN.GT.EPROJ) THEN
2391 WRITE(LOUT,'(A,E9.3,2A,E9.3,A)')
2392 & ' Requested energy (',EPN,'GeV) exceeds',
2393 & ' initialization energy (',EPROJ,'GeV) !'
2397 * re-initialize /DTPRTA/
2403 IBPROJ = IIBAR(IJPROJ)
2405 * calculate nuclear potentials (common /DTNPOT/)
2406 CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
2408 * initialize treatment for residual nuclei
2409 CALL DT_RESNCL(EPN,NLOOP,1)
2411 * sample hadron/nucleus-nucleus interaction
2412 CALL DT_KKEVNT(KKMAT,IREJ1)
2413 IF (IREJ1.GT.0) THEN
2414 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKINC'
2418 IF ((NPMASS.GT.1).OR.(NTMASS.GT.1)) THEN
2420 * intranuclear cascade of final state particles for KTAUGE generations
2422 CALL DT_FOZOCA(LFZC,IREJ1)
2423 IF (IREJ1.GT.0) THEN
2424 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKINC'
2428 * baryons unable to escape the nuclear potential are treated as
2429 * excited nucleons (ISTHKK=15,16)
2432 * decay of resonances produced in intranuclear cascade processes
2433 **sr 15-11-95 should be obsolete
2434 C IF (LFZC) CALL DT_DECAY1
2437 * treatment of residual nuclei
2438 CALL DT_RESNCL(EPN,NLOOP,2)
2440 * evaporation / fission / fragmentation
2441 * (if intranuclear cascade was sampled only)
2443 CALL DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ1)
2444 IF (IREJ1.GT.1) GOTO 101
2445 IF (IREJ1.EQ.1) GOTO 100
2450 * rejection of unphysical configurations
2451 C CALL DT_REJUCO(1,IREJ1)
2452 C IF (IREJ1.GT.0) THEN
2453 C IF (IOULEV(1).GT.0)
2454 C & WRITE(LOUT,*) 'rejected 3 in KKINC: too large x'
2458 * transform finale state into Lab.
2460 CALL DT_BEAMPR(WHAT,DUM,IFLAG)
2461 IF ((IFRAME.EQ.1).AND.(IFLAG.EQ.-1)) CALL DT_LT2LAB
2463 IF (IPI0.EQ.1) CALL DT_DECPI0
2465 C IF (NEVHKK.EQ.5) CALL DT_EVTOUT(4)
2473 *$ CREATE DT_DEFAUL.FOR
2476 *===defaul=============================================================*
2478 SUBROUTINE DT_DEFAUL(EPN,PPN)
2480 ************************************************************************
2481 * Variables are set to default values. *
2482 * This version dated 8.5.95 is written by S. Roesler. *
2483 ************************************************************************
2485 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2487 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
2488 PARAMETER (TWOPI = 6.283185307179586454D+00)
2490 * particle properties (BAMJET index convention)
2492 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2493 & IICH(210),IIBAR(210),K1(210),K2(210)
2497 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
2498 & EBINDP(2),EBINDN(2),EPOT(2,210),
2499 & ETACOU(2),ICOUL,LFERMI
2501 * interface HADRIN-DPM
2502 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
2504 * central particle production, impact parameter biasing
2505 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
2507 * properties of interacting particles
2508 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2510 * properties of photon/lepton projectiles
2511 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
2513 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2515 * emulsion treatment
2516 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2519 * parameter for intranuclear cascade
2521 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
2523 * various options for treatment of partons (DTUNUC 1.x)
2524 * (chain recombination, Cronin,..)
2525 LOGICAL LCO2CR,LINTPT
2526 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
2529 * threshold values for x-sampling (DTUNUC 1.x)
2530 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
2533 * flags for input different options
2534 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2535 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2536 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2538 * n-n cross section fluctuations
2539 PARAMETER (NBINS = 1000)
2540 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
2542 * flags for particle decays
2543 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
2544 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
2545 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
2547 * diquark-breaking mechanism
2548 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
2550 * nucleon-nucleon event-generator
2553 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
2555 * flags for diffractive interactions (DTUNUC 1.x)
2556 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
2558 * VDM parameter for photon-nucleus interactions
2559 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
2561 * Glauber formalism: flags and parameters for statistics
2564 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
2566 * kinematical cuts for lepton-nucleus interactions
2567 COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
2568 & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
2570 * flags for activated histograms
2571 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
2573 * cuts for variable energy runs
2574 COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
2576 * parameters for hA-diffraction
2577 COMMON /DTDIHA/ DIBETA,DIALPH
2581 COMMON /LEPTOI/ RPPN,LEPIN,INTER
2583 * steering flags for qel neutrino scattering modules
2584 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
2587 COMMON /DTEVNO/ NEVENT,ICASCA
2589 DATA POTMES /0.002D0/
2600 * nucleus independent meson potential
2648 **sr 7.4.98: changed after corrected B-sampling
2667 * definition of soft quark distributions
2672 * cutoff parameters for x-sampling
2718 CMODEL(1) = 'DTUNUC '
2719 CMODEL(2) = 'PHOJET '
2720 CMODEL(3) = 'LEPTO '
2721 CMODEL(4) = 'QNEUTRIN'
2758 IF (ITRSPT.EQ.1) THEN
2793 IF (ITRSPT.EQ.1) THEN
2799 * default Lab.-energy
2801 PPN = SQRT((EPN-AAM(IJPROJ))*(EPN+AAM(IJPROJ)))
2806 *$ CREATE DT_AAEVT.FOR
2809 *===aaevt==============================================================*
2811 SUBROUTINE DT_AAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
2814 ************************************************************************
2815 * This version dated 22.03.96 is written by S. Roesler. *
2816 ************************************************************************
2818 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2821 PARAMETER ( LINP = 10 ,
2825 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2827 * emulsion treatment
2828 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2832 COMMON /DTEVNO/ NEVENT,ICASCA
2834 CHARACTER*8 DATE,HHMMSS
2835 CHARACTER*9 CHDATE,CHTIME,CHZONE
2836 DIMENSION JDMNYR(8),IDMNYR(3)
2839 NMSG = MAX(NEVTS/100,1)
2841 * initialization of run-statistics and histograms
2844 CALL PHO_PHIST(1000,DUM)
2846 * initialization of Glauber-formalism
2847 IF (NCOMPO.LE.0) THEN
2848 CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
2851 CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
2856 C CALL IDATE(IDMNYR)
2857 C WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2858 C & IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
2859 CALL DATE_AND_TIME ( CHDATE, CHTIME, CHZONE, JDMNYR )
2860 WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2861 & JDMNYR(3),JDMNYR(2),MOD(JDMNYR(1),100)
2863 WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)')
2864 & IDMNYR(1),IDMNYR(2),IDMNYR(3)
2865 WRITE(LOUT,1001) DATE,HHMMSS
2866 1001 FORMAT(/,' DT_AAEVT: Initialisation finished. ( Date: ',A8,
2867 & ' Time: ',A8,' )')
2869 * generate NEVTS events
2872 * print run-status message
2873 IF (MOD(IEVT,NMSG).EQ.0) THEN
2874 C CALL IDATE(IDMNYR)
2875 C WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2876 C & IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
2877 CALL DATE_AND_TIME ( CHDATE, CHTIME, CHZONE, JDMNYR )
2878 WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2879 & JDMNYR(3),JDMNYR(2),MOD(JDMNYR(1),100)
2881 WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)')
2882 & IDMNYR(1),IDMNYR(2),IDMNYR(3)
2883 WRITE(LOUT,1000) IEVT-1,NEVTS,DATE,HHMMSS
2884 1000 FORMAT(/,1X,I8,' out of ',I8,' events sampled ( Date: ',A,
2885 & ' Time: ',A,' )',/)
2886 C WRITE(LOUT,1000) IEVT-1
2887 C1000 FORMAT(1X,I8,' events sampled')
2890 * treat nuclear emulsions
2891 IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
2892 * composite targets only
2895 CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,IREJ)
2897 CALL PHO_PHIST(2000,DUM)
2901 * print run-statistics and histograms to output-unit 6
2903 CALL PHO_PHIST(3000,DUM)
2910 *$ CREATE DT_LAEVT.FOR
2913 *===laevt==============================================================*
2915 SUBROUTINE DT_LAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
2918 ************************************************************************
2919 * Interface to run DPMJET for lepton-nucleus interactions. *
2920 * Kinematics is sampled using the equivalent photon approximation *
2921 * Based on GPHERA-routine by R. Engel. *
2922 * This version dated 23.03.96 is written by S. Roesler. *
2923 ************************************************************************
2925 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2928 PARAMETER ( LINP = 10 ,
2932 PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,
2933 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
2934 PARAMETER (TWOPI = 6.283185307179586454D+00,
2936 & ALPHEM = ONE/137.0D0)
2938 C CHARACTER*72 HEADER
2940 * particle properties (BAMJET index convention)
2942 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2943 & IICH(210),IIBAR(210),K1(210),K2(210)
2947 PARAMETER (NMXHKK=200000)
2949 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
2950 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
2951 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
2953 * extended event history
2954 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
2955 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
2958 * kinematical cuts for lepton-nucleus interactions
2959 COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
2960 & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
2962 * properties of interacting particles
2963 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2965 * properties of photon/lepton projectiles
2966 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
2968 * kinematics at lepton-gamma vertex
2969 COMMON /DTLGVX/ PPL0(4),PPL1(4),PPG(4),PPA(4)
2971 * flags for activated histograms
2972 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
2974 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2976 * emulsion treatment
2977 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2980 * Glauber formalism: cross sections
2981 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
2982 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
2983 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
2984 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
2985 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
2986 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
2987 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
2988 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
2989 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
2990 & BSLOPE,NEBINI,NQBINI
2992 * nucleon-nucleon event-generator
2995 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
2997 * flags for input different options
2998 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2999 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
3000 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
3003 COMMON /DTEVNO/ NEVENT,ICASCA
3005 DIMENSION XDUMB(40),BGTA(4)
3008 IF (MCGENE.EQ.3) THEN
3010 STOP ' This version does not contain LEPTO !'
3015 NMSG = MAX(NEVTS/10,1)
3017 * mass of incident lepton
3020 IDPPDG = IDT_IPDGHA(IDP)
3022 * consistency of kinematical limits
3023 Q2MIN = MAX(Q2MIN,TINY10)
3024 Q2MAX = MAX(Q2MAX,TINY10)
3025 YMIN = MIN(MAX(YMIN,TINY10),0.999D0)
3026 YMAX = MIN(MAX(YMAX,TINY10),0.999D0)
3028 * total energy of the lepton-nucleon system
3029 PTOTLN = SQRT( (PLEPT0(1)+PNUCL(1))**2+(PLEPT0(2)+PNUCL(2))**2
3030 & +(PLEPT0(3)+PNUCL(3))**2 )
3031 ETOTLN = PLEPT0(4)+PNUCL(4)
3032 ECMLN = SQRT((ETOTLN-PTOTLN)*(ETOTLN+PTOTLN))
3033 ECMAX = MIN(ECMAX,ECMLN)
3034 WRITE(LOUT,1003) ECMIN,ECMAX,YMIN,YMAX,Q2MIN,Q2MAX,EGMIN,
3036 1003 FORMAT(1X,'LAEVT:',16X,'kinematical cuts',/,22X,
3037 & '------------------',/,9X,'W (min) =',
3038 & F7.1,' GeV (max) =',F7.1,' GeV',/,9X,'y (min) =',
3039 & F7.3,8X,'(max) =',F7.3,/,9X,'Q^2 (min) =',F7.1,
3040 & ' GeV^2 (max) =',F7.1,' GeV^2',/,' (Lab) E_g (min) ='
3041 & ,F7.1,' GeV',/,' (Lab) theta (min) =',F7.4,8X,'(max) =',
3042 & F7.4,' for E_lpt >',F7.1,' GeV',/)
3044 * Lorentz-parameter for transf. into Lab
3045 BGTA(1) = PNUCL(1)/AAM(1)
3046 BGTA(2) = PNUCL(2)/AAM(1)
3047 BGTA(3) = PNUCL(3)/AAM(1)
3048 BGTA(4) = PNUCL(4)/AAM(1)
3049 * LT of incident lepton into Lab and dump it in DTEVT1
3050 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3051 & PLEPT0(1),PLEPT0(2),PLEPT0(3),PLEPT0(4),
3052 & PLTOT,PPL0(1),PPL0(2),PPL0(3),PPL0(4))
3053 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3054 & PNUCL(1),PNUCL(2),PNUCL(3),PNUCL(4),
3055 & PLTOT,PPA(1),PPA(2),PPA(3),PPA(4))
3056 * maximum energy of photon nucleon system
3057 PTOTGN = SQRT((YMAX*PPL0(1)+PPA(1))**2+(YMAX*PPL0(2)+PPA(2))**2
3058 & +(YMAX*PPL0(3)+PPA(3))**2)
3059 ETOTGN = YMAX*PPL0(4)+PPA(4)
3060 EGNMAX = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN))
3061 EGNMAX = MIN(EGNMAX,ECMAX)
3062 * minimum energy of photon nucleon system
3063 PTOTGN = SQRT((YMIN*PPL0(1)+PPA(1))**2+(YMIN*PPL0(2)+PPA(2))**2
3064 & +(YMIN*PPL0(3)+PPA(3))**2)
3065 ETOTGN = YMIN*PPL0(4)+PPA(4)
3066 EGNMIN = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN))
3067 EGNMIN = MAX(EGNMIN,ECMIN)
3069 * limits for Glauber-initialization
3071 Q2HI = MAX(Q2LI,MIN(Q2HI,Q2MAX))
3072 ECMLI = MAX(EGNMIN,THREE)
3074 WRITE(LOUT,1004) EGNMIN,EGNMAX,ECMLI,ECMHI,Q2LI,Q2HI
3075 1004 FORMAT(1X,'resulting limits:',/,9X,'W (min) =',F7.1,
3076 & ' GeV (max) =',F7.1,' GeV',/,/,' limits for ',
3077 & 'Glauber-initialization:',/,9X,'W (min) =',F7.1,
3078 & ' GeV (max) =',F7.1,' GeV',/,9X,'Q^2 (min) =',F7.1,
3079 & ' GeV^2 (max) =',F7.1,' GeV^2',/)
3080 * initialization of Glauber-formalism
3081 IF (NCOMPO.LE.0) THEN
3082 CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
3085 CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
3090 * initialization of run-statistics and histograms
3093 CALL PHO_PHIST(1000,DUM)
3095 * maximum photon-nucleus cross section
3099 IF (EGNMAX.GE.ECMNN(NEBINI)) THEN
3103 ELSEIF (EGNMAX.GT.ECMNN(1)) THEN
3105 IF (EGNMAX.LT.ECMNN(I)) THEN
3108 RAT = (EGNMAX-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
3114 SIGMAX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
3119 IF (EGNMIN.GE.ECMNN(NEBINI)) THEN
3123 ELSEIF (EGNMIN.GT.ECMNN(1)) THEN
3125 IF (EGNMIN.LT.ECMNN(I)) THEN
3128 RAT = (EGNMIN-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
3134 SIGXX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
3135 IF (SIGXX.GT.SIGMAX) EGNXX = EGNMIN
3136 SIGMAX = MAX(SIGMAX,SIGXX)
3137 WRITE(LOUT,'(9X,A,F8.3,A)') 'Sigma_tot (max) =',SIGMAX,' mb'
3139 * plot photon flux table
3144 ADY = LOG(YMAX/YMIN)/DBLE(MAXTAB-1)
3145 C WRITE(LOUT,'(/,1X,A)') 'LAEVT: photon flux '
3147 Y = EXP(AYMIN+ADY*DBLE(I-1))
3148 Q2LOW = MAX(Q2MIN,AMLPT2*Y**2/(ONE-Y))
3149 FF1 = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
3150 & -TWO*AMLPT2*Y*(ONE/Q2LOW-ONE/Q2MAX))
3151 FF2 = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
3152 & -TWO*(ONE-Y)/Y*(ONE-Q2LOW/Q2MAX))
3153 C WRITE(LOUT,'(5X,3E15.4)') Y,FF1,FF2
3156 * maximum residual weight for flux sampling (dy/y)
3158 Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY))
3159 WGHMAX = (ONE+(ONE-YY)**2)*LOG(Q2MAX/Q2LOW)
3160 & -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY
3162 CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY0)
3163 CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY1)
3164 CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY2)
3165 CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ0)
3166 CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ1)
3167 CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ2)
3168 CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE0)
3169 CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE1)
3170 CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE2)
3171 CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU0)
3172 CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU1)
3173 CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU2)
3175 CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX0)
3176 CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX1)
3177 CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX2)
3186 IF (MOD(IEVT,NMSG).EQ.0) THEN
3187 C OPEN(LDAT,FILE='/scrtch3/hr/sroesler/statusd5.out',
3188 C & STATUS='UNKNOWN')
3189 WRITE(LOUT,'(1X,I8,A)') IEVT-1,' events sampled'
3200 YY = EXP(AYRGE*DT_RNDM(RAT)+AYMIN)
3201 Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY))
3202 Q2LOG = LOG(Q2MAX/Q2LOW)
3203 WGH = (ONE+(ONE-YY)**2)*Q2LOG
3204 & -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY
3205 IF (WGHMAX.LT.WGH) WRITE(LOUT,1000) YY,WGHMAX,WGH
3206 1000 FORMAT(1X,'LAEVT: weight error!',3E12.5)
3207 IF (DT_RNDM(YY)*WGHMAX.GT.WGH) GOTO 101
3210 YEFF = ONE+(ONE-YY)**2
3212 Q2 = Q2LOW*EXP(Q2LOG*DT_RNDM(YY))
3213 WGH = (YEFF-TWO*(ONE-YY)*Q2LOW/Q2)/YEFF
3214 IF (WGH.LT.DT_RNDM(Q2)) GOTO 102
3217 c CALL DT_FILHGR(YY,ONE,IHFLY0,NC0)
3218 c CALL DT_FILHGR(Q2,ONE,IHFLQ0,NC0)
3220 * kinematics at lepton-photon vertex
3221 * scattered electron
3222 YQ2 = SQRT((ONE-YY)*Q2)
3223 Q2E = Q2/(4.0D0*PLEPT0(4))
3224 E1Y = (ONE-YY)*PLEPT0(4)
3225 CALL DT_DSFECF(SIF,COF)
3230 C THETA = ACOS( (E1Y-Q2E)/(E1Y+Q2E) )
3232 PGAMM(1) = -PLEPT1(1)
3233 PGAMM(2) = -PLEPT1(2)
3234 PGAMM(3) = PLEPT0(3)-PLEPT1(3)
3235 PGAMM(4) = PLEPT0(4)-PLEPT1(4)
3237 PTOTGN = SQRT( (PGAMM(1)+PNUCL(1))**2+(PGAMM(2)+PNUCL(2))**2
3238 & +(PGAMM(3)+PNUCL(3))**2 )
3239 ETOTGN = PGAMM(4)+PNUCL(4)
3240 ECMGN = (ETOTGN-PTOTGN)*(ETOTGN+PTOTGN)
3241 IF (ECMGN.LT.0.1D0) GOTO 101
3243 IF ((ECMGN.LT.ECMIN).OR.(ECMGN.GT.ECMAX)) GOTO 101
3245 * Lorentz-transformation into nucleon-rest system
3246 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3247 & PGAMM(1),PGAMM(2),PGAMM(3),PGAMM(4),
3248 & PGTOT,PPG(1),PPG(2),PPG(3),PPG(4))
3249 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3250 & PLEPT1(1),PLEPT1(2),PLEPT1(3),PLEPT1(4),
3251 & PLTOT,PPL1(1),PPL1(2),PPL1(3),PPL1(4))
3252 * temporary checks..
3253 Q2TMP = ABS(PPG(4)**2-PGTOT**2)
3254 IF (ABS(Q2-Q2TMP).GT.0.01D0) WRITE(LOUT,1001) Q2,Q2TMP
3255 1001 FORMAT(1X,'LAEVT: inconsistent kinematics (Q2,Q2TMP) ',
3257 ECMTMP = SQRT((PPG(4)+AAM(1)-PGTOT)*(PPG(4)+AAM(1)+PGTOT))
3258 IF (ABS(ECMGN-ECMTMP).GT.TINY10) WRITE(LOUT,1002) ECMGN,ECMTMP
3259 1002 FORMAT(1X,'LAEVT: inconsistent kinematics (ECMGN,ECMTMP) ',
3261 YYTMP = PPG(4)/PPL0(4)
3262 IF (ABS(YY-YYTMP).GT.0.01D0) WRITE(LOUT,1005) YY,YYTMP
3263 1005 FORMAT(1X,'LAEVT: inconsistent kinematics (YY,YYTMP) ',
3266 * lepton tagger (Lab)
3267 THETA = ACOS( PPL1(3)/PLTOT )
3268 IF (PPL1(4).GT.ELMIN) THEN
3269 IF ((THETA.LT.THMIN).OR.(THETA.GT.THMAX)) GOTO 101
3271 * photon energy-cut (Lab)
3272 IF (PPG(4).LT.EGMIN) GOTO 101
3273 IF (PPG(4).GT.EGMAX) GOTO 101
3275 XBJ = ABS(Q2/(1.876D0*PPG(4)))
3276 IF (XBJ.LT.XBJMIN) GOTO 101
3279 CALL DT_FILHGR( Q2,ONE,IHFLQ0,NC0)
3280 CALL DT_FILHGR( YY,ONE,IHFLY0,NC0)
3281 CALL DT_FILHGR( XBJ,ONE,IHFLX0,NC0)
3282 CALL DT_FILHGR(PPG(4),ONE,IHFLU0,NC0)
3283 CALL DT_FILHGR( ECMGN,ONE,IHFLE0,NC0)
3285 * rotation angles against z-axis
3287 C SID = SQRT((ONE-COD)*(ONE+COD))
3288 PPT = SQRT(PPG(1)**2+PPG(2)**2)
3292 IF (PGTOT*SID.GT.TINY10) THEN
3293 COF = PPG(1)/(SID*PGTOT)
3294 SIF = PPG(2)/(SID*PGTOT)
3295 ANORF = SQRT(COF*COF+SIF*SIF)
3300 IF (IXSTBL.EQ.0) THEN
3301 * change to photon projectile
3305 * re-initialize LTs with new kinematics
3306 * !!PGAMM ist set in cms (ECMGN) along z
3309 CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,ECMGN,0)
3312 * get emulsion component if requested
3313 IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
3314 * convolute with cross section
3315 CALL DT_SIGGAT(Q2LOW,EGNXX,STOTX,KKMAT)
3316 CALL DT_SIGGAT(Q2,ECMGN,STOT,KKMAT)
3317 IF (STOTX.LT.STOT) WRITE(LOUT,'(1X,A,/,6E12.3)')
3318 & 'LAEVT: warning STOTX<STOT ! ',Q2LOW,EGNMAX,STOTX,
3320 IF (DT_RNDM(Q2)*STOTX.GT.STOT) GOTO 100
3322 CALL DT_FILHGR( Q2,ONE,IHFLQ1,NC1)
3323 CALL DT_FILHGR( YY,ONE,IHFLY1,NC1)
3324 CALL DT_FILHGR( XBJ,ONE,IHFLX1,NC1)
3325 CALL DT_FILHGR(PPG(4),ONE,IHFLU1,NC1)
3326 CALL DT_FILHGR( ECMGN,ONE,IHFLE1,NC1)
3327 * composite targets only
3330 CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IJPROJ,EPN,KKMAT,
3332 * rotate momenta of final state particles back in photon-nucleon syst.
3333 DO 4 I=NPOINT(4),NHKK
3334 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
3335 & (ISTHKK(I).EQ.1001)) THEN
3339 CALL DT_MYTRAN(1,PX,PY,PZ,COD,SID,COF,SIF,
3340 & PHKK(1,I),PHKK(2,I),PHKK(3,I))
3345 CALL DT_FILHGR( Q2,ONE,IHFLQ2,NC1)
3346 CALL DT_FILHGR( YY,ONE,IHFLY2,NC1)
3347 CALL DT_FILHGR( XBJ,ONE,IHFLX2,NC1)
3348 CALL DT_FILHGR(PPG(4),ONE,IHFLU2,NC1)
3349 CALL DT_FILHGR( ECMGN,ONE,IHFLE2,NC1)
3351 * dump this event to histograms
3353 CALL PHO_PHIST(2000,DUM)
3357 WGY = ALPHEM/TWOPI*WGHMAX*DBLE(ITRY)/DBLE(ITRW)
3358 WGY = WGY*LOG(YMAX/YMIN)
3359 WEIGHT = WGY*SIGMAX*DBLE(NEVTS)/DBLE(ITRY)
3361 C HEADER = ' LAEVT: Q^2 distribution 0'
3362 C CALL DT_OUTHGR(IHFLQ0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3363 C HEADER = ' LAEVT: Q^2 distribution 1'
3364 C CALL DT_OUTHGR(IHFLQ1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3365 C HEADER = ' LAEVT: Q^2 distribution 2'
3366 C CALL DT_OUTHGR(IHFLQ2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3367 C HEADER = ' LAEVT: y distribution 0'
3368 C CALL DT_OUTHGR(IHFLY0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3369 C HEADER = ' LAEVT: y distribution 1'
3370 C CALL DT_OUTHGR(IHFLY1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3371 C HEADER = ' LAEVT: y distribution 2'
3372 C CALL DT_OUTHGR(IHFLY2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3373 C HEADER = ' LAEVT: x distribution 0'
3374 C CALL DT_OUTHGR(IHFLX0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3375 C HEADER = ' LAEVT: x distribution 1'
3376 C CALL DT_OUTHGR(IHFLX1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3377 C HEADER = ' LAEVT: x distribution 2'
3378 C CALL DT_OUTHGR(IHFLX2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3379 C HEADER = ' LAEVT: E_g distribution 0'
3380 C CALL DT_OUTHGR(IHFLU0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3381 C HEADER = ' LAEVT: E_g distribution 1'
3382 C CALL DT_OUTHGR(IHFLU1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3383 C HEADER = ' LAEVT: E_g distribution 2'
3384 C CALL DT_OUTHGR(IHFLU2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3385 C HEADER = ' LAEVT: E_c distribution 0'
3386 C CALL DT_OUTHGR(IHFLE0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3387 C HEADER = ' LAEVT: E_c distribution 1'
3388 C CALL DT_OUTHGR(IHFLE1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3389 C HEADER = ' LAEVT: E_c distribution 2'
3390 C CALL DT_OUTHGR(IHFLE2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3392 * print run-statistics and histograms to output-unit 6
3394 CALL PHO_PHIST(3000,DUM)
3396 IF (IXSTBL.EQ.0) CALL DT_STATIS(2)
3401 *$ CREATE DT_DTUINI.FOR
3404 *===dtuini=============================================================*
3406 SUBROUTINE DT_DTUINI(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
3409 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3412 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
3414 * emulsion treatment
3415 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
3418 * Glauber formalism: flags and parameters for statistics
3421 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
3423 CALL DT_INIT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,IGLAU)
3426 CALL PHO_PHIST(1000,DUM)
3428 IF (NCOMPO.LE.0) THEN
3429 CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
3432 CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
3435 IF (IOGLB.NE.100) CALL DT_SIGEMU
3441 *$ CREATE DT_DTUOUT.FOR
3444 *===dtuout=============================================================*
3446 SUBROUTINE DT_DTUOUT
3448 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3451 CALL PHO_PHIST(3000,DUM)
3458 *$ CREATE DT_BEAMPR.FOR
3461 *===beampr=============================================================*
3463 SUBROUTINE DT_BEAMPR(WHAT,PLAB,MODE)
3465 ************************************************************************
3466 * Initialization of event generation *
3467 * This version dated 7.4.98 is written by S. Roesler. *
3468 ************************************************************************
3470 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3473 PARAMETER ( LINP = 10 ,
3477 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
3478 PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
3484 PARAMETER (NMXHKK=200000)
3486 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3487 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3488 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3490 * extended event history
3491 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3492 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3495 * properties of interacting particles
3496 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
3498 * particle properties (BAMJET index convention)
3500 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
3501 & IICH(210),IIBAR(210),K1(210),K2(210)
3504 COMMON /DTBEAM/ P1(4),P2(4)
3506 C DIMENSION WHAT(6),P1(4),P2(4),P1CMS(4),P2CMS(4)
3507 DIMENSION WHAT(6),P1CMS(4),P2CMS(4)
3509 DATA LBEAM /.FALSE./
3516 IF (E1.LT.ZERO) E1 = DBLE(IPZ)/DBLE(IP)*ABS(WHAT(1))
3518 IF (E2.LT.ZERO) E2 = DBLE(ITZ)/DBLE(IT)*ABS(WHAT(2))
3519 PP1 = SQRT( (E1+AAM(IJPROJ))*(E1-AAM(IJPROJ)) )
3520 PP2 = SQRT( (E2+AAM(IJTARG))*(E2-AAM(IJTARG)) )
3521 TH = 1.D-6*WHAT(3)/2.D0
3523 P1(1) = PP1*SIN(TH)*COS(PH)
3524 P1(2) = PP1*SIN(TH)*SIN(PH)
3527 P2(1) = PP2*SIN(TH)*COS(PH)
3528 P2(2) = PP2*SIN(TH)*SIN(PH)
3529 P2(3) = -PP2*COS(TH)
3531 ECM = SQRT( (P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))**2
3532 & -(P1(3)+P2(3))**2 )
3533 ELAB = (ECM**2-AAM(IJPROJ)**2-AAM(IJTARG)**2)/(2.0D0*AAM(IJTARG))
3534 PLAB = SQRT( (ELAB+AAM(IJPROJ))*(ELAB-AAM(IJPROJ)) )
3535 BGX = (P1(1)+P2(1))/ECM
3536 BGY = (P1(2)+P2(2))/ECM
3537 BGZ = (P1(3)+P2(3))/ECM
3538 BGE = (P1(4)+P2(4))/ECM
3539 CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P1(1),P1(2),P1(3),P1(4),
3540 & P1TOT,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4))
3541 CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P2(1),P2(2),P2(3),P2(4),
3542 & P2TOT,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4))
3543 COD = P1CMS(3)/P1TOT
3544 C SID = SQRT((ONE-COD)*(ONE+COD))
3545 PPT = SQRT(P1CMS(1)**2+P1CMS(2)**2)
3549 IF (P1TOT*SID.GT.TINY10) THEN
3550 COF = P1CMS(1)/(SID*P1TOT)
3551 SIF = P1CMS(2)/(SID*P1TOT)
3552 ANORF = SQRT(COF*COF+SIF*SIF)
3557 C WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
3558 C WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
3559 C WRITE(LOUT,'(5E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),P1TOT
3560 C WRITE(LOUT,'(5E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),P2TOT
3564 C PAE = SQRT(AAM(IJPROJ)**2+PAZ**2)
3568 C PBE = SQRT(AAM(IJTARG)**2+PBZ**2)
3569 C WRITE(LOUT,'(4E15.4)') PAX,PAY,PAZ,PAE
3570 C WRITE(LOUT,'(4E15.4)') PBX,PBY,PBZ,PBE
3571 C CALL DT_MYTRAN(1,PAX,PAY,PAZ,COD,SID,COF,SIF,
3572 C & P1CMS(1),P1CMS(2),P1CMS(3))
3573 C CALL DT_MYTRAN(1,PBX,PBY,PBZ,COD,SID,COF,SIF,
3574 C & P2CMS(1),P2CMS(2),P2CMS(3))
3575 C WRITE(LOUT,'(4E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4)
3576 C WRITE(LOUT,'(4E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4)
3577 C CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),
3578 C & P1TOT,P1(1),P1(2),P1(3),P1(4))
3579 C CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),
3580 C & P2TOT,P2(1),P2(2),P2(3),P2(4))
3581 C WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
3582 C WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
3593 IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
3594 DO 20 I=NPOINT(4),NHKK
3595 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
3596 & (ISTHKK(I).EQ.1001)) THEN
3597 CALL DT_MYTRAN(1,PHKK(1,I),PHKK(2,I),PHKK(3,I),
3598 & COD,SID,COF,SIF,PXCMS,PYCMS,PZCMS)
3600 CALL DT_DALTRA(BGE,BGX,BGY,BGZ,PXCMS,PYCMS,PZCMS,PECMS,
3601 & PTOT,PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I))
3611 *$ CREATE DT_REJUCO.FOR
3614 *===rejuco=============================================================*
3616 SUBROUTINE DT_REJUCO(MODE,IREJ)
3618 ************************************************************************
3619 * REJection of Unphysical COnfigurations *
3620 * MODE = 1 rejection of particles with unphysically large energy *
3622 * This version dated 27.12.2006 is written by S. Roesler. *
3623 ************************************************************************
3625 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3628 PARAMETER ( LINP = 10 ,
3632 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
3633 PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
3635 * maximum x_cms of final state particle
3636 PARAMETER (XCMSMX = 1.4D0)
3640 PARAMETER (NMXHKK=200000)
3642 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3643 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3644 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3646 * extended event history
3647 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3648 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3651 * Lorentz-parameters of the current interaction
3652 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
3653 & UMO,PPCM,EPROJ,PPROJ
3658 IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
3660 DO 10 I=NPOINT(4),NHKK
3661 IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDHKK(I).NE.80000)) THEN
3662 XCMS = ABS(PHKK(4,I))/ECMHLF
3663 IF (XCMS.GT.XCMSMX) GOTO 9999
3673 *$ CREATE DT_EVENTB.FOR
3676 *===eventb=============================================================*
3678 SUBROUTINE DT_EVENTB(NCSY,IREJ)
3680 ************************************************************************
3681 * Treatment of nucleon-nucleon interactions with full two-component *
3682 * Dual Parton Model. *
3683 * NCSY number of nucleon-nucleon interactions *
3684 * IREJ rejection flag *
3685 * This version dated 14.01.2000 is written by S. Roesler *
3686 ************************************************************************
3688 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3691 PARAMETER ( LINP = 10 ,
3695 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
3699 PARAMETER (NMXHKK=200000)
3701 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3702 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3703 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3705 * extended event history
3706 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3707 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3709 *! uncomment this line for internal phojet-fragmentation
3710 C #include "dtu_dtevtp.inc"
3712 * particle properties (BAMJET index convention)
3714 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
3715 & IICH(210),IIBAR(210),K1(210),K2(210)
3717 * flags for input different options
3718 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
3719 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
3720 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
3723 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
3724 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
3725 & IREXCI(3),IRDIFF(2),IRINC
3727 * properties of interacting particles
3728 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
3730 * properties of photon/lepton projectiles
3731 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
3733 * various options for treatment of partons (DTUNUC 1.x)
3734 * (chain recombination, Cronin,..)
3735 LOGICAL LCO2CR,LINTPT
3736 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
3740 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
3741 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
3744 * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
3745 COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
3747 * Glauber formalism: collision properties
3748 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
3749 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
3751 * flags for diffractive interactions (DTUNUC 1.x)
3752 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
3754 * statistics: double-Pomeron exchange
3755 COMMON /DTFLG2/ INTFLG,IPOPO
3757 * flags for particle decays
3758 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
3759 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
3760 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
3762 * nucleon-nucleon event-generator
3765 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
3767 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
3768 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
3769 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
3770 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
3771 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
3773 C model switches and parameters
3775 INTEGER ISWMDL,IPAMDL
3776 DOUBLE PRECISION PARMDL
3777 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
3779 C initial state parton radiation (internal part)
3780 INTEGER MXISR3,MXISR4
3781 PARAMETER ( MXISR3 = 50, MXISR4 = 100 )
3782 INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC
3783 DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT
3784 COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3),
3785 & ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3),
3786 & IFL1(2,MXISR3),IFL2(2,MXISR3),
3787 & IBRA(2,MXISR4),IFANO(2),ISH(2),NACC
3789 C event debugging information
3791 PARAMETER (NMAXD=100)
3792 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
3793 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3794 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
3795 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3797 C general process information
3798 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
3799 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
3801 DIMENSION PP(4),PT(4),PTOT(4),PP1(4),PP2(4),PT1(4),PT2(4),
3802 & PPNN(4),PTNN(4),PTOTNN(4),PPSUB(4),PTSUB(4),
3803 & PPTCMS(4),PTTCMS(4),PPTMP(4),PTTMP(4),
3804 & KPRON(15),ISINGL(2000)
3806 * initial values for max. number of phojet scatterings and dtunuc chains
3807 * to be fragmented with one pyexec call
3808 DATA MXPHFR,MXDTFR /10,100/
3811 * pointer to first parton of the first chain in dtevt common
3813 * special flag for double-Pomeron statistics
3815 * counter for low-mass (DTUNUC) interactions
3817 * counter for interactions treated by PHOJET
3820 * scan interactions for single nucleon-nucleon interactions
3821 * (this has to be checked here because Cronin modifies parton momenta)
3823 IF (NCSY.GT.2000) STOP ' DT_EVENTB: NCSY > 2000 ! '
3827 MOT = JMOHKK(1,NC+1)
3828 DIFF1 = ABS(PHKK(4,MOP)-PHKK(4, NC)-PHKK(4,NC+2))
3829 DIFF2 = ABS(PHKK(4,MOT)-PHKK(4,NC+1)-PHKK(4,NC+3))
3830 IF ((DIFF1.LT.TINY10).AND.(DIFF2.LT.TINY10)) ISINGL(I) = 1
3834 * multiple scattering of chain ends
3835 IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
3836 IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
3838 * switch to PHOJET-settings for JETSET parameter
3841 * loop over nucleon-nucleon interaction
3845 * pick up one nucleon-nucleon interaction from DTEVT1
3846 * ppnn / ptnn - momenta of the interacting nucleons (cms)
3847 * ptotnn - total momentum of the interacting nucleons (cms)
3848 * pp1,2 / pt1,2 - momenta of the four partons
3849 * pp / pt - total momenta of the proj / targ partons
3850 * ptot - total momentum of the four partons
3852 MOT = JMOHKK(1,NC+1)
3854 PPNN(K) = PHKK(K,MOP)
3855 PTNN(K) = PHKK(K,MOT)
3856 PTOTNN(K) = PPNN(K)+PTNN(K)
3858 PT1(K) = PHKK(K,NC+1)
3859 PP2(K) = PHKK(K,NC+2)
3860 PT2(K) = PHKK(K,NC+3)
3861 PP(K) = PP1(K)+PP2(K)
3862 PT(K) = PT1(K)+PT2(K)
3863 PTOT(K) = PP(K)+PT(K)
3866 *-----------------------------------------------------------------------
3867 * this is a complete nucleon-nucleon interaction
3869 IF (ISINGL(I).EQ.1) THEN
3871 * initialize PHOJET-variables for remnant/valence-partons
3878 * save current settings of PHOJET process and min. bias flags
3880 KPRON(K) = IPRON(K,1)
3884 * check if forced sampling of diffractive interaction requested
3885 IF (ISINGD.LT.-1) THEN
3889 IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-3)) IPRON(5,1) = 1
3890 IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-4)) IPRON(6,1) = 1
3891 IF (ISINGD.EQ.-5) IPRON(4,1) = 1
3894 * for photons: a direct/anomalous interaction is not sampled
3895 * in PHOJET but already in Glauber-formalism. Here we check if such
3896 * an interaction is requested
3897 IF (IJPROJ.EQ.7) THEN
3898 * first switch off direct interactions
3900 * this is a direct interactions
3901 IF (IDIREC.EQ.1) THEN
3906 * this is an anomalous interactions
3907 * (iswmdl(2) = 0 only hard int. generated ( = 1 min. bias) )
3908 ELSEIF (IDIREC.EQ.2) THEN
3912 IF (IDIREC.NE.0) STOP ' DT_EVENTB: IDIREC > 0 ! '
3915 * make sure that total momenta of partons, pp and pt, are on mass
3916 * shell (Cronin may have srewed this up..)
3917 CALL DT_MASHEL(PP,PT,PHKK(5,MOP),PHKK(5,MOT),PPNN,PTNN,IR1)
3919 IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A)')
3920 & 'EVENTB: mass shell correction rejected'
3924 * initialize the incoming particles in PHOJET
3925 IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
3927 CALL PHO_SETPAR(1,22,0,VIRT)
3931 CALL PHO_SETPAR(1,IDHKK(MOP),0,ZERO)
3935 CALL PHO_SETPAR(2,IDHKK(MOT),0,ZERO)
3938 * initialize rejection loop counter for anomalous processes
3943 * temporary fix for ifano problem
3947 * generate complete hadron/nucleon/photon-nucleon event with PHOJET
3949 CALL PHO_EVENT(2,PPNN,PTNN,DUM,IREJ1)
3952 * for photons: special consistency check for anomalous interactions
3953 IF (IJPROJ.EQ.7) THEN
3954 IF (IRJANO.LT.30) THEN
3955 IF (IFANO(1).NE.0) THEN
3956 * here, an anomalous interaction was generated. Check if it
3957 * was also requested. Otherwise reject this event.
3958 IF (IDIREC.EQ.0) GOTO 800
3960 * here, an anomalous interaction was not generated. Check if it
3961 * was requested in which case we need to reject this event.
3962 IF (IDIREC.EQ.2) GOTO 800
3965 WRITE(LOUT,*) ' DT_EVENTB: Warning! IRJANO > 30 ',
3966 & IRJANO,IDIREC,NEVHKK
3970 * copy back original settings of PHOJET process and min. bias flags
3972 IPRON(K,1) = KPRON(K)
3976 * check if PHOJET has rejected this event
3977 IF (IREJ1.NE.0) THEN
3978 C IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
3979 WRITE(LOUT,'(1X,A,I4)')
3980 & 'EVENTB: chain system rejected',IDIREC
3987 * copy partons and strings from PHOJET common back into DTEVT for
3988 * external fragmentation
3991 *! uncomment this line for internal phojet-fragmentation
3992 C CALL DT_GETFSP(MO1,MO2,PPNN,PTNN,-1)
3994 CALL DT_GETPJE(MO1,MO2,PPNN,PTNN,-1,NPHOSC,IREJ1)
3995 IF (IREJ1.NE.0) THEN
3997 & WRITE(LOUT,'(1X,A,I4)') 'EVENTB: chain system rejected 1'
4001 * update statistics counter
4002 ICEVTG(IDCH(NC),29) = ICEVTG(IDCH(NC),29)+1
4004 *-----------------------------------------------------------------------
4005 * this interaction involves "remnants"
4009 * total mass of this system
4010 PPTOT = SQRT(PTOT(1)**2+PTOT(2)**2+PTOT(3)**2)
4011 AMTOT2 = (PTOT(4)-PPTOT)*(PTOT(4)+PPTOT)
4012 IF (AMTOT2.LT.ZERO) THEN
4015 AMTOT = SQRT(AMTOT2)
4018 * systems with masses larger than elojet are treated with PHOJET
4019 IF (AMTOT.GT.ELOJET) THEN
4021 * initialize PHOJET-variables for remnant/valence-partons
4022 * projectile parton flavors and valence flag
4023 IHFLD(1,1) = IDHKK(NC)
4024 IHFLD(1,2) = IDHKK(NC+2)
4026 IF ((IDCH(NC).EQ.6).OR.(IDCH(NC).EQ.7)
4027 & .OR.(IDCH(NC).EQ.8)) IHFLS(1) = 1
4028 * target parton flavors and valence flag
4029 IHFLD(2,1) = IDHKK(NC+1)
4030 IHFLD(2,2) = IDHKK(NC+3)
4032 IF ((IDCH(NC).EQ.4).OR.(IDCH(NC).EQ.5)
4033 & .OR.(IDCH(NC).EQ.8)) IHFLS(2) = 1
4034 * flag signalizing PHOJET how to treat the remnant:
4035 * iremn = -1 sea-quark remnant: PHOJET takes flavors from ihfld
4036 * iremn > -1 valence remnant: PHOJET assumes flavors according
4037 * to mother particle
4041 * initialize the incoming particles in PHOJET
4042 IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
4044 CALL PHO_SETPAR(1,22,IREMN1,VIRT)
4048 CALL PHO_SETPAR(1,IDHKK(MOP),IREMN1,ZERO)
4052 CALL PHO_SETPAR(2,IDHKK(MOT),IREMN2,ZERO)
4055 * calculate Lorentz parameter of the nucleon-nucleon cm-system
4056 PPTOTN = SQRT(PTOTNN(1)**2+PTOTNN(2)**2+PTOTNN(3)**2)
4057 AMNN = SQRT( (PTOTNN(4)-PPTOTN)*(PTOTNN(4)+PPTOTN) )
4058 BGX = PTOTNN(1)/AMNN
4059 BGY = PTOTNN(2)/AMNN
4060 BGZ = PTOTNN(3)/AMNN
4061 GAM = PTOTNN(4)/AMNN
4062 * transform interacting nucleons into nucleon-nucleon cm-system
4063 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
4064 & PPNN(1),PPNN(2),PPNN(3),PPNN(4),PPCMS,
4065 & PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4))
4066 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
4067 & PTNN(1),PTNN(2),PTNN(3),PTNN(4),PTCMS,
4068 & PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4))
4069 * transform (total) momenta of the proj and targ partons into
4070 * nucleon-nucleon cm-system
4071 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
4072 & PP(1),PP(2),PP(3),PP(4),
4073 & PPTSUB,PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4))
4074 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
4075 & PT(1),PT(2),PT(3),PT(4),
4076 & PTTSUB,PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4))
4077 * energy fractions of the proj and targ partons
4078 XPSUB = MIN(PPSUB(4)/PPTCMS(4),ONE)
4079 XTSUB = MIN(PTSUB(4)/PTTCMS(4),ONE)
4082 c PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
4083 c & (PPTCMS(2)+PTTCMS(2))**2 +
4084 c & (PPTCMS(3)+PTTCMS(3))**2 )
4085 c EOLDCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
4086 c & (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
4087 c PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
4088 c & (PPSUB(2)+PTSUB(2))**2 +
4089 c & (PPSUB(3)+PTSUB(3))**2 )
4090 c EOLDSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
4091 c & (PPSUB(4)+PTSUB(4)+PTOTSU) )
4094 * save current settings of PHOJET process and min. bias flags
4096 KPRON(K) = IPRON(K,1)
4098 * disallow direct photon int. (does not make sense here anyway)
4100 * disallow double pomeron processes (due to technical problems
4101 * in PHOJET, needs to be solved sometime)
4103 * disallow diffraction for sea-diquarks
4104 IF ((IABS(IHFLD(1,1)).GT.1100).AND.
4105 & (IABS(IHFLD(1,2)).GT.1100)) THEN
4109 IF ((IABS(IHFLD(2,1)).GT.1100).AND.
4110 & (IABS(IHFLD(2,2)).GT.1100)) THEN
4115 * we need massless partons: transform them on mass shell
4122 CALL DT_MASHEL(PPTMP,PTTMP,XMP,XMT,PPSUB,PTSUB,IREJ1)
4123 PPSUTO = SQRT(PPSUB(1)**2+PPSUB(2)**2+PPSUB(3)**2)
4124 PTSUTO = SQRT(PTSUB(1)**2+PTSUB(2)**2+PTSUB(3)**2)
4125 PSUTOT = SQRT((PPSUB(1)+PTSUB(1))**2+
4126 & (PPSUB(2)+PTSUB(2))**2+(PPSUB(3)+PTSUB(3))**2)
4127 * total energy of the subsysten after mass transformation
4128 * (should be the same as before..)
4129 SECM = SQRT( (PPSUB(4)+PTSUB(4)-PSUTOT)*
4130 & (PPSUB(4)+PTSUB(4)+PSUTOT) )
4132 * after mass shell transformation the x_sub - relation has to be
4133 * corrected. We therefore create "pseudo-momenta" of mother-nucleons.
4135 * The old version was to scale based on the original x_sub and the
4136 * 4-momenta of the subsystem. At very high energy this could lead to
4137 * "pseudo-cm energies" of the parent system considerably exceeding
4138 * the true cm energy. Now we keep the true cm energy and calculate
4139 * new x_sub instead.
4140 C old version PPTCMS(4) = PPSUB(4)/XPSUB
4141 PPTCMS(4) = MAX(PPTCMS(4),PPSUB(4))
4142 XPSUB = PPSUB(4)/PPTCMS(4)
4143 IF (IJPROJ.EQ.7) THEN
4144 AMP2 = PHKK(5,MOT)**2
4145 PTOT1 = SQRT(PPTCMS(4)**2-AMP2)
4148 PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOP))
4149 & *(PPTCMS(4)+PHKK(5,MOP)))
4150 C PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOT))
4151 C & *(PPTCMS(4)+PHKK(5,MOT)))
4153 C old version PTTCMS(4) = PTSUB(4)/XTSUB
4154 PTTCMS(4) = MAX(PTTCMS(4),PTSUB(4))
4155 XTSUB = PTSUB(4)/PTTCMS(4)
4156 PTOT2 = SQRT((PTTCMS(4)-PHKK(5,MOT))
4157 & *(PTTCMS(4)+PHKK(5,MOT)))
4159 PPTCMS(K) = PTOT1*PPSUB(K)/PPSUTO
4160 PTTCMS(K) = PTOT2*PTSUB(K)/PTSUTO
4165 * ppnn / ptnn - momenta of the int. nucleons (cms, negl. Fermi)
4166 * ptotnn - total momentum of the int. nucleons (cms, negl. Fermi)
4167 * pptcms/ pttcms - momenta of the interacting nucleons (cms)
4168 * pp1,2 / pt1,2 - momenta of the four partons
4170 * pp / pt - total momenta of the pr/ta partons (cms, negl. Fermi)
4171 * ptot - total momentum of the four partons (cms, negl. Fermi)
4172 * ppsub / ptsub - total momenta of the proj / targ partons (cms)
4174 c PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
4175 c & (PPTCMS(2)+PTTCMS(2))**2 +
4176 c & (PPTCMS(3)+PTTCMS(3))**2 )
4177 c ENEWCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
4178 c & (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
4179 c PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
4180 c & (PPSUB(2)+PTSUB(2))**2 +
4181 c & (PPSUB(3)+PTSUB(3))**2 )
4182 c ENEWSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
4183 c & (PPSUB(4)+PTSUB(4)+PTOTSU) )
4184 c IF (ENEWCM/EOLDCM.GT.1.1D0) THEN
4185 c WRITE(*,*) ' EOLDCM, ENEWCM : ',EOLDCM,ENEWCM
4186 c WRITE(*,*) ' EOLDSU, ENEWSU : ',EOLDSU,ENEWSU
4187 c WRITE(*,*) ' XPSUB, XTSUB : ',XPSUB,XTSUB
4189 c BBGX = (PPTCMS(1)+PTTCMS(1))/ENEWCM
4190 c BBGY = (PPTCMS(2)+PTTCMS(2))/ENEWCM
4191 c BBGZ = (PPTCMS(3)+PTTCMS(3))/ENEWCM
4192 c BGAM = (PPTCMS(4)+PTTCMS(4))/ENEWCM
4193 * transform interacting nucleons into nucleon-nucleon cm-system
4194 c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
4195 c & PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4),PPTOT,
4196 c & PPNEW1,PPNEW2,PPNEW3,PPNEW4)
4197 c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
4198 c & PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4),PTTOT,
4199 c & PTNEW1,PTNEW2,PTNEW3,PTNEW4)
4200 c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
4201 c & PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4),PPTOT,
4202 c & PPSUB1,PPSUB2,PPSUB3,PPSUB4)
4203 c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
4204 c & PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4),PTTOT,
4205 c & PTSUB1,PTSUB2,PTSUB3,PTSUB4)
4206 c PTSTCM = SQRT( (PPNEW1+PTNEW1)**2 +
4207 c & (PPNEW2+PTNEW2)**2 +
4208 c & (PPNEW3+PTNEW3)**2 )
4209 c ETSTCM = SQRT( (PPNEW4+PTNEW4-PTSTCM) *
4210 c & (PPNEW4+PTNEW4+PTSTCM) )
4211 c PTSTSU = SQRT( (PPSUB1+PTSUB1)**2 +
4212 c & (PPSUB2+PTSUB2)**2 +
4213 c & (PPSUB3+PTSUB3)**2 )
4214 c ETSTSU = SQRT( (PPSUB4+PTSUB4-PTSTSU) *
4215 c & (PPSUB4+PTSUB4+PTSTSU) )
4216 C WRITE(*,*) ' mother cmE :'
4217 C WRITE(*,*) ETSTCM,ENEWCM
4218 C WRITE(*,*) ' subsystem cmE :'
4219 C WRITE(*,*) ETSTSU,ENEWSU
4220 C WRITE(*,*) ' projectile mother :'
4221 C WRITE(*,*) PPNEW1,PPNEW2,PPNEW3,PPNEW4
4222 C WRITE(*,*) ' target mother :'
4223 C WRITE(*,*) PTNEW1,PTNEW2,PTNEW3,PTNEW4
4224 C WRITE(*,*) ' projectile subsystem:'
4225 C WRITE(*,*) PPSUB1,PPSUB2,PPSUB3,PPSUB4
4226 C WRITE(*,*) ' target subsystem:'
4227 C WRITE(*,*) PTSUB1,PTSUB2,PTSUB3,PTSUB4
4228 C WRITE(*,*) ' projectile subsystem should be:'
4229 C WRITE(*,*) ZERO,ZERO,XPSUB*ETSTCM/2.0D0,
4230 C & XPSUB*ETSTCM/2.0D0
4231 C WRITE(*,*) ' target subsystem should be:'
4232 C WRITE(*,*) ZERO,ZERO,-XTSUB*ETSTCM/2.0D0,
4233 C & XTSUB*ETSTCM/2.0D0
4234 C WRITE(*,*) ' subsystem cmE should be: '
4235 C WRITE(*,*) SQRT(XPSUB*XTSUB)*ETSTCM,XPSUB,XTSUB
4238 * generate complete remnant - nucleon/remnant event with PHOJET
4240 CALL PHO_EVENT(3,PPTCMS,PTTCMS,DUM,IREJ1)
4243 * copy back original settings of PHOJET process flags
4245 IPRON(K,1) = KPRON(K)
4248 * check if PHOJET has rejected this event
4249 IF (IREJ1.NE.0) THEN
4251 & WRITE(LOUT,'(1X,A)') 'EVENTB: chain system rejected'
4253 & 'XPSUB,XTSUB,SECM ',XPSUB,XTSUB,SECM,AMTOT
4260 * copy partons and strings from PHOJET common back into DTEVT for
4261 * external fragmentation
4264 *! uncomment this line for internal phojet-fragmentation
4265 C CALL DT_GETFSP(MO1,MO2,PP,PT,1)
4267 CALL DT_GETPJE(MO1,MO2,PP,PT,1,NPHOSC,IREJ1)
4268 IF (IREJ1.NE.0) THEN
4269 IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
4270 & 'EVENTB: chain system rejected 2'
4274 * update statistics counter
4275 ICEVTG(IDCH(NC),2) = ICEVTG(IDCH(NC),2)+1
4277 *-----------------------------------------------------------------------
4278 * two-chain approx. for smaller systems
4283 * special flag for double-Pomeron statistics
4286 * pick up flavors at the ends of the two chains
4291 * ..and the indices of the mothers
4296 CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
4297 & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
4299 * check if this chain system was rejected
4300 IF (IREJ1.GT.0) THEN
4301 IF (IOULEV(1).GT.0) THEN
4302 WRITE(LOUT,*) 'rejected 1 in EVENTB'
4303 WRITE(LOUT,'(1X,4(I6,4E12.3,/),E12.3)')
4304 & IFP1,PP1,IFT1,PT1,IFP2,PP2,IFT2,PT2,AMTOT
4309 * the following lines are for sea-sea chains rejected in GETCSY
4310 IF (IREJ1.EQ.-1) NDTUSC = NDTUSC-1
4311 ICEVTG(IDCH(NC),1) = ICEVTG(IDCH(NC),1)+1
4316 * update statistics counter
4317 ICEVTG(IDCH(NC),0) = ICEVTG(IDCH(NC),0)+1
4323 *-----------------------------------------------------------------------
4324 * treatment of low-mass chains (if there are any)
4326 IF (NDTUSC.GT.0) THEN
4328 * correct chains of very low masses for possible resonances
4329 IF (IRESCO.EQ.1) THEN
4330 CALL DT_EVTRES(IREJ1)
4331 IF (IREJ1.GT.0) THEN
4332 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2a in EVENTB'
4333 IRRES(1) = IRRES(1)+1
4337 * fragmentation of low-mass chains
4338 *! uncomment this line for internal phojet-fragmentation
4339 * (of course it will still be fragmented by DPMJET-routines but it
4340 * has to be done here instead of further below)
4341 C CALL DT_EVTFRA(IREJ1)
4342 C IF (IREJ1.GT.0) THEN
4343 C IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2b in EVENTB'
4348 *! uncomment this line for internal phojet-fragmentation
4349 C NPOINT(4) = NHKK+1
4350 IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
4353 *-----------------------------------------------------------------------
4354 * new di-quark breaking mechanisms
4358 IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
4359 & .OR.(PDBSEA(3).GT.0.0D0)) THEN
4364 *-----------------------------------------------------------------------
4365 * hadronize this event
4367 * hadronize PHOJET chain systems
4369 NPJE = NPHOSC/MXPHFR
4370 IF (MXPHFR.LT.MXLEFT) MXLEFT = 2
4372 NLEFT = NPHOSC-NPJE*MXPHFR
4375 IF ((JFRG.EQ.NPJE).AND.(NLEFT.LE.MXLEFT)) THEN
4376 CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4377 IF (IREJ1.GT.0) GOTO 22
4380 CALL DT_EVTFRG(1,NFRG,NPYMEM,IREJ1)
4381 IF (IREJ1.GT.0) GOTO 22
4383 IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4385 IF (NLEFT.GT.0) THEN
4386 CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4387 IF (IREJ1.GT.0) GOTO 22
4388 IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4391 CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4392 IF (IREJ1.GT.0) GOTO 22
4393 IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4396 * check max. filling level of jetset common and
4397 * reduce mxphfr if necessary
4398 IF (NPYMAX.GT.3000) THEN
4399 IF (NPYMAX.GT.3500) THEN
4400 MXPHFR = MAX(1,MXPHFR-2)
4402 MXPHFR = MAX(1,MXPHFR-1)
4404 C WRITE(LOUT,*) ' EVENTB: Mxphfr reduced to ',MXPHFR
4407 * hadronize DTUNUC chain systems
4410 CALL DT_EVTFRG(2,IBACK,NPYMEM,IREJ2)
4411 IF (IREJ2.GT.0) GOTO 22
4413 * check max. filling level of jetset common and
4414 * reduce mxdtfr if necessary
4415 IF (NPYMEM.GT.3000) THEN
4416 IF (NPYMEM.GT.3500) THEN
4417 MXDTFR = MAX(1,MXDTFR-20)
4419 MXDTFR = MAX(1,MXDTFR-10)
4421 C WRITE(LOUT,*) ' EVENTB: Mxdtfr reduced to ',MXDTFR
4424 IF (IBACK.EQ.-1) GOTO 23
4427 C CALL DT_EVTFRG(1,IREJ1)
4428 C CALL DT_EVTFRG(2,IREJ2)
4429 IF ((IREJ1.GT.0).OR.(IREJ2.GT.0)) THEN
4430 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTB'
4435 * get final state particles from /DTEVTP/
4436 *! uncomment this line for internal phojet-fragmentation
4437 C CALL DT_GETFSP(IDUM,IDUM,PP,PT,2)
4440 & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,88,IREJ3)
4441 C IF (IREJ3.NE.0) GOTO 9999
4451 *$ CREATE DT_GETPJE.FOR
4454 *===getpje=============================================================*
4456 SUBROUTINE DT_GETPJE(MO1,MO2,PP,PT,MODE,IPJE,IREJ)
4458 ************************************************************************
4459 * This subroutine copies PHOJET partons and strings from POEVT1 into *
4461 * MO1,MO2 indices of first and last mother-parton in DTEVT1 *
4462 * PP,PT 4-momenta of projectile/target being handled by *
4464 * This version dated 11.12.99 is written by S. Roesler *
4465 ************************************************************************
4467 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4470 PARAMETER ( LINP = 10 ,
4474 PARAMETER (TINY10=1.0D-10,TINY1=1.0D-1,
4475 & ZERO=0.0D0,ONE=1.0D0,OHALF=0.5D0)
4481 PARAMETER (NMXHKK=200000)
4483 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
4484 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
4485 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
4487 * extended event history
4488 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
4489 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
4492 * Lorentz-parameters of the current interaction
4493 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4494 & UMO,PPCM,EPROJ,PPROJ
4496 * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
4497 COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
4499 * flags for input different options
4500 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
4501 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
4502 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
4504 * statistics: double-Pomeron exchange
4505 COMMON /DTFLG2/ INTFLG,IPOPO
4508 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
4509 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
4513 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
4514 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
4515 & IREXCI(3),IRDIFF(2),IRINC
4516 C standard particle data interface
4519 PARAMETER (NMXHEP=4000)
4521 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
4522 DOUBLE PRECISION PHEP,VHEP
4523 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
4524 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
4526 C extension to standard particle data interface (PHOJET specific)
4527 INTEGER IMPART,IPHIST,ICOLOR
4528 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
4530 C color string configurations including collapsed strings and hadrons
4532 PARAMETER (MSTR=500)
4533 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
4534 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
4535 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
4536 & NNCH(MSTR),IBHAD(MSTR),ISTR
4538 C general process information
4539 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
4540 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
4542 C model switches and parameters
4544 INTEGER ISWMDL,IPAMDL
4545 DOUBLE PRECISION PARMDL
4546 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4548 C event debugging information
4550 PARAMETER (NMAXD=100)
4551 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4552 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4553 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4554 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4556 DIMENSION PP(4),PT(4)
4566 * store initial momenta for energy-momentum conservation check
4568 CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM1,IDUM2)
4569 CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM1,IDUM2)
4571 * copy partons and strings from POEVT1 into DTEVT1
4573 C IF ((NCODE(I).EQ.-99).AND.(IPAMDL(17).EQ.0)) THEN
4574 IF (NCODE(I).EQ.-99) THEN
4576 IDSTG = IDHEP(IDXSTG)
4583 CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PX,PY,PZ,PE,
4590 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4593 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4596 CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PPX,PPY,PPZ,PPE,
4603 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4607 IHIST(1,NHKK) = IPHIST(1,IDXSTG)
4609 ELSEIF (NCODE(I).GE.0) THEN
4610 * indices of partons and string in POEVT1
4611 IDX1 = ABS(JMOHEP(1,NPOS(1,I)))
4612 IDX2 = ABS(JMOHEP(2,NPOS(1,I)))
4613 IF ((IDX1.GT.IDX2).OR.(JMOHEP(2,NPOS(1,I)).GT.0)) THEN
4614 WRITE(LOUT,*) ' GETPJE: IDX1.GT.IDX2 ',IDX1,IDX2,
4615 & ' or JMOHEP(2,NPOS(1,I)).GT.0 ',JMOHEP(2,NPOS(1,I)),' ! '
4619 * find "mother" string of the string
4620 IDXMS1 = ABS(JMOHEP(1,IDX1))
4621 IDXMS2 = ABS(JMOHEP(1,IDX2))
4622 IF (IDXMS1.NE.IDXMS2) THEN
4625 C STOP ' GETPJE: IDXMS1.NE.IDXMS2 !'
4627 * search POEVT1 for the original hadron of the parton
4633 IF (IDHEP(IDXMS1).EQ.990) IPOM1 = 1
4635 IDXMS1 = ABS(JMOHEP(1,IDXMS1))
4636 IF ((IDXMS1.NE.1).AND.(IDXMS1.NE.2).AND.
4637 & (ILOOP.LT.MAXLOP)) GOTO 14
4638 IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 1 ! '
4644 IF (IDHEP(IDXMS2).EQ.990) IPOM2 = 1
4646 IF ((ILOOP.EQ.1).OR.(IDHEP(IDXMS2).GE.7777)) THEN
4647 IDXMS2 = ABS(JMOHEP(2,IDXMS2))
4649 IDXMS2 = ABS(JMOHEP(1,IDXMS2))
4651 IF ((IDXMS2.NE.1).AND.(IDXMS2.NE.2).AND.
4652 & (ILOOP.LT.MAXLOP)) GOTO 15
4653 IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 5 ! '
4655 IF (IDXMS1.EQ.1) THEN
4656 ISPTN1 = ISTHKK(MO1)
4660 ISPTN1 = ISTHKK(MO2)
4665 IF (IDXMS2.EQ.1) THEN
4666 ISPTN2 = ISTHKK(MO1)
4670 ISPTN2 = ISTHKK(MO2)
4674 * check for mis-identified mothers and switch mother indices if necessary
4675 IF ((IDXMS1.EQ.IDXMS2).AND.(IPROCE.NE.5).AND.(IPROCE.NE.6)
4676 & .AND.((IDHEP(IDX1).NE.21).OR.(IDHEP(IDX2).NE.21)).AND.
4678 IF (PHEP(3,IDX1).GT.PHEP(3,IDX2)) THEN
4679 ISPTN1 = ISTHKK(MO1)
4682 ISPTN2 = ISTHKK(MO2)
4686 ISPTN1 = ISTHKK(MO2)
4689 ISPTN2 = ISTHKK(MO1)
4694 * register partons in temporary common
4695 * parton at chain end
4700 * flag only partons coming from Pomeron with 41/42
4701 C IF ((IPOM1.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4702 IF (IPOM1.NE.0) THEN
4703 ISTX = ABS(ISPTN1)/10
4704 IMO = ABS(ISPTN1)-10*ISTX
4707 IF ((ICOLOR(2,IDX1).EQ.0).OR.(IDHEP(IDX1).EQ.21)) THEN
4708 ISTX = ABS(ISPTN1)/10
4709 IMO = ABS(ISPTN1)-10*ISTX
4710 IF ((IDHEP(IDX1).EQ.21).OR.
4711 & (ABS(IPHIST(1,IDX1)).GE.100)) THEN
4718 IF (ISPTN1.EQ.-21) NPVAL = NPVAL+1
4719 IF (ISPTN1.EQ.-22) NTVAL = NTVAL+1
4721 CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PX,PY,
4724 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4726 CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PPX,PPY,
4729 IHIST(1,NHKK) = IPHIST(1,IDX1)
4732 VHKK(KK,NHKK) = VHKK(KK,M2PTN1)
4733 WHKK(KK,NHKK) = WHKK(KK,M1PTN1)
4735 VHKK(4,NHKK) = VHKK(3,M2PTN1)/BLAB-VHKK(3,M1PTN1)/BGLAB
4736 WHKK(4,NHKK) = -WHKK(3,M1PTN1)/BLAB+WHKK(3,M2PTN1)/BGLAB
4739 NGLUON = IDX2-IDX1-1
4740 IF (NGLUON.GT.0) THEN
4741 DO 17 IGLUON=1,NGLUON
4743 IDXMS = ABS(JMOHEP(1,IDX))
4744 IF ((IDXMS.NE.1).AND.(IDXMS.NE.2)) THEN
4748 IDXMS = ABS(JMOHEP(1,IDXMS))
4749 IF ((IDXMS.NE.1).AND.(IDXMS.NE.2).AND.
4750 & (ILOOP.LT.MAXLOP)) GOTO 16
4751 IF (ILOOP.EQ.MAXLOP)
4752 & WRITE(LOUT,*) ' GETPJE: MAXLOP in 3 ! '
4754 IF (IDXMS.EQ.1) THEN
4767 IF ((ICOLOR(2,IDX).EQ.0).OR.(IDHEP(IDX).EQ.21)) THEN
4768 ISTX = ABS(ISPTN)/10
4769 IMO = ABS(ISPTN)-10*ISTX
4770 IF ((IDHEP(IDX).EQ.21).OR.
4771 & (ABS(IPHIST(1,IDX)).GE.100)) THEN
4777 IF (ISPTN.EQ.-21) NPVAL = NPVAL+1
4778 IF (ISPTN.EQ.-22) NTVAL = NTVAL+1
4780 CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4781 & PX,PY,PZ,PE,0,0,0)
4783 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4785 CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4786 & PPX,PPY,PPZ,PPE,0,0,0)
4788 IHIST(1,NHKK) = IPHIST(1,IDX)
4791 VHKK(KK,NHKK) = VHKK(KK,M2PTN)
4792 WHKK(KK,NHKK) = WHKK(KK,M1PTN)
4794 VHKK(4,NHKK)= VHKK(3,M2PTN)/BLAB-VHKK(3,M1PTN)/BGLAB
4795 WHKK(4,NHKK)= -WHKK(3,M1PTN)/BLAB+WHKK(3,M2PTN)/BGLAB
4798 * parton at chain end
4803 * flag only partons coming from Pomeron with 41/42
4804 C IF ((IPOM2.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4805 IF (IPOM2.NE.0) THEN
4806 ISTX = ABS(ISPTN2)/10
4807 IMO = ABS(ISPTN2)-10*ISTX
4810 IF ((ICOLOR(2,IDX2).EQ.0).OR.(IDHEP(IDX2).EQ.21)) THEN
4811 ISTX = ABS(ISPTN2)/10
4812 IMO = ABS(ISPTN2)-10*ISTX
4813 IF ((IDHEP(IDX2).EQ.21).OR.
4814 & (ABS(IPHIST(1,IDX2)).GE.100)) THEN
4821 IF (ISPTN2.EQ.-21) NPVAL = NPVAL+1
4822 IF (ISPTN2.EQ.-22) NTVAL = NTVAL+1
4824 CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4825 & PX,PY,PZ,PE,0,0,0)
4827 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4829 CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4830 & PPX,PPY,PPZ,PPE,0,0,0)
4832 IHIST(1,NHKK) = IPHIST(1,IDX2)
4835 VHKK(KK,NHKK) = VHKK(KK,M2PTN2)
4836 WHKK(KK,NHKK) = WHKK(KK,M1PTN2)
4838 VHKK(4,NHKK) = VHKK(3,M2PTN2)/BLAB-VHKK(3,M1PTN2)/BGLAB
4839 WHKK(4,NHKK) = -WHKK(3,M1PTN2)/BLAB+WHKK(3,M2PTN2)/BGLAB
4842 JSTRG = 100*IPROCE+NCODE(I)
4849 CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4850 & PX,PY,PZ,PE,0,0,0)
4856 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4859 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4862 CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4863 & PPX,PPY,PPZ,PPE,0,0,0)
4869 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4876 VHKK(KK,NHKK) = VHKK(KK,MO2)
4877 WHKK(KK,NHKK) = WHKK(KK,MO1)
4879 VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
4880 WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
4884 IF ( ((NPVAL.GT.2).OR.(NTVAL.GT.2)).AND.(LFLIP) ) THEN
4891 IF (UMO.GT.1.0D5) THEN
4896 CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,1000,IREJ2)
4898 IF (IREJ2.GT.ZERO) CALL PHO_PREVNT(0)
4902 * internal statistics
4903 * dble-Po statistics.
4904 IF (IPROCE.NE.4) IPOPO = 0
4908 IF ((IPROCE.GE.1).AND.(IPROCE.LE.8)) THEN
4909 ICEVTG(IDCHSY,IPROCE+2) = ICEVTG(IDCHSY,IPROCE+2)+1
4911 WRITE(LOUT,1000) IPROCE,NEVHKK,MO1
4912 1000 FORMAT(1X,'GETFSP: warning! incons. process id. (',I2,
4913 & ') at evt(chain) ',I6,'(',I2,')')
4915 IF (IPROCE.EQ.5) THEN
4916 IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3)) THEN
4917 ICEVTG(IDCHSY,18+IDIFR1) = ICEVTG(IDCHSY,18+IDIFR1)+1
4919 C WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4920 1001 FORMAT(1X,'GETFSP: warning! incons. diffrac. id. ',
4921 & '(IPROCE,IDIFR1,IDIFR2=',3I3,')')
4923 ELSEIF (IPROCE.EQ.6) THEN
4924 IF ((IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4925 ICEVTG(IDCHSY,21+IDIFR2) = ICEVTG(IDCHSY,21+IDIFR2)+1
4927 C WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4929 ELSEIF (IPROCE.EQ.7) THEN
4930 IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3).AND.
4931 & (IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4932 IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.1))
4933 & ICEVTG(IDCHSY,25) = ICEVTG(IDCHSY,25)+1
4934 IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.2))
4935 & ICEVTG(IDCHSY,26) = ICEVTG(IDCHSY,26)+1
4936 IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.2))
4937 & ICEVTG(IDCHSY,27) = ICEVTG(IDCHSY,27)+1
4938 IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.1))
4939 & ICEVTG(IDCHSY,28) = ICEVTG(IDCHSY,28)+1
4941 WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4944 IF ((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GE.1).AND.(KHDIR.LE.3))
4946 ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4947 ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4948 ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4950 ICEVTG(IDCHSY,14) = ICEVTG(IDCHSY,14)+KSPOM
4951 ICEVTG(IDCHSY,15) = ICEVTG(IDCHSY,15)+KHPOM
4952 ICEVTG(IDCHSY,16) = ICEVTG(IDCHSY,16)+KSREG
4953 ICEVTG(IDCHSY,17) = ICEVTG(IDCHSY,17)+(KSTRG+KHTRG)
4954 ICEVTG(IDCHSY,18) = ICEVTG(IDCHSY,18)+(KSLOO+KHLOO)
4963 *$ CREATE DT_PHOINI.FOR
4966 *===phoini=============================================================*
4968 SUBROUTINE DT_PHOINI
4970 ************************************************************************
4971 * Initialization PHOJET-event generator for nucleon-nucleon interact. *
4972 * This version dated 16.11.95 is written by S. Roesler *
4974 * Last change 27.12.2006 by S. Roesler. *
4975 ************************************************************************
4977 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4980 PARAMETER ( LINP = 10 ,
4984 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
4986 * nucleon-nucleon event-generator
4989 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
4991 * particle properties (BAMJET index convention)
4993 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
4994 & IICH(210),IIBAR(210),K1(210),K2(210)
4996 * Lorentz-parameters of the current interaction
4997 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4998 & UMO,PPCM,EPROJ,PPROJ
5000 * properties of interacting particles
5001 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5003 * properties of photon/lepton projectiles
5004 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5006 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
5008 * emulsion treatment
5009 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
5012 * VDM parameter for photon-nucleus interactions
5013 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
5017 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5018 & EBINDP(2),EBINDN(2),EPOT(2,210),
5019 & ETACOU(2),ICOUL,LFERMI
5021 * Glauber formalism: flags and parameters for statistics
5024 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
5026 * parameters for cascade calculations:
5027 * maximum mumber of PDF's which can be defined in phojet (limited
5028 * by the dimension of ipdfs in pho_setpdf)
5029 PARAMETER (MAXPDF = 20)
5030 * PDF parametrization and number of set for the first 30 hadrons in
5031 * the bamjet-code list
5032 * negative numbers mean that the PDF is set in phojet,
5033 * zero stands for "not a hadron"
5034 DIMENSION IPARPD(30),ISETPD(30)
5035 * PDF parametrization
5037 & -5,-5, 0, 0, 0, 0,-5,-5,-5, 0, 0, 5,-5,-5, 5, 5, 5, 5, 5, 5,
5038 & 5, 5,-5, 5, 5, 0, 0, 0, 0, 0/
5041 & -6,-6, 0, 0, 0, 0,-3,-6,-6, 0, 0, 2,-2,-2, 2, 2, 6, 6, 2, 6,
5042 & 6, 6,-2, 2, 2, 0, 0, 0, 0, 0/
5045 C COMMON /GLOCMS/ XECM,XPCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
5046 C PARAMETER ( MAXPRO = 16 )
5047 C PARAMETER ( MAXTAB = 20 )
5048 C COMMON /HAXSEC/ XSECTA(4,-1:MAXPRO,4,MAXTAB),XSECT(6,-1:MAXPRO),
5049 C & MXSECT(0:4,-1:MAXPRO,4),ECMSH(4,MAXTAB),ISTTAB
5051 C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
5052 C COMMON /PROCES/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15)
5055 C global event kinematics and particle IDs
5057 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
5058 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
5060 C hard cross sections and MC selection weights
5062 PARAMETER ( Max_pro_2 = 16 )
5063 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
5065 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
5066 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
5067 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
5068 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
5069 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
5070 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
5072 C model switches and parameters
5074 INTEGER ISWMDL,IPAMDL
5075 DOUBLE PRECISION PARMDL
5076 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
5078 C general process information
5079 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
5080 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
5082 DIMENSION PP(4),PT(4)
5085 DATA LSTART /.TRUE./
5090 * lepton-projectiles: initialize real photon instead
5091 IF ((IJP.EQ.3).OR.(IJP.EQ.4).OR.(IJP.EQ.10).OR.(IJP.EQ.11)) THEN
5096 IF (LPHOIN) CALL PHO_INIT(-1,LOUT,IDUM)
5098 * switch Reggeon off
5101 IFPAP(1) = IDT_IPDGHA(IJP)
5105 IFPAB(1) = IDT_ICIHAD(IFPAP(1))
5107 PMASS(1) = AAM(IFPAB(1))-SQRT(Q2)
5108 PVIRT(1) = PMASS(1)**2
5110 IFPAP(2) = IDT_IPDGHA(IJT)
5114 IFPAB(2) = IDT_ICIHAD(IFPAP(2))
5116 PMASS(2) = AAM(IFPAB(2))
5122 * get max. possible momenta of incoming particles to be used for PHOJET ini.
5126 IF (UMO.GE.1.E5) THEN
5129 IF (NCOMPO.GT.0) THEN
5132 CALL DT_NCLPOT(IEMUCH(I),IEMUMA(I),ITZ,IT,ZERO,ZERO,0)
5134 CALL DT_NCLPOT(IPZ,IP,IEMUCH(I),IEMUMA(I),ZERO,ZERO,0)
5136 PPFTMP = MAX(PFERMP(1),PFERMN(1))
5137 PTFTMP = MAX(PFERMP(2),PFERMN(2))
5138 IF (PPFTMP.GT.PPF) PPF = PPFTMP
5139 IF (PTFTMP.GT.PTF) PTF = PTFTMP
5142 CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
5143 PPF = MAX(PFERMP(1),PFERMN(1))
5144 PTF = MAX(PFERMP(2),PFERMN(2))
5150 AMP2 = SIGN(PMASS(1)**2,PMASS(1))
5152 PP(4) = SQRT(AMP2+PP(3)**2)
5154 EPF = SQRT(PPF**2+PMASS(1)**2)
5155 CALL DT_LTNUC(PPF,EPF,PP(3),PP(4),2)
5157 ETF = SQRT(PTF**2+PMASS(2)**2)
5158 CALL DT_LTNUC(PTF,ETF,PT(3),PT(4),3)
5159 ECMINI = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
5160 & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
5162 WRITE(LOUT,1001) IP,IPZ,SCPF,PPF,PP
5164 & ' DT_PHOINI: PHOJET initialized for projectile A,Z = ',
5165 & I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
5166 IF (NCOMPO.GT.0) THEN
5167 WRITE(LOUT,1002) SCPF,PTF,PT
5169 WRITE(LOUT,1003) IT,ITZ,SCPF,PTF,PT
5172 & ' DT_PHOINI: PHOJET initialized for target emulsion ',
5173 & /,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
5175 & ' DT_PHOINI: PHOJET initialized for target A,Z = ',
5176 & I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
5177 WRITE(LOUT,1004) ECMINI
5178 1004 FORMAT(' E_cm = ',E10.3)
5179 IF (IJP.EQ.8) WRITE(LOUT,1005)
5181 & ' DT_PHOINI: warning! proton parameters used for neutron',
5185 * switch off new diffractive cross sections at low energies for nuclei
5186 * (temporary solution)
5187 IF ((ISWMDL(30).NE.0).AND.((IP.GT.1).OR.(IT.GT.1))) THEN
5188 WRITE(LOUT,'(1X,A)')
5189 & ' DT_PHOINI: model-switch 30 for nuclei re-set !'
5190 CALL PHO_SETMDL(30,0,1)
5193 C IF (IJP.EQ.7) THEN
5194 C AMP2 = SIGN(PMASS(1)**2,PMASS(1))
5196 C PP(4) = SQRT(AMP2+PP(3)**2)
5199 C IF (IP.GT.1) PFERMX = 0.5D0
5200 C EFERMX = SQRT(PFERMX**2+PMASS(1)**2)
5201 C CALL DT_LTNUC(PFERMX,EFERMX,PP(3),PP(4),2)
5204 C IF ((IT.GT.1).OR.(NCOMPO.GT.0)) PFERMX = -0.5D0
5205 C EFERMX = SQRT(PFERMX**2+PMASS(2)**2)
5206 C CALL DT_LTNUC(PFERMX,EFERMX,PT(3),PT(4),3)
5209 IF ((ISHAD(2).EQ.1).AND.
5210 & ((IJPROJ.EQ. 7).OR.(IJPROJ.EQ.3).OR.(IJPROJ.EQ.4).OR.
5211 & (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11))) IPAMDL(13) = 1
5214 CALL PHO_EVENT(-1,PP,PT,SIGMAX,IREJ1)
5220 * patch for cascade calculations:
5221 * define parton distribution functions for other hadrons, i.e. other
5222 * then defined already in phojet
5223 IF (IOGLB.EQ.100) THEN
5225 1006 FORMAT(/,1X,'PHOINI: additional parton distribution functions',
5226 & ' assiged (ID,IPAR,ISET)',/)
5229 IF (IPARPD(I).NE.0) THEN
5231 IF (NPDF.GT.MAXPDF) STOP ' PHOINI: npdf > maxpdf !'
5232 IF ((IPARPD(I).GT.0).AND.(ISETPD(I).GT.0)) THEN
5233 IDPDG = IDT_IPDGHA(I)
5236 WRITE(LOUT,'(13X,A8,3I6)') ANAME(I),IDPDG,IPAR,ISET
5237 CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,0,0,-1)
5243 C CALL PHO_PHIST(-1,SIGMAX)
5245 IF (IREJ1.NE.0) THEN
5247 1000 FORMAT(1X,'PHOINI: PHOJET event-initialization failed!')
5254 *$ CREATE DT_EVENTD.FOR
5257 *===eventd=============================================================*
5259 SUBROUTINE DT_EVENTD(IREJ)
5261 ************************************************************************
5262 * Quasi-elastic neutrino nucleus scattering. *
5263 * This version dated 29.04.00 is written by S. Roesler. *
5264 ************************************************************************
5266 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5269 PARAMETER ( LINP = 10 ,
5273 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY5=1.0D-5)
5274 PARAMETER (SQTINF=1.0D+15)
5280 PARAMETER (NMXHKK=200000)
5282 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5283 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5284 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5286 * extended event history
5287 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5288 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5291 * flags for input different options
5292 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5293 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5294 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5295 PARAMETER (MAXLND=4000)
5296 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
5298 * properties of interacting particles
5299 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5301 * Lorentz-parameters of the current interaction
5302 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5303 & UMO,PPCM,EPROJ,PPROJ
5307 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5308 & EBINDP(2),EBINDN(2),EPOT(2,210),
5309 & ETACOU(2),ICOUL,LFERMI
5311 * steering flags for qel neutrino scattering modules
5312 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
5314 COMMON /QNPOL/ POLARX(4),PMODUL
5318 DATA LFIRST /.TRUE./
5330 * interacting target nucleon
5332 IF (NEUDEC.LE.9) THEN
5333 IF ((LTYP.EQ.1).OR.(LTYP.EQ.3).OR.(LTYP.EQ.5)) THEN
5341 RTYP = DT_RNDM(RTYP)
5342 ZFRAC = DBLE(ITZ)/DBLE(IT)
5343 IF (RTYP.LE.ZFRAC) THEN
5352 * select first nucleon in list with matching id and reset all other
5353 * nucleons which have been marked as "wounded" by ININUC
5356 IF ((IDHKK(I).EQ.NUCTYP).AND.(IFOUND.EQ.0)) THEN
5361 IF (ISTHKK(I).EQ.12) ISTHKK(I) = 14
5365 & STOP ' EVENTD: interacting target nucleon not found! '
5367 * correct position of proj. lepton: assume position of target nucleon
5369 VHKK(I,1) = VHKK(I,IDX)
5370 WHKK(I,1) = WHKK(I,IDX)
5373 * load initial momenta for conservation check
5375 CALL DT_EVTEMC(ZERO,ZERO,PPROJ,EPROJ,1,IDUM,IDUM)
5376 CALL DT_EVTEMC(PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),PHKK(4,IDX),
5380 * quasi-elastic scattering
5381 IF (NEUDEC.LT.9) THEN
5382 CALL DT_QEL_POL(EPROJ,LTYP,PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),
5383 & PHKK(4,IDX),PHKK(5,IDX))
5384 * CC event on p or n
5385 ELSEIF (NEUDEC.EQ.10) THEN
5386 CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,1,PHKK(1,IDX),PHKK(2,IDX),
5387 & PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5388 * NC event on p or n
5389 ELSEIF (NEUDEC.EQ.11) THEN
5390 CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,2,PHKK(1,IDX),PHKK(2,IDX),
5391 & PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5394 * get final state particles from Lund-common and write them into HKKEVT
5402 IF (K(I,1).EQ.1) THEN
5408 CALL DT_EVTPUT(1,ID,1,IDX,PX,PY,PZ,PE,0,0,0)
5409 IDBJ = IDT_ICIHAD(ID)
5410 EKIN = PHKK(4,NHKK)-PHKK(5,NHKK)
5411 IF ((IDBJ.EQ.1).OR.(IDBJ.EQ.8)) THEN
5412 IF (EKIN.LE.EPOT(2,IDBJ)) ISTHKK(NHKK) = 16
5414 VHKK(1,NHKK) = VHKK(1,IDX)
5415 VHKK(2,NHKK) = VHKK(2,IDX)
5416 VHKK(3,NHKK) = VHKK(3,IDX)
5417 VHKK(4,NHKK) = VHKK(4,IDX)
5419 C WHKK(1,NHKK) = POLARX(1)
5420 C WHKK(2,NHKK) = POLARX(2)
5421 C WHKK(3,NHKK) = POLARX(3)
5422 C WHKK(4,NHKK) = POLARX(4)
5424 WHKK(1,NHKK) = WHKK(1,IDX)
5425 WHKK(2,NHKK) = WHKK(2,IDX)
5426 WHKK(3,NHKK) = WHKK(3,IDX)
5427 WHKK(4,NHKK) = WHKK(4,IDX)
5429 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
5435 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,778,IREJ1)
5436 IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
5439 * transform momenta into cms (as required for inc etc.)
5441 IF (ISTHKK(I).EQ.1) THEN
5442 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,3)
5450 *$ CREATE DT_KKEVNT.FOR
5453 *===kkevnt=============================================================*
5455 SUBROUTINE DT_KKEVNT(KKMAT,IREJ)
5457 ************************************************************************
5458 * Treatment of complete nucleus-nucleus or hadron-nucleus scattering *
5459 * without nuclear effects (one event). *
5460 * This subroutine is an update of the previous version (KKEVT) written *
5461 * by J. Ranft/ H.-J. Moehring. *
5462 * This version dated 20.04.95 is written by S. Roesler *
5463 ************************************************************************
5465 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5468 PARAMETER ( LINP = 10 ,
5472 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10)
5474 PARAMETER ( MAXNCL = 260,
5477 & MAXSQU = 20*MAXVQU,
5478 & MAXINT = MAXVQU+MAXSQU)
5482 PARAMETER (NMXHKK=200000)
5484 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5485 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5486 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5488 * extended event history
5489 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5490 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5493 * flags for input different options
5494 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5495 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5496 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5499 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
5500 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
5501 & IREXCI(3),IRDIFF(2),IRINC
5504 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5505 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5508 * properties of interacting particles
5509 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5511 * Lorentz-parameters of the current interaction
5512 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5513 & UMO,PPCM,EPROJ,PPROJ
5515 * flags for diffractive interactions (DTUNUC 1.x)
5516 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
5518 * interface HADRIN-DPM
5519 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5521 * nucleon-nucleon event-generator
5524 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
5526 * coordinates of nucleons
5527 COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
5529 * interface between Glauber formalism and DPM
5530 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
5531 & INTER1(MAXINT),INTER2(MAXINT)
5533 * Glauber formalism: collision properties
5534 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5535 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
5537 * central particle production, impact parameter biasing
5538 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5541 * statistics: Glauber-formalism
5542 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
5545 DATA NEVOLD,IPOLD,ITOLD,JJPOLD,EPROLD /4*0,0.0D0/
5554 IF (MOD(NC,10).EQ.0) THEN
5555 WRITE(LOUT,1000) NEVHKK
5556 1000 FORMAT(1X,'KKEVNT: event ',I8,' rejected!')
5560 * initialize DTEVT1/DTEVT2
5563 * We need the following only in order to sample nucleon coordinates.
5564 * However we don't have parameters (cross sections, slope etc.)
5565 * for neutrinos available. Therefore switch projectile to proton
5567 IF (MCGENE.EQ.4) THEN
5574 IF ( (NEVHKK.NE.NEVOLD).OR.(ICENTR.GT.0).OR.
5575 * make sure that Glauber-formalism is called each time the interaction
5576 * configuration changed
5577 & (IP.NE.IPOLD).OR.(IT.NE.ITOLD).OR.(JJPROJ.NE.JJPOLD).OR.
5578 & (ABS(EPROJ-EPROLD).GT.TINY10) ) THEN
5579 * sample number of nucleon-nucleon coll. according to Glauber-form.
5580 CALL DT_GLAUBE(IP,IT,JJPROJ,BIMPAC,NN,NP,NT,JSSH,JTSH,KKMAT)
5591 * force diffractive particle production in h-K interactions
5592 IF (((ABS(ISINGD).GT.1).OR.(ABS(IDOUBD).GT.1)).AND.
5593 & (IP.EQ.1).AND.(NN.NE.1)) THEN
5598 * check number of involved proj. nucl. (NP) if central prod.is requested
5599 IF (ICENTR.GT.0) THEN
5600 CALL DT_CHKCEN(IP,IT,NP,NT,IBACK)
5601 IF (IBACK.GT.0) GOTO 10
5604 * get initial nucleon-configuration in projectile and target
5605 * rest-system (including Fermi-momenta if requested)
5606 CALL DT_ININUC(IJPROJ,IP,IPZ,PKOO,JSSH,1)
5608 IF (EPROJ.LE.EHADTH) MODE = 3
5609 CALL DT_ININUC(IJTARG,IT,ITZ,TKOO,JTSH,MODE)
5611 IF ((MCGENE.NE.3).AND.(MCGENE.NE.4)) THEN
5613 * activate HADRIN at low energies (implemented for h-N scattering only)
5614 IF (EPROJ.LE.EHADHI) THEN
5615 IF (EHADTH.LT.ZERO) THEN
5616 * smooth transition btwn. DPM and HADRIN
5617 FRAC = (EPROJ-EHADLO)/(EHADHI-EHADLO)
5619 IF (RR.GT.FRAC) THEN
5621 CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5622 IF (IREJ1.GT.0) GOTO 1
5625 WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5629 * fixed threshold for onset of production via HADRIN
5630 IF (EPROJ.LE.EHADTH) THEN
5632 CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5633 IF (IREJ1.GT.0) GOTO 1
5636 WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5641 1001 FORMAT(1X,'KKEVNT: warning! interaction of proj. (m=',
5642 & I3,') with target (m=',I3,')',/,11X,
5643 & 'at E_lab=',F5.1,'GeV (threshold-energy: ',F3.1,
5644 & 'GeV) cannot be handled')
5646 * sampling of momentum-x fractions & flavors of chain ends
5649 * Lorentz-transformation of wounded nucleons into nucl.-nucl. cms
5652 * collect momenta of chain ends and put them into DTEVT1
5653 CALL DT_GETPTN(IP,NN,NCSY,IREJ1)
5654 IF (IREJ1.NE.0) GOTO 1
5658 * handle chains including fragmentation (two-chain approximation)
5659 IF (MCGENE.EQ.1) THEN
5660 * two-chain approximation
5661 CALL DT_EVENTA(IJPROJ,IP,IT,NCSY,IREJ1)
5662 IF (IREJ1.NE.0) THEN
5663 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKEVNT'
5666 ELSEIF (MCGENE.EQ.2) THEN
5667 * multiple-Po exchange including minijets
5668 CALL DT_EVENTB(NCSY,IREJ1)
5669 IF (IREJ1.NE.0) THEN
5670 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKEVNT'
5673 ELSEIF (MCGENE.EQ.3) THEN
5674 STOP ' This version does not contain LEPTO !'
5676 ELSEIF (MCGENE.EQ.4) THEN
5677 * quasi-elastic neutrino scattering
5678 CALL DT_EVENTD(IREJ1)
5679 IF (IREJ1.NE.0) THEN
5680 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 4 in KKEVNT'
5684 WRITE(LOUT,1002) MCGENE
5685 1002 FORMAT(1X,'KKEVNT: warning! event-generator',I4,
5686 & ' not available - program stopped')
5697 *$ CREATE DT_CHKCEN.FOR
5700 *===chkcen=============================================================*
5702 SUBROUTINE DT_CHKCEN(IP,IT,NP,NT,IBACK)
5704 ************************************************************************
5705 * Check of number of involved projectile nucleons if central production*
5707 * Adopted from a part of the old KKEVT routine which was written by *
5708 * J. Ranft/H.-J.Moehring. *
5709 * This version dated 13.01.95 is written by S. Roesler *
5710 ************************************************************************
5712 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5715 PARAMETER ( LINP = 10 ,
5720 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5721 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5724 * central particle production, impact parameter biasing
5725 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5730 IF (ICENTR.EQ.2) THEN
5733 IF (NP.LT.IP-1) IBACK = 1
5734 ELSEIF (IP.LE.16) THEN
5735 IF (NP.LT.IP-2) IBACK = 1
5736 ELSEIF (IP.LE.32) THEN
5737 IF (NP.LT.IP-3) IBACK = 1
5738 ELSEIF (IP.GE.33) THEN
5739 IF (NP.LT.IP-5) IBACK = 1
5741 ELSEIF (IP.EQ.IT) THEN
5743 IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5745 IF (NP.LT.IP-IP/8) IBACK = 1
5747 ELSEIF (ABS(IP-IT).LT.3) THEN
5748 IF (NP.LT.IP-IP/8) IBACK = 1
5751 * new version (DPMJET, 5.6.99)
5754 IF (NP.LT.IP-1) IBACK = 1
5755 ELSEIF (IP.LE.16) THEN
5756 IF (NP.LT.IP-2) IBACK = 1
5757 ELSEIF (IP.LT.32) THEN
5758 IF (NP.LT.IP-3) IBACK = 1
5759 ELSEIF (IP.GE.32) THEN
5762 IF (NP.LT.IP-1) IBACK = 1
5765 IF (NP.LT.IP) IBACK = 1
5768 ELSEIF (IP.EQ.IT) THEN
5771 IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5774 IF (NP.LT.IP-IP/4) IBACK = 1
5776 ELSEIF (ABS(IP-IT).LT.3) THEN
5777 IF (NP.LT.IP-IP/8) IBACK = 1
5786 *$ CREATE DT_ININUC.FOR
5789 *===ininuc=============================================================*
5791 SUBROUTINE DT_ININUC(ID,NMASS,NCH,COORD,JS,IMODE)
5793 ************************************************************************
5794 * Samples initial configuration of nucleons in nucleus with mass NMASS *
5795 * including Fermi-momenta (if reqested). *
5796 * ID BAMJET-code for hadrons (instead of nuclei) *
5797 * NMASS mass number of nucleus (number of nucleons) *
5798 * NCH charge of nucleus *
5799 * COORD(3,NMASS) coordinates of nucleons inside nucleus in fm *
5800 * JS(NMASS) > 0 nucleon undergoes nucleon-nucleon interact. *
5801 * IMODE = 1 projectile nucleus *
5802 * = 2 target nucleus *
5803 * = 3 target nucleus (E_lab<E_thr for HADRIN) *
5804 * Adopted from a part of the old KKEVT routine which was written by *
5805 * J. Ranft/H.-J.Moehring. *
5806 * This version dated 13.01.95 is written by S. Roesler *
5807 ************************************************************************
5809 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5812 PARAMETER ( LINP = 10 ,
5816 PARAMETER (FM2MM=1.0D-12)
5818 PARAMETER ( MAXNCL = 260,
5821 & MAXSQU = 20*MAXVQU,
5822 & MAXINT = MAXVQU+MAXSQU)
5826 PARAMETER (NMXHKK=200000)
5828 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5829 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5830 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5832 * extended event history
5833 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5834 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5837 * flags for input different options
5838 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5839 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5840 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5842 * auxiliary common for chain system storage (DTUNUC 1.x)
5843 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
5847 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5848 & EBINDP(2),EBINDN(2),EPOT(2,210),
5849 & ETACOU(2),ICOUL,LFERMI
5851 * properties of photon/lepton projectiles
5852 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5854 * particle properties (BAMJET index convention)
5856 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5857 & IICH(210),IIBAR(210),K1(210),K2(210)
5859 * Glauber formalism: collision properties
5860 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5861 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
5863 * flavors of partons (DTUNUC 1.x)
5864 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5865 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5866 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
5867 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5868 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
5869 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5870 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
5872 * interface HADRIN-DPM
5873 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5875 DIMENSION PF(4),PFTOT(4),COORD(3,MAXNCL),JS(MAXNCL)
5877 * number of neutrons
5886 IF (IMODE.GT.2) MODE = 2
5887 **sr 29.5. new NPOINT(1)-definition
5888 C IF (IMODE.GE.2) NPOINT(1) = NHKK+1
5893 * get initial configuration
5896 IF (JS(I).GT.0) THEN
5897 ISTHKK(NHKK) = 10+MODE
5898 IF (IMODE.EQ.3) THEN
5899 * additional treatment if HADRIN-generator is requested
5901 IF (NHADRI.EQ.1) IDXTA = NHKK
5902 IF (NHADRI.GT.1) ISTHKK(NHKK) = 14
5905 ISTHKK(NHKK) = 12+MODE
5907 IF (NMASS.GE.2) THEN
5908 * treatment for nuclei
5909 FRAC = 1.0D0-DBLE(NCH)/DBLE(NMASS)
5911 IF ((RR.LT.FRAC).AND.(NN.LT.NNEU)) THEN
5914 ELSEIF ((RR.GE.FRAC).AND.(NP.LT.NCH)) THEN
5917 ELSEIF (NN.LT.NNEU) THEN
5920 ELSEIF (NP.LT.NCH) THEN
5924 IDHKK(NHKK) = IDT_IPDGHA(IDX)
5935 PBIN = SQRT(2.0D0*EBINDP(MODE)*AAM(1))
5938 PBIN = SQRT(2.0D0*EBINDN(MODE)*AAM(8))
5940 CALL DT_FER4M(PFER,PBIN,PF(1),PF(2),PF(3),PF(4),IDX)
5942 PFTOT(K) = PFTOT(K)+PF(K)
5943 PHKK(K,NHKK) = PF(K)
5945 PHKK(5,NHKK) = AAM(IDX)
5947 * treatment for hadrons
5948 IDHKK(NHKK) = IDT_IPDGHA(ID)
5950 PHKK(4,NHKK) = AAM(ID)
5951 PHKK(5,NHKK) = AAM(ID)
5953 C IF (IDHKK(NHKK).EQ.22) THEN
5954 C PHKK(4,NHKK) = AAM(33)
5955 C PHKK(5,NHKK) = AAM(33)
5960 PHKK(5,NHKK) = PHKK(5,NHKK)-SQRT(VIRT)
5967 VHKK(K,NHKK) = COORD(K,I)*FM2MM
5968 WHKK(K,NHKK) = COORD(K,I)*FM2MM
5970 IF (MODE.EQ.2) VHKK(1,NHKK) = VHKK(1,NHKK)+BIMPAC*FM2MM
5971 IF (MODE.EQ.2) WHKK(1,NHKK) = WHKK(1,NHKK)+BIMPAC*FM2MM
5972 VHKK(4,NHKK) = 0.0D0
5973 WHKK(4,NHKK) = 0.0D0
5976 * balance Fermi-momenta
5977 IF (NMASS.GE.2) THEN
5981 PHKK(K,NC) = PHKK(K,NC)-PFTOT(K)/DBLE(NMASS)
5983 PHKK(4,NC) = SQRT(PHKK(5,NC)**2+PHKK(1,NC)**2+
5984 & PHKK(2,NC)**2+PHKK(3,NC)**2)
5991 *$ CREATE DT_FER4M.FOR
5994 *===fer4m==============================================================*
5996 SUBROUTINE DT_FER4M(PFERM,PBIND,PXT,PYT,PZT,ET,KT)
5998 ************************************************************************
5999 * Sampling of nucleon Fermi-momenta from distributions at T=0. *
6000 * processed by S. Roesler, 17.10.95 *
6001 ************************************************************************
6003 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6006 PARAMETER ( LINP = 10 ,
6012 * particle properties (BAMJET index convention)
6014 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6015 & IICH(210),IIBAR(210),K1(210),K2(210)
6019 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
6020 & EBINDP(2),EBINDN(2),EPOT(2,210),
6021 & ETACOU(2),ICOUL,LFERMI
6023 DATA LSTART /.TRUE./
6029 1000 FORMAT(/,1X,'FER4M: sampling of Fermi-momenta activated')
6033 CALL DT_DFERMI(PABS)
6035 C IF (PABS.GE.PBIND) THEN
6037 C IF (MOD(ILOOP,500).EQ.0) THEN
6038 C WRITE(LOUT,1001) PABS,PBIND,ILOOP
6039 C1001 FORMAT(1X,'FER4M: Fermi-mom. corr. for binding',
6040 C & ' energy ',2E12.3,I6)
6044 CALL DT_DPOLI(POLC,POLS)
6045 CALL DT_DSFECF(SFE,CFE)
6049 ET = SQRT(PABS*PABS+AAM(KT)**2)
6063 *$ CREATE DT_NUC2CM.FOR
6066 *===nuc2cm=============================================================*
6068 SUBROUTINE DT_NUC2CM
6070 ************************************************************************
6071 * Lorentz-transformation of all wounded nucleons from Lab. to nucl.- *
6072 * nucl. cms. (This subroutine replaces NUCMOM.) *
6073 * This version dated 15.01.95 is written by S. Roesler *
6074 ************************************************************************
6076 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6079 PARAMETER ( LINP = 10 ,
6083 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
6087 PARAMETER (NMXHKK=200000)
6089 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6090 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6091 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6093 * extended event history
6094 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6095 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6099 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
6100 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
6103 * properties of photon/lepton projectiles
6104 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
6106 * particle properties (BAMJET index convention)
6108 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6109 & IICH(210),IIBAR(210),K1(210),K2(210)
6111 * Glauber formalism: collision properties
6112 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
6113 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
6116 * statistics: Glauber-formalism
6117 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
6129 IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.12)) THEN
6130 IF (ISTHKK(I).EQ.11) NWAACC = NWAACC+1
6131 IF (ISTHKK(I).EQ.12) NWBACC = NWBACC+1
6133 C IF (IDHKK(I).EQ.22) THEN
6141 C CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PEIN,
6142 C & PX,PY,PZ,PE,IDB,MODE)
6143 IF (PHKK(5,I).GT.ZERO) THEN
6144 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
6145 & PX,PY,PZ,PE,IDBAM(I),MODE)
6155 C IF (ID.EQ.22) ID = 113
6156 CALL DT_EVTPUT(IST,ID,I,0,PX,PY,PZ,PE,0,0,0)
6157 IF (ISTHKK(I).EQ.11) ICWP = ICWP+1
6158 IF (ISTHKK(I).EQ.12) ICWT = ICWT+1
6162 NWTACC = MAX(NWAACC,NWBACC)
6166 IF ((ICWP.EQ.0).OR.(ICWT.EQ.0)) THEN
6174 *$ CREATE DT_SPLPTN.FOR
6177 *===splptn=============================================================*
6179 SUBROUTINE DT_SPLPTN(NN)
6181 ************************************************************************
6182 * SamPLing of ParToN momenta and flavors. *
6183 * This version dated 15.01.95 is written by S. Roesler *
6184 ************************************************************************
6186 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6189 PARAMETER ( LINP = 10 ,
6193 * Lorentz-parameters of the current interaction
6194 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
6195 & UMO,PPCM,EPROJ,PPROJ
6197 * sample flavors of sea-quarks
6198 CALL DT_SPLFLA(NN,1)
6200 * sample x-values of partons at chain ends
6202 CALL DT_XKSAMP(NN,ECM)
6205 CALL DT_SPLFLA(NN,2)
6210 *$ CREATE DT_SPLFLA.FOR
6213 *===splfla=============================================================*
6215 SUBROUTINE DT_SPLFLA(NN,MODE)
6217 ************************************************************************
6218 * SamPLing of FLAvors of partons at chain ends. *
6219 * This subroutine replaces FLKSAA/FLKSAM. *
6220 * NN number of nucleon-nucleon interactions *
6221 * MODE = 1 sea-flavors *
6222 * = 2 valence-flavors *
6223 * Based on the original version written by J. Ranft/H.-J. Moehring. *
6224 * This version dated 16.01.95 is written by S. Roesler *
6225 ************************************************************************
6227 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6230 PARAMETER ( LINP = 10 ,
6234 PARAMETER ( MAXNCL = 260,
6237 & MAXSQU = 20*MAXVQU,
6238 & MAXINT = MAXVQU+MAXSQU)
6240 * flavors of partons (DTUNUC 1.x)
6241 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
6242 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
6243 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
6244 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
6245 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
6246 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
6247 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
6249 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6250 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
6251 & IXPV,IXPS,IXTV,IXTS,
6252 & INTVV1(MAXVQU),INTVV2(MAXVQU),
6253 & INTSV1(MAXVQU),INTSV2(MAXVQU),
6254 & INTVS1(MAXVQU),INTVS2(MAXVQU),
6255 & INTSS1(MAXSQU),INTSS2(MAXSQU),
6256 & INTDV1(MAXVQU),INTDV2(MAXVQU),
6257 & INTVD1(MAXVQU),INTVD2(MAXVQU),
6258 & INTDS1(MAXSQU),INTDS2(MAXSQU),
6259 & INTSD1(MAXSQU),INTSD2(MAXSQU)
6261 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6262 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
6263 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
6265 * particle properties (BAMJET index convention)
6267 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6268 & IICH(210),IIBAR(210),K1(210),K2(210)
6270 * various options for treatment of partons (DTUNUC 1.x)
6271 * (chain recombination, Cronin,..)
6272 LOGICAL LCO2CR,LINTPT
6273 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
6279 IPSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
6283 ITSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
6286 ELSEIF (MODE.EQ.2) THEN
6289 CALL DT_FLAHAD(KKPROJ(IFROVP(I)),IPVQ(I),IPPV1(I),IPPV2(I))
6292 CALL DT_FLAHAD(KKTARG(IFROVT(I)),ITVQ(I),ITTV1(I),ITTV2(I))
6299 *$ CREATE DT_GETPTN.FOR
6302 *===getptn=============================================================*
6304 SUBROUTINE DT_GETPTN(IP,NN,NCSY,IREJ)
6306 ************************************************************************
6307 * This subroutine collects partons at chain ends from temporary *
6308 * commons and puts them into DTEVT1. *
6309 * This version dated 15.01.95 is written by S. Roesler *
6310 ************************************************************************
6312 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6315 PARAMETER ( LINP = 10 ,
6319 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0)
6323 PARAMETER ( MAXNCL = 260,
6326 & MAXSQU = 20*MAXVQU,
6327 & MAXINT = MAXVQU+MAXSQU)
6331 PARAMETER (NMXHKK=200000)
6333 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6334 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6335 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6337 * extended event history
6338 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6339 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6342 * flags for input different options
6343 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6344 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6345 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6347 * auxiliary common for chain system storage (DTUNUC 1.x)
6348 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
6351 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
6352 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
6355 * flags for diffractive interactions (DTUNUC 1.x)
6356 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6358 * x-values of partons (DTUNUC 1.x)
6359 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
6360 & XTVQ(MAXVQU),XTVD(MAXVQU),
6361 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
6362 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
6364 * flavors of partons (DTUNUC 1.x)
6365 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
6366 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
6367 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
6368 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
6369 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
6370 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
6371 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
6373 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6374 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
6375 & IXPV,IXPS,IXTV,IXTS,
6376 & INTVV1(MAXVQU),INTVV2(MAXVQU),
6377 & INTSV1(MAXVQU),INTSV2(MAXVQU),
6378 & INTVS1(MAXVQU),INTVS2(MAXVQU),
6379 & INTSS1(MAXSQU),INTSS2(MAXSQU),
6380 & INTDV1(MAXVQU),INTDV2(MAXVQU),
6381 & INTVD1(MAXVQU),INTVD2(MAXVQU),
6382 & INTDS1(MAXSQU),INTDS2(MAXSQU),
6383 & INTSD1(MAXSQU),INTSD2(MAXSQU)
6385 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6386 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
6387 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
6389 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PP(4),PT(4)
6391 DATA AMSS,AMVS,AMDS,AMVD,AMVV/0.4D0,2.0D0,2.0D0,2.5D0,2.0D0/
6399 IF (ISKPCH(1,I).EQ.99) GOTO 10
6400 ICCHAI(1,1) = ICCHAI(1,1)+2
6403 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6404 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6406 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6407 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6408 PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6409 PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6411 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6412 & +(PP1(3)+PT1(3))**2)
6414 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6415 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6416 & +(PP2(3)+PT2(3))**2)
6418 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6419 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6422 IF ((AM1.LT.AMSS).OR.(AM2.LT.AMSS)) THEN
6423 C WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6424 5000 FORMAT(1X,'incon. chain mass SS: ',2I5,2E10.3)
6427 WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6429 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6430 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6431 IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6432 IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6433 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6435 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6437 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6439 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6446 IF (ISKPCH(2,I).EQ.99) GOTO 20
6447 ICCHAI(1,2) = ICCHAI(1,2)+2
6450 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6451 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6453 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6454 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6455 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6456 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6458 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6459 & +(PP1(3)+PT1(3))**2)
6461 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6462 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6463 & +(PP2(3)+PT2(3))**2)
6465 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6466 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6469 IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6470 C WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6471 5001 FORMAT(1X,'incon. chain mass DS: ',2I5,2E10.3)
6474 WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6476 IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6477 IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6478 IFT1 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6479 IFT2 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6480 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6482 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6484 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6486 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6493 IF (ISKPCH(3,I).EQ.99) GOTO 30
6494 ICCHAI(1,3) = ICCHAI(1,3)+2
6497 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6498 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6500 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6501 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6502 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6503 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6505 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6506 & +(PP1(3)+PT1(3))**2)
6508 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6509 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6510 & +(PP2(3)+PT2(3))**2)
6512 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6513 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6516 IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6517 C WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6518 5002 FORMAT(1X,'incon. chain mass SD: ',2I5,2E10.3)
6521 WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6523 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6524 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6525 IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6526 IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6527 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6529 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6531 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6533 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6538 * disea-valence chains
6540 IF (ISKPCH(5,I).EQ.99) GOTO 50
6541 ICCHAI(1,5) = ICCHAI(1,5)+2
6544 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6545 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6547 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6548 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6549 PT1(K) = XTVQ(IDXT) *PHKK(K,MOT)
6550 PT2(K) = XTVD(IDXT) *PHKK(K,MOT)
6552 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6553 & +(PP1(3)+PT1(3))**2)
6555 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6556 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6557 & +(PP2(3)+PT2(3))**2)
6559 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6560 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6563 IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6564 C WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6565 5003 FORMAT(1X,'incon. chain mass DV: ',2I5,2E10.3)
6568 WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6570 IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6571 IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6572 IFT1 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6573 IFT2 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6574 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6576 CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6578 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6580 CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6585 * valence-sea chains
6587 IF (ISKPCH(6,I).EQ.99) GOTO 60
6588 ICCHAI(1,6) = ICCHAI(1,6)+2
6591 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6592 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6594 PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6595 PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6596 PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6597 PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6599 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6600 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6601 IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6602 IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6603 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6605 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6607 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6609 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6611 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6613 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6614 & +(PP1(3)+PT1(3))**2)
6616 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6617 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6618 & +(PP2(3)+PT2(3))**2)
6620 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6622 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6624 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6626 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6628 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6630 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6631 & +(PP1(3)+PT2(3))**2)
6633 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6634 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6635 & +(PP2(3)+PT1(3))**2)
6637 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6639 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6642 IF ((AM1.LT.AMSS).OR.(AM2.LT.AMVS)) THEN
6643 C WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6644 5004 FORMAT(1X,'incon. chain mass VS: ',2I5,2E10.3)
6647 WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6652 * sea-valence chains
6654 IF (ISKPCH(4,I).EQ.99) GOTO 40
6655 ICCHAI(1,4) = ICCHAI(1,4)+2
6658 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6659 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6661 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6662 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6663 PT1(K) = XTVD(IDXT) *PHKK(K,MOT)
6664 PT2(K) = XTVQ(IDXT) *PHKK(K,MOT)
6666 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6667 & +(PP1(3)+PT1(3))**2)
6669 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6670 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6671 & +(PP2(3)+PT2(3))**2)
6673 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6674 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6677 IF ((AM1.LT.AMVS).OR.(AM2.LT.AMSS)) THEN
6678 C WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6679 5005 FORMAT(1X,'incon. chain mass SV: ',2I5,2E10.3)
6682 WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6684 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6685 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6686 IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6687 IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6688 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6690 CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6692 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6694 CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6699 * valence-disea chains
6701 IF (ISKPCH(7,I).EQ.99) GOTO 70
6702 ICCHAI(1,7) = ICCHAI(1,7)+2
6705 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6706 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6708 PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6709 PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6710 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6711 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6713 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6714 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6715 IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6716 IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6717 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6719 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6721 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6723 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6725 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6727 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6728 & +(PP1(3)+PT1(3))**2)
6730 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6731 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6732 & +(PP2(3)+PT2(3))**2)
6734 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6736 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6738 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6740 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6742 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6744 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6745 & +(PP1(3)+PT2(3))**2)
6747 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6748 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6749 & +(PP2(3)+PT1(3))**2)
6751 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6753 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6756 IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6757 C WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6758 5006 FORMAT(1X,'incon. chain mass VD: ',2I5,2E10.3)
6761 WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6766 * valence-valence chains
6768 IF (ISKPCH(8,I).EQ.99) GOTO 80
6769 ICCHAI(1,8) = ICCHAI(1,8)+2
6772 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6773 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6775 PP1(K) = XPVQ(IDXP)*PHKK(K,MOP)
6776 PP2(K) = XPVD(IDXP)*PHKK(K,MOP)
6777 PT1(K) = XTVD(IDXT)*PHKK(K,MOT)
6778 PT2(K) = XTVQ(IDXT)*PHKK(K,MOT)
6780 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6781 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6782 IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6783 IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6785 * check for diffractive event
6787 IF (((ISINGD.GT.0).OR.(IDOUBD.GT.0)).AND.
6788 & (IP.EQ.1).AND.(NN.EQ.1)) THEN
6790 PP(K) = PP1(K)+PP2(K)
6791 PT(K) = PT1(K)+PT2(K)
6794 CALL DT_DIFEVT(IFP1,IFP2,PP,MOP,
6795 & IFT1,IFT2,PT,MOT,IDIFF,NCSY,IREJ1)
6796 C IF (IREJ1.NE.0) GOTO 9999
6797 IF (IREJ1.NE.0) THEN
6805 IF (IDIFF.EQ.0) THEN
6806 * valence-valence chain system
6807 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6810 CALL DT_EVTPUT(-21,IFP1,MOP,0,
6811 & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6812 CALL DT_EVTPUT(-22,IFT1,MOT,0,
6813 & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6814 CALL DT_EVTPUT(-21,IFP2,MOP,0,
6815 & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6816 CALL DT_EVTPUT(-22,IFT2,MOT,0,
6817 & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6818 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6819 & +(PP1(3)+PT1(3))**2)
6821 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6822 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6823 & +(PP2(3)+PT2(3))**2)
6825 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6828 CALL DT_EVTPUT(-21,IFP1,MOP,0,
6829 & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6830 CALL DT_EVTPUT(-22,IFT2,MOT,0,
6831 & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6832 CALL DT_EVTPUT(-21,IFP2,MOP,0,
6833 & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6834 CALL DT_EVTPUT(-22,IFT1,MOT,0,
6835 & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6836 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6837 & +(PP1(3)+PT2(3))**2)
6839 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6840 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6841 & +(PP2(3)+PT1(3))**2)
6843 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6845 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6848 IF ((AM1.LT.AMVV).OR.(AM2.LT.AMVV)) THEN
6849 C WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6850 5007 FORMAT(1X,'incon. chain mass VV: ',2I5,2E10.3)
6853 WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6858 IF (ISTHKK(NPOINT(2)).EQ.1) NPOINT(2) = NPOINT(2)+1
6860 * energy-momentum & flavor conservation check
6861 IF (ABS(IDIFF).NE.1) THEN
6862 IF (IDIFF.NE.0) THEN
6863 IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-41,1,0,
6866 IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-31,-32,0,
6882 *$ CREATE DT_CHKCSY.FOR
6885 *===chkcsy=============================================================*
6887 SUBROUTINE DT_CHKCSY(ID1,ID2,LCHK)
6889 ************************************************************************
6890 * CHeCk Chain SYstem for consistency of partons at chain ends. *
6891 * ID1,ID2 PDG-numbers of partons at chain ends *
6892 * LCHK = .true. consistent chain *
6893 * = .false. inconsistent chain *
6894 * This version dated 18.01.95 is written by S. Roesler *
6895 ************************************************************************
6897 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6900 PARAMETER ( LINP = 10 ,
6909 IF ((ABS(ID1).LE.6).AND.(ABS(ID2).LE.6)) THEN
6910 IF (ID1*ID2.GT.0) LCHK = .FALSE.
6911 * q-qq, aq-aqaq chain
6912 ELSEIF (((ABS(ID1).LE.6).AND.(ABS(ID2).GT.6)).OR.
6913 & ((ABS(ID1).GT.6).AND.(ABS(ID2).LE.6))) THEN
6914 IF (ID1*ID2.LT.0) LCHK = .FALSE.
6916 ELSEIF ((ABS(ID1).GT.6).AND.(ABS(ID2).GT.6)) THEN
6917 IF (ID1*ID2.GT.0) LCHK = .FALSE.
6923 *$ CREATE DT_EVENTA.FOR
6926 *===eventa=============================================================*
6928 SUBROUTINE DT_EVENTA(ID,IP,IT,NCSY,IREJ)
6930 ************************************************************************
6931 * Treatment of nucleon-nucleon interactions in a two-chain *
6933 * (input) ID BAMJET-index of projectile hadron (in case of *
6935 * IP/IT mass number of projectile/target nucleus *
6936 * NCSY number of two chain systems *
6937 * IREJ rejection flag *
6938 * This version dated 15.01.95 is written by S. Roesler *
6939 ************************************************************************
6941 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6944 PARAMETER ( LINP = 10 ,
6948 PARAMETER (TINY10=1.0D-10)
6952 PARAMETER (NMXHKK=200000)
6954 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6955 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6956 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6958 * extended event history
6959 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6960 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6964 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6965 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6966 & IREXCI(3),IRDIFF(2),IRINC
6968 * flags for diffractive interactions (DTUNUC 1.x)
6969 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6971 * particle properties (BAMJET index convention)
6973 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6974 & IICH(210),IIBAR(210),K1(210),K2(210)
6976 * flags for input different options
6977 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6978 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6979 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6981 * various options for treatment of partons (DTUNUC 1.x)
6982 * (chain recombination, Cronin,..)
6983 LOGICAL LCO2CR,LINTPT
6984 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
6987 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
6992 * skip following treatment for low-mass diffraction
6993 IF (ABS(IFLAGD).EQ.1) THEN
6994 NPOINT(3) = NPOINT(2)
6998 * multiple scattering of chain ends
6999 IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
7000 IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
7003 * get a two-chain system from DTEVT1
7011 PT1(K) = PHKK(K,NC+1)
7012 PP2(K) = PHKK(K,NC+2)
7013 PT2(K) = PHKK(K,NC+3)
7019 CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
7020 & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
7021 IF (IREJ1.GT.0) THEN
7023 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTA'
7029 * meson/antibaryon projectile:
7030 * sample single-chain valence-valence systems (Reggeon contrib.)
7031 IF ((IP.EQ.1).AND.(ISICHA.EQ.1)) THEN
7032 IF (IIBAR(ID).LE.0) CALL DT_VV2SCH
7035 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
7036 * check DTEVT1 for remaining resonance mass corrections
7037 CALL DT_EVTRES(IREJ1)
7038 IF (IREJ1.GT.0) THEN
7039 IRRES(1) = IRRES(1)+1
7040 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in EVENTA'
7045 * assign p_t to two-"chain" systems consisting of two resonances only
7046 * since only entries for chains will be affected, this is obsolete
7047 * in case of JETSET-fragmetation
7050 * combine q-aq chains to color ropes (qq-aqaq) (chain fusion)
7051 IF (LCO2CR) CALL DT_COM2CR
7055 * fragmentation of the complete event
7056 **uncomment for internal phojet-fragmentation
7057 C CALL DT_EVTFRA(IREJ1)
7058 CALL DT_EVTFRG(2,IDUM,NPYMEM,IREJ1)
7059 IF (IREJ1.GT.0) THEN
7061 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 3 in EVENTA'
7065 * decay of possible resonances (should be obsolete)
7076 *$ CREATE DT_GETCSY.FOR
7079 *===getcsy=============================================================*
7081 SUBROUTINE DT_GETCSY(IFPR1,PP1,MOP1,IFPR2,PP2,MOP2,
7082 & IFTA1,PT1,MOT1,IFTA2,PT2,MOT2,IREJ)
7084 ************************************************************************
7085 * This version dated 15.01.95 is written by S. Roesler *
7086 ************************************************************************
7088 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7091 PARAMETER ( LINP = 10 ,
7095 PARAMETER (TINY10=1.0D-10)
7099 PARAMETER (NMXHKK=200000)
7101 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7102 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7103 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7105 * extended event history
7106 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7107 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7111 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7112 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7113 & IREXCI(3),IRDIFF(2),IRINC
7115 * flags for input different options
7116 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7117 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7118 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7120 * flags for diffractive interactions (DTUNUC 1.x)
7121 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
7123 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),
7124 & IFP1(2),IFP2(2),IFT1(2),IFT2(2),PCH1(4),PCH2(4)
7128 * get quark content of partons
7135 IFP1(1) = IDT_IPDG2B(IFPR1,1,2)
7136 IF (ABS(IFPR1).GE.1000) IFP1(2) = IDT_IPDG2B(IFPR1,2,2)
7137 IFP2(1) = IDT_IPDG2B(IFPR2,1,2)
7138 IF (ABS(IFPR2).GE.1000) IFP2(2) = IDT_IPDG2B(IFPR2,2,2)
7139 IFT1(1) = IDT_IPDG2B(IFTA1,1,2)
7140 IF (ABS(IFTA1).GE.1000) IFT1(2) = IDT_IPDG2B(IFTA1,2,2)
7141 IFT2(1) = IDT_IPDG2B(IFTA2,1,2)
7142 IF (ABS(IFTA2).GE.1000) IFT2(2) = IDT_IPDG2B(IFTA2,2,2)
7144 * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq, 3 - qq-aqaq)
7146 IF ((IFP1(2).EQ.0).AND.(IFT1(2).EQ.0)) IDCH1 = 1
7147 IF ((IFP1(2).NE.0).AND.(IFT1(2).NE.0)) IDCH1 = 3
7149 IF ((IFP2(2).EQ.0).AND.(IFT2(2).EQ.0)) IDCH2 = 1
7150 IF ((IFP2(2).NE.0).AND.(IFT2(2).NE.0)) IDCH2 = 3
7152 * store initial configuration for energy-momentum cons. check
7153 IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IDUM)
7155 * sample intrinsic p_t at chain-ends
7156 CALL DT_GETSPT(PP1,IFPR1,IFP1,PP2,IFPR2,IFP2,
7157 & PT1,IFTA1,IFT1,PT2,IFTA2,IFT2,
7158 & AMCH1,IDCH1,AMCH2,IDCH2,IDCH(MOP1),IREJ1)
7159 IF (IREJ1.NE.0) THEN
7160 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in GETCSY'
7165 C IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
7166 C IF ((IDCH1.EQ.3).OR.((IDCH1.GT.1).AND.(IDCH2.EQ.1))) THEN
7167 C* check second chain for resonance
7168 C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7169 C & AMCH2,AMCH2N,IDCH2,IREJ1)
7170 C IF (IREJ1.NE.0) GOTO 9999
7171 C IF (IDR2.NE.0) THEN
7172 C CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
7173 C & AMCH2,AMCH2N,AMCH1,IREJ1)
7174 C IF (IREJ1.NE.0) GOTO 9999
7176 C* check first chain for resonance
7177 C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7178 C & AMCH1,AMCH1N,IDCH1,IREJ1)
7179 C IF (IREJ1.NE.0) GOTO 9999
7180 C IF (IDR1.NE.0) IDR1 = 100*IDR1
7182 C* check first chain for resonance
7183 C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7184 C & AMCH1,AMCH1N,IDCH1,IREJ1)
7185 C IF (IREJ1.NE.0) GOTO 9999
7186 C IF (IDR1.NE.0) THEN
7187 C CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
7188 C & AMCH1,AMCH1N,AMCH2,IREJ1)
7189 C IF (IREJ1.NE.0) GOTO 9999
7191 C* check second chain for resonance
7192 C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7193 C & AMCH2,AMCH2N,IDCH2,IREJ1)
7194 C IF (IREJ1.NE.0) GOTO 9999
7195 C IF (IDR2.NE.0) IDR2 = 100*IDR2
7199 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
7200 * check chains for resonances
7201 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7202 & AMCH1,AMCH1N,IDCH1,IREJ1)
7203 IF (IREJ1.NE.0) GOTO 9999
7204 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7205 & AMCH2,AMCH2N,IDCH2,IREJ1)
7206 IF (IREJ1.NE.0) GOTO 9999
7207 * change kinematics corresponding to resonance-masses
7208 IF ( (IDR1.NE.0).AND.(IDR2.EQ.0) ) THEN
7209 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
7210 & AMCH1,AMCH1N,AMCH2,IREJ1)
7211 IF (IREJ1.GT.0) GOTO 9999
7212 IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
7213 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7214 & AMCH2,AMCH2N,IDCH2,IREJ1)
7215 IF (IREJ1.NE.0) GOTO 9999
7216 IF (IDR2.NE.0) IDR2 = 100*IDR2
7217 ELSEIF ( (IDR1.EQ.0).AND.(IDR2.NE.0) ) THEN
7218 CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
7219 & AMCH2,AMCH2N,AMCH1,IREJ1)
7220 IF (IREJ1.GT.0) GOTO 9999
7221 IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
7222 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7223 & AMCH1,AMCH1N,IDCH1,IREJ1)
7224 IF (IREJ1.NE.0) GOTO 9999
7225 IF (IDR1.NE.0) IDR1 = 100*IDR1
7226 ELSEIF ( (IDR1.NE.0).AND.(IDR2.NE.0) ) THEN
7227 AMDIF1 = ABS(AMCH1-AMCH1N)
7228 AMDIF2 = ABS(AMCH2-AMCH2N)
7229 IF (AMDIF2.LT.AMDIF1) THEN
7230 CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
7231 & AMCH2,AMCH2N,AMCH1,IREJ1)
7232 IF (IREJ1.GT.0) GOTO 9999
7233 IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
7234 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),
7235 & IDR1,IDXR1,AMCH1,AMCH1N,IDCH1,IREJ1)
7236 IF (IREJ1.NE.0) GOTO 9999
7237 IF (IDR1.NE.0) IDR1 = 100*IDR1
7239 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
7240 & AMCH1,AMCH1N,AMCH2,IREJ1)
7241 IF (IREJ1.GT.0) GOTO 9999
7242 IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
7243 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),
7244 & IDR2,IDXR2,AMCH2,AMCH2N,IDCH2,IREJ1)
7245 IF (IREJ1.NE.0) GOTO 9999
7246 IF (IDR2.NE.0) IDR2 = 100*IDR2
7251 * store final configuration for energy-momentum cons. check
7253 CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IDUM)
7254 CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
7255 IF (IREJ1.NE.0) GOTO 9999
7258 * put partons and chains into DTEVT1
7260 PCH1(I) = PP1(I)+PT1(I)
7261 PCH2(I) = PP2(I)+PT2(I)
7263 CALL DT_EVTPUT(-ISTHKK(MOP1),IFPR1,MOP1,0,PP1(1),PP1(2),
7264 & PP1(3),PP1(4),0,0,0)
7265 CALL DT_EVTPUT(-ISTHKK(MOT1),IFTA1,MOT1,0,PT1(1),PT1(2),
7266 & PT1(3),PT1(4),0,0,0)
7267 KCH = 100+IDCH(MOP1)*10+1
7268 CALL DT_EVTPUT(KCH,88888,-2,-1,
7269 & PCH1(1),PCH1(2),PCH1(3),PCH1(4),IDR1,IDXR1,IDCH(MOP1))
7270 CALL DT_EVTPUT(-ISTHKK(MOP2),IFPR2,MOP2,0,PP2(1),PP2(2),
7271 & PP2(3),PP2(4),0,0,0)
7272 CALL DT_EVTPUT(-ISTHKK(MOT2),IFTA2,MOT2,0,PT2(1),PT2(2),
7273 & PT2(3),PT2(4),0,0,0)
7275 CALL DT_EVTPUT(KCH,88888,-2,-1,
7276 & PCH2(1),PCH2(2),PCH2(3),PCH2(4),IDR2,IDXR2,IDCH(MOP2))
7281 IF ((IDCH(MOP1).LE.3).AND.(IDCH(MOP2).LE.3)) THEN
7282 * "cancel" sea-sea chains
7283 CALL DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ1)
7284 IF (IREJ1.NE.0) GOTO 9998
7285 **sr 16.5. flag for EVENTB
7294 *$ CREATE DT_CHKINE.FOR
7297 *===chkine=============================================================*
7299 SUBROUTINE DT_CHKINE(PP1I,IFP1,PP2I,IFP2,PT1I,IFT1,PT2I,IFT2,
7300 & AMCH1,AMCH1N,AMCH2,IREJ)
7302 ************************************************************************
7303 * This subroutine replaces CORMOM. *
7304 * This version dated 05.01.95 is written by S. Roesler *
7305 ************************************************************************
7307 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7310 PARAMETER ( LINP = 10 ,
7314 PARAMETER (TINY10=1.0D-10)
7316 * flags for input different options
7317 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7318 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7319 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7322 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7323 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7324 & IREXCI(3),IRDIFF(2),IRINC
7326 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),P1(4),P2(4),
7327 & PP1I(4),PP2I(4),PT1I(4),PT2I(4)
7332 SCALE = AMCH1N/MAX(AMCH1,TINY10)
7338 PP2(I) = PP2(I)+(1.0D0-SCALE)*PP1(I)
7339 PT2(I) = PT2(I)+(1.0D0-SCALE)*PT1(I)
7340 PP1(I) = SCALE*PP1(I)
7341 PT1(I) = SCALE*PT1(I)
7343 IF ((PP1(4).LT.0.0D0).OR.(PP2(4).LT.0.0D0).OR.
7344 & (PT1(4).LT.0.0D0).OR.(PT2(4).LT.0.0D0)) GOTO 9997
7347 PCH = SQRT( (PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2+
7348 & (PP2(3)+PT2(3))**2 )
7349 AMCH22 = (ECH-PCH)*(ECH+PCH)
7350 IF (AMCH22.LT.0.0D0) THEN
7352 & WRITE(LOUT,'(1X,A)') 'CHKINE: inconsistent treatment!'
7357 AMCH2 = SQRT(AMCH22)
7359 * put partons again on mass shell
7363 IF (JMSHL.EQ.1) THEN
7369 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
7370 IF (IREJ1.NE.0) THEN
7371 IF (JMSHL.EQ.0) GOTO 9998
7383 IF (JMSHL.EQ.1) THEN
7389 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P1,P2,IREJ1)
7390 IF (IREJ1.NE.0) THEN
7391 IF (JMSHL.EQ.0) GOTO 9998
7407 9997 IRCHKI(1) = IRCHKI(1)+1
7413 9998 IRCHKI(2) = IRCHKI(2)+1
7416 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in CHKINE'
7421 *$ CREATE DT_CH2RES.FOR
7424 *===ch2res=============================================================*
7426 SUBROUTINE DT_CH2RES(IF1,IF2,IF3,IF4,IDR,IDXR,
7427 & AM,AMN,IMODE,IREJ)
7429 ************************************************************************
7430 * Check chains for resonance production. *
7431 * This subroutine replaces COMCMA/COBCMA/COMCM2 *
7433 * IF1,2,3,4 input flavors (q,aq in any order) *
7435 * MODE = 1 check q-aq chain for meson-resonance *
7436 * = 2 check q-qq, aq-aqaq chain for baryon-resonance *
7437 * = 3 check qq-aqaq chain for lower mass cut *
7439 * IDR = 0 no resonances found *
7440 * = -1 pseudoscalar meson/octet baryon *
7441 * = 1 vector-meson/decuplet baryon *
7442 * IDXR BAMJET-index of corresponding resonance *
7443 * AMN mass of corresponding resonance *
7445 * IREJ rejection flag *
7446 * This version dated 06.01.95 is written by S. Roesler *
7447 ************************************************************************
7449 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7452 PARAMETER ( LINP = 10 ,
7456 * particle properties (BAMJET index convention)
7458 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7459 & IICH(210),IIBAR(210),K1(210),K2(210)
7461 * quark-content to particle index conversion (DTUNUC 1.x)
7462 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
7463 & IA08(6,21),IA10(6,21)
7466 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7467 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7468 & IREXCI(3),IRDIFF(2),IRINC
7470 * flags for input different options
7471 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7472 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7473 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7475 DIMENSION IF(4),JF(4)
7478 C DATA AMLOM,AMLOB /0.08D0,0.2D0/
7479 DATA AMLOM,AMLOB /0.1D0,0.7D0/
7481 C DATA AMLOM,AMLOB /0.001D0,0.001D0/
7485 IF ((MODE.LT.1).OR.(MODE.GT.3)) THEN
7486 WRITE(LOUT,1000) MODE
7487 1000 FORMAT(1X,'CH2RES: MODE ',I4,' not supported!',/,
7488 & 1X,' program stopped')
7497 IF ((AM.LE.0.0D0).AND.(MODE.EQ.1)) AMX = AMLOM
7498 IF ((AM.LE.0.0D0).AND.(MODE.EQ.2)) AMX = AMLOB
7506 IF (IF(I).NE.0) THEN
7511 IF (NF.LE.MODE) THEN
7512 WRITE(LOUT,1001) MODE,IF
7513 1001 FORMAT(1X,'CH2RES: inconsistent input flavors in MODE ',
7514 & I4,' IF1 = ',I4,' IF2 = ',I4,' IF3 = ',I4,' IF4 = ',I4)
7520 * check for meson resonance
7524 IF (JF(2).GT.0) THEN
7528 IFPS = IMPS(IFAQ,IFQ)
7529 IFV = IMVE(IFAQ,IFQ)
7533 IF (AMX.LT.AMV) THEN
7534 IF (AMX.LT.AMPS) THEN
7535 IF (IMODE.GT.0) THEN
7536 IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOM)) GOTO 9999
7538 IF (AMX.LT.0.8D0*AMPS) GOTO 9999
7542 * replace chain by pseudoscalar meson
7546 ELSEIF (AMX.LT.AMHI) THEN
7547 * replace chain by vector-meson
7554 * check for baryon resonance
7556 CALL DT_DBKLAS(JF(1),JF(2),JF(3),JB8,JB10)
7560 IF (AMX.LT.AM10) THEN
7561 IF (AMX.LT.AM8) THEN
7562 IF (IMODE.GT.0) THEN
7563 IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOB)) GOTO 9999
7565 IF (AMX.LT.0.8D0*AM8) GOTO 9999
7569 * replace chain by oktet baryon
7573 ELSEIF (AMX.LT.AMHI) THEN
7580 * check qq-aqaq for lower mass cut
7582 * empirical definition of AMHI to allow for (b-antib)-pair prod.
7584 IF (AMX.LT.AMHI) GOTO 9999
7588 IF ((IOULEV(1).GT.0).AND.(IMODE.GT.0))
7589 & WRITE(LOUT,*) 'rejected 1 in CH2RES',IMODE
7591 IRRES(2) = IRRES(2)+1
7595 *$ CREATE DT_RJSEAC.FOR
7598 *===rjseac=============================================================*
7600 SUBROUTINE DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ)
7602 ************************************************************************
7603 * ReJection of SEA-sea Chains. *
7604 * MOP1/2 entries of projectile sea-partons in DTEVT1 *
7605 * MOT1/2 entries of projectile sea-partons in DTEVT1 *
7606 * This version dated 16.01.95 is written by S. Roesler *
7607 ************************************************************************
7609 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7612 PARAMETER ( LINP = 10 ,
7616 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
7620 PARAMETER (NMXHKK=200000)
7622 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7623 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7624 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7626 * extended event history
7627 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7628 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7632 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7633 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7636 DIMENSION IDXSEA(2,2),IDXNUC(2),ISTVAL(2)
7640 * projectile sea q-aq-pair
7641 * indices of sea-pair
7644 * index of mother-nucleon
7645 IDXNUC(1) = JMOHKK(1,MOP1)
7646 * status of valence quarks to be corrected
7649 * target sea q-aq-pair
7650 * indices of sea-pair
7653 * index of mother-nucleon
7654 IDXNUC(2) = JMOHKK(1,MOT1)
7655 * status of valence quarks to be corrected
7660 DO 2 I=NPOINT(2),NHKK
7661 IF ((ISTHKK(I).EQ.ISTVAL(N)).AND.
7662 & (JMOHKK(1,I).EQ.IDXNUC(N))) THEN
7663 * valence parton found
7664 * inrease 4-momentum by sea 4-momentum
7666 PHKK(K,I) = PHKK(K,I)+PHKK(K,IDXSEA(N,1))+
7667 & PHKK(K,IDXSEA(N,2))
7669 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
7670 & PHKK(2,I)**2-PHKK(3,I)**2))
7673 ISTHKK(IDXSEA(N,J)) = 100
7674 IDHKK(IDXSEA(N,J)) = 0
7675 JMOHKK(1,IDXSEA(N,J)) = 0
7676 JMOHKK(2,IDXSEA(N,J)) = 0
7677 JDAHKK(1,IDXSEA(N,J)) = 0
7678 JDAHKK(2,IDXSEA(N,J)) = 0
7680 PHKK(K,IDXSEA(N,J)) = ZERO
7681 VHKK(K,IDXSEA(N,J)) = ZERO
7682 WHKK(K,IDXSEA(N,J)) = ZERO
7684 PHKK(5,IDXSEA(N,J)) = ZERO
7689 IF (IDONE.NE.1) THEN
7690 WRITE(LOUT,1000) NEVHKK,MOP1,MOP2,MOT1,MOT2
7691 1000 FORMAT(1X,'RJSEAC: event ',I8,': inconsistent event',
7692 & '-record!',/,1X,' sea-quark pairs ',
7693 & 2I5,4X,2I5,' could not be canceled!')
7705 *$ CREATE DT_VV2SCH.FOR
7708 *===vv2sch=============================================================*
7710 SUBROUTINE DT_VV2SCH
7712 ************************************************************************
7713 * Change Valence-Valence chain systems to Single CHain systems for *
7714 * hadron-nucleus collisions with meson or antibaryon projectile. *
7715 * (Reggeon contribution) *
7716 * The single chain system is approximately treated as one chain and a *
7718 * This version dated 18.01.95 is written by S. Roesler *
7719 ************************************************************************
7721 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7724 PARAMETER ( LINP = 10 ,
7728 PARAMETER (ZERO=0.0D0,TINY7=1.0D-7,TINY3=1.0D-3)
7734 PARAMETER (NMXHKK=200000)
7736 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7737 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7738 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7740 * extended event history
7741 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7742 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7745 * flags for input different options
7746 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7747 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7748 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7751 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7752 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7755 DIMENSION IF(4,2),MO(4),PP1(4),PP2(4),PT1(4),PT2(4),PCH1(4),
7758 DATA LSTART /.TRUE./
7763 1000 FORMAT(/,1X,'VV2SCH: Reggeon contribution to valance-',
7764 & 'valence chains treated')
7770 * get index of first chain
7771 DO 1 I=NPOINT(3),NHKK
7772 IF (IDHKK(I).EQ.88888) THEN
7779 IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)
7780 & .AND.(NC.LT.NSTOP)) THEN
7781 * get valence-valence chains
7782 IF ((IDCH(NC).EQ.8).AND.(IDCH(NC+3).EQ.8)) THEN
7783 * get "mother"-hadron indices
7784 MO1 = JMOHKK(1,JMOHKK(1,JMOHKK(1,NC)))
7785 MO2 = JMOHKK(1,JMOHKK(1,JMOHKK(2,NC)))
7786 KPROJ = IDT_ICIHAD(IDHKK(MO1))
7787 KTARG = IDT_ICIHAD(IDHKK(MO2))
7788 * Lab momentum of projectile hadron
7789 CALL DT_LTNUC(PHKK(3,MO1),PHKK(4,MO1),PPZ,PPE,-3)
7790 PTOT = SQRT(PHKK(1,MO1)**2+PHKK(2,MO1)**2+
7793 SICHAP = DT_PHNSCH(KPROJ,KTARG,PTOT)
7794 IF (DT_RNDM(PTOT).LE.SICHAP) THEN
7796 * single chain requested
7797 * get flavors of chain-end partons
7798 MO(1) = JMOHKK(1,NC)
7799 MO(2) = JMOHKK(2,NC)
7800 MO(3) = JMOHKK(1,NC+3)
7801 MO(4) = JMOHKK(2,NC+3)
7803 IF(I,1) = IDT_IPDG2B(IDHKK(MO(I)),1,2)
7805 IF (ABS(IDHKK(MO(I))).GE.1000)
7806 & IF(I,2) = IDT_IPDG2B(IDHKK(MO(I)),2,2)
7808 * which one is the q-aq chain?
7809 * N1,N1+1 - DTEVT1-entries for q-aq system
7810 * N2,N2+1 - DTEVT1-entries for the other chain
7811 IF ((IF(1,2).EQ.0).AND.(IF(2,2).EQ.0)) THEN
7816 ELSEIF ((IF(3,2).EQ.0).AND.(IF(4,2).EQ.0)) THEN
7826 PT1(K) = PHKK(K,N1+1)
7828 PT2(K) = PHKK(K,N2+1)
7830 AMCH1 = PHKK(5,N1+2)
7831 AMCH2 = PHKK(5,N2+2)
7832 * get meson-identity corresponding to flavors of q-aq chain
7835 CALL DT_CH2RES(IF(K1,1),IF(K1+1,1),0,0,IDR1,IDXR1,
7836 & ZERO,AMCH1N,1,IDUM)
7838 * change kinematics of chains
7839 CALL DT_CHKINE(PP1,IDHKK(N1), PP2,IDHKK(N2),
7840 & PT1,IDHKK(N1+1),PT2,IDHKK(N2+1),
7841 & AMCH1,AMCH1N,AMCH2,IREJ1)
7842 IF (IREJ1.NE.0) GOTO 10
7843 * check second chain for resonance
7845 IF ((IF(K2,2).NE.0).AND.(IF(K2+1,2).NE.0)) IDCHAI = 3
7846 CALL DT_CH2RES(IF(K2,1),IF(K2,2),IF(K2+1,1),IF(K2+1,2),
7847 & IDR2,IDXR2,AMCH2,AMCH2N,IDCHAI,IREJ1)
7848 IF (IREJ1.NE.0) GOTO 10
7849 IF (IDR2.NE.0) IDR2 = 100*IDR2
7850 * add partons and chains to DTEVT1
7852 PCH1(K) = PP1(K)+PT1(K)
7853 PCH2(K) = PP2(K)+PT2(K)
7855 CALL DT_EVTPUT(ISTHKK(N1),IDHKK(N1),N1,0,PP1(1),PP1(2),
7856 & PP1(3),PP1(4),0,0,0)
7857 CALL DT_EVTPUT(ISTHKK(N1+1),IDHKK(N1+1),N1+1,0,PT1(1),
7858 & PT1(2),PT1(3),PT1(4),0,0,0)
7859 KCH = ISTHKK(N1+2)+100
7860 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH1(1),PCH1(2),PCH1(3),
7861 & PCH1(4),IDR1,IDXR1,IDCH(N1+2))
7863 CALL DT_EVTPUT(ISTHKK(N2),IDHKK(N2),N2,0,PP2(1),PP2(2),
7864 & PP2(3),PP2(4),0,0,0)
7865 CALL DT_EVTPUT(ISTHKK(N2+1),IDHKK(N2+1),N2+1,0,PT2(1),
7866 & PT2(2),PT2(3),PT2(4),0,0,0)
7867 KCH = ISTHKK(N2+2)+100
7868 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH2(1),PCH2(2),PCH2(3),
7869 & PCH2(4),IDR2,IDXR2,IDCH(N2+2))
7885 *$ CREATE DT_PHNSCH.FOR
7888 *=== phnsch ===========================================================*
7890 DOUBLE PRECISION FUNCTION DT_PHNSCH( KP, KTARG, PLAB )
7892 *----------------------------------------------------------------------*
7894 * Probability for Hadron Nucleon Single CHain interactions: *
7896 * Created on 30 december 1993 by Alfredo Ferrari & Paola Sala *
7899 * Last change on 04-jan-94 by Alfredo Ferrari *
7901 * modified by J.R.for use in DTUNUC 6.1.94 *
7903 * Input variables: *
7904 * Kp = hadron projectile index (Part numbering *
7906 * Ktarg = target nucleon index (1=proton, 8=neutron) *
7907 * Plab = projectile laboratory momentum (GeV/c) *
7908 * Output variable: *
7909 * Phnsch = probability per single chain (particle *
7910 * exchange) interactions *
7912 *----------------------------------------------------------------------*
7914 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7917 PARAMETER ( LUNOUT = 6 )
7918 PARAMETER ( LUNERR = 6 )
7919 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
7920 PARAMETER ( ZERZER = 0.D+00 )
7921 PARAMETER ( ONEONE = 1.D+00 )
7922 PARAMETER ( TWOTWO = 2.D+00 )
7923 PARAMETER ( FIVFIV = 5.D+00 )
7924 PARAMETER ( HLFHLF = 0.5D+00 )
7926 PARAMETER ( NALLWP = 39 )
7927 PARAMETER ( IDMAXP = 210 )
7929 DIMENSION ICHRGE(39),AM(39)
7931 * particle properties (BAMJET index convention)
7933 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7934 & IICH(210),IIBAR(210),K1(210),K2(210)
7936 DIMENSION KPTOIP(210)
7938 * auxiliary common for reggeon exchange (DTUNUC 1.x)
7939 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
7940 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
7941 & IQTCHR(-6:6),MQUARK(3,39)
7943 DIMENSION SGTCOE (5,33), IHLP (NALLWP)
7944 DIMENSION SGTCO1(5,10),SGTCO2(5,8),SGTCO3(5,15)
7945 EQUIVALENCE (SGTCO1(1,1),SGTCOE(1,1))
7946 EQUIVALENCE (SGTCO2(1,1),SGTCOE(1,11))
7947 EQUIVALENCE (SGTCO3(1,1),SGTCOE(1,19))
7949 * Conversion from part to paprop numbering
7950 DATA KPTOIP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
7951 & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 66*0,
7952 & 34, 36, 31, 32, 33, 35, 37, 5*0, 38, 5*0, 39, 19*0, 27, 28, 74*0/
7954 * 1=baryon, 2=pion, 3=kaon, 4=antibaryon:
7955 DATA IHLP/1,4,5*0,1,4,2*0,3,2*2,2*3,1,4,3,3*1,2,
7956 & 2*3, 2, 4*0, 3*4, 1, 4, 1, 4, 1, 4 /
7957 C DATA ( ( SGTCOE (J,I), J=1,5 ), I=1,10 ) /
7959 * 1st reaction: gamma p total
7960 &0.147 D+00, ZERZER , ZERZER , 0.0022D+00, -0.0170D+00,
7961 * 2nd reaction: gamma d total
7962 &0.300 D+00, ZERZER , ZERZER , 0.0095D+00, -0.057 D+00,
7963 * 3rd reaction: pi+ p total
7964 &16.4 D+00, 19.3D+00, -0.42D+00, 0.19 D+00, ZERZER ,
7965 * 4th reaction: pi- p total
7966 &33.0 D+00, 14.0D+00, -1.36D+00, 0.456 D+00, -4.03 D+00,
7967 * 5th reaction: pi+/- d total
7968 &56.8 D+00, 42.2D+00, -1.45D+00, 0.65 D+00, -5.39 D+00,
7969 * 6th reaction: K+ p total
7970 &18.1 D+00, ZERZER , ZERZER , 0.26 D+00, -1.0 D+00,
7971 * 7th reaction: K+ n total
7972 &18.7 D+00, ZERZER , ZERZER , 0.21 D+00, -0.89 D+00,
7973 * 8th reaction: K+ d total
7974 &34.2 D+00, 7.9 D+00, -2.1 D+00, 0.346 D+00, -0.99 D+00,
7975 * 9th reaction: K- p total
7976 &32.1 D+00, ZERZER , ZERZER , 0.66 D+00, -5.6 D+00,
7977 * 10th reaction: K- n total
7978 &25.2 D+00, ZERZER , ZERZER , 0.38 D+00, -2.9 D+00/
7979 C DATA ( ( SGTCOE (J,I), J=1,5 ), I=11,18 ) /
7981 * 11th reaction: K- d total
7982 &57.6 D+00, ZERZER , ZERZER , 1.17 D+00, -9.5 D+00,
7983 * 12th reaction: p p total
7984 &48.0 D+00, ZERZER , ZERZER , 0.522 D+00, -4.51 D+00,
7985 * 13th reaction: p n total
7986 &47.30 D+00, ZERZER , ZERZER , 0.513 D+00, -4.27 D+00,
7987 * 14th reaction: p d total
7988 &91.3 D+00, ZERZER , ZERZER , 1.05 D+00, -8.8 D+00,
7989 * 15th reaction: pbar p total
7990 &38.4 D+00, 77.6D+00, -0.64D+00, 0.26 D+00, -1.2 D+00,
7991 * 16th reaction: pbar n total
7992 &ZERZER ,133.6D+00, -0.70D+00, -1.22 D+00, 13.7 D+00,
7993 * 17th reaction: pbar d total
7994 &112. D+00, 125.D+00, -1.08D+00, 1.14 D+00, -12.4 D+00,
7995 * 18th reaction: Lamda p total
7996 &30.4 D+00, ZERZER , ZERZER , ZERZER , 1.6 D+00/
7997 C DATA ( ( SGTCOE (J,I), J=1,5 ), I=19,33 ) /
7999 * 19th reaction: pi+ p elastic
8000 &ZERZER , 11.4D+00, -0.4 D+00, 0.079 D+00, ZERZER ,
8001 * 20th reaction: pi- p elastic
8002 &1.76 D+00, 11.2D+00, -0.64D+00, 0.043 D+00, ZERZER ,
8003 * 21st reaction: K+ p elastic
8004 &5.0 D+00, 8.1 D+00, -1.8 D+00, 0.16 D+00, -1.3 D+00,
8005 * 22nd reaction: K- p elastic
8006 &7.3 D+00, ZERZER , ZERZER , 0.29 D+00, -2.40 D+00,
8007 * 23rd reaction: p p elastic
8008 &11.9 D+00, 26.9D+00, -1.21D+00, 0.169 D+00, -1.85 D+00,
8009 * 24th reaction: p d elastic
8010 &16.1 D+00, ZERZER , ZERZER , 0.32 D+00, -3.4 D+00,
8011 * 25th reaction: pbar p elastic
8012 &10.2 D+00, 52.7D+00, -1.16D+00, 0.125 D+00, -1.28 D+00,
8013 * 26th reaction: pbar p elastic bis
8014 &10.6 D+00, 53.1D+00, -1.19D+00, 0.136 D+00, -1.41 D+00,
8015 * 27th reaction: pbar n elastic
8016 &36.5 D+00, ZERZER , ZERZER , ZERZER , -11.9 D+00,
8017 * 28th reaction: Lamda p elastic
8018 &12.3 D+00, ZERZER , ZERZER , ZERZER , -2.4 D+00,
8019 * 29th reaction: K- p ela bis
8020 &7.24 D+00, 46.0D+00, -4.71D+00, 0.279 D+00, -2.35 D+00,
8021 * 30th reaction: pi- p cx
8022 &ZERZER ,0.912D+00, -1.22D+00, ZERZER , ZERZER ,
8023 * 31st reaction: K- p cx
8024 &ZERZER , 3.39D+00, -1.75D+00, ZERZER , ZERZER ,
8025 * 32nd reaction: K+ n cx
8026 &ZERZER , 7.18D+00, -2.01D+00, ZERZER , ZERZER ,
8027 * 33rd reaction: pbar p cx
8028 &ZERZER , 18.8D+00, -2.01D+00, ZERZER , ZERZER /
8030 * +-------------------------------------------------------------------*
8031 ICHRGE(KTARG)=IICH(KTARG)
8032 AM (KTARG)=AAM (KTARG)
8033 * | Check for pi0 (d-dbar)
8034 IF ( KP .NE. 26 ) THEN
8040 * +-------------------------------------------------------------------*
8047 * +-------------------------------------------------------------------*
8048 * +-------------------------------------------------------------------*
8049 * | No such interactions for baryon-baryon
8050 IF ( IIBAR (KP) .GT. 0 ) THEN
8054 * +-------------------------------------------------------------------*
8055 * | No "annihilation" diagram possible for K+ p/n
8056 ELSE IF ( IP .EQ. 15 ) THEN
8060 * +-------------------------------------------------------------------*
8061 * | No "annihilation" diagram possible for K0 p/n
8062 ELSE IF ( IP .EQ. 24 ) THEN
8066 * +-------------------------------------------------------------------*
8067 * | No "annihilation" diagram possible for Omebar p/n
8068 ELSE IF ( IP .GE. 38 ) THEN
8073 * +-------------------------------------------------------------------*
8074 * +-------------------------------------------------------------------*
8075 * | If the momentum is larger than 50 GeV/c, compute the single
8076 * | chain probability at 50 GeV/c and extrapolate to the present
8077 * | momentum according to 1/sqrt(s)
8078 * | sigma = sigma_sch (50) * sqrt (s(50)/s) + sigma_dch
8079 * | P_sch (50) = sigma_sch (50) / ( sigma_dch + sigma_sch (50) )
8080 * | sigma_dch / sigma_sch (50) = 1 / P_sch (50) - 1
8081 * | sigma_dch / sigma_sch = 1 / P_sch - 1 = ( 1 / P_sch (50) - 1 )
8083 * | P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
8084 IF ( PLAB .GT. 50.D+00 ) THEN
8087 AMTSQ = AM (KTARG)**2
8088 EPROJ = SQRT ( PLAB**2 + AMPSQ )
8089 UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8090 EPROJ = SQRT ( PLA**2 + AMPSQ )
8091 UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8092 UMORAT = SQRT ( UMOSQ / UMO50 )
8094 * +-------------------------------------------------------------------*
8096 ELSE IF ( PLAB .LT. 3.D+00 ) THEN
8099 AMTSQ = AM (KTARG)**2
8100 EPROJ = SQRT ( PLAB**2 + AMPSQ )
8101 UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8102 EPROJ = SQRT ( PLA**2 + AMPSQ )
8103 UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8104 UMORAT = SQRT ( UMOSQ / UMO50 )
8106 * +-------------------------------------------------------------------*
8113 * +-------------------------------------------------------------------*
8115 * +-------------------------------------------------------------------*
8117 IF ( IHLP (IP) .EQ. 2 ) THEN
8123 * | Compute the pi+ p total cross section:
8124 SPPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8126 ACOF = SGTCOE (1,19)
8127 BCOF = SGTCOE (2,19)
8128 ENNE = SGTCOE (3,19)
8129 CCOF = SGTCOE (4,19)
8130 DCOF = SGTCOE (5,19)
8131 * | Compute the pi+ p elastic cross section:
8132 SPPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8134 * | Compute the pi+ p inelastic cross section:
8135 SPPPIN = SPPPTT - SPPPEL
8141 * | Compute the pi- p total cross section:
8142 SPMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8144 ACOF = SGTCOE (1,20)
8145 BCOF = SGTCOE (2,20)
8146 ENNE = SGTCOE (3,20)
8147 CCOF = SGTCOE (4,20)
8148 DCOF = SGTCOE (5,20)
8149 * | Compute the pi- p elastic cross section:
8150 SPMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8152 * | Compute the pi- p inelastic cross section:
8153 SPMPIN = SPMPTT - SPMPEL
8154 SIGDIA = SPMPIN - SPPPIN
8155 * | +----------------------------------------------------------------*
8156 * | | Charged pions: besides isospin consideration it is supposed
8157 * | | that (pi+ n)el is almost equal to (pi- p)el
8158 * | | and (pi+ p)el " " " " (pi- n)el
8159 * | | and all are almost equal among each others
8160 * | | (reasonable above 5 GeV/c)
8161 IF ( ICHRGE (IP) .NE. 0 ) THEN
8163 JREAC = 3 + IP - 13 + ICHRGE (IP) * KHELP
8164 ACOF = SGTCOE (1,JREAC)
8165 BCOF = SGTCOE (2,JREAC)
8166 ENNE = SGTCOE (3,JREAC)
8167 CCOF = SGTCOE (4,JREAC)
8168 DCOF = SGTCOE (5,JREAC)
8169 * | | Compute the total cross section:
8170 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8172 JREAC = 19 + IP - 13 + ICHRGE (IP) * KHELP
8173 ACOF = SGTCOE (1,JREAC)
8174 BCOF = SGTCOE (2,JREAC)
8175 ENNE = SGTCOE (3,JREAC)
8176 CCOF = SGTCOE (4,JREAC)
8177 DCOF = SGTCOE (5,JREAC)
8178 * | | Compute the elastic cross section:
8179 SHNCEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8181 * | | Compute the inelastic cross section:
8182 SHNCIN = SHNCTT - SHNCEL
8183 * | | Number of diagrams:
8184 NDIAGR = 1 + IP - 13 + ICHRGE (IP) * KHELP
8185 * | | Now compute the chain end (anti)quark-(anti)diquark
8186 IQFSC1 = 1 + IP - 13
8189 IQBSC2 = 1 + IP - 13
8191 * | +----------------------------------------------------------------*
8192 * | | pi0: besides isospin consideration it is supposed that the
8193 * | | elastic cross section is not very different from
8194 * | | pi+ p and/or pi- p (reasonable above 5 GeV/c)
8197 K2HLP = ( KP - 23 ) / 3
8198 * | | Number of diagrams:
8199 * | | For u ubar (k2hlp=0):
8200 * NDIAGR = 2 - KHELP
8201 * | | For d dbar (k2hlp=1):
8202 * NDIAGR = 2 + KHELP - K2HLP
8203 NDIAGR = 2 + KHELP * ( 2 * K2HLP - 1 ) - K2HLP
8204 SHNCIN = HLFHLF * ( SPPPIN + SPMPIN )
8205 * | | Now compute the chain end (anti)quark-(anti)diquark
8212 * | +----------------------------------------------------------------*
8214 * +-------------------------------------------------------------------*
8216 ELSE IF ( IHLP (IP) .EQ. 3 ) THEN
8222 * | Compute the K+ p total cross section:
8223 SKPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8225 ACOF = SGTCOE (1,21)
8226 BCOF = SGTCOE (2,21)
8227 ENNE = SGTCOE (3,21)
8228 CCOF = SGTCOE (4,21)
8229 DCOF = SGTCOE (5,21)
8230 * | Compute the K+ p elastic cross section:
8231 SKPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8233 * | Compute the K+ p inelastic cross section:
8234 SKPPIN = SKPPTT - SKPPEL
8240 * | Compute the K- p total cross section:
8241 SKMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8243 ACOF = SGTCOE (1,22)
8244 BCOF = SGTCOE (2,22)
8245 ENNE = SGTCOE (3,22)
8246 CCOF = SGTCOE (4,22)
8247 DCOF = SGTCOE (5,22)
8248 * | Compute the K- p elastic cross section:
8249 SKMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8251 * | Compute the K- p inelastic cross section:
8252 SKMPIN = SKMPTT - SKMPEL
8253 SIGDIA = HLFHLF * ( SKMPIN - SKPPIN )
8254 * | +----------------------------------------------------------------*
8255 * | | Charged Kaons: actually only K-
8256 IF ( ICHRGE (IP) .NE. 0 ) THEN
8258 * | | +-------------------------------------------------------------*
8259 * | | | Proton target:
8260 IF ( KHELP .EQ. 0 ) THEN
8262 * | | | Number of diagrams:
8265 * | | +-------------------------------------------------------------*
8266 * | | | Neutron target: besides isospin consideration it is supposed
8267 * | | | that (K- n)el is almost equal to (K- p)el
8268 * | | | (reasonable above 5 GeV/c)
8270 ACOF = SGTCOE (1,10)
8271 BCOF = SGTCOE (2,10)
8272 ENNE = SGTCOE (3,10)
8273 CCOF = SGTCOE (4,10)
8274 DCOF = SGTCOE (5,10)
8275 * | | | Compute the total cross section:
8276 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8278 * | | | Compute the elastic cross section:
8280 * | | | Compute the inelastic cross section:
8281 SHNCIN = SHNCTT - SHNCEL
8282 * | | | Number of diagrams:
8286 * | | +-------------------------------------------------------------*
8287 * | | Now compute the chain end (anti)quark-(anti)diquark
8293 * | +----------------------------------------------------------------*
8294 * | | K0's: (actually only K0bar)
8297 * | | +-------------------------------------------------------------*
8298 * | | | Proton target: (K0bar p)in supposed to be given by
8299 * | | | (K- p)in - Sig_diagr
8300 IF ( KHELP .EQ. 0 ) THEN
8301 SHNCIN = SKMPIN - SIGDIA
8302 * | | | Number of diagrams:
8305 * | | +-------------------------------------------------------------*
8306 * | | | Neutron target: (K0bar n)in supposed to be given by
8307 * | | | (K- n)in + Sig_diagr
8308 * | | | besides isospin consideration it is supposed
8309 * | | | that (K- n)el is almost equal to (K- p)el
8310 * | | | (reasonable above 5 GeV/c)
8312 ACOF = SGTCOE (1,10)
8313 BCOF = SGTCOE (2,10)
8314 ENNE = SGTCOE (3,10)
8315 CCOF = SGTCOE (4,10)
8316 DCOF = SGTCOE (5,10)
8317 * | | | Compute the total cross section:
8318 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8320 * | | | Compute the elastic cross section:
8322 * | | | Compute the inelastic cross section:
8323 SHNCIN = SHNCTT - SHNCEL + SIGDIA
8324 * | | | Number of diagrams:
8328 * | | +-------------------------------------------------------------*
8329 * | | Now compute the chain end (anti)quark-(anti)diquark
8336 * | +----------------------------------------------------------------*
8338 * +-------------------------------------------------------------------*
8340 ELSE IF ( IHLP (IP) .EQ. 4 .AND. IP .LE. 9 ) THEN
8341 * | For momenta between 3 and 5 GeV/c the use of tabulated data
8342 * | should be implemented!
8343 ACOF = SGTCOE (1,15)
8344 BCOF = SGTCOE (2,15)
8345 ENNE = SGTCOE (3,15)
8346 CCOF = SGTCOE (4,15)
8347 DCOF = SGTCOE (5,15)
8348 * | Compute the pbar p total cross section:
8349 SAPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8351 IF ( PLA .LT. FIVFIV ) THEN
8356 ACOF = SGTCOE (1,JREAC)
8357 BCOF = SGTCOE (2,JREAC)
8358 ENNE = SGTCOE (3,JREAC)
8359 CCOF = SGTCOE (4,JREAC)
8360 DCOF = SGTCOE (5,JREAC)
8361 * | Compute the pbar p elastic cross section:
8362 SAPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8364 * | Compute the pbar p inelastic cross section:
8365 SAPPIN = SAPPTT - SAPPEL
8366 ACOF = SGTCOE (1,12)
8367 BCOF = SGTCOE (2,12)
8368 ENNE = SGTCOE (3,12)
8369 CCOF = SGTCOE (4,12)
8370 DCOF = SGTCOE (5,12)
8371 * | Compute the p p total cross section:
8372 SPPTOT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8374 ACOF = SGTCOE (1,23)
8375 BCOF = SGTCOE (2,23)
8376 ENNE = SGTCOE (3,23)
8377 CCOF = SGTCOE (4,23)
8378 DCOF = SGTCOE (5,23)
8379 * | Compute the p p elastic cross section:
8380 SPPELA = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8382 * | Compute the K- p inelastic cross section:
8383 SPPINE = SPPTOT - SPPELA
8384 SIGDIA = ( SAPPIN - SPPINE ) / FIVFIV
8386 * | +----------------------------------------------------------------*
8388 IF ( ICHRGE (IP) .NE. 0 ) THEN
8390 * | | +-------------------------------------------------------------*
8391 * | | | Proton target:
8392 IF ( KHELP .EQ. 0 ) THEN
8393 * | | | Number of diagrams:
8397 * | | +-------------------------------------------------------------*
8398 * | | | Neutron target: it is supposed that (ap n)el is almost equal
8399 * | | | to (ap p)el (reasonable above 5 GeV/c)
8401 ACOF = SGTCOE (1,16)
8402 BCOF = SGTCOE (2,16)
8403 ENNE = SGTCOE (3,16)
8404 CCOF = SGTCOE (4,16)
8405 DCOF = SGTCOE (5,16)
8406 * | | | Compute the total cross section:
8407 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8409 * | | | Compute the elastic cross section:
8411 * | | | Compute the inelastic cross section:
8412 SHNCIN = SHNCTT - SHNCEL
8416 * | | +-------------------------------------------------------------*
8417 * | | Now compute the chain end (anti)quark-(anti)diquark
8418 * | | there are different possibilities, make a random choiche:
8420 RNCHEN = DT_RNDM(PUUBAR)
8421 IF ( RNCHEN .LT. PUUBAR ) THEN
8426 IQBSC1 = -IQFSC1 + KHELP
8429 * | +----------------------------------------------------------------*
8433 * | | +-------------------------------------------------------------*
8434 * | | | Proton target: (nbar p)in supposed to be given by
8435 * | | | (pbar p)in - Sig_diagr
8436 IF ( KHELP .EQ. 0 ) THEN
8437 SHNCIN = SAPPIN - SIGDIA
8440 * | | +-------------------------------------------------------------*
8441 * | | | Neutron target: (nbar n)el is supposed to be equal to
8442 * | | | (pbar p)el (reasonable above 5 GeV/c)
8444 * | | | Compute the total cross section:
8446 * | | | Compute the elastic cross section:
8448 * | | | Compute the inelastic cross section:
8449 SHNCIN = SHNCTT - SHNCEL
8453 * | | +-------------------------------------------------------------*
8454 * | | Now compute the chain end (anti)quark-(anti)diquark
8455 * | | there are different possibilities, make a random choiche:
8457 RNCHEN = DT_RNDM(RNCHEN)
8458 IF ( RNCHEN .LT. PDDBAR ) THEN
8463 IQBSC1 = -IQFSC1 + KHELP - 1
8467 * | +----------------------------------------------------------------*
8469 * +-------------------------------------------------------------------*
8470 * | Others: not yet implemented
8479 * +-------------------------------------------------------------------*
8480 DT_PHNSCH = NDIAGR * SIGDIA / SHNCIN
8481 IQECHC = IQECHR (IQFSC1) + IQECHR (IQFSC2) + IQECHR (IQBSC1)
8483 IQBCHC = IQBCHR (IQFSC1) + IQBCHR (IQFSC2) + IQBCHR (IQBSC1)
8487 IQSCHC = IQSCHR (IQFSC1) + IQSCHR (IQFSC2) + IQSCHR (IQBSC1)
8489 IQSPRO = IQSCHR (MQUARK(1,IP)) + IQSCHR (MQUARK(2,IP))
8490 & + IQSCHR (MQUARK(3,IP))
8491 * +-------------------------------------------------------------------*
8492 * | Consistency check:
8493 IF ( DT_PHNSCH .LE. ZERZER .OR. DT_PHNSCH .GT. ONEONE ) THEN
8494 WRITE (LUNOUT,*)' *** Phnsch,kp,ktarg,pla',
8495 & DT_PHNSCH,KP,KTARG,PLA,' ****'
8496 WRITE (LUNERR,*)' *** Phnsch,kp,ktarg,pla',
8497 & DT_PHNSCH,KP,KTARG,PLA,' ****'
8498 DT_PHNSCH = MAX ( DT_PHNSCH, ZERZER )
8499 DT_PHNSCH = MIN ( DT_PHNSCH, ONEONE )
8502 * +-------------------------------------------------------------------*
8503 * +-------------------------------------------------------------------*
8504 * | Consistency check:
8505 IF ( IQSPRO .NE. IQSCHC .OR. ICHRGE (IP) + ICHRGE (KTARG)
8506 & .NE. IQECHC .OR. IIBAR (KP) + IIBAR (KTARG) .NE. IQBCHC) THEN
8508 &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8509 & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8511 &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8512 & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8515 * +-------------------------------------------------------------------*
8516 * P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
8517 IF ( UMORAT .GT. ONEPLS )
8518 & DT_PHNSCH = ONEONE / ( ( ONEONE / DT_PHNSCH
8519 & - ONEONE ) * UMORAT + ONEONE )
8522 ENTRY DT_SCHQUA ( JQFSC1, JQFSC2, JQBSC1, JQBSC2 )
8528 *=== End of function Phnsch ===========================================*
8532 *$ CREATE DT_RESPT.FOR
8535 *===respt==============================================================*
8539 ************************************************************************
8540 * Check DTEVT1 for two-resonance systems and sample intrinsic p_t. *
8541 * This version dated 18.01.95 is written by S. Roesler *
8542 ************************************************************************
8544 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8547 PARAMETER ( LINP = 10 ,
8551 PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8555 PARAMETER (NMXHKK=200000)
8557 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8558 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8559 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8561 * extended event history
8562 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8563 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8566 * get index of first chain
8567 DO 1 I=NPOINT(3),NHKK
8568 IF (IDHKK(I).EQ.88888) THEN
8575 IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)) THEN
8576 C WRITE(LOUT,*)NC,NC+3,IDRES(NC),IDRES(NC+3)
8577 * skip VV-,SS- systems
8578 IF ((IDCH(NC ).NE.1).AND.(IDCH(NC ).NE.8).AND.
8579 & (IDCH(NC+3).NE.1).AND.(IDCH(NC+3).NE.8)) THEN
8580 * check if both "chains" are resonances
8581 IF ((IDRES(NC).NE.0).AND.(IDRES(NC+3).NE.0)) THEN
8582 CALL DT_SAPTRE(NC,NC+3)
8596 *$ CREATE DT_EVTRES.FOR
8599 *===evtres=============================================================*
8601 SUBROUTINE DT_EVTRES(IREJ)
8603 ************************************************************************
8604 * This version dated 14.12.94 is written by S. Roesler *
8605 ************************************************************************
8607 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8610 PARAMETER ( LINP = 10 ,
8614 PARAMETER (TINY5=1.0D-5,TINY10=1.0D-10)
8618 PARAMETER (NMXHKK=200000)
8620 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8621 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8622 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8624 * extended event history
8625 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8626 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8629 * flags for input different options
8630 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8631 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8632 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8634 * particle properties (BAMJET index convention)
8636 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
8637 & IICH(210),IIBAR(210),K1(210),K2(210)
8639 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),IFP(2),IFT(2)
8643 DO 1 I=NPOINT(3),NHKK
8644 IF (ABS(IDRES(I)).GE.100) THEN
8646 DO 2 J=NPOINT(3),NHKK
8647 IF (IDHKK(J).EQ.88888) THEN
8648 IF (PHKK(5,J).GT.AMMX) THEN
8654 IF (IDRES(IMMX).NE.0) THEN
8655 IF (IOULEV(3).GT.0) THEN
8656 WRITE(LOUT,'(1X,A)')
8657 & 'EVTRES: no chain for correc. found'
8666 IF (PHKK(3,IMO11).LT.0.0D0) THEN
8670 IMO21 = JMOHKK(1,IMMX)
8671 IMO22 = JMOHKK(2,IMMX)
8672 IF (PHKK(3,IMO21).LT.0.0D0) THEN
8673 IMO21 = JMOHKK(2,IMMX)
8674 IMO22 = JMOHKK(1,IMMX)
8677 AMCH1N = AAM(IDXRES(I))
8679 IFPR1 = IDHKK(IMO11)
8680 IFPR2 = IDHKK(IMO21)
8681 IFTA1 = IDHKK(IMO12)
8682 IFTA2 = IDHKK(IMO22)
8684 PP1(J) = PHKK(J,IMO11)
8685 PP2(J) = PHKK(J,IMO21)
8686 PT1(J) = PHKK(J,IMO12)
8687 PT2(J) = PHKK(J,IMO22)
8689 * store initial configuration for energy-momentum cons. check
8690 IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IREJ1)
8691 * correct kinematics of second chain
8692 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
8693 & AMCH1,AMCH1N,AMCH2,IREJ1)
8694 IF (IREJ1.NE.0) GOTO 9999
8695 * check now this chain for resonance mass
8696 IFP(1) = IDT_IPDG2B(IFPR2,1,2)
8698 IF (ABS(IFPR2).GE.1000) IFP(2) = IDT_IPDG2B(IFPR2,2,2)
8699 IFT(1) = IDT_IPDG2B(IFTA2,1,2)
8701 IF (ABS(IFTA2).GE.1000) IFT(2) = IDT_IPDG2B(IFTA2,2,2)
8703 IF ((IFP(2).EQ.0).AND.(IFT(2).EQ.0)) IDCH2 = 1
8704 IF ((IFP(2).NE.0).AND.(IFT(2).NE.0)) IDCH2 = 3
8705 CALL DT_CH2RES(IFP(1),IFP(2),IFT(1),IFT(2),IDR2,IDXR2,
8706 & AMCH2,AMCH2N,IDCH2,IREJ1)
8707 IF ((IREJ1.NE.0).OR.(IDR2.NE.0)) THEN
8709 & WRITE(LOUT,*) ' correction for resonance not poss.'
8715 * store final configuration for energy-momentum cons. check
8717 CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IREJ1)
8718 CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
8719 IF (IREJ1.NE.0) GOTO 9999
8722 PHKK(J,IMO11) = PP1(J)
8723 PHKK(J,IMO21) = PP2(J)
8724 PHKK(J,IMO12) = PT1(J)
8725 PHKK(J,IMO22) = PT2(J)
8727 * correct entries of chains
8729 PHKK(K,I) = PHKK(K,IMO11)+PHKK(K,IMO12)
8730 PHKK(K,IMMX) = PHKK(K,IMO21)+PHKK(K,IMO22)
8732 AM1 = PHKK(4,I)**2-PHKK(1,I)**2-PHKK(2,I)**2-PHKK(3,I)**2
8733 AM2 = PHKK(4,IMMX)**2-PHKK(1,IMMX)**2-PHKK(2,IMMX)**2-
8735 * ?? the following should now be obsolete
8737 C IF ((AM1.LT.0.0D0).OR.(AM2.LT.1.0D0)) THEN
8738 IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8740 WRITE(LOUT,'(1X,A,4G10.3)')
8741 & 'EVTRES: inonsistent mass-corr.',AM1,AM2
8745 PHKK(5,I) = SQRT(AM1)
8746 PHKK(5,IMMX) = SQRT(AM2)
8747 IDRES(I) = IDRES(I)/100
8748 IF ((ABS(PHKK(5,I)-AMCH1N).GT.TINY5).OR.
8749 & (ABS(PHKK(5,IMMX)-AMCH2).GT.TINY5)) THEN
8750 WRITE(LOUT,'(1X,A,4G10.3)')
8751 & 'EVTRES: inconsistent chain-masses',
8752 & PHKK(5,I),AMCH1N,PHKK(5,IMMX),AMCH2
8765 *$ CREATE DT_GETSPT.FOR
8768 *===getspt=============================================================*
8770 SUBROUTINE DT_GETSPT(PP1I,IFPR1,IFP1,PP2I,IFPR2,IFP2,
8771 & PT1I,IFTA1,IFT1,PT2I,IFTA2,IFT2,
8772 & AM1,IDCH1,AM2,IDCH2,IDCHAI,IREJ)
8774 ************************************************************************
8775 * This version dated 12.12.94 is written by S. Roesler *
8776 ************************************************************************
8778 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8781 PARAMETER ( LINP = 10 ,
8785 PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,ZERO=0.0D0)
8787 * various options for treatment of partons (DTUNUC 1.x)
8788 * (chain recombination, Cronin,..)
8789 LOGICAL LCO2CR,LINTPT
8790 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8793 * flags for input different options
8794 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8795 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8796 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8798 * flags for diffractive interactions (DTUNUC 1.x)
8799 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
8801 DIMENSION PP1(4),PP1I(4),PP2(4),PP2I(4),PT1(4),PT1I(4),
8802 & PT2(4),PT2I(4),P1(4),P2(4),
8803 & IFP1(2),IFP2(2),IFT1(2),IFT2(2),
8804 & PTOTI(4),PTOTF(4),DIFF(4)
8810 C IF ((IDCHAI.EQ.6).OR.(IDCHAI.EQ.7).OR.(IDCHAI.EQ.8)) B33P = 2.0D0
8811 C IF ((IDCHAI.EQ.4).OR.(IDCHAI.EQ.5).OR.(IDCHAI.EQ.8)) B33T = 2.0D0
8817 IF (IDIFF.NE.0) THEN
8823 PTOTI(I) = PP1I(I)+PP2I(I)+PT1I(I)+PT2I(I)
8829 * get initial chain masses
8830 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8831 & +(PP1(3)+PT1(3))**2)
8833 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
8834 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8835 & +(PP2(3)+PT2(3))**2)
8837 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
8838 IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8840 & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 1',
8850 C IF ((AM1.GE.3.0D0).AND.(AM2.GE.3.0D0)) THEN
8854 C IF (AM1.LT.0.6) THEN
8856 C ELSEIF ((AM1.GE.1.2).AND.(AM1.LT.3.0D0)) THEN
8859 C IF (AM2.LT.0.6) THEN
8861 C ELSEIF ((AM2.GE.1.2).AND.(AM2.LT.3.0D0)) THEN
8866 * check chain masses for very low mass chains
8867 C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8868 C & AM1,DUM,-IDCH1,IREJ1)
8869 C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8870 C & AM2,DUM,-IDCH2,IREJ2)
8871 C IF ((IREJ1.NE.0).OR.(IREJ2.NE.0)) THEN
8880 IF (MOD(IC,15).EQ.0) B33P = 2.0D0*B33P
8881 IF (MOD(IC,15).EQ.0) B33T = 2.0D0*B33T
8882 IF (MOD(IC,18).EQ.0) REDU = 0.0D0
8883 C IF (MOD(IC,19).EQ.0) JMSHL = 0
8884 IF (MOD(IC,20).EQ.0) GOTO 7
8885 C WRITE(LOUT,'(1X,A)') 'GETSPT: rejection '
8890 * get transverse momentum
8892 ES = -2.0D0/(B33P**2)
8893 & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8894 HPSP = SQRT(ES*ES+2.0D0*ES*0.94D0)
8896 ES = -2.0D0/(B33T**2)
8897 & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8898 HPST = SQRT(ES*ES+2.0D0*ES*0.94D0)
8904 CALL DT_DSFECF(SFE1,CFE1)
8905 CALL DT_DSFECF(SFE2,CFE2)
8907 PP1(1) = PP1I(1)+HPSP*CFE1
8908 PP1(2) = PP1I(2)+HPSP*SFE1
8909 PP2(1) = PP2I(1)-HPSP*CFE1
8910 PP2(2) = PP2I(2)-HPSP*SFE1
8911 PT1(1) = PT1I(1)+HPST*CFE2
8912 PT1(2) = PT1I(2)+HPST*SFE2
8913 PT2(1) = PT2I(1)-HPST*CFE2
8914 PT2(2) = PT2I(2)-HPST*SFE2
8916 PP1(1) = PP1I(1)+HPSP*CFE1
8917 PP1(2) = PP1I(2)+HPSP*SFE1
8918 PT1(1) = PT1I(1)-HPSP*CFE1
8919 PT1(2) = PT1I(2)-HPSP*SFE1
8920 PP2(1) = PP2I(1)+HPST*CFE2
8921 PP2(2) = PP2I(2)+HPST*SFE2
8922 PT2(1) = PT2I(1)-HPST*CFE2
8923 PT2(2) = PT2I(2)-HPST*SFE2
8926 * put partons on mass shell
8929 IF (JMSHL.EQ.1) THEN
8931 XMP1 = PYMASS(IFPR1)
8932 XMT1 = PYMASS(IFTA1)
8935 CALL DT_MASHEL(PP1,PT1,XMP1,XMT1,P1,P2,IREJ1)
8936 IF (IREJ1.NE.0) GOTO 2
8938 PTOTF(I) = P1(I)+P2(I)
8944 IF (JMSHL.EQ.1) THEN
8946 XMP2 = PYMASS(IFPR2)
8947 XMT2 = PYMASS(IFTA2)
8950 CALL DT_MASHEL(PP2,PT2,XMP2,XMT2,P1,P2,IREJ1)
8951 IF (IREJ1.NE.0) GOTO 2
8953 PTOTF(I) = PTOTF(I)+P1(I)+P2(I)
8960 DIFF(I) = PTOTI(I)-PTOTF(I)
8962 IF ((ABS(DIFF(1)).GT.TINY5).OR.(ABS(DIFF(2)).GT.TINY5).OR.
8963 & (ABS(DIFF(3)).GT.TINY5).OR.(ABS(DIFF(4)).GT.TINY5)) THEN
8964 WRITE(LOUT,'(1X,A,4G10.3)') 'GETSPT: inconsistencies ',DIFF
8967 PTOTP1 = SQRT(PP1(1)**2+PP1(2)**2+PP1(3)**2)
8968 AMP1 = SQRT(ABS( (PP1(4)-PTOTP1)*(PP1(4)+PTOTP1) ))
8969 PTOTP2 = SQRT(PP2(1)**2+PP2(2)**2+PP2(3)**2)
8970 AMP2 = SQRT(ABS( (PP2(4)-PTOTP2)*(PP2(4)+PTOTP2) ))
8971 PTOTT1 = SQRT(PT1(1)**2+PT1(2)**2+PT1(3)**2)
8972 AMT1 = SQRT(ABS( (PT1(4)-PTOTT1)*(PT1(4)+PTOTT1) ))
8973 PTOTT2 = SQRT(PT2(1)**2+PT2(2)**2+PT2(3)**2)
8974 AMT2 = SQRT(ABS( (PT2(4)-PTOTT2)*(PT2(4)+PTOTT2) ))
8975 IF ((ABS(AMP1-XMP1).GT.TINY3).OR.(ABS(AMP2-XMP2).GT.TINY3).OR.
8976 & (ABS(AMT1-XMT1).GT.TINY3).OR.(ABS(AMT2-XMT2).GT.TINY3))
8978 WRITE(LOUT,'(1X,A,2(4G10.3,/))')
8979 & 'GETSPT: inconsistent masses',
8980 & AMP1,XMP1,AMP2,XMP2,AMT1,XMT1,AMT2,XMT2
8981 * sr 22.11.00: commented. It should only have inconsistent masses for
8982 * ultrahigh energies due to rounding problems
8987 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8988 & +(PP1(3)+PT1(3))**2)
8990 AM1N = (ECH+PTOCH)*(ECH-PTOCH)
8991 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8992 & +(PP2(3)+PT2(3))**2)
8994 AM2N = (ECH+PTOCH)*(ECH-PTOCH)
8995 IF ((AM1N.LT.0.0D0).OR.(AM2N.LT.0.0D0)) THEN
8997 & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 2',
9004 * check chain masses for very low mass chains
9005 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
9006 & AM1N,DUM,-IDCH1,IREJ1)
9007 IF (IREJ1.NE.0) GOTO 2
9008 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
9009 & AM2N,DUM,-IDCH2,IREJ2)
9010 IF (IREJ2.NE.0) GOTO 2
9013 IF (AM1N.GT.ZERO) THEN
9031 *$ CREATE DT_SAPTRE.FOR
9034 *===saptre=============================================================*
9036 SUBROUTINE DT_SAPTRE(IDX1,IDX2)
9038 ************************************************************************
9039 * p-t sampling for two-resonance systems. ("BAMJET-like" method) *
9040 * IDX1,IDX2 indices of resonances ("chains") in DTEVT1 *
9041 * Adopted from the original SAPTRE written by J. Ranft. *
9042 * This version dated 18.01.95 is written by S. Roesler *
9043 ************************************************************************
9045 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9048 PARAMETER ( LINP = 10 ,
9052 PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
9056 PARAMETER (NMXHKK=200000)
9058 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9059 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9060 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9062 * extended event history
9063 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9064 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9067 * flags for input different options
9068 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
9069 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
9070 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
9072 DIMENSION PA1(4),PA2(4),P1(4),P2(4)
9076 ESMAX1 = PHKK(4,IDX1)-PHKK(5,IDX1)
9077 ESMAX2 = PHKK(4,IDX2)-PHKK(5,IDX2)
9078 ESMAX = MIN(ESMAX1,ESMAX2)
9079 IF (ESMAX.LE.0.05D0) RETURN
9083 PA1(K) = PHKK(K,IDX1)
9084 PA2(K) = PHKK(K,IDX2)
9088 CALL DT_EVTEMC(PA1(1),PA1(2),PA1(3),PA1(4),1,IDUM,IDUM)
9089 CALL DT_EVTEMC(PA2(1),PA2(2),PA2(3),PA2(4),2,IDUM,IDUM)
9093 IF (B3*ESMAX.LE.60.0D0) EXEB = EXP(-B3*ESMAX)
9094 BEXP = HMA*(1.0D0-EXEB)/B3
9095 AXEXP = (1.0D0-(B3*ESMAX-1.0D0)*EXEB)/B3**2
9096 WA = AXEXP/(BEXP+AXEXP)
9099 * ES is the transverse kinetic energy
9103 ES = -2.0D0/(B3**2)*LOG(X*Y+TINY7)
9106 ES = ABS(-LOG(X+TINY7)/B3)
9108 IF (ES.GT.ESMAX) GOTO 10
9110 * transverse momentum
9111 HPS = SQRT((ES-HMA)*(ES+HMA))
9113 CALL DT_DSFECF(SFE,CFE)
9116 PZ1NSQ = PA1(3)**2-HPS**2-2.0D0*PA1(1)*HPX-2.0D0*PA1(2)*HPY
9117 PZ2NSQ = PA2(3)**2-HPS**2+2.0D0*PA2(1)*HPX+2.0D0*PA2(2)*HPY
9118 IF ((PZ1NSQ.LT.TINY3).OR.(PZ2NSQ.LT.TINY3)) RETURN
9120 C PA1(3) = SIGN(SQRT(PZ1NSQ),PA1(3))
9121 C PA2(3) = SIGN(SQRT(PZ2NSQ),PA2(3))
9127 * put resonances on mass-shell again
9130 CALL DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ1)
9131 IF (IREJ1.NE.0) RETURN
9134 CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,IDUM,IDUM)
9135 CALL DT_EVTEMC(-P2(1),-P2(2),-P2(3),-P2(4),2,IDUM,IDUM)
9136 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,12,IREJ1)
9137 IF (IREJ1.NE.0) RETURN
9141 PHKK(K,IDX1) = P1(K)
9142 PHKK(K,IDX2) = P2(K)
9148 *$ CREATE DT_CRONIN.FOR
9151 *===cronin=============================================================*
9153 SUBROUTINE DT_CRONIN(INCL)
9155 ************************************************************************
9156 * Cronin-Effect. Multiple scattering of partons at chain ends. *
9157 * INCL = 1 multiple sc. in projectile *
9158 * = 2 multiple sc. in target *
9159 * This version dated 05.01.96 is written by S. Roesler. *
9160 ************************************************************************
9162 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9165 PARAMETER ( LINP = 10 ,
9169 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
9173 PARAMETER (NMXHKK=200000)
9175 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9176 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9177 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9179 * extended event history
9180 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9181 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9185 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
9186 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
9187 & IREXCI(3),IRDIFF(2),IRINC
9189 * Glauber formalism: collision properties
9190 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
9191 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
9193 DIMENSION R(3),PIN(4),POUT(4),DEV(4)
9199 DO 2 I=NPOINT(2),NHKK
9200 IF (ISTHKK(I).LT.0) THEN
9201 * get z-position of the chain
9202 R(1) = VHKK(1,I)*1.0D12
9203 IF (INCL.EQ.2) R(1) = VHKK(1,I)*1.0D12-BIMPAC
9204 R(2) = VHKK(2,I)*1.0D12
9206 IF ( (INCL.EQ.1).AND.(ISTHKK(IDXNU).EQ.10) )
9207 & IDXNU = JMOHKK(1,I-1)
9208 IF ( (INCL.EQ.2).AND.(ISTHKK(IDXNU).EQ. 9) )
9209 & IDXNU = JMOHKK(1,I+1)
9210 R(3) = VHKK(3,IDXNU)*1.0D12
9211 * position of target parton the chain is connected to
9215 * multiple scattering of parton with DTEVT1-index I
9216 CALL DT_CROMSC(PIN,R,POUT,INCL)
9218 C IF (NEVHKK.EQ.5) THEN
9219 C AMIN = PIN(4)**2-PIN(1)**2-PIN(2)**2-PIN(3)**2
9220 C AMOU = POUT(4)**2-POUT(1)**2-POUT(2)**2-POUT(3)**2
9221 C AMIN = SIGN(SQRT(ABS(AMIN)),AMIN)
9222 C AMOU = SIGN(SQRT(ABS(AMOU)),AMOU)
9223 C WRITE(6,'(A,I4,2E15.5)')'I,AMIN,AMOU: ',I,AMIN,AMOU
9224 C WRITE(6,'(A,4E15.5)')'PIN: ',PIN
9225 C WRITE(6,'(A,4E15.5)')'POUT: ',POUT
9228 * increase accumulator by energy-momentum difference
9230 DEV(K) = DEV(K)+POUT(K)-PIN(K)
9233 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
9234 & PHKK(2,I)**2-PHKK(3,I)**2))
9238 * dump accumulator to momenta of valence partons
9241 DO 5 I=NPOINT(2),NHKK
9242 IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
9244 ETOT = ETOT+PHKK(4,I)
9247 C WRITE(LOUT,1000) NVAL,(DEV(K)/DBLE(NVAL),K=1,4)
9248 1000 FORMAT(1X,'CRONIN : number of val. partons ',I4,/,
9250 DO 6 I=NPOINT(2),NHKK
9251 IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
9254 C PHKK(K,I) = PHKK(K,I)-DEV(K)/DBLE(NVAL)
9255 PHKK(K,I) = PHKK(K,I)-DEV(K)*E/ETOT
9257 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
9258 & PHKK(2,I)**2-PHKK(3,I)**2))
9265 *$ CREATE DT_CROMSC.FOR
9268 *===cromsc=============================================================*
9270 SUBROUTINE DT_CROMSC(PIN,R,POUT,INCL)
9272 ************************************************************************
9273 * Cronin-Effect. Multiple scattering of one parton passing through *
9275 * PIN(4) input 4-momentum of parton *
9276 * POUT(4) 4-momentum of parton after mult. scatt. *
9277 * R(3) spatial position of parton in target nucleus *
9278 * INCL = 1 multiple sc. in projectile *
9279 * = 2 multiple sc. in target *
9280 * This is a revised version of the original version written by J. Ranft*
9281 * This version dated 17.01.95 is written by S. Roesler. *
9282 ************************************************************************
9284 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9287 PARAMETER ( LINP = 10 ,
9291 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
9296 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
9297 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
9298 & IREXCI(3),IRDIFF(2),IRINC
9300 * Glauber formalism: collision properties
9301 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
9302 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
9304 * various options for treatment of partons (DTUNUC 1.x)
9305 * (chain recombination, Cronin,..)
9306 LOGICAL LCO2CR,LINTPT
9307 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
9310 DIMENSION PIN(4),POUT(4),R(3)
9312 DATA LSTART /.TRUE./
9314 IRCRON(1) = IRCRON(1)+1
9317 WRITE(LOUT,1000) CRONCO
9318 1000 FORMAT(/,1X,'CROMSC: multiple scattering of chain ends',
9319 & ' treated',/,10X,'with parameter CRONCO = ',F5.2)
9325 IF (INCL.EQ.2) RNCL = RTARG
9327 * Lorentz-transformation into Lab.
9329 CALL DT_LTNUC(PIN(3),PIN(4),PZ,PE,MODE)
9331 PTOT = SQRT(PIN(1)**2+PIN(2)**2+PZ**2)
9332 IF (PTOT.LE.8.0D0) GOTO 9997
9334 * direction cosines of parton before mult. scattering
9339 RTESQ = R(1)**2+R(2)**2+R(3)**2-RNCL**2
9340 IF (RTESQ.GE.-TINY3) GOTO 9999
9342 * calculate distance (DIST) from R to surface of nucleus (radius RNCL)
9343 * in the direction of particle motion
9345 A = COSX*R(1)+COSY*R(2)+COSZ*R(3)
9347 IF (TMP.LT.ZERO) GOTO 9998
9350 * multiple scattering angle
9351 THETO = CRONCO*SQRT(DIST)/PTOT
9352 IF (THETO.GT.0.1D0) THETO=0.1D0
9355 * Gaussian sampling of spatial angle
9356 CALL DT_RANNOR(R1,R2)
9357 THETA = ABS(R1*THETO)
9358 IF (THETA.GT.0.3D0) GOTO 9997
9359 CALL DT_DSFECF(SFE,CFE)
9363 * new direction cosines
9364 CALL DT_MYTRAN(1,COSX,COSY,COSZ,COSTH,SINTH,SFE,CFE,
9365 & COSXN,COSYN,COSZN)
9367 POUT(1) = COSXN*PTOT
9368 POUT(2) = COSYN*PTOT
9370 * Lorentz-transformation into nucl.-nucl. cms
9372 CALL DT_LTNUC(PZ,PE,POUT(3),POUT(4),MODE)
9374 C IF (ABS(PIN(4)-POUT(4)).GT.0.2D0) THEN
9375 C IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.1D0 ) THEN
9376 IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.05D0 ) THEN
9379 IF (MOD(NCBACK,200).EQ.0) THEN
9380 WRITE(LOUT,1001) THETO,PIN,POUT
9381 1001 FORMAT(1X,'CROMSC: inconsistent scattering angle ',
9382 & E12.4,/,1X,' PIN :',4E12.4,/,
9383 & 1X,' POUT:',4E12.4)
9391 9997 IRCRON(2) = IRCRON(2)+1
9393 9998 IRCRON(3) = IRCRON(3)+1
9402 *$ CREATE DT_COM2CR.FOR
9405 *===com2sr=============================================================*
9407 SUBROUTINE DT_COM2CR
9409 ************************************************************************
9410 * COMbine q-aq chains to Color Ropes (qq-aqaq). *
9411 * CUTOF parameter determining minimum number of not *
9412 * combined q-aq chains *
9413 * This subroutine replaces KKEVCC etc. *
9414 * This version dated 11.01.95 is written by S. Roesler. *
9415 ************************************************************************
9417 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9420 PARAMETER ( LINP = 10 ,
9426 PARAMETER (NMXHKK=200000)
9428 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9429 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9430 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9432 * extended event history
9433 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9434 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9438 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9439 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9442 * various options for treatment of partons (DTUNUC 1.x)
9443 * (chain recombination, Cronin,..)
9444 LOGICAL LCO2CR,LINTPT
9445 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
9448 DIMENSION IDXQA(248),IDXAQ(248)
9450 ICCHAI(1,9) = ICCHAI(1,9)+1
9453 * scan DTEVT1 for q-aq, aq-q chains
9454 DO 10 I=NPOINT(3),NHKK
9455 * skip "chains" which are resonances
9456 IF ((IDHKK(I).EQ.88888).AND.(IDRES(I).EQ.0)) THEN
9459 IF ((ABS(IDHKK(MO1)).LE.6).AND.(ABS(IDHKK(MO2)).LE.6)) THEN
9460 * q-aq, aq-q chain found, keep index
9461 IF (IDHKK(MO1).GT.0) THEN
9472 * minimum number of q-aq chains requested for the same projectile/
9474 NCHMIN = IDT_NPOISS(CUTOF)
9476 * combine q-aq chains of the same projectile
9477 CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,1)
9478 * combine q-aq chains of the same target
9479 CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,2)
9480 * combine aq-q chains of the same projectile
9481 CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,1)
9482 * combine aq-q chains of the same target
9483 CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,2)
9488 *$ CREATE DT_SCN4CR.FOR
9491 *===scn4cr=============================================================*
9493 SUBROUTINE DT_SCN4CR(NCH,IDXCH,NCHMIN,MODE)
9495 ************************************************************************
9496 * SCan q-aq chains for Color Ropes. *
9497 * This version dated 11.01.95 is written by S. Roesler. *
9498 ************************************************************************
9500 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9503 PARAMETER ( LINP = 10 ,
9509 PARAMETER (NMXHKK=200000)
9511 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9512 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9513 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9515 * extended event history
9516 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9517 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9520 DIMENSION IDXCH(248),IDXJN(248)
9523 IF (IDXCH(I).GT.0) THEN
9525 IDXMO = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(I))))
9529 IF (IDXCH(J).GT.0) THEN
9530 IDXMO1 = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(J))))
9531 IF (IDXMO.EQ.IDXMO1) THEN
9538 IF (NJOIN.GE.NCHMIN+2) THEN
9539 NJ = INT(DBLE(NJOIN-NCHMIN)/2.0D0)
9541 CALL DT_JOIN(IDXCH(IDXJN(J)),IDXCH(IDXJN(J+1)),IREJ1)
9542 IF (IREJ1.NE.0) GOTO 3
9544 IDXCH(IDXJN(J+1)) = 0
9553 *$ CREATE DT_JOIN.FOR
9556 *===join===============================================================*
9558 SUBROUTINE DT_JOIN(IDX1,IDX2,IREJ)
9560 ************************************************************************
9561 * This subroutine joins two q-aq chains to one qq-aqaq chain. *
9562 * IDX1, IDX2 DTEVT1 indices of chains to be joined *
9563 * This version dated 11.01.95 is written by S. Roesler. *
9564 ************************************************************************
9566 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9569 PARAMETER ( LINP = 10 ,
9575 PARAMETER (NMXHKK=200000)
9577 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9578 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9579 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9581 * extended event history
9582 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9583 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9586 * flags for input different options
9587 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
9588 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
9589 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
9592 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9593 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9596 DIMENSION MO(2,2),ID(2,2),IDX(2),PCH(4),PP(4),PT(4),P1(4),P2(4)
9604 MO(I,J) = JMOHKK(J,IDX(I))
9605 ID(I,J) = IDT_IPDG2B(IDHKK(MO(I,J)),1,2)
9610 IF ((ABS(ID(1,1)).GT.6).OR.(ABS(ID(1,2)).GT.6).OR.
9611 & (ABS(ID(2,1)).GT.6).OR.(ABS(ID(2,2)).GT.6).OR.
9612 & ((ID(1,1)*ID(2,1)).LT.0).OR.
9613 & ((ID(1,2)*ID(2,2)).LT.0)) THEN
9614 WRITE(LOUT,1000) IDX(1),MO(1,1),MO(1,2),IDX(2),MO(2,1),
9616 1000 FORMAT(1X,'JOIN: incons. chain system! chain ',I4,':',
9617 & 2I5,' chain ',I4,':',2I5)
9622 PP(K) = PHKK(K,MO(1,1))+PHKK(K,MO(2,1))
9623 PT(K) = PHKK(K,MO(1,2))+PHKK(K,MO(2,2))
9625 IF1 = IDT_IB2PDG(ID(1,1),ID(2,1),2)
9626 IF2 = IDT_IB2PDG(ID(1,2),ID(2,2),2)
9627 IST1 = ISTHKK(MO(1,1))
9628 IST2 = ISTHKK(MO(1,2))
9630 * put partons again on mass shell
9633 IF (IMSHL.EQ.1) THEN
9639 CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1)
9640 IF (IREJ1.NE.0) GOTO 9999
9646 * store new partons in DTEVT1
9647 CALL DT_EVTPUT(IST1,IF1,MO(1,1),MO(2,1),PP(1),PP(2),PP(3),PP(4),
9649 CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4),
9652 PCH(K) = PP(K)+PT(K)
9655 * check new chain for lower mass limit
9656 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
9657 AMCH = SQRT(ABS(PCH(4)**2-PCH(1)**2-PCH(2)**2-PCH(3)**2))
9658 CALL DT_CH2RES(ID(1,1),ID(2,1),ID(1,2),ID(2,2),IDUM,IDUM,
9659 & AMCH,AMCHN,3,IREJ1)
9660 IF (IREJ1.NE.0) THEN
9666 ICCHAI(2,9) = ICCHAI(2,9)+1
9667 * store new chain in DTEVT1
9669 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),0,0,9)
9670 IDHKK(IDX(1)) = 22222
9671 IDHKK(IDX(2)) = 22222
9672 * special treatment for space-time coordinates
9674 VHKK(K,NHKK) = (VHKK(K,IDX(1))+VHKK(K,IDX(2)))/2.0D0
9675 WHKK(K,NHKK) = (WHKK(K,IDX(1))+WHKK(K,IDX(2)))/2.0D0
9683 *$ CREATE DT_XSGLAU.FOR
9686 *===xsglau=============================================================*
9688 SUBROUTINE DT_XSGLAU(NA,NB,JJPROJ,XI,Q2I,ECMI,IE,IQ,NIDX)
9690 ************************************************************************
9691 * Total, elastic, quasi-elastic, inelastic cross sections according to *
9692 * Glauber's approach. *
9693 * NA / NB mass numbers of proj./target nuclei *
9694 * JJPROJ bamjet-index of projectile (=1 in case of proj.nucleus) *
9695 * XI,Q2I,ECMI kinematical variables x, Q^2, E_cm *
9696 * IE,IQ indices of energy and virtuality (the latter for gamma *
9697 * projectiles only) *
9698 * NIDX index of projectile/target nucleus *
9699 * This version dated 17.3.98 is written by S. Roesler *
9700 ************************************************************************
9702 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9705 PARAMETER ( LINP = 10 ,
9709 COMPLEX*16 CZERO,CONE,CTWO
9711 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
9712 & ONETHI=ONE/THREE,TINY25=1.0D-25)
9713 PARAMETER (TWOPI = 6.283185307179586454D+00,
9715 & GEV2MB = 0.38938D0,
9716 & GEV2FM = 0.1972D0,
9717 & ALPHEM = ONE/137.0D0,
9721 * approx. nucleon radius
9724 * particle properties (BAMJET index convention)
9726 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
9727 & IICH(210),IIBAR(210),K1(210),K2(210)
9729 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
9731 PARAMETER ( MAXNCL = 260,
9734 & MAXSQU = 20*MAXVQU,
9735 & MAXINT = MAXVQU+MAXSQU)
9737 * Glauber formalism: parameters
9738 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
9739 & BMAX(NCOMPX),BSTEP(NCOMPX),
9740 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
9743 * Glauber formalism: cross sections
9744 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
9745 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
9746 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
9747 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
9748 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
9749 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
9750 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
9751 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
9752 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
9753 & BSLOPE,NEBINI,NQBINI
9755 * Glauber formalism: flags and parameters for statistics
9758 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
9760 * nucleon-nucleon event-generator
9763 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
9765 * VDM parameter for photon-nucleus interactions
9766 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
9768 * parameters for hA-diffraction
9769 COMMON /DTDIHA/ DIBETA,DIALPH
9771 COMPLEX*16 PP11(MAXNCL),PP12(MAXNCL),PP21(MAXNCL),PP22(MAXNCL),
9772 & OMPP11,OMPP12,OMPP21,OMPP22,
9773 & DIPP11,DIPP12,DIPP21,DIPP22,AVDIPP,
9776 DIMENSION COOP1(3,MAXNCL),COOT1(3,MAXNCL),
9777 & COOP2(3,MAXNCL),COOT2(3,MAXNCL),
9780 PARAMETER (NPOINT=16)
9781 DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
9783 LOGICAL LFIRST,LOPEN
9784 DATA LFIRST,LOPEN /.TRUE.,.FALSE./
9787 * for quasi-elastic neutrino scattering set projectile to proton
9788 * it should not have an effect since the whole Glauber-formalism is
9789 * not needed for these interactions..
9790 IF (MCGENE.EQ.4) THEN
9796 IF ((ABS(IOGLB).EQ.1).AND.(.NOT.LOPEN)) THEN
9799 CFILE = CGLB//'.glb'
9800 OPEN(LDAT,FILE=CGLB//'.glb',STATUS='UNKNOWN')
9801 ELSEIF (I.GT.1) THEN
9802 CFILE = CGLB(1:I-1)//'.glb'
9803 OPEN(LDAT,FILE=CGLB(1:I-1)//'.glb',STATUS='UNKNOWN')
9810 CZERO = DCMPLX(ZERO,ZERO)
9811 CONE = DCMPLX(ONE,ZERO)
9812 CTWO = DCMPLX(TWO,ZERO)
9816 * re-define kinematics
9820 * g(Q2=0)-A, h-A, A-A scattering
9821 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9824 * g(Q2>0)-A scattering
9825 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(S.GT.ZERO)) THEN
9827 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9828 Q2 = (S-AMP2)*X/(ONE-X)
9829 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
9830 S = Q2*(ONE-X)/X+AMP2
9832 WRITE(LOUT,*) 'XSGLAU: inconsistent input ',S,Q2,X
9837 XNU = (S+Q2-AMP2)/(TWO*AMP)
9839 * parameters determining statistics in evaluating Glauber-xsection
9842 IF (NSITEB.GT.KSITEB) NSITEB = KSITEB
9844 * set up interaction geometry (common /DTGLAM/)
9845 * projectile/target radii
9846 RPRNCL = DT_RNCLUS(NA)
9847 RTANCL = DT_RNCLUS(NB)
9848 IF (IJPROJ.EQ.7) THEN
9850 RBSH(NTARG) = RTANCL
9851 BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9853 IF (NIDX.LE.-1) THEN
9855 RBSH(NTARG) = RTANCL
9856 BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9858 RASH(NTARG) = RPRNCL
9860 BMAX(NTARG) = 2.0D0*(RASH(NTARG)+RBSH(1))
9863 * maximum impact-parameter
9864 BSTEP(NTARG)= BMAX(NTARG)/DBLE(NSITEB-1)
9866 * slope, rho ( Re(f(0))/Im(f(0)) )
9867 IF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
9868 IF (MCGENE.EQ.2) THEN
9870 CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,SDUM1,SDUM2,SDUM3,
9873 BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
9875 IF (ECMNN(IE).LE.3.0D0) THEN
9877 ELSEIF ((ECMNN(IE).GT.3.0D0).AND.(ECMNN(IE).LE.50.D0)) THEN
9878 ROSH = -0.63D0+0.175D0*LOG(ECMNN(IE))
9879 ELSEIF (ECMNN(IE).GT.50.0D0) THEN
9882 ELSEIF (IJPROJ.EQ.7) THEN
9885 BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
9889 * projectile-nucleon xsection (in fm)
9890 IF (IJPROJ.EQ.7) THEN
9891 SIGSH = DT_SIGVP(X,Q2)/10.0D0
9893 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
9894 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
9895 C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
9897 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
9898 SIGSH = SIGSH/10.0D0
9901 * parameters for projectile diffraction (hA scattering only)
9902 IF ((MCGENE.EQ.2).AND.(NA.EQ.1).AND.(NB.GT.1).AND.(IJPROJ.NE.7)
9903 & .AND.(DIBETA.GE.ZERO)) THEN
9905 CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,STOT,SDUM2,SDIF1,BDUM,0)
9906 C DIBETA = SDIF1/STOT
9908 DIGAMM = SQRT(DIALPH**2+DIBETA**2)
9909 IF (DIBETA.LE.ZERO) THEN
9912 ALPGAM = DIALPH/DIGAMM
9916 FACDI = SQRT(FACDI1*FACDI2)
9917 WRITE(LOUT,*)'DIBETA,DIALPH,DIGAMM: ',DIBETA,DIALPH,DIGAMM
9929 BSITE( 0,IQ,NTARG,I) = ZERO
9930 BSITE(IE,IQ,NTARG,I) = ZERO
9949 FACN = ONE/DBLE(NSTATB)
9954 * initialize Gauss-integration for photon-proj.
9956 IF (IJPROJ.EQ.7) THEN
9957 IF (INTRGE(1).EQ.1) THEN
9958 AMLO2 = (3.0D0*AAM(13))**2
9959 ELSEIF (INTRGE(1).EQ.2) THEN
9964 IF (INTRGE(2).EQ.1) THEN
9966 ELSEIF (INTRGE(2).EQ.2) THEN
9971 AMHI20 = (ECMNN(IE)-AMP)**2
9972 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
9973 XAMLO = LOG( AMLO2+Q2 )
9974 XAMHI = LOG( AMHI2+Q2 )
9976 C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9979 CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9983 * ratio direct/total photon-nucleon xsection
9984 CALL DT_POILIK(NB,NTARG,ECMNN(IE),Q2,IPNT,RPNT,1)
9987 * read pre-initialized profile-function from file
9988 IF (IOGLB.EQ.1) THEN
9989 READ(LDAT,'(5I10,E15.5)') KJPROJ,IA,IB,ISTATB,ISITEB,DUM
9990 IF ((IA.NE.NA).OR.(IB.NE.NB)) THEN
9991 WRITE(LOUT,1000) CFILE,IA,IB,ISTATB,ISITEB,
9992 & NA,NB,NSTATB,NSITEB
9993 1000 FORMAT(' XSGLAU: inconsistent input data in file ',A12,/,
9994 & ' (IA,IB,ISTATB,ISITEB) ',4I10,/,
9995 & ' (NA,NB,NSTATB,NSITEB) ',4I10)
9998 IF (LFIRST) WRITE(LOUT,1001) CFILE
9999 1001 FORMAT(/,' XSGLAU: impact parameter distribution read from ',
10001 READ(LDAT,'(6E12.5)') XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),
10002 & XSQEP(IE,IQ,NTARG),XSQET(IE,IQ,NTARG),
10003 & XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
10004 READ(LDAT,'(6E12.5)') XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),
10005 & XEQEP(IE,IQ,NTARG),XEQET(IE,IQ,NTARG),
10006 & XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
10007 NLINES = INT(DBLE(NSITEB)/7.0D0)
10008 IF (NLINES.GT.0) THEN
10011 READ(LDAT,'(7E11.4)')
10012 & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
10015 ISTART = 7*NLINES+1
10016 IF (ISTART.LE.NSITEB) THEN
10017 READ(LDAT,'(7E11.4)')
10018 & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
10022 * variable projectile/target/energy runs:
10023 * read pre-initialized profile-functions from file
10024 ELSEIF (IOGLB.EQ.100) THEN
10025 CALL DT_GLBSET(IJPROJ,IINA,IINB,RRELAB,0)
10029 * cross sections averaged over NSTATB nucleon configurations
10031 C IF ((NA.EQ.207).AND.(NB.EQ.207)) WRITE(LOUT,*) 'conf. ',IS
10041 IF (NIDX.LE.-1) THEN
10042 CALL DT_CONUCL(COOP1,NA,RASH(1),0)
10043 CALL DT_CONUCL(COOT1,NB,RBSH(NTARG),1)
10044 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10045 CALL DT_CONUCL(COOP2,NA,RASH(1),0)
10046 CALL DT_CONUCL(COOT2,NB,RBSH(NTARG),1)
10049 CALL DT_CONUCL(COOP1,NA,RASH(NTARG),0)
10050 CALL DT_CONUCL(COOT1,NB,RBSH(1),1)
10051 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10052 CALL DT_CONUCL(COOP2,NA,RASH(NTARG),0)
10053 CALL DT_CONUCL(COOT2,NB,RBSH(1),1)
10057 * integration over impact parameter B
10058 DO 12 IB=1,NSITEB-1
10068 B = DBLE(IB)*BSTEP(NTARG)
10069 FACB = 10.0D0*TWOPI*B*BSTEP(NTARG)
10071 * integration over M_V^2 for photon-proj.
10077 IF (IJPROJ.EQ.7) THEN
10089 IF (IJPROJ.EQ.7) THEN
10090 AMV2 = EXP(ABSZX(IM))-Q2
10092 IF (AMV2.LT.16.0D0) THEN
10094 ELSEIF ((AMV2.GE.16.0D0).AND.(AMV2.LT.121.0D0)) THEN
10099 * define M_V dependent properties of nucleon scattering amplitude
10100 * V_M-nucleon xsection
10101 SIGMVD = RPNT*SIGSH/(AMV2+Q2+RL2)*10.0D0
10102 SIGMV = (ONE-RPNT)*SIGSH/(AMV2+Q2+RL2)
10103 * slope-parametrisation a la Kaidalov
10104 BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
10105 & +0.25D0*LOG(S/(AMV2+Q2)))
10107 IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+Q2)*GEV2FM
10108 * integration weight factor
10109 FACM = ALPHEM/(3.0D0*PI*(ONE-X))*
10110 & R*AMV2/(AMV2+Q2)*(ONE+EPSPOL*Q2/AMV2)*WEIGHT(IM)
10112 GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
10114 IF (IJPROJ.EQ.7) THEN
10115 RCA = GAM*SIGMV/TWOPI
10117 RCA = GAM*SIGSH/TWOPI
10120 CA = DCMPLX(RCA,FCA)
10129 * photon-projectile: check for supression by coherence length
10130 IF (IJPROJ.EQ.7) THEN
10131 IF (ABS(COOT1(3,INB)-COOT1(3,KK1)).GT.DCOH)THEN
10135 IF (ABS(COOT2(3,INB)-COOT2(3,KK2)).GT.DCOH)THEN
10141 X11 = B+COOT1(1,INB)-COOP1(1,INA)
10142 Y11 = COOT1(2,INB)-COOP1(2,INA)
10143 XY11 = GAM*(X11*X11+Y11*Y11)
10144 IF (XY11.LE.15.0D0) THEN
10145 C = CONE-CA*EXP(-XY11)
10146 AR = DBLE(PP11(INT1))
10147 AI = DIMAG(PP11(INT1))
10148 IF (ABS(AR).LT.TINY25) AR = ZERO
10149 IF (ABS(AI).LT.TINY25) AI = ZERO
10150 PP11(INT1) = DCMPLX(AR,AI)
10151 PP11(INT1) = PP11(INT1)*C
10154 SHI = SHI+LOG(AR*AR+AI*AI)
10156 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10157 X12 = B+COOT2(1,INB)-COOP1(1,INA)
10158 Y12 = COOT2(2,INB)-COOP1(2,INA)
10159 XY12 = GAM*(X12*X12+Y12*Y12)
10160 IF (XY12.LE.15.0D0) THEN
10161 C = CONE-CA*EXP(-XY12)
10162 AR = DBLE(PP12(INT2))
10163 AI = DIMAG(PP12(INT2))
10164 IF (ABS(AR).LT.TINY25) AR = ZERO
10165 IF (ABS(AI).LT.TINY25) AI = ZERO
10166 PP12(INT2) = DCMPLX(AR,AI)
10167 PP12(INT2) = PP12(INT2)*C
10169 X21 = B+COOT1(1,INB)-COOP2(1,INA)
10170 Y21 = COOT1(2,INB)-COOP2(2,INA)
10171 XY21 = GAM*(X21*X21+Y21*Y21)
10172 IF (XY21.LE.15.0D0) THEN
10173 C = CONE-CA*EXP(-XY21)
10174 AR = DBLE(PP21(INT1))
10175 AI = DIMAG(PP21(INT1))
10176 IF (ABS(AR).LT.TINY25) AR = ZERO
10177 IF (ABS(AI).LT.TINY25) AI = ZERO
10178 PP21(INT1) = DCMPLX(AR,AI)
10179 PP21(INT1) = PP21(INT1)*C
10181 X22 = B+COOT2(1,INB)-COOP2(1,INA)
10182 Y22 = COOT2(2,INB)-COOP2(2,INA)
10183 XY22 = GAM*(X22*X22+Y22*Y22)
10184 IF (XY22.LE.15.0D0) THEN
10185 C = CONE-CA*EXP(-XY22)
10186 AR = DBLE(PP22(INT2))
10187 AI = DIMAG(PP22(INT2))
10188 IF (ABS(AR).LT.TINY25) AR = ZERO
10189 IF (ABS(AI).LT.TINY25) AI = ZERO
10190 PP22(INT2) = DCMPLX(AR,AI)
10191 PP22(INT2) = PP22(INT2)*C
10202 IF (PP11(K).EQ.CZERO) THEN
10206 PPTMP1 = PP11(K)**(ONE-DIALPH-DIGAMM)
10207 PPTMP2 = PP11(K)**(ONE-DIALPH+DIGAMM)
10210 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10211 OMPP11 = OMPP11+AVDIPP
10212 C OMPP11 = OMPP11+(CONE-PP11(K))
10213 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10214 DIPP11 = DIPP11+AVDIPP
10215 IF (PP21(K).EQ.CZERO) THEN
10219 PPTMP1 = PP21(K)**(ONE-DIALPH-DIGAMM)
10220 PPTMP2 = PP21(K)**(ONE-DIALPH+DIGAMM)
10223 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10224 OMPP21 = OMPP21+AVDIPP
10225 C OMPP21 = OMPP21+(CONE-PP21(K))
10226 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10227 DIPP21 = DIPP21+AVDIPP
10234 IF (PP12(K).EQ.CZERO) THEN
10238 PPTMP1 = PP12(K)**(ONE-DIALPH-DIGAMM)
10239 PPTMP2 = PP12(K)**(ONE-DIALPH+DIGAMM)
10242 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10243 OMPP12 = OMPP12+AVDIPP
10244 C OMPP12 = OMPP12+(CONE-PP12(K))
10245 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10246 DIPP12 = DIPP12+AVDIPP
10247 IF (PP22(K).EQ.CZERO) THEN
10251 PPTMP1 = PP22(K)**(ONE-DIALPH-DIGAMM)
10252 PPTMP2 = PP22(K)**(ONE-DIALPH+DIGAMM)
10255 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10256 OMPP22 = OMPP22+AVDIPP
10257 C OMPP22 = OMPP22+(CONE-PP22(K))
10258 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10259 DIPP22 = DIPP22+AVDIPP
10262 SPROM = ONE-EXP(SHI)
10263 SPROB = SPROB+FACM*SPROM
10264 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10265 STOTM = DBLE(OMPP11+OMPP22)
10266 SELAM = DBLE(OMPP11*DCONJG(OMPP22))
10267 SQEPM = DBLE(OMPP11*DCONJG(OMPP21))-SELAM
10268 SQETM = DBLE(OMPP11*DCONJG(OMPP12))-SELAM
10269 SQE2M = DBLE(OMPP11*DCONJG(OMPP11))-SELAM-SQEPM-SQETM
10270 SDELM = DBLE(DIPP11*DCONJG(DIPP22))
10271 SDQEM = DBLE(DIPP11*DCONJG(DIPP21))-SDELM
10272 STOTB = STOTB+FACM*STOTM
10273 SELAB = SELAB+FACM*SELAM
10274 SDELB = SDELB+FACM*SDELM
10276 SQEPB = SQEPB+FACM*SQEPM
10277 SDQEB = SDQEB+FACM*SDQEM
10279 IF (NA.GT.1) SQETB = SQETB+FACM*SQETM
10280 IF ((NA.GT.1).AND.(NB.GT.1)) SQE2B = SQE2B+FACM*SQE2M
10281 IF (IJPROJ.EQ.7) SDIR = SDIR+FACM*SIGMVD
10286 STOTN = STOTN+FACB*STOTB
10287 SELAN = SELAN+FACB*SELAB
10288 SQEPN = SQEPN+FACB*SQEPB
10289 SQETN = SQETN+FACB*SQETB
10290 SQE2N = SQE2N+FACB*SQE2B
10291 SPRON = SPRON+FACB*SPROB
10292 SDELN = SDELN+FACB*SDELB
10293 SDQEN = SDQEN+FACB*SDQEB
10295 IF (IJPROJ.EQ.7) THEN
10296 BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*(STOTB-SELAB-SQEPB)
10298 IF (DIBETA.GT.ZERO) THEN
10299 BPROD(IB+1)= BPROD(IB+1)
10300 & +FACN*FACB*(STOTB-SELAB-SQEPB-SQETB-SQE2B)
10302 BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*SPROB
10308 STOT = STOT +FACN*STOTN
10309 STOT2 = STOT2+FACN*STOTN**2
10310 SELA = SELA +FACN*SELAN
10311 SELA2 = SELA2+FACN*SELAN**2
10312 SQEP = SQEP +FACN*SQEPN
10313 SQEP2 = SQEP2+FACN*SQEPN**2
10314 SQET = SQET +FACN*SQETN
10315 SQET2 = SQET2+FACN*SQETN**2
10316 SQE2 = SQE2 +FACN*SQE2N
10317 SQE22 = SQE22+FACN*SQE2N**2
10318 SPRO = SPRO +FACN*SPRON
10319 SPRO2 = SPRO2+FACN*SPRON**2
10320 SDEL = SDEL +FACN*SDELN
10321 SDEL2 = SDEL2+FACN*SDELN**2
10322 SDQE = SDQE +FACN*SDQEN
10323 SDQE2 = SDQE2+FACN*SDQEN**2
10327 * final cross sections
10329 XSTOT(IE,IQ,NTARG) = STOT
10331 & XSTOT(IE,IQ,NTARG) = XSTOT(IE,IQ,NTARG)+DBLE(NB)*SDIR
10333 XSELA(IE,IQ,NTARG) = SELA
10334 * 3) quasi-el.: A+B-->A+X (excluding 2)
10335 XSQEP(IE,IQ,NTARG) = SQEP
10336 * 4) quasi-el.: A+B-->X+B (excluding 2)
10337 XSQET(IE,IQ,NTARG) = SQET
10338 * 5) quasi-el.: A+B-->X (excluding 2-4)
10339 XSQE2(IE,IQ,NTARG) = SQE2
10340 * 6) production (= STOT-SELA-SQEP-SQET-SQE2!)
10341 IF (SDEL.GT.ZERO) THEN
10342 XSPRO(IE,IQ,NTARG) = STOT-SELA-SQEP-SQET-SQE2
10344 XSPRO(IE,IQ,NTARG) = SPRO
10346 * 7) projectile diffraction (el. scatt. off target)
10347 XSDEL(IE,IQ,NTARG) = SDEL
10348 * 8) projectile diffraction (quasi-el. scatt. off target)
10349 XSDQE(IE,IQ,NTARG) = SDQE
10351 XETOT(IE,IQ,NTARG) = SQRT(ABS(STOT2-STOT**2)/DBLE(NSTATB-1))
10352 XEELA(IE,IQ,NTARG) = SQRT(ABS(SELA2-SELA**2)/DBLE(NSTATB-1))
10353 XEQEP(IE,IQ,NTARG) = SQRT(ABS(SQEP2-SQEP**2)/DBLE(NSTATB-1))
10354 XEQET(IE,IQ,NTARG) = SQRT(ABS(SQET2-SQET**2)/DBLE(NSTATB-1))
10355 XEQE2(IE,IQ,NTARG) = SQRT(ABS(SQE22-SQE2**2)/DBLE(NSTATB-1))
10356 XEPRO(IE,IQ,NTARG) = SQRT(ABS(SPRO2-SPRO**2)/DBLE(NSTATB-1))
10357 XEDEL(IE,IQ,NTARG) = SQRT(ABS(SDEL2-SDEL**2)/DBLE(NSTATB-1))
10358 XEDQE(IE,IQ,NTARG) = SQRT(ABS(SDQE2-SDQE**2)/DBLE(NSTATB-1))
10360 IF (IJPROJ.EQ.7) THEN
10361 BNORM = XSTOT(IE,IQ,NTARG)-XSELA(IE,IQ,NTARG)
10362 & -XSQEP(IE,IQ,NTARG)
10364 BNORM = XSPRO(IE,IQ,NTARG)
10367 BSITE(IE,IQ,NTARG,I) = BPROD(I)/BNORM+BSITE(IE,IQ,NTARG,I-1)
10368 IF ((IE.EQ.1).AND.(IQ.EQ.1))
10369 & BSITE(0,1,NTARG,I) = BPROD(I)/BNORM+BSITE(0,1,NTARG,I-1)
10372 * write profile function data into file
10373 IF ((IOGLB.EQ.-1).OR.(IOGLB.EQ.-100)) THEN
10374 WRITE(LDAT,'(5I10,1P,E15.5)')
10375 & IJPROJ,NA,NB,NSTATB,NSITEB,ECMNN(IE)
10376 WRITE(LDAT,'(1P,6E12.5)')
10377 & XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),XSQEP(IE,IQ,NTARG),
10378 & XSQET(IE,IQ,NTARG),XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
10379 WRITE(LDAT,'(1P,6E12.5)')
10380 & XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),XEQEP(IE,IQ,NTARG),
10381 & XEQET(IE,IQ,NTARG),XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
10382 NLINES = INT(DBLE(NSITEB)/7.0D0)
10383 IF (NLINES.GT.0) THEN
10386 WRITE(LDAT,'(1P,7E11.4)')
10387 & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
10390 ISTART = 7*NLINES+1
10391 IF (ISTART.LE.NSITEB) THEN
10392 WRITE(LDAT,'(1P,7E11.4)')
10393 & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
10399 C IF (ABS(IOGLB).EQ.1) CLOSE(LDAT)
10404 *$ CREATE DT_GETBXS.FOR
10407 *===getbxs=============================================================*
10409 SUBROUTINE DT_GETBXS(XSFRAC,BLO,BHI,NIDX)
10411 ************************************************************************
10412 * Biasing in impact parameter space. *
10413 * XSFRAC = 0 : BLO - minimum impact parameter (input) *
10414 * BHI - maximum impact parameter (input) *
10415 * XSFRAC - fraction of cross section corresponding *
10416 * to impact parameter range (BLO,BHI) *
10418 * XSFRAC > 0 : XSFRAC - fraction of cross section (input) *
10419 * BHI - maximum impact parameter giving requested *
10420 * fraction of cross section in impact *
10421 * parameter range (0,BMAX) (output) *
10422 * This version dated 17.03.00 is written by S. Roesler *
10423 ************************************************************************
10425 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10428 PARAMETER ( LINP = 10 ,
10432 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10434 * Glauber formalism: parameters
10435 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10436 & BMAX(NCOMPX),BSTEP(NCOMPX),
10437 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10441 IF (XSFRAC.LE.0.0D0) THEN
10442 ILO = MIN(NSITEB-1,INT(BLO/BSTEP(NTARG)))
10443 IHI = MIN(NSITEB-1,INT(BHI/BSTEP(NTARG)))
10444 IF (ILO.GE.IHI) THEN
10448 IF (ILO.EQ.NSITEB-1) THEN
10449 FRCLO = BSITE(0,1,NTARG,NSITEB)
10451 FRCLO = BSITE(0,1,NTARG,ILO+1)
10452 & +(BLO-ILO*BSTEP(NTARG))/BSTEP(NTARG)
10453 & *(BSITE(0,1,NTARG,ILO+2)-BSITE(0,1,NTARG,ILO+1))
10455 IF (IHI.EQ.NSITEB-1) THEN
10456 FRCHI = BSITE(0,1,NTARG,NSITEB)
10458 FRCHI = BSITE(0,1,NTARG,IHI+1)
10459 & +(BHI-IHI*BSTEP(NTARG))/BSTEP(NTARG)
10460 & *(BSITE(0,1,NTARG,IHI+2)-BSITE(0,1,NTARG,IHI+1))
10462 XSFRAC = FRCHI-FRCLO
10467 IF (XSFRAC.LT.BSITE(0,1,NTARG,I+1)) THEN
10468 FAC = (XSFRAC -BSITE(0,1,NTARG,I))/
10469 & (BSITE(0,1,NTARG,I+1)-BSITE(0,1,NTARG,I))
10470 BHI = DBLE(I-1)*BSTEP(NTARG)+BSTEP(NTARG)*FAC
10480 *$ CREATE DT_CONUCL.FOR
10483 *===conucl=============================================================*
10485 SUBROUTINE DT_CONUCL(X,N,R,MODE)
10487 ************************************************************************
10488 * Calculation of coordinates of nucleons within nuclei. *
10489 * X(3,N) spatial coordinates of nucleons (in fm) (output) *
10490 * N / R number of nucleons / radius of nucleus (input) *
10491 * MODE = 0 coordinates not sorted *
10492 * = 1 coordinates sorted with increasing X(3,i) *
10493 * = 2 coordinates sorted with decreasing X(3,i) *
10494 * This version dated 26.10.95 is revised by S. Roesler *
10495 ************************************************************************
10497 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10500 PARAMETER ( LINP = 10 ,
10504 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10505 & ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10507 PARAMETER (TWOPI = 6.283185307179586454D+00 )
10509 PARAMETER (NSRT=10)
10510 DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10511 DIMENSION X(3,N),XTMP(3,260)
10513 CALL DT_COORDI(XTMP,IDXSRT,ICSRT,N,R)
10515 IF ((MODE.NE.0).AND.(N.GT.4)) THEN
10518 IF (MODE.EQ.2) THEN
10524 DO 2 J=1,ICSRT(ISRT)
10526 X(1,K) = XTMP(1,IDXSRT(ISRT,J))
10527 X(2,K) = XTMP(2,IDXSRT(ISRT,J))
10528 X(3,K) = XTMP(3,IDXSRT(ISRT,J))
10530 IF (ICSRT(ISRT).GT.1) THEN
10533 CALL DT_SORT(X,N,I0,I1,MODE)
10536 ELSEIF ((MODE.NE.0).AND.(N.GE.2).AND.(N.LE.4)) THEN
10542 CALL DT_SORT(X,N,1,N,MODE)
10554 *$ CREATE DT_COORDI.FOR
10557 *===coordi=============================================================*
10559 SUBROUTINE DT_COORDI(X,IDXSRT,ICSRT,N,R)
10561 ************************************************************************
10562 * Calculation of coordinates of nucleons within nuclei. *
10563 * X(3,N) spatial coordinates of nucleons (in fm) (output) *
10564 * N / R number of nucleons / radius of nucleus (input) *
10565 * Based on the original version by Shmakov et al. *
10566 * This version dated 26.10.95 is revised by S. Roesler *
10567 ************************************************************************
10569 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10572 PARAMETER ( LINP = 10 ,
10576 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10577 & ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10579 PARAMETER (TWOPI = 6.283185307179586454D+00 )
10583 PARAMETER (NSRT=10)
10584 DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10585 DIMENSION X(3,260),WD(4),RD(3)
10587 DATA PDIF/0.545D0/,R2MIN/0.16D0/
10588 DATA WD / 0.0D0, 0.178D0, 0.465D0, 1.0D0/
10589 DATA RD /2.09D0, 0.935D0, 0.697D0/
10599 ELSEIF (N.EQ.2) THEN
10600 EPS = DT_RNDM(RD(1))
10602 IF ((EPS.GE.WD(I)).AND.(EPS.LE.WD(I+1))) GOTO 40
10606 CALL DT_RANNOR(X1,X2)
10610 ELSEIF ((N.EQ.3).OR.(N.EQ.4)) THEN
10613 CALL DT_RANNOR(X3,X4)
10615 CALL DT_RANNOR(X1,X2)
10618 IF (LSTART) GOTO 80
10620 CALL DT_RANNOR(X3,X4)
10625 LSTART = .NOT.LSTART
10626 X1SUM = X1SUM+X(1,I)
10627 X2SUM = X2SUM+X(2,I)
10628 X3SUM = X3SUM+X(3,I)
10630 X1SUM = X1SUM/DBLE(N)
10631 X2SUM = X2SUM/DBLE(N)
10632 X3SUM = X3SUM/DBLE(N)
10634 X(1,I) = X(1,I)-X1SUM
10635 X(2,I) = X(2,I)-X2SUM
10636 X(3,I) = X(3,I)-X3SUM
10640 * maximum nuclear radius for coordinate sampling
10641 RMAX = R+4.605D0*PDIF
10643 * initialize pre-sorting
10647 DR = TWO*RMAX/DBLE(NSRT)
10649 * sample coordinates for N nucleons
10652 RAD = RMAX*(DT_RNDM(DR))**ONETHI
10653 F = DT_DENSIT(N,RAD,R)
10654 IF (DT_RNDM(RAD).GT.F) GOTO 120
10655 * theta, phi uniformly distributed
10656 CT = ONE-TWO*DT_RNDM(F)
10657 ST = SQRT((ONE-CT)*(ONE+CT))
10658 CALL DT_DSFECF(SFE,CFE)
10659 X(1,I) = RAD*ST*CFE
10660 X(2,I) = RAD*ST*SFE
10662 * ensure that distance between two nucleons is greater than R2MIN
10663 IF (I.LT.2) GOTO 122
10666 DIST2 = (X(1,I)-X(1,I2))**2+(X(2,I)-X(2,I2))**2+
10667 & (X(3,I)-X(3,I2))**2
10668 IF (DIST2.LE.R2MIN) GOTO 120
10671 * save index according to z-bin
10672 IDXZ = INT( (X(3,I)+RMAX)/DR )+1
10673 ICSRT(IDXZ) = ICSRT(IDXZ)+1
10674 IDXSRT(IDXZ,ICSRT(IDXZ)) = I
10675 X1SUM = X1SUM+X(1,I)
10676 X2SUM = X2SUM+X(2,I)
10677 X3SUM = X3SUM+X(3,I)
10679 X1SUM = X1SUM/DBLE(N)
10680 X2SUM = X2SUM/DBLE(N)
10681 X3SUM = X3SUM/DBLE(N)
10683 X(1,I) = X(1,I)-X1SUM
10684 X(2,I) = X(2,I)-X2SUM
10685 X(3,I) = X(3,I)-X3SUM
10693 *$ CREATE DT_DENSIT.FOR
10696 *===densit=============================================================*
10698 DOUBLE PRECISION FUNCTION DT_DENSIT(NA,R,RA)
10700 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10703 PARAMETER ( LINP = 10 ,
10707 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10708 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
10711 DIMENSION R0(18),FNORM(18)
10712 DATA R0 / ZERO, ZERO, ZERO, ZERO, 2.12D0,
10713 & 2.56D0, 2.41D0, 2.46D0, 2.52D0, 2.45D0,
10714 & 2.37D0, 2.46D0, 2.44D0, 2.54D0, 2.58D0,
10715 & 2.72D0, 2.66D0, 2.79D0/
10716 DATA FNORM /.1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10717 & .1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10718 & .1012D+01,.1039D+01,.1075D+01,.1118D+01,.1164D+01,
10719 & .1214D+01,.1265D+01,.1318D+01/
10720 DATA PDIF /0.545D0/
10726 ELSEIF ((NA.GT.4).AND.(NA.LE.18)) THEN
10727 R1 = R0(NA)/SQRT(2.5D0-4.0D0/DBLE(NA))
10728 DT_DENSIT = (ONE+(DBLE(NA)-4.0D0)/6.0D0*(R/R1)**2)
10729 & *EXP(-(R/R1)**2)/FNORM(NA)
10731 ELSEIF (NA.GT.18) THEN
10732 DT_DENSIT = ONE/(ONE+EXP((R-RA)/PDIF))
10738 *$ CREATE DT_RNCLUS.FOR
10741 *===rnclus=============================================================*
10743 DOUBLE PRECISION FUNCTION DT_RNCLUS(N)
10745 ************************************************************************
10746 * Nuclear radius for nucleus with mass number N. *
10747 * This version dated 26.9.00 is written by S. Roesler *
10748 ************************************************************************
10750 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10753 PARAMETER (ONE=1.0D0,THREE=3.0D0,ONETHI=ONE/THREE)
10756 PARAMETER (RNUCLE = 1.12D0)
10758 * nuclear radii for selected nuclei
10759 DIMENSION RADNUC(18)
10760 DATA RADNUC / 8*0.0D0,2.52D0,2.45D0,2.37D0,2.45D0,2.44D0,2.55D0,
10761 & 2.58D0,2.71D0,2.66D0,2.71D0/
10764 IF (RADNUC(N).GT.0.0D0) THEN
10765 DT_RNCLUS = RADNUC(N)
10767 DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10770 DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10776 *$ CREATE DT_DENTST.FOR
10779 *===dentst=============================================================*
10781 C PROGRAM DT_DENTST
10782 SUBROUTINE DT_DENTST
10784 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10787 OPEN(40,FILE='dentst.out',STATUS='UNKNOWN')
10788 OPEN(41,FILE='denmax.out',STATUS='UNKNOWN')
10793 DR = (RMAX-RMIN)/DBLE(NBINS)
10797 R = RMIN+DBLE(IR-1)*DR
10798 F = DT_DENSIT(IA,R,R)
10799 IF (F.GT.FMAX) FMAX = F
10800 WRITE(40,'(1X,I3,2E15.5)') IA,R,F
10802 WRITE(41,'(1X,I3,E15.5)') IA,FMAX
10810 *$ CREATE DT_SHMAKI.FOR
10813 *===shmaki=============================================================*
10815 SUBROUTINE DT_SHMAKI(NA,NCA,NB,NCB,IJP,PPN,MODE)
10817 ************************************************************************
10818 * Initialisation of Glauber formalism. This subroutine has to be *
10819 * called once (in case of target emulsions as often as many different *
10820 * target nuclei are considered) before events are sampled. *
10821 * NA / NCA mass number/charge of projectile nucleus *
10822 * NB / NCB mass number/charge of target nucleus *
10823 * IJP identity of projectile (hadrons/leptons/photons) *
10824 * PPN projectile momentum (for projectile nuclei: *
10825 * momentum per nucleon) in target rest system *
10826 * MODE = 0 Glauber formalism invoked *
10827 * = 1 fitted results are loaded from data-file *
10828 * = 99 NTARG is forced to be 1 *
10829 * (used in connection with GLAUBERI-card only) *
10830 * This version dated 22.03.96 is based on the original SHMAKI-routine *
10831 * and revised by S. Roesler. *
10832 ************************************************************************
10834 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10837 PARAMETER ( LINP = 10 ,
10841 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
10844 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10846 * Glauber formalism: parameters
10847 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10848 & BMAX(NCOMPX),BSTEP(NCOMPX),
10849 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10852 * Lorentz-parameters of the current interaction
10853 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10854 & UMO,PPCM,EPROJ,PPROJ
10856 * properties of photon/lepton projectiles
10857 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10859 * kinematical cuts for lepton-nucleus interactions
10860 COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
10861 & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
10863 * Glauber formalism: cross sections
10864 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10865 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10866 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10867 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10868 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10869 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10870 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10871 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10872 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10873 & BSLOPE,NEBINI,NQBINI
10875 * cuts for variable energy runs
10876 COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
10878 * nucleon-nucleon event-generator
10881 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10883 * Glauber formalism: flags and parameters for statistics
10886 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10888 DATA NTARG,ICOUT,IVEOUT /0,0,0/
10894 IF (MODE.EQ.99) NTARG = 1
10896 IF (MODE.EQ.-1) NIDX = NTARG
10898 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) ICOUT = ICOUT+1
10899 IF (ICOUT.EQ.1) WRITE(LOUT,1000)
10900 1000 FORMAT(//,1X,'SHMAKI: Glauber formalism (Shmakov et. al) -',
10901 & ' initialization',/,12X,'--------------------------',
10902 & '-------------------------',/)
10904 IF (MODE.EQ.2) THEN
10905 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10906 CALL DT_SHFAST(MODE,PPN,IBACK)
10907 STOP ' Glauber pre-initialization done'
10909 IF (MODE.EQ.1) THEN
10910 CALL DT_PROFBI(NA,NB,PPN,NTARG)
10913 IF (MODE.EQ.3) CALL DT_SHFAST(MODE,PPN,IBACK)
10914 IF (IBACK.EQ.1) THEN
10915 * lepton-nucleus (variable energy runs)
10916 IF ((IJP.EQ. 3).OR.(IJP.EQ. 4).OR.
10917 & (IJP.EQ.10).OR.(IJP.EQ.11)) THEN
10918 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10919 & WRITE(LOUT,1002) NB,NCB
10920 1002 FORMAT(1X,'variable energy run: projectile-id: 7',
10921 & ' target A/Z: ',I3,' /',I3,/,/,8X,
10922 & 'E_cm (GeV) Q^2 (GeV^2)',
10923 & ' Sigma_tot (mb) Sigma_in (mb)',/,7X,
10924 & '--------------------------------',
10925 & '------------------------------')
10926 AECMLO = LOG10(MIN(UMO,ECMLI))
10927 AECMHI = LOG10(MIN(UMO,ECMHI))
10929 DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
10930 IF (AECMLO.EQ.AECMHI) IESTEP = 0
10932 ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10933 IF (Q2HI.GT.0.1D0) THEN
10934 IF (Q2LI.LT.0.01D0) THEN
10935 CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10936 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10938 & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10945 AQ2LO = LOG10(Q2LI)
10946 AQ2HI = LOG10(Q2HI)
10947 DAQ2 = (AQ2HI-AQ2LO)/MAX(DBLE(IQSTEP),ONE)
10948 DO 2 J=IBIN,IQSTEP+IBIN
10949 Q2 = 10.0D0**(AQ2LO+DBLE(J-IBIN)*DAQ2)
10950 CALL DT_XSGLAU(NA,NB,7,ZERO,Q2,ECM,I,J,NIDX)
10951 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10952 & WRITE(LOUT,1003) ECMNN(I),
10953 & Q2G(J),XSTOT(I,J,NTARG),XSPRO(I,J,NTARG)
10956 CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10957 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10959 & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10961 1003 FORMAT(9X,F6.1,9X,F6.2,8X,F8.3,11X,F8.3)
10965 * hadron/photon/nucleus-nucleus
10966 IF ((ABS(VAREHI).GT.ZERO).AND.
10967 & (ABS(VAREHI).GT.ABS(VARELO))) THEN
10968 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) THEN
10969 WRITE(LOUT,1004) NA,NB,NCB
10970 1004 FORMAT(1X,'variable energy run: projectile-id:',
10971 & I3,' target A/Z: ',I3,' /',I3,/)
10973 1005 FORMAT(' E_cm (GeV) E_Lab (GeV) sig_tot^pp (mb)'
10974 & ,' Sigma_tot (mb) Sigma_prod (mb)',/,
10975 & ' -------------------------------------',
10976 & '--------------------------------------')
10978 AECMLO = LOG10(VARCLO)
10979 AECMHI = LOG10(VARCHI)
10981 DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
10982 IF (AECMLO.EQ.AECMHI) IESTEP = 0
10984 ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10989 ELAB = (ECM**2-AMP2-AMT2)/(TWO*AMT)
10990 PLAB = SQRT((ELAB+AMP)*(ELAB-AMP))
10991 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,ECM,I,1,NIDX)
10992 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10994 & ECM,PLAB,SIGSH,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10995 1006 FORMAT(1X,F9.1,1X,E11.3,1X,F12.2,8X,F10.3,8X,F8.3)
10999 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
11005 IF ((ICOUT.LT.15).AND.(IVEOUT.EQ.0).AND.(MCGENE.NE.4).AND.
11006 & (IOGLB.NE.100)) THEN
11007 WRITE(LOUT,1001) NA,NCA,NB,NCB,ECMNN(1),SIGSH*10.0D0,ROSH,
11008 & BSLOPE,NSITEB,NSTATB,XSPRO(1,1,NTARG)
11009 1001 FORMAT(38X,'projectile',
11010 & ' target',/,1X,'Mass number / charge',
11011 & 17X,I3,' /',I3,6X,I3,' /',I3,/,/,1X,
11012 & 'Nucleon-nucleon c.m. energy',9X,F10.2,' GeV',/,/,1X,
11013 & 'Parameters of elastic scattering amplitude:',/,5X,
11014 & 'sigma =',F7.2,' mb',6X,'rho = ',F9.4,6X,'slope = ',
11015 & F4.1,' GeV^-2',/,/,1X,'Number of b-steps',4X,I3,8X,
11016 & 'statistics at each b-step',4X,I5,/,/,1X,
11017 & 'Prod. cross section ',5X,F10.4,' mb',/)
11023 *$ CREATE DT_PROFBI.FOR
11026 *===profbi=============================================================*
11028 SUBROUTINE DT_PROFBI(NA,NB,PPN,NTARG)
11030 ************************************************************************
11031 * Integral over profile function (to be used for impact-parameter *
11032 * sampling during event generation). *
11033 * Fitted results are used. *
11034 * NA / NB mass numbers of proj./target nuclei *
11035 * PPN projectile momentum (for projectile nuclei: *
11036 * momentum per nucleon) in target rest system *
11037 * NTARG index of target material (i.e. kind of nucleus) *
11038 * This version dated 31.05.95 is revised by S. Roesler *
11039 ************************************************************************
11041 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11044 PARAMETER ( LINP = 10 ,
11050 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
11055 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11057 * Glauber formalism: parameters
11058 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11059 & BMAX(NCOMPX),BSTEP(NCOMPX),
11060 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11063 * Glauber formalism: cross sections
11064 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11065 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11066 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11067 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11068 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11069 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11070 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11071 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11072 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11073 & BSLOPE,NEBINI,NQBINI
11075 PARAMETER (NGLMAX=8000)
11076 DIMENSION NGLIT(NGLMAX),NGLIP(NGLMAX),GLAPPN(NGLMAX),
11077 & GLASIG(NGLMAX),GLAFIT(5,NGLMAX)
11079 DATA LSTART /.TRUE./
11082 * read fit-parameters from file
11083 OPEN(47,FILE='inpdata/glpara.dat',STATUS='UNKNOWN')
11086 READ(47,'(A80)') CNAME
11087 IF (CNAME.EQ.'STOP') GOTO 2
11089 READ(CNAME,*) NGLIP(I),NGLIT(I),GLAPPN(I),GLASIG(I),
11090 & GLAFIT(1,I),GLAFIT(2,I),GLAFIT(3,I),
11091 & GLAFIT(4,I),GLAFIT(5,I)
11092 IF (I+1.GT.NGLMAX) THEN
11094 1000 FORMAT(1X,'PROFBI: warning! array size exceeded - ',
11095 & 'program stopped')
11112 IF ((NNB.LT.NGLIT(J)).OR.(J.EQ.NGLPAR)) THEN
11113 IF (NNB.NE.NGLIT(J-1)) NNB = NGLIT(J-1)
11116 IF (J.EQ.NGLPAR) IPOINT = J+1-K
11117 IF ((NNA.GT.NGLIP(IPOINT)).OR.
11118 & (NNB.NE.NGLIT(IPOINT)).OR.(IPOINT.EQ.1)) THEN
11119 IF (IPOINT.EQ.1) IPOINT = 0
11120 NATMP = NGLIP(IPOINT+1)
11121 IF (PPN.LT.GLAPPN(IPOINT+1)) THEN
11127 C IF (J.EQ.NGLPAR) THEN
11131 DO 5 J1=J1BEG,J1END
11132 IF (NGLIP(J1).EQ.NATMP) THEN
11133 IF (PPN.LT.GLAPPN(J1)) THEN
11142 IF ((J.EQ.NGLPAR).AND.(PPN.GT.GLAPPN(NGLPAR)))
11151 IF (IDXGLA.EQ.0) THEN
11152 WRITE(LOUT,1001) NNA,NNB,PPN
11153 1001 FORMAT(1X,'PROFBI: configuration (NA,NB,PPN = ',
11154 & 2I4,F6.0,') not found ')
11158 * no interpolation yet available
11159 XSPRO(1,1,NTARG) = GLASIG(IDXGLA)
11161 BSITE(1,1,NTARG,1) = ZERO
11164 POLY = GLAFIT(1,IDXGLA)+GLAFIT(2,IDXGLA)*XX+
11165 & GLAFIT(3,IDXGLA)*XX**2+GLAFIT(4,IDXGLA)*XX**3+
11166 & GLAFIT(5,IDXGLA)*XX**4
11167 IF (ABS(POLY).GT.35.0D0) POLY = SIGN(35.0D0,POLY)
11168 BSITE(1,1,NTARG,I) = (1.0D0-EXP(-POLY))
11169 IF (BSITE(1,1,NTARG,I).LT.ZERO) BSITE(1,1,NTARG,I) = ZERO
11175 *$ CREATE DT_GLAUBE.FOR
11178 *===glaube=============================================================*
11180 SUBROUTINE DT_GLAUBE(NA,NB,IJPROJ,B,INTT,INTA,INTB,JS,JT,NIDX)
11182 ************************************************************************
11183 * Calculation of configuartion of interacting nucleons for one event. *
11184 * NB / NB mass numbers of proj./target nuclei (input) *
11185 * B impact parameter (output) *
11186 * INTT total number of wounded nucleons " *
11187 * INTA / INTB number of wounded nucleons in proj. / target " *
11188 * JS / JT(i) number of collisions proj. / target nucleon i is *
11189 * involved (output) *
11190 * NIDX index of projectile/target material (input) *
11191 * = -2 call within FLUKA transport calculation *
11192 * This is an update of the original routine SHMAKO by J.Ranft/HJM *
11193 * This version dated 22.03.96 is revised by S. Roesler *
11195 * Last change 27.12.2006 by S. Roesler. *
11196 ************************************************************************
11198 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11201 PARAMETER ( LINP = 10 ,
11205 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
11206 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
11208 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11210 PARAMETER ( MAXNCL = 260,
11213 & MAXSQU = 20*MAXVQU,
11214 & MAXINT = MAXVQU+MAXSQU)
11216 * Glauber formalism: parameters
11217 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11218 & BMAX(NCOMPX),BSTEP(NCOMPX),
11219 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11222 * Glauber formalism: cross sections
11223 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11224 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11225 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11226 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11227 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11228 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11229 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11230 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11231 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11232 & BSLOPE,NEBINI,NQBINI
11234 * Lorentz-parameters of the current interaction
11235 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
11236 & UMO,PPCM,EPROJ,PPROJ
11238 * properties of photon/lepton projectiles
11239 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
11241 * Glauber formalism: collision properties
11242 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
11243 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
11245 * Glauber formalism: flags and parameters for statistics
11248 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11250 DIMENSION JS(MAXNCL),JT(MAXNCL)
11254 * get actual energy from /DTLTRA/
11258 * new patch for pre-initialized variable projectile/target/energy runs,
11259 * bypassed for use within FLUKA (Nidx=-2)
11260 IF (IOGLB.EQ.100) THEN
11261 IF (NIDX.NE.-2) CALL DT_GLBSET(IJPROJ,NA,NB,EPROJ,1)
11263 * variable energy run, interpolate profile function
11268 IF (NEBINI.GT.1) THEN
11269 IF (ECMNOW.GE.ECMNN(NEBINI)) THEN
11273 ELSEIF (ECMNOW.GT.ECMNN(1)) THEN
11275 IF (ECMNOW.LT.ECMNN(I)) THEN
11278 RATE = (ECMNOW-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
11288 IF (NQBINI.GT.1) THEN
11289 IF (Q2.GE.Q2G(NQBINI)) THEN
11293 ELSEIF (Q2.GT.Q2G(1)) THEN
11295 IF (Q2.LT.Q2G(I)) THEN
11298 RATQ = LOG10( Q2/MAX(Q2G(J1),TINY14))/
11299 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
11300 C RATQ = (Q2-Q2G(J1))/(Q2G(J2)-Q2G(J1))
11309 BSITE(0,1,NTARG,I) = BSITE(I1,J1,NTARG,I)+
11310 & RATE*(BSITE(I2,J1,NTARG,I)-BSITE(I1,J1,NTARG,I))+
11311 & RATQ*(BSITE(I1,J2,NTARG,I)-BSITE(I1,J1,NTARG,I))+
11312 & RATE*RATQ*(BSITE(I2,J2,NTARG,I)-BSITE(I1,J2,NTARG,I)+
11313 & BSITE(I1,J1,NTARG,I)-BSITE(I2,J1,NTARG,I))
11317 CALL DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,INTT,INTA,INTB,IDIREC,NIDX)
11318 IF (NIDX.LE.-1) THEN
11320 RTARG = RBSH(NTARG)
11322 RPROJ = RASH(NTARG)
11329 *$ CREATE DT_DIAGR.FOR
11332 *===diagr==============================================================*
11334 SUBROUTINE DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,JNT,INTA,INTB,IDIREC,
11337 ************************************************************************
11338 * Based on the original version by Shmakov et al. *
11339 * This version dated 21.04.95 is revised by S. Roesler *
11340 ************************************************************************
11342 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11345 PARAMETER ( LINP = 10 ,
11349 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
11350 PARAMETER (TWOPI = 6.283185307179586454D+00,
11352 & GEV2MB = 0.38938D0,
11353 & GEV2FM = 0.1972D0,
11354 & ALPHEM = ONE/137.0D0,
11363 PARAMETER ( MAXNCL = 260,
11366 & MAXSQU = 20*MAXVQU,
11367 & MAXINT = MAXVQU+MAXSQU)
11369 * particle properties (BAMJET index convention)
11371 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11372 & IICH(210),IIBAR(210),K1(210),K2(210)
11374 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11376 * emulsion treatment
11377 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11380 * Glauber formalism: parameters
11381 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11382 & BMAX(NCOMPX),BSTEP(NCOMPX),
11383 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11386 * Glauber formalism: cross sections
11387 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11388 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11389 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11390 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11391 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11392 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11393 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11394 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11395 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11396 & BSLOPE,NEBINI,NQBINI
11398 * VDM parameter for photon-nucleus interactions
11399 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
11401 * nucleon-nucleon event-generator
11404 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
11406 C COMMON /CUTOFF/ PTCUT(4),CUTMU(4),FPS(4),FPH(4),PSOMIN,XSOMIN
11409 C obsolete cut-off information
11410 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
11411 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
11414 * coordinates of nucleons
11415 COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
11417 * interface between Glauber formalism and DPM
11418 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
11419 & INTER1(MAXINT),INTER2(MAXINT)
11421 * statistics: Glauber-formalism
11422 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
11424 * n-n cross section fluctuations
11425 PARAMETER (NBINS = 1000)
11426 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
11428 DIMENSION JS(MAXNCL),JT(MAXNCL),
11429 & JS0(MAXNCL),JT0(MAXNCL,MAXNCL),
11430 & JI1(MAXNCL,MAXNCL),JI2(MAXNCL,MAXNCL),JNT0(MAXNCL)
11431 DIMENSION NWA(0:210),NWB(0:210)
11434 DATA LFIRST /.TRUE./
11436 DATA NTARGO,ICNT /0,0/
11442 IF (NCOMPO.EQ.0) THEN
11452 IF (NTARG.EQ.-1) THEN
11453 IF (NCOMPO.EQ.0) THEN
11454 WRITE(LOUT,*) ' DIAGR: distribution of wounded nucleons'
11455 WRITE(LOUT,'(8X,A,3I7)') 'NCALL,NWAMAX,NWBMAX = ',
11456 & NCALL,NWAMAX,NWBMAX
11457 DO 18 I=1,MAX(NWAMAX,NWBMAX)
11458 WRITE(LOUT,'(8X,2I7,E12.4,I7,E12.4)')
11459 & I,NWA(I),DBLE(NWA(I))/DBLE(NCALL),
11460 & NWB(I),DBLE(NWB(I))/DBLE(NCALL)
11470 IF (SQ2.LE.ZERO) SQ2 = 0.0001D0
11472 X = SQ2/(S+SQ2-AMP2)
11473 XNU = (S+SQ2-AMP2)/(TWO*AMP)
11474 * photon projectiles: recalculate photon-nucleon amplitude
11475 IF (IJPROJ.EQ.7) THEN
11477 * VDM assumption: mass of V-meson
11478 AMV2 = DT_SAM2(SQ2,ECMNOW)
11480 IF (AMV.GT.2.0D0*PTCUT(1)) GOTO 15
11481 * check for pointlike interaction
11482 CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,1)
11484 C SIGSH = DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
11485 SIGSH = (ONE-RPNT)*DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
11488 BSLOPE = 2.0D0*(2.0D0+AMRHO0**2/(AMV2+SQ2)
11489 & +0.25D0*LOG(S/(AMV2+SQ2)))
11491 IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+SQ2)*GEV2FM
11492 ELSEIF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
11493 IF (MCGENE.EQ.2) THEN
11495 CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SDUM1,SDUM2,SDUM3,
11498 BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
11500 IF (ECMNOW.LE.3.0D0) THEN
11502 ELSEIF ((ECMNOW.GT.3.0D0).AND.(ECMNOW.LE.50.D0)) THEN
11503 ROSH = -0.63D0+0.175D0*LOG(ECMNOW)
11504 ELSEIF (ECMNOW.GT.50.0D0) THEN
11507 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
11508 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
11509 IF (MCGENE.EQ.2) THEN
11511 CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SIGSH,SDUM2,SDUM3,
11513 SIGSH = SIGSH/10.0D0
11515 C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
11517 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
11518 SIGSH = SIGSH/10.0D0
11521 BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
11523 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
11524 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
11525 C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
11527 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
11528 SIGSH = SIGSH/10.0D0
11530 GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
11532 RCA = GAM*SIGSH/TWOPI
11534 CA = DCMPLX(RCA,FCA)
11535 CI = DCMPLX(ONE,ZERO)
11539 IF (MCGENE.NE.3) CALL DT_MODB(B,NIDX)
11552 IF (IJPROJ.EQ.7) THEN
11562 * nucleon configuration
11563 C IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,5).EQ.0)) THEN
11564 IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,1).EQ.0)) THEN
11565 C CALL DT_CONUCL(PKOO,NA,RASH,2)
11566 C CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),1)
11567 IF (NIDX.LE.-1) THEN
11568 CALL DT_CONUCL(PKOO,NA,RASH(1),0)
11569 CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),0)
11571 CALL DT_CONUCL(PKOO,NA,RASH(NTARG),0)
11572 CALL DT_CONUCL(TKOO,NB,RBSH(1),0)
11578 * LEPTO: pick out one struck nucleon
11579 IF (MCGENE.EQ.3) THEN
11582 IDX = INT(DT_RNDM(X)*NB)+1
11589 * cross section fluctuations
11591 IF (IFLUCT.EQ.1) THEN
11592 IFLUK = INT((DT_RNDM(X)+0.001D0)*1000.0D0)
11593 AFLUC = FLUIXX(IFLUK)
11598 * photon-projectile: check for supression by coherence length
11599 IF (IJPROJ.EQ.7) THEN
11600 IF (ABS(TKOO(3,INB)-TKOO(3,KK1)).GT.DCOH) THEN
11605 QQ1 = B+TKOO(1,INB)-PKOO(1,INA)
11606 QQ2 = TKOO(2,INB)-PKOO(2,INA)
11607 XY = GAM*(QQ1*QQ1+QQ2*QQ2)
11608 IF (XY.LE.15.0D0) THEN
11609 C = CI-CA*AFLUC*EXP(-XY)
11613 IF (DT_RNDM(XY).GE.P) THEN
11615 IF (IJPROJ.EQ.7) THEN
11616 JNT0(KINT) = JNT0(KINT)+1
11617 IF (JNT0(KINT).GT.MAXNCL) THEN
11618 WRITE(LOUT,1001) MAXNCL
11620 & 'DIAGR: no. of requested interactions',
11621 & ' exceeds array dimensions ',I4)
11624 JS0(KINT) = JS0(KINT)+1
11625 JT0(KINT,INB) = JT0(KINT,INB)+1
11626 JI1(KINT,JNT0(KINT)) = INA
11627 JI2(KINT,JNT0(KINT)) = INB
11629 IF (JNT.GT.MAXINT) THEN
11630 WRITE(LOUT,1000) JNT, MAXINT
11632 & 'DIAGR: no. of requested interactions ('
11633 & ,I4,') exceeds array dimensions (',I4,')')
11636 JS(INA) = JS(INA)+1
11637 JT(INB) = JT(INB)+1
11647 IF (NTRY.LT.500) THEN
11650 C WRITE(6,*) ' new impact parameter required (old= ',B,')'
11656 IF (IJPROJ.EQ.7) THEN
11657 K = INT(ONE+DT_RNDM(X)*DBLE(KINT))
11659 IF (JNT0(K).EQ.0) THEN
11661 IF (K.GT.KINT) K = 1
11664 * supress Glauber-cascade by direct photon processes
11665 CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,2)
11666 IF (IPNT.GT.0) THEN
11670 JT(INB) = JT0(K,INB)
11671 IF (JT(INB).GT.0) GOTO 12
11681 JT(INB) = JT0(K,INB)
11684 INTER1(I) = JI1(K,I)
11685 INTER2(I) = JI2(K,I)
11694 IF (JS(I).NE.0) INTA=INTA+1
11697 IF (JT(I).NE.0) INTB=INTB+1
11706 IF (NCOMPO.EQ.0) THEN
11708 NWA(INTA) = NWA(INTA)+1
11709 NWB(INTB) = NWB(INTB)+1
11715 *$ CREATE DT_MODB.FOR
11718 *===modb===============================================================*
11720 SUBROUTINE DT_MODB(B,NIDX)
11722 ************************************************************************
11723 * Sampling of impact parameter of collision. *
11724 * B impact parameter (output) *
11725 * NIDX index of projectile/target material (input)*
11726 * Based on the original version by Shmakov et al. *
11727 * This version dated 21.04.95 is revised by S. Roesler *
11729 * Last change 27.12.2006 by S. Roesler. *
11730 ************************************************************************
11732 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11735 PARAMETER ( LINP = 10 ,
11739 PARAMETER (ZERO=0.0D0,TINY15=1.0D-15,ONE=1.0D0,TWO=2.0D0)
11741 LOGICAL LEFT,LFIRST
11743 * central particle production, impact parameter biasing
11744 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
11746 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11748 * Glauber formalism: parameters
11749 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11750 & BMAX(NCOMPX),BSTEP(NCOMPX),
11751 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11754 * Glauber formalism: cross sections
11755 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11756 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11757 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11758 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11759 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11760 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11761 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11762 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11763 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11764 & BSLOPE,NEBINI,NQBINI
11766 DATA LFIRST /.TRUE./
11769 IF (NIDX.LE.-1) THEN
11777 IF (ICENTR.EQ.2) THEN
11779 BB = DT_RNDM(B)*(0.3D0*RA)**2
11781 ELSEIF(RA.LT.RB)THEN
11782 BB = DT_RNDM(B)*1.4D0*(RB-RA)**2
11784 ELSEIF(RA.GT.RB)THEN
11785 BB = DT_RNDM(B)*1.4D0*(RA-RB)**2
11795 LEFT = ((BSITE(0,1,NTARG,I0)-Y)
11796 & *(BSITE(0,1,NTARG,I1)-Y)).LT.ZERO
11803 IF (I2-I0-2) 40,50,60
11806 IF (I1.GT.NSITEB) I1 = I0-1
11814 X0 = DBLE(I0-1)*BSTEP(NTARG)
11815 X1 = DBLE(I1-1)*BSTEP(NTARG)
11816 X2 = DBLE(I2-1)*BSTEP(NTARG)
11817 Y0 = BSITE(0,1,NTARG,I0)
11818 Y1 = BSITE(0,1,NTARG,I1)
11819 Y2 = BSITE(0,1,NTARG,I2)
11821 B = X0*(Y-Y1)*(Y-Y2)/((Y0-Y1)*(Y0-Y2)+TINY15)+
11822 & X1*(Y-Y0)*(Y-Y2)/((Y1-Y0)*(Y1-Y2)+TINY15)+
11823 & X2*(Y-Y0)*(Y-Y1)/((Y2-Y0)*(Y2-Y1)+TINY15)
11824 **sr 5.4.98: shift B by half the bin width to be in agreement with BPROD
11825 B = B+0.5D0*BSTEP(NTARG)
11826 IF (B.LT.ZERO) B = X1
11827 IF (B.GT.BMAX(NTARG)) B = BMAX(NTARG)
11828 IF (ICENTR.LT.0) THEN
11831 IF (ICENTR.LE.-100) THEN
11836 CALL DT_GETBXS(XSFRAC,BIMIN,BIMAX,NTARG)
11837 WRITE(LOUT,1000) RASH(1),RBSH(NTARG),BMAX(NTARG),
11838 & BIMIN,BIMAX,XSFRAC*100.0D0,
11839 & XSFRAC*XSPRO(1,1,NTARG)
11840 10000 FORMAT(/,1X,'DT_MODB: Biasing in impact parameter',
11841 & /,15X,'---------------------------'/,/,4X,
11842 & 'average radii of proj / targ :',F10.3,' fm /',
11843 & F7.3,' fm',/,4X,'corresp. b_max (4*(r_p+r_t)) :',
11844 & F10.3,' fm',/,/,21X,'b_lo / b_hi :',
11845 & F10.3,' fm /',F7.3,' fm',/,5X,'percentage of',
11846 & ' cross section :',F10.3,' %',/,5X,
11847 & 'corresponding cross section :',F10.3,' mb',/)
11849 IF (ABS(BIMAX-BIMIN).LT.1.0D-3) THEN
11852 IF ((B.LT.BIMIN).OR.(B.GT.BIMAX)) GOTO 9
11860 *$ CREATE DT_SHFAST.FOR
11863 *===shfast=============================================================*
11865 SUBROUTINE DT_SHFAST(MODE,PPN,IBACK)
11867 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11870 PARAMETER ( LINP = 10 ,
11874 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY1=1.0D-1,
11875 & ONE=1.0D0,TWO=2.0D0)
11877 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11879 * Glauber formalism: parameters
11880 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11881 & BMAX(NCOMPX),BSTEP(NCOMPX),
11882 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11885 * properties of interacting particles
11886 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11888 * Glauber formalism: cross sections
11889 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11890 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11891 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11892 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11893 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11894 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11895 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11896 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11897 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11898 & BSLOPE,NEBINI,NQBINI
11902 IF (MODE.EQ.2) THEN
11903 OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11904 WRITE(47,1000) IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG,PPN
11905 1000 FORMAT(1X,8I5,E15.5)
11906 WRITE(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11907 1001 FORMAT(1X,4E15.5)
11908 WRITE(47,1002) SIGSH,ROSH,GSH
11909 1002 FORMAT(1X,3E15.5)
11911 WRITE(47,'(1X,E15.5)') BSITE(1,1,1,I)
11913 WRITE(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11914 1003 FORMAT(1X,2I10,3E15.5)
11917 OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11918 READ(47,1000) JT,JTZ,JP,JPZ,JJPROJ,JBPROJ,JJTARG,JBTARG,PP
11919 IF ((JT.EQ.IT).AND.(JTZ.EQ.ITZ).AND.(JP.EQ.IP).AND.
11920 & (JPZ.EQ.IPZ).AND.(JJPROJ.EQ.IJPROJ).AND.(JBPROJ.EQ.IBPROJ)
11921 & .AND.(JJTARG.EQ.IJTARG).AND.(JBTARG.EQ.IBTARG).AND.
11922 & (ABS(PP-PPN).LT.(PPN*0.01D0))) THEN
11923 READ(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11924 READ(47,1002) SIGSH,ROSH,GSH
11926 READ(47,'(1X,E15.5)') BSITE(1,1,1,I)
11928 READ(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11938 *$ CREATE DT_POILIK.FOR
11941 *===poilik=============================================================*
11943 SUBROUTINE DT_POILIK(NB,NTARG,ECM,VIRT,IPNT,RPNT,MODE)
11945 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
11948 PARAMETER ( LINP = 10 ,
11952 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.0D0)
11956 C CHARACTER*8 MDLNA
11957 C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
11958 C PARAMETER (IEETAB=10)
11959 C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
11962 C model switches and parameters
11964 INTEGER ISWMDL,IPAMDL
11965 DOUBLE PRECISION PARMDL
11966 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11968 C energy-interpolation table
11970 PARAMETER ( IEETA2 = 20 )
11972 DOUBLE PRECISION SIGTAB,SIGECM
11973 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
11976 * VDM parameter for photon-nucleus interactions
11977 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
11980 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11982 * Glauber formalism: cross sections
11983 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11984 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11985 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11986 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11987 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11988 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11989 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11990 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11991 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11992 & BSLOPE,NEBINI,NQBINI
11995 DATA ECMOLD,Q2OLD /-1.0D0,-1.0D0/
11997 IF ((ECM.EQ.ECMOLD).AND.(VIRT.EQ.Q2OLD)) GOTO 3
11999 * load cross sections from interpolation table
12001 IF(ECM.LE.SIGECM(IP,1)) THEN
12004 ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
12006 IF(ECM.LE.SIGECM(IP,I)) GOTO 200
12012 WRITE(LOUT,'(/1X,A,2E12.3)')
12013 & 'POILIK:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
12018 IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
12019 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
12022 SIGANO = DT_SANO(ECM)
12024 * cross section dependence on photon virtuality
12027 FSUP1 = FSUP1+PARMDL(26+I)*(ONE+VIRT/(4.D0*PARMDL(30+I)))
12028 & /(ONE+VIRT/PARMDL(30+I))**2
12030 FSUP1 = FSUP1+PARMDL(30)/(ONE+VIRT/PARMDL(34))
12040 C SIGTOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
12041 CALL DT_SIGGP(ZERO,VIRT,ECM,ZERO,SIGTOT,DUM1,DUM2)
12042 IF (ISHAD(1).EQ.1) THEN
12043 SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
12047 SIGANO = FSUP1*FSUP2*SIGANO
12048 SIGTOT = SIGTOT-SIGDIR-SIGANO
12049 SIGDIR = SIGDIR/(FSUP1*FSUP2)
12050 SIGANO = SIGANO/(FSUP1*FSUP2)
12051 SIGTOT = SIGTOT+SIGDIR+SIGANO
12053 RR = DT_RNDM(SIGTOT)
12054 IF (RR.LT.SIGDIR/SIGTOT) THEN
12056 ELSEIF ((RR.GE.SIGDIR/SIGTOT).AND.
12057 & (RR.LT.(SIGDIR+SIGANO)/SIGTOT)) THEN
12062 RPNT = (SIGDIR+SIGANO)/SIGTOT
12063 C WRITE(LOUT,'(I3,2F15.5)') ISHAD(1),FAC1,FAC2
12064 C WRITE(LOUT,'(I3,2F15.5)') MODE,SIGDIR,SIGANO
12065 C WRITE(LOUT,'(I3,4F15.5)') MODE,SIGDIR+SIGANO,SIGTOT,RPNT,ECM
12066 C WRITE(LOUT,'(1X,6E12.4)') ECM,VIRT,SIGTOT,SIGDIR,SIGANO,RPNT
12067 IF (MODE.EQ.1) RETURN
12073 IF (ECM.GE.ECMNN(NEBINI)) THEN
12077 ELSEIF (ECM.GT.ECMNN(1)) THEN
12079 IF (ECM.LT.ECMNN(I)) THEN
12082 RATE = (ECM-ECMNN(K1))/(ECMNN(K2)-ECMNN(K1))
12091 IF (NQBINI.GT.1) THEN
12092 IF (VIRT.GE.Q2G(NQBINI)) THEN
12096 ELSEIF (VIRT.GT.Q2G(1)) THEN
12098 IF (VIRT.LT.Q2G(I)) THEN
12101 RATQ = LOG10( VIRT/MAX(Q2G(J1),TINY14))/
12102 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
12109 SGA = XSPRO(K1,J1,NTARG)+
12110 & RATE*(XSPRO(K2,J1,NTARG)-XSPRO(K1,J1,NTARG))+
12111 & RATQ*(XSPRO(K1,J2,NTARG)-XSPRO(K1,J1,NTARG))+
12112 & RATE*RATQ*(XSPRO(K2,J2,NTARG)-XSPRO(K1,J2,NTARG)+
12113 & XSPRO(K1,J1,NTARG)-XSPRO(K2,J1,NTARG))
12114 SDI = DBLE(NB)*SIGDIR
12115 SAN = DBLE(NB)*SIGANO
12118 IF (RR.LT.SDI/SGA) THEN
12120 ELSEIF ((RR.GE.SDI/SGA).AND.
12121 & (RR.LT.SPL/SGA)) THEN
12127 C WRITE(LOUT,'(I3,4F15.5)') MODE,SPL,SGA,RPNT,ECM
12133 *$ CREATE DT_GLBINI.FOR
12136 *===glbini=============================================================*
12138 SUBROUTINE DT_GLBINI(WHAT)
12140 ************************************************************************
12141 * Pre-initialization of profile function *
12142 * This version dated 28.11.00 is written by S. Roesler. *
12144 * Last change 27.12.2006 by S. Roesler. *
12145 ************************************************************************
12147 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12150 PARAMETER ( LINP = 10 ,
12154 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.D-14)
12158 * particle properties (BAMJET index convention)
12160 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12161 & IICH(210),IIBAR(210),K1(210),K2(210)
12163 * properties of interacting particles
12164 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
12166 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
12168 * emulsion treatment
12169 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
12172 * Glauber formalism: flags and parameters for statistics
12175 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
12177 * number of data sets other than protons and nuclei
12178 * at the moment = 2 (pions and kaons)
12179 PARAMETER (MAXOFF=2)
12180 DIMENSION IJPINI(5),IOFFST(25)
12181 DATA IJPINI / 13, 15, 0, 0, 0/
12182 * Glauber data-set to be used for hadron projectiles
12183 * (0=proton, 1=pion, 2=kaon)
12184 DATA (IOFFST(K),K=1,25) /
12185 & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
12187 * Acceptance interval for target nucleus mass
12188 PARAMETER (KBACC = 6)
12190 * flags for input different options
12191 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
12192 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
12193 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
12195 PARAMETER (MAXMSS = 100)
12196 DIMENSION IASAV(MAXMSS),IBSAV(MAXMSS)
12199 DATA JPEACH,JPSTEP / 18, 5 /
12201 * temporary patch until fix has been implemented in phojet:
12202 * maximum energy for pion projectile
12203 DATA ECMXPI / 100000.0D0 /
12205 *--------------------------------------------------------------------------
12206 * general initializations
12208 * steps in projectile mass number for initialization
12209 IF (WHAT(4).GT.ZERO) JPEACH = INT(WHAT(4))
12210 IF (WHAT(5).GT.ZERO) JPSTEP = INT(WHAT(5))
12212 * energy range and binning
12215 IF (ELO.GT.EHI) ELO = EHI
12216 NEBIN = MAX(INT(WHAT(3)),1)
12217 IF (ELO.EQ.EHI) NEBIN = 0
12218 LCMS = (WHAT(1).LT.ZERO).OR.(WHAT(2).LT.ZERO)
12222 ECMINI = SQRT(AAM(IJPROJ)**2+AAM(IJTARG)**2
12223 & +2.0D0*AAM(IJTARG)*EHI)
12226 * default arguments for Glauber-routine
12230 * initialize nuclear parameters, etc.
12232 * initialize evaporation if the code is not used as Fluka event generator
12233 IF (ITRSPT.NE.1) THEN
12239 * open Glauber-data output file
12240 IDX = INDEX(CGLB,' ')
12242 IF (IDX.GT.1) K = IDX-1
12243 OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
12245 *--------------------------------------------------------------------------
12246 * Glauber-initialization for proton and nuclei projectiles
12248 * initialize phojet for proton-proton interactions
12251 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
12254 * record projectile masses
12256 NPROJ = MIN(IP,JPEACH)
12257 DO 10 KPROJ=1,NPROJ
12259 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12260 IASAV(NASAV) = KPROJ
12262 IF (IP.GT.JPEACH) THEN
12263 NPROJ = DBLE(IP-JPEACH)/DBLE(JPSTEP)
12264 IF (NPROJ.EQ.0) THEN
12266 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12269 DO 11 IPROJ=1,NPROJ
12270 KPROJ = JPEACH+IPROJ*JPSTEP
12272 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12273 IASAV(NASAV) = KPROJ
12275 IF (KPROJ.LT.IP) THEN
12277 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12283 * record target masses
12286 IF (NCOMPO.GT.0) NTARG = NCOMPO
12287 DO 12 ITARG=1,NTARG
12289 IF (NBSAV.GT.MAXMSS) STOP ' GLBINI: NBSAV > MAXMSS ! '
12290 IF (NCOMPO.GT.0) THEN
12291 IBSAV(NBSAV) = IEMUMA(ITARG)
12298 WRITE(LDAT,1000) NEBIN,': ',SIGN(ELO,WHAT(1)),SIGN(EHI,WHAT(2))
12299 1000 FORMAT(I4,A,1P,2E13.5)
12300 NLINES = DBLE(NASAV)/18.0D0
12301 IF (NLINES.GT.0) THEN
12304 WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=1,18)
12306 WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=18*I-17,18*I)
12311 IF (I0.LE.NASAV) THEN
12313 WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=I0,NASAV)
12315 WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=I0,NASAV)
12318 NLINES = DBLE(NBSAV)/18.0D0
12319 IF (NLINES.GT.0) THEN
12322 WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=1,18)
12324 WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=18*I-17,18*I)
12329 IF (I0.LE.NBSAV) THEN
12331 WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=I0,NBSAV)
12333 WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=I0,NBSAV)
12337 * calculate Glauber-data for each energy and mass combination
12339 * loop over energy bins
12342 DEBIN = (EHI-ELO)/MAX(DBLE(NEBIN),ONE)
12344 E = ELO+DBLE(IE-1)*DEBIN
12347 E = MAX(2.0D0*AAM(IJPROJ)+0.1D0,E)
12352 E = MAX(AAM(IJPROJ)+0.1D0,E)
12353 CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
12356 * loop over projectile and target masses
12359 CALL DT_XSGLAU(IASAV(IPROJ),IBSAV(ITARG),IJPROJ,
12360 & XI,Q2I,ECM,1,1,-1)
12366 *--------------------------------------------------------------------------
12367 * Glauber-initialization for pion, kaon, ... projectiles
12371 * initialize phojet for this interaction
12374 IJPROJ = IJPINI(IJ)
12378 * temporary patch until fix has been implemented in phojet:
12379 IF (ECMINI.GT.ECMXPI) THEN
12380 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMXPI,1)
12382 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
12386 * calculate Glauber-data for each energy and mass combination
12388 * loop over energy bins
12390 E = ELO+DBLE(IE-1)*DEBIN
12393 E = MAX(2.0D0*AAM(IJPROJ)+TINY14,E)
12398 E = MAX(AAM(IJPROJ)+TINY14,E)
12399 CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
12402 * loop over projectile and target masses
12404 CALL DT_XSGLAU(1,IBSAV(ITARG),IJPROJ,XI,Q2I,ECM,1,1,-1)
12411 *--------------------------------------------------------------------------
12412 * close output unit(s), etc.
12419 *$ CREATE DT_GLBSET.FOR
12422 *===glbset=============================================================*
12424 SUBROUTINE DT_GLBSET(IDPROJ,NA,NB,ELAB,MODE)
12425 ************************************************************************
12426 * Interpolation of pre-initialized profile functions *
12427 * This version dated 28.11.00 is written by S. Roesler. *
12428 ************************************************************************
12430 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12433 PARAMETER ( LINP = 10 ,
12437 PARAMETER (ZERO=0.0D0,ONE=1.0D0)
12439 LOGICAL LCMS,LREAD,LFRST1,LFRST2
12441 * particle properties (BAMJET index convention)
12443 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12444 & IICH(210),IIBAR(210),K1(210),K2(210)
12446 * Glauber formalism: flags and parameters for statistics
12449 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
12451 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
12453 * Glauber formalism: parameters
12454 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
12455 & BMAX(NCOMPX),BSTEP(NCOMPX),
12456 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
12459 * Glauber formalism: cross sections
12460 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
12461 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
12462 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
12463 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
12464 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
12465 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
12466 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
12467 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
12468 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
12469 & BSLOPE,NEBINI,NQBINI
12471 * number of data sets other than protons and nuclei
12472 * at the moment = 2 (pions and kaons)
12473 PARAMETER (MAXOFF=2)
12474 DIMENSION IJPINI(5),IOFFST(25)
12475 DATA IJPINI / 13, 15, 0, 0, 0/
12476 * Glauber data-set to be used for hadron projectiles
12477 * (0=proton, 1=pion, 2=kaon)
12478 DATA (IOFFST(K),K=1,25) /
12479 & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
12481 * Acceptance interval for target nucleus mass
12482 PARAMETER (KBACC = 6)
12484 * emulsion treatment
12485 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
12488 PARAMETER (MAXSET=5000,
12490 DIMENSION XSIG(MAXSET,6),XERR(MAXSET,6),BPROFL(MAXSET,KSITEB)
12491 DIMENSION IABIN(MAXBIN),IBBIN(MAXBIN),XS(6),XE(6),
12492 & BPRO0(KSITEB),BPRO1(KSITEB),BPRO(KSITEB),
12495 DATA LREAD,LFRST1,LFRST2 /.FALSE.,.TRUE.,.TRUE./
12497 * read data from file
12499 IF (MODE.EQ.0) THEN
12522 IDX = INDEX(CGLB,' ')
12524 IF (IDX.GT.1) K = IDX-1
12525 OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
12526 WRITE(LOUT,1000) CGLB(1:K)//'.glb'
12527 1000 FORMAT(/,' GLBSET: impact parameter distributions read from ',
12530 * read binning information
12531 READ(LDAT,'(I4,2X,2E13.5)') NEBIN,ELO,EHI
12532 * return lower energy threshold to Fluka-interface
12535 WRITE(LOUT,'(1X,A)') ' equidistant logarithmic energy binning:'
12537 WRITE(LOUT,1001) '(cms)',ABS(ELO),ABS(EHI),NEBIN
12539 WRITE(LOUT,1001) '(lab)',ABS(ELO),ABS(EHI),NEBIN
12541 1001 FORMAT(2X,A5,' E_lo = ',1P,E9.3,' E_hi = ',1P,E9.3,4X,
12542 & 'No. of bins:',I5,/)
12543 ELO = LOG10(ABS(ELO))
12544 EHI = LOG10(ABS(EHI))
12545 DEBIN = (EHI-ELO)/ABS(DBLE(NEBIN))
12546 WRITE(LOUT,'(/,1X,A)') ' projectiles: (mass number)'
12547 READ(LDAT,'(I4,2X,18I4)') NABIN,(IABIN(J),J=1,18)
12548 IF (NABIN.LT.18) THEN
12549 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,NABIN)
12551 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,18)
12553 IF (NABIN.GT.MAXBIN) STOP ' GLBSET: NABIN > MAXBIN !'
12554 IF (NABIN.GT.18) THEN
12555 NLINES = DBLE(NABIN-18)/18.0D0
12556 IF (NLINES.GT.0) THEN
12559 READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
12560 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
12563 I0 = 18*(NLINES+1)+1
12564 IF (I0.LE.NABIN) THEN
12565 READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
12566 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
12569 WRITE(LOUT,'(/,1X,A)') ' targets: (mass number)'
12570 READ(LDAT,'(I4,2X,18I4)') NBBIN,(IBBIN(J),J=1,18)
12571 IF (NBBIN.LT.18) THEN
12572 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,NBBIN)
12574 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,18)
12576 IF (NBBIN.GT.MAXBIN) STOP ' GLBSET: NBBIN > MAXBIN !'
12577 IF (NBBIN.GT.18) THEN
12578 NLINES = DBLE(NBBIN-18)/18.0D0
12579 IF (NLINES.GT.0) THEN
12582 READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12583 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12586 I0 = 18*(NLINES+1)+1
12587 IF (I0.LE.NBBIN) THEN
12588 READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12589 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12592 * number of data sets to follow in the Glauber data file
12593 * this variable is used for checks of consistency of projectile
12594 * and target mass configurations given in header of Glauber data
12595 * file and the data-sets which follow in this file
12596 NSET0 = (NEBIN+1)*(NABIN+MAXOFF)*NBBIN
12598 * read profile function data
12604 IF (NSET.GT.MAXSET) STOP ' GLBSET: NSET > MAXSET ! '
12605 READ(LDAT,1002,END=100) IP,IA,IB,ISTATB,ISITEB,ECM
12606 1002 FORMAT(5I10,E15.5)
12607 IF ((IP.NE.1).AND.(IP.NE.IPOLD)) THEN
12609 IF (NAIDX.GT.10) STOP ' GLBSET: NAIDX > 10 !'
12613 READ(LDAT,'(6E12.5)') (XSIG(NSET,I),I=1,6)
12614 READ(LDAT,'(6E12.5)') (XERR(NSET,I),I=1,6)
12615 NLINES = INT(DBLE(ISITEB)/7.0D0)
12616 IF (NLINES.GT.0) THEN
12618 READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=7*I-6,7*I)
12623 & READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=I0,ISITEB)
12627 IF (NSET.NE.NSET0) STOP ' GLBSET: NSET.NE.NSET0 !'
12628 WRITE(LOUT,'(/,1X,A)')
12629 & ' projectiles other than protons and nuclei: (particle index)'
12630 IF (NAIDX.GT.0) THEN
12631 WRITE(LOUT,'(6X,18I4)') (IAIDX(J),J=1,NAIDX)
12633 WRITE(LOUT,'(6X,A)') 'none'
12640 IF (NCOMPO.EQ.0) THEN
12643 IEMUMA(NCOMPO) = IBBIN(J)
12644 IEMUCH(NCOMPO) = IEMUMA(NCOMPO)/2
12645 EMUFRA(NCOMPO) = 1.0D0
12650 * calculate profile function for certain set of parameters
12654 c write(*,*) 'glbset called for ',IDPROJ,NA,NB,ELAB,MODE
12656 * check for type of projectile and set index-offset to entry in
12657 * Glauber data array correspondingly
12658 IF (IDPROJ.GT.25) STOP ' GLBSET: IDPROJ > 25 !'
12659 IF (IOFFST(IDPROJ).EQ.-1) THEN
12660 STOP ' GLBSET: no data for this projectile !'
12661 ELSEIF (IOFFST(IDPROJ).GT.0) THEN
12662 IDXOFF = (NEBIN+1)*(NABIN+IOFFST(IDPROJ)-1)*NBBIN
12667 * get energy bin and interpolation factor
12669 E = SQRT(AAM(IDPROJ)**2+AAM(1)**2+2.0D0*AAM(1)*ELAB)
12676 WRITE(LOUT,*) ' GLBSET: Too low energy! (E_lo,E) ',ELO,E
12683 WRITE(LOUT,*) ' GLBSET: Too high energy! (E_hi,E) ',EHI,E
12688 IE0 = (E-ELO)/DEBIN+1
12690 FACE = (E-(ELO+DBLE(IE0-1)*DEBIN))/DEBIN
12692 * get target nucleus index
12696 NBDIFF = ABS(NB-IBBIN(I))
12697 IF (NB.EQ.IBBIN(I)) THEN
12700 ELSEIF (NBDIFF.LE.NBACC) THEN
12705 IF (KB.NE.0) GOTO 21
12706 WRITE(LOUT,*) ' GLBSET: data not found for target ',NB
12710 * get projectile nucleus bin and interpolation factor
12714 IF (IDXOFF.GT.0) THEN
12719 IF (NA.GT.IABIN(NABIN)) STOP ' GLBSET: NA > IABIN(NABIN) !'
12721 IF (NA.EQ.IABIN(I)) THEN
12725 ELSEIF (NA.LT.IABIN(I)) THEN
12731 WRITE(LOUT,*) ' GLBSET: data not found for projectile ',NA
12735 & FACNA = DBLE(NA-IABIN(KA0))/DBLE(IABIN(KA1)-IABIN(KA0))
12739 * interpolate profile functions for interactions ka0-kb and ka1-kb
12740 * for energy E separately
12741 IDX0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12742 IDX1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12743 IDY0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12744 IDY1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12746 BPRO0(I) = BPROFL(IDX0,I)
12747 & +FACE*(BPROFL(IDX1,I)-BPROFL(IDX0,I))
12748 BPRO1(I) = BPROFL(IDY0,I)
12749 & +FACE*(BPROFL(IDY1,I)-BPROFL(IDY0,I))
12751 RADB = DT_RNCLUS(NB)
12752 BSTP0 = 2.0D0*(DT_RNCLUS(IABIN(KA0))+RADB)/DBLE(ISITEB-1)
12753 BSTP1 = 2.0D0*(DT_RNCLUS(IABIN(KA1))+RADB)/DBLE(ISITEB-1)
12755 * interpolate cross sections for energy E and projectile mass
12757 XS0 = XSIG(IDX0,I)+FACE*(XSIG(IDX1,I)-XSIG(IDX0,I))
12758 XS1 = XSIG(IDY0,I)+FACE*(XSIG(IDY1,I)-XSIG(IDY0,I))
12759 XS(I) = XS0+FACNA*(XS1-XS0)
12760 XE0 = XERR(IDX0,I)+FACE*(XERR(IDX1,I)-XERR(IDX0,I))
12761 XE1 = XERR(IDY0,I)+FACE*(XERR(IDY1,I)-XERR(IDY0,I))
12762 XE(I) = XE0+FACNA*(XE1-XE0)
12765 * interpolate between ka0 and ka1
12766 RADA = DT_RNCLUS(NA)
12767 BMX = 2.0D0*(RADA+RADB)
12768 BSTP = BMX/DBLE(ISITEB-1)
12773 * calculate values of profile functions at B
12775 IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12776 IDX1 = MIN(IDX0+1,ISITEB)
12777 FACB = (B-DBLE(IDX0-1)*BSTP0)/BSTP0
12778 BPR0 = BPRO0(IDX0)+FACB*(BPRO0(IDX1)-BPRO0(IDX0))
12780 IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12781 IDX1 = MIN(IDX0+1,ISITEB)
12782 FACB = (B-DBLE(IDX0-1)*BSTP1)/BSTP1
12783 BPR1 = BPRO1(IDX0)+FACB*(BPRO1(IDX1)-BPRO1(IDX0))
12785 BPRO(I+1) = BPR0+FACNA*(BPR1-BPR0)
12788 * fill common dtglam
12795 BSITE(0,1,1,I) = BPRO(I)
12798 * fill common dtglxs
12799 XSTOT(1,1,1) = XS(1)
12800 XSELA(1,1,1) = XS(2)
12801 XSQEP(1,1,1) = XS(3)
12802 XSQET(1,1,1) = XS(4)
12803 XSQE2(1,1,1) = XS(5)
12804 XSPRO(1,1,1) = XS(6)
12805 XETOT(1,1,1) = XE(1)
12806 XEELA(1,1,1) = XE(2)
12807 XEQEP(1,1,1) = XE(3)
12808 XEQET(1,1,1) = XE(4)
12809 XEQE2(1,1,1) = XE(5)
12810 XEPRO(1,1,1) = XE(6)
12816 *$ CREATE DT_XKSAMP.FOR
12819 *===xksamp=============================================================*
12821 SUBROUTINE DT_XKSAMP(NN,ECM)
12823 ************************************************************************
12824 * Sampling of parton x-values and chain system for one interaction. *
12825 * processed by S. Roesler, 9.8.95 *
12826 ************************************************************************
12828 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12831 PARAMETER ( LINP = 10 ,
12835 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
12839 * lower cuts for (valence-sea/sea-valence) chain masses
12840 * antiquark-quark (u/d-sea quark) (s-sea quark)
12841 & AMIU = 0.5D0, AMIS = 0.8D0,
12842 * quark-diquark (u/d-sea quark) (s-sea quark)
12843 & AMAU = 2.6D0, AMAS = 2.6D0,
12844 * maximum lower valence-x threshold
12846 * fraction of sea-diquarks sampled out of sea-partons
12848 C & FRCDIQ = 0.9D0,
12853 * maximum number of trials to generate x's for the required number
12854 * of sea quark pairs for a given hadron
12859 LOGICAL ZUOVP,ZUOSP,ZUOVT,ZUOST,INTLO
12861 PARAMETER ( MAXNCL = 260,
12864 & MAXSQU = 20*MAXVQU,
12865 & MAXINT = MAXVQU+MAXSQU)
12869 PARAMETER (NMXHKK=200000)
12871 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
12872 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
12873 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
12875 * particle properties (BAMJET index convention)
12877 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12878 & IICH(210),IIBAR(210),K1(210),K2(210)
12880 * interface between Glauber formalism and DPM
12881 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
12882 & INTER1(MAXINT),INTER2(MAXINT)
12884 * properties of interacting particles
12885 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
12887 * threshold values for x-sampling (DTUNUC 1.x)
12888 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
12891 * x-values of partons (DTUNUC 1.x)
12892 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
12893 & XTVQ(MAXVQU),XTVD(MAXVQU),
12894 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
12895 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
12897 * flavors of partons (DTUNUC 1.x)
12898 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
12899 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
12900 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
12901 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
12902 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
12903 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
12904 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
12906 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12907 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
12908 & IXPV,IXPS,IXTV,IXTS,
12909 & INTVV1(MAXVQU),INTVV2(MAXVQU),
12910 & INTSV1(MAXVQU),INTSV2(MAXVQU),
12911 & INTVS1(MAXVQU),INTVS2(MAXVQU),
12912 & INTSS1(MAXSQU),INTSS2(MAXSQU),
12913 & INTDV1(MAXVQU),INTDV2(MAXVQU),
12914 & INTVD1(MAXVQU),INTVD2(MAXVQU),
12915 & INTDS1(MAXSQU),INTDS2(MAXSQU),
12916 & INTSD1(MAXSQU),INTSD2(MAXSQU)
12918 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12919 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
12920 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
12922 * auxiliary common for chain system storage (DTUNUC 1.x)
12923 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
12925 * flags for input different options
12926 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
12927 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
12928 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
12930 * various options for treatment of partons (DTUNUC 1.x)
12931 * (chain recombination, Cronin,..)
12932 LOGICAL LCO2CR,LINTPT
12933 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
12936 DIMENSION ZUOVP(MAXVQU),ZUOSP(MAXSQU),ZUOVT(MAXVQU),ZUOST(MAXSQU),
12939 * (1) initializations
12940 *-----------------------------------------------------------------------
12943 IF (ECM.LT.4.5D0) THEN
12946 ELSEIF ((ECM.GE.4.5D0).AND.(ECM.LT.7.5)) THEN
12947 C FRCDIQ = 0.6D0+(ECM-4.5D0)/3.0D0*0.3D0
12948 FRCDIQ = 0.4D0+(ECM-4.5D0)/3.0D0*0.3D0
12957 IF (I.LE.MAXVQU) THEN
12963 * lower thresholds for x-selection
12964 * sea-quarks (default: CSEA=0.2)
12965 IF (ECM.LT.10.0D0) THEN
12967 XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM
12968 C XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM**2.0D0
12970 C XSTHR = ONE/ECM**2
12974 XSTHR = CSEA/ECM**2
12975 C XSTHR = ONE/ECM**2
12977 IF ((IP.GE.150).AND.(IT.GE.150))
12978 & XSTHR = 2.5D0/(ECM*SQRT(ECM))
12981 * (default: SSMIMA=0.14) used for sea-diquarks (?)
12982 XSSTHR = SSMIMA/ECM
12984 * valence-quarks (default: CVQ=1.0)
12986 * valence-diquarks (default: CDQ=2.0)
12989 * maximum-x for sea-quarks
12990 XVCUT = XVTHR+XDTHR
12991 IF (XVCUT.GT.XVMAX) THEN
12993 XVTHR = XVCUT/3.0D0
12994 XDTHR = XVCUT-XVTHR
12997 **sr 18.4. test: DPMJET
12998 C XXSEAM=1.0 - XVTHR*(1.D0+0.3D0*DT_RNDM(V1))
12999 C & - XDTHR*(1.D0+0.3D0*DT_RNDM(V2))
13000 C & -0.01*(1.D0+1.5D0*DT_RNDM(V3))
13002 * maximum number of sea-pairs allowed kinematically
13003 C NSMAX = INT(OHALF*XXSEAM/XSTHR)
13004 RNSMAX = OHALF*XXSEAM/XSTHR
13005 IF (RNSMAX.GT.10000.0D0) THEN
13008 NSMAX = INT(OHALF*XXSEAM/XSTHR)
13010 * check kinematical limit for valence-x thresholds
13011 * (should be obsolete now)
13012 IF (XVCUT.GT.XVMAX) THEN
13013 WRITE(LOUT,1000) XVCUT,ECM
13014 1000 FORMAT(' XKSAMP: kin. limit for valence-x',
13015 & ' thresholds not allowed (',2E9.3,')')
13016 C XVTHR = XVMAX-XDTHR
13017 C IF (XVTHR.LT.ZERO) STOP
13021 * set eta for valence-x sampling (BETREJ)
13022 * (UNON per default, UNOM used for projectile mesons only)
13023 IF ((IJPROJ.NE.0).AND.(IBPROJ.EQ.0)) THEN
13029 * (2) select parton x-values of interacting projectile nucleons
13030 *-----------------------------------------------------------------------
13036 * get interacting projectile nucleon as sampled by Glauber
13037 IF (JSSH(IPP).NE.0) THEN
13043 * JIPP is the actual number of sea-pairs sampled for this nucleon
13044 JIPP = MIN(JSSH(IPP)-1,NSMAX)
13047 IF (JIPP.GT.0) THEN
13048 XSMAX = XXSEAM-2.0D0*DBLE(JIPP)*XSTHR
13050 IF (XSTHR.GE.XSMAX) THEN
13055 *>>>get x-values of sea-quark pairs
13059 * accumulator for sea x-values
13062 IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
13063 IF (NSCOUN.GT.NSEA) THEN
13064 * decrease the number of interactions after NSEA trials
13070 IF (IPSQ(IXPS+1).LE.2) THEN
13071 **sr 8.4.98 (1/sqrt(x))
13072 C XPSQI = DT_SAMPEX(XSTHR,XSMAX)
13073 C XPSQI = DT_SAMSQX(XSTHR,XSMAX)
13074 XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13077 IF (XSMAX.GT.XSTHR+BSQMA) THEN
13078 XPSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13080 **sr 8.4.98 (1/sqrt(x))
13081 C XPSQI = DT_SAMPEX(XSTHR,XSMAX)
13082 C XPSQI = DT_SAMSQX(XSTHR,XSMAX)
13083 XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13088 IF (IPSAQ(IXPS+1).GE.-2) THEN
13089 **sr 8.4.98 (1/sqrt(x))
13090 C XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
13091 C XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
13092 XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13095 IF (XSMAX.GT.XSTHR+BSQMA) THEN
13096 XPSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13098 **sr 8.4.98 (1/sqrt(x))
13099 C XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
13100 C XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
13101 XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13105 XXSEA = XXSEA+XPSQI+XPSAQI
13106 * check for maximum allowed sea x-value
13107 IF (XXSEA.GE.XXSEAM) THEN
13111 * accept this sea-quark pair
13114 XPSAQ(IXPS) = XPSAQI
13116 ZUOSP(IXPS) = .TRUE.
13120 *>>>get x-values of valence partons
13122 IF (XVTHR.GT.0.05D0) THEN
13123 XVHI = ONE-XXSEA-XDTHR
13124 XPVQI = DT_BETREJ(OHALF,UNOPRV,XVTHR,XVHI)
13127 XPVQI = DT_DBETAR(OHALF,UNOPRV)
13128 IF ((XPVQI.LT.XVTHR).OR.(ONE-XPVQI-XXSEA.LT.XDTHR))
13132 XPVDI = ONE-XPVQI-XXSEA
13133 * reject according to x**1.5
13134 XDTMP = XPVDI**1.5D0
13135 IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 99
13136 * accept these valence partons
13142 ZUOVP(IXPV) = .TRUE.
13147 * (3) select parton x-values of interacting target nucleons
13148 *-----------------------------------------------------------------------
13154 * get interacting target nucleon as sampled by Glauber
13155 IF (JTSH(ITT).NE.0) THEN
13161 * JITT is the actual number of sea-pairs sampled for this nucleon
13162 JITT = MIN(JTSH(ITT)-1,NSMAX)
13165 IF (JITT.GT.0) THEN
13166 XSMAX = XXSEAM-2.0D0*DBLE(JITT)*XSTHR
13168 IF (XSTHR.GE.XSMAX) THEN
13173 *>>>get x-values of sea-quark pairs
13177 * accumulator for sea x-values
13180 IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
13181 IF (NSCOUN.GT.NSEA)THEN
13182 * decrease the number of interactions after NSEA trials
13188 IF (ITSQ(IXTS+1).LE.2) THEN
13189 **sr 8.4.98 (1/sqrt(x))
13190 C XTSQI = DT_SAMPEX(XSTHR,XSMAX)
13191 C XTSQI = DT_SAMSQX(XSTHR,XSMAX)
13192 XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13195 IF (XSMAX.GT.XSTHR+BSQMA) THEN
13196 XTSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13198 **sr 8.4.98 (1/sqrt(x))
13199 C XTSQI = DT_SAMPEX(XSTHR,XSMAX)
13200 C XTSQI = DT_SAMSQX(XSTHR,XSMAX)
13201 XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13206 IF (ITSAQ(IXTS+1).GE.-2) THEN
13207 **sr 8.4.98 (1/sqrt(x))
13208 C XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
13209 C XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
13210 XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13213 IF (XSMAX.GT.XSTHR+BSQMA) THEN
13214 XTSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13216 **sr 8.4.98 (1/sqrt(x))
13217 C XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
13218 C XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
13219 XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13223 XXSEA = XXSEA+XTSQI+XTSAQI
13224 * check for maximum allowed sea x-value
13225 IF (XXSEA.GE.XXSEAM) THEN
13229 * accept this sea-quark pair
13232 XTSAQ(IXTS) = XTSAQI
13234 ZUOST(IXTS) = .TRUE.
13238 *>>>get x-values of valence partons
13240 IF (XVTHR.GT.0.05D0) THEN
13241 XVHI = ONE-XXSEA-XDTHR
13242 XTVQI = DT_BETREJ(OHALF,UNON,XVTHR,XVHI)
13245 XTVQI = DT_DBETAR(OHALF,UNON)
13246 IF ((XTVQI.LT.XVTHR).OR.(ONE-XTVQI-XXSEA.LT.XDTHR))
13250 XTVDI = ONE-XTVQI-XXSEA
13251 * reject according to x**1.5
13252 XDTMP = XTVDI**1.5D0
13253 IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 169
13254 * accept these valence partons
13260 ZUOVT(IXTV) = .TRUE.
13265 * (4) get valence-valence chains
13266 *-----------------------------------------------------------------------
13271 IPVAL = ITOVP(INTER1(I))
13272 ITVAL = ITOVT(INTER2(I))
13273 IF (ZUOVP(IPVAL).AND.ZUOVT(ITVAL)) THEN
13275 ZUOVP(IPVAL) = .FALSE.
13276 ZUOVT(ITVAL) = .FALSE.
13279 INTVV1(NVV) = IPVAL
13280 INTVV2(NVV) = ITVAL
13284 * (5) get sea-valence chains
13285 *-----------------------------------------------------------------------
13292 IPVAL = ITOVP(INTER1(I))
13293 ITVAL = ITOVT(INTER2(I))
13295 IF (ZUOSP(J).AND.(IFROSP(J).EQ.INTER1(I)).AND.
13296 & ZUOVT(ITVAL)) THEN
13298 ZUOVT(ITVAL) = .FALSE.
13300 IF (LSEADI.AND.(DT_RNDM(PLW).GT.FRCDIQ)) THEN
13301 * sample sea-diquark pair
13302 CALL DT_SAMSDQ(ECM,ITVAL,J,2,IREJ1)
13303 IF (IREJ1.EQ.0) GOTO 260
13308 INTSV2(NSV) = ITVAL
13310 *>>>correct chain kinematics according to minimum chain masses
13311 * the actual chain masses
13312 AMSVQ1 = XPSQ(J) *XTVD(ITVAL)*ECM**2
13313 AMSVQ2 = XPSAQ(J)*XTVQ(ITVAL)*ECM**2
13314 * get lower mass cuts
13315 IF (IPSQ(J).EQ.3) THEN
13320 * q being u/d-quark
13325 * chain mass above minimum - resampling of sea-q x-value
13326 IF (AMSVQ1.GT.AMCHK1) THEN
13327 XPSQTH = AMCHK1/(XTVD(ITVAL)*ECM**2)
13328 **sr 8.4.98 (1/sqrt(x))
13329 C XPSQXX = DT_SAMPEX(XPSQTH,XPSQ(J))
13330 C XPSQXX = DT_SAMSQX(XPSQTH,XPSQ(J))
13331 XPSQXX = DT_SAMPLW(XPSQTH,XPSQ(J),PLW)
13333 XPVD(IPVAL) = XPVD(IPVAL)+XPSQ(J)-XPSQXX
13335 * chain mass below minimum - reset sea-q x-value and correct
13336 * diquark-x of the same nucleon
13337 ELSEIF (AMSVQ1.LT.AMCHK1) THEN
13338 XPSQW = AMCHK1/(XTVD(ITVAL)*ECM**2)
13339 DXPSQ = XPSQW-XPSQ(J)
13340 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
13341 XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
13346 * chain mass below minimum - reset sea-aq x-value and correct
13347 * diquark-x of the same nucleon
13348 IF (AMSVQ2.LT.AMCHK2) THEN
13349 XPSQW = AMCHK2/(XTVQ(ITVAL)*ECM**2)
13350 DXPSQ = XPSQW-XPSAQ(J)
13351 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
13352 XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
13356 *>>>end of chain mass correction
13365 * (6) get valence-sea chains
13366 *-----------------------------------------------------------------------
13372 IPVAL = ITOVP(INTER1(I))
13373 ITVAL = ITOVT(INTER2(I))
13375 IF (ZUOVP(IPVAL).AND.ZUOST(J).AND.
13376 & (IFROST(J).EQ.INTER2(I))) THEN
13378 ZUOVP(IPVAL) = .FALSE.
13380 IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
13381 * sample sea-diquark pair
13382 CALL DT_SAMSDQ(ECM,IPVAL,J,1,IREJ1)
13383 IF (IREJ1.EQ.0) GOTO 290
13387 INTVS1(NVS) = IPVAL
13390 *>>>correct chain kinematics according to minimum chain masses
13391 * the actual chain masses
13392 AMVSQ1 = XPVQ(IPVAL)*XTSAQ(J)*ECM**2
13393 AMVSQ2 = XPVD(IPVAL)*XTSQ(J) *ECM**2
13394 * get lower mass cuts
13395 IF (ITSQ(J).EQ.3) THEN
13400 * q being u/d-quark
13405 * chain mass below minimum - reset sea-aq x-value and correct
13406 * diquark-x of the same nucleon
13407 IF (AMVSQ1.LT.AMCHK1) THEN
13408 XTSQW = AMCHK1/(XPVQ(IPVAL)*ECM**2)
13409 DXTSQ = XTSQW-XTSAQ(J)
13410 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
13411 XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
13416 * chain mass above minimum - resampling of sea-q x-value
13417 IF (AMVSQ2.GT.AMCHK2) THEN
13418 XTSQTH = AMCHK2/(XPVD(IPVAL)*ECM**2)
13419 **sr 8.4.98 (1/sqrt(x))
13420 C XTSQXX = DT_SAMPEX(XTSQTH,XTSQ(J))
13421 C XTSQXX = DT_SAMSQX(XTSQTH,XTSQ(J))
13422 XTSQXX = DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
13424 XTVD(ITVAL) = XTVD(ITVAL)+XTSQ(J)-XTSQXX
13426 * chain mass below minimum - reset sea-q x-value and correct
13427 * diquark-x of the same nucleon
13428 ELSEIF (AMVSQ2.LT.AMCHK2) THEN
13429 XTSQW = AMCHK2/(XPVD(IPVAL)*ECM**2)
13430 DXTSQ = XTSQW-XTSQ(J)
13431 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
13432 XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
13436 *>>>end of chain mass correction
13445 * (7) get sea-sea chains
13446 *-----------------------------------------------------------------------
13453 IPVAL = ITOVP(INTER1(I))
13454 ITVAL = ITOVT(INTER2(I))
13455 * loop over target partons not yet matched
13457 IF (ZUOST(J).AND.(IFROST(J).EQ.INTER2(I))) THEN
13458 * loop over projectile partons not yet matched
13460 IF (ZUOSP(JJ).AND.(IFROSP(JJ).EQ.INTER1(I))) THEN
13461 ZUOSP(JJ) = .FALSE.
13469 *---->chain recombination option
13470 VALFRA = DBLE(NVV/(NVV+IXPS+IXTS))
13471 IF (IRECOM.EQ.1.AND.(DT_RNDM(BSQMA).GT.VALFRA))
13473 * sea-sea chains may recombine with valence-valence chains
13474 * only if they have the same projectile or target nucleon
13476 IF (ISKPCH(8,IVV).NE.99) THEN
13477 IXVPR = INTVV1(IVV)
13478 IXVTA = INTVV2(IVV)
13479 IF ((INTER1(I).EQ.IFROVP(IXVPR)).OR.
13480 & (INTER2(I).EQ.IFROVT(IXVTA))) THEN
13481 * recombination possible, drop old v-v and s-s chains
13485 * (a) assign new s-v chains
13486 * ~~~~~~~~~~~~~~~~~~~~~~~~~
13488 & (DT_RNDM(VALFRA).GT.FRCDIQ))
13490 * sample sea-diquark pair
13491 CALL DT_SAMSDQ(ECM,IXVTA,JJ,2,
13493 IF (IREJ1.EQ.0) GOTO 4202
13498 INTSV2(NSV) = IXVTA
13499 *>>>>>>>>>>>correct chain kinematics according to minimum chain masses
13500 * the actual chain masses
13501 AMSVQ1 = XPSQ(JJ) *XTVD(IXVTA)
13503 AMSVQ2 = XPSAQ(JJ)*XTVQ(IXVTA)
13505 * get lower mass cuts
13506 IF (IPSQ(JJ).EQ.3) THEN
13511 * q being u/d-quark
13516 * chain mass above minimum - resampling of sea-q x-value
13517 IF (AMSVQ1.GT.AMCHK1) THEN
13519 & AMCHK1/(XTVD(IXVTA)*ECM**2)
13520 **sr 8.4.98 (1/sqrt(x))
13522 & DT_SAMPLW(XPSQTH,XPSQ(JJ),PLW)
13523 C & DT_SAMSQX(XPSQTH,XPSQ(JJ))
13524 C & DT_SAMPEX(XPSQTH,XPSQ(JJ))
13527 & XPVD(IPVAL)+XPSQ(JJ)-XPSQXX
13529 * chain mass below minimum - reset sea-q x-value and correct
13530 * diquark-x of the same nucleon
13531 ELSEIF (AMSVQ1.LT.AMCHK1) THEN
13533 & AMCHK1/(XTVD(IXVTA)*ECM**2)
13534 DXPSQ = XPSQW-XPSQ(JJ)
13535 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
13538 & XPVD(IPVAL)-DXPSQ
13543 * chain mass below minimum - reset sea-aq x-value and correct
13544 * diquark-x of the same nucleon
13545 IF (AMSVQ2.LT.AMCHK2) THEN
13547 & AMCHK2/(XTVQ(IXVTA)*ECM**2)
13548 DXPSQ = XPSQW-XPSAQ(JJ)
13549 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
13552 & XPVD(IPVAL)-DXPSQ
13556 *>>>>>>>>>>>end of chain mass correction
13559 * (b) assign new v-s chains
13560 * ~~~~~~~~~~~~~~~~~~~~~~~~~
13562 & DT_RNDM(AMSVQ2).GT.FRCDIQ))
13564 * sample sea-diquark pair
13565 CALL DT_SAMSDQ(ECM,IXVPR,J,1,
13567 IF (IREJ1.EQ.0) GOTO 4203
13571 INTVS1(NVS) = IXVPR
13573 *>>>>>>>>>>>correct chain kinematics according to minimum chain masses
13574 * the actual chain masses
13575 AMVSQ1 = XPVQ(IXVPR)*XTSAQ(J)*ECM**2
13576 AMVSQ2 = XPVD(IXVPR)*XTSQ(J) *ECM**2
13577 * get lower mass cuts
13578 IF (ITSQ(J).EQ.3) THEN
13583 * q being u/d-quark
13588 * chain mass below minimum - reset sea-aq x-value and correct
13589 * diquark-x of the same nucleon
13590 IF (AMVSQ1.LT.AMCHK1) THEN
13592 & AMCHK1/(XPVQ(IXVPR)*ECM**2)
13593 DXTSQ = XTSQW-XTSAQ(J)
13594 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13597 & XTVD(ITVAL)-DXTSQ
13601 IF (AMVSQ2.GT.AMCHK2) THEN
13603 & AMCHK2/(XPVD(IXVPR)*ECM**2)
13604 **sr 8.4.98 (1/sqrt(x))
13606 & DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
13607 C & DT_SAMSQX(XTSQTH,XTSQ(J))
13608 C & DT_SAMPEX(XTSQTH,XTSQ(J))
13611 & XTVD(ITVAL)+XTSQ(J)-XTSQXX
13613 ELSEIF (AMVSQ2.LT.AMCHK2) THEN
13615 & AMCHK2/(XPVD(IXVPR)*ECM**2)
13616 DXTSQ = XTSQW-XTSQ(J)
13617 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13620 & XTVD(ITVAL)-DXTSQ
13624 *>>>>>>>>>end of chain mass correction
13626 * jump out of s-s chain loop
13632 *---->end of chain recombination option
13634 * sample sea-diquark pair (projectile)
13635 IF (LSEADI.AND.(DT_RNDM(BSQMA).GT.FRCDIQ)) THEN
13636 CALL DT_SAMSDQ(ECM,J,JJ,4,IREJ1)
13637 IF (IREJ1.EQ.0) THEN
13642 * sample sea-diquark pair (target)
13643 IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
13644 CALL DT_SAMSDQ(ECM,JJ,J,3,IREJ1)
13645 IF (IREJ1.EQ.0) THEN
13650 *>>>>>correct chain kinematics according to minimum chain masses
13651 * the actual chain masses
13652 SSMA1Q = XPSQ(JJ) *XTSAQ(J)*ECM**2
13653 SSMA2Q = XPSAQ(JJ)*XTSQ(J) *ECM**2
13654 * check for lower mass cuts
13655 IF ((SSMA1Q.LT.SSMIMQ).OR.
13656 & (SSMA2Q.LT.SSMIMQ)) THEN
13657 IPVAL = ITOVP(INTER1(I))
13658 ITVAL = ITOVT(INTER2(I))
13659 IF ((XPVD(IPVAL).GT.XDTHR+3.5D0*XSSTHR).AND.
13660 & (XTVD(ITVAL).GT.XDTHR+3.5D0*XSSTHR))THEN
13661 * maximum allowed x values for sea quarks
13662 XSPMAX = ONE-XPVQ(IPVAL)-XDTHR-
13664 XSTMAX = ONE-XTVQ(ITVAL)-XDTHR-
13666 * resampling of x values not possible - skip sea-sea chains
13667 IF ((XSPMAX.LE.XSSTHR+0.05D0).OR.
13668 & (XSTMAX.LE.XSSTHR+0.05D0)) GOTO 380
13669 * resampling of x for projectile sea quark pair
13673 IF (XSSTHR.GT.0.05D0) THEN
13674 XPSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13676 XPSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13680 XPSQI = DT_DBETAR(XSEACU,UNOSEA)
13681 IF ((XPSQI.LT.XSSTHR).OR.
13682 & (XPSQI.GT.XSPMAX)) GOTO 320
13684 XPSAQI = DT_DBETAR(XSEACU,UNOSEA)
13685 IF ((XPSAQI.LT.XSSTHR).OR.
13686 & (XPSAQI.GT.XSPMAX)) GOTO 330
13688 * final test of remaining x for projectile diquark
13689 XPVDCO = XPVD(IPVAL)-XPSQI-XPSAQI
13690 & +XPSQ(JJ)+XPSAQ(JJ)
13691 IF (XPVDCO.LE.XDTHR) THEN
13693 C IF (ICOUS.LT.5) GOTO 310
13694 IF (ICOUS.LT.0.5D0) GOTO 310
13697 * resampling of x for target sea quark pair
13701 IF (XSSTHR.GT.0.05D0) THEN
13702 XTSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13704 XTSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13708 XTSQI = DT_DBETAR(XSEACU,UNOSEA)
13709 IF ((XTSQI.LT.XSSTHR).OR.
13710 & (XTSQI.GT.XSTMAX)) GOTO 360
13712 XTSAQI = DT_DBETAR(XSEACU,UNOSEA)
13713 IF ((XTSAQI.LT.XSSTHR).OR.
13714 & (XTSAQI.GT.XSTMAX)) GOTO 370
13716 * final test of remaining x for target diquark
13717 XTVDCO = XTVD(ITVAL)-XTSQI-XTSAQI
13718 & +XTSQ(J)+XTSAQ(J)
13719 IF (XTVDCO.LT.XDTHR) THEN
13720 IF (ICOUS.LT.5) GOTO 350
13723 XPVD(IPVAL) = XPVDCO
13724 XTVD(ITVAL) = XTVDCO
13729 *>>>>>end of chain mass correction
13732 * come here to discard s-s interaction
13733 * resampling of x values not allowed or unsuccessful
13740 * consider next s-s interaction
13750 * correct x-values of valence quarks for non-matching sea quarks
13753 IPVAL = ITOVP(IFROSP(I))
13754 XPVQ(IPVAL) = XPVQ(IPVAL)+XPSQ(I)+XPSAQ(I)
13762 ITVAL = ITOVT(IFROST(I))
13763 XTVQ(ITVAL) = XTVQ(ITVAL)+XTSQ(I)+XTSAQ(I)
13770 IF (ZUOVP(I)) ISTHKK(IFROVP(I)) = 13
13773 IF (ZUOVT(I)) ISTHKK(IFROVT(I)+IP) = 14
13779 *$ CREATE DT_SAMSDQ.FOR
13782 *===samsdq=============================================================*
13784 SUBROUTINE DT_SAMSDQ(ECM,IDX1,IDX2,MODE,IREJ)
13786 ************************************************************************
13787 * SAMpling of Sea-DiQuarks *
13788 * ECM cm-energy of the nucleon-nucleon system *
13789 * IDX1,2 indices of x-values of the participating *
13790 * partons (IDX2 is always the sea-q-pair to be *
13791 * changed to sea-qq-pair) *
13792 * MODE = 1 valence-q - sea-diq *
13793 * = 2 sea-diq - valence-q *
13794 * = 3 sea-q - sea-diq *
13795 * = 4 sea-diq - sea-q *
13796 * Based on DIQVS, DIQSV, DIQSSD, DIQDSS. *
13797 * This version dated 17.10.95 is written by S. Roesler *
13798 ************************************************************************
13800 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13803 PARAMETER (ZERO=0.0D0)
13805 * threshold values for x-sampling (DTUNUC 1.x)
13806 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
13809 * various options for treatment of partons (DTUNUC 1.x)
13810 * (chain recombination, Cronin,..)
13811 LOGICAL LCO2CR,LINTPT
13812 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
13815 PARAMETER ( MAXNCL = 260,
13818 & MAXSQU = 20*MAXVQU,
13819 & MAXINT = MAXVQU+MAXSQU)
13821 * x-values of partons (DTUNUC 1.x)
13822 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
13823 & XTVQ(MAXVQU),XTVD(MAXVQU),
13824 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
13825 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
13827 * flavors of partons (DTUNUC 1.x)
13828 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
13829 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
13830 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
13831 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
13832 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
13833 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
13834 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
13836 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13837 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
13838 & IXPV,IXPS,IXTV,IXTS,
13839 & INTVV1(MAXVQU),INTVV2(MAXVQU),
13840 & INTSV1(MAXVQU),INTSV2(MAXVQU),
13841 & INTVS1(MAXVQU),INTVS2(MAXVQU),
13842 & INTSS1(MAXSQU),INTSS2(MAXSQU),
13843 & INTDV1(MAXVQU),INTDV2(MAXVQU),
13844 & INTVD1(MAXVQU),INTVD2(MAXVQU),
13845 & INTDS1(MAXSQU),INTDS2(MAXSQU),
13846 & INTSD1(MAXSQU),INTSD2(MAXSQU)
13848 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13849 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
13850 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
13852 * auxiliary common for chain system storage (DTUNUC 1.x)
13853 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
13856 * threshold-x for valence diquarks
13859 GOTO (1,2,3,4) MODE
13861 *---------------------------------------------------------------------
13862 * proj. valence partons - targ. sea partons
13863 * get x-values and flavors for target sea-diquark pair
13869 * index of corr. val-diquark-x in target nucleon
13870 IDXVT = ITOVT(IFROST(IDXST))
13871 * available x above diquark thresholds for valence- and sea-diquarks
13872 XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13874 IF (XXD.GE.ZERO) THEN
13875 * x-values for the three diquarks of the target nucleon
13879 SR123 = RR1+RR2+RR3
13880 XXTV = XDTHR+RR1*XXD/SR123
13881 XXTSQ = XDTHR+RR2*XXD/SR123
13882 XXTSAQ = XDTHR+RR3*XXD/SR123
13885 XXTSQ = XTSQ(IDXST)
13886 XXTSAQ = XTSAQ(IDXST)
13888 * flavor of the second quarks in the sea-diquark pair
13889 ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13890 ITSAQ2(IDXST) = -ITSQ2(IDXST)
13891 * check masses of the new val-q - sea-qq, val-qq - sea-aqaq chains
13892 AM1 = XXTSQ *XPVQ(IDXVP)*ECM**2
13893 AM2 = XXTSAQ*XPVD(IDXVP)*ECM**2
13894 IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13896 & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN
13899 ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13900 * at least one strange quark
13901 & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN
13904 ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13908 * accept the new sea-diquark
13910 XTSQ(IDXST) = XXTSQ
13911 XTSAQ(IDXST) = XXTSAQ
13913 INTVD1(NVD) = IDXVP
13914 INTVD2(NVD) = IDXST
13918 *---------------------------------------------------------------------
13919 * proj. sea partons - targ. valence partons
13920 * get x-values and flavors for projectile sea-diquark pair
13926 * index of corr. val-diquark-x in projectile nucleon
13927 IDXVP = ITOVP(IFROSP(IDXSP))
13928 * available x above diquark thresholds for valence- and sea-diquarks
13929 XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13931 IF (XXD.GE.ZERO) THEN
13932 * x-values for the three diquarks of the projectile nucleon
13936 SR123 = RR1+RR2+RR3
13937 XXPV = XDTHR+RR1*XXD/SR123
13938 XXPSQ = XDTHR+RR2*XXD/SR123
13939 XXPSAQ = XDTHR+RR3*XXD/SR123
13942 XXPSQ = XPSQ(IDXSP)
13943 XXPSAQ = XPSAQ(IDXSP)
13945 * flavor of the second quarks in the sea-diquark pair
13946 IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13947 IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13948 * check masses of the new sea-qq - val-q, sea-aqaq - val-qq chains
13949 AM1 = XXPSQ *XTVQ(IDXVT)*ECM**2
13950 AM2 = XXPSAQ*XTVD(IDXVT)*ECM**2
13951 IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13953 & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN
13956 ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13957 * at least one strange quark
13958 & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN
13961 ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13965 * accept the new sea-diquark
13967 XPSQ(IDXSP) = XXPSQ
13968 XPSAQ(IDXSP) = XXPSAQ
13970 INTDV1(NDV) = IDXSP
13971 INTDV2(NDV) = IDXVT
13975 *---------------------------------------------------------------------
13976 * proj. sea partons - targ. sea partons
13977 * get x-values and flavors for target sea-diquark pair
13983 * index of corr. val-diquark-x in target nucleon
13984 IDXVT = ITOVT(IFROST(IDXST))
13985 * available x above diquark thresholds for valence- and sea-diquarks
13986 XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13988 IF (XXD.GE.ZERO) THEN
13989 * x-values for the three diquarks of the target nucleon
13993 SR123 = RR1+RR2+RR3
13994 XXTV = XDTHR+RR1*XXD/SR123
13995 XXTSQ = XDTHR+RR2*XXD/SR123
13996 XXTSAQ = XDTHR+RR3*XXD/SR123
13999 XXTSQ = XTSQ(IDXST)
14000 XXTSAQ = XTSAQ(IDXST)
14002 * flavor of the second quarks in the sea-diquark pair
14003 ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
14004 ITSAQ2(IDXST) = -ITSQ2(IDXST)
14005 * check masses of the new sea-q - sea-qq, sea-aq - sea-aqaq chains
14006 AM1 = XXTSQ *XPSQ(IDXSP)*ECM**2
14007 AM2 = XXTSAQ*XPSAQ(IDXSP)*ECM**2
14008 IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
14010 & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN
14013 ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
14014 * at least one strange quark
14015 & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN
14018 ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
14022 * accept the new sea-diquark
14024 XTSQ(IDXST) = XXTSQ
14025 XTSAQ(IDXST) = XXTSAQ
14027 INTSD1(NSD) = IDXSP
14028 INTSD2(NSD) = IDXST
14032 *---------------------------------------------------------------------
14033 * proj. sea partons - targ. sea partons
14034 * get x-values and flavors for projectile sea-diquark pair
14040 * index of corr. val-diquark-x in projectile nucleon
14041 IDXVP = ITOVP(IFROSP(IDXSP))
14042 * available x above diquark thresholds for valence- and sea-diquarks
14043 XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
14045 IF (XXD.GE.ZERO) THEN
14046 * x-values for the three diquarks of the projectile nucleon
14050 SR123 = RR1+RR2+RR3
14051 XXPV = XDTHR+RR1*XXD/SR123
14052 XXPSQ = XDTHR+RR2*XXD/SR123
14053 XXPSAQ = XDTHR+RR3*XXD/SR123
14056 XXPSQ = XPSQ(IDXSP)
14057 XXPSAQ = XPSAQ(IDXSP)
14059 * flavor of the second quarks in the sea-diquark pair
14060 IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
14061 IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
14062 * check masses of the new sea-qq - sea-q, sea-aqaq - sea-qq chains
14063 AM1 = XXPSQ *XTSQ(IDXST)*ECM**2
14064 AM2 = XXPSAQ*XTSAQ(IDXST)*ECM**2
14065 IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
14067 & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN
14070 ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
14071 * at least one strange quark
14072 & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN
14075 ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
14079 * accept the new sea-diquark
14081 XPSQ(IDXSP) = XXPSQ
14082 XPSAQ(IDXSP) = XXPSAQ
14084 INTDS1(NDS) = IDXSP
14085 INTDS2(NDS) = IDXST
14089 *$ CREATE DT_DIFEVT.FOR
14092 *===difevt=============================================================*
14094 SUBROUTINE DT_DIFEVT(IFP1,IFP2,PP,MOP,
14095 & IFT1,IFT2,PT,MOT,JDIFF,NCSY,IREJ)
14097 ************************************************************************
14098 * Interface to treatment of diffractive interactions. *
14099 * (input) IFP1/2 PDG-indizes of projectile partons *
14100 * (baryon: IFP2 - adiquark) *
14101 * PP(4) projectile 4-momentum *
14102 * IFT1/2 PDG-indizes of target partons *
14103 * (baryon: IFT1 - adiquark) *
14104 * PT(4) target 4-momentum *
14105 * (output) JDIFF = 0 no diffraction *
14106 * = 1/-1 LMSD/LMDD *
14107 * = 2/-2 HMSD/HMDD *
14108 * NCSY counter for two-chain systems *
14109 * dumped to DTEVT1 *
14110 * This version dated 14.02.95 is written by S. Roesler *
14111 ************************************************************************
14113 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14116 PARAMETER ( LINP = 10 ,
14120 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5,
14125 PARAMETER (NMXHKK=200000)
14127 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14128 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14129 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14131 * extended event history
14132 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14133 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14136 * flags for diffractive interactions (DTUNUC 1.x)
14137 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
14139 DIMENSION PP(4),PT(4)
14142 DATA LFIRST /.TRUE./
14149 XM = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
14150 & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
14151 * identities of projectile hadron / target nucleon
14152 KPROJ = IDT_ICIHAD(IDHKK(MOP))
14153 KTARG = IDT_ICIHAD(IDHKK(MOT))
14155 * single diffractive xsections
14156 CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM)
14157 * double diffractive xsections
14158 **!! no double diff yet
14159 C CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM,DDTOT,DDHM)
14163 * total inelastic xsection
14164 C SIGIN = DT_SHNTOT(KPROJ,KTARG,XM,ZERO)-DT_SHNELA(KPROJ,KTARG,XM)
14166 CALL DT_XSHN(KPROJ,KTARG,DUMZER,XM,SIGTO,SIGEL)
14167 SIGIN = MAX(SIGTO-SIGEL,ZERO)
14169 * fraction of diffractive processes
14170 FRADIF = (SDTOT+DDTOT)/SIGIN
14173 WRITE(LOUT,1000) XM,SDTOT,SIGIN
14174 1000 FORMAT(1X,'DIFEVT: single diffraction requested at E_cm = ',
14175 & F5.1,' GeV',/,9X,'sigma_sd = ',F4.1,' mb, sigma_in = ',
14180 IF ((DT_RNDM(DDHM).LE.FRADIF).OR.
14181 & (ISINGD.GT.1).OR.(IDOUBD.GT.1)) THEN
14182 * diffractive interaction requested by x-section or by user
14183 FRASD = SDTOT/(SDTOT+DDTOT)
14184 FRASDH = SDHM/SDTOT
14185 **sr needs to be specified!!
14186 C FRADDH = DDHM/DDTOT
14189 IF ((DT_RNDM(FRASD).LE.FRASD).OR.(ISINGD.GT.1)) THEN
14190 * single diffraction
14192 IF (DT_RNDM(DDTOT).LE.FRASDH) THEN
14195 IF (((ISINGD.EQ.4).OR.(DT_RNDM(DDTOT).GE.OHALF)).AND.
14196 & ISINGD.NE.3) THEN
14203 IF (((ISINGD.EQ.4).OR.(DT_RNDM(FRADDH).GE.OHALF)).AND.
14204 & ISINGD.NE.3) THEN
14210 * double diffraction
14212 IF (DT_RNDM(FRADDH).LE.FRADDH) THEN
14220 CALL DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
14221 & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
14222 IF (IREJ1.EQ.0) THEN
14224 IF ((KP.EQ.1).OR.(KT.EQ.1)) IFLAGD = KDIFF
14238 *$ CREATE DT_DIFFKI.FOR
14241 *===difkin=============================================================*
14243 SUBROUTINE DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
14244 & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ)
14246 ************************************************************************
14247 * Kinematics of diffractive nucleon-nucleon interaction. *
14248 * IFP1/2 PDG-indizes of projectile partons *
14249 * (baryon: IFP2 - adiquark) *
14250 * PP(4) projectile 4-momentum *
14251 * IFT1/2 PDG-indizes of target partons *
14252 * (baryon: IFT1 - adiquark) *
14253 * PT(4) target 4-momentum *
14254 * KP = 0 projectile quasi-elastically scattered *
14255 * = 1 excited to low-mass diff. state *
14256 * = 2 excited to high-mass diff. state *
14257 * KT = 0 target quasi-elastically scattered *
14258 * = 1 excited to low-mass diff. state *
14259 * = 2 excited to high-mass diff. state *
14260 * This version dated 12.02.95 is written by S. Roesler *
14261 ************************************************************************
14263 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14266 PARAMETER ( LINP = 10 ,
14270 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5)
14274 * particle properties (BAMJET index convention)
14276 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
14277 & IICH(210),IIBAR(210),K1(210),K2(210)
14279 * flags for input different options
14280 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14281 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14282 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14284 * rejection counter
14285 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
14286 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
14287 & IREXCI(3),IRDIFF(2),IRINC
14289 * kinematics of diffractive interactions (DTUNUC 1.x)
14290 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14292 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14293 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14295 DIMENSION PITOT(4),BGTOT(4),PP1(4),PT1(4),PPBLOB(4),PTBLOB(4),
14296 & PP(4),PT(4),PPOM1(4),DEV1(4),DEV2(4)
14298 DATA LSTART /.TRUE./
14302 2000 FORMAT(/,1X,'DIFEVT: diffractive interactions treated ')
14308 * initialize common /DTDIKI/
14310 * store momenta of initial incoming particles for emc-check
14312 CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM,IDUM)
14313 CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM,IDUM)
14316 * masses of initial particles
14317 XMP2 = PP(4)**2-PP(1)**2-PP(2)**2-PP(3)**2
14318 XMT2 = PT(4)**2-PT(1)**2-PT(2)**2-PT(3)**2
14319 IF ((XMP2.LT.ZERO).OR.(XMT2.LT.ZERO)) GOTO 9999
14322 * check quark-input (used to adjust coherence cond. for M-selection)
14324 IF ((ABS(IFP1).GE.1000).OR.(ABS(IFP2).GE.1000)) IBP = 1
14326 IF ((ABS(IFT1).GE.1000).OR.(ABS(IFT2).GE.1000)) IBT = 1
14328 * parameter for Lorentz-transformation into nucleon-nucleon cms
14330 PITOT(K) = PP(K)+PT(K)
14332 XMTOT2 = PITOT(4)**2-PITOT(1)**2-PITOT(2)**2-PITOT(3)**2
14333 IF (XMTOT2.LE.ZERO) THEN
14334 WRITE(LOUT,1000) XMTOT2
14335 1000 FORMAT(1X,'DIFEVT: negative cm. energy! ',
14336 & 'XMTOT2 = ',E12.3)
14339 XMTOT = SQRT(XMTOT2)
14341 BGTOT(K) = PITOT(K)/XMTOT
14343 * transformation of nucleons into cms
14344 CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PP(1),PP(2),
14345 & PP(3),PP(4),PPTOT,PP1(1),PP1(2),PP1(3),PP1(4))
14346 CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PT(1),PT(2),
14347 & PT(3),PT(4),PTTOT,PT1(1),PT1(2),PT1(3),PT1(4))
14350 C SID = SQRT((ONE-COD)*(ONE+COD))
14351 PPT = SQRT(PP1(1)**2+PP1(2)**2)
14355 IF(PPTOT*SID.GT.TINY10) THEN
14356 COF = PP1(1)/(SID*PPTOT)
14357 SIF = PP1(2)/(SID*PPTOT)
14358 ANORF = SQRT(COF*COF+SIF*SIF)
14362 * check consistency
14364 DEV1(K) = ABS(PP1(K)+PT1(K))
14366 DEV1(4) = ABS(DEV1(4)-XMTOT)
14367 IF ((DEV1(1).GT.TINY10).OR.(DEV1(2).GT.TINY10).OR.
14368 & (DEV1(3).GT.TINY10).OR.(DEV1(4).GT.TINY10)) THEN
14369 WRITE(LOUT,1001) DEV1
14370 1001 FORMAT(1X,'DIFEVT: inconsitent Lorentz-transformation! ',
14375 * select x-fractions in high-mass diff. interactions
14376 IF ((KP.EQ.2).OR.(KT.EQ.2)) CALL DT_XVALHM(KP,KT)
14378 * select diffractive masses
14381 XMPF = DT_XMLMD(XMTOT)
14382 CALL DT_LM2RES(IFP1,IFP2,XMPF,IDPR,IDXPR,IREJ1)
14383 IF (IREJ1.GT.0) GOTO 9999
14384 ELSEIF (KP.EQ.2) THEN
14385 XMPF = DT_XMHMD(XMTOT,IBP,1)
14391 XMTF = DT_XMLMD(XMTOT)
14392 CALL DT_LM2RES(IFT1,IFT2,XMTF,IDTR,IDXTR,IREJ1)
14393 IF (IREJ1.GT.0) GOTO 9999
14394 ELSEIF (KT.EQ.2) THEN
14395 XMTF = DT_XMHMD(XMTOT,IBT,2)
14400 * kinematical treatment of "two-particle" system (masses - XMPF,XMTF)
14403 PPBLOB(3) = DT_YLAMB(XMTOT2,XMPF2,XMTF2)/(2.D0*XMTOT)
14404 PPBLOB(4) = SQRT(XMPF2+PPBLOB(3)**2)
14406 * select momentum transfer (all t-values used here are <0)
14407 * minimum absolute value to produce diffractive masses
14408 TMIN = XMP2+XMPF2-2.0D0*(PP1(4)*PPBLOB(4)-PPTOT*PPBLOB(3))
14409 TT = DT_TDIFF(XMTOT,TMIN,XMPF,KP,XMTF,KT,IREJ1)
14410 IF (IREJ1.GT.0) GOTO 9999
14412 * longitudinal momentum of excited/elastically scattered projectile
14413 PPBLOB(3) = (TT-XMP2-XMPF2+2.0D0*PP1(4)*PPBLOB(4))/(2.0D0*PPTOT)
14414 * total transverse momentum due to t-selection
14415 PPBLT2 = PPBLOB(4)**2-PPBLOB(3)**2-XMPF2
14416 IF (PPBLT2.LT.ZERO) THEN
14417 WRITE(LOUT,1002) PPBLT2,KP,PP1,XMPF,KT,PT1,XMTF,TT
14418 1002 FORMAT(1X,'DIFEVT: inconsistent transverse momentum! ',
14419 & E12.3,2(/,1X,I2,5E12.3),/,1X,E12.3)
14422 CALL DT_DSFECF(SINPHI,COSPHI)
14423 PPBLT = SQRT(PPBLT2)
14424 PPBLOB(1) = COSPHI*PPBLT
14425 PPBLOB(2) = SINPHI*PPBLT
14427 * rotate excited/elastically scattered projectile into n-n cms.
14428 CALL DT_MYTRAN(1,PPBLOB(1),PPBLOB(2),PPBLOB(3),COD,SID,COF,SIF,
14434 * 4-momentum of excited/elastically scattered target and of exchanged
14437 IF (K.LT.4) PTBLOB(K) = -PPBLOB(K)
14438 PPOM1(K) = PP1(K)-PPBLOB(K)
14440 PTBLOB(4) = XMTOT-PPBLOB(4)
14442 * Lorentz-transformation back into system of initial diff. collision
14443 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
14444 & PPBLOB(1),PPBLOB(2),PPBLOB(3),PPBLOB(4),
14445 & PPTOTF,PPF(1),PPF(2),PPF(3),PPF(4))
14446 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
14447 & PTBLOB(1),PTBLOB(2),PTBLOB(3),PTBLOB(4),
14448 & PTTOTF,PTF(1),PTF(2),PTF(3),PTF(4))
14449 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
14450 & PPOM1(1),PPOM1(2),PPOM1(3),PPOM1(4),
14451 & PPOMTO,PPOM(1),PPOM(2),PPOM(3),PPOM(4))
14453 * store 4-momentum of elastically scattered particle (in single diff.
14459 ELSEIF (KT.EQ.0) THEN
14465 * check consistency of kinematical treatment so far
14467 CALL DT_EVTEMC(-PPF(1),-PPF(2),-PPF(3),-PPF(4),2,IDUM,IDUM)
14468 CALL DT_EVTEMC(-PTF(1),-PTF(2),-PTF(3),-PTF(4),2,IDUM,IDUM)
14469 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,60,IREJ1)
14470 IF (IREJ1.NE.0) GOTO 9999
14473 DEV1(K) = ABS(PP(K)-PPF(K)-PPOM(K))
14474 DEV2(K) = ABS(PT(K)-PTF(K)+PPOM(K))
14476 IF ((DEV1(1).GT.TINY5).OR.(DEV1(2).GT.TINY5).OR.
14477 & (DEV1(3).GT.TINY5).OR.(DEV1(4).GT.TINY5).OR.
14478 & (DEV2(1).GT.TINY5).OR.(DEV2(2).GT.TINY5).OR.
14479 & (DEV2(3).GT.TINY5).OR.(DEV2(4).GT.TINY5)) THEN
14480 WRITE(LOUT,1003) DEV1,DEV2
14481 1003 FORMAT(1X,'DIFEVT: inconsitent kinematical treatment! ',
14486 * kinematical treatment for low-mass diffraction
14487 CALL DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ1)
14488 IF (IREJ1.NE.0) GOTO 9999
14490 * dump diffractive chains into DTEVT1
14491 CALL DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
14492 IF (IREJ1.NE.0) GOTO 9999
14497 IRDIFF(1) = IRDIFF(1)+1
14502 *$ CREATE DT_XMHMD.FOR
14505 *===xmhmd==============================================================*
14507 DOUBLE PRECISION FUNCTION DT_XMHMD(ECM,IB,MODE)
14509 ************************************************************************
14510 * Diffractive mass in high mass single/double diffractive events. *
14511 * This version dated 11.02.95 is written by S. Roesler *
14512 ************************************************************************
14514 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14517 PARAMETER ( LINP = 10 ,
14521 PARAMETER (OHALF=0.5D0,ONE=1.0D0,ZERO=0.0D0)
14523 * kinematics of diffractive interactions (DTUNUC 1.x)
14524 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14526 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14527 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14529 C DATA XCOLOW /0.05D0/
14530 DATA XCOLOW /0.15D0/
14534 IF (MODE.EQ.2) XH = XTH(2)
14536 * minimum Pomeron-x for high-mass diffraction
14537 * (adjusted to get a smooth transition between HM and LM component)
14539 XDIMIN = (3.0D0+400.0D0*R**2)/(XH*ECM**2)
14540 IF (ECM.LE.300.0D0) THEN
14541 RR = (1.0D0-EXP(-((ECM/140.0D0)**4)))
14542 XDIMIN = (3.0D0+400.0D0*(R**2)*RR)/(XH*ECM**2)
14544 * maximum Pomeron-x for high-mass diffraction
14545 * (coherence condition, adjusted to fit to experimental data)
14547 * baryon-diffraction
14548 XDIMAX = XCOLOW*(1.0D0+EXP(-((ECM/420.0D0)**2)))
14550 * meson-diffraction
14551 XDIMAX = XCOLOW*(1.0D0+4.0D0*EXP(-((ECM/420.0D0)**2)))
14554 IF (XDIMIN.GE.XDIMAX) THEN
14555 XDIMIN = OHALF*XDIMAX
14561 IF (KLOOP.GT.20) RETURN
14562 * sample Pomeron-x from 1/x-distribution (critical Pomeron)
14563 XDIFF = DT_SAMPEX(XDIMIN,XDIMAX)
14564 * corr. diffr. mass
14565 DT_XMHMD = ECM*SQRT(XDIFF)
14566 IF (DT_XMHMD.LT.2.5D0) GOTO 1
14571 *$ CREATE DT_XMLMD.FOR
14574 *===xmlmd==============================================================*
14576 DOUBLE PRECISION FUNCTION DT_XMLMD(ECM)
14578 ************************************************************************
14579 * Diffractive mass in high mass single/double diffractive events. *
14580 * This version dated 11.02.95 is written by S. Roesler *
14581 ************************************************************************
14583 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14586 PARAMETER ( LINP = 10 ,
14590 * minimum Pomeron-x for low-mass diffraction
14593 * maximum Pomeron-x for low-mass diffraction
14594 * (adjusted to get a smooth transition between HM and LM component)
14597 IF (ECM.LE.300.0D0) SAM = 1.0D0-EXP(-((ECM/200.0D0)**4))
14598 R = DT_RNDM(AMO)*SAM
14599 AMAX= (1.0D0-SAM)*SQRT(0.1D0*ECM**2)+SAM*SQRT(400.0D0)
14600 AMU = R*SQRT(100.0D0)+(1.0D0-R)*AMAX
14602 * selection of diffractive mass
14603 * (adjusted to get a smooth transition between HM and LM component)
14605 IF (ECM.LE.50.0D0) THEN
14606 DT_XMLMD = AMO*(AMU/AMO)**R
14609 IF (ECM.LE.300.0D0) A = 0.7D0*(1.0D0-EXP(-((ECM/100.0D0)**2)))
14610 DT_XMLMD = 1.0D0/((R/(AMU**A)+(1.0D0-R)/(AMO**A))**(1.0D0/A))
14616 *$ CREATE DT_TDIFF.FOR
14619 *===tdiff==============================================================*
14621 DOUBLE PRECISION FUNCTION DT_TDIFF(ECM,TMIN,XM1I,K1,XM2I,K2,IREJ)
14623 ************************************************************************
14624 * t-selection for single/double diffractive interactions. *
14626 * TMIN minimum momentum transfer to produce diff. masses *
14627 * XM1/XM2 diffractively produced masses *
14628 * (for single diffraction XM2 is obsolete) *
14629 * K1/K2= 0 not excited *
14630 * = 1 low-mass excitation *
14631 * = 2 high-mass excitation *
14632 * This version dated 11.02.95 is written by S. Roesler *
14633 ************************************************************************
14635 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14638 PARAMETER ( LINP = 10 ,
14642 PARAMETER (ZERO=0.0D0)
14644 PARAMETER ( BTP0 = 3.7D0,
14645 & ALPHAP = 0.24D0 )
14658 IF ((K1.EQ.0).OR.(K2.EQ.0)) THEN
14659 * slope for single diffraction
14660 SLOPE = BTP0-2.0D0*ALPHAP*LOG(XDI)
14662 * slope for double diffraction
14663 SLOPE = -2.0D0*ALPHAP*LOG(XDI*XM2**2)
14668 IF (MOD(NCLOOP,1000).EQ.0) GOTO 9999
14670 T = -LOG(1.0D0-Y)/SLOPE
14671 IF (ABS(T).LE.ABS(TMIN)) GOTO 1
14677 WRITE(LOUT,1000) ECM,TMIN,XM1I,XM2I,K1,K2
14678 1000 FORMAT(1X,'DT_TDIFF: t-selection rejected!',/,
14679 & 1X,'ECM = ',E12.3,' TMIN = ',E12.2,/,1X,'XM1I = ',
14680 & E12.3,' XM2I = ',E12.3,' K1 = ',I2,' K2 = ',I2)
14685 *$ CREATE DT_XVALHM.FOR
14688 *===xvalhm=============================================================*
14690 SUBROUTINE DT_XVALHM(KP,KT)
14692 ************************************************************************
14693 * Sampling of parton x-values in high-mass diffractive interactions. *
14694 * This version dated 12.02.95 is written by S. Roesler *
14695 ************************************************************************
14697 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14700 PARAMETER ( LINP = 10 ,
14704 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0,TINY2=1.0D-2)
14706 * kinematics of diffractive interactions (DTUNUC 1.x)
14707 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14709 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14710 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14712 * various options for treatment of partons (DTUNUC 1.x)
14713 * (chain recombination, Cronin,..)
14714 LOGICAL LCO2CR,LINTPT
14715 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
14718 DATA UNON,XVQTHR /2.0D0,0.8D0/
14721 * x-fractions of projectile valence partons
14723 XPH(1) = DT_DBETAR(OHALF,UNON)
14724 IF (XPH(1).GE.XVQTHR) GOTO 1
14725 XPH(2) = ONE-XPH(1)
14726 * x-fractions of Pomeron q-aq-pair
14729 XPPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14730 XPPO(2) = ONE-XPPO(1)
14731 * flavors of Pomeron q-aq-pair
14732 IFLAV = INT(ONE+DT_RNDM(UNON)*(2.0D0+SEASQ))
14735 IF (DT_RNDM(UNON).GT.OHALF) THEN
14742 * x-fractions of projectile target partons
14744 XTH(1) = DT_DBETAR(OHALF,UNON)
14745 IF (XTH(1).GE.XVQTHR) GOTO 2
14746 XTH(2) = ONE-XTH(1)
14747 * x-fractions of Pomeron q-aq-pair
14750 XTPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14751 XTPO(2) = ONE-XTPO(1)
14752 * flavors of Pomeron q-aq-pair
14753 IFLAV = INT(ONE+DT_RNDM(XPOLO)*(2.0D0+SEASQ))
14756 IF (DT_RNDM(XPOLO).GT.OHALF) THEN
14765 *$ CREATE DT_LM2RES.FOR
14768 *===lm2res=============================================================*
14770 SUBROUTINE DT_LM2RES(IF1,IF2,XM,IDR,IDXR,IREJ)
14772 ************************************************************************
14773 * Check low-mass diffractive excitation for resonance mass. *
14774 * (input) IF1/2 PDG-indizes of valence partons *
14775 * (in/out) XM diffractive mass requested/corrected *
14776 * (output) IDR/IDXR id./BAMJET-index of resonance *
14777 * This version dated 12.02.95 is written by S. Roesler *
14778 ************************************************************************
14780 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14783 PARAMETER ( LINP = 10 ,
14787 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14789 * kinematics of diffractive interactions (DTUNUC 1.x)
14790 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14792 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14793 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14800 * BAMJET indices of partons
14801 IF1A = IDT_IPDG2B(IF1,1,2)
14802 IF (ABS(IF1).GE.1000) IF1B = IDT_IPDG2B(IF1,2,2)
14803 IF2A = IDT_IPDG2B(IF2,1,2)
14804 IF (ABS(IF2).GE.1000) IF2B = IDT_IPDG2B(IF2,2,2)
14806 * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq)
14808 IF ((IF1B.EQ.0).AND.(IF2B.EQ.0)) IDCH = 1
14810 * check for resonance mass
14811 CALL DT_CH2RES(IF1A,IF1B,IF2A,IF2B,IDR,IDXR,XMI,XMN,IDCH,IREJ1)
14812 IF (IREJ1.NE.0) GOTO 9999
14822 *$ CREATE DT_LMKINE.FOR
14825 *===lmkine=============================================================*
14827 SUBROUTINE DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ)
14829 ************************************************************************
14830 * Kinematical treatment of low-mass excitations. *
14831 * This version dated 12.02.95 is written by S. Roesler *
14832 ************************************************************************
14834 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14837 PARAMETER ( LINP = 10 ,
14841 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14843 * flags for input different options
14844 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14845 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14846 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14848 * kinematics of diffractive interactions (DTUNUC 1.x)
14849 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14851 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14852 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14854 DIMENSION P1(4),P2(4)
14859 PABS = SQRT(PPF(1)**2+PPF(2)**2+PPF(3)**2)
14861 FAC1 = OHALF*(POE+ONE)
14862 FAC2 = -OHALF*(POE-ONE)
14864 PPLM1(K) = FAC1*PPF(K)
14865 PPLM2(K) = FAC2*PPF(K)
14867 PPLM1(4) = FAC1*PABS
14868 PPLM2(4) = -FAC2*PABS
14869 IF (IMSHL.EQ.1) THEN
14874 CALL DT_MASHEL(PPLM1,PPLM2,XM1,XM2,P1,P2,IREJ1)
14875 IF (IREJ1.NE.0) GOTO 9999
14884 PABS = SQRT(PTF(1)**2+PTF(2)**2+PTF(3)**2)
14886 FAC1 = OHALF*(POE+ONE)
14887 FAC2 = -OHALF*(POE-ONE)
14889 PTLM2(K) = FAC1*PTF(K)
14890 PTLM1(K) = FAC2*PTF(K)
14892 PTLM2(4) = FAC1*PABS
14893 PTLM1(4) = -FAC2*PABS
14894 IF (IMSHL.EQ.1) THEN
14899 CALL DT_MASHEL(PTLM1,PTLM2,XM1,XM2,P1,P2,IREJ1)
14900 IF (IREJ1.NE.0) GOTO 9999
14911 WRITE(LOUT,'(A)') 'LMKINE: kinematical treatment rejected'
14916 *$ CREATE DT_DIFINI.FOR
14919 *===difini=============================================================*
14921 SUBROUTINE DT_DIFINI
14923 ************************************************************************
14924 * Initialization of common /DTDIKI/ *
14925 * This version dated 12.02.95 is written by S. Roesler *
14926 ************************************************************************
14928 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14931 PARAMETER ( LINP = 10 ,
14935 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14937 * kinematics of diffractive interactions (DTUNUC 1.x)
14938 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14940 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14941 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14969 *$ CREATE DT_DIFPUT.FOR
14972 *===difput=============================================================*
14974 SUBROUTINE DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,
14977 ************************************************************************
14978 * Dump diffractive chains into DTEVT1 *
14979 * This version dated 12.02.95 is written by S. Roesler *
14980 ************************************************************************
14982 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14985 PARAMETER ( LINP = 10 ,
14989 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14993 * kinematics of diffractive interactions (DTUNUC 1.x)
14994 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14996 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14997 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
15001 PARAMETER (NMXHKK=200000)
15003 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15004 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15005 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15007 * extended event history
15008 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15009 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15012 * rejection counter
15013 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
15014 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
15015 & IREXCI(3),IRDIFF(2),IRINC
15017 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PCH(4),PP(4),PT(4),
15018 & P1(4),P2(4),P3(4),P4(4)
15024 PCH(K) = PPLM1(K)+PPLM2(K)
15028 IF (DT_RNDM(PT).GT.OHALF) THEN
15032 CALL DT_EVTPUT(21,ID1,MOP,0,PPLM1(1),PPLM1(2),PPLM1(3),
15034 CALL DT_EVTPUT(21,ID2,MOP,0,PPLM2(1),PPLM2(2),PPLM2(3),
15036 CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
15038 ELSEIF (KP.EQ.2) THEN
15040 PP1(K) = XPH(1)*PP(K)
15041 PP2(K) = XPH(2)*PP(K)
15042 PT1(K) = -XPPO(1)*PPOM(K)
15043 PT2(K) = -XPPO(2)*PPOM(K)
15045 CALL DT_CHKCSY(IFP1,IFPPO(1),LCHK)
15049 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
15050 IF (IREJ1.NE.0) GOTO 9999
15051 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
15052 IF (IREJ1.NE.0) GOTO 9999
15059 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
15061 CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
15063 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
15065 CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
15068 CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
15069 IF (IREJ1.NE.0) GOTO 9999
15070 CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
15071 IF (IREJ1.NE.0) GOTO 9999
15078 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
15080 CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
15082 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
15084 CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
15089 CALL DT_EVTPUT(1,IDHKK(MOP),MOP,0,PSC(1),PSC(2),PSC(3),PSC(4),
15095 PCH(K) = PTLM1(K)+PTLM2(K)
15099 IF (DT_RNDM(PT).GT.OHALF) THEN
15103 CALL DT_EVTPUT(22,ID1,MOT,0,PTLM1(1),PTLM1(2),PTLM1(3),
15105 CALL DT_EVTPUT(22,ID2,MOT,0,PTLM2(1),PTLM2(2),PTLM2(3),
15107 CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
15109 ELSEIF (KT.EQ.2) THEN
15111 PP1(K) = XTPO(1)*PPOM(K)
15112 PP2(K) = XTPO(2)*PPOM(K)
15113 PT1(K) = XTH(2)*PT(K)
15114 PT2(K) = XTH(1)*PT(K)
15116 CALL DT_CHKCSY(IFTPO(1),IFT1,LCHK)
15120 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
15121 IF (IREJ1.NE.0) GOTO 9999
15122 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
15123 IF (IREJ1.NE.0) GOTO 9999
15130 CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
15132 CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
15134 CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
15136 CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
15139 CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
15140 IF (IREJ1.NE.0) GOTO 9999
15141 CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
15142 IF (IREJ1.NE.0) GOTO 9999
15149 CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
15151 CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
15153 CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
15155 CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
15160 CALL DT_EVTPUT(1,IDHKK(MOT),MOT,0,PSC(1),PSC(2),PSC(3),PSC(4),
15167 IRDIFF(2) = IRDIFF(2)+1
15171 *$ CREATE DT_EVTFRG.FOR
15174 *===evtfrg=============================================================*
15176 SUBROUTINE DT_EVTFRG(KMODE,NFRG,NPYMEM,IREJ)
15178 ************************************************************************
15179 * Hadronization of chains in DTEVT1. *
15182 * KMODE = 1 hadronization of PHOJET-chains (id=77xxx) *
15183 * = 2 hadronization of DTUNUC-chains (id=88xxx) *
15184 * NFRG if KMODE = 1 : upper index of PHOJET-scatterings to be *
15185 * hadronized with one PYEXEC call *
15186 * if KMODE = 2 : max. number of DTUNUC-chains to be hadronized *
15187 * with one PYEXEC call *
15189 * NPYMEM number of entries in JETSET-common after hadronization *
15190 * IREJ rejection flag *
15192 * This version dated 17.09.00 is written by S. Roesler *
15193 ************************************************************************
15195 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15198 PARAMETER ( LINP = 10 ,
15202 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1)
15203 PARAMETER (ONE=1.0D0,ZERO=0.0D0)
15207 PARAMETER (MXJOIN=200)
15211 PARAMETER (NMXHKK=200000)
15213 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15214 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15215 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15217 * extended event history
15218 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15219 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15222 * flags for input different options
15223 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15224 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15225 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15228 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
15229 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
15232 * flags for diffractive interactions (DTUNUC 1.x)
15233 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
15235 * nucleon-nucleon event-generator
15238 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
15241 C model switches and parameters
15243 INTEGER ISWMDL,IPAMDL
15244 DOUBLE PRECISION PARMDL
15245 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15248 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15249 PARAMETER (MAXLND=4000)
15250 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
15254 DIMENSION IJOIN(MXJOIN),ISJOIN(MXJOIN),IHISMO(8000),IFLG(4000)
15258 IF (MODE.NE.1) ISTSTG = 8
15267 IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
15268 DO 10 I=NPOINT(3),NEND
15269 * sr 14.02.00: seems to be not necessary anymore, commented
15270 C LACCEP = ((NOBAM(I).EQ.0).AND.(MODE.EQ.1)).OR.
15271 C & ((NOBAM(I).NE.0).AND.(MODE.EQ.2))
15273 * pick up chains from dtevt1
15274 IDCHK = IDHKK(I)/10000
15275 IF ((IDCHK.EQ.ISTSTG).AND.LACCEP) THEN
15276 IF (IDCHK.EQ.7) THEN
15277 IPJE = IDHKK(I)-IDCHK*10000
15278 IF (IPJE.NE.IFRG) THEN
15280 IF (IFRG.GT.NFRG) GOTO 16
15285 IF (IFRG.GT.NFRG) THEN
15290 * statistics counter
15291 c IF (IDCH(I).LE.8)
15292 c & ICCHAI(2,IDCH(I)) = ICCHAI(2,IDCH(I))+1
15293 c IF (IDRES(I).NE.0) ICRES(IDCH(I)) = ICRES(IDCH(I))+1
15294 * special treatment for small chains already corrected to hadrons
15295 IF (IDRES(I).NE.0) THEN
15296 IF (IDRES(I).EQ.11) THEN
15299 ID = IDT_IPDGHA(IDXRES(I))
15302 CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
15303 & PHKK(4,I),INIEMC,IDUM,IDUM)
15307 IF (IP.GT.MSTU(4)) STOP ' NEWFRA 1: IP.GT.MSTU(4) !'
15308 P(IP,1) = PHKK(1,I)
15309 P(IP,2) = PHKK(2,I)
15310 P(IP,3) = PHKK(3,I)
15311 P(IP,4) = PHKK(4,I)
15312 P(IP,5) = PHKK(5,I)
15318 IHIST(2,I) = 10000*IPJE+IP
15319 IF (IHIST(1,I).LE.-100) THEN
15321 IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
15328 DO 11 KK=JMOHKK(1,I),JMOHKK(2,I)
15330 CALL DT_EVTEMC(PHKK(1,KK),PHKK(2,KK),PHKK(3,KK),
15331 & PHKK(4,KK),INIEMC,IDUM,IDUM)
15332 CALL DT_EVTFLC(IDHKK(KK),1,INIEMC,IDUM,IDUM)
15336 IF (ID.EQ.0) ID = 21
15337 c PTOT = SQRT(PHKK(1,KK)**2+PHKK(2,KK)**2+PHKK(3,KK)**2)
15338 c AM0 = SQRT(ABS((PHKK(4,KK)-PTOT)*(PHKK(4,KK)+PTOT)))
15340 c AMRQ = PYMASS(ID)
15342 c AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
15343 c IF ((ABS(AMDIF2).GT.TINY3).AND.(PTOT.GT.ZERO).AND.
15344 c & (ABS(IDIFF).EQ.0)) THEN
15345 cC WRITE(LOUT,*)'here: ',NEVHKK,AM0,AMRQ
15346 c DELTA = -AMDIF2/(2.0D0*(PHKK(4,KK)+PTOT))
15347 c PHKK(4,KK) = PHKK(4,KK)+DELTA
15348 c PTOT1 = PTOT-DELTA
15349 c PHKK(1,KK) = PHKK(1,KK)*PTOT1/PTOT
15350 c PHKK(2,KK) = PHKK(2,KK)*PTOT1/PTOT
15351 c PHKK(3,KK) = PHKK(3,KK)*PTOT1/PTOT
15352 c PHKK(5,KK) = AMRQ
15355 IF (IP.GT.MSTU(4)) STOP ' NEWFRA 2: IP.GT.MSTU(4) !'
15356 P(IP,1) = PHKK(1,KK)
15357 P(IP,2) = PHKK(2,KK)
15358 P(IP,3) = PHKK(3,KK)
15359 P(IP,4) = PHKK(4,KK)
15360 P(IP,5) = PHKK(5,KK)
15366 IHIST(2,KK) = 10000*IPJE+IP
15367 IF (IHIST(1,KK).LE.-100) THEN
15369 IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
15373 IF (IJ.GT.MXJOIN) STOP 'IJ > MXJOIN !'
15378 * join the two-parton system
15380 CALL PYJOIN(IJ,IJOIN)
15391 * final state parton shower
15393 IF ((MCGENE.EQ.2).AND.(ISH.GE.2)) THEN
15394 IF ((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
15396 IF (ISJOIN(K1).EQ.0) GOTO 130
15398 IF ((IPAMDL(102).EQ.1).AND.(IHIST(1,I).NE.-100))
15400 IH1 = IHIST(2,I)/10000
15401 IF (IH1.NE.NPJE) GOTO 130
15402 IH1 = IHIST(2,I)-IH1*10000
15404 IF (ISJOIN(K2).EQ.0) GOTO 135
15406 IH2 = IHIST(2,II)/10000
15407 IF (IH2.NE.NPJE) GOTO 135
15408 IH2 = IHIST(2,II)-IH2*10000
15409 IF (IHIST(1,I).EQ.IHIST(1,II)) THEN
15410 PT1 = SQRT(PHKK(1,II)**2+PHKK(2,II)**2)
15411 PT2 = SQRT(PHKK(1, I)**2+PHKK(2, I)**2)
15413 RQLUN = MIN(PT1,PT2)
15414 CALL PYSHOW(IH1,IH2,RQLUN)
15426 CALL DT_INITJS(MODE)
15431 IF (MSTU(24).NE.0) THEN
15432 WRITE(LOUT,*) ' JETSET-reject at event',
15433 & NEVHKK,MSTU(24),KMODE
15434 C CALL DT_EVTOUT(4)
15441 * number of entries in LUJETS
15453 IF ((PYK(II,7).EQ.1).AND.(IFLG(II).NE.1)) THEN
15455 * pick up mother resonance if possible and put it together with
15456 * their decay-products into the common
15458 IF ((IDXMOR.GE.1).AND.(IDXMOR.LE.MAXLND)) THEN
15459 KFMOR = K(IDXMOR,2)
15460 ISMOR = K(IDXMOR,1)
15465 IF ((KFMOR.NE.91).AND.(KFMOR.NE.92).AND.
15466 & (KFMOR.NE.94).AND.(ISMOR.EQ.11)) THEN
15468 MO = IHISMO(PYK(IDXMOR,15))
15474 CALL DT_EVTPUT(2,ID,MO,0,PX,PY,PZ,PE,0,0,0)
15477 DO 15 JDAUG=K(IDXMOR,4),K(IDXMOR,5)
15478 IF (PYK(JDAUG,7).EQ.1) THEN
15485 CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
15492 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
15498 * there was no mother resonance
15499 MO = IHISMO(PYK(II,15))
15506 CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
15513 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
15520 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,6,IREJ1)
15521 C IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
15524 * global energy-momentum & flavor conservation check
15525 **sr 16.5. this check is skipped in case of phojet-treatment
15527 & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,12,IREJ3)
15529 * update statistics-counter for diffraction
15530 c IF (IFLAGD.NE.0) THEN
15531 c ICDIFF(1) = ICDIFF(1)+1
15532 c IF (IFLAGD.EQ. 1) ICDIFF(2) = ICDIFF(2)+1
15533 c IF (IFLAGD.EQ. 2) ICDIFF(3) = ICDIFF(3)+1
15534 c IF (IFLAGD.EQ.-1) ICDIFF(4) = ICDIFF(4)+1
15535 c IF (IFLAGD.EQ.-2) ICDIFF(5) = ICDIFF(5)+1
15547 *$ CREATE DT_DECAYS.FOR
15550 *===decay==============================================================*
15552 SUBROUTINE DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
15554 ************************************************************************
15555 * Resonance-decay. *
15556 * This subroutine replaces DDECAY/DECHKK. *
15557 * PIN(4) 4-momentum of resonance (input) *
15558 * IDXIN BAMJET-index of resonance (input) *
15559 * POUT(20,4) 4-momenta of decay-products (output) *
15560 * IDXOUT(20) BAMJET-indices of decay-products (output) *
15561 * NSEC number of secondaries (output) *
15562 * Adopted from the original version DECHKK. *
15563 * This version dated 09.01.95 is written by S. Roesler *
15564 ************************************************************************
15566 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15569 PARAMETER ( LINP = 10 ,
15573 PARAMETER (TINY17=1.0D-17)
15575 * HADRIN: decay channel information
15576 PARAMETER (IDMAX9=602)
15578 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
15580 * particle properties (BAMJET index convention)
15582 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
15583 & IICH(210),IIBAR(210),K1(210),K2(210)
15585 * flags for input different options
15586 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15587 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15588 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15590 DIMENSION PIN(4),PI(20,4),POUT(20,4),IDXOUT(20),
15591 & EF(3),PF(3),PFF(3),IDXSTK(20),IDX(3),
15592 & CODF(3),COFF(3),SIFF(3),DCOS(3),DCOSF(3)
15594 * ISTAB = 1 strong and weak decays
15595 * = 2 strong decays only
15596 * = 3 strong decays, weak decays for charmed particles and tau
15602 * put initial resonance to stack
15604 IDXSTK(NSTK) = IDXIN
15606 PI(NSTK,I) = PIN(I)
15609 * store initial configuration for energy-momentum cons. check
15610 IF (LEMCCK) CALL DT_EVTEMC(PI(NSTK,1),PI(NSTK,2),PI(NSTK,3),
15611 & PI(NSTK,4),1,IDUM,IDUM)
15614 * get particle from stack
15615 IDXI = IDXSTK(NSTK)
15616 * skip stable particles
15617 IF (ISTAB.EQ.1) THEN
15618 IF ((IDXI.EQ.135).OR. (IDXI.EQ.136)) GOTO 10
15619 IF ((IDXI.GE. 1).AND.(IDXI.LE. 7)) GOTO 10
15620 ELSEIF (ISTAB.EQ.2) THEN
15621 IF ((IDXI.GE. 1).AND.(IDXI.LE. 30)) GOTO 10
15622 IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
15623 IF ((IDXI.GE.115).AND.(IDXI.LE.122)) GOTO 10
15624 IF ((IDXI.GE.131).AND.(IDXI.LE.136)) GOTO 10
15625 IF ( IDXI.EQ.109) GOTO 10
15626 IF ((IDXI.GE.137).AND.(IDXI.LE.160)) GOTO 10
15627 ELSEIF (ISTAB.EQ.3) THEN
15628 IF ((IDXI.GE. 1).AND.(IDXI.LE. 23)) GOTO 10
15629 IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
15630 IF ((IDXI.GE.109).AND.(IDXI.LE.115)) GOTO 10
15631 IF ((IDXI.GE.133).AND.(IDXI.LE.136)) GOTO 10
15634 * calculate direction cosines and Lorentz-parameter of decaying part.
15635 PTOT = SQRT(PI(NSTK,1)**2+PI(NSTK,2)**2+PI(NSTK,3)**2)
15636 PTOT = MAX(PTOT,TINY17)
15638 DCOS(I) = PI(NSTK,I)/PTOT
15640 GAM = PI(NSTK,4)/AAM(IDXI)
15641 BGAM = PTOT/AAM(IDXI)
15643 * get decay-channel
15647 IF ((DT_RNDM(GAM)-TINY17).GT.WT(KCHAN)) GOTO 2
15649 * identities of secondaries
15650 IDX(1) = NZK(KCHAN,1)
15651 IDX(2) = NZK(KCHAN,2)
15652 IF (IDX(2).LT.1) GOTO 9999
15653 IDX(3) = NZK(KCHAN,3)
15655 * handle decay in rest system of decaying particle
15656 IF (IDX(3).EQ.0) THEN
15657 * two-particle decay
15659 CALL DT_DTWOPD(AAM(IDXI),EF(1),EF(2),PF(1),PF(2),
15660 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
15661 & AAM(IDX(1)),AAM(IDX(2)))
15663 * three-particle decay
15665 CALL DT_DTHREP(AAM(IDXI),EF(1),EF(2),EF(3),PF(1),PF(2),PF(3),
15666 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
15667 & CODF(3),COFF(3),SIFF(3),
15668 & AAM(IDX(1)),AAM(IDX(2)),AAM(IDX(3)))
15672 * transform decay products back
15675 CALL DT_DTRAFO(GAM,BGAM,DCOS(1),DCOS(2),DCOS(3),
15676 & CODF(I),COFF(I),SIFF(I),PF(I),EF(I),
15677 & PFF(I),DCOSF(1),DCOSF(2),DCOSF(3),PI(NSTK,4))
15678 * add particle to stack
15679 IDXSTK(NSTK) = IDX(I)
15681 PI(NSTK,J) = DCOSF(J)*PFF(I)
15687 * stable particle, put to output-arrays
15690 POUT(NSEC,I) = PI(NSTK,I)
15692 IDXOUT(NSEC) = IDXSTK(NSTK)
15693 * store secondaries for energy-momentum conservation check
15695 &CALL DT_EVTEMC(-POUT(NSEC,1),-POUT(NSEC,2),-POUT(NSEC,3),
15696 & -POUT(NSEC,4),2,IDUM,IDUM)
15698 IF (NSTK.GT.0) GOTO 100
15700 * check energy-momentum conservation
15702 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,5,IREJ1)
15703 IF (IREJ1.NE.0) GOTO 9999
15713 *$ CREATE DT_DECAY1.FOR
15716 *===decay1=============================================================*
15718 SUBROUTINE DT_DECAY1
15720 ************************************************************************
15721 * Decay of resonances stored in DTEVT1. *
15722 * This version dated 20.01.95 is written by S. Roesler *
15723 ************************************************************************
15725 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15728 PARAMETER ( LINP = 10 ,
15734 PARAMETER (NMXHKK=200000)
15736 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15737 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15738 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15740 * extended event history
15741 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15742 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15745 DIMENSION PIN(4),POUT(20,4),IDXOUT(20)
15748 C DO 1 I=NPOINT(5),NEND
15749 DO 1 I=NPOINT(4),NEND
15750 IF (ABS(ISTHKK(I)).EQ.1) THEN
15755 CALL DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
15756 IF (NSEC.GT.1) THEN
15758 IDHAD = IDT_IPDGHA(IDXOUT(N))
15759 CALL DT_EVTPUT(1,IDHAD,I,0,POUT(N,1),POUT(N,2),
15760 & POUT(N,3),POUT(N,4),0,0,0)
15769 *$ CREATE DT_DECPI0.FOR
15772 *===decpi0=============================================================*
15774 SUBROUTINE DT_DECPI0
15776 ************************************************************************
15777 * Decay of pi0 handled with JETSET. *
15778 * This version dated 18.02.96 is written by S. Roesler *
15779 ************************************************************************
15781 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15784 PARAMETER ( LINP = 10 ,
15788 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0,ZERO=0.0D0)
15792 PARAMETER (NMXHKK=200000)
15794 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15795 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15796 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15798 * extended event history
15799 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15800 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15803 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
15804 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15805 PARAMETER (MAXLND=4000)
15806 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
15808 * flags for input different options
15809 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15810 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15811 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15815 DIMENSION IHISMO(NMXHKK),P1(4)
15817 TWOPI = 2.0D0*ATAN2(0.0D0,-1.0D0)
15829 IF ((ISTHKK(I).EQ.1).AND.(IDHKK(I).EQ.111)) THEN
15835 IF (LEMCCK) CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
15836 & PHKK(4,I),INI,IDUM,IDUM)
15837 PT = SQRT(PHKK(1,I)**2+PHKK(2,I)**2)
15838 PTOT = SQRT(PT**2+PHKK(3,I)**2)
15839 COSTH = PHKK(3,I)/(PTOT+TINY10)
15840 IF (COSTH.GT.ONE) THEN
15842 ELSEIF (COSTH.LT.-ONE) THEN
15843 THETA = TWOPI/2.0D0
15845 THETA = ACOS(COSTH)
15847 PHI = ASIN(PHKK(2,I)/(PT +TINY10))
15848 IF (PHKK(1,I).LT.0.0D0)
15850 & PHI = SIGN(TWOPI/2.0D0-ABS(PHI),PHI)
15856 P(NN,5) = PHKK(5,I)
15858 CALL PY1ENT(NN,111,ENER,THETA,PHI)
15872 IF (PYK(II,7).EQ.1) THEN
15876 P1(KK) = PYP(II,KK)
15881 MO = IHISMO(PYK(II,15))
15883 CALL DT_EVTPUT(1,ID,MO,0,P1(1),P1(2),P1(3),P1(4),0,0,0)
15885 & CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,
15887 *sr: flag with neg. sign (for HELIOS p/A-W jobs)
15891 IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,7000,IREJ1)
15898 *$ CREATE DT_DTWOPD.FOR
15901 *===dtwopd=============================================================*
15903 SUBROUTINE DT_DTWOPD(UMO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,COD2,
15904 & COF2,SIF2,AM1,AM2)
15906 ************************************************************************
15907 * Two-particle decay. *
15908 * UMO cm-energy of the decaying system (input) *
15909 * AM1/AM2 masses of the decay products (input) *
15910 * ECM1,ECM2/PCM1,PCM2 cm-energies/momenta of the decay prod. (output) *
15911 * COD,COF,SIF direction cosines of the decay prod. (output) *
15912 * Revised by S. Roesler, 20.11.95 *
15913 ************************************************************************
15915 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15918 PARAMETER ( LINP = 10 ,
15922 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,ZERO=0.0D0)
15924 IF (UMO.LT.(AM1+AM2)) THEN
15925 WRITE(LOUT,1000) UMO,AM1,AM2
15926 1000 FORMAT(1X,'DTWOPD: inconsistent kinematics - UMO,AM1,AM2 ',
15931 ECM1 = ((UMO-AM2)*(UMO+AM2)+AM1*AM1)/(TWO*UMO)
15933 PCM1 = SQRT((ECM1-AM1)*(ECM1+AM1))
15935 CALL DT_DSFECF(SIF1,COF1)
15936 COD1 = TWO*DT_RNDM(PCM2)-ONE
15944 *$ CREATE DT_DTHREP.FOR
15947 *===dthrep=============================================================*
15949 SUBROUTINE DT_DTHREP(UMO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,
15950 & SIF1,COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
15952 ************************************************************************
15953 * Three-particle decay. *
15954 * UMO cm-energy of the decaying system (input) *
15955 * AM1/2/3 masses of the decay products (input) *
15956 * ECM1/2/2,PCM1/2/3 cm-energies/momenta of the decay prod. (output) *
15957 * COD,COF,SIF direction cosines of the decay prod. (output) *
15959 * Threpd89: slight revision by A. Ferrari *
15960 * Last change on 11-oct-93 by Alfredo Ferrari, INFN - Milan *
15961 * Revised by S. Roesler, 20.11.95 *
15962 ************************************************************************
15964 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15967 PARAMETER ( LINP = 10 ,
15971 PARAMETER ( ANGLSQ = 2.5D-31 )
15972 PARAMETER ( AZRZRZ = 1.0D-30 )
15973 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
15974 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
15975 PARAMETER ( ONEONE = 1.D+00 )
15976 PARAMETER ( TWOTWO = 2.D+00 )
15977 PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
15979 COMMON /HNGAMR/ REDU,AMO,AMM(15)
15981 * flags for input different options
15982 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15983 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15984 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15986 DIMENSION F(5),XX(5)
15990 C***S1, S2, S3 ARE THE INVARIANT MASSES OF THE PARTICLES 1, 2, 3
15991 C***J. VON NEUMANN - RANDOM - SELECTION OF S2
15992 C***CALCULATION OF THE MAXIMUM OF THE S2 - DISTRIBUTION
15999 * UFAK=1.0000000000001D0
16000 * IF (GU.GT.GO) UFAK=0.9999999999999D0
16018 S22=GU+(I-1.D0)*DS2
16020 RHO2=DT_YLAMB(S22,UMO2,AM11)*DT_YLAMB(S22,AM22,AM33)/
16022 IF(RHO2.LT.RHO1) GO TO 125
16024 125 S2SUP=(S22-S21)*.5D0+S21
16025 SUPRHO=DT_YLAMB(S2SUP,UMO2,AM11)*DT_YLAMB(S2SUP,AM22,AM33)/
16027 SUPRHO=SUPRHO*1.05D0
16029 IF (GU.LT.GO.AND.XO.LT.GU) XO=GU
16030 IF (GU.GT.GO.AND.XO.GT.GU) XO=GU
16036 F(1)=DT_YLAMB(XO,UMO2,AM11)*DT_YLAMB(XO,AM22,AM33)/(XO+EPS)
16037 F(2)=DT_YLAMB(X1,UMO2,AM11)*DT_YLAMB(X1,AM22,AM33)/(X1+EPS)
16039 X4=(XX(1)+XX(2))*0.5D0
16040 X5=(XX(2)+XX(3))*0.5D0
16041 F(4)=DT_YLAMB(X4,UMO2,AM11)*DT_YLAMB(X4,AM22,AM33)/
16043 F(5)=DT_YLAMB(X5,UMO2,AM11)*DT_YLAMB(X5,AM22,AM33)/
16050 IF (F (II).GE.F (III)) GO TO 128
16063 IF (XX(II).GE.XX(III)) GO TO 129
16077 IF (ITH.GT.200) REDU=-9.D0
16078 IF (ITH.GT.200) GO TO 400
16080 * S2=AM23+C*((UMO-AM1)**2-AM23)
16081 S2=AM23+C*(UMO-AM1-AM2-AM3)*(UMO-AM1+AM2+AM3)
16084 RHO=DT_YLAMB(S2,UMO2,AM11)*DT_YLAMB(S2,AM22,AM33)/S2
16085 IF(Y.GT.RHO) GO TO 1
16086 C***RANDOM SELECTION OF S3 AND CALCULATION OF S1
16088 S1=S1*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)/(2.D0*S2)-
16090 S3=UMO2+AM11+AM22+AM33-S1-S2
16091 ECM1=(UMO2+AM11-S2)/UMOO
16092 ECM2=(UMO2+AM22-S3)/UMOO
16093 ECM3=(UMO2+AM33-S1)/UMOO
16094 PCM1=SQRT((ECM1+AM1)*(ECM1-AM1))
16095 PCM2=SQRT((ECM2+AM2)*(ECM2-AM2))
16096 PCM3=SQRT((ECM3+AM3)*(ECM3-AM3))
16097 CALL DT_DSFECF(SFE,CFE)
16098 C***TH IS THE ANGLE BETWEEN PARTICLES 1 AND 2
16099 C***TH1, TH2 ARE THE ANGLES BETWEEN PARTICLES 1, 2 AND THE DIRECTION OF
16100 PCM12 = PCM1 * PCM2
16101 IF ( PCM12 .LT. ANGLSQ ) GO TO 200
16102 COSTH=(ECM1*ECM2+0.5D+00*(AM11+AM22-S1))/PCM12
16106 COSTH=(UW-0.5D+00)*2.D+00
16108 * IF(ABS(COSTH).GT.0.9999999999999999D0)
16109 * &COSTH=SIGN(0.9999999999999999D0,COSTH)
16110 IF(ABS(COSTH).GT.ONEONE)
16111 &COSTH=SIGN(ONEONE,COSTH)
16112 IF (REDU.LT.1.D+00) RETURN
16113 COSTH2=(PCM3*PCM3+PCM2*PCM2-PCM1*PCM1)/(2.D+00*PCM2*PCM3)
16114 * IF(ABS(COSTH2).GT.0.9999999999999999D0)
16115 * &COSTH2=SIGN(0.9999999999999999D0,COSTH2)
16116 IF(ABS(COSTH2).GT.ONEONE)
16117 &COSTH2=SIGN(ONEONE,COSTH2)
16118 SINTH2=SQRT((ONEONE-COSTH2)*(ONEONE+COSTH2))
16119 SINTH =SQRT((ONEONE-COSTH)*(ONEONE+COSTH))
16120 SINTH1=COSTH2*SINTH-COSTH*SINTH2
16121 COSTH1=COSTH*COSTH2+SINTH2*SINTH
16122 C***RANDOM SELECTION OF THE SPHERICAL COORDINATES OF THE DIRECTION OF PA
16123 C***CFE, SFE ARE COS AND SIN OF THE ROTATION ANGLE OF THE SYSTEM 1, 2 AR
16124 C***THE DIRECTION OF PARTICLE 3
16125 C***CALCULATION OF THE SPHERICAL COORDINATES OF PARTICLES 1, 2
16132 CALL DT_DSFECF(SIF3,COF3)
16133 COD3=TWOTWO*DT_RNDM(CX11)-ONEONE
16134 SID3=SQRT((1.D+00-COD3)*(1.D+00+COD3))
16136 COD1=CX11*COD3+CZ11*SID3
16137 CHLP=(ONEONE-COD1)*(ONEONE+COD1)
16138 IF(CHLP.LT.1.D-14)WRITE(LOUT,2)COD1,COF3,SID3,
16141 COF1=(CX11*SID3*COF3-CY11*SIF3-CZ11*COD3*COF3)/SID1
16142 SIF1=(CX11*SID3*SIF3+CY11*COF3-CZ11*COD3*SIF3)/SID1
16143 COD2=CX22*COD3+CZ22*SID3
16144 SID2=SQRT((ONEONE-COD2)*(ONEONE+COD2))
16145 COF2=(CX22*SID3*COF3-CY22*SIF3-CZ22*COD3*COF3)/SID2
16146 SIF2=(CX22*SID3*SIF3+CY22*COF3-CZ22*COD3*SIF3)/SID2
16148 * === Energy conservation check: === *
16149 EOCHCK = UMO - ECM1 - ECM2 - ECM3
16150 * SID1 = SQRT ( ( ONEONE - COD1 ) * ( ONEONE + COD1 ) )
16151 * SID2 = SQRT ( ( ONEONE - COD2 ) * ( ONEONE + COD2 ) )
16152 * SID3 = SQRT ( ( ONEONE - COD3 ) * ( ONEONE + COD3 ) )
16153 PZCHCK = PCM1 * COD1 + PCM2 * COD2 + PCM3 * COD3
16154 PXCHCK = PCM1 * COF1 * SID1 + PCM2 * COF2 * SID2
16155 & + PCM3 * COF3 * SID3
16156 PYCHCK = PCM1 * SIF1 * SID1 + PCM2 * SIF2 * SID2
16157 & + PCM3 * SIF3 * SID3
16158 EOCMPR = 1.D-12 * UMO
16159 IF ( ABS (EOCHCK) + ABS (PXCHCK) + ABS (PYCHCK) + ABS (PZCHCK)
16160 & .GT. EOCMPR ) THEN
16161 **sr 5.5.95 output-unit changed
16162 IF (IOULEV(1).GT.0) THEN
16164 & ' *** Threpd: energy/momentum conservation failure! ***',
16165 & EOCHCK,PXCHCK,PYCHCK,PZCHCK
16166 WRITE(LOUT,*)' *** SID1,SID2,SID3',SID1,SID2,SID3
16173 *$ CREATE DT_DBKLAS.FOR
16176 *===dbklas=============================================================*
16178 SUBROUTINE DT_DBKLAS(I,J,K,I8,I10)
16180 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16183 PARAMETER ( LINP = 10 ,
16187 * quark-content to particle index conversion (DTUNUC 1.x)
16188 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
16189 & IA08(6,21),IA10(6,21)
16194 CALL DT_INDEXD(J,K,IND)
16197 IF (I8.LE.0) I8 = I10
16204 CALL DT_INDEXD(JJ,KK,IND)
16207 IF (I8.LE.0) I8 = I10
16212 *$ CREATE DT_INDEXD.FOR
16215 *===indexd=============================================================*
16217 SUBROUTINE DT_INDEXD(KA,KB,IND)
16219 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16222 PARAMETER ( LINP = 10 ,
16231 IF ((KP.EQ.4).AND.(KS.EQ.5)) IND=4
16233 IF ((KP.EQ.6).AND.(KS.EQ.7)) IND=6
16234 IF ((KP.EQ.4).AND.(KS.EQ.4)) IND=7
16235 IF ((KP.EQ.6).AND.(KS.EQ.5)) IND=8
16237 IF (KP.EQ.10) IND=10
16238 IF ((KP.EQ.12).AND.(KS.EQ.8)) IND=11
16239 IF (KP.EQ.9) IND=12
16240 IF ((KP.EQ.12).AND.(KS.EQ.7)) IND=13
16241 IF (KP.EQ.15) IND=14
16242 IF (KP.EQ.18) IND=15
16243 IF (KP.EQ.16) IND=16
16244 IF (KP.EQ.20) IND=17
16245 IF (KP.EQ.24) IND=18
16246 IF (KP.EQ.25) IND=19
16247 IF (KP.EQ.30) IND=20
16248 IF (KP.EQ.36) IND=21
16253 *$ CREATE DT_DCHANT.FOR
16256 *===dchant=============================================================*
16258 SUBROUTINE DT_DCHANT
16260 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16263 PARAMETER ( LINP = 10 ,
16267 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
16269 * HADRIN: decay channel information
16270 PARAMETER (IDMAX9=602)
16272 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
16274 * particle properties (BAMJET index convention)
16276 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
16277 & IICH(210),IIBAR(210),K1(210),K2(210)
16279 DIMENSION HWT(IDMAX9)
16281 * change of weights wt from absolut values into the sum of wt of a dec.
16286 C WRITE(LOUT,'(A8,F5.2,2E10.3,2I4,2I10)')
16287 C & ANAME(KKK),AAM(KKK),GA(KKK),TAU(KKK),IICH(KKK),IIBAR(KKK),
16288 C & K1(KKK),K2(KKK)
16299 IF (HWT(J).GT.1.0001) WRITE(LOUT,1000) HWT(J),J,I,IK1
16300 1000 FORMAT(2X,15H ERROR IN HWT =,1F10.5,8H J,I,K1=,3I5)
16310 *$ CREATE DT_DDATAR.FOR
16313 *===ddatar=============================================================*
16315 SUBROUTINE DT_DDATAR
16317 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16320 PARAMETER ( LINP = 10 ,
16324 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
16326 * quark-content to particle index conversion (DTUNUC 1.x)
16327 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
16328 & IA08(6,21),IA10(6,21)
16330 DIMENSION IV(36),IP(36),IB(126),IBB(126),IA(126),IAA(126)
16332 DATA IV/ 33, 34, 38,123, 0, 0, 32, 33, 39,124,
16333 & 0, 0, 36, 37, 96,127, 0, 0,126,125,
16335 DATA IP/ 23, 14, 16,116, 0, 0, 13, 23, 25,117,
16336 & 0, 0, 15, 24, 31,120, 0, 0,119,118,
16338 DATA IB/ 0, 1, 21,140, 0, 0, 8, 22,137, 0,
16339 & 0, 97,138, 0, 0,146, 0, 0, 0, 0,
16340 & 0, 1, 8, 22,137, 0, 0, 0, 20,142,
16341 & 0, 0, 98,139, 0, 0,147, 0, 0, 0,
16342 & 0, 0, 21, 22, 97,138, 0, 0, 20, 98,
16343 & 139, 0, 0, 0,145, 0, 0,148, 0, 0,
16344 & 0, 0, 0,140,137,138,146, 0, 0,142,
16345 & 139,147, 0, 0,145,148, 50*0/
16346 DATA IBB/53, 54,104,161, 0, 0, 55,105,162, 0,
16347 & 0,107,164, 0, 0,167, 0, 0, 0, 0,
16348 & 0, 54, 55,105,162, 0, 0, 56,106,163,
16349 & 0, 0,108,165, 0, 0,168, 0, 0, 0,
16350 & 0, 0,104,105,107,164, 0, 0,106,108,
16351 & 165, 0, 0,109,166, 0, 0,169, 0, 0,
16352 & 0, 0, 0,161,162,164,167, 0, 0,163,
16353 & 165,168, 0, 0,166,169, 0, 0,170,47*0/
16354 DATA IA/ 0, 2, 99,152, 0, 0, 9,100,149, 0,
16355 & 0,102,150, 0, 0,158, 0, 0, 0, 0,
16356 & 0, 2, 9,100,149, 0, 0, 0,101,154,
16357 & 0, 0,103,151, 0, 0,159, 0, 0, 0,
16358 & 0, 0, 99,100,102,150, 0, 0,101,103,
16359 & 151, 0, 0, 0,157, 0, 0,160, 0, 0,
16360 & 0, 0, 0,152,149,150,158, 0, 0,154,
16361 & 151,159, 0, 0,157,160, 50*0/
16362 DATA IAA/67, 68,110,171, 0, 0, 69,111,172, 0,
16363 & 0,113,174, 0, 0,177, 0, 0, 0, 0,
16364 & 0, 68, 69,111,172, 0, 0, 70,112,173,
16365 & 0, 0,114,175, 0, 0,178, 0, 0, 0,
16366 & 0, 0,110,111,113,174, 0, 0,112,114,
16367 & 175, 0, 0,115,176, 0, 0,179, 0, 0,
16368 & 0, 0, 0,171,172,174,177, 0, 0,173,
16369 & 175,178, 0, 0,176,179, 0, 0,180,47*0/
16405 *$ CREATE DT_INITJS.FOR
16408 *===initjs=============================================================*
16410 SUBROUTINE DT_INITJS(MODE)
16412 ************************************************************************
16413 * Initialize JETSET paramters. *
16414 * MODE = 0 default settings *
16415 * = 1 PHOJET settings *
16416 * = 2 DTUNUC settings *
16417 * This version dated 16.02.96 is written by S. Roesler *
16419 * Last change 27.12.2006 by S. Roesler. *
16420 ************************************************************************
16422 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16425 PARAMETER ( LINP = 10 ,
16429 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
16431 LOGICAL LFIRST,LFIRDT,LFIRPH
16433 * INCLUDE '(DIMPAR)'
16434 * DIMPAR taken from FLUKA
16435 PARAMETER ( MXXRGN =20000 )
16436 PARAMETER ( MXXMDF = 710 )
16437 PARAMETER ( MXXMDE = 702 )
16438 PARAMETER ( MFSTCK =40000 )
16439 PARAMETER ( MESTCK = 100 )
16440 PARAMETER ( MOSTCK = 2000 )
16441 PARAMETER ( MXPRSN = 100 )
16442 PARAMETER ( MXPDPM = 800 )
16443 PARAMETER ( MXPSCS =30000 )
16444 PARAMETER ( MXGLWN = 300 )
16445 PARAMETER ( MXOUTU = 50 )
16446 PARAMETER ( NALLWP = 64 )
16447 PARAMETER ( NELEMX = 80 )
16448 PARAMETER ( MPDPDX = 18 )
16449 PARAMETER ( MXHTTR = 260 )
16450 PARAMETER ( MXSEAX = 20 )
16451 PARAMETER ( MXHTNC = MXSEAX + 1 )
16452 PARAMETER ( ICOMAX = 2400 )
16453 PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
16454 PARAMETER ( NSTBIS = 304 )
16455 PARAMETER ( NQSTIS = 46 )
16456 PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
16457 PARAMETER ( MXPABL = 120 )
16458 PARAMETER ( IDMAXP = 450 )
16459 PARAMETER ( IDMXDC = 2000 )
16460 PARAMETER ( MXMCIN = 410 )
16461 PARAMETER ( IHYPMX = 4 )
16462 PARAMETER ( MKBMX1 = 11 )
16463 PARAMETER ( MKBMX2 = 11 )
16464 PARAMETER ( MXIRRD = 2500 )
16465 PARAMETER ( MXTRDC = 1500 )
16466 PARAMETER ( NKTL = 17 )
16467 PARAMETER ( NBLNMX = 40000000 )
16470 * PART taken from FLUKA
16471 PARAMETER ( KPETA0 = 31 )
16472 PARAMETER ( KPRHOP = 32 )
16473 PARAMETER ( KPRHO0 = 33 )
16474 PARAMETER ( KPRHOM = 34 )
16475 PARAMETER ( KPOME0 = 35 )
16476 PARAMETER ( KPPHI0 = 96 )
16477 PARAMETER ( KPDEPP = 53 )
16478 PARAMETER ( KPDELP = 54 )
16479 PARAMETER ( KPDEL0 = 55 )
16480 PARAMETER ( KPDELM = 56 )
16481 PARAMETER ( KPN14P = 91 )
16482 PARAMETER ( KPN140 = 92 )
16483 * Low mass diffraction partners:
16484 PARAMETER ( KDETA0 = 0 )
16485 PARAMETER ( KDRHOP = 0 )
16486 PARAMETER ( KDRHO0 = 210 )
16487 PARAMETER ( KDRHOM = 0 )
16488 PARAMETER ( KDOME0 = 210 )
16489 PARAMETER ( KDPHI0 = 210 )
16490 PARAMETER ( KDDEPP = 0 )
16491 PARAMETER ( KDDELP = 0 )
16492 PARAMETER ( KDDEL0 = 0 )
16493 PARAMETER ( KDDELM = 0 )
16494 PARAMETER ( KDN14P = 0 )
16495 PARAMETER ( KDN140 = 0 )
16498 COMMON / PART / AM (-6:IDMAXP), GA (-6:IDMAXP),
16499 & TAU (-6:IDMAXP), AMDISC (-6:IDMAXP),
16500 & ZMNABS (-6:IDMAXP), ATNMNA (-6:IDMAXP),
16501 & ATXN14, ATMN14, RNRN14 (-10:10),
16502 & ICH (-6:IDMAXP), IBAR (-6:IDMAXP),
16503 & ISOSYM (-6:IDMAXP), ICHCON (-6:IDMAXP),
16504 & K1 (-6:IDMAXP), K2 (-6:IDMAXP),
16505 & KPTOIP (-6:IDMAXP), IPTOKP (-6:NALLWP),
16506 & KPTOIA (-6:IDMAXP), IATOKP (-6:MXPABL),
16507 & IDCFLG (-6:NALLWP), IPTYPE (-6:NALLWP)
16509 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16510 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
16511 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
16513 * flags for particle decays
16514 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
16515 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
16516 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
16518 * flags for input different options
16519 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16520 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16521 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16525 DIMENSION IDXSTA(40)
16527 * K0s pi0 lam alam sig+ asig+ sig- asig- tet0 atet0
16528 & / 310, 111, 3122,-3122, 3222,-3222, 3112,-3112, 3322,-3322,
16529 * tet- atet- om- aom- D+ D- D0 aD0 Ds+ aDs+
16530 & 3312,-3312, 3334,-3334, 411, -411, 421, -421, 431, -431,
16531 * etac lamc+alamc+sigc++ sigc+ sigc0asigc++asigc+asigc0 Ksic+
16532 & 441, 4122,-4122, 4222, 4212, 4112,-4222,-4212,-4112, 4232,
16533 * Ksic0 aKsic+aKsic0 sig0 asig0
16534 & 4132,-4232,-4132, 3212,-3212, 5*0/
16536 DATA LFIRST,LFIRDT,LFIRPH /.TRUE.,.TRUE.,.TRUE./
16539 * save default settings
16551 * LUJETS / PYJETS array-dimensions
16555 * increase maximum number of JETSET-error prints
16557 * prevent particles decaying
16561 KC = PYCOMP(IDXSTA(I))
16569 C ELSEIF ((I.EQ.4).OR.(I.EQ. 6).OR.
16570 C & (I.EQ.8).OR.(I.EQ.10)) THEN
16571 C ELSEIF (I.EQ.4) THEN
16578 ELSEIF (((I.EQ.34).OR.(I.EQ.35)).AND.(ISIG0.EQ.0)) THEN
16580 KC = PYCOMP(IDXSTA(I))
16589 * as Fluka event-generator: allow only paprop particles to be stable
16590 * and let all other particles decay (i.e. those with strong decays)
16591 IF (ITRSPT.EQ.1) THEN
16593 IF (KPTOIP(I).NE.0) THEN
16599 IF (MDCY(KC,1).EQ.1) THEN
16601 & ' DT_INITJS: Decay flag for FLUKA-',
16602 & 'transport : particle should not ',
16603 & 'decay : ',IDPDG,' ',ANAME(I)
16613 IF ((MDCY(KC,1).EQ.0).AND.(KPTOIP(KP).EQ.0).AND.
16614 & (ANAME(KP).NE.'BLANK ').AND.
16615 & (ANAME(KP).NE.'RNDFLV ')) THEN
16616 WRITE(LOUT,*) ' DT_INITJS: Decay flag for FLUKA-',
16617 & 'transport: particle should decay ',
16618 & ': ',IDPDG,' ',ANAME(KP)
16627 IF (PDB.LE.ZERO) THEN
16628 * no popcorn-mechanism
16634 * set JETSET-parameter requested by input cards
16635 IF (NMSTU.GT.0) THEN
16637 MSTU(IMSTU(I)) = MSTUX(I)
16640 IF (NMSTJ.GT.0) THEN
16642 MSTJ(IMSTJ(I)) = MSTJX(I)
16645 IF (NPARU.GT.0) THEN
16647 PARU(IPARU(I)) = PARUX(I)
16653 * PARJ(1) suppression of qq-aqaq pair prod. compared to
16654 * q-aq pair prod. (default: 0.1)
16655 * PARJ(2) strangeness suppression (default: 0.3)
16656 * PARJ(3) extra suppression of strange diquarks (default: 0.4)
16657 * PARJ(6) extra suppression of sas-pair shared by B and
16658 * aB in BMaB (default: 0.5)
16659 * PARJ(7) extra suppression of strange meson M in BMaB
16660 * configuration (default: 0.5)
16661 * PARJ(18) spin 3/2 baryon suppression (default: 1.0)
16662 * PARJ(21) width sigma in Gaussian p_x, p_y transverse
16663 * momentum distrib. for prim. hadrons (default: 0.35)
16664 * PARJ(42) b-parameter for symmetric Lund-fragmentation
16665 * function (default: 0.9 GeV^-2)
16668 IF (MODE.EQ.1) THEN
16675 C PARJ(18) = PDEF18
16676 C PARJ(21) = PDEF21
16677 C PARJ(42) = PDEF42
16678 **sr 18.11.98 parameter tuning
16679 C PARJ(1) = 0.092D0
16683 C PARJ(21) = 0.45D0
16685 **sr 28.04.99 parameter tuning (May 99 minor modifications)
16695 IF (NPARJ.GT.0) THEN
16697 IF (IPARJ(I).GT.0) PARJ(IPARJ(I)) = PARJX(I)
16701 WRITE(LOUT,'(1X,A)')
16702 & 'DT_INITJS: JETSET-parameter for PHOJET'
16707 ELSEIF (MODE.EQ.2) THEN
16708 IF (IFRAG(2).EQ.1) THEN
16709 **sr parameters before 9.3.96
16714 C PARJ(21) = 0.55D0
16716 **sr 18.11.98 parameter tuning
16721 C PARJ(21) = 0.45D0
16723 **sr 28.04.99 parameter tuning
16731 IF (NPARJ.GT.0) THEN
16733 IF (IPARJ(I).LT.0) THEN
16734 IDX = ABS(IPARJ(I))
16735 PARJ(IDX) = PARJX(I)
16740 WRITE(LOUT,'(1X,A)')
16741 & 'DT_INITJS: JETSET-parameter for DTUNUC'
16745 ELSEIF (IFRAG(2).EQ.2) THEN
16752 C PARJ(21) = 0.55D0
16783 *$ CREATE DT_JSPARA.FOR
16786 *===jspara=============================================================*
16788 SUBROUTINE DT_JSPARA(MODE)
16790 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16793 PARAMETER ( LINP = 10 ,
16797 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1,
16798 & ONE=1.0D0,ZERO=0.0D0)
16802 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16804 DIMENSION ISTU(200),QARU(200),ISTJ(200),QARJ(200)
16806 DATA LFIRST /.TRUE./
16808 * save the default JETSET-parameter on the first call
16820 1000 FORMAT(1X,'DT_JSPARA: new value (default value)')
16822 * compare the default JETSET-parameter with the present values
16824 IF ((MSTU(I).NE.ISTU(I)).AND.(I.NE.31)) THEN
16825 WRITE(LOUT,1002) 'MSTU(',I,MSTU(I),ISTU(I)
16826 C ISTU(I) = MSTU(I)
16828 DIFF = ABS(PARU(I)-QARU(I))
16829 IF ((DIFF.GE.1.0D-5).AND.(I.NE.21)) THEN
16830 WRITE(LOUT,1001) 'PARU(',I,PARU(I),QARU(I)
16831 C QARU(I) = PARU(I)
16833 IF (MSTJ(I).NE.ISTJ(I)) THEN
16834 WRITE(LOUT,1002) 'MSTJ(',I,MSTJ(I),ISTJ(I)
16835 C ISTJ(I) = MSTJ(I)
16837 DIFF = ABS(PARJ(I)-QARJ(I))
16838 IF (DIFF.GE.1.0D-5) THEN
16839 WRITE(LOUT,1001) 'PARJ(',I,PARJ(I),QARJ(I)
16840 C QARJ(I) = PARJ(I)
16843 1001 FORMAT(12X,A5,I3,'): ',F6.3,' (',F6.3,')')
16844 1002 FORMAT(12X,A5,I3,'): ',I6,' (',I6,')')
16848 *$ CREATE DT_FOZOCA.FOR
16851 *===fozoca=============================================================*
16853 SUBROUTINE DT_FOZOCA(LFZC,IREJ)
16855 ************************************************************************
16856 * This subroutine treats the complete FOrmation ZOne supressed intra- *
16857 * nuclear CAscade. *
16858 * LFZC = .true. cascade has been treated *
16859 * = .false. cascade skipped *
16860 * This is a completely revised version of the original FOZOKL. *
16861 * This version dated 18.11.95 is written by S. Roesler *
16862 ************************************************************************
16864 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16867 PARAMETER ( LINP = 10 ,
16871 PARAMETER (DLARGE=1.0D10,OHALF=0.5D0,ZERO=0.0D0)
16872 PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16874 LOGICAL LSTART,LCAS,LFZC
16878 PARAMETER (NMXHKK=200000)
16880 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16881 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16882 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16884 * extended event history
16885 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16886 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16889 * rejection counter
16890 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
16891 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
16892 & IREXCI(3),IRDIFF(2),IRINC
16894 * properties of interacting particles
16895 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
16897 * Glauber formalism: collision properties
16898 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
16899 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
16901 * flags for input different options
16902 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16903 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16904 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16906 * final state after intranuclear cascade step
16907 COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16909 * parameter for intranuclear cascade
16911 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16913 DIMENSION NCWOUN(2)
16915 DATA LSTART /.TRUE./
16920 * skip cascade if hadron-hadron interaction or if supressed by user
16921 IF (((IP.EQ.1).AND.(IT.EQ.1)).OR.(KTAUGE.LT.1)) GOTO 9999
16922 * skip cascade if not all possible chains systems are hadronized
16924 IF (.NOT.LHADRO(I)) GOTO 9999
16928 WRITE(LOUT,1000) KTAUGE,TAUFOR,INCMOD
16929 1000 FORMAT(/,1X,'FOZOCA: intranuclear cascade treated for a ',
16930 & 'maximum of',I4,' generations',/,10X,'formation time ',
16931 & 'parameter:',F5.1,' fm/c',9X,'modus:',I2)
16932 IF (ITAUVE.EQ.1) WRITE(LOUT,1001)
16933 IF (ITAUVE.EQ.2) WRITE(LOUT,1002)
16934 1001 FORMAT(10X,'p_t dependent formation zone',/)
16935 1002 FORMAT(10X,'constant formation zone',/)
16939 * in order to avoid wasting of cpu-time the DTEVT1-indices of nucleons
16940 * which may interact with final state particles are stored in a seperate
16941 * array - here all proj./target nucleon-indices (just for simplicity)
16943 DO 9 I=1,NPOINT(1)-1
16948 * initialize Pauli-principle treatment (find wounded nucleons)
16955 IF (ISTHKK(J).EQ.10+I) THEN
16956 NWOUND(I) = NWOUND(I)+1
16957 EWOUND(I,NWOUND(I)) = PHKK(4,J)
16958 IF (IDHKK(J).EQ.2212) NCWOUN(I) = NCWOUN(I)+1
16963 * modify nuclear potential for wounded nucleons
16964 IPRCL = IP -NWOUND(1)
16965 IPZRCL = IPZ-NCWOUN(1)
16966 ITRCL = IT -NWOUND(2)
16967 ITZRCL = ITZ-NCWOUN(2)
16968 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
16976 IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDCH(I).LT.KTAUGE)) THEN
16977 * select nucleus the cascade starts first (proj. - 1, target - -1)
16979 * projectile/target with probab. 1/2
16980 IF ((INCMOD.EQ.1).OR.(IDCH(I).GT.0)) THEN
16981 IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16982 * in the nucleus with highest mass
16983 ELSEIF (INCMOD.EQ.2) THEN
16986 ELSEIF (IP.EQ.IT) THEN
16987 IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16989 * the nucleus the cascade starts first is requested to be the one
16990 * moving in the direction of the secondary
16991 ELSEIF (INCMOD.EQ.3) THEN
16992 NCAS = INT(SIGN(1.0D0,PHKK(3,I)))
16994 * check that the selected "nucleus" is not a hadron
16995 IF (((NCAS.EQ. 1).AND.(IP.LE.1)).OR.
16996 & ((NCAS.EQ.-1).AND.(IT.LE.1))) NCAS = -NCAS
16998 * treat intranuclear cascade in the nucleus selected first
17000 CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
17001 IF (IREJ1.NE.0) GOTO 9998
17002 * treat intranuclear cascade in the other nucleus if this isn't a had.
17004 IF (((NCAS.EQ. 1).AND.(IP.GT.1)).OR.
17005 & ((NCAS.EQ.-1).AND.(IT.GT.1))) THEN
17006 IF (LCAS) CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
17007 IF (IREJ1.NE.0) GOTO 9998
17015 IF (NSTART.LE.NEND) GOTO 7
17020 * reject this event
17025 * intranucl. cascade not treated because of interaction properties or
17026 * it is supressed by user or it was rejected or...
17028 * reset flag characterizing direction of motion in n-n-cms
17030 C DO 9990 I=NPOINT(5),NHKK
17031 C IF (ISTHKK(I).EQ.-1) ISTHKK(I)=1
17037 *$ CREATE DT_INUCAS.FOR
17040 *===inucas=============================================================*
17042 SUBROUTINE DT_INUCAS(IT,IP,IDXCAS,LCAS,NCAS,IREJ)
17044 ************************************************************************
17045 * Formation zone supressed IntraNUclear CAScade for one final state *
17047 * IT, IP mass numbers of target, projectile nuclei *
17048 * IDXCAS index of final state particle in DTEVT1 *
17049 * NCAS = 1 intranuclear cascade in projectile *
17050 * = -1 intranuclear cascade in target *
17051 * This version dated 18.11.95 is written by S. Roesler *
17052 ************************************************************************
17054 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17057 PARAMETER ( LINP = 10 ,
17061 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
17062 & OHALF=0.5D0,ONE=1.0D0)
17063 PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
17064 PARAMETER (TWOPI=6.283185307179586454D+00)
17065 PARAMETER (PLOWH=0.01D0,PHIH=9.0D0)
17067 LOGICAL LABSOR,LCAS
17071 PARAMETER (NMXHKK=200000)
17073 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17074 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17075 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17077 * extended event history
17078 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17079 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17082 * final state after inc step
17083 PARAMETER (MAXFSP=10)
17084 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17086 * flags for input different options
17087 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17088 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17089 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17091 * particle properties (BAMJET index convention)
17093 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17094 & IICH(210),IIBAR(210),K1(210),K2(210)
17096 * Glauber formalism: collision properties
17097 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
17098 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
17100 * nuclear potential
17102 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17103 & EBINDP(2),EBINDN(2),EPOT(2,210),
17104 & ETACOU(2),ICOUL,LFERMI
17106 * parameter for intranuclear cascade
17108 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
17110 * final state after intranuclear cascade step
17111 COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
17113 * nucleon-nucleon event-generator
17116 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
17118 * statistics: residual nuclei
17119 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
17120 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
17121 & NINCST(2,4),NINCEV(2),
17122 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
17123 & NRESPB(2),NRESCH(2),NRESEV(4),
17124 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
17127 DIMENSION PCAS(2,5),PTOCAS(2),COSCAS(2,3),VTXCAS(2,4),VTXCA1(2,4),
17128 & PCAS1(5),PNUC(5),BGTA(4),
17129 & BGCAS(2),GACAS(2),BECAS(2),
17130 & RNUC(2),BIMPC(2),VTXDST(3),IDXSPE(2),IDSPE(2),NWTMP(2)
17132 DATA PDIF /0.545D0/
17137 IF (NINCEV(1).NE.NEVHKK) THEN
17139 NINCEV(2) = NINCEV(2)+1
17142 * "BAMJET-index" of this hadron
17143 IDCAS = IDBAM(IDXCAS)
17144 IF (IDT_MCHAD(IDCAS).EQ.-1) RETURN
17146 * skip gammas, electrons, etc..
17147 IF (AAM(IDCAS).LT.TINY2) RETURN
17149 * Lorentz-trsf. into projectile rest system
17151 CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
17152 & PHKK(4,IDXCAS),PCAS(1,1),PCAS(1,2),PCAS(1,3),
17153 & PCAS(1,4),IDCAS,-2)
17154 PTOCAS(1) = SQRT(PCAS(1,1)**2+PCAS(1,2)**2+PCAS(1,3)**2)
17155 PCAS(1,5) = (PCAS(1,4)-PTOCAS(1))*(PCAS(1,4)+PTOCAS(1))
17156 IF (PCAS(1,5).GT.ZERO) THEN
17157 PCAS(1,5) = SQRT(PCAS(1,5))
17159 PCAS(1,5) = AAM(IDCAS)
17162 COSCAS(1,K) = PCAS(1,K)/MAX(PTOCAS(1),TINY10)
17164 * Lorentz-parameters
17165 * particle rest system --> projectile rest system
17166 BGCAS(1) = PTOCAS(1)/MAX(PCAS(1,5),TINY10)
17167 GACAS(1) = PCAS(1,4)/MAX(PCAS(1,5),TINY10)
17168 BECAS(1) = BGCAS(1)/GACAS(1)
17172 IF (K.LE.3) COSCAS(1,K) = ZERO
17179 * Lorentz-trsf. into target rest system
17181 * LEPTO: final state particles are already in target rest frame
17182 C IF (MCGENE.EQ.3) THEN
17183 C PCAS(2,1) = PHKK(1,IDXCAS)
17184 C PCAS(2,2) = PHKK(2,IDXCAS)
17185 C PCAS(2,3) = PHKK(3,IDXCAS)
17186 C PCAS(2,4) = PHKK(4,IDXCAS)
17188 CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
17189 & PHKK(4,IDXCAS),PCAS(2,1),PCAS(2,2),PCAS(2,3),
17190 & PCAS(2,4),IDCAS,-3)
17192 PTOCAS(2) = SQRT(PCAS(2,1)**2+PCAS(2,2)**2+PCAS(2,3)**2)
17193 PCAS(2,5) = (PCAS(2,4)-PTOCAS(2))*(PCAS(2,4)+PTOCAS(2))
17194 IF (PCAS(2,5).GT.ZERO) THEN
17195 PCAS(2,5) = SQRT(PCAS(2,5))
17197 PCAS(2,5) = AAM(IDCAS)
17200 COSCAS(2,K) = PCAS(2,K)/MAX(PTOCAS(2),TINY10)
17202 * Lorentz-parameters
17203 * particle rest system --> target rest system
17204 BGCAS(2) = PTOCAS(2)/MAX(PCAS(2,5),TINY10)
17205 GACAS(2) = PCAS(2,4)/MAX(PCAS(2,5),TINY10)
17206 BECAS(2) = BGCAS(2)/GACAS(2)
17210 IF (K.LE.3) COSCAS(2,K) = ZERO
17218 * radii of nuclei (mm) modified by the wall-depth of the Woods-Saxon-
17219 * potential (see CONUCL)
17220 RNUC(1) = (RPROJ+4.605D0*PDIF)*FM2MM
17221 RNUC(2) = (RTARG+4.605D0*PDIF)*FM2MM
17222 * impact parameter (the projectile moving along z)
17224 BIMPC(2) = BIMPAC*FM2MM
17226 * get position of initial hadron in projectile/target rest-syst.
17228 VTXCAS(1,K) = WHKK(K,IDXCAS)
17229 VTXCAS(2,K) = VHKK(K,IDXCAS)
17234 IF (NCAS.EQ.-1) THEN
17239 IF (PTOCAS(ICAS).LT.TINY10) THEN
17240 WRITE(LOUT,1000) PTOCAS
17241 1000 FORMAT(1X,'INUCAS: warning! zero momentum of initial',
17242 & ' hadron ',/,20X,2E12.4)
17246 * reset spectator flags
17253 * formation length (in fm)
17257 DEL0 = TAUFOR*BGCAS(ICAS)
17258 IF (ITAUVE.EQ.1) THEN
17259 AMT = PCAS(ICAS,1)**2+PCAS(ICAS,2)**2+PCAS(ICAS,5)**2
17260 DEL0 = DEL0*PCAS(ICAS,5)**2/AMT
17263 * sample from exp(-del/del0)
17264 DEL1 = -DEL0*LOG(MAX(DT_RNDM(DEL0),TINY10))
17265 * save formation time
17266 TAUSA1 = DEL1/BGCAS(ICAS)
17267 REL1 = TAUSA1*BGCAS(I2)
17270 TAUSAM = DEL/BGCAS(ICAS)
17271 REL = TAUSAM*BGCAS(I2)
17273 * special treatment for negative particles unable to escape
17274 * nuclear potential (implemented for ap, pi-, K- only)
17276 IF ((IICH(IDCAS).EQ.-1).AND.(IDCAS.LT.20)) THEN
17277 * threshold energy = nuclear potential + Coulomb potential
17278 * (nuclear potential for hadron-nucleus interactions only)
17279 ETHR = AAM(IDCAS)+EPOT(ICAS,IDCAS)+ETACOU(ICAS)
17280 IF (PCAS(ICAS,4).LT.ETHR) THEN
17282 PCAS1(K) = PCAS(ICAS,K)
17284 * "absorb" negative particle in nucleus
17285 CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,0,IREJ1)
17286 IF (IREJ1.NE.0) GOTO 9999
17287 IF (NSPE.GE.1) LABSOR = .TRUE.
17291 * if the initial particle has not been absorbed proceed with
17293 IF (.NOT.LABSOR) THEN
17295 * calculate coordinates of hadron at the end of the formation zone
17296 * transport-time and -step in the rest system where this step is
17299 DTIME = DSTEP/BECAS(ICAS)
17301 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17302 RTIME = RSTEP/BECAS(I2)
17306 * save step whithout considering the overlapping region
17307 DSTEP1 = DEL1*FM2MM
17308 DTIME1 = DSTEP1/BECAS(ICAS)
17309 RSTEP1 = REL1*FM2MM
17310 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17311 RTIME1 = RSTEP1/BECAS(I2)
17315 * transport to the end of the formation zone in this system
17317 VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+DSTEP1*COSCAS(ICAS,K)
17318 VTXCA1(I2,K) = VTXCAS(I2,K) +RSTEP1*COSCAS(I2,K)
17319 VTXCAS(ICAS,K) = VTXCAS(ICAS,K)+DSTEP*COSCAS(ICAS,K)
17320 VTXCAS(I2,K) = VTXCAS(I2,K) +RSTEP*COSCAS(I2,K)
17322 VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME1
17323 VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME1
17324 VTXCAS(ICAS,4) = VTXCAS(ICAS,4)+DTIME
17325 VTXCAS(I2,4) = VTXCAS(I2,4) +RTIME
17327 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17328 XCAS = VTXCAS(ICAS,1)
17329 YCAS = VTXCAS(ICAS,2)
17330 XNCLTA = BIMPAC*FM2MM
17331 RNCLPR = (RPROJ+RNUCLE)*FM2MM
17332 RNCLTA = (RTARG+RNUCLE)*FM2MM
17333 C RNCLPR = (RPROJ+1.605D0*PDIF)*FM2MM
17334 C RNCLTA = (RTARG+1.605D0*PDIF)*FM2MM
17335 C RNCLPR = (RPROJ)*FM2MM
17336 C RNCLTA = (RTARG)*FM2MM
17337 RCASPR = SQRT( XCAS**2 +YCAS**2)
17338 RCASTA = SQRT((XCAS-XNCLTA)**2+YCAS**2)
17339 IF ((RCASPR.LT.RNCLPR).AND.(RCASTA.LT.RNCLTA)) THEN
17340 IF (IDCH(IDXCAS).EQ.0) NOBAM(IDXCAS) = 3
17344 * check if particle is already outside of the corresp. nucleus
17345 RDIST = SQRT((VTXCAS(ICAS,1)-BIMPC(ICAS))**2+
17346 & VTXCAS(ICAS,2)**2+VTXCAS(ICAS,3)**2)
17347 IF (RDIST.GE.RNUC(ICAS)) THEN
17348 * here: IDCH is the generation of the final state part. starting
17349 * with zero for hadronization products
17350 * flag particles of generation 0 being outside the nuclei after
17351 * formation time (to be used for excitation energy calculation)
17352 IF ((IDCH(IDXCAS).EQ.0).AND.(NOBAM(IDXCAS).LT.3))
17353 & NOBAM(IDXCAS) = NOBAM(IDXCAS)+ICAS
17362 * already here: skip particles being outside HADRIN "energy-window"
17363 * to avoid wasting of time
17364 NINCHR(ICAS,1) = NINCHR(ICAS,1)+1
17365 IF ((PTOCAS(ICAS).LE.PLOWH).OR.(PTOCAS(ICAS).GE.PHIH)) THEN
17366 NINCHR(ICAS,2) = NINCHR(ICAS,2)+1
17367 C WRITE(LOUT,1002) IDXCAS,IDCAS,ICAS,PTOCAS(ICAS),NEVHKK
17368 C1002 FORMAT(1X,'INUCAS: warning! momentum of particle with ',
17369 C & 'index ',I5,' (id: ',I3,') ',I3,/,11X,'p_tot = ',
17370 C & E12.4,', above or below HADRIN-thresholds',I6)
17375 DO 7 IDXHKK=1,NOINC
17377 * scan DTEVT1 for unwounded or excited nucleons
17378 IF ((ISTHKK(I).EQ.12+ICAS).OR.(ISTHKK(I).EQ.14+ICAS)) THEN
17380 IF (ICAS.EQ.1) THEN
17381 VTXDST(K) = WHKK(K,I)-VTXCAS(1,K)
17382 ELSEIF (ICAS.EQ.2) THEN
17383 VTXDST(K) = VHKK(K,I)-VTXCAS(2,K)
17386 POSNUC = VTXDST(1)*COSCAS(ICAS,1)+
17387 & VTXDST(2)*COSCAS(ICAS,2)+
17388 & VTXDST(3)*COSCAS(ICAS,3)
17389 * check if nucleon is situated in forward direction
17390 IF (POSNUC.GT.ZERO) THEN
17391 * distance between hadron and this nucleon
17392 DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17395 BIMNU2 = DISTNU**2-POSNUC**2
17396 IF (BIMNU2.LT.ZERO) THEN
17397 WRITE(LOUT,1001) DISTNU,POSNUC,BIMNU2
17398 1001 FORMAT(1X,'INUCAS: warning! inconsistent impact',
17399 & ' parameter ',/,20X,3E12.4)
17402 BIMNU = SQRT(BIMNU2)
17403 * maximum impact parameter to have interaction
17404 IDNUC = IDT_ICIHAD(IDHKK(I))
17405 IDNUC1 = IDT_MCHAD(IDNUC)
17406 IDCAS1 = IDT_MCHAD(IDCAS)
17408 PCAS1(K) = PCAS(ICAS,K)
17409 PNUC(K) = PHKK(K,I)
17411 * Lorentz-parameter for trafo into rest-system of target
17413 BGTA(K) = PNUC(K)/MAX(PNUC(5),TINY10)
17415 * transformation of projectile into rest-system of target
17416 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
17417 & PCAS1(1),PCAS1(2),PCAS1(3),PCAS1(4),
17418 & PPTOT,PX,PY,PZ,PE)
17420 C CALL DT_SIHNIN(IDCAS1,IDNUC1,PPTOT,SIGIN)
17421 C CALL DT_SIHNEL(IDCAS1,IDNUC1,PPTOT,SIGEL)
17423 CALL DT_XSHN(IDCAS1,IDNUC1,PPTOT,DUMZER,SIGTOT,SIGEL)
17424 CALL DT_SIHNAB(IDCAS1,IDNUC1,PPTOT,SIGAB)
17425 IF (((IDCAS1.EQ.13).OR.(IDCAS1.EQ.14)).AND.
17426 & (PPTOT.LT.0.15D0)) SIGEL = SIGEL/2.0D0
17427 SIGIN = SIGTOT-SIGEL-SIGAB
17428 C SIGTOT = SIGIN+SIGEL+SIGAB
17430 BIMMAX = SQRT(SIGTOT/(5.0D0*TWOPI))*FM2MM
17431 * check if interaction is possible
17432 IF (BIMNU.LE.BIMMAX) THEN
17433 * get nucleon with smallest distance and kind of interaction
17434 * (elastic/inelastic)
17435 IF (DISTNU.LT.DIST) THEN
17438 IF (IDNUC.NE.IDSPE(1)) THEN
17439 IDSPE(2) = IDSPE(1)
17440 IDXSPE(2) = IDXSPE(1)
17449 C IF ((IDCAS.EQ.2).OR.(IDCAS.EQ.9)) THEN
17451 C STOT = SIGIN+SIGEL
17453 C SELA = SIGEL+0.75D0*SIGIN
17454 C STOT = 0.25D0*SIGIN+SELA
17460 DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17462 IDNUC = IDT_ICIHAD(IDHKK(I))
17463 IF (IDNUC.EQ.1) THEN
17464 IF (DISTNU.LT.DISTP) THEN
17469 ELSEIF (IDNUC.EQ.8) THEN
17470 IF (DISTNU.LT.DISTN) THEN
17479 * there is no nucleon for a secondary interaction
17480 IF (NSPE.EQ.0) GOTO 9997
17482 C IF ((IDCAS.EQ.13).AND.((PCAS(ICAS,4)-PCAS(ICAS,5)).LT.0.1D0))
17483 C & WRITE(LOUT,*) STOT,SELA,SABS,IDXSPE
17484 IF (IDXSPE(2).EQ.0) THEN
17485 IF ((IDSPE(1).EQ.1).AND.(IDXN.GT.0)) THEN
17487 C IF (ICAS.EQ.1) THEN
17488 C VTXDST(K) = WHKK(K,IDXN)-WHKK(K,IDXSPE(1))
17489 C ELSEIF (ICAS.EQ.2) THEN
17490 C VTXDST(K) = VHKK(K,IDXN)-VHKK(K,IDXSPE(1))
17493 C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17495 C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSN.GT.ZERO)) THEN
17502 ELSEIF ((IDSPE(1).EQ.8).AND.(IDXP.GT.0)) THEN
17504 C IF (ICAS.EQ.1) THEN
17505 C VTXDST(K) = WHKK(K,IDXP)-WHKK(K,IDXSPE(1))
17506 C ELSEIF (ICAS.EQ.2) THEN
17507 C VTXDST(K) = VHKK(K,IDXP)-VHKK(K,IDXSPE(1))
17510 C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17512 C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSP.GT.ZERO)) THEN
17525 IF (RR.LT.SELA/STOT) THEN
17527 ELSEIF ((RR.GE.SELA/STOT).AND.(RR.LT.(SELA+SABS)/STOT)) THEN
17534 PCAS1(K) = PCAS(ICAS,K)
17535 PNUC(K) = PHKK(K,IDXSPE(1))
17537 IF (IPROC.EQ.3) THEN
17538 * 2-nucleon absorption of pion
17540 CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,1,IREJ1)
17541 IF (IREJ1.NE.0) GOTO 9999
17542 IF (NSPE.GE.1) LABSOR = .TRUE.
17544 * sample secondary interaction
17545 IDNUC = IDBAM(IDXSPE(1))
17546 CALL DT_HADRIN(IDCAS,PCAS1,IDNUC,PNUC,IPROC,IREJ1)
17547 IF (IREJ1.EQ.1) GOTO 9999
17548 IF (IREJ1.GT.1) GOTO 9998
17552 * update arrays to include Pauli-principle
17554 IF (NWOUND(ICAS).LE.299) THEN
17555 NWOUND(ICAS) = NWOUND(ICAS)+1
17556 EWOUND(ICAS,NWOUND(ICAS)) = PHKK(4,IDXSPE(I))
17560 * dump initial hadron for energy-momentum conservation check
17562 & CALL DT_EVTEMC(PCAS(ICAS,1),PCAS(ICAS,2),PCAS(ICAS,3),
17563 & PCAS(ICAS,4),1,IDUM,IDUM)
17565 * dump final state particles into DTEVT1
17567 * check if Pauli-principle is fulfilled
17569 NWTMP(1) = NWOUND(1)
17570 NWTMP(2) = NWOUND(2)
17574 IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
17575 & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1
17577 IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 117
17584 IF (IDX.EQ.1) MODE = -1
17585 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,MODE)
17587 * first check if cascade step is forbidden due to Pauli-principle
17588 * (in case of absorpion this step is forced)
17589 IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
17590 & (IDFSP(I).EQ.8))) THEN
17591 * get nuclear potential barrier
17592 POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
17593 IF (IDFSP(I).EQ.1) THEN
17594 POTLOW = POT-EBINDP(IDX)
17596 POTLOW = POT-EBINDN(IDX)
17598 * final state particle not able to escape nucleus
17599 IF (PE.LE.POTLOW) THEN
17600 * check if there are wounded nucleons
17601 IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
17602 & EWOUND(IDX,NWOUND(IDX)))) THEN
17604 NWOUND(IDX) = NWOUND(IDX)-1
17606 * interaction prohibited by Pauli-principle
17607 NWOUND(1) = NWTMP(1)
17608 NWOUND(2) = NWTMP(2)
17617 NWOUND(1) = NWTMP(1)
17618 NWOUND(2) = NWTMP(2)
17622 IST = ISTHKK(IDXCAS)
17626 IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
17627 & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1
17629 IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 17
17634 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,NCAS)
17636 * first check if cascade step is forbidden due to Pauli-principle
17637 * (in case of absorpion this step is forced)
17638 IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
17639 & (IDFSP(I).EQ.8))) THEN
17640 * get nuclear potential barrier
17641 POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
17642 IF (IDFSP(I).EQ.1) THEN
17643 POTLOW = POT-EBINDP(IDX)
17645 POTLOW = POT-EBINDN(IDX)
17647 * final state particle not able to escape nucleus
17648 IF (PE.LE.POTLOW) THEN
17649 * check if there are wounded nucleons
17650 IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
17651 & EWOUND(IDX,NWOUND(IDX)))) THEN
17652 NWOUND(IDX) = NWOUND(IDX)-1
17656 * interaction prohibited by Pauli-principle
17657 NWOUND(1) = NWTMP(1)
17658 NWOUND(2) = NWTMP(2)
17662 c ELSEIF (PE.LE.POT) THEN
17663 cC ELSEIF ((PE.LE.POT).AND.(NWOUND(IDX).GE.1)) THEN
17664 cC NWOUND(IDX) = NWOUND(IDX)-1
17666 c NPAULI = NPAULI+1
17672 * dump final state particles for energy-momentum conservation check
17673 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),-PFSP(3,I),
17674 & -PFSP(4,I),2,IDUM,IDUM)
17680 IF (ABS(IST).EQ.1) THEN
17681 * transform particles back into n-n cms
17682 * LEPTO: leave final state particles in target rest frame
17683 C IF (MCGENE.EQ.3) THEN
17690 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17691 & PFSP(4,I),IDFSP(I),IMODE)
17693 ELSEIF ((ICAS.EQ.2).AND.(IST.EQ.15)) THEN
17694 * target cascade but fsp got stuck in proj. --> transform it into
17695 * proj. rest system
17696 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17697 & PFSP(4,I),IDFSP(I),-1)
17698 ELSEIF ((ICAS.EQ.1).AND.(IST.EQ.16)) THEN
17699 * proj. cascade but fsp got stuck in target --> transform it into
17700 * target rest system
17701 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17702 & PFSP(4,I),IDFSP(I),1)
17705 * dump final state particles into DTEVT1
17706 IGEN = IDCH(IDXCAS)+1
17707 ID = IDT_IPDGHA(IDFSP(I))
17709 IF (LABSOR) IXR = 99
17710 CALL DT_EVTPUT(IST,ID,IDXCAS,IDXSPE(1),PFSP(1,I),
17711 & PFSP(2,I),PFSP(3,I),PFSP(4,I),0,IXR,IGEN)
17713 * update the counter for particles which got stuck inside the nucleus
17714 IF ((IST.EQ.15).OR.(IST.EQ.16)) THEN
17716 IDXINC(NOINC) = NHKK
17719 * in case of absorption the spatial treatment is an approximate
17720 * solution anyway (the positions of the nucleons which "absorb" the
17721 * cascade particle are not taken into consideration) therefore the
17722 * particles are produced at the position of the cascade particle
17724 WHKK(K,NHKK) = WHKK(K,IDXCAS)
17725 VHKK(K,NHKK) = VHKK(K,IDXCAS)
17728 * DDISTL - distance the cascade particle moves to the intera. point
17729 * (the position where impact-parameter = distance to the interacting
17730 * nucleon), DIST - distance to the interacting nucleon at the time of
17731 * formation of the cascade particle, BINT - impact-parameter of this
17732 * cascade-interaction
17733 DDISTL = SQRT(DIST**2-BINT**2)
17734 DTIME = DDISTL/BECAS(ICAS)
17735 DTIMEL = DDISTL/BGCAS(ICAS)
17736 RDISTL = DTIMEL*BGCAS(I2)
17737 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17738 RTIME = RDISTL/BECAS(I2)
17742 * RDISTL, RTIME are this step and time in the rest system of the other
17745 VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+COSCAS(ICAS,K)*DDISTL
17746 VTXCA1(I2,K) = VTXCAS(I2,K) +COSCAS(I2,K) *RDISTL
17748 VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME
17749 VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME
17750 * position of particle production is half the impact-parameter to
17751 * the interacting nucleon
17753 WHKK(K,NHKK) = OHALF*(VTXCA1(1,K)+WHKK(K,IDXSPE(1)))
17754 VHKK(K,NHKK) = OHALF*(VTXCA1(2,K)+VHKK(K,IDXSPE(1)))
17756 * time of production of secondary = time of interaction
17757 WHKK(4,NHKK) = VTXCA1(1,4)
17758 VHKK(4,NHKK) = VTXCA1(2,4)
17763 * modify status and position of cascade particle (the latter for
17764 * statistics reasons only)
17766 IF (LABSOR) ISTHKK(IDXCAS) = 19
17767 IF (.NOT.LABSOR) THEN
17769 WHKK(K,IDXCAS) = VTXCA1(1,K)
17770 VHKK(K,IDXCAS) = VTXCA1(2,K)
17776 * dump interacting nucleons for energy-momentum conservation check
17778 & CALL DT_EVTEMC(PHKK(1,IS),PHKK(2,IS),PHKK(3,IS),PHKK(4,IS),
17780 * modify entry for interacting nucleons
17781 IF (ISTHKK(IS).EQ.12+ICAS) ISTHKK(IS)=16+ICAS
17782 IF (ISTHKK(IS).EQ.14+ICAS) ISTHKK(IS)=2
17784 JDAHKK(1,IS) = JDAHKK(1,IDXSPE(1))
17785 JDAHKK(2,IS) = JDAHKK(2,IDXSPE(1))
17789 * check energy-momentum conservation
17791 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,500,IREJ1)
17792 IF (IREJ1.NE.0) GOTO 9999
17797 NINCCO(ICAS,1) = NINCCO(ICAS,1)+1
17799 IF (IPROC.EQ.1) NINCCO(ICAS,2) = NINCCO(ICAS,2)+1
17800 IF (IPROC.EQ.2) NINCCO(ICAS,3) = NINCCO(ICAS,3)+1
17807 * transport-step but no cascade step due to configuration (i.e. there
17808 * is no nucleon for interaction etc.)
17811 C WHKK(K,IDXCAS) = VTXCAS(1,K)
17812 C VHKK(K,IDXCAS) = VTXCAS(2,K)
17813 WHKK(K,IDXCAS) = VTXCA1(1,K)
17814 VHKK(K,IDXCAS) = VTXCA1(2,K)
17819 * no cascade-step because of configuration
17820 * (i.e. hadron outside nucleus etc.)
17830 *$ CREATE DT_ABSORP.FOR
17833 *===absorp=============================================================*
17835 SUBROUTINE DT_ABSORP(IDCAS,PCAS,NCAS,NSPE,IDSPE,IDXSPE,MODE,IREJ)
17837 ************************************************************************
17838 * Two-nucleon absorption of antiprotons, pi-, and K-. *
17839 * Antiproton absorption is handled by HADRIN. *
17840 * The following channels for meson-absorption are considered: *
17841 * pi- + p + p ---> n + p *
17842 * pi- + p + n ---> n + n *
17843 * K- + p + p ---> sigma+ + n / Lam + p / sigma0 + p *
17844 * K- + p + n ---> sigma- + n / Lam + n / sigma0 + n *
17845 * K- + p + p ---> sigma- + n *
17846 * IDCAS, PCAS identity, momentum of particle to be absorbed *
17847 * NCAS = 1 intranuclear cascade in projectile *
17848 * = -1 intranuclear cascade in target *
17849 * NSPE number of spectator nucleons involved *
17850 * IDXSPE(2) DTEVT1-indices of spectator nucleons involved *
17851 * Revised version of the original STOPIK written by HJM and J. Ranft. *
17852 * This version dated 24.02.95 is written by S. Roesler *
17853 ************************************************************************
17855 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17858 PARAMETER ( LINP = 10 ,
17862 PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,ONE=1.0D0,
17863 & ONETHI=0.3333D0,TWOTHI=0.6666D0)
17867 PARAMETER (NMXHKK=200000)
17869 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17870 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17871 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17873 * extended event history
17874 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17875 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17878 * flags for input different options
17879 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17880 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17881 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17883 * final state after inc step
17884 PARAMETER (MAXFSP=10)
17885 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17887 * particle properties (BAMJET index convention)
17889 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17890 & IICH(210),IIBAR(210),K1(210),K2(210)
17892 DIMENSION PCAS(5),IDXSPE(2),IDSPE(2),PSPE(2,5),PSPE1(5),
17893 & PTOT3P(4),BG3P(4),
17894 & ECMF(2),PCMF(2),CODF(2),COFF(2),SIFF(2)
17899 * skip particles others than ap, pi-, K- for mode=0
17900 IF ((MODE.EQ.0).AND.
17901 & (IDCAS.NE.2).AND.(IDCAS.NE.14).AND.(IDCAS.NE.16)) RETURN
17902 * skip particles others than pions for mode=1
17903 * (2-nucleon absorption in intranuclear cascade)
17904 IF ((MODE.EQ.1).AND.
17905 & (IDCAS.NE.13).AND.(IDCAS.NE.14).AND.(IDCAS.NE.23)) RETURN
17908 IF (NUCAS.EQ.-1) NUCAS = 2
17910 IF (MODE.EQ.0) THEN
17911 * scan spectator nucleons for nucleons being able to "absorb"
17916 IF ((ISTHKK(I).EQ.12+NUCAS).OR.(ISTHKK(I).EQ.14+NUCAS)) THEN
17919 IDSPE(NSPE) = IDBAM(I)
17920 IF ((NSPE.EQ.1).AND.(IDCAS.EQ.2)) GOTO 2
17921 IF (NSPE.EQ.2) THEN
17922 IF ((IDCAS.EQ.14).AND.(IDSPE(1).EQ.8).AND.
17923 & (IDSPE(2).EQ.8)) THEN
17924 * there is no pi-+n+n channel
17936 * transform excited projectile nucleons (status=15) into proj. rest s.
17939 PSPE(I,K) = PHKK(K,IDXSPE(I))
17943 * antiproton absorption
17944 IF ((IDCAS.EQ.2).AND.(NSPE.GE.1)) THEN
17946 PSPE1(K) = PSPE(1,K)
17948 CALL DT_HADRIN(IDCAS,PCAS,IDSPE(1),PSPE1,1,IREJ1)
17949 IF (IREJ1.NE.0) GOTO 9999
17952 ELSEIF (((IDCAS.EQ.13).OR.(IDCAS.EQ.14).OR.(IDCAS.EQ.23)
17953 & .OR.(IDCAS.EQ.16)).AND.(NSPE.GE.2)) THEN
17954 IF (IDCAS.EQ.14) THEN
17958 IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) IDFSP(2) = 1
17959 ELSEIF (IDCAS.EQ.13) THEN
17963 IF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) IDFSP(2) = 8
17964 ELSEIF (IDCAS.EQ.23) THEN
17966 IDFSP(1) = IDSPE(1)
17967 IDFSP(2) = IDSPE(2)
17968 ELSEIF (IDCAS.EQ.16) THEN
17971 IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) THEN
17972 IF (R.LT.ONETHI) THEN
17975 ELSEIF (R.LT.TWOTHI) THEN
17982 ELSEIF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) THEN
17986 IF (R.LT.ONETHI) THEN
17989 ELSEIF (R.LT.TWOTHI) THEN
17998 * dump initial particles for energy-momentum cons. check
18000 CALL DT_EVTEMC(PCAS(1),PCAS(2),PCAS(3),PCAS(4),1,IDUM,IDUM)
18001 CALL DT_EVTEMC(PSPE(1,1),PSPE(1,2),PSPE(1,3),PSPE(1,4),2,
18003 CALL DT_EVTEMC(PSPE(2,1),PSPE(2,2),PSPE(2,3),PSPE(2,4),2,
18006 * get Lorentz-parameter of 3 particle initial state
18008 PTOT3P(K) = PCAS(K)+PSPE(1,K)+PSPE(2,K)
18010 P3P = SQRT(PTOT3P(1)**2+PTOT3P(2)**2+PTOT3P(3)**2)
18011 AM3P = SQRT( (PTOT3P(4)-P3P)*(PTOT3P(4)+P3P) )
18013 BG3P(K) = PTOT3P(K)/MAX(AM3P,TINY10)
18015 * 2-particle decay of the 3-particle compound system
18016 CALL DT_DTWOPD(AM3P,ECMF(1),ECMF(2),PCMF(1),PCMF(2),
18017 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
18018 & AAM(IDFSP(1)),AAM(IDFSP(2)))
18020 SDF = SQRT((ONE-CODF(I))*(ONE+CODF(I)))
18021 PX = PCMF(I)*COFF(I)*SDF
18022 PY = PCMF(I)*SIFF(I)*SDF
18023 PZ = PCMF(I)*CODF(I)
18024 CALL DT_DALTRA(BG3P(4),BG3P(1),BG3P(2),BG3P(3),PX,PY,PZ,
18025 & ECMF(I),PTOFSP,PFSP(1,I),PFSP(2,I),PFSP(3,I),
18027 PFSP(5,I) = SQRT( (PFSP(4,I)-PTOFSP)*(PFSP(4,I)+PTOFSP) )
18028 * check consistency of kinematics
18029 IF (ABS(AAM(IDFSP(I))-PFSP(5,I)).GT.TINY5) THEN
18030 WRITE(LOUT,1001) IDFSP(I),AAM(IDFSP(I)),PFSP(5,I)
18031 1001 FORMAT(1X,'ABSORP: warning! inconsistent',
18032 & ' tree-particle kinematics',/,20X,'id: ',I3,
18033 & ' AAM = ',E10.4,' MFSP = ',E10.4)
18035 * dump final state particles for energy-momentum cons. check
18036 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
18037 & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
18041 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,100,IREJ1)
18042 IF (IREJ1.NE.0) THEN
18043 WRITE(LOUT,*)'ABSORB: EMC ',AAM(IDFSP(1)),AAM(IDFSP(2)),
18049 IF (IOULEV(3).GT.0) WRITE(LOUT,1000) IDCAS,NSPE
18050 1000 FORMAT(1X,'ABSORP: warning! absorption for particle ',I3,
18051 & ' impossible',/,20X,'too few spectators (',I2,')')
18058 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in ABSORP'
18063 *$ CREATE DT_HADRIN.FOR
18066 *===hadrin=============================================================*
18068 SUBROUTINE DT_HADRIN(IDPR,PPR,IDTA,PTA,MODE,IREJ)
18070 ************************************************************************
18071 * Interface to the HADRIN-routines for inelastic and elastic *
18073 * IDPR,PPR(5) identity, momentum of projectile *
18074 * IDTA,PTA(5) identity, momentum of target *
18075 * MODE = 1 inelastic interaction *
18076 * = 2 elastic interaction *
18077 * Revised version of the original FHAD. *
18078 * This version dated 27.10.95 is written by S. Roesler *
18079 ************************************************************************
18081 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18084 PARAMETER ( LINP = 10 ,
18088 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,
18089 & TINY2=1.0D-2,TINY1=1.0D-1,ONE=1.0D0)
18091 LOGICAL LCORR,LMSSG
18093 * flags for input different options
18094 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18095 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18096 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18098 * final state after inc step
18099 PARAMETER (MAXFSP=10)
18100 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
18102 * particle properties (BAMJET index convention)
18104 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18105 & IICH(210),IIBAR(210),K1(210),K2(210)
18106 * output-common for DHADRI/ELHAIN
18108 * final state from HADRIN interaction
18109 PARAMETER (MAXFIN=10)
18110 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
18111 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
18113 DIMENSION PPR(5),PPR1(5),PTA(5),BGTA(4),
18114 & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4),IMCORR(2)
18116 DATA LMSSG /.TRUE./
18125 * dump initial particles for energy-momentum cons. check
18127 CALL DT_EVTEMC(PPR(1),PPR(2),PPR(3),PPR(4),1,IDUM,IDUM)
18128 CALL DT_EVTEMC(PTA(1),PTA(2),PTA(3),PTA(4),2,IDUM,IDUM)
18131 AMP2 = PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2
18132 AMT2 = PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2
18133 IF ((AMP2.LT.ZERO).OR.(AMT2.LT.ZERO).OR.
18134 & (ABS(AMP2-AAM(IDPR)**2).GT.TINY5).OR.
18135 & (ABS(AMT2-AAM(IDTA)**2).GT.TINY5)) THEN
18136 IF (LMSSG.AND.(IOULEV(3).GT.0))
18137 & WRITE(LOUT,1000) AMP2,AAM(IDPR)**2,AMT2,AAM(IDTA)**2
18138 1000 FORMAT(1X,'HADRIN: warning! inconsistent projectile/target',
18139 & ' mass',/,20X,'AMP2 = ',E12.4,', AAM(IDPR)**2 = ',
18140 & E12.4,/,20X,'AMT2 = ',E12.4,', AAM(IDTA)**2 = ',E12.4)
18145 * convert initial state particles into particles which can be
18146 * handled by HADRIN
18149 IF ((IDHPR.LE.0).OR.(IDHPR.GE.111).OR.LCORR) THEN
18150 IF ((IDHPR.LE.0).OR.(IDHPR.GE.111)) IDHPR = 1
18157 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
18158 IF (IREJ1.GT.0) THEN
18159 WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.'
18166 PPR(5) = SQRT(PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2)
18167 PTA(5) = SQRT(PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2)
18170 * Lorentz-parameter for trafo into rest-system of target
18172 BGTA(K) = PTA(K)/PTA(5)
18174 * transformation of projectile into rest-system of target
18175 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),PPR(1),PPR(2),
18176 & PPR(3),PPR(4),PPRTO1,PPR1(1),PPR1(2),PPR1(3),
18179 * direction cosines of projectile in target rest system
18180 CX = PPR1(1)/PPRTO1
18181 CY = PPR1(2)/PPRTO1
18182 CZ = PPR1(3)/PPRTO1
18184 * sample inelastic interaction
18185 IF (MODE.EQ.1) THEN
18186 CALL DT_DHADRI(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA)
18187 IF (IRH.EQ.1) GOTO 9998
18188 * sample elastic interaction
18189 ELSEIF (MODE.EQ.2) THEN
18190 CALL DT_ELHAIN(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA,IREJ1)
18191 IF (IREJ1.NE.0) THEN
18192 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in HADRIN'
18195 IF (IRH.EQ.1) GOTO 9998
18197 WRITE(LOUT,1001) MODE,INTHAD
18198 1001 FORMAT(1X,'HADRIN: warning! inconsistent interaction mode',
18199 & I4,' (INTHAD =',I4,')')
18203 * transform final state particles back into Lab.
18206 PX = CXRH(I)*PLRH(I)
18207 PY = CYRH(I)*PLRH(I)
18208 PZ = CZRH(I)*PLRH(I)
18209 CALL DT_DALTRA(BGTA(4),BGTA(1),BGTA(2),BGTA(3),
18210 & PX,PY,PZ,ELRH(I),PTOFSP,PFSP(1,NFSP),
18211 & PFSP(2,NFSP),PFSP(3,NFSP),PFSP(4,NFSP))
18212 IDFSP(NFSP) = ITRH(I)
18213 AMFSP2 = PFSP(4,NFSP)**2-PFSP(1,NFSP)**2-PFSP(2,NFSP)**2-
18215 IF (AMFSP2.LT.-TINY3) THEN
18216 WRITE(LOUT,1002) IDFSP(NFSP),PFSP(1,NFSP),PFSP(2,NFSP),
18217 & PFSP(3,NFSP),PFSP(4,NFSP),AMFSP2
18218 1002 FORMAT(1X,'HADRIN: warning! final state particle (id = ',
18219 & I2,') with negative mass^2',/,1X,5E12.4)
18222 PFSP(5,NFSP) = SQRT(ABS(AMFSP2))
18223 IF (ABS(PFSP(5,NFSP)-AAM(IDFSP(NFSP))).GT.TINY1) THEN
18224 WRITE(LOUT,1003) IDFSP(NFSP),AAM(IDFSP(NFSP)),
18226 1003 FORMAT(1X,'HADRIN: warning! final state particle',
18227 & ' (id = ',I2,') with inconsistent mass',/,1X,
18230 IF (KCORR.GT.2) GOTO 9999
18231 IMCORR(KCORR) = NFSP
18234 * dump final state particles for energy-momentum cons. check
18235 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
18236 & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
18239 * transform momenta on mass shell in case of inconsistencies in
18241 IF (KCORR.GT.0) THEN
18242 IF (KCORR.EQ.2) THEN
18246 IF (IMCORR(1).EQ.1) THEN
18254 IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I1),PFSP(2,I1),
18255 & PFSP(3,I1),PFSP(4,I1),2,IDUM,IDUM)
18256 IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I2),PFSP(2,I2),
18257 & PFSP(3,I2),PFSP(4,I2),2,IDUM,IDUM)
18259 P1IN(K) = PFSP(K,I1)
18260 P2IN(K) = PFSP(K,I2)
18262 XM1 = AAM(IDFSP(I1))
18263 XM2 = AAM(IDFSP(I2))
18264 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
18265 IF (IREJ1.GT.0) THEN
18266 WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.'
18270 PFSP(K,I1) = P1OUT(K)
18271 PFSP(K,I2) = P2OUT(K)
18273 PFSP(5,I1) = SQRT(PFSP(4,I1)**2-PFSP(1,I1)**2
18274 & -PFSP(2,I1)**2-PFSP(3,I1)**2)
18275 PFSP(5,I2) = SQRT(PFSP(4,I2)**2-PFSP(1,I2)**2
18276 & -PFSP(2,I2)**2-PFSP(3,I2)**2)
18277 * dump final state particles for energy-momentum cons. check
18278 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I1),-PFSP(2,I1),
18279 & -PFSP(3,I1),-PFSP(4,I1),2,IDUM,IDUM)
18280 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I2),-PFSP(2,I2),
18281 & -PFSP(3,I2),-PFSP(4,I2),2,IDUM,IDUM)
18284 * check energy-momentum conservation
18286 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,102,IREJ1)
18287 IF (IREJ1.NE.0) GOTO 9999
18301 *$ CREATE DT_HADCOL.FOR
18304 *===hadcol=============================================================*
18306 SUBROUTINE DT_HADCOL(IDPROJ,PPN,IDXTAR,IREJ)
18308 ************************************************************************
18309 * Interface to the HADRIN-routines for inelastic and elastic *
18310 * scattering. This subroutine samples hadron-nucleus interactions *
18311 * below DPM-threshold. *
18312 * IDPROJ BAMJET-index of projectile hadron *
18313 * PPN projectile momentum in target rest frame *
18314 * IDXTAR DTEVT1-index of target nucleon undergoing *
18315 * interaction with projectile hadron *
18316 * This subroutine replaces HADHAD. *
18317 * This version dated 5.5.95 is written by S. Roesler *
18318 ************************************************************************
18320 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18323 PARAMETER ( LINP = 10 ,
18327 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0)
18333 PARAMETER (NMXHKK=200000)
18335 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18336 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18337 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18339 * extended event history
18340 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18341 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18344 * nuclear potential
18346 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18347 & EBINDP(2),EBINDN(2),EPOT(2,210),
18348 & ETACOU(2),ICOUL,LFERMI
18350 * interface HADRIN-DPM
18351 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
18353 * parameter for intranuclear cascade
18355 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
18357 * final state after inc step
18358 PARAMETER (MAXFSP=10)
18359 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
18361 * particle properties (BAMJET index convention)
18363 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18364 & IICH(210),IIBAR(210),K1(210),K2(210)
18366 DIMENSION PPROJ(5),PNUC(5)
18368 DATA LSTART /.TRUE./
18375 **sr 6/9/01 commented
18376 C TAUFOR = TAUFOR/2.0D0
18380 1000 FORMAT(/,1X,'HADCOL: Scattering handled by HADRIN')
18381 WRITE(LOUT,1001) TAUFOR
18382 1001 FORMAT(/,1X,'HADCOL: Formation zone parameter set to ',
18387 IDNUC = IDBAM(IDXTAR)
18388 IDNUC1 = IDT_MCHAD(IDNUC)
18389 IDPRO1 = IDT_MCHAD(IDPROJ)
18391 IF ((INTHAD.EQ.1).OR.(INTHAD.EQ.2)) THEN
18395 C CALL DT_SIHNIN(IDPRO1,IDNUC1,PPN,SIGIN)
18396 C CALL DT_SIHNEL(IDPRO1,IDNUC1,PPN,SIGEL)
18398 CALL DT_XSHN(IDPRO1,IDNUC1,PPN,DUMZER,SIGTOT,SIGEL)
18399 SIGIN = SIGTOT-SIGEL
18400 C SIGTOT = SIGIN+SIGEL
18403 IF (DT_RNDM(SIGIN).LT.SIGEL/SIGTOT) IPROC = 2
18409 PPROJ(5) = AAM(IDPROJ)
18410 PPROJ(4) = SQRT(PPROJ(5)**2+PPROJ(3)**2)
18412 PNUC(K) = PHKK(K,IDXTAR)
18418 IF (ILOOP.GT.100) GOTO 9999
18420 CALL DT_HADRIN(IDPROJ,PPROJ,IDNUC,PNUC,IPROC,IREJ1)
18421 IF (IREJ1.EQ.1) GOTO 9999
18423 IF (IREJ1.GT.1) THEN
18424 * no interaction possible
18425 * require Pauli blocking
18426 IF ((IDPROJ.EQ.1).AND.(PPROJ(4).LE.PFERMP(2)+PPROJ(5))) GOTO 2
18427 IF ((IDPROJ.EQ.8).AND.(PPROJ(4).LE.PFERMN(2)+PPROJ(5))) GOTO 2
18428 IF ((IIBAR(IDPROJ).NE.1).AND.
18429 & (PPROJ(4).LE.EPOT(2,IDPROJ)+PPROJ(5))) GOTO 2
18430 * store incoming particle as final state particle
18431 CALL DT_LTNUC(PPROJ(3),PPROJ(4),PCMS,ECMS,3)
18432 CALL DT_EVTPUT(1,IDPROJ,1,0,PPROJ(1),PPROJ(2),PCMS,ECMS,0,0,0)
18435 * require Pauli blocking for final state nucleons
18437 IF ((IDFSP(I).EQ.1).AND.
18438 & (PFSP(4,I).LE.PFERMP(2)+AAM(IDFSP(I)))) GOTO 2
18439 IF ((IDFSP(I).EQ.8).AND.
18440 & (PFSP(4,I).LE.PFERMN(2)+AAM(IDFSP(I)))) GOTO 2
18441 IF ((IIBAR(IDFSP(I)).NE.1).AND.
18442 & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I))))GOTO 2
18444 * store final state particles
18447 IF ((IIBAR(IDFSP(I)).EQ.1).AND.
18448 & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I)))) IST = 16
18449 IDHAD = IDT_IPDGHA(IDFSP(I))
18450 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PCMS,ECMS,3)
18451 CALL DT_EVTPUT(IST,IDHAD,1,IDXTAR,PFSP(1,I),PFSP(2,I),
18453 IF (I.EQ.1) NPOINT(4) = NHKK
18454 VHKK(1,NHKK) = 0.5D0*(VHKK(1,1)+VHKK(1,IDXTAR))
18455 VHKK(2,NHKK) = 0.5D0*(VHKK(2,1)+VHKK(2,IDXTAR))
18456 VHKK(3,NHKK) = VHKK(3,IDXTAR)
18457 VHKK(4,NHKK) = VHKK(4,IDXTAR)
18458 WHKK(1,NHKK) = 0.5D0*(WHKK(1,1)+WHKK(1,IDXTAR))
18459 WHKK(2,NHKK) = 0.5D0*(WHKK(2,1)+WHKK(2,IDXTAR))
18460 WHKK(3,NHKK) = WHKK(3,1)
18461 WHKK(4,NHKK) = WHKK(4,1)
18472 *$ CREATE DT_GETEMU.FOR
18475 *===getemu=============================================================*
18477 SUBROUTINE DT_GETEMU(IT,ITZ,KKMAT,MODE)
18479 ************************************************************************
18480 * Sampling of emulsion component to be considered as target-nucleus. *
18481 * This version dated 6.5.95 is written by S. Roesler. *
18482 ************************************************************************
18484 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18487 PARAMETER ( LINP = 10 ,
18491 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
18493 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
18495 * emulsion treatment
18496 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
18499 * Glauber formalism: flags and parameters for statistics
18502 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
18504 IF (MODE.EQ.0) THEN
18506 RR = DT_RNDM(SUMFRA)
18509 DO 1 ICOMP=1,NCOMPO
18510 SUMFRA = SUMFRA+EMUFRA(ICOMP)
18511 IF (SUMFRA.GT.RR) THEN
18513 ITZ = IEMUCH(ICOMP)
18520 WRITE(LOUT,'(1X,A,E12.3)')
18521 & 'Warning! norm. failure within emulsion fractions',
18525 ELSEIF (MODE.EQ.1) THEN
18528 IDIFF = ABS(IT-IEMUMA(I))
18529 IF (IDIFF.LT.NDIFF) THEN
18538 * bypass for variable projectile/target/energy runs: the correct
18539 * Glauber data will be always loaded on kkmat=1
18540 IF (IOGLB.EQ.100) THEN
18547 *$ CREATE DT_NCLPOT.FOR
18550 *===nclpot=============================================================*
18552 SUBROUTINE DT_NCLPOT(IPZ,IP,ITZ,IT,AFERP,AFERT,MODE)
18554 ************************************************************************
18555 * Calculation of Coulomb and nuclear potential for a given configurat. *
18556 * IPZ, IP charge/mass number of proj. *
18557 * ITZ, IT charge/mass number of targ. *
18558 * AFERP,AFERT factors modifying proj./target pot. *
18559 * if =0, FERMOD is used *
18560 * MODE = 0 calculation of binding energy *
18561 * = 1 pre-calculated binding energy is used *
18562 * This version dated 16.11.95 is written by S. Roesler. *
18564 * Last change 28.12.2006 by S. Roesler. *
18565 ************************************************************************
18567 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18570 PARAMETER ( LINP = 10 ,
18574 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
18579 * particle properties (BAMJET index convention)
18581 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18582 & IICH(210),IIBAR(210),K1(210),K2(210)
18584 * nuclear potential
18586 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18587 & EBINDP(2),EBINDN(2),EPOT(2,210),
18588 & ETACOU(2),ICOUL,LFERMI
18590 DIMENSION IDXPOT(14)
18591 * ap an lam alam sig- sig+ sig0 tet0 tet- asig-
18592 DATA IDXPOT / 2, 9, 17, 18, 20, 21, 22, 97, 98, 99,
18593 * asig0 asig+ atet0 atet+
18594 & 100, 101, 102, 103/
18597 DATA LSTART /.TRUE./
18599 IF (MODE.EQ.0) THEN
18611 IF (AFERP.LE.ZERO) FERMIP = FERMOD
18613 IF (AFERT.LE.ZERO) FERMIT = FERMOD
18615 * Fermi momenta and binding energy for projectile
18616 IF ((IP.GT.1).AND.LFERMI) THEN
18617 IF (MODE.EQ.0) THEN
18618 C EBINDP(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ-1)
18619 C EBINDN(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ)
18623 C EBINDP(1) = 1.0D-3*(ENERGY(ONE,ONE)+ENERGY(BIP,BIPZ)
18624 C & -ENERGY(AIP,AIPZ))
18625 EBINDP(1) = 1.0D-3*(EXMSAZ(ONE,ONE ,.TRUE.,IZDUM)
18626 & +EXMSAZ(BIP,BIPZ,.TRUE.,IZDUM)
18627 & -EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM))
18629 IF (AIP.LE.AIPZ) THEN
18630 EBINDN(1) = EBINDP(1)
18631 WRITE(LOUT,*) ' DT_NCLPOT: AIP.LE.AIPZ (',AIP,AIPZ,')'
18634 C EBINDN(1) = 1.0D-3*(ENERGY(ONE,ZERO)+ENERGY(BIP,AIPZ)
18635 C & -ENERGY(AIP,AIPZ))
18636 EBINDN(1) = 1.0D-3*(EXMSAZ(ONE,ZERO,.TRUE.,IZDUM)
18637 & +EXMSAZ(BIP,AIPZ,.TRUE.,IZDUM)
18638 & -EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM))
18642 PFERMP(1) = FERMIP*AN*(AIPZ/AIP)**0.333333D0
18643 PFERMN(1) = FERMIP*AN*((AIP-AIPZ)/AIP)**0.33333D0
18648 * effective nuclear potential for projectile
18649 C EPOT(1,1) = PFERMP(1)**2/(2.0D0*AAM(1)) + EBINDP(1)
18650 C EPOT(1,8) = PFERMN(1)**2/(2.0D0*AAM(8)) + EBINDN(1)
18651 EPOT(1,1) = SQRT(PFERMP(1)**2+AAM(1)**2) -AAM(1) + EBINDP(1)
18652 EPOT(1,8) = SQRT(PFERMN(1)**2+AAM(8)**2) -AAM(8) + EBINDN(1)
18654 * Fermi momenta and binding energy for target
18655 IF ((IT.GT.1).AND.LFERMI) THEN
18656 IF (MODE.EQ.0) THEN
18657 C EBINDP(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ-1)
18658 C EBINDN(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ)
18662 C EBINDP(2) = 1.0D-3*(ENERGY(ONE,ONE)+ENERGY(BIT,BITZ)
18663 C & -ENERGY(AIT,AITZ))
18664 EBINDP(2) = 1.0D-3*(EXMSAZ(ONE,ONE, .TRUE.,IZDUM)
18665 & +EXMSAZ(BIT,BITZ,.TRUE.,IZDUM)
18666 & -EXMSAZ(AIT,AITZ,.TRUE.,IZDUM))
18668 IF (AIT.LE.AITZ) THEN
18669 EBINDN(2) = EBINDP(2)
18670 WRITE(LOUT,*) ' DT_NCLPOT: AIT.LE.AIPT (',AIT,AIPT,')'
18673 C EBINDN(2) = 1.0D-3*(ENERGY(ONE,ZERO)+ENERGY(BIT,AITZ)
18674 C & -ENERGY(AIT,AITZ))
18675 EBINDN(2) = 1.0D-3*(EXMSAZ(ONE,ZERO,.TRUE.,IZDUM)
18676 & +EXMSAZ(BIT,AITZ,.TRUE.,IZDUM)
18677 & -EXMSAZ(AIT,AITZ,.TRUE.,IZDUM))
18681 PFERMP(2) = FERMIT*AN*(AITZ/AIT)**0.333333D0
18682 PFERMN(2) = FERMIT*AN*((AIT-AITZ)/AIT)**0.33333D0
18687 * effective nuclear potential for target
18688 C EPOT(2,1) = PFERMP(2)**2/(2.0D0*AAM(1)) + EBINDP(2)
18689 C EPOT(2,8) = PFERMN(2)**2/(2.0D0*AAM(8)) + EBINDN(2)
18690 EPOT(2,1) = SQRT(PFERMP(2)**2+AAM(1)**2) -AAM(1) + EBINDP(2)
18691 EPOT(2,8) = SQRT(PFERMN(2)**2+AAM(8)**2) -AAM(8) + EBINDN(2)
18694 EPOT(1,IDXPOT(I)) = EPOT(1,8)
18695 EPOT(2,IDXPOT(I)) = EPOT(2,8)
18701 IF (ICOUL.EQ.1) THEN
18703 & ETACOU(1) = 0.001116D0*AIPZ/(1.0D0+AIP**0.333D0)
18705 & ETACOU(2) = 0.001116D0*AITZ/(1.0D0+AIT**0.333D0)
18709 WRITE(LOUT,1000) IP,IPZ,IT,ITZ,EBINDP,EBINDN,
18710 & EPOT(1,1)-EBINDP(1),EPOT(2,1)-EBINDP(2),
18711 & EPOT(1,8)-EBINDN(1),EPOT(2,8)-EBINDN(2),
18713 1000 FORMAT(/,/,1X,'NCLPOT: quantities for inclusion of nuclear'
18714 & ,' effects',/,12X,'---------------------------',
18715 & '----------------',/,/,38X,'projectile',
18716 & ' target',/,/,1X,'Mass number / charge',
18717 & 17X,I3,' /',I3,6X,I3,' /',I3,/,1X,'Binding energy -',
18718 & ' proton (GeV) ',2E14.4,/,17X,'- neutron (GeV)'
18719 & ,1X,2E14.4,/,1X,'Fermi-potential - proton (GeV)',
18720 & 1X,2E14.4,/,17X,'- neutron (GeV) ',2E14.4,/,/,
18721 & 1X,'Scale factor for Fermi-momentum ',F4.2,/,
18722 & /,1X,'Coulomb-energy ',2(E14.4,' GeV '),/,/)
18729 *$ CREATE DT_RESNCL.FOR
18732 *===resncl=============================================================*
18734 SUBROUTINE DT_RESNCL(EPN,NLOOP,MODE)
18736 ************************************************************************
18737 * Treatment of residual nuclei and nuclear effects. *
18738 * MODE = 1 initializations *
18739 * = 2 treatment of final state *
18740 * This version dated 16.11.95 is written by S. Roesler. *
18742 * Last change 05.01.2007 by S. Roesler. *
18743 ************************************************************************
18745 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18748 PARAMETER ( LINP = 10 ,
18752 PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,THREE=3.D0,TINY3=1.0D-3,
18753 & TINY2=1.0D-2,TINY1=1.0D-1,TINY4=1.0D-4,TINY10=1.0D-10,
18754 & ONETHI=ONE/THREE)
18755 PARAMETER (AMUAMU = 0.93149432D0,
18758 PARAMETER ( EMVGEV = 1.0 D-03 )
18759 PARAMETER ( AMUGEV = 0.93149432 D+00 )
18760 PARAMETER ( AMPRTN = 0.93827231 D+00 )
18761 PARAMETER ( AMNTRN = 0.93956563 D+00 )
18762 PARAMETER ( AMELCT = 0.51099906 D-03 )
18763 PARAMETER ( HLFHLF = 0.5D+00 )
18764 PARAMETER ( FERTHO = 14.33 D-09 )
18765 PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
18766 PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
18767 PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
18771 PARAMETER (NMXHKK=200000)
18773 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18774 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18775 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18777 * extended event history
18778 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18779 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18782 * particle properties (BAMJET index convention)
18784 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18785 & IICH(210),IIBAR(210),K1(210),K2(210)
18787 * flags for input different options
18788 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18789 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18790 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18792 * nuclear potential
18794 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18795 & EBINDP(2),EBINDN(2),EPOT(2,210),
18796 & ETACOU(2),ICOUL,LFERMI
18798 * properties of interacting particles
18799 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
18801 * properties of photon/lepton projectiles
18802 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
18804 * Lorentz-parameters of the current interaction
18805 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
18806 & UMO,PPCM,EPROJ,PPROJ
18808 * treatment of residual nuclei: wounded nucleons
18809 COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
18811 * treatment of residual nuclei: 4-momenta
18812 LOGICAL LRCLPR,LRCLTA
18813 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18814 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18816 DIMENSION PFSP(4),PSEC(4),PSEC0(4)
18817 DIMENSION PMOMB(5000),IDXB(5000),PMOMM(10000),IDXM(10000),
18818 & IDXCOR(15000),IDXOTH(NMXHKK)
18822 *------- initializations
18825 * initialize arrays for residual nuclei
18840 * correction of projectile 4-momentum for effective target pot.
18841 * and Coulomb-energy (in case of hadron-nucleus interaction only)
18842 IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
18845 * positively charged hadron - check energy for Coloumb pot.
18846 IF (IICH(IJPROJ).EQ.1) THEN
18847 THRESH = ETACOU(2)+AAM(IJPROJ)
18848 IF (EPNI.LE.THRESH) THEN
18850 1000 FORMAT(/,1X,'KKINC: WARNING! projectile energy',
18851 & ' below Coulomb threshold - event rejected',/)
18855 * negatively charged hadron - increase energy by Coulomb energy
18856 ELSEIF (IICH(IJPROJ).EQ.-1) THEN
18857 EPNI = EPNI+ETACOU(2)
18859 IF ((IJPROJ.EQ.1).OR.(IJPROJ.EQ.8)) THEN
18860 * Effective target potential
18861 *sr 6.6. binding energy only (to avoid negative exc. energies)
18862 C EPNI = EPNI+EPOT(2,IJPROJ)
18864 IF ((IJPROJ.NE.1).AND.(ABS(EPOT(2,IJPROJ)).GT.5.0D-3))
18865 & EBIPOT = EBINDN(2)
18866 EPNI = EPNI+ABS(EBIPOT)
18867 * re-initialization of DTLTRA
18870 CALL DT_LTINI(IJPROJ,IJTARG,EPNI,DUM1,DUM2,0)
18874 * projectile in n-n cms
18875 IF ((IP.LE.1).AND.(IT.GT.1)) THEN
18876 PMASS1 = AAM(IJPROJ)
18878 C IF (IJPROJ.EQ.7) PMASS1 = AAM(33)
18879 IF (IJPROJ.EQ.7) PMASS1 = AAM(IJPROJ)-SQRT(VIRT)
18881 PM1 = SIGN(PMASS1**2,PMASS1)
18882 PM2 = SIGN(PMASS2**2,PMASS2)
18883 PINIPR(4) = (UMO**2-PM2+PM1)/(TWO*UMO)
18885 IF (PMASS1.GT.ZERO) THEN
18886 PINIPR(3) = SQRT((PINIPR(4)-PINIPR(5))
18887 & *(PINIPR(4)+PINIPR(5)))
18889 PINIPR(3) = SQRT(PINIPR(4)**2-PM1)
18894 C PINITA(5) = AIT*AMUAMU+1.0D-3*ENERGY(AIT,AITZ)
18895 PINITA(5) = AIT*AMUC12+EMVGEV*EXMSAZ(AIT,AITZ,.TRUE.,IZDUM)
18897 CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
18898 ELSEIF ((IP.GT.1).AND.(IT.LE.1)) THEN
18900 PMASS2 = AAM(IJTARG)
18901 PM1 = SIGN(PMASS1**2,PMASS1)
18902 PM2 = SIGN(PMASS2**2,PMASS2)
18903 PINITA(4) = (UMO**2-PM1+PM2)/(TWO*UMO)
18905 PINITA(3) = -SQRT((PINITA(4)-PINITA(5))
18906 & *(PINITA(4)+PINITA(5)))
18910 C PINIPR(5) = AIP*AMUAMU+1.0D-3*ENERGY(AIP,AIPZ)
18911 PINIPR(5) = AIP*AMUC12+EMVGEV*EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM)
18913 CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
18914 ELSEIF ((IP.GT.1).AND.(IT.GT.1)) THEN
18918 C PINIPR(5) = AIP*AMUAMU+1.0D-3*ENERGY(AIP,AIPZ)
18919 PINIPR(5) = AIP*AMUC12+EMVGEV*EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM)
18921 CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
18925 C PINITA(5) = AIT*AMUAMU+1.0D-3*ENERGY(AIT,AITZ)
18926 PINITA(5) = AIT*AMUC12+EMVGEV*EXMSAZ(AIT,AITZ,.TRUE.,IZDUM)
18928 CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
18933 *------- treatment of final state
18937 IF (NLOOP.GT.1) SCPOT = 0.10D0
18938 C WRITE(LOUT,*) 'event ',NEVHKK,NLOOP,SCPOT
18950 DO 900 I=NPOINT(4),NHKK
18952 IF (ISTHKK(I).EQ.1) THEN
18953 IF (IDBAM(I).EQ.7) GOTO 900
18956 * particle moving into forward direction
18957 IF (PHKK(3,I).GE.ZERO) THEN
18958 * most likely to be effected by projectile potential
18960 * there is no projectile nucleus, try target
18961 IF ((IP.LE.1).OR.((IP-NPW).LE.1)) THEN
18963 IF (IP.GT.1) IOTHER = 1
18964 * there is no target nucleus --> skip
18965 IF ((IT.LE.1).OR.((IT-NTW).LE.1)) GOTO 900
18967 * particle moving into backward direction
18969 * most likely to be effected by target potential
18971 * there is no target nucleus, try projectile
18972 IF ((IT.LE.1).OR.((IT-NTW).LE.1)) THEN
18974 IF (IT.GT.1) IOTHER = 1
18975 * there is no projectile nucleus --> skip
18976 IF ((IP.LE.1).OR.((IP-NPW).LE.1)) GOTO 900
18980 * nobam=3: particle is in overlap-region or neither inside proj. nor target
18981 * =1: particle is not in overlap-region AND is inside target (2)
18982 * =2: particle is not in overlap-region AND is inside projectile (1)
18983 * flag particles which are inside the nucleus ipot but not in its
18985 IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) IFLG = IPOT
18986 IF (IDBAM(I).NE.0) THEN
18987 * baryons: keep all nucleons and all others where flag is set
18988 IF (IIBAR(IDBAM(I)).NE.0) THEN
18989 IF ((IDBAM(I).EQ.1).OR.(IDBAM(I).EQ.8).OR.(IFLG.GT.0))
18992 PMOMB(NOB) = PHKK(3,I)
18993 IDXB(NOB) = SIGN(10000000*IABS(IFLG)
18994 & +1000000*IOTHER+I,IFLG)
18996 * mesons: keep only those mesons where flag is set
18998 IF (IFLG.GT.0) THEN
19000 PMOMM(NOM) = PHKK(3,I)
19001 IDXM(NOM) = 10000000*IFLG+1000000*IOTHER+I
19008 * sort particles in the arrays according to increasing long. momentum
19009 CALL DT_SORT1(PMOMB,IDXB,NOB,1,NOB,1)
19010 CALL DT_SORT1(PMOMM,IDXM,NOM,1,NOM,1)
19012 * shuffle indices into one and the same array according to the later
19013 * sequence of correction
19017 IF (PMOMB(I).GT.ZERO) GOTO 911
19019 IDXCOR(NCOR) = IDXB(I)
19025 IF (PMOMB(I).LT.ZERO) GOTO 913
19027 IDXCOR(NCOR) = IDXB(I)
19032 IF (PMOMB(I).GT.ZERO) THEN
19034 IDXCOR(NCOR) = IDXB(I)
19042 IDXCOR(NCOR) = IDXB(I)
19046 IF (PMOMM(I).GT.ZERO) GOTO 926
19048 IDXCOR(NCOR) = IDXM(I)
19053 IF (PMOMM(I).LT.ZERO) GOTO 928
19055 IDXCOR(NCOR) = IDXM(I)
19059 C IF (NEVHKK.EQ.484) THEN
19060 C WRITE(LOUT,9000) JPCW,JPW-JPCW,JTCW,JTW-JTCW
19061 C 9000 FORMAT(1X,'wounded nucleons (proj.-p,n targ.-p,n)',/,4I10)
19062 C WRITE(LOUT,9001) NOB,NOM,NCOR
19063 C 9001 FORMAT(1X,'produced particles (baryons,mesons,all)',3I10)
19064 C WRITE(LOUT,'(/,A)') ' baryons '
19066 CC J = IABS(IDXB(I))
19067 CC INDEX = J-IABS(J/10000000)*10000000
19068 C IPOT = IABS(IDXB(I))/10000000
19069 C IOTHER = IABS(IDXB(I))/1000000-IPOT*10
19070 C INDEX = IABS(IDXB(I))-IPOT*10000000-IOTHER*1000000
19071 C WRITE(LOUT,9002) I,INDEX,IDXB(I),IDBAM(INDEX),PMOMB(I)
19073 C WRITE(LOUT,'(/,A)') ' mesons '
19075 CC INDEX = IDXM(I)-IABS(IDXM(I)/10000000)*10000000
19076 C IPOT = IABS(IDXM(I))/10000000
19077 C IOTHER = IABS(IDXM(I))/1000000-IPOT*10
19078 C INDEX = IABS(IDXM(I))-IPOT*10000000-IOTHER*1000000
19079 C WRITE(LOUT,9002) I,INDEX,IDXM(I),IDBAM(INDEX),PMOMM(I)
19081 C 9002 FORMAT(1X,4I14,E14.5)
19082 C WRITE(LOUT,'(/,A)') ' all '
19084 CC J = IABS(IDXCOR(I))
19085 CC INDEX = J-IABS(J/10000000)*10000000
19086 CC IPOT = IABS(IDXCOR(I))/10000000
19087 C IOTHER = IABS(IDXCOR(I))/1000000-IPOT*10
19088 C INDEX = IABS(IDXCOR(I))-IPOT*10000000-IOTHER*1000000
19089 C WRITE(LOUT,9003) I,INDEX,IDXCOR(I),IDBAM(INDEX)
19091 C 9003 FORMAT(1X,4I14)
19095 IPOT = IABS(IDXCOR(ICOR))/10000000
19096 IOTHER = IABS(IDXCOR(ICOR))/1000000-IPOT*10
19097 I = IABS(IDXCOR(ICOR))-IPOT*10000000-IOTHER*1000000
19102 * reduction of particle momentum by corresponding nuclear potential
19103 * (this applies only if Fermi-momenta are requested)
19107 * Lorentz-transformation into the rest system of the selected nucleus
19109 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
19110 & PSEC(1),PSEC(2),PSEC(3),PSEC(4),IDSEC,IMODE)
19111 PSECO = SQRT(PSEC(1)**2+PSEC(2)**2+PSEC(3)**2)
19112 AMSEC = SQRT(ABS((PSEC(4)-PSECO)*(PSEC(4)+PSECO)))
19116 IF ((EPROJ.GE.1.0D4).AND.(IDSEC.EQ.7)) CHKLEV = TINY1
19117 IF (EPROJ.GE.2.0D6) CHKLEV = 1.0D0
19118 IF (ABS(AMSEC-AAM(IDSEC)).GT.CHKLEV) THEN
19119 IF (IOULEV(3).GT.0)
19120 & WRITE(LOUT,2000) I,NEVHKK,IDSEC,AMSEC,AAM(IDSEC)
19121 2000 FORMAT(1X,'RESNCL: inconsistent mass of particle',
19122 & ' at entry ',I5,' (evt.',I8,')',/,' IDSEC: ',
19123 & I4,' AMSEC: ',E12.3,' AAM(IDSEC): ',E12.3,/)
19131 * the correction for nuclear potential effects is applied to as many
19132 * p/n as many nucleons were wounded; the momenta of other final state
19133 * particles are corrected only if they materialize inside the corresp.
19134 * nucleus (here: NOBAM = 1 part. outside proj., = 2 part. outside targ
19135 * = 3 part. outside proj. and targ., >=10 in overlapping region)
19136 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) THEN
19137 IF (IPOT.EQ.1) THEN
19138 IF ((JPW.GT.0).AND.(IOTHER.EQ.0)) THEN
19139 * this is most likely a wounded nucleon
19141 C RDIST = SQRT((VHKK(1,IPW(JPW))/FM2MM)**2
19142 C & +(VHKK(2,IPW(JPW))/FM2MM)**2
19143 C & +(VHKK(3,IPW(JPW))/FM2MM)**2)
19144 C RAD = RNUCLE*DBLE(IP)**ONETHI
19145 C FDEN = 1.4D0*DT_DENSIT(IP,RDIST,RAD)
19146 C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
19148 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19152 * correct only if part. was materialized inside nucleus
19153 * and if it is ouside the overlapping region
19154 IF ((NOBAM(I).NE.1).AND.(NOBAM(I).LT.3)) THEN
19155 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19159 ELSEIF (IPOT.EQ.2) THEN
19160 IF ((JTW.GT.0).AND.(IOTHER.EQ.0)) THEN
19161 * this is most likely a wounded nucleon
19163 C RDIST = SQRT((VHKK(1,ITW(JTW))/FM2MM)**2
19164 C & +(VHKK(2,ITW(JTW))/FM2MM)**2
19165 C & +(VHKK(3,ITW(JTW))/FM2MM)**2)
19166 C RAD = RNUCLE*DBLE(IT)**ONETHI
19167 C FDEN = 1.4D0*DT_DENSIT(IT,RDIST,RAD)
19168 C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
19170 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19174 * correct only if part. was materialized inside nucleus
19175 IF ((NOBAM(I).NE.2).AND.(NOBAM(I).LT.3)) THEN
19176 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19182 IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) THEN
19183 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19188 IF (NLOOP.EQ.1) THEN
19189 * Coulomb energy correction:
19190 * the treatment of Coulomb potential correction is similar to the
19191 * one for nuclear potential
19192 IF (IDSEC.EQ.1) THEN
19193 IF ((IPOT.EQ.1).AND.(JPCW.GT.0)) THEN
19195 ELSEIF ((IPOT.EQ.2).AND.(JTCW.GT.0)) THEN
19198 IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
19201 IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
19203 IF (IICH(IDSEC).EQ.1) THEN
19204 * pos. particles: check if they are able to escape Coulomb potential
19205 IF (PSEC(4).LT.AMSEC+ETACOU(IPOT)) THEN
19206 ISTHKK(I) = 14+IPOT
19207 IF (ISTHKK(I).EQ.15) THEN
19209 PHKK(K,I) = PSEC0(K)
19210 TRCLPR(K) = TRCLPR(K)+PSEC0(K)
19212 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
19213 IF (IDSEC.EQ.1) NPCW = NPCW-1
19214 ELSEIF (ISTHKK(I).EQ.16) THEN
19216 PHKK(K,I) = PSEC0(K)
19217 TRCLTA(K) = TRCLTA(K)+PSEC0(K)
19219 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
19220 IF (IDSEC.EQ.1) NTCW = NTCW-1
19224 ELSEIF (IICH(IDSEC).EQ.-1) THEN
19225 * neg. particles: decrease energy by Coulomb-potential
19226 PSEC(4) = PSEC(4)-ETACOU(IPOT)
19233 IF (PSEC(4).LT.AMSEC) THEN
19234 IF (IOULEV(6).GT.0)
19235 & WRITE(LOUT,2001) I,IDSEC,PSEC(4),AMSEC
19236 2001 FORMAT(1X,'KKINC: particle at DTEVT1-pos. ',I5,
19237 & ' is not allowed to escape nucleus',/,
19238 & 8X,'id : ',I3,' reduced energy: ',E15.4,
19240 ISTHKK(I) = 14+IPOT
19241 IF (ISTHKK(I).EQ.15) THEN
19243 PHKK(K,I) = PSEC0(K)
19244 TRCLPR(K) = TRCLPR(K)+PSEC0(K)
19246 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
19247 IF (IDSEC.EQ.1) NPCW = NPCW-1
19248 ELSEIF (ISTHKK(I).EQ.16) THEN
19250 PHKK(K,I) = PSEC0(K)
19251 TRCLTA(K) = TRCLTA(K)+PSEC0(K)
19253 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
19254 IF (IDSEC.EQ.1) NTCW = NTCW-1
19259 IF (JPMOD.EQ.1) THEN
19260 PSECN = SQRT( (PSEC(4)-AMSEC)*(PSEC(4)+AMSEC) )
19261 * 4-momentum after correction for nuclear potential
19263 PSEC(K) = PSEC(K)*PSECN/PSECO
19266 * store recoil momentum from particles escaping the nuclear potentials
19268 IF (IPOT.EQ.1) THEN
19269 TRCLPR(K) = TRCLPR(K)+PSEC0(K)-PSEC(K)
19270 ELSEIF (IPOT.EQ.2) THEN
19271 TRCLTA(K) = TRCLTA(K)+PSEC0(K)-PSEC(K)
19275 * transform momentum back into n-n cms
19277 CALL DT_LTRANS(PSEC(1),PSEC(2),PSEC(3),PSEC(4),
19278 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
19286 PFSP(K) = PFSP(K)+PHKK(K,I)
19291 DO 33 I=NPOINT(4),NHKK
19292 IF ((ISTHKK(I).EQ.1).AND.(IDXOTH(I).LT.0)) THEN
19293 PFSP(1) = PFSP(1)+PHKK(1,I)
19294 PFSP(2) = PFSP(2)+PHKK(2,I)
19295 PFSP(3) = PFSP(3)+PHKK(3,I)
19296 PFSP(4) = PFSP(4)+PHKK(4,I)
19301 PRCLPR(K) = TRCLPR(K)
19302 PRCLTA(K) = TRCLTA(K)
19305 IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
19306 * hadron-nucleus interactions: get residual momentum from energy-
19307 * momentum conservation
19310 PRCLTA(K) = PINIPR(K)+PINITA(K)-PFSP(K)
19313 * nucleus-hadron, nucleus-nucleus: get residual momentum from
19314 * accumulated recoil momenta of particles leaving the spectators
19315 * transform accumulated recoil momenta of residual nuclei into
19319 CALL DT_LTNUC(PZI,PEI,PRCLPR(3),PRCLPR(4),2)
19322 CALL DT_LTNUC(PZI,PEI,PRCLTA(3),PRCLTA(4),3)
19323 C IF (IP.GT.1) THEN
19324 PRCLPR(3) = PRCLPR(3)+PINIPR(3)
19325 PRCLPR(4) = PRCLPR(4)+PINIPR(4)
19328 PRCLTA(3) = PRCLTA(3)+PINITA(3)
19329 PRCLTA(4) = PRCLTA(4)+PINITA(4)
19333 * check momenta of residual nuclei
19335 CALL DT_EVTEMC(-PINIPR(1),-PINIPR(2),-PINIPR(3),-PINIPR(4),
19337 CALL DT_EVTEMC(-PINITA(1),-PINITA(2),-PINITA(3),-PINITA(4),
19339 CALL DT_EVTEMC(PRCLPR(1),PRCLPR(2),PRCLPR(3),PRCLPR(4),
19341 CALL DT_EVTEMC(PRCLTA(1),PRCLTA(2),PRCLTA(3),PRCLTA(4),
19343 CALL DT_EVTEMC(PFSP(1),PFSP(2),PFSP(3),PFSP(4),2,IDUM,IDUM)
19344 **sr 19.12. changed to avoid output when used with phojet
19347 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,501,IREJ1)
19348 C IF ((NEVHKK.EQ.409).OR.(NEVHKK.EQ.460).OR.(NEVHKK.EQ.765))
19349 C & CALL DT_EVTOUT(4)
19350 IF (IREJ1.GT.0) RETURN
19356 *$ CREATE DT_SCN4BA.FOR
19359 *===scn4ba=============================================================*
19361 SUBROUTINE DT_SCN4BA
19363 ************************************************************************
19364 * SCan /DTEVT1/ 4 BAryons which are not able to escape nuclear pot. *
19365 * This version dated 12.12.95 is written by S. Roesler. *
19366 ************************************************************************
19368 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19371 PARAMETER ( LINP = 10 ,
19375 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
19380 PARAMETER (NMXHKK=200000)
19382 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
19383 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
19384 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
19386 * extended event history
19387 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
19388 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
19391 * particle properties (BAMJET index convention)
19393 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19394 & IICH(210),IIBAR(210),K1(210),K2(210)
19396 * properties of interacting particles
19397 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
19399 * nuclear potential
19401 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
19402 & EBINDP(2),EBINDN(2),EPOT(2,210),
19403 & ETACOU(2),ICOUL,LFERMI
19405 * treatment of residual nuclei: wounded nucleons
19406 COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
19408 * treatment of residual nuclei: 4-momenta
19409 LOGICAL LRCLPR,LRCLTA
19410 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
19411 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
19413 DIMENSION PLAB(2,5),PCMS(4)
19417 * get number of wounded nucleons
19434 * projectile nucleons wounded in primary interaction and in fzc
19435 IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.17)) THEN
19439 IF (IDHKK(I).EQ.2212) NPCW = NPCW+1
19440 IF (ISTHKK(I).EQ.11) NPW0 = NPW0+1
19441 C IF (IP.GT.1) THEN
19443 TRCLPR(K) = TRCLPR(K)-PHKK(K,I)
19446 * target nucleons wounded in primary interaction and in fzc
19447 ELSEIF ((ISTHKK(I).EQ.12).OR.(ISTHKK(I).EQ.18)) THEN
19451 IF (IDHKK(I).EQ.2212) NTCW = NTCW+1
19452 IF (ISTHKK(I).EQ.12) NTW0 = NTW0+1
19455 TRCLTA(K) = TRCLTA(K)-PHKK(K,I)
19458 ELSEIF (ISTHKK(I).EQ.13) THEN
19460 ELSEIF (ISTHKK(I).EQ.14) THEN
19465 DO 11 I=NPOINT(4),NHKK
19466 * baryons which are unable to escape the nuclear potential of proj.
19467 IF (ISTHKK(I).EQ.15) THEN
19470 IF (IIBAR(IDBAM(I)).NE.0) THEN
19472 IF (IICH(IDBAM(I)).GT.0) NPCW = NPCW-1
19475 TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
19477 * baryons which are unable to escape the nuclear potential of targ.
19478 ELSEIF (ISTHKK(I).EQ.16) THEN
19481 IF (IIBAR(IDBAM(I)).NE.0) THEN
19483 IF (IICH(IDBAM(I)).GT.0) NTCW = NTCW-1
19486 TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
19491 * residual nuclei so far
19495 * ckeck for "residual nuclei" consisting of one nucleon only
19496 * treat it as final state particle
19497 IF (IRESP.EQ.1) THEN
19499 IST = ISTHKK(ISGLPR)
19500 CALL DT_LTRANS(PHKK(1,ISGLPR),PHKK(2,ISGLPR),
19501 & PHKK(3,ISGLPR),PHKK(4,ISGLPR),
19502 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,2)
19503 IF (IST.EQ.13) THEN
19504 ISTHKK(ISGLPR) = 11
19508 CALL DT_EVTPUT(1,IDHKK(ISGLPR),ISGLPR,0,
19509 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),
19510 & IDRES(ISGLPR),IDXRES(ISGLPR),IDCH(ISGLPR))
19511 NOBAM(NHKK) = NOBAM(ISGLPR)
19512 JDAHKK(1,ISGLPR) = NHKK
19514 TRCLPR(K) = TRCLPR(K)-PHKK(K,ISGLPR)
19517 IF (IREST.EQ.1) THEN
19519 IST = ISTHKK(ISGLTA)
19520 CALL DT_LTRANS(PHKK(1,ISGLTA),PHKK(2,ISGLTA),
19521 & PHKK(3,ISGLTA),PHKK(4,ISGLTA),
19522 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,3)
19523 IF (IST.EQ.14) THEN
19524 ISTHKK(ISGLTA) = 12
19528 CALL DT_EVTPUT(1,IDHKK(ISGLTA),ISGLTA,0,
19529 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),
19530 & IDRES(ISGLTA),IDXRES(ISGLTA),IDCH(ISGLTA))
19531 NOBAM(NHKK) = NOBAM(ISGLTA)
19532 JDAHKK(1,ISGLTA) = NHKK
19534 TRCLTA(K) = TRCLTA(K)-PHKK(K,ISGLTA)
19538 * get nuclear potential corresp. to the residual nucleus
19543 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
19545 * baryons unable to escape the nuclear potential are treated as
19546 * excited nucleons (ISTHKK=15,16)
19547 DO 3 I=NPOINT(4),NHKK
19548 IF (ISTHKK(I).EQ.1) THEN
19550 IF ( ((ID.EQ.1).OR.(ID.EQ.8)).AND.(NOBAM(I).NE.3) ) THEN
19551 * final state n and p not being outside of both nuclei are considered
19554 IF ( (IP.GT.1) .AND.(IRESP.GT.1).AND.
19555 & (NOBAM(I).NE.1).AND.(NPW.GT.0) ) THEN
19556 * Lorentz-trsf. into proj. rest sys. for those being inside proj.
19557 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
19558 & PHKK(4,I),PLAB(1,1),PLAB(1,2),PLAB(1,3),
19560 PLABT = SQRT(PLAB(1,1)**2+PLAB(1,2)**2+PLAB(1,3)**2)
19561 PLAB(1,5) = SQRT(ABS( (PLAB(1,4)-PLABT)*
19562 & (PLAB(1,4)+PLABT) ))
19563 EKIN = PLAB(1,4)-PLAB(1,5)
19564 IF (EKIN.LE.EPOT(1,ID)) NPOTP = 15
19565 IF ((ID.EQ.1).AND.(NPCW.LE.0)) NPOTP = 1
19567 IF ( (IT.GT.1) .AND.(IREST.GT.1).AND.
19568 & (NOBAM(I).NE.2).AND.(NTW.GT.0) ) THEN
19569 * Lorentz-trsf. into targ. rest sys. for those being inside targ.
19570 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
19571 & PHKK(4,I),PLAB(2,1),PLAB(2,2),PLAB(2,3),
19573 PLABT = SQRT(PLAB(2,1)**2+PLAB(2,2)**2+PLAB(2,3)**2)
19574 PLAB(2,5) = SQRT(ABS( (PLAB(2,4)-PLABT)*
19575 & (PLAB(2,4)+PLABT) ))
19576 EKIN = PLAB(2,4)-PLAB(2,5)
19577 IF (EKIN.LE.EPOT(2,ID)) NPOTT = 16
19578 IF ((ID.EQ.1).AND.(NTCW.LE.0)) NPOTT = 1
19580 IF (PHKK(3,I).GE.ZERO) THEN
19582 IF (NPOTP.NE.1) ISTHKK(I) = NPOTP
19585 IF (NPOTT.NE.1) ISTHKK(I) = NPOTT
19587 IF (ISTHKK(I).NE.1) THEN
19590 PHKK(K,I) = PLAB(J,K)
19592 IF (ISTHKK(I).EQ.15) THEN
19594 IF (ID.EQ.1) NPCW = NPCW-1
19596 TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
19598 ELSEIF (ISTHKK(I).EQ.16) THEN
19600 IF (ID.EQ.1) NTCW = NTCW-1
19602 TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
19610 * again: get nuclear potential corresp. to the residual nucleus
19615 c AFERP = 1.2D0*FERMOD*(ONE+(DBLE(IP+10-NPW0)/DBLE(IP+10))**1.1D0)
19616 cC AFERP = 1.21D0*FERMOD*(ONE+(DBLE(IP+40-NPW0)/DBLE(IP+40))**1.1D0)
19617 c & *(0.94D0+0.3D0*EXP(-DBLE(NPW0)/5.0D0)) /2.0D0
19619 c AFERT = 1.2D0*FERMOD*(ONE+(DBLE(IT+10-NTW0)/DBLE(IT+10))**1.1D0)
19620 cC AFERT = 1.21D0*FERMOD*(ONE+(DBLE(IT+40-NTW0)/DBLE(IT+40))**1.1D0)
19621 c & *(0.94D0+0.3D0*EXP(-DBLE(NTW0)/5.0D0)) /2.0D0
19623 C IF (AFERP.LT.FERMOD) AFERP = FERMOD+0.1
19624 C IF (AFERT.LT.FERMOD) AFERT = FERMOD+0.1
19625 C IF (AFERP.GT.0.85D0) AFERP = 0.85D0
19626 C IF (AFERT.GT.0.85D0) AFERT = 0.85D0
19627 AFERP = FERMOD+0.1D0
19628 AFERT = FERMOD+0.1D0
19630 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,AFERP,AFERT,1)
19635 *$ CREATE DT_FICONF.FOR
19638 *===ficonf=============================================================*
19640 SUBROUTINE DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ)
19642 ************************************************************************
19643 * Treatment of FInal CONFiguration including evaporation, fission and *
19644 * Fermi-break-up (for light nuclei only). *
19645 * Adopted from the original routine FINALE and extended to residual *
19646 * projectile nuclei. *
19647 * This version dated 12.12.95 is written by S. Roesler. *
19649 * Last change 27.12.2006 by S. Roesler. *
19650 ************************************************************************
19652 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19655 PARAMETER ( LINP = 10 ,
19659 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
19660 PARAMETER (ANGLGB=5.0D-16)
19664 PARAMETER (NMXHKK=200000)
19666 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
19667 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
19668 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
19670 * extended event history
19671 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
19672 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
19675 * rejection counter
19676 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
19677 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
19678 & IREXCI(3),IRDIFF(2),IRINC
19680 * central particle production, impact parameter biasing
19681 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
19683 * particle properties (BAMJET index convention)
19685 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19686 & IICH(210),IIBAR(210),K1(210),K2(210)
19688 * treatment of residual nuclei: 4-momenta
19689 LOGICAL LRCLPR,LRCLTA
19690 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
19691 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
19693 * treatment of residual nuclei: properties of residual nuclei
19694 COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
19695 & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
19696 & NTOTFI(2),NPROFI(2)
19698 * statistics: residual nuclei
19699 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
19700 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
19701 & NINCST(2,4),NINCEV(2),
19702 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
19703 & NRESPB(2),NRESCH(2),NRESEV(4),
19704 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
19707 * flags for input different options
19708 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
19709 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
19710 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
19712 * INCLUDE '(DIMPAR)'
19713 * DIMPAR taken from FLUKA
19714 PARAMETER ( MXXRGN =20000 )
19715 PARAMETER ( MXXMDF = 710 )
19716 PARAMETER ( MXXMDE = 702 )
19717 PARAMETER ( MFSTCK =40000 )
19718 PARAMETER ( MESTCK = 100 )
19719 PARAMETER ( MOSTCK = 2000 )
19720 PARAMETER ( MXPRSN = 100 )
19721 PARAMETER ( MXPDPM = 800 )
19722 PARAMETER ( MXPSCS =30000 )
19723 PARAMETER ( MXGLWN = 300 )
19724 PARAMETER ( MXOUTU = 50 )
19725 PARAMETER ( NALLWP = 64 )
19726 PARAMETER ( NELEMX = 80 )
19727 PARAMETER ( MPDPDX = 18 )
19728 PARAMETER ( MXHTTR = 260 )
19729 PARAMETER ( MXSEAX = 20 )
19730 PARAMETER ( MXHTNC = MXSEAX + 1 )
19731 PARAMETER ( ICOMAX = 2400 )
19732 PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
19733 PARAMETER ( NSTBIS = 304 )
19734 PARAMETER ( NQSTIS = 46 )
19735 PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
19736 PARAMETER ( MXPABL = 120 )
19737 PARAMETER ( IDMAXP = 450 )
19738 PARAMETER ( IDMXDC = 2000 )
19739 PARAMETER ( MXMCIN = 410 )
19740 PARAMETER ( IHYPMX = 4 )
19741 PARAMETER ( MKBMX1 = 11 )
19742 PARAMETER ( MKBMX2 = 11 )
19743 PARAMETER ( MXIRRD = 2500 )
19744 PARAMETER ( MXTRDC = 1500 )
19745 PARAMETER ( NKTL = 17 )
19746 PARAMETER ( NBLNMX = 40000000 )
19748 * INCLUDE '(GENSTK)'
19749 * GENSTK taken from FLUKA
19750 COMMON / GENSTK / CXR (MXPSCS), CYR (MXPSCS),
19751 & CZR (MXPSCS), CXRPOL (MXPSCS), CYRPOL (MXPSCS),
19752 & CZRPOL (MXPSCS), TKI (MXPSCS), PLR (MXPSCS),
19753 & WEI (MXPSCS), AGESEC (MXPSCS), TV , TVCMS ,
19754 & TVRECL, TVHEAV, TVBIND,
19755 & KPART (MXPSCS), INFEXT (MXPSCS), NP0 , NP
19757 * INCLUDE '(RESNUC)'
19758 * RESNUC from FLUKA
19759 LOGICAL LRNFSS, LFRAGM
19760 COMMON /RESNUC/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
19761 & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
19762 & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES,
19763 & PYRES, PZRES, PTRES2, ANGRES, ANXRES, ANYRES,
19764 & ANZRES, TVESTR, ANESTR, BHYRES (IHYPMX),
19765 & KTARP, KTARN, IGREYP, IGREYN, IPDPM0, IPDPM1,
19766 & IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE, ICRES,
19767 & IBRES, ISTRES, ISMRES, IHYRES, IEVAPL, IEVAPH,
19768 & IEVPHO, IEVNEU, IEVPRO, IEVDEU, IEVTRI, IEV3HE,
19769 & IEV4HE, IDEEXG, IBTAR, ICHTAR, IBLEFT, ICLEFT,
19770 & ICESTR, IBESTR, IOTHER, KHYRES (IHYPMX),
19773 PARAMETER ( EMVGEV = 1.0 D-03 )
19774 PARAMETER ( AMUGEV = 0.93149432 D+00 )
19775 PARAMETER ( AMPRTN = 0.93827231 D+00 )
19776 PARAMETER ( AMNTRN = 0.93956563 D+00 )
19777 PARAMETER ( AMELCT = 0.51099906 D-03 )
19778 PARAMETER ( ELCCGS = 4.8032068 D-10 )
19779 PARAMETER ( ELCMKS = 1.60217733 D-19 )
19780 PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
19782 PARAMETER ( HLFHLF = 0.5D+00 )
19783 PARAMETER ( FERTHO = 14.33 D-09 )
19784 PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
19785 PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
19786 PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
19788 * INCLUDE '(NUCDAT)'
19790 PARAMETER ( AMUAMU = AMUGEV )
19791 PARAMETER ( AMPROT = AMPRTN )
19792 PARAMETER ( AMNEUT = AMNTRN )
19793 PARAMETER ( AMELEC = AMELCT )
19794 PARAMETER ( R0NUCL = 1.12 D+00 )
19795 PARAMETER ( RCCOUL = 1.7 D+00 )
19796 PARAMETER ( COULPR = COUGFM )
19797 PARAMETER ( AMHYDR = AMPRTN + AMELCT )
19798 PARAMETER ( AMHTON = AMHYDR - AMNTRN )
19799 PARAMETER ( AMNTOU = AMNTRN - AMUC12 )
19800 PARAMETER ( AMUCSQ = AMUC12 * AMUC12 )
19801 PARAMETER ( EBNDAV = HLFHLF * (AMPRTN + AMNTRN) - AMUC12 )
19802 * Gammin : threshold for deexcitation gammas production, set to 1 keV
19803 * (this means that up to 1 keV of energy unbalancing can occur
19805 PARAMETER ( GAMMIN = 1.0D-06 )
19806 PARAMETER ( GAMNSQ = 2.0D+00 * GAMMIN * GAMMIN )
19807 * Tvepsi : "epsilon" for excitation energy, set to gammin / 100
19808 PARAMETER ( TVEPSI = GAMMIN / 100.D+00 )
19810 COMMON /NUCDAT/ AV0WEL, APFRMX, AEFRMX, AEFRMA,
19811 & RDSNUC, V0WELL (2), PFRMMX (2), EFRMMX (2),
19812 & EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2),
19813 & VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2),
19814 & PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2),
19815 & EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2),
19816 & ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV ,
19817 & AMRCSQ , ATO1O3 , ZTO1O3 , FRMRFC ,
19820 * INCLUDE '(PAREVT)'
19822 PARAMETER ( FRDIFF = 0.2D+00 )
19823 PARAMETER ( ETHSEA = 1.0D+00 )
19825 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
19826 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
19827 & LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR,
19828 & LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
19829 COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
19830 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
19831 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
19832 & LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LPHDRC,
19833 & LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, LRVKIN,
19834 & LVP2XX, LV2XNW, LNWV2X, LEVFIN
19836 * INCLUDE '(FHEAVY)'
19838 PARAMETER ( MXHEAV = 100 )
19839 PARAMETER ( KXHEAV = 30 )
19841 COMMON / FHEAVY / CXHEAV (MXHEAV), CYHEAV (MXHEAV),
19842 & CZHEAV (MXHEAV), TKHEAV (MXHEAV),
19843 & PHEAVY (MXHEAV), WHEAVY (MXHEAV),
19844 & AGHEAV (MXHEAV), BHHEAV (IHYPMX,KXHEAV),
19845 & AMHEAV (KXHEAV), AMNHEA (KXHEAV),
19846 & KHEAVY (MXHEAV), INFHEA (MXHEAV),
19847 & ICHEAV (KXHEAV), IBHEAV (KXHEAV),
19848 & IMHEAV (KXHEAV), IHHEAV (KXHEAV),
19849 & KHHEAV (IHYPMX,KXHEAV), NPHEAV
19850 COMMON / FHEAVC / ANHEAV (KXHEAV)
19853 COMMON /DTEVNO/ NEVENT,ICASCA
19855 DIMENSION INUC(2),IDXPAR(2),IDPAR(2),AIF(2),AIZF(2),AMRCL(2),
19856 & PRCL(2,4),MO1(2),MO2(2),VRCL(2,4),WRCL(2,4),
19857 & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4)
19859 DIMENSION EXPNUC(2),EXC(2,260),NEXC(2,260)
19861 DATA EXC,NEXC /520*ZERO,520*0/
19862 DATA EXPNUC /4.0D-3,4.0D-3/
19868 * skip residual nucleus treatment if not requested or in case
19869 * of central collisions
19870 IF ((.NOT.LEVPRT).OR.(ICENTR.GT.0).OR.(ICENTR.EQ.-1)) RETURN
19897 * number of final state particles
19898 IF (ABS(ISTHKK(I)).EQ.1) THEN
19903 * properties of remaining nucleon configurations
19905 IF ((ISTHKK(I).EQ.13).OR.(ISTHKK(I).EQ.15)) KF = 1
19906 IF ((ISTHKK(I).EQ.14).OR.(ISTHKK(I).EQ.16)) KF = 2
19908 IF (MO1(KF).EQ.0) MO1(KF) = I
19910 * position of residual nucleus = average position of nucleons
19912 VRCL(KF,K) = VRCL(KF,K)+VHKK(K,I)
19913 WRCL(KF,K) = WRCL(KF,K)+WHKK(K,I)
19915 * total number of particles contributing to each residual nucleus
19916 NTOT(KF) = NTOT(KF)+1
19919 * total charge of residual nuclei
19920 NQ(KF) = NQ(KF)+IICH(IDTMP)
19921 * number of protons
19922 IF (IDHKK(I).EQ.2212) THEN
19923 NPRO(KF) = NPRO(KF)+1
19924 * number of neutrons
19925 ELSEIF (IDHKK(I).EQ.2112) THEN
19928 * number of baryons other than n, p
19929 IF (IIBAR(IDTMP).EQ.1) THEN
19931 IF (IICH(IDTMP).EQ.1) NHPOS(KF) = NHPOS(KF)+1
19933 * any other mesons (status set to 1)
19934 C WRITE(LOUT,1002) KF,IDTMP
19935 C1002 FORMAT(1X,'FICONF: residual nucleus ',I2,
19936 C & ' containing meson ',I4,', status set to 1')
19939 IDXTMP = IDXPAR(KF)
19940 NTOT(KF) = NTOT(KF)-1
19944 IDXPAR(KF) = IDXTMP
19948 * reject elastic events (def: one final state particle = projectile)
19949 IF ((IP.EQ.1).AND.(NFSP.EQ.1).AND.(IDFSP.EQ.IJPROJ)) THEN
19950 IREXCI(3) = IREXCI(3)+1
19955 * check if one nucleus disappeared..
19956 C IF ((IP.GT.1).AND.(NTOT(1).EQ.0).AND.(NTOT(2).NE.0)) THEN
19958 C PRCLTA(K) = PRCLTA(K)+PRCLPR(K)
19961 C ELSEIF ((IT.GT.1).AND.(NTOT(2).EQ.0).AND.(NTOT(1).NE.0)) THEN
19963 C PRCLPR(K) = PRCLPR(K)+PRCLTA(K)
19972 * get the average of the nucleon positions
19973 VRCL(I,K) = VRCL(I,K)/MAX(NTOT(I),1)
19974 WRCL(I,K) = WRCL(I,K)/MAX(NTOT(I),1)
19975 IF (I.EQ.1) PRCL(1,K) = PRCLPR(K)
19976 IF (I.EQ.2) PRCL(2,K) = PRCLTA(K)
19978 * mass number and charge of residual nuclei
19979 AIF(I) = DBLE(NTOT(I))
19980 AIZF(I) = DBLE(NPRO(I)+NHPOS(I))
19981 IF (NTOT(I).GT.1) THEN
19982 * masses of residual nuclei in ground state
19984 C AMRCL0(I) = AIF(I)*AMUAMU+1.0D-3*ENERGY(AIF(I),AIZF(I))
19985 AMRCL0(I) = AIF(I)*AMUC12
19986 & +EMVGEV*EXMSAZ(AIF(I),AIZF(I),.TRUE.,IZDUM)
19988 * masses of residual nuclei
19989 PTORCL = SQRT(PRCL(I,1)**2+PRCL(I,2)**2+PRCL(I,3)**2)
19990 AMRCL(I) = (PRCL(I,4)-PTORCL)*(PRCL(I,4)+PTORCL)
19991 IF (AMRCL(I).GT.ZERO) AMRCL(I) = SQRT(AMRCL(I))
19993 * M_res^2 < 0 : configuration not allowed
19995 * a) re-calculate E_exc with scaled nuclear potential
19996 * (conditional jump to label 9998)
19997 * b) or reject event if N_loop(max) is exceeded
19998 * (conditional jump to label 9999)
20000 IF (AMRCL(I).LE.ZERO) THEN
20001 IF (IOULEV(3).GT.0)
20002 & WRITE(LOUT,1000) I,PRCL(I,1),PRCL(I,2),PRCL(I,3),
20004 1000 FORMAT(1X,'warning! negative excitation energy',/,
20008 IF (NLOOP.LE.500) THEN
20011 IREXCI(2) = IREXCI(2)+1
20015 * 0 < M_res < M_res0 : mass below ground-state mass
20017 * a) we had residual nuclei with mass N_tot and reasonable E_exc
20018 * before- assign average E_exc of those configurations to this
20019 * one ( Nexc(i,N_tot) > 0 )
20020 * b) or (and this applies always if run in transport codes) go up
20021 * one mass number and
20022 * i) if mass now larger than proj/targ mass or if run in
20023 * transport codes assign average E_exc per wounded nucleon
20024 * x number of wounded nucleons (Inuc-Ntot)
20025 * ii) or assign average E_exc of those configurations to this
20026 * one ( Nexc(i,m) > 0 )
20028 ELSEIF ((AMRCL(I).GT.ZERO).AND.(AMRCL(I).LT.AMRCL0(I)))
20030 M = MIN(NTOT(I),260)
20031 IF (NEXC(I,M).GT.0) THEN
20032 AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
20036 **sr corrected 27.12.06
20037 * IF (M.GE.INUC(I)) THEN
20038 * AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I))
20039 IF ((M.GE.INUC(I)).OR.(ICASCA.GT.0)) THEN
20040 IF ( INUC (I) .GT. NTOT (I) ) THEN
20041 AMRCL(I) = AMRCL0(I)
20042 & + EXPNUC(I)*DBLE(MAX(INUC(I)-NTOT(I),0))
20044 AMRCL(I) = AMRCL0(I) + 0.5D+00 * EXPNUC(I)
20048 IF (NEXC(I,M).GT.0) THEN
20049 AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
20055 EEXC(I) = AMRCL(I)-AMRCL0(I)
20058 * M_res > 2.5 x M_res0 : unreasonably(?) high E_exc
20060 * a) re-calculate E_exc with scaled nuclear potential
20061 * (conditional jump to label 9998)
20062 * b) or reject event if N_loop(max) is exceeded
20063 * (conditional jump to label 9999)
20066 ELSEIF (AMRCL(I).GE.2.5D0*AMRCL0(I)) THEN
20067 IF (IOULEV(3).GT.0)
20068 & WRITE(LOUT,1004) I,AMRCL(I),AMRCL0(I),NTOT,NEVHKK
20069 1004 FORMAT(1X,'warning! too high excitation energy',/,
20070 & I4,1P,2E15.4,3I5)
20073 IF (NLOOP.LE.500) THEN
20076 IREXCI(2) = IREXCI(2)+1
20080 * Otherwise (reasonable E_exc) :
20081 * E_exc = M_res - M_res0
20082 * in addition: calculate and save E_exc per wounded nucleon as
20083 * well as E_exc in <E_exc> counter
20086 * excitation energies of residual nuclei
20087 EEXC(I) = AMRCL(I)-AMRCL0(I)
20088 **sr 27.12.06 new excitation energy correction by A.F.
20090 * all parts with Ilcopt<3 commented since not used
20092 * still to be done/decided:
20093 * Increase Icor and put back both residual nuclei on mass shell
20094 * with the exciting correction further below.
20095 * For the moment the modification in the excitation energy is simply
20096 * corrected by scaling the energy of the residual nucleus.
20101 NNCHIT = MAX ( INUC (I) - NTOT (I), 0 )
20102 IF ( ILCOPT .LE. 2 ) THEN
20103 C* Patch for Fermi momentum reduction correlated with impact parameter:
20104 C FRMRDC = MIN ( (PFRMAV(INUC(I))/APFRMX)**3, ONE )
20105 C DLKPRH = 0.1D+00 + 0.5D+00 / SQRT(DBLE(INUC(I)))
20106 C AKPRHO = ONE - DLKPRH
20107 C* f x K rho_cen + (1-f) x 0.5 x K rho_cen = frmrdc x rho_cen
20108 C FRCFLL = MAX ( 2.D+00 * FRMRDC / AKPRHO - ONE,
20110 C* REDORI = 0.75D+00
20112 C REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
20115 RDCORE = 1.14D+00 * DBLE(INUC(I))**(ONE/3.D+00)
20116 * Take out roughly one/half of the skin:
20117 RDCORE = RDCORE - 0.5D+00
20119 PRSKIN = (RDCORE+2.4D+00)**3 - FRCFLL
20120 PRSKIN = 0.5D+00 * PRSKIN / ( PRSKIN + FRCFLL )
20121 FRCFLL = ONE - PRSKIN
20122 FRMRDC = FRCFLL + 0.5D+00 * PRSKIN
20123 REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
20125 IF ( NNCHIT .GT. 0 ) THEN
20126 C IF ( ILCOPT .EQ. 1 ) THEN
20127 C SKINRH = ONE - FRCFLL / (DBLE(INUC(I))-ONE)
20128 C DO 1220 NCH = 1, 10
20129 C ETAETA = ( ONE - SKINRH**INUC(I)
20130 C & - DBLE(INUC(I))* ( ONE - FRCFLL )
20131 C & * ( ONE - SKINRH ) )
20132 C & / ( SKINRH**INUC(I) - DBLE (INUC(I))
20133 C & * ( ONE - FRCFLL) * SKINRH )
20134 C SKINRH = SKINRH * ( ONE + ETAETA )
20136 C PRSKIN = SKINRH**(NNCHIT-1)
20137 C ELSE IF ( ILCOPT .EQ. 2 ) THEN
20138 C PRSKIN = ONE - FRCFLL
20141 DO 1230 NCH = 1, NNCHIT
20142 IF (DT_RNDM(PRFRMI) .LT. PRSKIN) THEN
20143 PRFRMI = (( ONE - 2.D+00 * DLKPRH )
20144 & * DT_RNDM(PRFRMI))**0.333333333333D+00
20146 PRFRMI = ( ONE - 2.D+00 * DLKPRH
20147 & * DT_RNDM(PRFRMI))**0.333333333333D+00
20149 REDCTN = REDCTN + PRFRMI**2
20151 REDCTN = REDCTN / DBLE (NNCHIT)
20155 EEXC (I) = EEXC (I) * REDCTN / REDORI
20156 AMRCL (I) = AMRCL0 (I) + EEXC (I)
20157 PRCL(I,4) = SQRT ( PTORCL**2 + AMRCL(I)**2 )
20160 IF (ICASCA.EQ.0) THEN
20161 EXPNUC(I) = EEXC(I)/MAX(1,INUC(I)-NTOT(I))
20162 M = MIN(NTOT(I),260)
20163 EXC(I,M) = EXC(I,M)+EEXC(I)
20164 NEXC(I,M) = NEXC(I,M)+1
20167 ELSEIF (NTOT(I).EQ.1) THEN
20169 1003 FORMAT(1X,'FICONF: warning! NTOT(I)=1? (I=',I3,')')
20179 PRCLPR(5) = AMRCL(1)
20180 PRCLTA(5) = AMRCL(2)
20182 IF (ICOR.GT.0) THEN
20183 IF (INORCL.EQ.0) THEN
20184 * one or both residual nuclei consist of one nucleon only, transform
20185 * this nucleon on mass shell
20187 P1IN(K) = PRCL(1,K)
20188 P2IN(K) = PRCL(2,K)
20192 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
20193 IF (IREJ1.GT.0) THEN
20194 WRITE(LOUT,*) 'ficonf-mashel rejection'
20198 PRCL(1,K) = P1OUT(K)
20199 PRCL(2,K) = P2OUT(K)
20200 PRCLPR(K) = P1OUT(K)
20201 PRCLTA(K) = P2OUT(K)
20203 PRCLPR(5) = AMRCL(1)
20204 PRCLTA(5) = AMRCL(2)
20206 IF (IOULEV(3).GT.0)
20207 & WRITE(LOUT,1001) NEVHKK,INT(AIF(1)),INT(AIZF(1)),
20208 & INT(AIF(2)),INT(AIZF(2)),AMRCL0(1),
20209 & AMRCL(1),AMRCL(1)-AMRCL0(1),AMRCL0(2),
20210 & AMRCL(2),AMRCL(2)-AMRCL0(2)
20211 1001 FORMAT(1X,'FICONF: warning! no residual nucleus for',
20212 & ' correction',/,11X,'at event',I8,
20213 & ', nucleon config. 1:',2I4,' 2:',2I4,
20215 IF (NLOOP.LE.500) THEN
20218 IREXCI(1) = IREXCI(1)+1
20224 C IF (NRESEV(1).NE.NEVHKK) THEN
20225 C NRESEV(1) = NEVHKK
20226 C NRESEV(2) = NRESEV(2)+1
20228 NRESEV(2) = NRESEV(2)+1
20230 EXCDPM(I) = EXCDPM(I)+EEXC(I)
20231 EXCDPM(I+2) = EXCDPM(I+2)+(EEXC(I)/MAX(NTOT(I),1))
20232 NRESTO(I) = NRESTO(I)+NTOT(I)
20233 NRESPR(I) = NRESPR(I)+NPRO(I)
20234 NRESNU(I) = NRESNU(I)+NN(I)
20235 NRESBA(I) = NRESBA(I)+NH(I)
20236 NRESPB(I) = NRESPB(I)+NHPOS(I)
20237 NRESCH(I) = NRESCH(I)+NQ(I)
20243 * initialize evaporation counter
20245 IF ((INUC(I).GT.1).AND.(AIF(I).GT.ONE).AND.
20246 & (EEXC(I).GT.ZERO)) THEN
20247 * put residual nuclei into DTEVT1
20249 JMASS = INT( AIF(I))
20250 JCHAR = INT(AIZF(I))
20251 * the following patch is required to transmit the correct excitation
20253 IF (ITRSPT.EQ.1) THEN
20254 IF ((ABS(AMRCL(I)-AMRCL0(I)-EEXC(I)).GT.1.D-04).AND.
20255 & (IOULEV(3).GT.0))
20257 & ' DT_FICONF:AMRCL(I),AMRCL0(I),EEXC(I)',
20258 & AMRCL(I),AMRCL0(I),EEXC(I)
20260 PRCL(I,4) =SQRT(AMRCL(I)**2+PRCL(I,1)**2+PRCL(I,2)**2
20262 IF (ABS(PRCL0-PRCL(I,4)).GT.0.1D0) THEN
20264 & ' PRCL(I,4) recalculated :',PRCL0,PRCL(I,4)
20267 CALL DT_EVTPUT(1000,IDRCL,MO1(I),MO2(I),PRCL(I,1),
20268 & PRCL(I,2),PRCL(I,3),PRCL(I,4),JMASS,JCHAR,0)
20273 VHKK(J,NHKK) = VRCL(I,J)
20274 WHKK(J,NHKK) = WRCL(I,J)
20276 * interface to evaporation module - fill final residual nucleus into
20278 * fill resnuc only if code is not used as event generator in Fluka
20279 IF (ITRSPT.NE.1) THEN
20283 IBRES = NPRO(I)+NN(I)+NH(I)
20284 ICRES = NPRO(I)+NHPOS(I)
20287 PTRES = SQRT(PXRES**2+PYRES**2+PZRES**2)
20288 * ground state mass of the residual nucleus (should be equal to AM0T)
20291 AMMRES = AMNAMA ( AMNRES, IBRES, ICRES )
20295 * kinetic energy of residual nucleus
20296 TVRECL = PRCL(I,4)-AMRCL(I)
20297 * excitation energy of residual nucleus
20300 PTRES = SQRT(ABS(TVRECL*(TVRECL+
20301 & 2.0D0*(AMMRES+TVCMS))))
20302 IF (PTOLD.LT.ANGLGB) THEN
20303 CALL DT_RACO(PXRES,PYRES,PZRES)
20306 PXRES = PXRES*PTRES/PTOLD
20307 PYRES = PYRES*PTRES/PTOLD
20308 PZRES = PZRES*PTRES/PTOLD
20309 * zero counter of secondaries from evaporation
20319 * put evaporated particles and residual nuclei to DTEVT1
20321 CALL DT_EVA2HE(MO,EXCITF,I,IREJ1)
20324 EXCEVA(I) = EXCEVA(I)+EXCITF
20331 C9998 IREXCI(1) = IREXCI(1)+1
20340 *$ CREATE DT_EVA2HE.FOR
20343 *====eva2he============================================================*
20345 SUBROUTINE DT_EVA2HE(MO,EEXCF,IRCL,IREJ)
20347 ************************************************************************
20348 * Interface between common's of evaporation module (FKFINU,FKFHVY) *
20350 * MO DTEVT1-index of "mother" (residual) nucleus before evap. *
20351 * EEXCF exitation energy of residual nucleus after evaporation *
20352 * IRCL = 1 projectile residual nucleus *
20353 * = 2 target residual nucleus *
20354 * This version dated 19.04.95 is written by S. Roesler. *
20356 * Last change 27.12.2006 by S. Roesler. *
20357 ************************************************************************
20359 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20362 PARAMETER ( LINP = 10 ,
20366 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3)
20370 PARAMETER (NMXHKK=200000)
20372 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
20373 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
20374 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
20375 * Note: DTEVT2 - special use for heavy fragments !
20376 * (IDRES(I) = mass number, IDXRES(I) = charge)
20378 * extended event history
20379 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
20380 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
20383 * particle properties (BAMJET index convention)
20385 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20386 & IICH(210),IIBAR(210),K1(210),K2(210)
20388 * flags for input different options
20389 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
20390 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
20391 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
20393 * statistics: residual nuclei
20394 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
20395 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
20396 & NINCST(2,4),NINCEV(2),
20397 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
20398 & NRESPB(2),NRESCH(2),NRESEV(4),
20399 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
20402 * treatment of residual nuclei: properties of residual nuclei
20403 COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
20404 & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
20405 & NTOTFI(2),NPROFI(2)
20407 * INCLUDE '(DIMPAR)'
20409 PARAMETER ( MXXRGN =20000 )
20410 PARAMETER ( MXXMDF = 710 )
20411 PARAMETER ( MXXMDE = 702 )
20412 PARAMETER ( MFSTCK =40000 )
20413 PARAMETER ( MESTCK = 100 )
20414 PARAMETER ( MOSTCK = 2000 )
20415 PARAMETER ( MXPRSN = 100 )
20416 PARAMETER ( MXPDPM = 800 )
20417 PARAMETER ( MXPSCS =30000 )
20418 PARAMETER ( MXGLWN = 300 )
20419 PARAMETER ( MXOUTU = 50 )
20420 PARAMETER ( NALLWP = 64 )
20421 PARAMETER ( NELEMX = 80 )
20422 PARAMETER ( MPDPDX = 18 )
20423 PARAMETER ( MXHTTR = 260 )
20424 PARAMETER ( MXSEAX = 20 )
20425 PARAMETER ( MXHTNC = MXSEAX + 1 )
20426 PARAMETER ( ICOMAX = 2400 )
20427 PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
20428 PARAMETER ( NSTBIS = 304 )
20429 PARAMETER ( NQSTIS = 46 )
20430 PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
20431 PARAMETER ( MXPABL = 120 )
20432 PARAMETER ( IDMAXP = 450 )
20433 PARAMETER ( IDMXDC = 2000 )
20434 PARAMETER ( MXMCIN = 410 )
20435 PARAMETER ( IHYPMX = 4 )
20436 PARAMETER ( MKBMX1 = 11 )
20437 PARAMETER ( MKBMX2 = 11 )
20438 PARAMETER ( MXIRRD = 2500 )
20439 PARAMETER ( MXTRDC = 1500 )
20440 PARAMETER ( NKTL = 17 )
20441 PARAMETER ( NBLNMX = 40000000 )
20443 * INCLUDE '(GENSTK)'
20445 PARAMETER ( MXP = MXPSCS )
20447 COMMON / GENSTK / CXR (MXPSCS), CYR (MXPSCS),
20448 & CZR (MXPSCS), CXRPOL (MXPSCS), CYRPOL (MXPSCS),
20449 & CZRPOL (MXPSCS), TKI (MXPSCS), PLR (MXPSCS),
20450 & WEI (MXPSCS), AGESEC (MXPSCS), TV , TVCMS ,
20451 & TVRECL, TVHEAV, TVBIND,
20452 & KPART (MXPSCS), INFEXT (MXPSCS), NP0 , NP
20454 * INCLUDE '(RESNUC)'
20455 LOGICAL LRNFSS, LFRAGM
20456 COMMON /RESNUC/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
20457 & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
20458 & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES,
20459 & PYRES, PZRES, PTRES2, ANGRES, ANXRES, ANYRES,
20460 & ANZRES, TVESTR, ANESTR, BHYRES (IHYPMX),
20461 & KTARP, KTARN, IGREYP, IGREYN, IPDPM0, IPDPM1,
20462 & IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE, ICRES,
20463 & IBRES, ISTRES, ISMRES, IHYRES, IEVAPL, IEVAPH,
20464 & IEVPHO, IEVNEU, IEVPRO, IEVDEU, IEVTRI, IEV3HE,
20465 & IEV4HE, IDEEXG, IBTAR, ICHTAR, IBLEFT, ICLEFT,
20466 & ICESTR, IBESTR, IOTHER, KHYRES (IHYPMX),
20470 * INCLUDE '(FHEAVY)'
20472 PARAMETER ( MXHEAV = 100 )
20473 PARAMETER ( KXHEAV = 30 )
20475 COMMON / FHEAVY / CXHEAV (MXHEAV), CYHEAV (MXHEAV),
20476 & CZHEAV (MXHEAV), TKHEAV (MXHEAV),
20477 & PHEAVY (MXHEAV), WHEAVY (MXHEAV),
20478 & AGHEAV (MXHEAV), BHHEAV (IHYPMX,KXHEAV),
20479 & AMHEAV (KXHEAV), AMNHEA (KXHEAV),
20480 & KHEAVY (MXHEAV), INFHEA (MXHEAV),
20481 & ICHEAV (KXHEAV), IBHEAV (KXHEAV),
20482 & IMHEAV (KXHEAV), IHHEAV (KXHEAV),
20483 & KHHEAV (IHYPMX,KXHEAV), NPHEAV
20484 COMMON / FHEAVC / ANHEAV (KXHEAV)
20486 DIMENSION IPTOKP(39)
20487 DATA IPTOKP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
20488 & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 99,
20489 & 100, 101, 97, 102, 98, 103, 109, 115 /
20493 * skip if evaporation package is not included
20494 IF (.NOT.LEVAPO) RETURN
20497 IF (NRESEV(3).NE.NEVHKK) THEN
20499 NRESEV(4) = NRESEV(4)+1
20503 & CALL DT_EVTEMC(PHKK(1,MO),PHKK(2,MO),PHKK(3,MO),PHKK(4,MO),1,
20505 * mass number/charge of residual nucleus before evaporation
20509 * protons/neutrons/gammas
20514 ID = IPTOKP(KPART(I))
20515 IDPDG = IDT_IPDGHA(ID)
20516 AM = ((PLR(I)+TKI(I))*(PLR(I)-TKI(I)))/
20517 & (2.0D0*MAX(TKI(I),TINY10))
20518 IF (ABS(AM-AAM(ID)).GT.TINY3) THEN
20519 WRITE(LOUT,1000) ID,AM,AAM(ID)
20520 1000 FORMAT(1X,'EVA2HE: inconsistent mass of evap. ',
20521 & 'particle',I3,2E10.3)
20524 CALL DT_EVTPUT(-1,IDPDG,MO,0,PX,PY,PZ,PE,0,0,0)
20526 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
20527 IBTOT = IBTOT-IIBAR(ID)
20528 IZTOT = IZTOT-IICH(ID)
20533 PX = CXHEAV(I)*PHEAVY(I)
20534 PY = CYHEAV(I)*PHEAVY(I)
20535 PZ = CZHEAV(I)*PHEAVY(I)
20537 AM = ((PHEAVY(I)+TKHEAV(I))*(PHEAVY(I)-TKHEAV(I)))/
20538 & (2.0D0*MAX(TKHEAV(I),TINY10))
20540 CALL DT_EVTPUT(-1,IDHEAV,MO,0,PX,PY,PZ,PE,
20541 & IBHEAV(KHEAVY(I)),ICHEAV(KHEAVY(I)),0)
20543 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
20544 IBTOT = IBTOT-IBHEAV(KHEAVY(I))
20545 IZTOT = IZTOT-ICHEAV(KHEAVY(I))
20548 IF (IBRES.GT.0) THEN
20549 * residual nucleus after evaporation
20551 CALL DT_EVTPUT(1001,IDNUC,MO,0,PXRES,PYRES,PZRES,ERES,
20556 NTOTFI(IRCL) = IBRES
20557 NPROFI(IRCL) = ICRES
20558 IF (LEMCCK) CALL DT_EVTEMC(-PXRES,-PYRES,-PZRES,-ERES,2,IDUM,IDUM)
20559 IBTOT = IBTOT-IBRES
20560 IZTOT = IZTOT-ICRES
20562 * count events with fission
20563 NEVAFI(1,IRCL) = NEVAFI(1,IRCL)+1
20564 IF (LRNFSS) NEVAFI(2,IRCL) = NEVAFI(2,IRCL)+1
20566 * energy-momentum conservation check
20567 IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,40,IREJ)
20568 C IF (IREJ.GT.0) THEN
20569 C CALL DT_EVTOUT(4)
20570 C WRITE(*,*) EEXC(2),EEXCFI(2),NP,NPHEAV
20572 * baryon-number/charge conservation check
20573 IF (IBTOT+IZTOT.NE.0) THEN
20574 WRITE(LOUT,1001) NEVHKK,IBTOT,IZTOT
20575 1001 FORMAT(1X,'EVA2HE: baryon-number/charge conservation ',
20576 & 'failure at event ',I8,' : IBTOT,IZTOT = ',2I3)
20582 *$ CREATE DT_EBIND.FOR
20585 *===ebind==============================================================*
20587 DOUBLE PRECISION FUNCTION DT_EBIND(IA,IZ)
20589 ************************************************************************
20590 * Binding energy for nuclei. *
20591 * (Shirokov & Yudin, Yad. Fizika, Nauka, Moskva 1972) *
20593 * IZ atomic number *
20594 * This version dated 5.5.95 is updated by S. Roesler. *
20595 ************************************************************************
20597 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20600 PARAMETER ( LINP = 10 ,
20604 PARAMETER (ZERO=0.0D0)
20606 DATA A1, A2, A3, A4, A5
20607 & / 0.01575D0, 0.0178D0, 0.000710D0, 0.0237D0, 0.034D0/
20609 IF ((IA.LE.1).OR.(IZ.EQ.0)) THEN
20610 WRITE(LOUT,'(1X,A,2I5)') 'DT_EBIND IA,IZ set EBIND=0. ',IA,IZ
20615 DT_EBIND = A1*AA - A2*AA**0.666667D0-A3*IZ*IZ*AA**(-0.333333D0)
20616 & -A4*(IA-2*IZ)**2/AA
20617 IF (MOD(IA,2).EQ.1) THEN
20619 ELSEIF (MOD(IZ,2).EQ.1) THEN
20624 DT_EBIND = DT_EBIND - IA5*A5*AA**(-0.75D0)
20629 ************************************************************************
20631 * DPMJET 3.0: cross section routines *
20633 ************************************************************************
20636 * SUBROUTINE DT_SHNDIF
20637 * diffractive cross sections (all energies)
20638 * SUBROUTINE DT_PHOXS
20639 * total and inel. cross sections from PHOJET interpol. tables
20640 * SUBROUTINE DT_XSHN
20641 * total and el. cross sections for all energies
20642 * SUBROUTINE DT_SIHNAB
20643 * pion 2-nucleon absorption cross sections
20644 * SUBROUTINE DT_SIGEMU
20645 * cross section for target "compounds"
20646 * SUBROUTINE DT_SIGGA
20647 * photon nucleus cross sections
20648 * SUBROUTINE DT_SIGGAT
20649 * photon nucleus cross sections from tables
20650 * SUBROUTINE DT_SANO
20651 * anomalous hard photon-nucleon cross sections from tables
20652 * SUBROUTINE DT_SIGGP
20653 * photon nucleon cross sections
20654 * SUBROUTINE DT_SIGVEL
20655 * quasi-elastic vector meson prod. cross sections
20656 * DOUBLE PRECISION FUNCTION DT_SIGVP
20658 * DOUBLE PRECISION FUNCTION DT_RRM2
20659 * DOUBLE PRECISION FUNCTION DT_RM2
20660 * DOUBLE PRECISION FUNCTION DT_SAM2
20661 * SUBROUTINE DT_CKMT
20662 * SUBROUTINE DT_CKMTX
20663 * SUBROUTINE DT_PDF0
20664 * SUBROUTINE DT_CKMTQ0
20665 * SUBROUTINE DT_CKMTDE
20666 * SUBROUTINE DT_CKMTPR
20667 * FUNCTION DT_CKMTFF
20669 * SUBROUTINE DT_FLUINI
20670 * total nucleon cross section fluctuation treatment
20672 * SUBROUTINE DT_SIGTBL
20673 * pre-tabulation of low-energy elastic x-sec. using SIHNEL
20674 * SUBROUTINE DT_XSTABL
20678 *$ CREATE DT_SHNDIF.FOR
20681 *===shndif===============================================================*
20683 SUBROUTINE DT_SHNDIF(ECM,KPROJ,KTARG,SIGDIF,SIGDIH)
20685 **********************************************************************
20686 * Single diffractive hadron-nucleon cross sections *
20687 * S.Roesler 14/1/93 *
20689 * The cross sections are calculated from extrapolated single *
20690 * diffractive antiproton-proton cross sections (DTUJET92) using *
20691 * scaling relations between total and single diffractive cross *
20693 **********************************************************************
20695 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20697 PARAMETER (ZERO=0.0D0)
20699 * particle properties (BAMJET index convention)
20701 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20702 & IICH(210),IIBAR(210),K1(210),K2(210)
20704 CSD1 = 4.201483727D0
20705 CSD4 = -0.4763103556D-02
20706 CSD5 = 0.4324148297D0
20708 CHMSD1 = 0.8519297242D0
20709 CHMSD4 = -0.1443076599D-01
20710 CHMSD5 = 0.4014954567D0
20712 EPN = (ECM**2 -AAM(KPROJ)**2 -AAM(KTARG)**2)/(2.0D0*AAM(KTARG))
20713 PPN = SQRT((EPN-AAM(KPROJ))*(EPN+AAM(KPROJ)))
20715 SDIAPP = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
20716 SHMSD = CHMSD1+CHMSD4*LOG(PPN)**2+CHMSD5*LOG(PPN)
20717 FRAC = SHMSD/SDIAPP
20719 GOTO( 10, 20,999,999,999,999,999, 10, 20,999,
20720 & 999, 20, 20, 20, 20, 20, 10, 20, 20, 10,
20721 & 10, 10, 20, 20, 20) KPROJ
20724 *---------------------------- p - p , n - p , sigma0+- - p ,
20726 CSD1 = 6.004476070D0
20727 CSD4 = -0.1257784606D-03
20728 CSD5 = 0.2447335720D0
20729 SIGDIF = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
20730 SIGDIH = FRAC*SIGDIF
20737 C F = SDIAPP/DT_SHNTOT(KPSCAL,KTSCAL,ECM,ZERO)
20739 CALL DT_XSHN(KPSCAL,KTSCAL,DUMZER,ECM,SIGTO,SIGEL)
20742 C SIGDIF = DT_SHNTOT(KPROJ,KT,ECM,ZERO)*F
20743 CALL DT_XSHN(KPROJ,KT,DUMZER,ECM,SIGTO,SIGEL)
20745 SIGDIH = FRAC*SIGDIF
20749 *-------------------------- leptons..
20755 *$ CREATE DT_PHOXS.FOR
20758 *===phoxs================================================================*
20760 SUBROUTINE DT_PHOXS(KPROJ,KTARG,ECM,PLAB,STOT,SINE,SDIF1,BEL,MODE)
20762 ************************************************************************
20763 * Total/inelastic proton-nucleon cross sections taken from PHOJET- *
20764 * interpolation tables. *
20765 * This version dated 05.11.97 is written by S. Roesler *
20766 ************************************************************************
20768 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20771 PARAMETER ( LINP = 10 ,
20775 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
20776 PARAMETER (TWOPI = 6.283185307179586454D+00,
20778 & GEV2MB = 0.38938D0)
20781 DATA LFIRST /.TRUE./
20783 * nucleon-nucleon event-generator
20786 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
20788 * particle properties (BAMJET index convention)
20790 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20791 & IICH(210),IIBAR(210),K1(210),K2(210)
20794 C PARAMETER (IEETAB=10)
20795 C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
20798 C energy-interpolation table
20800 PARAMETER ( IEETA2 = 20 )
20802 DOUBLE PRECISION SIGTAB,SIGECM
20803 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
20806 IF ((MCGENE.NE.2).AND.(MODE.NE.1)) THEN
20807 WRITE(LOUT,*) MCGENE
20808 1000 FORMAT(1X,'PHOXS: warning! PHOJET not initialized (',I2,')')
20812 IF (ECM.LE.ZERO) THEN
20813 EPN = SQRT(AAM(KPROJ)**2+PLAB**2)
20814 ECM = SQRT(AAM(KPROJ)**2+AAM(KTARG)**2+2.0D0*EPN*AAM(KTARG))
20817 IF (MODE.EQ.1) THEN
20822 STOT = 21.7D0*S**DELDL+56.08D0*S**EPSDL
20824 BEL = 8.5D0+2.D0*ALPHAP*LOG(S)
20825 SIGEL = STOT**2/(16.D0*PI*BEL*GEV2MB)
20831 IF(ECM.LE.SIGECM(IP,1)) THEN
20834 ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
20836 IF (ECM.LE.SIGECM(IP,I)) GOTO 2
20843 WRITE(LOUT,'(/1X,A,2E12.3)')
20844 & 'PHOXS: warning! energy above initialization limit (',
20845 & ECM,SIGECM(IP,ISIMAX)
20852 IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
20853 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
20855 STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
20856 SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
20857 SDIF1 = FAC2*(SIGTAB(IP,30,I2)+SIGTAB(IP,32,I2))+
20858 & FAC1*(SIGTAB(IP,30,I1)+SIGTAB(IP,32,I1))
20859 BEL = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
20865 *$ CREATE DT_XSHN.FOR
20868 *===xshn===============================================================*
20870 SUBROUTINE DT_XSHN(IP,IT,PL,ECM,STOT,SELA)
20872 ************************************************************************
20873 * Total and elastic hadron-nucleon cross section. *
20874 * Below 500GeV cross sections are based on the '98 data compilation *
20875 * of the PDG. At higher energies PHOJET results are used (patched to *
20876 * the low energy data at 500GeV). *
20877 * IP projectile index (BAMJET numbering scheme) *
20878 * (should be in the range 1..25) *
20879 * IT target index (BAMJET numbering scheme) *
20880 * (1 = proton, 8 = neutron) *
20881 * PL laboratory momentum *
20882 * ECM cm. energy (ignored if PL>0) *
20883 * STOT total cross section *
20884 * SELA elastic cross section *
20885 * Last change: 24.4.99 by S. Roesler *
20886 ************************************************************************
20888 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20891 PARAMETER ( LINP = 10 ,
20895 PARAMETER (ZERO=0.0D0,ONE=1.0D0)
20897 PARAMETER (NPOIN1 = 54, NPOIN2 = 8,
20898 & PLABLO = 0.1D0, PTHRE = 5.0D0, PLABHI = 500.0D0)
20899 PARAMETER (NPOINT = NPOIN1+NPOIN2+1)
20903 * particle properties (BAMJET index convention)
20905 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20906 & IICH(210),IIBAR(210),K1(210),K2(210)
20908 * nucleon-nucleon event-generator
20911 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
20913 C PARAMETER (IEETAB=10)
20914 C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
20917 C energy-interpolation table
20919 PARAMETER ( IEETA2 = 20 )
20921 DOUBLE PRECISION SIGTAB,SIGECM
20922 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
20924 DIMENSION APL(NPOINT),ASIGTO(10,NPOINT),ASIGEL(10,NPOINT)
20925 DIMENSION IDXDAT(25,2)
20928 &-1.000,-0.969,-0.937,-0.906,-0.874,-0.843,-0.811,-0.780,-0.748,
20929 &-0.717,-0.685,-0.654,-0.622,-0.591,-0.560,-0.528,-0.497,-0.465,
20930 &-0.434,-0.402,-0.371,-0.339,-0.308,-0.276,-0.245,-0.213,-0.182,
20931 &-0.151,-0.119,-0.088,-0.056,-0.025, 0.007, 0.038, 0.070, 0.101,
20932 & 0.133, 0.164, 0.196, 0.227, 0.258, 0.290, 0.321, 0.353, 0.384,
20933 & 0.416, 0.447, 0.479, 0.510, 0.542, 0.573, 0.605, 0.636, 0.668,
20934 & 0.699, 0.949, 1.199, 1.449, 1.699, 1.949, 2.199, 2.449, 2.699/
20936 * total cross sections:
20938 DATA (ASIGTO(1,K),K=1,NPOINT) /
20939 & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
20940 & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
20941 & 1.577, 1.518, 1.462, 1.420, 1.393, 1.375, 1.363, 1.356, 1.352,
20942 & 1.350, 1.351, 1.359, 1.381, 1.410, 1.444, 1.487, 1.544, 1.596,
20943 & 1.650, 1.672, 1.676, 1.677, 1.677, 1.675, 1.675, 1.669, 1.664,
20944 & 1.658, 1.653, 1.645, 1.640, 1.634, 1.630, 1.625, 1.620, 1.617,
20945 & 1.614, 1.602, 1.594, 1.589, 1.581, 1.583, 1.588, 1.596, 1.603/
20947 DATA (ASIGTO(2,K),K=1,NPOINT) /
20948 & 2.778, 2.759, 2.739, 2.718, 2.697, 2.675, 2.651, 2.626, 2.598,
20949 & 2.569, 2.537, 2.502, 2.471, 2.443, 2.420, 2.389, 2.361, 2.329,
20950 & 2.313, 2.304, 2.268, 2.244, 2.222, 2.212, 2.178, 2.162, 2.151,
20951 & 2.132, 2.109, 2.097, 2.089, 2.078, 2.063, 2.049, 2.035, 2.024,
20952 & 2.014, 2.004, 1.993, 1.981, 1.970, 1.958, 1.946, 1.933, 1.921,
20953 & 1.909, 1.894, 1.885, 1.871, 1.854, 1.836, 1.825, 1.816, 1.802,
20954 & 1.790, 1.744, 1.694, 1.663, 1.642, 1.614, 1.623, 1.623, 1.630/
20956 DATA (ASIGTO(3,K),K=1,NPOINT) /
20957 & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
20958 & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
20959 & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
20960 & 1.547, 1.534, 1.526, 1.522, 1.520, 1.525, 1.536, 1.550, 1.566,
20961 & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
20962 & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
20963 & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
20965 DATA (ASIGTO(4,K),K=1,NPOINT) /
20966 & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
20967 & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
20968 & 2.001, 1.875, 1.801, 1.665, 1.609, 1.484, 1.412, 1.334, 1.195,
20969 & 1.160, 1.166, 1.208, 1.309, 1.356, 1.394, 1.406, 1.419, 1.473,
20970 & 1.540, 1.596, 1.570, 1.533, 1.516, 1.484, 1.471, 1.478, 1.492,
20971 & 1.497, 1.491, 1.479, 1.465, 1.453, 1.449, 1.450, 1.444, 1.428,
20972 & 1.422, 1.406, 1.384, 1.369, 1.364, 1.369, 1.374, 1.388, 1.395/
20974 DATA (ASIGTO(5,K),K=1,NPOINT) /
20975 & 0.458, 0.540, 0.626, 0.718, 0.819, 0.933, 1.063, 1.208, 1.226,
20976 & 1.436, 1.470, 1.594, 1.708, 1.786, 1.852, 1.836, 1.763, 1.679,
20977 & 1.590, 1.492, 1.445, 1.426, 1.423, 1.433, 1.473, 1.506, 1.547,
20978 & 1.660, 1.671, 1.545, 1.591, 1.687, 1.808, 1.656, 1.582, 1.543,
20979 & 1.562, 1.560, 1.537, 1.540, 1.549, 1.557, 1.557, 1.551, 1.535,
20980 & 1.527, 1.511, 1.510, 1.507, 1.500, 1.491, 1.483, 1.478, 1.468,
20981 & 1.463, 1.435, 1.408, 1.394, 1.384, 1.380, 1.383, 1.393, 1.411/
20983 DATA (ASIGTO(6,K),K=1,NPOINT) /
20984 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
20985 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
20986 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.096, 1.095,
20987 & 1.098, 1.105, 1.111, 1.139, 1.169, 1.209, 1.248, 1.259, 1.268,
20988 & 1.262, 1.257, 1.254, 1.252, 1.250, 1.249, 1.246, 1.244, 1.244,
20989 & 1.243, 1.240, 1.238, 1.237, 1.236, 1.235, 1.235, 1.236, 1.236,
20990 & 1.236, 1.233, 1.238, 1.248, 1.257, 1.272, 1.292, 1.311, 1.336/
20992 DATA (ASIGTO(7,K),K=1,NPOINT) /
20993 & 2.003, 2.002, 2.001, 2.000, 1.999, 1.998, 1.998, 1.997, 1.997,
20994 & 1.996, 1.995, 1.993, 1.990, 1.992, 1.974, 1.912, 1.865, 1.847,
20995 & 1.896, 1.950, 1.827, 1.681, 1.637, 1.616, 1.589, 1.545, 1.543,
20996 & 1.532, 1.603, 1.604, 1.616, 1.658, 1.700, 1.658, 1.595, 1.508,
20997 & 1.493, 1.514, 1.531, 1.523, 1.501, 1.479, 1.474, 1.467, 1.463,
20998 & 1.450, 1.444, 1.435, 1.426, 1.424, 1.423, 1.415, 1.401, 1.396,
20999 & 1.384, 1.364, 1.330, 1.313, 1.310, 1.309, 1.317, 1.329, 1.338/
21001 DATA (ASIGTO(8,K),K=1,NPOINT) /
21002 & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21003 & 0.631, 0.675, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21004 & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.102, 1.125, 1.147,
21005 & 1.168, 1.187, 1.205, 1.224, 1.248, 1.279, 1.315, 1.324, 1.301,
21006 & 1.285, 1.279, 1.274, 1.273, 1.272, 1.271, 1.267, 1.263, 1.261,
21007 & 1.259, 1.256, 1.252, 1.247, 1.244, 1.241, 1.240, 1.240, 1.240,
21008 & 1.241, 1.243, 1.245, 1.253, 1.265, 1.275, 1.293, 1.314, 1.342/
21010 DATA (ASIGTO(9,K),K=1,NPOINT) /
21011 & 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778,
21012 & 1.778, 1.778, 1.778, 1.778, 1.778, 1.779, 1.779, 1.778, 1.773,
21013 & 1.765, 1.746, 1.703, 1.646, 1.561, 1.488, 1.454, 1.437, 1.437,
21014 & 1.458, 1.505, 1.561, 1.588, 1.593, 1.581, 1.551, 1.500, 1.454,
21015 & 1.427, 1.408, 1.390, 1.372, 1.361, 1.356, 1.351, 1.347, 1.343,
21016 & 1.341, 1.340, 1.338, 1.337, 1.335, 1.334, 1.332, 1.331, 1.330,
21017 & 1.330, 1.313, 1.303, 1.288, 1.288, 1.297, 1.305, 1.320, 1.342/
21019 DATA (ASIGTO(10,K),K=1,NPOINT) /
21020 & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21021 & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.629,
21022 & 1.599, 1.576, 1.558, 1.543, 1.530, 1.520, 1.512, 1.505, 1.499,
21023 & 1.495, 1.495, 1.497, 1.504, 1.514, 1.525, 1.536, 1.550, 1.567,
21024 & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
21025 & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
21026 & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
21028 * elastic cross sections:
21030 DATA (ASIGEL(1,K),K=1,NPOINT) /
21031 & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
21032 & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
21033 & 1.577, 1.518, 1.462, 1.420, 1.393, 1.374, 1.360, 1.353, 1.350,
21034 & 1.351, 1.356, 1.362, 1.369, 1.376, 1.384, 1.385, 1.399, 1.397,
21035 & 1.389, 1.385, 1.379, 1.366, 1.358, 1.344, 1.320, 1.294, 1.275,
21036 & 1.260, 1.248, 1.235, 1.219, 1.199, 1.172, 1.144, 1.126, 1.115,
21037 & 1.104, 1.013, 0.962, 0.905, 0.869, 0.845, 0.846, 0.850, 0.868/
21039 DATA (ASIGEL(2,K),K=1,NPOINT) /
21040 & 1.987, 1.985, 1.983, 1.980, 1.978, 1.975, 1.971, 1.968, 1.963,
21041 & 1.958, 1.951, 1.944, 1.935, 1.925, 1.914, 1.902, 1.889, 1.875,
21042 & 1.859, 1.845, 1.834, 1.817, 1.792, 1.769, 1.754, 1.738, 1.720,
21043 & 1.702, 1.688, 1.676, 1.667, 1.659, 1.652, 1.645, 1.640, 1.636,
21044 & 1.620, 1.591, 1.562, 1.546, 1.540, 1.524, 1.496, 1.475, 1.457,
21045 & 1.429, 1.402, 1.373, 1.344, 1.330, 1.306, 1.294, 1.265, 1.228,
21046 & 1.204, 1.086, 0.977, 0.933, 0.914, 0.850, 0.862, 0.848, 0.845/
21048 DATA (ASIGEL(3,K),K=1,NPOINT) /
21049 & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
21050 & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
21051 & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
21052 & 1.544, 1.527, 1.514, 1.504, 1.495, 1.486, 1.476, 1.466, 1.454,
21053 & 1.440, 1.425, 1.409, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21054 & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21055 & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21057 DATA (ASIGEL(4,K),K=1,NPOINT) /
21058 & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
21059 & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
21060 & 2.001, 1.875, 1.801, 1.664, 1.610, 1.479, 1.423, 1.299, 1.166,
21061 & 1.097, 1.020, 0.958, 0.914, 1.013, 1.088, 1.153, 1.167, 1.235,
21062 & 1.240, 1.237, 1.202, 1.135, 1.090, 1.026, 0.975, 0.941, 0.904,
21063 & 0.894, 0.884, 0.862, 0.850, 0.845, 0.827, 0.805, 0.789, 0.776,
21064 & 0.763, 0.686, 0.626, 0.562, 0.505, 0.518, 0.525, 0.528, 0.528/
21066 DATA (ASIGEL(5,K),K=1,NPOINT) /
21067 & 0.266, 0.278, 0.294, 0.320, 0.360, 0.419, 0.503, 0.608, 0.727,
21068 & 0.850, 0.968, 1.071, 1.167, 1.305, 1.369, 1.404, 1.446, 1.217,
21069 & 1.112, 1.071, 1.014, 1.002, 0.996, 1.008, 1.070, 1.126, 1.209,
21070 & 1.300, 1.281, 1.188, 1.156, 1.341, 1.423, 1.314, 1.171, 1.140,
21071 & 1.106, 1.071, 1.011, 1.037, 1.026, 1.024, 0.988, 0.953, 0.895,
21072 & 0.894, 0.880, 0.871, 0.864, 0.853, 0.837, 0.820, 0.809, 0.800,
21073 & 0.782, 0.674, 0.612, 0.530, 0.521, 0.528, 0.524, 0.542, 0.569/
21075 DATA (ASIGEL(6,K),K=1,NPOINT) /
21076 & 1.064, 1.065, 1.065, 1.066, 1.066, 1.066, 1.066, 1.066, 1.066,
21077 & 1.065, 1.064, 1.063, 1.062, 1.062, 1.062, 1.064, 1.066, 1.070,
21078 & 1.076, 1.082, 1.088, 1.096, 1.103, 1.104, 1.104, 1.102, 1.093,
21079 & 1.087, 1.084, 1.079, 1.075, 1.067, 1.058, 1.040, 1.029, 1.012,
21080 & 1.003, 0.985, 0.935, 0.909, 0.880, 0.846, 0.790, 0.771, 0.759,
21081 & 0.743, 0.718, 0.681, 0.666, 0.645, 0.622, 0.606, 0.594, 0.584,
21082 & 0.575, 0.513, 0.453, 0.403, 0.356, 0.365, 0.389, 0.430, 0.477/
21084 DATA (ASIGEL(7,K),K=1,NPOINT) /
21085 & 1.941, 1.936, 1.931, 1.926, 1.919, 1.912, 1.903, 1.892, 1.878,
21086 & 1.863, 1.844, 1.821, 1.791, 1.755, 1.713, 1.666, 1.615, 1.561,
21087 & 1.533, 1.531, 1.518, 1.511, 1.452, 1.339, 1.265, 1.233, 1.188,
21088 & 1.184, 1.236, 1.316, 1.333, 1.336, 1.333, 1.277, 1.216, 1.077,
21089 & 1.018, 0.912, 0.926, 0.920, 0.910, 0.894, 0.830, 0.825, 0.800,
21090 & 0.788, 0.747, 0.703, 0.707, 0.689, 0.643, 0.633, 0.635, 0.618,
21091 & 0.584, 0.579, 0.461, 0.403, 0.405, 0.399, 0.408, 0.418, 0.413/
21093 DATA (ASIGEL(8,K),K=1,NPOINT) /
21094 & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21095 & 0.631, 0.676, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21096 & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.103, 1.126, 1.148,
21097 & 1.168, 1.187, 1.205, 1.223, 1.248, 1.282, 1.269, 1.185, 1.111,
21098 & 1.063, 1.031, 0.998, 0.964, 0.928, 0.889, 0.849, 0.814, 0.785,
21099 & 0.760, 0.738, 0.720, 0.703, 0.688, 0.674, 0.660, 0.648, 0.635,
21100 & 0.624, 0.536, 0.473, 0.442, 0.428, 0.428, 0.436, 0.453, 0.477/
21102 DATA (ASIGEL(9,K),K=1,NPOINT) /
21103 & 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613,
21104 & 1.613, 1.613, 1.613, 1.612, 1.613, 1.614, 1.614, 1.612, 1.606,
21105 & 1.593, 1.564, 1.498, 1.402, 1.240, 1.071, 0.977, 0.922, 0.914,
21106 & 0.961, 1.077, 1.214, 1.271, 1.290, 1.281, 1.217, 1.096, 0.979,
21107 & 0.896, 0.822, 0.736, 0.655, 0.608, 0.591, 0.580, 0.569, 0.559,
21108 & 0.550, 0.540, 0.531, 0.522, 0.514, 0.507, 0.500, 0.494, 0.489,
21109 & 0.485, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477/
21111 DATA (ASIGEL(10,K),K=1,NPOINT) /
21112 & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21113 & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.630,
21114 & 1.600, 1.577, 1.558, 1.542, 1.528, 1.518, 1.510, 1.505, 1.502,
21115 & 1.501, 1.500, 1.499, 1.496, 1.491, 1.485, 1.477, 1.466, 1.454,
21116 & 1.440, 1.425, 1.408, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21117 & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21118 & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21120 DATA (IDXDAT(K,1),K=1,25) /
21121 & 1, 2, 0, 0, 0, 0, 0, 3, 2, 0, 0,67, 4, 5, 6, 7,10, 2,67, 3,
21123 DATA (IDXDAT(K,2),K=1,25) /
21124 & 3, 2, 0, 0, 0, 0, 0, 1, 2, 0, 0,89, 5, 4, 8, 9, 1, 2,89, 1,
21127 DATA LFIRST /.TRUE./
21130 APLABL = LOG10(PLABLO)
21131 APLABH = LOG10(PLABHI)
21132 APTHRE = LOG10(PTHRE)
21133 ADP1 = (APTHRE-APLABL)/DBLE(NPOIN1)
21134 ADP2 = (APLABH-APTHRE)/DBLE(NPOIN2)
21137 PHOELA = SQRT(AAM(1)**2+PHOPLA**2)
21138 ECMS = SQRT(2.0D0*AAM(1)**2+2.0D0*AAM(1)*PHOELA)
21139 IF (MCGENE.EQ.2) THEN
21140 IF (ECMS.LE.SIGECM(1,ISIMAX)) THEN
21141 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,0)
21143 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21146 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21148 PHOSEL = PHOSTO-PHOSIN
21149 APHOST = LOG10(PHOSTO)
21150 APHOSE = LOG10(PHOSEL)
21157 IF ( (IP.LT.1).OR.((IT.NE.1).AND.(IT.NE.8)) ) THEN
21158 WRITE(LOUT,1000) IP,IT
21159 1000 FORMAT(1X,'DT_XSHN: cross sections not implemented for ',
21160 & 'proj/target',2I4)
21164 IF ((PLAB.LE.ZERO).AND.(ECMS.GT.ZERO)) THEN
21165 ELAB = (ECMS**2-AAM(IP)**2-AAM(IT)**2)/(2.0D0*AAM(IT))
21166 PLAB = SQRT((ELAB-AAM(IP))*(ELAB+AAM(IP)))
21167 ELSEIF ((PLAB.LE.ZERO).AND.(ECMS.LE.ZERO)) THEN
21168 WRITE(LOUT,1001) PLAB,ECMS
21169 1001 FORMAT(1X,'DT_XSHN: invalid momentum/cm-energy ',2E15.5)
21173 * index of spectrum
21176 IF (AAM(IP).GT.ZERO) THEN
21177 IF (ABS(IIBAR(IP)).GT.0) THEN
21187 IF (IT.EQ.8) IDXT = 2
21188 IDXS = IDXDAT(IDXP,IDXT)
21189 IF (IDXS.EQ.0) RETURN
21191 * compute momentum bin indices
21192 IF (PLAB.LT.PLABLO) THEN
21195 ELSEIF (PLAB.GE.PLABHI) THEN
21199 APLAB = LOG10(PLAB)
21200 IF ((PLAB.GE.PLABLO).AND.(PLAB.LT.PTHRE )) THEN
21201 IDX0 = INT((APLAB-APLABL)/ADP1)+1
21202 ELSEIF ((PLAB.GE.PTHRE ).AND.(PLAB.LT.PLABHI)) THEN
21203 IDX0 = INT((APLAB-APTHRE)/ADP2)+NPOIN1+1
21208 * interpolate cross section
21209 IF (IDXS.GT.10) THEN
21211 IDXS2 = IDXS-10*IDXS1
21212 IF (IDX0.EQ.IDX1) THEN
21213 IF (IDX0.EQ.1) THEN
21214 ASTOT = 0.5D0*(ASIGTO(IDXS1,IDX0)+ASIGTO(IDXS2,IDX0))
21215 ASELA = 0.5D0*(ASIGEL(IDXS1,IDX0)+ASIGEL(IDXS2,IDX0))
21218 CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21219 PHOSEL = PHOSTO-PHOSIN
21220 ASTOT1 = ASIGTO(IDXS1,NPOINT)-APHOST+LOG10(PHOSTO)
21221 ASELA1 = ASIGEL(IDXS1,NPOINT)-APHOSE+LOG10(PHOSEL)
21222 ASTOT2 = ASIGTO(IDXS2,NPOINT)-APHOST+LOG10(PHOSTO)
21223 ASELA2 = ASIGEL(IDXS2,NPOINT)-APHOSE+LOG10(PHOSEL)
21224 ASTOT = 0.5D0*(ASTOT1+ASTOT2)
21225 ASELA = 0.5D0*(ASELA1+ASELA2)
21228 FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21229 ASTOT1 = ASIGTO(IDXS1,IDX0)+
21230 & FAC*(ASIGTO(IDXS1,IDX1)-ASIGTO(IDXS1,IDX0))
21231 ASTOT2 = ASIGTO(IDXS2,IDX0)+
21232 & FAC*(ASIGTO(IDXS2,IDX1)-ASIGTO(IDXS2,IDX0))
21233 ASTOT = 0.5D0*(ASTOT1+ASTOT2)
21234 ASELA1 = ASIGEL(IDXS1,IDX0)+
21235 & FAC*(ASIGEL(IDXS1,IDX1)-ASIGEL(IDXS1,IDX0))
21236 ASELA2 = ASIGEL(IDXS2,IDX0)+
21237 & FAC*(ASIGEL(IDXS2,IDX1)-ASIGEL(IDXS2,IDX0))
21238 ASELA = 0.5D0*(ASELA1+ASELA2)
21241 IF (IDX0.EQ.IDX1) THEN
21242 IF (IDX0.EQ.1) THEN
21243 ASTOT = ASIGTO(IDXS,IDX0)
21244 ASELA = ASIGEL(IDXS,IDX0)
21247 CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21248 PHOSEL = PHOSTO-PHOSIN
21249 ASTOT = ASIGTO(IDXS,NPOINT)-APHOST+LOG10(PHOSTO)
21250 ASELA = ASIGEL(IDXS,NPOINT)-APHOSE+LOG10(PHOSEL)
21253 FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21254 ASTOT = ASIGTO(IDXS,IDX0)+
21255 & FAC*(ASIGTO(IDXS,IDX1)-ASIGTO(IDXS,IDX0))
21256 ASELA = ASIGEL(IDXS,IDX0)+
21257 & FAC*(ASIGEL(IDXS,IDX1)-ASIGEL(IDXS,IDX0))
21260 STOT = 10.0D0**ASTOT
21261 SELA = 10.0D0**ASELA
21266 *$ CREATE DT_SIHNAB.FOR
21269 *===sihnab===============================================================*
21271 SUBROUTINE DT_SIHNAB(IDP,IDT,PLAB,SIGABS)
21273 **********************************************************************
21274 * Pion 2-nucleon absorption cross sections. *
21275 * (sigma_tot for pi+ d --> p p, pi- d --> n n *
21276 * taken from Ritchie PRC 28 (1983) 926 ) *
21277 * This version dated 18.05.96 is written by S. Roesler *
21278 **********************************************************************
21280 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21282 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY3=1.0D-3)
21283 PARAMETER (AMPR = 938.0D0,
21293 IF ( ((IDP.NE.13).AND.(IDP.NE.14).AND.(IDP.NE.23))
21294 & .OR.((IDT.NE.1).AND.(IDT.NE.8)) ) RETURN
21296 EKIN = SQRT(AMPI**2+PTOT**2)-AMPI
21297 IF ((EKIN.LT.TINY3).OR.(EKIN.GT.400.0D0)) RETURN
21298 ECM = SQRT( (AMPI+AMDE)**2+TWO*EKIN*AMDE )
21299 SIGABS = A+B/SQRT(EKIN)+C*1.0D4/((ECM-ER)**2+D)
21300 * approximate 3N-abs., I=1-abs. etc.
21301 SIGABS = SIGABS/0.40D0
21302 * pi0-absorption (rough approximation!!)
21303 IF (IDP.EQ.23) SIGABS = 0.5D0*SIGABS
21308 *$ CREATE DT_SIGEMU.FOR
21311 *===sigemu=============================================================*
21313 SUBROUTINE DT_SIGEMU
21315 ************************************************************************
21316 * Combined cross section for target compounds. *
21317 * This version dated 6.4.98 is written by S. Roesler *
21318 ************************************************************************
21320 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21323 PARAMETER ( LINP = 10 ,
21327 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21328 & OHALF=0.5D0,ONE=1.0D0)
21330 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21332 * Glauber formalism: cross sections
21333 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21334 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21335 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21336 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21337 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21338 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21339 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21340 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21341 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21342 & BSLOPE,NEBINI,NQBINI
21344 * emulsion treatment
21345 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
21348 * nucleon-nucleon event-generator
21351 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21353 IF (MCGENE.NE.4) THEN
21354 WRITE(LOUT,'(A)') ' DT_SIGEMU: Combined cross sections'
21355 WRITE(LOUT,'(15X,A)') '-----------------------'
21375 IF (NCOMPO.GT.0) THEN
21377 SIGTOT = SIGTOT+EMUFRA(IC)*XSTOT(IE,IQ,IC)
21378 SIGELA = SIGELA+EMUFRA(IC)*XSELA(IE,IQ,IC)
21379 SIGQEP = SIGQEP+EMUFRA(IC)*XSQEP(IE,IQ,IC)
21380 SIGQET = SIGQET+EMUFRA(IC)*XSQET(IE,IQ,IC)
21381 SIGQE2 = SIGQE2+EMUFRA(IC)*XSQE2(IE,IQ,IC)
21382 SIGPRO = SIGPRO+EMUFRA(IC)*XSPRO(IE,IQ,IC)
21383 SIGDEL = SIGDEL+EMUFRA(IC)*XSDEL(IE,IQ,IC)
21384 SIGDQE = SIGDQE+EMUFRA(IC)*XSDQE(IE,IQ,IC)
21385 ERRTOT = ERRTOT+XETOT(IE,IQ,IC)**2
21386 ERRELA = ERRELA+XEELA(IE,IQ,IC)**2
21387 ERRQEP = ERRQEP+XEQEP(IE,IQ,IC)**2
21388 ERRQET = ERRQET+XEQET(IE,IQ,IC)**2
21389 ERRQE2 = ERRQE2+XEQE2(IE,IQ,IC)**2
21390 ERRPRO = ERRPRO+XEPRO(IE,IQ,IC)**2
21391 ERRDEL = ERRDEL+XEDEL(IE,IQ,IC)**2
21392 ERRDQE = ERRDQE+XEDQE(IE,IQ,IC)**2
21394 ERRTOT = SQRT(ERRTOT)
21395 ERRELA = SQRT(ERRELA)
21396 ERRQEP = SQRT(ERRQEP)
21397 ERRQET = SQRT(ERRQET)
21398 ERRQE2 = SQRT(ERRQE2)
21399 ERRPRO = SQRT(ERRPRO)
21400 ERRDEL = SQRT(ERRDEL)
21401 ERRDQE = SQRT(ERRDQE)
21403 SIGTOT = XSTOT(IE,IQ,1)
21404 SIGELA = XSELA(IE,IQ,1)
21405 SIGQEP = XSQEP(IE,IQ,1)
21406 SIGQET = XSQET(IE,IQ,1)
21407 SIGQE2 = XSQE2(IE,IQ,1)
21408 SIGPRO = XSPRO(IE,IQ,1)
21409 SIGDEL = XSDEL(IE,IQ,1)
21410 SIGDQE = XSDQE(IE,IQ,1)
21411 ERRTOT = XETOT(IE,IQ,1)
21412 ERRELA = XEELA(IE,IQ,1)
21413 ERRQEP = XEQEP(IE,IQ,1)
21414 ERRQET = XEQET(IE,IQ,1)
21415 ERRQE2 = XEQE2(IE,IQ,1)
21416 ERRPRO = XEPRO(IE,IQ,1)
21417 ERRDEL = XEDEL(IE,IQ,1)
21418 ERRDQE = XEDQE(IE,IQ,1)
21420 IF (MCGENE.NE.4) THEN
21421 WRITE(LOUT,1000) ECMNN(IE),Q2G(IQ)
21422 1000 FORMAT(/,1X,'E_cm =',F9.1,' GeV Q^2 =',F6.1,' GeV^2 :',/)
21423 WRITE(LOUT,1001) SIGTOT,ERRTOT
21424 1001 FORMAT(1X,'total',32X,F10.4,' +-',F11.5,' mb')
21425 WRITE(LOUT,1002) SIGELA,ERRELA
21426 1002 FORMAT(1X,'elastic',30X,F10.4,' +-',F11.5,' mb')
21427 WRITE(LOUT,1003) SIGQEP,ERRQEP
21428 1003 FORMAT(1X,'quasi-elastic (A+B-->A+X)',12X,F10.4,' +-',
21430 WRITE(LOUT,1004) SIGQET,ERRQET
21431 1004 FORMAT(1X,'quasi-elastic (A+B-->X+B)',12X,F10.4,' +-',
21433 WRITE(LOUT,1005) SIGQE2,ERRQE2
21434 1005 FORMAT(1X,'quasi-elastic (A+B-->X, excl. 2-4)',3X,F10.4,
21435 & ' +-',F11.5,' mb')
21436 WRITE(LOUT,1006) SIGPRO,ERRPRO
21437 1006 FORMAT(1X,'production',27X,F10.4,' +-',F11.5,' mb')
21438 WRITE(LOUT,1007) SIGDEL,ERRDEL
21439 1007 FORMAT(1X,'diff-el ',27X,F10.4,' +-',F11.5,' mb')
21440 WRITE(LOUT,1008) SIGDQE,ERRDQE
21441 1008 FORMAT(1X,'diff-qel ',27X,F10.4,' +-',F11.5,' mb')
21450 *$ CREATE DT_SIGGA.FOR
21453 *===sigga==============================================================*
21455 SUBROUTINE DT_SIGGA(NTI,XI,Q2I,ECMI,XNUI,STOT,ETOT,SIN,EIN,STOT0)
21457 ************************************************************************
21458 * Total/inelastic photon-nucleus cross sections. *
21459 * !!!! Overwrites SHMAKI-initialization. Do not use it during *
21460 * production runs !!!! *
21461 * This version dated 27.03.96 is written by S. Roesler *
21462 ************************************************************************
21464 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21467 PARAMETER ( LINP = 10 ,
21471 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21472 & OHALF=0.5D0,ONE=1.0D0)
21473 PARAMETER (AMPROT = 0.938D0)
21475 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21477 * Glauber formalism: cross sections
21478 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21479 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21480 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21481 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21482 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21483 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21484 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21485 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21486 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21487 & BSLOPE,NEBINI,NQBINI
21494 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21495 & ECM = SQRT(AMPROT**2-Q2+2.0D0*XNUI*AMPROT)
21496 CALL DT_XSGLAU(1,NT,7,X,Q2,ECM,1,1,-1)
21497 STOT = XSTOT(1,1,1)
21498 ETOT = XETOT(1,1,1)
21505 *$ CREATE DT_SIGGAT.FOR
21508 *===siggat=============================================================*
21510 SUBROUTINE DT_SIGGAT(Q2I,ECMI,STOT,NT)
21512 ************************************************************************
21513 * Total/inelastic photon-nucleus cross sections. *
21514 * Uses pre-tabulated cross section. *
21515 * This version dated 29.07.96 is written by S. Roesler *
21516 ************************************************************************
21518 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21521 PARAMETER ( LINP = 10 ,
21525 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21526 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21528 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21530 * Glauber formalism: cross sections
21531 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21532 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21533 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21534 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21535 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21536 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21537 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21538 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21539 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21540 & BSLOPE,NEBINI,NQBINI
21546 IF (NEBINI.GT.1) THEN
21547 IF (ECMI.GE.ECMNN(NEBINI)) THEN
21551 ELSEIF (ECMI.GT.ECMNN(1)) THEN
21553 IF (ECMI.LT.ECMNN(I)) THEN
21556 RATE = (ECMI-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
21566 IF (NQBINI.GT.1) THEN
21567 IF (Q2I.GE.Q2G(NQBINI)) THEN
21571 ELSEIF (Q2I.GT.Q2G(1)) THEN
21573 IF (Q2I.LT.Q2G(I)) THEN
21576 RATQ = LOG10( Q2I/MAX(Q2G(J1),TINY14))/
21577 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
21578 C RATQ = (Q2I-Q2G(J1))/(Q2G(J2)-Q2G(J1))
21586 STOT = XSTOT(I1,J1,NTARG)+
21587 & RATE*(XSTOT(I2,J1,NTARG)-XSTOT(I1,J1,NTARG))+
21588 & RATQ*(XSTOT(I1,J2,NTARG)-XSTOT(I1,J1,NTARG))+
21589 & RATE*RATQ*(XSTOT(I2,J2,NTARG)-XSTOT(I1,J2,NTARG)+
21590 & XSTOT(I1,J1,NTARG)-XSTOT(I2,J1,NTARG))
21595 *$ CREATE DT_SANO.FOR
21598 *===sigano=============================================================*
21600 DOUBLE PRECISION FUNCTION DT_SANO(ECM)
21602 ************************************************************************
21603 * This version dated 31.07.96 is written by S. Roesler *
21604 ************************************************************************
21606 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21609 PARAMETER ( LINP = 10 ,
21613 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21614 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21617 * VDM parameter for photon-nucleus interactions
21618 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21620 * properties of interacting particles
21621 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
21623 DIMENSION ECMANO(NE),FRAANO(NE),SIGHRD(NE)
21625 & 0.200D+02,0.500D+02,0.100D+03,0.200D+03,0.500D+03,
21626 & 0.100D+04,0.200D+04,0.500D+04
21628 * fixed cut (3 GeV/c)
21630 & 0.085D+00,0.114D+00,0.105D+00,0.091D+00,0.073D+00,
21631 & 0.062D+00,0.054D+00,0.042D+00
21634 & 4.0099D-04,3.3104D-03,1.1905D-02,3.6435D-02,1.3493D-01,
21635 & 3.3086D-01,7.6255D-01,2.1319D+00
21637 * running cut (based on obsolete Phojet-caluclations, bugs..)
21639 C & 0.251E+00,0.313E+00,0.279E+00,0.239E+00,0.186E+00,
21640 C & 0.167E+00,0.150E+00,0.131E+00
21643 C & 6.6569E-04,4.4949E-03,1.4837E-02,4.1466E-02,1.5071E-01,
21644 C & 2.5736E-01,4.5593E-01,8.2550E-01
21648 IF ((ISHAD(2).NE.1).OR.(IJPROJ.NE.7)) RETURN
21652 IF (ECM.GE.ECMANO(NE)) THEN
21655 ELSEIF (ECM.GT.ECMANO(1)) THEN
21657 IF (ECM.LT.ECMANO(IE)) THEN
21660 RATE = LOG10(ECM/ECMANO(J1))/LOG10(ECMANO(J2)/ECMANO(J1))
21666 IF ((J1.GT.0).AND.(J2.GT.0)) THEN
21667 AFRA1 = LOG10(MAX(FRAANO(J1)*SIGHRD(J1),TINY14))
21668 AFRA2 = LOG10(MAX(FRAANO(J2)*SIGHRD(J2),TINY14))
21669 DT_SANO = 10.0D0**(AFRA1+RATE*(AFRA2-AFRA1))
21675 *$ CREATE DT_SIGGP.FOR
21678 *===siggp==============================================================*
21680 SUBROUTINE DT_SIGGP(XI,Q2I,ECMI,XNUI,STOT,SINE,SDIR)
21682 ************************************************************************
21683 * Total/inelastic photon-nucleon cross sections. *
21684 * This version dated 30.04.96 is written by S. Roesler *
21685 ************************************************************************
21687 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21690 PARAMETER ( LINP = 10 ,
21694 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
21695 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
21697 & GEV2MB = 0.38938D0,
21698 & ALPHEM = ONE/137.0D0)
21700 * particle properties (BAMJET index convention)
21702 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21703 & IICH(210),IIBAR(210),K1(210),K2(210)
21705 * VDM parameter for photon-nucleus interactions
21706 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21709 C CHARACTER*8 MDLNA
21710 C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
21711 C PARAMETER (IEETAB=10)
21712 C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
21715 C model switches and parameters
21717 INTEGER ISWMDL,IPAMDL
21718 DOUBLE PRECISION PARMDL
21719 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
21721 C energy-interpolation table
21723 PARAMETER ( IEETA2 = 20 )
21725 DOUBLE PRECISION SIGTAB,SIGECM
21726 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
21729 C PARAMETER (NPOINT=80)
21730 PARAMETER (NPOINT=16)
21731 DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
21738 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21739 & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
21743 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21745 X = Q2/(W2+Q2-AAM(1)**2)
21747 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
21748 X = Q2/(W2+Q2-AAM(1)**2)
21749 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21750 Q2 = (W2-AAM(1)**2)*X/(ONE-X)
21751 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
21752 W2 = Q2*(ONE-X)/X+AAM(1)**2
21754 WRITE(LOUT,*) 'SIGGP: inconsistent input ',W2,Q2,X
21759 IF (MODEGA.EQ.1) THEN
21761 CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
21765 C ALLMF2 = PHO_ALLM97(Q2,W)
21767 C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
21768 STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
21771 ELSEIF (MODEGA.EQ.2) THEN
21772 IF (INTRGE(1).EQ.1) THEN
21773 AMLO2 = (3.0D0*AAM(13))**2
21774 ELSEIF (INTRGE(1).EQ.2) THEN
21779 IF (INTRGE(2).EQ.1) THEN
21781 ELSEIF (INTRGE(2).EQ.2) THEN
21786 AMHI20 = (ECM-AAM(1))**2
21787 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
21788 XAMLO = LOG( AMLO2+Q2 )
21789 XAMHI = LOG( AMHI2+Q2 )
21791 C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
21794 CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
21799 AM2 = EXP(ABSZX(J))-Q2
21800 IF (AM2.LT.16.0D0) THEN
21802 ELSEIF ((AM2.GE.16.0D0).AND.(AM2.LT.121.0D0)) THEN
21807 C FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
21808 FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
21809 & * (ONE+EPSPOL*Q2/AM2)
21810 SUM = SUM+WEIGHT(J)*FAC
21813 SDIR = DT_SIGVP(X,Q2)
21814 STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*SDIR
21815 SDIR = SDIR/(0.588D0+RL2+Q2)
21816 C STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*DT_SIGVP(X,Q2)
21817 ELSEIF (MODEGA.EQ.3) THEN
21818 CALL DT_SIGGA(1,XI,Q2I,ECMI,ZERO,STOT,ETOT,SINE,EINE,DUM)
21819 ELSEIF (MODEGA.EQ.4) THEN
21820 * load cross sections from PHOJET interpolation table
21822 IF(ECM.LE.SIGECM(IP,1)) THEN
21825 ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
21827 IF (ECM.LE.SIGECM(IP,I)) GOTO 3
21833 WRITE(LOUT,'(/1X,A,2E12.3)')
21834 & 'SIGGP:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
21839 IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
21840 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
21842 * cross section dependence on photon virtuality
21845 FSUP1 = FSUP1+PARMDL(26+I)*(1.D0+Q2/(4.D0*PARMDL(30+I)))
21846 & /(1.D0+Q2/PARMDL(30+I))**2
21848 FSUP1 = FSUP1+PARMDL(30)/(1.D0+Q2/PARMDL(34))
21852 STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
21853 SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
21854 SDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
21858 SDIR = SDIR/(FSUP1*FSUP2)
21867 *$ CREATE DT_SIGVEL.FOR
21870 *===sigvel=============================================================*
21872 SUBROUTINE DT_SIGVEL(XI,Q2I,ECMI,XNUI,IDXV,SVEL,SIG1,SIG2)
21874 ************************************************************************
21875 * Cross section for elastic vector meson production *
21876 * This version dated 10.05.96 is written by S. Roesler *
21877 ************************************************************************
21879 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21882 PARAMETER ( LINP = 10 ,
21886 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
21887 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
21889 & GEV2MB = 0.38938D0,
21890 & ALPHEM = ONE/137.0D0)
21892 * particle properties (BAMJET index convention)
21894 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21895 & IICH(210),IIBAR(210),K1(210),K2(210)
21897 * VDM parameter for photon-nucleus interactions
21898 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21901 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21902 & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
21906 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21908 X = Q2/(W2+Q2-AAM(1)**2)
21910 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
21911 X = Q2/(W2+Q2-AAM(1)**2)
21912 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21913 Q2 = (W2-AAM(1)**2)*X/(ONE-X)
21914 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
21915 W2 = Q2*(ONE-X)/X+AAM(1)**2
21917 WRITE(LOUT,*) 'SIGVEL: inconsistent input ',W2,Q2,X
21925 BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
21926 & +0.25D0*LOG(W2/(AMV2+Q2)))*GEV2MB
21928 STOVP = DT_SIGVP(X,Q2)/(AMV2+Q2+RL2)
21929 SELVP = STOVP**2*(ONE+ROSH**2)/(8.0D0*TWOPI*BSLOPE)
21931 IF (IDXV.EQ.33) THEN
21936 SIG1 = (AMV2/(AMV2+Q2))**2 * (ONE+EPSPOL*Q2/AMV2)
21938 SVEL = COUPL * (AMV2/(AMV2+Q2))**2
21939 & * (ONE+EPSPOL*Q2/AMV2) * SELVP
21944 *$ CREATE DT_SIGVP.FOR
21947 *===sigvp==============================================================*
21949 DOUBLE PRECISION FUNCTION DT_SIGVP(XI,Q2I)
21951 ************************************************************************
21953 ************************************************************************
21955 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21958 PARAMETER ( LINP = 10 ,
21962 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
21963 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
21965 & GEV2MB = 0.38938D0,
21966 & AMPROT = 0.938D0,
21967 & ALPHEM = ONE/137.0D0)
21969 * VDM parameter for photon-nucleus interactions
21970 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21974 IF (XI.LE.ZERO) X = 0.0001D0
21975 IF (Q2I.LE.ZERO) Q2 = 0.0001D0
21977 ECM = SQRT( Q2*(ONE-X)/X+AMPROT**2 )
21980 IF (MODEGA.EQ.1) THEN
21981 CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
21985 C ALLMF2 = PHO_ALLM97(Q2,W)
21987 C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
21988 C STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
21989 C DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))
21990 DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))*GEV2MB
21991 ELSEIF (MODEGA.EQ.4) THEN
21992 CALL DT_SIGGP(X,Q2,ECM,DUM1,STOT,DUM2,DUM3)
21993 C F2 = Q2*(ONE-X)/(TWOPI**2*ALPHEM*GEV2MB) * STOT
21994 DT_SIGVP = 3.0D0*PI/(ALPHEM*DT_RRM2(X,Q2)) * STOT
21996 STOP ' DT_SIGVP: F2 not defined for this MODEGA !'
22003 *$ CREATE DT_RRM2.FOR
22006 *===RRM2===============================================================*
22008 DOUBLE PRECISION FUNCTION DT_RRM2(X,Q2)
22010 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22013 PARAMETER ( LINP = 10 ,
22017 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22018 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22020 & GEV2MB = 0.38938D0)
22022 * particle properties (BAMJET index convention)
22024 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22025 & IICH(210),IIBAR(210),K1(210),K2(210)
22027 * VDM parameter for photon-nucleus interactions
22028 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22030 S = Q2*(ONE-X)/X+AAM(1)**2
22033 IF (INTRGE(1).EQ.1) THEN
22034 AMLO2 = (3.0D0*AAM(13))**2
22035 ELSEIF (INTRGE(1).EQ.2) THEN
22040 IF (INTRGE(2).EQ.1) THEN
22042 ELSEIF (INTRGE(2).EQ.2) THEN
22047 AMHI20 = (ECM-AAM(1))**2
22048 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22052 IF (AMHI2.LE.AM1C2) THEN
22053 DT_RRM2 = TWO*DT_RM2(AMLO2,AMHI2,Q2)
22054 ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22055 DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22056 & 10.0D0/3.0D0*DT_RM2(AM1C2,AMHI2,Q2)
22058 DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22059 & 10.0D0/3.0D0*DT_RM2(AM1C2,AM2C2,Q2)+
22060 & 11.0D0/3.0D0*DT_RM2(AM2C2,AMHI2,Q2)
22066 *$ CREATE DT_RM2.FOR
22069 *===RM2================================================================*
22071 DOUBLE PRECISION FUNCTION DT_RM2(AMLO2,AMHI2,Q2)
22073 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22076 PARAMETER ( LINP = 10 ,
22080 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22081 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22083 & GEV2MB = 0.38938D0)
22085 * VDM parameter for photon-nucleus interactions
22086 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22088 IF (RL2.LE.ZERO) THEN
22089 DT_RM2 = -ONE/(AMHI2+Q2)+Q2/(TWO*(AMHI2+Q2)**2) -
22090 & (-ONE/(AMLO2+Q2)+Q2/(TWO*(AMLO2+Q2)**2))
22091 & +EPSPOL*(-Q2/(TWO*(AMHI2+Q2)**2)+Q2/(TWO*(AMLO2+Q2)**2))
22093 TMPMLO = LOG(ONE+RL2/(AMLO2+Q2))
22094 TMPMHI = LOG(ONE+RL2/(AMHI2+Q2))
22095 DT_RM2 = Q2/(RL2*(AMHI2+Q2))-(Q2+RL2)/RL2**2*TMPMHI
22096 & -(Q2/(RL2*(AMLO2+Q2))-(Q2+RL2)/RL2**2*TMPMLO)
22098 & -Q2/(RL2*(AMHI2+Q2))+Q2/RL2**2*TMPMHI
22099 & -(-Q2/(RL2*(AMLO2+Q2))+Q2/RL2**2*TMPMLO))
22105 *$ CREATE DT_SAM2.FOR
22108 *===SAM2===============================================================*
22110 DOUBLE PRECISION FUNCTION DT_SAM2(Q2,ECM)
22112 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22115 PARAMETER ( LINP = 10 ,
22119 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
22120 & TENTRD=10.0D0/3.0D0,ELVTRD=11.0D0/3.0D0)
22121 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22123 & GEV2MB = 0.38938D0)
22125 * particle properties (BAMJET index convention)
22127 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22128 & IICH(210),IIBAR(210),K1(210),K2(210)
22130 * VDM parameter for photon-nucleus interactions
22131 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22134 IF (INTRGE(1).EQ.1) THEN
22135 AMLO2 = (3.0D0*AAM(13))**2
22136 ELSEIF (INTRGE(1).EQ.2) THEN
22141 IF (INTRGE(2).EQ.1) THEN
22143 ELSEIF (INTRGE(2).EQ.2) THEN
22148 AMHI20 = (ECM-AAM(1))**2
22149 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22153 YLO = LOG(AMLO2+Q2)
22154 YC1 = LOG(AM1C2+Q2)
22155 YC2 = LOG(AM2C2+Q2)
22156 YHI = LOG(AMHI2+Q2)
22157 IF (AMHI2.LE.AM1C2) THEN
22159 ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22166 YSAM2 = YLO+(YHI-YLO)*DT_RNDM(AM1C2)
22167 IF (YSAM2.LE.YC1) THEN
22169 ELSEIF ((YSAM2.GT.YC1).AND.(YSAM2.LE.YC2)) THEN
22174 WEIGMX = FACHI*(ONE-Q2*EXP( -YHI))
22175 XSAM2 = FAC *(ONE-Q2*EXP(-YSAM2))
22176 IF (DT_RNDM(YSAM2)*WEIGMX.GT.XSAM2) GOTO 1
22178 DT_SAM2 = EXP(YSAM2)-Q2
22183 *$ CREATE DT_CKMT.FOR
22186 *===ckmt===============================================================*
22188 SUBROUTINE DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,
22191 ************************************************************************
22192 * This version dated 31.01.96 is written by S. Roesler *
22193 ************************************************************************
22195 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22198 PARAMETER ( LINP = 10 ,
22202 PARAMETER (ZERO=0.0D0,TWO=2.0D0,TINY10=1.0D-10)
22204 PARAMETER (Q02 = 2.0D0,
22208 DIMENSION PD(-6:6),SEA(3),VAL(2)
22210 CALL DT_PDF0(Q02,X,F2Q0,VAL,SEA,GLU,IPAR)
22211 CALL DT_PDF0(Q12,X,F2Q1,VAL,SEA,GLU,IPAR)
22212 ADQ2 = LOG10(Q12)-LOG10(Q02)
22213 F2P = (F2Q1-F2Q0)/ADQ2
22214 CALL DT_CKMTX(IPAR,X,Q02,PD,F2PQ0)
22215 CALL DT_CKMTX(IPAR,X,Q12,PD,F2PQ1)
22216 F2PP = (F2PQ1-F2PQ0)/ADQ2
22217 FX = (F2P-F2PP)/(F2PP+LOG(DQ2)*F2PQ0+TINY10)*Q02
22219 Q2 = MAX(SCALE**2.0D0,TINY10)
22220 SMOOTH = 1.0D0+FX*(Q2-Q02)/Q2**2
22221 IF (Q2.LT.Q02) THEN
22222 CALL DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22233 CALL DT_CKMTX(IPAR,X,Q2,PD,F2)
22246 C USEA = USEA*SMOOTH
22247 C DSEA = DSEA*SMOOTH
22257 *$ CREATE DT_CKMTX.FOR
22259 SUBROUTINE DT_CKMTX(IPAR,X,SCALE2,PD,F2)
22260 C**********************************************************************
22262 C PDF based on Regge theory, evolved with .... by ....
22264 C input: IPAR 2212 proton (not installed)
22268 C output: PD(-6:6) x*f(x) parton distribution functions
22269 C (PDFLIB convention: d = PD(1), u = PD(2) )
22271 C**********************************************************************
22274 DOUBLE PRECISION X,SCALE2,PD(-6:6),CDN,CUP,F2
22276 PARAMETER ( LINP = 10 ,
22285 C QCD lambda for evolution
22288 C Q0**2 for evolution
22292 C the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
22293 C q(6)=x*charm, q(7)=x*gluon
22297 2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
22299 IF(IPAR.EQ.2212) THEN
22300 CALL DT_CKMTPR(1,0,XX,SB,QQ(1))
22301 CALL DT_CKMTPR(2,0,XX,SB,QQ(2))
22302 CALL DT_CKMTPR(3,0,XX,SB,QQ(3))
22303 CALL DT_CKMTPR(4,0,XX,SB,QQ(4))
22304 CALL DT_CKMTPR(5,0,XX,SB,QQ(5))
22305 CALL DT_CKMTPR(8,0,XX,SB,QQ(6))
22306 CALL DT_CKMTPR(7,0,XX,SB,QQ(7))
22307 C ELSEIF (IPAR.EQ.45) THEN
22308 C CALL CKMTPO(1,0,XX,SB,QQ(1))
22309 C CALL CKMTPO(2,0,XX,SB,QQ(2))
22310 C CALL CKMTPO(3,0,XX,SB,QQ(3))
22311 C CALL CKMTPO(4,0,XX,SB,QQ(4))
22312 C CALL CKMTPO(5,0,XX,SB,QQ(5))
22313 C CALL CKMTPO(8,0,XX,SB,QQ(6))
22314 C CALL CKMTPO(7,0,XX,SB,QQ(7))
22315 ELSEIF (IPAR.EQ.100) THEN
22316 CALL DT_CKMTDE(1,0,XX,SB,QQ(1))
22317 CALL DT_CKMTDE(2,0,XX,SB,QQ(2))
22318 CALL DT_CKMTDE(3,0,XX,SB,QQ(3))
22319 CALL DT_CKMTDE(4,0,XX,SB,QQ(4))
22320 CALL DT_CKMTDE(5,0,XX,SB,QQ(5))
22321 CALL DT_CKMTDE(8,0,XX,SB,QQ(6))
22322 CALL DT_CKMTDE(7,0,XX,SB,QQ(7))
22324 WRITE(LOUT,'(1X,A,I4,A)')
22325 & 'CKMTX: IPAR =',IPAR,' not implemented!'
22331 PD(-4) = DBLE(QQ(6))
22332 PD(-3) = DBLE(QQ(3))
22333 PD(-2) = DBLE(QQ(4))
22334 PD(-1) = DBLE(QQ(5))
22335 PD(0) = DBLE(QQ(7))
22336 PD(1) = DBLE(QQ(2))
22337 PD(2) = DBLE(QQ(1))
22338 PD(3) = DBLE(QQ(3))
22339 PD(4) = DBLE(QQ(6))
22342 IF(IPAR.EQ.45) THEN
22343 CDN = (PD(1)-PD(-1))/2.D0
22344 CUP = (PD(2)-PD(-2))/2.D0
22345 PD(-1) = PD(-1) + CDN
22346 PD(-2) = PD(-2) + CUP
22350 F2 = 4.0D0/9.0D0*(PD(2)-PD(3)+2.0D0*PD(3))+
22351 & 1.0D0/9.0D0*(PD(1)-PD(3)+2.0D0*PD(3))+
22352 & 1.0D0/9.0D0*(2.0D0*PD(3))+4.0D0/9.0D0*(2.0D0*PD(4))
22356 *$ CREATE DT_PDF0.FOR
22359 *===pdf0===============================================================*
22361 SUBROUTINE DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22363 ************************************************************************
22364 * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 *
22365 * an F_2-ansatz given in Capella et al. PLB 337(1994)358. *
22366 * IPAR = 2212 proton *
22368 * This version dated 31.01.96 is written by S. Roesler *
22369 ************************************************************************
22371 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22374 PARAMETER ( LINP = 10 ,
22378 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22387 & DELTA0 = 0.07684D0,
22392 & ALPHAR = 0.415D0,
22396 PARAMETER (NPOINT=16)
22397 C DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
22398 DIMENSION SEA(3),VAL(2)
22400 DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22401 AN = 1.5D0*(1.0D0+Q2/(Q2+C))
22403 IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22404 CALL DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22405 SEA(1) = 0.75D0*SEA0
22408 VAL(1) = 9.0D0/4.0D0*VALU0
22409 VAL(2) = 9.0D0*VALD0
22410 GLU0 = SEA(1)/(1.0D0-X)
22411 F2 = SEA0+VALU0+VALD0
22412 F2PDF = 4.0D0/9.0D0*(VAL(1)+2.0D0*SEA(1))+
22413 & 1.0D0/9.0D0*(VAL(2)+2.0D0*SEA(2))+
22414 & 1.0D0/9.0D0*(2.0D0*SEA(3))
22415 IF (ABS(F2-F2PDF).GT.TINY9) THEN
22416 WRITE(LOUT,'(1X,A,2E15.5)') 'inconsistent PDF! ',F2,F2PDF
22420 C CALL GSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22423 C CALL PHO_GAUSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22429 C CALL DT_CKMTQ0(Q2,ABSZX(J),IPAR,VALU0,VALD0,SEA0)
22430 C VALU0 = 9.0D0/4.0D0*VALU0
22431 C VALD0 = 9.0D0*VALD0
22432 C SEA0 = 0.75D0*SEA0
22433 C SUMQ = SUMQ+ (VALU0+VALD0+6.0D0*SEA0) *WEIGHT(J)
22434 C SUMG = SUMG+ (SEA0/(1.0D0-ABSZX(J))) *WEIGHT(J)
22436 C GLU = GLU0*(1.0D0-SUMQ)/SUMG
22438 WRITE(LOUT,'(1X,A,I4,A)')
22439 & 'PDF0: IPAR =',IPAR,' not implemented!'
22446 *$ CREATE DT_CKMTQ0.FOR
22449 *===ckmtq0=============================================================*
22451 SUBROUTINE DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22453 ************************************************************************
22454 * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 *
22455 * an F_2-ansatz given in Capella et al. PLB 337(1994)358. *
22456 * IPAR = 2212 proton *
22458 * This version dated 31.01.96 is written by S. Roesler *
22459 ************************************************************************
22461 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22464 PARAMETER ( LINP = 10 ,
22468 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22477 & DELTA0 = 0.07684D0,
22482 & ALPHAR = 0.415D0,
22486 DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22487 AN = 1.5D0*(1.0D0+Q2/(Q2+C))
22489 IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22490 IF (IPAR.EQ.2212) THEN
22497 SEA0 = AA*X**(-DELTA)*(1.0D0-X)**(AN+4.0D0)*
22498 & (Q2/(Q2+A))**(1.0D0+DELTA)
22499 VALU0 = BU*X**(1.0D0-ALPHAR)*(1.0D0-X)**AN*
22500 & (Q2/(Q2+B))**(ALPHAR)
22501 VALD0 = BD*X**(1.0D0-ALPHAR)*(1.0D0-X)**(AN+1.0D0)*
22502 & (Q2/(Q2+B))**(ALPHAR)
22504 WRITE(LOUT,'(1X,A,I4,A)')
22505 & 'CKMTQ0: IPAR =',IPAR,' not implemented!'
22513 *$ CREATE DT_CKMTDE.FOR
22515 SUBROUTINE DT_CKMTDE(I,NDRV,X,S,ANS)
22517 C**********************************************************************
22519 C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
22521 C This version by S. Roesler, 30.01.96
22522 C**********************************************************************
22525 DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
22526 EQUIVALENCE (GF(1,1,1),DL(1))
22529 DATA (DL(K),K= 1, 85) /
22530 &0.351858E+00,0.388489E+00,0.325356E+00,0.325356E+00,0.325356E+00,
22531 &0.325356E+00,0.445218E+01,0.000000E+00,0.419818E+00,0.459249E+00,
22532 &0.391167E+00,0.391143E+00,0.391125E+00,0.391167E+00,0.628186E+01,
22533 &0.703797E-01,0.498333E+00,0.540626E+00,0.467466E+00,0.467423E+00,
22534 &0.467393E+00,0.467466E+00,0.837368E+01,0.151191E+00,0.587839E+00,
22535 &0.633058E+00,0.554689E+00,0.554630E+00,0.554595E+00,0.554689E+00,
22536 &0.107170E+02,0.242877E+00,0.688652E+00,0.736861E+00,0.653150E+00,
22537 &0.653080E+00,0.653046E+00,0.653150E+00,0.132960E+02,0.345760E+00,
22538 &0.800961E+00,0.852226E+00,0.763038E+00,0.762961E+00,0.762933E+00,
22539 &0.763038E+00,0.160884E+02,0.460033E+00,0.924829E+00,0.979213E+00,
22540 &0.884414E+00,0.884335E+00,0.884319E+00,0.884414E+00,0.190679E+02,
22541 &0.585764E+00,0.106016E+01,0.111773E+01,0.101719E+01,0.101711E+01,
22542 &0.101711E+01,0.101719E+01,0.222033E+02,0.722864E+00,0.120670E+01,
22543 &0.126752E+01,0.116110E+01,0.116102E+01,0.116105E+01,0.116110E+01,
22544 &0.254603E+02,0.871079E+00,0.136402E+01,0.142815E+01,0.131571E+01,
22545 &0.131565E+01,0.131570E+01,0.131571E+01,0.288020E+02,0.102998E+01,
22546 &0.153151E+01,0.159900E+01,0.148043E+01,0.148038E+01,0.148046E+01/
22547 DATA (DL(K),K= 86, 170) /
22548 &0.148043E+01,0.321898E+02,0.119897E+01,0.170838E+01,0.177930E+01,
22549 &0.165447E+01,0.165444E+01,0.165455E+01,0.165447E+01,0.355845E+02,
22550 &0.137726E+01,0.189369E+01,0.196807E+01,0.183687E+01,0.183686E+01,
22551 &0.183701E+01,0.183687E+01,0.389473E+02,0.156390E+01,0.208631E+01,
22552 &0.216422E+01,0.202653E+01,0.202654E+01,0.202673E+01,0.202653E+01,
22553 &0.422402E+02,0.175779E+01,0.228501E+01,0.236648E+01,0.222220E+01,
22554 &0.222224E+01,0.222248E+01,0.222220E+01,0.454277E+02,0.195768E+01,
22555 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22556 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22557 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22558 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22559 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22560 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22561 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22562 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22563 &0.326035E+00,0.380777E+00,0.286363E+00,0.286363E+00,0.286363E+00,
22564 &0.286363E+00,0.392252E+01,-.138778E-16,0.380092E+00,0.438587E+00/
22565 DATA (DL(K),K= 171, 255) /
22566 &0.337452E+00,0.337430E+00,0.337424E+00,0.337452E+00,0.532193E+01,
22567 &0.553645E-01,0.440879E+00,0.503177E+00,0.395208E+00,0.395169E+00,
22568 &0.395165E+00,0.395208E+00,0.686454E+01,0.117354E+00,0.508415E+00,
22569 &0.574566E+00,0.459649E+00,0.459600E+00,0.459604E+00,0.459649E+00,
22570 &0.853316E+01,0.185994E+00,0.582647E+00,0.652699E+00,0.530722E+00,
22571 &0.530667E+00,0.530687E+00,0.530722E+00,0.103093E+02,0.261237E+00,
22572 &0.663404E+00,0.737405E+00,0.608254E+00,0.608199E+00,0.608241E+00,
22573 &0.608254E+00,0.121710E+02,0.342917E+00,0.750429E+00,0.828423E+00,
22574 &0.691990E+00,0.691941E+00,0.692009E+00,0.691990E+00,0.140946E+02,
22575 &0.430783E+00,0.843361E+00,0.925391E+00,0.781571E+00,0.781533E+00,
22576 &0.781632E+00,0.781571E+00,0.160553E+02,0.524479E+00,0.941741E+00,
22577 &0.102784E+01,0.876538E+00,0.876515E+00,0.876650E+00,0.876538E+00,
22578 &0.180277E+02,0.623549E+00,0.104501E+01,0.113521E+01,0.976335E+00,
22579 &0.976332E+00,0.976506E+00,0.976335E+00,0.199863E+02,0.727439E+00,
22580 &0.115251E+01,0.124685E+01,0.108031E+01,0.108034E+01,0.108055E+01,
22581 &0.108031E+01,0.219066E+02,0.835506E+00,0.126352E+01,0.136201E+01,
22582 &0.118775E+01,0.118780E+01,0.118806E+01,0.118775E+01,0.237652E+02/
22583 DATA (DL(K),K= 256, 340) /
22584 &0.947020E+00,0.137724E+01,0.147989E+01,0.129783E+01,0.129791E+01,
22585 &0.129822E+01,0.129783E+01,0.255406E+02,0.106119E+01,0.149279E+01,
22586 &0.159961E+01,0.140972E+01,0.140984E+01,0.141019E+01,0.140972E+01,
22587 &0.272135E+02,0.117715E+01,0.160929E+01,0.172028E+01,0.152252E+01,
22588 &0.152267E+01,0.152308E+01,0.152252E+01,0.287669E+02,0.129402E+01,
22589 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22590 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22591 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22592 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22593 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22594 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22595 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22596 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22597 &0.309785E+00,0.391282E+00,0.250518E+00,0.250518E+00,0.250518E+00,
22598 &0.250518E+00,0.343842E+01,-.138778E-16,0.352113E+00,0.438463E+00,
22599 &0.288877E+00,0.288863E+00,0.288878E+00,0.288877E+00,0.446765E+01,
22600 &0.424850E-01,0.398382E+00,0.489596E+00,0.331132E+00,0.331111E+00/
22601 DATA (DL(K),K= 341, 425) /
22602 &0.331148E+00,0.331132E+00,0.555902E+01,0.888369E-01,0.448375E+00,
22603 &0.544458E+00,0.377064E+00,0.377043E+00,0.377108E+00,0.377064E+00,
22604 &0.669490E+01,0.138845E+00,0.501854E+00,0.602811E+00,0.426440E+00,
22605 &0.426425E+00,0.426523E+00,0.426440E+00,0.785892E+01,0.192281E+00,
22606 &0.558506E+00,0.664331E+00,0.478946E+00,0.478944E+00,0.479079E+00,
22607 &0.478946E+00,0.903368E+01,0.248834E+00,0.617972E+00,0.728657E+00,
22608 &0.534229E+00,0.534244E+00,0.534421E+00,0.534229E+00,0.102022E+02,
22609 &0.308155E+00,0.679844E+00,0.795370E+00,0.591883E+00,0.591921E+00,
22610 &0.592141E+00,0.591883E+00,0.113479E+02,0.369841E+00,0.743667E+00,
22611 &0.864009E+00,0.651460E+00,0.651525E+00,0.651792E+00,0.651460E+00,
22612 &0.124553E+02,0.433447E+00,0.808951E+00,0.934073E+00,0.712474E+00,
22613 &0.712571E+00,0.712885E+00,0.712474E+00,0.135102E+02,0.498486E+00,
22614 &0.875171E+00,0.100503E+01,0.774408E+00,0.774541E+00,0.774902E+00,
22615 &0.774408E+00,0.144999E+02,0.564446E+00,0.941784E+00,0.107632E+01,
22616 &0.836726E+00,0.836897E+00,0.837307E+00,0.836726E+00,0.154136E+02,
22617 &0.630788E+00,0.100823E+01,0.114738E+01,0.898879E+00,0.899092E+00,
22618 &0.899551E+00,0.898879E+00,0.162423E+02,0.696967E+00,0.107396E+01/
22619 DATA (DL(K),K= 426, 510) /
22620 &0.121764E+01,0.960319E+00,0.960577E+00,0.961084E+00,0.960319E+00,
22621 &0.169791E+02,0.762433E+00,0.113843E+01,0.128655E+01,0.102051E+01,
22622 &0.102081E+01,0.102137E+01,0.102051E+01,0.176190E+02,0.826647E+00,
22623 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22624 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22625 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22626 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22627 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22628 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22629 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22630 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22631 &0.304680E+00,0.425088E+00,0.216504E+00,0.216504E+00,0.216504E+00,
22632 &0.216504E+00,0.298356E+01,0.000000E+00,0.337300E+00,0.463627E+00,
22633 &0.244023E+00,0.244024E+00,0.244063E+00,0.244023E+00,0.370271E+01,
22634 &0.316585E-01,0.371787E+00,0.503942E+00,0.273415E+00,0.273423E+00,
22635 &0.273505E+00,0.273415E+00,0.443039E+01,0.651685E-01,0.407853E+00,
22636 &0.545739E+00,0.304395E+00,0.304418E+00,0.304545E+00,0.304395E+00/
22637 DATA (DL(K),K= 511, 595) /
22638 &0.515321E+01,0.100252E+00,0.445229E+00,0.588741E+00,0.336700E+00,
22639 &0.336744E+00,0.336918E+00,0.336700E+00,0.586004E+01,0.136648E+00,
22640 &0.483606E+00,0.632629E+00,0.370026E+00,0.370095E+00,0.370318E+00,
22641 &0.370026E+00,0.654027E+01,0.174056E+00,0.522666E+00,0.677074E+00,
22642 &0.404062E+00,0.404162E+00,0.404433E+00,0.404062E+00,0.718442E+01,
22643 &0.212167E+00,0.562075E+00,0.721735E+00,0.438483E+00,0.438618E+00,
22644 &0.438938E+00,0.438483E+00,0.778423E+01,0.250658E+00,0.601494E+00,
22645 &0.766258E+00,0.472959E+00,0.473131E+00,0.473500E+00,0.472959E+00,
22646 &0.833276E+01,0.289199E+00,0.640580E+00,0.810290E+00,0.507156E+00,
22647 &0.507369E+00,0.507784E+00,0.507156E+00,0.882448E+01,0.327457E+00,
22648 &0.678993E+00,0.853479E+00,0.540747E+00,0.541003E+00,0.541463E+00,
22649 &0.540747E+00,0.925529E+01,0.365104E+00,0.716405E+00,0.895483E+00,
22650 &0.573411E+00,0.573714E+00,0.574216E+00,0.573411E+00,0.962250E+01,
22651 &0.401821E+00,0.752501E+00,0.935975E+00,0.604848E+00,0.605197E+00,
22652 &0.605740E+00,0.604848E+00,0.992478E+01,0.437304E+00,0.786987E+00,
22653 &0.974647E+00,0.634775E+00,0.635173E+00,0.635752E+00,0.634775E+00,
22654 &0.101620E+02,0.471269E+00,0.819594E+00,0.101122E+01,0.662936E+00/
22655 DATA (DL(K),K= 596, 680) /
22656 &0.663382E+00,0.663995E+00,0.662936E+00,0.103354E+02,0.503459E+00,
22657 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22658 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22659 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22660 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22661 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22662 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22663 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22664 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22665 &0.312661E+00,0.487836E+00,0.182562E+00,0.182562E+00,0.182562E+00,
22666 &0.182562E+00,0.253626E+01,0.000000E+00,0.336910E+00,0.518440E+00,
22667 &0.200702E+00,0.200721E+00,0.200779E+00,0.200702E+00,0.299460E+01,
22668 &0.224425E-01,0.361554E+00,0.549164E+00,0.219359E+00,0.219402E+00,
22669 &0.219517E+00,0.219359E+00,0.343183E+01,0.453742E-01,0.386348E+00,
22670 &0.579759E+00,0.238296E+00,0.238367E+00,0.238536E+00,0.238296E+00,
22671 &0.384076E+01,0.685610E-01,0.411080E+00,0.610003E+00,0.257305E+00,
22672 &0.257408E+00,0.257630E+00,0.257305E+00,0.421619E+01,0.917987E-01/
22673 DATA (DL(K),K= 681, 765) /
22674 &0.435528E+00,0.639668E+00,0.276174E+00,0.276313E+00,0.276583E+00,
22675 &0.276174E+00,0.455400E+01,0.114876E+00,0.459476E+00,0.668531E+00,
22676 &0.294698E+00,0.294875E+00,0.295191E+00,0.294698E+00,0.485107E+01,
22677 &0.137589E+00,0.482719E+00,0.696375E+00,0.312682E+00,0.312900E+00,
22678 &0.313258E+00,0.312682E+00,0.510539E+01,0.159742E+00,0.505060E+00,
22679 &0.722995E+00,0.329941E+00,0.330200E+00,0.330596E+00,0.329941E+00,
22680 &0.531589E+01,0.181149E+00,0.526315E+00,0.748199E+00,0.346303E+00,
22681 &0.346604E+00,0.347034E+00,0.346303E+00,0.548250E+01,0.201638E+00,
22682 &0.546317E+00,0.771808E+00,0.361613E+00,0.361957E+00,0.362418E+00,
22683 &0.361613E+00,0.560595E+01,0.221052E+00,0.564917E+00,0.793667E+00,
22684 &0.375735E+00,0.376122E+00,0.376609E+00,0.375735E+00,0.568772E+01,
22685 &0.239253E+00,0.581987E+00,0.813638E+00,0.388553E+00,0.388982E+00,
22686 &0.389491E+00,0.388553E+00,0.572992E+01,0.256122E+00,0.597419E+00,
22687 &0.831608E+00,0.399972E+00,0.400443E+00,0.400970E+00,0.399972E+00,
22688 &0.573516E+01,0.271562E+00,0.611129E+00,0.847487E+00,0.409919E+00,
22689 &0.410430E+00,0.410972E+00,0.409919E+00,0.570642E+01,0.285497E+00,
22690 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22691 DATA (DL(K),K= 766, 850) /
22692 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22693 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22694 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22695 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22696 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22697 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22698 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22699 &0.335149E+00,0.582072E+00,0.146415E+00,0.146415E+00,0.146415E+00,
22700 &0.146415E+00,0.206772E+01,0.000000E+00,0.351552E+00,0.603437E+00,
22701 &0.156515E+00,0.156542E+00,0.156595E+00,0.156515E+00,0.231143E+01,
22702 &0.146091E-01,0.367407E+00,0.623737E+00,0.166387E+00,0.166442E+00,
22703 &0.166542E+00,0.166387E+00,0.252488E+01,0.289315E-01,0.382571E+00,
22704 &0.642832E+00,0.175891E+00,0.175976E+00,0.176118E+00,0.175891E+00,
22705 &0.270658E+01,0.428312E-01,0.396926E+00,0.660609E+00,0.184917E+00,
22706 &0.185034E+00,0.185212E+00,0.184917E+00,0.285608E+01,0.561981E-01,
22707 &0.410365E+00,0.676962E+00,0.193365E+00,0.193513E+00,0.193722E+00,
22708 &0.193365E+00,0.297375E+01,0.689319E-01,0.422792E+00,0.691796E+00/
22709 DATA (DL(K),K= 851, 935) /
22710 &0.201144E+00,0.201324E+00,0.201560E+00,0.201144E+00,0.306050E+01,
22711 &0.809434E-01,0.434123E+00,0.705030E+00,0.208181E+00,0.208393E+00,
22712 &0.208650E+00,0.208181E+00,0.311775E+01,0.921567E-01,0.444287E+00,
22713 &0.716596E+00,0.214413E+00,0.214656E+00,0.214931E+00,0.214413E+00,
22714 &0.314738E+01,0.102508E+00,0.453228E+00,0.726441E+00,0.219792E+00,
22715 &0.220066E+00,0.220354E+00,0.219792E+00,0.315156E+01,0.111949E+00,
22716 &0.460906E+00,0.734527E+00,0.224285E+00,0.224589E+00,0.224886E+00,
22717 &0.224285E+00,0.313271E+01,0.120441E+00,0.467291E+00,0.740835E+00,
22718 &0.227870E+00,0.228203E+00,0.228506E+00,0.227870E+00,0.309338E+01,
22719 &0.127963E+00,0.472372E+00,0.745357E+00,0.230541E+00,0.230902E+00,
22720 &0.231208E+00,0.230541E+00,0.303621E+01,0.134506E+00,0.476148E+00,
22721 &0.748105E+00,0.232304E+00,0.232690E+00,0.232996E+00,0.232304E+00,
22722 &0.296381E+01,0.140070E+00,0.478635E+00,0.749103E+00,0.233176E+00,
22723 &0.233586E+00,0.233889E+00,0.233176E+00,0.287874E+01,0.144672E+00,
22724 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22725 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22726 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22727 DATA (DL(K),K= 936, 1020) /
22728 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22729 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22730 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22731 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22732 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22733 &0.370162E+00,0.695827E+00,0.105823E+00,0.105823E+00,0.105823E+00,
22734 &0.105823E+00,0.154556E+01,0.208167E-16,0.378214E+00,0.703794E+00,
22735 &0.109539E+00,0.109554E+00,0.109571E+00,0.109539E+00,0.162770E+01,
22736 &0.818783E-02,0.385258E+00,0.710067E+00,0.112818E+00,0.112847E+00,
22737 &0.112879E+00,0.112818E+00,0.168578E+01,0.158212E-01,0.391264E+00,
22738 &0.714648E+00,0.115620E+00,0.115666E+00,0.115709E+00,0.115620E+00,
22739 &0.172175E+01,0.228667E-01,0.396214E+00,0.717539E+00,0.117923E+00,
22740 &0.117985E+00,0.118037E+00,0.117923E+00,0.173756E+01,0.293009E-01,
22741 &0.400098E+00,0.718759E+00,0.119711E+00,0.119790E+00,0.119848E+00,
22742 &0.119711E+00,0.173541E+01,0.351123E-01,0.402915E+00,0.718332E+00,
22743 &0.120979E+00,0.121074E+00,0.121137E+00,0.120979E+00,0.171755E+01,
22744 &0.402951E-01,0.404672E+00,0.716292E+00,0.121728E+00,0.121840E+00/
22745 DATA (DL(K),K= 1021, 1105) /
22746 &0.121905E+00,0.121728E+00,0.168619E+01,0.448514E-01,0.405385E+00,
22747 &0.712681E+00,0.121967E+00,0.122095E+00,0.122161E+00,0.121967E+00,
22748 &0.164352E+01,0.487902E-01,0.405077E+00,0.707551E+00,0.121712E+00,
22749 &0.121855E+00,0.121920E+00,0.121712E+00,0.159162E+01,0.521265E-01,
22750 &0.403778E+00,0.700963E+00,0.120984E+00,0.121141E+00,0.121204E+00,
22751 &0.120984E+00,0.153245E+01,0.548814E-01,0.401525E+00,0.692984E+00,
22752 &0.119809E+00,0.119980E+00,0.120040E+00,0.119809E+00,0.146780E+01,
22753 &0.570807E-01,0.398361E+00,0.683691E+00,0.118218E+00,0.118402E+00,
22754 &0.118457E+00,0.118218E+00,0.139928E+01,0.587542E-01,0.394333E+00,
22755 &0.673166E+00,0.116244E+00,0.116440E+00,0.116490E+00,0.116244E+00,
22756 &0.132834E+01,0.599355E-01,0.389495E+00,0.661496E+00,0.113924E+00,
22757 &0.114131E+00,0.114175E+00,0.113924E+00,0.125620E+01,0.606602E-01,
22758 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22759 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22760 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22761 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22762 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22763 DATA (DL(K),K= 1106, 1190) /
22764 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22765 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22766 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22767 &0.394012E+00,0.757115E+00,0.772117E-01,0.772117E-01,0.772117E-01,
22768 &0.772117E-01,0.117279E+01,0.346945E-17,0.395841E+00,0.752988E+00,
22769 &0.780501E-01,0.780655E-01,0.780723E-01,0.780501E-01,0.118528E+01,
22770 &0.491697E-02,0.396627E+00,0.747223E+00,0.785386E-01,0.785692E-01,
22771 &0.785806E-01,0.785386E-01,0.118242E+01,0.932754E-02,0.396401E+00,
22772 &0.739901E+00,0.786820E-01,0.787273E-01,0.787413E-01,0.786820E-01,
22773 &0.116673E+01,0.132427E-01,0.395190E+00,0.731092E+00,0.784870E-01,
22774 &0.785464E-01,0.785613E-01,0.784870E-01,0.114033E+01,0.166738E-01,
22775 &0.393030E+00,0.720878E+00,0.779683E-01,0.780410E-01,0.780555E-01,
22776 &0.779683E-01,0.110528E+01,0.196392E-01,0.389962E+00,0.709342E+00,
22777 &0.771427E-01,0.772280E-01,0.772409E-01,0.771427E-01,0.106344E+01,
22778 &0.221591E-01,0.386027E+00,0.696571E+00,0.760304E-01,0.761276E-01,
22779 &0.761378E-01,0.760304E-01,0.101653E+01,0.242567E-01,0.381274E+00,
22780 &0.682657E+00,0.746543E-01,0.747623E-01,0.747692E-01,0.746543E-01/
22781 DATA (DL(K),K= 1191, 1275) /
22782 &0.966057E+00,0.259571E-01,0.375752E+00,0.667695E+00,0.730389E-01,
22783 &0.731569E-01,0.731598E-01,0.730389E-01,0.913345E+00,0.272876E-01,
22784 &0.369514E+00,0.651782E+00,0.712104E-01,0.713374E-01,0.713358E-01,
22785 &0.712104E-01,0.859530E+00,0.282763E-01,0.362616E+00,0.635021E+00,
22786 &0.691957E-01,0.693307E-01,0.693243E-01,0.691957E-01,0.805566E+00,
22787 &0.289524E-01,0.355116E+00,0.617511E+00,0.670220E-01,0.671640E-01,
22788 &0.671526E-01,0.670220E-01,0.752235E+00,0.293453E-01,0.347072E+00,
22789 &0.599357E+00,0.647162E-01,0.648642E-01,0.648478E-01,0.647162E-01,
22790 &0.700161E+00,0.294844E-01,0.338543E+00,0.580659E+00,0.623046E-01,
22791 &0.624578E-01,0.624363E-01,0.623046E-01,0.649828E+00,0.293983E-01,
22792 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22793 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22794 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22795 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22796 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22797 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22798 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22799 DATA (DL(K),K= 1276, 1360) /
22800 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22801 &0.408305E+00,0.775318E+00,0.509141E-01,0.509141E-01,0.509141E-01,
22802 &0.509141E-01,0.818839E+00,-.867362E-17,0.403619E+00,0.758058E+00,
22803 &0.502245E-01,0.502351E-01,0.502337E-01,0.502245E-01,0.795347E+00,
22804 &0.264045E-02,0.398068E+00,0.739709E+00,0.493454E-01,0.493661E-01,
22805 &0.493626E-01,0.493454E-01,0.764942E+00,0.491508E-02,0.391719E+00,
22806 &0.720394E+00,0.482952E-01,0.483253E-01,0.483192E-01,0.482952E-01,
22807 &0.729624E+00,0.685202E-02,0.384627E+00,0.700222E+00,0.470896E-01,
22808 &0.471285E-01,0.471194E-01,0.470896E-01,0.690906E+00,0.847433E-02,
22809 &0.376851E+00,0.679300E+00,0.457475E-01,0.457946E-01,0.457822E-01,
22810 &0.457475E-01,0.650078E+00,0.980774E-02,0.368452E+00,0.657739E+00,
22811 &0.442875E-01,0.443419E-01,0.443261E-01,0.442875E-01,0.608239E+00,
22812 &0.108769E-01,0.359490E+00,0.635646E+00,0.427281E-01,0.427892E-01,
22813 &0.427698E-01,0.427281E-01,0.566280E+00,0.117061E-01,0.350026E+00,
22814 &0.613128E+00,0.410878E-01,0.411549E-01,0.411320E-01,0.410878E-01,
22815 &0.524918E+00,0.123191E-01,0.340122E+00,0.590292E+00,0.393848E-01,
22816 &0.394571E-01,0.394308E-01,0.393848E-01,0.484713E+00,0.127393E-01/
22817 DATA (DL(K),K= 1361, 1445) /
22818 &0.329838E+00,0.567240E+00,0.376363E-01,0.377132E-01,0.376836E-01,
22819 &0.376363E-01,0.446084E+00,0.129888E-01,0.319236E+00,0.544074E+00,
22820 &0.358589E-01,0.359396E-01,0.359068E-01,0.358589E-01,0.409328E+00,
22821 &0.130888E-01,0.308374E+00,0.520890E+00,0.340678E-01,0.341517E-01,
22822 &0.341160E-01,0.340678E-01,0.374641E+00,0.130594E-01,0.297312E+00,
22823 &0.497781E+00,0.322772E-01,0.323636E-01,0.323253E-01,0.322772E-01,
22824 &0.342135E+00,0.129195E-01,0.286106E+00,0.474837E+00,0.304999E-01,
22825 &0.305882E-01,0.305474E-01,0.304999E-01,0.311854E+00,0.126863E-01,
22826 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22827 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22828 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22829 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22830 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22831 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22832 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22833 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22834 &0.407248E+00,0.746438E+00,0.335640E-01,0.335640E-01,0.335640E-01/
22835 DATA (DL(K),K= 1446, 1530) /
22836 &0.335640E-01,0.573540E+00,0.173472E-16,0.397516E+00,0.719825E+00,
22837 &0.324649E-01,0.324735E-01,0.324698E-01,0.324649E-01,0.540770E+00,
22838 &0.147177E-02,0.387197E+00,0.692869E+00,0.312911E-01,0.313075E-01,
22839 &0.313000E-01,0.312911E-01,0.505972E+00,0.269995E-02,0.376365E+00,
22840 &0.665689E+00,0.300576E-01,0.300811E-01,0.300699E-01,0.300576E-01,
22841 &0.470389E+00,0.371147E-02,0.365085E+00,0.638387E+00,0.287770E-01,
22842 &0.288070E-01,0.287922E-01,0.287770E-01,0.434885E+00,0.452768E-02,
22843 &0.353423E+00,0.611066E+00,0.274623E-01,0.274980E-01,0.274797E-01,
22844 &0.274623E-01,0.400103E+00,0.516996E-02,0.341442E+00,0.583823E+00,
22845 &0.261256E-01,0.261663E-01,0.261448E-01,0.261256E-01,0.366541E+00,
22846 &0.565807E-02,0.329207E+00,0.556753E+00,0.247782E-01,0.248234E-01,
22847 &0.247989E-01,0.247782E-01,0.334555E+00,0.601048E-02,0.316777E+00,
22848 &0.529946E+00,0.234308E-01,0.234798E-01,0.234525E-01,0.234308E-01,
22849 &0.304384E+00,0.624451E-02,0.304214E+00,0.503489E+00,0.220932E-01,
22850 &0.221452E-01,0.221155E-01,0.220932E-01,0.276170E+00,0.637618E-02,
22851 &0.291575E+00,0.477462E+00,0.207739E-01,0.208286E-01,0.207966E-01,
22852 &0.207739E-01,0.249976E+00,0.642028E-02,0.278917E+00,0.451941E+00/
22853 DATA (DL(K),K= 1531, 1615) /
22854 &0.194809E-01,0.195376E-01,0.195037E-01,0.194809E-01,0.225809E+00,
22855 &0.639038E-02,0.266293E+00,0.426995E+00,0.182209E-01,0.182791E-01,
22856 &0.182436E-01,0.182209E-01,0.203629E+00,0.629880E-02,0.253754E+00,
22857 &0.402686E+00,0.169996E-01,0.170587E-01,0.170219E-01,0.169996E-01,
22858 &0.183361E+00,0.615665E-02,0.241347E+00,0.379071E+00,0.158217E-01,
22859 &0.158814E-01,0.158436E-01,0.158217E-01,0.164907E+00,0.597385E-02,
22860 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22861 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22862 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22863 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22864 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22865 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22866 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22867 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22868 &0.395106E+00,0.689399E+00,0.218554E-01,0.218554E-01,0.218554E-01,
22869 &0.218554E-01,0.398362E+00,-.173472E-17,0.381441E+00,0.656777E+00,
22870 &0.207816E-01,0.207886E-01,0.207844E-01,0.207816E-01,0.366703E+00/
22871 DATA (DL(K),K= 1616, 1700) /
22872 &0.826643E-03,0.367505E+00,0.624578E+00,0.197001E-01,0.197133E-01,
22873 &0.197053E-01,0.197001E-01,0.335573E+00,0.149886E-02,0.353373E+00,
22874 &0.592889E+00,0.186195E-01,0.186383E-01,0.186266E-01,0.186195E-01,
22875 &0.305590E+00,0.203730E-02,0.339106E+00,0.561783E+00,0.175468E-01,
22876 &0.175705E-01,0.175555E-01,0.175468E-01,0.277136E+00,0.245817E-02,
22877 &0.324766E+00,0.531331E+00,0.164887E-01,0.165166E-01,0.164986E-01,
22878 &0.164887E-01,0.250424E+00,0.277666E-02,0.310411E+00,0.501599E+00,
22879 &0.154510E-01,0.154825E-01,0.154618E-01,0.154510E-01,0.225588E+00,
22880 &0.300658E-02,0.296100E+00,0.472648E+00,0.144390E-01,0.144735E-01,
22881 &0.144504E-01,0.144390E-01,0.202681E+00,0.316040E-02,0.281885E+00,
22882 &0.444535E+00,0.134570E-01,0.134940E-01,0.134689E-01,0.134570E-01,
22883 &0.181693E+00,0.324944E-02,0.267820E+00,0.417309E+00,0.125091E-01,
22884 &0.125481E-01,0.125212E-01,0.125091E-01,0.162572E+00,0.328396E-02,
22885 &0.253953E+00,0.391017E+00,0.115984E-01,0.116389E-01,0.116106E-01,
22886 &0.115984E-01,0.145235E+00,0.327313E-02,0.240328E+00,0.365695E+00,
22887 &0.107275E-01,0.107690E-01,0.107396E-01,0.107275E-01,0.129575E+00,
22888 &0.322510E-02,0.226989E+00,0.341375E+00,0.989805E-02,0.994030E-02/
22889 DATA (DL(K),K= 1701, 1785) /
22890 &0.990998E-02,0.989805E-02,0.115477E+00,0.314713E-02,0.213972E+00,
22891 &0.318081E+00,0.911149E-02,0.915408E-02,0.912316E-02,0.911149E-02,
22892 &0.102820E+00,0.304556E-02,0.201311E+00,0.295830E+00,0.836852E-02,
22893 &0.841111E-02,0.837984E-02,0.836852E-02,0.914804E-01,0.292596E-02,
22894 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22895 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22896 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22897 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22898 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22899 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22900 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22901 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22902 &0.374678E+00,0.616087E+00,0.139531E-01,0.139531E-01,0.139531E-01,
22903 &0.139531E-01,0.272491E+00,-.693889E-17,0.358052E+00,0.580345E+00,
22904 &0.130624E-01,0.130680E-01,0.130641E-01,0.130624E-01,0.245861E+00,
22905 &0.460255E-03,0.341487E+00,0.545719E+00,0.121971E-01,0.122076E-01,
22906 &0.122002E-01,0.121971E-01,0.220877E+00,0.826785E-03,0.325046E+00/
22907 DATA (DL(K),K= 1786, 1870) /
22908 &0.512244E+00,0.113599E-01,0.113748E-01,0.113641E-01,0.113599E-01,
22909 &0.197730E+00,0.111366E-02,0.308783E+00,0.479952E+00,0.105534E-01,
22910 &0.105720E-01,0.105585E-01,0.105534E-01,0.176497E+00,0.133192E-02,
22911 &0.292747E+00,0.448868E+00,0.977938E-02,0.980112E-02,0.978518E-02,
22912 &0.977938E-02,0.157150E+00,0.149139E-02,0.276986E+00,0.419015E+00,
22913 &0.903955E-02,0.906394E-02,0.904584E-02,0.903955E-02,0.139631E+00,
22914 &0.160093E-02,0.261546E+00,0.390412E+00,0.833509E-02,0.836165E-02,
22915 &0.834171E-02,0.833509E-02,0.123850E+00,0.166838E-02,0.246467E+00,
22916 &0.363074E+00,0.766687E-02,0.769516E-02,0.767369E-02,0.766687E-02,
22917 &0.109695E+00,0.170073E-02,0.231787E+00,0.337008E+00,0.703540E-02,
22918 &0.706500E-02,0.704230E-02,0.703540E-02,0.970428E-01,0.170416E-02,
22919 &0.217542E+00,0.312218E+00,0.644083E-02,0.647137E-02,0.644772E-02,
22920 &0.644083E-02,0.857658E-01,0.168409E-02,0.203759E+00,0.288701E+00,
22921 &0.588300E-02,0.591415E-02,0.588981E-02,0.588300E-02,0.757385E-01,
22922 &0.164528E-02,0.190467E+00,0.266449E+00,0.536147E-02,0.539292E-02,
22923 &0.536812E-02,0.536147E-02,0.668383E-01,0.159185E-02,0.177686E+00,
22924 &0.245447E+00,0.487551E-02,0.490698E-02,0.488195E-02,0.487551E-02/
22925 DATA (DL(K),K= 1871, 1955) /
22926 &0.589492E-01,0.152735E-02,0.165434E+00,0.225677E+00,0.442416E-02,
22927 &0.445543E-02,0.443037E-02,0.442416E-02,0.519652E-01,0.145483E-02,
22928 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22929 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22930 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22931 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22932 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22933 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22934 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22935 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22936 &0.348042E+00,0.534691E+00,0.867977E-02,0.867977E-02,0.867977E-02,
22937 &0.867977E-02,0.182547E+00,-.693889E-17,0.329349E+00,0.498248E+00,
22938 &0.800724E-02,0.801198E-02,0.800836E-02,0.800724E-02,0.161948E+00,
22939 &0.250949E-03,0.311047E+00,0.463485E+00,0.737155E-02,0.738040E-02,
22940 &0.737356E-02,0.737155E-02,0.143267E+00,0.447662E-03,0.293181E+00,
22941 &0.430377E+00,0.677169E-02,0.678409E-02,0.677441E-02,0.677169E-02,
22942 &0.126447E+00,0.598803E-03,0.275787E+00,0.398907E+00,0.620726E-02/
22943 DATA (DL(K),K= 1956, 2040) /
22944 &0.622265E-02,0.621051E-02,0.620726E-02,0.111401E+00,0.711280E-03,
22945 &0.258900E+00,0.369051E+00,0.567741E-02,0.569532E-02,0.568106E-02,
22946 &0.567741E-02,0.979944E-01,0.790986E-03,0.242550E+00,0.340785E+00,
22947 &0.518138E-02,0.520134E-02,0.518531E-02,0.518138E-02,0.860936E-01,
22948 &0.843227E-03,0.226765E+00,0.314083E+00,0.471828E-02,0.473987E-02,
22949 &0.472238E-02,0.471828E-02,0.755615E-01,0.872644E-03,0.211568E+00,
22950 &0.288916E+00,0.428714E-02,0.430998E-02,0.429133E-02,0.428714E-02,
22951 &0.662627E-01,0.883319E-03,0.196981E+00,0.265252E+00,0.388691E-02,
22952 &0.391065E-02,0.389112E-02,0.388691E-02,0.580684E-01,0.878818E-03,
22953 &0.183020E+00,0.243053E+00,0.351645E-02,0.354077E-02,0.352060E-02,
22954 &0.351645E-02,0.508578E-01,0.862228E-03,0.169696E+00,0.222280E+00,
22955 &0.317451E-02,0.319914E-02,0.317858E-02,0.317451E-02,0.445190E-01,
22956 &0.836224E-03,0.157017E+00,0.202888E+00,0.285982E-02,0.288450E-02,
22957 &0.286376E-02,0.285982E-02,0.389523E-01,0.803096E-03,0.144987E+00,
22958 &0.184832E+00,0.257101E-02,0.259553E-02,0.257480E-02,0.257101E-02,
22959 &0.340677E-01,0.764787E-03,0.133605E+00,0.168060E+00,0.230670E-02,
22960 &0.233087E-02,0.231031E-02,0.230670E-02,0.297820E-01,0.722929E-03/
22961 DATA (DL(K),K= 2041, 2125) /
22962 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22963 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22964 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22965 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22966 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22967 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22968 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22969 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22970 &0.316867E+00,0.451111E+00,0.522815E-02,0.522815E-02,0.522815E-02,
22971 &0.522815E-02,0.119118E+00,0.889046E-17,0.296950E+00,0.415915E+00,
22972 &0.475497E-02,0.475914E-02,0.475574E-02,0.475497E-02,0.104204E+00,
22973 &0.132513E-03,0.277735E+00,0.382805E+00,0.431809E-02,0.432582E-02,
22974 &0.431944E-02,0.431809E-02,0.910279E-01,0.235347E-03,0.259241E+00,
22975 &0.351694E+00,0.391455E-02,0.392531E-02,0.391637E-02,0.391455E-02,
22976 &0.794222E-01,0.313322E-03,0.241485E+00,0.322517E+00,0.354249E-02,
22977 &0.355575E-02,0.354464E-02,0.354249E-02,0.692354E-01,0.370408E-03,
22978 &0.224480E+00,0.295202E+00,0.319987E-02,0.321518E-02,0.320226E-02/
22979 DATA (DL(K),K= 2126, 2210) /
22980 &0.319987E-02,0.603106E-01,0.409866E-03,0.208235E+00,0.269681E+00,
22981 &0.288490E-02,0.290184E-02,0.288744E-02,0.288490E-02,0.525034E-01,
22982 &0.434663E-03,0.192759E+00,0.245887E+00,0.259589E-02,0.261407E-02,
22983 &0.259852E-02,0.259589E-02,0.456838E-01,0.447393E-03,0.178054E+00,
22984 &0.223752E+00,0.233123E-02,0.235033E-02,0.233390E-02,0.233123E-02,
22985 &0.397318E-01,0.450314E-03,0.164120E+00,0.203207E+00,0.208941E-02,
22986 &0.210910E-02,0.209206E-02,0.208941E-02,0.345396E-01,0.445394E-03,
22987 &0.150954E+00,0.184182E+00,0.186896E-02,0.188897E-02,0.187155E-02,
22988 &0.186896E-02,0.300131E-01,0.434333E-03,0.138548E+00,0.166608E+00,
22989 &0.166844E-02,0.168854E-02,0.167096E-02,0.166844E-02,0.260692E-01,
22990 &0.418584E-03,0.126892E+00,0.150412E+00,0.148650E-02,0.150648E-02,
22991 &0.148891E-02,0.148650E-02,0.226325E-01,0.399380E-03,0.115971E+00,
22992 &0.135523E+00,0.132180E-02,0.134148E-02,0.132409E-02,0.132180E-02,
22993 &0.196374E-01,0.377764E-03,0.105767E+00,0.121870E+00,0.117308E-02,
22994 &0.119231E-02,0.117524E-02,0.117308E-02,0.170312E-01,0.354610E-03,
22995 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22996 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22997 DATA (DL(K),K= 2211, 2295) /
22998 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22999 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23000 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23001 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23002 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23003 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23004 &0.282579E+00,0.369670E+00,0.302765E-02,0.302765E-02,0.302765E-02,
23005 &0.302765E-02,0.752529E-01,-.455365E-17,0.262229E+00,0.337209E+00,
23006 &0.271512E-02,0.271883E-02,0.271564E-02,0.271512E-02,0.651086E-01,
23007 &0.669321E-04,0.242857E+00,0.307069E+00,0.243269E-02,0.243953E-02,
23008 &0.243360E-02,0.243269E-02,0.563252E-01,0.118744E-03,0.224455E+00,
23009 &0.279111E+00,0.217687E-02,0.218631E-02,0.217808E-02,0.217687E-02,
23010 &0.487143E-01,0.157767E-03,0.207014E+00,0.253223E+00,0.194534E-02,
23011 &0.195689E-02,0.194675E-02,0.194534E-02,0.421227E-01,0.186063E-03,
23012 &0.190523E+00,0.229293E+00,0.173585E-02,0.174909E-02,0.173741E-02,
23013 &0.173585E-02,0.364156E-01,0.205286E-03,0.174969E+00,0.207218E+00,
23014 &0.154647E-02,0.156100E-02,0.154811E-02,0.154647E-02,0.314732E-01/
23015 DATA (DL(K),K= 2296, 2380) /
23016 &0.216964E-03,0.160335E+00,0.186895E+00,0.137545E-02,0.139092E-02,
23017 &0.137713E-02,0.137545E-02,0.271927E-01,0.222455E-03,0.146604E+00,
23018 &0.168227E+00,0.122121E-02,0.123733E-02,0.122290E-02,0.122121E-02,
23019 &0.234852E-01,0.222947E-03,0.133756E+00,0.151116E+00,0.108234E-02,
23020 &0.109881E-02,0.108400E-02,0.108234E-02,0.202747E-01,0.219474E-03,
23021 &0.121765E+00,0.135471E+00,0.957502E-03,0.974107E-03,0.959112E-03,
23022 &0.957502E-03,0.174932E-01,0.212928E-03,0.110606E+00,0.121198E+00,
23023 &0.845493E-03,0.862024E-03,0.847037E-03,0.845493E-03,0.150824E-01,
23024 &0.204075E-03,0.100250E+00,0.108210E+00,0.745196E-03,0.761482E-03,
23025 &0.746662E-03,0.745196E-03,0.129965E-01,0.193573E-03,0.906661E-01,
23026 &0.964191E-01,0.655569E-03,0.671466E-03,0.656948E-03,0.655569E-03,
23027 &0.111930E-01,0.181962E-03,0.818218E-01,0.857412E-01,0.575637E-03,
23028 &0.591030E-03,0.576925E-03,0.575637E-03,0.962922E-02,0.169687E-03,
23029 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23030 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23031 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23032 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23033 DATA (DL(K),K= 2381, 2465) /
23034 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23035 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23036 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23037 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23038 &0.246444E+00,0.293515E+00,0.167124E-02,0.167124E-02,0.167124E-02,
23039 &0.167124E-02,0.456929E-01,-.260209E-17,0.226393E+00,0.264836E+00,
23040 &0.147748E-02,0.148085E-02,0.147783E-02,0.147748E-02,0.392393E-01,
23041 &0.318190E-04,0.207552E+00,0.238550E+00,0.130596E-02,0.131212E-02,
23042 &0.130656E-02,0.130596E-02,0.337276E-01,0.566426E-04,0.189877E+00,
23043 &0.214470E+00,0.115347E-02,0.116190E-02,0.115427E-02,0.115347E-02,
23044 &0.290012E-01,0.753776E-04,0.173336E+00,0.192452E+00,0.101789E-02,
23045 &0.102811E-02,0.101881E-02,0.101789E-02,0.249381E-01,0.889466E-04,
23046 &0.157889E+00,0.172355E+00,0.897268E-03,0.908872E-03,0.898270E-03,
23047 &0.897268E-03,0.214419E-01,0.980950E-04,0.143501E+00,0.154046E+00,
23048 &0.789951E-03,0.802565E-03,0.790996E-03,0.789951E-03,0.184296E-01,
23049 &0.103536E-03,0.130132E+00,0.137402E+00,0.694510E-03,0.707811E-03,
23050 &0.695568E-03,0.694510E-03,0.158331E-01,0.105929E-03,0.117743E+00/
23051 DATA (DL(K),K= 2466, 2550) /
23052 &0.122303E+00,0.609684E-03,0.623394E-03,0.610733E-03,0.609684E-03,
23053 &0.135929E-01,0.105853E-03,0.106293E+00,0.108637E+00,0.534365E-03,
23054 &0.548244E-03,0.535386E-03,0.534365E-03,0.116583E-01,0.103825E-03,
23055 &0.957386E-01,0.962976E-01,0.467572E-03,0.481416E-03,0.468551E-03,
23056 &0.467572E-03,0.999103E-02,0.100301E-03,0.860376E-01,0.851820E-01,
23057 &0.408422E-03,0.422062E-03,0.409350E-03,0.408422E-03,0.855563E-02,
23058 &0.956675E-04,0.771455E-01,0.751930E-01,0.356117E-03,0.369416E-03,
23059 &0.356989E-03,0.356117E-03,0.731542E-02,0.902499E-04,0.690178E-01,
23060 &0.662386E-01,0.309950E-03,0.322797E-03,0.310761E-03,0.309950E-03,
23061 &0.624633E-02,0.843305E-04,0.616096E-01,0.582312E-01,0.269281E-03,
23062 &0.281590E-03,0.270030E-03,0.269281E-03,0.533230E-02,0.781441E-04,
23063 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23064 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23065 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23066 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23067 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23068 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23069 DATA (DL(K),K= 2551, 2635) /
23070 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23071 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23072 &0.209608E+00,0.224862E+00,0.869706E-03,0.869706E-03,0.869706E-03,
23073 &0.869706E-03,0.264204E-01,-.138236E-17,0.190523E+00,0.200603E+00,
23074 &0.757542E-03,0.760626E-03,0.757768E-03,0.757542E-03,0.226261E-01,
23075 &0.138827E-04,0.172819E+00,0.178656E+00,0.660281E-03,0.665837E-03,
23076 &0.660670E-03,0.660281E-03,0.194018E-01,0.249832E-04,0.156420E+00,
23077 &0.158805E+00,0.575414E-03,0.582918E-03,0.575917E-03,0.575414E-03,
23078 &0.166434E-01,0.334851E-04,0.141265E+00,0.140883E+00,0.501258E-03,
23079 &0.510252E-03,0.501836E-03,0.501258E-03,0.142710E-01,0.397017E-04,
23080 &0.127291E+00,0.124732E+00,0.436386E-03,0.446473E-03,0.437008E-03,
23081 &0.436386E-03,0.122297E-01,0.439154E-04,0.114437E+00,0.110205E+00,
23082 &0.379575E-03,0.390415E-03,0.380217E-03,0.379575E-03,0.104701E-01,
23083 &0.464110E-04,0.102644E+00,0.971655E-01,0.329805E-03,0.341109E-03,
23084 &0.330448E-03,0.329805E-03,0.895086E-02,0.474758E-04,0.918521E-01,
23085 &0.854876E-01,0.286206E-03,0.297729E-03,0.286836E-03,0.286206E-03,
23086 &0.764249E-02,0.473771E-04,0.820032E-01,0.750529E-01,0.248027E-03/
23087 DATA (DL(K),K= 2636, 2720) /
23088 &0.259564E-03,0.248633E-03,0.248027E-03,0.651744E-02,0.463561E-04,
23089 &0.730394E-01,0.657510E-01,0.214611E-03,0.225995E-03,0.215186E-03,
23090 &0.214611E-03,0.554573E-02,0.446239E-04,0.649040E-01,0.574789E-01,
23091 &0.185396E-03,0.196491E-03,0.185935E-03,0.185396E-03,0.470938E-02,
23092 &0.423722E-04,0.575411E-01,0.501405E-01,0.159891E-03,0.170590E-03,
23093 &0.160391E-03,0.159891E-03,0.399752E-02,0.397689E-04,0.508960E-01,
23094 &0.436466E-01,0.137650E-03,0.147874E-03,0.138111E-03,0.137650E-03,
23095 &0.338807E-02,0.369434E-04,0.449157E-01,0.379141E-01,0.118285E-03,
23096 &0.127973E-03,0.118705E-03,0.118285E-03,0.286125E-02,0.340035E-04,
23097 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23098 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23099 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23100 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23101 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23102 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23103 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23104 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23105 DATA (DL(K),K= 2721, 2805) /
23106 &0.173133E+00,0.165162E+00,0.420483E-03,0.420483E-03,0.420483E-03,
23107 &0.420483E-03,0.143704E-01,0.418773E-17,0.155600E+00,0.145586E+00,
23108 &0.360490E-03,0.363140E-03,0.360629E-03,0.360490E-03,0.123560E-01,
23109 &0.533279E-05,0.139551E+00,0.128113E+00,0.309555E-03,0.314310E-03,
23110 &0.309792E-03,0.309555E-03,0.106262E-01,0.982612E-05,0.124876E+00,
23111 &0.112516E+00,0.265952E-03,0.272344E-03,0.266256E-03,0.265952E-03,
23112 &0.913151E-02,0.133834E-04,0.111490E+00,0.986188E-01,0.228522E-03,
23113 &0.236138E-03,0.228869E-03,0.228522E-03,0.783135E-02,0.160429E-04,
23114 &0.993081E-01,0.862590E-01,0.196336E-03,0.204821E-03,0.196706E-03,
23115 &0.196336E-03,0.670031E-02,0.178799E-04,0.882484E-01,0.752883E-01,
23116 &0.168604E-03,0.177655E-03,0.168981E-03,0.168604E-03,0.572016E-02,
23117 &0.189837E-04,0.782334E-01,0.655714E-01,0.144684E-03,0.154047E-03,
23118 &0.145058E-03,0.144684E-03,0.487276E-02,0.194655E-04,0.691885E-01,
23119 &0.569841E-01,0.124035E-03,0.133497E-03,0.124397E-03,0.124035E-03,
23120 &0.413648E-02,0.194296E-04,0.610420E-01,0.494128E-01,0.106203E-03,
23121 &0.115592E-03,0.106548E-03,0.106203E-03,0.350042E-02,0.189800E-04,
23122 &0.537249E-01,0.427533E-01,0.908141E-04,0.999895E-04,0.911377E-04/
23123 DATA (DL(K),K= 2806, 2890) /
23124 &0.908141E-04,0.295961E-02,0.182192E-04,0.471713E-01,0.369100E-01,
23125 &0.775359E-04,0.863895E-04,0.778360E-04,0.775359E-04,0.249629E-02,
23126 &0.172287E-04,0.413182E-01,0.317957E-01,0.660857E-04,0.745356E-04,
23127 &0.663611E-04,0.660857E-04,0.209482E-02,0.160791E-04,0.361056E-01,
23128 &0.273306E-01,0.562298E-04,0.642173E-04,0.564804E-04,0.562298E-04,
23129 &0.175588E-02,0.148407E-04,0.314766E-01,0.234421E-01,0.477598E-04,
23130 &0.552457E-04,0.479859E-04,0.477598E-04,0.147398E-02,0.135653E-04,
23131 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23132 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23133 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23134 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23135 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23136 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23137 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23138 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23139 &0.138007E+00,0.115214E+00,0.185072E-03,0.185072E-03,0.185072E-03,
23140 &0.185072E-03,0.722856E-02,-.380826E-17,0.122517E+00,0.100251E+00/
23141 DATA (DL(K),K= 2891, 2975) /
23142 &0.155814E-03,0.158287E-03,0.155901E-03,0.155814E-03,0.630580E-02,
23143 &0.155371E-05,0.108535E+00,0.870870E-01,0.131535E-03,0.135909E-03,
23144 &0.131680E-03,0.131535E-03,0.547867E-02,0.304952E-05,0.959260E-01,
23145 &0.754985E-01,0.111183E-03,0.116980E-03,0.111366E-03,0.111183E-03,
23146 &0.473794E-02,0.433106E-05,0.845828E-01,0.653163E-01,0.940433E-04,
23147 &0.100851E-03,0.942493E-04,0.940433E-04,0.407647E-02,0.533613E-05,
23148 &0.744017E-01,0.563870E-01,0.795843E-04,0.870596E-04,0.798007E-04,
23149 &0.795843E-04,0.349165E-02,0.606691E-05,0.652864E-01,0.485720E-01,
23150 &0.673476E-04,0.752069E-04,0.675656E-04,0.673476E-04,0.297273E-02,
23151 &0.652898E-05,0.571466E-01,0.417472E-01,0.569700E-04,0.649812E-04,
23152 &0.571831E-04,0.569700E-04,0.251732E-02,0.675028E-05,0.498975E-01,
23153 &0.358008E-01,0.481618E-04,0.561391E-04,0.483654E-04,0.481618E-04,
23154 &0.212754E-02,0.677236E-05,0.434594E-01,0.306320E-01,0.406746E-04,
23155 &0.484724E-04,0.408657E-04,0.406746E-04,0.179059E-02,0.662814E-05,
23156 &0.377578E-01,0.261500E-01,0.343050E-04,0.418123E-04,0.344818E-04,
23157 &0.343050E-04,0.149563E-02,0.635273E-05,0.327229E-01,0.222734E-01,
23158 &0.288923E-04,0.360279E-04,0.290540E-04,0.288923E-04,0.124695E-02/
23159 DATA (DL(K),K= 2976, 3060) /
23160 &0.598767E-05,0.282894E-01,0.189287E-01,0.242960E-04,0.310036E-04,
23161 &0.244423E-04,0.242960E-04,0.104112E-02,0.556344E-05,0.243968E-01,
23162 &0.160504E-01,0.203920E-04,0.266363E-04,0.205232E-04,0.203920E-04,
23163 &0.863677E-03,0.510070E-05,0.209890E-01,0.135797E-01,0.170822E-04,
23164 &0.228449E-04,0.171989E-04,0.170822E-04,0.711641E-03,0.462338E-05,
23165 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23166 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23167 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23168 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23169 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23170 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23171 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23172 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23173 &0.105155E+00,0.752467E-01,0.719932E-04,0.719932E-04,0.719932E-04,
23174 &0.719932E-04,0.328057E-02,-.758942E-18,0.920856E-01,0.645455E-01,
23175 &0.592305E-04,0.615087E-04,0.592802E-04,0.592305E-04,0.295327E-02,
23176 &0.945234E-07,0.804695E-01,0.552770E-01,0.489125E-04,0.528632E-04/
23177 DATA (DL(K),K= 3061, 3145) /
23178 &0.489946E-04,0.489125E-04,0.261804E-02,0.365139E-06,0.701499E-01,
23179 &0.472409E-01,0.404786E-04,0.456186E-04,0.405807E-04,0.404786E-04,
23180 &0.229460E-02,0.686912E-06,0.610049E-01,0.402864E-01,0.335367E-04,
23181 &0.394631E-04,0.336495E-04,0.335367E-04,0.198445E-02,0.981070E-06,
23182 &0.529201E-01,0.342803E-01,0.278134E-04,0.342044E-04,0.279301E-04,
23183 &0.278134E-04,0.169772E-02,0.122521E-05,0.457907E-01,0.291037E-01,
23184 &0.230821E-04,0.296833E-04,0.231978E-04,0.230821E-04,0.144575E-02,
23185 &0.140819E-05,0.395205E-01,0.246522E-01,0.191553E-04,0.257661E-04,
23186 &0.192666E-04,0.191553E-04,0.122125E-02,0.152152E-05,0.340212E-01,
23187 &0.208330E-01,0.158874E-04,0.223546E-04,0.159921E-04,0.158874E-04,
23188 &0.101912E-02,0.156880E-05,0.292116E-01,0.175644E-01,0.131678E-04,
23189 &0.193783E-04,0.132645E-04,0.131678E-04,0.847586E-03,0.156432E-05,
23190 &0.250173E-01,0.147740E-01,0.109029E-04,0.167762E-04,0.109910E-04,
23191 &0.109029E-04,0.705515E-03,0.151845E-05,0.213702E-01,0.123979E-01,
23192 &0.901273E-05,0.144953E-04,0.909200E-05,0.901273E-05,0.581767E-03,
23193 &0.143817E-05,0.182083E-01,0.103797E-01,0.743733E-05,0.124978E-04,
23194 &0.750792E-05,0.743733E-05,0.475483E-03,0.133574E-05,0.154751E-01/
23195 DATA (DL(K),K= 3146, 3230) /
23196 &0.867011E-02,0.612722E-05,0.107517E-04,0.618950E-05,0.612722E-05,
23197 &0.390116E-03,0.122183E-05,0.131193E-01,0.722560E-02,0.503734E-05,
23198 &0.922584E-05,0.509185E-05,0.503734E-05,0.319980E-03,0.110130E-05,
23199 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23200 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23201 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23202 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23203 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23204 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23205 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23206 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23207 &0.754424E-01,0.449848E-01,0.236444E-04,0.236444E-04,0.236444E-04,
23208 &0.236444E-04,0.129291E-02,0.113079E-17,0.650429E-01,0.379660E-01,
23209 &0.187739E-04,0.207130E-04,0.187990E-04,0.187739E-04,0.124038E-02,
23210 &-.327995E-06,0.559588E-01,0.319936E-01,0.149625E-04,0.182671E-04,
23211 &0.150033E-04,0.149625E-04,0.113497E-02,-.464337E-06,0.480234E-01,
23212 &0.269030E-01,0.119484E-04,0.161746E-04,0.119982E-04,0.119484E-04/
23213 DATA (DL(K),K= 3231, 3315) /
23214 &0.100877E-02,-.490618E-06,0.411091E-01,0.225716E-01,0.954833E-05,
23215 &0.143391E-04,0.960250E-05,0.954833E-05,0.883852E-03,-.461770E-06,
23216 &0.350995E-01,0.188947E-01,0.763738E-05,0.127129E-04,0.769248E-05,
23217 &0.763738E-05,0.760077E-03,-.403363E-06,0.298897E-01,0.157798E-01,
23218 &0.611070E-05,0.112548E-04,0.616439E-05,0.611070E-05,0.639505E-03,
23219 &-.335607E-06,0.253856E-01,0.131470E-01,0.488993E-05,0.994021E-05,
23220 &0.494070E-05,0.488993E-05,0.534131E-03,-.267652E-06,0.215026E-01,
23221 &0.109271E-01,0.391276E-05,0.875190E-05,0.395967E-05,0.391276E-05,
23222 &0.445478E-03,-.205292E-06,0.181648E-01,0.906007E-02,0.312720E-05,
23223 &0.767418E-05,0.316978E-05,0.312720E-05,0.366232E-03,-.154024E-06,
23224 &0.153041E-01,0.749382E-02,0.249633E-05,0.670002E-05,0.253440E-05,
23225 &0.249633E-05,0.297435E-03,-.112673E-06,0.128596E-01,0.618334E-02,
23226 &0.199074E-05,0.582360E-05,0.202435E-05,0.199074E-05,0.242305E-03,
23227 &-.794410E-07,0.107770E-01,0.508977E-02,0.158457E-05,0.503733E-05,
23228 &0.161393E-05,0.158457E-05,0.196927E-03,-.546702E-07,0.900806E-02,
23229 &0.417964E-02,0.125888E-05,0.433619E-05,0.128428E-05,0.125888E-05,
23230 &0.158171E-03,-.364714E-07,0.751006E-02,0.342418E-02,0.998674E-06/
23231 DATA (DL(K),K= 3316, 3400) /
23232 &0.371518E-05,0.102046E-05,0.998674E-06,0.126865E-03,-.228706E-07,
23233 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23234 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23235 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23236 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23237 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23238 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23239 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23240 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23241 &0.496787E-01,0.236961E-01,0.607312E-05,0.607312E-05,0.607312E-05,
23242 &0.607312E-05,0.415108E-03,-.140523E-17,0.420445E-01,0.196196E-01,
23243 &0.443589E-05,0.603481E-05,0.444683E-05,0.443589E-05,0.444425E-03,
23244 &-.375397E-06,0.355108E-01,0.162223E-01,0.321766E-05,0.587645E-05,
23245 &0.323504E-05,0.321766E-05,0.432635E-03,-.593989E-06,0.299148E-01,
23246 &0.133836E-01,0.231504E-05,0.562250E-05,0.233581E-05,0.231504E-05,
23247 &0.395801E-03,-.699904E-06,0.251339E-01,0.110157E-01,0.164651E-05,
23248 &0.526880E-05,0.166853E-05,0.164651E-05,0.344925E-03,-.733095E-06/
23249 DATA (DL(K),K= 3401, 3485) /
23250 &0.210605E-01,0.904539E-02,0.115940E-05,0.485739E-05,0.118122E-05,
23251 &0.115940E-05,0.294439E-03,-.715193E-06,0.175989E-01,0.740944E-02,
23252 &0.808365E-06,0.441709E-05,0.829075E-06,0.808365E-06,0.249093E-03,
23253 &-.665420E-06,0.146656E-01,0.605433E-02,0.555563E-06,0.396078E-05,
23254 &0.574607E-06,0.555563E-06,0.205675E-03,-.600648E-06,0.121872E-01,
23255 &0.493466E-02,0.375914E-06,0.350822E-05,0.393011E-06,0.375914E-06,
23256 &0.166757E-03,-.529210E-06,0.100993E-01,0.401191E-02,0.250032E-06,
23257 &0.307359E-05,0.265094E-06,0.250032E-06,0.135196E-03,-.456996E-06,
23258 &0.834582E-02,0.325348E-02,0.162261E-06,0.266488E-05,0.175325E-06,
23259 &0.162261E-06,0.108862E-03,-.388821E-06,0.687767E-02,0.263179E-02,
23260 &0.102273E-06,0.228913E-05,0.113453E-06,0.102273E-06,0.865539E-04,
23261 &-.326325E-06,0.565221E-02,0.212357E-02,0.620694E-07,0.194975E-05,
23262 &0.715290E-07,0.620694E-07,0.687156E-04,-.270547E-06,0.463248E-02,
23263 &0.170926E-02,0.351992E-07,0.164711E-05,0.431226E-07,0.351992E-07,
23264 &0.543744E-04,-.222379E-06,0.378655E-02,0.137242E-02,0.178902E-07,
23265 &0.138124E-05,0.244675E-07,0.178902E-07,0.426626E-04,-.181158E-06,
23266 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23267 DATA (DL(K),K= 3486, 3570) /
23268 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23269 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23270 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23271 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23272 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23273 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23274 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23275 &0.286141E-01,0.102357E-01,0.105702E-05,0.105702E-05,0.105702E-05,
23276 &0.105702E-05,0.963318E-04,0.591070E-18,0.236608E-01,0.827483E-02,
23277 &0.548552E-06,0.163293E-05,0.551993E-06,0.548552E-06,0.133058E-03,
23278 &-.268677E-06,0.195282E-01,0.668247E-02,0.238780E-06,0.183459E-05,
23279 &0.243802E-06,0.238780E-06,0.135119E-03,-.393414E-06,0.160742E-01,
23280 &0.538444E-02,0.599864E-07,0.183277E-05,0.655085E-07,0.599864E-07,
23281 &0.124554E-03,-.428349E-06,0.131940E-01,0.432750E-02,-.392825E-07,
23282 &0.172071E-05,-.338391E-07,-.392825E-07,0.111121E-03,-.415550E-06,
23283 &0.107996E-01,0.346954E-02,-.875089E-07,0.154604E-05,-.824926E-07,
23284 &-.875089E-07,0.941854E-04,-.376855E-06,0.881435E-02,0.277463E-02/
23285 DATA (DL(K),K= 3571, 3655) /
23286 &-.103962E-06,0.135013E-05,-.995446E-07,-.103962E-06,0.772195E-04,
23287 &-.326008E-06,0.717317E-02,0.221313E-02,-.102844E-06,0.115335E-05,
23288 &-.990733E-07,-.102844E-06,0.626565E-04,-.272858E-06,0.582050E-02,
23289 &0.176061E-02,-.929503E-07,0.967229E-06,-.898064E-07,-.929503E-07,
23290 &0.499930E-04,-.222828E-06,0.470908E-02,0.139692E-02,-.791495E-07,
23291 &0.800414E-06,-.765797E-07,-.791495E-07,0.394181E-04,-.178141E-06,
23292 &0.379875E-02,0.110542E-02,-.647230E-07,0.655119E-06,-.626567E-07,
23293 &-.647230E-07,0.309999E-04,-.140000E-06,0.305549E-02,0.872447E-03,
23294 &-.515215E-07,0.530834E-06,-.498829E-07,-.515215E-07,0.240354E-04,
23295 &-.108633E-06,0.245058E-02,0.686769E-03,-.400234E-07,0.426835E-06,
23296 &-.387401E-07,-.400234E-07,0.184613E-04,-.832544E-07,0.195984E-02,
23297 &0.539209E-03,-.304312E-07,0.341169E-06,-.294373E-07,-.304312E-07,
23298 &0.143512E-04,-.630818E-07,0.156297E-02,0.422273E-03,-.228633E-07,
23299 &0.271199E-06,-.221014E-07,-.228633E-07,0.110898E-04,-.474683E-07,
23300 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23301 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23302 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23303 DATA (DL(K),K= 3656, 3740) /
23304 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23305 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23306 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23307 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23308 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23309 &0.129345E-01,0.308444E-02,0.903693E-07,0.903693E-07,0.903693E-07,
23310 &0.903693E-07,0.123538E-04,-.166230E-18,0.103598E-01,0.241354E-02,
23311 &0.155648E-06,-.205296E-06,0.154889E-06,0.155648E-06,0.267249E-04,
23312 &0.880707E-07,0.828507E-02,0.188764E-02,0.176333E-06,-.341498E-06,
23313 &0.175220E-06,0.176333E-06,0.306432E-04,0.125718E-06,0.660736E-02,
23314 &0.147304E-02,0.173444E-06,-.383695E-06,0.172215E-06,0.173444E-06,
23315 &0.280787E-04,0.135578E-06,0.525320E-02,0.114618E-02,0.158651E-06,
23316 &-.373371E-06,0.157437E-06,0.158651E-06,0.243526E-04,0.130412E-06,
23317 &0.416429E-02,0.889584E-03,0.137131E-06,-.333468E-06,0.136012E-06,
23318 &0.137131E-06,0.203463E-04,0.116115E-06,0.329102E-02,0.688580E-03,
23319 &0.113839E-06,-.280874E-06,0.112853E-06,0.113839E-06,0.161038E-04,
23320 &0.982305E-07,0.259282E-02,0.531508E-03,0.914374E-07,-.225427E-06/
23321 DATA (DL(K),K= 3741, 3825) /
23322 &0.905971E-07,0.914374E-07,0.125639E-04,0.798741E-07,0.203641E-02,
23323 &0.409120E-03,0.709595E-07,-.173123E-06,0.702607E-07,0.709595E-07,
23324 &0.979247E-05,0.624138E-07,0.159441E-02,0.314027E-03,0.532256E-07,
23325 &-.127272E-06,0.526566E-07,0.532256E-07,0.741899E-05,0.469253E-07,
23326 &0.124447E-02,0.240357E-03,0.385509E-07,-.888851E-07,0.380956E-07,
23327 &0.385509E-07,0.554070E-05,0.339174E-07,0.968328E-03,0.183454E-03,
23328 &0.267272E-07,-.580277E-07,0.263687E-07,0.267272E-07,0.420032E-05,
23329 &0.233280E-07,0.751159E-03,0.139632E-03,0.174605E-07,-.342016E-07,
23330 &0.171822E-07,0.174605E-07,0.315522E-05,0.149727E-07,0.580936E-03,
23331 &0.105986E-03,0.104515E-07,-.164567E-07,0.102383E-07,0.104515E-07,
23332 &0.230829E-05,0.863527E-08,0.447955E-03,0.802293E-04,0.531954E-08,
23333 &-.376312E-08,0.515829E-08,0.531954E-08,0.170771E-05,0.399662E-08,
23334 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23335 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23336 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23337 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23338 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23339 DATA (DL(K),K= 3826, 3910) /
23340 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23341 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23342 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23343 &0.324478E-02,0.386879E-03,0.135983E-08,0.135983E-08,0.135983E-08,
23344 &0.135983E-08,0.371787E-06,-.274599E-19,0.246219E-02,0.286505E-03,
23345 &-.106852E-06,0.327611E-06,-.106589E-06,-.106852E-06,0.231631E-05,
23346 &-.107814E-06,0.186777E-02,0.212413E-03,-.161566E-06,0.492001E-06,
23347 &-.161179E-06,-.161566E-06,0.311589E-05,-.162249E-06,0.141322E-02,
23348 &0.157212E-03,-.183398E-06,0.557106E-06,-.182972E-06,-.183398E-06,
23349 &0.267943E-05,-.183884E-06,0.106518E-02,0.115892E-03,-.185231E-06,
23350 &0.562185E-06,-.184809E-06,-.185231E-06,0.203027E-05,-.185573E-06,
23351 &0.800350E-03,0.851995E-04,-.174680E-06,0.530096E-06,-.174290E-06,
23352 &-.174680E-06,0.165870E-05,-.174922E-06,0.599444E-03,0.624676E-04,
23353 &-.157644E-06,0.478420E-06,-.157300E-06,-.157644E-06,0.130112E-05,
23354 &-.157815E-06,0.447433E-03,0.456556E-04,-.137838E-06,0.418429E-06,
23355 &-.137543E-06,-.137838E-06,0.903220E-06,-.137958E-06,0.332836E-03,
23356 &0.332643E-04,-.117616E-06,0.357179E-06,-.117368E-06,-.117616E-06/
23357 DATA (DL(K),K= 3911, 3995) /
23358 &0.636187E-06,-.117699E-06,0.246754E-03,0.241622E-04,-.984560E-07,
23359 &0.299077E-06,-.982529E-07,-.984560E-07,0.481221E-06,-.985144E-07,
23360 &0.182315E-03,0.174961E-04,-.811089E-07,0.246465E-06,-.809446E-07,
23361 &-.811089E-07,0.342859E-06,-.811495E-07,0.134250E-03,0.126299E-04,
23362 &-.659052E-07,0.200354E-06,-.657742E-07,-.659052E-07,0.227840E-06,
23363 &-.659334E-07,0.985288E-04,0.908931E-05,-.529252E-07,0.160947E-06,
23364 &-.528218E-07,-.529252E-07,0.161641E-06,-.529447E-07,0.720750E-04,
23365 &0.652153E-05,-.420621E-07,0.127943E-06,-.419814E-07,-.420621E-07,
23366 &0.119540E-06,-.420756E-07,0.525538E-04,0.466527E-05,-.331141E-07,
23367 &0.100758E-06,-.330516E-07,-.331141E-07,0.808991E-07,-.331233E-07,
23368 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23369 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23370 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23371 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23372 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23373 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23374 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23375 DATA (DL(K),K= 3996, 4000) /
23376 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23379 IF (X.GT.0.9985) RETURN
23380 IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
23386 F1(L) = GF(I,IS,KL)
23387 F2(L) = GF(I,IS1,KL)
23389 A1 = DT_CKMTFF(X,F1)
23390 A2 = DT_CKMTFF(X,F2)
23395 ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
23402 *$ CREATE DT_CKMTPR.FOR
23404 SUBROUTINE DT_CKMTPR(I,NDRV,X,S,ANS)
23406 C**********************************************************************
23408 C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
23410 C This version by S. Roesler, 31.01.96
23411 C**********************************************************************
23414 DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
23415 EQUIVALENCE (GF(1,1,1),DL(1))
23418 DATA (DL(K),K= 1, 85) /
23419 &0.367759E+00,0.350609E+00,0.325356E+00,0.325356E+00,0.325356E+00,
23420 &0.325356E+00,0.533117E+01,0.138778E-16,0.427988E+00,0.409718E+00,
23421 &0.382948E+00,0.382920E+00,0.382933E+00,0.382948E+00,0.686279E+01,
23422 &0.611113E-01,0.494752E+00,0.475328E+00,0.447011E+00,0.446959E+00,
23423 &0.446984E+00,0.447011E+00,0.855688E+01,0.128659E+00,0.568248E+00,
23424 &0.547637E+00,0.517743E+00,0.517671E+00,0.517705E+00,0.517743E+00,
23425 &0.104074E+02,0.202846E+00,0.648622E+00,0.626792E+00,0.595289E+00,
23426 &0.595201E+00,0.595244E+00,0.595289E+00,0.124065E+02,0.283819E+00,
23427 &0.735974E+00,0.712890E+00,0.679748E+00,0.679648E+00,0.679696E+00,
23428 &0.679748E+00,0.145441E+02,0.371679E+00,0.830359E+00,0.805987E+00,
23429 &0.771173E+00,0.771066E+00,0.771119E+00,0.771173E+00,0.168081E+02,
23430 &0.466485E+00,0.931778E+00,0.906084E+00,0.869566E+00,0.869456E+00,
23431 &0.869511E+00,0.869566E+00,0.191850E+02,0.568240E+00,0.104018E+01,
23432 &0.101313E+01,0.974873E+00,0.974763E+00,0.974819E+00,0.974873E+00,
23433 &0.216593E+02,0.676890E+00,0.115544E+01,0.112700E+01,0.108698E+01,
23434 &0.108687E+01,0.108693E+01,0.108698E+01,0.242146E+02,0.792321E+00,
23435 &0.127738E+01,0.124751E+01,0.120570E+01,0.120560E+01,0.120565E+01/
23436 DATA (DL(K),K= 86, 170) /
23437 &0.120570E+01,0.268333E+02,0.914356E+00,0.140577E+01,0.137444E+01,
23438 &0.133079E+01,0.133070E+01,0.133075E+01,0.133079E+01,0.294970E+02,
23439 &0.104275E+01,0.154028E+01,0.150745E+01,0.146194E+01,0.146187E+01,
23440 &0.146192E+01,0.146194E+01,0.321867E+02,0.117720E+01,0.168054E+01,
23441 &0.164619E+01,0.159879E+01,0.159874E+01,0.159877E+01,0.159879E+01,
23442 &0.348836E+02,0.131732E+01,0.182613E+01,0.179020E+01,0.174088E+01,
23443 &0.174086E+01,0.174088E+01,0.174088E+01,0.375685E+02,0.146269E+01,
23444 &0.197653E+01,0.193901E+01,0.188774E+01,0.188774E+01,0.188775E+01,
23445 &0.188774E+01,0.402228E+02,0.161282E+01,0.213121E+01,0.209205E+01,
23446 &0.203880E+01,0.203884E+01,0.203884E+01,0.203880E+01,0.428285E+02,
23447 &0.176714E+01,0.228955E+01,0.224873E+01,0.219348E+01,0.219355E+01,
23448 &0.219353E+01,0.219348E+01,0.453682E+02,0.192507E+01,0.245093E+01,
23449 &0.240840E+01,0.235113E+01,0.235123E+01,0.235120E+01,0.235113E+01,
23450 &0.478258E+02,0.208597E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23451 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23452 &0.349839E+00,0.324128E+00,0.286363E+00,0.286363E+00,0.286363E+00,
23453 &0.286363E+00,0.469694E+01,0.000000E+00,0.398361E+00,0.371065E+00/
23454 DATA (DL(K),K= 171, 255) /
23455 &0.331239E+00,0.331213E+00,0.331227E+00,0.331239E+00,0.586152E+01,
23456 &0.481683E-01,0.451010E+00,0.422096E+00,0.380182E+00,0.380137E+00,
23457 &0.380161E+00,0.380182E+00,0.711349E+01,0.100378E+00,0.507782E+00,
23458 &0.477215E+00,0.433187E+00,0.433128E+00,0.433160E+00,0.433187E+00,
23459 &0.844371E+01,0.156627E+00,0.568644E+00,0.536390E+00,0.490220E+00,
23460 &0.490152E+00,0.490190E+00,0.490220E+00,0.984291E+01,0.216886E+00,
23461 &0.633517E+00,0.599543E+00,0.551204E+00,0.551133E+00,0.551174E+00,
23462 &0.551204E+00,0.113005E+02,0.281079E+00,0.702295E+00,0.666565E+00,
23463 &0.616031E+00,0.615963E+00,0.616004E+00,0.616031E+00,0.128050E+02,
23464 &0.349101E+00,0.774832E+00,0.737311E+00,0.684556E+00,0.684495E+00,
23465 &0.684535E+00,0.684556E+00,0.143447E+02,0.420809E+00,0.850945E+00,
23466 &0.811598E+00,0.756596E+00,0.756547E+00,0.756583E+00,0.756596E+00,
23467 &0.159073E+02,0.496022E+00,0.930413E+00,0.889207E+00,0.831933E+00,
23468 &0.831901E+00,0.831931E+00,0.831933E+00,0.174801E+02,0.574524E+00,
23469 &0.101298E+01,0.969882E+00,0.910312E+00,0.910301E+00,0.910324E+00,
23470 &0.910312E+00,0.190508E+02,0.656061E+00,0.109836E+01,0.105333E+01,
23471 &0.991445E+00,0.991459E+00,0.991471E+00,0.991445E+00,0.206070E+02/
23472 DATA (DL(K),K= 256, 340) /
23473 &0.740345E+00,0.118622E+01,0.113923E+01,0.107501E+01,0.107505E+01,
23474 &0.107505E+01,0.107501E+01,0.221368E+02,0.827056E+00,0.127622E+01,
23475 &0.122724E+01,0.116065E+01,0.116073E+01,0.116072E+01,0.116065E+01,
23476 &0.236287E+02,0.915845E+00,0.136797E+01,0.131696E+01,0.124800E+01,
23477 &0.124812E+01,0.124809E+01,0.124800E+01,0.250721E+02,0.100634E+01,
23478 &0.146107E+01,0.140801E+01,0.133666E+01,0.133681E+01,0.133677E+01,
23479 &0.133666E+01,0.264571E+02,0.109813E+01,0.155511E+01,0.149996E+01,
23480 &0.142621E+01,0.142641E+01,0.142634E+01,0.142621E+01,0.277747E+02,
23481 &0.119081E+01,0.164964E+01,0.159239E+01,0.151622E+01,0.151646E+01,
23482 &0.151638E+01,0.151622E+01,0.290168E+02,0.128396E+01,0.174424E+01,
23483 &0.168485E+01,0.160626E+01,0.160655E+01,0.160645E+01,0.160626E+01,
23484 &0.301765E+02,0.137713E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23485 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23486 &0.345345E+00,0.306823E+00,0.250518E+00,0.250518E+00,0.250518E+00,
23487 &0.250518E+00,0.411726E+01,-.138778E-16,0.384210E+00,0.343514E+00,
23488 &0.284500E+00,0.284487E+00,0.284496E+00,0.284500E+00,0.496835E+01,
23489 &0.371582E-01,0.425419E+00,0.382518E+00,0.320782E+00,0.320762E+00/
23490 DATA (DL(K),K= 341, 425) /
23491 &0.320777E+00,0.320782E+00,0.585504E+01,0.765988E-01,0.468853E+00,
23492 &0.423717E+00,0.359246E+00,0.359226E+00,0.359243E+00,0.359246E+00,
23493 &0.676824E+01,0.118207E+00,0.514392E+00,0.466990E+00,0.399771E+00,
23494 &0.399758E+00,0.399775E+00,0.399771E+00,0.769967E+01,0.161865E+00,
23495 &0.561883E+00,0.512186E+00,0.442209E+00,0.442208E+00,0.442222E+00,
23496 &0.442209E+00,0.864071E+01,0.207426E+00,0.611162E+00,0.559140E+00,
23497 &0.486395E+00,0.486411E+00,0.486420E+00,0.486395E+00,0.958280E+01,
23498 &0.254727E+00,0.662044E+00,0.607667E+00,0.532145E+00,0.532185E+00,
23499 &0.532185E+00,0.532145E+00,0.105176E+02,0.303587E+00,0.714325E+00,
23500 &0.657566E+00,0.579261E+00,0.579328E+00,0.579318E+00,0.579261E+00,
23501 &0.114370E+02,0.353808E+00,0.767786E+00,0.708618E+00,0.627526E+00,
23502 &0.627625E+00,0.627603E+00,0.627526E+00,0.123333E+02,0.405174E+00,
23503 &0.822195E+00,0.760591E+00,0.676711E+00,0.676846E+00,0.676810E+00,
23504 &0.676711E+00,0.131994E+02,0.457458E+00,0.877307E+00,0.813242E+00,
23505 &0.726575E+00,0.726750E+00,0.726697E+00,0.726575E+00,0.140286E+02,
23506 &0.510420E+00,0.932865E+00,0.866317E+00,0.776867E+00,0.777085E+00,
23507 &0.777015E+00,0.776867E+00,0.148150E+02,0.563809E+00,0.988608E+00/
23508 DATA (DL(K),K= 426, 510) /
23509 &0.919556E+00,0.827330E+00,0.827594E+00,0.827505E+00,0.827330E+00,
23510 &0.155533E+02,0.617368E+00,0.104427E+01,0.972694E+00,0.877703E+00,
23511 &0.878016E+00,0.877907E+00,0.877703E+00,0.162391E+02,0.670837E+00,
23512 &0.109958E+01,0.102547E+01,0.927723E+00,0.928088E+00,0.927957E+00,
23513 &0.927723E+00,0.168687E+02,0.723954E+00,0.115428E+01,0.107761E+01,
23514 &0.977132E+00,0.977550E+00,0.977397E+00,0.977132E+00,0.174391E+02,
23515 &0.776458E+00,0.120809E+01,0.112886E+01,0.102567E+01,0.102615E+01,
23516 &0.102597E+01,0.102567E+01,0.179481E+02,0.828097E+00,0.126078E+01,
23517 &0.117898E+01,0.107310E+01,0.107363E+01,0.107343E+01,0.107310E+01,
23518 &0.183942E+02,0.878621E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23519 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23520 &0.357586E+00,0.299938E+00,0.216504E+00,0.216504E+00,0.216504E+00,
23521 &0.216504E+00,0.357260E+01,-.277556E-16,0.388529E+00,0.327984E+00,
23522 &0.241161E+00,0.241168E+00,0.241168E+00,0.241161E+00,0.415893E+01,
23523 &0.278429E-01,0.420472E+00,0.357015E+00,0.266823E+00,0.266844E+00,
23524 &0.266842E+00,0.266823E+00,0.474689E+01,0.566783E-01,0.453271E+00,
23525 &0.386886E+00,0.293349E+00,0.293389E+00,0.293381E+00,0.293349E+00/
23526 DATA (DL(K),K= 511, 595) /
23527 &0.532982E+01,0.863668E-01,0.486793E+00,0.417464E+00,0.320608E+00,
23528 &0.320673E+00,0.320657E+00,0.320608E+00,0.590219E+01,0.116779E+00,
23529 &0.520887E+00,0.448601E+00,0.348454E+00,0.348549E+00,0.348523E+00,
23530 &0.348454E+00,0.645868E+01,0.147773E+00,0.555403E+00,0.480149E+00,
23531 &0.376740E+00,0.376870E+00,0.376831E+00,0.376740E+00,0.699440E+01,
23532 &0.179201E+00,0.590183E+00,0.511950E+00,0.405314E+00,0.405482E+00,
23533 &0.405429E+00,0.405314E+00,0.750493E+01,0.210912E+00,0.625064E+00,
23534 &0.543845E+00,0.434019E+00,0.434229E+00,0.434159E+00,0.434019E+00,
23535 &0.798636E+01,0.242750E+00,0.659882E+00,0.575673E+00,0.462696E+00,
23536 &0.462952E+00,0.462864E+00,0.462696E+00,0.843528E+01,0.274558E+00,
23537 &0.694472E+00,0.607271E+00,0.491188E+00,0.491492E+00,0.491385E+00,
23538 &0.491188E+00,0.884885E+01,0.306178E+00,0.728669E+00,0.638478E+00,
23539 &0.519337E+00,0.519690E+00,0.519563E+00,0.519337E+00,0.922480E+01,
23540 &0.337451E+00,0.762311E+00,0.669133E+00,0.546987E+00,0.547392E+00,
23541 &0.547244E+00,0.546987E+00,0.956139E+01,0.368224E+00,0.795240E+00,
23542 &0.699084E+00,0.573988E+00,0.574447E+00,0.574277E+00,0.573988E+00,
23543 &0.985744E+01,0.398346E+00,0.827302E+00,0.728181E+00,0.600196E+00/
23544 DATA (DL(K),K= 596, 680) /
23545 &0.600710E+00,0.600518E+00,0.600196E+00,0.101123E+02,0.427671E+00,
23546 &0.858354E+00,0.756282E+00,0.625475E+00,0.626044E+00,0.625829E+00,
23547 &0.625475E+00,0.103258E+02,0.456064E+00,0.888257E+00,0.783256E+00,
23548 &0.649696E+00,0.650321E+00,0.650083E+00,0.649696E+00,0.104982E+02,
23549 &0.483395E+00,0.916887E+00,0.808981E+00,0.672742E+00,0.673422E+00,
23550 &0.673161E+00,0.672742E+00,0.106303E+02,0.509546E+00,0.944126E+00,
23551 &0.833345E+00,0.694506E+00,0.695243E+00,0.694958E+00,0.694506E+00,
23552 &0.107231E+02,0.534410E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23553 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23554 &0.390721E+00,0.304671E+00,0.182562E+00,0.182562E+00,0.182562E+00,
23555 &0.182562E+00,0.303699E+01,0.693889E-17,0.414806E+00,0.325059E+00,
23556 &0.199103E+00,0.199133E+00,0.199124E+00,0.199103E+00,0.339971E+01,
23557 &0.198528E-01,0.438929E+00,0.345508E+00,0.215797E+00,0.215862E+00,
23558 &0.215842E+00,0.215797E+00,0.374624E+01,0.398420E-01,0.462973E+00,
23559 &0.365903E+00,0.232531E+00,0.232635E+00,0.232601E+00,0.232531E+00,
23560 &0.407322E+01,0.598565E-01,0.486835E+00,0.386142E+00,0.249208E+00,
23561 &0.249352E+00,0.249304E+00,0.249208E+00,0.437817E+01,0.797987E-01/
23562 DATA (DL(K),K= 681, 765) /
23563 &0.510407E+00,0.406123E+00,0.265725E+00,0.265913E+00,0.265849E+00,
23564 &0.265725E+00,0.465901E+01,0.995694E-01,0.533588E+00,0.425746E+00,
23565 &0.281986E+00,0.282220E+00,0.282139E+00,0.281986E+00,0.491410E+01,
23566 &0.119072E+00,0.556274E+00,0.444912E+00,0.297897E+00,0.298178E+00,
23567 &0.298079E+00,0.297897E+00,0.514220E+01,0.138212E+00,0.578369E+00,
23568 &0.463528E+00,0.313366E+00,0.313696E+00,0.313578E+00,0.313366E+00,
23569 &0.534249E+01,0.156900E+00,0.599777E+00,0.481503E+00,0.328308E+00,
23570 &0.328688E+00,0.328549E+00,0.328308E+00,0.551456E+01,0.175048E+00,
23571 &0.620409E+00,0.498752E+00,0.342642E+00,0.343071E+00,0.342913E+00,
23572 &0.342642E+00,0.565833E+01,0.192575E+00,0.640181E+00,0.515196E+00,
23573 &0.356292E+00,0.356770E+00,0.356592E+00,0.356292E+00,0.577410E+01,
23574 &0.209407E+00,0.659017E+00,0.530764E+00,0.369190E+00,0.369718E+00,
23575 &0.369519E+00,0.369190E+00,0.586243E+01,0.225474E+00,0.676845E+00,
23576 &0.545389E+00,0.381275E+00,0.381852E+00,0.381633E+00,0.381275E+00,
23577 &0.592421E+01,0.240714E+00,0.693604E+00,0.559015E+00,0.392493E+00,
23578 &0.393118E+00,0.392880E+00,0.392493E+00,0.596052E+01,0.255072E+00,
23579 &0.709239E+00,0.571593E+00,0.402799E+00,0.403472E+00,0.403213E+00/
23580 DATA (DL(K),K= 766, 850) /
23581 &0.402799E+00,0.597267E+01,0.268502E+00,0.723703E+00,0.583081E+00,
23582 &0.412157E+00,0.412875E+00,0.412597E+00,0.412157E+00,0.596211E+01,
23583 &0.280966E+00,0.736960E+00,0.593447E+00,0.420536E+00,0.421299E+00,
23584 &0.421002E+00,0.420536E+00,0.593045E+01,0.292434E+00,0.748980E+00,
23585 &0.602669E+00,0.427918E+00,0.428723E+00,0.428408E+00,0.427918E+00,
23586 &0.587934E+01,0.302884E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23587 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23588 &0.448390E+00,0.320678E+00,0.146415E+00,0.146415E+00,0.146415E+00,
23589 &0.146415E+00,0.247594E+01,0.000000E+00,0.465760E+00,0.333734E+00,
23590 &0.155974E+00,0.156013E+00,0.156000E+00,0.155974E+00,0.265633E+01,
23591 &0.130329E-01,0.482525E+00,0.346293E+00,0.165233E+00,0.165311E+00,
23592 &0.165285E+00,0.165233E+00,0.281612E+01,0.257304E-01,0.498626E+00,
23593 &0.358294E+00,0.174131E+00,0.174249E+00,0.174209E+00,0.174131E+00,
23594 &0.295484E+01,0.380345E-01,0.514008E+00,0.369688E+00,0.182622E+00,
23595 &0.182779E+00,0.182724E+00,0.182622E+00,0.307242E+01,0.498976E-01,
23596 &0.528624E+00,0.380432E+00,0.190660E+00,0.190856E+00,0.190786E+00,
23597 &0.190660E+00,0.316911E+01,0.612760E-01,0.542428E+00,0.390485E+00/
23598 DATA (DL(K),K= 851, 935) /
23599 &0.198205E+00,0.198441E+00,0.198356E+00,0.198205E+00,0.324538E+01,
23600 &0.721303E-01,0.555382E+00,0.399810E+00,0.205224E+00,0.205498E+00,
23601 &0.205398E+00,0.205224E+00,0.330192E+01,0.824256E-01,0.567448E+00,
23602 &0.408377E+00,0.211687E+00,0.211997E+00,0.211882E+00,0.211687E+00,
23603 &0.333960E+01,0.921319E-01,0.578597E+00,0.416159E+00,0.217568E+00,
23604 &0.217915E+00,0.217784E+00,0.217568E+00,0.335945E+01,0.101224E+00,
23605 &0.588802E+00,0.423136E+00,0.222847E+00,0.223229E+00,0.223084E+00,
23606 &0.222847E+00,0.336262E+01,0.109681E+00,0.598043E+00,0.429293E+00,
23607 &0.227512E+00,0.227928E+00,0.227768E+00,0.227512E+00,0.335036E+01,
23608 &0.117489E+00,0.606305E+00,0.434619E+00,0.231551E+00,0.232000E+00,
23609 &0.231826E+00,0.231551E+00,0.332398E+01,0.124636E+00,0.613579E+00,
23610 &0.439110E+00,0.234962E+00,0.235442E+00,0.235254E+00,0.234962E+00,
23611 &0.328483E+01,0.131119E+00,0.619860E+00,0.442766E+00,0.237745E+00,
23612 &0.238254E+00,0.238053E+00,0.237745E+00,0.323429E+01,0.136936E+00,
23613 &0.625150E+00,0.445594E+00,0.239905E+00,0.240441E+00,0.240228E+00,
23614 &0.239905E+00,0.317371E+01,0.142091E+00,0.629453E+00,0.447603E+00,
23615 &0.241452E+00,0.242014E+00,0.241788E+00,0.241452E+00,0.310443E+01/
23616 DATA (DL(K),K= 936, 1020) /
23617 &0.146594E+00,0.632782E+00,0.448808E+00,0.242400E+00,0.242987E+00,
23618 &0.242749E+00,0.242400E+00,0.302775E+01,0.150456E+00,0.635151E+00,
23619 &0.449228E+00,0.242767E+00,0.243376E+00,0.243127E+00,0.242767E+00,
23620 &0.294491E+01,0.153694E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23621 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23622 &0.528765E+00,0.341825E+00,0.105823E+00,0.105823E+00,0.105823E+00,
23623 &0.105823E+00,0.185069E+01,-.138778E-16,0.538124E+00,0.347118E+00,
23624 &0.109762E+00,0.109780E+00,0.109774E+00,0.109762E+00,0.189644E+01,
23625 &0.738880E-02,0.546541E+00,0.351712E+00,0.113300E+00,0.113336E+00,
23626 &0.113324E+00,0.113300E+00,0.192700E+01,0.143076E-01,0.554014E+00,
23627 &0.355607E+00,0.116431E+00,0.116485E+00,0.116466E+00,0.116431E+00,
23628 &0.194356E+01,0.207515E-01,0.560546E+00,0.358805E+00,0.119150E+00,
23629 &0.119222E+00,0.119196E+00,0.119150E+00,0.194722E+01,0.267179E-01,
23630 &0.566139E+00,0.361311E+00,0.121459E+00,0.121549E+00,0.121515E+00,
23631 &0.121459E+00,0.193921E+01,0.322084E-01,0.570802E+00,0.363134E+00,
23632 &0.123359E+00,0.123467E+00,0.123426E+00,0.123359E+00,0.192071E+01,
23633 &0.372262E-01,0.574542E+00,0.364286E+00,0.124858E+00,0.124983E+00/
23634 DATA (DL(K),K= 1021, 1105) /
23635 &0.124933E+00,0.124858E+00,0.189295E+01,0.417774E-01,0.577372E+00,
23636 &0.364779E+00,0.125961E+00,0.126103E+00,0.126046E+00,0.125961E+00,
23637 &0.185710E+01,0.458703E-01,0.579307E+00,0.364629E+00,0.126681E+00,
23638 &0.126839E+00,0.126774E+00,0.126681E+00,0.181432E+01,0.495154E-01,
23639 &0.580363E+00,0.363857E+00,0.127029E+00,0.127202E+00,0.127130E+00,
23640 &0.127029E+00,0.176571E+01,0.527252E-01,0.580561E+00,0.362483E+00,
23641 &0.127020E+00,0.127208E+00,0.127128E+00,0.127020E+00,0.171231E+01,
23642 &0.555142E-01,0.579923E+00,0.360529E+00,0.126670E+00,0.126872E+00,
23643 &0.126785E+00,0.126670E+00,0.165511E+01,0.578985E-01,0.578474E+00,
23644 &0.358021E+00,0.125998E+00,0.126213E+00,0.126119E+00,0.125998E+00,
23645 &0.159501E+01,0.598958E-01,0.576241E+00,0.354987E+00,0.125022E+00,
23646 &0.125249E+00,0.125148E+00,0.125022E+00,0.153284E+01,0.615248E-01,
23647 &0.573252E+00,0.351453E+00,0.123762E+00,0.124000E+00,0.123893E+00,
23648 &0.123762E+00,0.146934E+01,0.628056E-01,0.569539E+00,0.347450E+00,
23649 &0.122240E+00,0.122488E+00,0.122375E+00,0.122240E+00,0.140517E+01,
23650 &0.637587E-01,0.565134E+00,0.343008E+00,0.120476E+00,0.120733E+00,
23651 &0.120615E+00,0.120476E+00,0.134093E+01,0.644054E-01,0.560071E+00/
23652 DATA (DL(K),K= 1106, 1190) /
23653 &0.338158E+00,0.118493E+00,0.118758E+00,0.118635E+00,0.118493E+00,
23654 &0.127712E+01,0.647671E-01,0.000000E+00,0.000000E+00,0.000000E+00,
23655 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23656 &0.584093E+00,0.349173E+00,0.772117E-01,0.772117E-01,0.772117E-01,
23657 &0.772117E-01,0.140433E+01,0.346945E-17,0.586736E+00,0.349017E+00,
23658 &0.785355E-01,0.785519E-01,0.785448E-01,0.785355E-01,0.139434E+01,
23659 &0.447504E-02,0.588402E+00,0.348237E+00,0.795437E-01,0.795759E-01,
23660 &0.795617E-01,0.795437E-01,0.137550E+01,0.854114E-02,0.589124E+00,
23661 &0.346861E+00,0.802498E-01,0.802970E-01,0.802758E-01,0.802498E-01,
23662 &0.134918E+01,0.122148E-01,0.588930E+00,0.344912E+00,0.806656E-01,
23663 &0.807271E-01,0.806990E-01,0.806656E-01,0.131652E+01,0.155101E-01,
23664 &0.587849E+00,0.342417E+00,0.808055E-01,0.808805E-01,0.808457E-01,
23665 &0.808055E-01,0.127862E+01,0.184435E-01,0.585912E+00,0.339402E+00,
23666 &0.806843E-01,0.807718E-01,0.807306E-01,0.806843E-01,0.123648E+01,
23667 &0.210315E-01,0.583151E+00,0.335894E+00,0.803173E-01,0.804166E-01,
23668 &0.803692E-01,0.803173E-01,0.119104E+01,0.232909E-01,0.579599E+00,
23669 &0.331923E+00,0.797205E-01,0.798308E-01,0.797775E-01,0.797205E-01/
23670 DATA (DL(K),K= 1191, 1275) /
23671 &0.114317E+01,0.252394E-01,0.575288E+00,0.327516E+00,0.789107E-01,
23672 &0.790310E-01,0.789721E-01,0.789107E-01,0.109362E+01,0.268946E-01,
23673 &0.570253E+00,0.322704E+00,0.779045E-01,0.780341E-01,0.779698E-01,
23674 &0.779045E-01,0.104307E+01,0.282745E-01,0.564530E+00,0.317515E+00,
23675 &0.767190E-01,0.768570E-01,0.767878E-01,0.767190E-01,0.992143E+00,
23676 &0.293974E-01,0.558155E+00,0.311981E+00,0.753713E-01,0.755169E-01,
23677 &0.754432E-01,0.753713E-01,0.941341E+00,0.302812E-01,0.551166E+00,
23678 &0.306131E+00,0.738784E-01,0.740308E-01,0.739528E-01,0.738784E-01,
23679 &0.891113E+00,0.309441E-01,0.543599E+00,0.299995E+00,0.722571E-01,
23680 &0.724154E-01,0.723336E-01,0.722571E-01,0.841829E+00,0.314037E-01,
23681 &0.535494E+00,0.293603E+00,0.705237E-01,0.706871E-01,0.706019E-01,
23682 &0.705237E-01,0.793794E+00,0.316774E-01,0.526888E+00,0.286986E+00,
23683 &0.686941E-01,0.688619E-01,0.687736E-01,0.686941E-01,0.747249E+00,
23684 &0.317823E-01,0.517822E+00,0.280172E+00,0.667836E-01,0.669551E-01,
23685 &0.668640E-01,0.667836E-01,0.702381E+00,0.317346E-01,0.508333E+00,
23686 &0.273189E+00,0.648068E-01,0.649814E-01,0.648879E-01,0.648068E-01,
23687 &0.659330E+00,0.315501E-01,0.000000E+00,0.000000E+00,0.000000E+00/
23688 DATA (DL(K),K= 1276, 1360) /
23689 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23690 &0.622739E+00,0.340676E+00,0.509141E-01,0.509141E-01,0.509141E-01,
23691 &0.509141E-01,0.980502E+00,-.173472E-17,0.617764E+00,0.335457E+00,
23692 &0.507607E-01,0.507701E-01,0.507651E-01,0.507607E-01,0.944375E+00,
23693 &0.242386E-02,0.611957E+00,0.329837E+00,0.504236E-01,0.504417E-01,
23694 &0.504321E-01,0.504236E-01,0.905225E+00,0.455851E-02,0.605372E+00,
23695 &0.323853E+00,0.499207E-01,0.499471E-01,0.499328E-01,0.499207E-01,
23696 &0.864035E+00,0.642656E-02,0.598052E+00,0.317537E+00,0.492668E-01,
23697 &0.493008E-01,0.492822E-01,0.492668E-01,0.821557E+00,0.804638E-02,
23698 &0.590044E+00,0.310919E+00,0.484772E-01,0.485183E-01,0.484955E-01,
23699 &0.484772E-01,0.778444E+00,0.943663E-02,0.581391E+00,0.304033E+00,
23700 &0.475665E-01,0.476142E-01,0.475874E-01,0.475665E-01,0.735263E+00,
23701 &0.106150E-01,0.572137E+00,0.296908E+00,0.465487E-01,0.466024E-01,
23702 &0.465720E-01,0.465487E-01,0.692487E+00,0.115984E-01,0.562326E+00,
23703 &0.289573E+00,0.454376E-01,0.454968E-01,0.454629E-01,0.454376E-01,
23704 &0.650510E+00,0.124032E-01,0.552003E+00,0.282060E+00,0.442463E-01,
23705 &0.443103E-01,0.442733E-01,0.442463E-01,0.609652E+00,0.130451E-01/
23706 DATA (DL(K),K= 1361, 1445) /
23707 &0.541210E+00,0.274395E+00,0.429871E-01,0.430555E-01,0.430156E-01,
23708 &0.429871E-01,0.570164E+00,0.135389E-01,0.529991E+00,0.266608E+00,
23709 &0.416720E-01,0.417443E-01,0.417018E-01,0.416720E-01,0.532237E+00,
23710 &0.138989E-01,0.518389E+00,0.258725E+00,0.403123E-01,0.403879E-01,
23711 &0.403431E-01,0.403123E-01,0.496010E+00,0.141386E-01,0.506446E+00,
23712 &0.250772E+00,0.389186E-01,0.389971E-01,0.389501E-01,0.389186E-01,
23713 &0.461573E+00,0.142708E-01,0.494204E+00,0.242775E+00,0.375006E-01,
23714 &0.375815E-01,0.375327E-01,0.375006E-01,0.428979E+00,0.143074E-01,
23715 &0.481705E+00,0.234757E+00,0.360674E-01,0.361503E-01,0.361000E-01,
23716 &0.360674E-01,0.398246E+00,0.142598E-01,0.468990E+00,0.226741E+00,
23717 &0.346276E-01,0.347120E-01,0.346605E-01,0.346276E-01,0.369363E+00,
23718 &0.141385E-01,0.456098E+00,0.218750E+00,0.331887E-01,0.332743E-01,
23719 &0.332216E-01,0.331887E-01,0.342300E+00,0.139532E-01,0.443068E+00,
23720 &0.210804E+00,0.317576E-01,0.318440E-01,0.317905E-01,0.317576E-01,
23721 &0.317005E+00,0.137130E-01,0.000000E+00,0.000000E+00,0.000000E+00,
23722 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23723 &0.631458E+00,0.318714E+00,0.335640E-01,0.335640E-01,0.335640E-01/
23724 DATA (DL(K),K= 1446, 1530) /
23725 &0.335640E-01,0.686773E+00,0.346945E-17,0.620274E+00,0.310241E+00,
23726 &0.329311E-01,0.329377E-01,0.329337E-01,0.329311E-01,0.646559E+00,
23727 &0.135960E-02,0.608504E+00,0.301610E+00,0.322083E-01,0.322210E-01,
23728 &0.322133E-01,0.322083E-01,0.606503E+00,0.252820E-02,0.596205E+00,
23729 &0.292854E+00,0.314099E-01,0.314281E-01,0.314169E-01,0.314099E-01,
23730 &0.567134E+00,0.352543E-02,0.583429E+00,0.284002E+00,0.305470E-01,
23731 &0.305704E-01,0.305558E-01,0.305470E-01,0.528824E+00,0.436693E-02,
23732 &0.570223E+00,0.275080E+00,0.296307E-01,0.296586E-01,0.296411E-01,
23733 &0.296307E-01,0.491848E+00,0.506768E-02,0.556637E+00,0.266115E+00,
23734 &0.286709E-01,0.287030E-01,0.286827E-01,0.286709E-01,0.456422E+00,
23735 &0.564157E-02,0.542717E+00,0.257131E+00,0.276770E-01,0.277128E-01,
23736 &0.276900E-01,0.276770E-01,0.422697E+00,0.610148E-02,0.528511E+00,
23737 &0.248154E+00,0.266578E-01,0.266968E-01,0.266718E-01,0.266578E-01,
23738 &0.390771E+00,0.645942E-02,0.514062E+00,0.239205E+00,0.256210E-01,
23739 &0.256629E-01,0.256359E-01,0.256210E-01,0.360700E+00,0.672653E-02,
23740 &0.499417E+00,0.230307E+00,0.245741E-01,0.246185E-01,0.245896E-01,
23741 &0.245741E-01,0.332498E+00,0.691312E-02,0.484617E+00,0.221480E+00/
23742 DATA (DL(K),K= 1531, 1615) /
23743 &0.235237E-01,0.235701E-01,0.235397E-01,0.235237E-01,0.306153E+00,
23744 &0.702875E-02,0.469706E+00,0.212745E+00,0.224757E-01,0.225238E-01,
23745 &0.224921E-01,0.224757E-01,0.281624E+00,0.708222E-02,0.454725E+00,
23746 &0.204118E+00,0.214355E-01,0.214850E-01,0.214522E-01,0.214355E-01,
23747 &0.258855E+00,0.708159E-02,0.439713E+00,0.195618E+00,0.204079E-01,
23748 &0.204586E-01,0.204249E-01,0.204079E-01,0.237774E+00,0.703428E-02,
23749 &0.424709E+00,0.187259E+00,0.193972E-01,0.194486E-01,0.194142E-01,
23750 &0.193972E-01,0.218298E+00,0.694702E-02,0.409750E+00,0.179057E+00,
23751 &0.184069E-01,0.184588E-01,0.184239E-01,0.184069E-01,0.200339E+00,
23752 &0.682594E-02,0.394870E+00,0.171023E+00,0.174402E-01,0.174924E-01,
23753 &0.174571E-01,0.174402E-01,0.183804E+00,0.667657E-02,0.380104E+00,
23754 &0.163171E+00,0.164997E-01,0.165519E-01,0.165164E-01,0.164997E-01,
23755 &0.168600E+00,0.650389E-02,0.000000E+00,0.000000E+00,0.000000E+00,
23756 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23757 &0.619056E+00,0.288873E+00,0.218554E-01,0.218554E-01,0.218554E-01,
23758 &0.218554E-01,0.477010E+00,-.867362E-17,0.602890E+00,0.278444E+00,
23759 &0.211480E-01,0.211530E-01,0.211497E-01,0.211480E-01,0.440877E+00/
23760 DATA (DL(K),K= 1616, 1700) /
23761 &0.767466E-03,0.586431E+00,0.268081E+00,0.204081E-01,0.204175E-01,
23762 &0.204113E-01,0.204081E-01,0.406417E+00,0.141432E-02,0.569736E+00,
23763 &0.257807E+00,0.196446E-01,0.196581E-01,0.196491E-01,0.196446E-01,
23764 &0.373808E+00,0.195508E-02,0.552853E+00,0.247642E+00,0.188646E-01,
23765 &0.188816E-01,0.188701E-01,0.188646E-01,0.343145E+00,0.240123E-02,
23766 &0.535829E+00,0.237603E+00,0.180743E-01,0.180945E-01,0.180808E-01,
23767 &0.180743E-01,0.314460E+00,0.276332E-02,0.518710E+00,0.227710E+00,
23768 &0.172796E-01,0.173025E-01,0.172868E-01,0.172796E-01,0.287750E+00,
23769 &0.305100E-02,0.501539E+00,0.217977E+00,0.164854E-01,0.165108E-01,
23770 &0.164933E-01,0.164854E-01,0.262983E+00,0.327305E-02,0.484360E+00,
23771 &0.208420E+00,0.156964E-01,0.157239E-01,0.157049E-01,0.156964E-01,
23772 &0.240098E+00,0.343744E-02,0.467213E+00,0.199053E+00,0.149165E-01,
23773 &0.149457E-01,0.149254E-01,0.149165E-01,0.219021E+00,0.355144E-02,
23774 &0.450140E+00,0.189889E+00,0.141493E-01,0.141800E-01,0.141586E-01,
23775 &0.141493E-01,0.199660E+00,0.362164E-02,0.433177E+00,0.180939E+00,
23776 &0.133978E-01,0.134297E-01,0.134073E-01,0.133978E-01,0.181918E+00,
23777 &0.365401E-02,0.416362E+00,0.172214E+00,0.126646E-01,0.126974E-01/
23778 DATA (DL(K),K= 1701, 1785) /
23779 &0.126742E-01,0.126646E-01,0.165692E+00,0.365394E-02,0.399729E+00,
23780 &0.163725E+00,0.119518E-01,0.119853E-01,0.119615E-01,0.119518E-01,
23781 &0.150875E+00,0.362628E-02,0.383310E+00,0.155477E+00,0.112613E-01,
23782 &0.112952E-01,0.112711E-01,0.112613E-01,0.137364E+00,0.357539E-02,
23783 &0.367138E+00,0.147479E+00,0.105945E-01,0.106287E-01,0.106042E-01,
23784 &0.105945E-01,0.125056E+00,0.350515E-02,0.351239E+00,0.139737E+00,
23785 &0.995250E-02,0.998673E-02,0.996211E-02,0.995250E-02,0.113852E+00,
23786 &0.341903E-02,0.335641E+00,0.132253E+00,0.933610E-02,0.937024E-02,
23787 &0.934557E-02,0.933610E-02,0.103659E+00,0.332009E-02,0.320367E+00,
23788 &0.125033E+00,0.874584E-02,0.877973E-02,0.875514E-02,0.874584E-02,
23789 &0.943886E-01,0.321106E-02,0.000000E+00,0.000000E+00,0.000000E+00,
23790 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23791 &0.591114E+00,0.254807E+00,0.139531E-01,0.139531E-01,0.139531E-01,
23792 &0.139531E-01,0.326288E+00,0.000000E+00,0.571121E+00,0.243424E+00,
23793 &0.133325E-01,0.133362E-01,0.133336E-01,0.133325E-01,0.296956E+00,
23794 &0.429082E-03,0.551151E+00,0.232297E+00,0.127105E-01,0.127175E-01,
23795 &0.127126E-01,0.127105E-01,0.269811E+00,0.785137E-03,0.531253E+00/
23796 DATA (DL(K),K= 1786, 1870) /
23797 &0.221436E+00,0.120916E-01,0.121015E-01,0.120945E-01,0.120916E-01,
23798 &0.244803E+00,0.107790E-02,0.511467E+00,0.210850E+00,0.114794E-01,
23799 &0.114918E-01,0.114829E-01,0.114794E-01,0.221863E+00,0.131504E-02,
23800 &0.491833E+00,0.200545E+00,0.108767E-01,0.108913E-01,0.108808E-01,
23801 &0.108767E-01,0.200886E+00,0.150337E-02,0.472388E+00,0.190531E+00,
23802 &0.102861E-01,0.103027E-01,0.102907E-01,0.102861E-01,0.181762E+00,
23803 &0.164910E-02,0.453170E+00,0.180812E+00,0.970979E-02,0.972799E-02,
23804 &0.971477E-02,0.970979E-02,0.164371E+00,0.175777E-02,0.434213E+00,
23805 &0.171394E+00,0.914959E-02,0.916916E-02,0.915488E-02,0.914959E-02,
23806 &0.148589E+00,0.183434E-02,0.415548E+00,0.162282E+00,0.860700E-02,
23807 &0.862770E-02,0.861252E-02,0.860700E-02,0.134293E+00,0.188328E-02,
23808 &0.397208E+00,0.153479E+00,0.808323E-02,0.810484E-02,0.808891E-02,
23809 &0.808323E-02,0.121361E+00,0.190856E-02,0.379220E+00,0.144989E+00,
23810 &0.757922E-02,0.760152E-02,0.758501E-02,0.757922E-02,0.109676E+00,
23811 &0.191374E-02,0.361611E+00,0.136811E+00,0.709565E-02,0.711846E-02,
23812 &0.710150E-02,0.709565E-02,0.991261E-01,0.190199E-02,0.344406E+00,
23813 &0.128948E+00,0.663300E-02,0.665614E-02,0.663885E-02,0.663300E-02/
23814 DATA (DL(K),K= 1871, 1955) /
23815 &0.896059E-01,0.187610E-02,0.327627E+00,0.121398E+00,0.619152E-02,
23816 &0.621484E-02,0.619734E-02,0.619152E-02,0.810177E-01,0.183856E-02,
23817 &0.311292E+00,0.114161E+00,0.577130E-02,0.579466E-02,0.577706E-02,
23818 &0.577130E-02,0.732709E-01,0.179155E-02,0.295421E+00,0.107235E+00,
23819 &0.537228E-02,0.539554E-02,0.537794E-02,0.537228E-02,0.662824E-01,
23820 &0.173700E-02,0.280026E+00,0.100616E+00,0.499423E-02,0.501728E-02,
23821 &0.499977E-02,0.499423E-02,0.599766E-01,0.167658E-02,0.265121E+00,
23822 &0.943000E-01,0.463683E-02,0.465958E-02,0.464223E-02,0.463683E-02,
23823 &0.542848E-01,0.161174E-02,0.000000E+00,0.000000E+00,0.000000E+00,
23824 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23825 &0.551659E+00,0.219084E+00,0.867977E-02,0.867977E-02,0.867977E-02,
23826 &0.867977E-02,0.218587E+00,-.173472E-16,0.528947E+00,0.207536E+00,
23827 &0.819621E-02,0.819909E-02,0.819696E-02,0.819621E-02,0.196367E+00,
23828 &0.234843E-03,0.506575E+00,0.196391E+00,0.772540E-02,0.773082E-02,
23829 &0.772680E-02,0.772540E-02,0.176280E+00,0.427503E-03,0.484579E+00,
23830 &0.185646E+00,0.726876E-02,0.727639E-02,0.727069E-02,0.726876E-02,
23831 &0.158158E+00,0.583933E-03,0.462988E+00,0.175298E+00,0.682746E-02/
23832 DATA (DL(K),K= 1956, 2040) /
23833 &0.683702E-02,0.682985E-02,0.682746E-02,0.141851E+00,0.708874E-03,
23834 &0.441830E+00,0.165345E+00,0.640226E-02,0.641347E-02,0.640502E-02,
23835 &0.640226E-02,0.127203E+00,0.806409E-03,0.421129E+00,0.155783E+00,
23836 &0.599380E-02,0.600641E-02,0.599686E-02,0.599380E-02,0.114065E+00,
23837 &0.880249E-03,0.400912E+00,0.146609E+00,0.560252E-02,0.561629E-02,
23838 &0.560581E-02,0.560252E-02,0.102296E+00,0.933676E-03,0.381199E+00,
23839 &0.137819E+00,0.522870E-02,0.524342E-02,0.523217E-02,0.522870E-02,
23840 &0.917608E-01,0.969607E-03,0.362011E+00,0.129407E+00,0.487247E-02,
23841 &0.488796E-02,0.487607E-02,0.487247E-02,0.823356E-01,0.990632E-03,
23842 &0.343367E+00,0.121370E+00,0.453385E-02,0.454992E-02,0.453753E-02,
23843 &0.453385E-02,0.739054E-01,0.999042E-03,0.325282E+00,0.113700E+00,
23844 &0.421272E-02,0.422921E-02,0.421644E-02,0.421272E-02,0.663651E-01,
23845 &0.996863E-03,0.307770E+00,0.106393E+00,0.390887E-02,0.392563E-02,
23846 &0.391260E-02,0.390887E-02,0.596195E-01,0.985881E-03,0.290841E+00,
23847 &0.994399E-01,0.362199E-02,0.363889E-02,0.362570E-02,0.362199E-02,
23848 &0.535826E-01,0.967664E-03,0.274506E+00,0.928343E-01,0.335170E-02,
23849 &0.336862E-02,0.335536E-02,0.335170E-02,0.481769E-01,0.943587E-03/
23850 DATA (DL(K),K= 2041, 2125) /
23851 &0.258771E+00,0.865679E-01,0.309756E-02,0.311439E-02,0.310114E-02,
23852 &0.309756E-02,0.433336E-01,0.914850E-03,0.243639E+00,0.806321E-01,
23853 &0.285905E-02,0.287571E-02,0.286255E-02,0.285905E-02,0.389912E-01,
23854 &0.882497E-03,0.229113E+00,0.750177E-01,0.263565E-02,0.265205E-02,
23855 &0.263905E-02,0.263565E-02,0.350948E-01,0.847432E-03,0.215193E+00,
23856 &0.697152E-01,0.242677E-02,0.244285E-02,0.243005E-02,0.242677E-02,
23857 &0.315960E-01,0.810432E-03,0.000000E+00,0.000000E+00,0.000000E+00,
23858 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23859 &0.503850E+00,0.183581E+00,0.522815E-02,0.522815E-02,0.522815E-02,
23860 &0.522815E-02,0.142635E+00,0.123599E-16,0.479478E+00,0.172477E+00,
23861 &0.488093E-02,0.488328E-02,0.488147E-02,0.488093E-02,0.126767E+00,
23862 &0.124505E-03,0.455750E+00,0.161879E+00,0.455054E-02,0.455493E-02,
23863 &0.455153E-02,0.455054E-02,0.112695E+00,0.225968E-03,0.432681E+00,
23864 &0.151771E+00,0.423664E-02,0.424278E-02,0.423800E-02,0.423664E-02,
23865 &0.100212E+00,0.307702E-03,0.410286E+00,0.142140E+00,0.393907E-02,
23866 &0.394671E-02,0.394073E-02,0.393907E-02,0.891488E-01,0.372395E-03,
23867 &0.388577E+00,0.132974E+00,0.365743E-02,0.366634E-02,0.365934E-02/
23868 DATA (DL(K),K= 2126, 2210) /
23869 &0.365743E-02,0.793490E-01,0.422302E-03,0.367563E+00,0.124259E+00,
23870 &0.339138E-02,0.340133E-02,0.339347E-02,0.339138E-02,0.706688E-01,
23871 &0.459484E-03,0.347256E+00,0.115984E+00,0.314049E-02,0.315129E-02,
23872 &0.314273E-02,0.314049E-02,0.629792E-01,0.485762E-03,0.327660E+00,
23873 &0.108136E+00,0.290433E-02,0.291580E-02,0.290667E-02,0.290433E-02,
23874 &0.561642E-01,0.502744E-03,0.308782E+00,0.100701E+00,0.268243E-02,
23875 &0.269440E-02,0.268483E-02,0.268243E-02,0.501207E-01,0.511853E-03,
23876 &0.290625E+00,0.936693E-01,0.247429E-02,0.248663E-02,0.247672E-02,
23877 &0.247429E-02,0.447569E-01,0.514346E-03,0.273189E+00,0.870261E-01,
23878 &0.227939E-02,0.229197E-02,0.228184E-02,0.227939E-02,0.399920E-01,
23879 &0.511328E-03,0.256475E+00,0.807592E-01,0.209722E-02,0.210991E-02,
23880 &0.209965E-02,0.209722E-02,0.357547E-01,0.503769E-03,0.240478E+00,
23881 &0.748555E-01,0.192721E-02,0.193992E-02,0.192961E-02,0.192721E-02,
23882 &0.319825E-01,0.492518E-03,0.225194E+00,0.693019E-01,0.176883E-02,
23883 &0.178147E-02,0.177117E-02,0.176883E-02,0.286209E-01,0.478318E-03,
23884 &0.210615E+00,0.640851E-01,0.162151E-02,0.163400E-02,0.162379E-02,
23885 &0.162151E-02,0.256219E-01,0.461813E-03,0.196733E+00,0.591917E-01/
23886 DATA (DL(K),K= 2211, 2295) /
23887 &0.148471E-02,0.149698E-02,0.148691E-02,0.148471E-02,0.229436E-01,
23888 &0.443561E-03,0.183536E+00,0.546085E-01,0.135786E-02,0.136986E-02,
23889 &0.135998E-02,0.135786E-02,0.205496E-01,0.424043E-03,0.171011E+00,
23890 &0.503219E-01,0.124042E-02,0.125211E-02,0.124246E-02,0.124042E-02,
23891 &0.184079E-01,0.403672E-03,0.000000E+00,0.000000E+00,0.000000E+00,
23892 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23893 &0.450310E+00,0.149685E+00,0.302765E-02,0.302765E-02,0.302765E-02,
23894 &0.302765E-02,0.901099E-01,-.108420E-17,0.425282E+00,0.139479E+00,
23895 &0.279499E-02,0.279691E-02,0.279537E-02,0.279499E-02,0.794239E-01,
23896 &0.632140E-04,0.401169E+00,0.129837E+00,0.257801E-02,0.258157E-02,
23897 &0.257870E-02,0.257801E-02,0.700941E-01,0.114711E-03,0.377966E+00,
23898 &0.120733E+00,0.237556E-02,0.238052E-02,0.237650E-02,0.237556E-02,
23899 &0.619270E-01,0.156107E-03,0.355668E+00,0.112145E+00,0.218688E-02,
23900 &0.219301E-02,0.218802E-02,0.218688E-02,0.547717E-01,0.188777E-03,
23901 &0.334269E+00,0.104052E+00,0.201113E-02,0.201823E-02,0.201243E-02,
23902 &0.201113E-02,0.484974E-01,0.213848E-03,0.313762E+00,0.964335E-01,
23903 &0.184758E-02,0.185546E-02,0.184900E-02,0.184758E-02,0.429879E-01/
23904 DATA (DL(K),K= 2296, 2380) /
23905 &0.232367E-03,0.294139E+00,0.892696E-01,0.169553E-02,0.170402E-02,
23906 &0.169703E-02,0.169553E-02,0.381432E-01,0.245270E-03,0.275389E+00,
23907 &0.825414E-01,0.155431E-02,0.156326E-02,0.155586E-02,0.155431E-02,
23908 &0.338762E-01,0.253383E-03,0.257502E+00,0.762303E-01,0.142329E-02,
23909 &0.143258E-02,0.142487E-02,0.142329E-02,0.301119E-01,0.257441E-03,
23910 &0.240464E+00,0.703180E-01,0.130188E-02,0.131138E-02,0.130347E-02,
23911 &0.130188E-02,0.267853E-01,0.258098E-03,0.224262E+00,0.647867E-01,
23912 &0.118950E-02,0.119912E-02,0.119108E-02,0.118950E-02,0.238409E-01,
23913 &0.255929E-03,0.208879E+00,0.596190E-01,0.108562E-02,0.109526E-02,
23914 &0.108717E-02,0.108562E-02,0.212308E-01,0.251442E-03,0.194298E+00,
23915 &0.547975E-01,0.989698E-03,0.999283E-03,0.991221E-03,0.989698E-03,
23916 &0.189136E-01,0.245082E-03,0.180499E+00,0.503054E-01,0.901248E-03,
23917 &0.910711E-03,0.902726E-03,0.901248E-03,0.168537E-01,0.237238E-03,
23918 &0.167463E+00,0.461263E-01,0.819789E-03,0.829074E-03,0.821215E-03,
23919 &0.819789E-03,0.150206E-01,0.228250E-03,0.155167E+00,0.422438E-01,
23920 &0.744866E-03,0.753925E-03,0.746234E-03,0.744866E-03,0.133878E-01,
23921 &0.218412E-03,0.143590E+00,0.386421E-01,0.676043E-03,0.684836E-03/
23922 DATA (DL(K),K= 2381, 2465) /
23923 &0.677349E-03,0.676043E-03,0.119320E-01,0.207976E-03,0.132706E+00,
23924 &0.353058E-01,0.612907E-03,0.621403E-03,0.614147E-03,0.612907E-03,
23925 &0.106334E-01,0.197159E-03,0.000000E+00,0.000000E+00,0.000000E+00,
23926 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23927 &0.393307E+00,0.118409E+00,0.167124E-02,0.167124E-02,0.167124E-02,
23928 &0.167124E-02,0.547140E-01,0.433681E-17,0.368555E+00,0.109414E+00,
23929 &0.152547E-02,0.152705E-02,0.152573E-02,0.152547E-02,0.479708E-01,
23930 &0.303147E-04,0.344946E+00,0.101001E+00,0.139202E-02,0.139494E-02,
23931 &0.139249E-02,0.139202E-02,0.421517E-01,0.552185E-04,0.322450E+00,
23932 &0.931345E-01,0.126960E-02,0.127363E-02,0.127024E-02,0.126960E-02,
23933 &0.371043E-01,0.753524E-04,0.301043E+00,0.857854E-01,0.115731E-02,
23934 &0.116225E-02,0.115808E-02,0.115731E-02,0.327131E-01,0.913172E-04,
23935 &0.280698E+00,0.789267E-01,0.105427E-02,0.105995E-02,0.105514E-02,
23936 &0.105427E-02,0.288844E-01,0.103605E-03,0.261390E+00,0.725323E-01,
23937 &0.959726E-03,0.965979E-03,0.960659E-03,0.959726E-03,0.255366E-01,
23938 &0.112688E-03,0.243091E+00,0.665774E-01,0.872987E-03,0.879676E-03,
23939 &0.873966E-03,0.872987E-03,0.226017E-01,0.119000E-03,0.225775E+00/
23940 DATA (DL(K),K= 2466, 2550) /
23941 &0.610385E-01,0.793435E-03,0.800438E-03,0.794441E-03,0.793435E-03,
23942 &0.200219E-01,0.122931E-03,0.209414E+00,0.558928E-01,0.720508E-03,
23943 &0.727716E-03,0.721524E-03,0.720508E-03,0.177490E-01,0.124835E-03,
23944 &0.193979E+00,0.511187E-01,0.653691E-03,0.661011E-03,0.654703E-03,
23945 &0.653691E-03,0.157425E-01,0.125031E-03,0.179441E+00,0.466950E-01,
23946 &0.592513E-03,0.599863E-03,0.593511E-03,0.592513E-03,0.139674E-01,
23947 &0.123805E-03,0.165770E+00,0.426018E-01,0.536539E-03,0.543850E-03,
23948 &0.537513E-03,0.536539E-03,0.123945E-01,0.121411E-03,0.152935E+00,
23949 &0.388195E-01,0.485370E-03,0.492584E-03,0.486314E-03,0.485370E-03,
23950 &0.109993E-01,0.118076E-03,0.140905E+00,0.353295E-01,0.438636E-03,
23951 &0.445702E-03,0.439543E-03,0.438636E-03,0.976027E-02,0.113999E-03,
23952 &0.129648E+00,0.321137E-01,0.395992E-03,0.402871E-03,0.396859E-03,
23953 &0.395992E-03,0.865895E-02,0.109353E-03,0.119131E+00,0.291550E-01,
23954 &0.357120E-03,0.363779E-03,0.357945E-03,0.357120E-03,0.767960E-02,
23955 &0.104292E-03,0.109323E+00,0.264366E-01,0.321725E-03,0.328139E-03,
23956 &0.322505E-03,0.321725E-03,0.680866E-02,0.989468E-04,0.100191E+00,
23957 &0.239428E-01,0.289531E-03,0.295679E-03,0.290266E-03,0.289531E-03/
23958 DATA (DL(K),K= 2551, 2635) /
23959 &0.603390E-02,0.934295E-04,0.000000E+00,0.000000E+00,0.000000E+00,
23960 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23961 &0.334851E+00,0.904666E-01,0.869706E-03,0.869706E-03,0.869706E-03,
23962 &0.869706E-03,0.316365E-01,-.311708E-17,0.311223E+00,0.828706E-01,
23963 &0.784673E-03,0.785968E-03,0.784847E-03,0.784673E-03,0.277037E-01,
23964 &0.134749E-04,0.288910E+00,0.758361E-01,0.708234E-03,0.710597E-03,
23965 &0.708543E-03,0.708234E-03,0.243298E-01,0.247881E-04,0.267855E+00,
23966 &0.693222E-01,0.639256E-03,0.642491E-03,0.639671E-03,0.639256E-03,
23967 &0.214125E-01,0.340882E-04,0.248015E+00,0.632964E-01,0.576953E-03,
23968 &0.580887E-03,0.577448E-03,0.576953E-03,0.188764E-01,0.415701E-04,
23969 &0.229343E+00,0.577274E-01,0.520615E-03,0.525096E-03,0.521167E-03,
23970 &0.520615E-03,0.166642E-01,0.474027E-04,0.211794E+00,0.525860E-01,
23971 &0.469624E-03,0.474520E-03,0.470215E-03,0.469624E-03,0.147265E-01,
23972 &0.517615E-04,0.195325E+00,0.478447E-01,0.423445E-03,0.428640E-03,
23973 &0.424060E-03,0.423445E-03,0.130234E-01,0.548213E-04,0.179891E+00,
23974 &0.434776E-01,0.381606E-03,0.387001E-03,0.382232E-03,0.381606E-03,
23975 &0.115226E-01,0.567474E-04,0.165449E+00,0.394601E-01,0.343691E-03/
23976 DATA (DL(K),K= 2636, 2720) /
23977 &0.349200E-03,0.344317E-03,0.343691E-03,0.101965E-01,0.576952E-04,
23978 &0.151958E+00,0.357691E-01,0.309329E-03,0.314879E-03,0.309948E-03,
23979 &0.309329E-03,0.902217E-02,0.578101E-04,0.139374E+00,0.323826E-01,
23980 &0.278192E-03,0.283721E-03,0.278796E-03,0.278192E-03,0.798131E-02,
23981 &0.572266E-04,0.127655E+00,0.292797E-01,0.249984E-03,0.255440E-03,
23982 &0.250569E-03,0.249984E-03,0.705796E-02,0.560672E-04,0.116760E+00,
23983 &0.264406E-01,0.224440E-03,0.229782E-03,0.225002E-03,0.224440E-03,
23984 &0.623793E-02,0.544420E-04,0.106647E+00,0.238467E-01,0.201321E-03,
23985 &0.206513E-03,0.201856E-03,0.201321E-03,0.550962E-02,0.524504E-04,
23986 &0.972762E-01,0.214802E-01,0.180411E-03,0.185425E-03,0.180918E-03,
23987 &0.180411E-03,0.486321E-02,0.501804E-04,0.886073E-01,0.193242E-01,
23988 &0.161512E-03,0.166328E-03,0.161990E-03,0.161512E-03,0.428946E-02,
23989 &0.477087E-04,0.806013E-01,0.173629E-01,0.144446E-03,0.149048E-03,
23990 &0.144894E-03,0.144446E-03,0.378030E-02,0.451020E-04,0.732197E-01,
23991 &0.155814E-01,0.129049E-03,0.133425E-03,0.129467E-03,0.129049E-03,
23992 &0.332897E-02,0.424179E-04,0.000000E+00,0.000000E+00,0.000000E+00,
23993 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23994 DATA (DL(K),K= 2721, 2805) /
23995 &0.276761E+00,0.663170E-01,0.420483E-03,0.420483E-03,0.420483E-03,
23996 &0.420483E-03,0.172075E-01,0.418773E-17,0.255003E+00,0.601925E-01,
23997 &0.374768E-03,0.375776E-03,0.374876E-03,0.374768E-03,0.151410E-01,
23998 &0.540038E-05,0.234664E+00,0.545789E-01,0.334420E-03,0.336252E-03,
23999 &0.334612E-03,0.334420E-03,0.133594E-01,0.101360E-04,0.215665E+00,
24000 &0.494328E-01,0.298611E-03,0.301108E-03,0.298867E-03,0.298611E-03,
24001 &0.118079E-01,0.141555E-04,0.197941E+00,0.447203E-01,0.266766E-03,
24002 &0.269787E-03,0.267068E-03,0.266766E-03,0.104461E-01,0.174750E-04,
24003 &0.181428E+00,0.404089E-01,0.238391E-03,0.241815E-03,0.238726E-03,
24004 &0.238391E-03,0.924609E-02,0.201244E-04,0.166064E+00,0.364687E-01,
24005 &0.213061E-03,0.216782E-03,0.213417E-03,0.213061E-03,0.818507E-02,
24006 &0.221467E-04,0.151790E+00,0.328719E-01,0.190418E-03,0.194343E-03,
24007 &0.190785E-03,0.190418E-03,0.724366E-02,0.235974E-04,0.138548E+00,
24008 &0.295925E-01,0.170150E-03,0.174202E-03,0.170521E-03,0.170150E-03,
24009 &0.640614E-02,0.245354E-04,0.126282E+00,0.266063E-01,0.151991E-03,
24010 &0.156104E-03,0.152359E-03,0.151991E-03,0.566089E-02,0.250221E-04,
24011 &0.114939E+00,0.238907E-01,0.135710E-03,0.139827E-03,0.136071E-03/
24012 DATA (DL(K),K= 2806, 2890) /
24013 &0.135710E-03,0.499773E-02,0.251191E-04,0.104465E+00,0.214245E-01,
24014 &0.121106E-03,0.125180E-03,0.121455E-03,0.121106E-03,0.440691E-02,
24015 &0.248850E-04,0.948101E-01,0.191879E-01,0.108002E-03,0.111994E-03,
24016 &0.108337E-03,0.108002E-03,0.388094E-02,0.243760E-04,0.859247E-01,
24017 &0.171625E-01,0.962435E-04,0.100124E-03,0.965624E-04,0.962435E-04,
24018 &0.341379E-02,0.236445E-04,0.777613E-01,0.153309E-01,0.856948E-04,
24019 &0.894394E-04,0.859960E-04,0.856948E-04,0.299910E-02,0.227378E-04,
24020 &0.702736E-01,0.136770E-01,0.762337E-04,0.798235E-04,0.765166E-04,
24021 &0.762337E-04,0.263116E-02,0.216984E-04,0.634174E-01,0.121859E-01,
24022 &0.677528E-04,0.711742E-04,0.680169E-04,0.677528E-04,0.230551E-02,
24023 &0.205642E-04,0.571500E-01,0.108434E-01,0.601554E-04,0.633990E-04,
24024 &0.604008E-04,0.601554E-04,0.201791E-02,0.193681E-04,0.514305E-01,
24025 &0.963651E-02,0.533545E-04,0.564148E-04,0.535814E-04,0.533545E-04,
24026 &0.176404E-02,0.181381E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24027 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24028 &0.220700E+00,0.461964E-01,0.185072E-03,0.185072E-03,0.185072E-03,
24029 &0.185072E-03,0.865568E-02,-.294090E-17,0.201438E+00,0.415162E-01/
24030 DATA (DL(K),K= 2891, 2975) /
24031 &0.162774E-03,0.163610E-03,0.162842E-03,0.162774E-03,0.772611E-02,
24032 &0.184134E-05,0.183625E+00,0.372730E-01,0.143469E-03,0.144974E-03,
24033 &0.143588E-03,0.143469E-03,0.690038E-02,0.359959E-05,0.167162E+00,
24034 &0.334245E-01,0.126634E-03,0.128666E-03,0.126791E-03,0.126634E-03,
24035 &0.616000E-02,0.518075E-05,0.151966E+00,0.299378E-01,0.111904E-03,
24036 &0.114340E-03,0.112088E-03,0.111904E-03,0.549219E-02,0.654232E-05,
24037 &0.137959E+00,0.267821E-01,0.989836E-04,0.101716E-03,0.991845E-04,
24038 &0.989836E-04,0.488896E-02,0.767008E-05,0.125065E+00,0.239289E-01,
24039 &0.876157E-04,0.905559E-04,0.878269E-04,0.876157E-04,0.434253E-02,
24040 &0.855860E-05,0.113213E+00,0.213524E-01,0.775899E-04,0.806611E-04,
24041 &0.778055E-04,0.775899E-04,0.384886E-02,0.921640E-05,0.102335E+00,
24042 &0.190285E-01,0.687292E-04,0.718676E-04,0.689446E-04,0.687292E-04,
24043 &0.340422E-02,0.965961E-05,0.923671E-01,0.169353E-01,0.608829E-04,
24044 &0.640353E-04,0.610944E-04,0.608829E-04,0.300332E-02,0.990752E-05,
24045 &0.832476E-01,0.150523E-01,0.539242E-04,0.570473E-04,0.541291E-04,
24046 &0.539242E-04,0.264288E-02,0.998320E-05,0.749179E-01,0.133608E-01,
24047 &0.477459E-04,0.508046E-04,0.479422E-04,0.477459E-04,0.232088E-02/
24048 DATA (DL(K),K= 2976, 3060) /
24049 &0.991147E-05,0.673221E-01,0.118435E-01,0.422554E-04,0.452220E-04,
24050 &0.424417E-04,0.422554E-04,0.203376E-02,0.971603E-05,0.604073E-01,
24051 &0.104845E-01,0.373730E-04,0.402263E-04,0.375483E-04,0.373730E-04,
24052 &0.177791E-02,0.941959E-05,0.541231E-01,0.926900E-02,0.330304E-04,
24053 &0.357544E-04,0.331943E-04,0.330304E-04,0.155117E-02,0.904408E-05,
24054 &0.484216E-01,0.818347E-02,0.291681E-04,0.317517E-04,0.293202E-04,
24055 &0.291681E-04,0.135108E-02,0.860921E-05,0.432578E-01,0.721549E-02,
24056 &0.257333E-04,0.281694E-04,0.258738E-04,0.257333E-04,0.117463E-02,
24057 &0.813214E-05,0.385889E-01,0.635362E-02,0.226802E-04,0.249648E-04,
24058 &0.228093E-04,0.226802E-04,0.101941E-02,0.762814E-05,0.343746E-01,
24059 &0.558739E-02,0.199682E-04,0.221003E-04,0.200863E-04,0.199682E-04,
24060 &0.883469E-03,0.711035E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24061 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24062 &0.168205E+00,0.301419E-01,0.719932E-04,0.719932E-04,0.719932E-04,
24063 &0.719932E-04,0.392825E-02,-.205998E-17,0.151922E+00,0.267932E-01,
24064 &0.623634E-04,0.630456E-04,0.624028E-04,0.623634E-04,0.361412E-02,
24065 &0.457084E-06,0.137042E+00,0.237932E-01,0.541981E-04,0.554098E-04/
24066 DATA (DL(K),K= 3061, 3145) /
24067 &0.542663E-04,0.541981E-04,0.330342E-02,0.989813E-06,0.123446E+00,
24068 &0.211038E-01,0.472163E-04,0.488314E-04,0.473050E-04,0.472163E-04,
24069 &0.300140E-02,0.152631E-05,0.111042E+00,0.186954E-01,0.412159E-04,
24070 &0.431273E-04,0.413184E-04,0.412159E-04,0.270826E-02,0.202092E-05,
24071 &0.997395E-01,0.165410E-01,0.360433E-04,0.381615E-04,0.361542E-04,
24072 &0.360433E-04,0.242968E-02,0.245400E-05,0.894558E-01,0.146159E-01,
24073 &0.315670E-04,0.338178E-04,0.316822E-04,0.315670E-04,0.216928E-02,
24074 &0.281218E-05,0.801130E-01,0.128978E-01,0.276779E-04,0.300002E-04,
24075 &0.277940E-04,0.276779E-04,0.192603E-02,0.308878E-05,0.716379E-01,
24076 &0.113663E-01,0.242878E-04,0.266317E-04,0.244024E-04,0.242878E-04,
24077 &0.170100E-02,0.328451E-05,0.639623E-01,0.100031E-01,0.213246E-04,
24078 &0.236502E-04,0.214357E-04,0.213246E-04,0.149649E-02,0.340483E-05,
24079 &0.570222E-01,0.879131E-02,0.187277E-04,0.210033E-04,0.188341E-04,
24080 &0.187277E-04,0.131163E-02,0.345656E-05,0.507574E-01,0.771565E-02,
24081 &0.164465E-04,0.186476E-04,0.165471E-04,0.164465E-04,0.114469E-02,
24082 &0.344782E-05,0.451118E-01,0.676223E-02,0.144396E-04,0.165480E-04,
24083 &0.145339E-04,0.144396E-04,0.995649E-03,0.338831E-05,0.400330E-01/
24084 DATA (DL(K),K= 3146, 3230) /
24085 &0.591841E-02,0.126720E-04,0.146744E-04,0.127597E-04,0.126720E-04,
24086 &0.863829E-03,0.328754E-05,0.354720E-01,0.517273E-02,0.111137E-04,
24087 &0.130013E-04,0.111946E-04,0.111137E-04,0.747293E-03,0.315403E-05,
24088 &0.313830E-01,0.451477E-02,0.973915E-05,0.115067E-04,0.981339E-05,
24089 &0.973915E-05,0.644664E-03,0.299600E-05,0.277237E-01,0.393511E-02,
24090 &0.852687E-05,0.101721E-04,0.859457E-05,0.852687E-05,0.555034E-03,
24091 &0.282099E-05,0.244545E-01,0.342521E-02,0.745784E-05,0.898076E-05,
24092 &0.751926E-05,0.745784E-05,0.476998E-03,0.263530E-05,0.215390E-01,
24093 &0.297737E-02,0.651555E-05,0.791817E-05,0.657100E-05,0.651555E-05,
24094 &0.409096E-03,0.244427E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24095 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24096 &0.120694E+00,0.180081E-01,0.236444E-04,0.236444E-04,0.236444E-04,
24097 &0.236444E-04,0.154817E-02,0.416656E-17,0.107713E+00,0.158098E-01,
24098 &0.200945E-04,0.206098E-04,0.201146E-04,0.200945E-04,0.151249E-02,
24099 &0.192118E-07,0.960063E-01,0.138667E-01,0.171552E-04,0.180593E-04,
24100 &0.171894E-04,0.171552E-04,0.143574E-02,0.116516E-06,0.854477E-01,
24101 &0.121473E-01,0.146986E-04,0.158894E-04,0.147425E-04,0.146986E-04/
24102 DATA (DL(K),K= 3231, 3315) /
24103 &0.133744E-02,0.251060E-06,0.759386E-01,0.106275E-01,0.126329E-04,
24104 &0.140252E-04,0.126830E-04,0.126329E-04,0.122900E-02,0.395272E-06,
24105 &0.673865E-01,0.928577E-02,0.108901E-04,0.124142E-04,0.109436E-04,
24106 &0.108901E-04,0.111367E-02,0.535145E-06,0.597062E-01,0.810254E-02,
24107 &0.941160E-05,0.110108E-04,0.946648E-05,0.941160E-05,0.996785E-03,
24108 &0.659421E-06,0.528194E-01,0.706039E-02,0.815165E-05,0.978016E-05,
24109 &0.820627E-05,0.815165E-05,0.885152E-03,0.762600E-06,0.466540E-01,
24110 &0.614371E-02,0.707299E-05,0.869464E-05,0.712616E-05,0.707299E-05,
24111 &0.780484E-03,0.842072E-06,0.411433E-01,0.533850E-02,0.614470E-05,
24112 &0.773135E-05,0.619559E-05,0.614470E-05,0.682563E-03,0.896683E-06,
24113 &0.362261E-01,0.463223E-02,0.534297E-05,0.687330E-05,0.539102E-05,
24114 &0.534297E-05,0.593317E-03,0.928176E-06,0.318459E-01,0.401364E-02,
24115 &0.464848E-05,0.610690E-05,0.469333E-05,0.464848E-05,0.513720E-03,
24116 &0.939174E-06,0.279510E-01,0.347266E-02,0.404483E-05,0.542054E-05,
24117 &0.408628E-05,0.404483E-05,0.442713E-03,0.932117E-06,0.244935E-01,
24118 &0.300029E-02,0.351893E-05,0.480507E-05,0.355692E-05,0.351893E-05,
24119 &0.379744E-03,0.910085E-06,0.214299E-01,0.258845E-02,0.306021E-05/
24120 DATA (DL(K),K= 3316, 3400) /
24121 &0.425313E-05,0.309476E-05,0.306021E-05,0.324785E-03,0.876365E-06,
24122 &0.187200E-01,0.222996E-02,0.265958E-05,0.375823E-05,0.269081E-05,
24123 &0.265958E-05,0.277080E-03,0.833755E-06,0.163273E-01,0.191840E-02,
24124 &0.230942E-05,0.331477E-05,0.233747E-05,0.230942E-05,0.235661E-03,
24125 &0.784780E-06,0.142185E-01,0.164805E-02,0.200337E-05,0.291797E-05,
24126 &0.202844E-05,0.200337E-05,0.199949E-03,0.731774E-06,0.123631E-01,
24127 &0.141382E-02,0.173596E-05,0.256351E-05,0.175824E-05,0.173596E-05,
24128 &0.169376E-03,0.676674E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24129 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24130 &0.794823E-01,0.948208E-02,0.607312E-05,0.607312E-05,0.607312E-05,
24131 &0.607312E-05,0.497062E-03,-.140523E-17,0.699344E-01,0.820355E-02,
24132 &0.500852E-05,0.538347E-05,0.501731E-05,0.500852E-05,0.542262E-03,
24133 &-.714686E-07,0.614560E-01,0.709106E-02,0.415227E-05,0.479898E-05,
24134 &0.416702E-05,0.415227E-05,0.549985E-03,-.960102E-07,0.539240E-01,
24135 &0.612155E-02,0.345977E-05,0.429563E-05,0.347839E-05,0.345977E-05,
24136 &0.531288E-03,-.894946E-07,0.472426E-01,0.527757E-02,0.289508E-05,
24137 &0.385164E-05,0.291595E-05,0.289508E-05,0.495120E-03,-.668594E-07/
24138 DATA (DL(K),K= 3401, 3485) /
24139 &0.413245E-01,0.454380E-02,0.243524E-05,0.345851E-05,0.245713E-05,
24140 &0.243524E-05,0.452156E-03,-.338861E-07,0.360903E-01,0.390658E-02,
24141 &0.205923E-05,0.310726E-05,0.208123E-05,0.205923E-05,0.406686E-03,
24142 &0.329349E-08,0.314681E-01,0.335393E-02,0.174861E-05,0.278918E-05,
24143 &0.177007E-05,0.174861E-05,0.359402E-03,0.387747E-07,0.273932E-01,
24144 &0.287528E-02,0.149082E-05,0.250013E-05,0.151127E-05,0.149082E-05,
24145 &0.313779E-03,0.705560E-07,0.238068E-01,0.246132E-02,0.127582E-05,
24146 &0.223699E-05,0.129498E-05,0.127582E-05,0.272195E-03,0.975744E-07,
24147 &0.206558E-01,0.210383E-02,0.109488E-05,0.199657E-05,0.111257E-05,
24148 &0.109488E-05,0.234227E-03,0.118651E-06,0.178921E-01,0.179558E-02,
24149 &0.941584E-06,0.177694E-05,0.957733E-06,0.941584E-06,0.199907E-03,
24150 &0.133780E-06,0.154726E-01,0.153020E-02,0.811157E-06,0.157680E-05,
24151 &0.825743E-06,0.811157E-06,0.169849E-03,0.143581E-06,0.133582E-01,
24152 &0.130209E-02,0.699567E-06,0.139481E-05,0.712624E-06,0.699567E-06,
24153 &0.143794E-03,0.148591E-06,0.115137E-01,0.110634E-02,0.603631E-06,
24154 &0.122977E-05,0.615228E-06,0.603631E-06,0.121163E-03,0.149477E-06,
24155 &0.990774E-02,0.938615E-03,0.520920E-06,0.108072E-05,0.531148E-06/
24156 DATA (DL(K),K= 3486, 3570) /
24157 &0.520920E-06,0.101725E-03,0.147055E-06,0.851194E-02,0.795146E-03,
24158 &0.449441E-06,0.946634E-06,0.458405E-06,0.449441E-06,0.852238E-04,
24159 &0.142064E-06,0.730103E-02,0.672622E-03,0.387542E-06,0.826497E-06,
24160 &0.395353E-06,0.387542E-06,0.712290E-04,0.135149E-06,0.625244E-02,
24161 &0.568155E-03,0.333888E-06,0.719316E-06,0.340658E-06,0.333888E-06,
24162 &0.593824E-04,0.126902E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24163 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24164 &0.457819E-01,0.409492E-02,0.105702E-05,0.105702E-05,0.105702E-05,
24165 &0.105702E-05,0.115350E-03,0.265810E-18,0.395724E-01,0.347873E-02,
24166 &0.812397E-06,0.103880E-05,0.815187E-06,0.812397E-06,0.160406E-03,
24167 &-.555147E-07,0.341639E-01,0.295295E-02,0.627904E-06,0.987449E-06,
24168 &0.632305E-06,0.627904E-06,0.174490E-03,-.847266E-07,0.294481E-01,
24169 &0.250329E-02,0.490075E-06,0.920197E-06,0.495305E-06,0.490075E-06,
24170 &0.174490E-03,-.944763E-07,0.253423E-01,0.211912E-02,0.387225E-06,
24171 &0.845257E-06,0.392760E-06,0.387225E-06,0.167111E-03,-.916775E-07,
24172 &0.217735E-01,0.179138E-02,0.309989E-06,0.766697E-06,0.315473E-06,
24173 &0.309989E-06,0.152540E-03,-.819158E-07,0.186760E-01,0.151211E-02/
24174 DATA (DL(K),K= 3571, 3655) /
24175 &0.252109E-06,0.688927E-06,0.257316E-06,0.252109E-06,0.135295E-03,
24176 &-.682145E-07,0.159921E-01,0.127447E-02,0.208612E-06,0.614302E-06,
24177 &0.213410E-06,0.208612E-06,0.118648E-03,-.528734E-07,0.136704E-01,
24178 &0.107254E-02,0.175203E-06,0.543807E-06,0.179526E-06,0.175203E-06,
24179 &0.102484E-03,-.379748E-07,0.116656E-01,0.901214E-03,0.149064E-06,
24180 &0.478363E-06,0.152890E-06,0.149064E-06,0.871530E-04,-.245007E-07,
24181 &0.993760E-02,0.756074E-03,0.128274E-06,0.418496E-06,0.131610E-06,
24182 &0.128274E-06,0.735682E-04,-.128491E-07,0.845081E-02,0.633315E-03,
24183 &0.111313E-06,0.364260E-06,0.114187E-06,0.111313E-06,0.617706E-04,
24184 &-.327698E-08,0.717398E-02,0.529654E-03,0.971373E-07,0.315568E-06,
24185 &0.995871E-07,0.971373E-07,0.514764E-04,0.421954E-08,0.607950E-02,
24186 &0.442265E-03,0.850687E-07,0.272228E-06,0.871375E-07,0.850687E-07,
24187 &0.426580E-04,0.982709E-08,0.514311E-02,0.368716E-03,0.746164E-07,
24188 &0.233927E-06,0.763489E-07,0.746164E-07,0.352463E-04,0.137715E-07,
24189 &0.434349E-02,0.306920E-03,0.654439E-07,0.200291E-06,0.668838E-07,
24190 &0.654439E-07,0.290260E-04,0.163078E-07,0.366196E-02,0.255085E-03,
24191 &0.573307E-07,0.170932E-06,0.585192E-07,0.573307E-07,0.238196E-04/
24192 DATA (DL(K),K= 3656, 3740) /
24193 &0.177037E-07,0.308217E-02,0.211681E-03,0.501185E-07,0.145441E-06,
24194 &0.510931E-07,0.501185E-07,0.195033E-04,0.182028E-07,0.258987E-02,
24195 &0.175396E-03,0.436915E-07,0.123415E-06,0.444860E-07,0.436915E-07,
24196 &0.159423E-04,0.180204E-07,0.000000E+00,0.000000E+00,0.000000E+00,
24197 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24198 &0.206951E-01,0.123383E-02,0.903693E-07,0.903693E-07,0.903693E-07,
24199 &0.903693E-07,0.147928E-04,0.131925E-18,0.174566E-01,0.102241E-02,
24200 &0.892028E-07,0.129792E-07,0.885875E-07,0.892028E-07,0.328931E-04,
24201 &0.168541E-07,0.147092E-01,0.846741E-03,0.841992E-07,-.346085E-07,
24202 &0.832249E-07,0.841992E-07,0.410825E-04,0.262547E-07,0.123736E-01,
24203 &0.700287E-03,0.769173E-07,-.620958E-07,0.757563E-07,0.769173E-07,
24204 &0.418512E-04,0.305542E-07,0.103910E-01,0.578275E-03,0.688622E-07,
24205 &-.753692E-07,0.676306E-07,0.688622E-07,0.392599E-04,0.318183E-07,
24206 &0.871109E-02,0.476815E-03,0.611778E-07,-.782788E-07,0.599557E-07,
24207 &0.611778E-07,0.356221E-04,0.316149E-07,0.728984E-02,0.392546E-03,
24208 &0.537256E-07,-.749101E-07,0.525642E-07,0.537256E-07,0.312295E-04,
24209 &0.301630E-07,0.608951E-02,0.322656E-03,0.466227E-07,-.678673E-07/
24210 DATA (DL(K),K= 3741, 3825) /
24211 &0.455521E-07,0.466227E-07,0.265816E-04,0.278681E-07,0.507758E-02,
24212 &0.264779E-03,0.400790E-07,-.588670E-07,0.391148E-07,0.400790E-07,
24213 &0.223044E-04,0.251720E-07,0.422604E-02,0.216927E-03,0.341205E-07,
24214 &-.492124E-07,0.332680E-07,0.341205E-07,0.185283E-04,0.222885E-07,
24215 &0.351082E-02,0.177427E-03,0.287480E-07,-.397442E-07,0.280058E-07,
24216 &0.287480E-07,0.152122E-04,0.193702E-07,0.291126E-02,0.144878E-03,
24217 &0.239699E-07,-.309608E-07,0.233320E-07,0.239699E-07,0.123840E-04,
24218 &0.165481E-07,0.240962E-02,0.118102E-03,0.197695E-07,-.231453E-07,
24219 &0.192276E-07,0.197695E-07,0.100316E-04,0.139043E-07,0.199075E-02,
24220 &0.961132E-04,0.161186E-07,-.164194E-07,0.156628E-07,0.161186E-07,
24221 &0.808648E-05,0.114903E-07,0.164168E-02,0.780880E-04,0.129826E-07,
24222 &-.107955E-07,0.126029E-07,0.129826E-07,0.648861E-05,0.933575E-08,
24223 &0.135135E-02,0.633381E-04,0.103192E-07,-.622051E-08,0.100055E-07,
24224 &0.103192E-07,0.519042E-05,0.744979E-08,0.111036E-02,0.512898E-04,
24225 &0.808255E-08,-.260101E-08,0.782557E-08,0.808255E-08,0.414192E-05,
24226 &0.582811E-08,0.910718E-03,0.414657E-04,0.622640E-08,0.177583E-09,
24227 &0.601750E-08,0.622640E-08,0.329729E-05,0.445766E-08,0.745657E-03/
24228 DATA (DL(K),K= 3826, 3910) /
24229 &0.334694E-04,0.470431E-08,0.223586E-08,0.453577E-08,0.470431E-08,
24230 &0.261981E-05,0.331859E-08,0.000000E+00,0.000000E+00,0.000000E+00,
24231 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24232 &0.519165E-02,0.154752E-03,0.135983E-08,0.135983E-08,0.135983E-08,
24233 &0.135983E-08,0.445189E-06,0.165858E-19,0.420352E-02,0.123002E-03,
24234 &-.202651E-07,0.730203E-07,-.200511E-07,-.202651E-07,0.358557E-05,
24235 &-.213089E-07,0.340143E-02,0.977718E-04,-.356451E-07,0.114908E-06,
24236 &-.353066E-07,-.356451E-07,0.384652E-05,-.364475E-07,0.274771E-02,
24237 &0.776124E-04,-.435588E-07,0.139200E-06,-.431556E-07,-.435588E-07,
24238 &0.404834E-05,-.441752E-07,0.221524E-02,0.614950E-04,-.471629E-07,
24239 &0.150069E-06,-.467352E-07,-.471629E-07,0.391615E-05,-.476355E-07,
24240 &0.178268E-02,0.486476E-04,-.477545E-07,0.151420E-06,-.473296E-07,
24241 &-.477545E-07,0.334100E-05,-.481163E-07,0.143185E-02,0.384202E-04,
24242 &-.462359E-07,0.146515E-06,-.458316E-07,-.462359E-07,0.275426E-05,
24243 &-.465126E-07,0.114781E-02,0.302894E-04,-.434031E-07,0.137587E-06,
24244 &-.430295E-07,-.434031E-07,0.226010E-05,-.436143E-07,0.918288E-03,
24245 &0.238367E-04,-.398089E-07,0.126321E-06,-.394715E-07,-.398089E-07/
24246 DATA (DL(K),K= 3911, 3995) /
24247 &0.180947E-05,-.399700E-07,0.733193E-03,0.187249E-04,-.358525E-07,
24248 &0.113940E-06,-.355529E-07,-.358525E-07,0.142045E-05,-.359751E-07,
24249 &0.584227E-03,0.146823E-04,-.318183E-07,0.101291E-06,-.315563E-07,
24250 &-.318183E-07,0.110919E-05,-.319115E-07,0.464586E-03,0.114914E-04,
24251 &-.278936E-07,0.889550E-07,-.276671E-07,-.278936E-07,0.860964E-06,
24252 &-.279643E-07,0.368700E-03,0.897731E-05,-.241972E-07,0.773096E-07,
24253 &-.240033E-07,-.241972E-07,0.662825E-06,-.242508E-07,0.292013E-03,
24254 &0.700034E-05,-.208001E-07,0.665779E-07,-.206356E-07,-.208001E-07,
24255 &0.508061E-06,-.208406E-07,0.230814E-03,0.544870E-05,-.177366E-07,
24256 &0.568734E-07,-.175982E-07,-.177366E-07,0.388493E-06,-.177672E-07,
24257 &0.182078E-03,0.423324E-05,-.150157E-07,0.482316E-07,-.149000E-07,
24258 &-.150157E-07,0.296111E-06,-.150387E-07,0.143349E-03,0.328297E-05,
24259 &-.126295E-07,0.406343E-07,-.125335E-07,-.126295E-07,0.225104E-06,
24260 &-.126468E-07,0.112639E-03,0.254145E-05,-.105595E-07,0.340280E-07,
24261 &-.104803E-07,-.105595E-07,0.170871E-06,-.105726E-07,0.883377E-04,
24262 &0.196395E-05,-.878062E-08,0.283380E-07,-.871555E-08,-.878062E-08,
24263 &0.129517E-06,-.879039E-08,0.000000E+00,0.000000E+00,0.000000E+00/
24264 DATA (DL(K),K= 3996, 4000) /
24265 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24268 IF (X.GT.0.9985) RETURN
24269 IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
24275 F1(L) = GF(I,IS,KL)
24276 F2(L) = GF(I,IS1,KL)
24278 A1 = DT_CKMTFF(X,F1)
24279 A2 = DT_CKMTFF(X,F2)
24284 ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
24290 *$ CREATE DT_CKMTFF.FOR
24292 FUNCTION DT_CKMTFF(X,FVL)
24293 C**********************************************************************
24295 C LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
24296 C FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
24297 C NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
24300 C**********************************************************************
24303 DIMENSION FVL(25),XGRID(25)
24304 DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
24305 *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
24309 IF(X.LT.XGRID(I)) GO TO 2
24314 ELSE IF(I.GT.23) THEN
24320 BXI=LOG(1.-XGRID(I))
24322 BXJ=LOG(1.-XGRID(J))
24324 BXK=LOG(1.-XGRID(K))
24325 FI=LOG(ABS(FVL(I)) +1.E-15)
24326 FJ=LOG(ABS(FVL(J)) +1.E-16)
24327 FK=LOG(ABS(FVL(K)) +1.E-17)
24328 DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
24329 ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
24331 ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
24332 BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
24333 IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
24335 C IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
24336 C WRITE(6,2001) X,FVL
24337 C 2001 FORMAT(8E12.4)
24338 C WRITE(6,2001) ALPHA,BETA,ALOGA,DET
24340 DT_CKMTFF=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
24344 *$ CREATE DT_FLUINI.FOR
24347 *===fluini=============================================================*
24349 SUBROUTINE DT_FLUINI
24351 ************************************************************************
24352 * Initialisation of the nucleon-nucleon cross section fluctuation *
24353 * treatment. The original version by J. Ranft. *
24354 * This version dated 21.04.95 is revised by S. Roesler. *
24355 ************************************************************************
24357 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24360 PARAMETER ( LINP = 10 ,
24364 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
24366 PARAMETER ( A = 0.1D0,
24372 * n-n cross section fluctuations
24373 PARAMETER (NBINS = 1000)
24374 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
24375 DIMENSION FLUSI(NBINS),FLUIX(NBINS)
24378 1000 FORMAT(/,1X,'FLUINI: hadronic cross section fluctuations ',
24387 FLUS = ((X-B)/(OM*B))**N
24388 IF (FLUS.LE.20.0D0) THEN
24389 FLUSI(I) = (X/B)*EXP(-FLUS)/(X/B+A)
24393 FLUSU = FLUSU+FLUSI(I)
24396 FLUSUU = FLUSUU+FLUSI(I)/FLUSU
24401 C1001 FORMAT(1X,'FLUCTUATIONS')
24402 C CALL PLOT(FLUIX,FLUSI,1000,1,1000,0.0D0,0.06D0,0.0D0,0.01D0)
24405 AF = DBLE(I)*0.001D0
24407 IF (AF.LE.FLUSI(J)) THEN
24408 FLUIXX(I) = FLUIX(J)
24414 FLUIXX(1) = FLUIX(1)
24415 FLUIXX(NBINS) = FLUIX(NBINS)
24420 *$ CREATE DT_SIGTBL.FOR
24423 *===sigtab=============================================================*
24425 SUBROUTINE DT_SIGTBL(JP,JT,PTOT,SIGE,MODE)
24427 ************************************************************************
24428 * This version dated 18.11.95 is written by S. Roesler *
24429 ************************************************************************
24431 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24434 PARAMETER ( LINP = 10 ,
24438 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24439 & OHALF=0.5D0,ONE=1.0D0)
24440 PARAMETER (PLO=0.01D0,PHI=20.0D0,NBINS=150)
24444 * particle properties (BAMJET index convention)
24446 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24447 & IICH(210),IIBAR(210),K1(210),K2(210)
24449 DIMENSION SIGEP(5,NBINS+1),SIGEN(5,NBINS+1),IDSIG(23)
24450 DATA IDSIG / 1, 0, 0, 0, 0, 0, 0, 2, 0, 0,
24451 & 0, 0, 3, 4, 0, 0, 0, 0, 0, 0,
24453 DATA LINIT /.FALSE./
24455 * precalculation and tabulation of elastic cross sections
24456 IF (ABS(MODE).EQ.1) THEN
24458 & OPEN(LDAT,FILE='outdata0/sigtab.out',STATUS='UNKNOWN')
24459 PLABLX = LOG10(PLO)
24460 PLABHX = LOG10(PHI)
24461 DPLAB = (PLABHX-PLABLX)/DBLE(NBINS)
24463 PLAB = PLABLX+DBLE(I-1)*DPLAB
24468 C CALL DT_SIHNEL(IPROJ,1,PLAB,SIGEP(IDX,I))
24469 C CALL DT_SIHNEL(IPROJ,8,PLAB,SIGEN(IDX,I))
24471 CALL DT_XSHN(IPROJ,1,PLAB,DUMZER,SIGTOT,SIGEP(IDX,I))
24472 CALL DT_XSHN(IPROJ,8,PLAB,DUMZER,SIGTOT,SIGEN(IDX,I))
24475 IF (MODE.EQ.1) THEN
24476 WRITE(LDAT,1000) PLAB,(SIGEP(IDX,I),IDX=1,5),
24477 & (SIGEN(IDX,I),IDX=1,5)
24478 1000 FORMAT(F5.1,10F7.2)
24481 IF (MODE.EQ.1) CLOSE(LDAT)
24485 IF (LINIT.AND.(JP.LE.23).AND.(PTOT.GE.PLO)
24486 & .AND.(PTOT.LE.PHI) ) THEN
24488 IF ( (IDX.GT.0).AND.((JT.EQ.1).OR.(JT.EQ.8)) ) THEN
24489 PLABX = LOG10(PTOT)
24490 IF (PLABX.LE.PLABLX) THEN
24493 ELSEIF (PLABX.GE.PLABHX) THEN
24497 I1 = INT((PLABX-PLABLX)/DPLAB)+1
24500 PLAB1X = PLABLX+DBLE(I1-1)*DPLAB
24501 PLAB2X = PLABLX+DBLE(I2-1)*DPLAB
24502 PBIN = PLAB2X-PLAB1X
24503 IF (PBIN.GT.TINY10) THEN
24504 RATX = (PLABX-PLAB1X)/(PLAB2X-PLAB1X)
24509 SIG1 = SIGEP(IDX,I1)
24510 SIG2 = SIGEP(IDX,I2)
24512 SIG1 = SIGEN(IDX,I1)
24513 SIG2 = SIGEN(IDX,I2)
24515 SIGE = SIG1+RATX*(SIG2-SIG1)
24523 *$ CREATE DT_XSTABL.FOR
24526 *===xstabl=============================================================*
24528 SUBROUTINE DT_XSTABL(WHAT,IXSQEL,IRATIO)
24530 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24533 PARAMETER ( LINP = 10 ,
24537 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24538 & OHALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
24539 LOGICAL LLAB,LELOG,LQLOG
24541 * particle properties (BAMJET index convention)
24543 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24544 & IICH(210),IIBAR(210),K1(210),K2(210)
24546 * properties of interacting particles
24547 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
24549 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
24551 * Glauber formalism: cross sections
24552 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
24553 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
24554 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
24555 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
24556 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
24557 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
24558 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
24559 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
24560 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
24561 & BSLOPE,NEBINI,NQBINI
24563 * emulsion treatment
24564 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
24569 LLAB = (WHAT(1).GT.ZERO).OR.(WHAT(2).GT.ZERO)
24572 IF (ELO.GT.EHI) ELO = EHI
24573 LELOG = WHAT(3).LT.ZERO
24574 NEBINS = MAX(INT(ABS(WHAT(3))),1)
24575 DEBINS = (EHI-ELO)/DBLE(NEBINS)
24579 ADEBIN = (AEHI-AELO)/DBLE(NEBINS)
24583 IF (Q2LO.GT.Q2HI) Q2LO = Q2HI
24584 LQLOG = WHAT(6).LT.ZERO
24585 NQBINS = MAX(INT(ABS(WHAT(6))),1)
24586 DQBINS = (Q2HI-Q2LO)/DBLE(NQBINS)
24588 AQ2LO = LOG10(Q2LO)
24589 AQ2HI = LOG10(Q2HI)
24590 ADQBIN = (AQ2HI-AQ2LO)/DBLE(NQBINS)
24593 IF ( ELO.EQ. EHI) NEBINS = 0
24594 IF (Q2LO.EQ.Q2HI) NQBINS = 0
24596 WRITE(LOUT,1000) ELO,EHI,LLAB,IXSQEL,Q2LO,Q2HI,IJPROJ,IP,IT
24597 1000 FORMAT(/,1X,'XSTABL: E_lo =',E10.3,' GeV E_hi =',E10.3,
24598 & ' GeV Lab = ',L1,' qel: ',I2,/,10X,'Q2_lo =',F10.5,
24599 & ' GeV^2 Q2_hi =',F10.5,' GeV^2',/,10X,'id_p = ',I2,
24600 & ' A_p = ',I3,' A_t = ',I3,/)
24602 C IF (IJPROJ.NE.7) THEN
24603 WRITE(LOUT,'(1X,A,/)')'(E,STOT,SELA,SQEP,SQET,SQE2,SINE,SPROD)'
24604 * normalize fractions of emulsion components
24605 IF (NCOMPO.GT.0) THEN
24608 SUMFRA = SUMFRA+EMUFRA(I)
24610 IF (SUMFRA.GT.ZERO) THEN
24612 EMUFRA(I) = EMUFRA(I)/SUMFRA
24617 C WRITE(LOUT,'(1X,A,/)') '(Q2,E,STOT,ETOT,SIN,EIN,STOT0)'
24621 E = 10**(AELO+DBLE(I-1)*ADEBIN)
24623 E = ELO+DBLE(I-1)*DEBINS
24627 Q2 = 10**(AQ2LO+DBLE(J-1)*ADQBIN)
24629 Q2 = Q2LO+DBLE(J-1)*DQBINS
24631 c IF (IJPROJ.NE.7) THEN
24635 CALL DT_LTINI(IJPROJ,1,E,PPN0,ECM,0)
24641 IF (IJPROJ.EQ.7) Q2I = Q2
24642 IF (NCOMPO.GT.0) THEN
24645 CALL DT_XSGLAU(IP,IIT,IJPROJ,XI,Q2I,ECM,1,1,-IC)
24648 CALL DT_XSGLAU(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,-1)
24649 C CALL AMPLIT(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,1)
24651 IF (NCOMPO.GT.0) THEN
24670 XTOT = XTOT+EMUFRA(IC)*XSTOT(1,1,IC)
24671 ETOT = ETOT+EMUFRA(IC)*XETOT(1,1,IC)**2
24672 XELA = XELA+EMUFRA(IC)*XSELA(1,1,IC)
24673 EELA = EELA+EMUFRA(IC)*XEELA(1,1,IC)**2
24674 XQEP = XQEP+EMUFRA(IC)*XSQEP(1,1,IC)
24675 EQEP = EQEP+EMUFRA(IC)*XEQEP(1,1,IC)**2
24676 XQET = XQET+EMUFRA(IC)*XSQET(1,1,IC)
24677 EQET = EQET+EMUFRA(IC)*XEQET(1,1,IC)**2
24678 XQE2 = XQE2+EMUFRA(IC)*XSQE2(1,1,IC)
24679 EQE2 = EQE2+EMUFRA(IC)*XEQE2(1,1,IC)**2
24680 XPRO = XPRO+EMUFRA(IC)*XSPRO(1,1,IC)
24681 EPRO = EPRO+EMUFRA(IC)*XEPRO(1,1,IC)**2
24682 XDEL = XDEL+EMUFRA(IC)*XSDEL(1,1,IC)
24683 EDEL = EDEL+EMUFRA(IC)*XEDEL(1,1,IC)**2
24684 XDQE = XDQE+EMUFRA(IC)*XSDQE(1,1,IC)
24685 EDQE = EDQE+EMUFRA(IC)*XEDQE(1,1,IC)**2
24686 YPRO = XSTOT(1,1,IC)-XSELA(1,1,IC)
24687 & -XSQEP(1,1,IC)-XSQET(1,1,IC)
24689 XPRO1= XPRO1+EMUFRA(IC)*YPRO
24699 WRITE(LOUT,'(8E9.3)')
24700 & E,XTOT,XELA,XQEP,XQET,XQE2,XPRO,XPRO1
24701 C WRITE(LOUT,'(4E9.3)')
24702 C & E,XDEL,XDQE,XDEL+XDQE
24704 WRITE(LOUT,'(11E10.3)')
24706 & XSTOT(1,1,1),XSELA(1,1,1),XSQEP(1,1,1),XSQET(1,1,1),
24707 & XSQE2(1,1,1),XSPRO(1,1,1),
24708 & XSTOT(1,1,1)-XSELA(1,1,1)-XSQEP(1,1,1)-XSQET(1,1,1)
24709 & -XSQE2(1,1,1),XSDEL(1,1,1),XSDQE(1,1,1),
24710 & XSDEL(1,1,1)+XSDQE(1,1,1)
24711 C WRITE(LOUT,'(4E9.3)') E,XSDEL(1,1,1),XSDQE(1,1,1),
24712 C & XSDEL(1,1,1)+XSDQE(1,1,1)
24716 c IF (IT.GT.1) THEN
24717 c IF (IXSQEL.EQ.0) THEN
24718 cC CALL DT_SIGGA(IT, Q2, E,ZERO,ZERO,
24719 cC CALL DT_SIGGA(IT, E,Q2,ZERO,ZERO,
24720 c CALL DT_SIGGA(IT,ZERO,Q2,ZERO,E,
24721 c & STOT,ETOT,SIN,EIN,STOT0)
24722 c IF (IRATIO.EQ.1) THEN
24723 c CALL DT_SIGGP( Q2, E,ZERO,ZERO,STGP,SIGP,SDGP)
24724 cC CALL DT_SIGGP( E,Q2,ZERO,ZERO,STGP,SIGP,SDGP)
24725 cC CALL DT_SIGGP(ZERO,Q2,ZERO,E,STGP,SIGP,SDGP)
24726 c*!! save cross sections
24731 c STOT = STOT/(DBLE(IT)*STGP)
24732 c SIN = SIN/(DBLE(IT)*SIGP)
24739 c & ' XSTABL: qel. xs. not implemented for nuclei'
24746 c IF (IXSQEL.EQ.0) THEN
24747 c CALL DT_SIGGP(ZERO,Q2,ZERO,E,STOT,SIN,SDIR)
24750 c CALL DT_SIGVEL(ZERO,Q2,ZERO,E,IXSQEL,STOT,SIN,STOT0)
24754 c IF (IT.GT.1) THEN
24755 c IF (IXSQEL.EQ.0) THEN
24756 c CALL DT_SIGGA(IT,ZERO,Q2,E,ZERO,
24757 c & STOT,ETOT,SIN,EIN,STOT0)
24758 c IF (IRATIO.EQ.1) THEN
24759 c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STGP,SIGP,SDGP)
24760 c*!! save cross sections
24765 c STOT = STOT/(DBLE(IT)*STGP)
24766 c SIN = SIN/(DBLE(IT)*SIGP)
24773 c & ' XSTABL: qel. xs. not implemented for nuclei'
24780 c IF (IXSQEL.EQ.0) THEN
24781 c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STOT,SIN,SDIR)
24784 c CALL DT_SIGVEL(ZERO,Q2,E,ZERO,IXSQEL,STOT,SIN,STOT0)
24788 cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,STOTA,ETOTA,STOTP,ZERO
24789 cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,SDIR
24790 cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,STOT0
24791 c WRITE(LOUT,'(1X,6E10.3)')Q2,E,STOT,ETOT,SIN,EIN
24799 *$ CREATE DT_TESTXS.FOR
24802 *===testxs=============================================================*
24804 SUBROUTINE DT_TESTXS
24806 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24809 DIMENSION XSTOT(26,2),XSELA(26,2)
24811 OPEN(10,FILE='testxs_ptot.out',STATUS='UNKNOWN')
24812 OPEN(11,FILE='testxs_pela.out',STATUS='UNKNOWN')
24813 OPEN(12,FILE='testxs_ntot.out',STATUS='UNKNOWN')
24814 OPEN(13,FILE='testxs_nela.out',STATUS='UNKNOWN')
24819 APLABL = LOG10(PLABL)
24820 APLABH = LOG10(PLABH)
24821 ADPLAB = (APLABH-APLABL)/DBLE(NBINS)
24823 ADP = APLABL+DBLE(I-1)*ADPLAB
24826 CALL DT_XSHN(J,1,P,DUMECM,XSTOT(J,1),XSELA(J,1))
24827 CALL DT_XSHN(J,8,P,DUMECM,XSTOT(J,2),XSELA(J,2))
24829 WRITE(10,1000) P,(XSTOT(K,1),K=1,26)
24830 WRITE(11,1000) P,(XSELA(K,1),K=1,26)
24831 WRITE(12,1000) P,(XSTOT(K,2),K=1,26)
24832 WRITE(13,1000) P,(XSELA(K,2),K=1,26)
24834 1000 FORMAT(F8.3,26F9.3)
24838 ************************************************************************
24840 * DTUNUC 2.0: library routines *
24841 * processed by S. Roesler, 6.5.95 *
24843 ************************************************************************
24845 * 1) Handling of parton momenta
24846 * SUBROUTINE MASHEL
24847 * SUBROUTINE DFERMI
24849 * 2) Handling of parton flavors and particle indices
24850 * INTEGER FUNCTION IPDG2B
24851 * INTEGER FUNCTION IB2PDG
24852 * INTEGER FUNCTION IQUARK
24853 * INTEGER FUNCTION IBJQUA
24854 * INTEGER FUNCTION ICIHAD
24855 * INTEGER FUNCTION IPDGHA
24856 * INTEGER FUNCTION MCHAD
24857 * SUBROUTINE FLAHAD
24859 * 3) Energy-momentum and quantum number conservation check routines
24862 * SUBROUTINE EVTEMC
24863 * SUBROUTINE EVTFLC
24864 * SUBROUTINE EVTCHG
24866 * 4) Transformations
24868 * SUBROUTINE LTRANS
24870 * SUBROUTINE DALTRA
24871 * SUBROUTINE DTRAFO
24872 * SUBROUTINE STTRAN
24873 * SUBROUTINE MYTRAN
24874 * SUBROUTINE LT2LAO
24875 * SUBROUTINE LT2LAB
24877 * 5) Sampling from distributions
24878 * INTEGER FUNCTION NPOISS
24879 * DOUBLE PRECISION FUNCTION SAMPXB
24880 * DOUBLE PRECISION FUNCTION SAMPEX
24881 * DOUBLE PRECISION FUNCTION SAMSQX
24882 * DOUBLE PRECISION FUNCTION BETREJ
24883 * DOUBLE PRECISION FUNCTION DGAMRN
24884 * DOUBLE PRECISION FUNCTION DBETAR
24885 * SUBROUTINE RANNOR
24887 * SUBROUTINE DSFECF
24890 * 6) Special functions, algorithms and service routines
24891 * DOUBLE PRECISION FUNCTION YLAMB
24894 * SUBROUTINE DT_XTIME
24896 * 7) Random number generator package
24897 * DOUBLE PRECISION FUNCTION DT_RNDM
24898 * SUBROUTINE DT_RNDMST
24899 * SUBROUTINE DT_RNDMIN
24900 * SUBROUTINE DT_RNDMOU
24901 * SUBROUTINE DT_RNDMTE
24903 ************************************************************************
24905 * 1) Handling of parton momenta *
24907 ************************************************************************
24908 *$ CREATE DT_MASHEL.FOR
24911 *===mashel=============================================================*
24913 SUBROUTINE DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
24915 ************************************************************************
24917 * rescaling of momenta of two partons to put both *
24920 * input: PA1,PA2 input momentum vectors *
24921 * XM1,2 desired masses of particles afterwards *
24922 * P1,P2 changed momentum vectors *
24924 * The original version is written by R. Engel. *
24925 * This version dated 12.12.94 is modified by S. Roesler. *
24926 ************************************************************************
24928 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24931 PARAMETER ( LINP = 10 ,
24935 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
24937 DIMENSION PA1(4),PA2(4),P1(4),P2(4)
24941 * Lorentz transformation into system CMS
24946 XPTOT = SQRT(PX**2+PY**2+PZ**2)
24947 XMS = (EE-XPTOT)*(EE+XPTOT)
24948 IF(XMS.LT.(XM1+XM2)**2) THEN
24949 C WRITE(LOUT,'(3E12.4)')XMS,XM1,XM2
24957 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
24958 & PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
24961 C SID = SQRT((ONE-COD)*(ONE+COD))
24962 PPT = SQRT(P1(1)**2+P1(2)**2)
24966 IF(PTOT1*SID.GT.TINY10) THEN
24967 COF = P1(1)/(SID*PTOT1)
24968 SIF = P1(2)/(SID*PTOT1)
24969 ANORF = SQRT(COF*COF+SIF*SIF)
24973 * new CM momentum and energies (for masses XM1,XM2)
24974 XM12 = SIGN(XM1**2,XM1)
24975 XM22 = SIGN(XM2**2,XM2)
24977 PCMP = DT_YLAMB(SS,XM12,XM22)/(2.D0*XMS)
24978 EE1 = SQRT(XM12+PCMP**2)
24982 CALL DT_MYTRAN(MODE,ZERO,ZERO,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
24983 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
24984 & PTOT1,P1(1),P1(2),P1(3),P1(4))
24985 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
24986 & PTOT2,P2(1),P2(2),P2(3),P2(4))
24987 * check consistency
24989 IF (ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
24991 ELSEIF (ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
24993 ELSEIF (ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
24995 ELSEIF (ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
25000 IF (IDEV.NE.0) THEN
25001 WRITE(LOUT,'(/1X,A,I3)')
25002 & 'MASHEL: inconsistent transformation',IDEV
25003 WRITE(LOUT,'(1X,A)') 'MASHEL: input momenta/masses:'
25004 WRITE(LOUT,'(1X,5E12.5)') (PA1(K),K=1,4),XM1
25005 WRITE(LOUT,'(1X,5E12.5)') (PA2(K),K=1,4),XM2
25006 WRITE(LOUT,'(1X,A)') 'MASHEL: output momenta:'
25007 WRITE(LOUT,'(5X,4E12.5)') (P1(K),K=1,4)
25008 WRITE(LOUT,'(5X,4E12.5)') (P2(K),K=1,4)
25017 *$ CREATE DT_DFERMI.FOR
25020 *===dfermi=============================================================*
25022 SUBROUTINE DT_DFERMI(GPART)
25024 ************************************************************************
25025 * Find largest of three random numbers. *
25026 ************************************************************************
25028 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25034 G(I)=DT_RNDM(GPART)
25036 IF (G(3).LT.G(2)) GOTO 40
25037 IF (G(3).LT.G(1)) GOTO 30
25042 40 IF (G(2).LT.G(1)) GOTO 30
25048 ************************************************************************
25050 * 2) Handling of parton flavors and particle indices *
25052 ************************************************************************
25053 *$ CREATE IDT_IPDG2B.FOR
25056 *===ipdg2b=============================================================*
25058 INTEGER FUNCTION IDT_IPDG2B(ID,NN,MODE)
25060 ************************************************************************
25062 * conversion of quark numbering scheme *
25064 * input: PDG parton numbering *
25065 * for diquarks: NN number of the constituent quark *
25066 * (e.g. ID=2301,NN=1 -> ICONV2=1) *
25068 * output: BAMJET particle codes *
25069 * 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) *
25070 * 2 d 8 a-d -2 a-d *
25071 * 3 s 9 a-s -3 a-s *
25072 * 4 c 10 a-c -4 a-c *
25074 * This is a modified version of ICONV2 written by R. Engel. *
25075 * This version dated 13.12.94 is written by S. Roesler. *
25076 ************************************************************************
25078 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25081 PARAMETER ( LINP = 10 ,
25089 IF (IDA.GE.1000) KF = 4
25090 IDA = IDA/(10**(KF-NN))
25093 * exchange up and dn quarks
25096 ELSEIF (IDA.EQ.2) THEN
25101 IF (MODE.EQ.1) THEN
25112 *$ CREATE IDT_IB2PDG.FOR
25115 *===ib2pdg=============================================================*
25117 INTEGER FUNCTION IDT_IB2PDG(ID1,ID2,MODE)
25119 ************************************************************************
25121 * conversion of quark numbering scheme *
25123 * input: BAMJET particle codes *
25124 * 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) *
25125 * 2 d 8 a-d -2 a-d *
25126 * 3 s 9 a-s -3 a-s *
25127 * 4 c 10 a-c -4 a-c *
25129 * output: PDG parton numbering *
25131 * This version dated 13.12.94 is written by S. Roesler. *
25132 ************************************************************************
25134 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25137 PARAMETER ( LINP = 10 ,
25141 DIMENSION IHKKQ(-6:6),IHKKQQ(-3:3,-3:3)
25142 DATA IHKKQ/-6,-5,-4,-3,-1,-2,0,2,1,3,4,5,6/
25143 DATA IHKKQQ/-3303,-3103,-3203,0,0,0,0, -3103,-1103,-2103,0,0,0,0,
25144 &-3203,-2103,-2203,0,0,0,0, 0,0,0,0,0,0,0, 0,0,0,0,2203,2103,3203,
25145 &0,0,0,0,2103,1103,3103, 0,0,0,0,3203,3103,3303/
25149 IF (MODE.EQ.1) THEN
25150 IF (ID1.GT.6) IDA = -(ID1-6)
25151 IF (ID2.GT.6) IDB = -(ID2-6)
25154 IDT_IB2PDG = IHKKQ(IDA)
25156 IDT_IB2PDG = IHKKQQ(IDA,IDB)
25162 *$ CREATE IDT_IQUARK.FOR
25165 *===ipdgqu=============================================================*
25167 INTEGER FUNCTION IDT_IQUARK(K,IDBAMJ)
25169 ************************************************************************
25171 * quark contents according to PDG conventions *
25172 * (random selection in case of quark mixing) *
25174 * input: IDBAMJ BAMJET particle code *
25175 * K 1..3 quark number *
25177 * output: 1 d (anti --> neg.) *
25182 * This version written by R. Engel. *
25183 ************************************************************************
25185 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25188 IQ = IDT_IBJQUA(K,IDBAMJ)
25193 * exchange of up and down
25194 IF (ABS(IQ).EQ.1) THEN
25196 ELSEIF (ABS(IQ).EQ.2) THEN
25204 *$ CREATE IDT_IBJQUA.FOR
25207 *===ibamq==============================================================*
25209 INTEGER FUNCTION IDT_IBJQUA(K,IDBAMJ)
25211 ************************************************************************
25213 * quark contents according to BAMJET conventions *
25214 * (random selection in case of quark mixing) *
25216 * input: IDBAMJ BAMJET particle code *
25217 * K 1..3 quark number *
25219 * output: 1 u 7 u bar *
25224 * This version written by R. Engel. *
25225 ************************************************************************
25227 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25230 DIMENSION ITAB(3,210)
25231 DATA ((ITAB(I,K),I=1,3),K=1,30) /
25232 & 1, 1, 2, 7, 7, 8, 0, 0, 0,
25233 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25234 & 0, 0, 0, 1, 2, 2, 7, 8, 8,
25236 C & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25237 & 0, 0, 0, 0, 0, 0, 3, 8, 0,
25239 & 1, 8, 0, 2, 7, 0, 1, 9, 0,
25241 C & 3, 7, 0, 0, 0, 0, 0, 0, 0,
25242 & 3, 7, 0, 3, 1, 2, 9, 7, 8,
25244 C & 0, 0, 0, 2, 2, 3, 1, 1, 3,
25245 & 2, 9, 0, 2, 2, 3, 1, 1, 3,
25247 & 1, 2, 3, 201,202, 0, 2, 9, 0,
25248 & 3, 8, 0, 0, 0, 0, 0, 0, 0,
25249 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25250 DATA ((ITAB(I,K),I=1,3),K=31,60) /
25251 & 3, 9, 0, 1, 8, 0, 203,204, 0,
25252 & 2, 7, 0, 0, 0, 0, 1, 9, 0,
25253 & 2, 9, 0, 3, 7, 0, 3, 8, 0,
25254 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25255 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25256 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25257 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25258 & 0, 0, 0, 1, 1, 1, 1, 1, 2,
25259 & 1, 2, 2, 2, 2, 2, 0, 0, 0,
25260 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25261 DATA ((ITAB(I,K),I=1,3),K=61,90) /
25262 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25263 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25264 & 7, 7, 7, 7, 7, 8, 7, 8, 8,
25265 & 8, 8, 8, 0, 0, 0, 0, 0, 0,
25266 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25267 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25268 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25269 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25270 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25271 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25272 DATA ((ITAB(I,K),I=1,3),K=91,120) /
25273 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25274 & 0, 0, 0, 0, 0, 0, 3, 9, 0,
25275 & 1, 3, 3, 2, 3, 3, 7, 7, 9,
25276 & 7, 8, 9, 8, 8, 9, 7, 9, 9,
25277 & 8, 9, 9, 1, 1, 3, 1, 2, 3,
25278 & 2, 2, 3, 1, 3, 3, 2, 3, 3,
25279 & 3, 3, 3, 7, 7, 9, 7, 8, 9,
25280 & 8, 8, 9, 7, 9, 9, 8, 9, 9,
25281 & 9, 9, 9, 4, 7, 0, 4, 8, 0,
25282 & 2, 10, 0, 1, 10, 0, 4, 9, 0 /
25283 DATA ((ITAB(I,K),I=1,3),K=121,150) /
25284 & 3, 10, 0, 4, 10, 0, 4, 7, 0,
25285 & 4, 8, 0, 2, 10, 0, 1, 10, 0,
25286 & 4, 9, 0, 3, 10, 0, 4, 10, 0,
25287 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25288 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25289 & 0, 0, 0, 1, 2, 4, 1, 3, 4,
25290 & 2, 3, 4, 1, 1, 4, 0, 0, 0,
25291 & 2, 2, 4, 0, 0, 0, 0, 0, 0,
25292 & 3, 3, 4, 1, 4, 4, 2, 4, 4,
25293 & 3, 4, 4, 7, 8, 10, 7, 9, 10 /
25294 DATA ((ITAB(I,K),I=1,3),K=151,180) /
25295 & 8, 9, 10, 7, 7, 10, 0, 0, 0,
25296 & 8, 8, 10, 0, 0, 0, 0, 0, 0,
25297 & 9, 9, 10, 7, 10, 10, 8, 10, 10,
25298 & 9, 10, 10, 1, 1, 4, 1, 2, 4,
25299 & 2, 2, 4, 1, 3, 4, 2, 3, 4,
25300 & 3, 3, 4, 1, 4, 4, 2, 4, 4,
25301 & 3, 4, 4, 4, 4, 4, 7, 7, 10,
25302 & 7, 8, 10, 8, 8, 10, 7, 9, 10,
25303 & 8, 9, 10, 9, 9, 10, 7, 10, 10,
25304 & 8, 10, 10, 9, 10, 10, 10, 10, 10 /
25305 DATA ((ITAB(I,K),I=1,3),K=181,210) /
25306 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25307 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25308 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25309 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25310 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25311 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25312 & 0, 0, 0, 0, 0, 0, 1, 7, 0,
25313 & 2, 8, 0, 1, 7, 0, 2, 8, 0,
25314 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25315 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25319 IF (ITAB(1,IDBAMJ).LE.200) THEN
25320 ID = ITAB(K,IDBAMJ)
25322 IF(IDOLD.NE.IDBAMJ) THEN
25323 IT = AINT((ITAB(2,IDBAMJ)-ITAB(1,IDBAMJ)+0.999999D0)*
25324 & DT_RNDM(ONE)+ITAB(1,IDBAMJ))
25336 *$ CREATE IDT_ICIHAD.FOR
25339 *===icihad=============================================================*
25341 INTEGER FUNCTION IDT_ICIHAD(MCIND)
25343 ************************************************************************
25344 * Conversion of particle index PDG proposal --> BAMJET-index scheme *
25345 * This is a completely new version dated 25.10.95. *
25346 * Renamed to be not in conflict with the modified PHOJET-version *
25347 ************************************************************************
25349 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25352 * hadron index conversion (BAMJET <--> PDG)
25353 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25354 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25359 IF ((KPDG.EQ.0).OR.(KPDG.GT.70000)) RETURN
25360 IF (MCIND.LT.0) THEN
25365 IF (KPDG.GE.10000) THEN
25367 IDT_ICIHAD = IBAM5(JSIGN,I)
25368 IF (IPDG5(JSIGN,I).EQ.MCIND) GOTO 5
25371 ELSEIF (KPDG.GE.1000) THEN
25373 IDT_ICIHAD = IBAM4(JSIGN,I)
25374 IF (IPDG4(JSIGN,I).EQ.MCIND) GOTO 5
25377 ELSEIF (KPDG.GE.100) THEN
25379 IDT_ICIHAD = IBAM3(JSIGN,I)
25380 IF (IPDG3(JSIGN,I).EQ.MCIND) GOTO 5
25383 ELSEIF (KPDG.GE.10) THEN
25385 IDT_ICIHAD = IBAM2(JSIGN,I)
25386 IF (IPDG2(JSIGN,I).EQ.MCIND) GOTO 5
25395 *$ CREATE IDT_IPDGHA.FOR
25398 *===ipdgha=============================================================*
25400 INTEGER FUNCTION IDT_IPDGHA(MCIND)
25402 ************************************************************************
25403 * Conversion of particle index BAMJET-index scheme --> PDG proposal *
25404 * Adopted from the original by S. Roesler. This version dated 12.5.95 *
25405 * Renamed to be not in conflict with the modified PHOJET-version *
25406 ************************************************************************
25408 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25411 * hadron index conversion (BAMJET <--> PDG)
25412 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25413 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25416 IDT_IPDGHA = IAMCIN(MCIND)
25421 *$ CREATE DT_FLAHAD.FOR
25424 *===flahad=============================================================*
25426 SUBROUTINE DT_FLAHAD(ID,IF1,IF2,IF3)
25428 ************************************************************************
25429 * sampling of FLAvor composition for HADrons/photons *
25430 * ID BAMJET-id of hadron *
25431 * IF1,2,3 flavor content *
25432 * (u,d,s: 1,2,3; au,ad,as: -1,-1,-3) *
25433 * Note: - u,d numbering as in BAMJET *
25434 * - ID .le. 30 !! *
25435 * This version dated 12.03.96 is written by S. Roesler *
25436 ************************************************************************
25438 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25441 * auxiliary common for reggeon exchange (DTUNUC 1.x)
25442 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
25443 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
25444 & IQTCHR(-6:6),MQUARK(3,39)
25446 DIMENSION JSEL(3,6)
25447 DATA JSEL/ 1,2,3, 2,3,1, 3,1,2, 1,3,2, 2,1,3, 3,2,1/
25451 * photon (charge dependent flavour sampling)
25452 K = INT(DT_RNDM(ONE)*6.D0+1.D0)
25456 ELSE IF(K.EQ.5) THEN
25463 IF(DT_RNDM(ONE).LT.0.5D0) THEN
25471 IX = INT(1.0D0+5.99999D0*DT_RNDM(ONE))
25472 IF1 = MQUARK(JSEL(1,IX),ID)
25473 IF2 = MQUARK(JSEL(2,IX),ID)
25474 IF3 = MQUARK(JSEL(3,IX),ID)
25475 IF ((IF1.EQ.0).AND.(IF3.NE.0)) THEN
25478 ELSEIF ((IF2.EQ.0).AND.(IF3.NE.0)) THEN
25487 *$ CREATE IDT_MCHAD.FOR
25490 *===mchad==============================================================*
25492 INTEGER FUNCTION IDT_MCHAD(ITDTU)
25494 ************************************************************************
25495 * Conversion of particle index BAMJET-index scheme --> HADRIN index s. *
25496 * Adopted from the original by S. Roesler. This version dated 6.5.95 *
25498 * Last change 28.12.2006 by S. Roesler. *
25499 ************************************************************************
25501 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25504 DIMENSION ITRANS(210)
25505 DATA ITRANS / 1, 2, -1, -1, -1, -1, -1, 8, 9, -1, -1, 24, 13, 14,
25506 &15, 16, 8, 9, 25, 8, 1, 8, 23, 24, 25, -1, -1, -1, -1, -1, 23, 13,
25507 &23, 14, 23, 15, 24, 16, 25, 15, 24, 16, 25, 15, 24, 16, 25, 1, 8,
25508 &8, 8, 1, 1, 1, 8, 8, 1, 1, 8, 8, 1, 8, 1, 8, 1, 8, 2, 2, 9, 9, 2,
25509 &2, 9, 9, 2, 9, 1, 13, 23, 14, 1, 1, 8, 8, 1, 1, 23, 14, 1, 8, 1,
25510 &8, 1, 8, 23, 23, 8, 8, 2, 9, 9, 9, 9, 1, 8, 8, 8, 8, 8, 2, 9, 9,
25511 &9, 9, 9, 85*- 1,7*-1,1,8,-1/
25513 IF ( ITDTU .GT. 0 ) THEN
25514 IDT_MCHAD = ITRANS(ITDTU)
25522 ************************************************************************
25524 * 3) Energy-momentum and quantum number conservation check routines *
25526 ************************************************************************
25527 *$ CREATE DT_EMC1.FOR
25530 *===emc1===============================================================*
25532 SUBROUTINE DT_EMC1(PP1,PP2,PT1,PT2,MODE,IPOS,IREJ)
25534 ************************************************************************
25535 * This version dated 15.12.94 is written by S. Roesler *
25536 ************************************************************************
25538 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25541 PARAMETER ( LINP = 10 ,
25545 PARAMETER (TINY10=1.0D-10)
25547 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
25551 IF ((MODE.EQ.0).OR.(ABS(MODE).GT.3))
25552 & WRITE(LOUT,'(1X,A,I6)')'EMC1: not supported MODE ',MODE
25554 IF ((MODE.GT.0).AND.(MODE.LT.3)) THEN
25555 IF (MODE.EQ.1) THEN
25556 CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),1,IDUM,IDUM)
25557 ELSEIF (MODE.EQ.2) THEN
25558 CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),2,IDUM,IDUM)
25560 CALL DT_EVTEMC(PP2(1),PP2(2),PP2(3),PP2(4),2,IDUM,IDUM)
25561 CALL DT_EVTEMC(PT1(1),PT1(2),PT1(3),PT1(4),2,IDUM,IDUM)
25562 CALL DT_EVTEMC(PT2(1),PT2(2),PT2(3),PT2(4),2,IDUM,IDUM)
25563 ELSEIF (MODE.LT.0) THEN
25564 IF (MODE.EQ.-1) THEN
25565 CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),1,IDUM,IDUM)
25566 ELSEIF (MODE.EQ.-2) THEN
25567 CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),2,IDUM,IDUM)
25569 CALL DT_EVTEMC(-PP2(1),-PP2(2),-PP2(3),-PP2(4),2,IDUM,IDUM)
25570 CALL DT_EVTEMC(-PT1(1),-PT1(2),-PT1(3),-PT1(4),2,IDUM,IDUM)
25571 CALL DT_EVTEMC(-PT2(1),-PT2(2),-PT2(3),-PT2(4),2,IDUM,IDUM)
25574 IF (ABS(MODE).EQ.3) THEN
25575 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,IPOS,IREJ1)
25576 IF (IREJ1.NE.0) GOTO 9999
25585 *$ CREATE DT_EMC2.FOR
25588 *===emc2===============================================================*
25590 SUBROUTINE DT_EMC2(IP1,IP2,IP3,IP4,IP5,MP,IN1,IN2,IN3,IN4,IN5,MN,
25593 ************************************************************************
25594 * MODE = 1 energy-momentum cons. check *
25595 * = 2 flavor-cons. check *
25596 * = 3 energy-momentum & flavor cons. check *
25597 * = 4 energy-momentum & charge cons. check *
25598 * = 5 energy-momentum & flavor & charge cons. check *
25599 * This version dated 16.01.95 is written by S. Roesler *
25600 ************************************************************************
25602 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25605 PARAMETER ( LINP = 10 ,
25609 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
25613 PARAMETER (NMXHKK=200000)
25615 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25616 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25617 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25619 * extended event history
25620 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
25621 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
25629 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25630 & CALL DT_EVTEMC(ZERO,ZERO,ZERO,ZERO,1,IDUM,IDUM)
25631 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25632 & CALL DT_EVTFLC(0,IDUM,1,IDUM,IDUM)
25633 IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,1,IDUM,IDUM)
25635 IF ((ISTHKK(I).EQ.IP1).OR.(ISTHKK(I).EQ.IP2).OR.
25636 & (ISTHKK(I).EQ.IP3).OR.(ISTHKK(I).EQ.IP4).OR.
25637 & (ISTHKK(I).EQ.IP5)) THEN
25638 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25640 & CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
25642 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25643 & CALL DT_EVTFLC(IDHKK(I),MP,2,IDUM,IDUM)
25644 IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25645 & CALL DT_EVTCHG(IDHKK(I),2,IDUM,IDUM)
25647 IF ((ISTHKK(I).EQ.IN1).OR.(ISTHKK(I).EQ.IN2).OR.
25648 & (ISTHKK(I).EQ.IN3).OR.(ISTHKK(I).EQ.IN4).OR.
25649 & (ISTHKK(I).EQ.IN5)) THEN
25650 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25652 & CALL DT_EVTEMC(-PHKK(1,I),-PHKK(2,I),-PHKK(3,I),-PHKK(4,I),
25654 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25655 & CALL DT_EVTFLC(IDHKK(I),MN,-2,IDUM,IDUM)
25656 IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25657 & CALL DT_EVTCHG(IDHKK(I),-2,IDUM,IDUM)
25660 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25661 & CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,IPOS,IREJ1)
25662 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25663 & CALL DT_EVTFLC(0,IDUM,3,IPOS,IREJ2)
25664 IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,3,IPOS,IREJ3)
25665 IF ((IREJ1.NE.0).OR.(IREJ2.NE.0).OR.(IREJ3.NE.0)) GOTO 9999
25674 *$ CREATE DT_EVTEMC.FOR
25677 *===evtemc=============================================================*
25679 SUBROUTINE DT_EVTEMC(PXIO,PYIO,PZIO,EIO,IMODE,IPOS,IREJ)
25681 ************************************************************************
25682 * This version dated 13.12.94 is written by S. Roesler *
25683 ************************************************************************
25685 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25688 PARAMETER ( LINP = 10 ,
25692 PARAMETER (TINY1=1.0D-1,TINY2=1.0D-2,TINY4=1.0D-4,TINY10=1.0D-10,
25697 PARAMETER (NMXHKK=200000)
25699 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25700 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25701 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25703 * flags for input different options
25704 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
25705 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
25706 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
25712 IF (MODE.EQ.4) THEN
25715 ELSEIF (MODE.EQ.5) THEN
25718 ELSEIF (MODE.EQ.-1) THEN
25723 IF (ABS(MODE).EQ.3) THEN
25728 IF ((IFRAG(1).EQ.2).AND.(CHKLEV.LT.TINY4)) CHKLEV = TINY4
25729 IF ((ABS(PXDEV).GT.CHKLEV).OR.(ABS(PYDEV).GT.CHKLEV).OR.
25730 & (ABS(PZDEV).GT.CHKLEV).OR.(ABS(EDEV).GT.CHKLEV)) THEN
25731 IF (IOULEV(2).GT.0) WRITE(LOUT,'(1X,A,I4,A,I8,A,/,4G10.3)')
25732 & 'EVTEMC: energy-momentum cons. failure at pos. ',IPOS,
25733 & ' event ',NEVHKK,
25734 & ' ! ',PXDEV,PYDEV,PZDEV,EDEV
25748 IF (MODE.EQ.1) THEN
25767 *$ CREATE DT_EVTFLC.FOR
25770 *===evtflc=============================================================*
25772 SUBROUTINE DT_EVTFLC(ID,ID1,MODE,IPOS,IREJ)
25774 ************************************************************************
25775 * Flavor conservation check. *
25776 * ID identity of particle *
25777 * ID1 = 1 ID for q,aq,qq,aqaq in PDG-numbering scheme *
25778 * = 2 ID for particle/resonance in BAMJET numbering scheme *
25779 * = 3 ID for particle/resonance in PDG numbering scheme *
25780 * MODE = 1 initialization and add ID *
25781 * =-1 initialization and subtract ID *
25783 * =-2 subtract ID *
25784 * = 3 check flavor cons. *
25785 * IPOS flag to give position of call of EVTFLC to output *
25786 * unit in case of violation *
25787 * This version dated 10.01.95 is written by S. Roesler *
25788 ************************************************************************
25790 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25793 PARAMETER ( LINP = 10 ,
25797 PARAMETER (TINY10=1.0D-10)
25801 IF (MODE.EQ.3) THEN
25803 WRITE(LOUT,'(1X,A,I3,A,I3)')
25804 & 'EVTFLC: flavor-conservation failure at pos. ',IPOS,
25813 IF (MODE.EQ.1) IFL = 0
25814 IF (ID.EQ.0) RETURN
25819 IF ((IDD.GE.100).AND.(IDD.LT.1000)) NQ = 2
25820 IF (IDD.GE.1000) NQ = 3
25822 IFBAM = IDT_IPDG2B(ID,I,2)
25823 IF (ABS(IFBAM).EQ.1) THEN
25824 IFBAM = SIGN(2,IFBAM)
25825 ELSEIF (ABS(IFBAM).EQ.2) THEN
25826 IFBAM = SIGN(1,IFBAM)
25828 IF (MODE.GT.0) THEN
25838 IF (ID1.EQ.3) IDD = IDT_ICIHAD(ID)
25839 IF ((ID1.EQ.2).OR.(ID1.EQ.3)) THEN
25841 IF (MODE.GT.0) THEN
25842 IFL = IFL+IDT_IQUARK(I,IDD)
25844 IFL = IFL-IDT_IQUARK(I,IDD)
25855 *$ CREATE DT_EVTCHG.FOR
25858 *===evtchg=============================================================*
25860 SUBROUTINE DT_EVTCHG(ID,MODE,IPOS,IREJ)
25862 ************************************************************************
25863 * Charge conservation check. *
25864 * ID identity of particle (PDG-numbering scheme) *
25865 * MODE = 1 initialization *
25866 * =-2 subtract ID-charge *
25867 * = 2 add ID-charge *
25868 * = 3 check charge cons. *
25869 * IPOS flag to give position of call of EVTCHG to output *
25870 * unit in case of violation *
25871 * This version dated 10.01.95 is written by S. Roesler *
25872 * Last change: s.r. 21.01.01 *
25873 ************************************************************************
25875 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25878 PARAMETER ( LINP = 10 ,
25884 PARAMETER (NMXHKK=200000)
25886 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25887 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25888 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25890 * particle properties (BAMJET index convention)
25892 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
25893 & IICH(210),IIBAR(210),K1(210),K2(210)
25897 IF (MODE.EQ.1) THEN
25903 IF (MODE.EQ.3) THEN
25904 IF ((ICH.NE.0).OR.(IBAR.NE.0)) THEN
25905 WRITE(LOUT,'(1X,A,I3,A,2I3,A,I8)')
25906 & 'EVTCHG: charge/baryo.-cons. failure at pos. ',IPOS,
25907 & '! ICH/IBAR= ',ICH,IBAR,' event ',NEVHKK
25917 IF (ID.EQ.0) RETURN
25919 IDD = IDT_ICIHAD(ID)
25920 * modification 21.1.01: use intrinsic phojet-functions to determine charge
25921 * and baryon number
25922 C IF (IDD.GT.0) THEN
25923 C IF (MODE.EQ.2) THEN
25924 C ICH = ICH+IICH(IDD)
25925 C IBAR = IBAR+IIBAR(IDD)
25926 C ELSEIF (MODE.EQ.-2) THEN
25927 C ICH = ICH-IICH(IDD)
25928 C IBAR = IBAR-IIBAR(IDD)
25931 C WRITE(LOUT,'(1X,A,3I6)') 'EVTCHG: (IDD = 0 !), IDD,ID=',IDD,ID
25932 C CALL DT_EVTOUT(4)
25935 IF (MODE.EQ.2) THEN
25936 ICH = ICH+IPHO_CHR3(ID,1)/3
25937 IBAR = IBAR+IPHO_BAR3(ID,1)/3
25938 ELSEIF (MODE.EQ.-2) THEN
25939 ICH = ICH-IPHO_CHR3(ID,1)/3
25940 IBAR = IBAR-IPHO_BAR3(ID,1)/3
25950 ************************************************************************
25952 * 4) Transformations *
25954 ************************************************************************
25955 *$ CREATE DT_LTINI.FOR
25958 *===ltini==============================================================*
25960 SUBROUTINE DT_LTINI(IDPR,IDTA,EPN0,PPN0,ECM0,MODE)
25962 ************************************************************************
25963 * Initializations of Lorentz-transformations, calculation of Lorentz- *
25965 * This version dated 13.11.95 is written by S. Roesler. *
25966 ************************************************************************
25968 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25971 PARAMETER ( LINP = 10 ,
25975 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,
25976 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
25978 * Lorentz-parameters of the current interaction
25979 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
25980 & UMO,PPCM,EPROJ,PPROJ
25982 * properties of photon/lepton projectiles
25983 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
25985 * particle properties (BAMJET index convention)
25987 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
25988 & IICH(210),IIBAR(210),K1(210),K2(210)
25990 * nucleon-nucleon event-generator
25993 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
25997 IF (MCGENE.NE.3) THEN
25998 * lepton-projectiles and PHOJET: initialize real photon instead
25999 IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26000 & (IDPR.EQ.10).OR.(IDPR.EQ.11).OR.
26001 & (IDPR.EQ. 5).OR.(IDPR.EQ. 6)) THEN
26010 AMP = AAM(IDP)-SQRT(ABS(Q2))
26012 AMP2 = SIGN(AMP**2,AMP)
26014 IF (ECM0.GT.ZERO) THEN
26015 EPN = (ECM**2-AMP2-AMT2)/(TWO*AMT)
26016 IF (AMP2.GT.ZERO) THEN
26017 PPN = SQRT((EPN+AMP)*(EPN-AMP))
26019 PPN = SQRT(EPN**2-AMP2)
26022 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26023 IF (IDP.EQ.7) EPN = ABS(EPN)
26024 IF (EPN.LT.ZERO) EPN = ABS(EPN)+AMP
26025 IF (AMP2.GT.ZERO) THEN
26026 PPN = SQRT((EPN+AMP)*(EPN-AMP))
26028 PPN = SQRT(EPN**2-AMP2)
26030 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26031 IF (AMP2.GT.ZERO) THEN
26032 EPN = PPN*SQRT(ONE+(AMP/PPN)**2)
26034 EPN = SQRT(PPN**2+AMP2)
26037 ECM = SQRT(AMP2+AMT2+TWO*AMT*EPN)
26042 IF (AMP2.GT.ZERO) THEN
26043 ETARG = (ECM**2-AMP2-AMT2)/(TWO*AMP)
26044 PTARG = -SQRT((ETARG+AMT)*(ETARG-AMT))
26049 * photon-projectiles (get momentum in cm-frame for virtuality Q^2)
26055 IF (ECM0.GT.ZERO) THEN
26058 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26059 S = AMGAM2+AMT2+TWO*AMT*ABS(EPN0)
26060 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26061 S = AMGAM2+AMT2+TWO*AMT*SQRT(PPN0**2+AMGAM2)
26064 PGAMM(3) = SQRT( (S**2-TWO*AMGAM2*S-TWO*AMT2*S-TWO*AMGAM2*AMT2
26065 & +AMGAM2**2+AMT2**2)/(4.0D0*S) )
26066 PGAMM(4) = SQRT(AMGAM2+PGAMM(3)**2)
26067 IF (MODE.EQ.1) THEN
26070 PNUCL(3) = -PGAMM(3)
26071 PNUCL(4) = SQRT(S)-PGAMM(4)
26074 IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26075 & (IDPR.EQ.10).OR.(IDPR.EQ.11)) THEN
26078 * neglect lepton masses
26079 C AMLPT2 = AAM(IDPR)**2
26082 IF (ECM0.GT.ZERO) THEN
26085 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26086 S = AMLPT2+AMT2+TWO*AMT*ABS(EPN0)
26087 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26088 S = AMLPT2+AMT2+TWO*AMT*SQRT(PPN0**2+AMLPT2)
26091 PLEPT0(3) = SQRT( (S**2-TWO*AMLPT2*S-TWO*AMT2*S-TWO*AMLPT2*AMT2
26092 & +AMLPT2**2+AMT2**2)/(4.0D0*S) )
26093 PLEPT0(4) = SQRT(AMLPT2+PLEPT0(3)**2)
26096 PNUCL(3) = -PLEPT0(3)
26097 PNUCL(4) = SQRT(S)-PLEPT0(4)
26099 * Lorentz-parameter for transformation Lab. - projectile rest system
26100 IF ((IDP.EQ.7).OR.(AMP.LT.TINY10)) THEN
26109 * Lorentz-parameter for transf. proj. rest sys. - nucl.-nucl. cms.
26114 GACMS(1) = (ETARG+AMP)/UMO
26115 BGCMS(1) = PTARG/UMO
26117 * Lorentz-parameter for transformation Lab. - nucl.-nucl. cms.
26118 GACMS(2) = (EPROJ+AMT)/UMO
26119 BGCMS(2) = PPROJ/UMO
26120 PPCM = GACMS(2)*PPROJ-BGCMS(2)*EPROJ
26129 *$ CREATE DT_LTRANS.FOR
26132 *===ltrans=============================================================*
26134 SUBROUTINE DT_LTRANS(PXI,PYI,PZI,PEI,PXO,PYO,PZO,PEO,ID,MODE)
26136 ************************************************************************
26137 * Lorentz-transformations. *
26138 * MODE = 1(-1) projectile rest syst. --> Lab (back) *
26139 * = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) *
26140 * = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) *
26141 * This version dated 01.11.95 is written by S. Roesler. *
26142 ************************************************************************
26144 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26147 PARAMETER ( LINP = 10 ,
26151 PARAMETER (TINY3=1.0D-3,ZERO=0.0D0,TWO=2.0D0)
26153 PARAMETER (SQTINF=1.0D+15)
26155 * particle properties (BAMJET index convention)
26157 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26158 & IICH(210),IIBAR(210),K1(210),K2(210)
26162 CALL DT_LTNUC(PZI,PEI,PZO,PEO,MODE)
26164 * check particle mass for consistency (numerical rounding errors)
26165 PO = SQRT(PXO*PXO+PYO*PYO+PZO*PZO)
26166 AMO2 = (PEO-PO)*(PEO+PO)
26167 AMORQ2 = AAM(ID)**2
26168 AMDIF2 = ABS(AMO2-AMORQ2)
26169 IF ((AMDIF2.GT.TINY3).AND.(PEO.LT.SQTINF).AND.(PO.GT.ZERO)) THEN
26170 DELTA = (AMORQ2-AMO2)/(TWO*(PEO+PO))
26176 C WRITE(6,*) 'LTRANS corrected', AMDIF2,PZI,PEI,PZO,PEO,MODE,ID
26182 *$ CREATE DT_LTNUC.FOR
26185 *===ltnuc==============================================================*
26187 SUBROUTINE DT_LTNUC(PIN,EIN,POUT,EOUT,MODE)
26189 ************************************************************************
26190 * Lorentz-transformations. *
26191 * PIN longitudnal momentum (input) *
26192 * EIN energy (input) *
26193 * POUT transformed long. momentum (output) *
26194 * EOUT transformed energy (output) *
26195 * MODE = 1(-1) projectile rest syst. --> Lab (back) *
26196 * = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) *
26197 * = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) *
26198 * This version dated 01.11.95 is written by S. Roesler. *
26199 ************************************************************************
26201 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26204 PARAMETER ( LINP = 10 ,
26208 PARAMETER (ZERO=0.0D0)
26210 * Lorentz-parameters of the current interaction
26211 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26212 & UMO,PPCM,EPROJ,PPROJ
26218 IF (ABS(MODE).EQ.1) THEN
26219 BG = -SIGN(BGLAB,DBLE(MODE))
26220 CALL DT_DALTRA(GALAB,BDUM1,BDUM2,-BG,PDUM1,PDUM2,PIN,EIN,
26221 & DUM1,DUM2,DUM3,POUT,EOUT)
26222 ELSEIF (ABS(MODE).EQ.2) THEN
26223 BG = SIGN(BGCMS(1),DBLE(MODE))
26224 CALL DT_DALTRA(GACMS(1),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26225 & DUM1,DUM2,DUM3,POUT,EOUT)
26226 ELSEIF (ABS(MODE).EQ.3) THEN
26227 BG = -SIGN(BGCMS(2),DBLE(MODE))
26228 CALL DT_DALTRA(GACMS(2),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26229 & DUM1,DUM2,DUM3,POUT,EOUT)
26231 WRITE(LOUT,1000) MODE
26232 1000 FORMAT(1X,'LTNUC: not supported mode (MODE = ',I3,')')
26240 *$ CREATE DT_DALTRA.FOR
26243 *===daltra=============================================================*
26245 SUBROUTINE DT_DALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
26247 ************************************************************************
26248 * Arbitrary Lorentz-transformation. *
26249 * Adopted from the original by S. Roesler. This version dated 15.01.95 *
26250 ************************************************************************
26252 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26254 PARAMETER (ONE=1.0D0)
26256 EP = PCX*BGX+PCY*BGY+PCZ*BGZ
26257 PE = EP/(GA+ONE)+EC
26261 P = SQRT(PX*PX+PY*PY+PZ*PZ)
26267 *$ CREATE DT_DTRAFO.FOR
26270 *====dtrafo============================================================*
26272 SUBROUTINE DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
26273 & PL,CXL,CYL,CZL,EL)
26275 C LORENTZ TRANSFORMATION INTO THE LAB - SYSTEM
26277 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26280 IF (ABS(COD).GT.1.0D0) COD = SIGN(1.0D0,COD)
26281 SID = SQRT(1.D0-COD*COD)
26285 PLZ = GAM*PCMZ+BGAM*ECM
26286 PL = SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
26287 EL = GAM*ECM+BGAM*PCMZ
26288 C ROTATION INTO THE ORIGINAL DIRECTION
26290 SIZ = SQRT(1.D0-COZ**2)
26291 CALL DT_STTRAN(CX,CY,CZ,COZ,SIZ,SIF,COF,CXL,CYL,CZL)
26296 *$ CREATE DT_STTRAN.FOR
26299 *====sttran============================================================*
26301 SUBROUTINE DT_STTRAN(XO,YO,ZO,CDE,SDE,SFE,CFE,X,Y,Z)
26303 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26305 DATA ANGLSQ/1.D-30/
26306 ************************************************************************
26307 * VERSION BY J. RANFT *
26310 * THIS IS A SUBROUTINE OF FLUKA TO GIVE NEW DIRECTION COSINES *
26312 * INPUT VARIABLES: *
26313 * XO,YO,ZO = ORIGINAL DIRECTION COSINES *
26314 * CDE,SDE = COSINE AND SINE OF THE POLAR (THETA) *
26315 * ANGLE OF "SCATTERING" *
26316 * SDE = SINE OF THE POLAR (THETA) ANGLE OF "SCATTERING" *
26317 * SFE,CFE = SINE AND COSINE OF THE AZIMUTHAL (PHI) ANGLE *
26318 * OF "SCATTERING" *
26320 * OUTPUT VARIABLES: *
26321 * X,Y,Z = NEW DIRECTION COSINES *
26323 * ROTATION OF COORDINATE SYSTEM (SEE CERN 64-47 ) *
26324 ************************************************************************
26327 * Changed by A. Ferrari
26329 * IF (ABS(XO)-0.0001D0) 1,1,2
26330 * 1 IF (ABS(YO)-0.0001D0) 3,3,2
26333 IF ( A .LT. ANGLSQ ) THEN
26342 X=-YO*XI/A-ZO*XO*YI/A+XO*ZI
26343 Y=XO*XI/A-ZO*YO*YI/A+YO*ZI
26350 *$ CREATE DT_MYTRAN.FOR
26353 *===mytran=============================================================*
26355 SUBROUTINE DT_MYTRAN(IMODE,XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
26357 ************************************************************************
26358 * This subroutine rotates the coordinate frame *
26359 * a) theta around y *
26360 * b) phi around z if IMODE = 1 *
26362 * x' cos(ph) -sin(ph) 0 cos(th) 0 sin(th) x *
26363 * y' = A B = sin(ph) cos(ph) 0 . 0 1 0 y *
26364 * z' 0 0 1 -sin(th) 0 cos(th) z *
26366 * and vice versa if IMODE = 0. *
26367 * This version dated 5.4.94 is based on the original version DTRAN *
26368 * by J. Ranft and is written by S. Roesler. *
26369 ************************************************************************
26371 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26374 PARAMETER ( LINP = 10 ,
26378 IF (IMODE.EQ.1) THEN
26379 X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
26380 Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
26381 Z=-SDE *XO +CDE *ZO
26383 X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
26385 Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
26390 *$ CREATE DT_LT2LAO.FOR
26393 *===lt2lab=============================================================*
26395 SUBROUTINE DT_LT2LAO
26397 ************************************************************************
26398 * Lorentz-transformation to lab-system. This subroutine scans DTEVT1 *
26399 * for final state particles/fragments defined in nucleon-nucleon-cms *
26400 * and transforms them back to the lab. *
26401 * This version dated 16.11.95 is written by S. Roesler *
26402 ************************************************************************
26404 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26407 PARAMETER ( LINP = 10 ,
26413 PARAMETER (NMXHKK=200000)
26415 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26416 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26417 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26419 * extended event history
26420 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26421 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26426 IF ( (NPOINT(4).EQ.0).OR.(NEND.LT.NPOINT(4)) ) RETURN
26427 DO 1 I=NPOINT(4),NEND
26429 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26430 & (ISTHKK(I).EQ.1001)) THEN
26431 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26433 CALL DT_EVTPUT(ISTHKK(I),IDHKK(I),I,0,PHKK(1,I),PHKK(2,I),
26434 & PZ,PE,IDRES(I),IDXRES(I),IDCH(I))
26435 IF ((ISTHKK(I).EQ.1000).OR.(ISTHKK(I).EQ.1001)) THEN
26436 ISTHKK(I) = 3*ISTHKK(I)
26439 IF (ISTHKK(I).EQ.-1) NOBAM(NHKK) = NOB
26440 ISTHKK(I) = SIGN(3,ISTHKK(I))
26449 *$ CREATE DT_LT2LAB.FOR
26452 *===lt2lab=============================================================*
26454 SUBROUTINE DT_LT2LAB
26456 ************************************************************************
26457 * Lorentz-transformation to lab-system. This subroutine scans DTEVT1 *
26458 * for final state particles/fragments defined in nucleon-nucleon-cms *
26459 * and transforms them to the lab. *
26460 * This version dated 07.01.96 is written by S. Roesler *
26461 ************************************************************************
26463 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26466 PARAMETER ( LINP = 10 ,
26472 PARAMETER (NMXHKK=200000)
26474 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26475 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26476 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26478 * extended event history
26479 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26480 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26483 IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
26484 DO 1 I=NPOINT(4),NHKK
26485 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26486 & (ISTHKK(I).EQ.1001)) THEN
26487 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26496 ************************************************************************
26498 * 5) Sampling from distributions *
26500 ************************************************************************
26501 *$ CREATE IDT_NPOISS.FOR
26504 *===npoiss=============================================================*
26506 INTEGER FUNCTION IDT_NPOISS(AVN)
26508 ************************************************************************
26509 * Sample according to Poisson distribution with Poisson parameter AVN. *
26510 * The original version written by J. Ranft. *
26511 * This version dated 11.1.95 is written by S. Roesler. *
26512 ************************************************************************
26514 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26517 PARAMETER ( LINP = 10 ,
26527 IF (A.GE.EXPAVN) THEN
26536 *$ CREATE DT_SAMPXB.FOR
26539 *===sampxb=============================================================*
26541 DOUBLE PRECISION FUNCTION DT_SAMPXB(X1,X2,B)
26543 ************************************************************************
26544 * Sampling from f(x)=1./SQRT(X**2+B**2) between x1 and x2. *
26545 * Processed by S. Roesler, 6.5.95 *
26546 ************************************************************************
26548 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26550 PARAMETER (TWO=2.0D0)
26552 A1 = LOG(X1+SQRT(X1**2+B**2))
26553 A2 = LOG(X2+SQRT(X2**2+B**2))
26555 A = AN*DT_RNDM(A1)+A1
26557 DT_SAMPXB = (BB**2-B**2)/(TWO*BB)
26562 *$ CREATE DT_SAMPEX.FOR
26565 *===sampex=============================================================*
26567 DOUBLE PRECISION FUNCTION DT_SAMPEX(X1,X2)
26569 ************************************************************************
26570 * Sampling from f(x)=1./x between x1 and x2. *
26571 * Processed by S. Roesler, 6.5.95 *
26572 ************************************************************************
26574 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26576 PARAMETER (ONE=1.0D0)
26581 DT_SAMPEX = EXP((ONE-R)*AL1+R*AL2)
26586 *$ CREATE DT_SAMSQX.FOR
26589 *===samsqx=============================================================*
26591 DOUBLE PRECISION FUNCTION DT_SAMSQX(X1,X2)
26593 ************************************************************************
26594 * Sampling from f(x)=1./x^0.5 between x1 and x2. *
26595 * Processed by S. Roesler, 6.5.95 *
26596 ************************************************************************
26598 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26600 PARAMETER (ONE=1.0D0)
26603 DT_SAMSQX = (R*SQRT(X2)+(ONE-R)*SQRT(X1))**2
26608 *$ CREATE DT_SAMPLW.FOR
26611 *===samplw=============================================================*
26613 DOUBLE PRECISION FUNCTION DT_SAMPLW(XMIN,XMAX,B)
26615 ************************************************************************
26616 * Sampling from f(x)=1/x^b between x_min and x_max. *
26617 * S. Roesler, 18.4.98 *
26618 ************************************************************************
26620 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26622 PARAMETER (ONE=1.0D0)
26626 DT_SAMPLW = EXP(R*LOG(XMAX)+(ONE-R)*LOG(XMIN))
26629 DT_SAMPLW = (R*XMAX**ONEMB+(ONE-R)*XMIN**ONEMB)**(ONE/ONEMB)
26635 *$ CREATE DT_BETREJ.FOR
26638 *===betrej=============================================================*
26640 DOUBLE PRECISION FUNCTION DT_BETREJ(GAM,ETA,XMIN,XMAX)
26642 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26645 PARAMETER ( LINP = 10 ,
26649 PARAMETER (ONE=1.0D0)
26651 IF (XMIN.GE.XMAX)THEN
26652 WRITE (LOUT,500) XMIN,XMAX
26653 500 FORMAT(1X,'DT_BETREJ: XMIN<XMAX execution stopped ',2F10.5)
26658 XX = XMIN+(XMAX-XMIN)*DT_RNDM(ETA)
26659 BETMAX = XMIN**(GAM-ONE)*(ONE-XMIN)**(ETA-ONE)
26660 YY = BETMAX*DT_RNDM(XX)
26661 BETXX = XX**(GAM-ONE)*(ONE-XX)**(ETA-ONE)
26662 IF (YY.GT.BETXX) GOTO 10
26668 *$ CREATE DT_DGAMRN.FOR
26671 *===dgamrn=============================================================*
26673 DOUBLE PRECISION FUNCTION DT_DGAMRN(ALAM,ETA)
26675 ************************************************************************
26676 * Sampling from Gamma-distribution. *
26677 * F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA) *
26678 * Processed by S. Roesler, 6.5.95 *
26679 ************************************************************************
26681 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26683 PARAMETER (ZERO=0.0D0,TINY9=1.0D-9,ONE=1.0D0)
26688 IF (F.EQ.ZERO) GOTO 20
26691 IF (NCOU.GE.11) GOTO 20
26692 IF (R.LT.F/(F+2.71828D0)) GOTO 30
26693 YYY = LOG(DT_RNDM(R)+TINY9)/F
26694 IF (ABS(YYY).GT.50.0D0) GOTO 20
26696 IF (LOG(DT_RNDM(Y)+TINY9).GT.-Y) GOTO 10
26700 30 Y = ONE-LOG(DT_RNDM(Y)+TINY9)
26701 IF (DT_RNDM(R).GT.Y**(F-ONE)) GOTO 10
26702 40 IF (N.EQ.0) GOTO 70
26705 60 Z = Z*DT_RNDM(Z)
26707 70 DT_DGAMRN = Y/ALAM
26712 *$ CREATE DT_DBETAR.FOR
26715 *===dbetar=============================================================*
26717 DOUBLE PRECISION FUNCTION DT_DBETAR(GAM,ETA)
26719 ************************************************************************
26720 * Sampling from Beta -distribution between 0.0 and 1.0 *
26721 * F(X)=X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM)/(GAMM(GAM)*GAMM(ETA))*
26722 * Processed by S. Roesler, 6.5.95 *
26723 ************************************************************************
26725 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26728 Y = DT_DGAMRN(1.0D0,GAM)
26729 Z = DT_DGAMRN(1.0D0,ETA)
26730 DT_DBETAR = Y/(Y+Z)
26735 *$ CREATE DT_RANNOR.FOR
26738 *===rannor=============================================================*
26740 SUBROUTINE DT_RANNOR(X,Y)
26742 ************************************************************************
26743 * Sampling from Gaussian distribution. *
26744 * Processed by S. Roesler, 6.5.95 *
26745 ************************************************************************
26747 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26749 PARAMETER (TINY10=1.0D-10)
26751 CALL DT_DSFECF(SFE,CFE)
26752 V = MAX(TINY10,DT_RNDM(X))
26753 A = SQRT(-2.D0*LOG(V))
26760 *$ CREATE DT_DPOLI.FOR
26763 *===dpoli==============================================================*
26765 SUBROUTINE DT_DPOLI(CS,SI)
26767 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26772 IF (U.LT.0.5D0) CS=-CS
26773 SI = SQRT(1.0D0-CS*CS+1.0D-10)
26778 *$ CREATE DT_DSFECF.FOR
26781 *===dsfecf=============================================================*
26783 SUBROUTINE DT_DSFECF(SFE,CFE)
26785 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26787 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
26795 IF (XY.GT.ONE) GOTO 1
26798 IF (DT_RNDM(X).LT.OHALF) SFE = -SFE
26802 *$ CREATE DT_RACO.FOR
26805 *===raco===============================================================*
26807 SUBROUTINE DT_RACO(WX,WY,WZ)
26809 ************************************************************************
26810 * Direction cosines of random uniform (isotropic) direction in three *
26811 * dimensional space *
26812 * Processed by S. Roesler, 20.11.95 *
26813 ************************************************************************
26815 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26817 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
26820 X = TWO*DT_RNDM(WX)-ONE
26824 IF (X2+Y2.GT.ONE) GOTO 10
26826 CFE = (X2-Y2)/(X2+Y2)
26827 SFE = TWO*X*Y/(X2+Y2)
26828 * z = 1/2 [ 1 + cos (theta) ]
26831 WZ = SQRT(Z*(ONE-Z))
26839 ************************************************************************
26841 * 6) Special functions, algorithms and service routines *
26843 ************************************************************************
26844 *$ CREATE DT_YLAMB.FOR
26847 *===ylamb==============================================================*
26849 DOUBLE PRECISION FUNCTION DT_YLAMB(X,Y,Z)
26851 ************************************************************************
26853 * auxiliary function for three particle decay mode *
26854 * (standard LAMBDA**(1/2) function) *
26856 * Adopted from an original version written by R. Engel. *
26857 * This version dated 12.12.94 is written by S. Roesler. *
26858 ************************************************************************
26860 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26864 XLAM = X*X-2.D0*X*(Y+Z)+YZ*YZ
26865 IF (XLAM.LE.0.D0) XLAM = ABS(XLAM)
26866 DT_YLAMB = SQRT(XLAM)
26871 *$ CREATE DT_SORT.FOR
26874 *===sort1==============================================================*
26876 SUBROUTINE DT_SORT(A,N,I0,I1,MODE)
26878 ************************************************************************
26879 * This subroutine sorts entries in A in increasing/decreasing order *
26881 * MODE = 1 increasing in A(3,i=1..N) *
26882 * = 2 decreasing in A(3,i=1..N) *
26883 * This version dated 21.04.95 is revised by S. Roesler *
26884 ************************************************************************
26886 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26898 IF (MODE.EQ.1) THEN
26899 IF (A(3,I).LE.A(3,J)) GOTO 20
26901 IF (A(3,I).GE.A(3,J)) GOTO 20
26914 IF (L.EQ.1) GOTO 10
26919 *$ CREATE DT_SORT1.FOR
26922 *===sort1==============================================================*
26924 SUBROUTINE DT_SORT1(A,IDX,N,I0,I1,MODE)
26926 ************************************************************************
26927 * This subroutine sorts entries in A in increasing/decreasing order *
26929 * MODE = 1 increasing in A(i=1..N) *
26930 * = 2 decreasing in A(i=1..N) *
26931 * This version dated 21.04.95 is revised by S. Roesler *
26932 ************************************************************************
26934 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26937 DIMENSION A(N),IDX(N)
26946 IF (MODE.EQ.1) THEN
26947 IF (A(I).LE.A(J)) GOTO 20
26949 IF (A(I).GE.A(J)) GOTO 20
26959 IF (L.EQ.1) GOTO 10
26964 *$ CREATE DT_XTIME.FOR
26967 *===xtime==============================================================*
26969 SUBROUTINE DT_XTIME
26971 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26974 PARAMETER ( LINP = 10 ,
26978 CHARACTER DAT*9,TIM*11
26982 C CALL GETDAT(IYEAR,IMONTH,IDAY)
26983 C CALL GETTIM(IHOUR,IMINUT,ISECND,IHSCND)
26987 C WRITE(LOUT,1000) DAT,TIM
26988 1000 FORMAT(/,2X,'Date: ',A9,3X,'Time: ',A11,/)
26993 ************************************************************************
26995 * 7) Random number generator package *
26997 * THIS IS A PACKAGE CONTAINING A RANDOM NUMBER GENERATOR AND *
26998 * SERVICE ROUTINES. *
26999 * THE ALGORITHM IS FROM *
27000 * 'TOWARD A UNVERSAL RANDOM NUMBER GENERATOR' *
27001 * G.MARSAGLIA, A.ZAMAN ; FSU-SCRI-87-50 *
27002 * IMPLEMENTATION BY K. HAHN DEC. 88, *
27003 * THIS GENERATOR SHOULD NOT DEPEND ON THE HARD WARE ( IF A REAL HAS *
27004 * AT LEAST 24 SIGNIFICANT BITS IN INTERNAL REPRESENTATION ), *
27005 * THE PERIOD IS ABOUT 2**144, *
27006 * TIME FOR ONE CALL AT IBM-XT IS ABOUT 0.7 MILLISECONDS, *
27007 * THE PACKAGE CONTAINS *
27008 * FUNCTION DT_RNDM(I) : GENERATOR *
27009 * SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB4): INITIALIZATION *
27010 * SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) : PUT SEED TO GENERATOR *
27011 * SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) : TAKE SEED FROM GENERATOR *
27012 * SUBROUTINE DT_RNDMTE(IO) : TEST OF GENERATOR *
27014 * FUNCTION DT_RNDM(I) *
27015 * GIVES UNIFORMLY DISTRIBUTED RANDOM NUMBERS IN (0..1) *
27016 * I - DUMMY VARIABLE, NOT USED *
27017 * SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1) *
27018 * INITIALIZES THE GENERATOR, MUST BE CALLED BEFORE USING DT_RNDM *
27019 * NA1,NA2,NA3,NB1 - VALUES FOR INITIALIZING THE GENERATOR *
27020 * NA? MUST BE IN 1..178 AND NOT ALL 1 *
27021 * 12,34,56 ARE THE STANDARD VALUES *
27022 * NB1 MUST BE IN 1..168 *
27023 * 78 IS THE STANDARD VALUE *
27024 * SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) *
27025 * PUTS SEED TO GENERATOR ( BRINGS GENERATOR IN THE SAME STATUS *
27026 * AS AFTER THE LAST DT_RNDMOU CALL ) *
27027 * U(97),C,CD,CM,I,J - SEED VALUES AS TAKEN FROM DT_RNDMOU *
27028 * SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) *
27029 * TAKES SEED FROM GENERATOR *
27030 * U(97),C,CD,CM,I,J - SEED VALUES *
27031 * SUBROUTINE DT_RNDMTE(IO) *
27032 * TEST OF THE GENERATOR *
27033 * IO - DEFINES OUTPUT *
27034 * = 0 OUTPUT ONLY IF AN ERROR IS DETECTED *
27035 * = 1 OUTPUT INDEPENDEND ON AN ERROR *
27036 * DT_RNDMTE USES DT_RNDMIN AND DT_RNDMOU TO BRING GENERATOR TO *
27038 * AS BEFORE CALL OF DT_RNDMTE *
27039 ************************************************************************
27040 *$ CREATE DT_RNDM.FOR
27043 *===rndm===============================================================*
27045 c$$$ DOUBLE PRECISION FUNCTION DT_RNDM(VDUMMY)
27047 c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27050 c$$$* counter of calls to random number generator
27051 c$$$* uncomment if needed
27052 c$$$C COMMON /DTRNCT/ IRNCT0,IRNCT1
27053 c$$$C LOGICAL LFIRST
27054 c$$$C DATA LFIRST /.TRUE./
27056 c$$$* counter of calls to random number generator
27057 c$$$* uncomment if needed
27058 c$$$C IF (LFIRST) THEN
27061 c$$$C LFIRST = .FALSE.
27064 c$$$ DT_RNDM = FLRNDM(VDUMMY)
27065 c$$$* counter of calls to random number generator
27066 c$$$* uncomment if needed
27067 c$$$C IRNCT1 = IRNCT1+1
27072 c$$$*$ CREATE DT_RNDMST.FOR
27073 c$$$*COPY DT_RNDMST
27075 c$$$*===rndmst=============================================================*
27077 c$$$ SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)
27079 c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27082 c$$$* random number generator
27083 c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27091 c$$$ DO 20 II2 = 1,97
27094 c$$$ DO 10 II1 = 1,24
27095 c$$$ MAT = MOD(MOD(MA1*MA2,179)*MA3,179)
27099 c$$$ MB1 = MOD(53*MB1+1,169)
27100 c$$$ IF ( MOD(MB1*MAT,64).GE.32 ) S = S+T
27101 c$$$ 10 T = 0.5D0*T
27103 c$$$ C = 362436.0D0/16777216.0D0
27104 c$$$ CD = 7654321.0D0/16777216.0D0
27105 c$$$ CM = 16777213.0D0/16777216.0D0
27109 c$$$*$ CREATE DT_RNDMIN.FOR
27110 c$$$*COPY DT_RNDMIN
27112 c$$$*===rndmin=============================================================*
27114 c$$$ SUBROUTINE DT_RNDMIN(UIN,CIN,CDIN,CMIN,IIN,JIN)
27116 c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27119 c$$$* random number generator
27120 c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27122 c$$$ DIMENSION UIN(97)
27124 c$$$ DO 10 KKK = 1,97
27125 c$$$ 10 U(KKK) = UIN(KKK)
27135 c$$$*$ CREATE DT_RNDMOU.FOR
27136 c$$$*COPY DT_RNDMOU
27138 c$$$*===rndmou=============================================================*
27140 c$$$ SUBROUTINE DT_RNDMOU(UOUT,COUT,CDOUT,CMOUT,IOUT,JOUT)
27142 c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27145 c$$$* random number generator
27146 c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27148 c$$$ DIMENSION UOUT(97)
27150 c$$$ DO 10 KKK = 1,97
27151 c$$$ 10 UOUT(KKK) = U(KKK)
27161 c$$$*$ CREATE DT_RNDMTE.FOR
27162 c$$$*COPY DT_RNDMTE
27164 c$$$*===rndmte=============================================================*
27166 c$$$ SUBROUTINE DT_RNDMTE(IO)
27168 c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27171 c$$$ DIMENSION UU(97),U(6),X(6),D(6)
27172 c$$$ DATA U / 6533892.D0, 14220222.D0, 7275067.D0, 6172232.D0,
27173 c$$$ +8354498.D0, 10633180.D0/
27175 c$$$ CALL DT_RNDMOU(UU,CC,CCD,CCM,II,JJ)
27176 c$$$ CALL DT_RNDMST(12,34,56,78)
27177 c$$$ DO 10 II1 = 1,20000
27178 c$$$ 10 XX = DT_RNDM(XX)
27180 c$$$ DO 20 II2 = 1,6
27181 c$$$ X(II2) = 4096.D0*(4096.D0*DT_RNDM(SD))
27182 c$$$ D(II2) = X(II2)-U(II2)
27183 c$$$ 20 SD = SD+D(II2)
27184 c$$$ CALL DT_RNDMIN(UU,CC,CCD,CCM,II,JJ)
27186 c$$$C IF ( IO.EQ. 1.OR. SD.NE.0. 0) WRITE(6,500) (U(I),X(I),D(I),I=1,6)
27187 c$$$ IF ((IO.EQ.1).OR.(SD.NE.0.0)) THEN
27188 c$$$C WRITE(6,1000)
27189 c$$$ 1000 FORMAT(/,/,1X,'DT_RNDMTE: Test of random-number generator...',
27194 c$$$ 500 FORMAT(' === TEST OF THE RANDOM-GENERATOR ===',/,
27195 c$$$ &' EXPECTED VALUE CALCULATED VALUE DIFFERENCE',/, 6(F17.
27196 c$$$ &1,F20.1,F15.3,/), ' === END OF TEST ;',
27197 c$$$ &' GENERATOR HAS THE SAME STATUS AS BEFORE CALLING DT_RNDMTE')
27200 *$ CREATE PHO_RNDM.FOR
27203 *===pho_rndm===========================================================*
27205 DOUBLE PRECISION FUNCTION PHO_RNDM(DUMMY)
27207 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27210 PHO_RNDM = DT_RNDM(DUMMY)
27218 *===pyr================================================================*
27220 DOUBLE PRECISION FUNCTION PYR(IDUMMY)
27222 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27225 DUMMY = DBLE(IDUMMY)
27226 PYR = DT_RNDM(DUMMY)
27230 *$ CREATE DT_TITLE.FOR
27233 *===title==============================================================*
27235 SUBROUTINE DT_TITLE
27237 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27240 PARAMETER ( LINP = 10 ,
27245 CHARACTER*11 CCHANG
27246 DATA CVERSI,CCHANG /'3.0-5 ','31 Oct 2008'/
27249 WRITE(LOUT,1000) CVERSI,CCHANG
27250 1000 FORMAT(1X,'+-------------------------------------------------',
27251 & '----------------------+',/,
27252 & 1X,'|',71X,'|',/,
27253 & 1X,'|',26X,'DPMJET version ',A6,24X,'|',/,
27254 & 1X,'|',71X,'|',/,
27255 & 1X,'|',22X,'(Last change: ',A11,')',23X,'|',/,
27256 & 1X,'|',71X,'|',/,
27257 & 1X,'|',12X,'Authors: Stefan Roesler (CERN)',27X,'|',/,
27258 & 1X,'|',21X,'Ralph Engel (FZ Karlsruhe)',19X,'|',/,
27259 & 1X,'|',21X,'Johannes Ranft (Siegen Univ.)',19X,'|',/,
27260 C & 1X,'|',71X,'|',/,
27261 C & 1X,'|',12X,'http://home.cern.ch/~sroesler/dpmjet3.html',
27263 & 1X,'|',71X,'|',/,
27264 & 1X,'+-------------------------------------------------',
27265 & '----------------------+',/,
27266 & 1X,'| Please send suggestions, bug reports, etc. to: ',
27267 & 'Stefan.Roesler@cern.ch |',/,
27268 & 1X,'+-------------------------------------------------',
27269 & '----------------------+',/)
27274 *$ CREATE DT_EVTINI.FOR
27277 *===evtini=============================================================*
27279 SUBROUTINE DT_EVTINI
27281 ************************************************************************
27282 * Initialization of DTEVT1. *
27283 * This version dated 15.01.94 is written by S. Roesler *
27284 ************************************************************************
27286 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27289 PARAMETER ( LINP = 10 ,
27295 PARAMETER (NMXHKK=200000)
27297 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27298 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27299 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27301 * extended event history
27302 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27303 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27307 COMMON /DTEVNO/ NEVENT,ICASCA
27309 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
27311 * emulsion treatment
27312 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
27315 * initialization of DTEVT1/DTEVT2
27317 IF (NEVENT.EQ.1) NEND = NMXHKK
27345 C* initialization of DTLTRA
27346 C IF (NCOMPO.GT.0) CALL DT_LTINI(ID,EPN,PPN,ECM)
27351 *$ CREATE DT_STATIS.FOR
27354 *===statis=============================================================*
27356 SUBROUTINE DT_STATIS(MODE)
27358 ************************************************************************
27359 * Initialization and output of run-statistics. *
27360 * MODE = 1 initialization *
27362 * This version dated 23.01.94 is written by S. Roesler *
27363 ************************************************************************
27365 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27368 PARAMETER ( LINP = 10 ,
27372 PARAMETER (TINY3=1.0D-3)
27375 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
27376 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
27379 * rejection counter
27380 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27381 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27382 & IREXCI(3),IRDIFF(2),IRINC
27384 * central particle production, impact parameter biasing
27385 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
27387 * various options for treatment of partons (DTUNUC 1.x)
27388 * (chain recombination, Cronin,..)
27389 LOGICAL LCO2CR,LINTPT
27390 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
27393 * nucleon-nucleon event-generator
27396 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
27398 * flags for particle decays
27399 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
27400 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
27401 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
27403 * diquark-breaking mechanism
27404 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
27406 DIMENSION PP(4),PT(4)
27413 * initialize statistics counter
27426 * initialize rejection counter
27457 * statistics counter
27459 1000 FORMAT(/,/,1X,'STATIS:',20X,'statistics of the run',/,
27460 & 28X,'---------------------')
27461 IF (ICREQU.GT.0) THEN
27462 WRITE(LOUT,1001) ICREQU,ICSAMP,DBLE(ICSAMP)/DBLE(ICREQU)
27463 1001 FORMAT(/,1X,'number of events requested / sampled',13X,
27464 & I8,' / ',I8,/,1X,'number of samp. evts per requested ',
27465 & 'event',11X,F9.1)
27467 IF (ICDIFF(1).NE.0) THEN
27468 WRITE(LOUT,1009) ICDIFF
27469 1009 FORMAT(/,1X,'diffractive events: total ',I8,/,49X,
27470 & 'low mass high mass',/,24X,'single diffraction',
27471 & 7X,I8,4X,I8,/,24X,'double diffraction',7X,I8,4X,I8)
27473 IF (ICENTR.GT.0.AND.ICSAMP.GT.0.AND.ICCPRO.GT.0) THEN
27474 WRITE(LOUT,1002) DBLE(ICCPRO)/DBLE(ICSAMP),
27475 & DBLE(ICSAMP)/DBLE(ICCPRO)
27476 1002 FORMAT(/,1X,'central production:',/,2X,'mean number',
27477 & ' of sampled Glauber-events per event',9X,F9.1,/,
27478 & 2X,'fraction of production cross section',21X,F10.6)
27480 IF (ICSAMP.GT.0) THEN
27481 WRITE(LOUT,1003) DBLE(ICDPR)/DBLE(ICSAMP),
27482 & DBLE(ICDTA)/DBLE(ICSAMP)
27483 1003 FORMAT(/,54X,'proj. targ.',/,1X,'average number of wounded',
27484 & ' nucleons after x-sampling',2(4X,F6.2))
27487 IF (MCGENE.EQ.1) THEN
27488 IF (ICSAMP.GT.0) THEN
27489 WRITE(LOUT,1004) DBLE(ICRJSS)/DBLE(ICSAMP)
27490 1004 FORMAT(/,1X,'mean number of sea-sea chain rejections per',
27491 & ' event',3X,F9.1)
27492 IF (ISICHA.EQ.1) THEN
27493 WRITE(LOUT,1005) DBLE(ICVV2S)/DBLE(ICSAMP)
27494 1005 FORMAT(/,1X,'Reggeon contribution:',/,1X,'mean number ',
27495 & 'of single chains per event',13X,F9.1)
27498 IF (ICSAMP.GT.0.AND.ICREQU.GT.0) THEN
27500 1006 FORMAT(/,1X,'chain system statistics: (per event)',/,
27501 & 23X,'mean number of chains mean number of chains',/,
27502 & 23X,'sampled hadronized having mass of a reso.')
27503 WRITE(LOUT,1007) (DBLE(ICCHAI(1,J))/(2.0D0*DBLE(ICSAMP)),
27504 & DBLE(ICCHAI(2,J))/(2.0D0*DBLE(ICREQU)),
27505 & DBLE(ICRES(J))/(2.0D0*DBLE(ICREQU)),J=1,8),
27506 & DBLE(ICCHAI(2,9))/MAX(DBLE(ICCHAI(1,9)),TINY3)
27507 1007 FORMAT(1X,'sea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27508 & 1X,'disea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27509 & 1X,'sea - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27510 & 1X,'sea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27511 & 1X,'disea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27512 & 1X,'valence - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27513 & 1X,'valence - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27514 & 1X,'valence - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27515 & 1X,'fused chains ',18X,F4.1,17X,F4.1,/)
27517 & (DBLE(IRCRON(I))/MAX(DBLE(IRCRON(1)),TINY3),I=2,3),
27518 & DBLE(IRPT)/DBLE(ICREQU),(DBLE(IRRES(I))/DBLE(ICREQU),I=1,2),
27519 & DBLE(LOMRES)/DBLE(ICREQU),DBLE(LOBRES)/DBLE(ICREQU),
27520 & (DBLE(IRCHKI(I))/DBLE(ICREQU),I=1,2),
27521 & (DBLE(IRDIFF(I))/DBLE(ICREQU),I=1,2),
27522 & DBLE(IRHHA)/DBLE(ICREQU),
27523 & DBLE(IRFRAG)/DBLE(ICREQU),DBLE(IREVT)/DBLE(ICREQU),
27524 & (DBLE(IREXCI(I))/DBLE(ICREQU),I=1,2),IREXCI(3)
27525 1008 FORMAT(/,1X,'Rejection counter: (NEVT = no. of events)',/,/,
27526 & 1X,'Cronin-effect (CRONIN)',15X,'IRCRON(2)/IRCRON(1) = ',
27527 & F7.2,/,38X,'IRCRON(3)/IRCRON(1) = ',F7.2,/,1X,
27528 & 'Intrins. p_t (GETSPT)',21X,'IRPT /NEVT = ',F7.2,/,
27529 & 1X,'Chain mass corr. for resonances (EVTRES)',2X,
27530 & 'IRRES(1) /NEVT = ',F7.2,/,33X,'(CH2RES) IRRES(2) /',
27531 & 'NEVT = ',F7.2,/,43X,'LOMRES /NEVT = ',F7.2,/,
27532 & 43X,'LOBRES /NEVT = ',F7.2,/,1X,'Kinem. corr. of',
27533 & ' 2-chain systems (CHKINE) IRCHKI(1)/NEVT = ',F7.2,/,
27534 & 43X,'IRCHKI(2)/NEVT = ',F7.2,/,1X,'Diffraction',31X,
27535 & 'IRDIFF(1)/NEVT = ',F7.2,/,43X,'IRDIFF(2)/NEVT = ',
27536 & F7.2,/,1X,'Total no. of rej.',
27537 & ' in chain-systems treatment (GETCSY)',/,43X,
27538 & 'IRHHA /NEVT = ',F7.2,/,1X,'Fragmentation (EVTFRA)',
27539 & ' (not yet used!)',4X,'IRFRAG /NEVT = ',F7.2,/,
27540 & 1X,'Total no. of rej. in DPM-treatment of one event',
27541 & ' (EVENTA)',/,43X,'IREVT /NEVT = ',F7.2,/,1X,
27542 & 'Treatment of final nucleon conf.',10X,'IREXCI(1)/NEVT = '
27543 & ,F7.2,/,43X,'IREXCI(2)/NEVT = ',F7.2,/,48X,
27544 & 'IREXCI(3) = ',I5,/)
27546 ELSEIF (MCGENE.EQ.2) THEN
27547 WRITE(LOUT,1010) ELOJET
27548 1010 FORMAT(/,/,1X,'PHOJET-treatment of chain systems above ',
27551 1011 FORMAT(/,1X,'1. chain system statistics - total numbers:',/,
27552 & 30X,'--------------',/,/,12X,'s-s',5X,'d-s',5X,'s-d',
27553 & 5X,'s-v',5X,'d-v',5X,'v-s',5X,'v-d',5X,'v-v')
27554 WRITE(LOUT,1012) ((ICEVTG(I,J),I=1,8),J=0,1),
27555 & (INT(ICCHAI(2,I)/2.0D0),I=1,8),
27556 & (ICEVTG(I,2),I=1,8),(ICEVTG(I,29),I=1,8),
27557 & ((ICEVTG(I,J),I=1,8),J=3,7),
27558 & ((ICEVTG(I,J),I=1,8),J=19,21),
27559 & (ICEVTG(I,8),I=1,8),
27560 & ((ICEVTG(I,J),I=1,8),J=22,24),
27561 & (ICEVTG(I,9),I=1,8),
27562 & ((ICEVTG(I,J),I=1,8),J=25,28),
27563 & ((ICEVTG(I,J),I=1,8),J=10,18)
27564 1012 FORMAT(/,1X,'req.to.',8I8,/,/,1X,'low rq.',8I8,/,1X,'low ac.',
27565 & 8I8,/,/,1X,'PHOJET ',8I8,/,' sngl ',8I8,/,/,
27566 & ' no-dif.',8I8,/,
27567 & ' el-sca.',8I8,/,' qel-sc.',8I8,/,' dbl-Po.',8I8,/,
27568 & ' diff-1 ',8I8,/,' low ',8I8,/,' high ',8I8,/,
27569 & ' h-diff',8I8,/,' diff-2 ',8I8,/,' low ',8I8,/,
27570 & ' high ',8I8,/,' h-diff',8I8,/,' dbl-di.',8I8,/,
27571 & ' lo-lo ',8I8,/,' hi-hi ',8I8,/,' lo-hi ',8I8,/,
27573 & ' dir-ga.',8I8,/,/,' dir-1 ',8I8,/,' dir-2 ',8I8,/,
27574 & ' dbl-dir',8I8,/,' s-Pom. ',8I8,/,' h-Pom. ',8I8,/,
27575 & ' s-Reg. ',8I8,/,' enh-trg',8I8,/,' enh-log',8I8)
27577 1013 FORMAT(/,1X,'2. chain system statistics -',
27578 & ' mean numbers per evt:',/,30X,'---------------------',
27579 & /,/,16X,'s-s',7X,'d-s',7X,'s-d')
27580 IF (ICSAMP.GT.0) THEN
27582 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=0,1),
27583 & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=1,3),
27584 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=2,18)
27585 1014 FORMAT(/,1X,'req.to. ',3E10.2,/,/,1X,'low rq. ',3E10.2,/,
27586 & 1X,'low ac. ',3E10.2,/,/,1X,'PHOJET ',3E10.2,/,/,
27587 & ' no-dif. ',3E10.2,/,' el-sca. ',3E10.2,/,
27588 & ' qel-sc. ',3E10.2,/,' dbl-Po. ',3E10.2,/,
27589 & ' diff-1 ',3E10.2,/,' diff-2 ',3E10.2,/,
27590 & ' dbl-di. ',3E10.2,/,' dir-ga. ',3E10.2,/,/,
27591 & ' dir-1 ',3E10.2,/,' dir-2 ',3E10.2,/,
27592 & ' dbl-dir ',3E10.2,/,' s-Pom. ',3E10.2,/,
27593 & ' h-Pom. ',3E10.2,/,' s-Reg. ',3E10.2,/,
27594 & ' enh-trg ',3E10.2,/,' enh-log ',3E10.2)
27597 1015 FORMAT(/,16X,'s-v',7X,'d-v',7X,'v-s',7X,'v-d',7X,'v-v')
27598 IF (ICSAMP.GT.0) THEN
27600 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=0,1),
27601 & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=4,8),
27602 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=2,18)
27603 1016 FORMAT(/,1X,'req.to. ',5E10.2,/,/,1X,'low rq. ',5E10.2,/,
27604 & 1X,'low ac. ',5E10.2,/,/,1X,'PHOJET ',5E10.2,/,/,
27605 & ' no-dif. ',5E10.2,/,' el-sca. ',5E10.2,/,
27606 & ' qel-sc. ',5E10.2,/,' dbl-Po. ',5E10.2,/,
27607 & ' diff-1 ',5E10.2,/,' diff-2 ',5E10.2,/,
27608 & ' dbl-di. ',5E10.2,/,' dir-ga. ',5E10.2,/,/,
27609 & ' dir-1 ',5E10.2,/,' dir-2 ',5E10.2,/,
27610 & ' dbl-dir ',5E10.2,/,' s-Pom. ',5E10.2,/,
27611 & ' h-Pom. ',5E10.2,/,' s-Reg. ',5E10.2,/,
27612 & ' enh-trg ',5E10.2,/,' enh-log ',5E10.2)
27618 IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
27619 & .OR.(PDBSEA(3).GT.0.0D0)) THEN
27620 WRITE(LOUT,*)'YGS1S,YGS2S,YUS1S,YUS2S',
27621 & DBRKA(1,1)+DBRKA(2,1),DBRKA(1,2)+DBRKA(2,2),
27622 & DBRKA(1,3)+DBRKA(2,3),DBRKA(1,4)+DBRKA(2,4)
27623 WRITE(LOUT,*)'YGS1R,YGS2R,YUS1R,YUS2R',
27624 & DBRKR(1,1)+DBRKR(2,1),DBRKR(1,2)+DBRKR(2,2),
27625 & DBRKR(1,3)+DBRKR(2,3),DBRKR(1,4)+DBRKR(2,4)
27626 WRITE(LOUT,*)'YGSA1S,YGSA2S,YUSA1S,YUSA2S',
27627 & DBRKA(1,5)+DBRKA(2,5),DBRKA(1,6)+DBRKA(2,6),
27628 & DBRKA(1,7)+DBRKA(2,7),DBRKA(1,8)+DBRKA(2,8)
27629 WRITE(LOUT,*)'YGSA1R,YGSA2R,YUSA1R,YUSA2R',
27630 & DBRKR(1,5)+DBRKR(2,5),DBRKR(1,6)+DBRKR(2,6),
27631 & DBRKR(1,7)+DBRKR(2,7),DBRKR(1,8)+DBRKR(2,8)
27632 WRITE(LOUT,*)'YG31S,YG32S,YU31S,YU32S',
27633 & DBRKA(3,1),DBRKA(3,2),
27634 & DBRKA(3,3),DBRKA(3,4)
27635 WRITE(LOUT,*)'YG31R,YG32R,YU31R,YU32R',
27636 & DBRKR(3,1),DBRKR(3,2),
27637 & DBRKR(3,3),DBRKR(3,4)
27638 WRITE(LOUT,*)'YG3A1S,YG3A2S,YU3A1S,YU3A2S',
27639 & DBRKA(3,5),DBRKA(3,6),
27640 & DBRKA(3,7),DBRKA(3,8)
27641 WRITE(LOUT,*)'YG3A1R,YG3A2R,YU3A1R,YU3A2R',
27642 & DBRKR(3,5),DBRKR(3,6),
27643 & DBRKR(3,7),DBRKR(3,8)
27647 IF (MCGENE.EQ.2) THEN
27649 C CALL PHO_PHIST(-2,SIGMAX)
27650 CALL PHO_EVENT(-2,PP,PT,FAC,IREJ1)
27659 *$ CREATE DT_EVTOUT.FOR
27662 *===evtout=============================================================*
27664 SUBROUTINE DT_EVTOUT(MODE)
27666 ************************************************************************
27667 * MODE = 1 plot content of complete DTEVT1 to out. unit *
27668 * 3 plot entries of extended DTEVT1 (DTEVT2) *
27669 * 4 plot entries of DTEVT1 and DTEVT2 *
27670 * This version dated 11.12.94 is written by S. Roesler *
27671 ************************************************************************
27673 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27676 PARAMETER ( LINP = 10 ,
27682 PARAMETER (NMXHKK=200000)
27684 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27685 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27686 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27688 DIMENSION IRANGE(NMXHKK)
27690 IF (MODE.EQ.2) RETURN
27692 CALL DT_EVTPLO(IRANGE,MODE)
27697 *$ CREATE DT_EVTPLO.FOR
27700 *===evtplo=============================================================*
27702 SUBROUTINE DT_EVTPLO(IRANGE,MODE)
27704 ************************************************************************
27705 * MODE = 1 plot content of complete DTEVT1 to out. unit *
27706 * 2 plot entries of DTEVT1 given by IRANGE *
27707 * 3 plot entries of extended DTEVT1 (DTEVT2) *
27708 * 4 plot entries of DTEVT1 and DTEVT2 *
27709 * 5 plot rejection counter *
27710 * This version dated 11.12.94 is written by S. Roesler *
27711 ************************************************************************
27713 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27716 PARAMETER ( LINP = 10 ,
27724 PARAMETER (NMXHKK=200000)
27726 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27727 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27728 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27730 * extended event history
27731 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27732 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27735 * rejection counter
27736 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27737 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27738 & IREXCI(3),IRDIFF(2),IRINC
27740 DIMENSION IRANGE(NMXHKK)
27742 IF ((MODE.EQ.1).OR.(MODE.EQ.4)) THEN
27744 1000 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTEVT1/',/,
27745 & 15X,' --------------------------',/,/,
27746 & ' ST ID M1 M2 D1 D2 PX PY',
27749 WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27750 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27751 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
27753 C WRITE(LOUT,1011) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27754 C & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27755 C & PHKK(3,I),PHKK(4,I)
27756 C WRITE(LOUT,'(4E15.4)')
27757 C & VHKK(1,I),VHKK(2,I),VHKK(3,I),VHKK(4,I)
27758 1001 FORMAT(I5,I5,I6,4I5,3F7.3,F8.3,F8.4)
27759 1011 FORMAT(I5,I5,I6,4I5,2E15.5)
27763 C WRITE(LOUT,1006) I,ISTHKK(I),
27764 C & VHKK(1,I),VHKK(2,I),VHKK(3,I),WHKK(1,I),
27765 C & WHKK(2,I),WHKK(3,I)
27766 C1006 FORMAT(1X,I4,I6,6E10.3)
27770 IF (MODE.EQ.2) THEN
27775 IF (IRANGE(NC).EQ.-100) GOTO 9999
27777 WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27778 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27779 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
27784 IF ((MODE.EQ.3).OR.(MODE.EQ.4)) THEN
27786 1002 FORMAT(/,1X,'EVTPLO:',14X,
27787 & ' content of COMMON /DTEVT1/,/DTEVT2/',/,
27788 & 15X,' -----------------------------------',/,/,
27789 & ' ST ID M1 M2 D1 D2 IDR IDXR',
27790 & ' NOBAM IDCH M',/)
27792 C IF ((ISTHKK(I).GT.10).OR.(ISTHKK(I).EQ.1)) THEN
27795 IF ((((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
27796 & (KF.NE.80000)).OR.(IDHKK(I).EQ.99999)) KF = 92
27798 CALL PYNAME(KF,CHAU)
27800 WRITE(LOUT,1003) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27801 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27802 & IDRES(I),IDXRES(I),NOBAM(I),IDCH(I),
27804 1003 FORMAT(I5,I5,I6,4I5,4I4,F8.4,2X,A)
27809 IF (MODE.EQ.5) THEN
27811 1004 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTREJC/',/,
27812 & 15X,' --------------------------',/)
27813 WRITE(LOUT,1005) IRPT,IRHHA,IRRES,LOMRES,LOBRES,IREMC,IRFRAG,
27815 1005 FORMAT(1X,'IRPT = ',I5,' IRHHA = ',I5,/,
27816 & 1X,'IRRES = ',2I5,' LOMRES = ',I5,' LOBRES = ',I5,/,
27817 & 1X,'IREMC = ',10I5,/,
27818 & 1X,'IRFRAG = ',I5,' IRSEA = ',I5,' IRCRON = ',I5,/)
27824 *$ CREATE DT_EVTPUT.FOR
27827 *===evtput=============================================================*
27829 SUBROUTINE DT_EVTPUT(IST,ID,M1,M2,PX,PY,PZ,E,IDR,IDXR,IDC)
27831 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27834 PARAMETER ( LINP = 10 ,
27838 PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,TINY3=1.0D-3,
27839 & TINY2=1.0D-2,SQTINF=1.0D+15,ZERO=0.0D0)
27843 PARAMETER (NMXHKK=200000)
27845 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27846 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27847 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27849 * extended event history
27850 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27851 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27854 * Lorentz-parameters of the current interaction
27855 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
27856 & UMO,PPCM,EPROJ,PPROJ
27858 * particle properties (BAMJET index convention)
27860 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
27861 & IICH(210),IIBAR(210),K1(210),K2(210)
27863 C IF (MODE.GT.100) THEN
27864 C WRITE(LOUT,'(1X,A,I5,A,I5)')
27865 C & 'EVTPUT: reset NHKK = ',NHKK,' to NHKK =',NHKK-MODE+100
27866 C NHKK = NHKK-MODE+100
27873 IF (NHKK.GT.NMXHKK) THEN
27874 WRITE(LOUT,1000) NHKK
27875 1000 FORMAT(1X,'EVTPUT: NHKK exeeds NMXHKK = ',I7,
27876 & '! program execution stopped..')
27879 IF (M1.LT.0) MO1 = NHKK+M1
27880 IF (M2.LT.0) MO2 = NHKK+M2
27883 JMOHKK(1,NHKK) = MO1
27884 JMOHKK(2,NHKK) = MO2
27888 IDXRES(NHKK) = IDXR
27890 ** here we need to do something..
27891 IF (ID.EQ.88888) THEN
27892 IDMO1 = ABS(IDHKK(MO1))
27893 IDMO2 = ABS(IDHKK(MO2))
27894 IF ((IDMO1.LT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 3
27895 IF ((IDMO1.LT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 4
27896 IF ((IDMO1.GT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 5
27897 IF ((IDMO1.GT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 6
27901 IDBAM(NHKK) = IDT_ICIHAD(ID)
27903 IF (JDAHKK(1,MO1).NE.0) THEN
27904 JDAHKK(2,MO1) = NHKK
27906 JDAHKK(1,MO1) = NHKK
27910 IF (JDAHKK(1,MO2).NE.0) THEN
27911 JDAHKK(2,MO2) = NHKK
27913 JDAHKK(1,MO2) = NHKK
27916 C IF ((IDBAM(NHKK).GT.0).AND.(IDBAM(NHKK).NE.7)) THEN
27917 C PTOT = SQRT(PX**2+PY**2+PZ**2)
27918 C AM0 = SQRT(ABS( (E-PTOT)*(E+PTOT) ))
27919 C AMRQ = AAM(IDBAM(NHKK))
27920 C AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
27921 C IF ((ABS(AMDIF2).GT.TINY3).AND.(E.LT.SQTINF).AND.
27922 C & (PTOT.GT.ZERO)) THEN
27923 C DELTA = -AMDIF2/(2.0D0*(E+PTOT))
27924 CC DELTA = (AMRQ2-AM2)/(2.0D0*(E+PTOT))
27926 C PTOT1 = PTOT-DELTA
27927 C PX = PX*PTOT1/PTOT
27928 C PY = PY*PTOT1/PTOT
27929 C PZ = PZ*PTOT1/PTOT
27936 PTOT = SQRT( PX**2+PY**2+PZ**2 )
27937 IF ((IDHKK(NHKK).GE.22).AND.(IDHKK(NHKK).LE.24)) THEN
27938 PHKK(5,NHKK) = PHKK(4,NHKK)**2-PTOT**2
27939 PHKK(5,NHKK) = SIGN(SQRT(ABS(PHKK(5,NHKK))),PHKK(5,NHKK))
27941 PHKK(5,NHKK) = (PHKK(4,NHKK)-PTOT)*(PHKK(4,NHKK)+PTOT)
27942 C IF ((PHKK(5,NHKK).LT.0.0D0).AND.(ABS(PHKK(5,NHKK)).GT.TINY4))
27943 C & WRITE(LOUT,'(1X,A,G10.3)')
27944 C & 'EVTPUT: negative mass**2 ',PHKK(5,NHKK)
27945 PHKK(5,NHKK) = SQRT(ABS(PHKK(5,NHKK)))
27948 IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.(ID.NE.80000)) THEN
27949 * special treatment for chains:
27950 * z coordinate of chain in Lab = pos. of target nucleon
27951 * time of chain-creation in Lab = time of passage of projectile
27952 * nucleus at pos. of taget nucleus
27953 C VHKK(1,NHKK) = 0.5D0*(VHKK(1,MO1)+VHKK(1,MO2))
27954 C VHKK(2,NHKK) = 0.5D0*(VHKK(2,MO1)+VHKK(2,MO2))
27955 VHKK(1,NHKK) = VHKK(1,MO2)
27956 VHKK(2,NHKK) = VHKK(2,MO2)
27957 VHKK(3,NHKK) = VHKK(3,MO2)
27958 VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
27959 C WHKK(1,NHKK) = 0.5D0*(WHKK(1,MO1)+WHKK(1,MO2))
27960 C WHKK(2,NHKK) = 0.5D0*(WHKK(2,MO1)+WHKK(2,MO2))
27961 WHKK(1,NHKK) = WHKK(1,MO1)
27962 WHKK(2,NHKK) = WHKK(2,MO1)
27963 WHKK(3,NHKK) = WHKK(3,MO1)
27964 WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
27968 VHKK(I,NHKK) = VHKK(I,MO1)
27969 WHKK(I,NHKK) = WHKK(I,MO1)
27973 VHKK(I,NHKK) = ZERO
27974 WHKK(I,NHKK) = ZERO
27982 *$ CREATE DT_CHASTA.FOR
27985 *===chasta=============================================================*
27987 SUBROUTINE DT_CHASTA(MODE)
27989 ************************************************************************
27990 * This subroutine performs CHAin STAtistics and checks sequence of *
27991 * partons in dtevt1 and sorts them with projectile partons coming *
27992 * first if necessary. *
27994 * This version dated 8.5.00 is written by S. Roesler. *
27995 ************************************************************************
27997 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28000 PARAMETER ( LINP = 10 ,
28008 PARAMETER (NMXHKK=200000)
28010 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28011 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28012 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28014 * extended event history
28015 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28016 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28019 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
28020 PARAMETER (MAXCHN=10000)
28021 COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
28023 DIMENSION ICHCFG(10,10,9,2),ICHTYP(5,5),
28024 & CCHTYP(9),ICHSTA(10),ITOT(10)
28025 DATA ICHCFG /1800*0/
28026 DATA (ICHTYP(1,K),K=1,5) / 0, 1, 3, 0, 0/
28027 DATA (ICHTYP(2,K),K=1,5) / 2, 0, 0, 5, 0/
28028 DATA (ICHTYP(3,K),K=1,5) / 4, 0, 0, 7, 0/
28029 DATA (ICHTYP(4,K),K=1,5) / 0, 6, 8, 0, 0/
28030 DATA (ICHTYP(5,K),K=1,5) / 0, 0, 0, 0, 9/
28031 DATA ICHSTA / 21, 22, 31, 32, 41, 42, 51, 52, 61, 62/
28032 DATA CCHTYP / ' q aq','aq q ',' q d ',' d q ','aq ad',
28033 & 'ad aq',' d ad','ad d ',' g g '/
28037 IF (MODE.EQ.-1) THEN
28040 * loop over DTEVT1 and analyse chain configurations
28042 ELSEIF (MODE.EQ.0) THEN
28043 DO 21 IDX=NPOINT(3),NHKK
28044 IDCHK = IDHKK(IDX)/10000
28045 IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
28046 & (IDHKK(IDX).NE.80000).AND.
28047 & (ISTHKK(IDX).NE.2).AND.(IDRES(IDX).EQ.0)) THEN
28048 IF (JMOHKK(1,IDX).GT.JMOHKK(2,IDX)) THEN
28049 WRITE(LOUT,*) ' CHASTA: JMOHKK(1,x) > JMOHKK(2,x) ',
28054 IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28055 IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28057 IMO1 = IST1-10*IMO1
28059 IMO2 = IST2-10*IMO2
28060 * swop parton entries if necessary since we need projectile partons
28061 * to come first in the common
28062 IF (IMO1.GT.IMO2) THEN
28063 NPTN = JMOHKK(2,IDX)-JMOHKK(1,IDX)+1
28065 I0 = JMOHKK(1,IDX)-1+K
28066 I1 = JMOHKK(2,IDX)+1-K
28068 ISTHKK(I0) = ISTHKK(I1)
28071 IDHKK(I0) = IDHKK(I1)
28073 IF (JDAHKK(1,JMOHKK(1,I0)).EQ.I0)
28074 & JDAHKK(1,JMOHKK(1,I0)) = I1
28075 IF (JDAHKK(2,JMOHKK(1,I0)).EQ.I0)
28076 & JDAHKK(2,JMOHKK(1,I0)) = I1
28077 IF (JDAHKK(1,JMOHKK(2,I0)).EQ.I0)
28078 & JDAHKK(1,JMOHKK(2,I0)) = I1
28079 IF (JDAHKK(2,JMOHKK(2,I0)).EQ.I0)
28080 & JDAHKK(2,JMOHKK(2,I0)) = I1
28081 IF (JDAHKK(1,JMOHKK(1,I1)).EQ.I1)
28082 & JDAHKK(1,JMOHKK(1,I1)) = I0
28083 IF (JDAHKK(2,JMOHKK(1,I1)).EQ.I1)
28084 & JDAHKK(2,JMOHKK(1,I1)) = I0
28085 IF (JDAHKK(1,JMOHKK(2,I1)).EQ.I1)
28086 & JDAHKK(1,JMOHKK(2,I1)) = I0
28087 IF (JDAHKK(2,JMOHKK(2,I1)).EQ.I1)
28088 & JDAHKK(2,JMOHKK(2,I1)) = I0
28089 ITMP = JMOHKK(1,I0)
28090 JMOHKK(1,I0) = JMOHKK(1,I1)
28091 JMOHKK(1,I1) = ITMP
28092 ITMP = JMOHKK(2,I0)
28093 JMOHKK(2,I0) = JMOHKK(2,I1)
28094 JMOHKK(2,I1) = ITMP
28095 ITMP = JDAHKK(1,I0)
28096 JDAHKK(1,I0) = JDAHKK(1,I1)
28097 JDAHKK(1,I1) = ITMP
28098 ITMP = JDAHKK(2,I0)
28099 JDAHKK(2,I0) = JDAHKK(2,I1)
28100 JDAHKK(2,I1) = ITMP
28105 PHKK(J,I0) = PHKK(J,I1)
28106 VHKK(J,I0) = VHKK(J,I1)
28107 WHKK(J,I0) = WHKK(J,I1)
28113 PHKK(5,I0) = PHKK(5,I1)
28116 IDRES(I0) = IDRES(I1)
28119 IDXRES(I0) = IDXRES(I1)
28122 NOBAM(I0) = NOBAM(I1)
28125 IDBAM(I0) = IDBAM(I1)
28128 IDCH(I0) = IDCH(I1)
28131 IHIST(1,I0) = IHIST(1,I1)
28134 IHIST(2,I0) = IHIST(2,I1)
28138 IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28139 IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28141 * parton 1 (projectile side)
28142 IF (IST1.EQ.21) THEN
28144 ELSEIF (IST1.EQ.22) THEN
28146 ELSEIF (IST1.EQ.31) THEN
28148 ELSEIF (IST1.EQ.32) THEN
28150 ELSEIF (IST1.EQ.41) THEN
28152 ELSEIF (IST1.EQ.42) THEN
28154 ELSEIF (IST1.EQ.51) THEN
28156 ELSEIF (IST1.EQ.52) THEN
28158 ELSEIF (IST1.EQ.61) THEN
28160 ELSEIF (IST1.EQ.62) THEN
28164 c & ' CHASTA: unknown parton status flag (',
28165 c & IST1,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28168 ID = IDHKK(JMOHKK(1,IDX))
28169 IF (ABS(ID).LE.4) THEN
28175 ELSEIF (ABS(ID).GE.1000) THEN
28181 ELSEIF (ID.EQ.21) THEN
28185 & ' CHASTA: inconsistent parton identity (',
28186 & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28190 * parton 2 (target side)
28191 IF (IST2.EQ.21) THEN
28193 ELSEIF (IST2.EQ.22) THEN
28195 ELSEIF (IST2.EQ.31) THEN
28197 ELSEIF (IST2.EQ.32) THEN
28199 ELSEIF (IST2.EQ.41) THEN
28201 ELSEIF (IST2.EQ.42) THEN
28203 ELSEIF (IST2.EQ.51) THEN
28205 ELSEIF (IST2.EQ.52) THEN
28207 ELSEIF (IST2.EQ.61) THEN
28209 ELSEIF (IST2.EQ.62) THEN
28213 c & ' CHASTA: unknown parton status flag (',
28214 c & IST2,') at entry ',JMOHKK(2,IDX),'(',IDX,')'
28217 ID = IDHKK(JMOHKK(2,IDX))
28218 IF (ABS(ID).LE.4) THEN
28224 ELSEIF (ABS(ID).GE.1000) THEN
28230 ELSEIF (ID.EQ.21) THEN
28234 & ' CHASTA: inconsistent parton identity (',
28235 & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28240 ITYPE = ICHTYP(ITYP1,ITYP2)
28241 IF (ITYPE.NE.0) THEN
28242 ICHCFG(IDX1,IDX2,ITYPE,1) =ICHCFG(IDX1,IDX2,ITYPE,1)+1
28243 NGLUON = JMOHKK(2,IDX)-JMOHKK(1,IDX)-1
28244 ICHCFG(IDX1,IDX2,ITYPE,2) =
28245 & ICHCFG(IDX1,IDX2,ITYPE,2)+NGLUON
28248 IF (NCHAIN.GT.MAXCHN) THEN
28249 WRITE(LOUT,*) ' CHASTA: NCHAIN > MAXCHN ! ',
28253 IDXCHN(1,NCHAIN) = IDX
28254 IDXCHN(2,NCHAIN) = ITYPE
28257 & ' CHASTA: inconsistent chain at entry ',IDX
28263 * write statistics to output unit
28265 ELSEIF (MODE.EQ.1) THEN
28266 WRITE(LOUT,'(/,A)') ' CHASTA: generated chain configurations'
28268 WRITE(LOUT,'(/,2A)')
28269 & ' -----------------------------------------',
28270 & '------------------------------------'
28272 & ' p\\t 21 22 31 32 41',
28273 & ' 42 51 52 61 62'
28275 & ' -----------------------------------------',
28276 & '------------------------------------'
28280 ITOT(J) = ITOT(J)+ICHCFG(I,J,K,1)
28283 WRITE(LOUT,'(1X,I2,5X,10I7,/)') ICHSTA(I),(ITOT(J),J=1,10)
28287 ISUM = ISUM+ICHCFG(I,J,K,1)
28290 & WRITE(LOUT,'(1X,A5,2X,10I7)')
28291 & CCHTYP(K),(ICHCFG(I,J,K,1),J=1,10)
28293 C WRITE(LOUT,'(2A)')
28294 C & ' -----------------------------------------',
28295 C & '-------------------------------'
28299 WRITE(LOUT,*) ' CHASTA: MODE ',MODE,' not supported !'
28305 *$ CREATE PHO_PHIST.FOR
28308 *===pohist=============================================================*
28310 SUBROUTINE PHO_PHIST(IMODE,WEIGHT)
28312 IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28315 PARAMETER ( LINP = 10 ,
28319 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
28321 * Glauber formalism: cross sections
28322 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
28323 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
28324 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
28325 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
28326 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
28327 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
28328 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
28329 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
28330 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
28331 & BSLOPE,NEBINI,NQBINI
28334 IF (IMODE.EQ.10) THEN
28338 IF (ABS(IMODE).LT.1000) THEN
28339 * PHOJET-statistics
28340 C CALL POHISX(IMODE,WEIGHT)
28341 IF (IMODE.EQ.-1) THEN
28343 XSTOT(1,1,1) = WEIGHT
28345 IF (IMODE.EQ. 1) MODE = 2
28346 IF (IMODE.EQ.-2) MODE = 3
28347 IF (MODE.EQ.2) CALL DT_SWPPHO(ILAB)
28348 C IF (MODE.EQ.3) WRITE(LOUT,*)
28349 C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization'
28350 CALL DT_HISTOG(MODE)
28351 CALL DT_USRHIS(MODE)
28353 * DTUNUC-statistics
28355 C IF (MODE.EQ.3) WRITE(LOUT,*)
28356 C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization'
28357 CALL DT_HISTOG(MODE)
28358 CALL DT_USRHIS(MODE)
28364 *$ CREATE DT_SWPPHO.FOR
28367 *===swppho=============================================================*
28369 SUBROUTINE DT_SWPPHO(ILAB)
28371 IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28374 PARAMETER ( LINP = 10 ,
28378 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28384 PARAMETER (NMXHKK=200000)
28386 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28387 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28388 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28390 * extended event history
28391 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28392 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28395 * flags for input different options
28396 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28397 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28398 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28400 * properties of photon/lepton projectiles
28401 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
28404 C PARAMETER (NMXHEP=2000)
28405 C COMMON/HEPEVS/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28406 C &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
28407 C COMMON /GLOCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28408 C COMMON /PLASAV/ PLAB
28410 C standard particle data interface
28413 PARAMETER (NMXHEP=4000)
28415 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28416 DOUBLE PRECISION PHEP,VHEP
28417 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28418 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28420 C extension to standard particle data interface (PHOJET specific)
28421 INTEGER IMPART,IPHIST,ICOLOR
28422 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28424 C global event kinematics and particle IDs
28425 INTEGER IFPAP,IFPAB
28426 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
28427 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28431 DATA LSTART /.TRUE./
28433 C IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0).AND.LSTART) THEN
28434 IF ((IFRAME.EQ.1).AND.LSTART) THEN
28438 IDP = IDT_ICIHAD(IFPAP(1))
28439 IDT = IDT_ICIHAD(IFPAP(2))
28441 CALL DT_LTINI(IDP,IDT,ELA,PLA,UMO,0)
28450 IF (MOD(ICOUNT,500).EQ.0) WRITE(LOUT,*)' SWPPHO: event # ',ICOUNT
28452 IF (ISTHEP(I).EQ.1) THEN
28455 IDHKK(NHKK) = IDHEP(I)
28461 PHKK(K,NHKK) = PHEP(K,I)
28462 VHKK(K,NHKK) = ZERO
28463 WHKK(K,NHKK) = ZERO
28465 IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0))
28466 & CALL DT_LTNUC(PHEP(3,I),PHEP(4,I),
28467 & PHKK(3,NHKK),PHKK(4,NHKK),-3)
28468 PHKK(5,NHKK) = PHEP(5,I)
28472 IDBAM(NHKK) = IDT_ICIHAD(IDHEP(I))
28480 *$ CREATE DT_HISTOG.FOR
28483 *===histog=============================================================*
28485 SUBROUTINE DT_HISTOG(MODE)
28487 ************************************************************************
28488 * This version dated 25.03.96 is written by S. Roesler *
28489 ************************************************************************
28491 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28494 PARAMETER ( LINP = 10 ,
28502 PARAMETER (NMXHKK=200000)
28504 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28505 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28506 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28508 * extended event history
28509 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28510 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28513 * event flag used for histograms
28514 COMMON /DTNORM/ ICEVT,IEVHKK
28516 * flags for activated histograms
28517 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
28522 *------------------------------------------------------------------
28526 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,1)
28527 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(1)
28530 *------------------------------------------------------------------
28531 * filling of histogram with event-record
28536 CALL DT_SWPFSP(I,LFSP,LRNL)
28538 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,2)
28539 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(2)
28541 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,5)
28543 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,4)
28546 *------------------------------------------------------------------
28549 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,3)
28550 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(3)
28555 *$ CREATE DT_SWPFSP.FOR
28558 *===swpfsp=============================================================*
28560 SUBROUTINE DT_SWPFSP(IDX,LFSP,LRNL)
28562 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28564 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28565 PARAMETER (TWOPI=6.283185307179586476925286766559D+00,
28567 & BOG =TWOPI/360.0D0)
28571 PARAMETER (NMXHKK=200000)
28573 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28574 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28575 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28577 * extended event history
28578 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28579 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28582 * particle properties (BAMJET index convention)
28584 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28585 & IICH(210),IIBAR(210),K1(210),K2(210)
28587 * Lorentz-parameters of the current interaction
28588 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28589 & UMO,PPCM,EPROJ,PPROJ
28591 * flags for input different options
28592 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28593 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28594 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28596 * INCLUDE '(DIMPAR)'
28598 PARAMETER ( MXXRGN =20000 )
28599 PARAMETER ( MXXMDF = 710 )
28600 PARAMETER ( MXXMDE = 702 )
28601 PARAMETER ( MFSTCK =40000 )
28602 PARAMETER ( MESTCK = 100 )
28603 PARAMETER ( MOSTCK = 2000 )
28604 PARAMETER ( MXPRSN = 100 )
28605 PARAMETER ( MXPDPM = 800 )
28606 PARAMETER ( MXPSCS =30000 )
28607 PARAMETER ( MXGLWN = 300 )
28608 PARAMETER ( MXOUTU = 50 )
28609 PARAMETER ( NALLWP = 64 )
28610 PARAMETER ( NELEMX = 80 )
28611 PARAMETER ( MPDPDX = 18 )
28612 PARAMETER ( MXHTTR = 260 )
28613 PARAMETER ( MXSEAX = 20 )
28614 PARAMETER ( MXHTNC = MXSEAX + 1 )
28615 PARAMETER ( ICOMAX = 2400 )
28616 PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
28617 PARAMETER ( NSTBIS = 304 )
28618 PARAMETER ( NQSTIS = 46 )
28619 PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
28620 PARAMETER ( MXPABL = 120 )
28621 PARAMETER ( IDMAXP = 450 )
28622 PARAMETER ( IDMXDC = 2000 )
28623 PARAMETER ( MXMCIN = 410 )
28624 PARAMETER ( IHYPMX = 4 )
28625 PARAMETER ( MKBMX1 = 11 )
28626 PARAMETER ( MKBMX2 = 11 )
28627 PARAMETER ( MXIRRD = 2500 )
28628 PARAMETER ( MXTRDC = 1500 )
28629 PARAMETER ( NKTL = 17 )
28630 PARAMETER ( NBLNMX = 40000000 )
28632 * INCLUDE '(PAREVT)'
28634 PARAMETER ( FRDIFF = 0.2D+00 )
28635 PARAMETER ( ETHSEA = 1.0D+00 )
28637 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
28638 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
28639 & LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR,
28640 & LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
28641 COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
28642 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
28643 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
28644 & LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LPHDRC,
28645 & LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, LRVKIN,
28646 & LVP2XX, LV2XNW, LNWV2X, LEVFIN
28648 * temporary storage for one final state particle
28649 LOGICAL LFRAG,LGREY,LBLACK
28650 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
28651 & SINTHE,COSTHE,THETA,THECMS,
28652 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
28653 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
28654 & LFRAG,LGREY,LBLACK
28662 IF (LEVPRT) ISTRNL = 1001
28664 IF (ABS(ISTHKK(IDX)).EQ.1) THEN
28668 IF (IDHKK(IDX).LT.80000) THEN
28670 IBARY = IIBAR(IDBJT)
28671 ICHAR = IICH(IDBJT)
28673 ELSEIF (IDHKK(IDX).EQ.80000) THEN
28676 ICHAR = IDXRES(IDX)
28677 AMASS = PHKK(5,IDX)
28679 IF ((ICHAR.EQ.1).AND.(INUT.EQ.1)) IDBJT = 116
28680 IF ((ICHAR.EQ.1).AND.(INUT.EQ.2)) IDBJT = 117
28681 IF ((ICHAR.EQ.2).AND.(INUT.EQ.1)) IDBJT = 118
28682 IF ((ICHAR.EQ.2).AND.(INUT.EQ.2)) IDBJT = 119
28683 IF (IDBJT.EQ.0) LFRAG = .TRUE.
28693 PTOT = SQRT(PT2+PZ**2)
28694 SINTHE = PT/MAX(PTOT,TINY14)
28695 COSTHE = PZ/MAX(PTOT,TINY14)
28696 IF (COSTHE.GT.ONE) THEN
28698 ELSEIF (COSTHE.LT.-ONE) THEN
28699 THETA = TWOPI/2.0D0
28701 THETA = ACOS(COSTHE)
28704 **sr 15.4.96 new E_t-definition
28705 IF (IBARY.GT.0) THEN
28707 ELSEIF (IBARY.LT.0) THEN
28708 ET = (EKIN+TWO*AMASS)*SINTHE
28713 XLAB = PZ/MAX(PPROJ,TINY14)
28714 C XLAB = PE/MAX(EPROJ,TINY14)
28715 BETA = SQRT(ABS( (ONE-AMASS/MAX(PE,TINY14))
28716 & *(ONE+AMASS/MAX(PE,TINY14)) ))
28719 IF (PMINUS.GT.TINY14) THEN
28720 YY = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28724 IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
28725 ETA = -LOG(TAN(THETA/TWO))
28729 IF (IFRAME.EQ.1) THEN
28730 CALL DT_LTNUC(PZ,PE,PZCMS,EECMS,3)
28731 PPLUS = EECMS+PZCMS
28732 PMINUS = EECMS-PZCMS
28733 IF ((PPLUS*PMINUS).GT.TINY14) THEN
28734 YYCMS = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28738 PTOTCM = SQRT(PT2+PZCMS**2)
28739 COSTH = PZCMS/MAX(PTOTCM,TINY14)
28740 IF (COSTH.GT.ONE) THEN
28742 ELSEIF (COSTH.LT.-ONE) THEN
28743 THECMS = TWOPI/2.0D0
28745 THECMS = ACOS(COSTH)
28747 IF ((THECMS.GT.TINY14).AND.((PI-THECMS).GT.TINY14)) THEN
28748 ETACMS = -LOG(TAN(THECMS/TWO))
28752 XF = PZCMS/MAX(PPCM,TINY14)
28753 THECMS = THECMS/BOG
28764 * set flag for "grey/black"
28768 IF (IDHKK(IDX).EQ.80000) EK = EKIN/DBLE(IBARY)
28769 IF (MULDEF.EQ.1) THEN
28771 IF ( ( (IDBJT.EQ. 1).AND.(EK.GT. 26.0D-3).AND.
28772 & (EK.LE.375.0D-3) ).OR.
28773 & ( (IDBJT.EQ.13).AND.(EK.GT. 12.0D-3).AND.
28774 & (EK.LE. 56.0D-3) ).OR.
28775 & ( (IDBJT.EQ.14).AND.(EK.GT. 12.0D-3).AND.
28776 & (EK.LE. 56.0D-3) ).OR.
28777 & ( (IDBJT.EQ.15).AND.(EK.GT. 20.0D-3).AND.
28778 & (EK.LE.198.0D-3) ).OR.
28779 & ( (IDBJT.EQ.16).AND.(EK.GT. 20.0D-3).AND.
28780 & (EK.LE.198.0D-3) ).OR.
28781 & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28782 & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28783 & (IDBJT.NE.16).AND.
28784 & (BETA.GT.0.23D0).AND.(BETA.LE.0.70D0) ) )
28786 IF ( ( (IDBJT.EQ. 1).AND.(EK.LE. 26.0D-3) ).OR.
28787 & ( (IDBJT.EQ.13).AND.(EK.LE. 12.0D-3) ).OR.
28788 & ( (IDBJT.EQ.14).AND.(EK.LE. 12.0D-3) ).OR.
28789 & ( (IDBJT.EQ.15).AND.(EK.LE. 20.0D-3) ).OR.
28790 & ( (IDBJT.EQ.16).AND.(EK.LE. 20.0D-3) ).OR.
28791 & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28792 & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28793 & (IDBJT.NE.16).AND.(BETA.LE.0.23D0) ) )
28797 IF ((BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)) LGREY=.TRUE.
28798 IF (BETA.LE.0.23D0) LBLACK=.TRUE.
28801 ELSEIF (ABS(ISTHKK(IDX)).EQ.ISTRNL) THEN
28807 ICHAR = IDXRES(IDX)
28808 AMASS = PHKK(5,IDX)
28815 PTOT = SQRT(PT2+PZ**2)
28816 SINTHE = PT/MAX(PTOT,TINY14)
28817 COSTHE = PZ/MAX(PTOT,TINY14)
28818 IF (COSTHE.GT.ONE) THEN
28820 ELSEIF (COSTHE.LT.-ONE) THEN
28821 THETA = TWOPI/2.0D0
28823 THETA = ACOS(COSTHE)
28826 **sr 15.4.96 new E_t-definition
28830 IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
28831 ETA = -LOG(TAN(THETA/TWO))
28843 *$ CREATE DT_HIMULT.FOR
28846 *===himult=============================================================*
28848 SUBROUTINE DT_HIMULT(MODE)
28850 ************************************************************************
28851 * Tables of average energies/multiplicities. *
28852 * This version dated 30.08.2000 is written by S. Roesler *
28853 ************************************************************************
28855 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28858 PARAMETER ( LINP = 10 ,
28862 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28864 PARAMETER (SWMEXP=1.7D0)
28866 CHARACTER*8 ANAMEH(4)
28868 * particle properties (BAMJET index convention)
28870 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28871 & IICH(210),IIBAR(210),K1(210),K2(210)
28873 * temporary storage for one final state particle
28874 LOGICAL LFRAG,LGREY,LBLACK
28875 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
28876 & SINTHE,COSTHE,THETA,THECMS,
28877 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
28878 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
28879 & LFRAG,LGREY,LBLACK
28881 * event flag used for histograms
28882 COMMON /DTNORM/ ICEVT,IEVHKK
28884 * Lorentz-parameters of the current interaction
28885 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28886 & UMO,PPCM,EPROJ,PPROJ
28888 PARAMETER (NOPART=210)
28889 DIMENSION AVMULT(4,NOPART),AVE(4,NOPART),AVSWM(4,NOPART),
28890 & AVPT(4,NOPART),IAVPT(4,NOPART)
28891 DATA ANAMEH /'DEUTERON','3-H ','3-HE ','4-HE '/
28895 *------------------------------------------------------------------
28910 *------------------------------------------------------------------
28911 * filling of histogram with event-record
28913 IF (PE.LT.0.0D0) THEN
28914 WRITE(LOUT,*) ' HIMULT: PE < 0 ! ',PE
28917 IF (.NOT.LFRAG) THEN
28919 IF (LGREY) IVEL = 3
28920 IF (LBLACK) IVEL = 4
28921 AVE(1,IDBJT) = AVE(1,IDBJT) +PE
28922 AVE(IVEL,IDBJT) = AVE(IVEL,IDBJT)+PE
28923 AVPT(1,IDBJT) = AVPT(1,IDBJT) +PT
28924 AVPT(IVEL,IDBJT) = AVPT(IVEL,IDBJT)+PT
28925 IAVPT(1,IDBJT) = IAVPT(1,IDBJT) +1
28926 IAVPT(IVEL,IDBJT) = IAVPT(IVEL,IDBJT)+1
28927 AVSWM(1,IDBJT) = AVSWM(1,IDBJT) +PE**SWMEXP
28928 AVSWM(IVEL,IDBJT) = AVSWM(IVEL,IDBJT)+PE**SWMEXP
28929 AVMULT(1,IDBJT) = AVMULT(1,IDBJT) +ONE
28930 AVMULT(IVEL,IDBJT) = AVMULT(IVEL,IDBJT)+ONE
28931 IF (IDBJT.LT.116) THEN
28932 * total energy, multiplicity
28933 AVE(1,30) = AVE(1,30) +PE
28934 AVE(IVEL,30) = AVE(IVEL,30)+PE
28935 AVPT(1,30) = AVPT(1,30) +PT
28936 AVPT(IVEL,30) = AVPT(IVEL,30)+PT
28937 IAVPT(1,30) = IAVPT(1,30) +1
28938 IAVPT(IVEL,30) = IAVPT(IVEL,30)+1
28939 AVSWM(1,30) = AVSWM(1,30)+PE**SWMEXP
28940 AVSWM(IVEL,30) = AVSWM(IVEL,30)+PE**SWMEXP
28941 AVMULT(1,30) = AVMULT(1,30) +ONE
28942 AVMULT(IVEL,30) = AVMULT(IVEL,30)+ONE
28943 * charged energy, multiplicity
28944 IF (ICHAR.LT.0) THEN
28945 AVE(1,26) = AVE(1,26) +PE
28946 AVE(IVEL,26) = AVE(IVEL,26)+PE
28947 AVPT(1,26) = AVPT(1,26) +PT
28948 AVPT(IVEL,26) = AVPT(IVEL,26)+PT
28949 IAVPT(1,26) = IAVPT(1,26) +1
28950 IAVPT(IVEL,26) = IAVPT(IVEL,26)+1
28951 AVSWM(1,26) = AVSWM(1,26) +PE**SWMEXP
28952 AVSWM(IVEL,26) = AVSWM(IVEL,26)+PE**SWMEXP
28953 AVMULT(1,26) = AVMULT(1,26) +ONE
28954 AVMULT(IVEL,26) = AVMULT(IVEL,26)+ONE
28956 IF (ICHAR.NE.0) THEN
28957 AVE(1,27) = AVE(1,27) +PE
28958 AVE(IVEL,27) = AVE(IVEL,27)+PE
28959 AVPT(1,27) = AVPT(1,27) +PT
28960 AVPT(IVEL,27) = AVPT(IVEL,27)+PT
28961 IAVPT(1,27) = IAVPT(1,27) +1
28962 IAVPT(IVEL,27) = IAVPT(IVEL,27)+1
28963 AVSWM(1,27) = AVSWM(1,27) +PE**SWMEXP
28964 AVSWM(IVEL,27) = AVSWM(IVEL,27)+PE**SWMEXP
28965 AVMULT(1,27) = AVMULT(1,27) +ONE
28966 AVMULT(IVEL,27) = AVMULT(IVEL,27)+ONE
28973 *------------------------------------------------------------------
28977 3000 FORMAT(/,1X,'HIMULT:',21X,'particle - statistics',/,
28978 & 29X,'---------------------',/)
28979 IF (MULDEF.EQ.1) THEN
28980 WRITE(LOUT,'(1X,A,/)') 'fast/grey/black: EMU-def.'
28984 WRITE(LOUT,3002) BETGRE,BETGRE,BETBLC,BETBLC
28985 3002 FORMAT(1X,'fast: beta > ',F4.2,' grey: ',F4.2,' > beta > '
28986 & ,F4.2,' black: beta < ',F4.2,/)
28988 WRITE(LOUT,3003) SWMEXP
28989 3003 FORMAT(1X,'particle |',12X,'average multiplicity',/,
28990 & 13X,'| total fast',
28991 C & ' grey black K f(',F3.1,')',/,1X,
28992 & ' grey black <pt> f(',F3.1,')',/,1X,
28993 & '------------+--------------',
28994 & '-------------------------------------------------')
28997 AVMULT(J,I) = AVMULT(J,I)/DBLE(MAX(ICEVT,1))
28998 AVE(J,I) = AVE(J,I)/DBLE(MAX(ICEVT,1))/EPROJ
28999 AVPT(J,I) = AVPT(J,I)/DBLE(MAX(IAVPT(J,I),1))
29000 AVSWM(J,I) = AVSWM(J,I)/DBLE(MAX(ICEVT,1))/EPROJ**SWMEXP
29003 WRITE(LOUT,3004) ANAME(I),I,
29004 & AVMULT(1,I),AVMULT(2,I),
29005 & AVMULT(3,I),AVMULT(4,I),
29006 C & AVE(1,I),AVSWM(1,I)
29007 & AVPT(1,I),AVSWM(1,I)
29008 ELSEIF (I.LE.119) THEN
29009 WRITE(LOUT,3004) ANAMEH(I-115),I,
29010 & AVMULT(1,I),AVMULT(2,I),
29011 & AVMULT(3,I),AVMULT(4,I),
29012 C & AVE(1,I),AVSWM(1,I)
29013 & AVPT(1,I),AVSWM(1,I)
29015 3004 FORMAT(1X,A8,I4,'| ',2F13.6,2F9.5,2F9.5)
29018 C WRITE(LOUT,'(A,F7.3)') ' number of charged heavy particles: ',
29019 C & AVMULT(3,27)+AVMULT(4,27)
29025 *$ CREATE DT_HISTAT.FOR
29028 *===histat=============================================================*
29030 SUBROUTINE DT_HISTAT(IDX,MODE)
29032 ************************************************************************
29033 * This version dated 26.02.96 is written by S. Roesler *
29035 * Last change 27.12.2006 by S. Roesler. *
29036 ************************************************************************
29038 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29041 PARAMETER ( LINP = 10 ,
29045 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
29046 PARAMETER (NDIM=199)
29050 PARAMETER (NMXHKK=200000)
29052 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
29053 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
29054 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
29056 * extended event history
29057 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
29058 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
29061 * particle properties (BAMJET index convention)
29063 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29064 & IICH(210),IIBAR(210),K1(210),K2(210)
29066 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
29068 * Glauber formalism: cross sections
29069 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
29070 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
29071 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
29072 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
29073 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
29074 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
29075 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
29076 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
29077 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
29078 & BSLOPE,NEBINI,NQBINI
29080 * emulsion treatment
29081 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
29084 * properties of interacting particles
29085 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
29087 * rejection counter
29088 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
29089 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
29090 & IREXCI(3),IRDIFF(2),IRINC
29092 * statistics: residual nuclei
29093 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
29094 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
29095 & NINCST(2,4),NINCEV(2),
29096 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
29097 & NRESPB(2),NRESCH(2),NRESEV(4),
29098 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
29101 * parameter for intranuclear cascade
29103 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
29105 * INCLUDE '(DIMPAR)'
29107 PARAMETER ( MXXRGN =20000 )
29108 PARAMETER ( MXXMDF = 710 )
29109 PARAMETER ( MXXMDE = 702 )
29110 PARAMETER ( MFSTCK =40000 )
29111 PARAMETER ( MESTCK = 100 )
29112 PARAMETER ( MOSTCK = 2000 )
29113 PARAMETER ( MXPRSN = 100 )
29114 PARAMETER ( MXPDPM = 800 )
29115 PARAMETER ( MXPSCS =30000 )
29116 PARAMETER ( MXGLWN = 300 )
29117 PARAMETER ( MXOUTU = 50 )
29118 PARAMETER ( NALLWP = 64 )
29119 PARAMETER ( NELEMX = 80 )
29120 PARAMETER ( MPDPDX = 18 )
29121 PARAMETER ( MXHTTR = 260 )
29122 PARAMETER ( MXSEAX = 20 )
29123 PARAMETER ( MXHTNC = MXSEAX + 1 )
29124 PARAMETER ( ICOMAX = 2400 )
29125 PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
29126 PARAMETER ( NSTBIS = 304 )
29127 PARAMETER ( NQSTIS = 46 )
29128 PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
29129 PARAMETER ( MXPABL = 120 )
29130 PARAMETER ( IDMAXP = 450 )
29131 PARAMETER ( IDMXDC = 2000 )
29132 PARAMETER ( MXMCIN = 410 )
29133 PARAMETER ( IHYPMX = 4 )
29134 PARAMETER ( MKBMX1 = 11 )
29135 PARAMETER ( MKBMX2 = 11 )
29136 PARAMETER ( MXIRRD = 2500 )
29137 PARAMETER ( MXTRDC = 1500 )
29138 PARAMETER ( NKTL = 17 )
29139 PARAMETER ( NBLNMX = 40000000 )
29141 * INCLUDE '(PAREVT)'
29143 PARAMETER ( FRDIFF = 0.2D+00 )
29144 PARAMETER ( ETHSEA = 1.0D+00 )
29146 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
29147 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
29148 & LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR,
29149 & LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
29150 COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
29151 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
29152 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
29153 & LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LPHDRC,
29154 & LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, LRVKIN,
29155 & LVP2XX, LV2XNW, LNWV2X, LEVFIN
29157 * INCLUDE '(FRBKCM)'
29159 * Maximum number of fragments to be emitted:
29160 PARAMETER ( MXFFBK = 6 )
29161 PARAMETER ( MXZFBK = 10 )
29162 PARAMETER ( MXNFBK = 12 )
29163 PARAMETER ( MXAFBK = 16 )
29164 PARAMETER ( MXASST = 25 )
29165 PARAMETER ( NXAFBK = MXAFBK + 1 )
29166 PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 + MXASST - NXAFBK )
29167 PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 + MXASST - NXAFBK )
29168 PARAMETER ( MXPSST = 700 )
29169 * Maximum number of pre-computed break-up combinations
29170 PARAMETER ( MXPPFB = 42500 )
29171 * Maximum number of break-up combinations, including special
29173 PARAMETER ( MXPSFB = 43000 )
29174 * Base for J multiplicity encoding:
29175 PARAMETER ( IBFRBK = 73 )
29176 * Maximum Ibfrbk exponent to avoid overflow of I*4(roughly at 2.1x10^9)
29177 * it must be (Ibfrbk-1) + (Ibfrbk-1)*Ibfrbk + (Ibfrbk-1)*Ibfrbk^2 + ...
29178 * ... + (Ibfrbk-1)*Ibfrbk^Jpwfbx < 2100000000,
29179 * --> Ibfrbk^(Jpwfbx+1) < 2100000000
29180 PARAMETER ( JPWFBX = 4 )
29181 LOGICAL LFRMBK, LNCMSS
29182 COMMON / FRBKCM / AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
29183 & WEIFBK (MXPSST), GAMFBK (MXPSST), EXFRBK (MXPSFB),
29184 & SDMFBK (MXPSFB), COUFBK (MXPSFB), CENFBK (MXPSFB),
29185 & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK, FRBKLS,
29186 & IFRBKN (MXPSST), IFRBKZ (MXPSST),
29187 & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
29188 & IPSIND (0:NXNFBK,0:NXZFBK,2), JPSIND (0:MXASST),
29189 & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
29190 & IFBCHA (9,MXPSFB), IPOSST, IPOSFB, IFBSTF, IFBPSF,
29191 & IFBFRB, IFBCHN, IFBNC1, IFBNC2, NBUFBK, LFRMBK, LNCMSS
29193 * INCLUDE '(EVAFLG)'
29195 LOGICAL LOLDEV, LUFULL, LNWLOW, LASMEN, LGMCMP, LGDRFT, LDSCLV,
29196 & LDSCGM, LNDSLD, LMNJPR, LBRPEN, LNWBRP, LIFKEY, LOLDSM,
29197 & LNAIPR, LGUSPR, LFLKCO, LLVMOD, LHVEVP, LHVECN, LHVCAL,
29198 & LHVRAL, LHVSGF, LTMCRR, LBZZCR, LQCSKP
29199 COMMON / EVAFLG / BRPNFR (0:2), EBRPFR (0:2), EMVBRP (0:2),
29200 & ILVMOD, JLVMOD, JSIPFL, IMSSFR, JMSSFR, IEVFSS, MXAHEV,
29201 & MXZHEV, IFHVFL, IFKYMX, IGMCMP, MPMODE, MSMODE, MUMODE,
29202 & MFMODE, MEMODE, MRMODE, ITMCRR, IASYCR, IFSBCR, IFSSBR,
29203 & LOLDEV, LUFULL, LNWLOW, LASMEN, LGMCMP, LGDRFT, LDSCLV,
29204 & LDSCGM, LNDSLD, LMNJPR, LBRPEN, LNWBRP, LIFKEY, LOLDSM,
29205 & LNAIPR, LGUSPR, LFLKCO, LLVMOD, LHVEVP, LHVECN, LHVCAL,
29206 & LHVRAL, LHVSGF, LTMCRR, LBZZCR, LQCSKP
29208 * temporary storage for one final state particle
29209 LOGICAL LFRAG,LGREY,LBLACK
29210 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
29211 & SINTHE,COSTHE,THETA,THECMS,
29212 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
29213 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
29214 & LFRAG,LGREY,LBLACK
29216 * event flag used for histograms
29217 COMMON /DTNORM/ ICEVT,IEVHKK
29219 * statistics: double-Pomeron exchange
29220 COMMON /DTFLG2/ INTFLG,IPOPO
29222 DIMENSION EMUSAM(NCOMPX)
29224 CHARACTER*13 CMSG(3)
29225 DATA CMSG /'not requested','not requested','not requested'/
29227 GOTO (1,2,3,4,5) MODE
29229 *------------------------------------------------------------------
29232 * emulsion treatment
29233 IF (NCOMPO.GT.0) THEN
29238 * common /DTSTA2/, statistics on i.n.c., residual nuclei, evap.
29259 IF (J.LE.2) NINCHR(I,J) = 0
29260 IF (J.LE.3) NINCCO(I,J) = 0
29261 IF (J.LE.4) NINCST(I,J) = 0
29270 **dble Po statistics.
29274 *------------------------------------------------------------------
29275 * filling of histogram with event-record
29277 IF (IST.EQ.-1) THEN
29278 IF (.NOT.LFRAG) THEN
29279 IF (IDPDG.EQ.2212) THEN
29280 NEVA(NOBAM(IDX),1) = NEVA(NOBAM(IDX),1)+1
29281 ELSEIF (IDPDG.EQ.2112) THEN
29282 NEVA(NOBAM(IDX),2) = NEVA(NOBAM(IDX),2)+1
29283 ELSEIF (IDPDG.EQ.22) THEN
29284 NEVAGA(NOBAM(IDX)) = NEVAGA(NOBAM(IDX))+1
29285 ELSEIF (IDPDG.EQ.80000) THEN
29286 IF (IDBJT.EQ.116) THEN
29287 NEVA(NOBAM(IDX),3) = NEVA(NOBAM(IDX),3)+1
29288 ELSEIF (IDBJT.EQ.117) THEN
29289 NEVA(NOBAM(IDX),4) = NEVA(NOBAM(IDX),4)+1
29290 ELSEIF (IDBJT.EQ.118) THEN
29291 NEVA(NOBAM(IDX),5) = NEVA(NOBAM(IDX),5)+1
29292 ELSEIF (IDBJT.EQ.119) THEN
29293 NEVA(NOBAM(IDX),6) = NEVA(NOBAM(IDX),6)+1
29297 * heavy fragments (here: fission products only)
29298 NEVAHY(NOBAM(IDX),1,IBARY) = NEVAHY(NOBAM(IDX),1,IBARY)+1
29299 NEVAHY(NOBAM(IDX),2,ICHAR) = NEVAHY(NOBAM(IDX),2,ICHAR)+1
29300 NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29302 ELSEIF ((IST.EQ.1).AND.(.NOT.LFRAG)) THEN
29303 IF (IDCH(IDX).GT.MAXGEN) MAXGEN = IDCH(IDX)
29307 *------------------------------------------------------------------
29311 **dble Po statistics.
29312 C WRITE(LOUT,'(1X,A,2I7,2E12.4)')
29313 C & '# evts. / # dble-Po. evts / s_in / s_popo :',
29314 C & ICEVT,KPOPO,XSPRO(1,1,1),XSPRO(1,1,1)*DBLE(KPOPO)/DBLE(ICEVT)
29316 * emulsion treatment
29317 IF (NCOMPO.GT.0) THEN
29319 3000 FORMAT(/,1X,'HISTAT:',14X,'statistics - target emulsion',/,
29320 & 22X,'----------------------------',/,/,19X,
29321 & 'mass charge fraction',/,39X,
29322 & 'input treated',/)
29324 WRITE(LOUT,3013) I,IEMUMA(I),IEMUCH(I),EMUFRA(I),
29325 & EMUSAM(I)/DBLE(ICEVT)
29326 3013 FORMAT(12X,I2,1X,2I8,6X,F7.3,5X,F7.3)
29330 * i.n.c. statistics: output
29331 WRITE(LOUT,3001) ICEVT,NRESEV(2),IRINC
29332 3001 FORMAT(/,1X,'HISTAT:',14X,'statistics - intranuclear cascade',/,
29333 & 22X,'---------------------------------',/,/,1X,
29334 & 'no. of events for normalization: (accepted final events,',
29335 & ' evt)',4X,I6,/,34X,'(events before evap.-step, evt1)',I6,
29336 & /,1X,'no. of rejected events due to intranuclear',
29337 & ' cascade',15X,I6,/)
29338 ICEV = MAX(ICEVT,1)
29340 IF (LEVPRT) ICEV1 = MAX(NRESEV(2),1)
29342 & (DBLE(NINCWO(I))/DBLE(ICEV),I=1,2),
29343 & ((DBLE(NINCST(I,J))/DBLE(ICEV),I=1,2),J=1,4),
29344 & KTAUGE,DBLE(NINCGE)/DBLE(ICEV),
29345 & (DBLE(NINCCO(I,1)+NINCCO(I,2)+NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29346 & (DBLE(NINCCO(I,2))/DBLE(ICEV1),I=1,2),
29347 & (DBLE(NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29348 & (DBLE(NINCCO(I,1))/DBLE(ICEV1),I=1,2)
29349 3002 FORMAT(1X,'no. of wounded nucl. in proj./ target (mean per evt)',
29350 & 5X,F6.2,' /',F6.2,/,1X,'no. of particles unable to escape',
29351 & ' proj./ target (mean per evt)',/,8X,'baryons: pos. ',
29352 & F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3,/,8X,
29353 & 'mesons: pos. ',F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3,
29354 & /,1X,'maximum no. of generations treated (maximum allowed:'
29355 & ,I4,')',/,43X,'(mean per evt)',5X,F6.2,/,1X,'no. of sec.',
29356 & ' interactions in proj./ target (mean per evt1)',
29357 & F7.3,' /',F7.3,/,8X,'out of which by inelastic',
29358 & ' interactions',12X,F7.3,' /',F7.3,/,21X,'by elastic ',
29359 & 'interactions',14X,F7.3,' /',F7.3,/,21X,'by absorption ',
29360 & '(ap, K-, pi- only) ',F7.3,' /',F7.3,/)
29361 WRITE(LOUT,3003) NRESEV(2),NRESEV(4),IREXCI,
29362 & IREXCI(1)+IREXCI(2)+IREXCI(3)
29363 3003 FORMAT(/,1X,'HISTAT:',14X,'statistics - residual nuclei, ',
29364 & 'evaporation',/,22X,'-----------------------------',
29365 & '------------',/,/,1X,'no. of events for normal.: ',
29366 & '(events handled by FICONF, evt)',7X,I6,/,28X,'(events',
29367 & ' passing the evap.-step, evt1) ',I6,/,1X,'no. of',
29368 & ' rejected events (',I4,',',I4,',',I4,')',22X,I6,/)
29371 3004 FORMAT(/,22X,'1) before evaporation-step:',/)
29372 ICEV = MAX(NRESEV(2),1)
29374 & (DBLE(NRESTO(I))/DBLE(ICEV),I=1,2),
29375 & (DBLE(NRESPR(I))/DBLE(ICEV),I=1,2),
29376 & (DBLE(NRESNU(I))/DBLE(ICEV),I=1,2),
29377 & (DBLE(NRESBA(I))/DBLE(ICEV),I=1,2),
29378 & (DBLE(NRESPB(I))/DBLE(ICEV),I=1,2),
29379 & (DBLE(NRESCH(I))/DBLE(ICEV),I=1,2),
29380 & (EXCDPM(I)/DBLE(ICEV),I=1,2),
29381 & (EXCDPM(I+2)/DBLE(ICEV),I=1,2)
29382 3005 FORMAT(1X,'residual nuclei: (mean values per evt)',12X,
29383 & 'proj. / target',/,/,8X,'total number of particles',15X,
29384 & 2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29385 & 'neutrons',18X,2F9.3,/,22X,'baryons',19X,2F9.3,/,22X,
29386 & 'pos. baryons',14X,2F9.3,/,8X,'total charge',28X,2F9.3,/,
29387 & /,8X,'excitation energy (bef. evap.-step) ',2E11.3,/,
29388 & 8X,'excitation energy per nucleon ',2E11.3,/,/)
29390 * evaporation / fission / fragmentation statistics: output
29391 ICEV = MAX(NRESEV(2),1)
29392 ICEV1 = MAX(NRESEV(4),1)
29394 & NEVA(1,1)+NEVA(1,2)+NEVA(1,3)+NEVA(1,4)+NEVA(1,5)+NEVA(1,6)
29396 & NEVA(2,1)+NEVA(2,2)+NEVA(2,3)+NEVA(2,4)+NEVA(2,5)+NEVA(2,6)
29399 IF (IEVFSS.EQ.1) CMSG(1) = 'requested '
29401 IF (LFRMBK) CMSG(2) = 'requested '
29402 IF (LDEEXG) CMSG(3) = 'requested '
29405 & DBLE(NTEVA1)/DBLE(ICEV1),DBLE(NTEVA2)/DBLE(ICEV1),
29406 & (DBLE(NEVA(I,1))/DBLE(ICEV1),I=1,2),
29407 & (DBLE(NEVA(I,2))/DBLE(ICEV1),I=1,2),
29408 & (DBLE(NEVA(I,3))/DBLE(ICEV1),I=1,2),
29409 & (DBLE(NEVA(I,4))/DBLE(ICEV1),I=1,2),
29410 & (DBLE(NEVA(I,5))/DBLE(ICEV1),I=1,2),
29411 & (DBLE(NEVA(I,6))/DBLE(ICEV1),I=1,2),
29412 & (DBLE(NEVAGA(I))/DBLE(ICEV1),I=1,2),
29413 & (DBLE(NEVAHT(I))/DBLE(ICEV1),I=1,2)
29414 3006 FORMAT(22X,'2) after evaporation-step:',/,/,1X,'Fission:',
29415 & 13X,A13,/,1X,'Fermi-Break-up:',6X,A13,/,1X,'Gamma-',
29416 & 'deexcitation:',2X,A13,/,/,
29417 & 1X,'evaporation/deexcitation: (mean values per evt1) ',
29418 & 'proj. / target',/,/,8X,'total number of evap. particles',
29419 & 9X,2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29420 & 'neutrons',18X,2F9.3,/,22X,'deuterons',17X,2F9.3,/,22X,
29421 & '3-H',23X,2F9.3,/,22X,'3-He',22X,2F9.3,/,22X,'4-He',22X,
29422 & 2F9.3,/,8X,'nucl. deexcit. gammas',19X,2F9.3,/,8X,
29423 & 'heavy fragments',25X,2F9.3,/)
29425 IF (IEVFSS.EQ.1) THEN
29427 WRITE(LOUT,3007) NEVAFI(1,1),NEVAFI(1,2),
29428 & NEVAFI(2,1),NEVAFI(2,2),
29429 & DBLE(NEVAFI(2,1))/DBLE(MAX(NEVAFI(1,1),1))*100.0D0,
29430 & DBLE(NEVAFI(2,2))/DBLE(MAX(NEVAFI(1,2),1))*100.0D0
29431 3007 FORMAT(1X,'Fission: total number of events',14X,2I9,/
29432 & 12X,'out of which fission occured',8X,2I9,/,
29433 & 50X,'(',F5.2,'%) (',F5.2,'%)',/)
29436 C IF ((LFRMBK).OR.(IEVFSS.EQ.1)) THEN
29439 C3008 FORMAT(1X,'heavy fragments - statistics:',7X,'charge',
29440 C & ' proj. / target',/)
29442 C IF ((NEVAHY(1,2,I).NE.0).OR.(NEVAHY(2,2,I).NE.0)) THEN
29443 C WRITE(LOUT,3009) I,
29444 C & (DBLE(NEVAHY(K,2,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29445 C3009 FORMAT(38X,I3,3X,2E12.3)
29449 C3010 FORMAT(1X,'heavy fragments - statistics:',7X,'mass ',
29450 C & ' proj. / target',/)
29452 C IF ((NEVAHY(1,1,I).NE.0).OR.(NEVAHY(2,1,I).NE.0)) THEN
29453 C WRITE(LOUT,3011) I,
29454 C & (DBLE(NEVAHY(K,1,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29455 C3011 FORMAT(38X,I3,3X,2E12.3)
29462 3012 FORMAT(22X,'2) after evaporation-step:',/,/,1X,
29463 & 'Evaporation: not requested',/)
29467 *------------------------------------------------------------------
29468 * filling of histogram with event-record
29470 * emulsion treatment
29471 IF (NCOMPO.GT.0) THEN
29473 IF (IT.EQ.IEMUMA(I)) THEN
29474 EMUSAM(I) = EMUSAM(I)+ONE
29478 NINCGE = NINCGE+MAXGEN
29480 **dble Po statistics.
29481 IF (IPOPO.EQ.1) KPOPO = KPOPO+1
29484 *------------------------------------------------------------------
29485 * filling of histogram with event-record
29487 IF ((ISTHKK(IDX).EQ.15).OR.(ISTHKK(IDX).EQ.16)) THEN
29488 IB = IIBAR(IDBAM(IDX))
29489 IC = IICH(IDBAM(IDX))
29491 IF ( ((ABS(IB).EQ.1).AND.(IC.EQ.1)).OR.(IC.EQ.0) ) THEN
29492 NINCST(J,1) = NINCST(J,1)+1
29493 ELSEIF ((ABS(IB).EQ.1).AND.(IC.EQ.-1)) THEN
29494 NINCST(J,2) = NINCST(J,2)+1
29495 ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ. 1)) THEN
29496 NINCST(J,3) = NINCST(J,3)+1
29497 ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ.-1)) THEN
29498 NINCST(J,4) = NINCST(J,4)+1
29500 ELSEIF (ISTHKK(IDX).EQ.17) THEN
29501 NINCWO(1) = NINCWO(1)+1
29502 ELSEIF (ISTHKK(IDX).EQ.18) THEN
29503 NINCWO(2) = NINCWO(2)+1
29504 ELSEIF (ISTHKK(IDX).EQ.1001) THEN
29508 NEVAHY(NOBAM(IDX),1,IB) = NEVAHY(NOBAM(IDX),1,IB)+1
29509 NEVAHY(NOBAM(IDX),2,IC) = NEVAHY(NOBAM(IDX),2,IC)+1
29511 NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29516 *$ CREATE DT_NEWHGR.FOR
29519 *===newhgr=============================================================*
29521 SUBROUTINE DT_NEWHGR(XLIM1,XLIM2,XLIM3,XLIMB,IBIN,IREFN)
29523 ************************************************************************
29525 * Histogram initialization. *
29527 * input: XLIM1/XLIM2 lower/upper edge of histogram-window *
29529 * IBIN > 0 number of bins in equidistant lin. binning *
29530 * = -1 reset histograms *
29531 * < -1 |IBIN| number of bins in equidistant log. *
29532 * binning or log. binning in user def. struc. *
29533 * XLIMB(*) user defined bin structure *
29535 * The bin structure is sensitive to *
29536 * XLIM1, XLIM3, IBIN if XLIM3 > 0 (lin.) *
29537 * XLIM1, XLIM2, IBIN if XLIM3 = 0 (lin. & log.) *
29538 * XLIMB, IBIN if XLIM3 < 0 *
29541 * output: IREFN histogram index *
29542 * (= -1 for inconsistent histogr. request) *
29544 * This subroutine is based on a original version by R. Engel. *
29545 * This version dated 22.4.95 is written by S. Roesler. *
29546 ************************************************************************
29548 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29551 PARAMETER ( LINP = 10 ,
29557 PARAMETER (ZERO = 0.0D0,
29564 PARAMETER (NHIS=150, NDIM=250)
29566 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29567 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29569 * auxiliary common for histograms
29570 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29572 DATA LSTART /.TRUE./
29574 * reset histogram counter
29575 IF (LSTART.OR.(IBIN.EQ.-1)) THEN
29577 IF (IBIN.EQ.-1) RETURN
29582 * check for maximum number of allowed histograms
29583 IF (IHIS.GT.NHIS) THEN
29584 WRITE(LOUT,1003) IHIS,NHIS,IHIS
29585 1003 FORMAT(1X,'NEWHGR: warning! number of histograms (',
29586 & I4,') exceeds array size (',I4,')',/,21X,
29587 & 'histogram',I3,' skipped!')
29592 IBINS(IHIS) = ABS(IBIN)
29593 * check requested number of bins
29594 IF (IBINS(IHIS).GE.NDIM) THEN
29595 WRITE(LOUT,1000) IBIN,NDIM,NDIM
29596 1000 FORMAT(1X,'NEWHGR: warning! number of bins (',
29597 & I3,') exceeds array size (',I3,')',/,21X,
29598 & 'and will be reset to ',I3)
29601 IF (IBINS(IHIS).EQ.0) THEN
29602 WRITE(LOUT,1001) IBIN,IHIS
29603 1001 FORMAT(1X,'NEWHGR: warning! inconsistent number of',
29604 & ' bins (',I3,')',/,21X,'histogram',I3,' skipped!')
29608 * initialize arrays
29611 HIST(K,IHIS,I) = ZERO
29612 HIST(K+3,IHIS,I) = ZERO
29613 TMPHIS(K,IHIS,I) = ZERO
29615 HIST(7,IHIS,I) = ZERO
29617 DENTRY(1,IHIS)= ZERO
29618 DENTRY(2,IHIS)= ZERO
29620 UNDERF(IHIS) = ZERO
29621 TMPUFL(IHIS) = ZERO
29622 TMPOFL(IHIS) = ZERO
29624 * bin str. sensitive to lower edge, bin size, and numb. of bins
29625 IF (XLIM3.GT.ZERO) THEN
29626 DO 3 K=1,IBINS(IHIS)+1
29627 HIST(1,IHIS,K) = XLIM1+DBLE(K-1)*XLIM3
29630 * bin str. sensitive to lower/upper edge and numb. of bins
29631 ELSEIF (XLIM3.EQ.ZERO) THEN
29633 IF (IBIN.GT.0) THEN
29636 IF (XLIM2.LE.XLIM1) THEN
29637 WRITE(LOUT,1002) XLIM1,XLIM2
29638 1002 FORMAT(1X,'NEWHGR: warning! inconsistent x-range',
29639 & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29643 ELSEIF (IBIN.LT.-1) THEN
29644 * logarithmic binning
29645 IF ((XLIM1.LE.ZERO).OR.(XLIM2.LE.ZERO)) THEN
29646 WRITE(LOUT,1004) XLIM1,XLIM2
29647 1004 FORMAT(1X,'NEWHGR: warning! inconsistent log. ',
29648 & 'binning',/,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29651 IF (XLIM2.LE.XLIM1) THEN
29652 WRITE(LOUT,1005) XLIM1,XLIM2
29653 1005 FORMAT(1X,'NEWHGR: warning! inconsistent x-range',
29654 & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29657 XLOW = LOG10(XLIM1)
29661 DX = ABS(XHI-XLOW)/DBLE(MAX(IBINS(IHIS),1))
29662 DO 4 K=1,IBINS(IHIS)+1
29663 HIST(1,IHIS,K) = XLOW+DBLE(K-1)*DX
29666 * user defined bin structure
29667 DO 5 K=1,IBINS(IHIS)+1
29668 IF (IBIN.GT.0) THEN
29669 HIST(1,IHIS,K) = XLIMB(K)
29671 ELSEIF (IBIN.LT.-1) THEN
29672 HIST(1,IHIS,K) = LOG10(XLIMB(K))
29678 * histogram accepted
29688 *$ CREATE DT_FILHGR.FOR
29691 *===filhgr=============================================================*
29693 SUBROUTINE DT_FILHGR(XI,YI,IHIS,NEVT)
29695 ************************************************************************
29697 * Scoring for histogram IHIS. *
29699 * This subroutine is based on a original version by R. Engel. *
29700 * This version dated 23.4.95 is written by S. Roesler. *
29701 ************************************************************************
29703 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29706 PARAMETER ( LINP = 10 ,
29710 PARAMETER (ZERO = 0.0D0,
29716 PARAMETER (NHIS=150, NDIM=250)
29718 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29719 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29721 * auxiliary common for histograms
29722 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29729 * dump content of temorary arrays into histograms
29730 IF ((NEVT.NE.NCEVT).OR.(NEVT.LT.0)) THEN
29731 CALL DT_EVTHIS(IDUM)
29735 * check histogram index
29736 IF (IHIS.EQ.-1) RETURN
29737 IF ((IHIS.LT.1).OR.(IHIS.GT.IHISL)) THEN
29738 C WRITE(LOUT,1000) IHIS,IHISL
29739 1000 FORMAT(1X,'FILHGR: warning! histogram index',I4,
29740 & ' out of range (1..',I3,')')
29744 IF ((ISWI(IHIS).EQ.1).OR.(ISWI(IHIS).EQ.3)) THEN
29745 * bin structure not explicitly given
29746 IF ((ISWI(IHIS).EQ.3).AND.(X.GT.ZERO)) X = LOG10(X)
29747 DX = ABS(HIST(1,IHIS,2)-HIST(1,IHIS,1))
29748 IF (X.LT.HIST(1,IHIS,1)) THEN
29751 I1 = INT( (X-HIST(1,IHIS,1))/MAX(DX,TINY) )+1
29754 ELSEIF ((ISWI(IHIS).EQ.2).OR.(ISWI(IHIS).EQ.4)) THEN
29755 * user defined bin structure
29756 IF ((ISWI(IHIS).EQ.4).AND.(X.GT.ZERO)) X = LOG10(X)
29757 IF (X.LT.HIST(1,IHIS,1)) THEN
29759 ELSE IF (X.GT.HIST(1,IHIS,IBINS(IHIS)+1)) THEN
29762 * binary sort algorithm
29764 KMAX = IBINS(IHIS)+1
29766 IF ((KMAX-KMIN).EQ.1) GOTO 2
29768 IF (X.LE.HIST(1,IHIS,KK)) THEN
29780 1001 FORMAT(1X,'FILHGR: warning! histogram not initialized')
29786 TMPUFL(IHIS) = TMPUFL(IHIS)+ONE
29787 ELSEIF (I1.LE.IBINS(IHIS)) THEN
29788 TMPHIS(1,IHIS,I1) = TMPHIS(1,IHIS,I1)+ONE
29789 IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
29790 TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+10**X
29792 TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+X
29794 TMPHIS(3,IHIS,I1) = TMPHIS(3,IHIS,I1)+Y
29796 TMPOFL(IHIS) = TMPOFL(IHIS)+ONE
29802 *$ CREATE DT_EVTHIS.FOR
29805 *===evthis=============================================================*
29807 SUBROUTINE DT_EVTHIS(NEVT)
29809 ************************************************************************
29810 * Dump content of temorary histograms into /DTHIS1/. This subroutine *
29811 * is called after each event and for the last event before any call *
29813 * NEVT number of events dumped, this is only needed to *
29814 * get the normalization after the last event *
29815 * This version dated 23.4.95 is written by S. Roesler. *
29816 ************************************************************************
29818 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29821 PARAMETER ( LINP = 10 ,
29827 PARAMETER (ZERO = 0.0D0,
29833 PARAMETER (NHIS=150, NDIM=250)
29835 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29836 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29838 * auxiliary common for histograms
29839 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29849 IF (TMPHIS(1,I,J).GT.ZERO) THEN
29851 HIST(2,I,J) = HIST(2,I,J)+ONE
29852 HIST(7,I,J) = HIST(7,I,J)+TMPHIS(1,I,J)
29853 DENTRY(2,I) = DENTRY(2,I)+TMPHIS(1,I,J)
29854 AVX = TMPHIS(2,I,J)/TMPHIS(1,I,J)
29855 HIST(3,I,J) = HIST(3,I,J)+TMPHIS(3,I,J)*AVX
29856 HIST(4,I,J) = HIST(4,I,J)+TMPHIS(3,I,J)*AVX**2
29857 HIST(5,I,J) = HIST(5,I,J)+TMPHIS(3,I,J)
29858 HIST(6,I,J) = HIST(6,I,J)+TMPHIS(3,I,J)**2
29859 TMPHIS(1,I,J) = ZERO
29860 TMPHIS(2,I,J) = ZERO
29861 TMPHIS(3,I,J) = ZERO
29865 IF (TMPUFL(I).GT.ZERO) THEN
29866 UNDERF(I) = UNDERF(I)+ONE
29868 ELSEIF (TMPOFL(I).GT.ZERO) THEN
29869 OVERF(I) = OVERF(I)+ONE
29873 DENTRY(1,I) = DENTRY(1,I)+ONE
29880 *$ CREATE DT_OUTHGR.FOR
29883 *===outhgr=============================================================*
29885 SUBROUTINE DT_OUTHGR(I1,I2,I3,I4,I5,I6,CHEAD,IHEAD,NEVTS,FAC,
29886 & ILOGY,INORM,NMODE)
29888 ************************************************************************
29890 * Plot histogram(s) to standard output unit *
29892 * I1..6 indices of histograms to be plotted *
29893 * CHEAD,IHEAD header string,integer *
29894 * NEVTS number of events *
29895 * FAC scaling factor *
29896 * ILOGY = 1 logarithmic y-axis *
29897 * INORM normalization *
29898 * = 0 no further normalization (FAC is obsolete) *
29899 * = 1 per event and bin width *
29900 * = 2 per entry and bin width *
29901 * = 3 per bin entry *
29902 * = 4 per event and "bin width" x1^2...x2^2 *
29903 * = 5 per event and "log. bin width" ln x1..ln x2 *
29905 * MODE = 0 no output but normalization applied *
29906 * = 1 all valid histograms separately (small frame) *
29907 * all valid histograms separately (small frame) *
29908 * = -1 and tables as histograms *
29909 * = 2 all valid histograms (one plot, wide frame) *
29910 * all valid histograms (one plot, wide frame) *
29911 * = -2 and tables as histograms *
29914 * Note: All histograms to be plotted with one call to this *
29915 * subroutine and |MODE|=2 must have the same bin structure! *
29916 * There is no test included ensuring this fact. *
29918 * This version dated 23.4.95 is written by S. Roesler. *
29919 ************************************************************************
29921 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29924 PARAMETER ( LINP = 10 ,
29930 PARAMETER (ZERO = 0.0D0,
29942 PARAMETER (NHIS=150, NDIM=250)
29944 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29945 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29947 PARAMETER (NDIM2 = 2*NDIM)
29948 DIMENSION XX(NDIM2),YY(NDIM2)
29950 PARAMETER (NHISTO = 6)
29951 DIMENSION YY1(NDIM,NHISTO),XX1(NDIM,NHISTO),IDX1(NHISTO),
29954 CHARACTER*43 CNORM(0:8)
29955 DATA CNORM /'no further normalization ',
29956 & 'per event and bin width ',
29957 & 'per entry1 and bin width ',
29958 & 'per bin entry ',
29959 & 'per event and "bin width" x1^2...x2^2 ',
29960 & 'per event and "log. bin width" ln x1..ln x2',
29962 & 'per bin entry1 ',
29963 & 'per entry2 and bin width '/
29974 * initialization if "wide frame" is requested
29975 IF (ABS(MODE).EQ.2) THEN
29985 WRITE(LOUT,'(/1X,A,I3,/,1X,70A1)') CHEAD,IHEAD,('=',II=1,70)
29987 * check histogram indices
29990 IF ((IDX1(I).GE.1).AND.(IDX1(I).LE.IHISL)) THEN
29991 IF (ISWI(IDX1(I)).NE.0) THEN
29992 IF (DENTRY(1,IDX1(I)).LT.ONE) THEN
29994 & IDX1(I),UNDERF(IDX1(I)),OVERF(IDX1(I))
29995 1000 FORMAT(/,1X,'OUTHGR: warning! no entries in',
29996 & ' histogram ',I3,/,21X,'underflows:',F10.0,
29997 & ' overflows: ',F10.0)
30007 1001 FORMAT(/,1X,'OUTHGR: warning! histogram indices not valid')
30011 * check normalization request
30012 IF ( ((FAC.EQ.ZERO).AND.(INORM.NE.0)).OR.
30013 & ((NEVTS.LT.1).AND.((INORM.EQ.1).OR.(INORM.EQ.4).OR.
30014 & (INORM.EQ.5).OR.(INORM.EQ.6))).OR.
30015 & (INORM.LT.0).OR.(INORM.GT.8) ) THEN
30016 WRITE(LOUT,1002) NEVTS,INORM,FAC
30017 1002 FORMAT(/,1X,'OUTHGR: warning! normalization request not ',
30018 & 'valid',/,21X,'NEVTS = ',I7,4X,'INORM = ',I2,4X,
30023 WRITE(LOUT,'(/,1X,A,I8)') 'number of events:',NEVTS
30025 * apply normalization
30030 IF (ISWI(I).EQ.1) THEN
30031 WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30032 1003 FORMAT(/,1X,'histo.',I4,', linear binning from',2X,E10.4,
30033 & ' to',2X,E10.4,',',2X,I3,' bins')
30034 ELSEIF (ISWI(I).EQ.2) THEN
30035 WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30037 1007 FORMAT(1X,'user defined bin structure')
30038 ELSEIF (ISWI(I).EQ.3) THEN
30040 & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30041 1004 FORMAT(/,1X,'histo.',I4,', logar. binning from',2X,E10.4,
30042 & ' to',2X,E10.4,',',2X,I3,' bins')
30043 ELSEIF (ISWI(I).EQ.4) THEN
30045 & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30048 WRITE(LOUT,1008) ISWI(I)
30049 1008 FORMAT(/,1X,'warning! inconsistent bin structure flag ',I4)
30051 WRITE(LOUT,1005) DENTRY(1,I),DENTRY(2,I),UNDERF(I),OVERF(I)
30052 1005 FORMAT(13X,'entries:',2F9.0,' underfl.:',F8.0,
30053 & ' overfl.:',F8.0)
30054 WRITE(LOUT,1009) CNORM(INORM)
30055 1009 FORMAT(1X,'normalization: ',A,/)
30058 CALL DT_GETBIN(I,K,NEVTS,INORM,XLOW,XHI,XMEAN,YMEAN,YERR)
30061 WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,YERR,HIST(2,I,K)
30062 WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,YERR,HIST(2,I,K)
30063 1006 FORMAT(1X,5E11.3)
30066 XX(II-1) = HIST(1,I,K)
30067 XX(II) = HIST(1,I,K+1)
30072 IF ((ISWI(I).EQ.3).OR.(ISWI(I).EQ.4))
30073 & XX1(K,N) = LOG10(XMEAN)
30078 IF (ABS(MODE).EQ.1) THEN
30080 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30081 IF(ILOGY.EQ.1) THEN
30082 CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30084 CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30091 IF (ABS(MODE).EQ.2) THEN
30092 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30093 NSIZE = NDIM*NHISTO
30094 DXLOW = HIST(1,IDX(1),1)
30095 DDX = ABS(HIST(1,IDX(1),2)-HIST(1,IDX(1),1))
30100 IF (YY1(J,I).LT.YLOW) THEN
30101 IF (ILOGY.EQ.1) THEN
30102 IF (YY1(J,I).GT.ZERO) YLOW = YY1(J,I)
30107 IF (YY1(J,I).GT.YHI) YHI = YY1(J,I)
30110 DY = (YHI-YLOW)/DBLE(NDIM)
30111 IF (DY.LE.ZERO) THEN
30112 WRITE(LOUT,'(1X,A,6I4,A,2E12.4)')
30113 & 'OUTHGR: warning! zero bin width for histograms ',
30114 & IDX,': ',YLOW,YHI
30117 IF (ILOGY.EQ.1) THEN
30119 DY = (LOG10(YHI)-YLOW)/100.0D0
30122 IF (YY1(J,I).LE.ZERO) THEN
30125 YY1(J,I) = LOG10(YY1(J,I))
30130 CALL DT_SRPLOT(XX1,YY1,NSIZE,NHISTO,NDIM,DXLOW,DDX,YLOW,DY)
30136 *$ CREATE DT_GETBIN.FOR
30139 *===getbin=============================================================*
30141 SUBROUTINE DT_GETBIN(IHIS,IBIN,KEVT,NORM,XLOW,XHI,
30142 & XMEAN,YMEAN,YERR)
30144 ************************************************************************
30145 * This version dated 23.4.95 is written by S. Roesler. *
30146 ************************************************************************
30148 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30151 PARAMETER ( LINP = 10 ,
30155 PARAMETER (ZERO = 0.0D0,
30157 & TINY35 = 1.0D-35)
30161 PARAMETER (NHIS=150, NDIM=250)
30163 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30164 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30166 XLOW = HIST(1,IHIS,IBIN)
30167 XHI = HIST(1,IHIS,IBIN+1)
30168 IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
30172 IF (NORM.EQ.2) THEN
30174 NEVT = INT(DENTRY(1,IHIS))
30175 ELSEIF (NORM.EQ.3) THEN
30177 NEVT = INT(HIST(2,IHIS,IBIN))
30178 ELSEIF (NORM.EQ.4) THEN
30179 DX = XHI**2-XLOW**2
30181 ELSEIF (NORM.EQ.5) THEN
30182 DX = LOG(ABS(XHI))-LOG(ABS(XLOW))
30184 ELSEIF (NORM.EQ.6) THEN
30187 ELSEIF (NORM.EQ.7) THEN
30189 NEVT = INT(HIST(7,IHIS,IBIN))
30190 ELSEIF (NORM.EQ.8) THEN
30192 NEVT = INT(DENTRY(2,IHIS))
30197 IF (ABS(DX).LT.TINY35) DX = ONE
30199 YMEAN = HIST(5,IHIS,IBIN)/DX/DBLE(NEVT)
30200 YMEAN2 = HIST(6,IHIS,IBIN)/DX**2/DBLE(NEVT)
30201 YERR = SQRT(ABS(YMEAN2-YMEAN**2))/SQRT(DBLE(NEVT))
30202 YSUM = HIST(5,IHIS,IBIN)
30203 IF (ABS(YSUM).LT.TINY35) YSUM = ONE
30204 C XMEAN = HIST(3,IHIS,IBIN)/YSUM/MAX(HIST(2,IHIS,IBIN),ONE)
30205 XMEAN = HIST(3,IHIS,IBIN)/YSUM
30206 IF (XMEAN.EQ.ZERO) XMEAN = XLOW
30211 *$ CREATE DT_JOIHIS.FOR
30214 *===joihis=============================================================*
30216 SUBROUTINE DT_JOIHIS(IH1,IH2,COPER,FAC1,FAC2,KEVT,NORM,ILOGY,MODE)
30218 ************************************************************************
30220 * Operation on histograms. *
30222 * input: IH1,IH2 histogram indices to be joined *
30223 * COPER character defining the requested operation, *
30224 * i.e. '+', '-', '*', '/' *
30225 * FAC1,FAC2 factors for joining, i.e. *
30226 * FAC1*histo1 COPER FAC2*histo2 *
30228 * This version dated 23.4.95 is written by S. Roesler. *
30229 ************************************************************************
30231 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30234 PARAMETER ( LINP = 10 ,
30240 PARAMETER (ZERO = 0.0D0,
30249 PARAMETER (NHIS=150, NDIM=250)
30251 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30252 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30254 PARAMETER (NDIM2 = 2*NDIM)
30255 DIMENSION XX(NDIM2),YY(NDIM2),YY1(NDIM),XX1(NDIM)
30257 CHARACTER*43 CNORM(0:6)
30258 DATA CNORM /'no further normalization ',
30259 & 'per event and bin width ',
30260 & 'per entry and bin width ',
30261 & 'per bin entry ',
30262 & 'per event and "bin width" x1^2...x2^2 ',
30263 & 'per event and "log. bin width" ln x1..ln x2',
30266 * check histogram indices
30267 IF ((IH1.LT. 1).OR.(IH2.LT. 1).OR.
30268 & (IH1.GT.IHISL).OR.(IH2.GT.IHISL)) THEN
30269 WRITE(LOUT,1000) IH1,IH2,IHISL
30270 1000 FORMAT(1X,'JOIHIS: warning! inconsistent histogram ',
30271 & 'indices (',I3,',',I3,'),',/,21X,'valid range: 1,',I3)
30275 * check bin structure of histograms to be joined
30276 IF (IBINS(IH1).NE.IBINS(IH2)) THEN
30277 WRITE(LOUT,1001) IH1,IH2,IBINS(IH1),IBINS(IH2)
30278 1001 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3,
30279 & ' and ',I3,' failed',/,21X,
30280 & 'due to different numbers of bins (',I3,',',I3,')')
30283 DO 1 K=1,IBINS(IH1)+1
30284 IF (ABS(HIST(1,IH1,K)-HIST(1,IH2,K)).GT.TINY8) THEN
30285 WRITE(LOUT,1002) IH1,IH2,K,HIST(1,IH1,K),HIST(1,IH2,K)
30286 1002 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3,
30287 & ' and ',I3,' failed at bin edge ',I3,/,21X,
30288 & 'X1,X2 = ',2E11.4)
30293 WRITE(LOUT,1003) IH1,IH2,COPER,FAC1,FAC2
30294 1003 FORMAT(1X,'JOIHIS: joining histograms ',I3,',',I3,' with ',
30295 & 'operation ',A,/,11X,'and factors ',2E11.4)
30296 WRITE(LOUT,1004) CNORM(NORM)
30297 1004 FORMAT(1X,'normalization: ',A,/)
30299 DO 2 K=1,IBINS(IH1)
30300 CALL DT_GETBIN(IH1,K,KEVT,NORM,XLOW1,XHI1,XMEAN1,YMEAN1,YERR1)
30301 CALL DT_GETBIN(IH2,K,KEVT,NORM,XLOW2,XHI2,XMEAN2,YMEAN2,YERR2)
30304 XMEAN = OHALF*(XMEAN1+XMEAN2)
30305 IF (COPER.EQ.'+') THEN
30306 YMEAN = FAC1*YMEAN1+FAC2*YMEAN2
30307 ELSEIF (COPER.EQ.'*') THEN
30308 YMEAN = FAC1*YMEAN1*FAC2*YMEAN2
30309 ELSEIF (COPER.EQ.'/') THEN
30310 IF (YMEAN2.EQ.ZERO) THEN
30313 IF (FAC2.EQ.ZERO) FAC2 = ONE
30314 YMEAN = FAC1*YMEAN1/(FAC2*YMEAN2)
30319 WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30320 WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30321 1006 FORMAT(1X,5E11.3)
30324 XX(II-1) = HIST(1,IH1,K)
30325 XX(II) = HIST(1,IH1,K+1)
30330 IF ((ISWI(IH1).EQ.3).OR.(ISWI(IH1).EQ.4)) XX1(K) = LOG10(XMEAN)
30335 IF (ABS(MODE).EQ.1) THEN
30336 IBIN2 = 2*IBINS(IH1)
30337 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30338 IF(ILOGY.EQ.1) THEN
30339 CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30341 CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30346 IF (ABS(MODE).EQ.2) THEN
30347 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30349 DXLOW = HIST(1,IH1,1)
30350 DDX = ABS(HIST(1,IH1,2)-HIST(1,IH1,1))
30354 IF (YY1(I).LT.YLOW) THEN
30355 IF (ILOGY.EQ.1) THEN
30356 IF (YY1(I).GT.ZERO) YLOW = YY1(I)
30361 IF (YY1(I).GT.YHI) YHI = YY1(I)
30363 DY = (YHI-YLOW)/DBLE(NDIM)
30364 IF (DY.LE.ZERO) THEN
30365 WRITE(LOUT,'(1X,A,2I4,A,2E12.4)')
30366 & 'JOIHIS: warning! zero bin width for histograms ',
30367 & IH1,IH2,': ',YLOW,YHI
30370 IF (ILOGY.EQ.1) THEN
30372 DY = (LOG10(YHI)-YLOW)/100.0D0
30374 IF (YY1(I).LE.ZERO) THEN
30377 YY1(I) = LOG10(YY1(I))
30381 CALL DT_SRPLOT(XX1,YY1,NSIZE,1,NDIM,DXLOW,DDX,YLOW,DY)
30387 WRITE(LOUT,1005) COPER
30388 1005 FORMAT(1X,'JOIHIS: unknown operation ',A)
30394 *$ CREATE DT_XGRAPH.FOR
30397 *===qgraph=============================================================*
30399 SUBROUTINE DT_XGRAPH(N,IARG,X,Y1,Y2)
30400 C***********************************************************************
30402 C calculate quasi graphic picture with 25 lines and 79 columns
30403 C ranges will be chosen automatically
30405 C input N dimension of input fields
30406 C IARG number of curves (fields) to plot
30411 C This subroutine is written by R. Engel.
30412 C***********************************************************************
30413 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30416 PARAMETER ( LINP = 10 ,
30421 DIMENSION X(N),Y1(N),Y2(N)
30422 PARAMETER (EPS=1.D-30)
30423 PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30425 CHARACTER COL(0:149,0:49)
30427 DATA SYMB /'0','e','z','#','x'/
30431 C*** automatic range fitting
30436 XMAX=MAX(X(I),XMAX)
30437 XMIN=MIN(X(I),XMIN)
30439 XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30442 DO 1100 K=0,IZEIL-1
30444 IF (ITEST.EQ.IYRAST) THEN
30445 DO 1010 L=1,ISPALT-1
30450 DO 1020 L=0,ISPALT-1,IXRAST
30454 DO 1030 L=1,ISPALT-1
30457 DO 1040 L=0,ISPALT-1,IXRAST
30469 YMAX=MAX(Y1(I),YMAX)
30470 YMIN=MIN(Y1(I),YMIN)
30474 YMAX=MAX(Y2(I),YMAX)
30475 YMIN=MIN(Y2(I),YMIN)
30478 YMAX=(YMAX-YMIN)/40.0D0+YMAX
30479 YMIN=YMIN-(YMAX-YMIN)/40.0D0
30480 YZOOM=(YMAX-YMIN)/DBLE(IZEIL)
30481 IF(YZOOM.LT.EPS) THEN
30482 WRITE(LOUT,'(1X,A)')
30483 & 'XGRAPH:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30492 L=NINT((X(K)-XMIN)/XZOOM)
30493 I=NINT((YMAX-Y1(K))/YZOOM)
30494 IF(ILAST.GE.0) THEN
30497 DO 55 II=0,LD,SIGN(1,LD)
30498 DO 66 KK=0,ID,SIGN(1,ID)
30499 COL(II+LLAST,KK+ILAST)=SYMB(1)
30514 L=NINT((X(K)-XMIN)/XZOOM)
30515 I=NINT((YMAX-Y2(K))/YZOOM)
30522 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30524 C*** write range of X
30526 XZOOM = (XMAX-XMIN)/DBLE(7)
30527 WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30529 DO 1300 K=0,IZEIL-1
30530 YPOS=YMAX-((DBLE(K)+0.5D0)*YZOOM)
30531 WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30532 110 FORMAT(1X,1PE9.2,70A1)
30535 C*** write range of X
30537 XZOOM = (XMAX-XMIN)/DBLE(7)
30538 WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30539 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30540 120 FORMAT(6X,7(1PE10.3))
30543 *$ CREATE DT_XGLOGY.FOR
30546 *===qglogy=============================================================*
30548 SUBROUTINE DT_XGLOGY(N,IARG,X,Y1,Y2)
30549 C***********************************************************************
30551 C calculate quasi graphic picture with 25 lines and 79 columns
30552 C logarithmic y axis
30553 C ranges will be chosen automatically
30555 C input N dimension of input fields
30556 C IARG number of curves (fields) to plot
30561 C This subroutine is written by R. Engel.
30562 C***********************************************************************
30564 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30567 PARAMETER ( LINP = 10 ,
30571 DIMENSION X(N),Y1(N),Y2(N)
30572 PARAMETER (EPS=1.D-30)
30573 PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30575 CHARACTER COL(0:149,0:49)
30576 PARAMETER (DEPS = 1.D-10)
30578 DATA SYMB /'0','e','z','#','x'/
30582 C*** automatic range fitting
30587 XMAX=MAX(X(I),XMAX)
30588 XMIN=MIN(X(I),XMIN)
30590 XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30593 DO 1100 K=0,IZEIL-1
30595 IF (ITEST.EQ.IYRAST) THEN
30596 DO 1010 L=1,ISPALT-1
30601 DO 1020 L=0,ISPALT-1,IXRAST
30605 DO 1030 L=1,ISPALT-1
30608 DO 1040 L=0,ISPALT-1,IXRAST
30618 YMIN=MAX(Y1(1),EPS)
30620 YMAX =MAX(Y1(I),YMAX)
30621 IF(Y1(I).GT.EPS) THEN
30622 IF(YMIN.EQ.EPS) THEN
30625 YMIN = MIN(Y1(I),YMIN)
30631 YMAX=MAX(Y2(I),YMAX)
30632 IF(Y2(I).GT.EPS) THEN
30633 IF(YMIN.EQ.EPS) THEN
30636 YMIN = MIN(Y2(I),YMIN)
30643 Y1(I) = MAX(Y1(I),YMIN)
30647 Y2(I) = MAX(Y2(I),YMIN)
30651 IF(YMAX.LE.YMIN) THEN
30652 WRITE(LOUT,'(/1X,A,2E12.3,/)')
30653 & 'XGLOGY:ERROR:YMIN,YMAX ',YMIN,YMAX
30654 WRITE(LOUT,'(1X,A)') 'MIN = MAX, OUTPUT SUPPRESSED'
30658 YMA=(LOG10(YMAX)-LOG10(YMIN))/20.0D0+LOG10(YMAX)
30659 YMI=LOG10(YMIN)-(LOG10(YMAX)-LOG10(YMIN))/20.0D0
30660 YZOOM=(YMA-YMI)/DBLE(IZEIL)
30661 IF(YZOOM.LT.EPS) THEN
30662 WRITE(LOUT,'(1X,A)')
30663 & 'XGLOGY:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30672 L=NINT((X(K)-XMIN)/XZOOM)
30673 I=NINT((YMA-LOG10(Y1(K)))/YZOOM)
30674 IF(ILAST.GE.0) THEN
30677 DO 55 II=0,LD,SIGN(1,LD)
30678 DO 66 KK=0,ID,SIGN(1,ID)
30679 COL(II+LLAST,KK+ILAST)=SYMB(1)
30694 L=NINT((X(K)-XMIN)/XZOOM)
30695 I=NINT((YMA-LOG10(Y2(K)))/YZOOM)
30702 WRITE(LOUT,'(2X,A)') '(LOGARITHMIC Y AXIS)'
30703 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30705 C*** write range of X
30707 XZOOM1 = (XMAX-XMIN)/DBLE(7)
30708 WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30710 DO 1300 K=0,IZEIL-1
30711 YPOS=10.D0**(YMA-((DBLE(K)+0.5D0)*YZOOM))
30712 WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30713 110 FORMAT(1X,1PE9.2,70A1)
30716 C*** write range of X
30718 WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30719 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30720 120 FORMAT(6X,7(1PE10.3))
30724 *$ CREATE DT_SRPLOT.FOR
30727 *===plot===============================================================*
30729 SUBROUTINE DT_SRPLOT(X,Y,N,M,MM,XO,DX,YO,DY)
30731 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30734 PARAMETER ( LINP = 10 ,
30740 * J. Ranft, (FORTRAN-Programmierung,J.R.,Teubner, Leipzig, 72)
30741 * This is a subroutine of fluka to plot Y across the page
30742 * as a function of X down the page. Up to 37 curves can be
30743 * plotted in the same picture with different plotting characters.
30744 * Output of first 10 overprinted characters addad by FB 88
30745 * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
30748 * X = array containing the values of X
30749 * Y = array containing the values of Y
30750 * N = number of values in X and in Y
30751 * can exceed the fixed number of lines
30752 * M = number of different curves X,Y are containing
30753 * MM = number of points in each curve i.e. N=M*MM
30754 * XO = smallest value of X to be plotted
30755 * DX = increment of X between subsequent lines
30756 * YO = smallest value of Y to be plotted
30757 * DY = increment of Y between subsequent character spaces
30759 * other variables used inside:
30760 * XX = numbers along the X-coordinate axis
30761 * YY = numbers along the Y-coordinate axis
30762 * LL = ten lines temporary storage for the plot
30763 * L = character set used to plot different curves
30764 * LOV = memorizes overprinted symbols
30765 * the first 10 overprinted symbols are printed on
30766 * the end of the line to avoid ambiguities
30767 * (added by FB as considered quite helpful)
30769 *********************************************************************
30771 DIMENSION XX(61),YY(61),LL(101,10)
30772 DIMENSION X(N),Y(N),L(40),LOV(40,10)
30773 INTEGER*4 LL, L, LOV
30775 11H*,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HZ,
30776 21H+,1HA,1HO,1HB,1HC,1HD,1HE,1HF,1HG,1HH,
30777 31HI,1HJ,1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,
30778 41HS,1HT,1HU,1HV,1HW,1HX,1HY,1H1,1H-,1H /
30787 20 YY(I)=YO+10.0D0*AI*DY
30788 WRITE(LOUT, 500) (YY(I),I=1,11)
30810 AIX=(X(II)-(XO-DX/2.0D0))/DX+1.0D0
30811 AIY=(Y(II)-(YO-DY/2.0D0))/DY+1.0D0
30813 * changed Sept.88 by FB to avoid INTEGER OVERFLOW
30814 IF( AIX .GT. 1.D0.AND. AIX .LT. 11.D0.AND. AIY .GT. 1.D0.AND
30815 + . AIY .LT. 102.D0) THEN
30818 IF( IX.GT. 0.AND. IX.LE. 10.AND. IY.GT. 0.AND. IY.LE. 101)
30820 IF(LL(IY,IX).NE.L(38).AND.LL(IY,IX).NE.L(39)) LOV(I,IX)
30831 WRITE(LOUT,510) XX(II),XX(III) , (LL(J,I),J=1,101) ,
30832 & (LOV(J,I),J=1,10)
30838 WRITE(LOUT, 500) (YY(I),I=1,11)
30841 500 FORMAT(11X,11(1PE10.2),11HOVERPRINTED)
30842 510 FORMAT(1X,2(1PE10.2),101A1,1H ,10A1)
30843 520 FORMAT(20X,10('1---------'),'1')
30845 *$ CREATE DT_DEFSET.FOR
30848 *===defset=============================================================*
30850 BLOCK DATA DT_DEFSET
30852 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30855 * flags for input different options
30856 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
30857 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
30858 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
30860 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
30862 * emulsion treatment
30863 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
30867 DATA IFRAG / 2, 1 /
30871 DATA IOULEV / -1, -1, -1, -1, -1, -1 /
30872 DATA LEMCCK / .FALSE. /
30873 DATA LHADRO / .FALSE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,
30874 & .TRUE.,.TRUE.,.TRUE./
30875 DATA LSEADI / .TRUE. /
30876 DATA LEVAPO / .TRUE. /
30881 DATA EMUFRA / NCOMPX*0.0D0 /
30882 DATA IEMUMA / NCOMPX*1 /
30883 DATA IEMUCH / NCOMPX*1 /
30889 *$ CREATE DT_HADPRP.FOR
30892 *===hadprp=============================================================*
30894 BLOCK DATA DT_HADPRP
30896 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30899 * auxiliary common for reggeon exchange (DTUNUC 1.x)
30900 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
30901 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
30902 & IQTCHR(-6:6),MQUARK(3,39)
30904 * hadron index conversion (BAMJET <--> PDG)
30905 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
30906 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
30909 * names of hadrons used in input-cards
30911 COMMON /DTPAIN/ BTYPE(30)
30914 *----------------------------------------------------------------------*
30916 * Quark content of particles: *
30917 * index quark el. charge bar. charge isospin isospin3 *
30918 * 1 = u 2/3 1/3 1/2 1/2 *
30919 * -1 = ubar -2/3 -1/3 1/2 -1/2 *
30920 * 2 = d -1/3 1/3 1/2 -1/2 *
30921 * -2 = dbar 1/3 -1/3 1/2 1/2 *
30922 * 3 = s -1/3 1/3 0 0 *
30923 * -3 = sbar 1/3 -1/3 0 0 *
30924 * 4 = c 2/3 1/3 0 0 *
30925 * -4 = cbar -2/3 -1/3 0 0 *
30926 * 5 = b -1/3 1/3 0 0 *
30927 * -5 = bbar 1/3 -1/3 0 0 *
30928 * 6 = t 2/3 1/3 0 0 *
30929 * -6 = tbar -2/3 -1/3 0 0 *
30931 * Mquark = particle quark composition (Paprop numbering) *
30932 * Iqechr = electric charge ( in 1/3 unit ) *
30933 * Iqbchr = baryonic charge ( in 1/3 unit ) *
30934 * Iqichr = isospin ( in 1/2 unit ), z component *
30935 * Iqschr = strangeness *
30937 * Iquchr = beauty *
30938 * Iqtchr = ...... *
30940 *----------------------------------------------------------------------*
30941 DATA IQECHR / -2, 1, -2, 1, 1, -2, 0, 2, -1, -1, 2, -1, 2 /
30942 DATA IQBCHR / 6*-1, 0, 6*1 /
30943 DATA IQICHR / 4*0, 1, -1, 0, 1, -1, 4*0 /
30944 DATA IQSCHR / 3*0, 1, 5*0, -1, 3*0 /
30945 DATA IQCCHR / 2*0, -1, 7*0, 1, 2*0 /
30946 DATA IQUCHR / 0, 1, 9*0, -1, 0 /
30947 DATA IQTCHR / -1, 11*0, 1 /
30949 & 2, 1, 1, -2,-1,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
30950 & 0, 0, 0, 0, 0, 0, 2, 2, 1, -2,-2,-1, 0, 0, 0,
30951 & 0, 0, 0, 0, 0, 0, 1,-2, 0, 2,-1, 0, 1,-3, 0,
30952 & 3,-1, 0, 1, 2, 3, -1,-2,-3, 0, 0, 0, 2, 2, 3,
30953 & 1, 1, 3, 1, 2, 3, 1,-1, 0, 2,-3, 0, 3,-2, 0,
30954 & 2,-2, 0, 3,-3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
30955 & -1,-1,-3, -1,-2,-3, -2,-2,-3, 1, 3, 3, -1,-3,-3,
30956 & 2, 3, 3, -2,-3,-3, 3, 3, 3, -3,-3,-3 /
30959 * (renamed) (HAdron InDex COnversion)
30960 * translation table version filled up by r.e. 25.01.94 *
30962 &2212,-2212,11,-11,12, -12,22,2112,-2112,-13,
30963 &13,130,211,-211,321, -321,3122,-3122,310,3112,
30964 &3222,3212,111,311,-311, 0,0,0,0,0,
30965 &221,213,113,-213,223, 323,313,-323,-313,10323,
30966 &10313,-10323,-10313,30323,30313, -30323,-30313,3224,3214,3114,
30967 &3216,3218,2224,2214,2114, 1114,12224,12214,12114,11114,
30968 &99999,99999,22212,22112,32124, 31214,-2224,-2214,-2114,-1114,
30969 &-12224,-12214,-12114,-11114,-2124, -1214,4*99999,
30971 &4*99999,331, 333,3322,3312,-3222,-3212,
30972 &-3112,-3322,-3312,3224,3214, 3114,3324,3314,3334,-3224,
30973 &-3214,-3114,-3324,-3314,-3334, 421,411,-411,-421,431,
30974 &-431,441,423,413,-413, -423,433,-433,20443,443,
30975 &-15,15,16,-16,14, -14,4122,4232,4132,4222,
30976 &4212,4112,3*99999, 3*99999,-4122,-4232,
30977 &-4132,-4222,-4212,-4112,99999, 5*99999,
30980 &5*99999 , 20211,20111,-20211,99999,20321,
30981 &-20321,20311,-20311,7*99999 ,
30982 &7*99999,12212,12112,99999/
30985 * (HAdron InDex COnversion)
30986 DATA (IPDG2(1,K),K=1,7)
30987 & / -11, -12, -13, -15, -16, -14, 0/
30988 DATA (IBAM2(1,K),K=1,7)
30989 & / 4, 6, 10, 131, 134, 136, 0/
30990 DATA (IPDG2(2,K),K=1,7)
30991 & / 11, 12, 22, 13, 15, 16, 14/
30992 DATA (IBAM2(2,K),K=1,7)
30993 & / 3, 5, 7, 11, 132, 133, 135/
30994 DATA (IPDG3(1,K),K=1,22)
30995 & / -211, -321, -311, -213, -323, -313, -411, -421,
30996 & -431, -413, -423, -433, 0, 0, 0, 0,
30997 & 0, 0, 0, 0, 0, 0/
30998 DATA (IBAM3(1,K),K=1,22)
30999 & / 14, 16, 25, 34, 38, 39, 118, 119,
31000 & 121, 125, 126, 128, 0, 0, 0, 0,
31001 & 0, 0, 0, 0, 0, 0/
31002 DATA (IPDG3(2,K),K=1,22)
31003 & / 130, 211, 321, 310, 111, 311, 221, 213,
31004 & 113, 223, 323, 313, 331, 333, 421, 411,
31005 & 431, 441, 423, 413, 433, 443/
31006 DATA (IBAM3(2,K),K=1,22)
31007 & / 12, 13, 15, 19, 23, 24, 31, 32,
31008 & 33, 35, 36, 37, 95, 96, 116, 117,
31009 & 120, 122, 123, 124, 127, 130/
31010 DATA (IPDG4(1,K),K=1,29)
31011 & / -2212, -2112, -3122, -2224, -2214, -2114, -1114, -2124,
31012 & -1214, -3222, -3212, -3112, -3322, -3312, -3224, -3214,
31013 & -3114, -3324, -3314, -3334, -4122, -4232, -4132, -4222,
31014 & -4212, -4112, 0, 0, 0/
31015 DATA (IBAM4(1,K),K=1,29)
31016 & / 2, 9, 18, 67, 68, 69, 70, 75,
31017 & 76, 99, 100, 101, 102, 103, 110, 111,
31018 & 112, 113, 114, 115, 149, 150, 151, 152,
31019 & 153, 154, 0, 0, 0/
31020 DATA (IPDG4(2,K),K=1,29)
31021 & / 2212, 2112, 3122, 3112, 3222, 3212, 3224, 3214,
31022 & 3114, 3216, 3218, 2224, 2214, 2114, 1114, 3322,
31023 & 3312, 3224, 3214, 3114, 3324, 3314, 3334, 4122,
31024 & 4232, 4132, 4222, 4212, 4112/
31025 DATA (IBAM4(2,K),K=1,29)
31026 & / 1, 8, 17, 20, 21, 22, 48, 49,
31027 & 50, 51, 52, 53, 54, 55, 56, 97,
31028 & 98, 104, 105, 106, 107, 108, 109, 137,
31029 & 138, 139, 140, 141, 142/
31030 DATA (IPDG5(1,K),K=1,19)
31031 & /-10323,-10313,-30323,-30313,-12224,-12214,-12114,-11114,
31032 & -20211,-20321,-20311, 0, 0, 0, 0, 0,
31034 DATA (IBAM5(1,K),K=1,19)
31035 & / 42, 43, 46, 47, 71, 72, 73, 74,
31036 & 188, 191, 193, 0, 0, 0, 0, 0,
31038 DATA (IPDG5(2,K),K=1,19)
31039 & / 10323, 10313, 30323, 30313, 12224, 12214, 12114, 11114,
31040 & 22212, 22112, 32124, 31214, 20443, 20211, 20111, 20321,
31041 & 20311, 12212, 12112/
31042 DATA (IBAM5(2,K),K=1,19)
31043 & / 40, 41, 44, 45, 57, 58, 59, 60,
31044 & 63, 64, 65, 66, 129, 186, 187, 190,
31048 * internal particle names
31049 DATA BTYPE / 'PROTON ' , 'APROTON ' , 'ELECTRON' , 'POSITRON' ,
31050 &'NEUTRIE ' , 'ANEUTRIE' , 'PHOTON ' , 'NEUTRON ' , 'ANEUTRON' ,
31051 &'MUON+ ' , 'MUON- ' , 'KAONLONG' , 'PION+ ' , 'PION- ' ,
31052 &'KAON+ ' , 'KAON- ' , 'LAMBDA ' , 'ALAMBDA ' , 'KAONSHRT' ,
31053 &'SIGMA- ' , 'SIGMA+ ' , 'SIGMAZER' , 'PIZERO ' , 'KAONZERO' ,
31054 &'AKAONZER' , 'NEUTRIM ' , 'ANEUTRIM' , 'NEUTRIT ' , 'ANEUTRIT' ,
31059 *$ CREATE DT_BLKD46.FOR
31062 *===blkd46=============================================================*
31064 BLOCK DATA DT_BLKD46
31066 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31069 PARAMETER ( AMELCT = 0.51099906 D-03 )
31070 PARAMETER ( AMMUON = 0.105658389 D+00 )
31072 * particle properties (BAMJET index convention)
31074 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
31075 & IICH(210),IIBAR(210),K1(210),K2(210)
31078 * Particle masses Engel version JETSET compatible
31079 C DATA (AAM(K),K=1,85) /
31080 C & .9383D+00, .9383D+00, AMELCT , AMELCT , .0000D+00,
31081 C & .0000D+00, .0000D+00, .9396D+00, .9396D+00, AMMUON ,
31082 C & AMMUON , .4977D+00, .1396D+00, .1396D+00, .4936D+00,
31083 C & .4936D+00, .1116D+01, .1116D+01, .4977D+00, .1197D+01,
31084 C & .1189D+01, .1193D+01, .1350D+00, .4977D+00, .4977D+00,
31085 C & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31086 C & .5488D+00, .7669D+00, .7700D+00, .7669D+00, .7820D+00,
31087 C & .8921D+00, .8962D+00, .8921D+00, .8962D+00, .1300D+01,
31088 C & .1300D+01, .1300D+01, .1300D+01, .1421D+01, .1421D+01,
31089 C & .1421D+01, .1421D+01, .1383D+01, .1384D+01, .1387D+01,
31090 C & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
31091 C & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
31092 C & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
31093 C & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
31094 C & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
31095 C & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
31096 C & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 /
31097 C DATA (AAM(K),K=86,183) /
31098 C & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
31099 C & .1700D+01, .1700D+01, .1820D+01, .2030D+01, .9575D+00,
31100 C & .1019D+01, .1315D+01, .1321D+01, .1189D+01, .1193D+01,
31101 C & .1197D+01, .1315D+01, .1321D+01, .1383D+01, .1384D+01,
31102 C & .1387D+01, .1532D+01, .1535D+01, .1672D+01, .1383D+01,
31103 C & .1384D+01, .1387D+01, .1532D+01, .1535D+01, .1672D+01,
31104 C & .1865D+01, .1869D+01, .1869D+01, .1865D+01, .1969D+01,
31105 C & .1969D+01, .2980D+01, .2007D+01, .2010D+01, .2010D+01,
31106 C & .2007D+01, .2113D+01, .2113D+01, .3686D+01, .3097D+01,
31107 C & .1784D+01, .1784D+01, .0000D+00, .0000D+00, .0000D+00,
31108 C & .0000D+00, .2285D+01, .2460D+01, .2460D+01, .2452D+01,
31109 C & .2453D+01, .2454D+01, .2560D+01, .2560D+01, .2730D+01,
31110 C & .3610D+01, .3610D+01, .3790D+01, .2285D+01, .2460D+01,
31111 C & .2460D+01, .2452D+01, .2453D+01, .2454D+01, .2560D+01,
31112 C & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
31113 C & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31114 C & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31115 C & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31116 C & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31117 C & .1250D+01, .1250D+01, .1250D+01 /
31118 C DATA (AAM ( I ), I = 184,210 ) /
31119 C & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31120 C & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31121 C & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31122 C & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31123 C & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31124 C & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31125 C & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31126 C & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31127 C & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31128 * sr 25.1.06: particle masses adjusted to Pythia
31129 DATA (AAM(K),K=1,85) /
31130 & .938270E+00,.938270E+00, AMELCT , AMELCT ,.000000E+00,
31131 & .000000E+00,.000000E+00,.939570E+00,.939570E+00, AMMUON ,
31132 & AMMUON ,.497670E+00,.139570E+00,.139570E+00,.493600E+00,
31133 & .493600E+00,.111568E+01,.111568E+01,.497670E+00,.119744E+01,
31134 & .118937E+01,.119255E+01,.134980E+00,.497670E+00,.497670E+00,
31135 & .0000D+00, .0000D+00, .0000D+00 , .0000D+00, .0000D+00,
31136 & .547450E+00,.766900E+00,.768500E+00,.766900E+00,.781940E+00,
31137 & .891600E+00,.896100E+00,.891600E+00,.896100E+00,.129000E+01,
31138 & .129000E+01,.129000E+01,.129000E+01, .1421D+01, .1421D+01,
31139 & .1421D+01, .1421D+01,.138280E+01,.138370E+01,.138720E+01,
31140 & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
31141 & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
31142 & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
31143 & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
31144 & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
31145 & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
31146 & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 /
31147 DATA (AAM(K),K=86,183) /
31148 & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
31149 & .1700D+01, .1700D+01, .1820D+01, .2030D+01,.957770E+00,
31150 & .101940E+01,.131490E+01,.132130E+01,.118937E+01,.119255E+01,
31151 & .119744E+01,.131490E+01,.132130E+01,.138280E+01,.138370E+01,
31152 & .138720E+01,.153180E+01, .1535D+01,.167245E+01,.138280E+01,
31153 & .138370E+01,.138720E+01,.153180E+01, .1535D+01,.167245E+01,
31154 & .186450E+01,.186930E+01,.186930E+01,.186450E+01,.196850E+01,
31155 & .196850E+01,.297980E+01,.200670E+01, .2010D+01, .2010D+01,
31156 & .200670E+01,.211240E+01,.211240E+01, .3686D+01,.309688E+01,
31157 & .177700E+01,.177700E+01, .0000D+00, .0000D+00, .0000D+00,
31158 & .0000D+00,.228490E+01,.246560E+01,.247030E+01,.245290E+01,
31159 & .245350E+01,.245210E+01, .2560D+01, .2560D+01, .2730D+01,
31160 & .3610D+01, .3610D+01, .3790D+01,.228490E+01,.246560E+01,
31161 & .2460D+01,.245290E+01,.245350E+01,.245210E+01, .2560D+01,
31162 & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
31163 & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31164 & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31165 & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31166 & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31167 & .1250D+01, .1250D+01, .1250D+01 /
31168 DATA (AAM ( I ), I = 184,210 ) /
31169 & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31170 & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31171 & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31172 & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31173 & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31174 & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31175 & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31176 & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31177 & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31178 * Particle mean lives
31179 DATA (TAU(K),K=1,183) /
31180 & .1000D+19, .1000D+19, .1000D+19, .1000D+19, .1000D+19,
31181 & .1000D+19, .1000D+19, .9180D+03, .9180D+03, .2200D-05,
31182 & .2200D-05, .5200D-07, .2600D-07, .2600D-07, .1200D-07,
31183 & .1200D-07, .2600D-09, .2600D-09, .9000D-10, .1500D-09,
31184 & .8000D-10, .5000D-14, .8000D-16, .0000D+00, .0000D+00,
31186 & .0000D+00, .3000D-09, .1700D-09, .8000D-10, .1000D-13,
31187 & .1500D-09, .3000D-09, .1700D-09, .0000D+00, .0000D+00,
31188 & .0000D+00, .0000D+00, .0000D+00, .1000D-09, .0000D+00,
31189 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .1000D-09,
31190 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31191 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31192 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31193 & .9000D-11, .9000D-11, .9000D-11, .9000D-11, .1000D+19,
31194 & .1000D+19, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31196 & .0000D+00, .0000D+00, .0000D+00 /
31197 DATA ( TAU ( I ), I = 184,210 ) /
31198 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31199 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31200 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31201 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31202 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31203 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31204 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31205 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31206 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00/
31207 * Resonance width Gamma in GeV
31208 DATA (GA(K),K= 1,85) /
31210 & .8500D-06, .1520D+00, .1520D+00, .1520D+00, .1000D-01,
31211 & .7900D-01, .7900D-01, .7900D-01, .7900D-01, .4500D+00,
31212 & .4500D+00, .4500D+00, .4500D+00, .1080D+00, .1080D+00,
31213 & .1080D+00, .1080D+00, .5000D-01, .5000D-01, .5000D-01,
31214 & .8500D-01, .1800D+00, .1150D+00, .1150D+00, .1150D+00,
31215 & .1150D+00, .2000D+00, .2000D+00, .2000D+00, .2000D+00,
31216 & .2000D+00, .2000D+00, .1000D+00, .1000D+00, .2000D+00,
31217 & .2000D+00, .1150D+00, .1150D+00, .1150D+00, .1150D+00,
31218 & .2000D+00, .2000D+00, .2000D+00, .2000D+00, .1000D+00,
31219 & .1000D+00, .2000D+00, .1000D+00, .1000D+00, .1000D+00,
31220 & .1000D+00, .1000D+00, .1000D+00, .1000D+00, .2000D+00 /
31221 DATA (GA(K),K= 86,183) /
31222 & .2000D+00, .2000D+00, .2000D+00, .1500D+00, .1500D+00,
31223 & .1500D+00, .1500D+00, .8500D-01, .1800D+00, .2000D-02,
31224 & .4000D-02, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31225 & .0000D+00, .0000D+00, .0000D+00, .3400D-01, .3400D-01,
31226 & .3600D-01, .9000D-02, .9000D-02, .0000D+00, .3400D-01,
31227 & .3400D-01, .3600D-01, .9000D-02, .9000D-02, .0000D+00,
31228 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31229 & .0000D+00, .0000D+00, .5000D-02, .2000D-02, .2000D-02,
31230 & .5000D-02, .2000D-02, .2000D-02, .2000D-03, .7000D-03,
31232 & .3000D+00, .3000D+00, .3000D+00 /
31233 DATA ( GA ( I ), I = 184,210 ) /
31234 & 2.00000000000000D-01, 2.00000000000000D-01, 3.00000000000000D-01,
31235 & 3.00000000000000D-01, 3.00000000000000D-01, 2.70000000000000D-01,
31236 & 2.50000000000000D-01, 2.50000000000000D-01, 2.50000000000000D-01,
31237 & 2.50000000000000D-01, 1.50000000000000D-01, 1.50000000000000D-01,
31238 & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31239 & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31240 & 6.00000000000000D-02, 6.00000000000000D-02, 6.00000000000000D-02,
31241 & 6.00000000000000D-02, 5.50000000000000D-02, 5.50000000000000D-02,
31242 & 2.00000000000000D-01, 2.00000000000000D-01, 0.00000000000000D+00/
31244 * S+1385+Sigma+(1385) L02030+Lambda0(2030)
31245 * Rho77=Rho(770) Om783=Omega(783) K*14=K*(1420) and so on
31246 * designation N*@@ means N*@1(@2)
31247 DATA (ANAME(K),K=1,85) /
31248 & 'P ','AP ','E- ','E+ ','NUE ',
31249 & 'ANUE ','GAM ','NEU ','ANEU ','MUE+ ',
31250 & 'MUE- ','K0L ','PI+ ','PI- ','K+ ',
31251 & 'K- ','LAM ','ALAM ','K0S ','SIGM- ',
31252 & 'SIGM+ ','SIGM0 ','PI0 ','K0 ','AK0 ',
31253 & 'BLANK ','BLANK ','BLANK ','BLANK ','BLANK ',
31254 & 'ETA550 ','RHO+77 ','RHO077 ','RHO-77 ','OM0783 ',
31255 & 'K*+892 ','K*0892 ','K*-892 ','AK*089 ','KA+125 ',
31256 & 'KA0125 ','KA-125 ','AKA012 ','K*+142 ','K*0142 ',
31257 & 'K*-142 ','AK*014 ','S+1385 ','S01385 ','S-1385 ',
31258 & 'L01820 ','L02030 ','N*++12 ','N*+ 12 ','N*012 ',
31259 & 'N*-12 ','N*++16 ','N*+16 ','N*016 ','N*-16 ',
31260 & 'N*+14 ','N*014 ','N*+15 ','N*015 ','N*+18 ',
31261 & 'N*018 ','AN--12 ','AN*-12 ','AN*012 ','AN*+12 ',
31262 & 'AN--16 ','AN*-16 ','AN*016 ','AN*+16 ','AN*-15 ',
31263 & 'AN*015 ','DE*=24 ','RPI+49 ','RPI049 ','RPI-49 ',
31264 & 'PIN++ ','PIN+0 ','PIN+- ','PIN-0 ','PPPI ' /
31265 DATA (ANAME(K),K=86,183) /
31266 & 'PNPI ','APPPI ','APNPI ','K+PPI ','K-PPI ',
31267 & 'K+NPI ','K-NPI ','S+1820 ','S-2030 ','ETA* ',
31268 & 'PHI ','TETA0 ','TETA- ','ASIG- ','ASIG0 ',
31269 & 'ASIG+ ','ATETA0 ','ATETA+ ','SIG*+ ','SIG*0 ',
31270 & 'SIG*- ','TETA*0 ','TETA* ','OMEGA- ','ASIG*- ',
31271 & 'ASIG*0 ','ASIG*+ ','ATET*0 ','ATET*+ ','OMEGA+ ',
31272 & 'D0 ','D+ ','D- ','AD0 ','F+ ',
31273 & 'F- ','ETAC ','D*0 ','D*+ ','D*- ',
31274 & 'AD*0 ','F*+ ','F*- ','PSI ','JPSI ',
31275 & 'TAU+ ','TAU- ','NUET ','ANUET ','NUEM ',
31276 & 'ANUEM ','C0+ ','A+ ','A0 ','C1++ ',
31277 & 'C1+ ','C10 ','S+ ','S0 ','T0 ',
31278 & 'XU++ ','XD+ ','XS+ ','AC0- ','AA- ',
31279 & 'AA0 ','AC1-- ','AC1- ','AC10 ','AS- ',
31280 & 'AS0 ','AT0 ','AXU-- ','AXD- ','AXS ',
31281 & 'C1*++ ','C1*+ ','C1*0 ','S*+ ','S*0 ',
31282 & 'T*0 ','XU*++ ','XD*+ ','XS*+ ','TETA++ ',
31283 & 'AC1*-- ','AC1*- ','AC1*0 ','AS*- ','AS*0 ',
31284 & 'AT*0 ','AXU*-- ','AXD*- ','AXS*- ','ATET-- ',
31285 & 'RO ','R+ ','R- ' /
31286 DATA ( ANAME ( I ), I = 184,210 ) /
31287 &'AN*-14 ','AN*014 ','PI+130 ','PI0130 ','PI-130 ','F01400 ',
31288 &'K*+146 ','K*-146 ','K*0146 ','AK0146 ','L01600 ','AL0160 ',
31289 &'S+1660 ','S01660 ','S-1660 ','AS-166 ','AS0166 ','AS+166 ',
31290 &'X01950 ','X-1950 ','AX0195 ','AX+195 ','OM-225 ','AOM+22 ',
31291 &'N*+14 ','N*014 ','BLANK '/
31292 * Charge of particles and resonances
31293 DATA (IICH ( I ), I = 1,210 ) /
31294 & 1, -1, -1, 1, 0, 0, 0, 0, 0, 1, -1, 0, 1, -1, 1,
31295 & -1, 0, 0, 0, -1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31296 & 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0,
31297 & -1, 0, 1, 0, -1, 0, 0, 2, 1, 0, -1, 2, 1, 0, -1,
31298 & 1, 0, 1, 0, 1, 0, -2, -1, 0, 1, -2, -1, 0, 1, -1,
31299 & 0, 1, 1, 0, -1, 2, 1, 0, -1, 2, 1, 0, -1, 2, 0,
31300 & 1, -1, 1, -1, 0, 0, 0, -1, -1, 0, 1, 0, 1, 1, 0,
31301 & -1, 0, -1, -1, -1, 0, 1, 0, 1, 1, 0, 1, -1, 0, 1,
31302 & -1, 0, 0, 1, -1, 0, 1, -1, 0, 0, 1, -1, 0, 0, 0,
31303 & 0, 1, 1, 0, 2, 1, 0, 1, 0, 0, 2, 1, 1, -1, -1,
31304 & 0, -2, -1, 0, -1, 0, 0, -2, -1, -1, 2, 1, 0, 1, 0,
31305 & 0, 2, 1, 1, 2, -2, -1, 0, -1, 0, 0, -2, -1, -1, -2,
31306 & 0, 1, -1, -1, 0, 1, 0, -1, 0, 1, -1, 0, 0, 0, 0,
31307 & 1, 0, -1, -1, 0, 1, 0, -1, 0, 1, -1, 1, 1, 0, 0/
31308 * Particle baryonic charges
31309 DATA (IIBAR ( I ), I = 1,210 ) /
31310 & 1, -1, 0, 0, 0, 0, 0, 1, -1, 0, 0, 0, 0, 0, 0,
31311 & 0, 1, -1, 0, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0,
31312 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31313 & 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
31314 & 1, 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31315 & -1, 2, 0, 0, 0, 1, 1, 1, 1, 2, 2, 0, 0, 1, 1,
31316 & 1, 1, 1, 1, 0, 0, 1, 1, -1, -1, -1, -1, -1, 1, 1,
31317 & 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, 0, 0, 0, 0, 0,
31318 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31319 & 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, -1, -1,
31320 & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 1, 1, 1, 1, 1,
31321 & 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31322 & 0, 0, 0, -1, -1, 0, 0, 0, 0, 0, 0, 0, 0, 1, -1,
31323 & 1, 1, 1, -1, -1, -1, 1, 1, -1, -1, 1, -1, 1, 1, 0/
31324 * First number of decay channels used for resonances
31325 * and decaying particles
31326 DATA K1/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 16, 17,
31327 & 18, 24, 30, 34, 38, 40, 41, 43, 44, 136, 138, 330, 327, 328,
31328 & 2*330, 46, 51, 52, 54, 55, 58,
31330 & 60, 62, 64, 66, 68, 70, 72, 74, 82, 90, 98, 106, 109, 112, 114,
31331 & 123, 140, 141, 143, 145, 146, 150, 157, 164, 168, 174, 180, 187,
31332 & 194, 202, 210, 211, 213, 215, 216, 220, 227, 234, 238, 245, 252,
31334 & 254, 255, 256, 257, 259, 262, 265, 267, 269, 272, 276, 279, 282,
31335 & 286, 290, 293, 299, 331, 335, 339, 340, 341, 343, 344, 345, 346,
31336 & 347, 350, 353, 356, 358, 360, 363, 366, 369, 372, 374, 376, 379,
31337 & 383, 385, 387, 391, 394, 397, 400, 402, 405, 408, 410, 412, 414,
31338 & 417, 420, 425, 430, 431, 432, 433, 434, 448, 452, 457, 458, 459,
31339 & 460, 461, 462, 466, 468, 470, 472, 486, 490, 495, 496, 497, 498,
31340 & 499, 500, 504, 506, 508, 510, 511, 512, 513, 514, 515, 516, 517,
31341 & 518, 519, 522, 523, 524, 525, 526, 527, 528, 529, 530, 531, 534,
31342 & 537, 539, 541, 547, 553, 558, 563, 568, 572, 573, 574, 575, 576,
31343 & 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, 589,
31345 * Last number of decay channels used for resonances
31346 * and decaying particles
31347 DATA K2/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 15, 16, 17,
31348 & 23, 29, 31, 35, 39, 40, 42, 43, 45, 137, 139, 330, 327, 328,
31349 & 2* 330, 50, 51, 53, 54, 57,
31351 & 59, 61, 63, 65, 67, 69, 71, 73, 81, 89, 97, 105, 108, 111, 113,
31352 & 122, 135, 140, 142, 144, 145, 149, 156, 163, 167, 173, 179, 186,
31353 & 193, 201, 209, 210, 212, 214, 215, 219, 226, 233, 237, 244, 251,
31355 & 253, 254, 255, 256, 258, 261, 264, 266, 268, 271, 275, 278, 281,
31356 & 285, 289, 292, 298, 307, 334, 338, 339, 340, 342, 343, 344, 345,
31357 & 346, 349, 352, 355, 357, 359, 362, 365, 368, 371, 373, 375, 378,
31358 & 382, 384, 386, 390, 393, 396, 399, 401, 404, 407, 409, 411, 413,
31359 & 416, 419, 424, 429, 430, 431, 432, 433, 447, 451, 456, 457, 458,
31360 & 459, 460, 461, 465, 467, 469, 471, 485, 489, 494, 495, 496, 497,
31361 & 498, 499, 503, 505, 507, 509, 510, 511, 512, 513, 514, 515, 516,
31362 & 517, 518, 521, 522, 523, 524, 525, 526, 527, 528, 529, 530, 533,
31363 & 536, 538, 540, 546, 552, 557, 562, 567, 571, 572, 573, 574, 575,
31364 & 576, 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588,
31365 & 589, 595, 601, 602 /
31369 *$ CREATE DT_BLKD47.FOR
31372 *===blkd47=============================================================*
31374 BLOCK DATA DT_BLKD47
31376 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31379 * HADRIN: decay channel information
31380 PARAMETER (IDMAX9=602)
31382 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
31384 * Name of decay channel
31385 * Designation N*@ means N*@1(1236)
31386 * @1=# means ++, @1 = = means --
31387 * Designation P+/0/- means Pi+/Pi0/Pi- , respectively
31388 DATA (ZKNAME(K),K= 1, 85) /
31389 & 'P ','AP ','E- ','E+ ','NUE ',
31390 & 'ANUE ','GAM ','PE-NUE ','APEANU ','EANUNU ',
31391 & 'E-NUAN ','3PI0 ','PI+-0 ','PIMUNU ','PIE-NU ',
31392 & 'MU+NUE ','MU-NUE ','MU+NUE ','PI+PI0 ','PI++- ',
31393 & 'PI+00 ','M+P0NU ','E+P0NU ','MU-NU ','PI-0 ',
31394 & 'PI+-- ','PI-00 ','M-P0NU ','E-P0NU ','PPI- ',
31395 & 'NPI0 ','PD-NUE ','PM-NUE ','APPI+ ','ANPI0 ',
31396 & 'APE+NU ','APM+NU ','PI+PI- ','PI0PI0 ','NPI- ',
31397 & 'PPI0 ','NPI+ ','LAGA ','GAGA ','GAE+E- ',
31398 & 'GAGA ','GAGAP0 ','PI000 ','PI+-0 ','PI+-GA ',
31399 & 'PI+0 ','PI+- ','PI00 ','PI-0 ','PI+-0 ',
31400 & 'PI+- ','PI0GA ','K+PI0 ','K0PI+ ','KOPI0 ',
31401 & 'K+PI- ','K-PI0 ','AK0PI- ','AK0PI0 ','K-PI+ ',
31402 & 'K+PI0 ','K0PI+ ','K0PI0 ','K+PI- ','K-PI0 ',
31403 & 'K0PI- ','AK0PI0 ','K-PI+ ','K+PI0 ','K0PI+ ',
31404 & 'K+89P0 ','K08PI+ ','K+RO77 ','K0RO+7 ','K+OM07 ',
31405 & 'K+E055 ','K0PI0 ','K+PI+ ','K089P0 ','K+8PI- ' /
31406 DATA (ZKNAME(K),K= 86,170) /
31407 & 'K0R077 ','K+R-77 ','K+R-77 ','K0OM07 ','K0E055 ',
31408 & 'K-PI0 ','K0PI- ','K-89P0 ','AK08P- ','K-R077 ',
31409 & 'AK0R-7 ','K-OM07 ','K-E055 ','AK0PI0 ','K-PI+ ',
31410 & 'AK08P0 ','K-8PI+ ','AK0R07 ','AK0OM7 ','AK0E05 ',
31411 & 'LA0PI+ ','SI0PI+ ','SI+PI0 ','LA0PI0 ','SI+PI- ',
31412 & 'SI-PI+ ','LA0PI- ','SI0PI- ','NEUAK0 ','PK- ',
31413 & 'SI+PI- ','SI0PI0 ','SI-PI+ ','LA0ET0 ','S+1PI- ',
31414 & 'S-1PI+ ','SO1PI0 ','NEUAK0 ','PK- ','LA0PI0 ',
31415 & 'LA0OM0 ','LA0RO0 ','SI+RO- ','SI-RO+ ','SI0RO0 ',
31416 & 'LA0ET0 ','SI0ET0 ','SI+PI- ','SI-PI+ ','SI0PI0 ',
31417 & 'K0S ','K0L ','K0S ','K0L ','P PI+ ',
31418 & 'P PI0 ','N PI+ ','P PI- ','N PI0 ','N PI- ',
31419 & 'P PI+ ','N*#PI0 ','N*+PI+ ','PRHO+ ','P PI0 ',
31420 & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ',
31421 & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ',
31422 & 'N*-PI+ ','PRHO- ','NRHO0 ','N PI- ','N*0PI- ',
31423 & 'N*-PI0 ','NRHO- ','PETA0 ','N*#PI- ','N*+PI0 ' /
31424 DATA (ZKNAME(K),K=171,255) /
31425 & 'N*0PI+ ','PRHO0 ','NRHO+ ','NETA0 ','N*+PI- ',
31426 & 'N*0PI0 ','N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ',
31427 & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ',
31428 & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ',
31429 & 'N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ','N PI+ ',
31430 & 'PRHO0 ','NRHO+ ','LAMK+ ','S+ K0 ','S0 K+ ',
31431 & 'PETA0 ','P PI- ','N PI0 ','PRHO- ','NRHO0 ',
31432 & 'LAMK0 ','S0 K0 ','S- K+ ','NETA/ ','APPI- ',
31433 & 'APPI0 ','ANPI- ','APPI+ ','ANPI0 ','ANPI+ ',
31434 & 'APPI- ','AN*=P0 ','AN*-P- ','APRHO- ','APPI0 ',
31435 & 'ANPI- ','AN*=P+ ','AN*-P0 ','AN*0P- ','APRHO0 ',
31436 & 'ANRHO- ','APPI+ ','ANPI0 ','AN*-P+ ','AN*0P0 ',
31437 & 'AN*+P- ','APRHO+ ','ANRHO0 ','ANPI+ ','AN*0P+ ',
31438 & 'AN*+P0 ','ANRHO+ ','APPI0 ','ANPI- ','AN*=P+ ',
31439 & 'AN*-P0 ','AN*0P- ','APRHO0 ','ANRHO- ','APPI+, ',
31440 & 'ANPI0 ','AN*-P+ ','AN*0P0 ','AN*+P- ','APRHO+ ',
31441 & 'ANRHO0 ','PN*014 ','NN*=14 ','PI+0 ','PI+- ' /
31442 DATA (ZKNAME(K),K=256,340) /
31443 & 'PI-0 ','P+0 ','N++ ','P+- ','P00 ',
31444 & 'N+0 ','N+- ','N00 ','P-0 ','N-0 ',
31445 & 'P-- ','PPPI0 ','PNPI+ ','PNPI0 ','PPPI- ',
31446 & 'NNPI+ ','APPPI0 ','APNPI+ ','ANNPI0 ','ANPPI- ',
31447 & 'APNPI0 ','APPPI- ','ANNPI- ','K+PPI0 ','K+NPI+ ',
31448 & 'K0PPI0 ','K-PPI0 ','K-NPI+ ','AKPPI- ','AKNPI0 ',
31449 & 'K+NPI0 ','K+PPI- ','K0PPI0 ','K0NPI+ ','K-NPI0 ',
31450 & 'K-PPI- ','AKNPI- ','PAK0 ','SI+PI0 ','SI0PI+ ',
31451 & 'SI+ETA ','S+1PI0 ','S01PI+ ','NEUK- ','LA0PI- ',
31452 & 'SI-OM0 ','LA0RO- ','SI0RO- ','SI-RO0 ','SI-ET0 ',
31453 & 'SI0PI- ','SI-0 ','BLANC ','BLANC ','BLANC ',
31454 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31455 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31456 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31457 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31458 & 'EPI+- ','EPI00 ','GAPI+- ','GAGA* ','K+- ',
31459 & 'KLKS ','PI+-0 ','EGA ','LPI0 ','LPI ' /
31460 DATA (ZKNAME(K),K=341,425) /
31461 & 'APPI0 ','ANPI- ','ALAGA ','ANPI ','ALPI0 ',
31462 & 'ALPI+ ','LAPI+ ','SI+PI0 ','SI0PI+ ','LAPI0 ',
31463 & 'SI+PI- ','SI-PI+ ','LAPI- ','SI-PI0 ','SI0PI- ',
31464 & 'TE0PI0 ','TE-PI+ ','TE0PI- ','TE-PI0 ','TE0PI ',
31465 & 'TE-PI ','LAK- ','ALPI- ','AS-PI0 ','AS0PI- ',
31466 & 'ALPI0 ','AS+PI- ','AS-PI+ ','ALPI+ ','AS+PI0 ',
31467 & 'AS0PI+ ','AT0PI0 ','AT+PI- ','AT0PI+ ','AT+PI0 ',
31468 & 'AT0PI ','AT+PI ','ALK+ ','K-PI+ ','K-PI+0 ',
31469 & 'K0PI+- ','K0PI0 ','K-PI++ ','AK0PI+ ','K+PI-- ',
31470 & 'K0PI- ','K+PI- ','K+PI-0 ','AKPI-+ ','AK0PI0 ',
31471 & 'ETAPIF ','K++- ','K+AK0 ','ETAPI- ','K--+ ',
31472 & 'K-K0 ','PI00 ','PI+- ','GAGA ','D0PI0 ',
31473 & 'D0GA ','D0PI+ ','D+PI0 ','DFGA ','AD0PI- ',
31474 & 'D-PI0 ','D-GA ','AD0PI0 ','AD0GA ','F+GA ',
31475 & 'F+GA ','F-GA ','F-GA ','PSPI+- ','PSPI00 ',
31476 & 'PSETA ','E+E- ','MUE+- ','PI+-0 ','M+NN ',
31477 & 'E+NN ','RHO+NT ','PI+ANT ','K*+ANT ','M-NN ' /
31478 DATA (ZKNAME(K),K=426,510) /
31479 & 'E-NN ','RHO-NT ','PI-NT ','K*-NT ','NUET ',
31480 & 'ANUET ','NUEM ','ANUEM ','SI+ETA ','SI+ET* ',
31481 & 'PAK0 ','TET0K+ ','SI*+ET ','N*+AK0 ','N*++K- ',
31482 & 'LAMRO+ ','SI0RO+ ','SI+RO0 ','SI+OME ','PAK*0 ',
31483 & 'N*+AK* ','N*++K* ','SI+AK0 ','TET0PI ','SI+AK* ',
31484 & 'TET0RO ','SI0AK* ','SI+K*- ','TET0OM ','TET-RO ',
31485 & 'SI*0AK ','C0+PI+ ','C0+PI0 ','C0+PI- ','A+GAM ',
31486 & 'A0GAM ','TET0AK ','TET0K* ','OM-RO+ ','OM-PI+ ',
31487 & 'C1++AK ','A+PI+ ','C0+AK0 ','A0PI+ ','A+AK0 ',
31488 & 'T0PI+ ','ASI-ET ','ASI-E* ','APK0 ','ATET0K ',
31489 & 'ASI*-E ','AN*-K0 ','AN*--K ','ALAMRO ','ASI0RO ',
31490 & 'ASI-RO ','ASI-OM ','APK*0 ','AN*-K* ','AN*--K ',
31491 & 'ASI-K0 ','ATETPI ','ASI-K* ','ATETRO ','ASI0K* ',
31492 & 'ASI-K* ','ATE0OM ','ATE+RO ','ASI*0K ','AC-PI- ',
31493 & 'AC-PI0 ','AC-PI+ ','AA-GAM ','AA0GAM ','ATET0K ',
31494 & 'ATE0K* ','AOM+RO ','AOM+PI ','AC1--K ','AA-PI- ',
31495 & 'AC0-K0 ','AA0PI- ','AA-K0 ','AT0PI- ','C1++GA ' /
31496 DATA (ZKNAME(K),K=511,540) /
31497 & 'C1++GA ','C10GAM ','S+GAM ','S0GAM ','T0GAM ',
31498 & 'XU++GA ','XD+GAM ','XS+GAM ','A+AKPI ','T02PI+ ',
31499 & 'C1++2K ','AC1--G ','AC1-GA ','AC10GA ','AS-GAM ',
31500 & 'AS0GAM ','AT0GAM ','AXU--G ','AXD-GA ','AXS-GA ',
31501 & 'AA-KPI ','AT02PI ','AC1--K ','RH-PI+ ','RH+PI- ',
31502 & 'RH3PI0 ','RH0PI+ ','RH+PI0 ','RH0PI- ','RH-PI0 ' /
31503 DATA (ZKNAME(I),I=541,602)/
31504 & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHO0','ANRHO-','ANETA ',
31505 & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0','RH0PI+','RH+PI0',
31506 & '3PI+00','3PI-++','F0PI+ ','RH+PI-','RH0PI0','3PI000','3PI0+-',
31507 & 'F0PI0 ','RH0PI-','RH-PI0','3PI-00','3PI--+','F0PI- ','PI0PI0',
31508 & 'PI+PI-','K+K- ','K0AK0 ','L01600','AL0160','K*+146','K*-146',
31509 & 'K*0146','AK0146','S+1660','S01660','S-1660','AS-166','AS0166',
31510 & 'AS+166','X01690','X-1690','AX0169','AX+169','OM-225','AOM+22',
31511 & 'N*PPI0','N*NPI+','N*P2P0','N*PP+-','N*D+P0','N*D0P+','N*NPI0',
31512 & 'N*PPI-','N*N2P0','N*NP+-','N*D+P-','N*D0P0','BLANK '/
31513 * Weight of decay channel
31514 DATA (WT(K),K= 1, 85) /
31515 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31516 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31517 & .1000D+01, .2100D+00, .1200D+00, .2700D+00, .4000D+00,
31518 & .1000D+01, .1000D+01, .6400D+00, .2100D+00, .6000D-01,
31519 & .2000D-01, .3000D-01, .4000D-01, .6400D+00, .2100D+00,
31520 & .6000D-01, .2000D-01, .3000D-01, .4000D-01, .6400D+00,
31521 & .3600D+00, .0000D+00, .0000D+00, .6400D+00, .3600D+00,
31522 & .0000D+00, .0000D+00, .6900D+00, .3100D+00, .1000D+01,
31523 & .5200D+00, .4800D+00, .1000D+01, .9900D+00, .1000D-01,
31524 & .3800D+00, .3000D-01, .3000D+00, .2400D+00, .5000D-01,
31525 & .1000D+01, .1000D+01, .0000D+00, .1000D+01, .9000D+00,
31526 & .1000D-01, .9000D-01, .3300D+00, .6700D+00, .3300D+00,
31527 & .6700D+00, .3300D+00, .6700D+00, .3300D+00, .6700D+00,
31528 & .3300D+00, .6700D+00, .3300D+00, .6700D+00, .3300D+00,
31529 & .6700D+00, .3300D+00, .6700D+00, .1900D+00, .3800D+00,
31530 & .9000D-01, .2000D+00, .3000D-01, .4000D-01, .5000D-01,
31531 & .2000D-01, .1900D+00, .3800D+00, .9000D-01, .2000D+00 /
31532 DATA (WT(K),K= 86,170) /
31533 & .3000D-01, .4000D-01, .5000D-01, .2000D-01, .1900D+00,
31534 & .3800D+00, .9000D-01, .2000D+00, .3000D-01, .4000D-01,
31535 & .5000D-01, .2000D-01, .1900D+00, .3800D+00, .9000D-01,
31536 & .2000D+00, .3000D-01, .4000D-01, .5000D-01, .2000D-01,
31537 & .8800D+00, .6000D-01, .6000D-01, .8800D+00, .6000D-01,
31538 & .6000D-01, .8800D+00, .1200D+00, .1900D+00, .1900D+00,
31539 & .1600D+00, .1600D+00, .1700D+00, .3000D-01, .3000D-01,
31540 & .3000D-01, .4000D-01, .1000D+00, .1000D+00, .2000D+00,
31541 & .1200D+00, .1000D+00, .4000D-01, .4000D-01, .5000D-01,
31542 & .7500D-01, .7500D-01, .3000D-01, .3000D-01, .4000D-01,
31543 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01,
31544 & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31545 & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31546 & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31547 & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31548 & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31549 & .2700D+00, .3000D+00, .4000D+00, .2000D+00, .1250D+00 /
31550 DATA (WT(K),K=171,255) /
31551 & .7500D-01, .7500D-01, .1250D+00, .4000D+00, .7500D-01,
31552 & .1250D+00, .2000D+00, .1250D+00, .7500D-01, .1800D+00,
31553 & .3700D+00, .1300D+00, .8000D-01, .4000D-01, .7000D-01,
31554 & .1300D+00, .3700D+00, .1800D+00, .4000D-01, .8000D-01,
31555 & .1300D+00, .1300D+00, .7000D-01, .7000D-01, .1300D+00,
31556 & .2300D+00, .4700D+00, .5000D-01, .2000D-01, .1000D-01,
31557 & .2000D-01, .1300D+00, .7000D-01, .4700D+00, .2300D+00,
31558 & .5000D-01, .1000D-01, .2000D-01, .2000D-01, .1000D+01,
31559 & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31560 & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31561 & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31562 & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31563 & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31564 & .2700D+00, .3000D+00, .1800D+00, .3700D+00, .1300D+00,
31565 & .8000D-01, .4000D-01, .7000D-01, .1300D+00, .3700D+00,
31566 & .1800D+00, .4000D-01, .8000D-01, .1300D+00, .1300D+00,
31567 & .7000D-01, .5000D+00, .5000D+00, .1000D+01, .1000D+01 /
31568 DATA (WT(K),K=256,340) /
31569 & .1000D+01, .8000D+00, .2000D+00, .6000D+00, .3000D+00,
31570 & .1000D+00, .6000D+00, .3000D+00, .1000D+00, .8000D+00,
31571 & .2000D+00, .3300D+00, .6700D+00, .6600D+00, .1700D+00,
31572 & .1700D+00, .3200D+00, .1700D+00, .3200D+00, .1900D+00,
31573 & .3300D+00, .3300D+00, .3400D+00, .3000D+00, .5000D-01,
31574 & .6500D+00, .3800D+00, .1200D+00, .3800D+00, .1200D+00,
31575 & .3800D+00, .1200D+00, .3800D+00, .1200D+00, .3000D+00,
31576 & .5000D-01, .6500D+00, .3800D+00, .2500D+00, .2500D+00,
31577 & .2000D-01, .5000D-01, .5000D-01, .2000D+00, .2000D+00,
31578 & .1200D+00, .1000D+00, .7000D-01, .7000D-01, .1400D+00,
31579 & .5000D-01, .5000D-01, .1000D+01, .1000D+01, .1000D+01,
31580 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31581 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31582 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31583 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31584 & .4800D+00, .2400D+00, .2600D+00, .2000D-01, .4700D+00,
31585 & .3500D+00, .1500D+00, .3000D-01, .1000D+01, .1000D+01 /
31586 DATA (WT(K),K=341,425) /
31587 & .5200D+00, .4800D+00, .1000D+01, .1000D+01, .1000D+01,
31588 & .1000D+01, .9000D+00, .5000D-01, .5000D-01, .9000D+00,
31589 & .5000D-01, .5000D-01, .9000D+00, .5000D-01, .5000D-01,
31590 & .3300D+00, .6700D+00, .6700D+00, .3300D+00, .2500D+00,
31591 & .2500D+00, .5000D+00, .9000D+00, .5000D-01, .5000D-01,
31592 & .9000D+00, .5000D-01, .5000D-01, .9000D+00, .5000D-01,
31593 & .5000D-01, .3300D+00, .6700D+00, .6700D+00, .3300D+00,
31594 & .2500D+00, .2500D+00, .5000D+00, .1000D+00, .5000D+00,
31595 & .1600D+00, .2400D+00, .7000D+00, .3000D+00, .7000D+00,
31596 & .3000D+00, .1000D+00, .5000D+00, .1600D+00, .2400D+00,
31597 & .3000D+00, .4000D+00, .3000D+00, .3000D+00, .4000D+00,
31598 & .3000D+00, .4900D+00, .4900D+00, .2000D-01, .5500D+00,
31599 & .4500D+00, .6800D+00, .3000D+00, .2000D-01, .6800D+00,
31600 & .3000D+00, .2000D-01, .5500D+00, .4500D+00, .9000D+00,
31601 & .1000D+00, .9000D+00, .1000D+00, .6000D+00, .3000D+00,
31602 & .1000D+00, .1000D+00, .1000D+00, .8000D+00, .2800D+00,
31603 & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .2800D+00 /
31604 DATA (WT(K),K=426,510) /
31605 & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .1000D+01,
31606 & .1000D+01, .1000D+01, .1000D+01, .2000D-01, .3000D-01,
31607 & .7000D-01, .2000D-01, .2000D-01, .4000D-01, .1300D+00,
31608 & .7000D-01, .6000D-01, .6000D-01, .2000D+00, .1400D+00,
31609 & .4000D-01, .1000D+00, .2500D+00, .3000D-01, .3000D+00,
31610 & .4200D+00, .2200D+00, .3500D+00, .1900D+00, .1600D+00,
31611 & .8000D-01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31612 & .1000D+01, .3700D+00, .2000D+00, .3600D+00, .7000D-01,
31613 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00,
31614 & .5000D+00, .2000D-01, .3000D-01, .7000D-01, .2000D-01,
31615 & .2000D-01, .4000D-01, .1300D+00, .7000D-01, .6000D-01,
31616 & .6000D-01, .2000D+00, .1400D+00, .4000D-01, .1000D+00,
31617 & .2500D+00, .3000D-01, .3000D+00, .4200D+00, .2200D+00,
31618 & .3500D+00, .1900D+00, .1600D+00, .8000D-01, .1000D+01,
31619 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .3700D+00,
31620 & .2000D+00, .3600D+00, .7000D-01, .5000D+00, .5000D+00,
31621 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01 /
31622 DATA (WT(K),K=511,540) /
31623 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31624 & .1000D+01, .1000D+01, .1000D+01, .3000D+00, .3000D+00,
31625 & .4000D+00, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31626 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31627 & .3000D+00, .3000D+00, .4000D+00, .3300D+00, .3300D+00,
31628 & .3400D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00 /
31630 DATA (WT(I),I=541,602) / .0D+00, .3334D+00, .2083D+00, 2*.125D+00,
31631 & .2083D+00, .0D+00, .125D+00, .2083D+00, .3334D+00, .2083D+00,
31632 & .125D+00, 0.2D+00, 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00,
31633 & 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, 0.2D+00, 0.3D+00,
31634 & 0.3D+00, 0.0D+00, 0.31D+00, 0.62D+00, 0.035D+00, 0.035D+00,
31635 & 18*1.D+00, 0.5D+00, 0.16D+00, 2*0.12D+00, 2*0.05D+00, 0.5D+00,
31636 & 0.16D+00, 2*0.12D+00, 2*0.05D+00, 1.D+00 /
31637 * Particle numbers in decay channel
31638 DATA (NZK(K,1),K= 1,170) /
31639 & 1, 2, 3, 4, 5, 6, 7, 1, 2, 4,
31640 & 3, 23, 13, 13, 13, 10, 11, 10, 13, 13,
31641 & 13, 10, 4, 11, 14, 14, 14, 11, 3, 1,
31642 & 8, 1, 1, 2, 9, 2, 2, 13, 23, 8,
31643 & 1, 8, 17, 7, 7, 7, 23, 23, 13, 13,
31644 & 13, 13, 23, 14, 13, 13, 23, 15, 24, 24,
31645 & 15, 16, 25, 25, 16, 15, 24, 24, 15, 16,
31646 & 24, 25, 16, 15, 24, 36, 37, 15, 24, 15,
31647 & 15, 24, 15, 37, 36, 24, 15, 24, 24, 16,
31648 & 24, 38, 39, 16, 25, 16, 16, 25, 16, 39,
31649 & 38, 25, 16, 25, 25, 17, 22, 21, 17, 21,
31650 & 20, 17, 22, 8, 1, 21, 22, 20, 17, 48,
31651 & 50, 49, 8, 1, 17, 17, 17, 21, 20, 22,
31652 & 17, 22, 21, 20, 22, 19, 12, 19, 12, 1,
31653 & 1, 8, 1, 8, 8, 1, 53, 54, 1, 1,
31654 & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55,
31655 & 56, 1, 8, 8, 55, 56, 8, 1, 53, 54 /
31656 DATA (NZK(K,1),K=171,340) /
31657 & 55, 1, 8, 8, 54, 55, 56, 1, 8, 1,
31658 & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55,
31659 & 56, 1, 8, 1, 8, 1, 8, 17, 21, 22,
31660 & 1, 1, 8, 1, 8, 17, 22, 20, 8, 2,
31661 & 2, 9, 2, 9, 9, 2, 67, 68, 2, 2,
31662 & 9, 67, 68, 69, 2, 9, 2, 9, 68, 69,
31663 & 70, 2, 9, 9, 69, 70, 9, 2, 9, 67,
31664 & 68, 69, 2, 9, 2, 9, 68, 69, 70, 2,
31665 & 9, 1, 8, 13, 13, 14, 1, 8, 1, 1,
31666 & 8, 8, 8, 1, 8, 1, 1, 1, 1, 1,
31667 & 8, 2, 2, 9, 9, 2, 2, 9, 15, 15,
31668 & 24, 16, 16, 25, 25, 15, 15, 24, 24, 16,
31669 & 16, 25, 1, 21, 22, 21, 48, 49, 8, 17,
31670 & 20, 17, 22, 20, 20, 22, 20, 0, 0, 0,
31671 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31672 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31673 & 31, 31, 13, 7, 15, 12, 13, 31, 17, 17 /
31674 DATA (NZK(K,1),K=341,510) /
31675 & 2, 9, 18, 9, 18, 18, 17, 21, 22, 17,
31676 & 21, 20, 17, 20, 22, 97, 98, 97, 98, 97,
31677 & 98, 17, 18, 99, 100, 18, 101, 99, 18, 101,
31678 & 100, 102, 103, 102, 103, 102, 103, 18, 16, 16,
31679 & 24, 24, 16, 25, 15, 24, 15, 15, 25, 25,
31680 & 31, 15, 15, 31, 16, 16, 23, 13, 7, 116,
31681 & 116, 116, 117, 117, 119, 118, 118, 119, 119, 120,
31682 & 120, 121, 121, 130, 130, 130, 4, 10, 13, 10,
31683 & 4, 32, 13, 36, 11, 3, 34, 14, 38, 133,
31684 & 134, 135, 136, 21, 21, 1, 97, 104, 54, 53,
31685 & 17, 22, 21, 21, 1, 54, 53, 21, 97, 21,
31686 & 97, 22, 21, 97, 98, 105, 137, 137, 137, 138,
31687 & 139, 97, 97, 109, 109, 140, 138, 137, 139, 138,
31688 & 145, 99, 99, 2, 102, 110, 68, 67, 18, 100,
31689 & 99, 99, 2, 68, 67, 99, 102, 99, 102, 100,
31690 & 99, 102, 103, 111, 149, 149, 149, 150, 151, 113,
31691 & 113, 115, 115, 152, 150, 149, 151, 150, 157, 140 /
31692 DATA (NZK(K,1),K=511,540) /
31693 & 141, 142, 143, 144, 145, 146, 147, 148, 138, 145,
31694 & 140, 152, 153, 154, 155, 156, 157, 158, 159, 160,
31695 & 150, 157, 152, 34, 32, 33, 33, 32, 33, 34 /
31696 DATA (NZK(I,1),I=541,602) / 2, 67, 68, 69, 2, 9, 9, 68, 69,
31697 & 70, 2, 9, 33, 32, 13, 14, 189, 32, 34, 23, 23, 189, 33, 34, 14,
31698 & 14, 189, 23, 13, 15, 24, 36, 38, 37, 39, 194, 195, 196, 197,
31699 & 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 1, 8, 1, 1, 54,
31700 & 55, 8, 1, 8, 8, 54, 55, 210/
31701 DATA (NZK(K,2),K= 1,170) /
31702 & 0, 0, 0, 0, 0, 0, 0, 3, 4, 6,
31703 & 5, 23, 14, 11, 3, 5, 5, 5, 23, 13,
31704 & 23, 23, 23, 5, 23, 13, 23, 23, 23, 14,
31705 & 23, 3, 11, 13, 23, 4, 10, 14, 23, 14,
31706 & 23, 13, 7, 7, 4, 7, 7, 23, 14, 14,
31707 & 23, 14, 23, 23, 14, 14, 7, 23, 13, 23,
31708 & 14, 23, 14, 23, 13, 23, 13, 23, 14, 23,
31709 & 14, 23, 13, 23, 13, 23, 13, 33, 32, 35,
31710 & 31, 23, 14, 23, 14, 33, 34, 35, 31, 23,
31711 & 14, 23, 14, 33, 34, 35, 31, 23, 13, 23,
31712 & 13, 33, 32, 35, 31, 13, 13, 23, 23, 14,
31713 & 13, 14, 14, 25, 16, 14, 23, 13, 31, 14,
31714 & 13, 23, 25, 16, 23, 35, 33, 34, 32, 33,
31715 & 31, 31, 14, 13, 23, 0, 0, 0, 0, 13,
31716 & 23, 13, 14, 23, 14, 13, 23, 13, 78, 23,
31717 & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23,
31718 & 13, 80, 79, 14, 14, 23, 80, 31, 14, 23 /
31719 DATA (NZK(K,2),K=171,340) /
31720 & 13, 79, 78, 31, 14, 23, 13, 80, 79, 23,
31721 & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23,
31722 & 13, 80, 79, 23, 13, 33, 32, 15, 24, 15,
31723 & 31, 14, 23, 34, 33, 24, 24, 15, 31, 14,
31724 & 23, 14, 13, 23, 13, 14, 23, 14, 80, 23,
31725 & 14, 13, 23, 14, 79, 80, 13, 23, 13, 23,
31726 & 14, 78, 79, 13, 13, 23, 78, 23, 14, 13,
31727 & 23, 14, 79, 80, 13, 23, 13, 23, 14, 78,
31728 & 79, 62, 61, 23, 14, 23, 13, 13, 13, 23,
31729 & 13, 13, 23, 14, 14, 14, 1, 8, 8, 1,
31730 & 8, 1, 8, 8, 1, 8, 1, 8, 1, 8,
31731 & 1, 1, 8, 1, 8, 8, 1, 1, 8, 8,
31732 & 1, 8, 25, 23, 13, 31, 23, 13, 16, 14,
31733 & 35, 34, 34, 33, 31, 14, 23, 0, 0, 0,
31734 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31735 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31736 & 13, 23, 14, 7, 16, 19, 14, 7, 23, 14 /
31737 DATA (NZK(K,2),K=341,510) /
31738 & 23, 14, 7, 13, 23, 13, 13, 23, 13, 23,
31739 & 14, 13, 14, 23, 14, 23, 13, 14, 23, 14,
31740 & 23, 16, 14, 23, 14, 23, 14, 13, 13, 23,
31741 & 13, 23, 14, 13, 23, 13, 23, 15, 13, 13,
31742 & 13, 23, 13, 13, 14, 14, 14, 14, 14, 23,
31743 & 13, 16, 25, 14, 15, 24, 23, 14, 7, 23,
31744 & 7, 13, 23, 7, 14, 23, 7, 23, 7, 7,
31745 & 7, 7, 7, 13, 23, 31, 3, 11, 14, 135,
31746 & 5, 134, 134, 134, 136, 6, 133, 133, 133, 0,
31747 & 0, 0, 0, 31, 95, 25, 15, 31, 95, 16,
31748 & 32, 32, 33, 35, 39, 39, 38, 25, 13, 39,
31749 & 32, 39, 38, 35, 32, 39, 13, 23, 14, 7,
31750 & 7, 25, 37, 32, 13, 25, 13, 25, 13, 25,
31751 & 13, 31, 95, 24, 16, 31, 24, 15, 34, 34,
31752 & 33, 35, 37, 37, 36, 24, 14, 37, 34, 37,
31753 & 36, 35, 34, 37, 14, 23, 13, 7, 7, 24,
31754 & 39, 34, 14, 24, 14, 24, 14, 24, 14, 7 /
31755 DATA (NZK(K,2),K=511,540) /
31756 & 7, 7, 7, 7, 7, 7, 7, 7, 25, 13,
31757 & 25, 7, 7, 7, 7, 7, 7, 7, 7, 7,
31758 & 24, 14, 24, 13, 14, 23, 13, 23, 14, 23 /
31759 DATA (NZK(I,2),I=541,602) / 31, 13, 23, 14, 79, 80, 31, 13, 23,
31760 & 14, 78, 79, 13, 23, 23, 13, 13, 14, 13, 23, 13, 23, 14, 23, 23,
31761 & 14, 14, 23, 14, 16, 25,
31762 & 4*23, 14*0, 23, 13, 23, 13, 23, 13, 23, 14,
31763 & 23, 13, 14, 23, 0 /
31764 DATA (NZK(K,3),K= 1,170) /
31765 & 0, 0, 0, 0, 0, 0, 0, 5, 6, 5,
31766 & 6, 23, 23, 5, 5, 0, 0, 0, 0, 14,
31767 & 23, 5, 5, 0, 0, 14, 23, 5, 5, 0,
31768 & 0, 5, 5, 0, 0, 5, 5, 0, 0, 0,
31769 & 0, 0, 0, 0, 3, 0, 7, 23, 23, 7,
31770 & 0, 0, 0, 0, 23, 0, 0, 0, 0, 0,
31772 DATA (NZK(K,3),K=171,340) /
31774 & 0, 0, 0, 0, 0, 0, 23, 13, 14, 23,
31775 & 23, 14, 23, 23, 23, 14, 23, 13, 23, 14,
31776 & 13, 23, 13, 23, 14, 23, 14, 14, 23, 13,
31777 & 13, 23, 13, 14, 23, 23, 14, 23, 13, 23,
31778 & 14, 14, 0, 0, 0, 0, 0, 0, 0, 0,
31780 & 14, 23, 7, 0, 0, 0, 23, 0, 0, 0 /
31781 DATA (NZK(K,3),K=341,510) /
31783 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 23,
31784 & 14, 0, 13, 0, 14, 0, 0, 23, 13, 0,
31785 & 0, 15, 0, 0, 16, 0, 0, 0, 0, 0,
31786 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31787 & 0, 0, 0, 14, 23, 0, 0, 0, 23, 134,
31788 & 134, 0, 0, 0, 133, 133, 0, 0, 0, 0,
31790 DATA (NZK(K,3),K=511,540) /
31791 & 0, 0, 0, 0, 0, 0, 0, 0, 13, 13,
31792 & 25, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31793 & 14, 14, 24, 0, 0, 0, 0, 0, 0, 0 /
31794 DATA (NZK(I,3),I=541,602) / 12*0, 2*0, 23, 13, 0, 2*0, 23, 14, 0,
31795 & 2*0, 23, 13, 0, 4*0, 18*0, 2*0, 23, 14, 2*0, 2*0, 23, 14, 2*0, 0/
31799 *$ CREATE DT_XHOINI.FOR
31802 *====phoini============================================================*
31804 SUBROUTINE DT_XHOINI
31805 C SUBROUTINE DT_PHOINI
31807 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31810 PARAMETER ( LINP = 10 ,
31817 *$ CREATE DT_XVENTB.FOR
31820 *====eventb============================================================*
31822 SUBROUTINE DT_XVENTB(NCSY,IREJ)
31823 C SUBROUTINE DT_EVENTB(NCSY,IREJ)
31825 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31828 PARAMETER ( LINP = 10 ,
31833 1000 FORMAT(1X,'EVENTB: PHOJET-package requested but not linked!')
31838 *$ CREATE DT_XVENT.FOR
31841 *===event==============================================================*
31843 SUBROUTINE DT_XVENT(IDUM,PP,PT,DUM,IREJ)
31844 C SUBROUTINE EVENT(IDUM,PP,PT,DUM,IREJ)
31846 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31849 DIMENSION PP(4),PT(4)
31854 *$ CREATE DT_XOHISX.FOR
31857 *===pohisx=============================================================*
31859 SUBROUTINE DT_XOHISX(I,X)
31860 C SUBROUTINE POHISX(I,X)
31862 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31868 *$ CREATE PHO_LHIST.FOR
31871 *===poluhi=============================================================*
31873 SUBROUTINE PHO_LHIST(I,X)
31877 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31883 *$ CREATE PDFSET.FOR
31886 C**********************************************************************
31888 C dummy subroutines, remove to link PDFLIB
31890 C**********************************************************************
31891 SUBROUTINE PDFSET(PARAM,VALUE)
31892 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31893 DIMENSION PARAM(20),VALUE(20)
31897 *$ CREATE STRUCTM.FOR
31900 SUBROUTINE STRUCTM(XI,SCALE2,UV,DV,US,DS,SS,CS,BS,TS,GL)
31901 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31904 *$ CREATE STRUCTP.FOR
31907 SUBROUTINE STRUCTP(XI,SCALE2,P2,IP2,UV,DV,US,DS,SS,CS,BS,TS,GL)
31908 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31911 *$ CREATE DT_DIQBRK.FOR
31914 *===diqbrk=============================================================*
31916 SUBROUTINE DT_XIQBRK
31917 C SUBROUTINE DT_DIQBRK
31919 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31922 STOP 'diquark-breaking not implemeted !'
31926 *$ CREATE DT_ELHAIN.FOR
31929 *===elhain=============================================================*
31931 SUBROUTINE DT_ELHAIN(IP,PLA,ELAB,CX,CY,CZ,IT,IREJ)
31933 ************************************************************************
31934 * Elastic hadron-hadron scattering. *
31935 * This is a revised version of the original. *
31936 * This version dated 03.04.98 is written by S. Roesler *
31937 ************************************************************************
31939 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31942 PARAMETER ( LINP = 10 ,
31946 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
31949 PARAMETER (ENNTHR = 3.5D0)
31950 PARAMETER (PLOWH=0.01D0,PHIH=9.0D0,
31951 & BLOWB=0.05D0,BHIB=0.2D0,
31952 & BLOWM=0.1D0, BHIM=2.0D0)
31954 * particle properties (BAMJET index convention)
31956 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
31957 & IICH(210),IIBAR(210),K1(210),K2(210)
31959 * final state from HADRIN interaction
31960 PARAMETER (MAXFIN=10)
31961 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
31962 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
31964 C DATA TSLOPE /10.0D0/
31970 PLAB = SQRT( (ELAB-AAM(IP))*(ELAB+AAM(IP)) )
31971 EKIN = ELAB-AAM(IP)
31972 * kinematical quantities in cms of the hadrons
31975 S = AMP2+AMT2+TWO*ELAB*AAM(IT)
31977 ECMP = OHALF*ECM+(AMP2-AMT2)/(TWO*ECM)
31978 PCM = SQRT( (ECMP-AAM(IP))*(ECMP+AAM(IP)) )
31980 * nucleon-nucleon scattering at E_kin<3.5: use DT_TSAMCS(HETC-KFA)
31981 IF ( ((IP.EQ.1).OR.(IP.EQ.8)).AND.
31982 & ((IT.EQ.1).OR.(IT.EQ.8)).AND.(EKIN.LT.ENNTHR) ) THEN
31983 * TSAMCS treats pp and np only, therefore change pn into np and
31989 IF (IP.EQ.8) KPROJ = 1
31991 CALL DT_TSAMCS(KPROJ,EKIN,CTCMS)
31992 T = TWO*PCM**2*(CTCMS-ONE)
31994 * very crude treatment otherwise: sample t from exponential dist.
31996 * momentum transfer t
31997 TMAX = TWO*TWO*PCM**2
31998 RR = (PLAB-PLOWH)/(PHIH-PLOWH)
31999 IF (IIBAR(IP).NE.0) THEN
32000 TSLOPE = BLOWB+RR*(BHIB-BLOWB)
32002 TSLOPE = BLOWM+RR*(BHIM-BLOWM)
32004 FMAX = EXP(-TSLOPE*TMAX)-ONE
32006 T = LOG(ONE+R*FMAX+TINY10)/TSLOPE
32007 IF (T.GT.ZERO) T = LOG(ONE+R*FMAX)/TSLOPE
32010 * target hadron in Lab after scattering
32011 ELRH(2) = (TWO*AMT2-T)/(TWO*AAM(IT))
32012 PLRH(2) = SQRT( ABS(ELRH(2)-AAM(IT))*(ELRH(2)+AAM(IT)) )
32013 IF (PLRH(2).LE.TINY10) THEN
32014 C WRITE(*,*)'ELHAIN: T,PLRH(2) ',T,PLRH(2)
32017 * projectile hadron in Lab after scattering
32018 ELRH(1) = ELAB+AAM(IT)-ELRH(2)
32019 PLRH(1) = SQRT( ABS(ELRH(1)-AAM(IP))*(ELRH(1)+AAM(IP)) )
32020 * scattering angle of projectile in Lab
32021 CTLABP = (T-TWO*AMP2+TWO*ELAB*ELRH(1))/(TWO*PLAB*PLRH(1))
32022 STLABP = SQRT( (ONE-CTLABP)*(ONE+CTLABP) )
32023 CALL DT_DSFECF(SPLABP,CPLABP)
32024 * direction cosines of projectile in Lab
32025 CALL DT_STTRAN(CX,CY,CZ,CTLABP,STLABP,SPLABP,CPLABP,
32026 & CXRH(1),CYRH(1),CZRH(1))
32027 * scattering angle of target in Lab
32028 PLLABT = PLAB-CTLABP*PLRH(1)
32029 CTLABT = PLLABT/PLRH(2)
32030 STLABT = SQRT( (ONE-CTLABT)*(ONE+CTLABT) )
32031 * direction cosines of target in Lab
32032 CALL DT_STTRAN(CX,CY,CZ,CTLABT,STLABT,-SPLABP,-CPLABP,
32033 & CXRH(2),CYRH(2),CZRH(2))
32042 *$ CREATE DT_TSAMCS.FOR
32045 *===tsamcs=============================================================*
32047 SUBROUTINE DT_TSAMCS(KPROJ,EKIN,CST)
32049 ************************************************************************
32050 * Sampling of cos(theta) for nucleon-proton scattering according to *
32051 * hetkfa2/bertini parametrization. *
32052 * This is a revised version of the original (HJM 24/10/88) *
32053 * This version dated 28.10.95 is written by S. Roesler *
32054 ************************************************************************
32056 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32059 PARAMETER ( LINP = 10 ,
32063 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
32066 DIMENSION DCLIN(195),DCHN(143),DCHNA(36),DCHNB(60)
32067 DIMENSION PDCI(60),PDCH(55)
32069 DATA (DCLIN(I),I=1,80) /
32070 & 5.000D-01, 1.000D+00, 0.000D+00, 1.000D+00, 0.000D+00,
32071 & 4.993D-01, 9.881D-01, 5.963D-02, 9.851D-01, 5.945D-02,
32072 & 4.936D-01, 8.955D-01, 5.224D-01, 8.727D-01, 5.091D-01,
32073 & 4.889D-01, 8.228D-01, 8.859D-01, 7.871D-01, 8.518D-01,
32074 & 4.874D-01, 7.580D-01, 1.210D+00, 7.207D-01, 1.117D+00,
32075 & 4.912D-01, 6.969D-01, 1.516D+00, 6.728D-01, 1.309D+00,
32076 & 5.075D-01, 6.471D-01, 1.765D+00, 6.667D-01, 1.333D+00,
32077 & 5.383D-01, 6.054D-01, 1.973D+00, 7.059D-01, 1.176D+00,
32078 & 5.397D-01, 5.990D-01, 2.005D+00, 7.023D-01, 1.191D+00,
32079 & 5.336D-01, 6.083D-01, 1.958D+00, 6.959D-01, 1.216D+00,
32080 & 5.317D-01, 6.075D-01, 1.962D+00, 6.897D-01, 1.241D+00,
32081 & 5.300D-01, 6.016D-01, 1.992D+00, 6.786D-01, 1.286D+00,
32082 & 5.281D-01, 6.063D-01, 1.969D+00, 6.786D-01, 1.286D+00,
32083 & 5.280D-01, 5.960D-01, 2.020D+00, 6.667D-01, 1.333D+00,
32084 & 5.273D-01, 5.920D-01, 2.040D+00, 6.604D-01, 1.358D+00,
32085 & 5.273D-01, 5.862D-01, 2.069D+00, 6.538D-01, 1.385D+00/
32086 DATA (DCLIN(I),I=81,160) /
32087 & 5.223D-01, 5.980D-01, 2.814D+00, 6.538D-01, 1.385D+00,
32088 & 5.202D-01, 5.969D-01, 2.822D+00, 6.471D-01, 1.412D+00,
32089 & 5.183D-01, 5.881D-01, 2.883D+00, 6.327D-01, 1.469D+00,
32090 & 5.159D-01, 5.866D-01, 2.894D+00, 6.250D-01, 1.500D+00,
32091 & 5.133D-01, 5.850D-01, 2.905D+00, 6.170D-01, 1.532D+00,
32092 & 5.106D-01, 5.833D-01, 2.917D+00, 6.087D-01, 1.565D+00,
32093 & 5.084D-01, 5.801D-01, 2.939D+00, 6.000D-01, 1.600D+00,
32094 & 5.063D-01, 5.763D-01, 2.966D+00, 5.909D-01, 1.636D+00,
32095 & 5.036D-01, 5.730D-01, 2.989D+00, 5.814D-01, 1.674D+00,
32096 & 5.014D-01, 5.683D-01, 3.022D+00, 5.714D-01, 1.714D+00,
32097 & 4.986D-01, 5.641D-01, 3.051D+00, 5.610D-01, 1.756D+00,
32098 & 4.964D-01, 5.580D-01, 3.094D+00, 5.500D-01, 1.800D+00,
32099 & 4.936D-01, 5.573D-01, 3.099D+00, 5.431D-01, 1.827D+00,
32100 & 4.909D-01, 5.509D-01, 3.144D+00, 5.313D-01, 1.875D+00,
32101 & 4.885D-01, 5.512D-01, 3.142D+00, 5.263D-01, 1.895D+00,
32102 & 4.857D-01, 5.437D-01, 3.194D+00, 5.135D-01, 1.946D+00/
32103 DATA (DCLIN(I),I=161,195) /
32104 & 4.830D-01, 5.353D-01, 3.253D+00, 5.000D-01, 2.000D+00,
32105 & 4.801D-01, 5.323D-01, 3.274D+00, 4.915D-01, 2.034D+00,
32106 & 4.770D-01, 5.228D-01, 3.341D+00, 4.767D-01, 2.093D+00,
32107 & 4.738D-01, 5.156D-01, 3.391D+00, 4.643D-01, 2.143D+00,
32108 & 4.701D-01, 5.010D-01, 3.493D+00, 4.444D-01, 2.222D+00,
32109 & 4.672D-01, 4.990D-01, 3.507D+00, 4.375D-01, 2.250D+00,
32110 & 4.634D-01, 4.856D-01, 3.601D+00, 4.194D-01, 2.323D+00/
32113 & 4.400D+02, 1.896D-01, 1.931D-01, 1.982D-01, 1.015D-01,
32114 & 1.029D-01, 4.180D-02, 4.228D-02, 4.282D-02, 4.350D-02,
32115 & 2.204D-02, 2.236D-02, 5.900D+02, 1.433D-01, 1.555D-01,
32116 & 1.774D-01, 1.000D-01, 1.128D-01, 5.132D-02, 5.600D-02,
32117 & 6.158D-02, 6.796D-02, 3.660D-02, 3.820D-02, 6.500D+02,
32118 & 1.192D-01, 1.334D-01, 1.620D-01, 9.527D-02, 1.141D-01,
32119 & 5.283D-02, 5.952D-02, 6.765D-02, 7.878D-02, 4.796D-02,
32120 & 6.957D-02, 8.000D+02, 4.872D-02, 6.694D-02, 1.152D-01,
32121 & 9.348D-02, 1.368D-01, 6.912D-02, 7.953D-02, 9.577D-02,
32122 & 1.222D-01, 7.755D-02, 9.525D-02, 1.000D+03, 3.997D-02,
32123 & 5.456D-02, 9.804D-02, 8.084D-02, 1.208D-01, 6.520D-02,
32124 & 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02, 1.093D-01/
32127 & 1.000D+03, 9.453D-02, 9.804D-02, 8.084D-02, 1.208D-01,
32128 & 6.520D-02, 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02,
32129 & 1.093D-01, 1.400D+03, 1.072D-01, 7.450D-02, 6.645D-02,
32130 & 1.136D-01, 6.750D-02, 8.580D-02, 1.110D-01, 1.530D-01,
32131 & 1.010D-01, 1.350D-01, 2.170D+03, 4.004D-02, 3.013D-02,
32132 & 2.664D-02, 5.511D-02, 4.240D-02, 7.660D-02, 1.364D-01,
32133 & 2.300D-01, 1.670D-01, 2.010D-01, 2.900D+03, 1.870D-02,
32134 & 1.804D-02, 1.320D-02, 2.970D-02, 2.860D-02, 5.160D-02,
32135 & 1.020D-01, 2.400D-01, 2.250D-01, 3.370D-01, 4.400D+03,
32136 & 1.196D-03, 8.784D-03, 1.517D-02, 2.874D-02, 2.488D-02,
32137 & 4.464D-02, 8.330D-02, 2.008D-01, 2.360D-01, 3.567D-01/
32139 DATA (DCHN(I),I=1,90) /
32140 & 4.770D-01, 4.750D-01, 4.715D-01, 4.685D-01, 4.650D-01,
32141 & 4.610D-01, 4.570D-01, 4.550D-01, 4.500D-01, 4.450D-01,
32142 & 4.405D-01, 4.350D-01, 4.300D-01, 4.250D-01, 4.200D-01,
32143 & 4.130D-01, 4.060D-01, 4.000D-01, 3.915D-01, 3.840D-01,
32144 & 3.760D-01, 3.675D-01, 3.580D-01, 3.500D-01, 3.400D-01,
32145 & 3.300D-01, 3.200D-01, 3.100D-01, 3.000D-01, 2.900D-01,
32146 & 2.800D-01, 2.700D-01, 2.600D-01, 2.500D-01, 2.400D-01,
32147 & 2.315D-01, 2.240D-01, 2.150D-01, 2.060D-01, 2.000D-01,
32148 & 1.915D-01, 1.850D-01, 1.780D-01, 1.720D-01, 1.660D-01,
32149 & 1.600D-01, 1.550D-01, 1.500D-01, 1.450D-01, 1.400D-01,
32150 & 1.360D-01, 1.320D-01, 1.280D-01, 1.250D-01, 1.210D-01,
32151 & 1.180D-01, 1.150D-01, 1.120D-01, 1.100D-01, 1.070D-01,
32152 & 1.050D-01, 1.030D-01, 1.010D-01, 9.900D-02, 9.700D-02,
32153 & 9.550D-02, 9.480D-02, 9.400D-02, 9.200D-02, 9.150D-02,
32154 & 9.100D-02, 9.000D-02, 8.990D-02, 8.900D-02, 8.850D-02,
32155 & 8.750D-02, 8.700D-02, 8.650D-02, 8.550D-02, 8.500D-02,
32156 & 8.499D-02, 8.450D-02, 8.350D-02, 8.300D-02, 8.250D-02,
32157 & 8.150D-02, 8.100D-02, 8.030D-02, 8.000D-02, 7.990D-02/
32158 DATA (DCHN(I),I=91,143) /
32159 & 7.980D-02, 7.950D-02, 7.900D-02, 7.860D-02, 7.800D-02,
32160 & 7.750D-02, 7.650D-02, 7.620D-02, 7.600D-02, 7.550D-02,
32161 & 7.530D-02, 7.500D-02, 7.499D-02, 7.498D-02, 7.480D-02,
32162 & 7.450D-02, 7.400D-02, 7.350D-02, 7.300D-02, 7.250D-02,
32163 & 7.230D-02, 7.200D-02, 7.100D-02, 7.050D-02, 7.020D-02,
32164 & 7.000D-02, 6.999D-02, 6.995D-02, 6.993D-02, 6.991D-02,
32165 & 6.990D-02, 6.870D-02, 6.850D-02, 6.800D-02, 6.780D-02,
32166 & 6.750D-02, 6.700D-02, 6.650D-02, 6.630D-02, 6.600D-02,
32167 & 6.550D-02, 6.525D-02, 6.510D-02, 6.500D-02, 6.499D-02,
32168 & 6.498D-02, 6.496D-02, 6.494D-02, 6.493D-02, 6.490D-02,
32169 & 6.488D-02, 6.485D-02, 6.480D-02/
32172 & 6.300D+02, 7.810D-02, 1.421D-01, 1.979D-01, 2.479D-01,
32173 & 3.360D-01, 5.400D-01, 7.236D-01, 1.000D+00, 1.540D+03,
32174 & 2.225D-01, 3.950D-01, 5.279D-01, 6.298D-01, 7.718D-01,
32175 & 9.405D-01, 9.835D-01, 1.000D+00, 2.560D+03, 2.625D-01,
32176 & 4.550D-01, 5.963D-01, 7.020D-01, 8.380D-01, 9.603D-01,
32177 & 9.903D-01, 1.000D+00, 3.520D+03, 4.250D-01, 6.875D-01,
32178 & 8.363D-01, 9.163D-01, 9.828D-01, 1.000D+00, 1.000D+00,
32182 & 6.300D+02, 3.800D-02, 7.164D-02, 1.275D-01, 2.171D-01,
32183 & 3.227D-01, 4.091D-01, 5.051D-01, 6.061D-01, 7.074D-01,
32184 & 8.434D-01, 1.000D+00, 2.040D+03, 1.200D-01, 2.115D-01,
32185 & 3.395D-01, 5.295D-01, 7.251D-01, 8.511D-01, 9.487D-01,
32186 & 9.987D-01, 1.000D+00, 1.000D+00, 1.000D+00, 2.200D+03,
32187 & 1.344D-01, 2.324D-01, 3.754D-01, 5.674D-01, 7.624D-01,
32188 & 8.896D-01, 9.808D-01, 1.000D+00, 1.000D+00, 1.000D+00,
32189 & 1.000D+00, 2.850D+03, 2.330D-01, 4.130D-01, 6.610D-01,
32190 & 9.010D-01, 9.970D-01, 1.000D+00, 1.000D+00, 1.000D+00,
32191 & 1.000D+00, 1.000D+00, 1.000D+00, 3.500D+03, 3.300D-01,
32192 & 5.450D-01, 7.950D-01, 1.000D+00, 1.000D+00, 1.000D+00,
32193 & 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00/
32196 IF (EKIN.GT.3.5D0) RETURN
32198 IF(KPROJ.EQ.8) GOTO 101
32199 IF(KPROJ.EQ.1) GOTO 102
32200 C* INVALID REACTION
32201 WRITE(LOUT,'(A,I5/A)')
32202 & ' INVALID PARTICLE TYPE IN DNUPRE - KPROJ=',KPROJ,
32203 & ' COS(THETA) = 1D0 RETURNED'
32205 C-------------------------------- NP ELASTIC SCATTERING----------
32207 IF (EKIN.GT.0.740D0)GOTO 1000
32208 IF (EKIN.LT.0.300D0)THEN
32209 C EKIN .LT. 300 MEV
32212 C 300 MEV < EKIN < 740 MEV
32217 IE=INT(ABS(ENER/0.020D0))
32218 UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
32219 C FORWARD/BACKWARD DECISION
32221 BWFW=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
32222 IF (DT_RNDM(CST).LT.BWFW)THEN
32230 COEF=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
32233 IF(RND.LT.COEF)THEN
32242 IF(VALUE2.GT.0.0)THEN
32243 CST=MAX(R1,R2,R3,R4)
32249 CST=-MAX(R1,R2,R3,R4,R5)
32253 CST=-MAX(R1,R2,R3,R4,R5,R6,R7)
32262 C******** EKIN .GT. 0.74 GEV
32264 1000 ENER=EKIN - 0.66D0
32265 C IE=ABS(ENER/0.02)
32266 IE=INT(ENER/0.02D0)
32269 UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
32271 BWFW=(DCHN(K+1)-DCHN(K))*UNIV + DCHN(K)
32274 IF (RND.GE.BWFW)THEN
32276 IF (DCHNA(K).GT.EMEV) THEN
32277 UNIVE=(EMEV-DCHNA(K-9))/(DCHNA(K)-DCHNA(K-9))
32278 UNIV=DT_RNDM(UNIVE)
32281 P=(DCHNA(II)-DCHNA(II-9))*UNIVE + DCHNA(II-9)
32284 UNIV=DT_RNDM(UNIVE)
32286 GOTO(290,290,290,290,330,340,350,360) I
32295 IF (DCHNB(K).GT.EMEV) THEN
32296 UNIVE=(EMEV-DCHNB(K-12))/(DCHNB(K)-DCHNB(K-12))
32297 UNIV=DT_RNDM(UNIVE)
32300 P=(DCHNB(II)-DCHNB(II-12))*UNIVE + DCHNB(II-12)
32305 GOTO(120,120,140,150,160,160,180,190,200,210,220) I
32312 120 CST=1.0D-2*FLTI-1.0D0
32314 140 CST=2.0D-2*UNIV-0.98D0
32316 150 CST=4.0D-2*UNIV-0.96D0
32318 160 CST=6.0D-2*FLTI-1.16D0
32320 180 CST=8.0D-2*UNIV-0.80D0
32322 190 CST=1.0D-1*UNIV-0.72D0
32324 200 CST=1.2D-1*UNIV-0.62D0
32326 210 CST=2.0D-1*UNIV-0.50D0
32328 220 CST=3.0D-1*(UNIV-1.0D0)
32331 290 CST=1.0D0-2.5d-2*FLTI
32333 330 CST=0.85D0+0.5D-1*UNIV
32335 340 CST=0.70D0+1.5D-1*UNIV
32337 350 CST=0.50D0+2.0D-1*UNIV
32339 360 CST=0.50D0*UNIV
32343 C----------------------------------- PP ELASTIC SCATTERING -------
32348 IF (EKIN.LE.0.500D0) THEN
32350 CST=2.0D0*RND-1.0D0
32353 ELSEIF (EKIN.LT.1.0D0) THEN
32355 IF (PDCI(K).GT.EMEV) THEN
32356 UNIVE=(EMEV-PDCI(K-12))/(PDCI(K)-PDCI(K-12))
32357 UNIV=DT_RNDM(UNIVE)
32361 SUM=SUM + (PDCI(II)-PDCI(II-12))*UNIVE + PDCI(II-12)
32363 IF (UNIV.LT.SUM)THEN
32366 GOTO(55,55,55,60,60,65,65,65,65,70,70) I
32373 IF (PDCH(K).GT.EMEV) THEN
32374 UNIVE=(EMEV-PDCH(K-11))/(PDCH(K)-PDCH(K-11))
32375 UNIV=DT_RNDM(UNIVE)
32379 SUM=SUM + (PDCH(II)-PDCH(II-11))*UNIVE + PDCH(II-11)
32381 IF (UNIV.LT.SUM)THEN
32384 GOTO(50,55,60,60,65,65,65,65,70,70) I
32395 60 CST=0.3D0+0.1D0*FLTI
32397 65 CST=0.6D0+0.04D0*FLTI
32399 70 CST=0.78D0+0.02D0*FLTI
32402 IF (DT_RNDM(CST).GT.0.5D0) CST=-CST
32407 *$ CREATE DT_DHADRI.FOR
32410 *===dhadri=============================================================*
32412 SUBROUTINE DT_DHADRI(N,PLAB,ELAB,CX,CY,CZ,ITTA)
32414 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32417 PARAMETER ( LINP = 10 ,
32422 C-----------------------------
32423 C*** INPUT VARIABLES LIST:
32424 C*** SAMPLING OF HADRON NUCLEON INTERACTION FOR (ABOUT) 0.1 LE PLAB LE 6
32425 C*** GEV/C LABORATORY MOMENTUM REGION
32426 C*** N - PROJECTILE HADRON INDEX
32427 C*** PLAB - LABORATORY MOMENTUM OF N (GEV/C)
32428 C*** ELAB - LABORATORY ENERGY OF N (GEV)
32429 C*** CX,CY,CZ - DIRECTION COSINES OF N IN THE LABORATORY SYSTEM
32430 C*** ITTA - TARGET NUCLEON INDEX
32431 C*** OUTPUT VARIABLES LIST OF PARTICLE CHARACTERISTICS IN /FINLSP/
32432 C IR COUNTS THE NUMBER OF PRODUCED PARTICLES
32433 C*** ITR - PARTICLE INDEX, CXR,CYR,CZR - DIRECTION COSINES (LAB. SYST.)
32434 C*** ELR,PLR LAB. ENERGY AND LAB. MOMENTUM OF THE SAMPLED PARTICLE
32435 C*** RESPECT., UNITS (GEV/C AND GEV)
32436 C----------------------------
32438 COMMON /HNGAMR/ REDU,AMO,AMM(15)
32440 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
32442 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
32443 & NRK(2,268),NURE(30,2)
32445 * particle properties (BAMJET index convention),
32446 * (dublicate of DTPART for HADRIN)
32447 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
32448 & K1H(110),K2H(110)
32450 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
32452 COMMON /HNMETL/ CXS(149),CYS(149),CZS(149),ELS(149),PLS(149),
32455 COMMON /HNDRUN/ RUNTES,EFTES
32457 * particle properties (BAMJET index convention)
32459 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
32460 & IICH(210),IIBAR(210),K1(210),K2(210)
32462 * final state from HADRIN interaction
32463 PARAMETER (MAXFIN=10)
32464 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
32465 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
32467 DIMENSION ITPRF(110)
32470 DATA ITPRF/-1,-1,5*1,-1,-1,1,1,1,-1,-1,-1,-1,6*1,-1,-1,-1,85*1/
32472 IF (N.LE.0.OR.N.GE.111)N=1
32473 IF (ITPRF( N ).GT.0 .OR. ITTA.GT.8) THEN
32476 * + ' FALSE USE OF THE PARTICLE TYPE INDEX: N, ITTA', N, ITTA
32478 *1000 FORMAT (3(5H ****/),A,2I4,3(5H ****/))
32479 * + 45H FALSE USE OF THE PARTICLE TYPE INDEX, N,LUE ,I4,3(5H ****/))
32482 IF (ABS(PLAB-5.0D0).LT.4.99999D0) GO TO 20
32483 C IF(IPRI.GE.1) WRITE (6,1010) PLAB
32485 1010 FORMAT ( ' PROJECTILE HADRON MOMENTUM OUTSIDE OF THE
32486 + ALLOWED REGION, PLAB=',1E15.5)
32489 UMODAT=N*1.11111D0+ITTA*2.19291D0
32490 IF(UMODAT.NE.UMODA) CALL DT_DCALUM(N,ITTA)
32497 IF (LOWP.GT.20) THEN
32498 C WRITE(LOUT,*) ' jump 1'
32502 IF (NNN.EQ.N) GO TO 50
32511 IF(ITTA.GT.1) IRE=NURE(N,2)
32513 C-----------------------------
32514 C*** IE,AMT,ECM,SI DETERMINATION
32515 C----------------------------
32516 CALL DT_DSIGIN(IRE,PLAB,N,IE,AMT ,AMN,ECM,SI,ITTA)
32519 C IF (AMH(1).NE.0.93828D0) IANTH=1
32520 IF (AMH(1).NE.0.9383D0) IANTH=1
32522 IF (IANTH.GE.0) SI=1.0D0
32525 C-----------------------------
32527 C IRE CHARACTERIZES THE REACTION
32528 C IE IS THE ENERGY INDEX
32529 C----------------------------
32530 IF (SI.LT.1.D-6) THEN
32531 C WRITE(LOUT,*) ' jump 2'
32534 IF (N.LE.NSTAB) GO TO 60
32535 RUNTES=RUNTES+1.0D0
32536 IF (RUNTES.LT.20.D0) WRITE(LOUT,1020)N
32537 1020 FORMAT(3H N=,I10,30H THE PROEKTILE IS A RESONANCE )
32538 IF(IBARH(N).EQ.1) N=8
32539 IF(IBARH(N).EQ.-1) N=9
32542 **sr 19.2.97: loop for direct channel suppression
32543 C IF (IMACH.GT.10) THEN
32544 IF (IMACH.GT.1000) THEN
32546 C WRITE(LOUT,*) ' jump 3'
32552 ECMN=(ECM**2+AMN2-AMT2)/(2.0D0*ECM )
32553 IF(ECMN.LE.AMN) ECMN=AMN
32554 PCMN=SQRT(ECMN**2-AMN2)
32557 IF (IANTH.GE.0) ECM=2.1D0
32559 C-----------------------------
32560 C*** RANDOM CHOICE OF REACTION CHANNEL
32561 C----------------------------
32566 C-----------------------------
32567 C*** PLACE REDUCED VERSION
32568 C----------------------------
32570 IDWK=IEII(IRE+1)-IIEI
32574 C-----------------------------
32575 C*** SHRINKAGE TO THE CONSIDERED ENERGY REGION FOR THE USE OF WEIGHTS
32576 C----------------------------
32578 HUMO=2.0D0*UMO(IIEI+IDWK)-UMO(IIEI+IDWK-1)
32579 IF (HUMO.LT.ECM) ECM=HUMO
32581 C-----------------------------
32582 C*** INTERPOLATION PREPARATION
32583 C----------------------------
32589 C-----------------------------
32591 C----------------------------
32596 IWK=IIWK+(IK-1)*IDWK+IE-IIEI
32600 C-----------------------------
32601 C*** TESTVARIABLE WICO/WICOR: IF CHANNEL IK HAS THE SAME WEIGHTS LIKE IK
32602 C GO TO NEXT CHANNEL, BECAUSE WKK((IK))-WKK((IK-1))=0, IK CAN NOT
32604 C----------------------------
32605 IF (PLAB.LT.PLABF(IIEI+2)) WDK=0.0D0
32606 WICO=WOK*1.23459876D0+WDK*1.735218469D0
32607 IF (WICO.EQ.WICOR) GO TO 70
32608 IF (UMO(IIEI+IDWK).LT.HECM) WDK=0.0D0
32611 C-----------------------------
32612 C*** INTERPOLATION IN CHANNEL WEIGHTS
32613 C----------------------------
32614 EKLIM=-THRESH(IIKI+IK)
32615 IELIM=IDT_IEFUND(EKLIM,IRE)
32616 DELIM=UMO(IELIM)+EKLIM
32618 DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
32619 IF (DELIM*DELIM-DETE*DETE) 90,90,80
32624 WKK=WOK-WDK*DEC/(DECC+1.D-9)
32626 C-----------------------------
32628 C----------------------------
32630 IF (VV.GT.WKK) GO TO 70
32632 C***IK IS THE REACTION CHANNEL
32633 C----------------------------
32645 IF (I1001.GT.50) GO TO 60
32647 IF (IT2*AMS.GT.IT2*ECM) GO TO 110
32650 IF (IANTH.GE.0) ECM=ELAB+AMT+0.00001D0
32653 IF (IT2.GT.0) GO TO 120
32654 **sr 19.2.97: supress direct channel for pp-collisions
32655 IF ((N.EQ.1).AND.(ITTA.EQ.1).AND.(IT2.LE.0)) THEN
32657 IF (RR.LE.0.75D0) GOTO 60
32661 C-----------------------------
32662 C INCLUSION OF DIRECT RESONANCES
32663 C RANDOM CHOICE OF DECAY CHANNELS OF THE DIRECT RESONANCE IT1
32664 C------------------------
32677 IF(WW.LT. 0.5D0) GO TO 130
32684 C-----------------------------
32685 C THE FIRST PARTICLE IS DEFINED TO BE THE FORWARD GOING ONE AT SMALL T
32692 IF(IB1.EQ.IBN) GO TO 140
32698 C-----------------------------
32699 C***IT1,IT2 ARE THE CREATED PARTICLES
32700 C***MOMENTA AND DIRECTION COSINA IN THE CM - SYSTEM
32701 C------------------------
32702 CALL DT_DTWOPA(ECM1,ECM2,PCM1,PCM2,COD1,COD2,COF1,COF2,SIF1,SIF2,
32703 *IT1,IT2,ECM,ECMN,PCMN,N,AM1,AM2)
32708 C-----------------------------
32709 C***TRANSFORMATION INTO LAB SYSTEM AND ROTATION
32710 C----------------------------
32711 CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD1,COF1,SIF1,
32712 &PCM1,ECM1,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32716 CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD2,COF2,SIF2,
32717 *PCM2,ECM2,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32720 C-----------------------------
32721 C***TEST STABLE OR UNSTABLE
32722 C----------------------------
32723 IF(ITS(IST).GT.NSTAB) GO TO 160
32726 C-----------------------------
32727 C***IRH IS THE NUMBER OF THE FINAL STABLE PARTICLE
32728 C----------------------------
32729 C* IF (REDU.LT.0.D0) GO TO 1009
32737 IF(IST.GE.1) GO TO 150
32741 C RANDOM CHOICE OF DECAY CHANNELS
32742 C----------------------------
32756 IF (VV.GT.WTI(IIK)) GO TO 180
32758 C IIK IS THE DECAY CHANNEL
32759 C----------------------------
32767 IF (IT2-1.LT.0) GO TO 240
32772 C IF IIK-KIN.LIM.GT.ACTUAL TOTAL CM-ENERGY, DO AGAIN RANDOM IIK-CHOICE
32773 C----------------------------
32774 IF (IECO.LE.10) GO TO 200
32776 IF(IATMPT.GT.3) THEN
32777 C WRITE(LOUT,*) ' jump 4'
32782 IF (I310.GT.50) GO TO 170
32783 IF (AMS.GT.ECO) GO TO 190
32785 C FOR THE DECAY CHANNEL
32786 C IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM IT
32787 C----------------------------
32788 IF (REDU.LT.0.D0) GO TO 30
32791 IF(IT3.EQ.0) GO TO 220
32794 CALL DT_DTHREP(ECO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,SIF1,
32795 *COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
32797 220 CALL DT_DTWOPD(ECO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,
32798 &COD2,COF2,SIF2,AM1,AM2)
32803 IF (REDU.GT.0.D0) GO TO 240
32805 IF (ITWTHC.GT.100) GO TO 30
32806 IF (ITWTH) 220,220,210
32809 IF (IT2-1.LT.0) GO TO 250
32816 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD1,COF1,SIF1,PCM1,ECM1,
32817 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32820 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD2,COF2,SIF2,PCM2,ECM2,
32821 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32822 IF (IT3.LE.0) GO TO 250
32825 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD3,COF3,SIF3,PCM3,ECM3,
32826 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32834 C----------------------------
32836 C ZERO CROSS SECTION CASE
32837 C----------------------------
32849 *$ CREATE DT_RUNTT.FOR
32852 *===runtt==============================================================*
32854 BLOCK DATA DT_RUNTT
32856 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32859 COMMON /HNDRUN/ RUNTES,EFTES
32861 DATA RUNTES,EFTES /100.D0,100.D0/
32865 *$ CREATE DT_NONAME.FOR
32868 *===noname=============================================================*
32870 BLOCK DATA DT_NONAME
32872 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32875 * slope parameters for HADRIN interactions
32876 COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
32878 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
32880 C DATAS DATAS DATAS DATAS DATAS
32882 DATA IKII/ 0, 15, 41, 67, 82, 93, 110, 133, 148, 159, 172, 183,
32883 & 207, 224, 241, 252, 268 /
32884 DATA IEII/ 0, 21, 46, 71, 92, 109, 126, 143, 160, 173, 186, 199,
32885 & 220, 241, 262, 279, 296 /
32886 DATA IRII/ 0, 315, 965, 1615, 1930, 2117, 2406, 2797, 3052, 3195,
32887 & 3364, 3507, 4011, 4368, 4725, 4912, 5184/
32890 C MASSES FOR THE SLOPE B(M) IN GEV
32891 C SLOPE B(M) FOR AN MESONIC SYSTEM
32892 C SLOPE B(M) FOR A BARYONIC SYSTEM
32895 DATA SM,BBM,BBB/ 0.8D0, 0.85D0, 0.9D0, 0.95D0, 1.D0,
32896 & 1.05D0, 1.1D0, 1.15D0, 1.2D0, 1.25D0,
32897 & 1.3D0, 1.35D0, 1.4D0, 1.45D0, 1.5D0,
32898 & 1.55D0, 1.6D0, 1.65D0, 1.7D0, 1.75D0,
32899 & 1.8D0, 1.85D0, 1.9D0, 1.95D0, 2.D0,
32900 & 15.6D0, 14.95D0, 14.3D0, 13.65D0, 13.D0,
32901 & 12.35D0, 11.7D0, 10.85D0, 10.D0, 9.15D0,
32902 & 8.3D0, 7.8D0, 7.3D0, 7.25D0, 7.2D0,
32903 & 6.95D0, 6.7D0, 6.6D0, 6.5D0, 6.3D0,
32904 & 6.1D0, 5.85D0, 5.6D0, 5.35D0, 5.1D0,
32905 & 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0,
32906 & 14.2D0, 13.4D0, 12.6D0,
32907 & 11.8D0, 11.2D0, 10.6D0, 9.8D0, 9.D0,
32908 & 8.25D0, 7.5D0, 6.25D0, 5.D0, 4.5D0, 5*4.D0 /
32912 *$ CREATE DT_DAMG.FOR
32915 *===damg===============================================================*
32917 DOUBLE PRECISION FUNCTION DT_DAMG(IT)
32919 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32922 * particle properties (BAMJET index convention),
32923 * (dublicate of DTPART for HADRIN)
32924 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
32925 & K1H(110),K2H(110)
32927 DIMENSION GASUNI(14)
32929 *-1.D0,-.98D0,-.95D0,-.87D0,-.72D0,-.48D0,
32930 *-.17D0,.17D0,.48D0,.72D0,.87D0,.95D0,.98D0,1.D0/
32931 DATA GAUNO/2.352D0/
32937 IF (IT.LE.0) GO TO 30
32938 IF (IT.LE.NSTAB) GO TO 20
32939 DGAUNI=GAUNO*GAUNON/DBLE(IO-1)
32941 VV=VV*2.0D0-1.0D0+1.D-16
32946 IF (VV.GT.V1) GO TO 10
32947 UNIGA=DGAUNI*(DBLE(I)-2.0D0+(VV-VO+1.D-16)/
32948 & (V1-VO)-(DBLE(IO)-1.0D0)*0.5D0)
32949 DAM=GAH(IT)*UNIGA/GAUNO
32961 *$ CREATE DT_DCALUM.FOR
32964 *===dcalum=============================================================*
32966 SUBROUTINE DT_DCALUM(N,ITTA)
32968 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32971 C*** C.M.S.-ENERGY AND REACTION CHANNEL THRESHOLD CALCULATION
32973 * particle properties (BAMJET index convention),
32974 * (dublicate of DTPART for HADRIN)
32975 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
32976 & K1H(110),K2H(110)
32978 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
32980 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
32982 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
32983 & NRK(2,268),NURE(30,2)
32985 IRE=NURE(N,ITTA/8+1)
32994 ELAB=SQRT(AM12+AM22+2.0D0*SQRT(PLAB2+AM12)*AM2)
33001 IF(NRK(2,IK).GT.0) GO TO 30
33010 IF(IN.GT.0)AMS=AMS+AMH(IN)
33012 IF(IN.GT.0) AMS=AMS+AMH(IN)
33013 IF (AMS.LT.AMSS) AMSS=AMS
33015 IF(UMOO.LT.AMSS) UMOO=AMSS
33021 *$ CREATE DT_DCHANH.FOR
33024 *===dchanh=============================================================*
33026 SUBROUTINE DT_DCHANH
33028 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33031 PARAMETER ( LINP = 10 ,
33035 * particle properties (BAMJET index convention),
33036 * (dublicate of DTPART for HADRIN)
33037 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33038 & K1H(110),K2H(110)
33040 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
33042 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33044 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33045 & NRK(2,268),NURE(30,2)
33047 DIMENSION HWT(460),HWK(40),SI(5184)
33048 EQUIVALENCE (WK(1),SI(1))
33049 C--------------------
33050 C*** USE ONLY FOR DATAPREPARATION OF PURE HADRIN
33051 C*** CALCULATION OF REACTION- AND DECAY-CHANNEL-WEIGHTS,
33052 C*** THRESHOLD ENERGIES+MOMENTA OF REACTION CHNLS.
33053 C*** CHANGE OF WT- AND WK-INPUTDATA INTO WEIGHTS FOR THE M.-C.-PROCEDURE
33054 C*** (ADDED ONE TO EACH OTHER FOR CORRESPONDING CHANNELS)
33055 C--------------------------
33059 IEE=IEII(IRE+1)-IEII(IRE)
33060 IKE=IKII(IRE+1)-IKII(IRE)
33063 * modifications to suppress elestic scattering 24/07/91
33068 IWK=IWKO+IEE*(IK-1)+IE
33069 IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
33070 SIS=SIS+SI(IWK)*SINORC
33074 IF (SIS.GE.1.D-12) GO TO 20
33080 IWK=IWKO+IEE*(IK-1)+IE
33081 IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
33082 SIO=SIO+SI(IWK)*SINORC/SIS
33086 IWK=IWKO+IEE*(IK-1)+IE
33091 INRK1=NRK(1,IIKI+IK)
33092 IF (INRK1.GT.0) AM111=AMH(INRK1)
33094 INRK2=NRK(2,IIKI+IK)
33095 IF (INRK2.GT.0) AM222=AMH(INRK2)
33096 THRESH(IIKI+IK)=AM111 +AM222
33097 IF (INRK2-1.GE.0) GO TO 60
33101 DO 50 INRK1=INRKK,INRKO
33102 INZK1=NZKI(INRK1,1)
33103 INZK2=NZKI(INRK1,2)
33104 INZK3=NZKI(INRK1,3)
33105 IF (INZK1.LE.0.OR.INZK1.GT.110) GO TO 50
33106 IF (INZK2.LE.0.OR.INZK2.GT.110) GO TO 50
33107 IF (INZK3.LE.0.OR.INZK3.GT.110) GO TO 50
33108 C WRITE (6,310)INRK1,INZK1,INZK2,INZK3
33110 AMS=AMH(INZK1)+AMH(INZK2)
33111 IF (INZK3-1.GE.0) AMS=AMS+AMH(INZK3)
33112 IF (AMSS.GT.AMS) AMSS=AMS
33115 IF (AMS.LT.UMO(IEO)) AMS=UMO(IEO)
33116 THRESH(IIKI+IK)=AMS
33127 IF (IK2.GT.460)IK2=460
33134 IF (ABS(HV-1.0D0).GT.1.D-4) WRITE(LOUT,1010)I,JI,HV
33135 1010 FORMAT (35H ERROR IN HWT, FALSE USE OF CHANWH ,2I6,F10.2)
33142 *$ CREATE DT_DHADDE.FOR
33145 *===dhadde=============================================================*
33147 SUBROUTINE DT_DHADDE
33149 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33152 * particle properties (BAMJET index convention)
33154 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
33155 & IICH(210),IIBAR(210),K1(210),K2(210)
33157 * HADRIN: decay channel information
33158 PARAMETER (IDMAX9=602)
33160 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
33162 * particle properties (BAMJET index convention),
33163 * (dublicate of DTPART for HADRIN)
33164 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33165 & K1H(110),K2H(110)
33167 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
33169 * decay channel information for HADRIN
33170 COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
33171 & K1Z(16),K2Z(16),WTZ(153),II22,
33172 & NZK1(153),NZK2(153),NZK3(153)
33178 IF (IRETUR.GT.1) RETURN
33184 IBARH(I) = IIBAR(I)
33199 NZKI(I,1) = NZK(I,1)
33200 NZKI(I,2) = NZK(I,2)
33201 NZKI(I,3) = NZK(I,3)
33216 NZKI(L,3) = NZK3(I)
33217 NZKI(L,2) = NZK2(I)
33218 NZKI(L,1) = NZK1(I)
33223 *$ CREATE IDT_IEFUND.FOR
33226 *===iefund=============================================================*
33228 INTEGER FUNCTION IDT_IEFUND(PL,IRE)
33230 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33233 C*****IEFUN CALCULATES A MOMENTUM INDEX
33235 PARAMETER ( LINP = 10 ,
33239 COMMON /HNDRUN/ RUNTES,EFTES
33241 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33243 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33244 & NRK(2,268),NURE(30,2)
33249 IF (PL.LT.0.) GO TO 30
33252 IF (PL.LE.PLABF(I)) GO TO 60
33255 IF ( EFTES.GT.40.D0) GO TO 20
33257 WRITE(LOUT,1000)PL,J
33263 IF (-PL.LE.UMO(I)) GO TO 60
33266 IF ( EFTES.GT.40.D0) GO TO 50
33268 WRITE(LOUT,1000)PL,I
33274 1000 FORMAT(14H PLAB OR -ECM=,E12.4,27H IS OUT OF CONSIDERED RANGE ,
33278 *$ CREATE DT_DSIGIN.FOR
33281 *===dsigin=============================================================*
33283 SUBROUTINE DT_DSIGIN(IRE ,PLAB,N,IE ,AMT ,AMN,ECM ,SI ,ITAR)
33285 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33288 * particle properties (BAMJET index convention),
33289 * (dublicate of DTPART for HADRIN)
33290 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33291 & K1H(110),K2H(110)
33293 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33295 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33296 & NRK(2,268),NURE(30,2)
33298 IE=IDT_IEFUND(PLAB,IRE)
33299 IF (IE.LE.IEII(IRE)) IE=IE+1
33304 ECM=SQRT(AMN2+AMT2+2.0D0*AMT*SQRT(AMN2+PLAB**2))
33305 C*** INTERPOLATION PREPARATION
33311 EKLIM=-THRESH(IIKI)
33314 IF (ECM.GT.ECMO) WDK=0.0D0
33315 C*** INTERPOLATION IN CHANNEL WEIGHTS
33316 IELIM=IDT_IEFUND(EKLIM,IRE)
33317 DELIM=UMO(IELIM)+EKLIM
33319 DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
33320 IF (DELIM*DELIM-DETE*DETE) 20,20,10
33325 WKK=WOK-WDK*DEC/(DECC+1.D-9)
33326 IF (WKK.LT.0.0D0) WKK=0.0D0
33328 IF (-EKLIM.GT.ECM) SI=1.D-14
33332 *$ CREATE DT_DTCHOI.FOR
33335 *===dtchoi=============================================================*
33337 SUBROUTINE DT_DTCHOI(T,P,PP,E,EE,I,II,N,AM1,AM2)
33339 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33342 C ****************************
33343 C TCHOIC CALCULATES A RANDOM VALUE
33344 C FOR THE FOUR-MOMENTUM-TRANSFER T
33345 C ****************************
33347 * particle properties (BAMJET index convention),
33348 * (dublicate of DTPART for HADRIN)
33349 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33350 & K1H(110),K2H(110)
33352 * slope parameters for HADRIN interactions
33353 COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
33357 IF (I.GT.30.AND.II.GT.30) GO TO 20
33360 IF (I.LE.30) GO TO 10
33368 IF (AMA.LE.AMB) GO TO 30
33374 K=INT((AMA-0.75D0)/0.05D0)
33376 IF (K-26.GE.0) K=25
33383 TMIN=-2.0D0*(E*EE-P*PP)+AMH(N)**2+AM1 **2
33384 TMAX=-2.0D0*(E*EE+P*PP)+AMH(N)**2+AM1 **2
33387 C IF (VB.LT.0.2D0) BM=BM*0.1
33394 IF (ABS(TMA).GT.120.D0) GO TO 70
33397 AN=(1.0D0/BM)*(EXP(TMI)-ETMA)
33398 C*** RANDOM CHOICE OF THE T - VALUE
33400 T=(1.0D0/BM)*LOG(ETMA+R*AN*BM)
33404 *$ CREATE DT_DTWOPA.FOR
33407 *===dtwopa=============================================================*
33409 SUBROUTINE DT_DTWOPA(E1,E2,P1,P2,COD1,COD2,COF1,COF2,SIF1,SIF2,
33410 &IT1,IT2,UMOO,ECM,P,N,AM1,AM2)
33412 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33415 C ******************************************************
33416 C QUASI TWO PARTICLE PRODUCTION
33417 C TWOPAR CALCULATES THE ENERGYS AND THE MOMENTA
33418 C FOR THE CREATED PARTICLES OR RESONANCES IT1 AND IT2
33419 C IN THE CM - SYSTEM
33420 C COD1,COD2,COF1,COF2,SIF1,SIF2 ARE THE ANGLES FOR
33421 C SPHERICAL COORDINATES
33422 C ******************************************************
33424 * particle properties (BAMJET index convention),
33425 * (dublicate of DTPART for HADRIN)
33426 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33427 & K1H(110),K2H(110)
33432 E1=((UMOO-AMB)*(UMOO+AMB) + AMA2)/(2.0D0*UMOO)
33434 IF (E1.LT.AMA*1.00001D0) E1=AMA*1.00001D0
33435 AMTE=(E1-AMA)*(E1+AMA)
33439 C / P2 / = / P1 / BUT OPPOSITE DIRECTIONS
33440 C DETERMINATION OF THE ANGLES
33441 C COS(THETA1)=COD1 COS(THETA2)=COD2
33442 C SIN(PHI1)=SIF1 SIN(PHI2)=SIF2
33443 C COS(PHI1)=COF1 COS(PHI2)=COF2
33444 C PHI IS UNIFORMLY DISTRIBUTED IN ( 0,2*PI )
33445 CALL DT_DSFECF(COF1,SIF1)
33448 C CALCULATION OF THETA1
33449 CALL DT_DTCHOI(TR,P,P1,ECM,E1,IT1,IT2,N,AM1,AM2)
33450 COD1=(TR-AMA2-AMH(N)*AMH(N)+2.0D0*ECM*E1)/(2.0D0*P*P1+1.D-18)
33451 IF (COD1.GT.0.9999999D0) COD1=0.9999999D0
33456 *$ CREATE DT_ZK.FOR
33459 *===zk=================================================================*
33463 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33466 * decay channel information for HADRIN
33467 COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
33468 & K1Z(16),K2Z(16),WTZ(153),II22,
33469 & NZK1(153),NZK2(153),NZK3(153)
33471 * decay channel information for HADRIN
33472 CHARACTER*8 ANAMZ,ZKNAM4,ZKNAM5,ZKNAM6
33473 COMMON /HNADDN/ ANAMZ(16),ZKNAM4(9),ZKNAM5(90),ZKNAM6(54)
33475 * Particle masses in GeV *
33476 DATA AMZ/ 3*2.2D0, 0.9576D0, 3*1.887D0, 2.4D0, 2.03D0, 2*1.44D0,
33478 * Resonance width Gamma in GeV *
33479 DATA GAZ/ 3*.2D0, .1D0, 4*.2D0, .18D0, 2*.2D0, 2*.15D0, 3*0.D0 /
33480 * Mean life time in seconds *
33481 DATA TAUZ / 16*0.D0 /
33482 * Charge of particles and resonances *
33483 DATA ICHZ/ 0, 1, 3*0, 1, -1, 0, 1, -1, 0, 0, 1 , 3*0 /
33484 * Baryonic charge *
33485 DATA IBARZ/ 2, 7*0, 1, -1, -1, 1, 1, 3*0 /
33486 * First number of decay channels used for resonances *
33487 * and decaying particles *
33488 DATA K1Z/ 308,310,313,317,322,365,393,421,425,434,440,446,449,
33490 * Last number of decay channels used for resonances *
33491 * and decaying particles *
33492 DATA K2Z/ 309,312,316,321,364,392,420,424,433,439,445,448,451,
33494 * Weight of decay channel *
33495 DATA WTZ/ .17D0, .83D0, 2*.33D0, .34D0, .17D0, 2*.33D0, .17D0,
33496 & .01D0, .13D0, .36D0, .27D0, .23D0, .0014D0, .0029D0, .0014D0,
33497 & .0029D0, 4*.0007D0, .0517D0, .0718D0, .0144D0, .0431D0, .0359D0,
33498 & .0718D0, .0014D0, .0273D0, .0014D0, .0431D0, 2*.0129D0, .0259D0,
33499 & .0517D0, .0359D0, .0014D0, 2*.0144D0, .0129D0, .0014D0, .0259D0,
33500 & .0359D0, .0072D0, .0474D0, .0948D0, .0259D0, .0072D0, .0144D0,
33501 & .0287D0, .0431D0, .0144D0, .0287D0, .0474D0, .0144D0, .0075D0,
33502 & .0057D0, .0019D0, .0038D0, .0095D0, 2*.0014D0, .0191D0, .0572D0,
33503 & .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0, .0686D0,.0172D0,
33504 & .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, .0190D0,
33505 & .0057D0, .0019D0, .0038D0, .0095D0, .0014D0, .0014D0, .0191D0,
33506 & .0572D0, .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0,.0686D0,
33507 & .0172D0, .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0,
33508 & .0190D0, 4*.25D0, 2*.2D0, .12D0, .1D0, .07D0, .07D0, .14D0,
33509 & 2*.05D0, .0D0, .3334D0, .2083D0, 2*.125D0, .2083D0, .0D0, .125D0,
33510 & .2083D0, .3334D0, .2083D0, .125D0, .3D0, .05D0, .65D0, .3D0,
33511 & .05D0, .65D0, 9*1.D0 /
33512 * Particle numbers in decay channel *
33513 DATA NZK1/ 8, 1, 2, 9, 1, 2, 9, 2, 9, 7, 13, 31, 15, 24, 23, 13,
33514 & 23, 13, 2*23, 14, 13, 23, 31, 98, 2*33, 32, 23, 14, 13, 35, 2*23,
33515 & 14, 13, 33, 23, 98, 31, 23, 14, 13, 35, 2*33, 32, 23, 35, 33, 32,
33516 & 98, 5*35, 4*13, 23, 13, 98, 32, 33, 23, 13, 23, 13, 14, 13, 32,
33517 & 13, 98, 23, 13, 2*32, 13, 33, 32, 98, 2*35, 4*14, 23, 14, 98,
33518 & 2*34, 23, 14, 23, 2*14, 13, 34, 14, 98, 23, 14, 2*34, 14, 33, 32,
33519 & 98, 2*35, 104, 61, 105, 62, 1, 17, 21, 17, 22, 2*21, 22, 21, 2,
33520 & 67, 68, 69, 2, 2*9, 68, 69, 70, 2, 9, 2*24, 15, 2*25, 16, 9*0/
33521 DATA NZK2/ 2*8, 1, 8, 9, 2*8, 2*1, 7, 14, 13, 16, 25, 23, 14, 23,
33522 & 14, 31, 33, 32, 34, 35, 31, 23, 31, 33, 34, 31, 32, 34, 31, 33,
33523 & 32, 2*33, 35, 31, 33, 31, 33, 32, 34, 35, 31, 33, 34, 35, 31,
33524 & 4*33, 32, 3*35, 2*23, 13, 31, 32, 33, 13, 31, 32, 2*31, 32, 33,
33525 & 32, 32, 35, 31, 2*32, 33, 31, 33, 35, 33, 3*32, 35, 2*23, 14,
33526 & 31, 34, 33, 14, 31, 33, 2*31, 34, 32, 33, 34, 35, 31, 2*34, 33,
33527 & 31, 33, 35, 33, 2*34, 33, 35, 1, 2, 8, 9, 25, 13, 35, 2*32, 33,
33528 & 31, 13, 23, 31, 13, 23, 14, 79, 80, 31, 13, 23, 14, 78, 79, 8,
33529 & 1, 8, 1, 8, 1, 9*0 /
33530 DATA NZK3/ 23, 14, 2*13, 23, 13, 2*23, 14, 0, 7, 14, 4*0, 2*23,
33531 & 10*0, 33, 2*31, 0, 33, 34, 32, 34, 0, 35, 0, 31, 3*35, 0, 3*31,
33532 & 35, 31, 33, 34, 31, 33, 34, 31, 33, 35, 0, 23, 14, 6*0, 32, 3*33,
33533 & 32, 34, 0, 35, 0, 2*35, 2*31, 35, 32, 34, 31, 33, 32, 0, 23, 13,
33534 & 6*0, 34, 2*33, 34, 33, 34, 0, 35, 0,2*35, 2*31, 35, 2*34, 31,
33535 & 2*34, 25*0, 23, 2*14, 23, 2*13, 9*0 /
33537 DATA ANAMZ / 'NNPI', 'ANPPI', 'ANNPI', ' ETS ',' PAP ',' PAN ',
33538 & 'APN', 'DEO ', 'S+2030', 'AN*-14', 'AN*014','KONPI ','AKOPPI',
33540 * Name of decay channel *
33541 DATA ZKNAM4/'NNPI0','PNPI-','APPPI+','ANNPI+','ANPPI0','APNPI+',
33542 & 'ANNPI0','APPPI0','ANPPI-'/
33543 DATA ZKNAM5/' GAGA ','P+P-GA','ETP+P-','K+K- ','K0AK0 ',
33544 & ' POPO ',' P+P- ','POPOPO','P+P0P-','P0ET ','&0R0 ','P-R+ ',
33545 & 'P+R- ','POOM ',' ETET ','ETSP0 ','R0ET ',' R0R0 ','R+R- ',
33546 & 'P0ETR0','P-ETR+','P+ETR-',' OMET ','P0R0R0','P0R+R-','P-R+R0',
33547 & 'P+R-R0','R0OM ','P0ETOM','ETSR0 ','ETETET','P0R0OM','P-R+OM',
33548 & 'P+R-OM','OMOM ','R0ETET','R0R0ET','R+R-ET','P0OMOM','OMETET',
33549 & 'R0R0R0','R+R0R-','ETSRET','OMR0R0','OMR+R-','OMOMET','OMOMR0',
33551 & ' P+PO ','P+POPO','P+P+P-','P+ET ','P0R+ ','P+R0 ','ETSP+ ',
33552 & 'R+ET ',' R0R+ ','POETR+','P+ETR0','POR+R-','P+R0R0','P-R+R+',
33553 & 'P+R-R+','R+OM ','P+ETOM','ETSR+ ','POR+OM','P+R0OM','R+ETET',
33554 & 'R+R0ET','P+OMOM','R0R0R+','R+R+R-','ETSR+E','OMR+R0','OMOMR+',
33555 & 'P-PO ','P-POPO','P-P-P+','P-ET ','POR- ','P-R0 ','ETSP- ',
33556 & 'R-ET ','R-R0 ','POETR-','P-ETR0','POR-R0','P-R+R-','P-R0R0'/
33557 DATA ZKNAM6/'P+R-R-','R-OM ','P-ETOM','ETSR- ','POR-OM','P-R0OM',
33558 & 'R-ETET','R-R0ET','P-OMOM','R0R0R-','R+R-R-','ETSR-E','OMR0R-',
33559 & 'OMOMR-', 'PAN-14','APN+14','NAN014','ANN014','PAKO ','LPI+ ',
33560 & 'SI+OM','LAMRO+','SI0RO+','SI+RO0','SI+ETA','SI0PI+','SI+PI0',
33561 & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHOO','ANRHO-','ANETA ',
33562 & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0',
33563 & 'KONPIO','KOPPI-','K+NPI-','AKOPPO','AKONP+','K-PPI+',
33568 *$ CREATE DT_BLKD43.FOR
33571 *===blkd43=============================================================*
33573 BLOCK DATA DT_BLKD43
33575 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33579 *=== reac =============================================================*
33581 *----------------------------------------------------------------------*
33583 * Created on 10 december 1991 by Alfredo Ferrari & Paola Sala *
33586 * Last change on 10-dec-91 by Alfredo Ferrari *
33588 * This is the original common reac of Hadrin *
33590 *----------------------------------------------------------------------*
33593 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33594 & NRK(2,268),NURE(30,2)
33597 & UMOPI(92), UMOKC(68), UMOP(39), UMON(63), UMOK0(34),
33598 & PLAPI(92), PLAKC(68), PLAP(39), PLAN(63), PLAK0(34),
33599 & SPIKP1(315), SPIKPU(278), SPIKPV(372),
33600 & SPIKPW(278), SPIKPX(372), SPIKP4(315),
33601 & SPIKP5(187), SPIKP6(289),
33602 & SKMPEL(102), SPIKP7(289), SKMNEL(68), SPIKP8(187),
33603 & SPIKP9(143), SPIKP0(169), SPKPV(143),
33604 & SAPPEL(105), SPIKPE(399), SAPNEL(84), SPIKPZ(273),
33605 & SANPEL(84) , SPIKPF(273),
33606 & SPKP15(187), SPKP16(272),
33607 & NRKPI(164), NRKKC(132), NRKP(70), NRKN(116), NRKK0(54),
33610 DIMENSION NRKLIN(532)
33611 EQUIVALENCE (NRK(1,1), NRKLIN(1))
33612 EQUIVALENCE ( UMO( 1), UMOPI(1)), ( UMO( 93), UMOKC(1))
33613 EQUIVALENCE ( UMO(161), UMOP(1)), ( UMO(200), UMON(1))
33614 EQUIVALENCE ( UMO(263), UMOK0(1))
33615 EQUIVALENCE ( PLABF( 1), PLAPI(1)), ( PLABF( 93), PLAKC(1))
33616 EQUIVALENCE ( PLABF(161), PLAP(1)), ( PLABF(200), PLAN(1))
33617 EQUIVALENCE ( PLABF(263), PLAK0(1))
33618 EQUIVALENCE ( WK( 1), SPIKP1(1)), ( WK( 316), SPIKPU(1))
33619 EQUIVALENCE ( WK( 594), SPIKPV(1)), ( WK( 966), SPIKPW(1))
33620 EQUIVALENCE ( WK(1244), SPIKPX(1)), ( WK(1616), SPIKP4(1))
33621 EQUIVALENCE ( WK(1931), SPIKP5(1)), ( WK(2118), SPIKP6(1))
33622 EQUIVALENCE ( WK(2407), SKMPEL(1)), ( WK(2509), SPIKP7(1))
33623 EQUIVALENCE ( WK(2798), SKMNEL(1)), ( WK(2866), SPIKP8(1))
33624 EQUIVALENCE ( WK(3053), SPIKP9(1)), ( WK(3196), SPIKP0(1))
33625 EQUIVALENCE ( WK(3365), SPKPV(1)), ( WK(3508), SAPPEL(1))
33626 EQUIVALENCE ( WK(3613), SPIKPE(1)), ( WK(4012), SAPNEL(1))
33627 EQUIVALENCE ( WK(4096), SPIKPZ(1)), ( WK(4369), SANPEL(1))
33628 EQUIVALENCE ( WK(4453), SPIKPF(1)), ( WK(4726), SPKP15(1))
33629 EQUIVALENCE ( WK(4913), SPKP16(1))
33630 EQUIVALENCE (NRK(1,1), NRKLIN(1))
33631 EQUIVALENCE (NRKLIN( 1), NRKPI(1)), (NRKLIN( 165), NRKKC(1))
33632 EQUIVALENCE (NRKLIN( 297), NRKP(1)), (NRKLIN( 367), NRKN(1))
33633 EQUIVALENCE (NRKLIN( 483), NRKK0(1))
33634 EQUIVALENCE (NURE(1,1), NURELN(1))
33638 DATA PLAPI / 0.D0, .3D0, .5D0, .6D0, .7D0, .8D0, .9D0, .95D0,1.D0,
33639 & 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0,
33640 & 3.D0, 3.5D0, 4.D0, 0.D0, .285D0, .4D0, .45D0, .5D0, .6D0, .7D0,
33641 & .75D0, .8D0, .85D0, .9D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0,
33642 & 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0,
33643 & .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, .75D0, .8D0, .85D0, .9D0,
33644 & 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0,
33645 & 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, .3D0, .5D0, .6D0, .7D0,
33646 & .8D0, .9D0, .95D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0,
33647 & 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0 /
33649 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33650 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33651 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33652 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33653 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33654 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33655 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33656 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33657 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33658 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33659 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33660 & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
33662 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33663 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33664 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33665 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33666 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33667 & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
33670 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33671 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33672 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33673 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33674 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33675 & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
33676 * app apn anp ann *
33678 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
33679 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33680 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33681 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
33682 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33683 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33684 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
33685 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33686 & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
33687 DATA SIIN / 296*0.D0 /
33688 DATA UMOPI/ 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
33689 & 1.557D0,1.615D0,1.6435D0,
33690 & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
33691 & 2.286D0,2.366D0,2.482D0,2.56D0,
33693 & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
33694 & 1.496D0,1.527D0,1.557D0,
33695 & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
33696 & 2.071D0,2.159D0,2.286D0,2.366D0,
33697 & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
33698 & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
33699 & 1.496D0,1.527D0,1.557D0,
33700 & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
33701 & 2.071D0,2.159D0,2.286D0,2.366D0,
33702 & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
33703 & 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
33704 & 1.557D0,1.615D0,1.6435D0,
33705 & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
33706 & 2.286D0,2.366D0,2.482D0,2.56D0,
33708 DATA UMOKC/ 1.44D0,
33709 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33710 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33712 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33713 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33715 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33716 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33718 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33719 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33721 DATA UMOK0/ 1.44D0,
33722 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33723 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33725 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33726 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33730 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33731 & 3.D0,3.1D0,3.2D0,
33732 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33733 & 3.D0,3.1D0,3.2D0,
33734 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33735 & 3.D0,3.1D0,3.2D0/
33736 * app apn anp ann *
33738 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
33739 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33740 & 3.D0,3.1D0,3.2D0,
33741 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
33742 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33743 & 3.D0,3.1D0,3.2D0,
33744 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
33745 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33746 & 3.D0,3.1D0,3.2D0/
33747 **** reaction channel state particles *
33748 DATA NRKPI / 13, 1, 15, 21, 81, 0, 13, 54, 23, 53, 13, 63, 13, 58,
33749 & 23, 57, 13, 65, 1, 32, 53, 31, 54, 32, 53, 33, 53, 35, 63, 32,
33750 & 13, 8, 23, 1, 17, 15, 21, 24, 22, 15, 82, 0, 61, 0, 13, 55, 23,
33751 & 54, 14, 53, 13, 64, 23, 63, 13, 59, 23, 58, 14, 57, 13, 66, 23,
33752 & 65, 1, 31, 8, 32, 1, 33, 1, 35, 54, 31, 55, 32, 54, 33, 53, 34,
33753 & 54, 35, 14, 1, 23, 8, 17, 24, 20, 15, 22, 24, 83, 0, 62, 0, 14,
33754 & 54, 23, 55, 13, 56, 14, 63, 23, 64, 14, 58, 23, 59, 13, 60, 14,
33755 & 65, 23, 66, 8, 31, 1, 34, 8, 33, 8, 35, 55, 31, 54, 34, 55, 33,
33756 & 56, 32, 55, 35, 14, 8, 24, 20, 84, 0, 14, 55, 23, 56, 14, 64, 14,
33757 & 59, 23, 60, 14, 66, 8, 34, 56, 31, 55, 34, 56, 33, 56, 35, 64,34/
33758 DATA NRKKC/ 15, 1, 89, 0, 24, 53, 15, 54, 1, 36, 1, 40, 1, 44, 36,
33759 & 63, 15, 63, 45, 53, 44, 54, 15, 8, 24, 1, 91, 0, 24, 54, 15, 55,
33760 & 8, 36, 1, 37, 8, 40, 1, 41, 8, 44, 1, 45, 36, 64, 37, 63, 15, 64,
33761 & 24, 63, 45, 54, 44, 55, 16, 1, 25, 8, 17, 23, 21, 14, 20,
33762 & 13, 22, 23, 90, 0, 38, 1, 39, 8, 16, 54, 25, 55, 1, 42, 8, 43,
33763 & 16, 63, 25, 64, 39, 64, 38, 63, 46, 54, 47, 55, 8, 47, 1, 46, 52,
33764 & 0, 51, 0, 16, 8, 17, 14, 20, 23, 22, 14, 92, 0, 8, 38, 16, 55,
33765 & 25, 56, 8, 42, 16, 64, 38, 64, 46, 55, 47, 56, 8, 46, 94, 0 /
33767 * k0 p k0 n ak0 p ak/ n *
33769 DATA NRKK0 / 24, 8, 106, 0, 15, 56, 24, 55, 37, 8, 41, 8, 45, 8,
33770 & 37, 64, 24, 64, 44, 56, 45, 55, 25, 1, 17, 13, 22, 13, 21, 23,
33771 & 107, 0, 39, 1, 25, 54, 16, 53, 43, 1, 25, 63, 39, 63, 47, 54, 46,
33772 & 53, 47, 1, 103, 0, 93, 0/
33774 DATA NRKP / 1, 1, 85, 0, 8, 53, 1, 54, 1, 63, 8, 57, 1, 58, 2*54,
33775 & 53, 55, 63, 54, 64, 53, 1, 8, 86, 0, 8, 54, 1, 55, 8, 63, 1, 64,
33776 & 8, 58, 1, 59, 64, 54, 63, 55, 54, 55, 53, 56, 77, 0, 2*8, 95, 0,
33777 & 8, 55, 1, 56, 8, 64, 8, 59, 1, 60, 2*55, 54, 56, 64, 55, 63, 56 /
33778 * app apn anp ann *
33779 DATA NRKN/ 1, 2, 17, 18, 15, 16, 8, 9, 13, 14, 99, 0, 87, 0, 1,
33780 & 68, 8, 69, 2, 54, 9, 55, 102, 0, 2, 63, 9, 64, 1, 75, 8, 76, 53,
33781 & 67, 54, 68, 55, 69, 56, 70, 63, 68, 64, 69, 75, 54, 76, 55, 2, 8,
33782 & 18, 20, 16, 24, 14, 23, 101, 0, 88, 0, 2, 55, 9, 56, 1, 67, 8,
33783 & 68, 2, 64, 8, 75, 2, 59, 8, 72, 68, 55, 67, 54, 69, 56, 1, 9, 18,
33784 & 21, 15, 25, 13, 23, 100, 0, 96, 0, 2, 53, 9, 54, 1, 69, 8, 70, 1,
33785 & 76, 9, 63, 1, 73, 9, 58, 55, 70, 53, 68, 54, 69 /
33786 **** channel cross section *
33787 DATA SPIKP1/ 0.D0, 300.D0, 40.D0, 20.D0, 13.D0,8.5D0,8.D0, 9.5D0,
33788 & 12.D0,14.D0,15.5D0,20.D0,17.D0,13.D0,10.D0,9.D0,8.5D0,8.D0,7.8D0,
33789 & 7.3D0, 6.7D0, 9*0.D0,.23D0,.35D0,.7D0,.52D0,.4D0,.3D0,.2D0,.15D0,
33790 & .13D0, .11D0, .09D0, .07D0, 0.D0, .033D0,.8D0,1.35D0,1.35D0,.5D0,
33791 & 15*0.D0, 3*0.D0,.00D0,0.80D0,2.2D0,3.6D0,4.6D0,4.7D0,3.5D0,2.4D0,
33792 &1.8D0,1.4D0,.75D0,.47D0,.25D0,.13D0,.08D0,6*0.D0,0.D0,1.2D0,3.3D0,
33793 & 5.4D0,6.9D0,7.3D0,5.3D0,3.6D0,2.7D0,2.2D0,1.1D0,.73D0,.4D0,.22D0,
33794 & .12D0,9*0.D0,.0D0,0.D0,2.0D0,4.4D0,6.8D0,9.9D0,7.9D0,6.0D0,3.8D0,
33795 &2.5D0,2.D0,1.4D0,1.D0,.6D0,.35D0,10*0.D0,.25D0,.55D0,.75D0,1.25D0,
33796 & 1.9D0,2.D0,1.8D0,1.5D0,1.25D0,1.D0,.8D0,6*0.D0,4*0.D0,.4D0,.85D0,
33797 & 1.1D0, 1.85D0, 2.8D0, 3.D0,2.7D0,2.2D0,1.85D0,1.5D0,1.2D0,6*0.D0,
33798 & 6*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, 5.6D0,
33799 & 5.2D0, 6*0.D0, 2*0.D0, .0D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0,
33800 & 2.75D0, 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 6*0.D0, 3*0.D0,
33801 & .0D0, .45D0, 1.4D0, 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0,
33802 & 8*0.D0, 5*0.D0, .0D0, .0D0, .6D0, .8D0, .95D0, .8D0, .7D0, .6D0,
33803 & .5D0, .4D0, 6*0.D0, 5*0.D0, .0D0, .00D0, .85D0, 1.2D0, 1.4D0,
33804 & 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 6*0.D0, 5*0.D0, .0D0, .00D0,
33805 & 1.D0, 1.5D0, 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 6*0.D0,
33806 & 10*0.D0, .5D0, 2.0D0, 3.3D0, 5.4D0, 7.D0 /
33808 DATA SPIKPU/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 20.D0,
33809 & 20.D0, 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
33810 & 10.D0, 10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
33811 & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
33812 & 4.2D0, 7.5D0, 3.4D0, 2.5D0, 2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0,
33813 & .6D0, .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0,
33814 & .48D0, .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0,
33815 & .065D0, .05D0, .04D0, 12*0.D0, .2D0, .25D0, .25D0, .2D0, .1D0,
33816 & .08D0, .06D0, .045D0, .03D0, .02D0, .01D0, .005D0, .003D0,
33817 & 12*0.D0, .3D0, .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0,
33818 & .09D0, .08D0, .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0,
33819 & 3.1D0, 4.5D0, 2.D0, 18*0.D0, 3*.0D0, 0.D0, 0.D0, 4.0D0, 11.D0,
33820 & 11.4D0, 10.3D0, 7.5D0, 6.8D0, 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0,
33821 & .35D0, 13*0.D0, .1D0, .34D0, .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0,
33822 & 2.3D0, 1.6D0, .95D0, .45D0, .28D0, .15D0, 10*0.D0, 2*0.D0, .17D0,
33823 & .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0, 6.2D0, 4.4D0, 3.D0, 1.8D0,
33824 & .9D0, .53D0, .28D0, 10*0.D0, 2*0.D0, .25D0, .82D0,
33825 & 1.3D0, 1.9D0, 2.8D0, 5.5D0 , 8.D0, 5.7D0, 3.9D0, 2.35D0, 1.15D0,
33826 & .69D0, .37D0, 10*0.D0, 7*0.D0, .0D0, .34D0, 1.5D0, 3.47D0,
33827 & 5.87D0, 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
33829 DATA SPIKPV/ 7*0.D0, .00D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
33830 & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 6*0.D0, 10*0.D0, .2D0,
33831 & .6D0, .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0,
33832 & 1.D0, .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0,
33833 & 3.5D0, 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0,
33834 & .31D0, .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0,
33835 & .23D0, 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0,
33836 & 5.D0, 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0,
33837 & 2.5D0, 3*0.D0, 3*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0,
33838 & 1.5D0, 1.1D0, .8D0, .7D0, .55D0, .3D0, 10*0.D0, 9*0.D0, .1D0,
33839 & .4D0, 1.D0, 1.4D0, 2.2D0, 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0,
33840 & .8D0, .6D0, .4D0, 12*0.D0, .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0,
33841 & 3.8D0, 3.3D0, 2.45D0, 2.05D0, 1.65D0, 1.2D0, .9D0, .6D0, 3*0.D0,
33842 & 9*0.D0, .10D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0,
33843 & 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, 13*0.D0, .2D0, .5D0, .7D0,
33844 & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
33845 & 17*0.D0, .2D0, .5D0, .85D0, 2.D0, 2.15D0, 2.05D0, 1.75D0, 1.D0,
33846 & 17*0.D0, .13D0, .33D0, .57D0, 1.33D0, 1.43D0, 1.36D0, 1.17D0,
33847 & .67D0, 17*0.D0, .07D0, .17D0, .28D0, .67D0, .72D0, .69D0, .58D0,
33848 & .33D0,17*0.D0,.4D0, .7D0, 1.D0, 1.6D0, 1.8D0, 2.3D0,1.9D0,1.7D0 /
33850 DATA SPIKPW/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 2*20.D0,
33851 & 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
33852 & 2*10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
33853 & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
33854 & 4.2D0, 7.5D0, 3.4D0, 2*2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, .6D0,
33855 & .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, .48D0,
33856 & .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, .065D0,
33857 & .05D0, .04D0, 12*0.D0, .2D0, 2*.25D0, .2D0, .1D0, .08D0, .06D0,
33858 & .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, 12*0.D0, .3D0,
33859 & .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, .09D0, .08D0,
33860 & .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, 3.1D0, 4.5D0,
33861 & 2.D0, 23*0.D0, 4.0D0, 11.D0, 11.4D0, 10.3D0, 7.5D0, 6.8D0,
33862 & 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, .35D0, 13*0.D0, .1D0, .34D0,
33863 & .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, 2.3D0, 1.6D0, .95D0, .45D0,
33864 & .28D0, .15D0, 12*0.D0, .17D0, .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0,
33865 & 6.2D0, 4.4D0, 3.D0, 1.8D0, .9D0, .53D0, .28D0, 12*0.D0, .25D0,
33866 & .82D0, 1.3D0, 1.9D0, 2.8D0, 5.5D0, 8.D0, 5.7D0, 3.9D0, 2.35D0,
33867 & 1.15D0, .69D0, .37D0, 18*0.D0, .34D0, 1.5D0, 3.47D0, 5.87D0,
33868 & 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
33870 DATA SPIKPX/ 8*0.D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
33871 & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 16*0.D0, .2D0, .6D0,
33872 & .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, 1.D0,
33873 & .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, 3.5D0,
33874 & 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, .31D0,
33875 & .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, .23D0,
33876 & 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, 5.D0,
33877 & 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, 2.5D0,
33878 & 6*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, 1.5D0, 1.1D0,
33879 & .8D0, .7D0, .55D0, .3D0, 19*0.D0, .1D0, .4D0, 1.D0, 1.4D0, 2.2D0,
33880 & 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, .8D0, .6D0, .4D0, 12*0.D0,
33881 & .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, 3.8D0, 3.3D0, 2.45D0, 2.05D0,
33882 & 1.65D0, 1.2D0, .9D0, .6D0, 12*0.D0, .10D0, .2D0, .5D0, .7D0,
33883 & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
33884 & 13*0.D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0,
33885 & 1.35D0, 1.15D0, .95D0, .7D0, 17*0.D0, .2D0, .5D0, .85D0, 2.D0,
33886 & 2.15D0, 2.05D0, 1.75D0, 1.D0, 17*0.D0, .13D0, .33D0, .57D0,
33887 & 1.33D0, 1.43D0, 1.36D0, 1.17D0, .67D0, 17*0.D0, .07D0, .17D0,
33888 & .28D0, .67D0, .72D0, .69D0, .58D0, .33D0, 17*0.D0, .4D0, .7D0,
33889 & 1.D0, 1.6D0, 1.8D0, 2.3D0, 1.9D0, 1.7D0 /
33891 DATA SPIKP4 / 0.D0, 300.D0, 40.D0, 20.D0, 13.D0, 8.5D0, 8.D0,
33892 & 9.5D0, 12.D0, 14.D0, 15.5D0, 20.D0, 17.D0, 13.D0, 10.D0, 9.D0,
33893 & 8.5D0, 8.D0, 7.8D0, 7.3D0, 6.7D0, 9*0.D0, .23D0, .35D0, .7D0,
33894 & .52D0, .4D0, .3D0, .2D0, .15D0, .13D0, .11D0, .09D0, .07D0, 0.D0,
33895 & .033D0, .8D0, 2*1.35D0, .5D0, 19*0.D0, 0.8D0, 2.2D0, 3.6D0,
33896 & 4.6D0, 4.7D0, 3.5D0, 2.4D0, 1.8D0, 1.4D0, .75D0, .47D0, .25D0,
33897 & .13D0, .08D0, 7*0.D0, 1.2D0, 3.3D0, 5.4D0, 6.9D0, 7.3D0, 5.3D0,
33898 & 3.6D0, 2.7D0, 2.2D0, 1.1D0, .73D0, .4D0, .22D0, .12D0, 11*0.D0,
33899 & 2.0D0, 4.4D0, 6.8D0, 9.9D0, 7.9D0, 6.0D0, 3.8D0, 2.5D0, 2.D0,
33900 & 1.4D0, 1.D0, .6D0, .35D0, 10*0.D0, .25D0, .55D0, .75D0, 1.25D0,
33901 & 1.9D0, 2.D0, 1.8D0, 1.5D0, 1.25D0, 1.D0, .8D0, 10*0.D0, .4D0,
33902 & .85D0, 1.1D0, 1.85D0, 2.8D0, 3.D0, 2.7D0, 2.2D0, 1.85D0, 1.5D0,
33903 & 1.2D0, 12*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0,
33904 & 5.6D0, 5.2D0, 9*0.D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, 2.75D0,
33905 & 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 10*0.D0, .45D0, 1.4D0,
33906 & 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, 15*0.D0, .6D0,
33907 & .8D0, .95D0, .8D0, .7D0, .6D0, .5D0, .4D0, 13*0.D0, .85D0, 1.2D0,
33908 & 1.4D0, 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 13*0.D0, 1.D0, 1.5D0,
33909 & 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 16*0.D0, .5D0, 2.0D0,
33910 & 3.3D0, 5.4D0, 7.D0 /
33912 DATA SPIKP5/ 0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0,
33913 & 7.D0, 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
33914 & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 13*0.D0, 0.9D0,
33915 & 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0,
33916 & .45D0, .21D0, .2D0, 3*0.D0, .9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
33917 & 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
33918 & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, 1.4D0,
33919 & 1.2D0, 1.05D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, 2*1.D0, .9D0,
33920 & .7D0, .4D0, .3D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.2D0,
33921 & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
33922 & 1.71D0, 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0,
33923 & 3.5D0, 2.85D0, 2.35D0, 2.01D0, 1.8D0, 12*0.D0, .1D0, .8D0,2.05D0,
33924 & 3.31D0, 3.5D0, 12*0.D0, .034D0, .2D0, .75D0, 1.04D0, 1.24D0 /
33926 DATA SPIKP6/ 0.D0, 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0,
33927 & 1.5D0, 1.2D0, 1.D0, .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0,
33928 & 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, 1.5D0, 1.2D0, 1.D0,
33929 & .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, .5D0, 1.3D0, 2.8D0,
33930 & 2.3D0, 1.6D0, .9D0, 13*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
33931 & 2.D0, 1.7D0, 1.5D0,1.2D0,.9D0,.6D0,.45D0,.21D0,.2D0,3*0.D0,0.9D0,
33932 & 2.5D0, 3.D0, 2.5D0, 2.3D0,2.D0,1.7D0,1.5D0,1.2D0,.9D0,.6D0,.45D0,
33933 & .21D0, .2D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.D0,1.8D0,1.7D0,1.4D0,
33934 & 1.2D0,1.15D0,.9D0,.66D0,.5D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.1D0,
33935 & 1.8D0,1.7D0,1.4D0,1.2D0, 1.15D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0,
33936 & 2*1.D0, .9D0, .7D0, .4D0, .35D0, .2D0, 9*0.D0, .3D0, 2*1.D0,.9D0,
33937 & .7D0, .4D0, .35D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.4D0,3.5D0,4.25D0,
33938 & 4.55D0, 4.85D0, 4.9D0, 9*0.D0, .1D0, 1.D0, 2.4D0, 3.5D0, 4.25D0,
33939 & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
33940 & 1.71D0, 1.6D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0,
33941 & 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0,4.4D0,4.D0,3.5D0,2.85D0,
33942 & 2.35D0, 2.01D0, 1.8D0, 6*0.D0, 1.4D0,3.8D0,5.D0,4.7D0,4.4D0,4.D0,
33943 & 3.5D0,2.85D0,2.35D0,2.01D0,1.8D0,12*0.D0,.1D0,.8D0,2.05D0,3.31D0,
33944 & 3.5D0, 12*0.D0, .034D0,.2D0,.75D0,1.04D0,1.24D0 /
33946 DATA SKMPEL/ 0.D0, 35.D0, 22.D0, 25.D0, 17.D0, 9.D0, 9.5D0, 8.D0,
33947 & 7.D0, 6.5D0, 6.1D0, 5.D0, 4.8D0, 4.6D0, 4.45D0, 4.3D0, 4.2D0,
33948 & 0.D0, 8.D0, 3.5D0, 8.D0, 3.D0, 1.9D0, 1.7D0, 1.D0, .9D0, .8D0,
33949 & .75D0, .5D0, .42D0, .38D0, .34D0, .25D0, .2D0,
33950 & 0.D0, 3.D0, 3.2D0, 3.5D0, 1.5D0, 1.4D0, 1.1D0, .6D0, .5D0,
33951 & .35D0, .28D0, .25D0, .18D0, .12D0, .1D0, .08D0, .04D0,
33952 & 0.D0, 8.5D0, 2.4D0, 1.7D0, 1.3D0, 1.3D0, 1.1D0, .5D0,
33953 & .4D0, .4D0, .35D0, .3D0, .28D0, .2D0, .16D0, .13D0, .11D0,
33954 & 0.D0, 7.D0, 4.8D0, 1.4D0, 1.9D0, .9D0, .4D0, .2D0, .13D0,
33955 & .1D0, .08D0, .06D0, .04D0, .02D0, .015D0, .01D0, .01D0,
33956 & 0.D0, 5.5D0, 1.D0, .8D0, .75D0, .32D0, .2D0, .1D0, .09D0,
33957 & .08D0, .065D0, .05D0, .04D0, .022D0, .017D0, 2*.01D0/
33958 DATA SPIKP7 / 0.D0, .56D0, 1.46D0, 3.16D0, 2.01D0, 1.28D0, .74D0,
33959 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
33960 & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 4*0.D0,
33961 & 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, 1.57D0,
33962 & 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0, 3.03D0,
33963 & 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0,
33964 & .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, 2.8D0,
33965 & 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0,
33966 & .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
33967 & .45D0, .39D0, .22D0, .07D0, 0.D0, 7*0.D0, .34D0, 1.12D0, 1.12D0,
33968 & 1.01D0, .78D0, .45D0, .39D0, .22D0, .07D0, 0.D0, 6*0.D0, 1.71D0,
33969 & 4.26D0, 5.6D0, 5.57D0, 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0,
33970 & 2.25D0, 2.D0, 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
33971 & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, .22D0,
33972 & .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 10*0.D0, .22D0, .8D0,
33973 & .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, .3D0, .7D0,1.D0,
33974 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, 1.72D0, 2.69D0,
33975 & 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 9*0.D0, .11D0, 1.72D0,
33976 & 2.69D0, 3.92D0, 4.76D0, 5.1D0, 5.44D0, 5.3D0, 5*0.D0,9.2D0,4.7D0,
33977 & 1.9D0, 10*0.D0, 2.5D0, 15.D0, 21.5D0, 15.3D0, 3.D0, 1.5D0,
33980 DATA SKMNEL/0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
33981 & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0,
33982 & 0.D0, 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0,
33983 & 1.9D0, .9D0, .5D0, .3D0, .24D0, .2D0, .18D0, .1D0, .09D0,
33984 & 0.D0, 1.8D0, 2.D0, 1.1D0, .9D0, .5D0, .5D0, .4D0, .4D0,
33985 & .2D0, .1D0, .06D0, .05D0, .04D0, .03D0, .02D0, .02D0,
33986 & 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, .7D0, .65D0,
33987 & .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, .03D0/
33988 DATA SPIKP8/0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
33989 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
33990 & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,
33991 & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
33992 & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
33993 & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
33994 & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
33995 & 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, .45D0,
33996 & .39D0, .22D0, .07D0, 0.D0,
33997 & 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
33998 & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0,
33999 & 10*0.D0, .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0,
34000 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0,
34001 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0,
34002 & 9*0.D0, .11D0, 1.72D0, 2.69D0, 3.92D0, 4.76D0,
34003 & 5.10D0, 5.44D0, 5.3D0,
34004 & 4*0.D0, 0.00D0, 9.2D0, 4.7D0, 1.9D0, 9*0.D0/
34006 DATA SPIKP9/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
34007 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
34008 & 0.D0, 3.6D0, 1.7D0, 10*0.D0,
34009 & .0D0, 0.D0, 8.7D0, 17.7D0, 18.8D0, 15.9D0,
34010 & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
34011 & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
34012 & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
34013 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
34014 & 16.9D0, 16.5D0, 11.D0, 5.5D0, 3.5D0,
34015 & 10*0.D0, 4.3D0, 7.6D0, 9.D0,
34016 & 10*0.D0, 1.7D0, 2.6D0, 3.D0,
34017 & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
34018 & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
34019 & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
34020 & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/
34022 DATA SPIKP0/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
34023 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
34024 & 0.D0, 1.8D0, .2D0, 12*0.D0,
34025 & 3.2D0, 6.05D0, 9.9D0, 5.1D0,
34026 & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
34027 & 2*.0D0, 3.2D0, 6.05D0, 9.9D0, 5.1D0,
34028 & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
34029 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
34030 & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
34031 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
34032 & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
34033 & 10*0.D0, .7D0, 5.1D0, 8.D0,
34034 & 10*0.D0, .7D0, 5.1D0, 8.D0,
34035 & 10*.0D0, .3D0, 2.8D0, 4.7D0,
34036 & 10*.0D0, .3D0, 2.8D0, 4.7D0,
34037 & 7*0.D0, 1.2D0, 2.5D0, 3.5D0, 6.D0, 5.3D0, 2.9D0,
34038 & 7*0.D0, 1.7D0, 3.6D0, 5.4D0, 9.D0, 7.6D0, 4.2D0,
34039 & 5*0.D0, 7.7D0, 6.1D0, 2.9D0, 5*0.D0/
34042 DATA SPKPV/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
34043 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
34044 & 0.D0, 3.6D0, 1.7D0, 12*0.D0,
34045 & 8.7D0, 17.7D0, 18.8D0, 15.9D0,
34046 & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
34047 & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
34048 & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
34049 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0, 16.9D0, 16.5D0,
34050 & 11.D0, 5.5D0, 3.5D0,
34051 & 10*0.D0, 4.3D0, 7.6D0, 9.D0,
34052 & 10*0.D0, 1.7D0, 2.6D0, 3.D0,
34053 & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
34054 & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
34055 & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
34056 & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/
34057 **************** ap - p - data *
34058 DATA SAPPEL/ 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
34059 & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
34060 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0,
34061 & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
34062 & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
34063 & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
34064 & 0.D0, 55.D0, 50.D0, 25.D0, 15.D0, 15.D0, 14.D0, 12.D0,
34065 & 10.D0, 7.D0, 6.D0, 4.D0, 3.3D0, 2.8D0, 2.4D0, 2.D0, 1.8D0,
34066 & 1.55D0, 1.3D0, .95D0, .75D0,
34067 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
34068 & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
34069 & .01D0, .008D0, .006D0, .005D0/
34070 DATA SPIKPE/0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
34071 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
34072 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0,
34073 & 9*0.D0, 2.D0, 2.5D0, .2D0, 19*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0,
34074 & 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, .3D0, 1.4D0,
34075 & 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0,
34076 & .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0,
34077 & .3D0, 10*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0,
34078 & .6D0, .5D0, .4D0, .3D0, 9*0.D0, .6D0, 2.5D0, 5.D0, 5.2D0, 5.1D0,
34079 & 5.4D0, 5.8D0, 2.8D0, 2.1D0, 1.8D0, 1.6D0, 1.2D0, 13*0.D0, 1.3D0,
34080 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
34081 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
34082 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
34083 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 14*0.D0, .2D0,
34084 & .5D0, 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0,
34085 & 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0,
34086 & 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, 1.6D0,
34087 & 1.4D0, 1.1D0, .9D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0,
34088 & .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0,
34089 & 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0 /
34090 **************** ap - n - data *
34092 & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
34093 & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
34094 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0,
34095 & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0,
34096 & .85D0, 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0,
34097 & .14D0, .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
34098 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
34099 & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
34100 & .01D0, .008D0, .006D0, .005D0 /
34101 DATA SPIKPZ/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
34102 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
34103 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
34104 & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34105 & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
34106 & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
34107 & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
34108 & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34109 & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34110 & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34111 & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
34112 & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
34113 & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
34114 & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
34117 **************** an - p - data *
34120 & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, 50.D0,
34121 & 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
34122 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0, .05D0,
34123 & .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
34124 & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
34125 & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
34126 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, .25D0,
34127 & .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
34128 & .01D0, .008D0, .006D0, .005D0 /
34129 DATA SPIKPF/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
34130 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
34131 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
34132 & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34133 & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
34134 & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
34135 & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
34136 & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34137 & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34138 & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34139 & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
34140 & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
34141 & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
34142 & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
34143 **** ko - n - data *
34144 DATA SPKP15/0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, 7.D0,
34145 & 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
34146 & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 10*0.D0,
34147 & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
34148 & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
34149 & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
34150 & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
34151 & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0,
34152 & 1.4D0, 1.2D0, 1.05D0, .9D0, .66D0, .5D0,
34153 & 7*0.D0, .3D0, 1.D0, 1.D0, .9D0, .7D0, .4D0, .30D0, .2D0,
34154 & 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.20D0, 4.55D0,
34156 & 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, 1.6D0,
34157 & 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, 3.5D0,
34158 & 2.85D0, 2.35D0, 2.01D0, 1.8D0,
34159 & 12*0.D0, .1D0, .8D0, 2.05D0, 3.31D0, 3.5D0,
34160 & 12*0.D0, .034D0, .20D0, .75D0, 1.04D0, 1.24D0 /
34161 **** ako - p - data *
34162 DATA SPKP16/ 0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
34163 & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, 0.D0,
34164 & 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, 1.9D0, .9D0, .5D0,
34165 & .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, 0.D0, 1.8D0, 2.D0, 1.1D0,
34166 & .9D0, .5D0, .5D0, .4D0, .4D0, .2D0, .1D0, .06D0, .05D0, .04D0,
34167 & .03D0, .02D0, .02D0, 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0,
34168 & .7D0, .65D0, .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0,
34169 & .03D0, 0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
34170 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0,
34171 & 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0,
34172 & 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0,
34173 & 1.01D0, .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0,
34174 & 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0,
34175 & .5D0, .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
34176 & .45D0, .39D0, .22D0, .07D0, 7*0.D0, 1.71D0, 4.26D0, 5.6D0,5.57D0,
34177 & 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0,
34178 & .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0,
34179 & .3D0, .7D0, 1.D0, 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0,
34180 & 1.72D0, 2.69D0, 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 5*0.D0,
34181 & 9.2D0, 4.7D0, 1.9D0, 9*0.D0, .0D0,2.5D0,15.D0,
34182 & 21.5D0, 15.3D0, 3.D0, 1.5D0, 10*0.D0 /
34183 DATA NURELN/9, 12, 5*0, 10, 14, 3*0, 1, 3, 5, 7, 6*0, 2, 6, 16,
34184 & 5*0, 10, 13, 5*0, 11, 12, 3*0, 2, 4, 6, 8, 6*0, 3, 15, 7, 5*0 /
34185 *= end*block.blkdt3 *
34187 *$ CREATE DT_QEL_POL.FOR
34190 *===qel_pol============================================================*
34192 SUBROUTINE DT_QEL_POL(ENU,LTYP,P21,P22,P23,P24,P25)
34194 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34198 CALL DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
34203 *$ CREATE DT_GEN_QEL.FOR
34205 C==================================================================
34206 C Generation of a Quasi-Elastic neutrino scattering
34207 C==================================================================
34209 *===gen_qel============================================================*
34211 SUBROUTINE DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
34213 C...Generate a quasi-elastic neutrino/antineutrino
34214 C. Interaction on a nuclear target
34215 C. INPUT : LTYP = neutrino type (1,...,6)
34216 C. ENU (GeV) = neutrino energy
34217 C----------------------------------------------------
34219 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34222 PARAMETER ( LINP = 10 ,
34225 PARAMETER (MAXLND=4000)
34226 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
34228 * nuclear potential
34230 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
34231 & EBINDP(2),EBINDN(2),EPOT(2,210),
34232 & ETACOU(2),ICOUL,LFERMI
34234 * steering flags for qel neutrino scattering modules
34235 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
34236 **sr - removed (not needed)
34237 C COMMON /CBAD/ LBAD, NBAD
34238 C COMMON /CNUC/ XMN,XMN2,PFERMI,EFERMI,EBIND,EB2,C0
34241 DIMENSION PI(3),PO(3)
34246 C REAL*8 MN(2), ML0(6), ML, ML2, MI, MI2, MF, MF2
34247 DIMENSION DBETA(3),DBETB(3),AMN(2),AML0(6)
34248 DATA AMN /0.93827231D0, 0.93956563D0/
34249 DATA AML0 /2*0.51100D-03,2*0.105659D0, 2*1.777D0/
34252 C DATA PFERMI/0.22D0/
34253 CGB+...Binding Energy
34254 DATA EBIND/0.008D0/
34258 IF(ININU.EQ.1)NDSIG=0
34263 AML = AML0(LTYP) ! massa leptoni
34264 AML2 = AML**2 ! massa leptoni **2
34265 C...Particle labels (LUND)
34275 K0 = (LTYP-1)/2 ! 2
34277 KA = 12 + 2*K0 ! 16
34278 IS = -1 + 2*LTYP - 4*K1 ! -1 +10 -8 = 1
34282 LNU = 2 - LTYP + 2*K1 ! 2 - 5 + 2 = - 1
34283 IF (LNU .EQ. 2) THEN
34311 EFMAX = SQRT(PFERMI**2 + AMI2) -AMI ! max. Fermi Energy
34312 ENWELL = EFMAX + EBIND ! depth of nuclear potential well
34317 C...4-momentum initial lepton
34318 P(1,5) = 0. ! massa
34319 P(1,4) = ENU0 ! energia
34324 C PF = PFERMI*PYR(0)**(1./3.)
34325 c write(23,*) PYR(0)
34326 c write(*,*) 'Pfermi=',PF
34329 C IF(ntry.GT.2) WRITE(*,*) ntry,enu0,k2
34330 IF (NTRY .GT. 500) THEN
34332 WRITE (LOUT,1001) NBAD, ENU
34335 C CT = -1. + 2.*PYR(0)
34337 C ST = SQRT(1.-CT*CT)
34338 C F = 2.*3.1415926*PYR(0)
34341 C P(2,4) = SQRT(PF*PF + MI2) - EBIND ! energia
34342 C P(2,1) = PF*ST*COS(F) ! px
34343 C P(2,2) = PF*ST*SIN(F) ! py
34344 C P(2,3) = PF*CT ! pz
34345 C P(2,5) = SQRT(P(2,4)**2-PF*PF) ! massa
34351 beta1=-p(2,1)/p(2,4)
34352 beta2=-p(2,2)/p(2,4)
34353 beta3=-p(2,3)/p(2,4)
34355 C WRITE(6,*)' before transforming into target rest frame'
34357 CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
34359 C print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
34362 phi11=atan(p(1,2)/p(1,3))
34367 CALL DT_TESTROT(PI,Po,PHI11,1)
34369 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34375 phi12=atan(p(1,1)/p(1,3))
34380 CALL DT_TESTROT(Pi,Po,PHI12,2)
34382 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34391 C...Kinematical limits in Q**2
34392 c S = P(2,5)**2 + 2.*ENU*(P(2,4)-P(2,3)) ! ????
34393 S = P(2,5)**2 + 2.*ENU*P(2,5)
34394 SQS = SQRT(S) ! E centro massa
34395 IF (SQS .LT. (AML + AMF + 3.E-03)) GOTO 100
34396 ELF = (S-AMF2+AML2)/(2.*SQS) ! energia leptone finale p
34397 PSTAR = (S-P(2,5)**2)/(2.*SQS) ! p* neutrino nel c.m.
34398 PLF = SQRT(ELF**2-AML2) ! 3-momento leptone finale
34399 Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF) ! + o -
34400 Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF) ! according con cos(theta)
34401 IF (Q2MIN .LT. 0.) Q2MIN = 0. ! ??? non fisico
34404 DSIGMAX = DT_DSQEL_Q2 (LTYP,ENU, Q2MIN)
34405 200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
34406 DSIG = DT_DSQEL_Q2 (LTYP,ENU, Q2)
34407 IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200
34408 CALL DT_QGAUS(Q2MIN,Q2MAX,DSIGEV,ENU,LTYP)
34410 C WRITE(6,*)' Q2,Q2min,Q2MAX,DSIGEV',
34411 C &Q2,Q2min,Q2MAX,DSIGEV
34413 C...c.m. frame. Neutrino along z axis
34414 DETOT = (P(1,4)) + (P(2,4)) ! e totale
34415 DBETA(1) = ((P(1,1)) + (P(2,1)))/DETOT ! px1+px2/etot = beta_x
34416 DBETA(2) = ((P(1,2)) + (P(2,2)))/DETOT !
34417 DBETA(3) = ((P(1,3)) + (P(2,3)))/DETOT !
34420 C WRITE(*,*) 'Input values laboratory frame'
34423 CALL PYROBO(0,0,0.0D0,0.0D0,-DBETA(1),-DBETA(2),-DBETA(3))
34426 c STHETA = ULANGL(P(1,3),P(1,1))
34427 c write(*,*) 'stheta' ,stheta
34429 c CALL PYROBO (0,0,-STHETA,0.,0.D0,0.D0,0.D0)
34432 C WRITE(*,*) 'Output values cm frame'
34433 C...Kinematic in c.m. frame
34434 CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) ! cos(theta) cm
34435 STSTAR = SQRT(1.-CTSTAR**2)
34436 PHI = 6.28319*PYR(0) ! random phi tra 0 e 2*pi
34437 P(4,5) = AML ! massa leptone
34438 P(4,4) = ELF ! e leptone
34439 P(4,3) = PLF*CTSTAR ! px
34440 P(4,1) = PLF*STSTAR*COS(PHI) ! py
34441 P(4,2) = PLF*STSTAR*SIN(PHI) ! pz
34443 P(5,5) = AMF ! barione
34444 P(5,4) = (S+AMF2-AML2)/(2.*SQS)! e barione
34445 P(5,3) = -P(4,3) ! px
34446 P(5,1) = -P(4,1) ! py
34447 P(5,2) = -P(4,2) ! pz
34450 P(3,1) = P(1,1)-P(4,1)
34451 P(3,2) = P(1,2)-P(4,2)
34452 P(3,3) = P(1,3)-P(4,3)
34453 P(3,4) = P(1,4)-P(4,4)
34455 C...Transform back to laboratory frame
34456 C WRITE(*,*) 'before going back to nucl rest frame'
34457 c CALL PYROBO (0,0,STHETA,0.,0.D0,0.D0,0.D0)
34460 CALL PYROBO(0,0,0.0D0,0.0D0,DBETA(1),DBETA(2),DBETA(3))
34462 C WRITE(*,*) 'Now back in nucl rest frame'
34463 IF(LTYP.GE.3) CALL DT_PREPOLA(Q2,LTYP,ENU)
34465 c********************************************
34471 CALL DT_TESTROT(Pi,Po,PHI12,3)
34473 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34479 c********************************************
34485 CALL DT_TESTROT(Pi,Po,PHI11,4)
34487 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34494 c********************************************
34496 C WRITE(*,*) 'Now back in lab frame'
34498 CALL PYROBO(1,5,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
34501 C...test (on final momentum of nucleon) if Fermi-blocking
34503 ENUCL = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2 + P(5,5)**2)
34505 IF (ENUCL.LT. EFMAX) THEN
34506 IF(INIPRI.LT.10)THEN
34508 C WRITE(6,*)' qel: Pauli ENUCL.LT.EFMAX ', ENUCL,EFMAX
34509 C...the interaction is not possible due to Pauli-Blocking and
34510 C...it must be resampled
34513 ELSE IF (ENUCL.LT.ENWELL.and.ENUCL.GE.EFMAX) THEN
34514 IF(INIPRI.LT.10)THEN
34516 C WRITE(6,*)' qel: inside ENUCL.LT.ENWELL ', ENUCL,ENWELL
34518 C Reject (J:R) here all these events
34519 C are otherwise rejected in dpmjet
34521 C...the interaction is possible, but the nucleon remains inside
34522 C...the nucleus. The nucleus is therefore left excited.
34523 C...We treat this case as a nucleon with 0 kinetic energy.
34529 ELSE IF (ENUCL.GE.ENWELL) THEN
34530 C WRITE(6,*)' qel ENUCL.GE.ENWELL ',ENUCL,ENWELL
34531 C...the interaction is possible, the nucleon can exit the nucleus
34532 C...but the nuclear well depth must be subtracted. The nucleus could be
34533 C...left in an excited state.
34534 Pstart = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2)
34535 C P(5,4) = ENUCL-ENWELL + AMF
34536 Pnucl = SQRT(P(5,4)**2-AMF**2)
34537 C...The 3-momentum is scaled assuming that the direction remains
34539 P(5,1) = P(5,1) * Pnucl/Pstart
34540 P(5,2) = P(5,2) * Pnucl/Pstart
34541 P(5,3) = P(5,3) * Pnucl/Pstart
34542 C WRITE(6,*)' qel new P(5,4) ',P(5,4)
34545 DSIGSU=DSIGSU+DSIGEV
34555 IF(NEUDEC.EQ.1.OR.NEUDEC.EQ.2) THEN
34557 CALL PYROBO(6,8,0.0D0,0.0D0,DBETB(1),DBETB(2),DBETB(3))
34561 C PRINT*,' FINE EVENTO '
34565 1001 FORMAT(2X, 'DT_GEN_QEL : event rejected ', I5, G10.3)
34568 *$ CREATE DT_MASS_INI.FOR
34570 C====================================================================
34572 C====================================================================
34574 *===mass_ini===========================================================*
34576 SUBROUTINE DT_MASS_INI
34577 C...Initialize the kinematics for the quasi-elastic cross section
34579 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34582 * particle masses used in qel neutrino scattering modules
34583 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
34584 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
34585 & EMPROTSQ,EMNEUTSQ,EMNSQ
34587 EML(1) = 0.51100D-03 ! e-
34588 EML(2) = EML(1) ! e+
34589 EML(3) = 0.105659D0 ! mu-
34590 EML(4) = EML(3) ! mu+
34591 EML(5) = 1.7777D0 ! tau-
34592 EML(6) = EML(5) ! tau+
34593 EMPROT = 0.93827231D0 ! p
34594 EMNEUT = 0.93956563D0 ! n
34595 EMPROTSQ = EMPROT**2
34596 EMNEUTSQ = EMNEUT**2
34597 EMN = (EMPROT + EMNEUT)/2.
34601 EMN1(J0+1) = EMNEUT
34602 EMN1(J0+2) = EMPROT
34603 EMN2(J0+1) = EMPROT
34604 EMN2(J0+2) = EMNEUT
34607 EMLSQ(J) = EML(J)**2
34608 ETQE(J) = ((EMN2(J)+ EML(J))**2-EMN1(J)**2)/(2.*EMN1(J))
34613 *$ CREATE DT_DSQEL_Q2.FOR
34616 *===dsqel_q2===========================================================*
34618 DOUBLE PRECISION FUNCTION DT_DSQEL_Q2 (JTYP,ENU, Q2)
34620 C...differential cross section for Quasi-Elastic scattering
34621 C. nu + N -> l + N'
34622 C. From Llewellin Smith Phys.Rep. 3C, 261, (1971).
34624 C. INPUT : JTYP = 1,...,6 nu_e, ...., nubar_tau
34625 C. ENU (GeV) = Neutrino energy
34626 C. Q2 (GeV**2) = (Transfer momentum)**2
34628 C. OUTPUT : DSQEL_Q2 = differential cross section :
34629 C. dsigma/dq**2 (10**-38 cm+2/GeV**2)
34630 C------------------------------------------------------------------
34632 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34635 * particle masses used in qel neutrino scattering modules
34636 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
34637 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
34638 & EMPROTSQ,EMNEUTSQ,EMNSQ
34639 **sr - removed (not needed)
34640 C COMMON /CAXIAL/ FA0, AXIAL2
34644 DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
34645 DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
34646 DATA AXIAL2 /1.03D0/ ! to be checked
34650 GVE = 1.D0/ (1.D0 + Q2/0.84D0**2)**2 ! G_e(q**2)
34651 GVM = (1.D0+CSI)*GVE ! G_m (q**2)
34652 X = Q2/(EMN*EMN) ! emn=massa barione
34654 FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
34655 FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
34656 FA = FA0/(1.D0 + Q2/AXIAL2)**2
34660 RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp)
34661 A1 = (4.D0+X)*FFA - (4.D0-X)*FFV1 + X*FFV2*(1.D0-XA)+4*X*FV1*FV2
34662 A2 = -RM * ((FV1 + FV2)**2 + FFA)
34663 AA = (XA+0.25D0*RM)*(A1 + A2)
34664 BB = -X*FA*(FV1 + FV2)
34665 CC = 0.25D0*(FFA + FFV1 + XA*FFV2)
34666 SU = (4.D0*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
34667 DT_DSQEL_Q2 = C0*(AA + SS(JTYP)*BB*SU + CC*SU*SU) / (ENU*ENU) !
34668 IF(DT_DSQEL_Q2 .LT. 0.D0) DT_DSQEL_Q2 = 0.D0
34673 *$ CREATE DT_PREPOLA.FOR
34676 *===prepola============================================================*
34678 SUBROUTINE DT_PREPOLA(Q2,JTYP,ENU)
34680 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34683 c By G. Battistoni and E. Scapparone (sept. 1997)
34685 c Albright & Jarlskog, Nucl Phys B84 (1975) 467
34688 PARAMETER (MAXLND=4000)
34689 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
34691 COMMON /QNPOL/ POLARX(4),PMODUL
34693 * particle masses used in qel neutrino scattering modules
34694 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
34695 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
34696 & EMPROTSQ,EMNEUTSQ,EMNSQ
34698 * steering flags for qel neutrino scattering modules
34699 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
34700 **sr - removed (not needed)
34701 C COMMON /CAXIAL/ FA0, AXIAL2
34702 C COMMON /TAUTAU/Q(4,5),ETL,PXL,PYL,PZL,
34703 C & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN
34705 REAL*8 POL(4,4),BB2(3)
34707 C DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
34708 DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
34709 **sr uncommented since common block CAXIAL is now commented
34710 DATA AXIAL2 /1.03D0/ ! to be checked
34720 GVE = 1.D0/ (1.D0 + Q2/(0.84D+00)**2)**2 ! G_e(q**2)
34721 GVM = (1.D0+CSI)*GVE ! G_m (q**2)
34722 X = Q2/(EMN*EMN) ! emn=massa barione
34724 FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
34725 FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
34726 FA = FA0/(1.D0 + Q2/AXIAL2**2)**2
34730 FP=2.D0*FA*RMM/(MPI**2 + Q2)
34731 RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp)
34732 A1 = (4.D0+X)*FFA-(4.D0-X)*FFV1+X*FFV2*(1.D0-XA)+4.D0*X*FV1*FV2
34733 A2 = -RM * ((FV1 + FV2)**2 + FFA)
34734 AA = (XA+0.25D+00*RM)*(A1 + A2)
34735 BB = -X*FA*(FV1 + FV2)
34736 CC = 0.25D+00*(FFA + FFV1 + XA*FFV2)
34737 SU = (4.D+00*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
34739 OMEGA1=FFA+XA*(FFA+(FV1+FV2)**2 ) ! articolo di ll...-smith
34741 OMEGA3=2.D+00*FA*(FV1+FV2)
34742 OMEGA4P=(-(FV1+FV2)**2-(FA+2*FP)**2+(4.0D+00+
34745 OMEGA4=(OMEGA4P-OMEGA2+2*OMEGA5)/4.D+00
34746 WW1=2.D+00*OMEGA1*EMN**2
34747 WW2=2.D+00*OMEGA2*EMN**2
34748 WW3=2.D+00*OMEGA3*EMN**2
34749 WW4=2.D+00*OMEGA4*EMN**2
34750 WW5=2.D+00*OMEGA5*EMN**2
34753 BB2(I)=-P(4,I)/P(4,4)
34757 c WRITE(*,*) 'Prepola: ready to transform to lepton rest frame'
34760 CALL PYROBO(0,0,0.0D0,0.0D0,BB2(1),BB2(2),BB2(3))
34762 * NOW PARTICLES ARE IN THE SCATTERED LEPTON REST FRAME
34765 c WRITE(*,*) 'Prepola: now in lepton rest frame'
34769 FRAC=QM2*WW1 + (2.D+00*EE*(EE-U) - 0.5D+00*QM2)*WW2 - SS(JTYP)*
34770 + (0.5D+00/(RMM**2))*(2.D+00*RMM*EE*Q2 - U*QM2)*WW3 +
34771 + ((RML**2)/(2.D+00*FM2))*(QM2*WW4-2.D+00*RMM*EE*WW5) !<=FM2 inv di RMM!!
34773 FACTK=2.D+00*WW1 -WW2 -SS(JTYP)*(EE/RMM)*WW3 +((EE-U)/RMM)*WW5
34774 + - ((RML**2)/FM2)*WW4 !<=FM2 inv di RMM!!
34776 FACTP=2.D+00*EE/RMM*WW2 - (QM2/(2.D+00*RMM**2))*(SS(JTYP)*WW3+WW5)
34779 POL(4,I)=RML*SS(JTYP)*(FACTK*P(1,I)+FACTP*P(2,I))/FRAC
34785 PMODUL=PMODUL+POL(4,I)**2
34788 IF(JTYP.GT.4.AND.NEUDEC.GT.0) THEN
34789 IF(NEUDEC.EQ.1) THEN
34790 CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-2),POLARX(3),
34792 + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
34794 c Tau has decayed in muon
34797 IF(NEUDEC.EQ.2) THEN
34798 CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-4),POLARX(3),
34800 + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
34802 c Tau has decayed in electron
34810 c fill common for muon(electron)
34818 IF(NEUDEC.EQ.1) THEN
34821 ELSEIF(NEUDEC.EQ.2) THEN
34825 ELSEIF(JTYP.EQ.6) THEN
34826 IF(NEUDEC.EQ.1) THEN
34828 ELSEIF(NEUDEC.EQ.2) THEN
34836 c fill common for tau_(anti)neutrino
34846 ELSEIF(JTYP.EQ.6) THEN
34853 c Fill common for muon(electron)_(anti)neutrino
34862 IF(NEUDEC.EQ.1) THEN
34864 ELSEIF(NEUDEC.EQ.2) THEN
34867 ELSEIF(JTYP.EQ.6) THEN
34868 IF(NEUDEC.EQ.1) THEN
34870 ELSEIF(NEUDEC.EQ.2) THEN
34881 c IF(PMODUL.GE.1.D+00) THEN
34882 c WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
34883 c write(*,*) pmodul
34885 c POL(4,I)=POL(4,I)/PMODUL
34886 c POLARX(I)=POL(4,I)
34890 c PMODUL=PMODUL+POL(4,I)**2
34892 c WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
34896 c WRITE(*,*) 'PMODUL = ',PMODUL
34900 c WRITE(*,*) 'prepola: Now back to nucl rest frame'
34902 CALL PYROBO(1,5,0.0D0,0.0D0,-BB2(1),-BB2(2),-BB2(3))
34904 XDC = V(4,1)+V(4,5)*P(4,1)/P(4,5)
34905 YDC = V(4,2)+V(4,5)*P(4,2)/P(4,5)
34906 ZDC = V(4,3)+V(4,5)*P(4,3)/P(4,5)
34916 *$ CREATE DT_TESTROT.FOR
34919 *===testrot============================================================*
34921 SUBROUTINE DT_TESTROT(PI,PO,PHI,MODE)
34923 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34926 DIMENSION ROT(3,3),PI(3),PO(3)
34928 IF (MODE.EQ.1) THEN
34933 ROT(2,2) = COS(PHI)
34934 ROT(2,3) = -SIN(PHI)
34936 ROT(3,2) = SIN(PHI)
34937 ROT(3,3) = COS(PHI)
34938 ELSEIF (MODE.EQ.2) THEN
34942 ROT(2,1) = COS(PHI)
34944 ROT(2,3) = -SIN(PHI)
34945 ROT(3,1) = SIN(PHI)
34947 ROT(3,3) = COS(PHI)
34948 ELSEIF (MODE.EQ.3) THEN
34952 ROT(1,2) = COS(PHI)
34954 ROT(3,2) = -SIN(PHI)
34955 ROT(1,3) = SIN(PHI)
34957 ROT(3,3) = COS(PHI)
34958 ELSEIF (MODE.EQ.4) THEN
34963 ROT(2,2) = COS(PHI)
34964 ROT(3,2) = -SIN(PHI)
34966 ROT(2,3) = SIN(PHI)
34967 ROT(3,3) = COS(PHI)
34969 STOP ' TESTROT: mode not supported!'
34972 PO(J) = ROT(J,1)*PI(1)+ROT(J,2)*PI(2)+ROT(J,3)*PI(3)
34978 *$ CREATE DT_LEPDCYP.FOR
34981 *===lepdcyp============================================================*
34983 SUBROUTINE DT_LEPDCYP(AMA,AML,POL,ETL,PXL,PYL,PZL,
34984 & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
34986 C-----------------------------------------------------------------
34988 C Author :- G. Battistoni 10-NOV-1995
34990 C=================================================================
34992 C Purpose : performs decay of polarized lepton in
34993 C its rest frame: a => b + l + anti-nu
34994 C (Example: mu- => nu-mu + e- + anti-nu-e)
34995 C Polarization is assumed along Z-axis
34997 C 1) b AND anti-nu ARE ASSUMED TO BE NEUTRINOS
34998 C OF NEGLIGIBLE MASS
34999 C 2) RADIATIVE CORRECTIONS ARE NOT CONSIDERED
35002 C Method : modifies phase space distribution obtained
35003 C by routine EXPLOD using a rejection against the
35004 C matrix element for unpolarized lepton decay
35006 C Inputs : Mass of a : AMA
35009 C (Example: fully polar. mu- decay: AMA=AMMUON, AML=AMELCT,
35012 C Outputs : kinematic variables in the rest frame of decaying lepton
35013 C ETL,PXL,PYL,PZL 4-moment of l
35014 C ETB,PXB,PYB,PZB 4-moment of b
35015 C ETN,PXN,PYN,PZN 4-moment of anti-nu
35017 C============================================================
35021 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35024 PARAMETER ( LINP = 10 ,
35028 PARAMETER ( KALGNM = 2 )
35029 PARAMETER ( ANGLGB = 5.0D-16 )
35030 PARAMETER ( ANGLSQ = 2.5D-31 )
35031 PARAMETER ( AXCSSV = 0.2D+16 )
35032 PARAMETER ( ANDRFL = 1.0D-38 )
35033 PARAMETER ( AVRFLW = 1.0D+38 )
35034 PARAMETER ( AINFNT = 1.0D+30 )
35035 PARAMETER ( AZRZRZ = 1.0D-30 )
35036 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
35037 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
35038 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
35039 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
35040 PARAMETER ( CSNNRM = 2.0D-15 )
35041 PARAMETER ( DMXTRN = 1.0D+08 )
35042 PARAMETER ( ZERZER = 0.D+00 )
35043 PARAMETER ( ONEONE = 1.D+00 )
35044 PARAMETER ( TWOTWO = 2.D+00 )
35045 PARAMETER ( THRTHR = 3.D+00 )
35046 PARAMETER ( FOUFOU = 4.D+00 )
35047 PARAMETER ( FIVFIV = 5.D+00 )
35048 PARAMETER ( SIXSIX = 6.D+00 )
35049 PARAMETER ( SEVSEV = 7.D+00 )
35050 PARAMETER ( EIGEIG = 8.D+00 )
35051 PARAMETER ( ANINEN = 9.D+00 )
35052 PARAMETER ( TENTEN = 10.D+00 )
35053 PARAMETER ( HLFHLF = 0.5D+00 )
35054 PARAMETER ( ONETHI = ONEONE / THRTHR )
35055 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
35056 PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
35057 PARAMETER ( ENEPER = 2.7182818284590452354 D+00 )
35058 PARAMETER ( SQRENT = 1.6487212707001281468 D+00 )
35059 PARAMETER ( CLIGHT = 2.99792458 D+10 )
35060 PARAMETER ( AVOGAD = 6.0221367 D+23 )
35061 PARAMETER ( AMELGR = 9.1093897 D-28 )
35062 PARAMETER ( PLCKBR = 1.05457266 D-27 )
35063 PARAMETER ( ELCCGS = 4.8032068 D-10 )
35064 PARAMETER ( ELCMKS = 1.60217733 D-19 )
35065 PARAMETER ( AMUGRM = 1.6605402 D-24 )
35066 PARAMETER ( AMMUMU = 0.113428913 D+00 )
35067 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
35068 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
35069 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
35070 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
35071 PARAMETER ( PLABRC = 0.197327053 D+00 )
35072 PARAMETER ( AMELCT = 0.51099906 D-03 )
35073 PARAMETER ( AMUGEV = 0.93149432 D+00 )
35074 PARAMETER ( AMMUON = 0.105658389 D+00 )
35075 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
35076 PARAMETER ( GEVMEV = 1.0 D+03 )
35077 PARAMETER ( EMVGEV = 1.0 D-03 )
35078 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
35079 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
35080 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
35082 C variables for EXPLOD
35084 PARAMETER ( KPMX = 10 )
35085 DIMENSION AMEXPL (KPMX), PXEXPL (KPMX), PYEXPL (KPMX),
35086 & PZEXPL (KPMX), ETEXPL (KPMX)
35090 **sr - removed (not needed)
35091 C COMMON /GBATNU/ ELERAT,NTRY
35094 C Initializes test variables
35099 C Maximum value for matrix element
35101 ELEMAX = ( AMA**2 + AML**2 )**2 / AMA**2 * ( AMA**2 - AML**2 +
35102 & SQRT( AMA**4 + AML**4 - 3.D+00 * AMA**2 * AML**2 ) )
35103 C + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
35104 C Inputs for EXPLOD
35105 C part. no. 1 is l (e- in mu- decay)
35106 C part. no. 2 is b (nu-mu in mu- decay)
35107 C part. no. 3 is anti-nu (anti-nu-e in mu- decay)
35108 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
35115 C phase space distribution
35120 CALL EXPLOD ( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
35124 C Calculates matrix element:
35125 C 64*GF**2{[P(a)-ama*S(a)]*P(anti-nu)}{P(l)*P(b)}
35126 C Here CTH is the cosine of the angle between anti-nu and Z axis
35128 CTH = PZEXPL(3) / SQRT ( PXEXPL(3)**2 + PYEXPL(3)**2 +
35130 PROD1 = ETEXPL(3) * AMA * (1.D+00 - POL * CTH)
35131 PROD2 = ETEXPL(1) * ETEXPL(2) - PXEXPL(1)*PXEXPL(2) -
35132 & PYEXPL(1)*PYEXPL(2) - PZEXPL(1)*PZEXPL(2)
35133 ELEMAT = 16.D+00 * PROD1 * PROD2
35134 IF(ELEMAT.GT.ELEMAX) THEN
35135 WRITE(LOUT,*) 'Problems in LEPDCY',ELEMAX,ELEMAT
35139 C Here performs the rejection
35141 TEST = DT_RNDM(ETOTEX) * ELEMAX
35142 IF ( TEST .GT. ELEMAT ) GO TO 100
35144 C final assignment of variables
35146 ELERAT = ELEMAT/ELEMAX
35162 *$ CREATE DT_GEN_DELTA.FOR
35164 C==================================================================
35165 C. Generation of Delta resonance events
35166 C==================================================================
35168 *===gen_delta==========================================================*
35170 SUBROUTINE DT_GEN_DELTA(ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25)
35172 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35175 PARAMETER ( LINP = 10 ,
35179 C...Generate a Delta-production neutrino/antineutrino
35180 C. CC-interaction on a nucleon
35182 C. INPUT ENU (GeV) = Neutrino Energy
35183 C. LLEP = neutrino type
35184 C. LTARG = nucleon target type 1=p, 2=n.
35185 C. JINT = 1:CC, 2::NC
35187 C. OUTPUT PPL(4) 4-monentum of final lepton
35188 C----------------------------------------------------
35189 PARAMETER (MAXLND=4000)
35190 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
35192 **sr - removed (not needed)
35193 C COMMON /CBAD/ LBAD, NBAD
35196 DIMENSION PI(3),PO(3)
35197 C REAL*4 AMD0, AMD, AMN(2), AML0(6), AML, AML2, AMDMIN
35198 DIMENSION AML0(6),AMN(2)
35199 DATA AMD0 /1.231/, GAMD /0.12/, DELD/0.169/, AMDMIN/1.084/
35200 DATA AMN /0.93827231, 0.93956563/
35201 DATA AML0 /2*0.51100E-03,2*0.105659, 2*1.777/
35203 c WRITE(6,*)' GEN_DEL',ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25
35205 C...Final lepton mass
35206 IF (JINT.EQ.1) THEN
35213 C...Particle labels (LUND)
35221 IF (LTARG .EQ. 1) THEN
35229 IS = -1 + 2*LLEP - 4*K1
35230 LNU = 2 - LLEP + 2*K1
35234 IF (JINT .EQ. 1) THEN ! CC interactions
35238 IF (LTARG .EQ. 1) THEN
35244 IF (LTARG .EQ. 1) THEN
35251 K(3,2) = 23 ! NC (Z0) interactions
35253 **sr 7.5.00: swop Delta's (bug), Delta+ for proton (LTARG=1),
35254 * Delta0 for neutron (LTARG=2)
35255 C IF (LTARG .EQ. 1) THEN
35260 IF (LTARG .EQ. 1) THEN
35268 C...4-momentum initial lepton
35274 C...4-momentum initial nucleon
35275 P(2,5) = AMN(LTARG)
35286 beta1=-p(2,1)/p(2,4)
35287 beta2=-p(2,2)/p(2,4)
35288 beta3=-p(2,3)/p(2,4)
35291 CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
35293 C print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
35295 phi11=atan(p(1,2)/p(1,3))
35300 CALL DT_TESTROT(PI,Po,PHI11,1)
35302 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35307 phi12=atan(p(1,1)/p(1,3))
35312 CALL DT_TESTROT(Pi,Po,PHI12,2)
35314 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35322 C...Generate the Mass of the Delta
35325 AMD=AMD0+0.5*GAMD*TAN((2.*R-1.)*ATAN(2.*DELD/GAMD))
35327 IF (NTRY .GT. 1000) THEN
35329 WRITE (LOUT,1001) NBAD, ENUU,AMD,AMDMIN,AMD0,GAMD,ET
35332 IF (AMD .LT. AMDMIN) GOTO 100
35333 ET = ((AMD+AML)**2 - AMN(LTARG)**2)/(2.*AMN(LTARG))
35334 IF (ENUU .LT. ET) GOTO 100
35336 C...Kinematical limits in Q**2
35337 S = AMN(LTARG)**2 + 2.*AMN(LTARG)*ENUU
35339 PSTAR = (S - AMN(LTARG)**2)/(2.*SQS)
35340 ELF = (S - AMD**2 + AML2)/(2.*SQS)
35341 PLF = SQRT(ELF**2 - AML2)
35342 Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)
35343 Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)
35344 IF (Q2MIN .LT. 0.) Q2MIN = 0.
35346 DSIGMAX = DT_DSIGMA_DELTA(LNU,-Q2MIN, S, AML, AMD)
35347 200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
35348 DSIG = DT_DSIGMA_DELTA(LNU,-Q2, S, AML, AMD)
35349 IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200
35351 C...Generate the kinematics of the final particles
35352 EISTAR = (S + AMN(LTARG)**2)/(2.*SQS)
35353 GAM = EISTAR/AMN(LTARG)
35355 CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF)
35356 EL = GAM*(ELF + BET*PLF*CTSTAR)
35357 PLZ = GAM*(PLF*CTSTAR + BET*ELF)
35358 PL = SQRT(EL**2 - AML2)
35359 PLT = SQRT(MAX(1.D-06,(PL*PL - PLZ*PLZ)))
35360 PHI = 6.28319*PYR(0)
35361 P(4,1) = PLT*COS(PHI)
35362 P(4,2) = PLT*SIN(PHI)
35367 C...4-momentum of Delta
35370 P(5,3) = ENUU-P(4,3)
35371 P(5,4) = ENUU+AMN(LTARG)-P(4,4)
35374 C...4-momentum of intermediate boson
35376 P(3,4) = P(1,4)-P(4,4)
35377 P(3,1) = P(1,1)-P(4,1)
35378 P(3,2) = P(1,2)-P(4,2)
35379 P(3,3) = P(1,3)-P(4,3)
35386 CALL DT_TESTROT(Pi,Po,PHI12,3)
35388 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35395 c********************************************
35401 CALL DT_TESTROT(Pi,Po,PHI11,4)
35403 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35409 c********************************************
35410 C transform back into Lab.
35412 CALL PYROBO(0,0,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
35414 C WRITE(6,*)' Lab fram ( fermi incl.) '
35419 1001 FORMAT(2X, 'DT_GEN_DELTA : event rejected ', I5, 6G10.3)
35422 *$ CREATE DT_DSIGMA_DELTA.FOR
35423 *COPY DT_DSIGMA_DELTA
35425 *===dsigma_delta=======================================================*
35427 DOUBLE PRECISION FUNCTION DT_DSIGMA_DELTA (LNU, QQ, S, AML, MD)
35429 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35432 C...Reaction nu + N -> lepton + Delta
35433 C. returns the cross section
35435 C. INPUT LNU = 1, 2 (neutrino-antineutrino)
35436 C. QQ = t (always negative) GeV**2
35437 C. S = (c.m energy)**2 GeV**2
35438 C. OUTPUT = 10**-38 cm+2/GeV**2
35439 C-----------------------------------------------------
35440 REAL*8 MN, MN2, MN4, MD,MD2, MD4
35442 DATA PI /3.1415926/
35444 GF = (1.1664 * 1.97)
35452 VQ = (MN2 - MD2 - QQ)/2.
35453 VPI = (MN2 + MD2 - QQ)/2.
35454 VK = (S + QQ - MN2 - AML2)/2.
35456 QK = (AML2 - QQ)/2.
35457 PIQ = (QQ + MN2 - MD2)/2.
35459 C3V = 2.07*SQRT(EXP(-6.3*Q)*(1.+9*Q))
35460 C3 = SQRT(3.)*C3V/MN
35461 C4 = -C3/MD ! attenzione al segno
35462 C5A = 1.18/(1.-QQ/0.4225)**2
35467 IF (LNU .EQ. 1) THEN
35468 ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
35469 . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
35470 . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
35471 . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
35472 ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
35473 . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
35474 . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
35475 . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
35476 . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
35477 . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ-
35478 . 4.*MN*C3*C5A*MD2*VK*QQ+4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
35479 . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
35480 . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
35481 . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
35482 . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK-MD*
35483 . C3*C5A*MD2*PIK*QQ+MD*C3*C5A*MD2*QK*PIQ-3.*MD*C3*C5A
35484 . *VK*VPI*QQ+MD*C3*C5A*VK*VQ*PIQ+3.*MD*C3*C5A*VPI*VQ*
35485 . QK-MD*C3*C5A*VQ**2*PIK+C4*C5A*MD2*VK*VPI*QQ+C4*C5A*
35486 . MD2*VK*VQ*PIQ-C4*C5A*MD2*VPI*VQ*QK-C4*C5A*MD2*VQ**2
35487 . *PIK-C4*C5A*MD4*PIK*QQ+C4*C5A*MD4*QK*PIQ-2.*MD2*VK
35488 . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
35489 . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
35490 . *C42-2.*MD2*VPI*QK**2*C32+ANS3
35492 ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
35493 . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
35494 . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
35495 . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
35496 ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
35497 . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
35498 . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
35499 . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
35500 . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
35501 . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ+
35502 . 4.*MN*C3*C5A*MD2*VK*QQ-4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
35503 . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
35504 . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
35505 . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
35506 . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK+MD*
35507 . C3*C5A*MD2*PIK*QQ-MD*C3*C5A*MD2*QK*PIQ+3.*MD*C3*C5A
35508 . *VK*VPI*QQ-MD*C3*C5A*VK*VQ*PIQ-3.*MD*C3*C5A*VPI*VQ*
35509 . QK+MD*C3*C5A*VQ**2*PIK-C4*C5A*MD2*VK*VPI*QQ-C4*C5A*
35510 . MD2*VK*VQ*PIQ+C4*C5A*MD2*VPI*VQ*QK+C4*C5A*MD2*VQ**2
35511 . *PIK+C4*C5A*MD4*PIK*QQ-C4*C5A*MD4*QK*PIQ-2.*MD2*VK
35512 . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
35513 . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
35514 . *C42-2.*MD2*VPI*QK**2*C32+ANS3
35518 P1CM = (S-MN2)/(2.*SQRT(S))
35519 DT_DSIGMA_DELTA = GF2/2. * ANS/(64.*PI*S*P1CM**2)
35524 *$ CREATE DT_QGAUS.FOR
35527 *===qgaus==============================================================*
35529 SUBROUTINE DT_QGAUS(A,B,SS,ENU,LTYP)
35531 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35534 DIMENSION X(5),W(5)
35535 DATA X/.1488743389D0,.4333953941D0,
35536 & .6794095682D0,.8650633666D0,.9739065285D0
35538 DATA W/.2955242247D0,.2692667193D0,
35539 & .2190863625D0,.1494513491D0,.0666713443D0
35546 SS=SS+W(J)*(DT_DSQEL_Q2(LTYP,ENU,XM+DX)+
35547 & DT_DSQEL_Q2(LTYP,ENU,XM-DX))
35553 *$ CREATE DT_DIQBRK.FOR
35556 *===diqbrk=============================================================*
35558 SUBROUTINE DT_DIQBRK
35560 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35565 PARAMETER (NMXHKK=200000)
35567 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
35568 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
35569 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
35571 * extended event history
35572 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
35573 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
35577 COMMON /DTEVNO/ NEVENT,ICASCA
35579 C IF(DT_RNDM(VV).LE.0.5D0)THEN
35580 C CALL GSQBS1(NHKK)
35581 C CALL GSQBS2(NHKK)
35582 C CALL USQBS1(NHKK)
35583 C CALL USQBS2(NHKK)
35584 C CALL GSABS1(NHKK)
35585 C CALL GSABS2(NHKK)
35586 C CALL USABS1(NHKK)
35587 C CALL USABS2(NHKK)
35589 C CALL GSQBS2(NHKK)
35590 C CALL GSQBS1(NHKK)
35591 C CALL USQBS2(NHKK)
35592 C CALL USQBS1(NHKK)
35593 C CALL GSABS2(NHKK)
35594 C CALL GSABS1(NHKK)
35595 C CALL USABS2(NHKK)
35596 C CALL USABS1(NHKK)
35599 IF(DT_RNDM(VV).LE.0.5D0) THEN
35622 *$ CREATE MUSQBS2.FOR
35626 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
35627 SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35628 * IP1,IP21,IP22,IPP1,IPP2,IPIP,ISQ,IGCOUN)
35630 C USQBS-2 diagram (split target diquark)
35632 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35635 PARAMETER ( LINP = 10 ,
35641 PARAMETER (NMXHKK=200000)
35643 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
35644 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
35645 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
35647 * extended event history
35648 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
35649 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
35652 * Lorentz-parameters of the current interaction
35653 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
35654 & UMO,PPCM,EPROJ,PPROJ
35656 * diquark-breaking mechanism
35657 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
35660 PARAMETER (NTMHKK= 300)
35661 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
35662 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
35665 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
35668 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
35669 COMMON /EVFLAG/ NUMEV
35671 C USQBS-2 diagram (split target diquark)
35674 C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
35675 C Input chain 2(NC2) sea-antiquark(NC2P)-sea-quark(NC2T)
35677 C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
35678 C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
35680 C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
35681 C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
35682 C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
35685 C Put new chains into COMMON /HKKTMP/
35690 C WRITE(LOUT,*)'MUSQBS2: IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
35694 C IF(NUMEV.EQ.-324)THEN
35695 C WRITE(LOUT,*)' MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
35696 C * 'IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN)',
35697 C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35698 C * IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN
35703 C determine x-values of NC1T diquark
35704 XDIQT=PHKK(4,NC1T)*2.D0/UMO
35705 XVQP=PHKK(4,NC1P)*2.D0/UMO
35707 C determine x-values of sea quark pair
35713 IF(ICOU.GE.500)THEN
35716 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 2234 ICOU. GT.500'
35720 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS2 call XSEAPA: UMO,XDIQT,XVQP ',
35725 C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
35726 IF (IPIP.EQ.1) THEN
35727 XQMAX = XDIQT/2.0D0
35728 XAQMAX = 2.D0*XVQP/3.0D0
35730 XQMAX = 2.D0*XVQP/3.0D0
35731 XAQMAX = XDIQT/2.0D0
35733 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
35735 C write(*,*) 'MUSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
35738 & WRITE(LOUT,*)'MUSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
35741 & WRITE(LOUT,*)'MUSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
35746 IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
35747 ELSEIF(IPIP.EQ.2)THEN
35748 IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
35751 WRITE(LOUT,'(A,4E12.4)')' MUSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
35752 & XDIQT,XVQP,XSQ,XSAQ
35755 C subtract xsq,xsaq from NC1T diquark and NC1P quark
35761 ELSEIF(IPIP.EQ.2)THEN
35766 & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
35768 C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
35773 IF(IVTHR.EQ.10)THEN
35776 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 3466 reject IVTHR 10'
35781 XVTHR=XVTHRO/(201-IVTHR)
35784 IF(XVTHR.GT.0.66D0*XDIQT)THEN
35787 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 380 XVTHR large',
35792 IF(DT_RNDM(V).LT.0.5D0)THEN
35793 XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
35796 XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
35800 WRITE(LOUT,'(A,2E12.4)')' MUSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
35803 C Prepare 4 momenta of new chains and chain ends
35805 C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
35806 C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
35809 C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
35810 C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
35811 C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
35813 C SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35814 C * IP1,IP21,IP22,IPP1,IPP2)
35821 ELSEIF(IPIP.EQ.2)THEN
35831 JDAHKT(1,1)=3+IIGLU1
35833 C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
35834 PHKT(1,1) =PHKK(1,NC2P)
35835 PHKT(2,1) =PHKK(2,NC2P)
35836 PHKT(3,1) =PHKK(3,NC2P)
35837 PHKT(4,1) =PHKK(4,NC2P)
35838 C PHKT(5,1) =PHKK(5,NC2P)
35839 XMIST =(PHKT(4,1)**2-
35840 * PHKT(3,1)**2-PHKT(2,1)**2-
35842 IF(XMIST.GT.0.D0)THEN
35843 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
35846 C WRITE(LOUT,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
35849 VHKT(1,1) =VHKK(1,NC2P)
35850 VHKT(2,1) =VHKK(2,NC2P)
35851 VHKT(3,1) =VHKK(3,NC2P)
35852 VHKT(4,1) =VHKK(4,NC2P)
35853 WHKT(1,1) =WHKK(1,NC2P)
35854 WHKT(2,1) =WHKK(2,NC2P)
35855 WHKT(3,1) =WHKK(3,NC2P)
35856 WHKT(4,1) =WHKK(4,NC2P)
35857 C Add here IIGLU1 gluons to this chaina
35862 IF(IIGLU1.GE.1)THEN
35864 DO 61 IIG=2,2+IIGLU1-1
35866 IDHKT(IIG) =IDHKK(KKG)
35870 JDAHKT(1,IIG)=3+IIGLU1
35872 PHKT(1,IIG)=PHKK(1,KKG)
35873 PG1=PG1+ PHKT(1,IIG)
35874 PHKT(2,IIG)=PHKK(2,KKG)
35875 PG2=PG2+ PHKT(2,IIG)
35876 PHKT(3,IIG)=PHKK(3,KKG)
35877 PG3=PG3+ PHKT(3,IIG)
35878 PHKT(4,IIG)=PHKK(4,KKG)
35879 PG4=PG4+ PHKT(4,IIG)
35880 PHKT(5,IIG)=PHKK(5,KKG)
35881 VHKT(1,IIG) =VHKK(1,KKG)
35882 VHKT(2,IIG) =VHKK(2,KKG)
35883 VHKT(3,IIG) =VHKK(3,KKG)
35884 VHKT(4,IIG) =VHKK(4,KKG)
35885 WHKT(1,IIG) =WHKK(1,KKG)
35886 WHKT(2,IIG) =WHKK(2,KKG)
35887 WHKT(3,IIG) =WHKK(3,KKG)
35888 WHKT(4,IIG) =WHKK(4,KKG)
35891 IDHKT(2+IIGLU1) =IP21
35892 ISTHKT(2+IIGLU1) =952
35893 JMOHKT(1,2+IIGLU1)=NC1T
35894 JMOHKT(2,2+IIGLU1)=0
35895 JDAHKT(1,2+IIGLU1)=3+IIGLU1
35896 JDAHKT(2,2+IIGLU1)=0
35897 PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
35898 PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
35899 PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
35900 PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
35901 C PHKT(5,2) =PHKK(5,NC1T)
35902 XMIST =(PHKT(4,2+IIGLU1)**2-
35903 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
35904 *PHKT(1,2+IIGLU1)**2)
35905 IF(XMIST.GT.0.D0)THEN
35906 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
35907 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
35908 *PHKT(1,2+IIGLU1)**2)
35910 C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
35911 PHKT(5,5+IIGLU1)=0.D0
35913 VHKT(1,2+IIGLU1) =VHKK(1,NC1T)
35914 VHKT(2,2+IIGLU1) =VHKK(2,NC1T)
35915 VHKT(3,2+IIGLU1) =VHKK(3,NC1T)
35916 VHKT(4,2+IIGLU1) =VHKK(4,NC1T)
35917 WHKT(1,2+IIGLU1) =WHKK(1,NC1T)
35918 WHKT(2,2+IIGLU1) =WHKK(2,NC1T)
35919 WHKT(3,2+IIGLU1) =WHKK(3,NC1T)
35920 WHKT(4,2+IIGLU1) =WHKK(4,NC1T)
35921 IDHKT(3+IIGLU1) =88888
35922 ISTHKT(3+IIGLU1) =95
35923 JMOHKT(1,3+IIGLU1)=1
35924 JMOHKT(2,3+IIGLU1)=2+IIGLU1
35925 JDAHKT(1,3+IIGLU1)=0
35926 JDAHKT(2,3+IIGLU1)=0
35927 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
35928 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
35929 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
35930 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
35932 * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
35933 * -PHKT(3,3+IIGLU1)**2)
35934 IF(XMIST.GT.0.D0)THEN
35936 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
35937 * -PHKT(3,3+IIGLU1)**2)
35939 C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
35940 PHKT(5,5+IIGLU1)=0.D0
35943 C IF(NUMEV.EQ.-324)THEN
35944 C WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
35946 C *JDAHKT(2,1),(PHKT(III,1),III=1,5)
35947 DO 71 IIG=2,2+IIGLU1-1
35948 C WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
35949 C & JMOHKT(1,IIG),JMOHKT(2,IIG),
35951 C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
35953 C WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
35954 C * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
35955 C *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
35956 C WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
35957 C * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
35958 C *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
35962 IF(IPP1.LE.-3.OR.IP21.GE.3)CHAMAL=CHAM3
35963 ELSEIF(IPIP.EQ.2)THEN
35964 IF(IPP1.GE.3.OR.IP21.LE.-3)CHAMAL=CHAM3
35966 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
35970 C WRITE(LOUT,*)' MUSQBS1 jump back from chain 3'
35973 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
35974 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
35975 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
35976 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
35977 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
35978 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
35979 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
35980 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
35982 IDHKT(4+IIGLU1) =-(ISAQ1-6)
35983 ELSEIF(IPIP.EQ.2)THEN
35984 IDHKT(4+IIGLU1) =ISAQ1
35986 ISTHKT(4+IIGLU1) =951
35987 JMOHKT(1,4+IIGLU1)=NC1P
35988 JMOHKT(2,4+IIGLU1)=0
35989 JDAHKT(1,4+IIGLU1)=6+IIGLU1
35990 JDAHKT(2,4+IIGLU1)=0
35991 C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
35992 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
35993 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
35994 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
35995 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
35996 C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
35997 XMIST =(PHKT(4,4+IIGLU1)**2-
35998 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
35999 *PHKT(1,4+IIGLU1)**2)
36000 IF(XMIST.GT.0.D0)THEN
36001 PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2-
36002 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
36003 *PHKT(1,4+IIGLU1)**2)
36005 C WRITE(LOUT,*)'MUSQBS2 parton 4 mass square LT.0 ',XMIST
36006 PHKT(5,4+IIGLU1)=0.D0
36008 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
36009 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
36010 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
36011 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
36012 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
36013 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
36014 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
36015 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
36016 IDHKT(5+IIGLU1) =IP22
36017 ISTHKT(5+IIGLU1) =952
36018 JMOHKT(1,5+IIGLU1)=NC1T
36019 JMOHKT(2,5+IIGLU1)=0
36020 JDAHKT(1,5+IIGLU1)=6+IIGLU1
36021 JDAHKT(2,5+IIGLU1)=0
36022 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
36023 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
36024 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
36025 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
36026 C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
36027 XMIST =(PHKT(4,5+IIGLU1)**2-
36028 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36029 *PHKT(1,5+IIGLU1)**2)
36030 IF(XMIST.GT.0.D0)THEN
36031 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
36032 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36033 *PHKT(1,5+IIGLU1)**2)
36035 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36036 PHKT(5,5+IIGLU1)=0.D0
36038 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
36039 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
36040 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
36041 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
36042 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
36043 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
36044 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
36045 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
36046 IDHKT(6+IIGLU1) =88888
36047 ISTHKT(6+IIGLU1) =95
36048 JMOHKT(1,6+IIGLU1)=4+IIGLU1
36049 JMOHKT(2,6+IIGLU1)=5+IIGLU1
36050 JDAHKT(1,6+IIGLU1)=0
36051 JDAHKT(2,6+IIGLU1)=0
36052 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
36053 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
36054 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
36055 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
36057 * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
36058 * -PHKT(3,6+IIGLU1)**2)
36059 IF(XMIST.GT.0.D0)THEN
36061 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
36062 * -PHKT(3,6+IIGLU1)**2)
36064 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36065 PHKT(5,5+IIGLU1)=0.D0
36067 C IF(IPIP.GE.2)THEN
36068 C IF(NUMEV.EQ.-324)THEN
36069 C WRITE(6,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
36070 C * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
36071 C *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
36072 C WRITE(6,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
36073 C * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
36074 C *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
36075 C WRITE(6,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
36076 C * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
36077 C *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
36081 IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
36082 ELSEIF(IPIP.EQ.2)THEN
36083 IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
36085 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
36089 C WRITE(6,*)' MUSQBS1 jump back from chain 6',
36090 C * CHAMAL,PHKT(5,6+IIGLU1)
36093 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
36094 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
36095 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
36096 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
36097 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
36098 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
36099 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
36100 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
36101 C IDHKT(7) =1000*IPP1+100*ISQ+1
36102 IDHKT(7+IIGLU1) =IP1
36103 ISTHKT(7+IIGLU1) =951
36104 JMOHKT(1,7+IIGLU1)=NC1P
36105 JMOHKT(2,7+IIGLU1)=0
36107 C JDAHKT(1,7+IIGLU1)=9+IIGLU1
36108 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
36110 JDAHKT(2,7+IIGLU1)=0
36111 PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
36112 PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
36113 PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
36114 PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
36115 C PHKT(5,7+IIGLU1) =PHKK(5,NC1P)
36116 XMIST =(PHKT(4,7+IIGLU1)**2-
36117 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
36118 *PHKT(1,7+IIGLU1)**2)
36119 IF(XMIST.GT.0.D0)THEN
36120 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
36121 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
36122 *PHKT(1,7+IIGLU1)**2)
36124 C WRITE(6,*)'MUSQBS2 parton 7 mass square LT.0 ',XMIST
36125 PHKT(5,7+IIGLU1)=0.D0
36127 VHKT(1,7+IIGLU1) =VHKK(1,NC1P)
36128 VHKT(2,7+IIGLU1) =VHKK(2,NC1P)
36129 VHKT(3,7+IIGLU1) =VHKK(3,NC1P)
36130 VHKT(4,7+IIGLU1) =VHKK(4,NC1P)
36131 WHKT(1,7+IIGLU1) =WHKK(1,NC1P)
36132 WHKT(2,7+IIGLU1) =WHKK(2,NC1P)
36133 WHKT(3,7+IIGLU1) =WHKK(3,NC1P)
36134 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
36135 C Insert here the IIGLU2 gluons
36140 IF(IIGLU2.GE.1)THEN
36142 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36143 KKG=JJG+IIG-7-IIGLU1
36144 IDHKT(IIG) =IDHKK(KKG)
36148 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
36150 PHKT(1,IIG)=PHKK(1,KKG)
36151 PG1=PG1+ PHKT(1,IIG)
36152 PHKT(2,IIG)=PHKK(2,KKG)
36153 PG2=PG2+ PHKT(2,IIG)
36154 PHKT(3,IIG)=PHKK(3,KKG)
36155 PG3=PG3+ PHKT(3,IIG)
36156 PHKT(4,IIG)=PHKK(4,KKG)
36157 PG4=PG4+ PHKT(4,IIG)
36158 PHKT(5,IIG)=PHKK(5,KKG)
36159 VHKT(1,IIG) =VHKK(1,KKG)
36160 VHKT(2,IIG) =VHKK(2,KKG)
36161 VHKT(3,IIG) =VHKK(3,KKG)
36162 VHKT(4,IIG) =VHKK(4,KKG)
36163 WHKT(1,IIG) =WHKK(1,KKG)
36164 WHKT(2,IIG) =WHKK(2,KKG)
36165 WHKT(3,IIG) =WHKK(3,KKG)
36166 WHKT(4,IIG) =WHKK(4,KKG)
36170 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3
36171 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
36172 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
36173 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
36174 ELSEIF(IPIP.EQ.2)THEN
36175 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3
36176 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
36177 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
36178 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
36180 ISTHKT(8+IIGLU1+IIGLU2) =952
36181 JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
36182 JMOHKT(2,8+IIGLU1+IIGLU2)=0
36183 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
36184 JDAHKT(2,8+IIGLU1+IIGLU2)=0
36185 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC2T)+
36186 * PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
36187 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC2T)+
36188 * PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
36189 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC2T)+
36190 * PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
36191 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC2T)+
36192 * PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
36193 C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
36194 C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
36195 IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
36197 C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
36198 C * ,PHKT(4,8+IIGLU1+IIGLU2), PHKK(4,NC2T),NC2T
36203 C PHKT(5,8) =PHKK(5,NC2T)
36204 XMIST =(PHKT(4,8+IIGLU1+IIGLU2)**2-
36205 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36206 *PHKT(1,8+IIGLU1+IIGLU2)**2)
36207 IF(XMIST.GT.0.D0)THEN
36208 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
36209 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36210 *PHKT(1,8+IIGLU1+IIGLU2)**2)
36212 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36213 PHKT(5,5+IIGLU1)=0.D0
36215 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T)
36216 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T)
36217 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T)
36218 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T)
36219 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T)
36220 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T)
36221 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T)
36222 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T)
36223 IDHKT(9+IIGLU1+IIGLU2) =88888
36224 ISTHKT(9+IIGLU1+IIGLU2) =95
36225 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
36226 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
36227 JDAHKT(1,9+IIGLU1+IIGLU2)=0
36228 JDAHKT(2,9+IIGLU1+IIGLU2)=0
36230 C PHKT(1,9+IIGLU1+IIGLU2)
36231 C * =PHKT(1,7+IIGLU1+IIGLU2)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
36232 C PHKT(2,9+IIGLU1+IIGLU2)
36233 C * =PHKT(2,7+IIGLU1+IIGLU2)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
36234 C PHKT(3,9+IIGLU1+IIGLU2)
36235 C * =PHKT(3,7+IIGLU1+IIGLU2)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
36236 C PHKT(4,9+IIGLU1+IIGLU2)
36237 C * =PHKT(4,7+IIGLU1+IIGLU2)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
36238 PHKT(1,9+IIGLU1+IIGLU2)
36239 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
36240 PHKT(2,9+IIGLU1+IIGLU2)
36241 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
36242 PHKT(3,9+IIGLU1+IIGLU2)
36243 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
36244 PHKT(4,9+IIGLU1+IIGLU2)
36245 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
36248 * =(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
36249 * -PHKT(2,9+IIGLU1+IIGLU2)**2
36250 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
36251 IF(XMIST.GT.0.D0)THEN
36252 PHKT(5,9+IIGLU1+IIGLU2)
36253 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
36254 * -PHKT(2,9+IIGLU1+IIGLU2)**2
36255 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
36257 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36258 PHKT(5,5+IIGLU1)=0.D0
36261 C IF(NUMEV.EQ.-324)THEN
36262 C WRITE(6,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
36263 C * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
36264 C *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
36265 C DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36266 C WRITE(6,*)IIG,ISTHKT(IIG),IDHKT(IIG),JMOHKT(1,IIG),JMOHKT(2,IIG),
36268 C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36270 C WRITE(6,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
36271 C * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
36272 C *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
36273 C *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
36274 C WRITE(6,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
36275 C * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
36276 C *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
36277 C *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
36281 IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
36282 ELSEIF(IPIP.EQ.2)THEN
36283 IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
36285 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
36289 C WRITE(6,*)' MUSQBS1 jump back from chain 9',
36290 C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
36293 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
36294 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
36295 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
36296 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
36297 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
36298 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
36299 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
36300 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
36303 IGCOUN=9+IIGLU1+IIGLU2
36307 *$ CREATE MGSQBS2.FOR
36311 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
36312 SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36313 * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,ISQ,IGCOUN)
36315 C GSQBS-2 diagram (split target diquark)
36317 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36320 PARAMETER ( LINP = 10 ,
36326 PARAMETER (NMXHKK=200000)
36328 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36329 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36330 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36332 * extended event history
36333 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36334 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36337 * Lorentz-parameters of the current interaction
36338 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
36339 & UMO,PPCM,EPROJ,PPROJ
36341 * diquark-breaking mechanism
36342 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
36345 PARAMETER (NTMHKK= 300)
36346 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
36347 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
36351 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
36354 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
36356 C GSQBS-2 diagram (split target diquark)
36359 C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
36360 C Input chain 2(NC2) valence-diquark(NC2P)-sea-quark(NC2T)
36362 C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
36363 C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
36365 C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
36366 C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36367 C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
36371 C Put new chains into COMMON /HKKTMP/
36376 C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
36379 C IF(IPIP.EQ.2)THEN
36380 C WRITE(6,*)' MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
36381 C * 'IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN)',
36382 C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36383 C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN
36388 C determine x-values of NC1T diquark
36389 XDIQT=PHKK(4,NC1T)*2.D0/UMO
36390 XVQP=PHKK(4,NC1P)*2.D0/UMO
36392 C determine x-values of sea quark pair
36398 IF(ICOU.GE.500)THEN
36402 & WRITE(LOUT,*)' MGSQBS2 Rejection 2234 ICOU. GT.500'
36407 & WRITE(LOUT,*)'MGSQBS2 call XSEAPA: UMO,XDIQT,XVQP ',
36412 C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
36413 IF (IPIP.EQ.1) THEN
36414 XQMAX = XDIQT/2.0D0
36415 XAQMAX = 2.D0*XVQP/3.0D0
36417 XQMAX = 2.D0*XVQP/3.0D0
36418 XAQMAX = XDIQT/2.0D0
36420 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
36422 C write(*,*) 'MGSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
36425 & WRITE(LOUT,*)'MGSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
36428 & WRITE(LOUT,*)'MGSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
36433 IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
36434 ELSEIF(IPIP.EQ.2)THEN
36435 IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
36438 WRITE(LOUT,'(A,4E12.4)')' MGSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
36439 & XDIQT,XVQP,XSQ,XSAQ
36442 C subtract xsq,xsaq from NC1T diquark and NC1P quark
36448 ELSEIF(IPIP.EQ.2)THEN
36453 & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
36455 C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
36460 IF(IVTHR.EQ.10)THEN
36463 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 3466 reject IVTHR 10'
36468 XVTHR=XVTHRO/(201-IVTHR)
36471 IF(XVTHR.GT.0.66D0*XDIQT)THEN
36474 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 Rejection 380 XVTHR large',
36479 IF(DT_RNDM(V).LT.0.5D0)THEN
36480 XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
36483 XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
36487 WRITE(LOUT,'(A,2E12.4)')' MGSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
36490 C Prepare 4 momenta of new chains and chain ends
36492 C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
36493 C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
36496 C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
36497 C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36498 C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
36500 C SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36501 C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IGCOUN)
36508 ELSEIF(IPIP.EQ.2)THEN
36515 C IDHKT(1) =1000*IPP11+100*IPP12+1
36520 IDHKT(4+IIGLU1) =-(ISAQ1-6)
36521 ELSEIF(IPIP.EQ.2)THEN
36522 IDHKT(4+IIGLU1) =ISAQ1
36524 ISTHKT(4+IIGLU1) =961
36525 JMOHKT(1,4+IIGLU1)=NC1P
36526 JMOHKT(2,4+IIGLU1)=0
36527 JDAHKT(1,4+IIGLU1)=6+IIGLU1
36528 JDAHKT(2,4+IIGLU1)=0
36529 C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36530 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
36531 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
36532 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
36533 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
36534 C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
36535 XXMIST=(PHKT(4,4+IIGLU1)**2-
36536 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
36537 *PHKT(1,4+IIGLU1)**2)
36538 IF(XXMIST.GT.0.D0)THEN
36539 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
36541 WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
36543 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
36545 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
36546 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
36547 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
36548 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
36549 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
36550 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
36551 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
36552 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
36553 IDHKT(5+IIGLU1) =IP22
36554 ISTHKT(5+IIGLU1) =962
36555 JMOHKT(1,5+IIGLU1)=NC1T
36556 JMOHKT(2,5+IIGLU1)=0
36557 JDAHKT(1,5+IIGLU1)=6+IIGLU1
36558 JDAHKT(2,5+IIGLU1)=0
36559 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
36560 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
36561 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
36562 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
36563 C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
36564 XXMIST=(PHKT(4,5+IIGLU1)**2-
36565 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36566 *PHKT(1,5+IIGLU1)**2)
36567 IF(XXMIST.GT.0.D0)THEN
36568 PHKT(5,5+IIGLU1) =SQRT(XXMIST)
36570 WRITE(LOUT,*)' MGSQBS2 XXMIST', XXMIST
36572 PHKT(5,5+IIGLU1) =SQRT(XXMIST)
36574 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
36575 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
36576 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
36577 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
36578 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
36579 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
36580 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
36581 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
36582 IDHKT(6+IIGLU1) =88888
36583 ISTHKT(6+IIGLU1) =96
36584 JMOHKT(1,6+IIGLU1)=4+IIGLU1
36585 JMOHKT(2,6+IIGLU1)=5+IIGLU1
36586 JDAHKT(1,6+IIGLU1)=0
36587 JDAHKT(2,6+IIGLU1)=0
36588 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
36589 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
36590 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
36591 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
36593 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
36594 * -PHKT(3,6+IIGLU1)**2)
36597 IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
36598 ELSEIF(IPIP.EQ.2)THEN
36599 IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
36601 C---------------------------------------------------
36602 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
36603 IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
36604 C we drop chain 6 and give the energy to chain 3
36605 IDHKT(6+IIGLU1)=22888
36607 C WRITE(6,*)' drop chain 6 xgive=1'
36609 ELSEIF(IDHKT(4+IIGLU1).EQ.-IP21)THEN
36610 C we drop chain 6 and give the energy to chain 3
36611 C and change KK11 to IDHKT(5)
36612 IDHKT(6+IIGLU1)=22888
36614 C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(5)'
36615 KK11=IDHKT(5+IIGLU1)
36617 ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP11)THEN
36618 C we drop chain 6 and give the energy to chain 3
36619 C and change KK21 to IDHKT(5+IIGLU1)
36620 C IDHKT(1) =1000*IPP11+100*IPP12+1
36621 IDHKT(6+IIGLU1)=22888
36623 C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(5+IIGLU1)'
36624 KK21=IDHKT(5+IIGLU1)
36626 ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP12)THEN
36627 C we drop chain 6 and give the energy to chain 3
36628 C and change KK22 to IDHKT(5)
36629 C IDHKT(1) =1000*IPP11+100*IPP12+1
36630 IDHKT(6+IIGLU1)=22888
36632 C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(5+IIGLU1)'
36633 KK22=IDHKT(5+IIGLU1)
36642 C---------------------------------------------------
36644 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
36645 * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
36646 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
36647 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
36648 * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
36649 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
36650 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
36651 * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
36652 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
36654 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
36655 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
36656 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
36657 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
36658 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
36659 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
36660 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
36661 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
36662 C IDHKT(1) =1000*IPP11+100*IPP12+1
36664 IDHKT(1) =1000*KK21+100*KK22+3
36665 IF(IDHKT(1).EQ.1203)IDHKT(1)=2103
36666 IF(IDHKT(1).EQ.1303)IDHKT(1)=3103
36667 IF(IDHKT(1).EQ.2303)IDHKT(1)=3203
36668 ELSEIF(IPIP.EQ.2)THEN
36669 IDHKT(1) =1000*KK21+100*KK22-3
36670 IF(IDHKT(1).EQ.-1203)IDHKT(1)=-2103
36671 IF(IDHKT(1).EQ.-1303)IDHKT(1)=-3103
36672 IF(IDHKT(1).EQ.-2303)IDHKT(1)=-3203
36677 JDAHKT(1,1)=3+IIGLU1
36679 C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
36680 PHKT(1,1) =PHKK(1,NC2P)
36681 *+XGIVE*PHKT(1,4+IIGLU1)
36682 PHKT(2,1) =PHKK(2,NC2P)
36683 *+XGIVE*PHKT(2,4+IIGLU1)
36684 PHKT(3,1) =PHKK(3,NC2P)
36685 *+XGIVE*PHKT(3,4+IIGLU1)
36686 PHKT(4,1) =PHKK(4,NC2P)
36687 *+XGIVE*PHKT(4,4+IIGLU1)
36688 C PHKT(5,1) =PHKK(5,NC2P)
36689 XXMIST=PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
36691 IF(XXMIST.GT.0.D0)THEN
36692 PHKT(5,1) =SQRT(XXMIST)
36694 WRITE(LOUT,*)'MGSQBS2',XXMIST
36696 PHKT(5,1) =SQRT(XXMIST)
36698 VHKT(1,1) =VHKK(1,NC2P)
36699 VHKT(2,1) =VHKK(2,NC2P)
36700 VHKT(3,1) =VHKK(3,NC2P)
36701 VHKT(4,1) =VHKK(4,NC2P)
36702 WHKT(1,1) =WHKK(1,NC2P)
36703 WHKT(2,1) =WHKK(2,NC2P)
36704 WHKT(3,1) =WHKK(3,NC2P)
36705 WHKT(4,1) =WHKK(4,NC2P)
36706 C Add here IIGLU1 gluons to this chaina
36711 IF(IIGLU1.GE.1)THEN
36713 DO 61 IIG=2,2+IIGLU1-1
36715 IDHKT(IIG) =IDHKK(KKG)
36719 JDAHKT(1,IIG)=3+IIGLU1
36721 PHKT(1,IIG)=PHKK(1,KKG)
36722 PG1=PG1+ PHKT(1,IIG)
36723 PHKT(2,IIG)=PHKK(2,KKG)
36724 PG2=PG2+ PHKT(2,IIG)
36725 PHKT(3,IIG)=PHKK(3,KKG)
36726 PG3=PG3+ PHKT(3,IIG)
36727 PHKT(4,IIG)=PHKK(4,KKG)
36728 PG4=PG4+ PHKT(4,IIG)
36729 PHKT(5,IIG)=PHKK(5,KKG)
36730 VHKT(1,IIG) =VHKK(1,KKG)
36731 VHKT(2,IIG) =VHKK(2,KKG)
36732 VHKT(3,IIG) =VHKK(3,KKG)
36733 VHKT(4,IIG) =VHKK(4,KKG)
36734 WHKT(1,IIG) =WHKK(1,KKG)
36735 WHKT(2,IIG) =WHKK(2,KKG)
36736 WHKT(3,IIG) =WHKK(3,KKG)
36737 WHKT(4,IIG) =WHKK(4,KKG)
36741 IDHKT(2+IIGLU1) =KK11
36742 ISTHKT(2+IIGLU1) =962
36743 JMOHKT(1,2+IIGLU1)=NC1T
36744 JMOHKT(2,2+IIGLU1)=0
36745 JDAHKT(1,2+IIGLU1)=3+IIGLU1
36746 JDAHKT(2,2+IIGLU1)=0
36747 PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
36748 C * +0.5D0*PHKK(1,NC2T)
36749 *+XGIVE*PHKT(1,5+IIGLU1)
36750 PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
36751 C *+0.5D0*PHKK(2,NC2T)
36752 *+XGIVE*PHKT(2,5+IIGLU1)
36753 PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
36754 C *+0.5D0*PHKK(3,NC2T)
36755 *+XGIVE*PHKT(3,5+IIGLU1)
36756 PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
36757 C *+0.5D0*PHKK(4,NC2T)
36758 *+XGIVE*PHKT(4,5+IIGLU1)
36759 C PHKT(5,2) =PHKK(5,NC1T)
36760 XXMIST=(PHKT(4,2+IIGLU1)**2-
36761 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
36762 *PHKT(1,2+IIGLU1)**2)
36763 IF(XXMIST.GT.0.D0)THEN
36764 PHKT(5,2+IIGLU1) =SQRT(XXMIST)
36766 WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
36768 PHKT(5,2+IIGLU1) =SQRT(XXMIST)
36770 VHKT(1,2+IIGLU1) =VHKK(1,NC1T)
36771 VHKT(2,2+IIGLU1) =VHKK(2,NC1T)
36772 VHKT(3,2+IIGLU1) =VHKK(3,NC1T)
36773 VHKT(4,2+IIGLU1) =VHKK(4,NC1T)
36774 WHKT(1,2+IIGLU1) =WHKK(1,NC1T)
36775 WHKT(2,2+IIGLU1) =WHKK(2,NC1T)
36776 WHKT(3,2+IIGLU1) =WHKK(3,NC1T)
36777 WHKT(4,2+IIGLU1) =WHKK(4,NC1T)
36778 IDHKT(3+IIGLU1) =88888
36779 ISTHKT(3+IIGLU1) =96
36780 JMOHKT(1,3+IIGLU1)=1
36781 JMOHKT(2,3+IIGLU1)=2+IIGLU1
36782 JDAHKT(1,3+IIGLU1)=0
36783 JDAHKT(2,3+IIGLU1)=0
36784 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
36785 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
36786 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
36787 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
36789 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
36790 * -PHKT(3,3+IIGLU1)**2)
36792 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
36794 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
36795 DO 71 IIG=2,2+IIGLU1-1
36796 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
36797 & JMOHKT(1,IIG),JMOHKT(2,IIG),
36799 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36801 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
36802 * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
36803 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
36804 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
36805 * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
36806 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
36810 IF(IPP11.GE.3.OR.IPP12.GE.3.OR.IP21.GE.3)CHAMAL=CHAB3
36811 ELSEIF(IPIP.EQ.2)THEN
36812 IF(IPP11.LE.-3.OR.IPP12.LE.-3.OR.IP21.LE.-3)CHAMAL=CHAB3
36814 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
36820 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
36821 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
36822 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
36823 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
36824 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
36825 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
36826 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
36827 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
36828 C IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+1
36829 IDHKT(7+IIGLU1) =IP1
36830 ISTHKT(7+IIGLU1) =961
36831 JMOHKT(1,7+IIGLU1)=NC1P
36832 JMOHKT(2,7+IIGLU1)=0
36833 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
36834 JDAHKT(2,7+IIGLU1)=0
36835 PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
36836 PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
36837 PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
36838 PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
36839 C PHKT(5,7+IIGLU1) =PHKK(5,NC1P)
36840 XXMIST=(PHKT(4,7+IIGLU1)**2-
36841 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
36842 *PHKT(1,7+IIGLU1)**2)
36843 IF(XXMIST.GT.0.D0)THEN
36844 PHKT(5,7+IIGLU1) =SQRT(XXMIST)
36846 WRITE(LOUT,*)' MGSQBS2, XXMIST',XXMIST
36848 PHKT(5,7+IIGLU1) =SQRT(XXMIST)
36850 VHKT(1,7+IIGLU1) =VHKK(1,NC1P)
36851 VHKT(2,7+IIGLU1) =VHKK(2,NC1P)
36852 VHKT(3,7+IIGLU1) =VHKK(3,NC1P)
36853 VHKT(4,7+IIGLU1) =VHKK(4,NC1P)
36854 WHKT(1,7+IIGLU1) =WHKK(1,NC1P)
36855 WHKT(2,7+IIGLU1) =WHKK(2,NC1P)
36856 WHKT(3,7+IIGLU1) =WHKK(3,NC1P)
36857 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
36858 C IDHKT(7) =1000*IPP1+100*ISQ+1
36859 C Insert here the IIGLU2 gluons
36864 IF(IIGLU2.GE.1)THEN
36866 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36867 KKG=JJG+IIG-7-IIGLU1
36868 IDHKT(IIG) =IDHKK(KKG)
36872 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
36874 PHKT(1,IIG)=PHKK(1,KKG)
36875 PG1=PG1+ PHKT(1,IIG)
36876 PHKT(2,IIG)=PHKK(2,KKG)
36877 PG2=PG2+ PHKT(2,IIG)
36878 PHKT(3,IIG)=PHKK(3,KKG)
36879 PG3=PG3+ PHKT(3,IIG)
36880 PHKT(4,IIG)=PHKK(4,KKG)
36881 PG4=PG4+ PHKT(4,IIG)
36882 PHKT(5,IIG)=PHKK(5,KKG)
36883 VHKT(1,IIG) =VHKK(1,KKG)
36884 VHKT(2,IIG) =VHKK(2,KKG)
36885 VHKT(3,IIG) =VHKK(3,KKG)
36886 VHKT(4,IIG) =VHKK(4,KKG)
36887 WHKT(1,IIG) =WHKK(1,KKG)
36888 WHKT(2,IIG) =WHKK(2,KKG)
36889 WHKT(3,IIG) =WHKK(3,KKG)
36890 WHKT(4,IIG) =WHKK(4,KKG)
36894 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3
36895 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
36896 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
36897 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
36898 ELSEIF(IPIP.EQ.2)THEN
36900 C IDHKT(8) =1000*IPP2+100*(-ISQ1+6)-3
36901 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3
36903 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
36904 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
36905 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
36907 ISTHKT(8+IIGLU1+IIGLU2) =962
36908 JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
36909 JMOHKT(2,8+IIGLU1+IIGLU2)=0
36910 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
36911 JDAHKT(2,8+IIGLU1+IIGLU2)=0
36912 C PHKT(1,8) =0.5D0*PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ/(XDIQT+XSQ)
36913 C PHKT(2,8) =0.5D0*PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ/(XDIQT+XSQ)
36914 C PHKT(3,8) =0.5D0*PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ/(XDIQT+XSQ)
36915 C PHKT(4,8) =0.5D0*PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ/(XDIQT+XSQ)
36916 PHKT(1,8+IIGLU1+IIGLU2) =
36917 * PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
36918 PHKT(2,8+IIGLU1+IIGLU2) =
36919 * PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
36920 PHKT(3,8+IIGLU1+IIGLU2) =
36921 * PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
36922 PHKT(4,8+IIGLU1+IIGLU2) =
36923 * PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
36924 C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
36925 C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
36926 IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
36928 C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
36933 C PHKT(5,8) =PHKK(5,NC2T)
36934 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
36935 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36936 *PHKT(1,8+IIGLU1+IIGLU2)**2)
36937 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T)
36938 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T)
36939 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T)
36940 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T)
36941 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T)
36942 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T)
36943 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T)
36944 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T)
36945 IDHKT(9+IIGLU1+IIGLU2) =88888
36946 ISTHKT(9+IIGLU1+IIGLU2) =96
36947 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
36948 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
36949 JDAHKT(1,9+IIGLU1+IIGLU2)=0
36950 JDAHKT(2,9+IIGLU1+IIGLU2)=0
36951 PHKT(1,9+IIGLU1+IIGLU2)
36952 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
36953 PHKT(2,9+IIGLU1+IIGLU2)
36954 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
36955 PHKT(3,9+IIGLU1+IIGLU2)
36956 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
36957 PHKT(4,9+IIGLU1+IIGLU2)
36958 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
36959 PHKT(5,9+IIGLU1+IIGLU2)
36960 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
36961 * PHKT(2,9+IIGLU1+IIGLU2)**2
36962 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
36964 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
36965 * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
36966 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
36967 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36968 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
36969 & JMOHKT(1,IIG),JMOHKT(2,IIG),
36971 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36973 WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
36974 * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
36975 *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
36976 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
36977 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
36978 * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
36979 *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
36980 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
36984 IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
36985 ELSEIF(IPIP.EQ.2)THEN
36986 IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
36988 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
36994 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
36995 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
36996 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
36997 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
36998 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
36999 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
37000 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
37001 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
37004 IGCOUN=9+IIGLU1+IIGLU2
37008 *$ CREATE MUSQBS1.FOR
37012 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
37013 SUBROUTINE MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37014 * IP11,IP12,IP2,IPP1,IPP2,IPIP,ISQ,IGCOUN)
37016 C USQBS-1 diagram (split projectile diquark)
37018 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37021 PARAMETER ( LINP = 10 ,
37027 PARAMETER (NMXHKK=200000)
37029 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
37030 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
37031 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
37033 * extended event history
37034 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
37035 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37038 * Lorentz-parameters of the current interaction
37039 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37040 & UMO,PPCM,EPROJ,PPROJ
37042 * diquark-breaking mechanism
37043 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37046 PARAMETER (NTMHKK= 300)
37047 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37048 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37051 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37054 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37055 COMMON /EVFLAG/ NUMEV
37057 C USQBS-1 diagram (split projectile diquark)
37059 C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
37060 C Input chain 2(NC2) sea-quark(NC2P)-sea-antiquark(NC2T)
37062 C Create quark(qsP)-antiquark(aqsT) pair, energy from NC1P and NC1T
37063 C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37065 C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
37066 C 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
37067 C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37069 C Put new chains into COMMON /HKKTMP/
37074 C WRITE(6,*)'MUSQBS1: IIGLU1,IIGLU2,IPIP ',IIGLU1,IIGLU2,IPIP
37078 C IF(NUMEV.EQ.-324)THEN
37079 WRITE(LOUT,*)' MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37080 * ' IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN)',
37081 *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37082 * IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN
37087 C determine x-values of NC1P diquark
37088 XDIQP=PHKK(4,NC1P)*2.D0/UMO
37089 XVQT=PHKK(4,NC1T)*2.D0/UMO
37091 C determine x-values of sea quark pair
37097 IF(ICOU.GE.500)THEN
37100 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 2234 ICOU. GT.100'
37104 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 call XSEAPA: UMO,XDIQP,XVQT ',
37109 C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37110 IF (IPIP.EQ.1) THEN
37111 XQMAX = XDIQP/2.0D0
37112 XAQMAX = 2.D0*XVQT/3.0D0
37114 XQMAX = 2.D0*XVQT/3.0D0
37115 XAQMAX = XDIQP/2.0D0
37117 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37119 C write(*,*) 'MUSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
37121 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37124 & WRITE(LOUT,*)'MUSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37129 IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37130 ELSEIF(IPIP.EQ.2)THEN
37131 IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37134 WRITE(LOUT,'(A,4E12.4)')' MUSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
37135 & XDIQP,XVQT,XSQ,XSAQ
37138 C subtract xsq,xsaq from NC1P diquark and NC1T quark
37144 ELSEIF(IPIP.EQ.2)THEN
37149 & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
37151 C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37156 IF(IVTHR.EQ.10)THEN
37159 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 3466 reject IVTHR 10'
37164 XVTHR=XVTHRO/(201-IVTHR)
37167 IF(XVTHR.GT.0.66D0*XDIQP)THEN
37170 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 380 XVTHR large',
37175 IF(DT_RNDM(V).LT.0.5D0)THEN
37176 XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37179 XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37183 WRITE(LOUT,'(A,2E12.4)')' MUSQBS1:XVPQI,XVPQII ',XVPQI,XVPQII
37186 C Prepare 4 momenta of new chains and chain ends
37188 C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37189 C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37191 C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
37192 C 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
37193 C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37199 ELSEIF(IPIP.EQ.2)THEN
37209 JDAHKT(1,1)=3+IIGLU1
37211 C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
37212 PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
37213 PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
37214 PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
37215 PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
37216 C PHKT(5,1) =PHKK(5,NC1P)
37217 XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
37219 IF(XMIST.GE.0.D0)THEN
37220 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
37223 C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37226 VHKT(1,1) =VHKK(1,NC1P)
37227 VHKT(2,1) =VHKK(2,NC1P)
37228 VHKT(3,1) =VHKK(3,NC1P)
37229 VHKT(4,1) =VHKK(4,NC1P)
37230 WHKT(1,1) =WHKK(1,NC1P)
37231 WHKT(2,1) =WHKK(2,NC1P)
37232 WHKT(3,1) =WHKK(3,NC1P)
37233 WHKT(4,1) =WHKK(4,NC1P)
37234 C Add here IIGLU1 gluons to this chaina
37239 IF(IIGLU1.GE.1)THEN
37241 DO 61 IIG=2,2+IIGLU1-1
37243 IDHKT(IIG) =IDHKK(KKG)
37247 JDAHKT(1,IIG)=3+IIGLU1
37249 PHKT(1,IIG)=PHKK(1,KKG)
37250 PG1=PG1+ PHKT(1,IIG)
37251 PHKT(2,IIG)=PHKK(2,KKG)
37252 PG2=PG2+ PHKT(2,IIG)
37253 PHKT(3,IIG)=PHKK(3,KKG)
37254 PG3=PG3+ PHKT(3,IIG)
37255 PHKT(4,IIG)=PHKK(4,KKG)
37256 PG4=PG4+ PHKT(4,IIG)
37257 PHKT(5,IIG)=PHKK(5,KKG)
37258 VHKT(1,IIG) =VHKK(1,KKG)
37259 VHKT(2,IIG) =VHKK(2,KKG)
37260 VHKT(3,IIG) =VHKK(3,KKG)
37261 VHKT(4,IIG) =VHKK(4,KKG)
37262 WHKT(1,IIG) =WHKK(1,KKG)
37263 WHKT(2,IIG) =WHKK(2,KKG)
37264 WHKT(3,IIG) =WHKK(3,KKG)
37265 WHKT(4,IIG) =WHKK(4,KKG)
37268 IDHKT(2+IIGLU1) =IPP2
37269 ISTHKT(2+IIGLU1) =932
37270 JMOHKT(1,2+IIGLU1)=NC2T
37271 JMOHKT(2,2+IIGLU1)=0
37272 JDAHKT(1,2+IIGLU1)=3+IIGLU1
37273 JDAHKT(2,2+IIGLU1)=0
37274 PHKT(1,2+IIGLU1) =PHKK(1,NC2T)
37275 PHKT(2,2+IIGLU1) =PHKK(2,NC2T)
37276 PHKT(3,2+IIGLU1) =PHKK(3,NC2T)
37277 PHKT(4,2+IIGLU1) =PHKK(4,NC2T)
37278 C PHKT(5,2+IIGLU1) =PHKK(5,NC2T)
37279 XMIST=(PHKT(4,2+IIGLU1)**2-
37280 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37281 *PHKT(1,2+IIGLU1)**2)
37282 IF(XMIST.GT.0.D0)THEN
37283 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
37284 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37285 *PHKT(1,2+IIGLU1)**2)
37287 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37288 PHKT(5,2+IIGLU1)=0.D0
37290 VHKT(1,2+IIGLU1) =VHKK(1,NC2T)
37291 VHKT(2,2+IIGLU1) =VHKK(2,NC2T)
37292 VHKT(3,2+IIGLU1) =VHKK(3,NC2T)
37293 VHKT(4,2+IIGLU1) =VHKK(4,NC2T)
37294 WHKT(1,2+IIGLU1) =WHKK(1,NC2T)
37295 WHKT(2,2+IIGLU1) =WHKK(2,NC2T)
37296 WHKT(3,2+IIGLU1) =WHKK(3,NC2T)
37297 WHKT(4,2+IIGLU1) =WHKK(4,NC2T)
37298 IDHKT(3+IIGLU1) =88888
37299 ISTHKT(3+IIGLU1) =94
37300 JMOHKT(1,3+IIGLU1)=1
37301 JMOHKT(2,3+IIGLU1)=2+IIGLU1
37302 JDAHKT(1,3+IIGLU1)=0
37303 JDAHKT(2,3+IIGLU1)=0
37304 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
37305 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
37306 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
37307 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
37309 * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37310 * -PHKT(3,3+IIGLU1)**2)
37311 IF(XMIST.GE.0.D0)THEN
37313 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37314 * -PHKT(3,3+IIGLU1)**2)
37316 C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37320 C IF(NUMEV.EQ.-324)THEN
37321 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),
37322 * JMOHKT(2,1),JDAHKT(1,1),
37323 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
37324 DO 71 IIG=2,2+IIGLU1-1
37325 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
37326 & JMOHKT(1,IIG),JMOHKT(2,IIG),
37328 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37330 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
37331 * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
37332 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
37333 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
37334 * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
37335 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
37339 IF(IP11.GE.3.OR.IPP2.GE.3)CHAMAL=CHAM3
37340 ELSEIF(IPIP.EQ.2)THEN
37341 IF(IP11.LE.-3.OR.IPP2.LE.-3)CHAMAL=CHAM3
37343 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
37347 C WRITE(6,*)' MUSQBS1 jump back from chain 3'
37350 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
37351 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
37352 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
37353 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
37354 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
37355 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
37356 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
37357 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
37358 IDHKT(4+IIGLU1) =IP12
37359 ISTHKT(4+IIGLU1) =931
37360 JMOHKT(1,4+IIGLU1)=NC1P
37361 JMOHKT(2,4+IIGLU1)=0
37362 JDAHKT(1,4+IIGLU1)=6+IIGLU1
37363 JDAHKT(2,4+IIGLU1)=0
37364 C create chain 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
37365 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
37366 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
37367 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
37368 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
37369 C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
37370 XMIST =(PHKT(4,4+IIGLU1)**2-
37371 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37372 *PHKT(1,4+IIGLU1)**2)
37373 IF(XMIST.GT.0.D0)THEN
37374 PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2-
37375 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37376 *PHKT(1,4+IIGLU1)**2)
37378 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37379 PHKT(5,4+IIGLU1)=0.D0
37381 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
37382 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
37383 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
37384 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
37385 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
37386 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
37387 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
37388 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
37390 IDHKT(5+IIGLU1) =-(ISAQ1-6)
37391 ELSEIF(IPIP.EQ.2)THEN
37392 IDHKT(5+IIGLU1) =ISAQ1
37394 ISTHKT(5+IIGLU1) =932
37395 JMOHKT(1,5+IIGLU1)=NC1T
37396 JMOHKT(2,5+IIGLU1)=0
37397 JDAHKT(1,5+IIGLU1)=6+IIGLU1
37398 JDAHKT(2,5+IIGLU1)=0
37399 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
37400 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
37401 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
37402 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
37403 C IF( PHKT(4,5).EQ.0.D0)THEN
37408 C PHKT(5,5) =PHKK(5,NC1T)
37409 XMIST=(PHKT(4,5+IIGLU1)**2-
37410 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37411 *PHKT(1,5+IIGLU1)**2)
37412 IF(XMIST.GT.0.D0)THEN
37413 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
37414 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37415 *PHKT(1,5+IIGLU1)**2)
37417 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37418 PHKT(5,5+IIGLU1)=0.D0
37420 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
37421 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
37422 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
37423 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
37424 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
37425 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
37426 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
37427 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
37428 IDHKT(6+IIGLU1) =88888
37429 ISTHKT(6+IIGLU1) =94
37430 JMOHKT(1,6+IIGLU1)=4+IIGLU1
37431 JMOHKT(2,6+IIGLU1)=5+IIGLU1
37432 JDAHKT(1,6+IIGLU1)=0
37433 JDAHKT(2,6+IIGLU1)=0
37434 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37435 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37436 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37437 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37439 * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37440 * -PHKT(3,6+IIGLU1)**2)
37441 IF(XMIST.GE.0.D0)THEN
37443 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37444 * -PHKT(3,6+IIGLU1)**2)
37446 C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37449 C IF(IPIP.EQ.3)THEN
37452 IF(IP12.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
37453 ELSEIF(IPIP.EQ.2)THEN
37454 IF(IP12.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
37456 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37460 C WRITE(6,*)' MGSQBS1 jump back from chain 6',
37461 C & CHAMAL,PHKT(5,6+IIGLU1)
37465 C IF(NUMEV.EQ.-324)THEN
37466 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
37467 * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
37468 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
37469 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
37470 * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
37471 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
37472 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
37473 * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
37474 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
37476 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
37477 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
37478 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
37479 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
37480 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
37481 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
37482 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
37483 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
37485 IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+3
37486 IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
37487 IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
37488 IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
37489 ELSEIF(IPIP.EQ.2)THEN
37490 IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3
37491 IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
37492 IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
37493 IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
37494 C WRITE(6,*)'IDHKT(7+IIGLU1),IPP1,ISQ1',IDHKT(7+IIGLU1),IPP1,ISQ1
37496 ISTHKT(7+IIGLU1) =931
37497 JMOHKT(1,7+IIGLU1)=NC2P
37498 JMOHKT(2,7+IIGLU1)=0
37499 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
37500 JDAHKT(2,7+IIGLU1)=0
37501 C create chain 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37502 PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
37503 PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
37504 PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
37505 PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
37506 C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
37507 C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
37508 IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
37510 C WRITE(6,*)'reject PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P)'
37515 C PHKT(5,7) =PHKK(5,NC2P)
37516 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
37517 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
37518 *PHKT(1,7+IIGLU1)**2)
37519 VHKT(1,7+IIGLU1) =VHKK(1,NC2P)
37520 VHKT(2,7+IIGLU1) =VHKK(2,NC2P)
37521 VHKT(3,7+IIGLU1) =VHKK(3,NC2P)
37522 VHKT(4,7+IIGLU1) =VHKK(4,NC2P)
37523 WHKT(1,7+IIGLU1) =WHKK(1,NC2P)
37524 WHKT(2,7+IIGLU1) =WHKK(2,NC2P)
37525 WHKT(3,7+IIGLU1) =WHKK(3,NC2P)
37526 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
37527 C Insert here the IIGLU2 gluons
37532 IF(IIGLU2.GE.1)THEN
37534 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37535 KKG=JJG+IIG-7-IIGLU1
37536 IDHKT(IIG) =IDHKK(KKG)
37540 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
37542 PHKT(1,IIG)=PHKK(1,KKG)
37543 PG1=PG1+ PHKT(1,IIG)
37544 PHKT(2,IIG)=PHKK(2,KKG)
37545 PG2=PG2+ PHKT(2,IIG)
37546 PHKT(3,IIG)=PHKK(3,KKG)
37547 PG3=PG3+ PHKT(3,IIG)
37548 PHKT(4,IIG)=PHKK(4,KKG)
37549 PG4=PG4+ PHKT(4,IIG)
37550 PHKT(5,IIG)=PHKK(5,KKG)
37551 VHKT(1,IIG) =VHKK(1,KKG)
37552 VHKT(2,IIG) =VHKK(2,KKG)
37553 VHKT(3,IIG) =VHKK(3,KKG)
37554 VHKT(4,IIG) =VHKK(4,KKG)
37555 WHKT(1,IIG) =WHKK(1,KKG)
37556 WHKT(2,IIG) =WHKK(2,KKG)
37557 WHKT(3,IIG) =WHKK(3,KKG)
37558 WHKT(4,IIG) =WHKK(4,KKG)
37561 IDHKT(8+IIGLU1+IIGLU2) =IP2
37562 ISTHKT(8+IIGLU1+IIGLU2) =932
37563 JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
37564 JMOHKT(2,8+IIGLU1+IIGLU2)=0
37565 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
37566 JDAHKT(2,8+IIGLU1+IIGLU2)=0
37567 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
37568 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
37569 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
37570 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
37571 C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T)
37572 XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
37573 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37574 *PHKT(1,8+IIGLU1+IIGLU2)**2)
37575 IF(XMIST.GT.0.D0)THEN
37576 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
37577 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37578 *PHKT(1,8+IIGLU1+IIGLU2)**2)
37580 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37581 PHKT(5,8+IIGLU1+IIGLU2)=0.D0
37583 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T)
37584 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T)
37585 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T)
37586 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T)
37587 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T)
37588 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T)
37589 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T)
37590 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T)
37591 IDHKT(9+IIGLU1+IIGLU2) =88888
37592 ISTHKT(9+IIGLU1+IIGLU2) =94
37593 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
37594 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
37595 JDAHKT(1,9+IIGLU1+IIGLU2)=0
37596 JDAHKT(2,9+IIGLU1+IIGLU2)=0
37597 PHKT(1,9+IIGLU1+IIGLU2)
37598 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
37599 PHKT(2,9+IIGLU1+IIGLU2)
37600 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
37601 PHKT(3,9+IIGLU1+IIGLU2)
37602 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
37603 PHKT(4,9+IIGLU1+IIGLU2)
37604 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
37606 *=(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37607 * -PHKT(2,9+IIGLU1+IIGLU2)**2
37608 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
37609 IF(XMIST.GE.0.D0)THEN
37610 PHKT(5,9+IIGLU1+IIGLU2)
37611 *=SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37612 * -PHKT(2,9+IIGLU1+IIGLU2)**2
37613 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
37615 C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37619 C IF(NUMEV.EQ.-324)THEN
37620 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
37621 * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
37622 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
37623 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37624 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
37625 & JMOHKT(1,IIG),JMOHKT(2,IIG),
37627 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37629 WRITE(LOUT,*)8+IIGLU1+IIGLU2,
37630 * ISTHKT(8+IIGLU1+IIGLU2),IDHKT(8+IIGLU1+IIGLU2),
37631 * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
37632 *JDAHKT(1,8+IIGLU1+IIGLU2),
37633 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
37634 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
37635 * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
37636 *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
37637 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
37641 IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
37642 ELSEIF(IPIP.EQ.2)THEN
37643 IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
37645 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
37649 C WRITE(6,*)' MGSQBS1 jump back from chain 9',
37650 C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
37653 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
37654 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
37655 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
37656 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
37657 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
37658 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
37659 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
37660 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
37663 IGCOUN=9+IIGLU1+IIGLU2
37667 *$ CREATE MGSQBS1.FOR
37670 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
37671 SUBROUTINE MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37672 * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,ISQ,IGCOUN)
37674 C GSQBS-1 diagram (split projectile diquark)
37676 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37679 PARAMETER ( LINP = 10 ,
37685 PARAMETER (NMXHKK=200000)
37687 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
37688 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
37689 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
37691 * extended event history
37692 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
37693 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37696 * Lorentz-parameters of the current interaction
37697 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37698 & UMO,PPCM,EPROJ,PPROJ
37700 * diquark-breaking mechanism
37701 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37704 PARAMETER (NTMHKK= 300)
37705 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37706 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37709 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37712 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37714 C GSQBS-1 diagram (split projectile diquark)
37717 C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
37718 C Input chain 2(NC2) sea-quark(NC2P)-valence-diquark(NC2T)
37720 C Create quark(qs)-antiquark(aqs) pair energy from NC1P and NC1T
37721 C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37723 C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
37724 C 6 valence quark(vq2P 4)-sea-quark(aqsP 5)
37725 C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37727 C Put new chains into COMMON /HKKTMP/
37732 C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
37734 NNNC1=IDHKK(NC1)/1000
37735 MMMC1=IDHKK(NC1)-NNNC1*1000
37737 NNNC2=IDHKK(NC2)/1000
37738 MMMC2=IDHKK(NC2)-NNNC2*1000
37742 WRITE(LOUT,*)' MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37743 * ' IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN)',
37744 *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37745 * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN
37750 C determine x-values of NC1P diquark
37751 XDIQP=PHKK(4,NC1P)*2.D0/UMO
37752 XVQT=PHKK(4,NC1T)*2.D0/UMO
37754 C determine x-values of sea quark pair
37760 IF(ICOU.GE.500)THEN
37763 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 Rejection 2234 ICOU. GT.100'
37767 IF(IPCO.GE.3)WRITE(LOUT,*)'MGSQBS1 call XSEAPA: UMO,XDIQP,XVQT ',
37772 C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37773 IF (IPIP.EQ.1) THEN
37774 XQMAX = XDIQP/2.0D0
37775 XAQMAX = 2.D0*XVQT/3.0D0
37777 XQMAX = 2.D0*XVQT/3.0D0
37778 XAQMAX = XDIQP/2.0D0
37780 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37782 C write(*,*) 'MGSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
37785 & WRITE(LOUT,*)'MGSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37788 & WRITE(LOUT,*)'MGSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37793 IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37794 ELSEIF(IPIP.EQ.2)THEN
37795 IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37798 WRITE(LOUT,'(A,4E12.4)')' MGSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
37799 & XDIQP,XVQT,XSQ,XSAQ
37802 C subtract xsq,xsaq from NC1P diquark and NC1T quark
37808 C IF (XDIQP.LT.0.0D0) WRITE(*,*) ' mgsqbs1: XDIQP<0!!',XDIQP
37811 ELSEIF(IPIP.EQ.2)THEN
37816 & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
37818 C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37823 IF(IVTHR.EQ.10)THEN
37826 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 3466 reject IVTHR 10'
37831 XVTHR=XVTHRO/(201-IVTHR)
37834 IF(XVTHR.GT.0.66D0*XDIQP)THEN
37838 & WRITE(LOUT,*)' MGSQBS1 Rejection 380 XVTHR large',
37843 IF(DT_RNDM(V).LT.0.5D0)THEN
37844 XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37847 XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37851 WRITE(LOUT,'(A,4E12.4)')' MGSQBS1:XVTHR,XDIQP,XVPQI,XVPQII ',
37852 & XVTHR,XDIQP,XVPQI,XVPQII
37855 C Prepare 4 momenta of new chains and chain ends
37857 C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37858 C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37860 C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
37861 C 6 valence quark(vq2P 4)-sea-quark(aqsP 5)
37862 C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37868 ELSEIF(IPIP.EQ.2)THEN
37875 C IDHKT(2) =1000*IPP21+100*IPP22+1
37879 IDHKT(4+IIGLU1) =IP12
37880 ISTHKT(4+IIGLU1) =921
37881 JMOHKT(1,4+IIGLU1)=NC1P
37882 JMOHKT(2,4+IIGLU1)=0
37883 JDAHKT(1,4+IIGLU1)=6+IIGLU1
37884 JDAHKT(2,4+IIGLU1)=0
37886 IF ((XDIQP.LT.0.0D0).OR.(XVPQII.LT.0.0D0).OR.
37887 & (XSQ1.LT.0.0D0)) WRITE(LOUT,*) ' mgsqbs1: ',XDIQP,XVPQII,XSQ1
37889 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
37890 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
37891 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
37892 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
37893 C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
37894 XXMIST=(PHKT(4,4+IIGLU1)**2-
37895 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37896 * PHKT(1,4+IIGLU1)**2)
37897 IF(XXMIST.GT.0.D0)THEN
37898 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
37900 WRITE(LOUT,*)'MGSQBS1 XXMIST',XXMIST
37902 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
37904 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
37905 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
37906 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
37907 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
37908 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
37909 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
37910 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
37911 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
37913 IDHKT(5+IIGLU1) =-(ISAQ1-6)
37914 ELSEIF(IPIP.EQ.2)THEN
37915 IDHKT(5+IIGLU1) =ISAQ1
37917 ISTHKT(5+IIGLU1) =922
37918 JMOHKT(1,5+IIGLU1)=NC1T
37919 JMOHKT(2,5+IIGLU1)=0
37920 JDAHKT(1,5+IIGLU1)=6+IIGLU1
37921 JDAHKT(2,5+IIGLU1)=0
37923 IF ((XSAQ1.LT.0.0D0).OR.(XVQT .LT.0.0D0))
37924 & WRITE(LOUT,*) ' mgsqbs2: ',XSAQ1,XVQT
37926 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
37927 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
37928 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
37929 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
37930 C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
37931 XMIST=(PHKT(4,5+IIGLU1)**2-
37932 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37933 *PHKT(1,5+IIGLU1)**2)
37934 IF(XMIST.GT.0.D0)THEN
37935 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
37936 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37937 *PHKT(1,5+IIGLU1)**2)
37939 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37940 PHKT(5,5+IIGLU1)=0.D0
37942 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
37943 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
37944 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
37945 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
37946 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
37947 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
37948 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
37949 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
37950 IDHKT(6+IIGLU1) =88888
37951 C IDHKT(6) =1000*NNNC1+MMMC1
37952 ISTHKT(6+IIGLU1) =93
37954 JMOHKT(1,6+IIGLU1)=4+IIGLU1
37955 JMOHKT(2,6+IIGLU1)=5+IIGLU1
37956 JDAHKT(1,6+IIGLU1)=0
37957 JDAHKT(2,6+IIGLU1)=0
37958 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37959 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37960 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37961 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37963 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37964 * -PHKT(3,6+IIGLU1)**2)
37967 IF(IP12.GE.3.OR.ISAQ.GE.9)CHAMAL=CHAM3
37968 ELSEIF(IPIP.EQ.2)THEN
37969 IF(IP12.LE.-3.OR.ISAQ.GE.3)CHAMAL=CHAM3
37971 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37972 IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
37973 C we drop chain 6 and give the energy to chain 3
37974 IDHKT(6+IIGLU1)=33888
37976 C WRITE(6,*)' drop chain 6 xgive=1'
37978 ELSEIF(IDHKT(5+IIGLU1).EQ.-IP11)THEN
37979 C we drop chain 6 and give the energy to chain 3
37980 C and change KK11 to IDHKT(4)
37981 IDHKT(6+IIGLU1)=33888
37983 C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(4+IIGLU1)'
37984 KK11=IDHKT(4+IIGLU1)
37986 ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP21)THEN
37987 C we drop chain 6 and give the energy to chain 3
37988 C and change KK21 to IDHKT(4)
37989 C IDHKT(2) =1000*IPP21+100*IPP22+1
37990 IDHKT(6+IIGLU1)=33888
37992 C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(4+IIGLU1)'
37993 KK21=IDHKT(4+IIGLU1)
37995 ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP22)THEN
37996 C we drop chain 6 and give the energy to chain 3
37997 C and change KK22 to IDHKT(4)
37998 C IDHKT(2) =1000*IPP21+100*IPP22+1
37999 IDHKT(6+IIGLU1)=33888
38001 C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(4+IIGLU1)'
38002 KK22=IDHKT(4+IIGLU1)
38008 C WRITE(6,*)' MGSQBS1 jump back from chain 6'
38013 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
38014 * JMOHKT(1,4+IIGLU1),
38015 * JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
38016 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
38017 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
38018 * JMOHKT(1,5+IIGLU1),
38019 * JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
38020 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
38021 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
38022 * JMOHKT(1,6+IIGLU1),
38023 * JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
38024 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
38026 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
38027 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
38028 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
38029 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
38030 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
38031 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
38032 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
38033 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
38039 JDAHKT(1,1)=3+IIGLU1
38041 PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
38042 C * +0.5D0*PHKK(1,NC2P)
38043 *+XGIVE*PHKT(1,4+IIGLU1)
38044 PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
38045 C * +0.5D0*PHKK(2,NC2P)
38046 *+XGIVE*PHKT(2,4+IIGLU1)
38047 PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
38048 C * +0.5D0*PHKK(3,NC2P)
38049 *+XGIVE*PHKT(3,4+IIGLU1)
38050 PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
38051 C * +0.5D0*PHKK(4,NC2P)
38052 *+XGIVE*PHKT(4,4+IIGLU1)
38053 C PHKT(5,1) =PHKK(5,NC1P)
38054 XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38056 IF(XMIST.GE.0.D0)THEN
38057 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38060 C WRITE(6,*)'MGSQBS1 parton 1 mass square LT.0 ',XMIST
38063 VHKT(1,1) =VHKK(1,NC1P)
38064 VHKT(2,1) =VHKK(2,NC1P)
38065 VHKT(3,1) =VHKK(3,NC1P)
38066 VHKT(4,1) =VHKK(4,NC1P)
38067 WHKT(1,1) =WHKK(1,NC1P)
38068 WHKT(2,1) =WHKK(2,NC1P)
38069 WHKT(3,1) =WHKK(3,NC1P)
38070 WHKT(4,1) =WHKK(4,NC1P)
38071 C Add here IIGLU1 gluons to this chaina
38076 IF(IIGLU1.GE.1)THEN
38078 DO 61 IIG=2,2+IIGLU1-1
38080 IDHKT(IIG) =IDHKK(KKG)
38084 JDAHKT(1,IIG)=3+IIGLU1
38086 PHKT(1,IIG)=PHKK(1,KKG)
38087 PG1=PG1+ PHKT(1,IIG)
38088 PHKT(2,IIG)=PHKK(2,KKG)
38089 PG2=PG2+ PHKT(2,IIG)
38090 PHKT(3,IIG)=PHKK(3,KKG)
38091 PG3=PG3+ PHKT(3,IIG)
38092 PHKT(4,IIG)=PHKK(4,KKG)
38093 PG4=PG4+ PHKT(4,IIG)
38094 PHKT(5,IIG)=PHKK(5,KKG)
38095 VHKT(1,IIG) =VHKK(1,KKG)
38096 VHKT(2,IIG) =VHKK(2,KKG)
38097 VHKT(3,IIG) =VHKK(3,KKG)
38098 VHKT(4,IIG) =VHKK(4,KKG)
38099 WHKT(1,IIG) =WHKK(1,KKG)
38100 WHKT(2,IIG) =WHKK(2,KKG)
38101 WHKT(3,IIG) =WHKK(3,KKG)
38102 WHKT(4,IIG) =WHKK(4,KKG)
38105 C IDHKT(2) =1000*IPP21+100*IPP22+1
38107 IDHKT(2+IIGLU1) =1000*KK21+100*KK22+3
38108 IF(IDHKT(2+IIGLU1).EQ.1203)IDHKT(2+IIGLU1)=2103
38109 IF(IDHKT(2+IIGLU1).EQ.1303)IDHKT(2+IIGLU1)=3103
38110 IF(IDHKT(2+IIGLU1).EQ.2303)IDHKT(2+IIGLU1)=3203
38111 ELSEIF(IPIP.EQ.2)THEN
38112 IDHKT(2+IIGLU1) =1000*KK21+100*KK22-3
38113 IF(IDHKT(2+IIGLU1).EQ.-1203)IDHKT(2+IIGLU1)=-2103
38114 IF(IDHKT(2+IIGLU1).EQ.-1303)IDHKT(2+IIGLU1)=-3103
38115 IF(IDHKT(2+IIGLU1).EQ.-2303)IDHKT(2+IIGLU1)=-3203
38117 ISTHKT(2+IIGLU1) =922
38118 JMOHKT(1,2+IIGLU1)=NC2T
38119 JMOHKT(2,2+IIGLU1)=0
38120 JDAHKT(1,2+IIGLU1)=3+IIGLU1
38121 JDAHKT(2,2+IIGLU1)=0
38122 PHKT(1,2+IIGLU1) =PHKK(1,NC2T)
38123 *+XGIVE*PHKT(1,5+IIGLU1)
38124 PHKT(2,2+IIGLU1) =PHKK(2,NC2T)
38125 *+XGIVE*PHKT(2,5+IIGLU1)
38126 PHKT(3,2+IIGLU1) =PHKK(3,NC2T)
38127 *+XGIVE*PHKT(3,5+IIGLU1)
38128 PHKT(4,2+IIGLU1) =PHKK(4,NC2T)
38129 *+XGIVE*PHKT(4,5+IIGLU1)
38130 C PHKT(5,2) =PHKK(5,NC2T)
38131 XMIST=(PHKT(4,2+IIGLU1)**2-
38132 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38133 *PHKT(1,2+IIGLU1)**2)
38134 IF(XMIST.GT.0.D0)THEN
38135 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
38136 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38137 *PHKT(1,2+IIGLU1)**2)
38139 C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
38140 PHKT(5,2+IIGLU1)=0.D0
38142 VHKT(1,2+IIGLU1) =VHKK(1,NC2T)
38143 VHKT(2,2+IIGLU1) =VHKK(2,NC2T)
38144 VHKT(3,2+IIGLU1) =VHKK(3,NC2T)
38145 VHKT(4,2+IIGLU1) =VHKK(4,NC2T)
38146 WHKT(1,2+IIGLU1) =WHKK(1,NC2T)
38147 WHKT(2,2+IIGLU1) =WHKK(2,NC2T)
38148 WHKT(3,2+IIGLU1) =WHKK(3,NC2T)
38149 WHKT(4,2+IIGLU1) =WHKK(4,NC2T)
38150 IDHKT(3+IIGLU1) =88888
38151 C IDHKT(3) =1000*NNNC1+MMMC1+10
38152 ISTHKT(3+IIGLU1) =93
38154 JMOHKT(1,3+IIGLU1)=1
38155 JMOHKT(2,3+IIGLU1)=2+IIGLU1
38156 JDAHKT(1,3+IIGLU1)=0
38157 JDAHKT(2,3+IIGLU1)=0
38158 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
38159 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
38160 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
38161 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
38163 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38164 * -PHKT(3,3+IIGLU1)**2)
38166 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
38168 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
38169 DO 71 IIG=2,2+IIGLU1-1
38170 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38171 & JMOHKT(1,IIG),JMOHKT(2,IIG),
38173 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38175 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),
38176 & IDHKT(2),JMOHKT(1,2+IIGLU1),
38177 * JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
38178 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
38179 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
38180 * JMOHKT(1,3+IIGLU1),
38181 * JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
38182 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
38186 C IF(IPIP.EQ.1)THEN
38187 C IF(IPP21.GE.3.OR.IPP22.GE.3.OR.IP11.GE.3)CHAMAL=CHAB3
38188 C ELSEIF(IPIP.EQ.2)THEN
38189 C IF(IPP21.LE.-3.OR.IPP22.LE.-3.OR.IP11.LE.-3)CHAMAL=CHAB3
38192 IF(KK21.GE.3.OR.KK22.GE.3.OR.KK11.GE.3)CHAMAL=CHAB3
38193 ELSEIF(IPIP.EQ.2)THEN
38194 IF(KK21.LE.-3.OR.KK22.LE.-3.OR.KK11.LE.-3)CHAMAL=CHAB3
38197 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
38201 C WRITE(6,*)' MGSQBS1 jump back from chain 3'
38204 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
38205 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
38206 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
38207 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
38208 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
38209 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
38210 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
38211 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
38213 IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ1+3
38214 IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
38215 IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
38216 IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
38217 ELSEIF(IPIP.EQ.2)THEN
38218 IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3
38219 IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
38220 IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
38221 IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
38222 C WRITE(6,*)'IDHKT(7),IPP1,ISQ1',IDHKT(7),IPP1,ISQ1
38224 ISTHKT(7+IIGLU1) =921
38225 JMOHKT(1,7+IIGLU1)=NC2P
38226 JMOHKT(2,7+IIGLU1)=0
38227 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
38228 JDAHKT(2,7+IIGLU1)=0
38229 C PHKT(1,7) =0.5D0*PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ/(XDIQP+XSQ)
38230 C PHKT(2,7) =0.5D0*PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ/(XDIQP+XSQ)
38231 C PHKT(3,7) =0.5D0*PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ/(XDIQP+XSQ)
38232 C PHKT(4,7+IIGLU1) =0.5D0*PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ/(XDIQP+XSQ)
38234 IF ((XSQ1 .LT.0.0D0).OR.(XDIQP .LT.0.0D0))
38235 & WRITE(LOUT,*) ' mgsqbs3: ',XSQ1,XDIQP
38237 PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
38238 PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
38239 PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
38240 PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
38241 C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
38242 C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
38243 IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
38245 C WRITE(6,*)'reject PHKT(4,7).GE. PHKK(4,NC1P)'
38250 C PHKT(5,7) =PHKK(5,NC2P)
38251 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
38252 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
38253 *PHKT(1,7+IIGLU1)**2)
38254 VHKT(1,7+IIGLU1) =VHKK(1,NC2P)
38255 VHKT(2,7+IIGLU1) =VHKK(2,NC2P)
38256 VHKT(3,7+IIGLU1) =VHKK(3,NC2P)
38257 VHKT(4,7+IIGLU1) =VHKK(4,NC2P)
38258 WHKT(1,7+IIGLU1) =WHKK(1,NC2P)
38259 WHKT(2,7+IIGLU1) =WHKK(2,NC2P)
38260 WHKT(3,7+IIGLU1) =WHKK(3,NC2P)
38261 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
38262 C Insert here the IIGLU2 gluons
38267 IF(IIGLU2.GE.1)THEN
38269 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38270 KKG=JJG+IIG-7-IIGLU1
38271 IDHKT(IIG) =IDHKK(KKG)
38275 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
38277 PHKT(1,IIG)=PHKK(1,KKG)
38278 PG1=PG1+ PHKT(1,IIG)
38279 PHKT(2,IIG)=PHKK(2,KKG)
38280 PG2=PG2+ PHKT(2,IIG)
38281 PHKT(3,IIG)=PHKK(3,KKG)
38282 PG3=PG3+ PHKT(3,IIG)
38283 PHKT(4,IIG)=PHKK(4,KKG)
38284 PG4=PG4+ PHKT(4,IIG)
38285 PHKT(5,IIG)=PHKK(5,KKG)
38286 VHKT(1,IIG) =VHKK(1,KKG)
38287 VHKT(2,IIG) =VHKK(2,KKG)
38288 VHKT(3,IIG) =VHKK(3,KKG)
38289 VHKT(4,IIG) =VHKK(4,KKG)
38290 WHKT(1,IIG) =WHKK(1,KKG)
38291 WHKT(2,IIG) =WHKK(2,KKG)
38292 WHKT(3,IIG) =WHKK(3,KKG)
38293 WHKT(4,IIG) =WHKK(4,KKG)
38296 IDHKT(8+IIGLU1+IIGLU2) =IP2
38297 ISTHKT(8+IIGLU1+IIGLU2) =922
38298 JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
38299 JMOHKT(2,8+IIGLU1+IIGLU2)=0
38300 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
38301 JDAHKT(2,8+IIGLU1+IIGLU2)=0
38303 IF ((XVQT.LT.0.0D0).OR.(XSAQ1 .LT.0.0D0))
38304 & WRITE(LOUT,*) ' mgsqbs4: ',XVQT,XSAQ1
38306 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
38307 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
38308 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
38309 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
38310 C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T)
38311 XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
38312 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38313 *PHKT(1,8+IIGLU1+IIGLU2)**2)
38314 IF(XMIST.GT.0.D0)THEN
38315 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
38316 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38317 *PHKT(1,8+IIGLU1+IIGLU2)**2)
38319 C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
38320 PHKT(5,8+IIGLU1+IIGLU2)=0.D0
38322 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T)
38323 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T)
38324 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T)
38325 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T)
38326 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T)
38327 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T)
38328 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T)
38329 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T)
38330 IDHKT(9+IIGLU1+IIGLU2) =88888
38331 C IDHKT(9) =1000*NNNC2+MMMC2+10
38332 ISTHKT(9+IIGLU1+IIGLU2) =93
38334 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
38335 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
38336 JDAHKT(1,9+IIGLU1+IIGLU2)=0
38337 JDAHKT(2,9+IIGLU1+IIGLU2)=0
38338 PHKT(1,9+IIGLU1+IIGLU2) =PHKT(1,7+IIGLU1)
38339 * +PHKT(1,8+IIGLU1+IIGLU2)+PG1
38340 PHKT(2,9+IIGLU1+IIGLU2) =PHKT(2,7+IIGLU1)
38341 * +PHKT(2,8+IIGLU1+IIGLU2)+PG2
38342 PHKT(3,9+IIGLU1+IIGLU2) =PHKT(3,7+IIGLU1)
38343 * +PHKT(3,8+IIGLU1+IIGLU2)+PG3
38344 PHKT(4,9+IIGLU1+IIGLU2) =PHKT(4,7+IIGLU1)
38345 * +PHKT(4,8+IIGLU1+IIGLU2)+PG4
38346 PHKT(5,9+IIGLU1+IIGLU2)
38347 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
38348 * PHKT(2,9+IIGLU1+IIGLU2)**2
38349 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
38351 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
38352 * JMOHKT(1,7+IIGLU1),
38353 * JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
38354 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
38355 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38356 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38357 & JMOHKT(1,IIG),JMOHKT(2,IIG),
38359 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38361 WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
38362 * IDHKT(8+IIGLU1+IIGLU2),
38363 * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
38364 * JDAHKT(1,8+IIGLU1+IIGLU2),
38365 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
38366 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
38367 * IDHKT(9+IIGLU1+IIGLU2),
38368 * JMOHKT(1,9+IIGLU1+IIGLU2),JMOHKT(2,9+IIGLU1+IIGLU2),
38369 * JDAHKT(1,9+IIGLU1+IIGLU2),
38370 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
38374 IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
38375 ELSEIF(IPIP.EQ.2)THEN
38376 IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
38378 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
38382 C WRITE(6,*)' MGSQBS1 jump back from chain 9',
38383 C & 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
38386 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
38387 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
38388 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
38389 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
38390 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
38391 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
38392 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
38393 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
38395 IGCOUN=9+IIGLU1+IIGLU2
38400 *$ CREATE HKKHKT.FOR
38403 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
38405 SUBROUTINE HKKHKT(I,J)
38406 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38411 PARAMETER (NMXHKK=200000)
38413 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38414 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38415 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38417 * extended event history
38418 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38419 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38422 PARAMETER (NTMHKK= 300)
38423 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38424 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38427 ISTHKK(I) =ISTHKT(J)
38429 C IF(J.EQ.3.OR.J.EQ.6.OR.J.EQ.9)THEN
38430 IF(IDHKK(I).EQ.88888)THEN
38433 JMOHKK(1,I)=I-(J-JMOHKT(1,J))
38434 JMOHKK(2,I)=I-(J-JMOHKT(2,J))
38436 JMOHKK(1,I)=JMOHKT(1,J)
38437 JMOHKK(2,I)=JMOHKT(2,J)
38439 JDAHKK(1,I)=JDAHKT(1,J)
38440 JDAHKK(2,I)=JDAHKT(2,J)
38441 C IF(J.EQ.1.OR.J.EQ.4.OR.J.EQ.7)THEN
38443 C ELSEIF(J.EQ.2.OR.J.EQ.5.OR.J.EQ.8)THEN
38446 IF(JDAHKT(1,J).GT.0)THEN
38447 JDAHKK(1,I)=I+(JDAHKT(1,J)-J)
38449 PHKK(1,I) =PHKT(1,J)
38450 PHKK(2,I) =PHKT(2,J)
38451 PHKK(3,I) =PHKT(3,J)
38452 PHKK(4,I) =PHKT(4,J)
38453 PHKK(5,I) =PHKT(5,J)
38454 VHKK(1,I) =VHKT(1,J)
38455 VHKK(2,I) =VHKT(2,J)
38456 VHKK(3,I) =VHKT(3,J)
38457 VHKK(4,I) =VHKT(4,J)
38458 WHKK(1,I) =WHKT(1,J)
38459 WHKK(2,I) =WHKT(2,J)
38460 WHKK(3,I) =WHKT(3,J)
38461 WHKK(4,I) =WHKT(4,J)
38465 *$ CREATE DT_DBREAK.FOR
38468 *===dbreak=============================================================*
38470 SUBROUTINE DT_DBREAK(MODE)
38472 ************************************************************************
38473 * This is the steering subroutine for the different diquark breaking *
38476 * MODE = 1 breaking of projectile diquark in qq-q chain using *
38477 * a sea quark (q-qq chain) of the same projectile *
38478 * = 2 breaking of target diquark in q-qq chain using *
38479 * a sea quark (qq-q chain) of the same target *
38480 * = 3 breaking of projectile diquark in qq-q chain using *
38481 * a sea quark (q-aq chain) of the same projectile *
38482 * = 4 breaking of target diquark in q-qq chain using *
38483 * a sea quark (aq-q chain) of the same target *
38484 * = 5 breaking of projectile anti-diquark in aqaq-aq chain using *
38485 * a sea anti-quark (aq-aqaq chain) of the same projectile *
38486 * = 6 breaking of target anti-diquark in aq-aqaq chain using *
38487 * a sea anti-quark (aqaq-aq chain) of the same target *
38488 * = 7 breaking of projectile anti-diquark in aqaq-aq chain using *
38489 * a sea anti-quark (aq-q chain) of the same projectile *
38490 * = 8 breaking of target anti-diquark in aq-aqaq chain using *
38491 * a sea anti-quark (q-aq chain) of the same target *
38493 * Original version by J. Ranft. *
38494 * This version dated 17.5.00 is written by S. Roesler. *
38495 ************************************************************************
38497 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38500 PARAMETER ( LINP = 10 ,
38506 PARAMETER (NMXHKK=200000)
38508 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38509 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38510 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38512 * extended event history
38513 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38514 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38517 * flags for input different options
38518 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
38519 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
38520 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
38522 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
38523 PARAMETER (MAXCHN=10000)
38524 COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
38526 * diquark-breaking mechanism
38527 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
38529 * flags for particle decays
38530 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
38531 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
38532 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
38535 * chain identifiers
38536 * ( 1 = q-aq, 2 = aq-q, 3 = q-qq, 4 = qq-q,
38537 * 5 = aq-adq, 6 = adq-aq, 7 = dq-adq, 8 = adq-dq )
38538 DIMENSION IDCHN1(8),IDCHN2(8)
38539 DATA IDCHN1 / 4, 3, 4, 3, 6, 5, 6, 5/
38540 DATA IDCHN2 / 3, 4, 1, 2, 5, 6, 2, 1/
38542 * parton identifiers
38543 * ( +-21/22 = valence, +-31/32 = Glauber-sea, +-41/42 = Pomeron (diff),
38544 * +-51/52 = unitarity-sea, +-61/62 = gluons )
38545 DIMENSION ISP1P(8,3),ISP1T(8,3),ISP2P(8,3),ISP2T(8,3)
38546 DATA ISP1P / 21, 21, 21, 21, 21, 21, 21, 21,
38547 & 31, 31, 31, 31, 31, 31, 31, 31,
38548 & 41, 41, 41, 41, 51, 51, 51, 51/
38549 DATA ISP1T / 22, 22, 22, 22, 22, 22, 22, 22,
38550 & 32, 32, 32, 32, 32, 32, 32, 32,
38551 & 42, 42, 42, 42, 52, 52, 52, 52/
38552 DATA ISP2P / 31, 21, 31, 31, 21, 21, 21, 21,
38553 & 51, 31, 41, 41, 31, 31, 31, 31,
38554 & 0, 41, 51, 51, 51, 51, 51, 51/
38555 DATA ISP2T / 22, 32, 32, 32, 22, 22, 22, 22,
38556 & 32, 52, 42, 42, 32, 32, 32, 32,
38557 & 42, 0, 52, 52, 52, 52, 52, 52/
38559 IF (NCHAIN.LE.0) RETURN
38562 IS1P = ABS(ISTHKK(JMOHKK(1,IDX1)))
38563 IS1T = ABS(ISTHKK(JMOHKK(2,IDX1)))
38564 IF ( (IDXCHN(2,I).EQ.IDCHN1(MODE))
38566 & ((IS1P.EQ.ISP1P(MODE,1)).OR.(IS1P.EQ.ISP1P(MODE,2)).OR.
38567 & (IS1P.EQ.ISP1P(MODE,3)))
38569 & ((IS1T.EQ.ISP1T(MODE,1)).OR.(IS1T.EQ.ISP1T(MODE,2)).OR.
38570 & (IS1T.EQ.ISP1T(MODE,3)))
38574 IS2P = ABS(ISTHKK(JMOHKK(1,IDX2)))
38575 IS2T = ABS(ISTHKK(JMOHKK(2,IDX2)))
38576 IF ( (IDXCHN(2,J).EQ.IDCHN2(MODE))
38578 & ((IS2P.EQ.ISP2P(MODE,1)).OR.(IS2P.EQ.ISP2P(MODE,2))
38579 & .OR.(IS2P.EQ.ISP2P(MODE,3)))
38581 & ((IS2T.EQ.ISP2T(MODE,1)).OR.(IS2T.EQ.ISP2T(MODE,2))
38582 & .OR.(IS2T.EQ.ISP2T(MODE,3)))
38584 * find mother nucleons of the diquark to be splitted and of the
38585 * sea-quark and reject this combination if it is not the same
38586 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.
38587 & (MODE.EQ.5).OR.(MODE.EQ.7)) THEN
38592 IDXMO1 = JMOHKK(IANCES,IDX1)
38594 IF ((JMOHKK(1,IDXMO1).NE.0).AND.
38595 & (JMOHKK(2,IDXMO1).NE.0)) THEN
38600 IF (JMOHKK(IANC,IDXMO1).NE.0) THEN
38601 IDXMO1 = JMOHKK(IANC,IDXMO1)
38604 IDXMO2 = JMOHKK(IANCES,IDX2)
38606 IF ((JMOHKK(1,IDXMO2).NE.0).AND.
38607 & (JMOHKK(2,IDXMO2).NE.0)) THEN
38612 IF (JMOHKK(IANC,IDXMO2).NE.0) THEN
38613 IDXMO2 = JMOHKK(IANC,IDXMO2)
38616 IF (IDXMO1.NE.IDXMO2) GOTO 2
38617 * quark content of projectile parton
38618 IP1 = IDHKK(JMOHKK(1,IDX1))
38620 IP12 = (IP1-1000*IP11)/100
38621 IP2 = IDHKK(JMOHKK(2,IDX1))
38623 IP22 = (IP2-1000*IP21)/100
38624 * quark content of target parton
38625 IT1 = IDHKK(JMOHKK(1,IDX2))
38627 IT12 = (IT1-1000*IT11)/100
38628 IT2 = IDHKK(JMOHKK(2,IDX2))
38630 IT22 = (IT2-1000*IT21)/100
38631 * split diquark and form new chains
38632 IF (MODE.EQ.1) THEN
38633 IF (IT1.EQ.4) GOTO 2
38634 CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38635 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38636 & IP11,IP12,IP2,IT1,IT21,IT22,1,IPQ,IGCOUN)
38637 ELSEIF (MODE.EQ.2) THEN
38638 IF (IT2.EQ.4) GOTO 2
38639 CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38640 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38641 & IP1,IP21,IP22,IT11,IT12,IT2,1,IPQ,IGCOUN)
38642 ELSEIF (MODE.EQ.3) THEN
38643 IF (IT1.EQ.4) GOTO 2
38644 CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38645 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38646 & IP11,IP12,IP2,IT1,IT2,1,IPQ,IGCOUN)
38647 ELSEIF (MODE.EQ.4) THEN
38648 IF (IT2.EQ.4) GOTO 2
38649 CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38650 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38651 & IP1,IP21,IP22,IT1,IT2,1,IPQ,IGCOUN)
38652 ELSEIF (MODE.EQ.5) THEN
38653 CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38654 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38655 & IP11,IP12,IP2,IT1,IT21,IT22,2,IPQ,IGCOUN)
38656 ELSEIF (MODE.EQ.6) THEN
38657 CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38658 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38659 & IP1,IP21,IP22,IT11,IT12,IT2,2,IPQ,IGCOUN)
38660 ELSEIF (MODE.EQ.7) THEN
38661 CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38662 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38663 & IP11,IP12,IP2,IT1,IT2,2,IPQ,IGCOUN)
38664 ELSEIF (MODE.EQ.8) THEN
38665 CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38666 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38667 & IP1,IP21,IP22,IT1,IT2,2,IPQ,IGCOUN)
38669 IF (IREJ.GE.1) THEN
38670 if ((ipq.lt.0).or.(ipq.ge.4))
38671 & write(LOUT,*) 'ipq !!!',ipq,mode
38672 DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
38673 * accept or reject new chains corresponding to PDBSEA
38675 IF ((IPQ.EQ.1).OR.(IPQ.EQ.2)) THEN
38676 ACC = DBRKA(1,MODE)+DBRKA(2,MODE)
38677 REJ = DBRKR(1,MODE)+DBRKR(2,MODE)
38678 ELSEIF (IPQ.EQ.3) THEN
38679 ACC = DBRKA(3,MODE)
38680 REJ = DBRKR(3,MODE)
38682 WRITE(LOUT,*) ' inconsistent IPQ ! ',IPQ
38685 IF (ACC/(ACC+REJ).LE.PDBSEA(IPQ)) THEN
38686 DBRKA(IPQ,MODE) = DBRKA(IPQ,MODE)+1.0D0
38689 DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
38692 * new chains have been accepted and are now copied into HKKEVT
38693 IF (IACC.EQ.1) THEN
38695 CALL DT_EVTEMC(PHKK(1,IDX1),PHKK(2,IDX1),
38696 & PHKK(3,IDX1),PHKK(4,IDX1),
38698 CALL DT_EVTEMC(PHKK(1,IDX2),PHKK(2,IDX2),
38699 & PHKK(3,IDX2),PHKK(4,IDX2),
38702 IDHKK(IDX1) = 99888
38703 IDHKK(IDX2) = 99888
38708 CALL HKKHKT(NHKK,K)
38709 IF ((LEMCCK).AND.(IDHKK(NHKK).EQ.88888))THEN
38714 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
38719 CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,9000,
38721 IF (IREJ.NE.0) CALL DT_EVTOUT(4)
38733 *$ CREATE DT_CQPAIR.FOR
38736 *===cqpair=============================================================*
38738 SUBROUTINE DT_CQPAIR(XQMAX,XAQMAX,XQ,XAQ,IFLV,IREJ)
38740 ************************************************************************
38741 * This subroutine Creates a Quark-antiquark PAIR from the sea. *
38743 * XQMAX maxium energy fraction of quark (input) *
38744 * XAQMAX maxium energy fraction of antiquark (input) *
38745 * XQ energy fraction of quark (output) *
38746 * XAQ energy fraction of antiquark (output) *
38747 * IFLV quark flavour (- antiquark flavor) (output) *
38749 * This version dated 14.5.00 is written by S. Roesler. *
38750 ************************************************************************
38752 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38755 PARAMETER ( LINP = 10 ,
38759 * Lorentz-parameters of the current interaction
38760 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
38761 & UMO,PPCM,EPROJ,PPROJ
38768 * sample quark flavour
38770 * set seasq here (the one from DTCHAI should be used in the future)
38772 IFLV = INT(1.0D0+DT_RNDM(XQMAX)*(2.0D0+SEASQ))
38774 * sample energy fractions of sea pair
38775 * we first sample the energy fraction of a gluon and then split the gluon
38777 * maximum energy fraction of the gluon forced via input
38778 XGMAXI = XQMAX+XAQMAX
38779 * minimum energy fraction of the gluon
38780 XTHR1 = 4.0D0 /UMO**2
38781 XTHR2 = 0.54D0/UMO**1.5D0
38782 XGMIN = MAX(XTHR1,XTHR2)
38783 * maximum energy fraction of the gluon
38785 XGMAX = MIN(XGMAXI,XGMAX)
38786 IF (XGMIN.GE.XGMAX) THEN
38791 * sample energy fraction of the gluon
38795 IF (NLOOP.GE.50) THEN
38799 XGLUON = DT_SAMSQX(XGMIN,XGMAX)
38800 EGLUON = XGLUON*UMO/2.0D0
38802 * split gluon into q-aq pair (we follow PHOJET's subroutine PHO_GLU2QU)
38803 ZMIN = MIN(0.1D0,0.5D0/EGLUON)
38806 XHLP = ((1.0D0-RZ)*ZMIN**3+RZ*ZMAX**3)**0.33333
38808 IF (RQ.LT.0.5D0) THEN
38815 IF ((XQ.GT.XQMAX).OR.(XAQ.GT.XAQMAX)) GOTO 1