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(4000,2),BRAT(4000),KFDP(4000,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(4000,2),BRAT(4000),KFDP(4000,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(4000,2),BRAT(4000),KFDP(4000,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 WRITE(LOUT,1001) ICREQU,ICSAMP,DBLE(ICSAMP)/DBLE(ICREQU)
27462 1001 FORMAT(/,1X,'number of events requested / sampled',13X,
27463 & I8,' / ',I8,/,1X,'number of samp. evts per requested ',
27464 & 'event',11X,F9.1)
27465 IF (ICDIFF(1).NE.0) THEN
27466 WRITE(LOUT,1009) ICDIFF
27467 1009 FORMAT(/,1X,'diffractive events: total ',I8,/,49X,
27468 & 'low mass high mass',/,24X,'single diffraction',
27469 & 7X,I8,4X,I8,/,24X,'double diffraction',7X,I8,4X,I8)
27471 IF (ICENTR.GT.0) THEN
27472 WRITE(LOUT,1002) DBLE(ICCPRO)/DBLE(ICSAMP),
27473 & DBLE(ICSAMP)/DBLE(ICCPRO)
27474 1002 FORMAT(/,1X,'central production:',/,2X,'mean number',
27475 & ' of sampled Glauber-events per event',9X,F9.1,/,
27476 & 2X,'fraction of production cross section',21X,F10.6)
27478 WRITE(LOUT,1003) DBLE(ICDPR)/DBLE(ICSAMP),
27479 & DBLE(ICDTA)/DBLE(ICSAMP)
27480 1003 FORMAT(/,54X,'proj. targ.',/,1X,'average number of wounded',
27481 & ' nucleons after x-sampling',2(4X,F6.2))
27483 IF (MCGENE.EQ.1) THEN
27484 WRITE(LOUT,1004) DBLE(ICRJSS)/DBLE(ICSAMP)
27485 1004 FORMAT(/,1X,'mean number of sea-sea chain rejections per',
27486 & ' event',3X,F9.1)
27487 IF (ISICHA.EQ.1) THEN
27488 WRITE(LOUT,1005) DBLE(ICVV2S)/DBLE(ICSAMP)
27489 1005 FORMAT(/,1X,'Reggeon contribution:',/,1X,'mean number ',
27490 & 'of single chains per event',13X,F9.1)
27493 1006 FORMAT(/,1X,'chain system statistics: (per event)',/,
27494 & 23X,'mean number of chains mean number of chains',/,
27495 & 23X,'sampled hadronized having mass of a reso.')
27496 WRITE(LOUT,1007) (DBLE(ICCHAI(1,J))/(2.0D0*DBLE(ICSAMP)),
27497 & DBLE(ICCHAI(2,J))/(2.0D0*DBLE(ICREQU)),
27498 & DBLE(ICRES(J))/(2.0D0*DBLE(ICREQU)),J=1,8),
27499 & DBLE(ICCHAI(2,9))/MAX(DBLE(ICCHAI(1,9)),TINY3)
27500 1007 FORMAT(1X,'sea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27501 & 1X,'disea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27502 & 1X,'sea - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27503 & 1X,'sea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27504 & 1X,'disea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27505 & 1X,'valence - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27506 & 1X,'valence - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27507 & 1X,'valence - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27508 & 1X,'fused chains ',18X,F4.1,17X,F4.1,/)
27510 & (DBLE(IRCRON(I))/MAX(DBLE(IRCRON(1)),TINY3),I=2,3),
27511 & DBLE(IRPT)/DBLE(ICREQU),(DBLE(IRRES(I))/DBLE(ICREQU),I=1,2),
27512 & DBLE(LOMRES)/DBLE(ICREQU),DBLE(LOBRES)/DBLE(ICREQU),
27513 & (DBLE(IRCHKI(I))/DBLE(ICREQU),I=1,2),
27514 & (DBLE(IRDIFF(I))/DBLE(ICREQU),I=1,2),
27515 & DBLE(IRHHA)/DBLE(ICREQU),
27516 & DBLE(IRFRAG)/DBLE(ICREQU),DBLE(IREVT)/DBLE(ICREQU),
27517 & (DBLE(IREXCI(I))/DBLE(ICREQU),I=1,2),IREXCI(3)
27518 1008 FORMAT(/,1X,'Rejection counter: (NEVT = no. of events)',/,/,
27519 & 1X,'Cronin-effect (CRONIN)',15X,'IRCRON(2)/IRCRON(1) = ',
27520 & F7.2,/,38X,'IRCRON(3)/IRCRON(1) = ',F7.2,/,1X,
27521 & 'Intrins. p_t (GETSPT)',21X,'IRPT /NEVT = ',F7.2,/,
27522 & 1X,'Chain mass corr. for resonances (EVTRES)',2X,
27523 & 'IRRES(1) /NEVT = ',F7.2,/,33X,'(CH2RES) IRRES(2) /',
27524 & 'NEVT = ',F7.2,/,43X,'LOMRES /NEVT = ',F7.2,/,
27525 & 43X,'LOBRES /NEVT = ',F7.2,/,1X,'Kinem. corr. of',
27526 & ' 2-chain systems (CHKINE) IRCHKI(1)/NEVT = ',F7.2,/,
27527 & 43X,'IRCHKI(2)/NEVT = ',F7.2,/,1X,'Diffraction',31X,
27528 & 'IRDIFF(1)/NEVT = ',F7.2,/,43X,'IRDIFF(2)/NEVT = ',
27529 & F7.2,/,1X,'Total no. of rej.',
27530 & ' in chain-systems treatment (GETCSY)',/,43X,
27531 & 'IRHHA /NEVT = ',F7.2,/,1X,'Fragmentation (EVTFRA)',
27532 & ' (not yet used!)',4X,'IRFRAG /NEVT = ',F7.2,/,
27533 & 1X,'Total no. of rej. in DPM-treatment of one event',
27534 & ' (EVENTA)',/,43X,'IREVT /NEVT = ',F7.2,/,1X,
27535 & 'Treatment of final nucleon conf.',10X,'IREXCI(1)/NEVT = '
27536 & ,F7.2,/,43X,'IREXCI(2)/NEVT = ',F7.2,/,48X,
27537 & 'IREXCI(3) = ',I5,/)
27538 ELSEIF (MCGENE.EQ.2) THEN
27539 WRITE(LOUT,1010) ELOJET
27540 1010 FORMAT(/,/,1X,'PHOJET-treatment of chain systems above ',
27543 1011 FORMAT(/,1X,'1. chain system statistics - total numbers:',/,
27544 & 30X,'--------------',/,/,12X,'s-s',5X,'d-s',5X,'s-d',
27545 & 5X,'s-v',5X,'d-v',5X,'v-s',5X,'v-d',5X,'v-v')
27546 WRITE(LOUT,1012) ((ICEVTG(I,J),I=1,8),J=0,1),
27547 & (INT(ICCHAI(2,I)/2.0D0),I=1,8),
27548 & (ICEVTG(I,2),I=1,8),(ICEVTG(I,29),I=1,8),
27549 & ((ICEVTG(I,J),I=1,8),J=3,7),
27550 & ((ICEVTG(I,J),I=1,8),J=19,21),
27551 & (ICEVTG(I,8),I=1,8),
27552 & ((ICEVTG(I,J),I=1,8),J=22,24),
27553 & (ICEVTG(I,9),I=1,8),
27554 & ((ICEVTG(I,J),I=1,8),J=25,28),
27555 & ((ICEVTG(I,J),I=1,8),J=10,18)
27556 1012 FORMAT(/,1X,'req.to.',8I8,/,/,1X,'low rq.',8I8,/,1X,'low ac.',
27557 & 8I8,/,/,1X,'PHOJET ',8I8,/,' sngl ',8I8,/,/,
27558 & ' no-dif.',8I8,/,
27559 & ' el-sca.',8I8,/,' qel-sc.',8I8,/,' dbl-Po.',8I8,/,
27560 & ' diff-1 ',8I8,/,' low ',8I8,/,' high ',8I8,/,
27561 & ' h-diff',8I8,/,' diff-2 ',8I8,/,' low ',8I8,/,
27562 & ' high ',8I8,/,' h-diff',8I8,/,' dbl-di.',8I8,/,
27563 & ' lo-lo ',8I8,/,' hi-hi ',8I8,/,' lo-hi ',8I8,/,
27565 & ' dir-ga.',8I8,/,/,' dir-1 ',8I8,/,' dir-2 ',8I8,/,
27566 & ' dbl-dir',8I8,/,' s-Pom. ',8I8,/,' h-Pom. ',8I8,/,
27567 & ' s-Reg. ',8I8,/,' enh-trg',8I8,/,' enh-log',8I8)
27569 1013 FORMAT(/,1X,'2. chain system statistics -',
27570 & ' mean numbers per evt:',/,30X,'---------------------',
27571 & /,/,16X,'s-s',7X,'d-s',7X,'s-d')
27573 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=0,1),
27574 & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=1,3),
27575 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=2,18)
27576 1014 FORMAT(/,1X,'req.to. ',3E10.2,/,/,1X,'low rq. ',3E10.2,/,
27577 & 1X,'low ac. ',3E10.2,/,/,1X,'PHOJET ',3E10.2,/,/,
27578 & ' no-dif. ',3E10.2,/,' el-sca. ',3E10.2,/,
27579 & ' qel-sc. ',3E10.2,/,' dbl-Po. ',3E10.2,/,
27580 & ' diff-1 ',3E10.2,/,' diff-2 ',3E10.2,/,
27581 & ' dbl-di. ',3E10.2,/,' dir-ga. ',3E10.2,/,/,
27582 & ' dir-1 ',3E10.2,/,' dir-2 ',3E10.2,/,
27583 & ' dbl-dir ',3E10.2,/,' s-Pom. ',3E10.2,/,
27584 & ' h-Pom. ',3E10.2,/,' s-Reg. ',3E10.2,/,
27585 & ' enh-trg ',3E10.2,/,' enh-log ',3E10.2)
27587 1015 FORMAT(/,16X,'s-v',7X,'d-v',7X,'v-s',7X,'v-d',7X,'v-v')
27589 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=0,1),
27590 & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=4,8),
27591 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=2,18)
27592 1016 FORMAT(/,1X,'req.to. ',5E10.2,/,/,1X,'low rq. ',5E10.2,/,
27593 & 1X,'low ac. ',5E10.2,/,/,1X,'PHOJET ',5E10.2,/,/,
27594 & ' no-dif. ',5E10.2,/,' el-sca. ',5E10.2,/,
27595 & ' qel-sc. ',5E10.2,/,' dbl-Po. ',5E10.2,/,
27596 & ' diff-1 ',5E10.2,/,' diff-2 ',5E10.2,/,
27597 & ' dbl-di. ',5E10.2,/,' dir-ga. ',5E10.2,/,/,
27598 & ' dir-1 ',5E10.2,/,' dir-2 ',5E10.2,/,
27599 & ' dbl-dir ',5E10.2,/,' s-Pom. ',5E10.2,/,
27600 & ' h-Pom. ',5E10.2,/,' s-Reg. ',5E10.2,/,
27601 & ' enh-trg ',5E10.2,/,' enh-log ',5E10.2)
27606 IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
27607 & .OR.(PDBSEA(3).GT.0.0D0)) THEN
27608 WRITE(LOUT,*)'YGS1S,YGS2S,YUS1S,YUS2S',
27609 & DBRKA(1,1)+DBRKA(2,1),DBRKA(1,2)+DBRKA(2,2),
27610 & DBRKA(1,3)+DBRKA(2,3),DBRKA(1,4)+DBRKA(2,4)
27611 WRITE(LOUT,*)'YGS1R,YGS2R,YUS1R,YUS2R',
27612 & DBRKR(1,1)+DBRKR(2,1),DBRKR(1,2)+DBRKR(2,2),
27613 & DBRKR(1,3)+DBRKR(2,3),DBRKR(1,4)+DBRKR(2,4)
27614 WRITE(LOUT,*)'YGSA1S,YGSA2S,YUSA1S,YUSA2S',
27615 & DBRKA(1,5)+DBRKA(2,5),DBRKA(1,6)+DBRKA(2,6),
27616 & DBRKA(1,7)+DBRKA(2,7),DBRKA(1,8)+DBRKA(2,8)
27617 WRITE(LOUT,*)'YGSA1R,YGSA2R,YUSA1R,YUSA2R',
27618 & DBRKR(1,5)+DBRKR(2,5),DBRKR(1,6)+DBRKR(2,6),
27619 & DBRKR(1,7)+DBRKR(2,7),DBRKR(1,8)+DBRKR(2,8)
27620 WRITE(LOUT,*)'YG31S,YG32S,YU31S,YU32S',
27621 & DBRKA(3,1),DBRKA(3,2),
27622 & DBRKA(3,3),DBRKA(3,4)
27623 WRITE(LOUT,*)'YG31R,YG32R,YU31R,YU32R',
27624 & DBRKR(3,1),DBRKR(3,2),
27625 & DBRKR(3,3),DBRKR(3,4)
27626 WRITE(LOUT,*)'YG3A1S,YG3A2S,YU3A1S,YU3A2S',
27627 & DBRKA(3,5),DBRKA(3,6),
27628 & DBRKA(3,7),DBRKA(3,8)
27629 WRITE(LOUT,*)'YG3A1R,YG3A2R,YU3A1R,YU3A2R',
27630 & DBRKR(3,5),DBRKR(3,6),
27631 & DBRKR(3,7),DBRKR(3,8)
27635 IF (MCGENE.EQ.2) THEN
27637 C CALL PHO_PHIST(-2,SIGMAX)
27638 CALL PHO_EVENT(-2,PP,PT,FAC,IREJ1)
27647 *$ CREATE DT_EVTOUT.FOR
27650 *===evtout=============================================================*
27652 SUBROUTINE DT_EVTOUT(MODE)
27654 ************************************************************************
27655 * MODE = 1 plot content of complete DTEVT1 to out. unit *
27656 * 3 plot entries of extended DTEVT1 (DTEVT2) *
27657 * 4 plot entries of DTEVT1 and DTEVT2 *
27658 * This version dated 11.12.94 is written by S. Roesler *
27659 ************************************************************************
27661 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27664 PARAMETER ( LINP = 10 ,
27670 PARAMETER (NMXHKK=200000)
27672 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27673 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27674 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27676 DIMENSION IRANGE(NMXHKK)
27678 IF (MODE.EQ.2) RETURN
27680 CALL DT_EVTPLO(IRANGE,MODE)
27685 *$ CREATE DT_EVTPLO.FOR
27688 *===evtplo=============================================================*
27690 SUBROUTINE DT_EVTPLO(IRANGE,MODE)
27692 ************************************************************************
27693 * MODE = 1 plot content of complete DTEVT1 to out. unit *
27694 * 2 plot entries of DTEVT1 given by IRANGE *
27695 * 3 plot entries of extended DTEVT1 (DTEVT2) *
27696 * 4 plot entries of DTEVT1 and DTEVT2 *
27697 * 5 plot rejection counter *
27698 * This version dated 11.12.94 is written by S. Roesler *
27699 ************************************************************************
27701 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27704 PARAMETER ( LINP = 10 ,
27712 PARAMETER (NMXHKK=200000)
27714 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27715 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27716 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27718 * extended event history
27719 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27720 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27723 * rejection counter
27724 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27725 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27726 & IREXCI(3),IRDIFF(2),IRINC
27728 DIMENSION IRANGE(NMXHKK)
27730 IF ((MODE.EQ.1).OR.(MODE.EQ.4)) THEN
27732 1000 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTEVT1/',/,
27733 & 15X,' --------------------------',/,/,
27734 & ' ST ID M1 M2 D1 D2 PX PY',
27737 WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27738 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27739 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
27741 C WRITE(LOUT,1011) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27742 C & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27743 C & PHKK(3,I),PHKK(4,I)
27744 C WRITE(LOUT,'(4E15.4)')
27745 C & VHKK(1,I),VHKK(2,I),VHKK(3,I),VHKK(4,I)
27746 1001 FORMAT(I5,I5,I6,4I5,3F7.3,F8.3,F8.4)
27747 1011 FORMAT(I5,I5,I6,4I5,2E15.5)
27751 C WRITE(LOUT,1006) I,ISTHKK(I),
27752 C & VHKK(1,I),VHKK(2,I),VHKK(3,I),WHKK(1,I),
27753 C & WHKK(2,I),WHKK(3,I)
27754 C1006 FORMAT(1X,I4,I6,6E10.3)
27758 IF (MODE.EQ.2) THEN
27763 IF (IRANGE(NC).EQ.-100) GOTO 9999
27765 WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27766 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27767 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
27772 IF ((MODE.EQ.3).OR.(MODE.EQ.4)) THEN
27774 1002 FORMAT(/,1X,'EVTPLO:',14X,
27775 & ' content of COMMON /DTEVT1/,/DTEVT2/',/,
27776 & 15X,' -----------------------------------',/,/,
27777 & ' ST ID M1 M2 D1 D2 IDR IDXR',
27778 & ' NOBAM IDCH M',/)
27780 C IF ((ISTHKK(I).GT.10).OR.(ISTHKK(I).EQ.1)) THEN
27783 IF ((((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
27784 & (KF.NE.80000)).OR.(IDHKK(I).EQ.99999)) KF = 92
27786 CALL PYNAME(KF,CHAU)
27788 WRITE(LOUT,1003) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27789 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27790 & IDRES(I),IDXRES(I),NOBAM(I),IDCH(I),
27792 1003 FORMAT(I5,I5,I6,4I5,4I4,F8.4,2X,A)
27797 IF (MODE.EQ.5) THEN
27799 1004 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTREJC/',/,
27800 & 15X,' --------------------------',/)
27801 WRITE(LOUT,1005) IRPT,IRHHA,IRRES,LOMRES,LOBRES,IREMC,IRFRAG,
27803 1005 FORMAT(1X,'IRPT = ',I5,' IRHHA = ',I5,/,
27804 & 1X,'IRRES = ',2I5,' LOMRES = ',I5,' LOBRES = ',I5,/,
27805 & 1X,'IREMC = ',10I5,/,
27806 & 1X,'IRFRAG = ',I5,' IRSEA = ',I5,' IRCRON = ',I5,/)
27812 *$ CREATE DT_EVTPUT.FOR
27815 *===evtput=============================================================*
27817 SUBROUTINE DT_EVTPUT(IST,ID,M1,M2,PX,PY,PZ,E,IDR,IDXR,IDC)
27819 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27822 PARAMETER ( LINP = 10 ,
27826 PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,TINY3=1.0D-3,
27827 & TINY2=1.0D-2,SQTINF=1.0D+15,ZERO=0.0D0)
27831 PARAMETER (NMXHKK=200000)
27833 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27834 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27835 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27837 * extended event history
27838 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27839 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27842 * Lorentz-parameters of the current interaction
27843 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
27844 & UMO,PPCM,EPROJ,PPROJ
27846 * particle properties (BAMJET index convention)
27848 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
27849 & IICH(210),IIBAR(210),K1(210),K2(210)
27851 C IF (MODE.GT.100) THEN
27852 C WRITE(LOUT,'(1X,A,I5,A,I5)')
27853 C & 'EVTPUT: reset NHKK = ',NHKK,' to NHKK =',NHKK-MODE+100
27854 C NHKK = NHKK-MODE+100
27861 IF (NHKK.GT.NMXHKK) THEN
27862 WRITE(LOUT,1000) NHKK
27863 1000 FORMAT(1X,'EVTPUT: NHKK exeeds NMXHKK = ',I7,
27864 & '! program execution stopped..')
27867 IF (M1.LT.0) MO1 = NHKK+M1
27868 IF (M2.LT.0) MO2 = NHKK+M2
27871 JMOHKK(1,NHKK) = MO1
27872 JMOHKK(2,NHKK) = MO2
27876 IDXRES(NHKK) = IDXR
27878 ** here we need to do something..
27879 IF (ID.EQ.88888) THEN
27880 IDMO1 = ABS(IDHKK(MO1))
27881 IDMO2 = ABS(IDHKK(MO2))
27882 IF ((IDMO1.LT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 3
27883 IF ((IDMO1.LT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 4
27884 IF ((IDMO1.GT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 5
27885 IF ((IDMO1.GT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 6
27889 IDBAM(NHKK) = IDT_ICIHAD(ID)
27891 IF (JDAHKK(1,MO1).NE.0) THEN
27892 JDAHKK(2,MO1) = NHKK
27894 JDAHKK(1,MO1) = NHKK
27898 IF (JDAHKK(1,MO2).NE.0) THEN
27899 JDAHKK(2,MO2) = NHKK
27901 JDAHKK(1,MO2) = NHKK
27904 C IF ((IDBAM(NHKK).GT.0).AND.(IDBAM(NHKK).NE.7)) THEN
27905 C PTOT = SQRT(PX**2+PY**2+PZ**2)
27906 C AM0 = SQRT(ABS( (E-PTOT)*(E+PTOT) ))
27907 C AMRQ = AAM(IDBAM(NHKK))
27908 C AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
27909 C IF ((ABS(AMDIF2).GT.TINY3).AND.(E.LT.SQTINF).AND.
27910 C & (PTOT.GT.ZERO)) THEN
27911 C DELTA = -AMDIF2/(2.0D0*(E+PTOT))
27912 CC DELTA = (AMRQ2-AM2)/(2.0D0*(E+PTOT))
27914 C PTOT1 = PTOT-DELTA
27915 C PX = PX*PTOT1/PTOT
27916 C PY = PY*PTOT1/PTOT
27917 C PZ = PZ*PTOT1/PTOT
27924 PTOT = SQRT( PX**2+PY**2+PZ**2 )
27925 IF ((IDHKK(NHKK).GE.22).AND.(IDHKK(NHKK).LE.24)) THEN
27926 PHKK(5,NHKK) = PHKK(4,NHKK)**2-PTOT**2
27927 PHKK(5,NHKK) = SIGN(SQRT(ABS(PHKK(5,NHKK))),PHKK(5,NHKK))
27929 PHKK(5,NHKK) = (PHKK(4,NHKK)-PTOT)*(PHKK(4,NHKK)+PTOT)
27930 C IF ((PHKK(5,NHKK).LT.0.0D0).AND.(ABS(PHKK(5,NHKK)).GT.TINY4))
27931 C & WRITE(LOUT,'(1X,A,G10.3)')
27932 C & 'EVTPUT: negative mass**2 ',PHKK(5,NHKK)
27933 PHKK(5,NHKK) = SQRT(ABS(PHKK(5,NHKK)))
27936 IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.(ID.NE.80000)) THEN
27937 * special treatment for chains:
27938 * z coordinate of chain in Lab = pos. of target nucleon
27939 * time of chain-creation in Lab = time of passage of projectile
27940 * nucleus at pos. of taget nucleus
27941 C VHKK(1,NHKK) = 0.5D0*(VHKK(1,MO1)+VHKK(1,MO2))
27942 C VHKK(2,NHKK) = 0.5D0*(VHKK(2,MO1)+VHKK(2,MO2))
27943 VHKK(1,NHKK) = VHKK(1,MO2)
27944 VHKK(2,NHKK) = VHKK(2,MO2)
27945 VHKK(3,NHKK) = VHKK(3,MO2)
27946 VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
27947 C WHKK(1,NHKK) = 0.5D0*(WHKK(1,MO1)+WHKK(1,MO2))
27948 C WHKK(2,NHKK) = 0.5D0*(WHKK(2,MO1)+WHKK(2,MO2))
27949 WHKK(1,NHKK) = WHKK(1,MO1)
27950 WHKK(2,NHKK) = WHKK(2,MO1)
27951 WHKK(3,NHKK) = WHKK(3,MO1)
27952 WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
27956 VHKK(I,NHKK) = VHKK(I,MO1)
27957 WHKK(I,NHKK) = WHKK(I,MO1)
27961 VHKK(I,NHKK) = ZERO
27962 WHKK(I,NHKK) = ZERO
27970 *$ CREATE DT_CHASTA.FOR
27973 *===chasta=============================================================*
27975 SUBROUTINE DT_CHASTA(MODE)
27977 ************************************************************************
27978 * This subroutine performs CHAin STAtistics and checks sequence of *
27979 * partons in dtevt1 and sorts them with projectile partons coming *
27980 * first if necessary. *
27982 * This version dated 8.5.00 is written by S. Roesler. *
27983 ************************************************************************
27985 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27988 PARAMETER ( LINP = 10 ,
27996 PARAMETER (NMXHKK=200000)
27998 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27999 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28000 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28002 * extended event history
28003 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28004 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28007 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
28008 PARAMETER (MAXCHN=10000)
28009 COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
28011 DIMENSION ICHCFG(10,10,9,2),ICHTYP(5,5),
28012 & CCHTYP(9),ICHSTA(10),ITOT(10)
28013 DATA ICHCFG /1800*0/
28014 DATA (ICHTYP(1,K),K=1,5) / 0, 1, 3, 0, 0/
28015 DATA (ICHTYP(2,K),K=1,5) / 2, 0, 0, 5, 0/
28016 DATA (ICHTYP(3,K),K=1,5) / 4, 0, 0, 7, 0/
28017 DATA (ICHTYP(4,K),K=1,5) / 0, 6, 8, 0, 0/
28018 DATA (ICHTYP(5,K),K=1,5) / 0, 0, 0, 0, 9/
28019 DATA ICHSTA / 21, 22, 31, 32, 41, 42, 51, 52, 61, 62/
28020 DATA CCHTYP / ' q aq','aq q ',' q d ',' d q ','aq ad',
28021 & 'ad aq',' d ad','ad d ',' g g '/
28025 IF (MODE.EQ.-1) THEN
28028 * loop over DTEVT1 and analyse chain configurations
28030 ELSEIF (MODE.EQ.0) THEN
28031 DO 21 IDX=NPOINT(3),NHKK
28032 IDCHK = IDHKK(IDX)/10000
28033 IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
28034 & (IDHKK(IDX).NE.80000).AND.
28035 & (ISTHKK(IDX).NE.2).AND.(IDRES(IDX).EQ.0)) THEN
28036 IF (JMOHKK(1,IDX).GT.JMOHKK(2,IDX)) THEN
28037 WRITE(LOUT,*) ' CHASTA: JMOHKK(1,x) > JMOHKK(2,x) ',
28042 IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28043 IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28045 IMO1 = IST1-10*IMO1
28047 IMO2 = IST2-10*IMO2
28048 * swop parton entries if necessary since we need projectile partons
28049 * to come first in the common
28050 IF (IMO1.GT.IMO2) THEN
28051 NPTN = JMOHKK(2,IDX)-JMOHKK(1,IDX)+1
28053 I0 = JMOHKK(1,IDX)-1+K
28054 I1 = JMOHKK(2,IDX)+1-K
28056 ISTHKK(I0) = ISTHKK(I1)
28059 IDHKK(I0) = IDHKK(I1)
28061 IF (JDAHKK(1,JMOHKK(1,I0)).EQ.I0)
28062 & JDAHKK(1,JMOHKK(1,I0)) = I1
28063 IF (JDAHKK(2,JMOHKK(1,I0)).EQ.I0)
28064 & JDAHKK(2,JMOHKK(1,I0)) = I1
28065 IF (JDAHKK(1,JMOHKK(2,I0)).EQ.I0)
28066 & JDAHKK(1,JMOHKK(2,I0)) = I1
28067 IF (JDAHKK(2,JMOHKK(2,I0)).EQ.I0)
28068 & JDAHKK(2,JMOHKK(2,I0)) = I1
28069 IF (JDAHKK(1,JMOHKK(1,I1)).EQ.I1)
28070 & JDAHKK(1,JMOHKK(1,I1)) = I0
28071 IF (JDAHKK(2,JMOHKK(1,I1)).EQ.I1)
28072 & JDAHKK(2,JMOHKK(1,I1)) = I0
28073 IF (JDAHKK(1,JMOHKK(2,I1)).EQ.I1)
28074 & JDAHKK(1,JMOHKK(2,I1)) = I0
28075 IF (JDAHKK(2,JMOHKK(2,I1)).EQ.I1)
28076 & JDAHKK(2,JMOHKK(2,I1)) = I0
28077 ITMP = JMOHKK(1,I0)
28078 JMOHKK(1,I0) = JMOHKK(1,I1)
28079 JMOHKK(1,I1) = ITMP
28080 ITMP = JMOHKK(2,I0)
28081 JMOHKK(2,I0) = JMOHKK(2,I1)
28082 JMOHKK(2,I1) = ITMP
28083 ITMP = JDAHKK(1,I0)
28084 JDAHKK(1,I0) = JDAHKK(1,I1)
28085 JDAHKK(1,I1) = ITMP
28086 ITMP = JDAHKK(2,I0)
28087 JDAHKK(2,I0) = JDAHKK(2,I1)
28088 JDAHKK(2,I1) = ITMP
28093 PHKK(J,I0) = PHKK(J,I1)
28094 VHKK(J,I0) = VHKK(J,I1)
28095 WHKK(J,I0) = WHKK(J,I1)
28101 PHKK(5,I0) = PHKK(5,I1)
28104 IDRES(I0) = IDRES(I1)
28107 IDXRES(I0) = IDXRES(I1)
28110 NOBAM(I0) = NOBAM(I1)
28113 IDBAM(I0) = IDBAM(I1)
28116 IDCH(I0) = IDCH(I1)
28119 IHIST(1,I0) = IHIST(1,I1)
28122 IHIST(2,I0) = IHIST(2,I1)
28126 IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28127 IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28129 * parton 1 (projectile side)
28130 IF (IST1.EQ.21) THEN
28132 ELSEIF (IST1.EQ.22) THEN
28134 ELSEIF (IST1.EQ.31) THEN
28136 ELSEIF (IST1.EQ.32) THEN
28138 ELSEIF (IST1.EQ.41) THEN
28140 ELSEIF (IST1.EQ.42) THEN
28142 ELSEIF (IST1.EQ.51) THEN
28144 ELSEIF (IST1.EQ.52) THEN
28146 ELSEIF (IST1.EQ.61) THEN
28148 ELSEIF (IST1.EQ.62) THEN
28152 c & ' CHASTA: unknown parton status flag (',
28153 c & IST1,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28156 ID = IDHKK(JMOHKK(1,IDX))
28157 IF (ABS(ID).LE.4) THEN
28163 ELSEIF (ABS(ID).GE.1000) THEN
28169 ELSEIF (ID.EQ.21) THEN
28173 & ' CHASTA: inconsistent parton identity (',
28174 & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28178 * parton 2 (target side)
28179 IF (IST2.EQ.21) THEN
28181 ELSEIF (IST2.EQ.22) THEN
28183 ELSEIF (IST2.EQ.31) THEN
28185 ELSEIF (IST2.EQ.32) THEN
28187 ELSEIF (IST2.EQ.41) THEN
28189 ELSEIF (IST2.EQ.42) THEN
28191 ELSEIF (IST2.EQ.51) THEN
28193 ELSEIF (IST2.EQ.52) THEN
28195 ELSEIF (IST2.EQ.61) THEN
28197 ELSEIF (IST2.EQ.62) THEN
28201 c & ' CHASTA: unknown parton status flag (',
28202 c & IST2,') at entry ',JMOHKK(2,IDX),'(',IDX,')'
28205 ID = IDHKK(JMOHKK(2,IDX))
28206 IF (ABS(ID).LE.4) THEN
28212 ELSEIF (ABS(ID).GE.1000) THEN
28218 ELSEIF (ID.EQ.21) THEN
28222 & ' CHASTA: inconsistent parton identity (',
28223 & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28228 ITYPE = ICHTYP(ITYP1,ITYP2)
28229 IF (ITYPE.NE.0) THEN
28230 ICHCFG(IDX1,IDX2,ITYPE,1) =ICHCFG(IDX1,IDX2,ITYPE,1)+1
28231 NGLUON = JMOHKK(2,IDX)-JMOHKK(1,IDX)-1
28232 ICHCFG(IDX1,IDX2,ITYPE,2) =
28233 & ICHCFG(IDX1,IDX2,ITYPE,2)+NGLUON
28236 IF (NCHAIN.GT.MAXCHN) THEN
28237 WRITE(LOUT,*) ' CHASTA: NCHAIN > MAXCHN ! ',
28241 IDXCHN(1,NCHAIN) = IDX
28242 IDXCHN(2,NCHAIN) = ITYPE
28245 & ' CHASTA: inconsistent chain at entry ',IDX
28251 * write statistics to output unit
28253 ELSEIF (MODE.EQ.1) THEN
28254 WRITE(LOUT,'(/,A)') ' CHASTA: generated chain configurations'
28256 WRITE(LOUT,'(/,2A)')
28257 & ' -----------------------------------------',
28258 & '------------------------------------'
28260 & ' p\\t 21 22 31 32 41',
28261 & ' 42 51 52 61 62'
28263 & ' -----------------------------------------',
28264 & '------------------------------------'
28268 ITOT(J) = ITOT(J)+ICHCFG(I,J,K,1)
28271 WRITE(LOUT,'(1X,I2,5X,10I7,/)') ICHSTA(I),(ITOT(J),J=1,10)
28275 ISUM = ISUM+ICHCFG(I,J,K,1)
28278 & WRITE(LOUT,'(1X,A5,2X,10I7)')
28279 & CCHTYP(K),(ICHCFG(I,J,K,1),J=1,10)
28281 C WRITE(LOUT,'(2A)')
28282 C & ' -----------------------------------------',
28283 C & '-------------------------------'
28287 WRITE(LOUT,*) ' CHASTA: MODE ',MODE,' not supported !'
28293 *$ CREATE PHO_PHIST.FOR
28296 *===pohist=============================================================*
28298 SUBROUTINE PHO_PHIST(IMODE,WEIGHT)
28300 IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28303 PARAMETER ( LINP = 10 ,
28307 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
28309 * Glauber formalism: cross sections
28310 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
28311 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
28312 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
28313 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
28314 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
28315 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
28316 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
28317 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
28318 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
28319 & BSLOPE,NEBINI,NQBINI
28322 IF (IMODE.EQ.10) THEN
28326 IF (ABS(IMODE).LT.1000) THEN
28327 * PHOJET-statistics
28328 C CALL POHISX(IMODE,WEIGHT)
28329 IF (IMODE.EQ.-1) THEN
28331 XSTOT(1,1,1) = WEIGHT
28333 IF (IMODE.EQ. 1) MODE = 2
28334 IF (IMODE.EQ.-2) MODE = 3
28335 IF (MODE.EQ.2) CALL DT_SWPPHO(ILAB)
28336 C IF (MODE.EQ.3) WRITE(LOUT,*)
28337 C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization'
28338 CALL DT_HISTOG(MODE)
28339 CALL DT_USRHIS(MODE)
28341 * DTUNUC-statistics
28343 C IF (MODE.EQ.3) WRITE(LOUT,*)
28344 C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization'
28345 CALL DT_HISTOG(MODE)
28346 CALL DT_USRHIS(MODE)
28352 *$ CREATE DT_SWPPHO.FOR
28355 *===swppho=============================================================*
28357 SUBROUTINE DT_SWPPHO(ILAB)
28359 IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28362 PARAMETER ( LINP = 10 ,
28366 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28372 PARAMETER (NMXHKK=200000)
28374 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28375 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28376 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28378 * extended event history
28379 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28380 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28383 * flags for input different options
28384 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28385 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28386 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28388 * properties of photon/lepton projectiles
28389 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
28392 C PARAMETER (NMXHEP=2000)
28393 C COMMON/HEPEVS/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28394 C &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
28395 C COMMON /GLOCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28396 C COMMON /PLASAV/ PLAB
28398 C standard particle data interface
28401 PARAMETER (NMXHEP=4000)
28403 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28404 DOUBLE PRECISION PHEP,VHEP
28405 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28406 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28408 C extension to standard particle data interface (PHOJET specific)
28409 INTEGER IMPART,IPHIST,ICOLOR
28410 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28412 C global event kinematics and particle IDs
28413 INTEGER IFPAP,IFPAB
28414 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
28415 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28419 DATA LSTART /.TRUE./
28421 C IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0).AND.LSTART) THEN
28422 IF ((IFRAME.EQ.1).AND.LSTART) THEN
28426 IDP = IDT_ICIHAD(IFPAP(1))
28427 IDT = IDT_ICIHAD(IFPAP(2))
28429 CALL DT_LTINI(IDP,IDT,ELA,PLA,UMO,0)
28438 IF (MOD(ICOUNT,500).EQ.0) WRITE(LOUT,*)' SWPPHO: event # ',ICOUNT
28440 IF (ISTHEP(I).EQ.1) THEN
28443 IDHKK(NHKK) = IDHEP(I)
28449 PHKK(K,NHKK) = PHEP(K,I)
28450 VHKK(K,NHKK) = ZERO
28451 WHKK(K,NHKK) = ZERO
28453 IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0))
28454 & CALL DT_LTNUC(PHEP(3,I),PHEP(4,I),
28455 & PHKK(3,NHKK),PHKK(4,NHKK),-3)
28456 PHKK(5,NHKK) = PHEP(5,I)
28460 IDBAM(NHKK) = IDT_ICIHAD(IDHEP(I))
28468 *$ CREATE DT_HISTOG.FOR
28471 *===histog=============================================================*
28473 SUBROUTINE DT_HISTOG(MODE)
28475 ************************************************************************
28476 * This version dated 25.03.96 is written by S. Roesler *
28477 ************************************************************************
28479 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28482 PARAMETER ( LINP = 10 ,
28490 PARAMETER (NMXHKK=200000)
28492 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28493 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28494 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28496 * extended event history
28497 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28498 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28501 * event flag used for histograms
28502 COMMON /DTNORM/ ICEVT,IEVHKK
28504 * flags for activated histograms
28505 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
28510 *------------------------------------------------------------------
28514 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,1)
28515 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(1)
28518 *------------------------------------------------------------------
28519 * filling of histogram with event-record
28524 CALL DT_SWPFSP(I,LFSP,LRNL)
28526 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,2)
28527 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(2)
28529 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,5)
28531 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,4)
28534 *------------------------------------------------------------------
28537 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,3)
28538 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(3)
28543 *$ CREATE DT_SWPFSP.FOR
28546 *===swpfsp=============================================================*
28548 SUBROUTINE DT_SWPFSP(IDX,LFSP,LRNL)
28550 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28552 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28553 PARAMETER (TWOPI=6.283185307179586476925286766559D+00,
28555 & BOG =TWOPI/360.0D0)
28559 PARAMETER (NMXHKK=200000)
28561 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28562 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28563 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28565 * extended event history
28566 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28567 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28570 * particle properties (BAMJET index convention)
28572 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28573 & IICH(210),IIBAR(210),K1(210),K2(210)
28575 * Lorentz-parameters of the current interaction
28576 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28577 & UMO,PPCM,EPROJ,PPROJ
28579 * flags for input different options
28580 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28581 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28582 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28584 * INCLUDE '(DIMPAR)'
28586 PARAMETER ( MXXRGN =20000 )
28587 PARAMETER ( MXXMDF = 710 )
28588 PARAMETER ( MXXMDE = 702 )
28589 PARAMETER ( MFSTCK =40000 )
28590 PARAMETER ( MESTCK = 100 )
28591 PARAMETER ( MOSTCK = 2000 )
28592 PARAMETER ( MXPRSN = 100 )
28593 PARAMETER ( MXPDPM = 800 )
28594 PARAMETER ( MXPSCS =30000 )
28595 PARAMETER ( MXGLWN = 300 )
28596 PARAMETER ( MXOUTU = 50 )
28597 PARAMETER ( NALLWP = 64 )
28598 PARAMETER ( NELEMX = 80 )
28599 PARAMETER ( MPDPDX = 18 )
28600 PARAMETER ( MXHTTR = 260 )
28601 PARAMETER ( MXSEAX = 20 )
28602 PARAMETER ( MXHTNC = MXSEAX + 1 )
28603 PARAMETER ( ICOMAX = 2400 )
28604 PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
28605 PARAMETER ( NSTBIS = 304 )
28606 PARAMETER ( NQSTIS = 46 )
28607 PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
28608 PARAMETER ( MXPABL = 120 )
28609 PARAMETER ( IDMAXP = 450 )
28610 PARAMETER ( IDMXDC = 2000 )
28611 PARAMETER ( MXMCIN = 410 )
28612 PARAMETER ( IHYPMX = 4 )
28613 PARAMETER ( MKBMX1 = 11 )
28614 PARAMETER ( MKBMX2 = 11 )
28615 PARAMETER ( MXIRRD = 2500 )
28616 PARAMETER ( MXTRDC = 1500 )
28617 PARAMETER ( NKTL = 17 )
28618 PARAMETER ( NBLNMX = 40000000 )
28620 * INCLUDE '(PAREVT)'
28622 PARAMETER ( FRDIFF = 0.2D+00 )
28623 PARAMETER ( ETHSEA = 1.0D+00 )
28625 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
28626 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
28627 & LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR,
28628 & LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
28629 COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
28630 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
28631 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
28632 & LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LPHDRC,
28633 & LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, LRVKIN,
28634 & LVP2XX, LV2XNW, LNWV2X, LEVFIN
28636 * temporary storage for one final state particle
28637 LOGICAL LFRAG,LGREY,LBLACK
28638 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
28639 & SINTHE,COSTHE,THETA,THECMS,
28640 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
28641 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
28642 & LFRAG,LGREY,LBLACK
28650 IF (LEVPRT) ISTRNL = 1001
28652 IF (ABS(ISTHKK(IDX)).EQ.1) THEN
28656 IF (IDHKK(IDX).LT.80000) THEN
28658 IBARY = IIBAR(IDBJT)
28659 ICHAR = IICH(IDBJT)
28661 ELSEIF (IDHKK(IDX).EQ.80000) THEN
28664 ICHAR = IDXRES(IDX)
28665 AMASS = PHKK(5,IDX)
28667 IF ((ICHAR.EQ.1).AND.(INUT.EQ.1)) IDBJT = 116
28668 IF ((ICHAR.EQ.1).AND.(INUT.EQ.2)) IDBJT = 117
28669 IF ((ICHAR.EQ.2).AND.(INUT.EQ.1)) IDBJT = 118
28670 IF ((ICHAR.EQ.2).AND.(INUT.EQ.2)) IDBJT = 119
28671 IF (IDBJT.EQ.0) LFRAG = .TRUE.
28681 PTOT = SQRT(PT2+PZ**2)
28682 SINTHE = PT/MAX(PTOT,TINY14)
28683 COSTHE = PZ/MAX(PTOT,TINY14)
28684 IF (COSTHE.GT.ONE) THEN
28686 ELSEIF (COSTHE.LT.-ONE) THEN
28687 THETA = TWOPI/2.0D0
28689 THETA = ACOS(COSTHE)
28692 **sr 15.4.96 new E_t-definition
28693 IF (IBARY.GT.0) THEN
28695 ELSEIF (IBARY.LT.0) THEN
28696 ET = (EKIN+TWO*AMASS)*SINTHE
28701 XLAB = PZ/MAX(PPROJ,TINY14)
28702 C XLAB = PE/MAX(EPROJ,TINY14)
28703 BETA = SQRT(ABS( (ONE-AMASS/MAX(PE,TINY14))
28704 & *(ONE+AMASS/MAX(PE,TINY14)) ))
28707 IF (PMINUS.GT.TINY14) THEN
28708 YY = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28712 IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
28713 ETA = -LOG(TAN(THETA/TWO))
28717 IF (IFRAME.EQ.1) THEN
28718 CALL DT_LTNUC(PZ,PE,PZCMS,EECMS,3)
28719 PPLUS = EECMS+PZCMS
28720 PMINUS = EECMS-PZCMS
28721 IF ((PPLUS*PMINUS).GT.TINY14) THEN
28722 YYCMS = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28726 PTOTCM = SQRT(PT2+PZCMS**2)
28727 COSTH = PZCMS/MAX(PTOTCM,TINY14)
28728 IF (COSTH.GT.ONE) THEN
28730 ELSEIF (COSTH.LT.-ONE) THEN
28731 THECMS = TWOPI/2.0D0
28733 THECMS = ACOS(COSTH)
28735 IF ((THECMS.GT.TINY14).AND.((PI-THECMS).GT.TINY14)) THEN
28736 ETACMS = -LOG(TAN(THECMS/TWO))
28740 XF = PZCMS/MAX(PPCM,TINY14)
28741 THECMS = THECMS/BOG
28752 * set flag for "grey/black"
28756 IF (IDHKK(IDX).EQ.80000) EK = EKIN/DBLE(IBARY)
28757 IF (MULDEF.EQ.1) THEN
28759 IF ( ( (IDBJT.EQ. 1).AND.(EK.GT. 26.0D-3).AND.
28760 & (EK.LE.375.0D-3) ).OR.
28761 & ( (IDBJT.EQ.13).AND.(EK.GT. 12.0D-3).AND.
28762 & (EK.LE. 56.0D-3) ).OR.
28763 & ( (IDBJT.EQ.14).AND.(EK.GT. 12.0D-3).AND.
28764 & (EK.LE. 56.0D-3) ).OR.
28765 & ( (IDBJT.EQ.15).AND.(EK.GT. 20.0D-3).AND.
28766 & (EK.LE.198.0D-3) ).OR.
28767 & ( (IDBJT.EQ.16).AND.(EK.GT. 20.0D-3).AND.
28768 & (EK.LE.198.0D-3) ).OR.
28769 & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28770 & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28771 & (IDBJT.NE.16).AND.
28772 & (BETA.GT.0.23D0).AND.(BETA.LE.0.70D0) ) )
28774 IF ( ( (IDBJT.EQ. 1).AND.(EK.LE. 26.0D-3) ).OR.
28775 & ( (IDBJT.EQ.13).AND.(EK.LE. 12.0D-3) ).OR.
28776 & ( (IDBJT.EQ.14).AND.(EK.LE. 12.0D-3) ).OR.
28777 & ( (IDBJT.EQ.15).AND.(EK.LE. 20.0D-3) ).OR.
28778 & ( (IDBJT.EQ.16).AND.(EK.LE. 20.0D-3) ).OR.
28779 & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28780 & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28781 & (IDBJT.NE.16).AND.(BETA.LE.0.23D0) ) )
28785 IF ((BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)) LGREY=.TRUE.
28786 IF (BETA.LE.0.23D0) LBLACK=.TRUE.
28789 ELSEIF (ABS(ISTHKK(IDX)).EQ.ISTRNL) THEN
28795 ICHAR = IDXRES(IDX)
28796 AMASS = PHKK(5,IDX)
28803 PTOT = SQRT(PT2+PZ**2)
28804 SINTHE = PT/MAX(PTOT,TINY14)
28805 COSTHE = PZ/MAX(PTOT,TINY14)
28806 IF (COSTHE.GT.ONE) THEN
28808 ELSEIF (COSTHE.LT.-ONE) THEN
28809 THETA = TWOPI/2.0D0
28811 THETA = ACOS(COSTHE)
28814 **sr 15.4.96 new E_t-definition
28818 IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
28819 ETA = -LOG(TAN(THETA/TWO))
28831 *$ CREATE DT_HIMULT.FOR
28834 *===himult=============================================================*
28836 SUBROUTINE DT_HIMULT(MODE)
28838 ************************************************************************
28839 * Tables of average energies/multiplicities. *
28840 * This version dated 30.08.2000 is written by S. Roesler *
28841 ************************************************************************
28843 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28846 PARAMETER ( LINP = 10 ,
28850 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28852 PARAMETER (SWMEXP=1.7D0)
28854 CHARACTER*8 ANAMEH(4)
28856 * particle properties (BAMJET index convention)
28858 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28859 & IICH(210),IIBAR(210),K1(210),K2(210)
28861 * temporary storage for one final state particle
28862 LOGICAL LFRAG,LGREY,LBLACK
28863 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
28864 & SINTHE,COSTHE,THETA,THECMS,
28865 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
28866 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
28867 & LFRAG,LGREY,LBLACK
28869 * event flag used for histograms
28870 COMMON /DTNORM/ ICEVT,IEVHKK
28872 * Lorentz-parameters of the current interaction
28873 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28874 & UMO,PPCM,EPROJ,PPROJ
28876 PARAMETER (NOPART=210)
28877 DIMENSION AVMULT(4,NOPART),AVE(4,NOPART),AVSWM(4,NOPART),
28878 & AVPT(4,NOPART),IAVPT(4,NOPART)
28879 DATA ANAMEH /'DEUTERON','3-H ','3-HE ','4-HE '/
28883 *------------------------------------------------------------------
28898 *------------------------------------------------------------------
28899 * filling of histogram with event-record
28901 IF (PE.LT.0.0D0) THEN
28902 WRITE(LOUT,*) ' HIMULT: PE < 0 ! ',PE
28905 IF (.NOT.LFRAG) THEN
28907 IF (LGREY) IVEL = 3
28908 IF (LBLACK) IVEL = 4
28909 AVE(1,IDBJT) = AVE(1,IDBJT) +PE
28910 AVE(IVEL,IDBJT) = AVE(IVEL,IDBJT)+PE
28911 AVPT(1,IDBJT) = AVPT(1,IDBJT) +PT
28912 AVPT(IVEL,IDBJT) = AVPT(IVEL,IDBJT)+PT
28913 IAVPT(1,IDBJT) = IAVPT(1,IDBJT) +1
28914 IAVPT(IVEL,IDBJT) = IAVPT(IVEL,IDBJT)+1
28915 AVSWM(1,IDBJT) = AVSWM(1,IDBJT) +PE**SWMEXP
28916 AVSWM(IVEL,IDBJT) = AVSWM(IVEL,IDBJT)+PE**SWMEXP
28917 AVMULT(1,IDBJT) = AVMULT(1,IDBJT) +ONE
28918 AVMULT(IVEL,IDBJT) = AVMULT(IVEL,IDBJT)+ONE
28919 IF (IDBJT.LT.116) THEN
28920 * total energy, multiplicity
28921 AVE(1,30) = AVE(1,30) +PE
28922 AVE(IVEL,30) = AVE(IVEL,30)+PE
28923 AVPT(1,30) = AVPT(1,30) +PT
28924 AVPT(IVEL,30) = AVPT(IVEL,30)+PT
28925 IAVPT(1,30) = IAVPT(1,30) +1
28926 IAVPT(IVEL,30) = IAVPT(IVEL,30)+1
28927 AVSWM(1,30) = AVSWM(1,30)+PE**SWMEXP
28928 AVSWM(IVEL,30) = AVSWM(IVEL,30)+PE**SWMEXP
28929 AVMULT(1,30) = AVMULT(1,30) +ONE
28930 AVMULT(IVEL,30) = AVMULT(IVEL,30)+ONE
28931 * charged energy, multiplicity
28932 IF (ICHAR.LT.0) THEN
28933 AVE(1,26) = AVE(1,26) +PE
28934 AVE(IVEL,26) = AVE(IVEL,26)+PE
28935 AVPT(1,26) = AVPT(1,26) +PT
28936 AVPT(IVEL,26) = AVPT(IVEL,26)+PT
28937 IAVPT(1,26) = IAVPT(1,26) +1
28938 IAVPT(IVEL,26) = IAVPT(IVEL,26)+1
28939 AVSWM(1,26) = AVSWM(1,26) +PE**SWMEXP
28940 AVSWM(IVEL,26) = AVSWM(IVEL,26)+PE**SWMEXP
28941 AVMULT(1,26) = AVMULT(1,26) +ONE
28942 AVMULT(IVEL,26) = AVMULT(IVEL,26)+ONE
28944 IF (ICHAR.NE.0) THEN
28945 AVE(1,27) = AVE(1,27) +PE
28946 AVE(IVEL,27) = AVE(IVEL,27)+PE
28947 AVPT(1,27) = AVPT(1,27) +PT
28948 AVPT(IVEL,27) = AVPT(IVEL,27)+PT
28949 IAVPT(1,27) = IAVPT(1,27) +1
28950 IAVPT(IVEL,27) = IAVPT(IVEL,27)+1
28951 AVSWM(1,27) = AVSWM(1,27) +PE**SWMEXP
28952 AVSWM(IVEL,27) = AVSWM(IVEL,27)+PE**SWMEXP
28953 AVMULT(1,27) = AVMULT(1,27) +ONE
28954 AVMULT(IVEL,27) = AVMULT(IVEL,27)+ONE
28961 *------------------------------------------------------------------
28965 3000 FORMAT(/,1X,'HIMULT:',21X,'particle - statistics',/,
28966 & 29X,'---------------------',/)
28967 IF (MULDEF.EQ.1) THEN
28968 WRITE(LOUT,'(1X,A,/)') 'fast/grey/black: EMU-def.'
28972 WRITE(LOUT,3002) BETGRE,BETGRE,BETBLC,BETBLC
28973 3002 FORMAT(1X,'fast: beta > ',F4.2,' grey: ',F4.2,' > beta > '
28974 & ,F4.2,' black: beta < ',F4.2,/)
28976 WRITE(LOUT,3003) SWMEXP
28977 3003 FORMAT(1X,'particle |',12X,'average multiplicity',/,
28978 & 13X,'| total fast',
28979 C & ' grey black K f(',F3.1,')',/,1X,
28980 & ' grey black <pt> f(',F3.1,')',/,1X,
28981 & '------------+--------------',
28982 & '-------------------------------------------------')
28985 AVMULT(J,I) = AVMULT(J,I)/DBLE(MAX(ICEVT,1))
28986 AVE(J,I) = AVE(J,I)/DBLE(MAX(ICEVT,1))/EPROJ
28987 AVPT(J,I) = AVPT(J,I)/DBLE(MAX(IAVPT(J,I),1))
28988 AVSWM(J,I) = AVSWM(J,I)/DBLE(MAX(ICEVT,1))/EPROJ**SWMEXP
28991 WRITE(LOUT,3004) ANAME(I),I,
28992 & AVMULT(1,I),AVMULT(2,I),
28993 & AVMULT(3,I),AVMULT(4,I),
28994 C & AVE(1,I),AVSWM(1,I)
28995 & AVPT(1,I),AVSWM(1,I)
28996 ELSEIF (I.LE.119) THEN
28997 WRITE(LOUT,3004) ANAMEH(I-115),I,
28998 & AVMULT(1,I),AVMULT(2,I),
28999 & AVMULT(3,I),AVMULT(4,I),
29000 C & AVE(1,I),AVSWM(1,I)
29001 & AVPT(1,I),AVSWM(1,I)
29003 3004 FORMAT(1X,A8,I4,'| ',2F13.6,2F9.5,2F9.5)
29006 C WRITE(LOUT,'(A,F7.3)') ' number of charged heavy particles: ',
29007 C & AVMULT(3,27)+AVMULT(4,27)
29013 *$ CREATE DT_HISTAT.FOR
29016 *===histat=============================================================*
29018 SUBROUTINE DT_HISTAT(IDX,MODE)
29020 ************************************************************************
29021 * This version dated 26.02.96 is written by S. Roesler *
29023 * Last change 27.12.2006 by S. Roesler. *
29024 ************************************************************************
29026 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29029 PARAMETER ( LINP = 10 ,
29033 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
29034 PARAMETER (NDIM=199)
29038 PARAMETER (NMXHKK=200000)
29040 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
29041 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
29042 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
29044 * extended event history
29045 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
29046 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
29049 * particle properties (BAMJET index convention)
29051 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29052 & IICH(210),IIBAR(210),K1(210),K2(210)
29054 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
29056 * Glauber formalism: cross sections
29057 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
29058 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
29059 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
29060 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
29061 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
29062 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
29063 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
29064 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
29065 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
29066 & BSLOPE,NEBINI,NQBINI
29068 * emulsion treatment
29069 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
29072 * properties of interacting particles
29073 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
29075 * rejection counter
29076 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
29077 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
29078 & IREXCI(3),IRDIFF(2),IRINC
29080 * statistics: residual nuclei
29081 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
29082 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
29083 & NINCST(2,4),NINCEV(2),
29084 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
29085 & NRESPB(2),NRESCH(2),NRESEV(4),
29086 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
29089 * parameter for intranuclear cascade
29091 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
29093 * INCLUDE '(DIMPAR)'
29095 PARAMETER ( MXXRGN =20000 )
29096 PARAMETER ( MXXMDF = 710 )
29097 PARAMETER ( MXXMDE = 702 )
29098 PARAMETER ( MFSTCK =40000 )
29099 PARAMETER ( MESTCK = 100 )
29100 PARAMETER ( MOSTCK = 2000 )
29101 PARAMETER ( MXPRSN = 100 )
29102 PARAMETER ( MXPDPM = 800 )
29103 PARAMETER ( MXPSCS =30000 )
29104 PARAMETER ( MXGLWN = 300 )
29105 PARAMETER ( MXOUTU = 50 )
29106 PARAMETER ( NALLWP = 64 )
29107 PARAMETER ( NELEMX = 80 )
29108 PARAMETER ( MPDPDX = 18 )
29109 PARAMETER ( MXHTTR = 260 )
29110 PARAMETER ( MXSEAX = 20 )
29111 PARAMETER ( MXHTNC = MXSEAX + 1 )
29112 PARAMETER ( ICOMAX = 2400 )
29113 PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
29114 PARAMETER ( NSTBIS = 304 )
29115 PARAMETER ( NQSTIS = 46 )
29116 PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
29117 PARAMETER ( MXPABL = 120 )
29118 PARAMETER ( IDMAXP = 450 )
29119 PARAMETER ( IDMXDC = 2000 )
29120 PARAMETER ( MXMCIN = 410 )
29121 PARAMETER ( IHYPMX = 4 )
29122 PARAMETER ( MKBMX1 = 11 )
29123 PARAMETER ( MKBMX2 = 11 )
29124 PARAMETER ( MXIRRD = 2500 )
29125 PARAMETER ( MXTRDC = 1500 )
29126 PARAMETER ( NKTL = 17 )
29127 PARAMETER ( NBLNMX = 40000000 )
29129 * INCLUDE '(PAREVT)'
29131 PARAMETER ( FRDIFF = 0.2D+00 )
29132 PARAMETER ( ETHSEA = 1.0D+00 )
29134 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
29135 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
29136 & LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR,
29137 & LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
29138 COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
29139 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
29140 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
29141 & LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LPHDRC,
29142 & LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, LRVKIN,
29143 & LVP2XX, LV2XNW, LNWV2X, LEVFIN
29145 * INCLUDE '(FRBKCM)'
29147 * Maximum number of fragments to be emitted:
29148 PARAMETER ( MXFFBK = 6 )
29149 PARAMETER ( MXZFBK = 10 )
29150 PARAMETER ( MXNFBK = 12 )
29151 PARAMETER ( MXAFBK = 16 )
29152 PARAMETER ( MXASST = 25 )
29153 PARAMETER ( NXAFBK = MXAFBK + 1 )
29154 PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 + MXASST - NXAFBK )
29155 PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 + MXASST - NXAFBK )
29156 PARAMETER ( MXPSST = 700 )
29157 * Maximum number of pre-computed break-up combinations
29158 PARAMETER ( MXPPFB = 42500 )
29159 * Maximum number of break-up combinations, including special
29161 PARAMETER ( MXPSFB = 43000 )
29162 * Base for J multiplicity encoding:
29163 PARAMETER ( IBFRBK = 73 )
29164 * Maximum Ibfrbk exponent to avoid overflow of I*4(roughly at 2.1x10^9)
29165 * it must be (Ibfrbk-1) + (Ibfrbk-1)*Ibfrbk + (Ibfrbk-1)*Ibfrbk^2 + ...
29166 * ... + (Ibfrbk-1)*Ibfrbk^Jpwfbx < 2100000000,
29167 * --> Ibfrbk^(Jpwfbx+1) < 2100000000
29168 PARAMETER ( JPWFBX = 4 )
29169 LOGICAL LFRMBK, LNCMSS
29170 COMMON / FRBKCM / AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
29171 & WEIFBK (MXPSST), GAMFBK (MXPSST), EXFRBK (MXPSFB),
29172 & SDMFBK (MXPSFB), COUFBK (MXPSFB), CENFBK (MXPSFB),
29173 & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK, FRBKLS,
29174 & IFRBKN (MXPSST), IFRBKZ (MXPSST),
29175 & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
29176 & IPSIND (0:NXNFBK,0:NXZFBK,2), JPSIND (0:MXASST),
29177 & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
29178 & IFBCHA (9,MXPSFB), IPOSST, IPOSFB, IFBSTF, IFBPSF,
29179 & IFBFRB, IFBCHN, IFBNC1, IFBNC2, NBUFBK, LFRMBK, LNCMSS
29181 * INCLUDE '(EVAFLG)'
29183 LOGICAL LOLDEV, LUFULL, LNWLOW, LASMEN, LGMCMP, LGDRFT, LDSCLV,
29184 & LDSCGM, LNDSLD, LMNJPR, LBRPEN, LNWBRP, LIFKEY, LOLDSM,
29185 & LNAIPR, LGUSPR, LFLKCO, LLVMOD, LHVEVP, LHVECN, LHVCAL,
29186 & LHVRAL, LHVSGF, LTMCRR, LBZZCR, LQCSKP
29187 COMMON / EVAFLG / BRPNFR (0:2), EBRPFR (0:2), EMVBRP (0:2),
29188 & ILVMOD, JLVMOD, JSIPFL, IMSSFR, JMSSFR, IEVFSS, MXAHEV,
29189 & MXZHEV, IFHVFL, IFKYMX, IGMCMP, MPMODE, MSMODE, MUMODE,
29190 & MFMODE, MEMODE, MRMODE, ITMCRR, IASYCR, IFSBCR, IFSSBR,
29191 & LOLDEV, LUFULL, LNWLOW, LASMEN, LGMCMP, LGDRFT, LDSCLV,
29192 & LDSCGM, LNDSLD, LMNJPR, LBRPEN, LNWBRP, LIFKEY, LOLDSM,
29193 & LNAIPR, LGUSPR, LFLKCO, LLVMOD, LHVEVP, LHVECN, LHVCAL,
29194 & LHVRAL, LHVSGF, LTMCRR, LBZZCR, LQCSKP
29196 * temporary storage for one final state particle
29197 LOGICAL LFRAG,LGREY,LBLACK
29198 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
29199 & SINTHE,COSTHE,THETA,THECMS,
29200 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
29201 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
29202 & LFRAG,LGREY,LBLACK
29204 * event flag used for histograms
29205 COMMON /DTNORM/ ICEVT,IEVHKK
29207 * statistics: double-Pomeron exchange
29208 COMMON /DTFLG2/ INTFLG,IPOPO
29210 DIMENSION EMUSAM(NCOMPX)
29212 CHARACTER*13 CMSG(3)
29213 DATA CMSG /'not requested','not requested','not requested'/
29215 GOTO (1,2,3,4,5) MODE
29217 *------------------------------------------------------------------
29220 * emulsion treatment
29221 IF (NCOMPO.GT.0) THEN
29226 * common /DTSTA2/, statistics on i.n.c., residual nuclei, evap.
29247 IF (J.LE.2) NINCHR(I,J) = 0
29248 IF (J.LE.3) NINCCO(I,J) = 0
29249 IF (J.LE.4) NINCST(I,J) = 0
29258 **dble Po statistics.
29262 *------------------------------------------------------------------
29263 * filling of histogram with event-record
29265 IF (IST.EQ.-1) THEN
29266 IF (.NOT.LFRAG) THEN
29267 IF (IDPDG.EQ.2212) THEN
29268 NEVA(NOBAM(IDX),1) = NEVA(NOBAM(IDX),1)+1
29269 ELSEIF (IDPDG.EQ.2112) THEN
29270 NEVA(NOBAM(IDX),2) = NEVA(NOBAM(IDX),2)+1
29271 ELSEIF (IDPDG.EQ.22) THEN
29272 NEVAGA(NOBAM(IDX)) = NEVAGA(NOBAM(IDX))+1
29273 ELSEIF (IDPDG.EQ.80000) THEN
29274 IF (IDBJT.EQ.116) THEN
29275 NEVA(NOBAM(IDX),3) = NEVA(NOBAM(IDX),3)+1
29276 ELSEIF (IDBJT.EQ.117) THEN
29277 NEVA(NOBAM(IDX),4) = NEVA(NOBAM(IDX),4)+1
29278 ELSEIF (IDBJT.EQ.118) THEN
29279 NEVA(NOBAM(IDX),5) = NEVA(NOBAM(IDX),5)+1
29280 ELSEIF (IDBJT.EQ.119) THEN
29281 NEVA(NOBAM(IDX),6) = NEVA(NOBAM(IDX),6)+1
29285 * heavy fragments (here: fission products only)
29286 NEVAHY(NOBAM(IDX),1,IBARY) = NEVAHY(NOBAM(IDX),1,IBARY)+1
29287 NEVAHY(NOBAM(IDX),2,ICHAR) = NEVAHY(NOBAM(IDX),2,ICHAR)+1
29288 NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29290 ELSEIF ((IST.EQ.1).AND.(.NOT.LFRAG)) THEN
29291 IF (IDCH(IDX).GT.MAXGEN) MAXGEN = IDCH(IDX)
29295 *------------------------------------------------------------------
29299 **dble Po statistics.
29300 C WRITE(LOUT,'(1X,A,2I7,2E12.4)')
29301 C & '# evts. / # dble-Po. evts / s_in / s_popo :',
29302 C & ICEVT,KPOPO,XSPRO(1,1,1),XSPRO(1,1,1)*DBLE(KPOPO)/DBLE(ICEVT)
29304 * emulsion treatment
29305 IF (NCOMPO.GT.0) THEN
29307 3000 FORMAT(/,1X,'HISTAT:',14X,'statistics - target emulsion',/,
29308 & 22X,'----------------------------',/,/,19X,
29309 & 'mass charge fraction',/,39X,
29310 & 'input treated',/)
29312 WRITE(LOUT,3013) I,IEMUMA(I),IEMUCH(I),EMUFRA(I),
29313 & EMUSAM(I)/DBLE(ICEVT)
29314 3013 FORMAT(12X,I2,1X,2I8,6X,F7.3,5X,F7.3)
29318 * i.n.c. statistics: output
29319 WRITE(LOUT,3001) ICEVT,NRESEV(2),IRINC
29320 3001 FORMAT(/,1X,'HISTAT:',14X,'statistics - intranuclear cascade',/,
29321 & 22X,'---------------------------------',/,/,1X,
29322 & 'no. of events for normalization: (accepted final events,',
29323 & ' evt)',4X,I6,/,34X,'(events before evap.-step, evt1)',I6,
29324 & /,1X,'no. of rejected events due to intranuclear',
29325 & ' cascade',15X,I6,/)
29326 ICEV = MAX(ICEVT,1)
29328 IF (LEVPRT) ICEV1 = MAX(NRESEV(2),1)
29330 & (DBLE(NINCWO(I))/DBLE(ICEV),I=1,2),
29331 & ((DBLE(NINCST(I,J))/DBLE(ICEV),I=1,2),J=1,4),
29332 & KTAUGE,DBLE(NINCGE)/DBLE(ICEV),
29333 & (DBLE(NINCCO(I,1)+NINCCO(I,2)+NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29334 & (DBLE(NINCCO(I,2))/DBLE(ICEV1),I=1,2),
29335 & (DBLE(NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29336 & (DBLE(NINCCO(I,1))/DBLE(ICEV1),I=1,2)
29337 3002 FORMAT(1X,'no. of wounded nucl. in proj./ target (mean per evt)',
29338 & 5X,F6.2,' /',F6.2,/,1X,'no. of particles unable to escape',
29339 & ' proj./ target (mean per evt)',/,8X,'baryons: pos. ',
29340 & F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3,/,8X,
29341 & 'mesons: pos. ',F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3,
29342 & /,1X,'maximum no. of generations treated (maximum allowed:'
29343 & ,I4,')',/,43X,'(mean per evt)',5X,F6.2,/,1X,'no. of sec.',
29344 & ' interactions in proj./ target (mean per evt1)',
29345 & F7.3,' /',F7.3,/,8X,'out of which by inelastic',
29346 & ' interactions',12X,F7.3,' /',F7.3,/,21X,'by elastic ',
29347 & 'interactions',14X,F7.3,' /',F7.3,/,21X,'by absorption ',
29348 & '(ap, K-, pi- only) ',F7.3,' /',F7.3,/)
29349 WRITE(LOUT,3003) NRESEV(2),NRESEV(4),IREXCI,
29350 & IREXCI(1)+IREXCI(2)+IREXCI(3)
29351 3003 FORMAT(/,1X,'HISTAT:',14X,'statistics - residual nuclei, ',
29352 & 'evaporation',/,22X,'-----------------------------',
29353 & '------------',/,/,1X,'no. of events for normal.: ',
29354 & '(events handled by FICONF, evt)',7X,I6,/,28X,'(events',
29355 & ' passing the evap.-step, evt1) ',I6,/,1X,'no. of',
29356 & ' rejected events (',I4,',',I4,',',I4,')',22X,I6,/)
29359 3004 FORMAT(/,22X,'1) before evaporation-step:',/)
29360 ICEV = MAX(NRESEV(2),1)
29362 & (DBLE(NRESTO(I))/DBLE(ICEV),I=1,2),
29363 & (DBLE(NRESPR(I))/DBLE(ICEV),I=1,2),
29364 & (DBLE(NRESNU(I))/DBLE(ICEV),I=1,2),
29365 & (DBLE(NRESBA(I))/DBLE(ICEV),I=1,2),
29366 & (DBLE(NRESPB(I))/DBLE(ICEV),I=1,2),
29367 & (DBLE(NRESCH(I))/DBLE(ICEV),I=1,2),
29368 & (EXCDPM(I)/DBLE(ICEV),I=1,2),
29369 & (EXCDPM(I+2)/DBLE(ICEV),I=1,2)
29370 3005 FORMAT(1X,'residual nuclei: (mean values per evt)',12X,
29371 & 'proj. / target',/,/,8X,'total number of particles',15X,
29372 & 2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29373 & 'neutrons',18X,2F9.3,/,22X,'baryons',19X,2F9.3,/,22X,
29374 & 'pos. baryons',14X,2F9.3,/,8X,'total charge',28X,2F9.3,/,
29375 & /,8X,'excitation energy (bef. evap.-step) ',2E11.3,/,
29376 & 8X,'excitation energy per nucleon ',2E11.3,/,/)
29378 * evaporation / fission / fragmentation statistics: output
29379 ICEV = MAX(NRESEV(2),1)
29380 ICEV1 = MAX(NRESEV(4),1)
29382 & NEVA(1,1)+NEVA(1,2)+NEVA(1,3)+NEVA(1,4)+NEVA(1,5)+NEVA(1,6)
29384 & NEVA(2,1)+NEVA(2,2)+NEVA(2,3)+NEVA(2,4)+NEVA(2,5)+NEVA(2,6)
29387 IF (IEVFSS.EQ.1) CMSG(1) = 'requested '
29389 IF (LFRMBK) CMSG(2) = 'requested '
29390 IF (LDEEXG) CMSG(3) = 'requested '
29393 & DBLE(NTEVA1)/DBLE(ICEV1),DBLE(NTEVA2)/DBLE(ICEV1),
29394 & (DBLE(NEVA(I,1))/DBLE(ICEV1),I=1,2),
29395 & (DBLE(NEVA(I,2))/DBLE(ICEV1),I=1,2),
29396 & (DBLE(NEVA(I,3))/DBLE(ICEV1),I=1,2),
29397 & (DBLE(NEVA(I,4))/DBLE(ICEV1),I=1,2),
29398 & (DBLE(NEVA(I,5))/DBLE(ICEV1),I=1,2),
29399 & (DBLE(NEVA(I,6))/DBLE(ICEV1),I=1,2),
29400 & (DBLE(NEVAGA(I))/DBLE(ICEV1),I=1,2),
29401 & (DBLE(NEVAHT(I))/DBLE(ICEV1),I=1,2)
29402 3006 FORMAT(22X,'2) after evaporation-step:',/,/,1X,'Fission:',
29403 & 13X,A13,/,1X,'Fermi-Break-up:',6X,A13,/,1X,'Gamma-',
29404 & 'deexcitation:',2X,A13,/,/,
29405 & 1X,'evaporation/deexcitation: (mean values per evt1) ',
29406 & 'proj. / target',/,/,8X,'total number of evap. particles',
29407 & 9X,2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29408 & 'neutrons',18X,2F9.3,/,22X,'deuterons',17X,2F9.3,/,22X,
29409 & '3-H',23X,2F9.3,/,22X,'3-He',22X,2F9.3,/,22X,'4-He',22X,
29410 & 2F9.3,/,8X,'nucl. deexcit. gammas',19X,2F9.3,/,8X,
29411 & 'heavy fragments',25X,2F9.3,/)
29413 IF (IEVFSS.EQ.1) THEN
29415 WRITE(LOUT,3007) NEVAFI(1,1),NEVAFI(1,2),
29416 & NEVAFI(2,1),NEVAFI(2,2),
29417 & DBLE(NEVAFI(2,1))/DBLE(MAX(NEVAFI(1,1),1))*100.0D0,
29418 & DBLE(NEVAFI(2,2))/DBLE(MAX(NEVAFI(1,2),1))*100.0D0
29419 3007 FORMAT(1X,'Fission: total number of events',14X,2I9,/
29420 & 12X,'out of which fission occured',8X,2I9,/,
29421 & 50X,'(',F5.2,'%) (',F5.2,'%)',/)
29424 C IF ((LFRMBK).OR.(IEVFSS.EQ.1)) THEN
29427 C3008 FORMAT(1X,'heavy fragments - statistics:',7X,'charge',
29428 C & ' proj. / target',/)
29430 C IF ((NEVAHY(1,2,I).NE.0).OR.(NEVAHY(2,2,I).NE.0)) THEN
29431 C WRITE(LOUT,3009) I,
29432 C & (DBLE(NEVAHY(K,2,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29433 C3009 FORMAT(38X,I3,3X,2E12.3)
29437 C3010 FORMAT(1X,'heavy fragments - statistics:',7X,'mass ',
29438 C & ' proj. / target',/)
29440 C IF ((NEVAHY(1,1,I).NE.0).OR.(NEVAHY(2,1,I).NE.0)) THEN
29441 C WRITE(LOUT,3011) I,
29442 C & (DBLE(NEVAHY(K,1,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29443 C3011 FORMAT(38X,I3,3X,2E12.3)
29450 3012 FORMAT(22X,'2) after evaporation-step:',/,/,1X,
29451 & 'Evaporation: not requested',/)
29455 *------------------------------------------------------------------
29456 * filling of histogram with event-record
29458 * emulsion treatment
29459 IF (NCOMPO.GT.0) THEN
29461 IF (IT.EQ.IEMUMA(I)) THEN
29462 EMUSAM(I) = EMUSAM(I)+ONE
29466 NINCGE = NINCGE+MAXGEN
29468 **dble Po statistics.
29469 IF (IPOPO.EQ.1) KPOPO = KPOPO+1
29472 *------------------------------------------------------------------
29473 * filling of histogram with event-record
29475 IF ((ISTHKK(IDX).EQ.15).OR.(ISTHKK(IDX).EQ.16)) THEN
29476 IB = IIBAR(IDBAM(IDX))
29477 IC = IICH(IDBAM(IDX))
29479 IF ( ((ABS(IB).EQ.1).AND.(IC.EQ.1)).OR.(IC.EQ.0) ) THEN
29480 NINCST(J,1) = NINCST(J,1)+1
29481 ELSEIF ((ABS(IB).EQ.1).AND.(IC.EQ.-1)) THEN
29482 NINCST(J,2) = NINCST(J,2)+1
29483 ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ. 1)) THEN
29484 NINCST(J,3) = NINCST(J,3)+1
29485 ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ.-1)) THEN
29486 NINCST(J,4) = NINCST(J,4)+1
29488 ELSEIF (ISTHKK(IDX).EQ.17) THEN
29489 NINCWO(1) = NINCWO(1)+1
29490 ELSEIF (ISTHKK(IDX).EQ.18) THEN
29491 NINCWO(2) = NINCWO(2)+1
29492 ELSEIF (ISTHKK(IDX).EQ.1001) THEN
29496 NEVAHY(NOBAM(IDX),1,IB) = NEVAHY(NOBAM(IDX),1,IB)+1
29497 NEVAHY(NOBAM(IDX),2,IC) = NEVAHY(NOBAM(IDX),2,IC)+1
29499 NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29504 *$ CREATE DT_NEWHGR.FOR
29507 *===newhgr=============================================================*
29509 SUBROUTINE DT_NEWHGR(XLIM1,XLIM2,XLIM3,XLIMB,IBIN,IREFN)
29511 ************************************************************************
29513 * Histogram initialization. *
29515 * input: XLIM1/XLIM2 lower/upper edge of histogram-window *
29517 * IBIN > 0 number of bins in equidistant lin. binning *
29518 * = -1 reset histograms *
29519 * < -1 |IBIN| number of bins in equidistant log. *
29520 * binning or log. binning in user def. struc. *
29521 * XLIMB(*) user defined bin structure *
29523 * The bin structure is sensitive to *
29524 * XLIM1, XLIM3, IBIN if XLIM3 > 0 (lin.) *
29525 * XLIM1, XLIM2, IBIN if XLIM3 = 0 (lin. & log.) *
29526 * XLIMB, IBIN if XLIM3 < 0 *
29529 * output: IREFN histogram index *
29530 * (= -1 for inconsistent histogr. request) *
29532 * This subroutine is based on a original version by R. Engel. *
29533 * This version dated 22.4.95 is written by S. Roesler. *
29534 ************************************************************************
29536 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29539 PARAMETER ( LINP = 10 ,
29545 PARAMETER (ZERO = 0.0D0,
29552 PARAMETER (NHIS=150, NDIM=250)
29554 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29555 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29557 * auxiliary common for histograms
29558 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29560 DATA LSTART /.TRUE./
29562 * reset histogram counter
29563 IF (LSTART.OR.(IBIN.EQ.-1)) THEN
29565 IF (IBIN.EQ.-1) RETURN
29570 * check for maximum number of allowed histograms
29571 IF (IHIS.GT.NHIS) THEN
29572 WRITE(LOUT,1003) IHIS,NHIS,IHIS
29573 1003 FORMAT(1X,'NEWHGR: warning! number of histograms (',
29574 & I4,') exceeds array size (',I4,')',/,21X,
29575 & 'histogram',I3,' skipped!')
29580 IBINS(IHIS) = ABS(IBIN)
29581 * check requested number of bins
29582 IF (IBINS(IHIS).GE.NDIM) THEN
29583 WRITE(LOUT,1000) IBIN,NDIM,NDIM
29584 1000 FORMAT(1X,'NEWHGR: warning! number of bins (',
29585 & I3,') exceeds array size (',I3,')',/,21X,
29586 & 'and will be reset to ',I3)
29589 IF (IBINS(IHIS).EQ.0) THEN
29590 WRITE(LOUT,1001) IBIN,IHIS
29591 1001 FORMAT(1X,'NEWHGR: warning! inconsistent number of',
29592 & ' bins (',I3,')',/,21X,'histogram',I3,' skipped!')
29596 * initialize arrays
29599 HIST(K,IHIS,I) = ZERO
29600 HIST(K+3,IHIS,I) = ZERO
29601 TMPHIS(K,IHIS,I) = ZERO
29603 HIST(7,IHIS,I) = ZERO
29605 DENTRY(1,IHIS)= ZERO
29606 DENTRY(2,IHIS)= ZERO
29608 UNDERF(IHIS) = ZERO
29609 TMPUFL(IHIS) = ZERO
29610 TMPOFL(IHIS) = ZERO
29612 * bin str. sensitive to lower edge, bin size, and numb. of bins
29613 IF (XLIM3.GT.ZERO) THEN
29614 DO 3 K=1,IBINS(IHIS)+1
29615 HIST(1,IHIS,K) = XLIM1+DBLE(K-1)*XLIM3
29618 * bin str. sensitive to lower/upper edge and numb. of bins
29619 ELSEIF (XLIM3.EQ.ZERO) THEN
29621 IF (IBIN.GT.0) THEN
29624 IF (XLIM2.LE.XLIM1) THEN
29625 WRITE(LOUT,1002) XLIM1,XLIM2
29626 1002 FORMAT(1X,'NEWHGR: warning! inconsistent x-range',
29627 & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29631 ELSEIF (IBIN.LT.-1) THEN
29632 * logarithmic binning
29633 IF ((XLIM1.LE.ZERO).OR.(XLIM2.LE.ZERO)) THEN
29634 WRITE(LOUT,1004) XLIM1,XLIM2
29635 1004 FORMAT(1X,'NEWHGR: warning! inconsistent log. ',
29636 & 'binning',/,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29639 IF (XLIM2.LE.XLIM1) THEN
29640 WRITE(LOUT,1005) XLIM1,XLIM2
29641 1005 FORMAT(1X,'NEWHGR: warning! inconsistent x-range',
29642 & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29645 XLOW = LOG10(XLIM1)
29649 DX = ABS(XHI-XLOW)/DBLE(MAX(IBINS(IHIS),1))
29650 DO 4 K=1,IBINS(IHIS)+1
29651 HIST(1,IHIS,K) = XLOW+DBLE(K-1)*DX
29654 * user defined bin structure
29655 DO 5 K=1,IBINS(IHIS)+1
29656 IF (IBIN.GT.0) THEN
29657 HIST(1,IHIS,K) = XLIMB(K)
29659 ELSEIF (IBIN.LT.-1) THEN
29660 HIST(1,IHIS,K) = LOG10(XLIMB(K))
29666 * histogram accepted
29676 *$ CREATE DT_FILHGR.FOR
29679 *===filhgr=============================================================*
29681 SUBROUTINE DT_FILHGR(XI,YI,IHIS,NEVT)
29683 ************************************************************************
29685 * Scoring for histogram IHIS. *
29687 * This subroutine is based on a original version by R. Engel. *
29688 * This version dated 23.4.95 is written by S. Roesler. *
29689 ************************************************************************
29691 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29694 PARAMETER ( LINP = 10 ,
29698 PARAMETER (ZERO = 0.0D0,
29704 PARAMETER (NHIS=150, NDIM=250)
29706 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29707 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29709 * auxiliary common for histograms
29710 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29717 * dump content of temorary arrays into histograms
29718 IF ((NEVT.NE.NCEVT).OR.(NEVT.LT.0)) THEN
29719 CALL DT_EVTHIS(IDUM)
29723 * check histogram index
29724 IF (IHIS.EQ.-1) RETURN
29725 IF ((IHIS.LT.1).OR.(IHIS.GT.IHISL)) THEN
29726 C WRITE(LOUT,1000) IHIS,IHISL
29727 1000 FORMAT(1X,'FILHGR: warning! histogram index',I4,
29728 & ' out of range (1..',I3,')')
29732 IF ((ISWI(IHIS).EQ.1).OR.(ISWI(IHIS).EQ.3)) THEN
29733 * bin structure not explicitly given
29734 IF ((ISWI(IHIS).EQ.3).AND.(X.GT.ZERO)) X = LOG10(X)
29735 DX = ABS(HIST(1,IHIS,2)-HIST(1,IHIS,1))
29736 IF (X.LT.HIST(1,IHIS,1)) THEN
29739 I1 = INT( (X-HIST(1,IHIS,1))/MAX(DX,TINY) )+1
29742 ELSEIF ((ISWI(IHIS).EQ.2).OR.(ISWI(IHIS).EQ.4)) THEN
29743 * user defined bin structure
29744 IF ((ISWI(IHIS).EQ.4).AND.(X.GT.ZERO)) X = LOG10(X)
29745 IF (X.LT.HIST(1,IHIS,1)) THEN
29747 ELSE IF (X.GT.HIST(1,IHIS,IBINS(IHIS)+1)) THEN
29750 * binary sort algorithm
29752 KMAX = IBINS(IHIS)+1
29754 IF ((KMAX-KMIN).EQ.1) GOTO 2
29756 IF (X.LE.HIST(1,IHIS,KK)) THEN
29768 1001 FORMAT(1X,'FILHGR: warning! histogram not initialized')
29774 TMPUFL(IHIS) = TMPUFL(IHIS)+ONE
29775 ELSEIF (I1.LE.IBINS(IHIS)) THEN
29776 TMPHIS(1,IHIS,I1) = TMPHIS(1,IHIS,I1)+ONE
29777 IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
29778 TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+10**X
29780 TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+X
29782 TMPHIS(3,IHIS,I1) = TMPHIS(3,IHIS,I1)+Y
29784 TMPOFL(IHIS) = TMPOFL(IHIS)+ONE
29790 *$ CREATE DT_EVTHIS.FOR
29793 *===evthis=============================================================*
29795 SUBROUTINE DT_EVTHIS(NEVT)
29797 ************************************************************************
29798 * Dump content of temorary histograms into /DTHIS1/. This subroutine *
29799 * is called after each event and for the last event before any call *
29801 * NEVT number of events dumped, this is only needed to *
29802 * get the normalization after the last event *
29803 * This version dated 23.4.95 is written by S. Roesler. *
29804 ************************************************************************
29806 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29809 PARAMETER ( LINP = 10 ,
29815 PARAMETER (ZERO = 0.0D0,
29821 PARAMETER (NHIS=150, NDIM=250)
29823 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29824 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29826 * auxiliary common for histograms
29827 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29837 IF (TMPHIS(1,I,J).GT.ZERO) THEN
29839 HIST(2,I,J) = HIST(2,I,J)+ONE
29840 HIST(7,I,J) = HIST(7,I,J)+TMPHIS(1,I,J)
29841 DENTRY(2,I) = DENTRY(2,I)+TMPHIS(1,I,J)
29842 AVX = TMPHIS(2,I,J)/TMPHIS(1,I,J)
29843 HIST(3,I,J) = HIST(3,I,J)+TMPHIS(3,I,J)*AVX
29844 HIST(4,I,J) = HIST(4,I,J)+TMPHIS(3,I,J)*AVX**2
29845 HIST(5,I,J) = HIST(5,I,J)+TMPHIS(3,I,J)
29846 HIST(6,I,J) = HIST(6,I,J)+TMPHIS(3,I,J)**2
29847 TMPHIS(1,I,J) = ZERO
29848 TMPHIS(2,I,J) = ZERO
29849 TMPHIS(3,I,J) = ZERO
29853 IF (TMPUFL(I).GT.ZERO) THEN
29854 UNDERF(I) = UNDERF(I)+ONE
29856 ELSEIF (TMPOFL(I).GT.ZERO) THEN
29857 OVERF(I) = OVERF(I)+ONE
29861 DENTRY(1,I) = DENTRY(1,I)+ONE
29868 *$ CREATE DT_OUTHGR.FOR
29871 *===outhgr=============================================================*
29873 SUBROUTINE DT_OUTHGR(I1,I2,I3,I4,I5,I6,CHEAD,IHEAD,NEVTS,FAC,
29874 & ILOGY,INORM,NMODE)
29876 ************************************************************************
29878 * Plot histogram(s) to standard output unit *
29880 * I1..6 indices of histograms to be plotted *
29881 * CHEAD,IHEAD header string,integer *
29882 * NEVTS number of events *
29883 * FAC scaling factor *
29884 * ILOGY = 1 logarithmic y-axis *
29885 * INORM normalization *
29886 * = 0 no further normalization (FAC is obsolete) *
29887 * = 1 per event and bin width *
29888 * = 2 per entry and bin width *
29889 * = 3 per bin entry *
29890 * = 4 per event and "bin width" x1^2...x2^2 *
29891 * = 5 per event and "log. bin width" ln x1..ln x2 *
29893 * MODE = 0 no output but normalization applied *
29894 * = 1 all valid histograms separately (small frame) *
29895 * all valid histograms separately (small frame) *
29896 * = -1 and tables as histograms *
29897 * = 2 all valid histograms (one plot, wide frame) *
29898 * all valid histograms (one plot, wide frame) *
29899 * = -2 and tables as histograms *
29902 * Note: All histograms to be plotted with one call to this *
29903 * subroutine and |MODE|=2 must have the same bin structure! *
29904 * There is no test included ensuring this fact. *
29906 * This version dated 23.4.95 is written by S. Roesler. *
29907 ************************************************************************
29909 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29912 PARAMETER ( LINP = 10 ,
29918 PARAMETER (ZERO = 0.0D0,
29930 PARAMETER (NHIS=150, NDIM=250)
29932 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29933 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29935 PARAMETER (NDIM2 = 2*NDIM)
29936 DIMENSION XX(NDIM2),YY(NDIM2)
29938 PARAMETER (NHISTO = 6)
29939 DIMENSION YY1(NDIM,NHISTO),XX1(NDIM,NHISTO),IDX1(NHISTO),
29942 CHARACTER*43 CNORM(0:8)
29943 DATA CNORM /'no further normalization ',
29944 & 'per event and bin width ',
29945 & 'per entry1 and bin width ',
29946 & 'per bin entry ',
29947 & 'per event and "bin width" x1^2...x2^2 ',
29948 & 'per event and "log. bin width" ln x1..ln x2',
29950 & 'per bin entry1 ',
29951 & 'per entry2 and bin width '/
29962 * initialization if "wide frame" is requested
29963 IF (ABS(MODE).EQ.2) THEN
29973 WRITE(LOUT,'(/1X,A,I3,/,1X,70A1)') CHEAD,IHEAD,('=',II=1,70)
29975 * check histogram indices
29978 IF ((IDX1(I).GE.1).AND.(IDX1(I).LE.IHISL)) THEN
29979 IF (ISWI(IDX1(I)).NE.0) THEN
29980 IF (DENTRY(1,IDX1(I)).LT.ONE) THEN
29982 & IDX1(I),UNDERF(IDX1(I)),OVERF(IDX1(I))
29983 1000 FORMAT(/,1X,'OUTHGR: warning! no entries in',
29984 & ' histogram ',I3,/,21X,'underflows:',F10.0,
29985 & ' overflows: ',F10.0)
29995 1001 FORMAT(/,1X,'OUTHGR: warning! histogram indices not valid')
29999 * check normalization request
30000 IF ( ((FAC.EQ.ZERO).AND.(INORM.NE.0)).OR.
30001 & ((NEVTS.LT.1).AND.((INORM.EQ.1).OR.(INORM.EQ.4).OR.
30002 & (INORM.EQ.5).OR.(INORM.EQ.6))).OR.
30003 & (INORM.LT.0).OR.(INORM.GT.8) ) THEN
30004 WRITE(LOUT,1002) NEVTS,INORM,FAC
30005 1002 FORMAT(/,1X,'OUTHGR: warning! normalization request not ',
30006 & 'valid',/,21X,'NEVTS = ',I7,4X,'INORM = ',I2,4X,
30011 WRITE(LOUT,'(/,1X,A,I8)') 'number of events:',NEVTS
30013 * apply normalization
30018 IF (ISWI(I).EQ.1) THEN
30019 WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30020 1003 FORMAT(/,1X,'histo.',I4,', linear binning from',2X,E10.4,
30021 & ' to',2X,E10.4,',',2X,I3,' bins')
30022 ELSEIF (ISWI(I).EQ.2) THEN
30023 WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30025 1007 FORMAT(1X,'user defined bin structure')
30026 ELSEIF (ISWI(I).EQ.3) THEN
30028 & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30029 1004 FORMAT(/,1X,'histo.',I4,', logar. binning from',2X,E10.4,
30030 & ' to',2X,E10.4,',',2X,I3,' bins')
30031 ELSEIF (ISWI(I).EQ.4) THEN
30033 & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30036 WRITE(LOUT,1008) ISWI(I)
30037 1008 FORMAT(/,1X,'warning! inconsistent bin structure flag ',I4)
30039 WRITE(LOUT,1005) DENTRY(1,I),DENTRY(2,I),UNDERF(I),OVERF(I)
30040 1005 FORMAT(13X,'entries:',2F9.0,' underfl.:',F8.0,
30041 & ' overfl.:',F8.0)
30042 WRITE(LOUT,1009) CNORM(INORM)
30043 1009 FORMAT(1X,'normalization: ',A,/)
30046 CALL DT_GETBIN(I,K,NEVTS,INORM,XLOW,XHI,XMEAN,YMEAN,YERR)
30049 WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,YERR,HIST(2,I,K)
30050 WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,YERR,HIST(2,I,K)
30051 1006 FORMAT(1X,5E11.3)
30054 XX(II-1) = HIST(1,I,K)
30055 XX(II) = HIST(1,I,K+1)
30060 IF ((ISWI(I).EQ.3).OR.(ISWI(I).EQ.4))
30061 & XX1(K,N) = LOG10(XMEAN)
30066 IF (ABS(MODE).EQ.1) THEN
30068 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30069 IF(ILOGY.EQ.1) THEN
30070 CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30072 CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30079 IF (ABS(MODE).EQ.2) THEN
30080 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30081 NSIZE = NDIM*NHISTO
30082 DXLOW = HIST(1,IDX(1),1)
30083 DDX = ABS(HIST(1,IDX(1),2)-HIST(1,IDX(1),1))
30088 IF (YY1(J,I).LT.YLOW) THEN
30089 IF (ILOGY.EQ.1) THEN
30090 IF (YY1(J,I).GT.ZERO) YLOW = YY1(J,I)
30095 IF (YY1(J,I).GT.YHI) YHI = YY1(J,I)
30098 DY = (YHI-YLOW)/DBLE(NDIM)
30099 IF (DY.LE.ZERO) THEN
30100 WRITE(LOUT,'(1X,A,6I4,A,2E12.4)')
30101 & 'OUTHGR: warning! zero bin width for histograms ',
30102 & IDX,': ',YLOW,YHI
30105 IF (ILOGY.EQ.1) THEN
30107 DY = (LOG10(YHI)-YLOW)/100.0D0
30110 IF (YY1(J,I).LE.ZERO) THEN
30113 YY1(J,I) = LOG10(YY1(J,I))
30118 CALL DT_SRPLOT(XX1,YY1,NSIZE,NHISTO,NDIM,DXLOW,DDX,YLOW,DY)
30124 *$ CREATE DT_GETBIN.FOR
30127 *===getbin=============================================================*
30129 SUBROUTINE DT_GETBIN(IHIS,IBIN,KEVT,NORM,XLOW,XHI,
30130 & XMEAN,YMEAN,YERR)
30132 ************************************************************************
30133 * This version dated 23.4.95 is written by S. Roesler. *
30134 ************************************************************************
30136 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30139 PARAMETER ( LINP = 10 ,
30143 PARAMETER (ZERO = 0.0D0,
30145 & TINY35 = 1.0D-35)
30149 PARAMETER (NHIS=150, NDIM=250)
30151 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30152 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30154 XLOW = HIST(1,IHIS,IBIN)
30155 XHI = HIST(1,IHIS,IBIN+1)
30156 IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
30160 IF (NORM.EQ.2) THEN
30162 NEVT = INT(DENTRY(1,IHIS))
30163 ELSEIF (NORM.EQ.3) THEN
30165 NEVT = INT(HIST(2,IHIS,IBIN))
30166 ELSEIF (NORM.EQ.4) THEN
30167 DX = XHI**2-XLOW**2
30169 ELSEIF (NORM.EQ.5) THEN
30170 DX = LOG(ABS(XHI))-LOG(ABS(XLOW))
30172 ELSEIF (NORM.EQ.6) THEN
30175 ELSEIF (NORM.EQ.7) THEN
30177 NEVT = INT(HIST(7,IHIS,IBIN))
30178 ELSEIF (NORM.EQ.8) THEN
30180 NEVT = INT(DENTRY(2,IHIS))
30185 IF (ABS(DX).LT.TINY35) DX = ONE
30187 YMEAN = HIST(5,IHIS,IBIN)/DX/DBLE(NEVT)
30188 YMEAN2 = HIST(6,IHIS,IBIN)/DX**2/DBLE(NEVT)
30189 YERR = SQRT(ABS(YMEAN2-YMEAN**2))/SQRT(DBLE(NEVT))
30190 YSUM = HIST(5,IHIS,IBIN)
30191 IF (ABS(YSUM).LT.TINY35) YSUM = ONE
30192 C XMEAN = HIST(3,IHIS,IBIN)/YSUM/MAX(HIST(2,IHIS,IBIN),ONE)
30193 XMEAN = HIST(3,IHIS,IBIN)/YSUM
30194 IF (XMEAN.EQ.ZERO) XMEAN = XLOW
30199 *$ CREATE DT_JOIHIS.FOR
30202 *===joihis=============================================================*
30204 SUBROUTINE DT_JOIHIS(IH1,IH2,COPER,FAC1,FAC2,KEVT,NORM,ILOGY,MODE)
30206 ************************************************************************
30208 * Operation on histograms. *
30210 * input: IH1,IH2 histogram indices to be joined *
30211 * COPER character defining the requested operation, *
30212 * i.e. '+', '-', '*', '/' *
30213 * FAC1,FAC2 factors for joining, i.e. *
30214 * FAC1*histo1 COPER FAC2*histo2 *
30216 * This version dated 23.4.95 is written by S. Roesler. *
30217 ************************************************************************
30219 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30222 PARAMETER ( LINP = 10 ,
30228 PARAMETER (ZERO = 0.0D0,
30237 PARAMETER (NHIS=150, NDIM=250)
30239 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30240 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30242 PARAMETER (NDIM2 = 2*NDIM)
30243 DIMENSION XX(NDIM2),YY(NDIM2),YY1(NDIM),XX1(NDIM)
30245 CHARACTER*43 CNORM(0:6)
30246 DATA CNORM /'no further normalization ',
30247 & 'per event and bin width ',
30248 & 'per entry and bin width ',
30249 & 'per bin entry ',
30250 & 'per event and "bin width" x1^2...x2^2 ',
30251 & 'per event and "log. bin width" ln x1..ln x2',
30254 * check histogram indices
30255 IF ((IH1.LT. 1).OR.(IH2.LT. 1).OR.
30256 & (IH1.GT.IHISL).OR.(IH2.GT.IHISL)) THEN
30257 WRITE(LOUT,1000) IH1,IH2,IHISL
30258 1000 FORMAT(1X,'JOIHIS: warning! inconsistent histogram ',
30259 & 'indices (',I3,',',I3,'),',/,21X,'valid range: 1,',I3)
30263 * check bin structure of histograms to be joined
30264 IF (IBINS(IH1).NE.IBINS(IH2)) THEN
30265 WRITE(LOUT,1001) IH1,IH2,IBINS(IH1),IBINS(IH2)
30266 1001 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3,
30267 & ' and ',I3,' failed',/,21X,
30268 & 'due to different numbers of bins (',I3,',',I3,')')
30271 DO 1 K=1,IBINS(IH1)+1
30272 IF (ABS(HIST(1,IH1,K)-HIST(1,IH2,K)).GT.TINY8) THEN
30273 WRITE(LOUT,1002) IH1,IH2,K,HIST(1,IH1,K),HIST(1,IH2,K)
30274 1002 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3,
30275 & ' and ',I3,' failed at bin edge ',I3,/,21X,
30276 & 'X1,X2 = ',2E11.4)
30281 WRITE(LOUT,1003) IH1,IH2,COPER,FAC1,FAC2
30282 1003 FORMAT(1X,'JOIHIS: joining histograms ',I3,',',I3,' with ',
30283 & 'operation ',A,/,11X,'and factors ',2E11.4)
30284 WRITE(LOUT,1004) CNORM(NORM)
30285 1004 FORMAT(1X,'normalization: ',A,/)
30287 DO 2 K=1,IBINS(IH1)
30288 CALL DT_GETBIN(IH1,K,KEVT,NORM,XLOW1,XHI1,XMEAN1,YMEAN1,YERR1)
30289 CALL DT_GETBIN(IH2,K,KEVT,NORM,XLOW2,XHI2,XMEAN2,YMEAN2,YERR2)
30292 XMEAN = OHALF*(XMEAN1+XMEAN2)
30293 IF (COPER.EQ.'+') THEN
30294 YMEAN = FAC1*YMEAN1+FAC2*YMEAN2
30295 ELSEIF (COPER.EQ.'*') THEN
30296 YMEAN = FAC1*YMEAN1*FAC2*YMEAN2
30297 ELSEIF (COPER.EQ.'/') THEN
30298 IF (YMEAN2.EQ.ZERO) THEN
30301 IF (FAC2.EQ.ZERO) FAC2 = ONE
30302 YMEAN = FAC1*YMEAN1/(FAC2*YMEAN2)
30307 WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30308 WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30309 1006 FORMAT(1X,5E11.3)
30312 XX(II-1) = HIST(1,IH1,K)
30313 XX(II) = HIST(1,IH1,K+1)
30318 IF ((ISWI(IH1).EQ.3).OR.(ISWI(IH1).EQ.4)) XX1(K) = LOG10(XMEAN)
30323 IF (ABS(MODE).EQ.1) THEN
30324 IBIN2 = 2*IBINS(IH1)
30325 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30326 IF(ILOGY.EQ.1) THEN
30327 CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30329 CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30334 IF (ABS(MODE).EQ.2) THEN
30335 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30337 DXLOW = HIST(1,IH1,1)
30338 DDX = ABS(HIST(1,IH1,2)-HIST(1,IH1,1))
30342 IF (YY1(I).LT.YLOW) THEN
30343 IF (ILOGY.EQ.1) THEN
30344 IF (YY1(I).GT.ZERO) YLOW = YY1(I)
30349 IF (YY1(I).GT.YHI) YHI = YY1(I)
30351 DY = (YHI-YLOW)/DBLE(NDIM)
30352 IF (DY.LE.ZERO) THEN
30353 WRITE(LOUT,'(1X,A,2I4,A,2E12.4)')
30354 & 'JOIHIS: warning! zero bin width for histograms ',
30355 & IH1,IH2,': ',YLOW,YHI
30358 IF (ILOGY.EQ.1) THEN
30360 DY = (LOG10(YHI)-YLOW)/100.0D0
30362 IF (YY1(I).LE.ZERO) THEN
30365 YY1(I) = LOG10(YY1(I))
30369 CALL DT_SRPLOT(XX1,YY1,NSIZE,1,NDIM,DXLOW,DDX,YLOW,DY)
30375 WRITE(LOUT,1005) COPER
30376 1005 FORMAT(1X,'JOIHIS: unknown operation ',A)
30382 *$ CREATE DT_XGRAPH.FOR
30385 *===qgraph=============================================================*
30387 SUBROUTINE DT_XGRAPH(N,IARG,X,Y1,Y2)
30388 C***********************************************************************
30390 C calculate quasi graphic picture with 25 lines and 79 columns
30391 C ranges will be chosen automatically
30393 C input N dimension of input fields
30394 C IARG number of curves (fields) to plot
30399 C This subroutine is written by R. Engel.
30400 C***********************************************************************
30401 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30404 PARAMETER ( LINP = 10 ,
30409 DIMENSION X(N),Y1(N),Y2(N)
30410 PARAMETER (EPS=1.D-30)
30411 PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30413 CHARACTER COL(0:149,0:49)
30415 DATA SYMB /'0','e','z','#','x'/
30419 C*** automatic range fitting
30424 XMAX=MAX(X(I),XMAX)
30425 XMIN=MIN(X(I),XMIN)
30427 XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30430 DO 1100 K=0,IZEIL-1
30432 IF (ITEST.EQ.IYRAST) THEN
30433 DO 1010 L=1,ISPALT-1
30438 DO 1020 L=0,ISPALT-1,IXRAST
30442 DO 1030 L=1,ISPALT-1
30445 DO 1040 L=0,ISPALT-1,IXRAST
30457 YMAX=MAX(Y1(I),YMAX)
30458 YMIN=MIN(Y1(I),YMIN)
30462 YMAX=MAX(Y2(I),YMAX)
30463 YMIN=MIN(Y2(I),YMIN)
30466 YMAX=(YMAX-YMIN)/40.0D0+YMAX
30467 YMIN=YMIN-(YMAX-YMIN)/40.0D0
30468 YZOOM=(YMAX-YMIN)/DBLE(IZEIL)
30469 IF(YZOOM.LT.EPS) THEN
30470 WRITE(LOUT,'(1X,A)')
30471 & 'XGRAPH:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30480 L=NINT((X(K)-XMIN)/XZOOM)
30481 I=NINT((YMAX-Y1(K))/YZOOM)
30482 IF(ILAST.GE.0) THEN
30485 DO 55 II=0,LD,SIGN(1,LD)
30486 DO 66 KK=0,ID,SIGN(1,ID)
30487 COL(II+LLAST,KK+ILAST)=SYMB(1)
30502 L=NINT((X(K)-XMIN)/XZOOM)
30503 I=NINT((YMAX-Y2(K))/YZOOM)
30510 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30512 C*** write range of X
30514 XZOOM = (XMAX-XMIN)/DBLE(7)
30515 WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30517 DO 1300 K=0,IZEIL-1
30518 YPOS=YMAX-((DBLE(K)+0.5D0)*YZOOM)
30519 WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30520 110 FORMAT(1X,1PE9.2,70A1)
30523 C*** write range of X
30525 XZOOM = (XMAX-XMIN)/DBLE(7)
30526 WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30527 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30528 120 FORMAT(6X,7(1PE10.3))
30531 *$ CREATE DT_XGLOGY.FOR
30534 *===qglogy=============================================================*
30536 SUBROUTINE DT_XGLOGY(N,IARG,X,Y1,Y2)
30537 C***********************************************************************
30539 C calculate quasi graphic picture with 25 lines and 79 columns
30540 C logarithmic y axis
30541 C ranges will be chosen automatically
30543 C input N dimension of input fields
30544 C IARG number of curves (fields) to plot
30549 C This subroutine is written by R. Engel.
30550 C***********************************************************************
30552 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30555 PARAMETER ( LINP = 10 ,
30559 DIMENSION X(N),Y1(N),Y2(N)
30560 PARAMETER (EPS=1.D-30)
30561 PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30563 CHARACTER COL(0:149,0:49)
30564 PARAMETER (DEPS = 1.D-10)
30566 DATA SYMB /'0','e','z','#','x'/
30570 C*** automatic range fitting
30575 XMAX=MAX(X(I),XMAX)
30576 XMIN=MIN(X(I),XMIN)
30578 XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30581 DO 1100 K=0,IZEIL-1
30583 IF (ITEST.EQ.IYRAST) THEN
30584 DO 1010 L=1,ISPALT-1
30589 DO 1020 L=0,ISPALT-1,IXRAST
30593 DO 1030 L=1,ISPALT-1
30596 DO 1040 L=0,ISPALT-1,IXRAST
30606 YMIN=MAX(Y1(1),EPS)
30608 YMAX =MAX(Y1(I),YMAX)
30609 IF(Y1(I).GT.EPS) THEN
30610 IF(YMIN.EQ.EPS) THEN
30613 YMIN = MIN(Y1(I),YMIN)
30619 YMAX=MAX(Y2(I),YMAX)
30620 IF(Y2(I).GT.EPS) THEN
30621 IF(YMIN.EQ.EPS) THEN
30624 YMIN = MIN(Y2(I),YMIN)
30631 Y1(I) = MAX(Y1(I),YMIN)
30635 Y2(I) = MAX(Y2(I),YMIN)
30639 IF(YMAX.LE.YMIN) THEN
30640 WRITE(LOUT,'(/1X,A,2E12.3,/)')
30641 & 'XGLOGY:ERROR:YMIN,YMAX ',YMIN,YMAX
30642 WRITE(LOUT,'(1X,A)') 'MIN = MAX, OUTPUT SUPPRESSED'
30646 YMA=(LOG10(YMAX)-LOG10(YMIN))/20.0D0+LOG10(YMAX)
30647 YMI=LOG10(YMIN)-(LOG10(YMAX)-LOG10(YMIN))/20.0D0
30648 YZOOM=(YMA-YMI)/DBLE(IZEIL)
30649 IF(YZOOM.LT.EPS) THEN
30650 WRITE(LOUT,'(1X,A)')
30651 & 'XGLOGY:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30660 L=NINT((X(K)-XMIN)/XZOOM)
30661 I=NINT((YMA-LOG10(Y1(K)))/YZOOM)
30662 IF(ILAST.GE.0) THEN
30665 DO 55 II=0,LD,SIGN(1,LD)
30666 DO 66 KK=0,ID,SIGN(1,ID)
30667 COL(II+LLAST,KK+ILAST)=SYMB(1)
30682 L=NINT((X(K)-XMIN)/XZOOM)
30683 I=NINT((YMA-LOG10(Y2(K)))/YZOOM)
30690 WRITE(LOUT,'(2X,A)') '(LOGARITHMIC Y AXIS)'
30691 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30693 C*** write range of X
30695 XZOOM1 = (XMAX-XMIN)/DBLE(7)
30696 WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30698 DO 1300 K=0,IZEIL-1
30699 YPOS=10.D0**(YMA-((DBLE(K)+0.5D0)*YZOOM))
30700 WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30701 110 FORMAT(1X,1PE9.2,70A1)
30704 C*** write range of X
30706 WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30707 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30708 120 FORMAT(6X,7(1PE10.3))
30712 *$ CREATE DT_SRPLOT.FOR
30715 *===plot===============================================================*
30717 SUBROUTINE DT_SRPLOT(X,Y,N,M,MM,XO,DX,YO,DY)
30719 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30722 PARAMETER ( LINP = 10 ,
30728 * J. Ranft, (FORTRAN-Programmierung,J.R.,Teubner, Leipzig, 72)
30729 * This is a subroutine of fluka to plot Y across the page
30730 * as a function of X down the page. Up to 37 curves can be
30731 * plotted in the same picture with different plotting characters.
30732 * Output of first 10 overprinted characters addad by FB 88
30733 * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
30736 * X = array containing the values of X
30737 * Y = array containing the values of Y
30738 * N = number of values in X and in Y
30739 * can exceed the fixed number of lines
30740 * M = number of different curves X,Y are containing
30741 * MM = number of points in each curve i.e. N=M*MM
30742 * XO = smallest value of X to be plotted
30743 * DX = increment of X between subsequent lines
30744 * YO = smallest value of Y to be plotted
30745 * DY = increment of Y between subsequent character spaces
30747 * other variables used inside:
30748 * XX = numbers along the X-coordinate axis
30749 * YY = numbers along the Y-coordinate axis
30750 * LL = ten lines temporary storage for the plot
30751 * L = character set used to plot different curves
30752 * LOV = memorizes overprinted symbols
30753 * the first 10 overprinted symbols are printed on
30754 * the end of the line to avoid ambiguities
30755 * (added by FB as considered quite helpful)
30757 *********************************************************************
30759 DIMENSION XX(61),YY(61),LL(101,10)
30760 DIMENSION X(N),Y(N),L(40),LOV(40,10)
30762 11H*,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HZ,
30763 21H+,1HA,1HO,1HB,1HC,1HD,1HE,1HF,1HG,1HH,
30764 31HI,1HJ,1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,
30765 41HS,1HT,1HU,1HV,1HW,1HX,1HY,1H1,1H-,1H /
30774 20 YY(I)=YO+10.0D0*AI*DY
30775 WRITE(LOUT, 500) (YY(I),I=1,11)
30797 AIX=(X(II)-(XO-DX/2.0D0))/DX+1.0D0
30798 AIY=(Y(II)-(YO-DY/2.0D0))/DY+1.0D0
30800 * changed Sept.88 by FB to avoid INTEGER OVERFLOW
30801 IF( AIX .GT. 1.D0.AND. AIX .LT. 11.D0.AND. AIY .GT. 1.D0.AND
30802 + . AIY .LT. 102.D0) THEN
30805 IF( IX.GT. 0.AND. IX.LE. 10.AND. IY.GT. 0.AND. IY.LE. 101)
30807 IF(LL(IY,IX).NE.L(38).AND.LL(IY,IX).NE.L(39)) LOV(I,IX)
30818 WRITE(LOUT,510) XX(II),XX(III) , (LL(J,I),J=1,101) ,
30819 & (LOV(J,I),J=1,10)
30825 WRITE(LOUT, 500) (YY(I),I=1,11)
30828 500 FORMAT(11X,11(1PE10.2),11HOVERPRINTED)
30829 510 FORMAT(1X,2(1PE10.2),101A1,1H ,10A1)
30830 520 FORMAT(20X,10('1---------'),'1')
30832 *$ CREATE DT_DEFSET.FOR
30835 *===defset=============================================================*
30837 BLOCK DATA DT_DEFSET
30839 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30842 * flags for input different options
30843 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
30844 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
30845 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
30847 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
30849 * emulsion treatment
30850 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
30854 DATA IFRAG / 2, 1 /
30858 DATA IOULEV / -1, -1, -1, -1, -1, -1 /
30859 DATA LEMCCK / .FALSE. /
30860 DATA LHADRO / .FALSE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,
30861 & .TRUE.,.TRUE.,.TRUE./
30862 DATA LSEADI / .TRUE. /
30863 DATA LEVAPO / .TRUE. /
30868 DATA EMUFRA / NCOMPX*0.0D0 /
30869 DATA IEMUMA / NCOMPX*1 /
30870 DATA IEMUCH / NCOMPX*1 /
30876 *$ CREATE DT_HADPRP.FOR
30879 *===hadprp=============================================================*
30881 BLOCK DATA DT_HADPRP
30883 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30886 * auxiliary common for reggeon exchange (DTUNUC 1.x)
30887 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
30888 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
30889 & IQTCHR(-6:6),MQUARK(3,39)
30891 * hadron index conversion (BAMJET <--> PDG)
30892 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
30893 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
30896 * names of hadrons used in input-cards
30898 COMMON /DTPAIN/ BTYPE(30)
30901 *----------------------------------------------------------------------*
30903 * Quark content of particles: *
30904 * index quark el. charge bar. charge isospin isospin3 *
30905 * 1 = u 2/3 1/3 1/2 1/2 *
30906 * -1 = ubar -2/3 -1/3 1/2 -1/2 *
30907 * 2 = d -1/3 1/3 1/2 -1/2 *
30908 * -2 = dbar 1/3 -1/3 1/2 1/2 *
30909 * 3 = s -1/3 1/3 0 0 *
30910 * -3 = sbar 1/3 -1/3 0 0 *
30911 * 4 = c 2/3 1/3 0 0 *
30912 * -4 = cbar -2/3 -1/3 0 0 *
30913 * 5 = b -1/3 1/3 0 0 *
30914 * -5 = bbar 1/3 -1/3 0 0 *
30915 * 6 = t 2/3 1/3 0 0 *
30916 * -6 = tbar -2/3 -1/3 0 0 *
30918 * Mquark = particle quark composition (Paprop numbering) *
30919 * Iqechr = electric charge ( in 1/3 unit ) *
30920 * Iqbchr = baryonic charge ( in 1/3 unit ) *
30921 * Iqichr = isospin ( in 1/2 unit ), z component *
30922 * Iqschr = strangeness *
30924 * Iquchr = beauty *
30925 * Iqtchr = ...... *
30927 *----------------------------------------------------------------------*
30928 DATA IQECHR / -2, 1, -2, 1, 1, -2, 0, 2, -1, -1, 2, -1, 2 /
30929 DATA IQBCHR / 6*-1, 0, 6*1 /
30930 DATA IQICHR / 4*0, 1, -1, 0, 1, -1, 4*0 /
30931 DATA IQSCHR / 3*0, 1, 5*0, -1, 3*0 /
30932 DATA IQCCHR / 2*0, -1, 7*0, 1, 2*0 /
30933 DATA IQUCHR / 0, 1, 9*0, -1, 0 /
30934 DATA IQTCHR / -1, 11*0, 1 /
30936 & 2, 1, 1, -2,-1,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
30937 & 0, 0, 0, 0, 0, 0, 2, 2, 1, -2,-2,-1, 0, 0, 0,
30938 & 0, 0, 0, 0, 0, 0, 1,-2, 0, 2,-1, 0, 1,-3, 0,
30939 & 3,-1, 0, 1, 2, 3, -1,-2,-3, 0, 0, 0, 2, 2, 3,
30940 & 1, 1, 3, 1, 2, 3, 1,-1, 0, 2,-3, 0, 3,-2, 0,
30941 & 2,-2, 0, 3,-3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
30942 & -1,-1,-3, -1,-2,-3, -2,-2,-3, 1, 3, 3, -1,-3,-3,
30943 & 2, 3, 3, -2,-3,-3, 3, 3, 3, -3,-3,-3 /
30946 * (renamed) (HAdron InDex COnversion)
30947 * translation table version filled up by r.e. 25.01.94 *
30949 &2212,-2212,11,-11,12, -12,22,2112,-2112,-13,
30950 &13,130,211,-211,321, -321,3122,-3122,310,3112,
30951 &3222,3212,111,311,-311, 0,0,0,0,0,
30952 &221,213,113,-213,223, 323,313,-323,-313,10323,
30953 &10313,-10323,-10313,30323,30313, -30323,-30313,3224,3214,3114,
30954 &3216,3218,2224,2214,2114, 1114,12224,12214,12114,11114,
30955 &99999,99999,22212,22112,32124, 31214,-2224,-2214,-2114,-1114,
30956 &-12224,-12214,-12114,-11114,-2124, -1214,4*99999,
30958 &4*99999,331, 333,3322,3312,-3222,-3212,
30959 &-3112,-3322,-3312,3224,3214, 3114,3324,3314,3334,-3224,
30960 &-3214,-3114,-3324,-3314,-3334, 421,411,-411,-421,431,
30961 &-431,441,423,413,-413, -423,433,-433,20443,443,
30962 &-15,15,16,-16,14, -14,4122,4232,4132,4222,
30963 &4212,4112,3*99999, 3*99999,-4122,-4232,
30964 &-4132,-4222,-4212,-4112,99999, 5*99999,
30967 &5*99999 , 20211,20111,-20211,99999,20321,
30968 &-20321,20311,-20311,7*99999 ,
30969 &7*99999,12212,12112,99999/
30972 * (HAdron InDex COnversion)
30973 DATA (IPDG2(1,K),K=1,7)
30974 & / -11, -12, -13, -15, -16, -14, 0/
30975 DATA (IBAM2(1,K),K=1,7)
30976 & / 4, 6, 10, 131, 134, 136, 0/
30977 DATA (IPDG2(2,K),K=1,7)
30978 & / 11, 12, 22, 13, 15, 16, 14/
30979 DATA (IBAM2(2,K),K=1,7)
30980 & / 3, 5, 7, 11, 132, 133, 135/
30981 DATA (IPDG3(1,K),K=1,22)
30982 & / -211, -321, -311, -213, -323, -313, -411, -421,
30983 & -431, -413, -423, -433, 0, 0, 0, 0,
30984 & 0, 0, 0, 0, 0, 0/
30985 DATA (IBAM3(1,K),K=1,22)
30986 & / 14, 16, 25, 34, 38, 39, 118, 119,
30987 & 121, 125, 126, 128, 0, 0, 0, 0,
30988 & 0, 0, 0, 0, 0, 0/
30989 DATA (IPDG3(2,K),K=1,22)
30990 & / 130, 211, 321, 310, 111, 311, 221, 213,
30991 & 113, 223, 323, 313, 331, 333, 421, 411,
30992 & 431, 441, 423, 413, 433, 443/
30993 DATA (IBAM3(2,K),K=1,22)
30994 & / 12, 13, 15, 19, 23, 24, 31, 32,
30995 & 33, 35, 36, 37, 95, 96, 116, 117,
30996 & 120, 122, 123, 124, 127, 130/
30997 DATA (IPDG4(1,K),K=1,29)
30998 & / -2212, -2112, -3122, -2224, -2214, -2114, -1114, -2124,
30999 & -1214, -3222, -3212, -3112, -3322, -3312, -3224, -3214,
31000 & -3114, -3324, -3314, -3334, -4122, -4232, -4132, -4222,
31001 & -4212, -4112, 0, 0, 0/
31002 DATA (IBAM4(1,K),K=1,29)
31003 & / 2, 9, 18, 67, 68, 69, 70, 75,
31004 & 76, 99, 100, 101, 102, 103, 110, 111,
31005 & 112, 113, 114, 115, 149, 150, 151, 152,
31006 & 153, 154, 0, 0, 0/
31007 DATA (IPDG4(2,K),K=1,29)
31008 & / 2212, 2112, 3122, 3112, 3222, 3212, 3224, 3214,
31009 & 3114, 3216, 3218, 2224, 2214, 2114, 1114, 3322,
31010 & 3312, 3224, 3214, 3114, 3324, 3314, 3334, 4122,
31011 & 4232, 4132, 4222, 4212, 4112/
31012 DATA (IBAM4(2,K),K=1,29)
31013 & / 1, 8, 17, 20, 21, 22, 48, 49,
31014 & 50, 51, 52, 53, 54, 55, 56, 97,
31015 & 98, 104, 105, 106, 107, 108, 109, 137,
31016 & 138, 139, 140, 141, 142/
31017 DATA (IPDG5(1,K),K=1,19)
31018 & /-10323,-10313,-30323,-30313,-12224,-12214,-12114,-11114,
31019 & -20211,-20321,-20311, 0, 0, 0, 0, 0,
31021 DATA (IBAM5(1,K),K=1,19)
31022 & / 42, 43, 46, 47, 71, 72, 73, 74,
31023 & 188, 191, 193, 0, 0, 0, 0, 0,
31025 DATA (IPDG5(2,K),K=1,19)
31026 & / 10323, 10313, 30323, 30313, 12224, 12214, 12114, 11114,
31027 & 22212, 22112, 32124, 31214, 20443, 20211, 20111, 20321,
31028 & 20311, 12212, 12112/
31029 DATA (IBAM5(2,K),K=1,19)
31030 & / 40, 41, 44, 45, 57, 58, 59, 60,
31031 & 63, 64, 65, 66, 129, 186, 187, 190,
31035 * internal particle names
31036 DATA BTYPE / 'PROTON ' , 'APROTON ' , 'ELECTRON' , 'POSITRON' ,
31037 &'NEUTRIE ' , 'ANEUTRIE' , 'PHOTON ' , 'NEUTRON ' , 'ANEUTRON' ,
31038 &'MUON+ ' , 'MUON- ' , 'KAONLONG' , 'PION+ ' , 'PION- ' ,
31039 &'KAON+ ' , 'KAON- ' , 'LAMBDA ' , 'ALAMBDA ' , 'KAONSHRT' ,
31040 &'SIGMA- ' , 'SIGMA+ ' , 'SIGMAZER' , 'PIZERO ' , 'KAONZERO' ,
31041 &'AKAONZER' , 'NEUTRIM ' , 'ANEUTRIM' , 'NEUTRIT ' , 'ANEUTRIT' ,
31046 *$ CREATE DT_BLKD46.FOR
31049 *===blkd46=============================================================*
31051 BLOCK DATA DT_BLKD46
31053 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31056 PARAMETER ( AMELCT = 0.51099906 D-03 )
31057 PARAMETER ( AMMUON = 0.105658389 D+00 )
31059 * particle properties (BAMJET index convention)
31061 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
31062 & IICH(210),IIBAR(210),K1(210),K2(210)
31065 * Particle masses Engel version JETSET compatible
31066 C DATA (AAM(K),K=1,85) /
31067 C & .9383D+00, .9383D+00, AMELCT , AMELCT , .0000D+00,
31068 C & .0000D+00, .0000D+00, .9396D+00, .9396D+00, AMMUON ,
31069 C & AMMUON , .4977D+00, .1396D+00, .1396D+00, .4936D+00,
31070 C & .4936D+00, .1116D+01, .1116D+01, .4977D+00, .1197D+01,
31071 C & .1189D+01, .1193D+01, .1350D+00, .4977D+00, .4977D+00,
31072 C & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31073 C & .5488D+00, .7669D+00, .7700D+00, .7669D+00, .7820D+00,
31074 C & .8921D+00, .8962D+00, .8921D+00, .8962D+00, .1300D+01,
31075 C & .1300D+01, .1300D+01, .1300D+01, .1421D+01, .1421D+01,
31076 C & .1421D+01, .1421D+01, .1383D+01, .1384D+01, .1387D+01,
31077 C & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
31078 C & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
31079 C & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
31080 C & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
31081 C & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
31082 C & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
31083 C & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 /
31084 C DATA (AAM(K),K=86,183) /
31085 C & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
31086 C & .1700D+01, .1700D+01, .1820D+01, .2030D+01, .9575D+00,
31087 C & .1019D+01, .1315D+01, .1321D+01, .1189D+01, .1193D+01,
31088 C & .1197D+01, .1315D+01, .1321D+01, .1383D+01, .1384D+01,
31089 C & .1387D+01, .1532D+01, .1535D+01, .1672D+01, .1383D+01,
31090 C & .1384D+01, .1387D+01, .1532D+01, .1535D+01, .1672D+01,
31091 C & .1865D+01, .1869D+01, .1869D+01, .1865D+01, .1969D+01,
31092 C & .1969D+01, .2980D+01, .2007D+01, .2010D+01, .2010D+01,
31093 C & .2007D+01, .2113D+01, .2113D+01, .3686D+01, .3097D+01,
31094 C & .1784D+01, .1784D+01, .0000D+00, .0000D+00, .0000D+00,
31095 C & .0000D+00, .2285D+01, .2460D+01, .2460D+01, .2452D+01,
31096 C & .2453D+01, .2454D+01, .2560D+01, .2560D+01, .2730D+01,
31097 C & .3610D+01, .3610D+01, .3790D+01, .2285D+01, .2460D+01,
31098 C & .2460D+01, .2452D+01, .2453D+01, .2454D+01, .2560D+01,
31099 C & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
31100 C & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31101 C & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31102 C & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31103 C & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31104 C & .1250D+01, .1250D+01, .1250D+01 /
31105 C DATA (AAM ( I ), I = 184,210 ) /
31106 C & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31107 C & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31108 C & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31109 C & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31110 C & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31111 C & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31112 C & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31113 C & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31114 C & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31115 * sr 25.1.06: particle masses adjusted to Pythia
31116 DATA (AAM(K),K=1,85) /
31117 & .938270E+00,.938270E+00, AMELCT , AMELCT ,.000000E+00,
31118 & .000000E+00,.000000E+00,.939570E+00,.939570E+00, AMMUON ,
31119 & AMMUON ,.497670E+00,.139570E+00,.139570E+00,.493600E+00,
31120 & .493600E+00,.111568E+01,.111568E+01,.497670E+00,.119744E+01,
31121 & .118937E+01,.119255E+01,.134980E+00,.497670E+00,.497670E+00,
31122 & .0000D+00, .0000D+00, .0000D+00 , .0000D+00, .0000D+00,
31123 & .547450E+00,.766900E+00,.768500E+00,.766900E+00,.781940E+00,
31124 & .891600E+00,.896100E+00,.891600E+00,.896100E+00,.129000E+01,
31125 & .129000E+01,.129000E+01,.129000E+01, .1421D+01, .1421D+01,
31126 & .1421D+01, .1421D+01,.138280E+01,.138370E+01,.138720E+01,
31127 & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
31128 & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
31129 & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
31130 & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
31131 & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
31132 & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
31133 & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 /
31134 DATA (AAM(K),K=86,183) /
31135 & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
31136 & .1700D+01, .1700D+01, .1820D+01, .2030D+01,.957770E+00,
31137 & .101940E+01,.131490E+01,.132130E+01,.118937E+01,.119255E+01,
31138 & .119744E+01,.131490E+01,.132130E+01,.138280E+01,.138370E+01,
31139 & .138720E+01,.153180E+01, .1535D+01,.167245E+01,.138280E+01,
31140 & .138370E+01,.138720E+01,.153180E+01, .1535D+01,.167245E+01,
31141 & .186450E+01,.186930E+01,.186930E+01,.186450E+01,.196850E+01,
31142 & .196850E+01,.297980E+01,.200670E+01, .2010D+01, .2010D+01,
31143 & .200670E+01,.211240E+01,.211240E+01, .3686D+01,.309688E+01,
31144 & .177700E+01,.177700E+01, .0000D+00, .0000D+00, .0000D+00,
31145 & .0000D+00,.228490E+01,.246560E+01,.247030E+01,.245290E+01,
31146 & .245350E+01,.245210E+01, .2560D+01, .2560D+01, .2730D+01,
31147 & .3610D+01, .3610D+01, .3790D+01,.228490E+01,.246560E+01,
31148 & .2460D+01,.245290E+01,.245350E+01,.245210E+01, .2560D+01,
31149 & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
31150 & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31151 & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31152 & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31153 & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31154 & .1250D+01, .1250D+01, .1250D+01 /
31155 DATA (AAM ( I ), I = 184,210 ) /
31156 & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31157 & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31158 & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31159 & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31160 & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31161 & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31162 & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31163 & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31164 & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31165 * Particle mean lives
31166 DATA (TAU(K),K=1,183) /
31167 & .1000D+19, .1000D+19, .1000D+19, .1000D+19, .1000D+19,
31168 & .1000D+19, .1000D+19, .9180D+03, .9180D+03, .2200D-05,
31169 & .2200D-05, .5200D-07, .2600D-07, .2600D-07, .1200D-07,
31170 & .1200D-07, .2600D-09, .2600D-09, .9000D-10, .1500D-09,
31171 & .8000D-10, .5000D-14, .8000D-16, .0000D+00, .0000D+00,
31173 & .0000D+00, .3000D-09, .1700D-09, .8000D-10, .1000D-13,
31174 & .1500D-09, .3000D-09, .1700D-09, .0000D+00, .0000D+00,
31175 & .0000D+00, .0000D+00, .0000D+00, .1000D-09, .0000D+00,
31176 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .1000D-09,
31177 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31178 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31179 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31180 & .9000D-11, .9000D-11, .9000D-11, .9000D-11, .1000D+19,
31181 & .1000D+19, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31183 & .0000D+00, .0000D+00, .0000D+00 /
31184 DATA ( TAU ( I ), I = 184,210 ) /
31185 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31186 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31187 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31188 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31189 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31190 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31191 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31192 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31193 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00/
31194 * Resonance width Gamma in GeV
31195 DATA (GA(K),K= 1,85) /
31197 & .8500D-06, .1520D+00, .1520D+00, .1520D+00, .1000D-01,
31198 & .7900D-01, .7900D-01, .7900D-01, .7900D-01, .4500D+00,
31199 & .4500D+00, .4500D+00, .4500D+00, .1080D+00, .1080D+00,
31200 & .1080D+00, .1080D+00, .5000D-01, .5000D-01, .5000D-01,
31201 & .8500D-01, .1800D+00, .1150D+00, .1150D+00, .1150D+00,
31202 & .1150D+00, .2000D+00, .2000D+00, .2000D+00, .2000D+00,
31203 & .2000D+00, .2000D+00, .1000D+00, .1000D+00, .2000D+00,
31204 & .2000D+00, .1150D+00, .1150D+00, .1150D+00, .1150D+00,
31205 & .2000D+00, .2000D+00, .2000D+00, .2000D+00, .1000D+00,
31206 & .1000D+00, .2000D+00, .1000D+00, .1000D+00, .1000D+00,
31207 & .1000D+00, .1000D+00, .1000D+00, .1000D+00, .2000D+00 /
31208 DATA (GA(K),K= 86,183) /
31209 & .2000D+00, .2000D+00, .2000D+00, .1500D+00, .1500D+00,
31210 & .1500D+00, .1500D+00, .8500D-01, .1800D+00, .2000D-02,
31211 & .4000D-02, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31212 & .0000D+00, .0000D+00, .0000D+00, .3400D-01, .3400D-01,
31213 & .3600D-01, .9000D-02, .9000D-02, .0000D+00, .3400D-01,
31214 & .3400D-01, .3600D-01, .9000D-02, .9000D-02, .0000D+00,
31215 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31216 & .0000D+00, .0000D+00, .5000D-02, .2000D-02, .2000D-02,
31217 & .5000D-02, .2000D-02, .2000D-02, .2000D-03, .7000D-03,
31219 & .3000D+00, .3000D+00, .3000D+00 /
31220 DATA ( GA ( I ), I = 184,210 ) /
31221 & 2.00000000000000D-01, 2.00000000000000D-01, 3.00000000000000D-01,
31222 & 3.00000000000000D-01, 3.00000000000000D-01, 2.70000000000000D-01,
31223 & 2.50000000000000D-01, 2.50000000000000D-01, 2.50000000000000D-01,
31224 & 2.50000000000000D-01, 1.50000000000000D-01, 1.50000000000000D-01,
31225 & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31226 & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31227 & 6.00000000000000D-02, 6.00000000000000D-02, 6.00000000000000D-02,
31228 & 6.00000000000000D-02, 5.50000000000000D-02, 5.50000000000000D-02,
31229 & 2.00000000000000D-01, 2.00000000000000D-01, 0.00000000000000D+00/
31231 * S+1385+Sigma+(1385) L02030+Lambda0(2030)
31232 * Rho77=Rho(770) Om783=Omega(783) K*14=K*(1420) and so on
31233 * designation N*@@ means N*@1(@2)
31234 DATA (ANAME(K),K=1,85) /
31235 & 'P ','AP ','E- ','E+ ','NUE ',
31236 & 'ANUE ','GAM ','NEU ','ANEU ','MUE+ ',
31237 & 'MUE- ','K0L ','PI+ ','PI- ','K+ ',
31238 & 'K- ','LAM ','ALAM ','K0S ','SIGM- ',
31239 & 'SIGM+ ','SIGM0 ','PI0 ','K0 ','AK0 ',
31240 & 'BLANK ','BLANK ','BLANK ','BLANK ','BLANK ',
31241 & 'ETA550 ','RHO+77 ','RHO077 ','RHO-77 ','OM0783 ',
31242 & 'K*+892 ','K*0892 ','K*-892 ','AK*089 ','KA+125 ',
31243 & 'KA0125 ','KA-125 ','AKA012 ','K*+142 ','K*0142 ',
31244 & 'K*-142 ','AK*014 ','S+1385 ','S01385 ','S-1385 ',
31245 & 'L01820 ','L02030 ','N*++12 ','N*+ 12 ','N*012 ',
31246 & 'N*-12 ','N*++16 ','N*+16 ','N*016 ','N*-16 ',
31247 & 'N*+14 ','N*014 ','N*+15 ','N*015 ','N*+18 ',
31248 & 'N*018 ','AN--12 ','AN*-12 ','AN*012 ','AN*+12 ',
31249 & 'AN--16 ','AN*-16 ','AN*016 ','AN*+16 ','AN*-15 ',
31250 & 'AN*015 ','DE*=24 ','RPI+49 ','RPI049 ','RPI-49 ',
31251 & 'PIN++ ','PIN+0 ','PIN+- ','PIN-0 ','PPPI ' /
31252 DATA (ANAME(K),K=86,183) /
31253 & 'PNPI ','APPPI ','APNPI ','K+PPI ','K-PPI ',
31254 & 'K+NPI ','K-NPI ','S+1820 ','S-2030 ','ETA* ',
31255 & 'PHI ','TETA0 ','TETA- ','ASIG- ','ASIG0 ',
31256 & 'ASIG+ ','ATETA0 ','ATETA+ ','SIG*+ ','SIG*0 ',
31257 & 'SIG*- ','TETA*0 ','TETA* ','OMEGA- ','ASIG*- ',
31258 & 'ASIG*0 ','ASIG*+ ','ATET*0 ','ATET*+ ','OMEGA+ ',
31259 & 'D0 ','D+ ','D- ','AD0 ','F+ ',
31260 & 'F- ','ETAC ','D*0 ','D*+ ','D*- ',
31261 & 'AD*0 ','F*+ ','F*- ','PSI ','JPSI ',
31262 & 'TAU+ ','TAU- ','NUET ','ANUET ','NUEM ',
31263 & 'ANUEM ','C0+ ','A+ ','A0 ','C1++ ',
31264 & 'C1+ ','C10 ','S+ ','S0 ','T0 ',
31265 & 'XU++ ','XD+ ','XS+ ','AC0- ','AA- ',
31266 & 'AA0 ','AC1-- ','AC1- ','AC10 ','AS- ',
31267 & 'AS0 ','AT0 ','AXU-- ','AXD- ','AXS ',
31268 & 'C1*++ ','C1*+ ','C1*0 ','S*+ ','S*0 ',
31269 & 'T*0 ','XU*++ ','XD*+ ','XS*+ ','TETA++ ',
31270 & 'AC1*-- ','AC1*- ','AC1*0 ','AS*- ','AS*0 ',
31271 & 'AT*0 ','AXU*-- ','AXD*- ','AXS*- ','ATET-- ',
31272 & 'RO ','R+ ','R- ' /
31273 DATA ( ANAME ( I ), I = 184,210 ) /
31274 &'AN*-14 ','AN*014 ','PI+130 ','PI0130 ','PI-130 ','F01400 ',
31275 &'K*+146 ','K*-146 ','K*0146 ','AK0146 ','L01600 ','AL0160 ',
31276 &'S+1660 ','S01660 ','S-1660 ','AS-166 ','AS0166 ','AS+166 ',
31277 &'X01950 ','X-1950 ','AX0195 ','AX+195 ','OM-225 ','AOM+22 ',
31278 &'N*+14 ','N*014 ','BLANK '/
31279 * Charge of particles and resonances
31280 DATA (IICH ( I ), I = 1,210 ) /
31281 & 1, -1, -1, 1, 0, 0, 0, 0, 0, 1, -1, 0, 1, -1, 1,
31282 & -1, 0, 0, 0, -1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31283 & 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0,
31284 & -1, 0, 1, 0, -1, 0, 0, 2, 1, 0, -1, 2, 1, 0, -1,
31285 & 1, 0, 1, 0, 1, 0, -2, -1, 0, 1, -2, -1, 0, 1, -1,
31286 & 0, 1, 1, 0, -1, 2, 1, 0, -1, 2, 1, 0, -1, 2, 0,
31287 & 1, -1, 1, -1, 0, 0, 0, -1, -1, 0, 1, 0, 1, 1, 0,
31288 & -1, 0, -1, -1, -1, 0, 1, 0, 1, 1, 0, 1, -1, 0, 1,
31289 & -1, 0, 0, 1, -1, 0, 1, -1, 0, 0, 1, -1, 0, 0, 0,
31290 & 0, 1, 1, 0, 2, 1, 0, 1, 0, 0, 2, 1, 1, -1, -1,
31291 & 0, -2, -1, 0, -1, 0, 0, -2, -1, -1, 2, 1, 0, 1, 0,
31292 & 0, 2, 1, 1, 2, -2, -1, 0, -1, 0, 0, -2, -1, -1, -2,
31293 & 0, 1, -1, -1, 0, 1, 0, -1, 0, 1, -1, 0, 0, 0, 0,
31294 & 1, 0, -1, -1, 0, 1, 0, -1, 0, 1, -1, 1, 1, 0, 0/
31295 * Particle baryonic charges
31296 DATA (IIBAR ( I ), I = 1,210 ) /
31297 & 1, -1, 0, 0, 0, 0, 0, 1, -1, 0, 0, 0, 0, 0, 0,
31298 & 0, 1, -1, 0, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0,
31299 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31300 & 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
31301 & 1, 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31302 & -1, 2, 0, 0, 0, 1, 1, 1, 1, 2, 2, 0, 0, 1, 1,
31303 & 1, 1, 1, 1, 0, 0, 1, 1, -1, -1, -1, -1, -1, 1, 1,
31304 & 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, 0, 0, 0, 0, 0,
31305 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31306 & 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, -1, -1,
31307 & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 1, 1, 1, 1, 1,
31308 & 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31309 & 0, 0, 0, -1, -1, 0, 0, 0, 0, 0, 0, 0, 0, 1, -1,
31310 & 1, 1, 1, -1, -1, -1, 1, 1, -1, -1, 1, -1, 1, 1, 0/
31311 * First number of decay channels used for resonances
31312 * and decaying particles
31313 DATA K1/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 16, 17,
31314 & 18, 24, 30, 34, 38, 40, 41, 43, 44, 136, 138, 330, 327, 328,
31315 & 2*330, 46, 51, 52, 54, 55, 58,
31317 & 60, 62, 64, 66, 68, 70, 72, 74, 82, 90, 98, 106, 109, 112, 114,
31318 & 123, 140, 141, 143, 145, 146, 150, 157, 164, 168, 174, 180, 187,
31319 & 194, 202, 210, 211, 213, 215, 216, 220, 227, 234, 238, 245, 252,
31321 & 254, 255, 256, 257, 259, 262, 265, 267, 269, 272, 276, 279, 282,
31322 & 286, 290, 293, 299, 331, 335, 339, 340, 341, 343, 344, 345, 346,
31323 & 347, 350, 353, 356, 358, 360, 363, 366, 369, 372, 374, 376, 379,
31324 & 383, 385, 387, 391, 394, 397, 400, 402, 405, 408, 410, 412, 414,
31325 & 417, 420, 425, 430, 431, 432, 433, 434, 448, 452, 457, 458, 459,
31326 & 460, 461, 462, 466, 468, 470, 472, 486, 490, 495, 496, 497, 498,
31327 & 499, 500, 504, 506, 508, 510, 511, 512, 513, 514, 515, 516, 517,
31328 & 518, 519, 522, 523, 524, 525, 526, 527, 528, 529, 530, 531, 534,
31329 & 537, 539, 541, 547, 553, 558, 563, 568, 572, 573, 574, 575, 576,
31330 & 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, 589,
31332 * Last number of decay channels used for resonances
31333 * and decaying particles
31334 DATA K2/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 15, 16, 17,
31335 & 23, 29, 31, 35, 39, 40, 42, 43, 45, 137, 139, 330, 327, 328,
31336 & 2* 330, 50, 51, 53, 54, 57,
31338 & 59, 61, 63, 65, 67, 69, 71, 73, 81, 89, 97, 105, 108, 111, 113,
31339 & 122, 135, 140, 142, 144, 145, 149, 156, 163, 167, 173, 179, 186,
31340 & 193, 201, 209, 210, 212, 214, 215, 219, 226, 233, 237, 244, 251,
31342 & 253, 254, 255, 256, 258, 261, 264, 266, 268, 271, 275, 278, 281,
31343 & 285, 289, 292, 298, 307, 334, 338, 339, 340, 342, 343, 344, 345,
31344 & 346, 349, 352, 355, 357, 359, 362, 365, 368, 371, 373, 375, 378,
31345 & 382, 384, 386, 390, 393, 396, 399, 401, 404, 407, 409, 411, 413,
31346 & 416, 419, 424, 429, 430, 431, 432, 433, 447, 451, 456, 457, 458,
31347 & 459, 460, 461, 465, 467, 469, 471, 485, 489, 494, 495, 496, 497,
31348 & 498, 499, 503, 505, 507, 509, 510, 511, 512, 513, 514, 515, 516,
31349 & 517, 518, 521, 522, 523, 524, 525, 526, 527, 528, 529, 530, 533,
31350 & 536, 538, 540, 546, 552, 557, 562, 567, 571, 572, 573, 574, 575,
31351 & 576, 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588,
31352 & 589, 595, 601, 602 /
31356 *$ CREATE DT_BLKD47.FOR
31359 *===blkd47=============================================================*
31361 BLOCK DATA DT_BLKD47
31363 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31366 * HADRIN: decay channel information
31367 PARAMETER (IDMAX9=602)
31369 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
31371 * Name of decay channel
31372 * Designation N*@ means N*@1(1236)
31373 * @1=# means ++, @1 = = means --
31374 * Designation P+/0/- means Pi+/Pi0/Pi- , respectively
31375 DATA (ZKNAME(K),K= 1, 85) /
31376 & 'P ','AP ','E- ','E+ ','NUE ',
31377 & 'ANUE ','GAM ','PE-NUE ','APEANU ','EANUNU ',
31378 & 'E-NUAN ','3PI0 ','PI+-0 ','PIMUNU ','PIE-NU ',
31379 & 'MU+NUE ','MU-NUE ','MU+NUE ','PI+PI0 ','PI++- ',
31380 & 'PI+00 ','M+P0NU ','E+P0NU ','MU-NU ','PI-0 ',
31381 & 'PI+-- ','PI-00 ','M-P0NU ','E-P0NU ','PPI- ',
31382 & 'NPI0 ','PD-NUE ','PM-NUE ','APPI+ ','ANPI0 ',
31383 & 'APE+NU ','APM+NU ','PI+PI- ','PI0PI0 ','NPI- ',
31384 & 'PPI0 ','NPI+ ','LAGA ','GAGA ','GAE+E- ',
31385 & 'GAGA ','GAGAP0 ','PI000 ','PI+-0 ','PI+-GA ',
31386 & 'PI+0 ','PI+- ','PI00 ','PI-0 ','PI+-0 ',
31387 & 'PI+- ','PI0GA ','K+PI0 ','K0PI+ ','KOPI0 ',
31388 & 'K+PI- ','K-PI0 ','AK0PI- ','AK0PI0 ','K-PI+ ',
31389 & 'K+PI0 ','K0PI+ ','K0PI0 ','K+PI- ','K-PI0 ',
31390 & 'K0PI- ','AK0PI0 ','K-PI+ ','K+PI0 ','K0PI+ ',
31391 & 'K+89P0 ','K08PI+ ','K+RO77 ','K0RO+7 ','K+OM07 ',
31392 & 'K+E055 ','K0PI0 ','K+PI+ ','K089P0 ','K+8PI- ' /
31393 DATA (ZKNAME(K),K= 86,170) /
31394 & 'K0R077 ','K+R-77 ','K+R-77 ','K0OM07 ','K0E055 ',
31395 & 'K-PI0 ','K0PI- ','K-89P0 ','AK08P- ','K-R077 ',
31396 & 'AK0R-7 ','K-OM07 ','K-E055 ','AK0PI0 ','K-PI+ ',
31397 & 'AK08P0 ','K-8PI+ ','AK0R07 ','AK0OM7 ','AK0E05 ',
31398 & 'LA0PI+ ','SI0PI+ ','SI+PI0 ','LA0PI0 ','SI+PI- ',
31399 & 'SI-PI+ ','LA0PI- ','SI0PI- ','NEUAK0 ','PK- ',
31400 & 'SI+PI- ','SI0PI0 ','SI-PI+ ','LA0ET0 ','S+1PI- ',
31401 & 'S-1PI+ ','SO1PI0 ','NEUAK0 ','PK- ','LA0PI0 ',
31402 & 'LA0OM0 ','LA0RO0 ','SI+RO- ','SI-RO+ ','SI0RO0 ',
31403 & 'LA0ET0 ','SI0ET0 ','SI+PI- ','SI-PI+ ','SI0PI0 ',
31404 & 'K0S ','K0L ','K0S ','K0L ','P PI+ ',
31405 & 'P PI0 ','N PI+ ','P PI- ','N PI0 ','N PI- ',
31406 & 'P PI+ ','N*#PI0 ','N*+PI+ ','PRHO+ ','P PI0 ',
31407 & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ',
31408 & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ',
31409 & 'N*-PI+ ','PRHO- ','NRHO0 ','N PI- ','N*0PI- ',
31410 & 'N*-PI0 ','NRHO- ','PETA0 ','N*#PI- ','N*+PI0 ' /
31411 DATA (ZKNAME(K),K=171,255) /
31412 & 'N*0PI+ ','PRHO0 ','NRHO+ ','NETA0 ','N*+PI- ',
31413 & 'N*0PI0 ','N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ',
31414 & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ',
31415 & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ',
31416 & 'N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ','N PI+ ',
31417 & 'PRHO0 ','NRHO+ ','LAMK+ ','S+ K0 ','S0 K+ ',
31418 & 'PETA0 ','P PI- ','N PI0 ','PRHO- ','NRHO0 ',
31419 & 'LAMK0 ','S0 K0 ','S- K+ ','NETA/ ','APPI- ',
31420 & 'APPI0 ','ANPI- ','APPI+ ','ANPI0 ','ANPI+ ',
31421 & 'APPI- ','AN*=P0 ','AN*-P- ','APRHO- ','APPI0 ',
31422 & 'ANPI- ','AN*=P+ ','AN*-P0 ','AN*0P- ','APRHO0 ',
31423 & 'ANRHO- ','APPI+ ','ANPI0 ','AN*-P+ ','AN*0P0 ',
31424 & 'AN*+P- ','APRHO+ ','ANRHO0 ','ANPI+ ','AN*0P+ ',
31425 & 'AN*+P0 ','ANRHO+ ','APPI0 ','ANPI- ','AN*=P+ ',
31426 & 'AN*-P0 ','AN*0P- ','APRHO0 ','ANRHO- ','APPI+, ',
31427 & 'ANPI0 ','AN*-P+ ','AN*0P0 ','AN*+P- ','APRHO+ ',
31428 & 'ANRHO0 ','PN*014 ','NN*=14 ','PI+0 ','PI+- ' /
31429 DATA (ZKNAME(K),K=256,340) /
31430 & 'PI-0 ','P+0 ','N++ ','P+- ','P00 ',
31431 & 'N+0 ','N+- ','N00 ','P-0 ','N-0 ',
31432 & 'P-- ','PPPI0 ','PNPI+ ','PNPI0 ','PPPI- ',
31433 & 'NNPI+ ','APPPI0 ','APNPI+ ','ANNPI0 ','ANPPI- ',
31434 & 'APNPI0 ','APPPI- ','ANNPI- ','K+PPI0 ','K+NPI+ ',
31435 & 'K0PPI0 ','K-PPI0 ','K-NPI+ ','AKPPI- ','AKNPI0 ',
31436 & 'K+NPI0 ','K+PPI- ','K0PPI0 ','K0NPI+ ','K-NPI0 ',
31437 & 'K-PPI- ','AKNPI- ','PAK0 ','SI+PI0 ','SI0PI+ ',
31438 & 'SI+ETA ','S+1PI0 ','S01PI+ ','NEUK- ','LA0PI- ',
31439 & 'SI-OM0 ','LA0RO- ','SI0RO- ','SI-RO0 ','SI-ET0 ',
31440 & 'SI0PI- ','SI-0 ','BLANC ','BLANC ','BLANC ',
31441 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31442 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31443 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31444 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31445 & 'EPI+- ','EPI00 ','GAPI+- ','GAGA* ','K+- ',
31446 & 'KLKS ','PI+-0 ','EGA ','LPI0 ','LPI ' /
31447 DATA (ZKNAME(K),K=341,425) /
31448 & 'APPI0 ','ANPI- ','ALAGA ','ANPI ','ALPI0 ',
31449 & 'ALPI+ ','LAPI+ ','SI+PI0 ','SI0PI+ ','LAPI0 ',
31450 & 'SI+PI- ','SI-PI+ ','LAPI- ','SI-PI0 ','SI0PI- ',
31451 & 'TE0PI0 ','TE-PI+ ','TE0PI- ','TE-PI0 ','TE0PI ',
31452 & 'TE-PI ','LAK- ','ALPI- ','AS-PI0 ','AS0PI- ',
31453 & 'ALPI0 ','AS+PI- ','AS-PI+ ','ALPI+ ','AS+PI0 ',
31454 & 'AS0PI+ ','AT0PI0 ','AT+PI- ','AT0PI+ ','AT+PI0 ',
31455 & 'AT0PI ','AT+PI ','ALK+ ','K-PI+ ','K-PI+0 ',
31456 & 'K0PI+- ','K0PI0 ','K-PI++ ','AK0PI+ ','K+PI-- ',
31457 & 'K0PI- ','K+PI- ','K+PI-0 ','AKPI-+ ','AK0PI0 ',
31458 & 'ETAPIF ','K++- ','K+AK0 ','ETAPI- ','K--+ ',
31459 & 'K-K0 ','PI00 ','PI+- ','GAGA ','D0PI0 ',
31460 & 'D0GA ','D0PI+ ','D+PI0 ','DFGA ','AD0PI- ',
31461 & 'D-PI0 ','D-GA ','AD0PI0 ','AD0GA ','F+GA ',
31462 & 'F+GA ','F-GA ','F-GA ','PSPI+- ','PSPI00 ',
31463 & 'PSETA ','E+E- ','MUE+- ','PI+-0 ','M+NN ',
31464 & 'E+NN ','RHO+NT ','PI+ANT ','K*+ANT ','M-NN ' /
31465 DATA (ZKNAME(K),K=426,510) /
31466 & 'E-NN ','RHO-NT ','PI-NT ','K*-NT ','NUET ',
31467 & 'ANUET ','NUEM ','ANUEM ','SI+ETA ','SI+ET* ',
31468 & 'PAK0 ','TET0K+ ','SI*+ET ','N*+AK0 ','N*++K- ',
31469 & 'LAMRO+ ','SI0RO+ ','SI+RO0 ','SI+OME ','PAK*0 ',
31470 & 'N*+AK* ','N*++K* ','SI+AK0 ','TET0PI ','SI+AK* ',
31471 & 'TET0RO ','SI0AK* ','SI+K*- ','TET0OM ','TET-RO ',
31472 & 'SI*0AK ','C0+PI+ ','C0+PI0 ','C0+PI- ','A+GAM ',
31473 & 'A0GAM ','TET0AK ','TET0K* ','OM-RO+ ','OM-PI+ ',
31474 & 'C1++AK ','A+PI+ ','C0+AK0 ','A0PI+ ','A+AK0 ',
31475 & 'T0PI+ ','ASI-ET ','ASI-E* ','APK0 ','ATET0K ',
31476 & 'ASI*-E ','AN*-K0 ','AN*--K ','ALAMRO ','ASI0RO ',
31477 & 'ASI-RO ','ASI-OM ','APK*0 ','AN*-K* ','AN*--K ',
31478 & 'ASI-K0 ','ATETPI ','ASI-K* ','ATETRO ','ASI0K* ',
31479 & 'ASI-K* ','ATE0OM ','ATE+RO ','ASI*0K ','AC-PI- ',
31480 & 'AC-PI0 ','AC-PI+ ','AA-GAM ','AA0GAM ','ATET0K ',
31481 & 'ATE0K* ','AOM+RO ','AOM+PI ','AC1--K ','AA-PI- ',
31482 & 'AC0-K0 ','AA0PI- ','AA-K0 ','AT0PI- ','C1++GA ' /
31483 DATA (ZKNAME(K),K=511,540) /
31484 & 'C1++GA ','C10GAM ','S+GAM ','S0GAM ','T0GAM ',
31485 & 'XU++GA ','XD+GAM ','XS+GAM ','A+AKPI ','T02PI+ ',
31486 & 'C1++2K ','AC1--G ','AC1-GA ','AC10GA ','AS-GAM ',
31487 & 'AS0GAM ','AT0GAM ','AXU--G ','AXD-GA ','AXS-GA ',
31488 & 'AA-KPI ','AT02PI ','AC1--K ','RH-PI+ ','RH+PI- ',
31489 & 'RH3PI0 ','RH0PI+ ','RH+PI0 ','RH0PI- ','RH-PI0 ' /
31490 DATA (ZKNAME(I),I=541,602)/
31491 & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHO0','ANRHO-','ANETA ',
31492 & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0','RH0PI+','RH+PI0',
31493 & '3PI+00','3PI-++','F0PI+ ','RH+PI-','RH0PI0','3PI000','3PI0+-',
31494 & 'F0PI0 ','RH0PI-','RH-PI0','3PI-00','3PI--+','F0PI- ','PI0PI0',
31495 & 'PI+PI-','K+K- ','K0AK0 ','L01600','AL0160','K*+146','K*-146',
31496 & 'K*0146','AK0146','S+1660','S01660','S-1660','AS-166','AS0166',
31497 & 'AS+166','X01690','X-1690','AX0169','AX+169','OM-225','AOM+22',
31498 & 'N*PPI0','N*NPI+','N*P2P0','N*PP+-','N*D+P0','N*D0P+','N*NPI0',
31499 & 'N*PPI-','N*N2P0','N*NP+-','N*D+P-','N*D0P0','BLANK '/
31500 * Weight of decay channel
31501 DATA (WT(K),K= 1, 85) /
31502 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31503 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31504 & .1000D+01, .2100D+00, .1200D+00, .2700D+00, .4000D+00,
31505 & .1000D+01, .1000D+01, .6400D+00, .2100D+00, .6000D-01,
31506 & .2000D-01, .3000D-01, .4000D-01, .6400D+00, .2100D+00,
31507 & .6000D-01, .2000D-01, .3000D-01, .4000D-01, .6400D+00,
31508 & .3600D+00, .0000D+00, .0000D+00, .6400D+00, .3600D+00,
31509 & .0000D+00, .0000D+00, .6900D+00, .3100D+00, .1000D+01,
31510 & .5200D+00, .4800D+00, .1000D+01, .9900D+00, .1000D-01,
31511 & .3800D+00, .3000D-01, .3000D+00, .2400D+00, .5000D-01,
31512 & .1000D+01, .1000D+01, .0000D+00, .1000D+01, .9000D+00,
31513 & .1000D-01, .9000D-01, .3300D+00, .6700D+00, .3300D+00,
31514 & .6700D+00, .3300D+00, .6700D+00, .3300D+00, .6700D+00,
31515 & .3300D+00, .6700D+00, .3300D+00, .6700D+00, .3300D+00,
31516 & .6700D+00, .3300D+00, .6700D+00, .1900D+00, .3800D+00,
31517 & .9000D-01, .2000D+00, .3000D-01, .4000D-01, .5000D-01,
31518 & .2000D-01, .1900D+00, .3800D+00, .9000D-01, .2000D+00 /
31519 DATA (WT(K),K= 86,170) /
31520 & .3000D-01, .4000D-01, .5000D-01, .2000D-01, .1900D+00,
31521 & .3800D+00, .9000D-01, .2000D+00, .3000D-01, .4000D-01,
31522 & .5000D-01, .2000D-01, .1900D+00, .3800D+00, .9000D-01,
31523 & .2000D+00, .3000D-01, .4000D-01, .5000D-01, .2000D-01,
31524 & .8800D+00, .6000D-01, .6000D-01, .8800D+00, .6000D-01,
31525 & .6000D-01, .8800D+00, .1200D+00, .1900D+00, .1900D+00,
31526 & .1600D+00, .1600D+00, .1700D+00, .3000D-01, .3000D-01,
31527 & .3000D-01, .4000D-01, .1000D+00, .1000D+00, .2000D+00,
31528 & .1200D+00, .1000D+00, .4000D-01, .4000D-01, .5000D-01,
31529 & .7500D-01, .7500D-01, .3000D-01, .3000D-01, .4000D-01,
31530 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01,
31531 & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31532 & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31533 & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31534 & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31535 & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31536 & .2700D+00, .3000D+00, .4000D+00, .2000D+00, .1250D+00 /
31537 DATA (WT(K),K=171,255) /
31538 & .7500D-01, .7500D-01, .1250D+00, .4000D+00, .7500D-01,
31539 & .1250D+00, .2000D+00, .1250D+00, .7500D-01, .1800D+00,
31540 & .3700D+00, .1300D+00, .8000D-01, .4000D-01, .7000D-01,
31541 & .1300D+00, .3700D+00, .1800D+00, .4000D-01, .8000D-01,
31542 & .1300D+00, .1300D+00, .7000D-01, .7000D-01, .1300D+00,
31543 & .2300D+00, .4700D+00, .5000D-01, .2000D-01, .1000D-01,
31544 & .2000D-01, .1300D+00, .7000D-01, .4700D+00, .2300D+00,
31545 & .5000D-01, .1000D-01, .2000D-01, .2000D-01, .1000D+01,
31546 & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31547 & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31548 & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31549 & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31550 & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31551 & .2700D+00, .3000D+00, .1800D+00, .3700D+00, .1300D+00,
31552 & .8000D-01, .4000D-01, .7000D-01, .1300D+00, .3700D+00,
31553 & .1800D+00, .4000D-01, .8000D-01, .1300D+00, .1300D+00,
31554 & .7000D-01, .5000D+00, .5000D+00, .1000D+01, .1000D+01 /
31555 DATA (WT(K),K=256,340) /
31556 & .1000D+01, .8000D+00, .2000D+00, .6000D+00, .3000D+00,
31557 & .1000D+00, .6000D+00, .3000D+00, .1000D+00, .8000D+00,
31558 & .2000D+00, .3300D+00, .6700D+00, .6600D+00, .1700D+00,
31559 & .1700D+00, .3200D+00, .1700D+00, .3200D+00, .1900D+00,
31560 & .3300D+00, .3300D+00, .3400D+00, .3000D+00, .5000D-01,
31561 & .6500D+00, .3800D+00, .1200D+00, .3800D+00, .1200D+00,
31562 & .3800D+00, .1200D+00, .3800D+00, .1200D+00, .3000D+00,
31563 & .5000D-01, .6500D+00, .3800D+00, .2500D+00, .2500D+00,
31564 & .2000D-01, .5000D-01, .5000D-01, .2000D+00, .2000D+00,
31565 & .1200D+00, .1000D+00, .7000D-01, .7000D-01, .1400D+00,
31566 & .5000D-01, .5000D-01, .1000D+01, .1000D+01, .1000D+01,
31567 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31568 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31569 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31570 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31571 & .4800D+00, .2400D+00, .2600D+00, .2000D-01, .4700D+00,
31572 & .3500D+00, .1500D+00, .3000D-01, .1000D+01, .1000D+01 /
31573 DATA (WT(K),K=341,425) /
31574 & .5200D+00, .4800D+00, .1000D+01, .1000D+01, .1000D+01,
31575 & .1000D+01, .9000D+00, .5000D-01, .5000D-01, .9000D+00,
31576 & .5000D-01, .5000D-01, .9000D+00, .5000D-01, .5000D-01,
31577 & .3300D+00, .6700D+00, .6700D+00, .3300D+00, .2500D+00,
31578 & .2500D+00, .5000D+00, .9000D+00, .5000D-01, .5000D-01,
31579 & .9000D+00, .5000D-01, .5000D-01, .9000D+00, .5000D-01,
31580 & .5000D-01, .3300D+00, .6700D+00, .6700D+00, .3300D+00,
31581 & .2500D+00, .2500D+00, .5000D+00, .1000D+00, .5000D+00,
31582 & .1600D+00, .2400D+00, .7000D+00, .3000D+00, .7000D+00,
31583 & .3000D+00, .1000D+00, .5000D+00, .1600D+00, .2400D+00,
31584 & .3000D+00, .4000D+00, .3000D+00, .3000D+00, .4000D+00,
31585 & .3000D+00, .4900D+00, .4900D+00, .2000D-01, .5500D+00,
31586 & .4500D+00, .6800D+00, .3000D+00, .2000D-01, .6800D+00,
31587 & .3000D+00, .2000D-01, .5500D+00, .4500D+00, .9000D+00,
31588 & .1000D+00, .9000D+00, .1000D+00, .6000D+00, .3000D+00,
31589 & .1000D+00, .1000D+00, .1000D+00, .8000D+00, .2800D+00,
31590 & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .2800D+00 /
31591 DATA (WT(K),K=426,510) /
31592 & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .1000D+01,
31593 & .1000D+01, .1000D+01, .1000D+01, .2000D-01, .3000D-01,
31594 & .7000D-01, .2000D-01, .2000D-01, .4000D-01, .1300D+00,
31595 & .7000D-01, .6000D-01, .6000D-01, .2000D+00, .1400D+00,
31596 & .4000D-01, .1000D+00, .2500D+00, .3000D-01, .3000D+00,
31597 & .4200D+00, .2200D+00, .3500D+00, .1900D+00, .1600D+00,
31598 & .8000D-01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31599 & .1000D+01, .3700D+00, .2000D+00, .3600D+00, .7000D-01,
31600 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00,
31601 & .5000D+00, .2000D-01, .3000D-01, .7000D-01, .2000D-01,
31602 & .2000D-01, .4000D-01, .1300D+00, .7000D-01, .6000D-01,
31603 & .6000D-01, .2000D+00, .1400D+00, .4000D-01, .1000D+00,
31604 & .2500D+00, .3000D-01, .3000D+00, .4200D+00, .2200D+00,
31605 & .3500D+00, .1900D+00, .1600D+00, .8000D-01, .1000D+01,
31606 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .3700D+00,
31607 & .2000D+00, .3600D+00, .7000D-01, .5000D+00, .5000D+00,
31608 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01 /
31609 DATA (WT(K),K=511,540) /
31610 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31611 & .1000D+01, .1000D+01, .1000D+01, .3000D+00, .3000D+00,
31612 & .4000D+00, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31613 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31614 & .3000D+00, .3000D+00, .4000D+00, .3300D+00, .3300D+00,
31615 & .3400D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00 /
31617 DATA (WT(I),I=541,602) / .0D+00, .3334D+00, .2083D+00, 2*.125D+00,
31618 & .2083D+00, .0D+00, .125D+00, .2083D+00, .3334D+00, .2083D+00,
31619 & .125D+00, 0.2D+00, 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00,
31620 & 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, 0.2D+00, 0.3D+00,
31621 & 0.3D+00, 0.0D+00, 0.31D+00, 0.62D+00, 0.035D+00, 0.035D+00,
31622 & 18*1.D+00, 0.5D+00, 0.16D+00, 2*0.12D+00, 2*0.05D+00, 0.5D+00,
31623 & 0.16D+00, 2*0.12D+00, 2*0.05D+00, 1.D+00 /
31624 * Particle numbers in decay channel
31625 DATA (NZK(K,1),K= 1,170) /
31626 & 1, 2, 3, 4, 5, 6, 7, 1, 2, 4,
31627 & 3, 23, 13, 13, 13, 10, 11, 10, 13, 13,
31628 & 13, 10, 4, 11, 14, 14, 14, 11, 3, 1,
31629 & 8, 1, 1, 2, 9, 2, 2, 13, 23, 8,
31630 & 1, 8, 17, 7, 7, 7, 23, 23, 13, 13,
31631 & 13, 13, 23, 14, 13, 13, 23, 15, 24, 24,
31632 & 15, 16, 25, 25, 16, 15, 24, 24, 15, 16,
31633 & 24, 25, 16, 15, 24, 36, 37, 15, 24, 15,
31634 & 15, 24, 15, 37, 36, 24, 15, 24, 24, 16,
31635 & 24, 38, 39, 16, 25, 16, 16, 25, 16, 39,
31636 & 38, 25, 16, 25, 25, 17, 22, 21, 17, 21,
31637 & 20, 17, 22, 8, 1, 21, 22, 20, 17, 48,
31638 & 50, 49, 8, 1, 17, 17, 17, 21, 20, 22,
31639 & 17, 22, 21, 20, 22, 19, 12, 19, 12, 1,
31640 & 1, 8, 1, 8, 8, 1, 53, 54, 1, 1,
31641 & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55,
31642 & 56, 1, 8, 8, 55, 56, 8, 1, 53, 54 /
31643 DATA (NZK(K,1),K=171,340) /
31644 & 55, 1, 8, 8, 54, 55, 56, 1, 8, 1,
31645 & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55,
31646 & 56, 1, 8, 1, 8, 1, 8, 17, 21, 22,
31647 & 1, 1, 8, 1, 8, 17, 22, 20, 8, 2,
31648 & 2, 9, 2, 9, 9, 2, 67, 68, 2, 2,
31649 & 9, 67, 68, 69, 2, 9, 2, 9, 68, 69,
31650 & 70, 2, 9, 9, 69, 70, 9, 2, 9, 67,
31651 & 68, 69, 2, 9, 2, 9, 68, 69, 70, 2,
31652 & 9, 1, 8, 13, 13, 14, 1, 8, 1, 1,
31653 & 8, 8, 8, 1, 8, 1, 1, 1, 1, 1,
31654 & 8, 2, 2, 9, 9, 2, 2, 9, 15, 15,
31655 & 24, 16, 16, 25, 25, 15, 15, 24, 24, 16,
31656 & 16, 25, 1, 21, 22, 21, 48, 49, 8, 17,
31657 & 20, 17, 22, 20, 20, 22, 20, 0, 0, 0,
31658 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31659 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31660 & 31, 31, 13, 7, 15, 12, 13, 31, 17, 17 /
31661 DATA (NZK(K,1),K=341,510) /
31662 & 2, 9, 18, 9, 18, 18, 17, 21, 22, 17,
31663 & 21, 20, 17, 20, 22, 97, 98, 97, 98, 97,
31664 & 98, 17, 18, 99, 100, 18, 101, 99, 18, 101,
31665 & 100, 102, 103, 102, 103, 102, 103, 18, 16, 16,
31666 & 24, 24, 16, 25, 15, 24, 15, 15, 25, 25,
31667 & 31, 15, 15, 31, 16, 16, 23, 13, 7, 116,
31668 & 116, 116, 117, 117, 119, 118, 118, 119, 119, 120,
31669 & 120, 121, 121, 130, 130, 130, 4, 10, 13, 10,
31670 & 4, 32, 13, 36, 11, 3, 34, 14, 38, 133,
31671 & 134, 135, 136, 21, 21, 1, 97, 104, 54, 53,
31672 & 17, 22, 21, 21, 1, 54, 53, 21, 97, 21,
31673 & 97, 22, 21, 97, 98, 105, 137, 137, 137, 138,
31674 & 139, 97, 97, 109, 109, 140, 138, 137, 139, 138,
31675 & 145, 99, 99, 2, 102, 110, 68, 67, 18, 100,
31676 & 99, 99, 2, 68, 67, 99, 102, 99, 102, 100,
31677 & 99, 102, 103, 111, 149, 149, 149, 150, 151, 113,
31678 & 113, 115, 115, 152, 150, 149, 151, 150, 157, 140 /
31679 DATA (NZK(K,1),K=511,540) /
31680 & 141, 142, 143, 144, 145, 146, 147, 148, 138, 145,
31681 & 140, 152, 153, 154, 155, 156, 157, 158, 159, 160,
31682 & 150, 157, 152, 34, 32, 33, 33, 32, 33, 34 /
31683 DATA (NZK(I,1),I=541,602) / 2, 67, 68, 69, 2, 9, 9, 68, 69,
31684 & 70, 2, 9, 33, 32, 13, 14, 189, 32, 34, 23, 23, 189, 33, 34, 14,
31685 & 14, 189, 23, 13, 15, 24, 36, 38, 37, 39, 194, 195, 196, 197,
31686 & 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 1, 8, 1, 1, 54,
31687 & 55, 8, 1, 8, 8, 54, 55, 210/
31688 DATA (NZK(K,2),K= 1,170) /
31689 & 0, 0, 0, 0, 0, 0, 0, 3, 4, 6,
31690 & 5, 23, 14, 11, 3, 5, 5, 5, 23, 13,
31691 & 23, 23, 23, 5, 23, 13, 23, 23, 23, 14,
31692 & 23, 3, 11, 13, 23, 4, 10, 14, 23, 14,
31693 & 23, 13, 7, 7, 4, 7, 7, 23, 14, 14,
31694 & 23, 14, 23, 23, 14, 14, 7, 23, 13, 23,
31695 & 14, 23, 14, 23, 13, 23, 13, 23, 14, 23,
31696 & 14, 23, 13, 23, 13, 23, 13, 33, 32, 35,
31697 & 31, 23, 14, 23, 14, 33, 34, 35, 31, 23,
31698 & 14, 23, 14, 33, 34, 35, 31, 23, 13, 23,
31699 & 13, 33, 32, 35, 31, 13, 13, 23, 23, 14,
31700 & 13, 14, 14, 25, 16, 14, 23, 13, 31, 14,
31701 & 13, 23, 25, 16, 23, 35, 33, 34, 32, 33,
31702 & 31, 31, 14, 13, 23, 0, 0, 0, 0, 13,
31703 & 23, 13, 14, 23, 14, 13, 23, 13, 78, 23,
31704 & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23,
31705 & 13, 80, 79, 14, 14, 23, 80, 31, 14, 23 /
31706 DATA (NZK(K,2),K=171,340) /
31707 & 13, 79, 78, 31, 14, 23, 13, 80, 79, 23,
31708 & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23,
31709 & 13, 80, 79, 23, 13, 33, 32, 15, 24, 15,
31710 & 31, 14, 23, 34, 33, 24, 24, 15, 31, 14,
31711 & 23, 14, 13, 23, 13, 14, 23, 14, 80, 23,
31712 & 14, 13, 23, 14, 79, 80, 13, 23, 13, 23,
31713 & 14, 78, 79, 13, 13, 23, 78, 23, 14, 13,
31714 & 23, 14, 79, 80, 13, 23, 13, 23, 14, 78,
31715 & 79, 62, 61, 23, 14, 23, 13, 13, 13, 23,
31716 & 13, 13, 23, 14, 14, 14, 1, 8, 8, 1,
31717 & 8, 1, 8, 8, 1, 8, 1, 8, 1, 8,
31718 & 1, 1, 8, 1, 8, 8, 1, 1, 8, 8,
31719 & 1, 8, 25, 23, 13, 31, 23, 13, 16, 14,
31720 & 35, 34, 34, 33, 31, 14, 23, 0, 0, 0,
31721 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31722 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31723 & 13, 23, 14, 7, 16, 19, 14, 7, 23, 14 /
31724 DATA (NZK(K,2),K=341,510) /
31725 & 23, 14, 7, 13, 23, 13, 13, 23, 13, 23,
31726 & 14, 13, 14, 23, 14, 23, 13, 14, 23, 14,
31727 & 23, 16, 14, 23, 14, 23, 14, 13, 13, 23,
31728 & 13, 23, 14, 13, 23, 13, 23, 15, 13, 13,
31729 & 13, 23, 13, 13, 14, 14, 14, 14, 14, 23,
31730 & 13, 16, 25, 14, 15, 24, 23, 14, 7, 23,
31731 & 7, 13, 23, 7, 14, 23, 7, 23, 7, 7,
31732 & 7, 7, 7, 13, 23, 31, 3, 11, 14, 135,
31733 & 5, 134, 134, 134, 136, 6, 133, 133, 133, 0,
31734 & 0, 0, 0, 31, 95, 25, 15, 31, 95, 16,
31735 & 32, 32, 33, 35, 39, 39, 38, 25, 13, 39,
31736 & 32, 39, 38, 35, 32, 39, 13, 23, 14, 7,
31737 & 7, 25, 37, 32, 13, 25, 13, 25, 13, 25,
31738 & 13, 31, 95, 24, 16, 31, 24, 15, 34, 34,
31739 & 33, 35, 37, 37, 36, 24, 14, 37, 34, 37,
31740 & 36, 35, 34, 37, 14, 23, 13, 7, 7, 24,
31741 & 39, 34, 14, 24, 14, 24, 14, 24, 14, 7 /
31742 DATA (NZK(K,2),K=511,540) /
31743 & 7, 7, 7, 7, 7, 7, 7, 7, 25, 13,
31744 & 25, 7, 7, 7, 7, 7, 7, 7, 7, 7,
31745 & 24, 14, 24, 13, 14, 23, 13, 23, 14, 23 /
31746 DATA (NZK(I,2),I=541,602) / 31, 13, 23, 14, 79, 80, 31, 13, 23,
31747 & 14, 78, 79, 13, 23, 23, 13, 13, 14, 13, 23, 13, 23, 14, 23, 23,
31748 & 14, 14, 23, 14, 16, 25,
31749 & 4*23, 14*0, 23, 13, 23, 13, 23, 13, 23, 14,
31750 & 23, 13, 14, 23, 0 /
31751 DATA (NZK(K,3),K= 1,170) /
31752 & 0, 0, 0, 0, 0, 0, 0, 5, 6, 5,
31753 & 6, 23, 23, 5, 5, 0, 0, 0, 0, 14,
31754 & 23, 5, 5, 0, 0, 14, 23, 5, 5, 0,
31755 & 0, 5, 5, 0, 0, 5, 5, 0, 0, 0,
31756 & 0, 0, 0, 0, 3, 0, 7, 23, 23, 7,
31757 & 0, 0, 0, 0, 23, 0, 0, 0, 0, 0,
31759 DATA (NZK(K,3),K=171,340) /
31761 & 0, 0, 0, 0, 0, 0, 23, 13, 14, 23,
31762 & 23, 14, 23, 23, 23, 14, 23, 13, 23, 14,
31763 & 13, 23, 13, 23, 14, 23, 14, 14, 23, 13,
31764 & 13, 23, 13, 14, 23, 23, 14, 23, 13, 23,
31765 & 14, 14, 0, 0, 0, 0, 0, 0, 0, 0,
31767 & 14, 23, 7, 0, 0, 0, 23, 0, 0, 0 /
31768 DATA (NZK(K,3),K=341,510) /
31770 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 23,
31771 & 14, 0, 13, 0, 14, 0, 0, 23, 13, 0,
31772 & 0, 15, 0, 0, 16, 0, 0, 0, 0, 0,
31773 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31774 & 0, 0, 0, 14, 23, 0, 0, 0, 23, 134,
31775 & 134, 0, 0, 0, 133, 133, 0, 0, 0, 0,
31777 DATA (NZK(K,3),K=511,540) /
31778 & 0, 0, 0, 0, 0, 0, 0, 0, 13, 13,
31779 & 25, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31780 & 14, 14, 24, 0, 0, 0, 0, 0, 0, 0 /
31781 DATA (NZK(I,3),I=541,602) / 12*0, 2*0, 23, 13, 0, 2*0, 23, 14, 0,
31782 & 2*0, 23, 13, 0, 4*0, 18*0, 2*0, 23, 14, 2*0, 2*0, 23, 14, 2*0, 0/
31786 *$ CREATE DT_XHOINI.FOR
31789 *====phoini============================================================*
31791 SUBROUTINE DT_XHOINI
31792 C SUBROUTINE DT_PHOINI
31794 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31797 PARAMETER ( LINP = 10 ,
31804 *$ CREATE DT_XVENTB.FOR
31807 *====eventb============================================================*
31809 SUBROUTINE DT_XVENTB(NCSY,IREJ)
31810 C SUBROUTINE DT_EVENTB(NCSY,IREJ)
31812 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31815 PARAMETER ( LINP = 10 ,
31820 1000 FORMAT(1X,'EVENTB: PHOJET-package requested but not linked!')
31825 *$ CREATE DT_XVENT.FOR
31828 *===event==============================================================*
31830 SUBROUTINE DT_XVENT(IDUM,PP,PT,DUM,IREJ)
31831 C SUBROUTINE EVENT(IDUM,PP,PT,DUM,IREJ)
31833 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31836 DIMENSION PP(4),PT(4)
31841 *$ CREATE DT_XOHISX.FOR
31844 *===pohisx=============================================================*
31846 SUBROUTINE DT_XOHISX(I,X)
31847 C SUBROUTINE POHISX(I,X)
31849 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31855 *$ CREATE PHO_LHIST.FOR
31858 *===poluhi=============================================================*
31860 SUBROUTINE PHO_LHIST(I,X)
31864 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31870 *$ CREATE PDFSET.FOR
31873 C**********************************************************************
31875 C dummy subroutines, remove to link PDFLIB
31877 C**********************************************************************
31878 SUBROUTINE PDFSET(PARAM,VALUE)
31879 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31880 DIMENSION PARAM(20),VALUE(20)
31884 *$ CREATE STRUCTM.FOR
31887 SUBROUTINE STRUCTM(XI,SCALE2,UV,DV,US,DS,SS,CS,BS,TS,GL)
31888 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31891 *$ CREATE STRUCTP.FOR
31894 SUBROUTINE STRUCTP(XI,SCALE2,P2,IP2,UV,DV,US,DS,SS,CS,BS,TS,GL)
31895 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31898 *$ CREATE DT_DIQBRK.FOR
31901 *===diqbrk=============================================================*
31903 SUBROUTINE DT_XIQBRK
31904 C SUBROUTINE DT_DIQBRK
31906 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31909 STOP 'diquark-breaking not implemeted !'
31913 *$ CREATE DT_ELHAIN.FOR
31916 *===elhain=============================================================*
31918 SUBROUTINE DT_ELHAIN(IP,PLA,ELAB,CX,CY,CZ,IT,IREJ)
31920 ************************************************************************
31921 * Elastic hadron-hadron scattering. *
31922 * This is a revised version of the original. *
31923 * This version dated 03.04.98 is written by S. Roesler *
31924 ************************************************************************
31926 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31929 PARAMETER ( LINP = 10 ,
31933 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
31936 PARAMETER (ENNTHR = 3.5D0)
31937 PARAMETER (PLOWH=0.01D0,PHIH=9.0D0,
31938 & BLOWB=0.05D0,BHIB=0.2D0,
31939 & BLOWM=0.1D0, BHIM=2.0D0)
31941 * particle properties (BAMJET index convention)
31943 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
31944 & IICH(210),IIBAR(210),K1(210),K2(210)
31946 * final state from HADRIN interaction
31947 PARAMETER (MAXFIN=10)
31948 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
31949 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
31951 C DATA TSLOPE /10.0D0/
31957 PLAB = SQRT( (ELAB-AAM(IP))*(ELAB+AAM(IP)) )
31958 EKIN = ELAB-AAM(IP)
31959 * kinematical quantities in cms of the hadrons
31962 S = AMP2+AMT2+TWO*ELAB*AAM(IT)
31964 ECMP = OHALF*ECM+(AMP2-AMT2)/(TWO*ECM)
31965 PCM = SQRT( (ECMP-AAM(IP))*(ECMP+AAM(IP)) )
31967 * nucleon-nucleon scattering at E_kin<3.5: use DT_TSAMCS(HETC-KFA)
31968 IF ( ((IP.EQ.1).OR.(IP.EQ.8)).AND.
31969 & ((IT.EQ.1).OR.(IT.EQ.8)).AND.(EKIN.LT.ENNTHR) ) THEN
31970 * TSAMCS treats pp and np only, therefore change pn into np and
31976 IF (IP.EQ.8) KPROJ = 1
31978 CALL DT_TSAMCS(KPROJ,EKIN,CTCMS)
31979 T = TWO*PCM**2*(CTCMS-ONE)
31981 * very crude treatment otherwise: sample t from exponential dist.
31983 * momentum transfer t
31984 TMAX = TWO*TWO*PCM**2
31985 RR = (PLAB-PLOWH)/(PHIH-PLOWH)
31986 IF (IIBAR(IP).NE.0) THEN
31987 TSLOPE = BLOWB+RR*(BHIB-BLOWB)
31989 TSLOPE = BLOWM+RR*(BHIM-BLOWM)
31991 FMAX = EXP(-TSLOPE*TMAX)-ONE
31993 T = LOG(ONE+R*FMAX+TINY10)/TSLOPE
31994 IF (T.GT.ZERO) T = LOG(ONE+R*FMAX)/TSLOPE
31997 * target hadron in Lab after scattering
31998 ELRH(2) = (TWO*AMT2-T)/(TWO*AAM(IT))
31999 PLRH(2) = SQRT( ABS(ELRH(2)-AAM(IT))*(ELRH(2)+AAM(IT)) )
32000 IF (PLRH(2).LE.TINY10) THEN
32001 C WRITE(*,*)'ELHAIN: T,PLRH(2) ',T,PLRH(2)
32004 * projectile hadron in Lab after scattering
32005 ELRH(1) = ELAB+AAM(IT)-ELRH(2)
32006 PLRH(1) = SQRT( ABS(ELRH(1)-AAM(IP))*(ELRH(1)+AAM(IP)) )
32007 * scattering angle of projectile in Lab
32008 CTLABP = (T-TWO*AMP2+TWO*ELAB*ELRH(1))/(TWO*PLAB*PLRH(1))
32009 STLABP = SQRT( (ONE-CTLABP)*(ONE+CTLABP) )
32010 CALL DT_DSFECF(SPLABP,CPLABP)
32011 * direction cosines of projectile in Lab
32012 CALL DT_STTRAN(CX,CY,CZ,CTLABP,STLABP,SPLABP,CPLABP,
32013 & CXRH(1),CYRH(1),CZRH(1))
32014 * scattering angle of target in Lab
32015 PLLABT = PLAB-CTLABP*PLRH(1)
32016 CTLABT = PLLABT/PLRH(2)
32017 STLABT = SQRT( (ONE-CTLABT)*(ONE+CTLABT) )
32018 * direction cosines of target in Lab
32019 CALL DT_STTRAN(CX,CY,CZ,CTLABT,STLABT,-SPLABP,-CPLABP,
32020 & CXRH(2),CYRH(2),CZRH(2))
32029 *$ CREATE DT_TSAMCS.FOR
32032 *===tsamcs=============================================================*
32034 SUBROUTINE DT_TSAMCS(KPROJ,EKIN,CST)
32036 ************************************************************************
32037 * Sampling of cos(theta) for nucleon-proton scattering according to *
32038 * hetkfa2/bertini parametrization. *
32039 * This is a revised version of the original (HJM 24/10/88) *
32040 * This version dated 28.10.95 is written by S. Roesler *
32041 ************************************************************************
32043 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32046 PARAMETER ( LINP = 10 ,
32050 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
32053 DIMENSION DCLIN(195),DCHN(143),DCHNA(36),DCHNB(60)
32054 DIMENSION PDCI(60),PDCH(55)
32056 DATA (DCLIN(I),I=1,80) /
32057 & 5.000D-01, 1.000D+00, 0.000D+00, 1.000D+00, 0.000D+00,
32058 & 4.993D-01, 9.881D-01, 5.963D-02, 9.851D-01, 5.945D-02,
32059 & 4.936D-01, 8.955D-01, 5.224D-01, 8.727D-01, 5.091D-01,
32060 & 4.889D-01, 8.228D-01, 8.859D-01, 7.871D-01, 8.518D-01,
32061 & 4.874D-01, 7.580D-01, 1.210D+00, 7.207D-01, 1.117D+00,
32062 & 4.912D-01, 6.969D-01, 1.516D+00, 6.728D-01, 1.309D+00,
32063 & 5.075D-01, 6.471D-01, 1.765D+00, 6.667D-01, 1.333D+00,
32064 & 5.383D-01, 6.054D-01, 1.973D+00, 7.059D-01, 1.176D+00,
32065 & 5.397D-01, 5.990D-01, 2.005D+00, 7.023D-01, 1.191D+00,
32066 & 5.336D-01, 6.083D-01, 1.958D+00, 6.959D-01, 1.216D+00,
32067 & 5.317D-01, 6.075D-01, 1.962D+00, 6.897D-01, 1.241D+00,
32068 & 5.300D-01, 6.016D-01, 1.992D+00, 6.786D-01, 1.286D+00,
32069 & 5.281D-01, 6.063D-01, 1.969D+00, 6.786D-01, 1.286D+00,
32070 & 5.280D-01, 5.960D-01, 2.020D+00, 6.667D-01, 1.333D+00,
32071 & 5.273D-01, 5.920D-01, 2.040D+00, 6.604D-01, 1.358D+00,
32072 & 5.273D-01, 5.862D-01, 2.069D+00, 6.538D-01, 1.385D+00/
32073 DATA (DCLIN(I),I=81,160) /
32074 & 5.223D-01, 5.980D-01, 2.814D+00, 6.538D-01, 1.385D+00,
32075 & 5.202D-01, 5.969D-01, 2.822D+00, 6.471D-01, 1.412D+00,
32076 & 5.183D-01, 5.881D-01, 2.883D+00, 6.327D-01, 1.469D+00,
32077 & 5.159D-01, 5.866D-01, 2.894D+00, 6.250D-01, 1.500D+00,
32078 & 5.133D-01, 5.850D-01, 2.905D+00, 6.170D-01, 1.532D+00,
32079 & 5.106D-01, 5.833D-01, 2.917D+00, 6.087D-01, 1.565D+00,
32080 & 5.084D-01, 5.801D-01, 2.939D+00, 6.000D-01, 1.600D+00,
32081 & 5.063D-01, 5.763D-01, 2.966D+00, 5.909D-01, 1.636D+00,
32082 & 5.036D-01, 5.730D-01, 2.989D+00, 5.814D-01, 1.674D+00,
32083 & 5.014D-01, 5.683D-01, 3.022D+00, 5.714D-01, 1.714D+00,
32084 & 4.986D-01, 5.641D-01, 3.051D+00, 5.610D-01, 1.756D+00,
32085 & 4.964D-01, 5.580D-01, 3.094D+00, 5.500D-01, 1.800D+00,
32086 & 4.936D-01, 5.573D-01, 3.099D+00, 5.431D-01, 1.827D+00,
32087 & 4.909D-01, 5.509D-01, 3.144D+00, 5.313D-01, 1.875D+00,
32088 & 4.885D-01, 5.512D-01, 3.142D+00, 5.263D-01, 1.895D+00,
32089 & 4.857D-01, 5.437D-01, 3.194D+00, 5.135D-01, 1.946D+00/
32090 DATA (DCLIN(I),I=161,195) /
32091 & 4.830D-01, 5.353D-01, 3.253D+00, 5.000D-01, 2.000D+00,
32092 & 4.801D-01, 5.323D-01, 3.274D+00, 4.915D-01, 2.034D+00,
32093 & 4.770D-01, 5.228D-01, 3.341D+00, 4.767D-01, 2.093D+00,
32094 & 4.738D-01, 5.156D-01, 3.391D+00, 4.643D-01, 2.143D+00,
32095 & 4.701D-01, 5.010D-01, 3.493D+00, 4.444D-01, 2.222D+00,
32096 & 4.672D-01, 4.990D-01, 3.507D+00, 4.375D-01, 2.250D+00,
32097 & 4.634D-01, 4.856D-01, 3.601D+00, 4.194D-01, 2.323D+00/
32100 & 4.400D+02, 1.896D-01, 1.931D-01, 1.982D-01, 1.015D-01,
32101 & 1.029D-01, 4.180D-02, 4.228D-02, 4.282D-02, 4.350D-02,
32102 & 2.204D-02, 2.236D-02, 5.900D+02, 1.433D-01, 1.555D-01,
32103 & 1.774D-01, 1.000D-01, 1.128D-01, 5.132D-02, 5.600D-02,
32104 & 6.158D-02, 6.796D-02, 3.660D-02, 3.820D-02, 6.500D+02,
32105 & 1.192D-01, 1.334D-01, 1.620D-01, 9.527D-02, 1.141D-01,
32106 & 5.283D-02, 5.952D-02, 6.765D-02, 7.878D-02, 4.796D-02,
32107 & 6.957D-02, 8.000D+02, 4.872D-02, 6.694D-02, 1.152D-01,
32108 & 9.348D-02, 1.368D-01, 6.912D-02, 7.953D-02, 9.577D-02,
32109 & 1.222D-01, 7.755D-02, 9.525D-02, 1.000D+03, 3.997D-02,
32110 & 5.456D-02, 9.804D-02, 8.084D-02, 1.208D-01, 6.520D-02,
32111 & 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02, 1.093D-01/
32114 & 1.000D+03, 9.453D-02, 9.804D-02, 8.084D-02, 1.208D-01,
32115 & 6.520D-02, 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02,
32116 & 1.093D-01, 1.400D+03, 1.072D-01, 7.450D-02, 6.645D-02,
32117 & 1.136D-01, 6.750D-02, 8.580D-02, 1.110D-01, 1.530D-01,
32118 & 1.010D-01, 1.350D-01, 2.170D+03, 4.004D-02, 3.013D-02,
32119 & 2.664D-02, 5.511D-02, 4.240D-02, 7.660D-02, 1.364D-01,
32120 & 2.300D-01, 1.670D-01, 2.010D-01, 2.900D+03, 1.870D-02,
32121 & 1.804D-02, 1.320D-02, 2.970D-02, 2.860D-02, 5.160D-02,
32122 & 1.020D-01, 2.400D-01, 2.250D-01, 3.370D-01, 4.400D+03,
32123 & 1.196D-03, 8.784D-03, 1.517D-02, 2.874D-02, 2.488D-02,
32124 & 4.464D-02, 8.330D-02, 2.008D-01, 2.360D-01, 3.567D-01/
32126 DATA (DCHN(I),I=1,90) /
32127 & 4.770D-01, 4.750D-01, 4.715D-01, 4.685D-01, 4.650D-01,
32128 & 4.610D-01, 4.570D-01, 4.550D-01, 4.500D-01, 4.450D-01,
32129 & 4.405D-01, 4.350D-01, 4.300D-01, 4.250D-01, 4.200D-01,
32130 & 4.130D-01, 4.060D-01, 4.000D-01, 3.915D-01, 3.840D-01,
32131 & 3.760D-01, 3.675D-01, 3.580D-01, 3.500D-01, 3.400D-01,
32132 & 3.300D-01, 3.200D-01, 3.100D-01, 3.000D-01, 2.900D-01,
32133 & 2.800D-01, 2.700D-01, 2.600D-01, 2.500D-01, 2.400D-01,
32134 & 2.315D-01, 2.240D-01, 2.150D-01, 2.060D-01, 2.000D-01,
32135 & 1.915D-01, 1.850D-01, 1.780D-01, 1.720D-01, 1.660D-01,
32136 & 1.600D-01, 1.550D-01, 1.500D-01, 1.450D-01, 1.400D-01,
32137 & 1.360D-01, 1.320D-01, 1.280D-01, 1.250D-01, 1.210D-01,
32138 & 1.180D-01, 1.150D-01, 1.120D-01, 1.100D-01, 1.070D-01,
32139 & 1.050D-01, 1.030D-01, 1.010D-01, 9.900D-02, 9.700D-02,
32140 & 9.550D-02, 9.480D-02, 9.400D-02, 9.200D-02, 9.150D-02,
32141 & 9.100D-02, 9.000D-02, 8.990D-02, 8.900D-02, 8.850D-02,
32142 & 8.750D-02, 8.700D-02, 8.650D-02, 8.550D-02, 8.500D-02,
32143 & 8.499D-02, 8.450D-02, 8.350D-02, 8.300D-02, 8.250D-02,
32144 & 8.150D-02, 8.100D-02, 8.030D-02, 8.000D-02, 7.990D-02/
32145 DATA (DCHN(I),I=91,143) /
32146 & 7.980D-02, 7.950D-02, 7.900D-02, 7.860D-02, 7.800D-02,
32147 & 7.750D-02, 7.650D-02, 7.620D-02, 7.600D-02, 7.550D-02,
32148 & 7.530D-02, 7.500D-02, 7.499D-02, 7.498D-02, 7.480D-02,
32149 & 7.450D-02, 7.400D-02, 7.350D-02, 7.300D-02, 7.250D-02,
32150 & 7.230D-02, 7.200D-02, 7.100D-02, 7.050D-02, 7.020D-02,
32151 & 7.000D-02, 6.999D-02, 6.995D-02, 6.993D-02, 6.991D-02,
32152 & 6.990D-02, 6.870D-02, 6.850D-02, 6.800D-02, 6.780D-02,
32153 & 6.750D-02, 6.700D-02, 6.650D-02, 6.630D-02, 6.600D-02,
32154 & 6.550D-02, 6.525D-02, 6.510D-02, 6.500D-02, 6.499D-02,
32155 & 6.498D-02, 6.496D-02, 6.494D-02, 6.493D-02, 6.490D-02,
32156 & 6.488D-02, 6.485D-02, 6.480D-02/
32159 & 6.300D+02, 7.810D-02, 1.421D-01, 1.979D-01, 2.479D-01,
32160 & 3.360D-01, 5.400D-01, 7.236D-01, 1.000D+00, 1.540D+03,
32161 & 2.225D-01, 3.950D-01, 5.279D-01, 6.298D-01, 7.718D-01,
32162 & 9.405D-01, 9.835D-01, 1.000D+00, 2.560D+03, 2.625D-01,
32163 & 4.550D-01, 5.963D-01, 7.020D-01, 8.380D-01, 9.603D-01,
32164 & 9.903D-01, 1.000D+00, 3.520D+03, 4.250D-01, 6.875D-01,
32165 & 8.363D-01, 9.163D-01, 9.828D-01, 1.000D+00, 1.000D+00,
32169 & 6.300D+02, 3.800D-02, 7.164D-02, 1.275D-01, 2.171D-01,
32170 & 3.227D-01, 4.091D-01, 5.051D-01, 6.061D-01, 7.074D-01,
32171 & 8.434D-01, 1.000D+00, 2.040D+03, 1.200D-01, 2.115D-01,
32172 & 3.395D-01, 5.295D-01, 7.251D-01, 8.511D-01, 9.487D-01,
32173 & 9.987D-01, 1.000D+00, 1.000D+00, 1.000D+00, 2.200D+03,
32174 & 1.344D-01, 2.324D-01, 3.754D-01, 5.674D-01, 7.624D-01,
32175 & 8.896D-01, 9.808D-01, 1.000D+00, 1.000D+00, 1.000D+00,
32176 & 1.000D+00, 2.850D+03, 2.330D-01, 4.130D-01, 6.610D-01,
32177 & 9.010D-01, 9.970D-01, 1.000D+00, 1.000D+00, 1.000D+00,
32178 & 1.000D+00, 1.000D+00, 1.000D+00, 3.500D+03, 3.300D-01,
32179 & 5.450D-01, 7.950D-01, 1.000D+00, 1.000D+00, 1.000D+00,
32180 & 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00/
32183 IF (EKIN.GT.3.5D0) RETURN
32185 IF(KPROJ.EQ.8) GOTO 101
32186 IF(KPROJ.EQ.1) GOTO 102
32187 C* INVALID REACTION
32188 WRITE(LOUT,'(A,I5/A)')
32189 & ' INVALID PARTICLE TYPE IN DNUPRE - KPROJ=',KPROJ,
32190 & ' COS(THETA) = 1D0 RETURNED'
32192 C-------------------------------- NP ELASTIC SCATTERING----------
32194 IF (EKIN.GT.0.740D0)GOTO 1000
32195 IF (EKIN.LT.0.300D0)THEN
32196 C EKIN .LT. 300 MEV
32199 C 300 MEV < EKIN < 740 MEV
32204 IE=INT(ABS(ENER/0.020D0))
32205 UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
32206 C FORWARD/BACKWARD DECISION
32208 BWFW=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
32209 IF (DT_RNDM(CST).LT.BWFW)THEN
32217 COEF=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
32220 IF(RND.LT.COEF)THEN
32229 IF(VALUE2.GT.0.0)THEN
32230 CST=MAX(R1,R2,R3,R4)
32236 CST=-MAX(R1,R2,R3,R4,R5)
32240 CST=-MAX(R1,R2,R3,R4,R5,R6,R7)
32249 C******** EKIN .GT. 0.74 GEV
32251 1000 ENER=EKIN - 0.66D0
32252 C IE=ABS(ENER/0.02)
32253 IE=INT(ENER/0.02D0)
32256 UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
32258 BWFW=(DCHN(K+1)-DCHN(K))*UNIV + DCHN(K)
32261 IF (RND.GE.BWFW)THEN
32263 IF (DCHNA(K).GT.EMEV) THEN
32264 UNIVE=(EMEV-DCHNA(K-9))/(DCHNA(K)-DCHNA(K-9))
32265 UNIV=DT_RNDM(UNIVE)
32268 P=(DCHNA(II)-DCHNA(II-9))*UNIVE + DCHNA(II-9)
32271 UNIV=DT_RNDM(UNIVE)
32273 GOTO(290,290,290,290,330,340,350,360) I
32282 IF (DCHNB(K).GT.EMEV) THEN
32283 UNIVE=(EMEV-DCHNB(K-12))/(DCHNB(K)-DCHNB(K-12))
32284 UNIV=DT_RNDM(UNIVE)
32287 P=(DCHNB(II)-DCHNB(II-12))*UNIVE + DCHNB(II-12)
32292 GOTO(120,120,140,150,160,160,180,190,200,210,220) I
32299 120 CST=1.0D-2*FLTI-1.0D0
32301 140 CST=2.0D-2*UNIV-0.98D0
32303 150 CST=4.0D-2*UNIV-0.96D0
32305 160 CST=6.0D-2*FLTI-1.16D0
32307 180 CST=8.0D-2*UNIV-0.80D0
32309 190 CST=1.0D-1*UNIV-0.72D0
32311 200 CST=1.2D-1*UNIV-0.62D0
32313 210 CST=2.0D-1*UNIV-0.50D0
32315 220 CST=3.0D-1*(UNIV-1.0D0)
32318 290 CST=1.0D0-2.5d-2*FLTI
32320 330 CST=0.85D0+0.5D-1*UNIV
32322 340 CST=0.70D0+1.5D-1*UNIV
32324 350 CST=0.50D0+2.0D-1*UNIV
32326 360 CST=0.50D0*UNIV
32330 C----------------------------------- PP ELASTIC SCATTERING -------
32335 IF (EKIN.LE.0.500D0) THEN
32337 CST=2.0D0*RND-1.0D0
32340 ELSEIF (EKIN.LT.1.0D0) THEN
32342 IF (PDCI(K).GT.EMEV) THEN
32343 UNIVE=(EMEV-PDCI(K-12))/(PDCI(K)-PDCI(K-12))
32344 UNIV=DT_RNDM(UNIVE)
32348 SUM=SUM + (PDCI(II)-PDCI(II-12))*UNIVE + PDCI(II-12)
32350 IF (UNIV.LT.SUM)THEN
32353 GOTO(55,55,55,60,60,65,65,65,65,70,70) I
32360 IF (PDCH(K).GT.EMEV) THEN
32361 UNIVE=(EMEV-PDCH(K-11))/(PDCH(K)-PDCH(K-11))
32362 UNIV=DT_RNDM(UNIVE)
32366 SUM=SUM + (PDCH(II)-PDCH(II-11))*UNIVE + PDCH(II-11)
32368 IF (UNIV.LT.SUM)THEN
32371 GOTO(50,55,60,60,65,65,65,65,70,70) I
32382 60 CST=0.3D0+0.1D0*FLTI
32384 65 CST=0.6D0+0.04D0*FLTI
32386 70 CST=0.78D0+0.02D0*FLTI
32389 IF (DT_RNDM(CST).GT.0.5D0) CST=-CST
32394 *$ CREATE DT_DHADRI.FOR
32397 *===dhadri=============================================================*
32399 SUBROUTINE DT_DHADRI(N,PLAB,ELAB,CX,CY,CZ,ITTA)
32401 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32404 PARAMETER ( LINP = 10 ,
32409 C-----------------------------
32410 C*** INPUT VARIABLES LIST:
32411 C*** SAMPLING OF HADRON NUCLEON INTERACTION FOR (ABOUT) 0.1 LE PLAB LE 6
32412 C*** GEV/C LABORATORY MOMENTUM REGION
32413 C*** N - PROJECTILE HADRON INDEX
32414 C*** PLAB - LABORATORY MOMENTUM OF N (GEV/C)
32415 C*** ELAB - LABORATORY ENERGY OF N (GEV)
32416 C*** CX,CY,CZ - DIRECTION COSINES OF N IN THE LABORATORY SYSTEM
32417 C*** ITTA - TARGET NUCLEON INDEX
32418 C*** OUTPUT VARIABLES LIST OF PARTICLE CHARACTERISTICS IN /FINLSP/
32419 C IR COUNTS THE NUMBER OF PRODUCED PARTICLES
32420 C*** ITR - PARTICLE INDEX, CXR,CYR,CZR - DIRECTION COSINES (LAB. SYST.)
32421 C*** ELR,PLR LAB. ENERGY AND LAB. MOMENTUM OF THE SAMPLED PARTICLE
32422 C*** RESPECT., UNITS (GEV/C AND GEV)
32423 C----------------------------
32425 COMMON /HNGAMR/ REDU,AMO,AMM(15)
32427 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
32429 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
32430 & NRK(2,268),NURE(30,2)
32432 * particle properties (BAMJET index convention),
32433 * (dublicate of DTPART for HADRIN)
32434 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
32435 & K1H(110),K2H(110)
32437 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
32439 COMMON /HNMETL/ CXS(149),CYS(149),CZS(149),ELS(149),PLS(149),
32442 COMMON /HNDRUN/ RUNTES,EFTES
32444 * particle properties (BAMJET index convention)
32446 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
32447 & IICH(210),IIBAR(210),K1(210),K2(210)
32449 * final state from HADRIN interaction
32450 PARAMETER (MAXFIN=10)
32451 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
32452 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
32454 DIMENSION ITPRF(110)
32457 DATA ITPRF/-1,-1,5*1,-1,-1,1,1,1,-1,-1,-1,-1,6*1,-1,-1,-1,85*1/
32459 IF (N.LE.0.OR.N.GE.111)N=1
32460 IF (ITPRF( N ).GT.0 .OR. ITTA.GT.8) THEN
32463 * + ' FALSE USE OF THE PARTICLE TYPE INDEX: N, ITTA', N, ITTA
32465 *1000 FORMAT (3(5H ****/),A,2I4,3(5H ****/))
32466 * + 45H FALSE USE OF THE PARTICLE TYPE INDEX, N,LUE ,I4,3(5H ****/))
32469 IF (ABS(PLAB-5.0D0).LT.4.99999D0) GO TO 20
32470 C IF(IPRI.GE.1) WRITE (6,1010) PLAB
32472 1010 FORMAT ( ' PROJECTILE HADRON MOMENTUM OUTSIDE OF THE
32473 + ALLOWED REGION, PLAB=',1E15.5)
32476 UMODAT=N*1.11111D0+ITTA*2.19291D0
32477 IF(UMODAT.NE.UMODA) CALL DT_DCALUM(N,ITTA)
32484 IF (LOWP.GT.20) THEN
32485 C WRITE(LOUT,*) ' jump 1'
32489 IF (NNN.EQ.N) GO TO 50
32498 IF(ITTA.GT.1) IRE=NURE(N,2)
32500 C-----------------------------
32501 C*** IE,AMT,ECM,SI DETERMINATION
32502 C----------------------------
32503 CALL DT_DSIGIN(IRE,PLAB,N,IE,AMT ,AMN,ECM,SI,ITTA)
32506 C IF (AMH(1).NE.0.93828D0) IANTH=1
32507 IF (AMH(1).NE.0.9383D0) IANTH=1
32509 IF (IANTH.GE.0) SI=1.0D0
32512 C-----------------------------
32514 C IRE CHARACTERIZES THE REACTION
32515 C IE IS THE ENERGY INDEX
32516 C----------------------------
32517 IF (SI.LT.1.D-6) THEN
32518 C WRITE(LOUT,*) ' jump 2'
32521 IF (N.LE.NSTAB) GO TO 60
32522 RUNTES=RUNTES+1.0D0
32523 IF (RUNTES.LT.20.D0) WRITE(LOUT,1020)N
32524 1020 FORMAT(3H N=,I10,30H THE PROEKTILE IS A RESONANCE )
32525 IF(IBARH(N).EQ.1) N=8
32526 IF(IBARH(N).EQ.-1) N=9
32529 **sr 19.2.97: loop for direct channel suppression
32530 C IF (IMACH.GT.10) THEN
32531 IF (IMACH.GT.1000) THEN
32533 C WRITE(LOUT,*) ' jump 3'
32539 ECMN=(ECM**2+AMN2-AMT2)/(2.0D0*ECM )
32540 IF(ECMN.LE.AMN) ECMN=AMN
32541 PCMN=SQRT(ECMN**2-AMN2)
32544 IF (IANTH.GE.0) ECM=2.1D0
32546 C-----------------------------
32547 C*** RANDOM CHOICE OF REACTION CHANNEL
32548 C----------------------------
32553 C-----------------------------
32554 C*** PLACE REDUCED VERSION
32555 C----------------------------
32557 IDWK=IEII(IRE+1)-IIEI
32561 C-----------------------------
32562 C*** SHRINKAGE TO THE CONSIDERED ENERGY REGION FOR THE USE OF WEIGHTS
32563 C----------------------------
32565 HUMO=2.0D0*UMO(IIEI+IDWK)-UMO(IIEI+IDWK-1)
32566 IF (HUMO.LT.ECM) ECM=HUMO
32568 C-----------------------------
32569 C*** INTERPOLATION PREPARATION
32570 C----------------------------
32576 C-----------------------------
32578 C----------------------------
32583 IWK=IIWK+(IK-1)*IDWK+IE-IIEI
32587 C-----------------------------
32588 C*** TESTVARIABLE WICO/WICOR: IF CHANNEL IK HAS THE SAME WEIGHTS LIKE IK
32589 C GO TO NEXT CHANNEL, BECAUSE WKK((IK))-WKK((IK-1))=0, IK CAN NOT
32591 C----------------------------
32592 IF (PLAB.LT.PLABF(IIEI+2)) WDK=0.0D0
32593 WICO=WOK*1.23459876D0+WDK*1.735218469D0
32594 IF (WICO.EQ.WICOR) GO TO 70
32595 IF (UMO(IIEI+IDWK).LT.HECM) WDK=0.0D0
32598 C-----------------------------
32599 C*** INTERPOLATION IN CHANNEL WEIGHTS
32600 C----------------------------
32601 EKLIM=-THRESH(IIKI+IK)
32602 IELIM=IDT_IEFUND(EKLIM,IRE)
32603 DELIM=UMO(IELIM)+EKLIM
32605 DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
32606 IF (DELIM*DELIM-DETE*DETE) 90,90,80
32611 WKK=WOK-WDK*DEC/(DECC+1.D-9)
32613 C-----------------------------
32615 C----------------------------
32617 IF (VV.GT.WKK) GO TO 70
32619 C***IK IS THE REACTION CHANNEL
32620 C----------------------------
32632 IF (I1001.GT.50) GO TO 60
32634 IF (IT2*AMS.GT.IT2*ECM) GO TO 110
32637 IF (IANTH.GE.0) ECM=ELAB+AMT+0.00001D0
32640 IF (IT2.GT.0) GO TO 120
32641 **sr 19.2.97: supress direct channel for pp-collisions
32642 IF ((N.EQ.1).AND.(ITTA.EQ.1).AND.(IT2.LE.0)) THEN
32644 IF (RR.LE.0.75D0) GOTO 60
32648 C-----------------------------
32649 C INCLUSION OF DIRECT RESONANCES
32650 C RANDOM CHOICE OF DECAY CHANNELS OF THE DIRECT RESONANCE IT1
32651 C------------------------
32664 IF(WW.LT. 0.5D0) GO TO 130
32671 C-----------------------------
32672 C THE FIRST PARTICLE IS DEFINED TO BE THE FORWARD GOING ONE AT SMALL T
32679 IF(IB1.EQ.IBN) GO TO 140
32685 C-----------------------------
32686 C***IT1,IT2 ARE THE CREATED PARTICLES
32687 C***MOMENTA AND DIRECTION COSINA IN THE CM - SYSTEM
32688 C------------------------
32689 CALL DT_DTWOPA(ECM1,ECM2,PCM1,PCM2,COD1,COD2,COF1,COF2,SIF1,SIF2,
32690 *IT1,IT2,ECM,ECMN,PCMN,N,AM1,AM2)
32695 C-----------------------------
32696 C***TRANSFORMATION INTO LAB SYSTEM AND ROTATION
32697 C----------------------------
32698 CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD1,COF1,SIF1,
32699 &PCM1,ECM1,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32703 CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD2,COF2,SIF2,
32704 *PCM2,ECM2,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32707 C-----------------------------
32708 C***TEST STABLE OR UNSTABLE
32709 C----------------------------
32710 IF(ITS(IST).GT.NSTAB) GO TO 160
32713 C-----------------------------
32714 C***IRH IS THE NUMBER OF THE FINAL STABLE PARTICLE
32715 C----------------------------
32716 C* IF (REDU.LT.0.D0) GO TO 1009
32724 IF(IST.GE.1) GO TO 150
32728 C RANDOM CHOICE OF DECAY CHANNELS
32729 C----------------------------
32743 IF (VV.GT.WTI(IIK)) GO TO 180
32745 C IIK IS THE DECAY CHANNEL
32746 C----------------------------
32754 IF (IT2-1.LT.0) GO TO 240
32759 C IF IIK-KIN.LIM.GT.ACTUAL TOTAL CM-ENERGY, DO AGAIN RANDOM IIK-CHOICE
32760 C----------------------------
32761 IF (IECO.LE.10) GO TO 200
32763 IF(IATMPT.GT.3) THEN
32764 C WRITE(LOUT,*) ' jump 4'
32769 IF (I310.GT.50) GO TO 170
32770 IF (AMS.GT.ECO) GO TO 190
32772 C FOR THE DECAY CHANNEL
32773 C IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM IT
32774 C----------------------------
32775 IF (REDU.LT.0.D0) GO TO 30
32778 IF(IT3.EQ.0) GO TO 220
32781 CALL DT_DTHREP(ECO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,SIF1,
32782 *COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
32784 220 CALL DT_DTWOPD(ECO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,
32785 &COD2,COF2,SIF2,AM1,AM2)
32790 IF (REDU.GT.0.D0) GO TO 240
32792 IF (ITWTHC.GT.100) GO TO 30
32793 IF (ITWTH) 220,220,210
32796 IF (IT2-1.LT.0) GO TO 250
32803 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD1,COF1,SIF1,PCM1,ECM1,
32804 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32807 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD2,COF2,SIF2,PCM2,ECM2,
32808 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32809 IF (IT3.LE.0) GO TO 250
32812 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD3,COF3,SIF3,PCM3,ECM3,
32813 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32821 C----------------------------
32823 C ZERO CROSS SECTION CASE
32824 C----------------------------
32836 *$ CREATE DT_RUNTT.FOR
32839 *===runtt==============================================================*
32841 BLOCK DATA DT_RUNTT
32843 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32846 COMMON /HNDRUN/ RUNTES,EFTES
32848 DATA RUNTES,EFTES /100.D0,100.D0/
32852 *$ CREATE DT_NONAME.FOR
32855 *===noname=============================================================*
32857 BLOCK DATA DT_NONAME
32859 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32862 * slope parameters for HADRIN interactions
32863 COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
32865 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
32867 C DATAS DATAS DATAS DATAS DATAS
32869 DATA IKII/ 0, 15, 41, 67, 82, 93, 110, 133, 148, 159, 172, 183,
32870 & 207, 224, 241, 252, 268 /
32871 DATA IEII/ 0, 21, 46, 71, 92, 109, 126, 143, 160, 173, 186, 199,
32872 & 220, 241, 262, 279, 296 /
32873 DATA IRII/ 0, 315, 965, 1615, 1930, 2117, 2406, 2797, 3052, 3195,
32874 & 3364, 3507, 4011, 4368, 4725, 4912, 5184/
32877 C MASSES FOR THE SLOPE B(M) IN GEV
32878 C SLOPE B(M) FOR AN MESONIC SYSTEM
32879 C SLOPE B(M) FOR A BARYONIC SYSTEM
32882 DATA SM,BBM,BBB/ 0.8D0, 0.85D0, 0.9D0, 0.95D0, 1.D0,
32883 & 1.05D0, 1.1D0, 1.15D0, 1.2D0, 1.25D0,
32884 & 1.3D0, 1.35D0, 1.4D0, 1.45D0, 1.5D0,
32885 & 1.55D0, 1.6D0, 1.65D0, 1.7D0, 1.75D0,
32886 & 1.8D0, 1.85D0, 1.9D0, 1.95D0, 2.D0,
32887 & 15.6D0, 14.95D0, 14.3D0, 13.65D0, 13.D0,
32888 & 12.35D0, 11.7D0, 10.85D0, 10.D0, 9.15D0,
32889 & 8.3D0, 7.8D0, 7.3D0, 7.25D0, 7.2D0,
32890 & 6.95D0, 6.7D0, 6.6D0, 6.5D0, 6.3D0,
32891 & 6.1D0, 5.85D0, 5.6D0, 5.35D0, 5.1D0,
32892 & 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0,
32893 & 14.2D0, 13.4D0, 12.6D0,
32894 & 11.8D0, 11.2D0, 10.6D0, 9.8D0, 9.D0,
32895 & 8.25D0, 7.5D0, 6.25D0, 5.D0, 4.5D0, 5*4.D0 /
32899 *$ CREATE DT_DAMG.FOR
32902 *===damg===============================================================*
32904 DOUBLE PRECISION FUNCTION DT_DAMG(IT)
32906 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32909 * particle properties (BAMJET index convention),
32910 * (dublicate of DTPART for HADRIN)
32911 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
32912 & K1H(110),K2H(110)
32914 DIMENSION GASUNI(14)
32916 *-1.D0,-.98D0,-.95D0,-.87D0,-.72D0,-.48D0,
32917 *-.17D0,.17D0,.48D0,.72D0,.87D0,.95D0,.98D0,1.D0/
32918 DATA GAUNO/2.352D0/
32924 IF (IT.LE.0) GO TO 30
32925 IF (IT.LE.NSTAB) GO TO 20
32926 DGAUNI=GAUNO*GAUNON/DBLE(IO-1)
32928 VV=VV*2.0D0-1.0D0+1.D-16
32933 IF (VV.GT.V1) GO TO 10
32934 UNIGA=DGAUNI*(DBLE(I)-2.0D0+(VV-VO+1.D-16)/
32935 & (V1-VO)-(DBLE(IO)-1.0D0)*0.5D0)
32936 DAM=GAH(IT)*UNIGA/GAUNO
32948 *$ CREATE DT_DCALUM.FOR
32951 *===dcalum=============================================================*
32953 SUBROUTINE DT_DCALUM(N,ITTA)
32955 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32958 C*** C.M.S.-ENERGY AND REACTION CHANNEL THRESHOLD CALCULATION
32960 * particle properties (BAMJET index convention),
32961 * (dublicate of DTPART for HADRIN)
32962 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
32963 & K1H(110),K2H(110)
32965 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
32967 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
32969 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
32970 & NRK(2,268),NURE(30,2)
32972 IRE=NURE(N,ITTA/8+1)
32981 ELAB=SQRT(AM12+AM22+2.0D0*SQRT(PLAB2+AM12)*AM2)
32988 IF(NRK(2,IK).GT.0) GO TO 30
32997 IF(IN.GT.0)AMS=AMS+AMH(IN)
32999 IF(IN.GT.0) AMS=AMS+AMH(IN)
33000 IF (AMS.LT.AMSS) AMSS=AMS
33002 IF(UMOO.LT.AMSS) UMOO=AMSS
33008 *$ CREATE DT_DCHANH.FOR
33011 *===dchanh=============================================================*
33013 SUBROUTINE DT_DCHANH
33015 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33018 PARAMETER ( LINP = 10 ,
33022 * particle properties (BAMJET index convention),
33023 * (dublicate of DTPART for HADRIN)
33024 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33025 & K1H(110),K2H(110)
33027 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
33029 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33031 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33032 & NRK(2,268),NURE(30,2)
33034 DIMENSION HWT(460),HWK(40),SI(5184)
33035 EQUIVALENCE (WK(1),SI(1))
33036 C--------------------
33037 C*** USE ONLY FOR DATAPREPARATION OF PURE HADRIN
33038 C*** CALCULATION OF REACTION- AND DECAY-CHANNEL-WEIGHTS,
33039 C*** THRESHOLD ENERGIES+MOMENTA OF REACTION CHNLS.
33040 C*** CHANGE OF WT- AND WK-INPUTDATA INTO WEIGHTS FOR THE M.-C.-PROCEDURE
33041 C*** (ADDED ONE TO EACH OTHER FOR CORRESPONDING CHANNELS)
33042 C--------------------------
33046 IEE=IEII(IRE+1)-IEII(IRE)
33047 IKE=IKII(IRE+1)-IKII(IRE)
33050 * modifications to suppress elestic scattering 24/07/91
33055 IWK=IWKO+IEE*(IK-1)+IE
33056 IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
33057 SIS=SIS+SI(IWK)*SINORC
33061 IF (SIS.GE.1.D-12) GO TO 20
33067 IWK=IWKO+IEE*(IK-1)+IE
33068 IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
33069 SIO=SIO+SI(IWK)*SINORC/SIS
33073 IWK=IWKO+IEE*(IK-1)+IE
33078 INRK1=NRK(1,IIKI+IK)
33079 IF (INRK1.GT.0) AM111=AMH(INRK1)
33081 INRK2=NRK(2,IIKI+IK)
33082 IF (INRK2.GT.0) AM222=AMH(INRK2)
33083 THRESH(IIKI+IK)=AM111 +AM222
33084 IF (INRK2-1.GE.0) GO TO 60
33088 DO 50 INRK1=INRKK,INRKO
33089 INZK1=NZKI(INRK1,1)
33090 INZK2=NZKI(INRK1,2)
33091 INZK3=NZKI(INRK1,3)
33092 IF (INZK1.LE.0.OR.INZK1.GT.110) GO TO 50
33093 IF (INZK2.LE.0.OR.INZK2.GT.110) GO TO 50
33094 IF (INZK3.LE.0.OR.INZK3.GT.110) GO TO 50
33095 C WRITE (6,310)INRK1,INZK1,INZK2,INZK3
33097 AMS=AMH(INZK1)+AMH(INZK2)
33098 IF (INZK3-1.GE.0) AMS=AMS+AMH(INZK3)
33099 IF (AMSS.GT.AMS) AMSS=AMS
33102 IF (AMS.LT.UMO(IEO)) AMS=UMO(IEO)
33103 THRESH(IIKI+IK)=AMS
33114 IF (IK2.GT.460)IK2=460
33121 IF (ABS(HV-1.0D0).GT.1.D-4) WRITE(LOUT,1010)I,JI,HV
33122 1010 FORMAT (35H ERROR IN HWT, FALSE USE OF CHANWH ,2I6,F10.2)
33129 *$ CREATE DT_DHADDE.FOR
33132 *===dhadde=============================================================*
33134 SUBROUTINE DT_DHADDE
33136 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33139 * particle properties (BAMJET index convention)
33141 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
33142 & IICH(210),IIBAR(210),K1(210),K2(210)
33144 * HADRIN: decay channel information
33145 PARAMETER (IDMAX9=602)
33147 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
33149 * particle properties (BAMJET index convention),
33150 * (dublicate of DTPART for HADRIN)
33151 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33152 & K1H(110),K2H(110)
33154 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
33156 * decay channel information for HADRIN
33157 COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
33158 & K1Z(16),K2Z(16),WTZ(153),II22,
33159 & NZK1(153),NZK2(153),NZK3(153)
33165 IF (IRETUR.GT.1) RETURN
33171 IBARH(I) = IIBAR(I)
33186 NZKI(I,1) = NZK(I,1)
33187 NZKI(I,2) = NZK(I,2)
33188 NZKI(I,3) = NZK(I,3)
33203 NZKI(L,3) = NZK3(I)
33204 NZKI(L,2) = NZK2(I)
33205 NZKI(L,1) = NZK1(I)
33210 *$ CREATE IDT_IEFUND.FOR
33213 *===iefund=============================================================*
33215 INTEGER FUNCTION IDT_IEFUND(PL,IRE)
33217 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33220 C*****IEFUN CALCULATES A MOMENTUM INDEX
33222 PARAMETER ( LINP = 10 ,
33226 COMMON /HNDRUN/ RUNTES,EFTES
33228 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33230 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33231 & NRK(2,268),NURE(30,2)
33236 IF (PL.LT.0.) GO TO 30
33239 IF (PL.LE.PLABF(I)) GO TO 60
33242 IF ( EFTES.GT.40.D0) GO TO 20
33244 WRITE(LOUT,1000)PL,J
33250 IF (-PL.LE.UMO(I)) GO TO 60
33253 IF ( EFTES.GT.40.D0) GO TO 50
33255 WRITE(LOUT,1000)PL,I
33261 1000 FORMAT(14H PLAB OR -ECM=,E12.4,27H IS OUT OF CONSIDERED RANGE ,
33265 *$ CREATE DT_DSIGIN.FOR
33268 *===dsigin=============================================================*
33270 SUBROUTINE DT_DSIGIN(IRE ,PLAB,N,IE ,AMT ,AMN,ECM ,SI ,ITAR)
33272 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33275 * particle properties (BAMJET index convention),
33276 * (dublicate of DTPART for HADRIN)
33277 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33278 & K1H(110),K2H(110)
33280 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33282 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33283 & NRK(2,268),NURE(30,2)
33285 IE=IDT_IEFUND(PLAB,IRE)
33286 IF (IE.LE.IEII(IRE)) IE=IE+1
33291 ECM=SQRT(AMN2+AMT2+2.0D0*AMT*SQRT(AMN2+PLAB**2))
33292 C*** INTERPOLATION PREPARATION
33298 EKLIM=-THRESH(IIKI)
33301 IF (ECM.GT.ECMO) WDK=0.0D0
33302 C*** INTERPOLATION IN CHANNEL WEIGHTS
33303 IELIM=IDT_IEFUND(EKLIM,IRE)
33304 DELIM=UMO(IELIM)+EKLIM
33306 DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
33307 IF (DELIM*DELIM-DETE*DETE) 20,20,10
33312 WKK=WOK-WDK*DEC/(DECC+1.D-9)
33313 IF (WKK.LT.0.0D0) WKK=0.0D0
33315 IF (-EKLIM.GT.ECM) SI=1.D-14
33319 *$ CREATE DT_DTCHOI.FOR
33322 *===dtchoi=============================================================*
33324 SUBROUTINE DT_DTCHOI(T,P,PP,E,EE,I,II,N,AM1,AM2)
33326 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33329 C ****************************
33330 C TCHOIC CALCULATES A RANDOM VALUE
33331 C FOR THE FOUR-MOMENTUM-TRANSFER T
33332 C ****************************
33334 * particle properties (BAMJET index convention),
33335 * (dublicate of DTPART for HADRIN)
33336 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33337 & K1H(110),K2H(110)
33339 * slope parameters for HADRIN interactions
33340 COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
33344 IF (I.GT.30.AND.II.GT.30) GO TO 20
33347 IF (I.LE.30) GO TO 10
33355 IF (AMA.LE.AMB) GO TO 30
33361 K=INT((AMA-0.75D0)/0.05D0)
33363 IF (K-26.GE.0) K=25
33370 TMIN=-2.0D0*(E*EE-P*PP)+AMH(N)**2+AM1 **2
33371 TMAX=-2.0D0*(E*EE+P*PP)+AMH(N)**2+AM1 **2
33374 C IF (VB.LT.0.2D0) BM=BM*0.1
33381 IF (ABS(TMA).GT.120.D0) GO TO 70
33384 AN=(1.0D0/BM)*(EXP(TMI)-ETMA)
33385 C*** RANDOM CHOICE OF THE T - VALUE
33387 T=(1.0D0/BM)*LOG(ETMA+R*AN*BM)
33391 *$ CREATE DT_DTWOPA.FOR
33394 *===dtwopa=============================================================*
33396 SUBROUTINE DT_DTWOPA(E1,E2,P1,P2,COD1,COD2,COF1,COF2,SIF1,SIF2,
33397 &IT1,IT2,UMOO,ECM,P,N,AM1,AM2)
33399 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33402 C ******************************************************
33403 C QUASI TWO PARTICLE PRODUCTION
33404 C TWOPAR CALCULATES THE ENERGYS AND THE MOMENTA
33405 C FOR THE CREATED PARTICLES OR RESONANCES IT1 AND IT2
33406 C IN THE CM - SYSTEM
33407 C COD1,COD2,COF1,COF2,SIF1,SIF2 ARE THE ANGLES FOR
33408 C SPHERICAL COORDINATES
33409 C ******************************************************
33411 * particle properties (BAMJET index convention),
33412 * (dublicate of DTPART for HADRIN)
33413 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33414 & K1H(110),K2H(110)
33419 E1=((UMOO-AMB)*(UMOO+AMB) + AMA2)/(2.0D0*UMOO)
33421 IF (E1.LT.AMA*1.00001D0) E1=AMA*1.00001D0
33422 AMTE=(E1-AMA)*(E1+AMA)
33426 C / P2 / = / P1 / BUT OPPOSITE DIRECTIONS
33427 C DETERMINATION OF THE ANGLES
33428 C COS(THETA1)=COD1 COS(THETA2)=COD2
33429 C SIN(PHI1)=SIF1 SIN(PHI2)=SIF2
33430 C COS(PHI1)=COF1 COS(PHI2)=COF2
33431 C PHI IS UNIFORMLY DISTRIBUTED IN ( 0,2*PI )
33432 CALL DT_DSFECF(COF1,SIF1)
33435 C CALCULATION OF THETA1
33436 CALL DT_DTCHOI(TR,P,P1,ECM,E1,IT1,IT2,N,AM1,AM2)
33437 COD1=(TR-AMA2-AMH(N)*AMH(N)+2.0D0*ECM*E1)/(2.0D0*P*P1+1.D-18)
33438 IF (COD1.GT.0.9999999D0) COD1=0.9999999D0
33443 *$ CREATE DT_ZK.FOR
33446 *===zk=================================================================*
33450 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33453 * decay channel information for HADRIN
33454 COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
33455 & K1Z(16),K2Z(16),WTZ(153),II22,
33456 & NZK1(153),NZK2(153),NZK3(153)
33458 * decay channel information for HADRIN
33459 CHARACTER*8 ANAMZ,ZKNAM4,ZKNAM5,ZKNAM6
33460 COMMON /HNADDN/ ANAMZ(16),ZKNAM4(9),ZKNAM5(90),ZKNAM6(54)
33462 * Particle masses in GeV *
33463 DATA AMZ/ 3*2.2D0, 0.9576D0, 3*1.887D0, 2.4D0, 2.03D0, 2*1.44D0,
33465 * Resonance width Gamma in GeV *
33466 DATA GAZ/ 3*.2D0, .1D0, 4*.2D0, .18D0, 2*.2D0, 2*.15D0, 3*0.D0 /
33467 * Mean life time in seconds *
33468 DATA TAUZ / 16*0.D0 /
33469 * Charge of particles and resonances *
33470 DATA ICHZ/ 0, 1, 3*0, 1, -1, 0, 1, -1, 0, 0, 1 , 3*0 /
33471 * Baryonic charge *
33472 DATA IBARZ/ 2, 7*0, 1, -1, -1, 1, 1, 3*0 /
33473 * First number of decay channels used for resonances *
33474 * and decaying particles *
33475 DATA K1Z/ 308,310,313,317,322,365,393,421,425,434,440,446,449,
33477 * Last number of decay channels used for resonances *
33478 * and decaying particles *
33479 DATA K2Z/ 309,312,316,321,364,392,420,424,433,439,445,448,451,
33481 * Weight of decay channel *
33482 DATA WTZ/ .17D0, .83D0, 2*.33D0, .34D0, .17D0, 2*.33D0, .17D0,
33483 & .01D0, .13D0, .36D0, .27D0, .23D0, .0014D0, .0029D0, .0014D0,
33484 & .0029D0, 4*.0007D0, .0517D0, .0718D0, .0144D0, .0431D0, .0359D0,
33485 & .0718D0, .0014D0, .0273D0, .0014D0, .0431D0, 2*.0129D0, .0259D0,
33486 & .0517D0, .0359D0, .0014D0, 2*.0144D0, .0129D0, .0014D0, .0259D0,
33487 & .0359D0, .0072D0, .0474D0, .0948D0, .0259D0, .0072D0, .0144D0,
33488 & .0287D0, .0431D0, .0144D0, .0287D0, .0474D0, .0144D0, .0075D0,
33489 & .0057D0, .0019D0, .0038D0, .0095D0, 2*.0014D0, .0191D0, .0572D0,
33490 & .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0, .0686D0,.0172D0,
33491 & .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, .0190D0,
33492 & .0057D0, .0019D0, .0038D0, .0095D0, .0014D0, .0014D0, .0191D0,
33493 & .0572D0, .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0,.0686D0,
33494 & .0172D0, .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0,
33495 & .0190D0, 4*.25D0, 2*.2D0, .12D0, .1D0, .07D0, .07D0, .14D0,
33496 & 2*.05D0, .0D0, .3334D0, .2083D0, 2*.125D0, .2083D0, .0D0, .125D0,
33497 & .2083D0, .3334D0, .2083D0, .125D0, .3D0, .05D0, .65D0, .3D0,
33498 & .05D0, .65D0, 9*1.D0 /
33499 * Particle numbers in decay channel *
33500 DATA NZK1/ 8, 1, 2, 9, 1, 2, 9, 2, 9, 7, 13, 31, 15, 24, 23, 13,
33501 & 23, 13, 2*23, 14, 13, 23, 31, 98, 2*33, 32, 23, 14, 13, 35, 2*23,
33502 & 14, 13, 33, 23, 98, 31, 23, 14, 13, 35, 2*33, 32, 23, 35, 33, 32,
33503 & 98, 5*35, 4*13, 23, 13, 98, 32, 33, 23, 13, 23, 13, 14, 13, 32,
33504 & 13, 98, 23, 13, 2*32, 13, 33, 32, 98, 2*35, 4*14, 23, 14, 98,
33505 & 2*34, 23, 14, 23, 2*14, 13, 34, 14, 98, 23, 14, 2*34, 14, 33, 32,
33506 & 98, 2*35, 104, 61, 105, 62, 1, 17, 21, 17, 22, 2*21, 22, 21, 2,
33507 & 67, 68, 69, 2, 2*9, 68, 69, 70, 2, 9, 2*24, 15, 2*25, 16, 9*0/
33508 DATA NZK2/ 2*8, 1, 8, 9, 2*8, 2*1, 7, 14, 13, 16, 25, 23, 14, 23,
33509 & 14, 31, 33, 32, 34, 35, 31, 23, 31, 33, 34, 31, 32, 34, 31, 33,
33510 & 32, 2*33, 35, 31, 33, 31, 33, 32, 34, 35, 31, 33, 34, 35, 31,
33511 & 4*33, 32, 3*35, 2*23, 13, 31, 32, 33, 13, 31, 32, 2*31, 32, 33,
33512 & 32, 32, 35, 31, 2*32, 33, 31, 33, 35, 33, 3*32, 35, 2*23, 14,
33513 & 31, 34, 33, 14, 31, 33, 2*31, 34, 32, 33, 34, 35, 31, 2*34, 33,
33514 & 31, 33, 35, 33, 2*34, 33, 35, 1, 2, 8, 9, 25, 13, 35, 2*32, 33,
33515 & 31, 13, 23, 31, 13, 23, 14, 79, 80, 31, 13, 23, 14, 78, 79, 8,
33516 & 1, 8, 1, 8, 1, 9*0 /
33517 DATA NZK3/ 23, 14, 2*13, 23, 13, 2*23, 14, 0, 7, 14, 4*0, 2*23,
33518 & 10*0, 33, 2*31, 0, 33, 34, 32, 34, 0, 35, 0, 31, 3*35, 0, 3*31,
33519 & 35, 31, 33, 34, 31, 33, 34, 31, 33, 35, 0, 23, 14, 6*0, 32, 3*33,
33520 & 32, 34, 0, 35, 0, 2*35, 2*31, 35, 32, 34, 31, 33, 32, 0, 23, 13,
33521 & 6*0, 34, 2*33, 34, 33, 34, 0, 35, 0,2*35, 2*31, 35, 2*34, 31,
33522 & 2*34, 25*0, 23, 2*14, 23, 2*13, 9*0 /
33524 DATA ANAMZ / 'NNPI', 'ANPPI', 'ANNPI', ' ETS ',' PAP ',' PAN ',
33525 & 'APN', 'DEO ', 'S+2030', 'AN*-14', 'AN*014','KONPI ','AKOPPI',
33527 * Name of decay channel *
33528 DATA ZKNAM4/'NNPI0','PNPI-','APPPI+','ANNPI+','ANPPI0','APNPI+',
33529 & 'ANNPI0','APPPI0','ANPPI-'/
33530 DATA ZKNAM5/' GAGA ','P+P-GA','ETP+P-','K+K- ','K0AK0 ',
33531 & ' POPO ',' P+P- ','POPOPO','P+P0P-','P0ET ','&0R0 ','P-R+ ',
33532 & 'P+R- ','POOM ',' ETET ','ETSP0 ','R0ET ',' R0R0 ','R+R- ',
33533 & 'P0ETR0','P-ETR+','P+ETR-',' OMET ','P0R0R0','P0R+R-','P-R+R0',
33534 & 'P+R-R0','R0OM ','P0ETOM','ETSR0 ','ETETET','P0R0OM','P-R+OM',
33535 & 'P+R-OM','OMOM ','R0ETET','R0R0ET','R+R-ET','P0OMOM','OMETET',
33536 & 'R0R0R0','R+R0R-','ETSRET','OMR0R0','OMR+R-','OMOMET','OMOMR0',
33538 & ' P+PO ','P+POPO','P+P+P-','P+ET ','P0R+ ','P+R0 ','ETSP+ ',
33539 & 'R+ET ',' R0R+ ','POETR+','P+ETR0','POR+R-','P+R0R0','P-R+R+',
33540 & 'P+R-R+','R+OM ','P+ETOM','ETSR+ ','POR+OM','P+R0OM','R+ETET',
33541 & 'R+R0ET','P+OMOM','R0R0R+','R+R+R-','ETSR+E','OMR+R0','OMOMR+',
33542 & 'P-PO ','P-POPO','P-P-P+','P-ET ','POR- ','P-R0 ','ETSP- ',
33543 & 'R-ET ','R-R0 ','POETR-','P-ETR0','POR-R0','P-R+R-','P-R0R0'/
33544 DATA ZKNAM6/'P+R-R-','R-OM ','P-ETOM','ETSR- ','POR-OM','P-R0OM',
33545 & 'R-ETET','R-R0ET','P-OMOM','R0R0R-','R+R-R-','ETSR-E','OMR0R-',
33546 & 'OMOMR-', 'PAN-14','APN+14','NAN014','ANN014','PAKO ','LPI+ ',
33547 & 'SI+OM','LAMRO+','SI0RO+','SI+RO0','SI+ETA','SI0PI+','SI+PI0',
33548 & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHOO','ANRHO-','ANETA ',
33549 & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0',
33550 & 'KONPIO','KOPPI-','K+NPI-','AKOPPO','AKONP+','K-PPI+',
33555 *$ CREATE DT_BLKD43.FOR
33558 *===blkd43=============================================================*
33560 BLOCK DATA DT_BLKD43
33562 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33566 *=== reac =============================================================*
33568 *----------------------------------------------------------------------*
33570 * Created on 10 december 1991 by Alfredo Ferrari & Paola Sala *
33573 * Last change on 10-dec-91 by Alfredo Ferrari *
33575 * This is the original common reac of Hadrin *
33577 *----------------------------------------------------------------------*
33580 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33581 & NRK(2,268),NURE(30,2)
33584 & UMOPI(92), UMOKC(68), UMOP(39), UMON(63), UMOK0(34),
33585 & PLAPI(92), PLAKC(68), PLAP(39), PLAN(63), PLAK0(34),
33586 & SPIKP1(315), SPIKPU(278), SPIKPV(372),
33587 & SPIKPW(278), SPIKPX(372), SPIKP4(315),
33588 & SPIKP5(187), SPIKP6(289),
33589 & SKMPEL(102), SPIKP7(289), SKMNEL(68), SPIKP8(187),
33590 & SPIKP9(143), SPIKP0(169), SPKPV(143),
33591 & SAPPEL(105), SPIKPE(399), SAPNEL(84), SPIKPZ(273),
33592 & SANPEL(84) , SPIKPF(273),
33593 & SPKP15(187), SPKP16(272),
33594 & NRKPI(164), NRKKC(132), NRKP(70), NRKN(116), NRKK0(54),
33597 DIMENSION NRKLIN(532)
33598 EQUIVALENCE (NRK(1,1), NRKLIN(1))
33599 EQUIVALENCE ( UMO( 1), UMOPI(1)), ( UMO( 93), UMOKC(1))
33600 EQUIVALENCE ( UMO(161), UMOP(1)), ( UMO(200), UMON(1))
33601 EQUIVALENCE ( UMO(263), UMOK0(1))
33602 EQUIVALENCE ( PLABF( 1), PLAPI(1)), ( PLABF( 93), PLAKC(1))
33603 EQUIVALENCE ( PLABF(161), PLAP(1)), ( PLABF(200), PLAN(1))
33604 EQUIVALENCE ( PLABF(263), PLAK0(1))
33605 EQUIVALENCE ( WK( 1), SPIKP1(1)), ( WK( 316), SPIKPU(1))
33606 EQUIVALENCE ( WK( 594), SPIKPV(1)), ( WK( 966), SPIKPW(1))
33607 EQUIVALENCE ( WK(1244), SPIKPX(1)), ( WK(1616), SPIKP4(1))
33608 EQUIVALENCE ( WK(1931), SPIKP5(1)), ( WK(2118), SPIKP6(1))
33609 EQUIVALENCE ( WK(2407), SKMPEL(1)), ( WK(2509), SPIKP7(1))
33610 EQUIVALENCE ( WK(2798), SKMNEL(1)), ( WK(2866), SPIKP8(1))
33611 EQUIVALENCE ( WK(3053), SPIKP9(1)), ( WK(3196), SPIKP0(1))
33612 EQUIVALENCE ( WK(3365), SPKPV(1)), ( WK(3508), SAPPEL(1))
33613 EQUIVALENCE ( WK(3613), SPIKPE(1)), ( WK(4012), SAPNEL(1))
33614 EQUIVALENCE ( WK(4096), SPIKPZ(1)), ( WK(4369), SANPEL(1))
33615 EQUIVALENCE ( WK(4453), SPIKPF(1)), ( WK(4726), SPKP15(1))
33616 EQUIVALENCE ( WK(4913), SPKP16(1))
33617 EQUIVALENCE (NRK(1,1), NRKLIN(1))
33618 EQUIVALENCE (NRKLIN( 1), NRKPI(1)), (NRKLIN( 165), NRKKC(1))
33619 EQUIVALENCE (NRKLIN( 297), NRKP(1)), (NRKLIN( 367), NRKN(1))
33620 EQUIVALENCE (NRKLIN( 483), NRKK0(1))
33621 EQUIVALENCE (NURE(1,1), NURELN(1))
33625 DATA PLAPI / 0.D0, .3D0, .5D0, .6D0, .7D0, .8D0, .9D0, .95D0,1.D0,
33626 & 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0,
33627 & 3.D0, 3.5D0, 4.D0, 0.D0, .285D0, .4D0, .45D0, .5D0, .6D0, .7D0,
33628 & .75D0, .8D0, .85D0, .9D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0,
33629 & 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0,
33630 & .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, .75D0, .8D0, .85D0, .9D0,
33631 & 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0,
33632 & 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, .3D0, .5D0, .6D0, .7D0,
33633 & .8D0, .9D0, .95D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0,
33634 & 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0 /
33636 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33637 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33638 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33639 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33640 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33641 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33642 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33643 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33644 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33645 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33646 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33647 & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
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/
33657 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33658 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33659 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33660 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33661 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33662 & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
33663 * app apn anp ann *
33665 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
33666 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33667 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33668 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
33669 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33670 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33671 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
33672 & .74D0, 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 DATA SIIN / 296*0.D0 /
33675 DATA UMOPI/ 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
33676 & 1.557D0,1.615D0,1.6435D0,
33677 & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
33678 & 2.286D0,2.366D0,2.482D0,2.56D0,
33680 & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
33681 & 1.496D0,1.527D0,1.557D0,
33682 & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
33683 & 2.071D0,2.159D0,2.286D0,2.366D0,
33684 & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
33685 & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
33686 & 1.496D0,1.527D0,1.557D0,
33687 & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
33688 & 2.071D0,2.159D0,2.286D0,2.366D0,
33689 & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
33690 & 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
33691 & 1.557D0,1.615D0,1.6435D0,
33692 & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
33693 & 2.286D0,2.366D0,2.482D0,2.56D0,
33695 DATA UMOKC/ 1.44D0,
33696 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33697 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33699 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33700 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33702 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33703 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33705 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33706 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33708 DATA UMOK0/ 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,
33717 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33718 & 3.D0,3.1D0,3.2D0,
33719 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33720 & 3.D0,3.1D0,3.2D0,
33721 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33722 & 3.D0,3.1D0,3.2D0/
33723 * app apn anp ann *
33725 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
33726 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33727 & 3.D0,3.1D0,3.2D0,
33728 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
33729 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33730 & 3.D0,3.1D0,3.2D0,
33731 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
33732 & 2.D0,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 **** reaction channel state particles *
33735 DATA NRKPI / 13, 1, 15, 21, 81, 0, 13, 54, 23, 53, 13, 63, 13, 58,
33736 & 23, 57, 13, 65, 1, 32, 53, 31, 54, 32, 53, 33, 53, 35, 63, 32,
33737 & 13, 8, 23, 1, 17, 15, 21, 24, 22, 15, 82, 0, 61, 0, 13, 55, 23,
33738 & 54, 14, 53, 13, 64, 23, 63, 13, 59, 23, 58, 14, 57, 13, 66, 23,
33739 & 65, 1, 31, 8, 32, 1, 33, 1, 35, 54, 31, 55, 32, 54, 33, 53, 34,
33740 & 54, 35, 14, 1, 23, 8, 17, 24, 20, 15, 22, 24, 83, 0, 62, 0, 14,
33741 & 54, 23, 55, 13, 56, 14, 63, 23, 64, 14, 58, 23, 59, 13, 60, 14,
33742 & 65, 23, 66, 8, 31, 1, 34, 8, 33, 8, 35, 55, 31, 54, 34, 55, 33,
33743 & 56, 32, 55, 35, 14, 8, 24, 20, 84, 0, 14, 55, 23, 56, 14, 64, 14,
33744 & 59, 23, 60, 14, 66, 8, 34, 56, 31, 55, 34, 56, 33, 56, 35, 64,34/
33745 DATA NRKKC/ 15, 1, 89, 0, 24, 53, 15, 54, 1, 36, 1, 40, 1, 44, 36,
33746 & 63, 15, 63, 45, 53, 44, 54, 15, 8, 24, 1, 91, 0, 24, 54, 15, 55,
33747 & 8, 36, 1, 37, 8, 40, 1, 41, 8, 44, 1, 45, 36, 64, 37, 63, 15, 64,
33748 & 24, 63, 45, 54, 44, 55, 16, 1, 25, 8, 17, 23, 21, 14, 20,
33749 & 13, 22, 23, 90, 0, 38, 1, 39, 8, 16, 54, 25, 55, 1, 42, 8, 43,
33750 & 16, 63, 25, 64, 39, 64, 38, 63, 46, 54, 47, 55, 8, 47, 1, 46, 52,
33751 & 0, 51, 0, 16, 8, 17, 14, 20, 23, 22, 14, 92, 0, 8, 38, 16, 55,
33752 & 25, 56, 8, 42, 16, 64, 38, 64, 46, 55, 47, 56, 8, 46, 94, 0 /
33754 * k0 p k0 n ak0 p ak/ n *
33756 DATA NRKK0 / 24, 8, 106, 0, 15, 56, 24, 55, 37, 8, 41, 8, 45, 8,
33757 & 37, 64, 24, 64, 44, 56, 45, 55, 25, 1, 17, 13, 22, 13, 21, 23,
33758 & 107, 0, 39, 1, 25, 54, 16, 53, 43, 1, 25, 63, 39, 63, 47, 54, 46,
33759 & 53, 47, 1, 103, 0, 93, 0/
33761 DATA NRKP / 1, 1, 85, 0, 8, 53, 1, 54, 1, 63, 8, 57, 1, 58, 2*54,
33762 & 53, 55, 63, 54, 64, 53, 1, 8, 86, 0, 8, 54, 1, 55, 8, 63, 1, 64,
33763 & 8, 58, 1, 59, 64, 54, 63, 55, 54, 55, 53, 56, 77, 0, 2*8, 95, 0,
33764 & 8, 55, 1, 56, 8, 64, 8, 59, 1, 60, 2*55, 54, 56, 64, 55, 63, 56 /
33765 * app apn anp ann *
33766 DATA NRKN/ 1, 2, 17, 18, 15, 16, 8, 9, 13, 14, 99, 0, 87, 0, 1,
33767 & 68, 8, 69, 2, 54, 9, 55, 102, 0, 2, 63, 9, 64, 1, 75, 8, 76, 53,
33768 & 67, 54, 68, 55, 69, 56, 70, 63, 68, 64, 69, 75, 54, 76, 55, 2, 8,
33769 & 18, 20, 16, 24, 14, 23, 101, 0, 88, 0, 2, 55, 9, 56, 1, 67, 8,
33770 & 68, 2, 64, 8, 75, 2, 59, 8, 72, 68, 55, 67, 54, 69, 56, 1, 9, 18,
33771 & 21, 15, 25, 13, 23, 100, 0, 96, 0, 2, 53, 9, 54, 1, 69, 8, 70, 1,
33772 & 76, 9, 63, 1, 73, 9, 58, 55, 70, 53, 68, 54, 69 /
33773 **** channel cross section *
33774 DATA SPIKP1/ 0.D0, 300.D0, 40.D0, 20.D0, 13.D0,8.5D0,8.D0, 9.5D0,
33775 & 12.D0,14.D0,15.5D0,20.D0,17.D0,13.D0,10.D0,9.D0,8.5D0,8.D0,7.8D0,
33776 & 7.3D0, 6.7D0, 9*0.D0,.23D0,.35D0,.7D0,.52D0,.4D0,.3D0,.2D0,.15D0,
33777 & .13D0, .11D0, .09D0, .07D0, 0.D0, .033D0,.8D0,1.35D0,1.35D0,.5D0,
33778 & 15*0.D0, 3*0.D0,.00D0,0.80D0,2.2D0,3.6D0,4.6D0,4.7D0,3.5D0,2.4D0,
33779 &1.8D0,1.4D0,.75D0,.47D0,.25D0,.13D0,.08D0,6*0.D0,0.D0,1.2D0,3.3D0,
33780 & 5.4D0,6.9D0,7.3D0,5.3D0,3.6D0,2.7D0,2.2D0,1.1D0,.73D0,.4D0,.22D0,
33781 & .12D0,9*0.D0,.0D0,0.D0,2.0D0,4.4D0,6.8D0,9.9D0,7.9D0,6.0D0,3.8D0,
33782 &2.5D0,2.D0,1.4D0,1.D0,.6D0,.35D0,10*0.D0,.25D0,.55D0,.75D0,1.25D0,
33783 & 1.9D0,2.D0,1.8D0,1.5D0,1.25D0,1.D0,.8D0,6*0.D0,4*0.D0,.4D0,.85D0,
33784 & 1.1D0, 1.85D0, 2.8D0, 3.D0,2.7D0,2.2D0,1.85D0,1.5D0,1.2D0,6*0.D0,
33785 & 6*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, 5.6D0,
33786 & 5.2D0, 6*0.D0, 2*0.D0, .0D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0,
33787 & 2.75D0, 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 6*0.D0, 3*0.D0,
33788 & .0D0, .45D0, 1.4D0, 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0,
33789 & 8*0.D0, 5*0.D0, .0D0, .0D0, .6D0, .8D0, .95D0, .8D0, .7D0, .6D0,
33790 & .5D0, .4D0, 6*0.D0, 5*0.D0, .0D0, .00D0, .85D0, 1.2D0, 1.4D0,
33791 & 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 6*0.D0, 5*0.D0, .0D0, .00D0,
33792 & 1.D0, 1.5D0, 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 6*0.D0,
33793 & 10*0.D0, .5D0, 2.0D0, 3.3D0, 5.4D0, 7.D0 /
33795 DATA SPIKPU/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 20.D0,
33796 & 20.D0, 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
33797 & 10.D0, 10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
33798 & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
33799 & 4.2D0, 7.5D0, 3.4D0, 2.5D0, 2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0,
33800 & .6D0, .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0,
33801 & .48D0, .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0,
33802 & .065D0, .05D0, .04D0, 12*0.D0, .2D0, .25D0, .25D0, .2D0, .1D0,
33803 & .08D0, .06D0, .045D0, .03D0, .02D0, .01D0, .005D0, .003D0,
33804 & 12*0.D0, .3D0, .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0,
33805 & .09D0, .08D0, .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0,
33806 & 3.1D0, 4.5D0, 2.D0, 18*0.D0, 3*.0D0, 0.D0, 0.D0, 4.0D0, 11.D0,
33807 & 11.4D0, 10.3D0, 7.5D0, 6.8D0, 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0,
33808 & .35D0, 13*0.D0, .1D0, .34D0, .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0,
33809 & 2.3D0, 1.6D0, .95D0, .45D0, .28D0, .15D0, 10*0.D0, 2*0.D0, .17D0,
33810 & .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0, 6.2D0, 4.4D0, 3.D0, 1.8D0,
33811 & .9D0, .53D0, .28D0, 10*0.D0, 2*0.D0, .25D0, .82D0,
33812 & 1.3D0, 1.9D0, 2.8D0, 5.5D0 , 8.D0, 5.7D0, 3.9D0, 2.35D0, 1.15D0,
33813 & .69D0, .37D0, 10*0.D0, 7*0.D0, .0D0, .34D0, 1.5D0, 3.47D0,
33814 & 5.87D0, 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
33816 DATA SPIKPV/ 7*0.D0, .00D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
33817 & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 6*0.D0, 10*0.D0, .2D0,
33818 & .6D0, .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0,
33819 & 1.D0, .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0,
33820 & 3.5D0, 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0,
33821 & .31D0, .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0,
33822 & .23D0, 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0,
33823 & 5.D0, 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0,
33824 & 2.5D0, 3*0.D0, 3*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0,
33825 & 1.5D0, 1.1D0, .8D0, .7D0, .55D0, .3D0, 10*0.D0, 9*0.D0, .1D0,
33826 & .4D0, 1.D0, 1.4D0, 2.2D0, 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0,
33827 & .8D0, .6D0, .4D0, 12*0.D0, .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0,
33828 & 3.8D0, 3.3D0, 2.45D0, 2.05D0, 1.65D0, 1.2D0, .9D0, .6D0, 3*0.D0,
33829 & 9*0.D0, .10D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0,
33830 & 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, 13*0.D0, .2D0, .5D0, .7D0,
33831 & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
33832 & 17*0.D0, .2D0, .5D0, .85D0, 2.D0, 2.15D0, 2.05D0, 1.75D0, 1.D0,
33833 & 17*0.D0, .13D0, .33D0, .57D0, 1.33D0, 1.43D0, 1.36D0, 1.17D0,
33834 & .67D0, 17*0.D0, .07D0, .17D0, .28D0, .67D0, .72D0, .69D0, .58D0,
33835 & .33D0,17*0.D0,.4D0, .7D0, 1.D0, 1.6D0, 1.8D0, 2.3D0,1.9D0,1.7D0 /
33837 DATA SPIKPW/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 2*20.D0,
33838 & 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
33839 & 2*10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
33840 & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
33841 & 4.2D0, 7.5D0, 3.4D0, 2*2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, .6D0,
33842 & .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, .48D0,
33843 & .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, .065D0,
33844 & .05D0, .04D0, 12*0.D0, .2D0, 2*.25D0, .2D0, .1D0, .08D0, .06D0,
33845 & .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, 12*0.D0, .3D0,
33846 & .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, .09D0, .08D0,
33847 & .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, 3.1D0, 4.5D0,
33848 & 2.D0, 23*0.D0, 4.0D0, 11.D0, 11.4D0, 10.3D0, 7.5D0, 6.8D0,
33849 & 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, .35D0, 13*0.D0, .1D0, .34D0,
33850 & .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, 2.3D0, 1.6D0, .95D0, .45D0,
33851 & .28D0, .15D0, 12*0.D0, .17D0, .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0,
33852 & 6.2D0, 4.4D0, 3.D0, 1.8D0, .9D0, .53D0, .28D0, 12*0.D0, .25D0,
33853 & .82D0, 1.3D0, 1.9D0, 2.8D0, 5.5D0, 8.D0, 5.7D0, 3.9D0, 2.35D0,
33854 & 1.15D0, .69D0, .37D0, 18*0.D0, .34D0, 1.5D0, 3.47D0, 5.87D0,
33855 & 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
33857 DATA SPIKPX/ 8*0.D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
33858 & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 16*0.D0, .2D0, .6D0,
33859 & .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, 1.D0,
33860 & .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, 3.5D0,
33861 & 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, .31D0,
33862 & .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, .23D0,
33863 & 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, 5.D0,
33864 & 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, 2.5D0,
33865 & 6*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, 1.5D0, 1.1D0,
33866 & .8D0, .7D0, .55D0, .3D0, 19*0.D0, .1D0, .4D0, 1.D0, 1.4D0, 2.2D0,
33867 & 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, .8D0, .6D0, .4D0, 12*0.D0,
33868 & .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, 3.8D0, 3.3D0, 2.45D0, 2.05D0,
33869 & 1.65D0, 1.2D0, .9D0, .6D0, 12*0.D0, .10D0, .2D0, .5D0, .7D0,
33870 & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
33871 & 13*0.D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0,
33872 & 1.35D0, 1.15D0, .95D0, .7D0, 17*0.D0, .2D0, .5D0, .85D0, 2.D0,
33873 & 2.15D0, 2.05D0, 1.75D0, 1.D0, 17*0.D0, .13D0, .33D0, .57D0,
33874 & 1.33D0, 1.43D0, 1.36D0, 1.17D0, .67D0, 17*0.D0, .07D0, .17D0,
33875 & .28D0, .67D0, .72D0, .69D0, .58D0, .33D0, 17*0.D0, .4D0, .7D0,
33876 & 1.D0, 1.6D0, 1.8D0, 2.3D0, 1.9D0, 1.7D0 /
33878 DATA SPIKP4 / 0.D0, 300.D0, 40.D0, 20.D0, 13.D0, 8.5D0, 8.D0,
33879 & 9.5D0, 12.D0, 14.D0, 15.5D0, 20.D0, 17.D0, 13.D0, 10.D0, 9.D0,
33880 & 8.5D0, 8.D0, 7.8D0, 7.3D0, 6.7D0, 9*0.D0, .23D0, .35D0, .7D0,
33881 & .52D0, .4D0, .3D0, .2D0, .15D0, .13D0, .11D0, .09D0, .07D0, 0.D0,
33882 & .033D0, .8D0, 2*1.35D0, .5D0, 19*0.D0, 0.8D0, 2.2D0, 3.6D0,
33883 & 4.6D0, 4.7D0, 3.5D0, 2.4D0, 1.8D0, 1.4D0, .75D0, .47D0, .25D0,
33884 & .13D0, .08D0, 7*0.D0, 1.2D0, 3.3D0, 5.4D0, 6.9D0, 7.3D0, 5.3D0,
33885 & 3.6D0, 2.7D0, 2.2D0, 1.1D0, .73D0, .4D0, .22D0, .12D0, 11*0.D0,
33886 & 2.0D0, 4.4D0, 6.8D0, 9.9D0, 7.9D0, 6.0D0, 3.8D0, 2.5D0, 2.D0,
33887 & 1.4D0, 1.D0, .6D0, .35D0, 10*0.D0, .25D0, .55D0, .75D0, 1.25D0,
33888 & 1.9D0, 2.D0, 1.8D0, 1.5D0, 1.25D0, 1.D0, .8D0, 10*0.D0, .4D0,
33889 & .85D0, 1.1D0, 1.85D0, 2.8D0, 3.D0, 2.7D0, 2.2D0, 1.85D0, 1.5D0,
33890 & 1.2D0, 12*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0,
33891 & 5.6D0, 5.2D0, 9*0.D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, 2.75D0,
33892 & 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 10*0.D0, .45D0, 1.4D0,
33893 & 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, 15*0.D0, .6D0,
33894 & .8D0, .95D0, .8D0, .7D0, .6D0, .5D0, .4D0, 13*0.D0, .85D0, 1.2D0,
33895 & 1.4D0, 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 13*0.D0, 1.D0, 1.5D0,
33896 & 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 16*0.D0, .5D0, 2.0D0,
33897 & 3.3D0, 5.4D0, 7.D0 /
33899 DATA SPIKP5/ 0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0,
33900 & 7.D0, 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
33901 & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 13*0.D0, 0.9D0,
33902 & 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0,
33903 & .45D0, .21D0, .2D0, 3*0.D0, .9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
33904 & 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
33905 & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, 1.4D0,
33906 & 1.2D0, 1.05D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, 2*1.D0, .9D0,
33907 & .7D0, .4D0, .3D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.2D0,
33908 & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
33909 & 1.71D0, 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0,
33910 & 3.5D0, 2.85D0, 2.35D0, 2.01D0, 1.8D0, 12*0.D0, .1D0, .8D0,2.05D0,
33911 & 3.31D0, 3.5D0, 12*0.D0, .034D0, .2D0, .75D0, 1.04D0, 1.24D0 /
33913 DATA SPIKP6/ 0.D0, 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0,
33914 & 1.5D0, 1.2D0, 1.D0, .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0,
33915 & 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, 1.5D0, 1.2D0, 1.D0,
33916 & .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, .5D0, 1.3D0, 2.8D0,
33917 & 2.3D0, 1.6D0, .9D0, 13*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
33918 & 2.D0, 1.7D0, 1.5D0,1.2D0,.9D0,.6D0,.45D0,.21D0,.2D0,3*0.D0,0.9D0,
33919 & 2.5D0, 3.D0, 2.5D0, 2.3D0,2.D0,1.7D0,1.5D0,1.2D0,.9D0,.6D0,.45D0,
33920 & .21D0, .2D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.D0,1.8D0,1.7D0,1.4D0,
33921 & 1.2D0,1.15D0,.9D0,.66D0,.5D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.1D0,
33922 & 1.8D0,1.7D0,1.4D0,1.2D0, 1.15D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0,
33923 & 2*1.D0, .9D0, .7D0, .4D0, .35D0, .2D0, 9*0.D0, .3D0, 2*1.D0,.9D0,
33924 & .7D0, .4D0, .35D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.4D0,3.5D0,4.25D0,
33925 & 4.55D0, 4.85D0, 4.9D0, 9*0.D0, .1D0, 1.D0, 2.4D0, 3.5D0, 4.25D0,
33926 & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
33927 & 1.71D0, 1.6D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0,
33928 & 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0,4.4D0,4.D0,3.5D0,2.85D0,
33929 & 2.35D0, 2.01D0, 1.8D0, 6*0.D0, 1.4D0,3.8D0,5.D0,4.7D0,4.4D0,4.D0,
33930 & 3.5D0,2.85D0,2.35D0,2.01D0,1.8D0,12*0.D0,.1D0,.8D0,2.05D0,3.31D0,
33931 & 3.5D0, 12*0.D0, .034D0,.2D0,.75D0,1.04D0,1.24D0 /
33933 DATA SKMPEL/ 0.D0, 35.D0, 22.D0, 25.D0, 17.D0, 9.D0, 9.5D0, 8.D0,
33934 & 7.D0, 6.5D0, 6.1D0, 5.D0, 4.8D0, 4.6D0, 4.45D0, 4.3D0, 4.2D0,
33935 & 0.D0, 8.D0, 3.5D0, 8.D0, 3.D0, 1.9D0, 1.7D0, 1.D0, .9D0, .8D0,
33936 & .75D0, .5D0, .42D0, .38D0, .34D0, .25D0, .2D0,
33937 & 0.D0, 3.D0, 3.2D0, 3.5D0, 1.5D0, 1.4D0, 1.1D0, .6D0, .5D0,
33938 & .35D0, .28D0, .25D0, .18D0, .12D0, .1D0, .08D0, .04D0,
33939 & 0.D0, 8.5D0, 2.4D0, 1.7D0, 1.3D0, 1.3D0, 1.1D0, .5D0,
33940 & .4D0, .4D0, .35D0, .3D0, .28D0, .2D0, .16D0, .13D0, .11D0,
33941 & 0.D0, 7.D0, 4.8D0, 1.4D0, 1.9D0, .9D0, .4D0, .2D0, .13D0,
33942 & .1D0, .08D0, .06D0, .04D0, .02D0, .015D0, .01D0, .01D0,
33943 & 0.D0, 5.5D0, 1.D0, .8D0, .75D0, .32D0, .2D0, .1D0, .09D0,
33944 & .08D0, .065D0, .05D0, .04D0, .022D0, .017D0, 2*.01D0/
33945 DATA SPIKP7 / 0.D0, .56D0, 1.46D0, 3.16D0, 2.01D0, 1.28D0, .74D0,
33946 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
33947 & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 4*0.D0,
33948 & 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, 1.57D0,
33949 & 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0, 3.03D0,
33950 & 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0,
33951 & .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, 2.8D0,
33952 & 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0,
33953 & .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
33954 & .45D0, .39D0, .22D0, .07D0, 0.D0, 7*0.D0, .34D0, 1.12D0, 1.12D0,
33955 & 1.01D0, .78D0, .45D0, .39D0, .22D0, .07D0, 0.D0, 6*0.D0, 1.71D0,
33956 & 4.26D0, 5.6D0, 5.57D0, 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0,
33957 & 2.25D0, 2.D0, 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
33958 & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, .22D0,
33959 & .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 10*0.D0, .22D0, .8D0,
33960 & .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, .3D0, .7D0,1.D0,
33961 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, 1.72D0, 2.69D0,
33962 & 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 9*0.D0, .11D0, 1.72D0,
33963 & 2.69D0, 3.92D0, 4.76D0, 5.1D0, 5.44D0, 5.3D0, 5*0.D0,9.2D0,4.7D0,
33964 & 1.9D0, 10*0.D0, 2.5D0, 15.D0, 21.5D0, 15.3D0, 3.D0, 1.5D0,
33967 DATA SKMNEL/0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
33968 & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0,
33969 & 0.D0, 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0,
33970 & 1.9D0, .9D0, .5D0, .3D0, .24D0, .2D0, .18D0, .1D0, .09D0,
33971 & 0.D0, 1.8D0, 2.D0, 1.1D0, .9D0, .5D0, .5D0, .4D0, .4D0,
33972 & .2D0, .1D0, .06D0, .05D0, .04D0, .03D0, .02D0, .02D0,
33973 & 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, .7D0, .65D0,
33974 & .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, .03D0/
33975 DATA SPIKP8/0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
33976 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
33977 & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,
33978 & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
33979 & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
33980 & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
33981 & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
33982 & 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, .45D0,
33983 & .39D0, .22D0, .07D0, 0.D0,
33984 & 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
33985 & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0,
33986 & 10*0.D0, .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0,
33987 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0,
33988 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0,
33989 & 9*0.D0, .11D0, 1.72D0, 2.69D0, 3.92D0, 4.76D0,
33990 & 5.10D0, 5.44D0, 5.3D0,
33991 & 4*0.D0, 0.00D0, 9.2D0, 4.7D0, 1.9D0, 9*0.D0/
33993 DATA SPIKP9/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
33994 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
33995 & 0.D0, 3.6D0, 1.7D0, 10*0.D0,
33996 & .0D0, 0.D0, 8.7D0, 17.7D0, 18.8D0, 15.9D0,
33997 & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
33998 & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
33999 & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
34000 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
34001 & 16.9D0, 16.5D0, 11.D0, 5.5D0, 3.5D0,
34002 & 10*0.D0, 4.3D0, 7.6D0, 9.D0,
34003 & 10*0.D0, 1.7D0, 2.6D0, 3.D0,
34004 & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
34005 & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
34006 & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
34007 & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/
34009 DATA SPIKP0/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
34010 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
34011 & 0.D0, 1.8D0, .2D0, 12*0.D0,
34012 & 3.2D0, 6.05D0, 9.9D0, 5.1D0,
34013 & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
34014 & 2*.0D0, 3.2D0, 6.05D0, 9.9D0, 5.1D0,
34015 & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
34016 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
34017 & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
34018 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
34019 & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
34020 & 10*0.D0, .7D0, 5.1D0, 8.D0,
34021 & 10*0.D0, .7D0, 5.1D0, 8.D0,
34022 & 10*.0D0, .3D0, 2.8D0, 4.7D0,
34023 & 10*.0D0, .3D0, 2.8D0, 4.7D0,
34024 & 7*0.D0, 1.2D0, 2.5D0, 3.5D0, 6.D0, 5.3D0, 2.9D0,
34025 & 7*0.D0, 1.7D0, 3.6D0, 5.4D0, 9.D0, 7.6D0, 4.2D0,
34026 & 5*0.D0, 7.7D0, 6.1D0, 2.9D0, 5*0.D0/
34029 DATA SPKPV/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
34030 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
34031 & 0.D0, 3.6D0, 1.7D0, 12*0.D0,
34032 & 8.7D0, 17.7D0, 18.8D0, 15.9D0,
34033 & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
34034 & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
34035 & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
34036 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0, 16.9D0, 16.5D0,
34037 & 11.D0, 5.5D0, 3.5D0,
34038 & 10*0.D0, 4.3D0, 7.6D0, 9.D0,
34039 & 10*0.D0, 1.7D0, 2.6D0, 3.D0,
34040 & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
34041 & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
34042 & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
34043 & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/
34044 **************** ap - p - data *
34045 DATA SAPPEL/ 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
34046 & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
34047 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0,
34048 & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
34049 & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
34050 & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
34051 & 0.D0, 55.D0, 50.D0, 25.D0, 15.D0, 15.D0, 14.D0, 12.D0,
34052 & 10.D0, 7.D0, 6.D0, 4.D0, 3.3D0, 2.8D0, 2.4D0, 2.D0, 1.8D0,
34053 & 1.55D0, 1.3D0, .95D0, .75D0,
34054 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
34055 & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
34056 & .01D0, .008D0, .006D0, .005D0/
34057 DATA SPIKPE/0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
34058 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
34059 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0,
34060 & 9*0.D0, 2.D0, 2.5D0, .2D0, 19*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0,
34061 & 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, .3D0, 1.4D0,
34062 & 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0,
34063 & .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0,
34064 & .3D0, 10*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0,
34065 & .6D0, .5D0, .4D0, .3D0, 9*0.D0, .6D0, 2.5D0, 5.D0, 5.2D0, 5.1D0,
34066 & 5.4D0, 5.8D0, 2.8D0, 2.1D0, 1.8D0, 1.6D0, 1.2D0, 13*0.D0, 1.3D0,
34067 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
34068 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
34069 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
34070 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 14*0.D0, .2D0,
34071 & .5D0, 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0,
34072 & 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0,
34073 & 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, 1.6D0,
34074 & 1.4D0, 1.1D0, .9D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0,
34075 & .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0,
34076 & 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0 /
34077 **************** ap - n - data *
34079 & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
34080 & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
34081 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0,
34082 & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0,
34083 & .85D0, 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0,
34084 & .14D0, .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
34085 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
34086 & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
34087 & .01D0, .008D0, .006D0, .005D0 /
34088 DATA SPIKPZ/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
34089 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
34090 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
34091 & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34092 & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
34093 & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
34094 & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
34095 & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34096 & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34097 & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34098 & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
34099 & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
34100 & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
34101 & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
34104 **************** an - p - data *
34107 & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, 50.D0,
34108 & 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
34109 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0, .05D0,
34110 & .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
34111 & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
34112 & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
34113 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, .25D0,
34114 & .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
34115 & .01D0, .008D0, .006D0, .005D0 /
34116 DATA SPIKPF/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
34117 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
34118 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
34119 & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34120 & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
34121 & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
34122 & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
34123 & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34124 & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34125 & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34126 & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
34127 & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
34128 & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
34129 & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
34130 **** ko - n - data *
34131 DATA SPKP15/0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, 7.D0,
34132 & 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
34133 & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 10*0.D0,
34134 & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
34135 & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
34136 & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
34137 & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
34138 & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0,
34139 & 1.4D0, 1.2D0, 1.05D0, .9D0, .66D0, .5D0,
34140 & 7*0.D0, .3D0, 1.D0, 1.D0, .9D0, .7D0, .4D0, .30D0, .2D0,
34141 & 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.20D0, 4.55D0,
34143 & 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, 1.6D0,
34144 & 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, 3.5D0,
34145 & 2.85D0, 2.35D0, 2.01D0, 1.8D0,
34146 & 12*0.D0, .1D0, .8D0, 2.05D0, 3.31D0, 3.5D0,
34147 & 12*0.D0, .034D0, .20D0, .75D0, 1.04D0, 1.24D0 /
34148 **** ako - p - data *
34149 DATA SPKP16/ 0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
34150 & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, 0.D0,
34151 & 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, 1.9D0, .9D0, .5D0,
34152 & .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, 0.D0, 1.8D0, 2.D0, 1.1D0,
34153 & .9D0, .5D0, .5D0, .4D0, .4D0, .2D0, .1D0, .06D0, .05D0, .04D0,
34154 & .03D0, .02D0, .02D0, 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0,
34155 & .7D0, .65D0, .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0,
34156 & .03D0, 0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
34157 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0,
34158 & 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0,
34159 & 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0,
34160 & 1.01D0, .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0,
34161 & 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0,
34162 & .5D0, .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
34163 & .45D0, .39D0, .22D0, .07D0, 7*0.D0, 1.71D0, 4.26D0, 5.6D0,5.57D0,
34164 & 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0,
34165 & .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0,
34166 & .3D0, .7D0, 1.D0, 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0,
34167 & 1.72D0, 2.69D0, 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 5*0.D0,
34168 & 9.2D0, 4.7D0, 1.9D0, 9*0.D0, .0D0,2.5D0,15.D0,
34169 & 21.5D0, 15.3D0, 3.D0, 1.5D0, 10*0.D0 /
34170 DATA NURELN/9, 12, 5*0, 10, 14, 3*0, 1, 3, 5, 7, 6*0, 2, 6, 16,
34171 & 5*0, 10, 13, 5*0, 11, 12, 3*0, 2, 4, 6, 8, 6*0, 3, 15, 7, 5*0 /
34172 *= end*block.blkdt3 *
34174 *$ CREATE DT_QEL_POL.FOR
34177 *===qel_pol============================================================*
34179 SUBROUTINE DT_QEL_POL(ENU,LTYP,P21,P22,P23,P24,P25)
34181 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34185 CALL DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
34190 *$ CREATE DT_GEN_QEL.FOR
34192 C==================================================================
34193 C Generation of a Quasi-Elastic neutrino scattering
34194 C==================================================================
34196 *===gen_qel============================================================*
34198 SUBROUTINE DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
34200 C...Generate a quasi-elastic neutrino/antineutrino
34201 C. Interaction on a nuclear target
34202 C. INPUT : LTYP = neutrino type (1,...,6)
34203 C. ENU (GeV) = neutrino energy
34204 C----------------------------------------------------
34206 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34209 PARAMETER ( LINP = 10 ,
34212 PARAMETER (MAXLND=4000)
34213 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
34215 * nuclear potential
34217 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
34218 & EBINDP(2),EBINDN(2),EPOT(2,210),
34219 & ETACOU(2),ICOUL,LFERMI
34221 * steering flags for qel neutrino scattering modules
34222 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
34223 **sr - removed (not needed)
34224 C COMMON /CBAD/ LBAD, NBAD
34225 C COMMON /CNUC/ XMN,XMN2,PFERMI,EFERMI,EBIND,EB2,C0
34228 DIMENSION PI(3),PO(3)
34233 C REAL*8 MN(2), ML0(6), ML, ML2, MI, MI2, MF, MF2
34234 DIMENSION DBETA(3),DBETB(3),AMN(2),AML0(6)
34235 DATA AMN /0.93827231D0, 0.93956563D0/
34236 DATA AML0 /2*0.51100D-03,2*0.105659D0, 2*1.777D0/
34239 C DATA PFERMI/0.22D0/
34240 CGB+...Binding Energy
34241 DATA EBIND/0.008D0/
34245 IF(ININU.EQ.1)NDSIG=0
34250 AML = AML0(LTYP) ! massa leptoni
34251 AML2 = AML**2 ! massa leptoni **2
34252 C...Particle labels (LUND)
34262 K0 = (LTYP-1)/2 ! 2
34264 KA = 12 + 2*K0 ! 16
34265 IS = -1 + 2*LTYP - 4*K1 ! -1 +10 -8 = 1
34269 LNU = 2 - LTYP + 2*K1 ! 2 - 5 + 2 = - 1
34270 IF (LNU .EQ. 2) THEN
34298 EFMAX = SQRT(PFERMI**2 + AMI2) -AMI ! max. Fermi Energy
34299 ENWELL = EFMAX + EBIND ! depth of nuclear potential well
34304 C...4-momentum initial lepton
34305 P(1,5) = 0. ! massa
34306 P(1,4) = ENU0 ! energia
34311 C PF = PFERMI*PYR(0)**(1./3.)
34312 c write(23,*) PYR(0)
34313 c write(*,*) 'Pfermi=',PF
34316 C IF(ntry.GT.2) WRITE(*,*) ntry,enu0,k2
34317 IF (NTRY .GT. 500) THEN
34319 WRITE (LOUT,1001) NBAD, ENU
34322 C CT = -1. + 2.*PYR(0)
34324 C ST = SQRT(1.-CT*CT)
34325 C F = 2.*3.1415926*PYR(0)
34328 C P(2,4) = SQRT(PF*PF + MI2) - EBIND ! energia
34329 C P(2,1) = PF*ST*COS(F) ! px
34330 C P(2,2) = PF*ST*SIN(F) ! py
34331 C P(2,3) = PF*CT ! pz
34332 C P(2,5) = SQRT(P(2,4)**2-PF*PF) ! massa
34338 beta1=-p(2,1)/p(2,4)
34339 beta2=-p(2,2)/p(2,4)
34340 beta3=-p(2,3)/p(2,4)
34342 C WRITE(6,*)' before transforming into target rest frame'
34344 CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
34346 C print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
34349 phi11=atan(p(1,2)/p(1,3))
34354 CALL DT_TESTROT(PI,Po,PHI11,1)
34356 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34362 phi12=atan(p(1,1)/p(1,3))
34367 CALL DT_TESTROT(Pi,Po,PHI12,2)
34369 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34378 C...Kinematical limits in Q**2
34379 c S = P(2,5)**2 + 2.*ENU*(P(2,4)-P(2,3)) ! ????
34380 S = P(2,5)**2 + 2.*ENU*P(2,5)
34381 SQS = SQRT(S) ! E centro massa
34382 IF (SQS .LT. (AML + AMF + 3.E-03)) GOTO 100
34383 ELF = (S-AMF2+AML2)/(2.*SQS) ! energia leptone finale p
34384 PSTAR = (S-P(2,5)**2)/(2.*SQS) ! p* neutrino nel c.m.
34385 PLF = SQRT(ELF**2-AML2) ! 3-momento leptone finale
34386 Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF) ! + o -
34387 Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF) ! according con cos(theta)
34388 IF (Q2MIN .LT. 0.) Q2MIN = 0. ! ??? non fisico
34391 DSIGMAX = DT_DSQEL_Q2 (LTYP,ENU, Q2MIN)
34392 200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
34393 DSIG = DT_DSQEL_Q2 (LTYP,ENU, Q2)
34394 IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200
34395 CALL DT_QGAUS(Q2MIN,Q2MAX,DSIGEV,ENU,LTYP)
34397 C WRITE(6,*)' Q2,Q2min,Q2MAX,DSIGEV',
34398 C &Q2,Q2min,Q2MAX,DSIGEV
34400 C...c.m. frame. Neutrino along z axis
34401 DETOT = (P(1,4)) + (P(2,4)) ! e totale
34402 DBETA(1) = ((P(1,1)) + (P(2,1)))/DETOT ! px1+px2/etot = beta_x
34403 DBETA(2) = ((P(1,2)) + (P(2,2)))/DETOT !
34404 DBETA(3) = ((P(1,3)) + (P(2,3)))/DETOT !
34407 C WRITE(*,*) 'Input values laboratory frame'
34410 CALL PYROBO(0,0,0.0D0,0.0D0,-DBETA(1),-DBETA(2),-DBETA(3))
34413 c STHETA = ULANGL(P(1,3),P(1,1))
34414 c write(*,*) 'stheta' ,stheta
34416 c CALL PYROBO (0,0,-STHETA,0.,0.D0,0.D0,0.D0)
34419 C WRITE(*,*) 'Output values cm frame'
34420 C...Kinematic in c.m. frame
34421 CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) ! cos(theta) cm
34422 STSTAR = SQRT(1.-CTSTAR**2)
34423 PHI = 6.28319*PYR(0) ! random phi tra 0 e 2*pi
34424 P(4,5) = AML ! massa leptone
34425 P(4,4) = ELF ! e leptone
34426 P(4,3) = PLF*CTSTAR ! px
34427 P(4,1) = PLF*STSTAR*COS(PHI) ! py
34428 P(4,2) = PLF*STSTAR*SIN(PHI) ! pz
34430 P(5,5) = AMF ! barione
34431 P(5,4) = (S+AMF2-AML2)/(2.*SQS)! e barione
34432 P(5,3) = -P(4,3) ! px
34433 P(5,1) = -P(4,1) ! py
34434 P(5,2) = -P(4,2) ! pz
34437 P(3,1) = P(1,1)-P(4,1)
34438 P(3,2) = P(1,2)-P(4,2)
34439 P(3,3) = P(1,3)-P(4,3)
34440 P(3,4) = P(1,4)-P(4,4)
34442 C...Transform back to laboratory frame
34443 C WRITE(*,*) 'before going back to nucl rest frame'
34444 c CALL PYROBO (0,0,STHETA,0.,0.D0,0.D0,0.D0)
34447 CALL PYROBO(0,0,0.0D0,0.0D0,DBETA(1),DBETA(2),DBETA(3))
34449 C WRITE(*,*) 'Now back in nucl rest frame'
34450 IF(LTYP.GE.3) CALL DT_PREPOLA(Q2,LTYP,ENU)
34452 c********************************************
34458 CALL DT_TESTROT(Pi,Po,PHI12,3)
34460 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34466 c********************************************
34472 CALL DT_TESTROT(Pi,Po,PHI11,4)
34474 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34481 c********************************************
34483 C WRITE(*,*) 'Now back in lab frame'
34485 CALL PYROBO(1,5,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
34488 C...test (on final momentum of nucleon) if Fermi-blocking
34490 ENUCL = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2 + P(5,5)**2)
34492 IF (ENUCL.LT. EFMAX) THEN
34493 IF(INIPRI.LT.10)THEN
34495 C WRITE(6,*)' qel: Pauli ENUCL.LT.EFMAX ', ENUCL,EFMAX
34496 C...the interaction is not possible due to Pauli-Blocking and
34497 C...it must be resampled
34500 ELSE IF (ENUCL.LT.ENWELL.and.ENUCL.GE.EFMAX) THEN
34501 IF(INIPRI.LT.10)THEN
34503 C WRITE(6,*)' qel: inside ENUCL.LT.ENWELL ', ENUCL,ENWELL
34505 C Reject (J:R) here all these events
34506 C are otherwise rejected in dpmjet
34508 C...the interaction is possible, but the nucleon remains inside
34509 C...the nucleus. The nucleus is therefore left excited.
34510 C...We treat this case as a nucleon with 0 kinetic energy.
34516 ELSE IF (ENUCL.GE.ENWELL) THEN
34517 C WRITE(6,*)' qel ENUCL.GE.ENWELL ',ENUCL,ENWELL
34518 C...the interaction is possible, the nucleon can exit the nucleus
34519 C...but the nuclear well depth must be subtracted. The nucleus could be
34520 C...left in an excited state.
34521 Pstart = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2)
34522 C P(5,4) = ENUCL-ENWELL + AMF
34523 Pnucl = SQRT(P(5,4)**2-AMF**2)
34524 C...The 3-momentum is scaled assuming that the direction remains
34526 P(5,1) = P(5,1) * Pnucl/Pstart
34527 P(5,2) = P(5,2) * Pnucl/Pstart
34528 P(5,3) = P(5,3) * Pnucl/Pstart
34529 C WRITE(6,*)' qel new P(5,4) ',P(5,4)
34532 DSIGSU=DSIGSU+DSIGEV
34542 IF(NEUDEC.EQ.1.OR.NEUDEC.EQ.2) THEN
34544 CALL PYROBO(6,8,0.0D0,0.0D0,DBETB(1),DBETB(2),DBETB(3))
34548 C PRINT*,' FINE EVENTO '
34552 1001 FORMAT(2X, 'DT_GEN_QEL : event rejected ', I5, G10.3)
34555 *$ CREATE DT_MASS_INI.FOR
34557 C====================================================================
34559 C====================================================================
34561 *===mass_ini===========================================================*
34563 SUBROUTINE DT_MASS_INI
34564 C...Initialize the kinematics for the quasi-elastic cross section
34566 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34569 * particle masses used in qel neutrino scattering modules
34570 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
34571 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
34572 & EMPROTSQ,EMNEUTSQ,EMNSQ
34574 EML(1) = 0.51100D-03 ! e-
34575 EML(2) = EML(1) ! e+
34576 EML(3) = 0.105659D0 ! mu-
34577 EML(4) = EML(3) ! mu+
34578 EML(5) = 1.7777D0 ! tau-
34579 EML(6) = EML(5) ! tau+
34580 EMPROT = 0.93827231D0 ! p
34581 EMNEUT = 0.93956563D0 ! n
34582 EMPROTSQ = EMPROT**2
34583 EMNEUTSQ = EMNEUT**2
34584 EMN = (EMPROT + EMNEUT)/2.
34588 EMN1(J0+1) = EMNEUT
34589 EMN1(J0+2) = EMPROT
34590 EMN2(J0+1) = EMPROT
34591 EMN2(J0+2) = EMNEUT
34594 EMLSQ(J) = EML(J)**2
34595 ETQE(J) = ((EMN2(J)+ EML(J))**2-EMN1(J)**2)/(2.*EMN1(J))
34600 *$ CREATE DT_DSQEL_Q2.FOR
34603 *===dsqel_q2===========================================================*
34605 DOUBLE PRECISION FUNCTION DT_DSQEL_Q2 (JTYP,ENU, Q2)
34607 C...differential cross section for Quasi-Elastic scattering
34608 C. nu + N -> l + N'
34609 C. From Llewellin Smith Phys.Rep. 3C, 261, (1971).
34611 C. INPUT : JTYP = 1,...,6 nu_e, ...., nubar_tau
34612 C. ENU (GeV) = Neutrino energy
34613 C. Q2 (GeV**2) = (Transfer momentum)**2
34615 C. OUTPUT : DSQEL_Q2 = differential cross section :
34616 C. dsigma/dq**2 (10**-38 cm+2/GeV**2)
34617 C------------------------------------------------------------------
34619 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34622 * particle masses used in qel neutrino scattering modules
34623 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
34624 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
34625 & EMPROTSQ,EMNEUTSQ,EMNSQ
34626 **sr - removed (not needed)
34627 C COMMON /CAXIAL/ FA0, AXIAL2
34631 DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
34632 DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
34633 DATA AXIAL2 /1.03D0/ ! to be checked
34637 GVE = 1.D0/ (1.D0 + Q2/0.84D0**2)**2 ! G_e(q**2)
34638 GVM = (1.D0+CSI)*GVE ! G_m (q**2)
34639 X = Q2/(EMN*EMN) ! emn=massa barione
34641 FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
34642 FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
34643 FA = FA0/(1.D0 + Q2/AXIAL2)**2
34647 RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp)
34648 A1 = (4.D0+X)*FFA - (4.D0-X)*FFV1 + X*FFV2*(1.D0-XA)+4*X*FV1*FV2
34649 A2 = -RM * ((FV1 + FV2)**2 + FFA)
34650 AA = (XA+0.25D0*RM)*(A1 + A2)
34651 BB = -X*FA*(FV1 + FV2)
34652 CC = 0.25D0*(FFA + FFV1 + XA*FFV2)
34653 SU = (4.D0*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
34654 DT_DSQEL_Q2 = C0*(AA + SS(JTYP)*BB*SU + CC*SU*SU) / (ENU*ENU) !
34655 IF(DT_DSQEL_Q2 .LT. 0.D0) DT_DSQEL_Q2 = 0.D0
34660 *$ CREATE DT_PREPOLA.FOR
34663 *===prepola============================================================*
34665 SUBROUTINE DT_PREPOLA(Q2,JTYP,ENU)
34667 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34670 c By G. Battistoni and E. Scapparone (sept. 1997)
34672 c Albright & Jarlskog, Nucl Phys B84 (1975) 467
34675 PARAMETER (MAXLND=4000)
34676 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
34678 COMMON /QNPOL/ POLARX(4),PMODUL
34680 * particle masses used in qel neutrino scattering modules
34681 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
34682 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
34683 & EMPROTSQ,EMNEUTSQ,EMNSQ
34685 * steering flags for qel neutrino scattering modules
34686 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
34687 **sr - removed (not needed)
34688 C COMMON /CAXIAL/ FA0, AXIAL2
34689 C COMMON /TAUTAU/Q(4,5),ETL,PXL,PYL,PZL,
34690 C & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN
34692 REAL*8 POL(4,4),BB2(3)
34694 C DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
34695 DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
34696 **sr uncommented since common block CAXIAL is now commented
34697 DATA AXIAL2 /1.03D0/ ! to be checked
34707 GVE = 1.D0/ (1.D0 + Q2/(0.84D+00)**2)**2 ! G_e(q**2)
34708 GVM = (1.D0+CSI)*GVE ! G_m (q**2)
34709 X = Q2/(EMN*EMN) ! emn=massa barione
34711 FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
34712 FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
34713 FA = FA0/(1.D0 + Q2/AXIAL2**2)**2
34717 FP=2.D0*FA*RMM/(MPI**2 + Q2)
34718 RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp)
34719 A1 = (4.D0+X)*FFA-(4.D0-X)*FFV1+X*FFV2*(1.D0-XA)+4.D0*X*FV1*FV2
34720 A2 = -RM * ((FV1 + FV2)**2 + FFA)
34721 AA = (XA+0.25D+00*RM)*(A1 + A2)
34722 BB = -X*FA*(FV1 + FV2)
34723 CC = 0.25D+00*(FFA + FFV1 + XA*FFV2)
34724 SU = (4.D+00*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
34726 OMEGA1=FFA+XA*(FFA+(FV1+FV2)**2 ) ! articolo di ll...-smith
34728 OMEGA3=2.D+00*FA*(FV1+FV2)
34729 OMEGA4P=(-(FV1+FV2)**2-(FA+2*FP)**2+(4.0D+00+
34732 OMEGA4=(OMEGA4P-OMEGA2+2*OMEGA5)/4.D+00
34733 WW1=2.D+00*OMEGA1*EMN**2
34734 WW2=2.D+00*OMEGA2*EMN**2
34735 WW3=2.D+00*OMEGA3*EMN**2
34736 WW4=2.D+00*OMEGA4*EMN**2
34737 WW5=2.D+00*OMEGA5*EMN**2
34740 BB2(I)=-P(4,I)/P(4,4)
34744 c WRITE(*,*) 'Prepola: ready to transform to lepton rest frame'
34747 CALL PYROBO(0,0,0.0D0,0.0D0,BB2(1),BB2(2),BB2(3))
34749 * NOW PARTICLES ARE IN THE SCATTERED LEPTON REST FRAME
34752 c WRITE(*,*) 'Prepola: now in lepton rest frame'
34756 FRAC=QM2*WW1 + (2.D+00*EE*(EE-U) - 0.5D+00*QM2)*WW2 - SS(JTYP)*
34757 + (0.5D+00/(RMM**2))*(2.D+00*RMM*EE*Q2 - U*QM2)*WW3 +
34758 + ((RML**2)/(2.D+00*FM2))*(QM2*WW4-2.D+00*RMM*EE*WW5) !<=FM2 inv di RMM!!
34760 FACTK=2.D+00*WW1 -WW2 -SS(JTYP)*(EE/RMM)*WW3 +((EE-U)/RMM)*WW5
34761 + - ((RML**2)/FM2)*WW4 !<=FM2 inv di RMM!!
34763 FACTP=2.D+00*EE/RMM*WW2 - (QM2/(2.D+00*RMM**2))*(SS(JTYP)*WW3+WW5)
34766 POL(4,I)=RML*SS(JTYP)*(FACTK*P(1,I)+FACTP*P(2,I))/FRAC
34772 PMODUL=PMODUL+POL(4,I)**2
34775 IF(JTYP.GT.4.AND.NEUDEC.GT.0) THEN
34776 IF(NEUDEC.EQ.1) THEN
34777 CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-2),POLARX(3),
34779 + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
34781 c Tau has decayed in muon
34784 IF(NEUDEC.EQ.2) THEN
34785 CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-4),POLARX(3),
34787 + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
34789 c Tau has decayed in electron
34797 c fill common for muon(electron)
34805 IF(NEUDEC.EQ.1) THEN
34808 ELSEIF(NEUDEC.EQ.2) THEN
34812 ELSEIF(JTYP.EQ.6) THEN
34813 IF(NEUDEC.EQ.1) THEN
34815 ELSEIF(NEUDEC.EQ.2) THEN
34823 c fill common for tau_(anti)neutrino
34833 ELSEIF(JTYP.EQ.6) THEN
34840 c Fill common for muon(electron)_(anti)neutrino
34849 IF(NEUDEC.EQ.1) THEN
34851 ELSEIF(NEUDEC.EQ.2) THEN
34854 ELSEIF(JTYP.EQ.6) THEN
34855 IF(NEUDEC.EQ.1) THEN
34857 ELSEIF(NEUDEC.EQ.2) THEN
34868 c IF(PMODUL.GE.1.D+00) THEN
34869 c WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
34870 c write(*,*) pmodul
34872 c POL(4,I)=POL(4,I)/PMODUL
34873 c POLARX(I)=POL(4,I)
34877 c PMODUL=PMODUL+POL(4,I)**2
34879 c WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
34883 c WRITE(*,*) 'PMODUL = ',PMODUL
34887 c WRITE(*,*) 'prepola: Now back to nucl rest frame'
34889 CALL PYROBO(1,5,0.0D0,0.0D0,-BB2(1),-BB2(2),-BB2(3))
34891 XDC = V(4,1)+V(4,5)*P(4,1)/P(4,5)
34892 YDC = V(4,2)+V(4,5)*P(4,2)/P(4,5)
34893 ZDC = V(4,3)+V(4,5)*P(4,3)/P(4,5)
34903 *$ CREATE DT_TESTROT.FOR
34906 *===testrot============================================================*
34908 SUBROUTINE DT_TESTROT(PI,PO,PHI,MODE)
34910 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34913 DIMENSION ROT(3,3),PI(3),PO(3)
34915 IF (MODE.EQ.1) THEN
34920 ROT(2,2) = COS(PHI)
34921 ROT(2,3) = -SIN(PHI)
34923 ROT(3,2) = SIN(PHI)
34924 ROT(3,3) = COS(PHI)
34925 ELSEIF (MODE.EQ.2) THEN
34929 ROT(2,1) = COS(PHI)
34931 ROT(2,3) = -SIN(PHI)
34932 ROT(3,1) = SIN(PHI)
34934 ROT(3,3) = COS(PHI)
34935 ELSEIF (MODE.EQ.3) THEN
34939 ROT(1,2) = COS(PHI)
34941 ROT(3,2) = -SIN(PHI)
34942 ROT(1,3) = SIN(PHI)
34944 ROT(3,3) = COS(PHI)
34945 ELSEIF (MODE.EQ.4) THEN
34950 ROT(2,2) = COS(PHI)
34951 ROT(3,2) = -SIN(PHI)
34953 ROT(2,3) = SIN(PHI)
34954 ROT(3,3) = COS(PHI)
34956 STOP ' TESTROT: mode not supported!'
34959 PO(J) = ROT(J,1)*PI(1)+ROT(J,2)*PI(2)+ROT(J,3)*PI(3)
34965 *$ CREATE DT_LEPDCYP.FOR
34968 *===lepdcyp============================================================*
34970 SUBROUTINE DT_LEPDCYP(AMA,AML,POL,ETL,PXL,PYL,PZL,
34971 & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
34973 C-----------------------------------------------------------------
34975 C Author :- G. Battistoni 10-NOV-1995
34977 C=================================================================
34979 C Purpose : performs decay of polarized lepton in
34980 C its rest frame: a => b + l + anti-nu
34981 C (Example: mu- => nu-mu + e- + anti-nu-e)
34982 C Polarization is assumed along Z-axis
34984 C 1) b AND anti-nu ARE ASSUMED TO BE NEUTRINOS
34985 C OF NEGLIGIBLE MASS
34986 C 2) RADIATIVE CORRECTIONS ARE NOT CONSIDERED
34989 C Method : modifies phase space distribution obtained
34990 C by routine EXPLOD using a rejection against the
34991 C matrix element for unpolarized lepton decay
34993 C Inputs : Mass of a : AMA
34996 C (Example: fully polar. mu- decay: AMA=AMMUON, AML=AMELCT,
34999 C Outputs : kinematic variables in the rest frame of decaying lepton
35000 C ETL,PXL,PYL,PZL 4-moment of l
35001 C ETB,PXB,PYB,PZB 4-moment of b
35002 C ETN,PXN,PYN,PZN 4-moment of anti-nu
35004 C============================================================
35008 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35011 PARAMETER ( LINP = 10 ,
35015 PARAMETER ( KALGNM = 2 )
35016 PARAMETER ( ANGLGB = 5.0D-16 )
35017 PARAMETER ( ANGLSQ = 2.5D-31 )
35018 PARAMETER ( AXCSSV = 0.2D+16 )
35019 PARAMETER ( ANDRFL = 1.0D-38 )
35020 PARAMETER ( AVRFLW = 1.0D+38 )
35021 PARAMETER ( AINFNT = 1.0D+30 )
35022 PARAMETER ( AZRZRZ = 1.0D-30 )
35023 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
35024 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
35025 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
35026 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
35027 PARAMETER ( CSNNRM = 2.0D-15 )
35028 PARAMETER ( DMXTRN = 1.0D+08 )
35029 PARAMETER ( ZERZER = 0.D+00 )
35030 PARAMETER ( ONEONE = 1.D+00 )
35031 PARAMETER ( TWOTWO = 2.D+00 )
35032 PARAMETER ( THRTHR = 3.D+00 )
35033 PARAMETER ( FOUFOU = 4.D+00 )
35034 PARAMETER ( FIVFIV = 5.D+00 )
35035 PARAMETER ( SIXSIX = 6.D+00 )
35036 PARAMETER ( SEVSEV = 7.D+00 )
35037 PARAMETER ( EIGEIG = 8.D+00 )
35038 PARAMETER ( ANINEN = 9.D+00 )
35039 PARAMETER ( TENTEN = 10.D+00 )
35040 PARAMETER ( HLFHLF = 0.5D+00 )
35041 PARAMETER ( ONETHI = ONEONE / THRTHR )
35042 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
35043 PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
35044 PARAMETER ( ENEPER = 2.7182818284590452354 D+00 )
35045 PARAMETER ( SQRENT = 1.6487212707001281468 D+00 )
35046 PARAMETER ( CLIGHT = 2.99792458 D+10 )
35047 PARAMETER ( AVOGAD = 6.0221367 D+23 )
35048 PARAMETER ( AMELGR = 9.1093897 D-28 )
35049 PARAMETER ( PLCKBR = 1.05457266 D-27 )
35050 PARAMETER ( ELCCGS = 4.8032068 D-10 )
35051 PARAMETER ( ELCMKS = 1.60217733 D-19 )
35052 PARAMETER ( AMUGRM = 1.6605402 D-24 )
35053 PARAMETER ( AMMUMU = 0.113428913 D+00 )
35054 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
35055 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
35056 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
35057 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
35058 PARAMETER ( PLABRC = 0.197327053 D+00 )
35059 PARAMETER ( AMELCT = 0.51099906 D-03 )
35060 PARAMETER ( AMUGEV = 0.93149432 D+00 )
35061 PARAMETER ( AMMUON = 0.105658389 D+00 )
35062 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
35063 PARAMETER ( GEVMEV = 1.0 D+03 )
35064 PARAMETER ( EMVGEV = 1.0 D-03 )
35065 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
35066 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
35067 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
35069 C variables for EXPLOD
35071 PARAMETER ( KPMX = 10 )
35072 DIMENSION AMEXPL (KPMX), PXEXPL (KPMX), PYEXPL (KPMX),
35073 & PZEXPL (KPMX), ETEXPL (KPMX)
35077 **sr - removed (not needed)
35078 C COMMON /GBATNU/ ELERAT,NTRY
35081 C Initializes test variables
35086 C Maximum value for matrix element
35088 ELEMAX = ( AMA**2 + AML**2 )**2 / AMA**2 * ( AMA**2 - AML**2 +
35089 & SQRT( AMA**4 + AML**4 - 3.D+00 * AMA**2 * AML**2 ) )
35090 C + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
35091 C Inputs for EXPLOD
35092 C part. no. 1 is l (e- in mu- decay)
35093 C part. no. 2 is b (nu-mu in mu- decay)
35094 C part. no. 3 is anti-nu (anti-nu-e in mu- decay)
35095 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
35102 C phase space distribution
35107 CALL EXPLOD ( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
35111 C Calculates matrix element:
35112 C 64*GF**2{[P(a)-ama*S(a)]*P(anti-nu)}{P(l)*P(b)}
35113 C Here CTH is the cosine of the angle between anti-nu and Z axis
35115 CTH = PZEXPL(3) / SQRT ( PXEXPL(3)**2 + PYEXPL(3)**2 +
35117 PROD1 = ETEXPL(3) * AMA * (1.D+00 - POL * CTH)
35118 PROD2 = ETEXPL(1) * ETEXPL(2) - PXEXPL(1)*PXEXPL(2) -
35119 & PYEXPL(1)*PYEXPL(2) - PZEXPL(1)*PZEXPL(2)
35120 ELEMAT = 16.D+00 * PROD1 * PROD2
35121 IF(ELEMAT.GT.ELEMAX) THEN
35122 WRITE(LOUT,*) 'Problems in LEPDCY',ELEMAX,ELEMAT
35126 C Here performs the rejection
35128 TEST = DT_RNDM(ETOTEX) * ELEMAX
35129 IF ( TEST .GT. ELEMAT ) GO TO 100
35131 C final assignment of variables
35133 ELERAT = ELEMAT/ELEMAX
35149 *$ CREATE DT_GEN_DELTA.FOR
35151 C==================================================================
35152 C. Generation of Delta resonance events
35153 C==================================================================
35155 *===gen_delta==========================================================*
35157 SUBROUTINE DT_GEN_DELTA(ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25)
35159 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35162 PARAMETER ( LINP = 10 ,
35166 C...Generate a Delta-production neutrino/antineutrino
35167 C. CC-interaction on a nucleon
35169 C. INPUT ENU (GeV) = Neutrino Energy
35170 C. LLEP = neutrino type
35171 C. LTARG = nucleon target type 1=p, 2=n.
35172 C. JINT = 1:CC, 2::NC
35174 C. OUTPUT PPL(4) 4-monentum of final lepton
35175 C----------------------------------------------------
35176 PARAMETER (MAXLND=4000)
35177 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
35179 **sr - removed (not needed)
35180 C COMMON /CBAD/ LBAD, NBAD
35183 DIMENSION PI(3),PO(3)
35184 C REAL*4 AMD0, AMD, AMN(2), AML0(6), AML, AML2, AMDMIN
35185 DIMENSION AML0(6),AMN(2)
35186 DATA AMD0 /1.231/, GAMD /0.12/, DELD/0.169/, AMDMIN/1.084/
35187 DATA AMN /0.93827231, 0.93956563/
35188 DATA AML0 /2*0.51100E-03,2*0.105659, 2*1.777/
35190 c WRITE(6,*)' GEN_DEL',ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25
35192 C...Final lepton mass
35193 IF (JINT.EQ.1) THEN
35200 C...Particle labels (LUND)
35208 IF (LTARG .EQ. 1) THEN
35216 IS = -1 + 2*LLEP - 4*K1
35217 LNU = 2 - LLEP + 2*K1
35221 IF (JINT .EQ. 1) THEN ! CC interactions
35225 IF (LTARG .EQ. 1) THEN
35231 IF (LTARG .EQ. 1) THEN
35238 K(3,2) = 23 ! NC (Z0) interactions
35240 **sr 7.5.00: swop Delta's (bug), Delta+ for proton (LTARG=1),
35241 * Delta0 for neutron (LTARG=2)
35242 C IF (LTARG .EQ. 1) THEN
35247 IF (LTARG .EQ. 1) THEN
35255 C...4-momentum initial lepton
35261 C...4-momentum initial nucleon
35262 P(2,5) = AMN(LTARG)
35273 beta1=-p(2,1)/p(2,4)
35274 beta2=-p(2,2)/p(2,4)
35275 beta3=-p(2,3)/p(2,4)
35278 CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
35280 C print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
35282 phi11=atan(p(1,2)/p(1,3))
35287 CALL DT_TESTROT(PI,Po,PHI11,1)
35289 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35294 phi12=atan(p(1,1)/p(1,3))
35299 CALL DT_TESTROT(Pi,Po,PHI12,2)
35301 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35309 C...Generate the Mass of the Delta
35312 AMD=AMD0+0.5*GAMD*TAN((2.*R-1.)*ATAN(2.*DELD/GAMD))
35314 IF (NTRY .GT. 1000) THEN
35316 WRITE (LOUT,1001) NBAD, ENUU,AMD,AMDMIN,AMD0,GAMD,ET
35319 IF (AMD .LT. AMDMIN) GOTO 100
35320 ET = ((AMD+AML)**2 - AMN(LTARG)**2)/(2.*AMN(LTARG))
35321 IF (ENUU .LT. ET) GOTO 100
35323 C...Kinematical limits in Q**2
35324 S = AMN(LTARG)**2 + 2.*AMN(LTARG)*ENUU
35326 PSTAR = (S - AMN(LTARG)**2)/(2.*SQS)
35327 ELF = (S - AMD**2 + AML2)/(2.*SQS)
35328 PLF = SQRT(ELF**2 - AML2)
35329 Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)
35330 Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)
35331 IF (Q2MIN .LT. 0.) Q2MIN = 0.
35333 DSIGMAX = DT_DSIGMA_DELTA(LNU,-Q2MIN, S, AML, AMD)
35334 200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
35335 DSIG = DT_DSIGMA_DELTA(LNU,-Q2, S, AML, AMD)
35336 IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200
35338 C...Generate the kinematics of the final particles
35339 EISTAR = (S + AMN(LTARG)**2)/(2.*SQS)
35340 GAM = EISTAR/AMN(LTARG)
35342 CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF)
35343 EL = GAM*(ELF + BET*PLF*CTSTAR)
35344 PLZ = GAM*(PLF*CTSTAR + BET*ELF)
35345 PL = SQRT(EL**2 - AML2)
35346 PLT = SQRT(MAX(1.D-06,(PL*PL - PLZ*PLZ)))
35347 PHI = 6.28319*PYR(0)
35348 P(4,1) = PLT*COS(PHI)
35349 P(4,2) = PLT*SIN(PHI)
35354 C...4-momentum of Delta
35357 P(5,3) = ENUU-P(4,3)
35358 P(5,4) = ENUU+AMN(LTARG)-P(4,4)
35361 C...4-momentum of intermediate boson
35363 P(3,4) = P(1,4)-P(4,4)
35364 P(3,1) = P(1,1)-P(4,1)
35365 P(3,2) = P(1,2)-P(4,2)
35366 P(3,3) = P(1,3)-P(4,3)
35373 CALL DT_TESTROT(Pi,Po,PHI12,3)
35375 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35382 c********************************************
35388 CALL DT_TESTROT(Pi,Po,PHI11,4)
35390 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35396 c********************************************
35397 C transform back into Lab.
35399 CALL PYROBO(0,0,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
35401 C WRITE(6,*)' Lab fram ( fermi incl.) '
35406 1001 FORMAT(2X, 'DT_GEN_DELTA : event rejected ', I5, 6G10.3)
35409 *$ CREATE DT_DSIGMA_DELTA.FOR
35410 *COPY DT_DSIGMA_DELTA
35412 *===dsigma_delta=======================================================*
35414 DOUBLE PRECISION FUNCTION DT_DSIGMA_DELTA (LNU, QQ, S, AML, MD)
35416 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35419 C...Reaction nu + N -> lepton + Delta
35420 C. returns the cross section
35422 C. INPUT LNU = 1, 2 (neutrino-antineutrino)
35423 C. QQ = t (always negative) GeV**2
35424 C. S = (c.m energy)**2 GeV**2
35425 C. OUTPUT = 10**-38 cm+2/GeV**2
35426 C-----------------------------------------------------
35427 REAL*8 MN, MN2, MN4, MD,MD2, MD4
35429 DATA PI /3.1415926/
35431 GF = (1.1664 * 1.97)
35439 VQ = (MN2 - MD2 - QQ)/2.
35440 VPI = (MN2 + MD2 - QQ)/2.
35441 VK = (S + QQ - MN2 - AML2)/2.
35443 QK = (AML2 - QQ)/2.
35444 PIQ = (QQ + MN2 - MD2)/2.
35446 C3V = 2.07*SQRT(EXP(-6.3*Q)*(1.+9*Q))
35447 C3 = SQRT(3.)*C3V/MN
35448 C4 = -C3/MD ! attenzione al segno
35449 C5A = 1.18/(1.-QQ/0.4225)**2
35454 IF (LNU .EQ. 1) THEN
35455 ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
35456 . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
35457 . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
35458 . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
35459 ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
35460 . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
35461 . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
35462 . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
35463 . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
35464 . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ-
35465 . 4.*MN*C3*C5A*MD2*VK*QQ+4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
35466 . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
35467 . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
35468 . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
35469 . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK-MD*
35470 . C3*C5A*MD2*PIK*QQ+MD*C3*C5A*MD2*QK*PIQ-3.*MD*C3*C5A
35471 . *VK*VPI*QQ+MD*C3*C5A*VK*VQ*PIQ+3.*MD*C3*C5A*VPI*VQ*
35472 . QK-MD*C3*C5A*VQ**2*PIK+C4*C5A*MD2*VK*VPI*QQ+C4*C5A*
35473 . MD2*VK*VQ*PIQ-C4*C5A*MD2*VPI*VQ*QK-C4*C5A*MD2*VQ**2
35474 . *PIK-C4*C5A*MD4*PIK*QQ+C4*C5A*MD4*QK*PIQ-2.*MD2*VK
35475 . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
35476 . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
35477 . *C42-2.*MD2*VPI*QK**2*C32+ANS3
35479 ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
35480 . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
35481 . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
35482 . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
35483 ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
35484 . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
35485 . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
35486 . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
35487 . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
35488 . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ+
35489 . 4.*MN*C3*C5A*MD2*VK*QQ-4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
35490 . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
35491 . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
35492 . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
35493 . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK+MD*
35494 . C3*C5A*MD2*PIK*QQ-MD*C3*C5A*MD2*QK*PIQ+3.*MD*C3*C5A
35495 . *VK*VPI*QQ-MD*C3*C5A*VK*VQ*PIQ-3.*MD*C3*C5A*VPI*VQ*
35496 . QK+MD*C3*C5A*VQ**2*PIK-C4*C5A*MD2*VK*VPI*QQ-C4*C5A*
35497 . MD2*VK*VQ*PIQ+C4*C5A*MD2*VPI*VQ*QK+C4*C5A*MD2*VQ**2
35498 . *PIK+C4*C5A*MD4*PIK*QQ-C4*C5A*MD4*QK*PIQ-2.*MD2*VK
35499 . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
35500 . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
35501 . *C42-2.*MD2*VPI*QK**2*C32+ANS3
35505 P1CM = (S-MN2)/(2.*SQRT(S))
35506 DT_DSIGMA_DELTA = GF2/2. * ANS/(64.*PI*S*P1CM**2)
35511 *$ CREATE DT_QGAUS.FOR
35514 *===qgaus==============================================================*
35516 SUBROUTINE DT_QGAUS(A,B,SS,ENU,LTYP)
35518 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35521 DIMENSION X(5),W(5)
35522 DATA X/.1488743389D0,.4333953941D0,
35523 & .6794095682D0,.8650633666D0,.9739065285D0
35525 DATA W/.2955242247D0,.2692667193D0,
35526 & .2190863625D0,.1494513491D0,.0666713443D0
35533 SS=SS+W(J)*(DT_DSQEL_Q2(LTYP,ENU,XM+DX)+
35534 & DT_DSQEL_Q2(LTYP,ENU,XM-DX))
35540 *$ CREATE DT_DIQBRK.FOR
35543 *===diqbrk=============================================================*
35545 SUBROUTINE DT_DIQBRK
35547 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35552 PARAMETER (NMXHKK=200000)
35554 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
35555 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
35556 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
35558 * extended event history
35559 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
35560 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
35564 COMMON /DTEVNO/ NEVENT,ICASCA
35566 C IF(DT_RNDM(VV).LE.0.5D0)THEN
35567 C CALL GSQBS1(NHKK)
35568 C CALL GSQBS2(NHKK)
35569 C CALL USQBS1(NHKK)
35570 C CALL USQBS2(NHKK)
35571 C CALL GSABS1(NHKK)
35572 C CALL GSABS2(NHKK)
35573 C CALL USABS1(NHKK)
35574 C CALL USABS2(NHKK)
35576 C CALL GSQBS2(NHKK)
35577 C CALL GSQBS1(NHKK)
35578 C CALL USQBS2(NHKK)
35579 C CALL USQBS1(NHKK)
35580 C CALL GSABS2(NHKK)
35581 C CALL GSABS1(NHKK)
35582 C CALL USABS2(NHKK)
35583 C CALL USABS1(NHKK)
35586 IF(DT_RNDM(VV).LE.0.5D0) THEN
35609 *$ CREATE MUSQBS2.FOR
35613 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
35614 SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35615 * IP1,IP21,IP22,IPP1,IPP2,IPIP,ISQ,IGCOUN)
35617 C USQBS-2 diagram (split target diquark)
35619 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35622 PARAMETER ( LINP = 10 ,
35628 PARAMETER (NMXHKK=200000)
35630 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
35631 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
35632 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
35634 * extended event history
35635 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
35636 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
35639 * Lorentz-parameters of the current interaction
35640 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
35641 & UMO,PPCM,EPROJ,PPROJ
35643 * diquark-breaking mechanism
35644 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
35647 PARAMETER (NTMHKK= 300)
35648 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
35649 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
35652 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
35655 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
35656 COMMON /EVFLAG/ NUMEV
35658 C USQBS-2 diagram (split target diquark)
35661 C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
35662 C Input chain 2(NC2) sea-antiquark(NC2P)-sea-quark(NC2T)
35664 C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
35665 C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
35667 C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
35668 C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
35669 C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
35672 C Put new chains into COMMON /HKKTMP/
35677 C WRITE(LOUT,*)'MUSQBS2: IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
35681 C IF(NUMEV.EQ.-324)THEN
35682 C WRITE(LOUT,*)' MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
35683 C * 'IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN)',
35684 C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35685 C * IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN
35690 C determine x-values of NC1T diquark
35691 XDIQT=PHKK(4,NC1T)*2.D0/UMO
35692 XVQP=PHKK(4,NC1P)*2.D0/UMO
35694 C determine x-values of sea quark pair
35700 IF(ICOU.GE.500)THEN
35703 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 2234 ICOU. GT.500'
35707 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS2 call XSEAPA: UMO,XDIQT,XVQP ',
35712 C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
35713 IF (IPIP.EQ.1) THEN
35714 XQMAX = XDIQT/2.0D0
35715 XAQMAX = 2.D0*XVQP/3.0D0
35717 XQMAX = 2.D0*XVQP/3.0D0
35718 XAQMAX = XDIQT/2.0D0
35720 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
35722 C write(*,*) 'MUSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
35725 & WRITE(LOUT,*)'MUSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
35728 & WRITE(LOUT,*)'MUSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
35733 IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
35734 ELSEIF(IPIP.EQ.2)THEN
35735 IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
35738 WRITE(LOUT,'(A,4E12.4)')' MUSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
35739 & XDIQT,XVQP,XSQ,XSAQ
35742 C subtract xsq,xsaq from NC1T diquark and NC1P quark
35748 ELSEIF(IPIP.EQ.2)THEN
35753 & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
35755 C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
35760 IF(IVTHR.EQ.10)THEN
35763 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 3466 reject IVTHR 10'
35768 XVTHR=XVTHRO/(201-IVTHR)
35771 IF(XVTHR.GT.0.66D0*XDIQT)THEN
35774 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 380 XVTHR large',
35779 IF(DT_RNDM(V).LT.0.5D0)THEN
35780 XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
35783 XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
35787 WRITE(LOUT,'(A,2E12.4)')' MUSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
35790 C Prepare 4 momenta of new chains and chain ends
35792 C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
35793 C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
35796 C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
35797 C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
35798 C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
35800 C SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35801 C * IP1,IP21,IP22,IPP1,IPP2)
35808 ELSEIF(IPIP.EQ.2)THEN
35818 JDAHKT(1,1)=3+IIGLU1
35820 C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
35821 PHKT(1,1) =PHKK(1,NC2P)
35822 PHKT(2,1) =PHKK(2,NC2P)
35823 PHKT(3,1) =PHKK(3,NC2P)
35824 PHKT(4,1) =PHKK(4,NC2P)
35825 C PHKT(5,1) =PHKK(5,NC2P)
35826 XMIST =(PHKT(4,1)**2-
35827 * PHKT(3,1)**2-PHKT(2,1)**2-
35829 IF(XMIST.GT.0.D0)THEN
35830 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
35833 C WRITE(LOUT,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
35836 VHKT(1,1) =VHKK(1,NC2P)
35837 VHKT(2,1) =VHKK(2,NC2P)
35838 VHKT(3,1) =VHKK(3,NC2P)
35839 VHKT(4,1) =VHKK(4,NC2P)
35840 WHKT(1,1) =WHKK(1,NC2P)
35841 WHKT(2,1) =WHKK(2,NC2P)
35842 WHKT(3,1) =WHKK(3,NC2P)
35843 WHKT(4,1) =WHKK(4,NC2P)
35844 C Add here IIGLU1 gluons to this chaina
35849 IF(IIGLU1.GE.1)THEN
35851 DO 61 IIG=2,2+IIGLU1-1
35853 IDHKT(IIG) =IDHKK(KKG)
35857 JDAHKT(1,IIG)=3+IIGLU1
35859 PHKT(1,IIG)=PHKK(1,KKG)
35860 PG1=PG1+ PHKT(1,IIG)
35861 PHKT(2,IIG)=PHKK(2,KKG)
35862 PG2=PG2+ PHKT(2,IIG)
35863 PHKT(3,IIG)=PHKK(3,KKG)
35864 PG3=PG3+ PHKT(3,IIG)
35865 PHKT(4,IIG)=PHKK(4,KKG)
35866 PG4=PG4+ PHKT(4,IIG)
35867 PHKT(5,IIG)=PHKK(5,KKG)
35868 VHKT(1,IIG) =VHKK(1,KKG)
35869 VHKT(2,IIG) =VHKK(2,KKG)
35870 VHKT(3,IIG) =VHKK(3,KKG)
35871 VHKT(4,IIG) =VHKK(4,KKG)
35872 WHKT(1,IIG) =WHKK(1,KKG)
35873 WHKT(2,IIG) =WHKK(2,KKG)
35874 WHKT(3,IIG) =WHKK(3,KKG)
35875 WHKT(4,IIG) =WHKK(4,KKG)
35878 IDHKT(2+IIGLU1) =IP21
35879 ISTHKT(2+IIGLU1) =952
35880 JMOHKT(1,2+IIGLU1)=NC1T
35881 JMOHKT(2,2+IIGLU1)=0
35882 JDAHKT(1,2+IIGLU1)=3+IIGLU1
35883 JDAHKT(2,2+IIGLU1)=0
35884 PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
35885 PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
35886 PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
35887 PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
35888 C PHKT(5,2) =PHKK(5,NC1T)
35889 XMIST =(PHKT(4,2+IIGLU1)**2-
35890 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
35891 *PHKT(1,2+IIGLU1)**2)
35892 IF(XMIST.GT.0.D0)THEN
35893 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
35894 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
35895 *PHKT(1,2+IIGLU1)**2)
35897 C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
35898 PHKT(5,5+IIGLU1)=0.D0
35900 VHKT(1,2+IIGLU1) =VHKK(1,NC1T)
35901 VHKT(2,2+IIGLU1) =VHKK(2,NC1T)
35902 VHKT(3,2+IIGLU1) =VHKK(3,NC1T)
35903 VHKT(4,2+IIGLU1) =VHKK(4,NC1T)
35904 WHKT(1,2+IIGLU1) =WHKK(1,NC1T)
35905 WHKT(2,2+IIGLU1) =WHKK(2,NC1T)
35906 WHKT(3,2+IIGLU1) =WHKK(3,NC1T)
35907 WHKT(4,2+IIGLU1) =WHKK(4,NC1T)
35908 IDHKT(3+IIGLU1) =88888
35909 ISTHKT(3+IIGLU1) =95
35910 JMOHKT(1,3+IIGLU1)=1
35911 JMOHKT(2,3+IIGLU1)=2+IIGLU1
35912 JDAHKT(1,3+IIGLU1)=0
35913 JDAHKT(2,3+IIGLU1)=0
35914 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
35915 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
35916 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
35917 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
35919 * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
35920 * -PHKT(3,3+IIGLU1)**2)
35921 IF(XMIST.GT.0.D0)THEN
35923 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
35924 * -PHKT(3,3+IIGLU1)**2)
35926 C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
35927 PHKT(5,5+IIGLU1)=0.D0
35930 C IF(NUMEV.EQ.-324)THEN
35931 C WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
35933 C *JDAHKT(2,1),(PHKT(III,1),III=1,5)
35934 DO 71 IIG=2,2+IIGLU1-1
35935 C WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
35936 C & JMOHKT(1,IIG),JMOHKT(2,IIG),
35938 C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
35940 C WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
35941 C * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
35942 C *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
35943 C WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
35944 C * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
35945 C *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
35949 IF(IPP1.LE.-3.OR.IP21.GE.3)CHAMAL=CHAM3
35950 ELSEIF(IPIP.EQ.2)THEN
35951 IF(IPP1.GE.3.OR.IP21.LE.-3)CHAMAL=CHAM3
35953 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
35957 C WRITE(LOUT,*)' MUSQBS1 jump back from chain 3'
35960 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
35961 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
35962 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
35963 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
35964 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
35965 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
35966 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
35967 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
35969 IDHKT(4+IIGLU1) =-(ISAQ1-6)
35970 ELSEIF(IPIP.EQ.2)THEN
35971 IDHKT(4+IIGLU1) =ISAQ1
35973 ISTHKT(4+IIGLU1) =951
35974 JMOHKT(1,4+IIGLU1)=NC1P
35975 JMOHKT(2,4+IIGLU1)=0
35976 JDAHKT(1,4+IIGLU1)=6+IIGLU1
35977 JDAHKT(2,4+IIGLU1)=0
35978 C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
35979 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
35980 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
35981 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
35982 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
35983 C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
35984 XMIST =(PHKT(4,4+IIGLU1)**2-
35985 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
35986 *PHKT(1,4+IIGLU1)**2)
35987 IF(XMIST.GT.0.D0)THEN
35988 PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2-
35989 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
35990 *PHKT(1,4+IIGLU1)**2)
35992 C WRITE(LOUT,*)'MUSQBS2 parton 4 mass square LT.0 ',XMIST
35993 PHKT(5,4+IIGLU1)=0.D0
35995 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
35996 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
35997 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
35998 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
35999 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
36000 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
36001 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
36002 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
36003 IDHKT(5+IIGLU1) =IP22
36004 ISTHKT(5+IIGLU1) =952
36005 JMOHKT(1,5+IIGLU1)=NC1T
36006 JMOHKT(2,5+IIGLU1)=0
36007 JDAHKT(1,5+IIGLU1)=6+IIGLU1
36008 JDAHKT(2,5+IIGLU1)=0
36009 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
36010 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
36011 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
36012 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
36013 C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
36014 XMIST =(PHKT(4,5+IIGLU1)**2-
36015 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36016 *PHKT(1,5+IIGLU1)**2)
36017 IF(XMIST.GT.0.D0)THEN
36018 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
36019 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36020 *PHKT(1,5+IIGLU1)**2)
36022 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36023 PHKT(5,5+IIGLU1)=0.D0
36025 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
36026 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
36027 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
36028 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
36029 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
36030 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
36031 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
36032 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
36033 IDHKT(6+IIGLU1) =88888
36034 ISTHKT(6+IIGLU1) =95
36035 JMOHKT(1,6+IIGLU1)=4+IIGLU1
36036 JMOHKT(2,6+IIGLU1)=5+IIGLU1
36037 JDAHKT(1,6+IIGLU1)=0
36038 JDAHKT(2,6+IIGLU1)=0
36039 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
36040 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
36041 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
36042 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
36044 * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
36045 * -PHKT(3,6+IIGLU1)**2)
36046 IF(XMIST.GT.0.D0)THEN
36048 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
36049 * -PHKT(3,6+IIGLU1)**2)
36051 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36052 PHKT(5,5+IIGLU1)=0.D0
36054 C IF(IPIP.GE.2)THEN
36055 C IF(NUMEV.EQ.-324)THEN
36056 C WRITE(6,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
36057 C * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
36058 C *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
36059 C WRITE(6,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
36060 C * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
36061 C *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
36062 C WRITE(6,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
36063 C * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
36064 C *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
36068 IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
36069 ELSEIF(IPIP.EQ.2)THEN
36070 IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
36072 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
36076 C WRITE(6,*)' MUSQBS1 jump back from chain 6',
36077 C * CHAMAL,PHKT(5,6+IIGLU1)
36080 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
36081 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
36082 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
36083 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
36084 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
36085 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
36086 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
36087 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
36088 C IDHKT(7) =1000*IPP1+100*ISQ+1
36089 IDHKT(7+IIGLU1) =IP1
36090 ISTHKT(7+IIGLU1) =951
36091 JMOHKT(1,7+IIGLU1)=NC1P
36092 JMOHKT(2,7+IIGLU1)=0
36094 C JDAHKT(1,7+IIGLU1)=9+IIGLU1
36095 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
36097 JDAHKT(2,7+IIGLU1)=0
36098 PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
36099 PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
36100 PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
36101 PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
36102 C PHKT(5,7+IIGLU1) =PHKK(5,NC1P)
36103 XMIST =(PHKT(4,7+IIGLU1)**2-
36104 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
36105 *PHKT(1,7+IIGLU1)**2)
36106 IF(XMIST.GT.0.D0)THEN
36107 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
36108 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
36109 *PHKT(1,7+IIGLU1)**2)
36111 C WRITE(6,*)'MUSQBS2 parton 7 mass square LT.0 ',XMIST
36112 PHKT(5,7+IIGLU1)=0.D0
36114 VHKT(1,7+IIGLU1) =VHKK(1,NC1P)
36115 VHKT(2,7+IIGLU1) =VHKK(2,NC1P)
36116 VHKT(3,7+IIGLU1) =VHKK(3,NC1P)
36117 VHKT(4,7+IIGLU1) =VHKK(4,NC1P)
36118 WHKT(1,7+IIGLU1) =WHKK(1,NC1P)
36119 WHKT(2,7+IIGLU1) =WHKK(2,NC1P)
36120 WHKT(3,7+IIGLU1) =WHKK(3,NC1P)
36121 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
36122 C Insert here the IIGLU2 gluons
36127 IF(IIGLU2.GE.1)THEN
36129 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36130 KKG=JJG+IIG-7-IIGLU1
36131 IDHKT(IIG) =IDHKK(KKG)
36135 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
36137 PHKT(1,IIG)=PHKK(1,KKG)
36138 PG1=PG1+ PHKT(1,IIG)
36139 PHKT(2,IIG)=PHKK(2,KKG)
36140 PG2=PG2+ PHKT(2,IIG)
36141 PHKT(3,IIG)=PHKK(3,KKG)
36142 PG3=PG3+ PHKT(3,IIG)
36143 PHKT(4,IIG)=PHKK(4,KKG)
36144 PG4=PG4+ PHKT(4,IIG)
36145 PHKT(5,IIG)=PHKK(5,KKG)
36146 VHKT(1,IIG) =VHKK(1,KKG)
36147 VHKT(2,IIG) =VHKK(2,KKG)
36148 VHKT(3,IIG) =VHKK(3,KKG)
36149 VHKT(4,IIG) =VHKK(4,KKG)
36150 WHKT(1,IIG) =WHKK(1,KKG)
36151 WHKT(2,IIG) =WHKK(2,KKG)
36152 WHKT(3,IIG) =WHKK(3,KKG)
36153 WHKT(4,IIG) =WHKK(4,KKG)
36157 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3
36158 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
36159 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
36160 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
36161 ELSEIF(IPIP.EQ.2)THEN
36162 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3
36163 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
36164 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
36165 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
36167 ISTHKT(8+IIGLU1+IIGLU2) =952
36168 JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
36169 JMOHKT(2,8+IIGLU1+IIGLU2)=0
36170 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
36171 JDAHKT(2,8+IIGLU1+IIGLU2)=0
36172 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC2T)+
36173 * PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
36174 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC2T)+
36175 * PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
36176 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC2T)+
36177 * PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
36178 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC2T)+
36179 * PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
36180 C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
36181 C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
36182 IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
36184 C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
36185 C * ,PHKT(4,8+IIGLU1+IIGLU2), PHKK(4,NC2T),NC2T
36190 C PHKT(5,8) =PHKK(5,NC2T)
36191 XMIST =(PHKT(4,8+IIGLU1+IIGLU2)**2-
36192 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36193 *PHKT(1,8+IIGLU1+IIGLU2)**2)
36194 IF(XMIST.GT.0.D0)THEN
36195 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
36196 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36197 *PHKT(1,8+IIGLU1+IIGLU2)**2)
36199 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36200 PHKT(5,5+IIGLU1)=0.D0
36202 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T)
36203 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T)
36204 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T)
36205 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T)
36206 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T)
36207 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T)
36208 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T)
36209 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T)
36210 IDHKT(9+IIGLU1+IIGLU2) =88888
36211 ISTHKT(9+IIGLU1+IIGLU2) =95
36212 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
36213 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
36214 JDAHKT(1,9+IIGLU1+IIGLU2)=0
36215 JDAHKT(2,9+IIGLU1+IIGLU2)=0
36217 C PHKT(1,9+IIGLU1+IIGLU2)
36218 C * =PHKT(1,7+IIGLU1+IIGLU2)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
36219 C PHKT(2,9+IIGLU1+IIGLU2)
36220 C * =PHKT(2,7+IIGLU1+IIGLU2)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
36221 C PHKT(3,9+IIGLU1+IIGLU2)
36222 C * =PHKT(3,7+IIGLU1+IIGLU2)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
36223 C PHKT(4,9+IIGLU1+IIGLU2)
36224 C * =PHKT(4,7+IIGLU1+IIGLU2)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
36225 PHKT(1,9+IIGLU1+IIGLU2)
36226 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
36227 PHKT(2,9+IIGLU1+IIGLU2)
36228 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
36229 PHKT(3,9+IIGLU1+IIGLU2)
36230 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
36231 PHKT(4,9+IIGLU1+IIGLU2)
36232 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
36235 * =(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
36236 * -PHKT(2,9+IIGLU1+IIGLU2)**2
36237 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
36238 IF(XMIST.GT.0.D0)THEN
36239 PHKT(5,9+IIGLU1+IIGLU2)
36240 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
36241 * -PHKT(2,9+IIGLU1+IIGLU2)**2
36242 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
36244 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36245 PHKT(5,5+IIGLU1)=0.D0
36248 C IF(NUMEV.EQ.-324)THEN
36249 C WRITE(6,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
36250 C * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
36251 C *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
36252 C DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36253 C WRITE(6,*)IIG,ISTHKT(IIG),IDHKT(IIG),JMOHKT(1,IIG),JMOHKT(2,IIG),
36255 C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36257 C WRITE(6,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
36258 C * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
36259 C *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
36260 C *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
36261 C WRITE(6,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
36262 C * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
36263 C *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
36264 C *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
36268 IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
36269 ELSEIF(IPIP.EQ.2)THEN
36270 IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
36272 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
36276 C WRITE(6,*)' MUSQBS1 jump back from chain 9',
36277 C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
36280 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
36281 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
36282 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
36283 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
36284 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
36285 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
36286 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
36287 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
36290 IGCOUN=9+IIGLU1+IIGLU2
36294 *$ CREATE MGSQBS2.FOR
36298 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
36299 SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36300 * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,ISQ,IGCOUN)
36302 C GSQBS-2 diagram (split target diquark)
36304 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36307 PARAMETER ( LINP = 10 ,
36313 PARAMETER (NMXHKK=200000)
36315 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36316 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36317 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36319 * extended event history
36320 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36321 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36324 * Lorentz-parameters of the current interaction
36325 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
36326 & UMO,PPCM,EPROJ,PPROJ
36328 * diquark-breaking mechanism
36329 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
36332 PARAMETER (NTMHKK= 300)
36333 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
36334 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
36338 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
36341 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
36343 C GSQBS-2 diagram (split target diquark)
36346 C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
36347 C Input chain 2(NC2) valence-diquark(NC2P)-sea-quark(NC2T)
36349 C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
36350 C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
36352 C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
36353 C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36354 C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
36358 C Put new chains into COMMON /HKKTMP/
36363 C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
36366 C IF(IPIP.EQ.2)THEN
36367 C WRITE(6,*)' MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
36368 C * 'IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN)',
36369 C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36370 C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN
36375 C determine x-values of NC1T diquark
36376 XDIQT=PHKK(4,NC1T)*2.D0/UMO
36377 XVQP=PHKK(4,NC1P)*2.D0/UMO
36379 C determine x-values of sea quark pair
36385 IF(ICOU.GE.500)THEN
36389 & WRITE(LOUT,*)' MGSQBS2 Rejection 2234 ICOU. GT.500'
36394 & WRITE(LOUT,*)'MGSQBS2 call XSEAPA: UMO,XDIQT,XVQP ',
36399 C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
36400 IF (IPIP.EQ.1) THEN
36401 XQMAX = XDIQT/2.0D0
36402 XAQMAX = 2.D0*XVQP/3.0D0
36404 XQMAX = 2.D0*XVQP/3.0D0
36405 XAQMAX = XDIQT/2.0D0
36407 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
36409 C write(*,*) 'MGSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
36412 & WRITE(LOUT,*)'MGSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
36415 & WRITE(LOUT,*)'MGSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
36420 IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
36421 ELSEIF(IPIP.EQ.2)THEN
36422 IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
36425 WRITE(LOUT,'(A,4E12.4)')' MGSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
36426 & XDIQT,XVQP,XSQ,XSAQ
36429 C subtract xsq,xsaq from NC1T diquark and NC1P quark
36435 ELSEIF(IPIP.EQ.2)THEN
36440 & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
36442 C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
36447 IF(IVTHR.EQ.10)THEN
36450 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 3466 reject IVTHR 10'
36455 XVTHR=XVTHRO/(201-IVTHR)
36458 IF(XVTHR.GT.0.66D0*XDIQT)THEN
36461 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 Rejection 380 XVTHR large',
36466 IF(DT_RNDM(V).LT.0.5D0)THEN
36467 XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
36470 XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
36474 WRITE(LOUT,'(A,2E12.4)')' MGSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
36477 C Prepare 4 momenta of new chains and chain ends
36479 C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
36480 C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
36483 C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
36484 C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36485 C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
36487 C SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36488 C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IGCOUN)
36495 ELSEIF(IPIP.EQ.2)THEN
36502 C IDHKT(1) =1000*IPP11+100*IPP12+1
36507 IDHKT(4+IIGLU1) =-(ISAQ1-6)
36508 ELSEIF(IPIP.EQ.2)THEN
36509 IDHKT(4+IIGLU1) =ISAQ1
36511 ISTHKT(4+IIGLU1) =961
36512 JMOHKT(1,4+IIGLU1)=NC1P
36513 JMOHKT(2,4+IIGLU1)=0
36514 JDAHKT(1,4+IIGLU1)=6+IIGLU1
36515 JDAHKT(2,4+IIGLU1)=0
36516 C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36517 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
36518 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
36519 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
36520 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
36521 C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
36522 XXMIST=(PHKT(4,4+IIGLU1)**2-
36523 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
36524 *PHKT(1,4+IIGLU1)**2)
36525 IF(XXMIST.GT.0.D0)THEN
36526 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
36528 WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
36530 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
36532 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
36533 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
36534 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
36535 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
36536 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
36537 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
36538 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
36539 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
36540 IDHKT(5+IIGLU1) =IP22
36541 ISTHKT(5+IIGLU1) =962
36542 JMOHKT(1,5+IIGLU1)=NC1T
36543 JMOHKT(2,5+IIGLU1)=0
36544 JDAHKT(1,5+IIGLU1)=6+IIGLU1
36545 JDAHKT(2,5+IIGLU1)=0
36546 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
36547 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
36548 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
36549 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
36550 C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
36551 XXMIST=(PHKT(4,5+IIGLU1)**2-
36552 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36553 *PHKT(1,5+IIGLU1)**2)
36554 IF(XXMIST.GT.0.D0)THEN
36555 PHKT(5,5+IIGLU1) =SQRT(XXMIST)
36557 WRITE(LOUT,*)' MGSQBS2 XXMIST', XXMIST
36559 PHKT(5,5+IIGLU1) =SQRT(XXMIST)
36561 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
36562 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
36563 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
36564 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
36565 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
36566 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
36567 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
36568 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
36569 IDHKT(6+IIGLU1) =88888
36570 ISTHKT(6+IIGLU1) =96
36571 JMOHKT(1,6+IIGLU1)=4+IIGLU1
36572 JMOHKT(2,6+IIGLU1)=5+IIGLU1
36573 JDAHKT(1,6+IIGLU1)=0
36574 JDAHKT(2,6+IIGLU1)=0
36575 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
36576 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
36577 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
36578 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
36580 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
36581 * -PHKT(3,6+IIGLU1)**2)
36584 IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
36585 ELSEIF(IPIP.EQ.2)THEN
36586 IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
36588 C---------------------------------------------------
36589 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
36590 IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
36591 C we drop chain 6 and give the energy to chain 3
36592 IDHKT(6+IIGLU1)=22888
36594 C WRITE(6,*)' drop chain 6 xgive=1'
36596 ELSEIF(IDHKT(4+IIGLU1).EQ.-IP21)THEN
36597 C we drop chain 6 and give the energy to chain 3
36598 C and change KK11 to IDHKT(5)
36599 IDHKT(6+IIGLU1)=22888
36601 C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(5)'
36602 KK11=IDHKT(5+IIGLU1)
36604 ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP11)THEN
36605 C we drop chain 6 and give the energy to chain 3
36606 C and change KK21 to IDHKT(5+IIGLU1)
36607 C IDHKT(1) =1000*IPP11+100*IPP12+1
36608 IDHKT(6+IIGLU1)=22888
36610 C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(5+IIGLU1)'
36611 KK21=IDHKT(5+IIGLU1)
36613 ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP12)THEN
36614 C we drop chain 6 and give the energy to chain 3
36615 C and change KK22 to IDHKT(5)
36616 C IDHKT(1) =1000*IPP11+100*IPP12+1
36617 IDHKT(6+IIGLU1)=22888
36619 C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(5+IIGLU1)'
36620 KK22=IDHKT(5+IIGLU1)
36629 C---------------------------------------------------
36631 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
36632 * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
36633 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
36634 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
36635 * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
36636 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
36637 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
36638 * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
36639 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
36641 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
36642 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
36643 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
36644 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
36645 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
36646 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
36647 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
36648 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
36649 C IDHKT(1) =1000*IPP11+100*IPP12+1
36651 IDHKT(1) =1000*KK21+100*KK22+3
36652 IF(IDHKT(1).EQ.1203)IDHKT(1)=2103
36653 IF(IDHKT(1).EQ.1303)IDHKT(1)=3103
36654 IF(IDHKT(1).EQ.2303)IDHKT(1)=3203
36655 ELSEIF(IPIP.EQ.2)THEN
36656 IDHKT(1) =1000*KK21+100*KK22-3
36657 IF(IDHKT(1).EQ.-1203)IDHKT(1)=-2103
36658 IF(IDHKT(1).EQ.-1303)IDHKT(1)=-3103
36659 IF(IDHKT(1).EQ.-2303)IDHKT(1)=-3203
36664 JDAHKT(1,1)=3+IIGLU1
36666 C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
36667 PHKT(1,1) =PHKK(1,NC2P)
36668 *+XGIVE*PHKT(1,4+IIGLU1)
36669 PHKT(2,1) =PHKK(2,NC2P)
36670 *+XGIVE*PHKT(2,4+IIGLU1)
36671 PHKT(3,1) =PHKK(3,NC2P)
36672 *+XGIVE*PHKT(3,4+IIGLU1)
36673 PHKT(4,1) =PHKK(4,NC2P)
36674 *+XGIVE*PHKT(4,4+IIGLU1)
36675 C PHKT(5,1) =PHKK(5,NC2P)
36676 XXMIST=PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
36678 IF(XXMIST.GT.0.D0)THEN
36679 PHKT(5,1) =SQRT(XXMIST)
36681 WRITE(LOUT,*)'MGSQBS2',XXMIST
36683 PHKT(5,1) =SQRT(XXMIST)
36685 VHKT(1,1) =VHKK(1,NC2P)
36686 VHKT(2,1) =VHKK(2,NC2P)
36687 VHKT(3,1) =VHKK(3,NC2P)
36688 VHKT(4,1) =VHKK(4,NC2P)
36689 WHKT(1,1) =WHKK(1,NC2P)
36690 WHKT(2,1) =WHKK(2,NC2P)
36691 WHKT(3,1) =WHKK(3,NC2P)
36692 WHKT(4,1) =WHKK(4,NC2P)
36693 C Add here IIGLU1 gluons to this chaina
36698 IF(IIGLU1.GE.1)THEN
36700 DO 61 IIG=2,2+IIGLU1-1
36702 IDHKT(IIG) =IDHKK(KKG)
36706 JDAHKT(1,IIG)=3+IIGLU1
36708 PHKT(1,IIG)=PHKK(1,KKG)
36709 PG1=PG1+ PHKT(1,IIG)
36710 PHKT(2,IIG)=PHKK(2,KKG)
36711 PG2=PG2+ PHKT(2,IIG)
36712 PHKT(3,IIG)=PHKK(3,KKG)
36713 PG3=PG3+ PHKT(3,IIG)
36714 PHKT(4,IIG)=PHKK(4,KKG)
36715 PG4=PG4+ PHKT(4,IIG)
36716 PHKT(5,IIG)=PHKK(5,KKG)
36717 VHKT(1,IIG) =VHKK(1,KKG)
36718 VHKT(2,IIG) =VHKK(2,KKG)
36719 VHKT(3,IIG) =VHKK(3,KKG)
36720 VHKT(4,IIG) =VHKK(4,KKG)
36721 WHKT(1,IIG) =WHKK(1,KKG)
36722 WHKT(2,IIG) =WHKK(2,KKG)
36723 WHKT(3,IIG) =WHKK(3,KKG)
36724 WHKT(4,IIG) =WHKK(4,KKG)
36728 IDHKT(2+IIGLU1) =KK11
36729 ISTHKT(2+IIGLU1) =962
36730 JMOHKT(1,2+IIGLU1)=NC1T
36731 JMOHKT(2,2+IIGLU1)=0
36732 JDAHKT(1,2+IIGLU1)=3+IIGLU1
36733 JDAHKT(2,2+IIGLU1)=0
36734 PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
36735 C * +0.5D0*PHKK(1,NC2T)
36736 *+XGIVE*PHKT(1,5+IIGLU1)
36737 PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
36738 C *+0.5D0*PHKK(2,NC2T)
36739 *+XGIVE*PHKT(2,5+IIGLU1)
36740 PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
36741 C *+0.5D0*PHKK(3,NC2T)
36742 *+XGIVE*PHKT(3,5+IIGLU1)
36743 PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
36744 C *+0.5D0*PHKK(4,NC2T)
36745 *+XGIVE*PHKT(4,5+IIGLU1)
36746 C PHKT(5,2) =PHKK(5,NC1T)
36747 XXMIST=(PHKT(4,2+IIGLU1)**2-
36748 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
36749 *PHKT(1,2+IIGLU1)**2)
36750 IF(XXMIST.GT.0.D0)THEN
36751 PHKT(5,2+IIGLU1) =SQRT(XXMIST)
36753 WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
36755 PHKT(5,2+IIGLU1) =SQRT(XXMIST)
36757 VHKT(1,2+IIGLU1) =VHKK(1,NC1T)
36758 VHKT(2,2+IIGLU1) =VHKK(2,NC1T)
36759 VHKT(3,2+IIGLU1) =VHKK(3,NC1T)
36760 VHKT(4,2+IIGLU1) =VHKK(4,NC1T)
36761 WHKT(1,2+IIGLU1) =WHKK(1,NC1T)
36762 WHKT(2,2+IIGLU1) =WHKK(2,NC1T)
36763 WHKT(3,2+IIGLU1) =WHKK(3,NC1T)
36764 WHKT(4,2+IIGLU1) =WHKK(4,NC1T)
36765 IDHKT(3+IIGLU1) =88888
36766 ISTHKT(3+IIGLU1) =96
36767 JMOHKT(1,3+IIGLU1)=1
36768 JMOHKT(2,3+IIGLU1)=2+IIGLU1
36769 JDAHKT(1,3+IIGLU1)=0
36770 JDAHKT(2,3+IIGLU1)=0
36771 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
36772 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
36773 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
36774 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
36776 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
36777 * -PHKT(3,3+IIGLU1)**2)
36779 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
36781 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
36782 DO 71 IIG=2,2+IIGLU1-1
36783 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
36784 & JMOHKT(1,IIG),JMOHKT(2,IIG),
36786 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36788 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
36789 * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
36790 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
36791 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
36792 * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
36793 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
36797 IF(IPP11.GE.3.OR.IPP12.GE.3.OR.IP21.GE.3)CHAMAL=CHAB3
36798 ELSEIF(IPIP.EQ.2)THEN
36799 IF(IPP11.LE.-3.OR.IPP12.LE.-3.OR.IP21.LE.-3)CHAMAL=CHAB3
36801 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
36807 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
36808 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
36809 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
36810 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
36811 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
36812 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
36813 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
36814 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
36815 C IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+1
36816 IDHKT(7+IIGLU1) =IP1
36817 ISTHKT(7+IIGLU1) =961
36818 JMOHKT(1,7+IIGLU1)=NC1P
36819 JMOHKT(2,7+IIGLU1)=0
36820 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
36821 JDAHKT(2,7+IIGLU1)=0
36822 PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
36823 PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
36824 PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
36825 PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
36826 C PHKT(5,7+IIGLU1) =PHKK(5,NC1P)
36827 XXMIST=(PHKT(4,7+IIGLU1)**2-
36828 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
36829 *PHKT(1,7+IIGLU1)**2)
36830 IF(XXMIST.GT.0.D0)THEN
36831 PHKT(5,7+IIGLU1) =SQRT(XXMIST)
36833 WRITE(LOUT,*)' MGSQBS2, XXMIST',XXMIST
36835 PHKT(5,7+IIGLU1) =SQRT(XXMIST)
36837 VHKT(1,7+IIGLU1) =VHKK(1,NC1P)
36838 VHKT(2,7+IIGLU1) =VHKK(2,NC1P)
36839 VHKT(3,7+IIGLU1) =VHKK(3,NC1P)
36840 VHKT(4,7+IIGLU1) =VHKK(4,NC1P)
36841 WHKT(1,7+IIGLU1) =WHKK(1,NC1P)
36842 WHKT(2,7+IIGLU1) =WHKK(2,NC1P)
36843 WHKT(3,7+IIGLU1) =WHKK(3,NC1P)
36844 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
36845 C IDHKT(7) =1000*IPP1+100*ISQ+1
36846 C Insert here the IIGLU2 gluons
36851 IF(IIGLU2.GE.1)THEN
36853 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36854 KKG=JJG+IIG-7-IIGLU1
36855 IDHKT(IIG) =IDHKK(KKG)
36859 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
36861 PHKT(1,IIG)=PHKK(1,KKG)
36862 PG1=PG1+ PHKT(1,IIG)
36863 PHKT(2,IIG)=PHKK(2,KKG)
36864 PG2=PG2+ PHKT(2,IIG)
36865 PHKT(3,IIG)=PHKK(3,KKG)
36866 PG3=PG3+ PHKT(3,IIG)
36867 PHKT(4,IIG)=PHKK(4,KKG)
36868 PG4=PG4+ PHKT(4,IIG)
36869 PHKT(5,IIG)=PHKK(5,KKG)
36870 VHKT(1,IIG) =VHKK(1,KKG)
36871 VHKT(2,IIG) =VHKK(2,KKG)
36872 VHKT(3,IIG) =VHKK(3,KKG)
36873 VHKT(4,IIG) =VHKK(4,KKG)
36874 WHKT(1,IIG) =WHKK(1,KKG)
36875 WHKT(2,IIG) =WHKK(2,KKG)
36876 WHKT(3,IIG) =WHKK(3,KKG)
36877 WHKT(4,IIG) =WHKK(4,KKG)
36881 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3
36882 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
36883 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
36884 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
36885 ELSEIF(IPIP.EQ.2)THEN
36887 C IDHKT(8) =1000*IPP2+100*(-ISQ1+6)-3
36888 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3
36890 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
36891 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
36892 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
36894 ISTHKT(8+IIGLU1+IIGLU2) =962
36895 JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
36896 JMOHKT(2,8+IIGLU1+IIGLU2)=0
36897 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
36898 JDAHKT(2,8+IIGLU1+IIGLU2)=0
36899 C PHKT(1,8) =0.5D0*PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ/(XDIQT+XSQ)
36900 C PHKT(2,8) =0.5D0*PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ/(XDIQT+XSQ)
36901 C PHKT(3,8) =0.5D0*PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ/(XDIQT+XSQ)
36902 C PHKT(4,8) =0.5D0*PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ/(XDIQT+XSQ)
36903 PHKT(1,8+IIGLU1+IIGLU2) =
36904 * PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
36905 PHKT(2,8+IIGLU1+IIGLU2) =
36906 * PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
36907 PHKT(3,8+IIGLU1+IIGLU2) =
36908 * PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
36909 PHKT(4,8+IIGLU1+IIGLU2) =
36910 * PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
36911 C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
36912 C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
36913 IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
36915 C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
36920 C PHKT(5,8) =PHKK(5,NC2T)
36921 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
36922 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36923 *PHKT(1,8+IIGLU1+IIGLU2)**2)
36924 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T)
36925 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T)
36926 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T)
36927 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T)
36928 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T)
36929 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T)
36930 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T)
36931 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T)
36932 IDHKT(9+IIGLU1+IIGLU2) =88888
36933 ISTHKT(9+IIGLU1+IIGLU2) =96
36934 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
36935 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
36936 JDAHKT(1,9+IIGLU1+IIGLU2)=0
36937 JDAHKT(2,9+IIGLU1+IIGLU2)=0
36938 PHKT(1,9+IIGLU1+IIGLU2)
36939 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
36940 PHKT(2,9+IIGLU1+IIGLU2)
36941 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
36942 PHKT(3,9+IIGLU1+IIGLU2)
36943 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
36944 PHKT(4,9+IIGLU1+IIGLU2)
36945 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
36946 PHKT(5,9+IIGLU1+IIGLU2)
36947 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
36948 * PHKT(2,9+IIGLU1+IIGLU2)**2
36949 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
36951 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
36952 * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
36953 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
36954 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36955 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
36956 & JMOHKT(1,IIG),JMOHKT(2,IIG),
36958 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36960 WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
36961 * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
36962 *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
36963 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
36964 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
36965 * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
36966 *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
36967 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
36971 IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
36972 ELSEIF(IPIP.EQ.2)THEN
36973 IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
36975 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
36981 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
36982 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
36983 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
36984 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
36985 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
36986 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
36987 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
36988 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
36991 IGCOUN=9+IIGLU1+IIGLU2
36995 *$ CREATE MUSQBS1.FOR
36999 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
37000 SUBROUTINE MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37001 * IP11,IP12,IP2,IPP1,IPP2,IPIP,ISQ,IGCOUN)
37003 C USQBS-1 diagram (split projectile diquark)
37005 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37008 PARAMETER ( LINP = 10 ,
37014 PARAMETER (NMXHKK=200000)
37016 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
37017 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
37018 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
37020 * extended event history
37021 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
37022 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37025 * Lorentz-parameters of the current interaction
37026 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37027 & UMO,PPCM,EPROJ,PPROJ
37029 * diquark-breaking mechanism
37030 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37033 PARAMETER (NTMHKK= 300)
37034 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37035 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37038 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37041 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37042 COMMON /EVFLAG/ NUMEV
37044 C USQBS-1 diagram (split projectile diquark)
37046 C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
37047 C Input chain 2(NC2) sea-quark(NC2P)-sea-antiquark(NC2T)
37049 C Create quark(qsP)-antiquark(aqsT) pair, energy from NC1P and NC1T
37050 C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37052 C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
37053 C 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
37054 C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37056 C Put new chains into COMMON /HKKTMP/
37061 C WRITE(6,*)'MUSQBS1: IIGLU1,IIGLU2,IPIP ',IIGLU1,IIGLU2,IPIP
37065 C IF(NUMEV.EQ.-324)THEN
37066 WRITE(LOUT,*)' MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37067 * ' IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN)',
37068 *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37069 * IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN
37074 C determine x-values of NC1P diquark
37075 XDIQP=PHKK(4,NC1P)*2.D0/UMO
37076 XVQT=PHKK(4,NC1T)*2.D0/UMO
37078 C determine x-values of sea quark pair
37084 IF(ICOU.GE.500)THEN
37087 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 2234 ICOU. GT.100'
37091 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 call XSEAPA: UMO,XDIQP,XVQT ',
37096 C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37097 IF (IPIP.EQ.1) THEN
37098 XQMAX = XDIQP/2.0D0
37099 XAQMAX = 2.D0*XVQT/3.0D0
37101 XQMAX = 2.D0*XVQT/3.0D0
37102 XAQMAX = XDIQP/2.0D0
37104 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37106 C write(*,*) 'MUSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
37108 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37111 & WRITE(LOUT,*)'MUSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37116 IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37117 ELSEIF(IPIP.EQ.2)THEN
37118 IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37121 WRITE(LOUT,'(A,4E12.4)')' MUSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
37122 & XDIQP,XVQT,XSQ,XSAQ
37125 C subtract xsq,xsaq from NC1P diquark and NC1T quark
37131 ELSEIF(IPIP.EQ.2)THEN
37136 & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
37138 C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37143 IF(IVTHR.EQ.10)THEN
37146 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 3466 reject IVTHR 10'
37151 XVTHR=XVTHRO/(201-IVTHR)
37154 IF(XVTHR.GT.0.66D0*XDIQP)THEN
37157 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 380 XVTHR large',
37162 IF(DT_RNDM(V).LT.0.5D0)THEN
37163 XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37166 XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37170 WRITE(LOUT,'(A,2E12.4)')' MUSQBS1:XVPQI,XVPQII ',XVPQI,XVPQII
37173 C Prepare 4 momenta of new chains and chain ends
37175 C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37176 C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37178 C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
37179 C 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
37180 C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37186 ELSEIF(IPIP.EQ.2)THEN
37196 JDAHKT(1,1)=3+IIGLU1
37198 C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
37199 PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
37200 PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
37201 PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
37202 PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
37203 C PHKT(5,1) =PHKK(5,NC1P)
37204 XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
37206 IF(XMIST.GE.0.D0)THEN
37207 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
37210 C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37213 VHKT(1,1) =VHKK(1,NC1P)
37214 VHKT(2,1) =VHKK(2,NC1P)
37215 VHKT(3,1) =VHKK(3,NC1P)
37216 VHKT(4,1) =VHKK(4,NC1P)
37217 WHKT(1,1) =WHKK(1,NC1P)
37218 WHKT(2,1) =WHKK(2,NC1P)
37219 WHKT(3,1) =WHKK(3,NC1P)
37220 WHKT(4,1) =WHKK(4,NC1P)
37221 C Add here IIGLU1 gluons to this chaina
37226 IF(IIGLU1.GE.1)THEN
37228 DO 61 IIG=2,2+IIGLU1-1
37230 IDHKT(IIG) =IDHKK(KKG)
37234 JDAHKT(1,IIG)=3+IIGLU1
37236 PHKT(1,IIG)=PHKK(1,KKG)
37237 PG1=PG1+ PHKT(1,IIG)
37238 PHKT(2,IIG)=PHKK(2,KKG)
37239 PG2=PG2+ PHKT(2,IIG)
37240 PHKT(3,IIG)=PHKK(3,KKG)
37241 PG3=PG3+ PHKT(3,IIG)
37242 PHKT(4,IIG)=PHKK(4,KKG)
37243 PG4=PG4+ PHKT(4,IIG)
37244 PHKT(5,IIG)=PHKK(5,KKG)
37245 VHKT(1,IIG) =VHKK(1,KKG)
37246 VHKT(2,IIG) =VHKK(2,KKG)
37247 VHKT(3,IIG) =VHKK(3,KKG)
37248 VHKT(4,IIG) =VHKK(4,KKG)
37249 WHKT(1,IIG) =WHKK(1,KKG)
37250 WHKT(2,IIG) =WHKK(2,KKG)
37251 WHKT(3,IIG) =WHKK(3,KKG)
37252 WHKT(4,IIG) =WHKK(4,KKG)
37255 IDHKT(2+IIGLU1) =IPP2
37256 ISTHKT(2+IIGLU1) =932
37257 JMOHKT(1,2+IIGLU1)=NC2T
37258 JMOHKT(2,2+IIGLU1)=0
37259 JDAHKT(1,2+IIGLU1)=3+IIGLU1
37260 JDAHKT(2,2+IIGLU1)=0
37261 PHKT(1,2+IIGLU1) =PHKK(1,NC2T)
37262 PHKT(2,2+IIGLU1) =PHKK(2,NC2T)
37263 PHKT(3,2+IIGLU1) =PHKK(3,NC2T)
37264 PHKT(4,2+IIGLU1) =PHKK(4,NC2T)
37265 C PHKT(5,2+IIGLU1) =PHKK(5,NC2T)
37266 XMIST=(PHKT(4,2+IIGLU1)**2-
37267 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37268 *PHKT(1,2+IIGLU1)**2)
37269 IF(XMIST.GT.0.D0)THEN
37270 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
37271 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37272 *PHKT(1,2+IIGLU1)**2)
37274 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37275 PHKT(5,2+IIGLU1)=0.D0
37277 VHKT(1,2+IIGLU1) =VHKK(1,NC2T)
37278 VHKT(2,2+IIGLU1) =VHKK(2,NC2T)
37279 VHKT(3,2+IIGLU1) =VHKK(3,NC2T)
37280 VHKT(4,2+IIGLU1) =VHKK(4,NC2T)
37281 WHKT(1,2+IIGLU1) =WHKK(1,NC2T)
37282 WHKT(2,2+IIGLU1) =WHKK(2,NC2T)
37283 WHKT(3,2+IIGLU1) =WHKK(3,NC2T)
37284 WHKT(4,2+IIGLU1) =WHKK(4,NC2T)
37285 IDHKT(3+IIGLU1) =88888
37286 ISTHKT(3+IIGLU1) =94
37287 JMOHKT(1,3+IIGLU1)=1
37288 JMOHKT(2,3+IIGLU1)=2+IIGLU1
37289 JDAHKT(1,3+IIGLU1)=0
37290 JDAHKT(2,3+IIGLU1)=0
37291 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
37292 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
37293 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
37294 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
37296 * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37297 * -PHKT(3,3+IIGLU1)**2)
37298 IF(XMIST.GE.0.D0)THEN
37300 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37301 * -PHKT(3,3+IIGLU1)**2)
37303 C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37307 C IF(NUMEV.EQ.-324)THEN
37308 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),
37309 * JMOHKT(2,1),JDAHKT(1,1),
37310 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
37311 DO 71 IIG=2,2+IIGLU1-1
37312 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
37313 & JMOHKT(1,IIG),JMOHKT(2,IIG),
37315 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37317 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
37318 * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
37319 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
37320 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
37321 * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
37322 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
37326 IF(IP11.GE.3.OR.IPP2.GE.3)CHAMAL=CHAM3
37327 ELSEIF(IPIP.EQ.2)THEN
37328 IF(IP11.LE.-3.OR.IPP2.LE.-3)CHAMAL=CHAM3
37330 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
37334 C WRITE(6,*)' MUSQBS1 jump back from chain 3'
37337 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
37338 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
37339 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
37340 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
37341 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
37342 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
37343 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
37344 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
37345 IDHKT(4+IIGLU1) =IP12
37346 ISTHKT(4+IIGLU1) =931
37347 JMOHKT(1,4+IIGLU1)=NC1P
37348 JMOHKT(2,4+IIGLU1)=0
37349 JDAHKT(1,4+IIGLU1)=6+IIGLU1
37350 JDAHKT(2,4+IIGLU1)=0
37351 C create chain 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
37352 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
37353 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
37354 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
37355 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
37356 C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
37357 XMIST =(PHKT(4,4+IIGLU1)**2-
37358 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37359 *PHKT(1,4+IIGLU1)**2)
37360 IF(XMIST.GT.0.D0)THEN
37361 PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2-
37362 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37363 *PHKT(1,4+IIGLU1)**2)
37365 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37366 PHKT(5,4+IIGLU1)=0.D0
37368 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
37369 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
37370 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
37371 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
37372 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
37373 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
37374 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
37375 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
37377 IDHKT(5+IIGLU1) =-(ISAQ1-6)
37378 ELSEIF(IPIP.EQ.2)THEN
37379 IDHKT(5+IIGLU1) =ISAQ1
37381 ISTHKT(5+IIGLU1) =932
37382 JMOHKT(1,5+IIGLU1)=NC1T
37383 JMOHKT(2,5+IIGLU1)=0
37384 JDAHKT(1,5+IIGLU1)=6+IIGLU1
37385 JDAHKT(2,5+IIGLU1)=0
37386 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
37387 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
37388 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
37389 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
37390 C IF( PHKT(4,5).EQ.0.D0)THEN
37395 C PHKT(5,5) =PHKK(5,NC1T)
37396 XMIST=(PHKT(4,5+IIGLU1)**2-
37397 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37398 *PHKT(1,5+IIGLU1)**2)
37399 IF(XMIST.GT.0.D0)THEN
37400 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
37401 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37402 *PHKT(1,5+IIGLU1)**2)
37404 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37405 PHKT(5,5+IIGLU1)=0.D0
37407 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
37408 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
37409 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
37410 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
37411 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
37412 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
37413 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
37414 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
37415 IDHKT(6+IIGLU1) =88888
37416 ISTHKT(6+IIGLU1) =94
37417 JMOHKT(1,6+IIGLU1)=4+IIGLU1
37418 JMOHKT(2,6+IIGLU1)=5+IIGLU1
37419 JDAHKT(1,6+IIGLU1)=0
37420 JDAHKT(2,6+IIGLU1)=0
37421 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37422 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37423 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37424 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37426 * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37427 * -PHKT(3,6+IIGLU1)**2)
37428 IF(XMIST.GE.0.D0)THEN
37430 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37431 * -PHKT(3,6+IIGLU1)**2)
37433 C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37436 C IF(IPIP.EQ.3)THEN
37439 IF(IP12.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
37440 ELSEIF(IPIP.EQ.2)THEN
37441 IF(IP12.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
37443 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37447 C WRITE(6,*)' MGSQBS1 jump back from chain 6',
37448 C & CHAMAL,PHKT(5,6+IIGLU1)
37452 C IF(NUMEV.EQ.-324)THEN
37453 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
37454 * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
37455 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
37456 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
37457 * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
37458 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
37459 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
37460 * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
37461 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
37463 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
37464 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
37465 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
37466 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
37467 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
37468 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
37469 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
37470 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
37472 IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+3
37473 IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
37474 IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
37475 IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
37476 ELSEIF(IPIP.EQ.2)THEN
37477 IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3
37478 IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
37479 IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
37480 IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
37481 C WRITE(6,*)'IDHKT(7+IIGLU1),IPP1,ISQ1',IDHKT(7+IIGLU1),IPP1,ISQ1
37483 ISTHKT(7+IIGLU1) =931
37484 JMOHKT(1,7+IIGLU1)=NC2P
37485 JMOHKT(2,7+IIGLU1)=0
37486 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
37487 JDAHKT(2,7+IIGLU1)=0
37488 C create chain 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37489 PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
37490 PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
37491 PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
37492 PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
37493 C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
37494 C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
37495 IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
37497 C WRITE(6,*)'reject PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P)'
37502 C PHKT(5,7) =PHKK(5,NC2P)
37503 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
37504 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
37505 *PHKT(1,7+IIGLU1)**2)
37506 VHKT(1,7+IIGLU1) =VHKK(1,NC2P)
37507 VHKT(2,7+IIGLU1) =VHKK(2,NC2P)
37508 VHKT(3,7+IIGLU1) =VHKK(3,NC2P)
37509 VHKT(4,7+IIGLU1) =VHKK(4,NC2P)
37510 WHKT(1,7+IIGLU1) =WHKK(1,NC2P)
37511 WHKT(2,7+IIGLU1) =WHKK(2,NC2P)
37512 WHKT(3,7+IIGLU1) =WHKK(3,NC2P)
37513 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
37514 C Insert here the IIGLU2 gluons
37519 IF(IIGLU2.GE.1)THEN
37521 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37522 KKG=JJG+IIG-7-IIGLU1
37523 IDHKT(IIG) =IDHKK(KKG)
37527 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
37529 PHKT(1,IIG)=PHKK(1,KKG)
37530 PG1=PG1+ PHKT(1,IIG)
37531 PHKT(2,IIG)=PHKK(2,KKG)
37532 PG2=PG2+ PHKT(2,IIG)
37533 PHKT(3,IIG)=PHKK(3,KKG)
37534 PG3=PG3+ PHKT(3,IIG)
37535 PHKT(4,IIG)=PHKK(4,KKG)
37536 PG4=PG4+ PHKT(4,IIG)
37537 PHKT(5,IIG)=PHKK(5,KKG)
37538 VHKT(1,IIG) =VHKK(1,KKG)
37539 VHKT(2,IIG) =VHKK(2,KKG)
37540 VHKT(3,IIG) =VHKK(3,KKG)
37541 VHKT(4,IIG) =VHKK(4,KKG)
37542 WHKT(1,IIG) =WHKK(1,KKG)
37543 WHKT(2,IIG) =WHKK(2,KKG)
37544 WHKT(3,IIG) =WHKK(3,KKG)
37545 WHKT(4,IIG) =WHKK(4,KKG)
37548 IDHKT(8+IIGLU1+IIGLU2) =IP2
37549 ISTHKT(8+IIGLU1+IIGLU2) =932
37550 JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
37551 JMOHKT(2,8+IIGLU1+IIGLU2)=0
37552 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
37553 JDAHKT(2,8+IIGLU1+IIGLU2)=0
37554 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
37555 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
37556 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
37557 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
37558 C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T)
37559 XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
37560 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37561 *PHKT(1,8+IIGLU1+IIGLU2)**2)
37562 IF(XMIST.GT.0.D0)THEN
37563 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
37564 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37565 *PHKT(1,8+IIGLU1+IIGLU2)**2)
37567 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37568 PHKT(5,8+IIGLU1+IIGLU2)=0.D0
37570 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T)
37571 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T)
37572 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T)
37573 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T)
37574 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T)
37575 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T)
37576 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T)
37577 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T)
37578 IDHKT(9+IIGLU1+IIGLU2) =88888
37579 ISTHKT(9+IIGLU1+IIGLU2) =94
37580 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
37581 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
37582 JDAHKT(1,9+IIGLU1+IIGLU2)=0
37583 JDAHKT(2,9+IIGLU1+IIGLU2)=0
37584 PHKT(1,9+IIGLU1+IIGLU2)
37585 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
37586 PHKT(2,9+IIGLU1+IIGLU2)
37587 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
37588 PHKT(3,9+IIGLU1+IIGLU2)
37589 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
37590 PHKT(4,9+IIGLU1+IIGLU2)
37591 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
37593 *=(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37594 * -PHKT(2,9+IIGLU1+IIGLU2)**2
37595 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
37596 IF(XMIST.GE.0.D0)THEN
37597 PHKT(5,9+IIGLU1+IIGLU2)
37598 *=SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37599 * -PHKT(2,9+IIGLU1+IIGLU2)**2
37600 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
37602 C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37606 C IF(NUMEV.EQ.-324)THEN
37607 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
37608 * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
37609 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
37610 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37611 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
37612 & JMOHKT(1,IIG),JMOHKT(2,IIG),
37614 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37616 WRITE(LOUT,*)8+IIGLU1+IIGLU2,
37617 * ISTHKT(8+IIGLU1+IIGLU2),IDHKT(8+IIGLU1+IIGLU2),
37618 * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
37619 *JDAHKT(1,8+IIGLU1+IIGLU2),
37620 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
37621 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
37622 * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
37623 *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
37624 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
37628 IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
37629 ELSEIF(IPIP.EQ.2)THEN
37630 IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
37632 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
37636 C WRITE(6,*)' MGSQBS1 jump back from chain 9',
37637 C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
37640 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
37641 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
37642 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
37643 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
37644 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
37645 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
37646 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
37647 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
37650 IGCOUN=9+IIGLU1+IIGLU2
37654 *$ CREATE MGSQBS1.FOR
37657 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
37658 SUBROUTINE MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37659 * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,ISQ,IGCOUN)
37661 C GSQBS-1 diagram (split projectile diquark)
37663 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37666 PARAMETER ( LINP = 10 ,
37672 PARAMETER (NMXHKK=200000)
37674 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
37675 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
37676 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
37678 * extended event history
37679 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
37680 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37683 * Lorentz-parameters of the current interaction
37684 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37685 & UMO,PPCM,EPROJ,PPROJ
37687 * diquark-breaking mechanism
37688 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37691 PARAMETER (NTMHKK= 300)
37692 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37693 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37696 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37699 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37701 C GSQBS-1 diagram (split projectile diquark)
37704 C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
37705 C Input chain 2(NC2) sea-quark(NC2P)-valence-diquark(NC2T)
37707 C Create quark(qs)-antiquark(aqs) pair energy from NC1P and NC1T
37708 C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37710 C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
37711 C 6 valence quark(vq2P 4)-sea-quark(aqsP 5)
37712 C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37714 C Put new chains into COMMON /HKKTMP/
37719 C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
37721 NNNC1=IDHKK(NC1)/1000
37722 MMMC1=IDHKK(NC1)-NNNC1*1000
37724 NNNC2=IDHKK(NC2)/1000
37725 MMMC2=IDHKK(NC2)-NNNC2*1000
37729 WRITE(LOUT,*)' MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37730 * ' IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN)',
37731 *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37732 * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN
37737 C determine x-values of NC1P diquark
37738 XDIQP=PHKK(4,NC1P)*2.D0/UMO
37739 XVQT=PHKK(4,NC1T)*2.D0/UMO
37741 C determine x-values of sea quark pair
37747 IF(ICOU.GE.500)THEN
37750 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 Rejection 2234 ICOU. GT.100'
37754 IF(IPCO.GE.3)WRITE(LOUT,*)'MGSQBS1 call XSEAPA: UMO,XDIQP,XVQT ',
37759 C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37760 IF (IPIP.EQ.1) THEN
37761 XQMAX = XDIQP/2.0D0
37762 XAQMAX = 2.D0*XVQT/3.0D0
37764 XQMAX = 2.D0*XVQT/3.0D0
37765 XAQMAX = XDIQP/2.0D0
37767 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37769 C write(*,*) 'MGSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
37772 & WRITE(LOUT,*)'MGSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37775 & WRITE(LOUT,*)'MGSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37780 IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37781 ELSEIF(IPIP.EQ.2)THEN
37782 IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37785 WRITE(LOUT,'(A,4E12.4)')' MGSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
37786 & XDIQP,XVQT,XSQ,XSAQ
37789 C subtract xsq,xsaq from NC1P diquark and NC1T quark
37795 C IF (XDIQP.LT.0.0D0) WRITE(*,*) ' mgsqbs1: XDIQP<0!!',XDIQP
37798 ELSEIF(IPIP.EQ.2)THEN
37803 & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
37805 C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37810 IF(IVTHR.EQ.10)THEN
37813 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 3466 reject IVTHR 10'
37818 XVTHR=XVTHRO/(201-IVTHR)
37821 IF(XVTHR.GT.0.66D0*XDIQP)THEN
37825 & WRITE(LOUT,*)' MGSQBS1 Rejection 380 XVTHR large',
37830 IF(DT_RNDM(V).LT.0.5D0)THEN
37831 XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37834 XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37838 WRITE(LOUT,'(A,4E12.4)')' MGSQBS1:XVTHR,XDIQP,XVPQI,XVPQII ',
37839 & XVTHR,XDIQP,XVPQI,XVPQII
37842 C Prepare 4 momenta of new chains and chain ends
37844 C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37845 C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37847 C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
37848 C 6 valence quark(vq2P 4)-sea-quark(aqsP 5)
37849 C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37855 ELSEIF(IPIP.EQ.2)THEN
37862 C IDHKT(2) =1000*IPP21+100*IPP22+1
37866 IDHKT(4+IIGLU1) =IP12
37867 ISTHKT(4+IIGLU1) =921
37868 JMOHKT(1,4+IIGLU1)=NC1P
37869 JMOHKT(2,4+IIGLU1)=0
37870 JDAHKT(1,4+IIGLU1)=6+IIGLU1
37871 JDAHKT(2,4+IIGLU1)=0
37873 IF ((XDIQP.LT.0.0D0).OR.(XVPQII.LT.0.0D0).OR.
37874 & (XSQ1.LT.0.0D0)) WRITE(LOUT,*) ' mgsqbs1: ',XDIQP,XVPQII,XSQ1
37876 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
37877 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
37878 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
37879 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
37880 C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
37881 XXMIST=(PHKT(4,4+IIGLU1)**2-
37882 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37883 * PHKT(1,4+IIGLU1)**2)
37884 IF(XXMIST.GT.0.D0)THEN
37885 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
37887 WRITE(LOUT,*)'MGSQBS1 XXMIST',XXMIST
37889 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
37891 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
37892 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
37893 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
37894 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
37895 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
37896 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
37897 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
37898 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
37900 IDHKT(5+IIGLU1) =-(ISAQ1-6)
37901 ELSEIF(IPIP.EQ.2)THEN
37902 IDHKT(5+IIGLU1) =ISAQ1
37904 ISTHKT(5+IIGLU1) =922
37905 JMOHKT(1,5+IIGLU1)=NC1T
37906 JMOHKT(2,5+IIGLU1)=0
37907 JDAHKT(1,5+IIGLU1)=6+IIGLU1
37908 JDAHKT(2,5+IIGLU1)=0
37910 IF ((XSAQ1.LT.0.0D0).OR.(XVQT .LT.0.0D0))
37911 & WRITE(LOUT,*) ' mgsqbs2: ',XSAQ1,XVQT
37913 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
37914 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
37915 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
37916 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
37917 C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
37918 XMIST=(PHKT(4,5+IIGLU1)**2-
37919 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37920 *PHKT(1,5+IIGLU1)**2)
37921 IF(XMIST.GT.0.D0)THEN
37922 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
37923 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37924 *PHKT(1,5+IIGLU1)**2)
37926 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37927 PHKT(5,5+IIGLU1)=0.D0
37929 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
37930 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
37931 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
37932 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
37933 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
37934 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
37935 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
37936 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
37937 IDHKT(6+IIGLU1) =88888
37938 C IDHKT(6) =1000*NNNC1+MMMC1
37939 ISTHKT(6+IIGLU1) =93
37941 JMOHKT(1,6+IIGLU1)=4+IIGLU1
37942 JMOHKT(2,6+IIGLU1)=5+IIGLU1
37943 JDAHKT(1,6+IIGLU1)=0
37944 JDAHKT(2,6+IIGLU1)=0
37945 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37946 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37947 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37948 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37950 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37951 * -PHKT(3,6+IIGLU1)**2)
37954 IF(IP12.GE.3.OR.ISAQ.GE.9)CHAMAL=CHAM3
37955 ELSEIF(IPIP.EQ.2)THEN
37956 IF(IP12.LE.-3.OR.ISAQ.GE.3)CHAMAL=CHAM3
37958 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37959 IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
37960 C we drop chain 6 and give the energy to chain 3
37961 IDHKT(6+IIGLU1)=33888
37963 C WRITE(6,*)' drop chain 6 xgive=1'
37965 ELSEIF(IDHKT(5+IIGLU1).EQ.-IP11)THEN
37966 C we drop chain 6 and give the energy to chain 3
37967 C and change KK11 to IDHKT(4)
37968 IDHKT(6+IIGLU1)=33888
37970 C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(4+IIGLU1)'
37971 KK11=IDHKT(4+IIGLU1)
37973 ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP21)THEN
37974 C we drop chain 6 and give the energy to chain 3
37975 C and change KK21 to IDHKT(4)
37976 C IDHKT(2) =1000*IPP21+100*IPP22+1
37977 IDHKT(6+IIGLU1)=33888
37979 C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(4+IIGLU1)'
37980 KK21=IDHKT(4+IIGLU1)
37982 ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP22)THEN
37983 C we drop chain 6 and give the energy to chain 3
37984 C and change KK22 to IDHKT(4)
37985 C IDHKT(2) =1000*IPP21+100*IPP22+1
37986 IDHKT(6+IIGLU1)=33888
37988 C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(4+IIGLU1)'
37989 KK22=IDHKT(4+IIGLU1)
37995 C WRITE(6,*)' MGSQBS1 jump back from chain 6'
38000 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
38001 * JMOHKT(1,4+IIGLU1),
38002 * JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
38003 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
38004 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
38005 * JMOHKT(1,5+IIGLU1),
38006 * JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
38007 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
38008 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
38009 * JMOHKT(1,6+IIGLU1),
38010 * JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
38011 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
38013 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
38014 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
38015 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
38016 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
38017 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
38018 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
38019 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
38020 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
38026 JDAHKT(1,1)=3+IIGLU1
38028 PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
38029 C * +0.5D0*PHKK(1,NC2P)
38030 *+XGIVE*PHKT(1,4+IIGLU1)
38031 PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
38032 C * +0.5D0*PHKK(2,NC2P)
38033 *+XGIVE*PHKT(2,4+IIGLU1)
38034 PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
38035 C * +0.5D0*PHKK(3,NC2P)
38036 *+XGIVE*PHKT(3,4+IIGLU1)
38037 PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
38038 C * +0.5D0*PHKK(4,NC2P)
38039 *+XGIVE*PHKT(4,4+IIGLU1)
38040 C PHKT(5,1) =PHKK(5,NC1P)
38041 XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38043 IF(XMIST.GE.0.D0)THEN
38044 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38047 C WRITE(6,*)'MGSQBS1 parton 1 mass square LT.0 ',XMIST
38050 VHKT(1,1) =VHKK(1,NC1P)
38051 VHKT(2,1) =VHKK(2,NC1P)
38052 VHKT(3,1) =VHKK(3,NC1P)
38053 VHKT(4,1) =VHKK(4,NC1P)
38054 WHKT(1,1) =WHKK(1,NC1P)
38055 WHKT(2,1) =WHKK(2,NC1P)
38056 WHKT(3,1) =WHKK(3,NC1P)
38057 WHKT(4,1) =WHKK(4,NC1P)
38058 C Add here IIGLU1 gluons to this chaina
38063 IF(IIGLU1.GE.1)THEN
38065 DO 61 IIG=2,2+IIGLU1-1
38067 IDHKT(IIG) =IDHKK(KKG)
38071 JDAHKT(1,IIG)=3+IIGLU1
38073 PHKT(1,IIG)=PHKK(1,KKG)
38074 PG1=PG1+ PHKT(1,IIG)
38075 PHKT(2,IIG)=PHKK(2,KKG)
38076 PG2=PG2+ PHKT(2,IIG)
38077 PHKT(3,IIG)=PHKK(3,KKG)
38078 PG3=PG3+ PHKT(3,IIG)
38079 PHKT(4,IIG)=PHKK(4,KKG)
38080 PG4=PG4+ PHKT(4,IIG)
38081 PHKT(5,IIG)=PHKK(5,KKG)
38082 VHKT(1,IIG) =VHKK(1,KKG)
38083 VHKT(2,IIG) =VHKK(2,KKG)
38084 VHKT(3,IIG) =VHKK(3,KKG)
38085 VHKT(4,IIG) =VHKK(4,KKG)
38086 WHKT(1,IIG) =WHKK(1,KKG)
38087 WHKT(2,IIG) =WHKK(2,KKG)
38088 WHKT(3,IIG) =WHKK(3,KKG)
38089 WHKT(4,IIG) =WHKK(4,KKG)
38092 C IDHKT(2) =1000*IPP21+100*IPP22+1
38094 IDHKT(2+IIGLU1) =1000*KK21+100*KK22+3
38095 IF(IDHKT(2+IIGLU1).EQ.1203)IDHKT(2+IIGLU1)=2103
38096 IF(IDHKT(2+IIGLU1).EQ.1303)IDHKT(2+IIGLU1)=3103
38097 IF(IDHKT(2+IIGLU1).EQ.2303)IDHKT(2+IIGLU1)=3203
38098 ELSEIF(IPIP.EQ.2)THEN
38099 IDHKT(2+IIGLU1) =1000*KK21+100*KK22-3
38100 IF(IDHKT(2+IIGLU1).EQ.-1203)IDHKT(2+IIGLU1)=-2103
38101 IF(IDHKT(2+IIGLU1).EQ.-1303)IDHKT(2+IIGLU1)=-3103
38102 IF(IDHKT(2+IIGLU1).EQ.-2303)IDHKT(2+IIGLU1)=-3203
38104 ISTHKT(2+IIGLU1) =922
38105 JMOHKT(1,2+IIGLU1)=NC2T
38106 JMOHKT(2,2+IIGLU1)=0
38107 JDAHKT(1,2+IIGLU1)=3+IIGLU1
38108 JDAHKT(2,2+IIGLU1)=0
38109 PHKT(1,2+IIGLU1) =PHKK(1,NC2T)
38110 *+XGIVE*PHKT(1,5+IIGLU1)
38111 PHKT(2,2+IIGLU1) =PHKK(2,NC2T)
38112 *+XGIVE*PHKT(2,5+IIGLU1)
38113 PHKT(3,2+IIGLU1) =PHKK(3,NC2T)
38114 *+XGIVE*PHKT(3,5+IIGLU1)
38115 PHKT(4,2+IIGLU1) =PHKK(4,NC2T)
38116 *+XGIVE*PHKT(4,5+IIGLU1)
38117 C PHKT(5,2) =PHKK(5,NC2T)
38118 XMIST=(PHKT(4,2+IIGLU1)**2-
38119 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38120 *PHKT(1,2+IIGLU1)**2)
38121 IF(XMIST.GT.0.D0)THEN
38122 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
38123 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38124 *PHKT(1,2+IIGLU1)**2)
38126 C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
38127 PHKT(5,2+IIGLU1)=0.D0
38129 VHKT(1,2+IIGLU1) =VHKK(1,NC2T)
38130 VHKT(2,2+IIGLU1) =VHKK(2,NC2T)
38131 VHKT(3,2+IIGLU1) =VHKK(3,NC2T)
38132 VHKT(4,2+IIGLU1) =VHKK(4,NC2T)
38133 WHKT(1,2+IIGLU1) =WHKK(1,NC2T)
38134 WHKT(2,2+IIGLU1) =WHKK(2,NC2T)
38135 WHKT(3,2+IIGLU1) =WHKK(3,NC2T)
38136 WHKT(4,2+IIGLU1) =WHKK(4,NC2T)
38137 IDHKT(3+IIGLU1) =88888
38138 C IDHKT(3) =1000*NNNC1+MMMC1+10
38139 ISTHKT(3+IIGLU1) =93
38141 JMOHKT(1,3+IIGLU1)=1
38142 JMOHKT(2,3+IIGLU1)=2+IIGLU1
38143 JDAHKT(1,3+IIGLU1)=0
38144 JDAHKT(2,3+IIGLU1)=0
38145 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
38146 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
38147 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
38148 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
38150 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38151 * -PHKT(3,3+IIGLU1)**2)
38153 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
38155 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
38156 DO 71 IIG=2,2+IIGLU1-1
38157 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38158 & JMOHKT(1,IIG),JMOHKT(2,IIG),
38160 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38162 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),
38163 & IDHKT(2),JMOHKT(1,2+IIGLU1),
38164 * JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
38165 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
38166 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
38167 * JMOHKT(1,3+IIGLU1),
38168 * JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
38169 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
38173 C IF(IPIP.EQ.1)THEN
38174 C IF(IPP21.GE.3.OR.IPP22.GE.3.OR.IP11.GE.3)CHAMAL=CHAB3
38175 C ELSEIF(IPIP.EQ.2)THEN
38176 C IF(IPP21.LE.-3.OR.IPP22.LE.-3.OR.IP11.LE.-3)CHAMAL=CHAB3
38179 IF(KK21.GE.3.OR.KK22.GE.3.OR.KK11.GE.3)CHAMAL=CHAB3
38180 ELSEIF(IPIP.EQ.2)THEN
38181 IF(KK21.LE.-3.OR.KK22.LE.-3.OR.KK11.LE.-3)CHAMAL=CHAB3
38184 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
38188 C WRITE(6,*)' MGSQBS1 jump back from chain 3'
38191 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
38192 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
38193 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
38194 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
38195 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
38196 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
38197 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
38198 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
38200 IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ1+3
38201 IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
38202 IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
38203 IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
38204 ELSEIF(IPIP.EQ.2)THEN
38205 IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3
38206 IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
38207 IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
38208 IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
38209 C WRITE(6,*)'IDHKT(7),IPP1,ISQ1',IDHKT(7),IPP1,ISQ1
38211 ISTHKT(7+IIGLU1) =921
38212 JMOHKT(1,7+IIGLU1)=NC2P
38213 JMOHKT(2,7+IIGLU1)=0
38214 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
38215 JDAHKT(2,7+IIGLU1)=0
38216 C PHKT(1,7) =0.5D0*PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ/(XDIQP+XSQ)
38217 C PHKT(2,7) =0.5D0*PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ/(XDIQP+XSQ)
38218 C PHKT(3,7) =0.5D0*PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ/(XDIQP+XSQ)
38219 C PHKT(4,7+IIGLU1) =0.5D0*PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ/(XDIQP+XSQ)
38221 IF ((XSQ1 .LT.0.0D0).OR.(XDIQP .LT.0.0D0))
38222 & WRITE(LOUT,*) ' mgsqbs3: ',XSQ1,XDIQP
38224 PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
38225 PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
38226 PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
38227 PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
38228 C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
38229 C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
38230 IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
38232 C WRITE(6,*)'reject PHKT(4,7).GE. PHKK(4,NC1P)'
38237 C PHKT(5,7) =PHKK(5,NC2P)
38238 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
38239 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
38240 *PHKT(1,7+IIGLU1)**2)
38241 VHKT(1,7+IIGLU1) =VHKK(1,NC2P)
38242 VHKT(2,7+IIGLU1) =VHKK(2,NC2P)
38243 VHKT(3,7+IIGLU1) =VHKK(3,NC2P)
38244 VHKT(4,7+IIGLU1) =VHKK(4,NC2P)
38245 WHKT(1,7+IIGLU1) =WHKK(1,NC2P)
38246 WHKT(2,7+IIGLU1) =WHKK(2,NC2P)
38247 WHKT(3,7+IIGLU1) =WHKK(3,NC2P)
38248 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
38249 C Insert here the IIGLU2 gluons
38254 IF(IIGLU2.GE.1)THEN
38256 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38257 KKG=JJG+IIG-7-IIGLU1
38258 IDHKT(IIG) =IDHKK(KKG)
38262 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
38264 PHKT(1,IIG)=PHKK(1,KKG)
38265 PG1=PG1+ PHKT(1,IIG)
38266 PHKT(2,IIG)=PHKK(2,KKG)
38267 PG2=PG2+ PHKT(2,IIG)
38268 PHKT(3,IIG)=PHKK(3,KKG)
38269 PG3=PG3+ PHKT(3,IIG)
38270 PHKT(4,IIG)=PHKK(4,KKG)
38271 PG4=PG4+ PHKT(4,IIG)
38272 PHKT(5,IIG)=PHKK(5,KKG)
38273 VHKT(1,IIG) =VHKK(1,KKG)
38274 VHKT(2,IIG) =VHKK(2,KKG)
38275 VHKT(3,IIG) =VHKK(3,KKG)
38276 VHKT(4,IIG) =VHKK(4,KKG)
38277 WHKT(1,IIG) =WHKK(1,KKG)
38278 WHKT(2,IIG) =WHKK(2,KKG)
38279 WHKT(3,IIG) =WHKK(3,KKG)
38280 WHKT(4,IIG) =WHKK(4,KKG)
38283 IDHKT(8+IIGLU1+IIGLU2) =IP2
38284 ISTHKT(8+IIGLU1+IIGLU2) =922
38285 JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
38286 JMOHKT(2,8+IIGLU1+IIGLU2)=0
38287 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
38288 JDAHKT(2,8+IIGLU1+IIGLU2)=0
38290 IF ((XVQT.LT.0.0D0).OR.(XSAQ1 .LT.0.0D0))
38291 & WRITE(LOUT,*) ' mgsqbs4: ',XVQT,XSAQ1
38293 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
38294 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
38295 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
38296 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
38297 C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T)
38298 XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
38299 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38300 *PHKT(1,8+IIGLU1+IIGLU2)**2)
38301 IF(XMIST.GT.0.D0)THEN
38302 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
38303 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38304 *PHKT(1,8+IIGLU1+IIGLU2)**2)
38306 C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
38307 PHKT(5,8+IIGLU1+IIGLU2)=0.D0
38309 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T)
38310 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T)
38311 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T)
38312 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T)
38313 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T)
38314 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T)
38315 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T)
38316 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T)
38317 IDHKT(9+IIGLU1+IIGLU2) =88888
38318 C IDHKT(9) =1000*NNNC2+MMMC2+10
38319 ISTHKT(9+IIGLU1+IIGLU2) =93
38321 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
38322 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
38323 JDAHKT(1,9+IIGLU1+IIGLU2)=0
38324 JDAHKT(2,9+IIGLU1+IIGLU2)=0
38325 PHKT(1,9+IIGLU1+IIGLU2) =PHKT(1,7+IIGLU1)
38326 * +PHKT(1,8+IIGLU1+IIGLU2)+PG1
38327 PHKT(2,9+IIGLU1+IIGLU2) =PHKT(2,7+IIGLU1)
38328 * +PHKT(2,8+IIGLU1+IIGLU2)+PG2
38329 PHKT(3,9+IIGLU1+IIGLU2) =PHKT(3,7+IIGLU1)
38330 * +PHKT(3,8+IIGLU1+IIGLU2)+PG3
38331 PHKT(4,9+IIGLU1+IIGLU2) =PHKT(4,7+IIGLU1)
38332 * +PHKT(4,8+IIGLU1+IIGLU2)+PG4
38333 PHKT(5,9+IIGLU1+IIGLU2)
38334 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
38335 * PHKT(2,9+IIGLU1+IIGLU2)**2
38336 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
38338 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
38339 * JMOHKT(1,7+IIGLU1),
38340 * JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
38341 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
38342 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38343 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38344 & JMOHKT(1,IIG),JMOHKT(2,IIG),
38346 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38348 WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
38349 * IDHKT(8+IIGLU1+IIGLU2),
38350 * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
38351 * JDAHKT(1,8+IIGLU1+IIGLU2),
38352 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
38353 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
38354 * IDHKT(9+IIGLU1+IIGLU2),
38355 * JMOHKT(1,9+IIGLU1+IIGLU2),JMOHKT(2,9+IIGLU1+IIGLU2),
38356 * JDAHKT(1,9+IIGLU1+IIGLU2),
38357 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
38361 IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
38362 ELSEIF(IPIP.EQ.2)THEN
38363 IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
38365 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
38369 C WRITE(6,*)' MGSQBS1 jump back from chain 9',
38370 C & 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
38373 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
38374 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
38375 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
38376 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
38377 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
38378 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
38379 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
38380 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
38382 IGCOUN=9+IIGLU1+IIGLU2
38387 *$ CREATE HKKHKT.FOR
38390 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
38392 SUBROUTINE HKKHKT(I,J)
38393 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38398 PARAMETER (NMXHKK=200000)
38400 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38401 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38402 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38404 * extended event history
38405 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38406 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38409 PARAMETER (NTMHKK= 300)
38410 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38411 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38414 ISTHKK(I) =ISTHKT(J)
38416 C IF(J.EQ.3.OR.J.EQ.6.OR.J.EQ.9)THEN
38417 IF(IDHKK(I).EQ.88888)THEN
38420 JMOHKK(1,I)=I-(J-JMOHKT(1,J))
38421 JMOHKK(2,I)=I-(J-JMOHKT(2,J))
38423 JMOHKK(1,I)=JMOHKT(1,J)
38424 JMOHKK(2,I)=JMOHKT(2,J)
38426 JDAHKK(1,I)=JDAHKT(1,J)
38427 JDAHKK(2,I)=JDAHKT(2,J)
38428 C IF(J.EQ.1.OR.J.EQ.4.OR.J.EQ.7)THEN
38430 C ELSEIF(J.EQ.2.OR.J.EQ.5.OR.J.EQ.8)THEN
38433 IF(JDAHKT(1,J).GT.0)THEN
38434 JDAHKK(1,I)=I+(JDAHKT(1,J)-J)
38436 PHKK(1,I) =PHKT(1,J)
38437 PHKK(2,I) =PHKT(2,J)
38438 PHKK(3,I) =PHKT(3,J)
38439 PHKK(4,I) =PHKT(4,J)
38440 PHKK(5,I) =PHKT(5,J)
38441 VHKK(1,I) =VHKT(1,J)
38442 VHKK(2,I) =VHKT(2,J)
38443 VHKK(3,I) =VHKT(3,J)
38444 VHKK(4,I) =VHKT(4,J)
38445 WHKK(1,I) =WHKT(1,J)
38446 WHKK(2,I) =WHKT(2,J)
38447 WHKK(3,I) =WHKT(3,J)
38448 WHKK(4,I) =WHKT(4,J)
38452 *$ CREATE DT_DBREAK.FOR
38455 *===dbreak=============================================================*
38457 SUBROUTINE DT_DBREAK(MODE)
38459 ************************************************************************
38460 * This is the steering subroutine for the different diquark breaking *
38463 * MODE = 1 breaking of projectile diquark in qq-q chain using *
38464 * a sea quark (q-qq chain) of the same projectile *
38465 * = 2 breaking of target diquark in q-qq chain using *
38466 * a sea quark (qq-q chain) of the same target *
38467 * = 3 breaking of projectile diquark in qq-q chain using *
38468 * a sea quark (q-aq chain) of the same projectile *
38469 * = 4 breaking of target diquark in q-qq chain using *
38470 * a sea quark (aq-q chain) of the same target *
38471 * = 5 breaking of projectile anti-diquark in aqaq-aq chain using *
38472 * a sea anti-quark (aq-aqaq chain) of the same projectile *
38473 * = 6 breaking of target anti-diquark in aq-aqaq chain using *
38474 * a sea anti-quark (aqaq-aq chain) of the same target *
38475 * = 7 breaking of projectile anti-diquark in aqaq-aq chain using *
38476 * a sea anti-quark (aq-q chain) of the same projectile *
38477 * = 8 breaking of target anti-diquark in aq-aqaq chain using *
38478 * a sea anti-quark (q-aq chain) of the same target *
38480 * Original version by J. Ranft. *
38481 * This version dated 17.5.00 is written by S. Roesler. *
38482 ************************************************************************
38484 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38487 PARAMETER ( LINP = 10 ,
38493 PARAMETER (NMXHKK=200000)
38495 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38496 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38497 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38499 * extended event history
38500 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38501 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38504 * flags for input different options
38505 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
38506 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
38507 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
38509 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
38510 PARAMETER (MAXCHN=10000)
38511 COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
38513 * diquark-breaking mechanism
38514 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
38516 * flags for particle decays
38517 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
38518 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
38519 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
38522 * chain identifiers
38523 * ( 1 = q-aq, 2 = aq-q, 3 = q-qq, 4 = qq-q,
38524 * 5 = aq-adq, 6 = adq-aq, 7 = dq-adq, 8 = adq-dq )
38525 DIMENSION IDCHN1(8),IDCHN2(8)
38526 DATA IDCHN1 / 4, 3, 4, 3, 6, 5, 6, 5/
38527 DATA IDCHN2 / 3, 4, 1, 2, 5, 6, 2, 1/
38529 * parton identifiers
38530 * ( +-21/22 = valence, +-31/32 = Glauber-sea, +-41/42 = Pomeron (diff),
38531 * +-51/52 = unitarity-sea, +-61/62 = gluons )
38532 DIMENSION ISP1P(8,3),ISP1T(8,3),ISP2P(8,3),ISP2T(8,3)
38533 DATA ISP1P / 21, 21, 21, 21, 21, 21, 21, 21,
38534 & 31, 31, 31, 31, 31, 31, 31, 31,
38535 & 41, 41, 41, 41, 51, 51, 51, 51/
38536 DATA ISP1T / 22, 22, 22, 22, 22, 22, 22, 22,
38537 & 32, 32, 32, 32, 32, 32, 32, 32,
38538 & 42, 42, 42, 42, 52, 52, 52, 52/
38539 DATA ISP2P / 31, 21, 31, 31, 21, 21, 21, 21,
38540 & 51, 31, 41, 41, 31, 31, 31, 31,
38541 & 0, 41, 51, 51, 51, 51, 51, 51/
38542 DATA ISP2T / 22, 32, 32, 32, 22, 22, 22, 22,
38543 & 32, 52, 42, 42, 32, 32, 32, 32,
38544 & 42, 0, 52, 52, 52, 52, 52, 52/
38546 IF (NCHAIN.LE.0) RETURN
38549 IS1P = ABS(ISTHKK(JMOHKK(1,IDX1)))
38550 IS1T = ABS(ISTHKK(JMOHKK(2,IDX1)))
38551 IF ( (IDXCHN(2,I).EQ.IDCHN1(MODE))
38553 & ((IS1P.EQ.ISP1P(MODE,1)).OR.(IS1P.EQ.ISP1P(MODE,2)).OR.
38554 & (IS1P.EQ.ISP1P(MODE,3)))
38556 & ((IS1T.EQ.ISP1T(MODE,1)).OR.(IS1T.EQ.ISP1T(MODE,2)).OR.
38557 & (IS1T.EQ.ISP1T(MODE,3)))
38561 IS2P = ABS(ISTHKK(JMOHKK(1,IDX2)))
38562 IS2T = ABS(ISTHKK(JMOHKK(2,IDX2)))
38563 IF ( (IDXCHN(2,J).EQ.IDCHN2(MODE))
38565 & ((IS2P.EQ.ISP2P(MODE,1)).OR.(IS2P.EQ.ISP2P(MODE,2))
38566 & .OR.(IS2P.EQ.ISP2P(MODE,3)))
38568 & ((IS2T.EQ.ISP2T(MODE,1)).OR.(IS2T.EQ.ISP2T(MODE,2))
38569 & .OR.(IS2T.EQ.ISP2T(MODE,3)))
38571 * find mother nucleons of the diquark to be splitted and of the
38572 * sea-quark and reject this combination if it is not the same
38573 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.
38574 & (MODE.EQ.5).OR.(MODE.EQ.7)) THEN
38579 IDXMO1 = JMOHKK(IANCES,IDX1)
38581 IF ((JMOHKK(1,IDXMO1).NE.0).AND.
38582 & (JMOHKK(2,IDXMO1).NE.0)) THEN
38587 IF (JMOHKK(IANC,IDXMO1).NE.0) THEN
38588 IDXMO1 = JMOHKK(IANC,IDXMO1)
38591 IDXMO2 = JMOHKK(IANCES,IDX2)
38593 IF ((JMOHKK(1,IDXMO2).NE.0).AND.
38594 & (JMOHKK(2,IDXMO2).NE.0)) THEN
38599 IF (JMOHKK(IANC,IDXMO2).NE.0) THEN
38600 IDXMO2 = JMOHKK(IANC,IDXMO2)
38603 IF (IDXMO1.NE.IDXMO2) GOTO 2
38604 * quark content of projectile parton
38605 IP1 = IDHKK(JMOHKK(1,IDX1))
38607 IP12 = (IP1-1000*IP11)/100
38608 IP2 = IDHKK(JMOHKK(2,IDX1))
38610 IP22 = (IP2-1000*IP21)/100
38611 * quark content of target parton
38612 IT1 = IDHKK(JMOHKK(1,IDX2))
38614 IT12 = (IT1-1000*IT11)/100
38615 IT2 = IDHKK(JMOHKK(2,IDX2))
38617 IT22 = (IT2-1000*IT21)/100
38618 * split diquark and form new chains
38619 IF (MODE.EQ.1) THEN
38620 IF (IT1.EQ.4) GOTO 2
38621 CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38622 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38623 & IP11,IP12,IP2,IT1,IT21,IT22,1,IPQ,IGCOUN)
38624 ELSEIF (MODE.EQ.2) THEN
38625 IF (IT2.EQ.4) GOTO 2
38626 CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38627 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38628 & IP1,IP21,IP22,IT11,IT12,IT2,1,IPQ,IGCOUN)
38629 ELSEIF (MODE.EQ.3) THEN
38630 IF (IT1.EQ.4) GOTO 2
38631 CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38632 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38633 & IP11,IP12,IP2,IT1,IT2,1,IPQ,IGCOUN)
38634 ELSEIF (MODE.EQ.4) THEN
38635 IF (IT2.EQ.4) GOTO 2
38636 CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38637 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38638 & IP1,IP21,IP22,IT1,IT2,1,IPQ,IGCOUN)
38639 ELSEIF (MODE.EQ.5) THEN
38640 CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38641 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38642 & IP11,IP12,IP2,IT1,IT21,IT22,2,IPQ,IGCOUN)
38643 ELSEIF (MODE.EQ.6) THEN
38644 CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38645 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38646 & IP1,IP21,IP22,IT11,IT12,IT2,2,IPQ,IGCOUN)
38647 ELSEIF (MODE.EQ.7) THEN
38648 CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38649 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38650 & IP11,IP12,IP2,IT1,IT2,2,IPQ,IGCOUN)
38651 ELSEIF (MODE.EQ.8) THEN
38652 CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38653 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38654 & IP1,IP21,IP22,IT1,IT2,2,IPQ,IGCOUN)
38656 IF (IREJ.GE.1) THEN
38657 if ((ipq.lt.0).or.(ipq.ge.4))
38658 & write(LOUT,*) 'ipq !!!',ipq,mode
38659 DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
38660 * accept or reject new chains corresponding to PDBSEA
38662 IF ((IPQ.EQ.1).OR.(IPQ.EQ.2)) THEN
38663 ACC = DBRKA(1,MODE)+DBRKA(2,MODE)
38664 REJ = DBRKR(1,MODE)+DBRKR(2,MODE)
38665 ELSEIF (IPQ.EQ.3) THEN
38666 ACC = DBRKA(3,MODE)
38667 REJ = DBRKR(3,MODE)
38669 WRITE(LOUT,*) ' inconsistent IPQ ! ',IPQ
38672 IF (ACC/(ACC+REJ).LE.PDBSEA(IPQ)) THEN
38673 DBRKA(IPQ,MODE) = DBRKA(IPQ,MODE)+1.0D0
38676 DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
38679 * new chains have been accepted and are now copied into HKKEVT
38680 IF (IACC.EQ.1) THEN
38682 CALL DT_EVTEMC(PHKK(1,IDX1),PHKK(2,IDX1),
38683 & PHKK(3,IDX1),PHKK(4,IDX1),
38685 CALL DT_EVTEMC(PHKK(1,IDX2),PHKK(2,IDX2),
38686 & PHKK(3,IDX2),PHKK(4,IDX2),
38689 IDHKK(IDX1) = 99888
38690 IDHKK(IDX2) = 99888
38695 CALL HKKHKT(NHKK,K)
38696 IF ((LEMCCK).AND.(IDHKK(NHKK).EQ.88888))THEN
38701 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
38706 CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,9000,
38708 IF (IREJ.NE.0) CALL DT_EVTOUT(4)
38720 *$ CREATE DT_CQPAIR.FOR
38723 *===cqpair=============================================================*
38725 SUBROUTINE DT_CQPAIR(XQMAX,XAQMAX,XQ,XAQ,IFLV,IREJ)
38727 ************************************************************************
38728 * This subroutine Creates a Quark-antiquark PAIR from the sea. *
38730 * XQMAX maxium energy fraction of quark (input) *
38731 * XAQMAX maxium energy fraction of antiquark (input) *
38732 * XQ energy fraction of quark (output) *
38733 * XAQ energy fraction of antiquark (output) *
38734 * IFLV quark flavour (- antiquark flavor) (output) *
38736 * This version dated 14.5.00 is written by S. Roesler. *
38737 ************************************************************************
38739 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38742 PARAMETER ( LINP = 10 ,
38746 * Lorentz-parameters of the current interaction
38747 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
38748 & UMO,PPCM,EPROJ,PPROJ
38755 * sample quark flavour
38757 * set seasq here (the one from DTCHAI should be used in the future)
38759 IFLV = INT(1.0D0+DT_RNDM(XQMAX)*(2.0D0+SEASQ))
38761 * sample energy fractions of sea pair
38762 * we first sample the energy fraction of a gluon and then split the gluon
38764 * maximum energy fraction of the gluon forced via input
38765 XGMAXI = XQMAX+XAQMAX
38766 * minimum energy fraction of the gluon
38767 XTHR1 = 4.0D0 /UMO**2
38768 XTHR2 = 0.54D0/UMO**1.5D0
38769 XGMIN = MAX(XTHR1,XTHR2)
38770 * maximum energy fraction of the gluon
38772 XGMAX = MIN(XGMAXI,XGMAX)
38773 IF (XGMIN.GE.XGMAX) THEN
38778 * sample energy fraction of the gluon
38782 IF (NLOOP.GE.50) THEN
38786 XGLUON = DT_SAMSQX(XGMIN,XGMAX)
38787 EGLUON = XGLUON*UMO/2.0D0
38789 * split gluon into q-aq pair (we follow PHOJET's subroutine PHO_GLU2QU)
38790 ZMIN = MIN(0.1D0,0.5D0/EGLUON)
38793 XHLP = ((1.0D0-RZ)*ZMIN**3+RZ*ZMAX**3)**0.33333
38795 IF (RQ.LT.0.5D0) THEN
38802 IF ((XQ.GT.XQMAX).OR.(XAQ.GT.XAQMAX)) GOTO 1