4 * +-------------------------------------------------------------+
10 * | S. Roesler+), R. Engel#), J. Ranft*) |
13 * | CH-1211 Geneva 23, Switzerland |
14 * | Email: Stefan.Roesler@cern.ch |
16 * | #) Institut fuer Kernphysik |
17 * | Forschungszentrum Karlsruhe |
18 * | D-76021 Karlsruhe, Germany |
20 * | *) University of Siegen, Dept. of Physics |
21 * | D-57068 Siegen, Germany |
24 * | http://home.cern.ch/sroesler/dpmjet3.html |
27 * | Monte Carlo models used for event generation: |
28 * | PHOJET 1.12, JETSET 7.4 and LEPTO 6.5.1 |
30 * +-------------------------------------------------------------+
33 *===init===============================================================*
35 SUBROUTINE DT_INIT(NCASES,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
38 ************************************************************************
39 * Initialization of event generation *
40 * This version dated 7.4.98 is written by S. Roesler. *
42 * Last change 27.12.2006 by S. Roesler. *
43 ************************************************************************
45 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
48 PARAMETER ( LINP = 10 ,
51 PARAMETER (ZERO=0.0D0,ONE=1.0D0)
53 * particle properties (BAMJET index convention)
55 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
56 & IICH(210),IIBAR(210),K1(210),K2(210)
58 * names of hadrons used in input-cards
60 COMMON /DTPAIN/ BTYPE(30)
63 * DIMPAR taken from FLUKA
64 PARAMETER ( MXXRGN =20000 )
65 PARAMETER ( MXXMDF = 710 )
66 PARAMETER ( MXXMDE = 702 )
67 PARAMETER ( MFSTCK =40000 )
68 PARAMETER ( MESTCK = 100 )
69 PARAMETER ( MOSTCK = 2000 )
70 PARAMETER ( MXPRSN = 100 )
71 PARAMETER ( MXPDPM = 800 )
72 PARAMETER ( MXPSCS =30000 )
73 PARAMETER ( MXGLWN = 300 )
74 PARAMETER ( MXOUTU = 50 )
75 PARAMETER ( NALLWP = 64 )
76 PARAMETER ( NELEMX = 80 )
77 PARAMETER ( MPDPDX = 18 )
78 PARAMETER ( MXHTTR = 260 )
79 PARAMETER ( MXSEAX = 20 )
80 PARAMETER ( MXHTNC = MXSEAX + 1 )
81 PARAMETER ( ICOMAX = 2400 )
82 PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
83 PARAMETER ( NSTBIS = 304 )
84 PARAMETER ( NQSTIS = 46 )
85 PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
86 PARAMETER ( MXPABL = 120 )
87 PARAMETER ( IDMAXP = 450 )
88 PARAMETER ( IDMXDC = 2000 )
89 PARAMETER ( MXMCIN = 410 )
90 PARAMETER ( IHYPMX = 4 )
91 PARAMETER ( MKBMX1 = 11 )
92 PARAMETER ( MKBMX2 = 11 )
93 PARAMETER ( MXIRRD = 2500 )
94 PARAMETER ( MXTRDC = 1500 )
95 PARAMETER ( NKTL = 17 )
96 PARAMETER ( NBLNMX = 40000000 )
99 * PAREVT taken from FLUKA
100 PARAMETER ( FRDIFF = 0.2D+00 )
101 PARAMETER ( ETHSEA = 1.0D+00 )
103 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
104 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
105 & LNUCRI, LPEANU, LEVBME, LPHDRC, LATMSS, LISMRS, LCHDCY,
106 & LCHDCR, LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
107 COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
108 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
109 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
110 & LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LEVBME,
111 & LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR,
112 & LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
115 * EVAFLG taken from FLUKA
116 LOGICAL LOLDEV, LUFULL, LNWLOW, LASMEN, LGMCMP, LGDRFT, LDSCLV,
117 & LDSCGM, LNDSLD, LMNJPR, LBRPEN, LNWBRP, LIFKEY, LOLDSM,
118 & LNAIPR, LGUSPR, LFLKCO, LLVMOD, LHVEVP, LHVECN, LHVCAL,
119 & LHVRAL, LHVSGF, LTMCRR, LBZZCR, LQCSKP, LEEXLV, LGEXLV
120 COMMON / EVAFLG / BRPNFR (0:2), EBRPFR (0:2), EMVBRP (0:2),
122 & ILVMOD, JLVMOD, JSIPFL, IMSSFR, JMSSFR, IEVFSS, MXAHEV,
123 & MXZHEV, IFHVFL, IFKYMX, IGMCMP, MPMODE, MSMODE, MUMODE,
124 & MFMODE, MEMODE, MRMODE, ITMCRR, IASYCR, IFSBCR, IFSSBR,
125 & LOLDEV, LUFULL, LNWLOW, LASMEN, LGMCMP, LGDRFT, LDSCLV,
126 & LDSCGM, LNDSLD, LMNJPR, LBRPEN, LNWBRP, LIFKEY, LOLDSM,
127 & LNAIPR, LGUSPR, LFLKCO, LLVMOD, LHVEVP, LHVECN, LHVCAL,
128 & LHVRAL, LHVSGF, LTMCRR, LBZZCR, LQCSKP, LEEXLV, LGEXLV
131 * FRBKCM taken from FLUKA
132 * Maximum number of fragments to be emitted:
133 PARAMETER ( MXFFBK = 6 )
134 PARAMETER ( MXZFBK = 10 )
135 PARAMETER ( MXNFBK = 12 )
136 PARAMETER ( MXAFBK = 16 )
137 PARAMETER ( MXASST = 25 )
138 PARAMETER ( NXAFBK = MXAFBK + 1 )
139 PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 + MXASST - NXAFBK )
140 PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 + MXASST - NXAFBK )
141 PARAMETER ( MXPSST = 700 )
142 * Maximum number of pre-computed break-up combinations
143 PARAMETER ( MXPPFB = 42500 )
144 * Maximum number of break-up combinations, including special
146 PARAMETER ( MXPSFB = 43000 )
147 * Base for J multiplicity encoding:
148 PARAMETER ( IBFRBK = 73 )
149 * Maximum Ibfrbk exponent to avoid overflow of I*4(roughly at 2.1x10^9)
150 * it must be (Ibfrbk-1) + (Ibfrbk-1)*Ibfrbk + (Ibfrbk-1)*Ibfrbk^2 + ...
151 * ... + (Ibfrbk-1)*Ibfrbk^Jpwfbx < 2100000000,
152 * --> Ibfrbk^(Jpwfbx+1) < 2100000000
153 PARAMETER ( JPWFBX = 4 )
154 LOGICAL LFRMBK, LNCMSS
155 COMMON / FRBKCM / AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
156 & WEIFBK (MXPSST), GAMFBK (MXPSST), EXFRBK (MXPSFB),
157 & SDMFBK (MXPSFB), COUFBK (MXPSFB), CENFBK (MXPSFB),
158 & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK, FRBKLS,
159 & IFRBKN (MXPSST), IFRBKZ (MXPSST),
160 & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
161 & IPSIND (0:NXNFBK,0:NXZFBK,2), JPSIND (0:MXASST),
162 & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
163 & IFBCHA (9,MXPSFB), IPOSST, IPOSFB, IFBSTF, IFBPSF,
164 & IFBFRB, IFBCHN, IFBNC1, IFBNC2, NBUFBK, LFRMBK, LNCMSS
165 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
168 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
171 * Glauber formalism: parameters
172 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
173 & BMAX(NCOMPX),BSTEP(NCOMPX),
174 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
177 * Glauber formalism: cross sections
178 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
179 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
180 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
181 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
182 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
183 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
184 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
185 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
186 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
187 & BSLOPE,NEBINI,NQBINI
189 * interface HADRIN-DPM
190 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
192 * central particle production, impact parameter biasing
193 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
195 * parameter for intranuclear cascade
197 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
199 * various options for treatment of partons (DTUNUC 1.x)
200 * (chain recombination, Cronin,..)
201 LOGICAL LCO2CR,LINTPT
202 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
205 * threshold values for x-sampling (DTUNUC 1.x)
206 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
209 * flags for input different options
210 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
211 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
212 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
216 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
217 & EBINDP(2),EBINDN(2),EPOT(2,210),
218 & ETACOU(2),ICOUL,LFERMI
220 * n-n cross section fluctuations
221 PARAMETER (NBINS = 1000)
222 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
224 * flags for particle decays
225 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
226 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
227 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
229 * diquark-breaking mechanism
230 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
232 * nucleon-nucleon event-generator
235 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
237 * properties of interacting particles
238 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
240 * properties of photon/lepton projectiles
241 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
243 * flags for diffractive interactions (DTUNUC 1.x)
244 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
246 * parameters for hA-diffraction
247 COMMON /DTDIHA/ DIBETA,DIALPH
249 * Lorentz-parameters of the current interaction
250 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
251 & UMO,PPCM,EPROJ,PPROJ
253 * kinematical cuts for lepton-nucleus interactions
254 COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
255 & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
257 * VDM parameter for photon-nucleus interactions
258 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
260 * Glauber formalism: flags and parameters for statistics
263 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
265 * cuts for variable energy runs
266 COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
268 * flags for activated histograms
269 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
271 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
272 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
275 **LUND single / double precision
276 REAL CUT,PARL,TMPX,TMPY,TMPW2,TMPQ2,TMPU
277 COMMON /LEPTOU/ CUT(14),LST(40),PARL(30),
278 & TMPX,TMPY,TMPW2,TMPQ2,TMPU
282 COMMON /LEPTOI/ RPPN,LEPIN,INTER
284 * steering flags for qel neutrino scattering modules
285 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
288 COMMON /DTEVNO/ NEVENT,ICASCA
293 DIMENSION XDUMB(40),IPRANG(5)
295 PARAMETER (MXCARD=58)
296 CHARACTER*78 CLINE,CTITLE
298 CHARACTER*8 BLANK,SDUM
299 CHARACTER*10 CODE,CODEWD
301 LOGICAL LSTART,LEINP,LXSTAB
302 DIMENSION WHAT(6),CODE(MXCARD)
304 & 'TITLE ','PROJPAR ','TARPAR ','ENERGY ',
305 & 'MOMENTUM ','CMENERGY ','EMULSION ','FERMI ',
306 & 'TAUFOR ','PAULI ','COULOMB ','HADRIN ',
307 & 'EVAP ','EMCCHECK ','MODEL ','PHOINPUT ',
308 & 'GLAUBERI ','FLUCTUAT ','CENTRAL ','RECOMBIN ',
309 & 'COMBIJET ','XCUTS ','INTPT ','CRONINPT ',
310 & 'SEADISTR ','SEASU3 ','DIQUARKS ','RESONANC ',
311 & 'DIFFRACT ','SINGLECH ','NOFRAGME ','HADRONIZE ',
312 & 'POPCORN ','PARDECAY ','BEAM ','LUND-MSTU ',
313 & 'LUND-MSTJ ','LUND-MDCY ','LUND-PARJ ','LUND-PARU ',
314 & 'OUTLEVEL ','FRAME ','L-TAG ','L-ETAG ',
315 & 'ECMS-CUT ','VDM-PAR1 ','HISTOGRAM ','XS-TABLE ',
316 & 'GLAUB-PAR ','GLAUB-INI ','VDM-PAR2 ','XS-QELPRO ',
317 & 'RNDMINIT ','LEPTO-CUT ','LEPTO-LST ','LEPTO-PARL',
321 DATA LSTART,LXSTAB,IFIRST /.TRUE.,.FALSE.,1/
324 *---------------------------------------------------------------------
325 * at the first call of INIT: initialize event generation
329 * initialization and test of the random number generator
330 IF (ITRSPT.NE.1) THEN
336 CALL RNINIT (INSEED,IJKLIN,ISEED1,ISEED2)
339 * initialization of BAMJET, DECAY and HADRIN
344 * set default values for input variables
345 CALL DT_DEFAUL(EPN,PPN)
348 * flag for collision energy input
353 *---------------------------------------------------------------------
356 * bypass reading input cards (e.g. for use with Fluka)
357 * in this case Epn is expected to carry the beam momentum
358 IF (NCASES.EQ.-1) THEN
372 * read control card from input-unit LINP
373 READ(LINP,'(A78)',END=9999) CLINE
374 IF (CLINE(1:1).EQ.'*') THEN
376 WRITE(LOUT,'(A78)') CLINE
379 C READ(CLINE,1000,END=9999) CODEWD,(WHAT(I),I=1,6),SDUM
380 C1000 FORMAT(A10,6E10.0,A8)
384 READ(CLINE,1006,END=9999) CODEWD,CWHAT,SDUM
385 1006 FORMAT(A10,A60,A8)
386 READ(CWHAT,*,END=1007) (WHAT(I),I=1,6)
388 WRITE(LOUT,1001) CODEWD,(WHAT(I),I=1,6),SDUM
389 1001 FORMAT(A10,6G10.3,A8)
393 * check for valid control card and get card index
396 IF (CODEWD.EQ.CODE(I)) ICW = I
399 WRITE(LOUT,1002) CODEWD
400 1002 FORMAT(/,1X,'---> ',A10,': invalid control-card !',/)
405 *------------------------------------------------------------
406 * TITLE , PROJPAR , TARPAR , ENERGY , MOMENTUM,
407 & 100 , 110 , 120 , 130 , 140 ,
409 *------------------------------------------------------------
410 * CMENERGY, EMULSION, FERMI , TAUFOR , PAULI ,
411 & 150 , 160 , 170 , 180 , 190 ,
413 *------------------------------------------------------------
414 * COULOMB , HADRIN , EVAP , EMCCHECK, MODEL ,
415 & 200 , 210 , 220 , 230 , 240 ,
417 *------------------------------------------------------------
418 * PHOINPUT, GLAUBERI, FLUCTUAT, CENTRAL , RECOMBIN,
419 & 250 , 260 , 270 , 280 , 290 ,
421 *------------------------------------------------------------
422 * COMBIJET, XCUTS , INTPT , CRONINPT, SEADISTR,
423 & 300 , 310 , 320 , 330 , 340 ,
425 *------------------------------------------------------------
426 * SEASU3 , DIQUARKS, RESONANC, DIFFRACT, SINGLECH,
427 & 350 , 360 , 370 , 380 , 390 ,
429 *------------------------------------------------------------
430 * NOFRAGME, HADRONIZE, POPCORN , PARDECAY, BEAM ,
431 & 400 , 410 , 420 , 430 , 440 ,
433 *------------------------------------------------------------
434 * LUND-MSTU, LUND-MSTJ, LUND-MDCY, LUND-PARJ, LUND-PARU,
435 & 450 , 451 , 452 , 460 , 470 ,
437 *------------------------------------------------------------
438 * OUTLEVEL, FRAME , L-TAG , L-ETAG , ECMS-CUT,
439 & 480 , 490 , 500 , 510 , 520 ,
441 *------------------------------------------------------------
442 * VDM-PAR1, HISTOGRAM, XS-TABLE , GLAUB-PAR, GLAUB-INI,
443 & 530 , 540 , 550 , 560 , 565 ,
445 *------------------------------------------------------------
446 * , , VDM-PAR2, XS-QELPRO, RNDMINIT ,
449 *------------------------------------------------------------
450 * LEPTO-CUT, LEPTO-LST,LEPTO-PARL, START , STOP )
451 & 600 , 610 , 620 , 630 , 640 ) , ICW
453 *------------------------------------------------------------
457 *********************************************************************
459 * control card: codewd = TITLE *
461 * what (1..6), sdum no meaning *
463 * Note: The control-card following this must consist of *
464 * a string of characters usually giving the title of *
467 *********************************************************************
470 READ(LINP,'(A78)') CTITLE
471 WRITE(LOUT,'(//,5X,A78,//)') CTITLE
474 *********************************************************************
476 * control card: codewd = PROJPAR *
478 * what (1) = mass number of projectile nucleus default: 1 *
479 * what (2) = charge of projectile nucleus default: 1 *
480 * what (3..6) no meaning *
481 * sdum projectile particle code word *
483 * Note: If sdum is defined what (1..2) have no meaning. *
485 *********************************************************************
488 IF (SDUM.EQ.BLANK) THEN
496 IF (SDUM.EQ.BTYPE(II)) THEN
501 ELSEIF (II.EQ.27) THEN
503 ELSEIF (II.EQ.28) THEN
505 ELSEIF (II.EQ.29) THEN
510 IBPROJ = IIBAR(IJPROJ)
512 IF ((IJPROJ.EQ.7).AND.(WHAT(1).GT.ZERO)) VIRT = WHAT(1)
514 IF (((IJPROJ.EQ. 3).OR.(IJPROJ.EQ. 4).OR.
515 & (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11)).AND.
516 & (WHAT(1).GT.ZERO)) Q2HI = WHAT(1)
519 IF (IJPROJ.EQ.0) THEN
521 1110 FORMAT(/,1X,'invalid PROJPAR card !',/)
527 *********************************************************************
529 * control card: codewd = TARPAR *
531 * what (1) = mass number of target nucleus default: 1 *
532 * what (2) = charge of target nucleus default: 1 *
533 * what (3..6) no meaning *
534 * sdum target particle code word *
536 * Note: If sdum is defined what (1..2) have no meaning. *
538 *********************************************************************
541 IF (SDUM.EQ.BLANK) THEN
549 IF (SDUM.EQ.BTYPE(II)) THEN
553 IBTARG = IIBAR(IJTARG)
556 IF (IJTARG.EQ.0) THEN
558 1120 FORMAT(/,1X,'invalid TARPAR card !',/)
564 *********************************************************************
566 * control card: codewd = ENERGY *
568 * what (1) = energy (GeV) of projectile in Lab. *
569 * if what(1) < 0: |what(1)| = kinetic energy *
571 * if |what(2)| > 0: min. energy for variable *
573 * what (2) = max. energy for variable energy runs *
574 * if what(2) < 0: |what(2)| = kinetic energy *
576 *********************************************************************
582 IF ((ABS(WHAT(2)).GT.ZERO).AND.
583 & (ABS(WHAT(2)).GT.ABS(WHAT(1)))) THEN
591 *********************************************************************
593 * control card: codewd = MOMENTUM *
595 * what (1) = momentum (GeV/c) of projectile in Lab. *
596 * default: 200 GeV/c *
597 * what (2..6), sdum no meaning *
599 *********************************************************************
608 *********************************************************************
610 * control card: codewd = CMENERGY *
612 * what (1) = energy in nucleon-nucleon cms. *
614 * what (2..6), sdum no meaning *
616 *********************************************************************
625 *********************************************************************
627 * control card: codewd = EMULSION *
629 * definition of nuclear emulsions *
631 * what(1) mass number of emulsion component *
632 * what(2) charge of emulsion component *
633 * what(3) fraction of events in which a scattering on a *
634 * nucleus of this properties is performed *
635 * what(4,5,6) as what(1,2,3) but for another component *
636 * default: no emulsion *
639 * Note: If this input-card is once used with valid parameters *
640 * TARPAR is obsolete. *
641 * Not the absolute values of the fractions are important *
642 * but only the ratios of fractions of different comp. *
643 * This control card can be repeatedly used to define *
644 * emulsions consisting of up to 10 elements. *
646 *********************************************************************
649 IF ((WHAT(1).GT.ZERO).AND.(WHAT(2).GT.ZERO)
650 & .AND.(ABS(WHAT(3)).GT.ZERO)) THEN
652 IF (NCOMPO.GT.NCOMPX) THEN
656 IEMUMA(NCOMPO) = INT(WHAT(1))
657 IEMUCH(NCOMPO) = INT(WHAT(2))
658 EMUFRA(NCOMPO) = WHAT(3)
660 C CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO))
662 IF ((WHAT(4).GT.ZERO).AND.(WHAT(5).GT.ZERO)
663 & .AND.(ABS(WHAT(6)).GT.ZERO)) THEN
665 IF (NCOMPO.GT.NCOMPX) THEN
669 IEMUMA(NCOMPO) = INT(WHAT(4))
670 IEMUCH(NCOMPO) = INT(WHAT(5))
671 EMUFRA(NCOMPO) = WHAT(6)
672 C CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO))
674 1600 FORMAT(1X,'too many emulsion components - program stopped')
677 *********************************************************************
679 * control card: codewd = FERMI *
681 * what (1) = -1 Fermi-motion of nucleons not treated *
683 * what (2) = scale factor for Fermi-momentum *
685 * what (3..6), sdum no meaning *
687 *********************************************************************
690 IF (WHAT(1).EQ.-1.0D0) THEN
696 IF (XMOD.GE.ZERO) FERMOD = XMOD
699 *********************************************************************
701 * control card: codewd = TAUFOR *
703 * formation time supressed intranuclear cascade *
705 * what (1) formation time (in fm/c) *
706 * note: what(1)=10. corresponds roughly to an *
707 * average formation time of 1 fm/c *
709 * what (2) number of generations followed *
711 * what (3) = 1. p_t-dependent formation zone *
712 * = 2. constant formation zone *
714 * what (4) modus of selection of nucleus where the *
715 * cascade if followed first *
716 * = 1. proj./target-nucleus with probab. 1/2 *
717 * = 2. nucleus with highest mass *
718 * = 3. proj. nucleus if particle is moving in pos. z *
719 * targ. nucleus if particle is moving in neg. z *
721 * what (5..6), sdum no meaning *
723 *********************************************************************
727 KTAUGE = INT(WHAT(2))
729 IF ((WHAT(3).GE.1.0D0).AND.(WHAT(3).LE.2.0D0))
730 & ITAUVE = INT(WHAT(3))
731 IF ((WHAT(4).GE.1.0D0).AND.(WHAT(4).LE.3.0D0))
732 & INCMOD = INT(WHAT(4))
735 *********************************************************************
737 * control card: codewd = PAULI *
739 * what (1) = -1 Pauli's principle for secondary *
740 * interactions not treated *
742 * what (2..6), sdum no meaning *
744 *********************************************************************
747 IF (WHAT(1).EQ.-1.0D0) THEN
754 *********************************************************************
756 * control card: codewd = COULOMB *
758 * what (1) = -1. Coulomb-energy treatment switched off *
760 * what (2..6), sdum no meaning *
762 *********************************************************************
766 IF (WHAT(1).EQ.-1.0D0) THEN
773 *********************************************************************
775 * control card: codewd = HADRIN *
779 * what (1) = 0. elastic/inelastic interactions with probab. *
780 * as defined by cross-sections *
781 * = 1. inelastic interactions forced *
782 * = 2. elastic interactions forced *
784 * what (2) upper threshold in total energy (GeV) below *
785 * which interactions are sampled by HADRIN *
787 * what (3..6), sdum no meaning *
789 *********************************************************************
793 IF ((IWHAT.GE.0).AND.(IWHAT.LE.2)) INTHAD = IWHAT
794 IF ((WHAT(2).GT.ZERO).AND.(WHAT(2).LT.15.0D0)) EHADTH = WHAT(2)
797 *********************************************************************
799 * control card: codewd = EVAP *
801 * evaporation module *
803 * what (1) =< -1 ==> evaporation is switched off *
804 * >= 1 ==> evaporation is performed *
806 * what (1) = i1 + i2*10 + i3*100 + i4*10000 *
807 * (i1, i2, i3, i4 >= 0 ) *
809 * i1 is the flag for selecting the T=0 level density option used *
810 * = 1: standard EVAP level densities with Cook pairing *
812 * = 2: Z,N-dependent Gilbert & Cameron level densities *
814 * = 3: Julich A-dependent level densities *
815 * = 4: Z,N-dependent Brancazio & Cameron level densities *
817 * i2 >= 1: high energy fission activated *
818 * (default high energy fission activated) *
820 * i3 = 0: No energy dependence for level densities *
821 * = 1: Standard Ignyatuk (1975, 1st) energy dependence *
822 * for level densities (default) *
823 * = 2: Standard Ignyatuk (1975, 1st) energy dependence *
824 * for level densities with NOT used set of parameters *
825 * = 3: Standard Ignyatuk (1975, 1st) energy dependence *
826 * for level densities with NOT used set of parameters *
827 * = 4: Second Ignyatuk (1975, 2nd) energy dependence *
828 * for level densities *
829 * = 5: Second Ignyatuk (1975, 2nd) energy dependence *
830 * for level densities with fit 1 Iljinov & Mebel set of *
832 * = 6: Second Ignyatuk (1975, 2nd) energy dependence *
833 * for level densities with fit 2 Iljinov & Mebel set of *
835 * = 7: Second Ignyatuk (1975, 2nd) energy dependence *
836 * for level densities with fit 3 Iljinov & Mebel set of *
838 * = 8: Second Ignyatuk (1975, 2nd) energy dependence *
839 * for level densities with fit 4 Iljinov & Mebel set of *
842 * i4 >= 1: Original Gilbert and Cameron pairing energies used *
843 * (default Cook's modified pairing energies) *
845 * what (2) = ig + 10 * if (ig and if must have the same sign) *
847 * ig =< -1 ==> deexcitation gammas are not produced *
848 * (if the evaporation step is not performed *
849 * they are never produced) *
850 * if =< -1 ==> Fermi Break Up is not invoked *
851 * (if the evaporation step is not performed *
852 * it is never invoked) *
853 * The default is: deexcitation gamma produced and Fermi break up *
854 * activated for the new preequilibrium, not *
855 * activated otherwise. *
856 * what (3..6), sdum no meaning *
858 *********************************************************************
861 IF (WHAT(1).LE.-1.0D0) THEN
868 IF ( NINT (WHAT (1)) .GE. 10000 ) THEN
870 JLVHLP = NINT (WHAT (1)) / 10000
871 WHAT (1) = WHAT (1) - 10000.D+00 * JLVHLP
873 IF ( NINT (WHAT (1)) .GE. 100 ) THEN
874 JLVMOD = NINT (WHAT (1)) / 100
875 WHAT (1) = WHAT (1) - 100.D+00 * JLVMOD
877 IF ( NINT (WHAT (1)) .GE. 10 ) THEN
881 JLVHLP = NINT (WHAT (1)) / 10
882 WHAT (1) = WHAT (1) - 10.D+00 * JLVHLP
883 ELSE IF ( NINT (WHTSAV) .NE. 0 ) THEN
888 IF ( NINT (WHAT (1)) .GE. 0 ) THEN
890 ILVMOD = NINT (WHAT(1))
891 IF ( ABS (NINT (WHAT (2))) .GE. 10 ) THEN
893 JLVHLP = NINT (WHAT (2)) / 10
894 WHAT (2) = WHAT (2) - 10.D+00 * JLVHLP
895 ELSE IF ( NINT (WHAT (2)) .NE. 0 ) THEN
898 IF ( NINT (WHAT (2)) .GE. 0 ) THEN
903 **sr heavies are always put to /FKFHVY/
904 C IF ( NINT (WHAT(3)) .GE. 1 ) THEN
920 *********************************************************************
922 * control card: codewd = EMCCHECK *
924 * extended energy-momentum / quantum-number conservation check *
926 * what (1) = -1 extended check not performed *
928 * what (2..6), sdum no meaning *
930 *********************************************************************
933 IF (WHAT(1).EQ.-1) THEN
940 *********************************************************************
942 * control card: codewd = MODEL *
944 * Model to be used to treat nucleon-nucleon interactions *
946 * sdum = DTUNUC two-chain model *
947 * = PHOJET multiple chains including minijets *
949 * = QNEUTRIN quasi-elastic neutrino scattering *
953 * what (1) (variable INTER) *
954 * = 1 gamma exchange *
957 * = 4 gamma/Z0 exchange *
959 * if sdum = QNEUTRIN: *
960 * what (1) = 0 elastic scattering on nucleon and *
961 * tau does not decay (default) *
962 * = 1 decay of tau into mu.. *
963 * = 2 decay of tau into e.. *
964 * = 10 CC events on p and n *
965 * = 11 NC events on p and n *
967 * what (2..6) no meaning *
969 *********************************************************************
972 IF (SDUM.EQ.CMODEL(1)) THEN
974 ELSEIF (SDUM.EQ.CMODEL(2)) THEN
976 ELSEIF (SDUM.EQ.CMODEL(3)) THEN
978 IF ((WHAT(1).GE.1.0D0).AND.(WHAT(1).LE.4.0D0))
979 & INTER = INT(WHAT(1))
980 ELSEIF (SDUM.EQ.CMODEL(4)) THEN
983 IF ((IWHAT.EQ.1 ).OR.(IWHAT.EQ.2 ).OR.
984 & (IWHAT.EQ.10).OR.(IWHAT.EQ.11))
987 STOP ' Unknown model !'
991 *********************************************************************
993 * control card: codewd = PHOINPUT *
995 * Start of input-section for PHOJET-specific input-cards *
996 * Note: This section will not be finished before giving *
998 * what (1..6), sdum no meaning *
1000 *********************************************************************
1005 CALL PHO_INIT(LINP,LOUT,IREJ1)
1007 IF (IREJ1.NE.0) THEN
1008 WRITE(LOUT,'(1X,A)')'INIT: reading PHOJET-input failed'
1015 *********************************************************************
1017 * control card: codewd = GLAUBERI *
1019 * Pre-initialization of impact parameter selection *
1021 * what (1..6), sdum no meaning *
1023 *********************************************************************
1026 IF (IFIRST.NE.99) THEN
1027 CALL DT_RNDMST(12,34,56,78)
1029 OPEN(40,FILE='outdata0/shm.out',STATUS='UNKNOWN')
1030 C OPEN(11,FILE='outdata0/shm.dbg',STATUS='UNKNOWN')
1041 ADP = (APHI-APLOW)/DBLE(IPPN)
1062 IT = ITLOW+(NCIT-1)*IDIT
1065 C IIP = (IPHI-IPLOW)/IDIP
1066 C IF (IIP.EQ.0) IIP = 1
1067 C IF (IT.EQ.IPLOW) IIP = 0
1071 CC IF (NCIP.LE.IIP) THEN
1072 C IP = IPLOW+(NCIP-1)*IDIP
1076 IF (IP.GT.IT) GOTO 472
1079 APPN = APLOW+DBLE(NCP-1)*ADP
1082 OPEN(12,FILE='outdata0/shm.sta',STATUS='UNKNOWN')
1083 WRITE(12,'(1X,2I5,E15.3)') IP,IT,PPN
1090 CALL DT_NEWHGR(XDUM,XDUM,XDUM,XDUMB,-1,IHDUM)
1091 CALL DT_NEWHGR(XLIM1,XLIM2,XLIM3,XDUMB,IBIN,IHSHMA)
1094 C IF ((IP.GT.10).OR.(IT.GT.10)) THEN
1102 CALL DT_SHMAKI(IP,IDUM1,IT,IDUM1,IJPROJ,PPN,99)
1103 SIGAV = SIGAV+XSPRO(1,1,1)
1106 CALL DT_FILHGR(XC,BSITE(1,1,1,J),IHSHMA,I)
1110 CALL DT_EVTHIS(IDUM)
1112 C CALL OUTGEN(IHSHMA,0,0,0,0,0,HEADER,0,NEVFIT,ONE,0,1,-1)
1114 C CALL GENFIT(XPARA)
1115 C WRITE(40,'(2I4,E11.3,F6.0,5E11.3)')
1116 C & IP,IT,PPN,SIGAV/DBLE(NEVFIT),XPARA
1126 *********************************************************************
1128 * control card: codewd = FLUCTUAT *
1130 * Treatment of cross section fluctuations *
1132 * what (1) = 1 treat cross section fluctuations *
1134 * what (1..6), sdum no meaning *
1136 *********************************************************************
1140 IF (WHAT(1).EQ.ONE) THEN
1146 *********************************************************************
1148 * control card: codewd = CENTRAL *
1150 * what (1) = 1. central production forced default: 0 *
1151 * if what (1) < 0 and > -100 *
1152 * what (2) = min. impact parameter default: 0 *
1153 * what (3) = max. impact parameter default: b_max *
1154 * if what (1) < -99 *
1155 * what (2) = fraction of cross section default: 1 *
1156 * if what (1) = -1 : evaporation/fzc suppressed *
1157 * if what (1) < -1 : evaporation/fzc allowed *
1159 * what (4..6), sdum no meaning *
1161 *********************************************************************
1164 ICENTR = INT(WHAT(1))
1165 IF (ICENTR.LT.0) THEN
1166 IF (ICENTR.GT.-100) THEN
1175 *********************************************************************
1177 * control card: codewd = RECOMBIN *
1179 * Chain recombination *
1180 * (recombine S-S and V-V chains to V-S chains) *
1182 * what (1) = -1. recombination switched off default: 1 *
1183 * what (2..6), sdum no meaning *
1185 *********************************************************************
1189 IF (WHAT(1).EQ.-1.0D0) IRECOM = 0
1192 *********************************************************************
1194 * control card: codewd = COMBIJET *
1196 * chain fusion (2 q-aq --> qq-aqaq) *
1198 * what (1) = 1 fusion treated *
1200 * what (2) minimum number of uncombined chains from *
1201 * single projectile or target nucleons *
1203 * what (3..6), sdum no meaning *
1205 *********************************************************************
1209 IF (INT(WHAT(1)).EQ.1) LCO2CR = .TRUE.
1210 IF (WHAT(2).GE.ZERO) CUTOF = WHAT(2)
1213 *********************************************************************
1215 * control card: codewd = XCUTS *
1217 * thresholds for x-sampling *
1219 * what (1) defines lower threshold for val.-q x-value (CVQ) *
1221 * what (2) defines lower threshold for val.-qq x-value (CDQ) *
1223 * what (3) defines lower threshold for sea-q x-value (CSEA) *
1225 * what (4) sea-q x-values in S-S chains (SSMIMA) *
1227 * what (5) not used *
1229 * what (6), sdum no meaning *
1231 * Note: Lower thresholds (what(1..3)) are def. as x_thr=CXXX/ECM *
1233 *********************************************************************
1236 IF (WHAT(1).GE.0.5D0) CVQ = WHAT(1)
1237 IF (WHAT(2).GE.ONE) CDQ = WHAT(2)
1238 IF (WHAT(3).GE.0.1D0) CSEA = WHAT(3)
1239 IF (WHAT(4).GE.ZERO) THEN
1243 IF (WHAT(5).GT.2.0D0) VVMTHR = WHAT(5)
1246 *********************************************************************
1248 * control card: codewd = INTPT *
1250 * what (1) = -1 intrinsic transverse momenta of partons *
1251 * not treated default: 1 *
1252 * what (2..6), sdum no meaning *
1254 *********************************************************************
1257 IF (WHAT(1).EQ.-1.0D0) THEN
1264 *********************************************************************
1266 * control card: codewd = CRONINPT *
1268 * Cronin effect (multiple scattering of partons at chain ends) *
1270 * what (1) = -1 Cronin effect not treated default: 1 *
1271 * what (2) = 0 scattering parameter default: 0.64 *
1272 * what (3..6), sdum no meaning *
1274 *********************************************************************
1277 IF (WHAT(1).EQ.-1.0D0) THEN
1285 *********************************************************************
1287 * control card: codewd = SEADISTR *
1289 * what (1) (XSEACO) sea(x) prop. 1/x**what (1) default: 1. *
1290 * what (2) (UNON) default: 2. *
1291 * what (3) (UNOM) default: 1.5 *
1292 * what (4) (UNOSEA) default: 5. *
1293 * qdis(x) prop. (1-x)**what (1) etc. *
1294 * what (5..6), sdum no meaning *
1296 *********************************************************************
1300 XSEACU = 1.05D0-XSEACO
1302 IF (UNON.LT.0.1D0) UNON = 2.0D0
1304 IF (UNOM.LT.0.1D0) UNOM = 1.5D0
1306 IF (UNOSEA.LT.0.1D0) UNOSEA = 5.0D0
1309 *********************************************************************
1311 * control card: codewd = SEASU3 *
1313 * Treatment of strange-quarks at chain ends *
1315 * what (1) (SEASQ) strange-quark supression factor *
1316 * iflav = 1.+rndm*(2.+SEASQ) *
1318 * what (2..6), sdum no meaning *
1320 *********************************************************************
1326 *********************************************************************
1328 * control card: codewd = DIQUARKS *
1330 * what (1) = -1. sea-diquark/antidiquark-pairs not treated *
1332 * what (2..6), sdum no meaning *
1334 *********************************************************************
1337 IF (WHAT(1).EQ.-1.0D0) THEN
1344 *********************************************************************
1346 * control card: codewd = RESONANC *
1348 * treatment of low mass chains *
1350 * what (1) = -1 low chain masses are not corrected for resonance *
1351 * masses (obsolete for BAMJET-fragmentation) *
1353 * what (2) = -1 massless partons default: 1. (massive) *
1354 * default: 1. (massive) *
1355 * what (3) = -1 chain-system containing chain of too small *
1356 * mass is rejected (note: this does not fully *
1357 * apply to S-S chains) default: 0. *
1358 * what (4..6), sdum no meaning *
1360 *********************************************************************
1366 IF (WHAT(1).EQ.-ONE) IRESCO = 0
1367 IF (WHAT(2).EQ.-ONE) IMSHL = 0
1368 IF (WHAT(3).EQ.-ONE) IRESRJ = 1
1371 *********************************************************************
1373 * control card: codewd = DIFFRACT *
1375 * Treatment of diffractive events *
1377 * what (1) = (ISINGD) 0 no single diffraction *
1378 * 1 single diffraction included *
1379 * +-2 single diffractive events only *
1380 * +-3 projectile single diffraction only *
1381 * +-4 target single diffraction only *
1382 * -5 double pomeron exchange only *
1383 * (neg. sign applies to PHOJET events) *
1386 * what (2) = (IDOUBD) 0 no double diffraction *
1387 * 1 double diffraction included *
1388 * 2 double diffractive events only *
1390 * what (3) = 1 projectile diffraction treated (2-channel form.) *
1392 * what (4) = alpha-parameter in projectile diffraction *
1394 * what (5..6), sdum no meaning *
1396 *********************************************************************
1399 IF (ABS(WHAT(1)).GT.ZERO) ISINGD = INT(WHAT(1))
1400 IF (ABS(WHAT(2)).GT.ZERO) IDOUBD = INT(WHAT(2))
1401 IF ((ISINGD.GT.1).AND.(IDOUBD.GT.1)) THEN
1403 1380 FORMAT(1X,'INIT: inconsistent DIFFRACT - input !',/,
1404 & 11X,'IDOUBD is reset to zero')
1407 IF (WHAT(3).GT.ZERO) DIBETA = WHAT(3)
1408 IF (WHAT(4).GT.ZERO) DIALPH = WHAT(4)
1411 *********************************************************************
1413 * control card: codewd = SINGLECH *
1415 * what (1) = 1. Regge contribution (one chain) included *
1417 * what (2..6), sdum no meaning *
1419 *********************************************************************
1423 IF (WHAT(1).EQ.ONE) ISICHA = 1
1426 *********************************************************************
1428 * control card: codewd = NOFRAGME *
1430 * biased chain hadronization *
1432 * what (1..6) = -1 no of hadronizsation of S-S chains *
1433 * = -2 no of hadronizsation of D-S chains *
1434 * = -3 no of hadronizsation of S-D chains *
1435 * = -4 no of hadronizsation of S-V chains *
1436 * = -5 no of hadronizsation of D-V chains *
1437 * = -6 no of hadronizsation of V-S chains *
1438 * = -7 no of hadronizsation of V-D chains *
1439 * = -8 no of hadronizsation of V-V chains *
1440 * = -9 no of hadronizsation of comb. chains *
1441 * default: complete hadronization *
1444 *********************************************************************
1448 ICHAIN = INT(WHAT(I))
1449 IF ((ICHAIN.LE.-1).AND.(ICHAIN.GE.-9))
1450 & LHADRO(ABS(ICHAIN)) = .FALSE.
1454 *********************************************************************
1456 * control card: codewd = HADRONIZE *
1458 * hadronization model and parameter switch *
1460 * what (1) = 1 hadronization via BAMJET *
1461 * = 2 hadronization via JETSET *
1463 * what (2) = 1..3 parameter set to be used *
1464 * JETSET: 3 sets available *
1465 * ( = 3 default JETSET-parameters) *
1466 * BAMJET: 1 set available *
1468 * what (3..6), sdum no meaning *
1470 *********************************************************************
1473 IWHAT1 = INT(WHAT(1))
1474 IWHAT2 = INT(WHAT(2))
1475 IF ((IWHAT1.EQ.1).OR.(IWHAT1.EQ.2)) IFRAG(1) = IWHAT1
1476 IF ((IWHAT1.EQ.2).AND.(IWHAT2.GE.1).AND.(IWHAT2.LE.3))
1480 *********************************************************************
1482 * control card: codewd = POPCORN *
1484 * "Popcorn-effect" in fragmentation and diquark breaking diagrams *
1486 * what (1) = (PDB) frac. of diquark fragmenting directly into *
1487 * baryons (PYTHIA/JETSET fragmentation) *
1488 * (JETSET: = 0. Popcorn mechanism switched off) *
1490 * what (2) = probability for accepting a diquark breaking *
1491 * diagram involving the generation of a u/d quark- *
1492 * antiquark pair default: 0.0 *
1493 * what (3) = same a what (2), here for s quark-antiquark pair *
1495 * what (4..6), sdum no meaning *
1497 *********************************************************************
1500 IF (WHAT(1).GE.0.0D0) PDB = WHAT(1)
1501 IF (WHAT(2).GE.0.0D0) THEN
1505 IF (WHAT(3).GE.0.0D0) PDBSEA(3) = WHAT(3)
1507 DBRKA(1,I) = DBRKR(1,I)*PDBSEA(1)/(1.D0-PDBSEA(1))
1508 DBRKA(2,I) = DBRKR(2,I)*PDBSEA(2)/(1.D0-PDBSEA(2))
1509 DBRKA(3,I) = DBRKR(3,I)*PDBSEA(3)/(1.D0-PDBSEA(3))
1513 *********************************************************************
1515 * control card: codewd = PARDECAY *
1517 * what (1) = 1. Sigma0/Asigma0 are decaying within JETSET *
1518 * = 2. pion^0 decay after intranucl. cascade *
1519 * default: no decay *
1520 * what (2..6), sdum no meaning *
1522 *********************************************************************
1525 IF (WHAT(1).EQ.ONE) ISIG0 = 1
1526 IF (WHAT(1).EQ.2.0D0) IPI0 = 1
1529 *********************************************************************
1531 * control card: codewd = BEAM *
1533 * definition of beam parameters *
1535 * what (1/2) > 0 : energy of beam 1/2 (GeV) *
1536 * < 0 : abs(what(1/2)) energy per charge of *
1538 * (beam 1 is directed into positive z-direction) *
1539 * what (3) beam crossing angle, defined as 2x angle between *
1540 * one beam and the z-axis (micro rad) *
1541 * what (4) angle with x-axis defining the collision plane *
1542 * what (5..6), sdum no meaning *
1544 * Note: this card requires previously defined projectile and *
1545 * target identities (PROJPAR, TARPAR) *
1547 *********************************************************************
1550 CALL DT_BEAMPR(WHAT,PPN,1)
1556 *********************************************************************
1558 * control card: codewd = LUND-MSTU *
1560 * set parameter MSTU in JETSET-common /LUDAT1/ *
1562 * what (1) = index according to LUND-common block *
1563 * what (2) = new value of MSTU( int(what(1)) ) *
1564 * what (3), what(4) and what (5), what(6) further *
1565 * parameter in the same way as what (1) and *
1567 * default: default-Lund or corresponding to *
1568 * the set given in HADRONIZE *
1570 *********************************************************************
1573 IF (WHAT(1).GT.ZERO) THEN
1575 IMSTU(NMSTU) = INT(WHAT(1))
1576 MSTUX(NMSTU) = INT(WHAT(2))
1578 IF (WHAT(3).GT.ZERO) THEN
1580 IMSTU(NMSTU) = INT(WHAT(3))
1581 MSTUX(NMSTU) = INT(WHAT(4))
1583 IF (WHAT(5).GT.ZERO) THEN
1585 IMSTU(NMSTU) = INT(WHAT(5))
1586 MSTUX(NMSTU) = INT(WHAT(6))
1590 *********************************************************************
1592 * control card: codewd = LUND-MSTJ *
1594 * set parameter MSTJ in JETSET-common /LUDAT1/ *
1596 * what (1) = index according to LUND-common block *
1597 * what (2) = new value of MSTJ( int(what(1)) ) *
1598 * what (3), what(4) and what (5), what(6) further *
1599 * parameter in the same way as what (1) and *
1601 * default: default-Lund or corresponding to *
1602 * the set given in HADRONIZE *
1604 *********************************************************************
1607 IF (WHAT(1).GT.ZERO) THEN
1609 IMSTJ(NMSTJ) = INT(WHAT(1))
1610 MSTJX(NMSTJ) = INT(WHAT(2))
1612 IF (WHAT(3).GT.ZERO) THEN
1614 IMSTJ(NMSTJ) = INT(WHAT(3))
1615 MSTJX(NMSTJ) = INT(WHAT(4))
1617 IF (WHAT(5).GT.ZERO) THEN
1619 IMSTJ(NMSTJ) = INT(WHAT(5))
1620 MSTJX(NMSTJ) = INT(WHAT(6))
1624 *********************************************************************
1626 * control card: codewd = LUND-MDCY *
1628 * set parameter MDCY(I,1) for particle decays in JETSET-common *
1631 * what (1-6) = PDG particle index of particle which should *
1633 * default: default-Lund or forced in *
1636 *********************************************************************
1640 IF (WHAT(I).NE.ZERO) THEN
1642 KC = PYCOMP(INT(WHAT(I)))
1649 *********************************************************************
1651 * control card: codewd = LUND-PARJ *
1653 * set parameter PARJ in JETSET-common /LUDAT1/ *
1655 * what (1) = index according to LUND-common block *
1656 * what (2) = new value of PARJ( int(what(1)) ) *
1657 * what (3), what(4) and what (5), what(6) further *
1658 * parameter in the same way as what (1) and *
1660 * default: default-Lund or corresponding to *
1661 * the set given in HADRONIZE *
1663 *********************************************************************
1666 IF (WHAT(1).NE.ZERO) THEN
1668 IPARJ(NPARJ) = INT(WHAT(1))
1669 PARJX(NPARJ) = WHAT(2)
1671 IF (WHAT(3).NE.ZERO) THEN
1673 IPARJ(NPARJ) = INT(WHAT(3))
1674 PARJX(NPARJ) = WHAT(4)
1676 IF (WHAT(5).NE.ZERO) THEN
1678 IPARJ(NPARJ) = INT(WHAT(5))
1679 PARJX(NPARJ) = WHAT(6)
1683 *********************************************************************
1685 * control card: codewd = LUND-PARU *
1687 * set parameter PARJ in JETSET-common /LUDAT1/ *
1689 * what (1) = index according to LUND-common block *
1690 * what (2) = new value of PARU( int(what(1)) ) *
1691 * what (3), what(4) and what (5), what(6) further *
1692 * parameter in the same way as what (1) and *
1694 * default: default-Lund or corresponding to *
1695 * the set given in HADRONIZE *
1697 *********************************************************************
1700 IF (WHAT(1).GT.ZERO) THEN
1702 IPARU(NPARU) = INT(WHAT(1))
1703 PARUX(NPARU) = WHAT(2)
1705 IF (WHAT(3).GT.ZERO) THEN
1707 IPARU(NPARU) = INT(WHAT(3))
1708 PARUX(NPARU) = WHAT(4)
1710 IF (WHAT(5).GT.ZERO) THEN
1712 IPARU(NPARU) = INT(WHAT(5))
1713 PARUX(NPARU) = WHAT(6)
1717 *********************************************************************
1719 * control card: codewd = OUTLEVEL *
1721 * output control switches *
1723 * what (1) = internal rejection informations default: 0 *
1724 * what (2) = energy-momentum conservation check output *
1726 * what (3) = internal warning messages default: 0 *
1727 * what (4..6), sdum not yet used *
1729 *********************************************************************
1733 IOULEV(K) = INT(WHAT(K))
1737 *********************************************************************
1739 * control card: codewd = FRAME *
1741 * frame in which final state is given in DTEVT1 *
1743 * what (1) = 1 target rest frame (laboratory) *
1744 * = 2 nucleon-nucleon cms *
1747 *********************************************************************
1750 KFRAME = INT(WHAT(1))
1751 IF ((KFRAME.GE.1).AND.(KFRAME.LE.2)) IFRAME = KFRAME
1754 *********************************************************************
1756 * control card: codewd = L-TAG *
1759 * definition of kinematical cuts for radiated photon and *
1760 * outgoing lepton detection in lepton-nucleus interactions *
1762 * what (1) = y_min *
1763 * what (2) = y_max *
1764 * what (3) = Q^2_min *
1765 * what (4) = Q^2_max *
1766 * what (5) = theta_min (Lab) *
1767 * what (6) = theta_max (Lab) *
1768 * default: no cuts *
1771 *********************************************************************
1782 *********************************************************************
1784 * control card: codewd = L-ETAG *
1787 * what (1) = min. outgoing lepton energy (in Lab) *
1788 * what (2) = min. photon energy (in Lab) *
1789 * what (3) = max. photon energy (in Lab) *
1790 * default: no cuts *
1791 * what (2..6), sdum no meaning *
1793 *********************************************************************
1796 ELMIN = MAX(WHAT(1),ZERO)
1797 EGMIN = MAX(WHAT(2),ZERO)
1798 EGMAX = MAX(WHAT(3),ZERO)
1801 *********************************************************************
1803 * control card: codewd = ECMS-CUT *
1805 * what (1) = min. c.m. energy to be sampled *
1806 * what (2) = max. c.m. energy to be sampled *
1807 * what (3) = min x_Bj to be sampled *
1808 * default: no cuts *
1809 * what (3..6), sdum no meaning *
1811 *********************************************************************
1816 IF (ECMIN.GT.ECMAX) ECMIN = ECMAX
1817 XBJMIN = MAX(WHAT(3),ZERO)
1820 *********************************************************************
1822 * control card: codewd = VDM-PAR1 *
1824 * parameters in gamma-nucleus cross section calculation *
1826 * what (1) = Lambda^2 default: 2. *
1827 * what (2) lower limit in M^2 integration *
1830 * = 3 (m_phi)^2 default: 1 *
1831 * what (3) upper limit in M^2 integration *
1834 * = 3 s default: 3 *
1835 * what (4) CKMT F_2 structure function *
1837 * = 100 deuteron default: 2212 *
1838 * what (5) calculation of gamma-nucleon xsections *
1839 * = 1 according to CKMT-parametrization of F_2 *
1840 * = 2 integrating SIGVP over M^2 *
1842 * = 4 PHOJET cross sections default: 4 *
1844 * what (6), sdum no meaning *
1846 *********************************************************************
1849 IF (WHAT(1).GE.ZERO) RL2 = WHAT(1)
1850 IF ((WHAT(2).GE.1).AND.(WHAT(2).LE.3)) INTRGE(1) = INT(WHAT(2))
1851 IF ((WHAT(3).GE.1).AND.(WHAT(3).LE.3)) INTRGE(2) = INT(WHAT(3))
1852 IF ((WHAT(4).EQ.2212).OR.(WHAT(4).EQ.100)) IDPDF = INT(WHAT(4))
1853 IF ((WHAT(5).GE.1).AND.(WHAT(5).LE.4)) MODEGA = INT(WHAT(5))
1856 *********************************************************************
1858 * control card: codewd = HISTOGRAM *
1860 * activate different classes of histograms *
1862 * default: no histograms *
1864 *********************************************************************
1868 IF ((WHAT(J).GE.100).AND.(WHAT(J).LE.150)) THEN
1869 IHISPP(INT(WHAT(J))-100) = 1
1870 ELSEIF ((ABS(WHAT(J)).GE.200).AND.(ABS(WHAT(J)).LE.250)) THEN
1871 IHISXS(INT(ABS(WHAT(J)))-200) = 1
1872 IF (WHAT(J).LT.ZERO) IXSTBL = 1
1877 *********************************************************************
1879 * control card: codewd = XS-TABLE *
1881 * output of cross section table for requested interaction *
1882 * - particle production deactivated ! - *
1884 * what (1) lower energy limit for tabulation *
1886 * < 0 nucleon-nucleon cms *
1887 * what (2) upper energy limit for tabulation *
1889 * < 0 nucleon-nucleon cms *
1890 * what (3) > 0 # of equidistant lin. bins in E *
1891 * < 0 # of equidistant log. bins in E *
1892 * what (4) lower limit of particle virtuality (photons) *
1893 * what (5) upper limit of particle virtuality (photons) *
1894 * what (6) > 0 # of equidistant lin. bins in Q^2 *
1895 * < 0 # of equidistant log. bins in Q^2 *
1897 *********************************************************************
1900 IF (WHAT(1).EQ.99999.0D0) THEN
1901 IRATIO = INT(WHAT(2))
1904 CMENER = ABS(WHAT(2))
1905 IF (.NOT.LXSTAB) THEN
1911 IF ((.NOT.LXSTAB).OR.(CMENER.NE.CMEOLD)) THEN
1913 IF (WHAT(2).GT.ZERO)
1914 & CMENER = SQRT(2.0D0*AAM(1)**2+2.0D0*WHAT(2)*AAM(1))
1917 C WRITE(LOUT,*) 'CMENER = ',CMENER
1918 CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,CMENER,1)
1921 CALL DT_XSTABL(WHAT,IXSQEL,IRATIO)
1926 *********************************************************************
1928 * control card: codewd = GLAUB-PAR *
1930 * parameters in Glauber-formalism *
1932 * what (1) # of nucleon configurations sampled in integration *
1933 * over nuclear desity default: 1000 *
1934 * what (2) # of bins for integration over impact-parameter and *
1935 * for profile-function calculation default: 49 *
1936 * what (3) = 1 calculation of tot., el. and qel. cross sections *
1938 * what (4) = 1 read pre-calculated impact-parameter distrib. *
1940 * =-1 dump pre-calculated impact-parameter distrib. *
1942 * = 100 read pre-calculated impact-parameter distrib. *
1943 * for variable projectile/target/energy runs *
1946 * what (5..6) no meaning *
1947 * sdum if |what (4)| = 1 name of in/output-file (sdum.glb) *
1949 *********************************************************************
1952 IF (WHAT(1).GT.ZERO) JSTATB = INT(WHAT(1))
1953 IF (WHAT(2).GT.ZERO) JBINSB = INT(WHAT(2))
1954 IF (WHAT(3).EQ.ONE) LPROD = .FALSE.
1955 IF ((ABS(WHAT(4)).EQ.ONE).OR.(WHAT(4).EQ.100)) THEN
1956 IOGLB = INT(WHAT(4))
1961 *********************************************************************
1963 * control card: codewd = GLAUB-INI *
1965 * pre-initialization of profile function *
1967 * what (1) lower energy limit for initialization *
1969 * < 0 nucleon-nucleon cms *
1970 * what (2) upper energy limit for initialization *
1972 * < 0 nucleon-nucleon cms *
1973 * what (3) > 0 # of equidistant lin. bins in E *
1974 * < 0 # of equidistant log. bins in E *
1975 * what (4) maximum projectile mass number for which the *
1976 * Glauber data are initialized for each *
1977 * projectile mass number *
1978 * (if <= mass given with the PROJPAR-card) *
1980 * what (5) steps in mass number starting from what (4) *
1981 * up to mass number defined with PROJPAR-card *
1982 * for which Glauber data are initialized *
1984 * what (6) no meaning *
1987 *********************************************************************
1991 CALL DT_GLBINI(WHAT)
1994 *********************************************************************
1996 * control card: codewd = VDM-PAR2 *
1998 * parameters in gamma-nucleus cross section calculation *
2000 * what (1) = 0 no suppression of shadowing by direct photon *
2002 * = 1 suppression .. default: 1 *
2003 * what (2) = 0 no suppression of shadowing by anomalous *
2004 * component if photon-F_2 *
2005 * = 1 suppression .. default: 1 *
2006 * what (3) = 0 no suppression of shadowing by coherence *
2007 * length of the photon *
2008 * = 1 suppression .. default: 1 *
2009 * what (4) = 1 longitudinal polarized photons are taken into *
2011 * eps*R*Q^2/M^2 = what(4)*Q^2/M^2 default: 0 *
2012 * what (5..6), sdum no meaning *
2014 *********************************************************************
2017 IF ((WHAT(1).EQ.ZERO).OR.(WHAT(1).EQ.ONE)) ISHAD(1) = INT(WHAT(1))
2018 IF ((WHAT(2).EQ.ZERO).OR.(WHAT(2).EQ.ONE)) ISHAD(2) = INT(WHAT(2))
2019 IF ((WHAT(3).EQ.ZERO).OR.(WHAT(3).EQ.ONE)) ISHAD(3) = INT(WHAT(3))
2023 *********************************************************************
2025 * control card: XS-QELPRO *
2027 * what (1..6), sdum no meaning *
2029 *********************************************************************
2032 IXSQEL = ABS(WHAT(1))
2035 *********************************************************************
2037 * control card: RNDMINIT *
2039 * initialization of random number generator *
2041 * what (1..4) values for initialization (= 1..168) *
2042 * what (5..6), sdum no meaning *
2044 *********************************************************************
2047 IF ((WHAT(1).LT.1.0D0).OR.(WHAT(1).GT.168.0D0)) THEN
2052 IF ((WHAT(2).LT.1.0D0).OR.(WHAT(2).GT.168.0D0)) THEN
2057 IF ((WHAT(3).LT.1.0D0).OR.(WHAT(3).GT.168.0D0)) THEN
2062 IF ((WHAT(4).LT.1.0D0).OR.(WHAT(4).GT.168.0D0)) THEN
2067 CALL DT_RNDMST(NA1,NA2,NA3,NA4)
2070 *********************************************************************
2072 * control card: codewd = LEPTO-CUT *
2074 * set parameter CUT in LEPTO-common /LEPTOU/ *
2076 * what (1) = index in CUT-array *
2077 * what (2) = new value of CUT( int(what(1)) ) *
2078 * what (3), what(4) and what (5), what(6) further *
2079 * parameter in the same way as what (1) and *
2081 * default: default-LEPTO parameters *
2083 *********************************************************************
2086 IF (WHAT(1).GT.ZERO) CUT(INT(WHAT(1))) = WHAT(2)
2087 IF (WHAT(3).GT.ZERO) CUT(INT(WHAT(3))) = WHAT(4)
2088 IF (WHAT(5).GT.ZERO) CUT(INT(WHAT(5))) = WHAT(6)
2091 *********************************************************************
2093 * control card: codewd = LEPTO-LST *
2095 * set parameter LST in LEPTO-common /LEPTOU/ *
2097 * what (1) = index in LST-array *
2098 * what (2) = new value of LST( int(what(1)) ) *
2099 * what (3), what(4) and what (5), what(6) further *
2100 * parameter in the same way as what (1) and *
2102 * default: default-LEPTO parameters *
2104 *********************************************************************
2107 IF (WHAT(1).GT.ZERO) LST(INT(WHAT(1))) = INT(WHAT(2))
2108 IF (WHAT(3).GT.ZERO) LST(INT(WHAT(3))) = INT(WHAT(4))
2109 IF (WHAT(5).GT.ZERO) LST(INT(WHAT(5))) = INT(WHAT(6))
2112 *********************************************************************
2114 * control card: codewd = LEPTO-PARL *
2116 * set parameter PARL in LEPTO-common /LEPTOU/ *
2118 * what (1) = index in PARL-array *
2119 * what (2) = new value of PARL( int(what(1)) ) *
2120 * what (3), what(4) and what (5), what(6) further *
2121 * parameter in the same way as what (1) and *
2123 * default: default-LEPTO parameters *
2125 *********************************************************************
2128 IF (WHAT(1).GT.ZERO) PARL(INT(WHAT(1))) = WHAT(2)
2129 IF (WHAT(3).GT.ZERO) PARL(INT(WHAT(3))) = WHAT(4)
2130 IF (WHAT(5).GT.ZERO) PARL(INT(WHAT(5))) = WHAT(6)
2133 *********************************************************************
2135 * control card: codewd = START *
2137 * what (1) = number of events default: 100. *
2138 * what (2) = 0 Glauber initialization follows *
2139 * = 1 Glauber initialization supressed, fitted *
2140 * results are used instead *
2141 * (this does not apply if emulsion-treatment *
2143 * = 2 Glauber initialization is written to *
2144 * output-file shmakov.out *
2145 * = 3 Glauber initialization is read from input-file *
2146 * shmakov.out default: 0 *
2147 * what (3..6) no meaning *
2148 * what (3..6) no meaning *
2150 *********************************************************************
2154 * check for cross-section table output only
2157 NCASES = INT(WHAT(1))
2158 IF (NCASES.LE.0) NCASES = 100
2159 IGLAU = INT(WHAT(2))
2160 IF ((IGLAU.NE.1).AND.(IGLAU.NE.2).AND.(IGLAU.NE.3))
2169 IF (IDP.LE.0) IDP = 1
2170 * muon neutrinos: temporary (missing index)
2171 * (new patch in projpar: therefore the following this is probably not
2172 * necessary anymore..)
2173 C IF (IDP.EQ.26) IDP = 5
2174 C IF (IDP.EQ.27) IDP = 6
2176 * redefine collision energy
2178 IF (ABS(VAREHI).GT.ZERO) THEN
2180 IF (VARELO.LT.EHADLO) VARELO = EHADLO
2181 CALL DT_LTINI(IDP,IDT,VARELO,PDUM,VARCLO,1)
2183 CALL DT_LTINI(IDP,IDT,VAREHI,PDUM,VARCHI,1)
2185 CALL DT_LTINI(IDP,IDT,EPN,PPN,CMENER,1)
2188 1003 FORMAT(1X,'INIT: collision energy not defined!',/,
2189 & 1X,' -program stopped- ')
2193 * switch off evaporation (even if requested) if central coll. requ.
2194 IF ((ICENTR.EQ.-1).OR.(ICENTR.GT.0).OR.(XSFRAC.LT.0.5D0)) THEN
2197 1004 FORMAT(1X,/,'Warning! Evaporation request rejected since',
2198 & ' central collisions forced.')
2205 * initialization of evaporation-module
2207 * initialize evaporation if the code is not used as Fluka event generator
2208 WRITE(LOUT,*) ' ITRSPT = ', ITRSPT
2209 IF (ITRSPT.NE.1) THEN
2213 WRITE(LOUT,*) ' LEVPRT = ',LEVPRT
2214 IF (LEVPRT) LHEAVY = .TRUE.
2215 * save the default JETSET-parameter
2218 WRITE(LOUT,*) ' IDP = ',IDP,' MCGENE = ',MCGENE
2219 * force use of phojet for g-A
2220 IF ((IDP.EQ.7).AND.(MCGENE.NE.3)) MCGENE = 2
2221 * initialization of nucleon-nucleon event generator
2222 IF (MCGENE.EQ.2) CALL DT_PHOINI
2223 * initialization of LEPTO event generator
2224 IF (MCGENE.EQ.3) THEN
2226 STOP ' This version does not contain LEPTO !'
2230 * initialization of quasi-elastic neutrino scattering
2231 IF (MCGENE.EQ.4) THEN
2232 IF (IJPROJ.EQ.5) THEN
2234 ELSEIF (IJPROJ.EQ.6) THEN
2236 ELSEIF (IJPROJ.EQ.135) THEN
2238 ELSEIF (IJPROJ.EQ.136) THEN
2240 ELSEIF (IJPROJ.EQ.133) THEN
2242 ELSEIF (IJPROJ.EQ.134) THEN
2247 * normalize fractions of emulsion components
2248 IF (NCOMPO.GT.0) THEN
2251 SUMFRA = SUMFRA+EMUFRA(I)
2253 IF (SUMFRA.GT.ZERO) THEN
2255 EMUFRA(I) = EMUFRA(I)/SUMFRA
2260 * disallow Cronin's multiple scattering for nucleus-nucleus interactions
2261 IF ((IP.GT.1) .AND. (IT.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,
5538 * central particle production, impact parameter biasing
5539 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5542 * statistics: Glauber-formalism
5543 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
5546 DATA NEVOLD,IPOLD,ITOLD,JJPOLD,EPROLD /4*0,0.0D0/
5557 IF (MOD(NC,10).EQ.0) THEN
5558 WRITE(LOUT,1000) NEVHKK
5559 1000 FORMAT(1X,'KKEVNT: event ',I8,' rejected!')
5563 * initialize DTEVT1/DTEVT2
5566 * We need the following only in order to sample nucleon coordinates.
5567 * However we don't have parameters (cross sections, slope etc.)
5568 * for neutrinos available. Therefore switch projectile to proton
5570 IF (MCGENE.EQ.4) THEN
5577 IF ( (NEVHKK.NE.NEVOLD).OR.(ICENTR.GT.0).OR.
5578 * make sure that Glauber-formalism is called each time the interaction
5579 * configuration changed
5580 & (IP.NE.IPOLD).OR.(IT.NE.ITOLD).OR.(JJPROJ.NE.JJPOLD).OR.
5581 & (ABS(EPROJ-EPROLD).GT.TINY10) ) THEN
5582 * sample number of nucleon-nucleon coll. according to Glauber-form.
5583 CALL DT_GLAUBE(IP,IT,JJPROJ,BIMPAC,NN,NP,NT,JSSH,JTSH,KKMAT)
5594 * WRITE(6,*)' PROJ.NUCL. ',I,' NCOLL = ',NCP
5598 * WRITE(6,*)' TAR.NUCL. ',I,' NCOLL = ',NCT
5602 * force diffractive particle production in h-K interactions
5603 IF (((ABS(ISINGD).GT.1).OR.(ABS(IDOUBD).GT.1)).AND.
5604 & (IP.EQ.1).AND.(NN.NE.1)) THEN
5609 * check number of involved proj. nucl. (NP) if central prod.is requested
5610 IF (ICENTR.GT.0) THEN
5611 CALL DT_CHKCEN(IP,IT,NP,NT,IBACK)
5612 IF (IBACK.GT.0) GOTO 10
5615 * get initial nucleon-configuration in projectile and target
5616 * rest-system (including Fermi-momenta if requested)
5617 CALL DT_ININUC(IJPROJ,IP,IPZ,PKOO,JSSH,1)
5619 IF (EPROJ.LE.EHADTH) MODE = 3
5620 CALL DT_ININUC(IJTARG,IT,ITZ,TKOO,JTSH,MODE)
5622 IF ((MCGENE.NE.3).AND.(MCGENE.NE.4)) THEN
5624 * activate HADRIN at low energies (implemented for h-N scattering only)
5625 IF (EPROJ.LE.EHADHI) THEN
5626 IF (EHADTH.LT.ZERO) THEN
5627 * smooth transition btwn. DPM and HADRIN
5628 FRAC = (EPROJ-EHADLO)/(EHADHI-EHADLO)
5630 IF (RR.GT.FRAC) THEN
5632 CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5633 IF (IREJ1.GT.0) GOTO 1
5636 WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5640 * fixed threshold for onset of production via HADRIN
5641 IF (EPROJ.LE.EHADTH) THEN
5643 CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5644 IF (IREJ1.GT.0) GOTO 1
5647 WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5652 1001 FORMAT(1X,'KKEVNT: warning! interaction of proj. (m=',
5653 & I3,') with target (m=',I3,')',/,11X,
5654 & 'at E_lab=',F5.1,'GeV (threshold-energy: ',F3.1,
5655 & 'GeV) cannot be handled')
5657 * sampling of momentum-x fractions & flavors of chain ends
5660 * Lorentz-transformation of wounded nucleons into nucl.-nucl. cms
5663 * collect momenta of chain ends and put them into DTEVT1
5664 CALL DT_GETPTN(IP,NN,NCSY,IREJ1)
5665 IF (IREJ1.NE.0) GOTO 1
5669 * handle chains including fragmentation (two-chain approximation)
5670 IF (MCGENE.EQ.1) THEN
5671 * two-chain approximation
5672 CALL DT_EVENTA(IJPROJ,IP,IT,NCSY,IREJ1)
5673 IF (IREJ1.NE.0) THEN
5674 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKEVNT'
5677 ELSEIF (MCGENE.EQ.2) THEN
5678 * multiple-Po exchange including minijets
5679 CALL DT_EVENTB(NCSY,IREJ1)
5680 IF (IREJ1.NE.0) THEN
5681 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKEVNT'
5684 ELSEIF (MCGENE.EQ.3) THEN
5685 STOP ' This version does not contain LEPTO !'
5687 ELSEIF (MCGENE.EQ.4) THEN
5688 * quasi-elastic neutrino scattering
5689 CALL DT_EVENTD(IREJ1)
5690 IF (IREJ1.NE.0) THEN
5691 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 4 in KKEVNT'
5695 WRITE(LOUT,1002) MCGENE
5696 1002 FORMAT(1X,'KKEVNT: warning! event-generator',I4,
5697 & ' not available - program stopped')
5708 *$ CREATE DT_CHKCEN.FOR
5711 *===chkcen=============================================================*
5713 SUBROUTINE DT_CHKCEN(IP,IT,NP,NT,IBACK)
5715 ************************************************************************
5716 * Check of number of involved projectile nucleons if central production*
5718 * Adopted from a part of the old KKEVT routine which was written by *
5719 * J. Ranft/H.-J.Moehring. *
5720 * This version dated 13.01.95 is written by S. Roesler *
5721 ************************************************************************
5723 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5726 PARAMETER ( LINP = 10 ,
5731 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5732 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5735 * central particle production, impact parameter biasing
5736 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5741 IF (ICENTR.EQ.2) THEN
5744 IF (NP.LT.IP-1) IBACK = 1
5745 ELSEIF (IP.LE.16) THEN
5746 IF (NP.LT.IP-2) IBACK = 1
5747 ELSEIF (IP.LE.32) THEN
5748 IF (NP.LT.IP-3) IBACK = 1
5749 ELSEIF (IP.GE.33) THEN
5750 IF (NP.LT.IP-5) IBACK = 1
5752 ELSEIF (IP.EQ.IT) THEN
5754 IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5756 IF (NP.LT.IP-IP/8) IBACK = 1
5758 ELSEIF (ABS(IP-IT).LT.3) THEN
5759 IF (NP.LT.IP-IP/8) IBACK = 1
5762 * new version (DPMJET, 5.6.99)
5765 IF (NP.LT.IP-1) IBACK = 1
5766 ELSEIF (IP.LE.16) THEN
5767 IF (NP.LT.IP-2) IBACK = 1
5768 ELSEIF (IP.LT.32) THEN
5769 IF (NP.LT.IP-3) IBACK = 1
5770 ELSEIF (IP.GE.32) THEN
5773 IF (NP.LT.IP-1) IBACK = 1
5776 IF (NP.LT.IP) IBACK = 1
5779 ELSEIF (IP.EQ.IT) THEN
5782 IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5785 IF (NP.LT.IP-IP/4) IBACK = 1
5787 ELSEIF (ABS(IP-IT).LT.3) THEN
5788 IF (NP.LT.IP-IP/8) IBACK = 1
5797 *$ CREATE DT_ININUC.FOR
5800 *===ininuc=============================================================*
5802 SUBROUTINE DT_ININUC(ID,NMASS,NCH,COORD,JS,IMODE)
5804 ************************************************************************
5805 * Samples initial configuration of nucleons in nucleus with mass NMASS *
5806 * including Fermi-momenta (if reqested). *
5807 * ID BAMJET-code for hadrons (instead of nuclei) *
5808 * NMASS mass number of nucleus (number of nucleons) *
5809 * NCH charge of nucleus *
5810 * COORD(3,NMASS) coordinates of nucleons inside nucleus in fm *
5811 * JS(NMASS) > 0 nucleon undergoes nucleon-nucleon interact. *
5812 * IMODE = 1 projectile nucleus *
5813 * = 2 target nucleus *
5814 * = 3 target nucleus (E_lab<E_thr for HADRIN) *
5815 * Adopted from a part of the old KKEVT routine which was written by *
5816 * J. Ranft/H.-J.Moehring. *
5817 * This version dated 13.01.95 is written by S. Roesler *
5818 ************************************************************************
5820 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5823 PARAMETER ( LINP = 10 ,
5827 PARAMETER (FM2MM=1.0D-12)
5829 PARAMETER ( MAXNCL = 260,
5832 & MAXSQU = 20*MAXVQU,
5833 & MAXINT = MAXVQU+MAXSQU)
5837 PARAMETER (NMXHKK=200000)
5839 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5840 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5841 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5843 * extended event history
5844 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5845 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5848 * flags for input different options
5849 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5850 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5851 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5853 * auxiliary common for chain system storage (DTUNUC 1.x)
5854 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
5858 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5859 & EBINDP(2),EBINDN(2),EPOT(2,210),
5860 & ETACOU(2),ICOUL,LFERMI
5862 * properties of photon/lepton projectiles
5863 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5865 * particle properties (BAMJET index convention)
5867 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5868 & IICH(210),IIBAR(210),K1(210),K2(210)
5870 * Glauber formalism: collision properties
5871 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5872 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
5874 * flavors of partons (DTUNUC 1.x)
5875 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5876 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5877 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
5878 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5879 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
5880 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5881 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
5883 * interface HADRIN-DPM
5884 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5886 DIMENSION PF(4),PFTOT(4),COORD(3,MAXNCL),JS(MAXNCL)
5888 * number of neutrons
5897 IF (IMODE.GT.2) MODE = 2
5898 **sr 29.5. new NPOINT(1)-definition
5899 C IF (IMODE.GE.2) NPOINT(1) = NHKK+1
5904 * get initial configuration
5907 IF (JS(I).GT.0) THEN
5908 ISTHKK(NHKK) = 10+MODE
5909 IF (IMODE.EQ.3) THEN
5910 * additional treatment if HADRIN-generator is requested
5912 IF (NHADRI.EQ.1) IDXTA = NHKK
5913 IF (NHADRI.GT.1) ISTHKK(NHKK) = 14
5916 ISTHKK(NHKK) = 12+MODE
5918 IF (NMASS.GE.2) THEN
5919 * treatment for nuclei
5920 FRAC = 1.0D0-DBLE(NCH)/DBLE(NMASS)
5922 IF ((RR.LT.FRAC).AND.(NN.LT.NNEU)) THEN
5925 ELSEIF ((RR.GE.FRAC).AND.(NP.LT.NCH)) THEN
5928 ELSEIF (NN.LT.NNEU) THEN
5931 ELSEIF (NP.LT.NCH) THEN
5935 IDHKK(NHKK) = IDT_IPDGHA(IDX)
5946 PBIN = SQRT(2.0D0*EBINDP(MODE)*AAM(1))
5949 PBIN = SQRT(2.0D0*EBINDN(MODE)*AAM(8))
5951 CALL DT_FER4M(PFER,PBIN,PF(1),PF(2),PF(3),PF(4),IDX)
5953 PFTOT(K) = PFTOT(K)+PF(K)
5954 PHKK(K,NHKK) = PF(K)
5956 PHKK(5,NHKK) = AAM(IDX)
5958 * treatment for hadrons
5959 IDHKK(NHKK) = IDT_IPDGHA(ID)
5961 PHKK(4,NHKK) = AAM(ID)
5962 PHKK(5,NHKK) = AAM(ID)
5964 C IF (IDHKK(NHKK).EQ.22) THEN
5965 C PHKK(4,NHKK) = AAM(33)
5966 C PHKK(5,NHKK) = AAM(33)
5971 PHKK(5,NHKK) = PHKK(5,NHKK)-SQRT(VIRT)
5978 VHKK(K,NHKK) = COORD(K,I)*FM2MM
5979 WHKK(K,NHKK) = COORD(K,I)*FM2MM
5981 IF (MODE.EQ.2) VHKK(1,NHKK) = VHKK(1,NHKK)+BIMPAC*FM2MM
5982 IF (MODE.EQ.2) WHKK(1,NHKK) = WHKK(1,NHKK)+BIMPAC*FM2MM
5983 VHKK(4,NHKK) = 0.0D0
5984 WHKK(4,NHKK) = 0.0D0
5987 * balance Fermi-momenta
5988 IF (NMASS.GE.2) THEN
5992 PHKK(K,NC) = PHKK(K,NC)-PFTOT(K)/DBLE(NMASS)
5994 PHKK(4,NC) = SQRT(PHKK(5,NC)**2+PHKK(1,NC)**2+
5995 & PHKK(2,NC)**2+PHKK(3,NC)**2)
6002 *$ CREATE DT_FER4M.FOR
6005 *===fer4m==============================================================*
6007 SUBROUTINE DT_FER4M(PFERM,PBIND,PXT,PYT,PZT,ET,KT)
6009 ************************************************************************
6010 * Sampling of nucleon Fermi-momenta from distributions at T=0. *
6011 * processed by S. Roesler, 17.10.95 *
6012 ************************************************************************
6014 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6017 PARAMETER ( LINP = 10 ,
6023 * particle properties (BAMJET index convention)
6025 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6026 & IICH(210),IIBAR(210),K1(210),K2(210)
6030 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
6031 & EBINDP(2),EBINDN(2),EPOT(2,210),
6032 & ETACOU(2),ICOUL,LFERMI
6034 DATA LSTART /.TRUE./
6040 1000 FORMAT(/,1X,'FER4M: sampling of Fermi-momenta activated')
6044 CALL DT_DFERMI(PABS)
6046 C IF (PABS.GE.PBIND) THEN
6048 C IF (MOD(ILOOP,500).EQ.0) THEN
6049 C WRITE(LOUT,1001) PABS,PBIND,ILOOP
6050 C1001 FORMAT(1X,'FER4M: Fermi-mom. corr. for binding',
6051 C & ' energy ',2E12.3,I6)
6055 CALL DT_DPOLI(POLC,POLS)
6056 CALL DT_DSFECF(SFE,CFE)
6060 ET = SQRT(PABS*PABS+AAM(KT)**2)
6074 *$ CREATE DT_NUC2CM.FOR
6077 *===nuc2cm=============================================================*
6079 SUBROUTINE DT_NUC2CM
6081 ************************************************************************
6082 * Lorentz-transformation of all wounded nucleons from Lab. to nucl.- *
6083 * nucl. cms. (This subroutine replaces NUCMOM.) *
6084 * This version dated 15.01.95 is written by S. Roesler *
6085 ************************************************************************
6087 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6090 PARAMETER ( LINP = 10 ,
6094 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
6098 PARAMETER (NMXHKK=200000)
6100 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6101 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6102 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6104 * extended event history
6105 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6106 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6110 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
6111 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
6114 * properties of photon/lepton projectiles
6115 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
6117 * particle properties (BAMJET index convention)
6119 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6120 & IICH(210),IIBAR(210),K1(210),K2(210)
6122 * Glauber formalism: collision properties
6123 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
6124 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
6127 * statistics: Glauber-formalism
6128 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
6140 IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.12)) THEN
6141 IF (ISTHKK(I).EQ.11) NWAACC = NWAACC+1
6142 IF (ISTHKK(I).EQ.12) NWBACC = NWBACC+1
6144 C IF (IDHKK(I).EQ.22) THEN
6152 C CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PEIN,
6153 C & PX,PY,PZ,PE,IDB,MODE)
6154 IF (PHKK(5,I).GT.ZERO) THEN
6155 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
6156 & PX,PY,PZ,PE,IDBAM(I),MODE)
6166 C IF (ID.EQ.22) ID = 113
6167 CALL DT_EVTPUT(IST,ID,I,0,PX,PY,PZ,PE,0,0,0)
6168 IF (ISTHKK(I).EQ.11) ICWP = ICWP+1
6169 IF (ISTHKK(I).EQ.12) ICWT = ICWT+1
6173 NWTACC = MAX(NWAACC,NWBACC)
6177 IF ((ICWP.EQ.0).OR.(ICWT.EQ.0)) THEN
6185 *$ CREATE DT_SPLPTN.FOR
6188 *===splptn=============================================================*
6190 SUBROUTINE DT_SPLPTN(NN)
6192 ************************************************************************
6193 * SamPLing of ParToN momenta and flavors. *
6194 * This version dated 15.01.95 is written by S. Roesler *
6195 ************************************************************************
6197 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6200 PARAMETER ( LINP = 10 ,
6204 * Lorentz-parameters of the current interaction
6205 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
6206 & UMO,PPCM,EPROJ,PPROJ
6208 * sample flavors of sea-quarks
6209 CALL DT_SPLFLA(NN,1)
6211 * sample x-values of partons at chain ends
6213 CALL DT_XKSAMP(NN,ECM)
6216 CALL DT_SPLFLA(NN,2)
6221 *$ CREATE DT_SPLFLA.FOR
6224 *===splfla=============================================================*
6226 SUBROUTINE DT_SPLFLA(NN,MODE)
6228 ************************************************************************
6229 * SamPLing of FLAvors of partons at chain ends. *
6230 * This subroutine replaces FLKSAA/FLKSAM. *
6231 * NN number of nucleon-nucleon interactions *
6232 * MODE = 1 sea-flavors *
6233 * = 2 valence-flavors *
6234 * Based on the original version written by J. Ranft/H.-J. Moehring. *
6235 * This version dated 16.01.95 is written by S. Roesler *
6236 ************************************************************************
6238 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6241 PARAMETER ( LINP = 10 ,
6245 PARAMETER ( MAXNCL = 260,
6248 & MAXSQU = 20*MAXVQU,
6249 & MAXINT = MAXVQU+MAXSQU)
6251 * flavors of partons (DTUNUC 1.x)
6252 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
6253 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
6254 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
6255 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
6256 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
6257 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
6258 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
6260 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6261 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
6262 & IXPV,IXPS,IXTV,IXTS,
6263 & INTVV1(MAXVQU),INTVV2(MAXVQU),
6264 & INTSV1(MAXVQU),INTSV2(MAXVQU),
6265 & INTVS1(MAXVQU),INTVS2(MAXVQU),
6266 & INTSS1(MAXSQU),INTSS2(MAXSQU),
6267 & INTDV1(MAXVQU),INTDV2(MAXVQU),
6268 & INTVD1(MAXVQU),INTVD2(MAXVQU),
6269 & INTDS1(MAXSQU),INTDS2(MAXSQU),
6270 & INTSD1(MAXSQU),INTSD2(MAXSQU)
6272 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6273 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
6274 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
6276 * particle properties (BAMJET index convention)
6278 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6279 & IICH(210),IIBAR(210),K1(210),K2(210)
6281 * various options for treatment of partons (DTUNUC 1.x)
6282 * (chain recombination, Cronin,..)
6283 LOGICAL LCO2CR,LINTPT
6284 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
6290 IPSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
6294 ITSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
6297 ELSEIF (MODE.EQ.2) THEN
6300 CALL DT_FLAHAD(KKPROJ(IFROVP(I)),IPVQ(I),IPPV1(I),IPPV2(I))
6303 CALL DT_FLAHAD(KKTARG(IFROVT(I)),ITVQ(I),ITTV1(I),ITTV2(I))
6310 *$ CREATE DT_GETPTN.FOR
6313 *===getptn=============================================================*
6315 SUBROUTINE DT_GETPTN(IP,NN,NCSY,IREJ)
6317 ************************************************************************
6318 * This subroutine collects partons at chain ends from temporary *
6319 * commons and puts them into DTEVT1. *
6320 * This version dated 15.01.95 is written by S. Roesler *
6321 ************************************************************************
6323 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6326 PARAMETER ( LINP = 10 ,
6330 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0)
6334 PARAMETER ( MAXNCL = 260,
6337 & MAXSQU = 20*MAXVQU,
6338 & MAXINT = MAXVQU+MAXSQU)
6342 PARAMETER (NMXHKK=200000)
6344 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6345 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6346 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6348 * extended event history
6349 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6350 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6353 * flags for input different options
6354 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6355 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6356 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6358 * auxiliary common for chain system storage (DTUNUC 1.x)
6359 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
6362 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
6363 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
6366 * flags for diffractive interactions (DTUNUC 1.x)
6367 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6369 * x-values of partons (DTUNUC 1.x)
6370 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
6371 & XTVQ(MAXVQU),XTVD(MAXVQU),
6372 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
6373 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
6375 * flavors of partons (DTUNUC 1.x)
6376 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
6377 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
6378 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
6379 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
6380 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
6381 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
6382 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
6384 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6385 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
6386 & IXPV,IXPS,IXTV,IXTS,
6387 & INTVV1(MAXVQU),INTVV2(MAXVQU),
6388 & INTSV1(MAXVQU),INTSV2(MAXVQU),
6389 & INTVS1(MAXVQU),INTVS2(MAXVQU),
6390 & INTSS1(MAXSQU),INTSS2(MAXSQU),
6391 & INTDV1(MAXVQU),INTDV2(MAXVQU),
6392 & INTVD1(MAXVQU),INTVD2(MAXVQU),
6393 & INTDS1(MAXSQU),INTDS2(MAXSQU),
6394 & INTSD1(MAXSQU),INTSD2(MAXSQU)
6396 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6397 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
6398 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
6400 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PP(4),PT(4)
6402 DATA AMSS,AMVS,AMDS,AMVD,AMVV/0.4D0,2.0D0,2.0D0,2.5D0,2.0D0/
6410 IF (ISKPCH(1,I).EQ.99) GOTO 10
6411 ICCHAI(1,1) = ICCHAI(1,1)+2
6414 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6415 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6417 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6418 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6419 PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6420 PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6422 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6423 & +(PP1(3)+PT1(3))**2)
6425 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6426 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6427 & +(PP2(3)+PT2(3))**2)
6429 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6430 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6433 IF ((AM1.LT.AMSS).OR.(AM2.LT.AMSS)) THEN
6434 C WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6435 5000 FORMAT(1X,'incon. chain mass SS: ',2I5,2E10.3)
6438 WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6440 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6441 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6442 IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6443 IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6444 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6446 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6448 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6450 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6457 IF (ISKPCH(2,I).EQ.99) GOTO 20
6458 ICCHAI(1,2) = ICCHAI(1,2)+2
6461 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6462 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6464 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6465 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6466 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6467 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6469 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6470 & +(PP1(3)+PT1(3))**2)
6472 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6473 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6474 & +(PP2(3)+PT2(3))**2)
6476 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6477 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6480 IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6481 C WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6482 5001 FORMAT(1X,'incon. chain mass DS: ',2I5,2E10.3)
6485 WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6487 IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6488 IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6489 IFT1 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6490 IFT2 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6491 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6493 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6495 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6497 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6504 IF (ISKPCH(3,I).EQ.99) GOTO 30
6505 ICCHAI(1,3) = ICCHAI(1,3)+2
6508 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6509 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6511 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6512 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6513 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6514 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6516 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6517 & +(PP1(3)+PT1(3))**2)
6519 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6520 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6521 & +(PP2(3)+PT2(3))**2)
6523 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6524 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6527 IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6528 C WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6529 5002 FORMAT(1X,'incon. chain mass SD: ',2I5,2E10.3)
6532 WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6534 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6535 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6536 IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6537 IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6538 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6540 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6542 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6544 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6549 * disea-valence chains
6551 IF (ISKPCH(5,I).EQ.99) GOTO 50
6552 ICCHAI(1,5) = ICCHAI(1,5)+2
6555 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6556 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6558 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6559 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6560 PT1(K) = XTVQ(IDXT) *PHKK(K,MOT)
6561 PT2(K) = XTVD(IDXT) *PHKK(K,MOT)
6563 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6564 & +(PP1(3)+PT1(3))**2)
6566 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6567 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6568 & +(PP2(3)+PT2(3))**2)
6570 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6571 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6574 IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6575 C WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6576 5003 FORMAT(1X,'incon. chain mass DV: ',2I5,2E10.3)
6579 WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6581 IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6582 IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6583 IFT1 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6584 IFT2 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6585 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6587 CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6589 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6591 CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6596 * valence-sea chains
6598 IF (ISKPCH(6,I).EQ.99) GOTO 60
6599 ICCHAI(1,6) = ICCHAI(1,6)+2
6602 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6603 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6605 PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6606 PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6607 PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6608 PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6610 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6611 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6612 IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6613 IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6614 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6616 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6618 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6620 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6622 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6624 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6625 & +(PP1(3)+PT1(3))**2)
6627 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6628 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6629 & +(PP2(3)+PT2(3))**2)
6631 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6633 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6635 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6637 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6639 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6641 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6642 & +(PP1(3)+PT2(3))**2)
6644 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6645 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6646 & +(PP2(3)+PT1(3))**2)
6648 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6650 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6653 IF ((AM1.LT.AMSS).OR.(AM2.LT.AMVS)) THEN
6654 C WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6655 5004 FORMAT(1X,'incon. chain mass VS: ',2I5,2E10.3)
6658 WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6663 * sea-valence chains
6665 IF (ISKPCH(4,I).EQ.99) GOTO 40
6666 ICCHAI(1,4) = ICCHAI(1,4)+2
6669 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6670 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6672 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6673 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6674 PT1(K) = XTVD(IDXT) *PHKK(K,MOT)
6675 PT2(K) = XTVQ(IDXT) *PHKK(K,MOT)
6677 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6678 & +(PP1(3)+PT1(3))**2)
6680 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6681 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6682 & +(PP2(3)+PT2(3))**2)
6684 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6685 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6688 IF ((AM1.LT.AMVS).OR.(AM2.LT.AMSS)) THEN
6689 C WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6690 5005 FORMAT(1X,'incon. chain mass SV: ',2I5,2E10.3)
6693 WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6695 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6696 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6697 IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6698 IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6699 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6701 CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6703 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6705 CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6710 * valence-disea chains
6712 IF (ISKPCH(7,I).EQ.99) GOTO 70
6713 ICCHAI(1,7) = ICCHAI(1,7)+2
6716 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6717 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6719 PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6720 PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6721 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6722 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6724 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6725 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6726 IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6727 IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6728 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6730 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6732 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6734 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6736 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6738 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6739 & +(PP1(3)+PT1(3))**2)
6741 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6742 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6743 & +(PP2(3)+PT2(3))**2)
6745 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6747 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6749 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6751 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6753 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6755 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6756 & +(PP1(3)+PT2(3))**2)
6758 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6759 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6760 & +(PP2(3)+PT1(3))**2)
6762 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6764 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6767 IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6768 C WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6769 5006 FORMAT(1X,'incon. chain mass VD: ',2I5,2E10.3)
6772 WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6777 * valence-valence chains
6779 IF (ISKPCH(8,I).EQ.99) GOTO 80
6780 ICCHAI(1,8) = ICCHAI(1,8)+2
6783 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6784 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6786 PP1(K) = XPVQ(IDXP)*PHKK(K,MOP)
6787 PP2(K) = XPVD(IDXP)*PHKK(K,MOP)
6788 PT1(K) = XTVD(IDXT)*PHKK(K,MOT)
6789 PT2(K) = XTVQ(IDXT)*PHKK(K,MOT)
6791 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6792 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6793 IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6794 IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6796 * check for diffractive event
6798 IF (((ISINGD.GT.0).OR.(IDOUBD.GT.0)).AND.
6799 & (IP.EQ.1).AND.(NN.EQ.1)) THEN
6801 PP(K) = PP1(K)+PP2(K)
6802 PT(K) = PT1(K)+PT2(K)
6805 CALL DT_DIFEVT(IFP1,IFP2,PP,MOP,
6806 & IFT1,IFT2,PT,MOT,IDIFF,NCSY,IREJ1)
6807 C IF (IREJ1.NE.0) GOTO 9999
6808 IF (IREJ1.NE.0) THEN
6816 IF (IDIFF.EQ.0) THEN
6817 * valence-valence chain system
6818 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6821 CALL DT_EVTPUT(-21,IFP1,MOP,0,
6822 & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6823 CALL DT_EVTPUT(-22,IFT1,MOT,0,
6824 & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6825 CALL DT_EVTPUT(-21,IFP2,MOP,0,
6826 & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6827 CALL DT_EVTPUT(-22,IFT2,MOT,0,
6828 & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6829 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6830 & +(PP1(3)+PT1(3))**2)
6832 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6833 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6834 & +(PP2(3)+PT2(3))**2)
6836 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6839 CALL DT_EVTPUT(-21,IFP1,MOP,0,
6840 & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6841 CALL DT_EVTPUT(-22,IFT2,MOT,0,
6842 & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6843 CALL DT_EVTPUT(-21,IFP2,MOP,0,
6844 & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6845 CALL DT_EVTPUT(-22,IFT1,MOT,0,
6846 & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6847 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6848 & +(PP1(3)+PT2(3))**2)
6850 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6851 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6852 & +(PP2(3)+PT1(3))**2)
6854 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6856 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6859 IF ((AM1.LT.AMVV).OR.(AM2.LT.AMVV)) THEN
6860 C WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6861 5007 FORMAT(1X,'incon. chain mass VV: ',2I5,2E10.3)
6864 WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6869 IF (ISTHKK(NPOINT(2)).EQ.1) NPOINT(2) = NPOINT(2)+1
6871 * energy-momentum & flavor conservation check
6872 IF (ABS(IDIFF).NE.1) THEN
6873 IF (IDIFF.NE.0) THEN
6874 IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-41,1,0,
6877 IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-31,-32,0,
6893 *$ CREATE DT_CHKCSY.FOR
6896 *===chkcsy=============================================================*
6898 SUBROUTINE DT_CHKCSY(ID1,ID2,LCHK)
6900 ************************************************************************
6901 * CHeCk Chain SYstem for consistency of partons at chain ends. *
6902 * ID1,ID2 PDG-numbers of partons at chain ends *
6903 * LCHK = .true. consistent chain *
6904 * = .false. inconsistent chain *
6905 * This version dated 18.01.95 is written by S. Roesler *
6906 ************************************************************************
6908 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6911 PARAMETER ( LINP = 10 ,
6920 IF ((ABS(ID1).LE.6).AND.(ABS(ID2).LE.6)) THEN
6921 IF (ID1*ID2.GT.0) LCHK = .FALSE.
6922 * q-qq, aq-aqaq chain
6923 ELSEIF (((ABS(ID1).LE.6).AND.(ABS(ID2).GT.6)).OR.
6924 & ((ABS(ID1).GT.6).AND.(ABS(ID2).LE.6))) THEN
6925 IF (ID1*ID2.LT.0) LCHK = .FALSE.
6927 ELSEIF ((ABS(ID1).GT.6).AND.(ABS(ID2).GT.6)) THEN
6928 IF (ID1*ID2.GT.0) LCHK = .FALSE.
6934 *$ CREATE DT_EVENTA.FOR
6937 *===eventa=============================================================*
6939 SUBROUTINE DT_EVENTA(ID,IP,IT,NCSY,IREJ)
6941 ************************************************************************
6942 * Treatment of nucleon-nucleon interactions in a two-chain *
6944 * (input) ID BAMJET-index of projectile hadron (in case of *
6946 * IP/IT mass number of projectile/target nucleus *
6947 * NCSY number of two chain systems *
6948 * IREJ rejection flag *
6949 * This version dated 15.01.95 is written by S. Roesler *
6950 ************************************************************************
6952 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6955 PARAMETER ( LINP = 10 ,
6959 PARAMETER (TINY10=1.0D-10)
6963 PARAMETER (NMXHKK=200000)
6965 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6966 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6967 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6969 * extended event history
6970 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6971 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6975 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6976 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6977 & IREXCI(3),IRDIFF(2),IRINC
6979 * flags for diffractive interactions (DTUNUC 1.x)
6980 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6982 * particle properties (BAMJET index convention)
6984 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6985 & IICH(210),IIBAR(210),K1(210),K2(210)
6987 * flags for input different options
6988 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6989 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6990 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6992 * various options for treatment of partons (DTUNUC 1.x)
6993 * (chain recombination, Cronin,..)
6994 LOGICAL LCO2CR,LINTPT
6995 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
6998 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
7003 * skip following treatment for low-mass diffraction
7004 IF (ABS(IFLAGD).EQ.1) THEN
7005 NPOINT(3) = NPOINT(2)
7009 * multiple scattering of chain ends
7010 IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
7011 IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
7014 * get a two-chain system from DTEVT1
7022 PT1(K) = PHKK(K,NC+1)
7023 PP2(K) = PHKK(K,NC+2)
7024 PT2(K) = PHKK(K,NC+3)
7030 CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
7031 & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
7032 IF (IREJ1.GT.0) THEN
7034 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTA'
7040 * meson/antibaryon projectile:
7041 * sample single-chain valence-valence systems (Reggeon contrib.)
7042 IF ((IP.EQ.1).AND.(ISICHA.EQ.1)) THEN
7043 IF (IIBAR(ID).LE.0) CALL DT_VV2SCH
7046 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
7047 * check DTEVT1 for remaining resonance mass corrections
7048 CALL DT_EVTRES(IREJ1)
7049 IF (IREJ1.GT.0) THEN
7050 IRRES(1) = IRRES(1)+1
7051 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in EVENTA'
7056 * assign p_t to two-"chain" systems consisting of two resonances only
7057 * since only entries for chains will be affected, this is obsolete
7058 * in case of JETSET-fragmetation
7061 * combine q-aq chains to color ropes (qq-aqaq) (chain fusion)
7062 IF (LCO2CR) CALL DT_COM2CR
7066 * fragmentation of the complete event
7067 **uncomment for internal phojet-fragmentation
7068 C CALL DT_EVTFRA(IREJ1)
7069 CALL DT_EVTFRG(2,IDUM,NPYMEM,IREJ1)
7070 IF (IREJ1.GT.0) THEN
7072 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 3 in EVENTA'
7076 * decay of possible resonances (should be obsolete)
7087 *$ CREATE DT_GETCSY.FOR
7090 *===getcsy=============================================================*
7092 SUBROUTINE DT_GETCSY(IFPR1,PP1,MOP1,IFPR2,PP2,MOP2,
7093 & IFTA1,PT1,MOT1,IFTA2,PT2,MOT2,IREJ)
7095 ************************************************************************
7096 * This version dated 15.01.95 is written by S. Roesler *
7097 ************************************************************************
7099 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7102 PARAMETER ( LINP = 10 ,
7106 PARAMETER (TINY10=1.0D-10)
7110 PARAMETER (NMXHKK=200000)
7112 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7113 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7114 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7116 * extended event history
7117 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7118 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7122 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7123 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7124 & IREXCI(3),IRDIFF(2),IRINC
7126 * flags for input different options
7127 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7128 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7129 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7131 * flags for diffractive interactions (DTUNUC 1.x)
7132 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
7134 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),
7135 & IFP1(2),IFP2(2),IFT1(2),IFT2(2),PCH1(4),PCH2(4)
7139 * get quark content of partons
7146 IFP1(1) = IDT_IPDG2B(IFPR1,1,2)
7147 IF (ABS(IFPR1).GE.1000) IFP1(2) = IDT_IPDG2B(IFPR1,2,2)
7148 IFP2(1) = IDT_IPDG2B(IFPR2,1,2)
7149 IF (ABS(IFPR2).GE.1000) IFP2(2) = IDT_IPDG2B(IFPR2,2,2)
7150 IFT1(1) = IDT_IPDG2B(IFTA1,1,2)
7151 IF (ABS(IFTA1).GE.1000) IFT1(2) = IDT_IPDG2B(IFTA1,2,2)
7152 IFT2(1) = IDT_IPDG2B(IFTA2,1,2)
7153 IF (ABS(IFTA2).GE.1000) IFT2(2) = IDT_IPDG2B(IFTA2,2,2)
7155 * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq, 3 - qq-aqaq)
7157 IF ((IFP1(2).EQ.0).AND.(IFT1(2).EQ.0)) IDCH1 = 1
7158 IF ((IFP1(2).NE.0).AND.(IFT1(2).NE.0)) IDCH1 = 3
7160 IF ((IFP2(2).EQ.0).AND.(IFT2(2).EQ.0)) IDCH2 = 1
7161 IF ((IFP2(2).NE.0).AND.(IFT2(2).NE.0)) IDCH2 = 3
7163 * store initial configuration for energy-momentum cons. check
7164 IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IDUM)
7166 * sample intrinsic p_t at chain-ends
7167 CALL DT_GETSPT(PP1,IFPR1,IFP1,PP2,IFPR2,IFP2,
7168 & PT1,IFTA1,IFT1,PT2,IFTA2,IFT2,
7169 & AMCH1,IDCH1,AMCH2,IDCH2,IDCH(MOP1),IREJ1)
7170 IF (IREJ1.NE.0) THEN
7171 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in GETCSY'
7176 C IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
7177 C IF ((IDCH1.EQ.3).OR.((IDCH1.GT.1).AND.(IDCH2.EQ.1))) THEN
7178 C* check second chain for resonance
7179 C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7180 C & AMCH2,AMCH2N,IDCH2,IREJ1)
7181 C IF (IREJ1.NE.0) GOTO 9999
7182 C IF (IDR2.NE.0) THEN
7183 C CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
7184 C & AMCH2,AMCH2N,AMCH1,IREJ1)
7185 C IF (IREJ1.NE.0) GOTO 9999
7187 C* check first chain for resonance
7188 C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7189 C & AMCH1,AMCH1N,IDCH1,IREJ1)
7190 C IF (IREJ1.NE.0) GOTO 9999
7191 C IF (IDR1.NE.0) IDR1 = 100*IDR1
7193 C* check first chain for resonance
7194 C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7195 C & AMCH1,AMCH1N,IDCH1,IREJ1)
7196 C IF (IREJ1.NE.0) GOTO 9999
7197 C IF (IDR1.NE.0) THEN
7198 C CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
7199 C & AMCH1,AMCH1N,AMCH2,IREJ1)
7200 C IF (IREJ1.NE.0) GOTO 9999
7202 C* check second chain for resonance
7203 C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7204 C & AMCH2,AMCH2N,IDCH2,IREJ1)
7205 C IF (IREJ1.NE.0) GOTO 9999
7206 C IF (IDR2.NE.0) IDR2 = 100*IDR2
7210 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
7211 * check chains for resonances
7212 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7213 & AMCH1,AMCH1N,IDCH1,IREJ1)
7214 IF (IREJ1.NE.0) GOTO 9999
7215 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7216 & AMCH2,AMCH2N,IDCH2,IREJ1)
7217 IF (IREJ1.NE.0) GOTO 9999
7218 * change kinematics corresponding to resonance-masses
7219 IF ( (IDR1.NE.0).AND.(IDR2.EQ.0) ) THEN
7220 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
7221 & AMCH1,AMCH1N,AMCH2,IREJ1)
7222 IF (IREJ1.GT.0) GOTO 9999
7223 IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
7224 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7225 & AMCH2,AMCH2N,IDCH2,IREJ1)
7226 IF (IREJ1.NE.0) GOTO 9999
7227 IF (IDR2.NE.0) IDR2 = 100*IDR2
7228 ELSEIF ( (IDR1.EQ.0).AND.(IDR2.NE.0) ) THEN
7229 CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
7230 & AMCH2,AMCH2N,AMCH1,IREJ1)
7231 IF (IREJ1.GT.0) GOTO 9999
7232 IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
7233 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7234 & AMCH1,AMCH1N,IDCH1,IREJ1)
7235 IF (IREJ1.NE.0) GOTO 9999
7236 IF (IDR1.NE.0) IDR1 = 100*IDR1
7237 ELSEIF ( (IDR1.NE.0).AND.(IDR2.NE.0) ) THEN
7238 AMDIF1 = ABS(AMCH1-AMCH1N)
7239 AMDIF2 = ABS(AMCH2-AMCH2N)
7240 IF (AMDIF2.LT.AMDIF1) THEN
7241 CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
7242 & AMCH2,AMCH2N,AMCH1,IREJ1)
7243 IF (IREJ1.GT.0) GOTO 9999
7244 IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
7245 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),
7246 & IDR1,IDXR1,AMCH1,AMCH1N,IDCH1,IREJ1)
7247 IF (IREJ1.NE.0) GOTO 9999
7248 IF (IDR1.NE.0) IDR1 = 100*IDR1
7250 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
7251 & AMCH1,AMCH1N,AMCH2,IREJ1)
7252 IF (IREJ1.GT.0) GOTO 9999
7253 IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
7254 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),
7255 & IDR2,IDXR2,AMCH2,AMCH2N,IDCH2,IREJ1)
7256 IF (IREJ1.NE.0) GOTO 9999
7257 IF (IDR2.NE.0) IDR2 = 100*IDR2
7262 * store final configuration for energy-momentum cons. check
7264 CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IDUM)
7265 CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
7266 IF (IREJ1.NE.0) GOTO 9999
7269 * put partons and chains into DTEVT1
7271 PCH1(I) = PP1(I)+PT1(I)
7272 PCH2(I) = PP2(I)+PT2(I)
7274 CALL DT_EVTPUT(-ISTHKK(MOP1),IFPR1,MOP1,0,PP1(1),PP1(2),
7275 & PP1(3),PP1(4),0,0,0)
7276 CALL DT_EVTPUT(-ISTHKK(MOT1),IFTA1,MOT1,0,PT1(1),PT1(2),
7277 & PT1(3),PT1(4),0,0,0)
7278 KCH = 100+IDCH(MOP1)*10+1
7279 CALL DT_EVTPUT(KCH,88888,-2,-1,
7280 & PCH1(1),PCH1(2),PCH1(3),PCH1(4),IDR1,IDXR1,IDCH(MOP1))
7281 CALL DT_EVTPUT(-ISTHKK(MOP2),IFPR2,MOP2,0,PP2(1),PP2(2),
7282 & PP2(3),PP2(4),0,0,0)
7283 CALL DT_EVTPUT(-ISTHKK(MOT2),IFTA2,MOT2,0,PT2(1),PT2(2),
7284 & PT2(3),PT2(4),0,0,0)
7286 CALL DT_EVTPUT(KCH,88888,-2,-1,
7287 & PCH2(1),PCH2(2),PCH2(3),PCH2(4),IDR2,IDXR2,IDCH(MOP2))
7292 IF ((IDCH(MOP1).LE.3).AND.(IDCH(MOP2).LE.3)) THEN
7293 * "cancel" sea-sea chains
7294 CALL DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ1)
7295 IF (IREJ1.NE.0) GOTO 9998
7296 **sr 16.5. flag for EVENTB
7305 *$ CREATE DT_CHKINE.FOR
7308 *===chkine=============================================================*
7310 SUBROUTINE DT_CHKINE(PP1I,IFP1,PP2I,IFP2,PT1I,IFT1,PT2I,IFT2,
7311 & AMCH1,AMCH1N,AMCH2,IREJ)
7313 ************************************************************************
7314 * This subroutine replaces CORMOM. *
7315 * This version dated 05.01.95 is written by S. Roesler *
7316 ************************************************************************
7318 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7321 PARAMETER ( LINP = 10 ,
7325 PARAMETER (TINY10=1.0D-10)
7327 * flags for input different options
7328 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7329 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7330 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7333 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7334 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7335 & IREXCI(3),IRDIFF(2),IRINC
7337 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),P1(4),P2(4),
7338 & PP1I(4),PP2I(4),PT1I(4),PT2I(4)
7343 SCALE = AMCH1N/MAX(AMCH1,TINY10)
7349 PP2(I) = PP2(I)+(1.0D0-SCALE)*PP1(I)
7350 PT2(I) = PT2(I)+(1.0D0-SCALE)*PT1(I)
7351 PP1(I) = SCALE*PP1(I)
7352 PT1(I) = SCALE*PT1(I)
7354 IF ((PP1(4).LT.0.0D0).OR.(PP2(4).LT.0.0D0).OR.
7355 & (PT1(4).LT.0.0D0).OR.(PT2(4).LT.0.0D0)) GOTO 9997
7358 PCH = SQRT( (PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2+
7359 & (PP2(3)+PT2(3))**2 )
7360 AMCH22 = (ECH-PCH)*(ECH+PCH)
7361 IF (AMCH22.LT.0.0D0) THEN
7363 & WRITE(LOUT,'(1X,A)') 'CHKINE: inconsistent treatment!'
7368 AMCH2 = SQRT(AMCH22)
7370 * put partons again on mass shell
7374 IF (JMSHL.EQ.1) THEN
7380 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
7381 IF (IREJ1.NE.0) THEN
7382 IF (JMSHL.EQ.0) GOTO 9998
7394 IF (JMSHL.EQ.1) THEN
7400 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P1,P2,IREJ1)
7401 IF (IREJ1.NE.0) THEN
7402 IF (JMSHL.EQ.0) GOTO 9998
7418 9997 IRCHKI(1) = IRCHKI(1)+1
7424 9998 IRCHKI(2) = IRCHKI(2)+1
7427 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in CHKINE'
7432 *$ CREATE DT_CH2RES.FOR
7435 *===ch2res=============================================================*
7437 SUBROUTINE DT_CH2RES(IF1,IF2,IF3,IF4,IDR,IDXR,
7438 & AM,AMN,IMODE,IREJ)
7440 ************************************************************************
7441 * Check chains for resonance production. *
7442 * This subroutine replaces COMCMA/COBCMA/COMCM2 *
7444 * IF1,2,3,4 input flavors (q,aq in any order) *
7446 * MODE = 1 check q-aq chain for meson-resonance *
7447 * = 2 check q-qq, aq-aqaq chain for baryon-resonance *
7448 * = 3 check qq-aqaq chain for lower mass cut *
7450 * IDR = 0 no resonances found *
7451 * = -1 pseudoscalar meson/octet baryon *
7452 * = 1 vector-meson/decuplet baryon *
7453 * IDXR BAMJET-index of corresponding resonance *
7454 * AMN mass of corresponding resonance *
7456 * IREJ rejection flag *
7457 * This version dated 06.01.95 is written by S. Roesler *
7458 ************************************************************************
7460 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7463 PARAMETER ( LINP = 10 ,
7467 * particle properties (BAMJET index convention)
7469 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7470 & IICH(210),IIBAR(210),K1(210),K2(210)
7472 * quark-content to particle index conversion (DTUNUC 1.x)
7473 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
7474 & IA08(6,21),IA10(6,21)
7477 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7478 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7479 & IREXCI(3),IRDIFF(2),IRINC
7481 * flags for input different options
7482 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7483 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7484 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7486 DIMENSION IF(4),JF(4)
7489 C DATA AMLOM,AMLOB /0.08D0,0.2D0/
7490 DATA AMLOM,AMLOB /0.1D0,0.7D0/
7492 C DATA AMLOM,AMLOB /0.001D0,0.001D0/
7496 IF ((MODE.LT.1).OR.(MODE.GT.3)) THEN
7497 WRITE(LOUT,1000) MODE
7498 1000 FORMAT(1X,'CH2RES: MODE ',I4,' not supported!',/,
7499 & 1X,' program stopped')
7508 IF ((AM.LE.0.0D0).AND.(MODE.EQ.1)) AMX = AMLOM
7509 IF ((AM.LE.0.0D0).AND.(MODE.EQ.2)) AMX = AMLOB
7517 IF (IF(I).NE.0) THEN
7522 IF (NF.LE.MODE) THEN
7523 WRITE(LOUT,1001) MODE,IF
7524 1001 FORMAT(1X,'CH2RES: inconsistent input flavors in MODE ',
7525 & I4,' IF1 = ',I4,' IF2 = ',I4,' IF3 = ',I4,' IF4 = ',I4)
7531 * check for meson resonance
7535 IF (JF(2).GT.0) THEN
7539 IFPS = IMPS(IFAQ,IFQ)
7540 IFV = IMVE(IFAQ,IFQ)
7544 IF (AMX.LT.AMV) THEN
7545 IF (AMX.LT.AMPS) THEN
7546 IF (IMODE.GT.0) THEN
7547 IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOM)) GOTO 9999
7549 IF (AMX.LT.0.8D0*AMPS) GOTO 9999
7553 * replace chain by pseudoscalar meson
7557 ELSEIF (AMX.LT.AMHI) THEN
7558 * replace chain by vector-meson
7565 * check for baryon resonance
7567 CALL DT_DBKLAS(JF(1),JF(2),JF(3),JB8,JB10)
7571 IF (AMX.LT.AM10) THEN
7572 IF (AMX.LT.AM8) THEN
7573 IF (IMODE.GT.0) THEN
7574 IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOB)) GOTO 9999
7576 IF (AMX.LT.0.8D0*AM8) GOTO 9999
7580 * replace chain by oktet baryon
7584 ELSEIF (AMX.LT.AMHI) THEN
7591 * check qq-aqaq for lower mass cut
7593 * empirical definition of AMHI to allow for (b-antib)-pair prod.
7595 IF (AMX.LT.AMHI) GOTO 9999
7599 IF ((IOULEV(1).GT.0).AND.(IMODE.GT.0))
7600 & WRITE(LOUT,*) 'rejected 1 in CH2RES',IMODE
7602 IRRES(2) = IRRES(2)+1
7606 *$ CREATE DT_RJSEAC.FOR
7609 *===rjseac=============================================================*
7611 SUBROUTINE DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ)
7613 ************************************************************************
7614 * ReJection of SEA-sea Chains. *
7615 * MOP1/2 entries of projectile sea-partons in DTEVT1 *
7616 * MOT1/2 entries of projectile sea-partons in DTEVT1 *
7617 * This version dated 16.01.95 is written by S. Roesler *
7618 ************************************************************************
7620 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7623 PARAMETER ( LINP = 10 ,
7627 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
7631 PARAMETER (NMXHKK=200000)
7633 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7634 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7635 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7637 * extended event history
7638 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7639 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7643 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7644 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7647 DIMENSION IDXSEA(2,2),IDXNUC(2),ISTVAL(2)
7651 * projectile sea q-aq-pair
7652 * indices of sea-pair
7655 * index of mother-nucleon
7656 IDXNUC(1) = JMOHKK(1,MOP1)
7657 * status of valence quarks to be corrected
7660 * target sea q-aq-pair
7661 * indices of sea-pair
7664 * index of mother-nucleon
7665 IDXNUC(2) = JMOHKK(1,MOT1)
7666 * status of valence quarks to be corrected
7671 DO 2 I=NPOINT(2),NHKK
7672 IF ((ISTHKK(I).EQ.ISTVAL(N)).AND.
7673 & (JMOHKK(1,I).EQ.IDXNUC(N))) THEN
7674 * valence parton found
7675 * inrease 4-momentum by sea 4-momentum
7677 PHKK(K,I) = PHKK(K,I)+PHKK(K,IDXSEA(N,1))+
7678 & PHKK(K,IDXSEA(N,2))
7680 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
7681 & PHKK(2,I)**2-PHKK(3,I)**2))
7684 ISTHKK(IDXSEA(N,J)) = 100
7685 IDHKK(IDXSEA(N,J)) = 0
7686 JMOHKK(1,IDXSEA(N,J)) = 0
7687 JMOHKK(2,IDXSEA(N,J)) = 0
7688 JDAHKK(1,IDXSEA(N,J)) = 0
7689 JDAHKK(2,IDXSEA(N,J)) = 0
7691 PHKK(K,IDXSEA(N,J)) = ZERO
7692 VHKK(K,IDXSEA(N,J)) = ZERO
7693 WHKK(K,IDXSEA(N,J)) = ZERO
7695 PHKK(5,IDXSEA(N,J)) = ZERO
7700 IF (IDONE.NE.1) THEN
7701 WRITE(LOUT,1000) NEVHKK,MOP1,MOP2,MOT1,MOT2
7702 1000 FORMAT(1X,'RJSEAC: event ',I8,': inconsistent event',
7703 & '-record!',/,1X,' sea-quark pairs ',
7704 & 2I5,4X,2I5,' could not be canceled!')
7716 *$ CREATE DT_VV2SCH.FOR
7719 *===vv2sch=============================================================*
7721 SUBROUTINE DT_VV2SCH
7723 ************************************************************************
7724 * Change Valence-Valence chain systems to Single CHain systems for *
7725 * hadron-nucleus collisions with meson or antibaryon projectile. *
7726 * (Reggeon contribution) *
7727 * The single chain system is approximately treated as one chain and a *
7729 * This version dated 18.01.95 is written by S. Roesler *
7730 ************************************************************************
7732 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7735 PARAMETER ( LINP = 10 ,
7739 PARAMETER (ZERO=0.0D0,TINY7=1.0D-7,TINY3=1.0D-3)
7745 PARAMETER (NMXHKK=200000)
7747 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7748 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7749 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7751 * extended event history
7752 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7753 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7756 * flags for input different options
7757 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7758 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7759 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7762 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7763 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7766 DIMENSION IF(4,2),MO(4),PP1(4),PP2(4),PT1(4),PT2(4),PCH1(4),
7769 DATA LSTART /.TRUE./
7774 1000 FORMAT(/,1X,'VV2SCH: Reggeon contribution to valance-',
7775 & 'valence chains treated')
7781 * get index of first chain
7782 DO 1 I=NPOINT(3),NHKK
7783 IF (IDHKK(I).EQ.88888) THEN
7790 IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)
7791 & .AND.(NC.LT.NSTOP)) THEN
7792 * get valence-valence chains
7793 IF ((IDCH(NC).EQ.8).AND.(IDCH(NC+3).EQ.8)) THEN
7794 * get "mother"-hadron indices
7795 MO1 = JMOHKK(1,JMOHKK(1,JMOHKK(1,NC)))
7796 MO2 = JMOHKK(1,JMOHKK(1,JMOHKK(2,NC)))
7797 KPROJ = IDT_ICIHAD(IDHKK(MO1))
7798 KTARG = IDT_ICIHAD(IDHKK(MO2))
7799 * Lab momentum of projectile hadron
7800 CALL DT_LTNUC(PHKK(3,MO1),PHKK(4,MO1),PPZ,PPE,-3)
7801 PTOT = SQRT(PHKK(1,MO1)**2+PHKK(2,MO1)**2+
7804 SICHAP = DT_PHNSCH(KPROJ,KTARG,PTOT)
7805 IF (DT_RNDM(PTOT).LE.SICHAP) THEN
7807 * single chain requested
7808 * get flavors of chain-end partons
7809 MO(1) = JMOHKK(1,NC)
7810 MO(2) = JMOHKK(2,NC)
7811 MO(3) = JMOHKK(1,NC+3)
7812 MO(4) = JMOHKK(2,NC+3)
7814 IF(I,1) = IDT_IPDG2B(IDHKK(MO(I)),1,2)
7816 IF (ABS(IDHKK(MO(I))).GE.1000)
7817 & IF(I,2) = IDT_IPDG2B(IDHKK(MO(I)),2,2)
7819 * which one is the q-aq chain?
7820 * N1,N1+1 - DTEVT1-entries for q-aq system
7821 * N2,N2+1 - DTEVT1-entries for the other chain
7822 IF ((IF(1,2).EQ.0).AND.(IF(2,2).EQ.0)) THEN
7827 ELSEIF ((IF(3,2).EQ.0).AND.(IF(4,2).EQ.0)) THEN
7837 PT1(K) = PHKK(K,N1+1)
7839 PT2(K) = PHKK(K,N2+1)
7841 AMCH1 = PHKK(5,N1+2)
7842 AMCH2 = PHKK(5,N2+2)
7843 * get meson-identity corresponding to flavors of q-aq chain
7846 CALL DT_CH2RES(IF(K1,1),IF(K1+1,1),0,0,IDR1,IDXR1,
7847 & ZERO,AMCH1N,1,IDUM)
7849 * change kinematics of chains
7850 CALL DT_CHKINE(PP1,IDHKK(N1), PP2,IDHKK(N2),
7851 & PT1,IDHKK(N1+1),PT2,IDHKK(N2+1),
7852 & AMCH1,AMCH1N,AMCH2,IREJ1)
7853 IF (IREJ1.NE.0) GOTO 10
7854 * check second chain for resonance
7856 IF ((IF(K2,2).NE.0).AND.(IF(K2+1,2).NE.0)) IDCHAI = 3
7857 CALL DT_CH2RES(IF(K2,1),IF(K2,2),IF(K2+1,1),IF(K2+1,2),
7858 & IDR2,IDXR2,AMCH2,AMCH2N,IDCHAI,IREJ1)
7859 IF (IREJ1.NE.0) GOTO 10
7860 IF (IDR2.NE.0) IDR2 = 100*IDR2
7861 * add partons and chains to DTEVT1
7863 PCH1(K) = PP1(K)+PT1(K)
7864 PCH2(K) = PP2(K)+PT2(K)
7866 CALL DT_EVTPUT(ISTHKK(N1),IDHKK(N1),N1,0,PP1(1),PP1(2),
7867 & PP1(3),PP1(4),0,0,0)
7868 CALL DT_EVTPUT(ISTHKK(N1+1),IDHKK(N1+1),N1+1,0,PT1(1),
7869 & PT1(2),PT1(3),PT1(4),0,0,0)
7870 KCH = ISTHKK(N1+2)+100
7871 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH1(1),PCH1(2),PCH1(3),
7872 & PCH1(4),IDR1,IDXR1,IDCH(N1+2))
7874 CALL DT_EVTPUT(ISTHKK(N2),IDHKK(N2),N2,0,PP2(1),PP2(2),
7875 & PP2(3),PP2(4),0,0,0)
7876 CALL DT_EVTPUT(ISTHKK(N2+1),IDHKK(N2+1),N2+1,0,PT2(1),
7877 & PT2(2),PT2(3),PT2(4),0,0,0)
7878 KCH = ISTHKK(N2+2)+100
7879 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH2(1),PCH2(2),PCH2(3),
7880 & PCH2(4),IDR2,IDXR2,IDCH(N2+2))
7896 *$ CREATE DT_PHNSCH.FOR
7899 *=== phnsch ===========================================================*
7901 DOUBLE PRECISION FUNCTION DT_PHNSCH( KP, KTARG, PLAB )
7903 *----------------------------------------------------------------------*
7905 * Probability for Hadron Nucleon Single CHain interactions: *
7907 * Created on 30 december 1993 by Alfredo Ferrari & Paola Sala *
7910 * Last change on 04-jan-94 by Alfredo Ferrari *
7912 * modified by J.R.for use in DTUNUC 6.1.94 *
7914 * Input variables: *
7915 * Kp = hadron projectile index (Part numbering *
7917 * Ktarg = target nucleon index (1=proton, 8=neutron) *
7918 * Plab = projectile laboratory momentum (GeV/c) *
7919 * Output variable: *
7920 * Phnsch = probability per single chain (particle *
7921 * exchange) interactions *
7923 *----------------------------------------------------------------------*
7925 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7928 PARAMETER ( LUNOUT = 6 )
7929 PARAMETER ( LUNERR = 6 )
7930 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
7931 PARAMETER ( ZERZER = 0.D+00 )
7932 PARAMETER ( ONEONE = 1.D+00 )
7933 PARAMETER ( TWOTWO = 2.D+00 )
7934 PARAMETER ( FIVFIV = 5.D+00 )
7935 PARAMETER ( HLFHLF = 0.5D+00 )
7937 PARAMETER ( NALLWP = 39 )
7938 PARAMETER ( IDMAXP = 210 )
7940 DIMENSION ICHRGE(39),AM(39)
7942 * particle properties (BAMJET index convention)
7944 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7945 & IICH(210),IIBAR(210),K1(210),K2(210)
7947 DIMENSION KPTOIP(210)
7949 * auxiliary common for reggeon exchange (DTUNUC 1.x)
7950 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
7951 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
7952 & IQTCHR(-6:6),MQUARK(3,39)
7954 DIMENSION SGTCOE (5,33), IHLP (NALLWP)
7955 DIMENSION SGTCO1(5,10),SGTCO2(5,8),SGTCO3(5,15)
7956 EQUIVALENCE (SGTCO1(1,1),SGTCOE(1,1))
7957 EQUIVALENCE (SGTCO2(1,1),SGTCOE(1,11))
7958 EQUIVALENCE (SGTCO3(1,1),SGTCOE(1,19))
7960 * Conversion from part to paprop numbering
7961 DATA KPTOIP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
7962 & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 66*0,
7963 & 34, 36, 31, 32, 33, 35, 37, 5*0, 38, 5*0, 39, 19*0, 27, 28, 74*0/
7965 * 1=baryon, 2=pion, 3=kaon, 4=antibaryon:
7966 DATA IHLP/1,4,5*0,1,4,2*0,3,2*2,2*3,1,4,3,3*1,2,
7967 & 2*3, 2, 4*0, 3*4, 1, 4, 1, 4, 1, 4 /
7968 C DATA ( ( SGTCOE (J,I), J=1,5 ), I=1,10 ) /
7970 * 1st reaction: gamma p total
7971 &0.147 D+00, ZERZER , ZERZER , 0.0022D+00, -0.0170D+00,
7972 * 2nd reaction: gamma d total
7973 &0.300 D+00, ZERZER , ZERZER , 0.0095D+00, -0.057 D+00,
7974 * 3rd reaction: pi+ p total
7975 &16.4 D+00, 19.3D+00, -0.42D+00, 0.19 D+00, ZERZER ,
7976 * 4th reaction: pi- p total
7977 &33.0 D+00, 14.0D+00, -1.36D+00, 0.456 D+00, -4.03 D+00,
7978 * 5th reaction: pi+/- d total
7979 &56.8 D+00, 42.2D+00, -1.45D+00, 0.65 D+00, -5.39 D+00,
7980 * 6th reaction: K+ p total
7981 &18.1 D+00, ZERZER , ZERZER , 0.26 D+00, -1.0 D+00,
7982 * 7th reaction: K+ n total
7983 &18.7 D+00, ZERZER , ZERZER , 0.21 D+00, -0.89 D+00,
7984 * 8th reaction: K+ d total
7985 &34.2 D+00, 7.9 D+00, -2.1 D+00, 0.346 D+00, -0.99 D+00,
7986 * 9th reaction: K- p total
7987 &32.1 D+00, ZERZER , ZERZER , 0.66 D+00, -5.6 D+00,
7988 * 10th reaction: K- n total
7989 &25.2 D+00, ZERZER , ZERZER , 0.38 D+00, -2.9 D+00/
7990 C DATA ( ( SGTCOE (J,I), J=1,5 ), I=11,18 ) /
7992 * 11th reaction: K- d total
7993 &57.6 D+00, ZERZER , ZERZER , 1.17 D+00, -9.5 D+00,
7994 * 12th reaction: p p total
7995 &48.0 D+00, ZERZER , ZERZER , 0.522 D+00, -4.51 D+00,
7996 * 13th reaction: p n total
7997 &47.30 D+00, ZERZER , ZERZER , 0.513 D+00, -4.27 D+00,
7998 * 14th reaction: p d total
7999 &91.3 D+00, ZERZER , ZERZER , 1.05 D+00, -8.8 D+00,
8000 * 15th reaction: pbar p total
8001 &38.4 D+00, 77.6D+00, -0.64D+00, 0.26 D+00, -1.2 D+00,
8002 * 16th reaction: pbar n total
8003 &ZERZER ,133.6D+00, -0.70D+00, -1.22 D+00, 13.7 D+00,
8004 * 17th reaction: pbar d total
8005 &112. D+00, 125.D+00, -1.08D+00, 1.14 D+00, -12.4 D+00,
8006 * 18th reaction: Lamda p total
8007 &30.4 D+00, ZERZER , ZERZER , ZERZER , 1.6 D+00/
8008 C DATA ( ( SGTCOE (J,I), J=1,5 ), I=19,33 ) /
8010 * 19th reaction: pi+ p elastic
8011 &ZERZER , 11.4D+00, -0.4 D+00, 0.079 D+00, ZERZER ,
8012 * 20th reaction: pi- p elastic
8013 &1.76 D+00, 11.2D+00, -0.64D+00, 0.043 D+00, ZERZER ,
8014 * 21st reaction: K+ p elastic
8015 &5.0 D+00, 8.1 D+00, -1.8 D+00, 0.16 D+00, -1.3 D+00,
8016 * 22nd reaction: K- p elastic
8017 &7.3 D+00, ZERZER , ZERZER , 0.29 D+00, -2.40 D+00,
8018 * 23rd reaction: p p elastic
8019 &11.9 D+00, 26.9D+00, -1.21D+00, 0.169 D+00, -1.85 D+00,
8020 * 24th reaction: p d elastic
8021 &16.1 D+00, ZERZER , ZERZER , 0.32 D+00, -3.4 D+00,
8022 * 25th reaction: pbar p elastic
8023 &10.2 D+00, 52.7D+00, -1.16D+00, 0.125 D+00, -1.28 D+00,
8024 * 26th reaction: pbar p elastic bis
8025 &10.6 D+00, 53.1D+00, -1.19D+00, 0.136 D+00, -1.41 D+00,
8026 * 27th reaction: pbar n elastic
8027 &36.5 D+00, ZERZER , ZERZER , ZERZER , -11.9 D+00,
8028 * 28th reaction: Lamda p elastic
8029 &12.3 D+00, ZERZER , ZERZER , ZERZER , -2.4 D+00,
8030 * 29th reaction: K- p ela bis
8031 &7.24 D+00, 46.0D+00, -4.71D+00, 0.279 D+00, -2.35 D+00,
8032 * 30th reaction: pi- p cx
8033 &ZERZER ,0.912D+00, -1.22D+00, ZERZER , ZERZER ,
8034 * 31st reaction: K- p cx
8035 &ZERZER , 3.39D+00, -1.75D+00, ZERZER , ZERZER ,
8036 * 32nd reaction: K+ n cx
8037 &ZERZER , 7.18D+00, -2.01D+00, ZERZER , ZERZER ,
8038 * 33rd reaction: pbar p cx
8039 &ZERZER , 18.8D+00, -2.01D+00, ZERZER , ZERZER /
8041 * +-------------------------------------------------------------------*
8042 ICHRGE(KTARG)=IICH(KTARG)
8043 AM (KTARG)=AAM (KTARG)
8044 * | Check for pi0 (d-dbar)
8045 IF ( KP .NE. 26 ) THEN
8051 * +-------------------------------------------------------------------*
8058 * +-------------------------------------------------------------------*
8059 * +-------------------------------------------------------------------*
8060 * | No such interactions for baryon-baryon
8061 IF ( IIBAR (KP) .GT. 0 ) THEN
8065 * +-------------------------------------------------------------------*
8066 * | No "annihilation" diagram possible for K+ p/n
8067 ELSE IF ( IP .EQ. 15 ) THEN
8071 * +-------------------------------------------------------------------*
8072 * | No "annihilation" diagram possible for K0 p/n
8073 ELSE IF ( IP .EQ. 24 ) THEN
8077 * +-------------------------------------------------------------------*
8078 * | No "annihilation" diagram possible for Omebar p/n
8079 ELSE IF ( IP .GE. 38 ) THEN
8084 * +-------------------------------------------------------------------*
8085 * +-------------------------------------------------------------------*
8086 * | If the momentum is larger than 50 GeV/c, compute the single
8087 * | chain probability at 50 GeV/c and extrapolate to the present
8088 * | momentum according to 1/sqrt(s)
8089 * | sigma = sigma_sch (50) * sqrt (s(50)/s) + sigma_dch
8090 * | P_sch (50) = sigma_sch (50) / ( sigma_dch + sigma_sch (50) )
8091 * | sigma_dch / sigma_sch (50) = 1 / P_sch (50) - 1
8092 * | sigma_dch / sigma_sch = 1 / P_sch - 1 = ( 1 / P_sch (50) - 1 )
8094 * | P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
8095 IF ( PLAB .GT. 50.D+00 ) THEN
8098 AMTSQ = AM (KTARG)**2
8099 EPROJ = SQRT ( PLAB**2 + AMPSQ )
8100 UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8101 EPROJ = SQRT ( PLA**2 + AMPSQ )
8102 UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8103 UMORAT = SQRT ( UMOSQ / UMO50 )
8105 * +-------------------------------------------------------------------*
8107 ELSE IF ( PLAB .LT. 3.D+00 ) THEN
8110 AMTSQ = AM (KTARG)**2
8111 EPROJ = SQRT ( PLAB**2 + AMPSQ )
8112 UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8113 EPROJ = SQRT ( PLA**2 + AMPSQ )
8114 UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8115 UMORAT = SQRT ( UMOSQ / UMO50 )
8117 * +-------------------------------------------------------------------*
8124 * +-------------------------------------------------------------------*
8126 * +-------------------------------------------------------------------*
8128 IF ( IHLP (IP) .EQ. 2 ) THEN
8134 * | Compute the pi+ p total cross section:
8135 SPPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8137 ACOF = SGTCOE (1,19)
8138 BCOF = SGTCOE (2,19)
8139 ENNE = SGTCOE (3,19)
8140 CCOF = SGTCOE (4,19)
8141 DCOF = SGTCOE (5,19)
8142 * | Compute the pi+ p elastic cross section:
8143 SPPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8145 * | Compute the pi+ p inelastic cross section:
8146 SPPPIN = SPPPTT - SPPPEL
8152 * | Compute the pi- p total cross section:
8153 SPMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8155 ACOF = SGTCOE (1,20)
8156 BCOF = SGTCOE (2,20)
8157 ENNE = SGTCOE (3,20)
8158 CCOF = SGTCOE (4,20)
8159 DCOF = SGTCOE (5,20)
8160 * | Compute the pi- p elastic cross section:
8161 SPMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8163 * | Compute the pi- p inelastic cross section:
8164 SPMPIN = SPMPTT - SPMPEL
8165 SIGDIA = SPMPIN - SPPPIN
8166 * | +----------------------------------------------------------------*
8167 * | | Charged pions: besides isospin consideration it is supposed
8168 * | | that (pi+ n)el is almost equal to (pi- p)el
8169 * | | and (pi+ p)el " " " " (pi- n)el
8170 * | | and all are almost equal among each others
8171 * | | (reasonable above 5 GeV/c)
8172 IF ( ICHRGE (IP) .NE. 0 ) THEN
8174 JREAC = 3 + IP - 13 + ICHRGE (IP) * KHELP
8175 ACOF = SGTCOE (1,JREAC)
8176 BCOF = SGTCOE (2,JREAC)
8177 ENNE = SGTCOE (3,JREAC)
8178 CCOF = SGTCOE (4,JREAC)
8179 DCOF = SGTCOE (5,JREAC)
8180 * | | Compute the total cross section:
8181 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8183 JREAC = 19 + IP - 13 + ICHRGE (IP) * KHELP
8184 ACOF = SGTCOE (1,JREAC)
8185 BCOF = SGTCOE (2,JREAC)
8186 ENNE = SGTCOE (3,JREAC)
8187 CCOF = SGTCOE (4,JREAC)
8188 DCOF = SGTCOE (5,JREAC)
8189 * | | Compute the elastic cross section:
8190 SHNCEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8192 * | | Compute the inelastic cross section:
8193 SHNCIN = SHNCTT - SHNCEL
8194 * | | Number of diagrams:
8195 NDIAGR = 1 + IP - 13 + ICHRGE (IP) * KHELP
8196 * | | Now compute the chain end (anti)quark-(anti)diquark
8197 IQFSC1 = 1 + IP - 13
8200 IQBSC2 = 1 + IP - 13
8202 * | +----------------------------------------------------------------*
8203 * | | pi0: besides isospin consideration it is supposed that the
8204 * | | elastic cross section is not very different from
8205 * | | pi+ p and/or pi- p (reasonable above 5 GeV/c)
8208 K2HLP = ( KP - 23 ) / 3
8209 * | | Number of diagrams:
8210 * | | For u ubar (k2hlp=0):
8211 * NDIAGR = 2 - KHELP
8212 * | | For d dbar (k2hlp=1):
8213 * NDIAGR = 2 + KHELP - K2HLP
8214 NDIAGR = 2 + KHELP * ( 2 * K2HLP - 1 ) - K2HLP
8215 SHNCIN = HLFHLF * ( SPPPIN + SPMPIN )
8216 * | | Now compute the chain end (anti)quark-(anti)diquark
8223 * | +----------------------------------------------------------------*
8225 * +-------------------------------------------------------------------*
8227 ELSE IF ( IHLP (IP) .EQ. 3 ) THEN
8233 * | Compute the K+ p total cross section:
8234 SKPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8236 ACOF = SGTCOE (1,21)
8237 BCOF = SGTCOE (2,21)
8238 ENNE = SGTCOE (3,21)
8239 CCOF = SGTCOE (4,21)
8240 DCOF = SGTCOE (5,21)
8241 * | Compute the K+ p elastic cross section:
8242 SKPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8244 * | Compute the K+ p inelastic cross section:
8245 SKPPIN = SKPPTT - SKPPEL
8251 * | Compute the K- p total cross section:
8252 SKMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8254 ACOF = SGTCOE (1,22)
8255 BCOF = SGTCOE (2,22)
8256 ENNE = SGTCOE (3,22)
8257 CCOF = SGTCOE (4,22)
8258 DCOF = SGTCOE (5,22)
8259 * | Compute the K- p elastic cross section:
8260 SKMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8262 * | Compute the K- p inelastic cross section:
8263 SKMPIN = SKMPTT - SKMPEL
8264 SIGDIA = HLFHLF * ( SKMPIN - SKPPIN )
8265 * | +----------------------------------------------------------------*
8266 * | | Charged Kaons: actually only K-
8267 IF ( ICHRGE (IP) .NE. 0 ) THEN
8269 * | | +-------------------------------------------------------------*
8270 * | | | Proton target:
8271 IF ( KHELP .EQ. 0 ) THEN
8273 * | | | Number of diagrams:
8276 * | | +-------------------------------------------------------------*
8277 * | | | Neutron target: besides isospin consideration it is supposed
8278 * | | | that (K- n)el is almost equal to (K- p)el
8279 * | | | (reasonable above 5 GeV/c)
8281 ACOF = SGTCOE (1,10)
8282 BCOF = SGTCOE (2,10)
8283 ENNE = SGTCOE (3,10)
8284 CCOF = SGTCOE (4,10)
8285 DCOF = SGTCOE (5,10)
8286 * | | | Compute the total cross section:
8287 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8289 * | | | Compute the elastic cross section:
8291 * | | | Compute the inelastic cross section:
8292 SHNCIN = SHNCTT - SHNCEL
8293 * | | | Number of diagrams:
8297 * | | +-------------------------------------------------------------*
8298 * | | Now compute the chain end (anti)quark-(anti)diquark
8304 * | +----------------------------------------------------------------*
8305 * | | K0's: (actually only K0bar)
8308 * | | +-------------------------------------------------------------*
8309 * | | | Proton target: (K0bar p)in supposed to be given by
8310 * | | | (K- p)in - Sig_diagr
8311 IF ( KHELP .EQ. 0 ) THEN
8312 SHNCIN = SKMPIN - SIGDIA
8313 * | | | Number of diagrams:
8316 * | | +-------------------------------------------------------------*
8317 * | | | Neutron target: (K0bar n)in supposed to be given by
8318 * | | | (K- n)in + Sig_diagr
8319 * | | | besides isospin consideration it is supposed
8320 * | | | that (K- n)el is almost equal to (K- p)el
8321 * | | | (reasonable above 5 GeV/c)
8323 ACOF = SGTCOE (1,10)
8324 BCOF = SGTCOE (2,10)
8325 ENNE = SGTCOE (3,10)
8326 CCOF = SGTCOE (4,10)
8327 DCOF = SGTCOE (5,10)
8328 * | | | Compute the total cross section:
8329 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8331 * | | | Compute the elastic cross section:
8333 * | | | Compute the inelastic cross section:
8334 SHNCIN = SHNCTT - SHNCEL + SIGDIA
8335 * | | | Number of diagrams:
8339 * | | +-------------------------------------------------------------*
8340 * | | Now compute the chain end (anti)quark-(anti)diquark
8347 * | +----------------------------------------------------------------*
8349 * +-------------------------------------------------------------------*
8351 ELSE IF ( IHLP (IP) .EQ. 4 .AND. IP .LE. 9 ) THEN
8352 * | For momenta between 3 and 5 GeV/c the use of tabulated data
8353 * | should be implemented!
8354 ACOF = SGTCOE (1,15)
8355 BCOF = SGTCOE (2,15)
8356 ENNE = SGTCOE (3,15)
8357 CCOF = SGTCOE (4,15)
8358 DCOF = SGTCOE (5,15)
8359 * | Compute the pbar p total cross section:
8360 SAPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8362 IF ( PLA .LT. FIVFIV ) THEN
8367 ACOF = SGTCOE (1,JREAC)
8368 BCOF = SGTCOE (2,JREAC)
8369 ENNE = SGTCOE (3,JREAC)
8370 CCOF = SGTCOE (4,JREAC)
8371 DCOF = SGTCOE (5,JREAC)
8372 * | Compute the pbar p elastic cross section:
8373 SAPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8375 * | Compute the pbar p inelastic cross section:
8376 SAPPIN = SAPPTT - SAPPEL
8377 ACOF = SGTCOE (1,12)
8378 BCOF = SGTCOE (2,12)
8379 ENNE = SGTCOE (3,12)
8380 CCOF = SGTCOE (4,12)
8381 DCOF = SGTCOE (5,12)
8382 * | Compute the p p total cross section:
8383 SPPTOT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8385 ACOF = SGTCOE (1,23)
8386 BCOF = SGTCOE (2,23)
8387 ENNE = SGTCOE (3,23)
8388 CCOF = SGTCOE (4,23)
8389 DCOF = SGTCOE (5,23)
8390 * | Compute the p p elastic cross section:
8391 SPPELA = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8393 * | Compute the K- p inelastic cross section:
8394 SPPINE = SPPTOT - SPPELA
8395 SIGDIA = ( SAPPIN - SPPINE ) / FIVFIV
8397 * | +----------------------------------------------------------------*
8399 IF ( ICHRGE (IP) .NE. 0 ) THEN
8401 * | | +-------------------------------------------------------------*
8402 * | | | Proton target:
8403 IF ( KHELP .EQ. 0 ) THEN
8404 * | | | Number of diagrams:
8408 * | | +-------------------------------------------------------------*
8409 * | | | Neutron target: it is supposed that (ap n)el is almost equal
8410 * | | | to (ap p)el (reasonable above 5 GeV/c)
8412 ACOF = SGTCOE (1,16)
8413 BCOF = SGTCOE (2,16)
8414 ENNE = SGTCOE (3,16)
8415 CCOF = SGTCOE (4,16)
8416 DCOF = SGTCOE (5,16)
8417 * | | | Compute the total cross section:
8418 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8420 * | | | Compute the elastic cross section:
8422 * | | | Compute the inelastic cross section:
8423 SHNCIN = SHNCTT - SHNCEL
8427 * | | +-------------------------------------------------------------*
8428 * | | Now compute the chain end (anti)quark-(anti)diquark
8429 * | | there are different possibilities, make a random choiche:
8431 RNCHEN = DT_RNDM(PUUBAR)
8432 IF ( RNCHEN .LT. PUUBAR ) THEN
8437 IQBSC1 = -IQFSC1 + KHELP
8440 * | +----------------------------------------------------------------*
8444 * | | +-------------------------------------------------------------*
8445 * | | | Proton target: (nbar p)in supposed to be given by
8446 * | | | (pbar p)in - Sig_diagr
8447 IF ( KHELP .EQ. 0 ) THEN
8448 SHNCIN = SAPPIN - SIGDIA
8451 * | | +-------------------------------------------------------------*
8452 * | | | Neutron target: (nbar n)el is supposed to be equal to
8453 * | | | (pbar p)el (reasonable above 5 GeV/c)
8455 * | | | Compute the total cross section:
8457 * | | | Compute the elastic cross section:
8459 * | | | Compute the inelastic cross section:
8460 SHNCIN = SHNCTT - SHNCEL
8464 * | | +-------------------------------------------------------------*
8465 * | | Now compute the chain end (anti)quark-(anti)diquark
8466 * | | there are different possibilities, make a random choiche:
8468 RNCHEN = DT_RNDM(RNCHEN)
8469 IF ( RNCHEN .LT. PDDBAR ) THEN
8474 IQBSC1 = -IQFSC1 + KHELP - 1
8478 * | +----------------------------------------------------------------*
8480 * +-------------------------------------------------------------------*
8481 * | Others: not yet implemented
8490 * +-------------------------------------------------------------------*
8491 DT_PHNSCH = NDIAGR * SIGDIA / SHNCIN
8492 IQECHC = IQECHR (IQFSC1) + IQECHR (IQFSC2) + IQECHR (IQBSC1)
8494 IQBCHC = IQBCHR (IQFSC1) + IQBCHR (IQFSC2) + IQBCHR (IQBSC1)
8498 IQSCHC = IQSCHR (IQFSC1) + IQSCHR (IQFSC2) + IQSCHR (IQBSC1)
8500 IQSPRO = IQSCHR (MQUARK(1,IP)) + IQSCHR (MQUARK(2,IP))
8501 & + IQSCHR (MQUARK(3,IP))
8502 * +-------------------------------------------------------------------*
8503 * | Consistency check:
8504 IF ( DT_PHNSCH .LE. ZERZER .OR. DT_PHNSCH .GT. ONEONE ) THEN
8505 WRITE (LUNOUT,*)' *** Phnsch,kp,ktarg,pla',
8506 & DT_PHNSCH,KP,KTARG,PLA,' ****'
8507 WRITE (LUNERR,*)' *** Phnsch,kp,ktarg,pla',
8508 & DT_PHNSCH,KP,KTARG,PLA,' ****'
8509 DT_PHNSCH = MAX ( DT_PHNSCH, ZERZER )
8510 DT_PHNSCH = MIN ( DT_PHNSCH, ONEONE )
8513 * +-------------------------------------------------------------------*
8514 * +-------------------------------------------------------------------*
8515 * | Consistency check:
8516 IF ( IQSPRO .NE. IQSCHC .OR. ICHRGE (IP) + ICHRGE (KTARG)
8517 & .NE. IQECHC .OR. IIBAR (KP) + IIBAR (KTARG) .NE. IQBCHC) THEN
8519 &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8520 & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8522 &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8523 & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8526 * +-------------------------------------------------------------------*
8527 * P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
8528 IF ( UMORAT .GT. ONEPLS )
8529 & DT_PHNSCH = ONEONE / ( ( ONEONE / DT_PHNSCH
8530 & - ONEONE ) * UMORAT + ONEONE )
8533 ENTRY DT_SCHQUA ( JQFSC1, JQFSC2, JQBSC1, JQBSC2 )
8539 *=== End of function Phnsch ===========================================*
8543 *$ CREATE DT_RESPT.FOR
8546 *===respt==============================================================*
8550 ************************************************************************
8551 * Check DTEVT1 for two-resonance systems and sample intrinsic p_t. *
8552 * This version dated 18.01.95 is written by S. Roesler *
8553 ************************************************************************
8555 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8558 PARAMETER ( LINP = 10 ,
8562 PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8566 PARAMETER (NMXHKK=200000)
8568 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8569 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8570 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8572 * extended event history
8573 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8574 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8577 * get index of first chain
8578 DO 1 I=NPOINT(3),NHKK
8579 IF (IDHKK(I).EQ.88888) THEN
8586 IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)) THEN
8587 C WRITE(LOUT,*)NC,NC+3,IDRES(NC),IDRES(NC+3)
8588 * skip VV-,SS- systems
8589 IF ((IDCH(NC ).NE.1).AND.(IDCH(NC ).NE.8).AND.
8590 & (IDCH(NC+3).NE.1).AND.(IDCH(NC+3).NE.8)) THEN
8591 * check if both "chains" are resonances
8592 IF ((IDRES(NC).NE.0).AND.(IDRES(NC+3).NE.0)) THEN
8593 CALL DT_SAPTRE(NC,NC+3)
8607 *$ CREATE DT_EVTRES.FOR
8610 *===evtres=============================================================*
8612 SUBROUTINE DT_EVTRES(IREJ)
8614 ************************************************************************
8615 * This version dated 14.12.94 is written by S. Roesler *
8616 ************************************************************************
8618 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8621 PARAMETER ( LINP = 10 ,
8625 PARAMETER (TINY5=1.0D-5,TINY10=1.0D-10)
8629 PARAMETER (NMXHKK=200000)
8631 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8632 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8633 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8635 * extended event history
8636 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8637 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8640 * flags for input different options
8641 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8642 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8643 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8645 * particle properties (BAMJET index convention)
8647 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
8648 & IICH(210),IIBAR(210),K1(210),K2(210)
8650 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),IFP(2),IFT(2)
8654 DO 1 I=NPOINT(3),NHKK
8655 IF (ABS(IDRES(I)).GE.100) THEN
8657 DO 2 J=NPOINT(3),NHKK
8658 IF (IDHKK(J).EQ.88888) THEN
8659 IF (PHKK(5,J).GT.AMMX) THEN
8665 IF (IDRES(IMMX).NE.0) THEN
8666 IF (IOULEV(3).GT.0) THEN
8667 WRITE(LOUT,'(1X,A)')
8668 & 'EVTRES: no chain for correc. found'
8677 IF (PHKK(3,IMO11).LT.0.0D0) THEN
8681 IMO21 = JMOHKK(1,IMMX)
8682 IMO22 = JMOHKK(2,IMMX)
8683 IF (PHKK(3,IMO21).LT.0.0D0) THEN
8684 IMO21 = JMOHKK(2,IMMX)
8685 IMO22 = JMOHKK(1,IMMX)
8688 AMCH1N = AAM(IDXRES(I))
8690 IFPR1 = IDHKK(IMO11)
8691 IFPR2 = IDHKK(IMO21)
8692 IFTA1 = IDHKK(IMO12)
8693 IFTA2 = IDHKK(IMO22)
8695 PP1(J) = PHKK(J,IMO11)
8696 PP2(J) = PHKK(J,IMO21)
8697 PT1(J) = PHKK(J,IMO12)
8698 PT2(J) = PHKK(J,IMO22)
8700 * store initial configuration for energy-momentum cons. check
8701 IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IREJ1)
8702 * correct kinematics of second chain
8703 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
8704 & AMCH1,AMCH1N,AMCH2,IREJ1)
8705 IF (IREJ1.NE.0) GOTO 9999
8706 * check now this chain for resonance mass
8707 IFP(1) = IDT_IPDG2B(IFPR2,1,2)
8709 IF (ABS(IFPR2).GE.1000) IFP(2) = IDT_IPDG2B(IFPR2,2,2)
8710 IFT(1) = IDT_IPDG2B(IFTA2,1,2)
8712 IF (ABS(IFTA2).GE.1000) IFT(2) = IDT_IPDG2B(IFTA2,2,2)
8714 IF ((IFP(2).EQ.0).AND.(IFT(2).EQ.0)) IDCH2 = 1
8715 IF ((IFP(2).NE.0).AND.(IFT(2).NE.0)) IDCH2 = 3
8716 CALL DT_CH2RES(IFP(1),IFP(2),IFT(1),IFT(2),IDR2,IDXR2,
8717 & AMCH2,AMCH2N,IDCH2,IREJ1)
8718 IF ((IREJ1.NE.0).OR.(IDR2.NE.0)) THEN
8720 & WRITE(LOUT,*) ' correction for resonance not poss.'
8726 * store final configuration for energy-momentum cons. check
8728 CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IREJ1)
8729 CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
8730 IF (IREJ1.NE.0) GOTO 9999
8733 PHKK(J,IMO11) = PP1(J)
8734 PHKK(J,IMO21) = PP2(J)
8735 PHKK(J,IMO12) = PT1(J)
8736 PHKK(J,IMO22) = PT2(J)
8738 * correct entries of chains
8740 PHKK(K,I) = PHKK(K,IMO11)+PHKK(K,IMO12)
8741 PHKK(K,IMMX) = PHKK(K,IMO21)+PHKK(K,IMO22)
8743 AM1 = PHKK(4,I)**2-PHKK(1,I)**2-PHKK(2,I)**2-PHKK(3,I)**2
8744 AM2 = PHKK(4,IMMX)**2-PHKK(1,IMMX)**2-PHKK(2,IMMX)**2-
8746 * ?? the following should now be obsolete
8748 C IF ((AM1.LT.0.0D0).OR.(AM2.LT.1.0D0)) THEN
8749 IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8751 WRITE(LOUT,'(1X,A,4G10.3)')
8752 & 'EVTRES: inonsistent mass-corr.',AM1,AM2
8756 PHKK(5,I) = SQRT(AM1)
8757 PHKK(5,IMMX) = SQRT(AM2)
8758 IDRES(I) = IDRES(I)/100
8759 IF ((ABS(PHKK(5,I)-AMCH1N).GT.TINY5).OR.
8760 & (ABS(PHKK(5,IMMX)-AMCH2).GT.TINY5)) THEN
8761 WRITE(LOUT,'(1X,A,4G10.3)')
8762 & 'EVTRES: inconsistent chain-masses',
8763 & PHKK(5,I),AMCH1N,PHKK(5,IMMX),AMCH2
8776 *$ CREATE DT_GETSPT.FOR
8779 *===getspt=============================================================*
8781 SUBROUTINE DT_GETSPT(PP1I,IFPR1,IFP1,PP2I,IFPR2,IFP2,
8782 & PT1I,IFTA1,IFT1,PT2I,IFTA2,IFT2,
8783 & AM1,IDCH1,AM2,IDCH2,IDCHAI,IREJ)
8785 ************************************************************************
8786 * This version dated 12.12.94 is written by S. Roesler *
8787 ************************************************************************
8789 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8792 PARAMETER ( LINP = 10 ,
8796 PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,ZERO=0.0D0)
8798 * various options for treatment of partons (DTUNUC 1.x)
8799 * (chain recombination, Cronin,..)
8800 LOGICAL LCO2CR,LINTPT
8801 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8804 * flags for input different options
8805 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8806 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8807 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8809 * flags for diffractive interactions (DTUNUC 1.x)
8810 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
8812 DIMENSION PP1(4),PP1I(4),PP2(4),PP2I(4),PT1(4),PT1I(4),
8813 & PT2(4),PT2I(4),P1(4),P2(4),
8814 & IFP1(2),IFP2(2),IFT1(2),IFT2(2),
8815 & PTOTI(4),PTOTF(4),DIFF(4)
8821 C IF ((IDCHAI.EQ.6).OR.(IDCHAI.EQ.7).OR.(IDCHAI.EQ.8)) B33P = 2.0D0
8822 C IF ((IDCHAI.EQ.4).OR.(IDCHAI.EQ.5).OR.(IDCHAI.EQ.8)) B33T = 2.0D0
8828 IF (IDIFF.NE.0) THEN
8834 PTOTI(I) = PP1I(I)+PP2I(I)+PT1I(I)+PT2I(I)
8840 * get initial chain masses
8841 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8842 & +(PP1(3)+PT1(3))**2)
8844 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
8845 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8846 & +(PP2(3)+PT2(3))**2)
8848 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
8849 IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8851 & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 1',
8861 C IF ((AM1.GE.3.0D0).AND.(AM2.GE.3.0D0)) THEN
8865 C IF (AM1.LT.0.6) THEN
8867 C ELSEIF ((AM1.GE.1.2).AND.(AM1.LT.3.0D0)) THEN
8870 C IF (AM2.LT.0.6) THEN
8872 C ELSEIF ((AM2.GE.1.2).AND.(AM2.LT.3.0D0)) THEN
8877 * check chain masses for very low mass chains
8878 C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8879 C & AM1,DUM,-IDCH1,IREJ1)
8880 C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8881 C & AM2,DUM,-IDCH2,IREJ2)
8882 C IF ((IREJ1.NE.0).OR.(IREJ2.NE.0)) THEN
8891 IF (MOD(IC,15).EQ.0) B33P = 2.0D0*B33P
8892 IF (MOD(IC,15).EQ.0) B33T = 2.0D0*B33T
8893 IF (MOD(IC,18).EQ.0) REDU = 0.0D0
8894 C IF (MOD(IC,19).EQ.0) JMSHL = 0
8895 IF (MOD(IC,20).EQ.0) GOTO 7
8896 C WRITE(LOUT,'(1X,A)') 'GETSPT: rejection '
8901 * get transverse momentum
8903 ES = -2.0D0/(B33P**2)
8904 & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8905 HPSP = SQRT(ES*ES+2.0D0*ES*0.94D0)
8907 ES = -2.0D0/(B33T**2)
8908 & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8909 HPST = SQRT(ES*ES+2.0D0*ES*0.94D0)
8915 CALL DT_DSFECF(SFE1,CFE1)
8916 CALL DT_DSFECF(SFE2,CFE2)
8918 PP1(1) = PP1I(1)+HPSP*CFE1
8919 PP1(2) = PP1I(2)+HPSP*SFE1
8920 PP2(1) = PP2I(1)-HPSP*CFE1
8921 PP2(2) = PP2I(2)-HPSP*SFE1
8922 PT1(1) = PT1I(1)+HPST*CFE2
8923 PT1(2) = PT1I(2)+HPST*SFE2
8924 PT2(1) = PT2I(1)-HPST*CFE2
8925 PT2(2) = PT2I(2)-HPST*SFE2
8927 PP1(1) = PP1I(1)+HPSP*CFE1
8928 PP1(2) = PP1I(2)+HPSP*SFE1
8929 PT1(1) = PT1I(1)-HPSP*CFE1
8930 PT1(2) = PT1I(2)-HPSP*SFE1
8931 PP2(1) = PP2I(1)+HPST*CFE2
8932 PP2(2) = PP2I(2)+HPST*SFE2
8933 PT2(1) = PT2I(1)-HPST*CFE2
8934 PT2(2) = PT2I(2)-HPST*SFE2
8937 * put partons on mass shell
8940 IF (JMSHL.EQ.1) THEN
8942 XMP1 = PYMASS(IFPR1)
8943 XMT1 = PYMASS(IFTA1)
8946 CALL DT_MASHEL(PP1,PT1,XMP1,XMT1,P1,P2,IREJ1)
8947 IF (IREJ1.NE.0) GOTO 2
8949 PTOTF(I) = P1(I)+P2(I)
8955 IF (JMSHL.EQ.1) THEN
8957 XMP2 = PYMASS(IFPR2)
8958 XMT2 = PYMASS(IFTA2)
8961 CALL DT_MASHEL(PP2,PT2,XMP2,XMT2,P1,P2,IREJ1)
8962 IF (IREJ1.NE.0) GOTO 2
8964 PTOTF(I) = PTOTF(I)+P1(I)+P2(I)
8971 DIFF(I) = PTOTI(I)-PTOTF(I)
8973 IF ((ABS(DIFF(1)).GT.TINY5).OR.(ABS(DIFF(2)).GT.TINY5).OR.
8974 & (ABS(DIFF(3)).GT.TINY5).OR.(ABS(DIFF(4)).GT.TINY5)) THEN
8975 WRITE(LOUT,'(1X,A,4G10.3)') 'GETSPT: inconsistencies ',DIFF
8978 PTOTP1 = SQRT(PP1(1)**2+PP1(2)**2+PP1(3)**2)
8979 AMP1 = SQRT(ABS( (PP1(4)-PTOTP1)*(PP1(4)+PTOTP1) ))
8980 PTOTP2 = SQRT(PP2(1)**2+PP2(2)**2+PP2(3)**2)
8981 AMP2 = SQRT(ABS( (PP2(4)-PTOTP2)*(PP2(4)+PTOTP2) ))
8982 PTOTT1 = SQRT(PT1(1)**2+PT1(2)**2+PT1(3)**2)
8983 AMT1 = SQRT(ABS( (PT1(4)-PTOTT1)*(PT1(4)+PTOTT1) ))
8984 PTOTT2 = SQRT(PT2(1)**2+PT2(2)**2+PT2(3)**2)
8985 AMT2 = SQRT(ABS( (PT2(4)-PTOTT2)*(PT2(4)+PTOTT2) ))
8986 IF ((ABS(AMP1-XMP1).GT.TINY3).OR.(ABS(AMP2-XMP2).GT.TINY3).OR.
8987 & (ABS(AMT1-XMT1).GT.TINY3).OR.(ABS(AMT2-XMT2).GT.TINY3))
8989 WRITE(LOUT,'(1X,A,2(4G10.3,/))')
8990 & 'GETSPT: inconsistent masses',
8991 & AMP1,XMP1,AMP2,XMP2,AMT1,XMT1,AMT2,XMT2
8992 * sr 22.11.00: commented. It should only have inconsistent masses for
8993 * ultrahigh energies due to rounding problems
8998 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8999 & +(PP1(3)+PT1(3))**2)
9001 AM1N = (ECH+PTOCH)*(ECH-PTOCH)
9002 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
9003 & +(PP2(3)+PT2(3))**2)
9005 AM2N = (ECH+PTOCH)*(ECH-PTOCH)
9006 IF ((AM1N.LT.0.0D0).OR.(AM2N.LT.0.0D0)) THEN
9008 & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 2',
9015 * check chain masses for very low mass chains
9016 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
9017 & AM1N,DUM,-IDCH1,IREJ1)
9018 IF (IREJ1.NE.0) GOTO 2
9019 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
9020 & AM2N,DUM,-IDCH2,IREJ2)
9021 IF (IREJ2.NE.0) GOTO 2
9024 IF (AM1N.GT.ZERO) THEN
9042 *$ CREATE DT_SAPTRE.FOR
9045 *===saptre=============================================================*
9047 SUBROUTINE DT_SAPTRE(IDX1,IDX2)
9049 ************************************************************************
9050 * p-t sampling for two-resonance systems. ("BAMJET-like" method) *
9051 * IDX1,IDX2 indices of resonances ("chains") in DTEVT1 *
9052 * Adopted from the original SAPTRE written by J. Ranft. *
9053 * This version dated 18.01.95 is written by S. Roesler *
9054 ************************************************************************
9056 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9059 PARAMETER ( LINP = 10 ,
9063 PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
9067 PARAMETER (NMXHKK=200000)
9069 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9070 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9071 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9073 * extended event history
9074 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9075 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9078 * flags for input different options
9079 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
9080 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
9081 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
9083 DIMENSION PA1(4),PA2(4),P1(4),P2(4)
9087 ESMAX1 = PHKK(4,IDX1)-PHKK(5,IDX1)
9088 ESMAX2 = PHKK(4,IDX2)-PHKK(5,IDX2)
9089 ESMAX = MIN(ESMAX1,ESMAX2)
9090 IF (ESMAX.LE.0.05D0) RETURN
9094 PA1(K) = PHKK(K,IDX1)
9095 PA2(K) = PHKK(K,IDX2)
9099 CALL DT_EVTEMC(PA1(1),PA1(2),PA1(3),PA1(4),1,IDUM,IDUM)
9100 CALL DT_EVTEMC(PA2(1),PA2(2),PA2(3),PA2(4),2,IDUM,IDUM)
9104 IF (B3*ESMAX.LE.60.0D0) EXEB = EXP(-B3*ESMAX)
9105 BEXP = HMA*(1.0D0-EXEB)/B3
9106 AXEXP = (1.0D0-(B3*ESMAX-1.0D0)*EXEB)/B3**2
9107 WA = AXEXP/(BEXP+AXEXP)
9110 * ES is the transverse kinetic energy
9114 ES = -2.0D0/(B3**2)*LOG(X*Y+TINY7)
9117 ES = ABS(-LOG(X+TINY7)/B3)
9119 IF (ES.GT.ESMAX) GOTO 10
9121 * transverse momentum
9122 HPS = SQRT((ES-HMA)*(ES+HMA))
9124 CALL DT_DSFECF(SFE,CFE)
9127 PZ1NSQ = PA1(3)**2-HPS**2-2.0D0*PA1(1)*HPX-2.0D0*PA1(2)*HPY
9128 PZ2NSQ = PA2(3)**2-HPS**2+2.0D0*PA2(1)*HPX+2.0D0*PA2(2)*HPY
9129 IF ((PZ1NSQ.LT.TINY3).OR.(PZ2NSQ.LT.TINY3)) RETURN
9131 C PA1(3) = SIGN(SQRT(PZ1NSQ),PA1(3))
9132 C PA2(3) = SIGN(SQRT(PZ2NSQ),PA2(3))
9138 * put resonances on mass-shell again
9141 CALL DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ1)
9142 IF (IREJ1.NE.0) RETURN
9145 CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,IDUM,IDUM)
9146 CALL DT_EVTEMC(-P2(1),-P2(2),-P2(3),-P2(4),2,IDUM,IDUM)
9147 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,12,IREJ1)
9148 IF (IREJ1.NE.0) RETURN
9152 PHKK(K,IDX1) = P1(K)
9153 PHKK(K,IDX2) = P2(K)
9159 *$ CREATE DT_CRONIN.FOR
9162 *===cronin=============================================================*
9164 SUBROUTINE DT_CRONIN(INCL)
9166 ************************************************************************
9167 * Cronin-Effect. Multiple scattering of partons at chain ends. *
9168 * INCL = 1 multiple sc. in projectile *
9169 * = 2 multiple sc. in target *
9170 * This version dated 05.01.96 is written by S. Roesler. *
9171 ************************************************************************
9173 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9176 PARAMETER ( LINP = 10 ,
9180 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
9184 PARAMETER (NMXHKK=200000)
9186 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9187 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9188 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9190 * extended event history
9191 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9192 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9196 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
9197 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
9198 & IREXCI(3),IRDIFF(2),IRINC
9200 * Glauber formalism: collision properties
9201 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
9202 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
9204 DIMENSION R(3),PIN(4),POUT(4),DEV(4)
9210 DO 2 I=NPOINT(2),NHKK
9211 IF (ISTHKK(I).LT.0) THEN
9212 * get z-position of the chain
9213 R(1) = VHKK(1,I)*1.0D12
9214 IF (INCL.EQ.2) R(1) = VHKK(1,I)*1.0D12-BIMPAC
9215 R(2) = VHKK(2,I)*1.0D12
9217 IF ( (INCL.EQ.1).AND.(ISTHKK(IDXNU).EQ.10) )
9218 & IDXNU = JMOHKK(1,I-1)
9219 IF ( (INCL.EQ.2).AND.(ISTHKK(IDXNU).EQ. 9) )
9220 & IDXNU = JMOHKK(1,I+1)
9221 R(3) = VHKK(3,IDXNU)*1.0D12
9222 * position of target parton the chain is connected to
9226 * multiple scattering of parton with DTEVT1-index I
9227 CALL DT_CROMSC(PIN,R,POUT,INCL)
9229 C IF (NEVHKK.EQ.5) THEN
9230 C AMIN = PIN(4)**2-PIN(1)**2-PIN(2)**2-PIN(3)**2
9231 C AMOU = POUT(4)**2-POUT(1)**2-POUT(2)**2-POUT(3)**2
9232 C AMIN = SIGN(SQRT(ABS(AMIN)),AMIN)
9233 C AMOU = SIGN(SQRT(ABS(AMOU)),AMOU)
9234 C WRITE(6,'(A,I4,2E15.5)')'I,AMIN,AMOU: ',I,AMIN,AMOU
9235 C WRITE(6,'(A,4E15.5)')'PIN: ',PIN
9236 C WRITE(6,'(A,4E15.5)')'POUT: ',POUT
9239 * increase accumulator by energy-momentum difference
9241 DEV(K) = DEV(K)+POUT(K)-PIN(K)
9244 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
9245 & PHKK(2,I)**2-PHKK(3,I)**2))
9249 * dump accumulator to momenta of valence partons
9252 DO 5 I=NPOINT(2),NHKK
9253 IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
9255 ETOT = ETOT+PHKK(4,I)
9258 C WRITE(LOUT,1000) NVAL,(DEV(K)/DBLE(NVAL),K=1,4)
9259 1000 FORMAT(1X,'CRONIN : number of val. partons ',I4,/,
9261 DO 6 I=NPOINT(2),NHKK
9262 IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
9265 C PHKK(K,I) = PHKK(K,I)-DEV(K)/DBLE(NVAL)
9266 PHKK(K,I) = PHKK(K,I)-DEV(K)*E/ETOT
9268 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
9269 & PHKK(2,I)**2-PHKK(3,I)**2))
9276 *$ CREATE DT_CROMSC.FOR
9279 *===cromsc=============================================================*
9281 SUBROUTINE DT_CROMSC(PIN,R,POUT,INCL)
9283 ************************************************************************
9284 * Cronin-Effect. Multiple scattering of one parton passing through *
9286 * PIN(4) input 4-momentum of parton *
9287 * POUT(4) 4-momentum of parton after mult. scatt. *
9288 * R(3) spatial position of parton in target nucleus *
9289 * INCL = 1 multiple sc. in projectile *
9290 * = 2 multiple sc. in target *
9291 * This is a revised version of the original version written by J. Ranft*
9292 * This version dated 17.01.95 is written by S. Roesler. *
9293 ************************************************************************
9295 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9298 PARAMETER ( LINP = 10 ,
9302 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
9307 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
9308 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
9309 & IREXCI(3),IRDIFF(2),IRINC
9311 * Glauber formalism: collision properties
9312 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
9313 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
9315 * various options for treatment of partons (DTUNUC 1.x)
9316 * (chain recombination, Cronin,..)
9317 LOGICAL LCO2CR,LINTPT
9318 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
9321 DIMENSION PIN(4),POUT(4),R(3)
9323 DATA LSTART /.TRUE./
9325 IRCRON(1) = IRCRON(1)+1
9328 WRITE(LOUT,1000) CRONCO
9329 1000 FORMAT(/,1X,'CROMSC: multiple scattering of chain ends',
9330 & ' treated',/,10X,'with parameter CRONCO = ',F5.2)
9336 IF (INCL.EQ.2) RNCL = RTARG
9338 * Lorentz-transformation into Lab.
9340 CALL DT_LTNUC(PIN(3),PIN(4),PZ,PE,MODE)
9342 PTOT = SQRT(PIN(1)**2+PIN(2)**2+PZ**2)
9343 IF (PTOT.LE.8.0D0) GOTO 9997
9345 * direction cosines of parton before mult. scattering
9350 RTESQ = R(1)**2+R(2)**2+R(3)**2-RNCL**2
9351 IF (RTESQ.GE.-TINY3) GOTO 9999
9353 * calculate distance (DIST) from R to surface of nucleus (radius RNCL)
9354 * in the direction of particle motion
9356 A = COSX*R(1)+COSY*R(2)+COSZ*R(3)
9358 IF (TMP.LT.ZERO) GOTO 9998
9361 * multiple scattering angle
9362 THETO = CRONCO*SQRT(DIST)/PTOT
9363 IF (THETO.GT.0.1D0) THETO=0.1D0
9366 * Gaussian sampling of spatial angle
9367 CALL DT_RANNOR(R1,R2)
9368 THETA = ABS(R1*THETO)
9369 IF (THETA.GT.0.3D0) GOTO 9997
9370 CALL DT_DSFECF(SFE,CFE)
9374 * new direction cosines
9375 CALL DT_MYTRAN(1,COSX,COSY,COSZ,COSTH,SINTH,SFE,CFE,
9376 & COSXN,COSYN,COSZN)
9378 POUT(1) = COSXN*PTOT
9379 POUT(2) = COSYN*PTOT
9381 * Lorentz-transformation into nucl.-nucl. cms
9383 CALL DT_LTNUC(PZ,PE,POUT(3),POUT(4),MODE)
9385 C IF (ABS(PIN(4)-POUT(4)).GT.0.2D0) THEN
9386 C IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.1D0 ) THEN
9387 IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.05D0 ) THEN
9390 IF (MOD(NCBACK,200).EQ.0) THEN
9391 WRITE(LOUT,1001) THETO,PIN,POUT
9392 1001 FORMAT(1X,'CROMSC: inconsistent scattering angle ',
9393 & E12.4,/,1X,' PIN :',4E12.4,/,
9394 & 1X,' POUT:',4E12.4)
9402 9997 IRCRON(2) = IRCRON(2)+1
9404 9998 IRCRON(3) = IRCRON(3)+1
9413 *$ CREATE DT_COM2CR.FOR
9416 *===com2sr=============================================================*
9418 SUBROUTINE DT_COM2CR
9420 ************************************************************************
9421 * COMbine q-aq chains to Color Ropes (qq-aqaq). *
9422 * CUTOF parameter determining minimum number of not *
9423 * combined q-aq chains *
9424 * This subroutine replaces KKEVCC etc. *
9425 * This version dated 11.01.95 is written by S. Roesler. *
9426 ************************************************************************
9428 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9431 PARAMETER ( LINP = 10 ,
9437 PARAMETER (NMXHKK=200000)
9439 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9440 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9441 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9443 * extended event history
9444 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9445 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9449 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9450 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9453 * various options for treatment of partons (DTUNUC 1.x)
9454 * (chain recombination, Cronin,..)
9455 LOGICAL LCO2CR,LINTPT
9456 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
9459 DIMENSION IDXQA(248),IDXAQ(248)
9461 ICCHAI(1,9) = ICCHAI(1,9)+1
9464 * scan DTEVT1 for q-aq, aq-q chains
9465 DO 10 I=NPOINT(3),NHKK
9466 * skip "chains" which are resonances
9467 IF ((IDHKK(I).EQ.88888).AND.(IDRES(I).EQ.0)) THEN
9470 IF ((ABS(IDHKK(MO1)).LE.6).AND.(ABS(IDHKK(MO2)).LE.6)) THEN
9471 * q-aq, aq-q chain found, keep index
9472 IF (IDHKK(MO1).GT.0) THEN
9483 * minimum number of q-aq chains requested for the same projectile/
9485 NCHMIN = IDT_NPOISS(CUTOF)
9487 * combine q-aq chains of the same projectile
9488 CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,1)
9489 * combine q-aq chains of the same target
9490 CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,2)
9491 * combine aq-q chains of the same projectile
9492 CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,1)
9493 * combine aq-q chains of the same target
9494 CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,2)
9499 *$ CREATE DT_SCN4CR.FOR
9502 *===scn4cr=============================================================*
9504 SUBROUTINE DT_SCN4CR(NCH,IDXCH,NCHMIN,MODE)
9506 ************************************************************************
9507 * SCan q-aq chains for Color Ropes. *
9508 * This version dated 11.01.95 is written by S. Roesler. *
9509 ************************************************************************
9511 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9514 PARAMETER ( LINP = 10 ,
9520 PARAMETER (NMXHKK=200000)
9522 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9523 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9524 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9526 * extended event history
9527 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9528 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9531 DIMENSION IDXCH(248),IDXJN(248)
9534 IF (IDXCH(I).GT.0) THEN
9536 IDXMO = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(I))))
9540 IF (IDXCH(J).GT.0) THEN
9541 IDXMO1 = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(J))))
9542 IF (IDXMO.EQ.IDXMO1) THEN
9549 IF (NJOIN.GE.NCHMIN+2) THEN
9550 NJ = INT(DBLE(NJOIN-NCHMIN)/2.0D0)
9552 CALL DT_JOIN(IDXCH(IDXJN(J)),IDXCH(IDXJN(J+1)),IREJ1)
9553 IF (IREJ1.NE.0) GOTO 3
9555 IDXCH(IDXJN(J+1)) = 0
9564 *$ CREATE DT_JOIN.FOR
9567 *===join===============================================================*
9569 SUBROUTINE DT_JOIN(IDX1,IDX2,IREJ)
9571 ************************************************************************
9572 * This subroutine joins two q-aq chains to one qq-aqaq chain. *
9573 * IDX1, IDX2 DTEVT1 indices of chains to be joined *
9574 * This version dated 11.01.95 is written by S. Roesler. *
9575 ************************************************************************
9577 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9580 PARAMETER ( LINP = 10 ,
9586 PARAMETER (NMXHKK=200000)
9588 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9589 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9590 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9592 * extended event history
9593 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9594 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9597 * flags for input different options
9598 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
9599 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
9600 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
9603 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9604 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9607 DIMENSION MO(2,2),ID(2,2),IDX(2),PCH(4),PP(4),PT(4),P1(4),P2(4)
9615 MO(I,J) = JMOHKK(J,IDX(I))
9616 ID(I,J) = IDT_IPDG2B(IDHKK(MO(I,J)),1,2)
9621 IF ((ABS(ID(1,1)).GT.6).OR.(ABS(ID(1,2)).GT.6).OR.
9622 & (ABS(ID(2,1)).GT.6).OR.(ABS(ID(2,2)).GT.6).OR.
9623 & ((ID(1,1)*ID(2,1)).LT.0).OR.
9624 & ((ID(1,2)*ID(2,2)).LT.0)) THEN
9625 WRITE(LOUT,1000) IDX(1),MO(1,1),MO(1,2),IDX(2),MO(2,1),
9627 1000 FORMAT(1X,'JOIN: incons. chain system! chain ',I4,':',
9628 & 2I5,' chain ',I4,':',2I5)
9633 PP(K) = PHKK(K,MO(1,1))+PHKK(K,MO(2,1))
9634 PT(K) = PHKK(K,MO(1,2))+PHKK(K,MO(2,2))
9636 IF1 = IDT_IB2PDG(ID(1,1),ID(2,1),2)
9637 IF2 = IDT_IB2PDG(ID(1,2),ID(2,2),2)
9638 IST1 = ISTHKK(MO(1,1))
9639 IST2 = ISTHKK(MO(1,2))
9641 * put partons again on mass shell
9644 IF (IMSHL.EQ.1) THEN
9650 CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1)
9651 IF (IREJ1.NE.0) GOTO 9999
9657 * store new partons in DTEVT1
9658 CALL DT_EVTPUT(IST1,IF1,MO(1,1),MO(2,1),PP(1),PP(2),PP(3),PP(4),
9660 CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4),
9663 PCH(K) = PP(K)+PT(K)
9666 * check new chain for lower mass limit
9667 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
9668 AMCH = SQRT(ABS(PCH(4)**2-PCH(1)**2-PCH(2)**2-PCH(3)**2))
9669 CALL DT_CH2RES(ID(1,1),ID(2,1),ID(1,2),ID(2,2),IDUM,IDUM,
9670 & AMCH,AMCHN,3,IREJ1)
9671 IF (IREJ1.NE.0) THEN
9677 ICCHAI(2,9) = ICCHAI(2,9)+1
9678 * store new chain in DTEVT1
9680 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),0,0,9)
9681 IDHKK(IDX(1)) = 22222
9682 IDHKK(IDX(2)) = 22222
9683 * special treatment for space-time coordinates
9685 VHKK(K,NHKK) = (VHKK(K,IDX(1))+VHKK(K,IDX(2)))/2.0D0
9686 WHKK(K,NHKK) = (WHKK(K,IDX(1))+WHKK(K,IDX(2)))/2.0D0
9694 *$ CREATE DT_XSGLAU.FOR
9697 *===xsglau=============================================================*
9699 SUBROUTINE DT_XSGLAU(NA,NB,JJPROJ,XI,Q2I,ECMI,IE,IQ,NIDX)
9701 ************************************************************************
9702 * Total, elastic, quasi-elastic, inelastic cross sections according to *
9703 * Glauber's approach. *
9704 * NA / NB mass numbers of proj./target nuclei *
9705 * JJPROJ bamjet-index of projectile (=1 in case of proj.nucleus) *
9706 * XI,Q2I,ECMI kinematical variables x, Q^2, E_cm *
9707 * IE,IQ indices of energy and virtuality (the latter for gamma *
9708 * projectiles only) *
9709 * NIDX index of projectile/target nucleus *
9710 * This version dated 17.3.98 is written by S. Roesler *
9711 ************************************************************************
9713 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9716 PARAMETER ( LINP = 10 ,
9720 COMPLEX*16 CZERO,CONE,CTWO
9722 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
9723 & ONETHI=ONE/THREE,TINY25=1.0D-25)
9724 PARAMETER (TWOPI = 6.283185307179586454D+00,
9726 & GEV2MB = 0.38938D0,
9727 & GEV2FM = 0.1972D0,
9728 & ALPHEM = ONE/137.0D0,
9732 * approx. nucleon radius
9735 * particle properties (BAMJET index convention)
9737 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
9738 & IICH(210),IIBAR(210),K1(210),K2(210)
9740 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
9742 PARAMETER ( MAXNCL = 260,
9745 & MAXSQU = 20*MAXVQU,
9746 & MAXINT = MAXVQU+MAXSQU)
9748 * Glauber formalism: parameters
9749 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
9750 & BMAX(NCOMPX),BSTEP(NCOMPX),
9751 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
9754 * Glauber formalism: cross sections
9755 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
9756 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
9757 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
9758 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
9759 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
9760 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
9761 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
9762 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
9763 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
9764 & BSLOPE,NEBINI,NQBINI
9766 * Glauber formalism: flags and parameters for statistics
9769 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
9771 * nucleon-nucleon event-generator
9774 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
9776 * VDM parameter for photon-nucleus interactions
9777 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
9779 * parameters for hA-diffraction
9780 COMMON /DTDIHA/ DIBETA,DIALPH
9782 COMPLEX*16 PP11(MAXNCL),PP12(MAXNCL),PP21(MAXNCL),PP22(MAXNCL),
9783 & OMPP11,OMPP12,OMPP21,OMPP22,
9784 & DIPP11,DIPP12,DIPP21,DIPP22,AVDIPP,
9787 DIMENSION COOP1(3,MAXNCL),COOT1(3,MAXNCL),
9788 & COOP2(3,MAXNCL),COOT2(3,MAXNCL),
9791 PARAMETER (NPOINT=16)
9792 DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
9794 LOGICAL LFIRST,LOPEN
9795 DATA LFIRST,LOPEN /.TRUE.,.FALSE./
9798 * for quasi-elastic neutrino scattering set projectile to proton
9799 * it should not have an effect since the whole Glauber-formalism is
9800 * not needed for these interactions..
9801 IF (MCGENE.EQ.4) THEN
9807 IF ((ABS(IOGLB).EQ.1).AND.(.NOT.LOPEN)) THEN
9810 CFILE = CGLB//'.glb'
9811 OPEN(LDAT,FILE=CGLB//'.glb',STATUS='UNKNOWN')
9812 ELSEIF (I.GT.1) THEN
9813 CFILE = CGLB(1:I-1)//'.glb'
9814 OPEN(LDAT,FILE=CGLB(1:I-1)//'.glb',STATUS='UNKNOWN')
9821 CZERO = DCMPLX(ZERO,ZERO)
9822 CONE = DCMPLX(ONE,ZERO)
9823 CTWO = DCMPLX(TWO,ZERO)
9827 * re-define kinematics
9831 * g(Q2=0)-A, h-A, A-A scattering
9832 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9835 * g(Q2>0)-A scattering
9836 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(S.GT.ZERO)) THEN
9838 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9839 Q2 = (S-AMP2)*X/(ONE-X)
9840 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
9841 S = Q2*(ONE-X)/X+AMP2
9843 WRITE(LOUT,*) 'XSGLAU: inconsistent input ',S,Q2,X
9848 XNU = (S+Q2-AMP2)/(TWO*AMP)
9850 * parameters determining statistics in evaluating Glauber-xsection
9853 IF (NSITEB.GT.KSITEB) NSITEB = KSITEB
9855 * set up interaction geometry (common /DTGLAM/)
9856 * projectile/target radii
9857 RPRNCL = DT_RNCLUS(NA)
9858 RTANCL = DT_RNCLUS(NB)
9859 IF (IJPROJ.EQ.7) THEN
9861 RBSH(NTARG) = RTANCL
9862 BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9864 IF (NIDX.LE.-1) THEN
9866 RBSH(NTARG) = RTANCL
9867 BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9869 RASH(NTARG) = RPRNCL
9871 BMAX(NTARG) = 2.0D0*(RASH(NTARG)+RBSH(1))
9874 * maximum impact-parameter
9875 BSTEP(NTARG)= BMAX(NTARG)/DBLE(NSITEB-1)
9877 * slope, rho ( Re(f(0))/Im(f(0)) )
9878 IF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
9879 IF (MCGENE.EQ.2) THEN
9881 CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,SDUM1,SDUM2,SDUM3,
9884 BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
9886 IF (ECMNN(IE).LE.3.0D0) THEN
9888 ELSEIF ((ECMNN(IE).GT.3.0D0).AND.(ECMNN(IE).LE.50.D0)) THEN
9889 ROSH = -0.63D0+0.175D0*LOG(ECMNN(IE))
9890 ELSEIF (ECMNN(IE).GT.50.0D0) THEN
9893 ELSEIF (IJPROJ.EQ.7) THEN
9896 BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
9900 * projectile-nucleon xsection (in fm)
9901 IF (IJPROJ.EQ.7) THEN
9902 SIGSH = DT_SIGVP(X,Q2)/10.0D0
9904 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
9905 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
9906 C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
9908 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
9909 SIGSH = SIGSH/10.0D0
9912 * parameters for projectile diffraction (hA scattering only)
9913 IF ((MCGENE.EQ.2).AND.(NA.EQ.1).AND.(NB.GT.1).AND.(IJPROJ.NE.7)
9914 & .AND.(DIBETA.GE.ZERO)) THEN
9916 CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,STOT,SDUM2,SDIF1,BDUM,0)
9917 C DIBETA = SDIF1/STOT
9919 DIGAMM = SQRT(DIALPH**2+DIBETA**2)
9920 IF (DIBETA.LE.ZERO) THEN
9923 ALPGAM = DIALPH/DIGAMM
9927 FACDI = SQRT(FACDI1*FACDI2)
9928 WRITE(LOUT,*)'DIBETA,DIALPH,DIGAMM: ',DIBETA,DIALPH,DIGAMM
9940 BSITE( 0,IQ,NTARG,I) = ZERO
9941 BSITE(IE,IQ,NTARG,I) = ZERO
9960 FACN = ONE/DBLE(NSTATB)
9965 * initialize Gauss-integration for photon-proj.
9967 IF (IJPROJ.EQ.7) THEN
9968 IF (INTRGE(1).EQ.1) THEN
9969 AMLO2 = (3.0D0*AAM(13))**2
9970 ELSEIF (INTRGE(1).EQ.2) THEN
9975 IF (INTRGE(2).EQ.1) THEN
9977 ELSEIF (INTRGE(2).EQ.2) THEN
9982 AMHI20 = (ECMNN(IE)-AMP)**2
9983 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
9984 XAMLO = LOG( AMLO2+Q2 )
9985 XAMHI = LOG( AMHI2+Q2 )
9987 C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9990 CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9994 * ratio direct/total photon-nucleon xsection
9995 CALL DT_POILIK(NB,NTARG,ECMNN(IE),Q2,IPNT,RPNT,1)
9998 * read pre-initialized profile-function from file
9999 IF (IOGLB.EQ.1) THEN
10000 READ(LDAT,'(5I10,E15.5)') KJPROJ,IA,IB,ISTATB,ISITEB,DUM
10001 IF ((IA.NE.NA).OR.(IB.NE.NB)) THEN
10002 WRITE(LOUT,1000) CFILE,IA,IB,ISTATB,ISITEB,
10003 & NA,NB,NSTATB,NSITEB
10004 1000 FORMAT(' XSGLAU: inconsistent input data in file ',A12,/,
10005 & ' (IA,IB,ISTATB,ISITEB) ',4I10,/,
10006 & ' (NA,NB,NSTATB,NSITEB) ',4I10)
10009 IF (LFIRST) WRITE(LOUT,1001) CFILE
10010 1001 FORMAT(/,' XSGLAU: impact parameter distribution read from ',
10012 READ(LDAT,'(6E12.5)') XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),
10013 & XSQEP(IE,IQ,NTARG),XSQET(IE,IQ,NTARG),
10014 & XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
10015 READ(LDAT,'(6E12.5)') XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),
10016 & XEQEP(IE,IQ,NTARG),XEQET(IE,IQ,NTARG),
10017 & XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
10018 NLINES = INT(DBLE(NSITEB)/7.0D0)
10019 IF (NLINES.GT.0) THEN
10022 READ(LDAT,'(7E11.4)')
10023 & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
10026 ISTART = 7*NLINES+1
10027 IF (ISTART.LE.NSITEB) THEN
10028 READ(LDAT,'(7E11.4)')
10029 & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
10033 * variable projectile/target/energy runs:
10034 * read pre-initialized profile-functions from file
10035 ELSEIF (IOGLB.EQ.100) THEN
10036 CALL DT_GLBSET(IJPROJ,IINA,IINB,RRELAB,0)
10040 * cross sections averaged over NSTATB nucleon configurations
10042 C IF ((NA.EQ.207).AND.(NB.EQ.207)) WRITE(LOUT,*) 'conf. ',IS
10052 IF (NIDX.LE.-1) THEN
10053 CALL DT_CONUCL(COOP1,NA,RASH(1),0)
10054 CALL DT_CONUCL(COOT1,NB,RBSH(NTARG),1)
10055 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10056 CALL DT_CONUCL(COOP2,NA,RASH(1),0)
10057 CALL DT_CONUCL(COOT2,NB,RBSH(NTARG),1)
10060 CALL DT_CONUCL(COOP1,NA,RASH(NTARG),0)
10061 CALL DT_CONUCL(COOT1,NB,RBSH(1),1)
10062 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10063 CALL DT_CONUCL(COOP2,NA,RASH(NTARG),0)
10064 CALL DT_CONUCL(COOT2,NB,RBSH(1),1)
10068 * integration over impact parameter B
10069 DO 12 IB=1,NSITEB-1
10079 B = DBLE(IB)*BSTEP(NTARG)
10080 FACB = 10.0D0*TWOPI*B*BSTEP(NTARG)
10082 * integration over M_V^2 for photon-proj.
10088 IF (IJPROJ.EQ.7) THEN
10100 IF (IJPROJ.EQ.7) THEN
10101 AMV2 = EXP(ABSZX(IM))-Q2
10103 IF (AMV2.LT.16.0D0) THEN
10105 ELSEIF ((AMV2.GE.16.0D0).AND.(AMV2.LT.121.0D0)) THEN
10110 * define M_V dependent properties of nucleon scattering amplitude
10111 * V_M-nucleon xsection
10112 SIGMVD = RPNT*SIGSH/(AMV2+Q2+RL2)*10.0D0
10113 SIGMV = (ONE-RPNT)*SIGSH/(AMV2+Q2+RL2)
10114 * slope-parametrisation a la Kaidalov
10115 BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
10116 & +0.25D0*LOG(S/(AMV2+Q2)))
10118 IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+Q2)*GEV2FM
10119 * integration weight factor
10120 FACM = ALPHEM/(3.0D0*PI*(ONE-X))*
10121 & R*AMV2/(AMV2+Q2)*(ONE+EPSPOL*Q2/AMV2)*WEIGHT(IM)
10123 GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
10125 IF (IJPROJ.EQ.7) THEN
10126 RCA = GAM*SIGMV/TWOPI
10128 RCA = GAM*SIGSH/TWOPI
10131 CA = DCMPLX(RCA,FCA)
10140 * photon-projectile: check for supression by coherence length
10141 IF (IJPROJ.EQ.7) THEN
10142 IF (ABS(COOT1(3,INB)-COOT1(3,KK1)).GT.DCOH)THEN
10146 IF (ABS(COOT2(3,INB)-COOT2(3,KK2)).GT.DCOH)THEN
10152 X11 = B+COOT1(1,INB)-COOP1(1,INA)
10153 Y11 = COOT1(2,INB)-COOP1(2,INA)
10154 XY11 = GAM*(X11*X11+Y11*Y11)
10155 IF (XY11.LE.15.0D0) THEN
10156 C = CONE-CA*EXP(-XY11)
10157 AR = DBLE(PP11(INT1))
10158 AI = DIMAG(PP11(INT1))
10159 IF (ABS(AR).LT.TINY25) AR = ZERO
10160 IF (ABS(AI).LT.TINY25) AI = ZERO
10161 PP11(INT1) = DCMPLX(AR,AI)
10162 PP11(INT1) = PP11(INT1)*C
10165 SHI = SHI+LOG(AR*AR+AI*AI)
10167 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10168 X12 = B+COOT2(1,INB)-COOP1(1,INA)
10169 Y12 = COOT2(2,INB)-COOP1(2,INA)
10170 XY12 = GAM*(X12*X12+Y12*Y12)
10171 IF (XY12.LE.15.0D0) THEN
10172 C = CONE-CA*EXP(-XY12)
10173 AR = DBLE(PP12(INT2))
10174 AI = DIMAG(PP12(INT2))
10175 IF (ABS(AR).LT.TINY25) AR = ZERO
10176 IF (ABS(AI).LT.TINY25) AI = ZERO
10177 PP12(INT2) = DCMPLX(AR,AI)
10178 PP12(INT2) = PP12(INT2)*C
10180 X21 = B+COOT1(1,INB)-COOP2(1,INA)
10181 Y21 = COOT1(2,INB)-COOP2(2,INA)
10182 XY21 = GAM*(X21*X21+Y21*Y21)
10183 IF (XY21.LE.15.0D0) THEN
10184 C = CONE-CA*EXP(-XY21)
10185 AR = DBLE(PP21(INT1))
10186 AI = DIMAG(PP21(INT1))
10187 IF (ABS(AR).LT.TINY25) AR = ZERO
10188 IF (ABS(AI).LT.TINY25) AI = ZERO
10189 PP21(INT1) = DCMPLX(AR,AI)
10190 PP21(INT1) = PP21(INT1)*C
10192 X22 = B+COOT2(1,INB)-COOP2(1,INA)
10193 Y22 = COOT2(2,INB)-COOP2(2,INA)
10194 XY22 = GAM*(X22*X22+Y22*Y22)
10195 IF (XY22.LE.15.0D0) THEN
10196 C = CONE-CA*EXP(-XY22)
10197 AR = DBLE(PP22(INT2))
10198 AI = DIMAG(PP22(INT2))
10199 IF (ABS(AR).LT.TINY25) AR = ZERO
10200 IF (ABS(AI).LT.TINY25) AI = ZERO
10201 PP22(INT2) = DCMPLX(AR,AI)
10202 PP22(INT2) = PP22(INT2)*C
10213 IF (PP11(K).EQ.CZERO) THEN
10217 PPTMP1 = PP11(K)**(ONE-DIALPH-DIGAMM)
10218 PPTMP2 = PP11(K)**(ONE-DIALPH+DIGAMM)
10221 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10222 OMPP11 = OMPP11+AVDIPP
10223 C OMPP11 = OMPP11+(CONE-PP11(K))
10224 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10225 DIPP11 = DIPP11+AVDIPP
10226 IF (PP21(K).EQ.CZERO) THEN
10230 PPTMP1 = PP21(K)**(ONE-DIALPH-DIGAMM)
10231 PPTMP2 = PP21(K)**(ONE-DIALPH+DIGAMM)
10234 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10235 OMPP21 = OMPP21+AVDIPP
10236 C OMPP21 = OMPP21+(CONE-PP21(K))
10237 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10238 DIPP21 = DIPP21+AVDIPP
10245 IF (PP12(K).EQ.CZERO) THEN
10249 PPTMP1 = PP12(K)**(ONE-DIALPH-DIGAMM)
10250 PPTMP2 = PP12(K)**(ONE-DIALPH+DIGAMM)
10253 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10254 OMPP12 = OMPP12+AVDIPP
10255 C OMPP12 = OMPP12+(CONE-PP12(K))
10256 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10257 DIPP12 = DIPP12+AVDIPP
10258 IF (PP22(K).EQ.CZERO) THEN
10262 PPTMP1 = PP22(K)**(ONE-DIALPH-DIGAMM)
10263 PPTMP2 = PP22(K)**(ONE-DIALPH+DIGAMM)
10266 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10267 OMPP22 = OMPP22+AVDIPP
10268 C OMPP22 = OMPP22+(CONE-PP22(K))
10269 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10270 DIPP22 = DIPP22+AVDIPP
10273 SPROM = ONE-EXP(SHI)
10274 SPROB = SPROB+FACM*SPROM
10275 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10276 STOTM = DBLE(OMPP11+OMPP22)
10277 SELAM = DBLE(OMPP11*DCONJG(OMPP22))
10278 SQEPM = DBLE(OMPP11*DCONJG(OMPP21))-SELAM
10279 SQETM = DBLE(OMPP11*DCONJG(OMPP12))-SELAM
10280 SQE2M = DBLE(OMPP11*DCONJG(OMPP11))-SELAM-SQEPM-SQETM
10281 SDELM = DBLE(DIPP11*DCONJG(DIPP22))
10282 SDQEM = DBLE(DIPP11*DCONJG(DIPP21))-SDELM
10283 STOTB = STOTB+FACM*STOTM
10284 SELAB = SELAB+FACM*SELAM
10285 SDELB = SDELB+FACM*SDELM
10287 SQEPB = SQEPB+FACM*SQEPM
10288 SDQEB = SDQEB+FACM*SDQEM
10290 IF (NA.GT.1) SQETB = SQETB+FACM*SQETM
10291 IF ((NA.GT.1).AND.(NB.GT.1)) SQE2B = SQE2B+FACM*SQE2M
10292 IF (IJPROJ.EQ.7) SDIR = SDIR+FACM*SIGMVD
10297 STOTN = STOTN+FACB*STOTB
10298 SELAN = SELAN+FACB*SELAB
10299 SQEPN = SQEPN+FACB*SQEPB
10300 SQETN = SQETN+FACB*SQETB
10301 SQE2N = SQE2N+FACB*SQE2B
10302 SPRON = SPRON+FACB*SPROB
10303 SDELN = SDELN+FACB*SDELB
10304 SDQEN = SDQEN+FACB*SDQEB
10306 IF (IJPROJ.EQ.7) THEN
10307 BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*(STOTB-SELAB-SQEPB)
10309 IF (DIBETA.GT.ZERO) THEN
10310 BPROD(IB+1)= BPROD(IB+1)
10311 & +FACN*FACB*(STOTB-SELAB-SQEPB-SQETB-SQE2B)
10313 BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*SPROB
10319 STOT = STOT +FACN*STOTN
10320 STOT2 = STOT2+FACN*STOTN**2
10321 SELA = SELA +FACN*SELAN
10322 SELA2 = SELA2+FACN*SELAN**2
10323 SQEP = SQEP +FACN*SQEPN
10324 SQEP2 = SQEP2+FACN*SQEPN**2
10325 SQET = SQET +FACN*SQETN
10326 SQET2 = SQET2+FACN*SQETN**2
10327 SQE2 = SQE2 +FACN*SQE2N
10328 SQE22 = SQE22+FACN*SQE2N**2
10329 SPRO = SPRO +FACN*SPRON
10330 SPRO2 = SPRO2+FACN*SPRON**2
10331 SDEL = SDEL +FACN*SDELN
10332 SDEL2 = SDEL2+FACN*SDELN**2
10333 SDQE = SDQE +FACN*SDQEN
10334 SDQE2 = SDQE2+FACN*SDQEN**2
10338 * final cross sections
10340 XSTOT(IE,IQ,NTARG) = STOT
10342 & XSTOT(IE,IQ,NTARG) = XSTOT(IE,IQ,NTARG)+DBLE(NB)*SDIR
10344 XSELA(IE,IQ,NTARG) = SELA
10345 * 3) quasi-el.: A+B-->A+X (excluding 2)
10346 XSQEP(IE,IQ,NTARG) = SQEP
10347 * 4) quasi-el.: A+B-->X+B (excluding 2)
10348 XSQET(IE,IQ,NTARG) = SQET
10349 * 5) quasi-el.: A+B-->X (excluding 2-4)
10350 XSQE2(IE,IQ,NTARG) = SQE2
10351 * 6) production (= STOT-SELA-SQEP-SQET-SQE2!)
10352 IF (SDEL.GT.ZERO) THEN
10353 XSPRO(IE,IQ,NTARG) = STOT-SELA-SQEP-SQET-SQE2
10355 XSPRO(IE,IQ,NTARG) = SPRO
10357 * 7) projectile diffraction (el. scatt. off target)
10358 XSDEL(IE,IQ,NTARG) = SDEL
10359 * 8) projectile diffraction (quasi-el. scatt. off target)
10360 XSDQE(IE,IQ,NTARG) = SDQE
10362 XETOT(IE,IQ,NTARG) = SQRT(ABS(STOT2-STOT**2)/DBLE(NSTATB-1))
10363 XEELA(IE,IQ,NTARG) = SQRT(ABS(SELA2-SELA**2)/DBLE(NSTATB-1))
10364 XEQEP(IE,IQ,NTARG) = SQRT(ABS(SQEP2-SQEP**2)/DBLE(NSTATB-1))
10365 XEQET(IE,IQ,NTARG) = SQRT(ABS(SQET2-SQET**2)/DBLE(NSTATB-1))
10366 XEQE2(IE,IQ,NTARG) = SQRT(ABS(SQE22-SQE2**2)/DBLE(NSTATB-1))
10367 XEPRO(IE,IQ,NTARG) = SQRT(ABS(SPRO2-SPRO**2)/DBLE(NSTATB-1))
10368 XEDEL(IE,IQ,NTARG) = SQRT(ABS(SDEL2-SDEL**2)/DBLE(NSTATB-1))
10369 XEDQE(IE,IQ,NTARG) = SQRT(ABS(SDQE2-SDQE**2)/DBLE(NSTATB-1))
10371 IF (IJPROJ.EQ.7) THEN
10372 BNORM = XSTOT(IE,IQ,NTARG)-XSELA(IE,IQ,NTARG)
10373 & -XSQEP(IE,IQ,NTARG)
10375 BNORM = XSPRO(IE,IQ,NTARG)
10378 BSITE(IE,IQ,NTARG,I) = BPROD(I)/BNORM+BSITE(IE,IQ,NTARG,I-1)
10379 IF ((IE.EQ.1).AND.(IQ.EQ.1))
10380 & BSITE(0,1,NTARG,I) = BPROD(I)/BNORM+BSITE(0,1,NTARG,I-1)
10383 * write profile function data into file
10384 IF ((IOGLB.EQ.-1).OR.(IOGLB.EQ.-100)) THEN
10385 WRITE(LDAT,'(5I10,1P,E15.5)')
10386 & IJPROJ,NA,NB,NSTATB,NSITEB,ECMNN(IE)
10387 WRITE(LDAT,'(1P,6E12.5)')
10388 & XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),XSQEP(IE,IQ,NTARG),
10389 & XSQET(IE,IQ,NTARG),XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
10390 WRITE(LDAT,'(1P,6E12.5)')
10391 & XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),XEQEP(IE,IQ,NTARG),
10392 & XEQET(IE,IQ,NTARG),XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
10393 NLINES = INT(DBLE(NSITEB)/7.0D0)
10394 IF (NLINES.GT.0) THEN
10397 WRITE(LDAT,'(1P,7E11.4)')
10398 & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
10401 ISTART = 7*NLINES+1
10402 IF (ISTART.LE.NSITEB) THEN
10403 WRITE(LDAT,'(1P,7E11.4)')
10404 & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
10410 C IF (ABS(IOGLB).EQ.1) CLOSE(LDAT)
10415 *$ CREATE DT_GETBXS.FOR
10418 *===getbxs=============================================================*
10420 SUBROUTINE DT_GETBXS(XSFRAC,BLO,BHI,NIDX)
10422 ************************************************************************
10423 * Biasing in impact parameter space. *
10424 * XSFRAC = 0 : BLO - minimum impact parameter (input) *
10425 * BHI - maximum impact parameter (input) *
10426 * XSFRAC - fraction of cross section corresponding *
10427 * to impact parameter range (BLO,BHI) *
10429 * XSFRAC > 0 : XSFRAC - fraction of cross section (input) *
10430 * BHI - maximum impact parameter giving requested *
10431 * fraction of cross section in impact *
10432 * parameter range (0,BMAX) (output) *
10433 * This version dated 17.03.00 is written by S. Roesler *
10434 ************************************************************************
10436 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10439 PARAMETER ( LINP = 10 ,
10443 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10445 * Glauber formalism: parameters
10446 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10447 & BMAX(NCOMPX),BSTEP(NCOMPX),
10448 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10452 IF (XSFRAC.LE.0.0D0) THEN
10453 ILO = MIN(NSITEB-1,INT(BLO/BSTEP(NTARG)))
10454 IHI = MIN(NSITEB-1,INT(BHI/BSTEP(NTARG)))
10455 IF (ILO.GE.IHI) THEN
10459 IF (ILO.EQ.NSITEB-1) THEN
10460 FRCLO = BSITE(0,1,NTARG,NSITEB)
10462 FRCLO = BSITE(0,1,NTARG,ILO+1)
10463 & +(BLO-ILO*BSTEP(NTARG))/BSTEP(NTARG)
10464 & *(BSITE(0,1,NTARG,ILO+2)-BSITE(0,1,NTARG,ILO+1))
10466 IF (IHI.EQ.NSITEB-1) THEN
10467 FRCHI = BSITE(0,1,NTARG,NSITEB)
10469 FRCHI = BSITE(0,1,NTARG,IHI+1)
10470 & +(BHI-IHI*BSTEP(NTARG))/BSTEP(NTARG)
10471 & *(BSITE(0,1,NTARG,IHI+2)-BSITE(0,1,NTARG,IHI+1))
10473 XSFRAC = FRCHI-FRCLO
10478 IF (XSFRAC.LT.BSITE(0,1,NTARG,I+1)) THEN
10479 FAC = (XSFRAC -BSITE(0,1,NTARG,I))/
10480 & (BSITE(0,1,NTARG,I+1)-BSITE(0,1,NTARG,I))
10481 BHI = DBLE(I-1)*BSTEP(NTARG)+BSTEP(NTARG)*FAC
10491 *$ CREATE DT_CONUCL.FOR
10494 *===conucl=============================================================*
10496 SUBROUTINE DT_CONUCL(X,N,R,MODE)
10498 ************************************************************************
10499 * Calculation of coordinates of nucleons within nuclei. *
10500 * X(3,N) spatial coordinates of nucleons (in fm) (output) *
10501 * N / R number of nucleons / radius of nucleus (input) *
10502 * MODE = 0 coordinates not sorted *
10503 * = 1 coordinates sorted with increasing X(3,i) *
10504 * = 2 coordinates sorted with decreasing X(3,i) *
10505 * This version dated 26.10.95 is revised by S. Roesler *
10506 ************************************************************************
10508 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10511 PARAMETER ( LINP = 10 ,
10515 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10516 & ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10518 PARAMETER (TWOPI = 6.283185307179586454D+00 )
10520 PARAMETER (NSRT=10)
10521 DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10522 DIMENSION X(3,N),XTMP(3,260)
10524 CALL DT_COORDI(XTMP,IDXSRT,ICSRT,N,R)
10526 IF ((MODE.NE.0).AND.(N.GT.4)) THEN
10529 IF (MODE.EQ.2) THEN
10535 DO 2 J=1,ICSRT(ISRT)
10537 X(1,K) = XTMP(1,IDXSRT(ISRT,J))
10538 X(2,K) = XTMP(2,IDXSRT(ISRT,J))
10539 X(3,K) = XTMP(3,IDXSRT(ISRT,J))
10541 IF (ICSRT(ISRT).GT.1) THEN
10544 CALL DT_SORT(X,N,I0,I1,MODE)
10547 ELSEIF ((MODE.NE.0).AND.(N.GE.2).AND.(N.LE.4)) THEN
10553 CALL DT_SORT(X,N,1,N,MODE)
10565 *$ CREATE DT_COORDI.FOR
10568 *===coordi=============================================================*
10570 SUBROUTINE DT_COORDI(X,IDXSRT,ICSRT,N,R)
10572 ************************************************************************
10573 * Calculation of coordinates of nucleons within nuclei. *
10574 * X(3,N) spatial coordinates of nucleons (in fm) (output) *
10575 * N / R number of nucleons / radius of nucleus (input) *
10576 * Based on the original version by Shmakov et al. *
10577 * This version dated 26.10.95 is revised by S. Roesler *
10578 ************************************************************************
10580 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10583 PARAMETER ( LINP = 10 ,
10587 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10588 & ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10590 PARAMETER (TWOPI = 6.283185307179586454D+00 )
10594 PARAMETER (NSRT=10)
10595 DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10596 DIMENSION X(3,260),WD(4),RD(3)
10598 DATA PDIF/0.545D0/,R2MIN/0.16D0/
10599 DATA WD / 0.0D0, 0.178D0, 0.465D0, 1.0D0/
10600 DATA RD /2.09D0, 0.935D0, 0.697D0/
10610 ELSEIF (N.EQ.2) THEN
10611 EPS = DT_RNDM(RD(1))
10613 IF ((EPS.GE.WD(I)).AND.(EPS.LE.WD(I+1))) GOTO 40
10617 CALL DT_RANNOR(X1,X2)
10621 ELSEIF ((N.EQ.3).OR.(N.EQ.4)) THEN
10624 CALL DT_RANNOR(X3,X4)
10626 CALL DT_RANNOR(X1,X2)
10629 IF (LSTART) GOTO 80
10631 CALL DT_RANNOR(X3,X4)
10636 LSTART = .NOT.LSTART
10637 X1SUM = X1SUM+X(1,I)
10638 X2SUM = X2SUM+X(2,I)
10639 X3SUM = X3SUM+X(3,I)
10641 X1SUM = X1SUM/DBLE(N)
10642 X2SUM = X2SUM/DBLE(N)
10643 X3SUM = X3SUM/DBLE(N)
10645 X(1,I) = X(1,I)-X1SUM
10646 X(2,I) = X(2,I)-X2SUM
10647 X(3,I) = X(3,I)-X3SUM
10651 * maximum nuclear radius for coordinate sampling
10652 RMAX = R+4.605D0*PDIF
10654 * initialize pre-sorting
10658 DR = TWO*RMAX/DBLE(NSRT)
10660 * sample coordinates for N nucleons
10663 RAD = RMAX*(DT_RNDM(DR))**ONETHI
10664 F = DT_DENSIT(N,RAD,R)
10665 IF (DT_RNDM(RAD).GT.F) GOTO 120
10666 * theta, phi uniformly distributed
10667 CT = ONE-TWO*DT_RNDM(F)
10668 ST = SQRT((ONE-CT)*(ONE+CT))
10669 CALL DT_DSFECF(SFE,CFE)
10670 X(1,I) = RAD*ST*CFE
10671 X(2,I) = RAD*ST*SFE
10673 * ensure that distance between two nucleons is greater than R2MIN
10674 IF (I.LT.2) GOTO 122
10677 DIST2 = (X(1,I)-X(1,I2))**2+(X(2,I)-X(2,I2))**2+
10678 & (X(3,I)-X(3,I2))**2
10679 IF (DIST2.LE.R2MIN) GOTO 120
10682 * save index according to z-bin
10683 IDXZ = INT( (X(3,I)+RMAX)/DR )+1
10684 ICSRT(IDXZ) = ICSRT(IDXZ)+1
10685 IDXSRT(IDXZ,ICSRT(IDXZ)) = I
10686 X1SUM = X1SUM+X(1,I)
10687 X2SUM = X2SUM+X(2,I)
10688 X3SUM = X3SUM+X(3,I)
10690 X1SUM = X1SUM/DBLE(N)
10691 X2SUM = X2SUM/DBLE(N)
10692 X3SUM = X3SUM/DBLE(N)
10694 X(1,I) = X(1,I)-X1SUM
10695 X(2,I) = X(2,I)-X2SUM
10696 X(3,I) = X(3,I)-X3SUM
10704 *$ CREATE DT_DENSIT.FOR
10707 *===densit=============================================================*
10709 DOUBLE PRECISION FUNCTION DT_DENSIT(NA,R,RA)
10711 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10714 PARAMETER ( LINP = 10 ,
10718 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10719 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
10722 DIMENSION R0(18),FNORM(18)
10723 DATA R0 / ZERO, ZERO, ZERO, ZERO, 2.12D0,
10724 & 2.56D0, 2.41D0, 2.46D0, 2.52D0, 2.45D0,
10725 & 2.37D0, 2.46D0, 2.44D0, 2.54D0, 2.58D0,
10726 & 2.72D0, 2.66D0, 2.79D0/
10727 DATA FNORM /.1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10728 & .1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10729 & .1012D+01,.1039D+01,.1075D+01,.1118D+01,.1164D+01,
10730 & .1214D+01,.1265D+01,.1318D+01/
10731 DATA PDIF /0.545D0/
10737 ELSEIF ((NA.GT.4).AND.(NA.LE.18)) THEN
10738 R1 = R0(NA)/SQRT(2.5D0-4.0D0/DBLE(NA))
10739 DT_DENSIT = (ONE+(DBLE(NA)-4.0D0)/6.0D0*(R/R1)**2)
10740 & *EXP(-(R/R1)**2)/FNORM(NA)
10742 ELSEIF (NA.GT.18) THEN
10743 DT_DENSIT = ONE/(ONE+EXP((R-RA)/PDIF))
10749 *$ CREATE DT_RNCLUS.FOR
10752 *===rnclus=============================================================*
10754 DOUBLE PRECISION FUNCTION DT_RNCLUS(N)
10756 ************************************************************************
10757 * Nuclear radius for nucleus with mass number N. *
10758 * This version dated 26.9.00 is written by S. Roesler *
10759 ************************************************************************
10761 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10764 PARAMETER (ONE=1.0D0,THREE=3.0D0,ONETHI=ONE/THREE)
10767 PARAMETER (RNUCLE = 1.12D0)
10769 * nuclear radii for selected nuclei
10770 DIMENSION RADNUC(18)
10771 DATA RADNUC / 8*0.0D0,2.52D0,2.45D0,2.37D0,2.45D0,2.44D0,2.55D0,
10772 & 2.58D0,2.71D0,2.66D0,2.71D0/
10775 IF (RADNUC(N).GT.0.0D0) THEN
10776 DT_RNCLUS = RADNUC(N)
10778 DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10781 DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10787 *$ CREATE DT_DENTST.FOR
10790 *===dentst=============================================================*
10792 C PROGRAM DT_DENTST
10793 SUBROUTINE DT_DENTST
10795 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10798 OPEN(40,FILE='dentst.out',STATUS='UNKNOWN')
10799 OPEN(41,FILE='denmax.out',STATUS='UNKNOWN')
10804 DR = (RMAX-RMIN)/DBLE(NBINS)
10808 R = RMIN+DBLE(IR-1)*DR
10809 F = DT_DENSIT(IA,R,R)
10810 IF (F.GT.FMAX) FMAX = F
10811 WRITE(40,'(1X,I3,2E15.5)') IA,R,F
10813 WRITE(41,'(1X,I3,E15.5)') IA,FMAX
10821 *$ CREATE DT_SHMAKI.FOR
10824 *===shmaki=============================================================*
10826 SUBROUTINE DT_SHMAKI(NA,NCA,NB,NCB,IJP,PPN,MODE)
10828 ************************************************************************
10829 * Initialisation of Glauber formalism. This subroutine has to be *
10830 * called once (in case of target emulsions as often as many different *
10831 * target nuclei are considered) before events are sampled. *
10832 * NA / NCA mass number/charge of projectile nucleus *
10833 * NB / NCB mass number/charge of target nucleus *
10834 * IJP identity of projectile (hadrons/leptons/photons) *
10835 * PPN projectile momentum (for projectile nuclei: *
10836 * momentum per nucleon) in target rest system *
10837 * MODE = 0 Glauber formalism invoked *
10838 * = 1 fitted results are loaded from data-file *
10839 * = 99 NTARG is forced to be 1 *
10840 * (used in connection with GLAUBERI-card only) *
10841 * This version dated 22.03.96 is based on the original SHMAKI-routine *
10842 * and revised by S. Roesler. *
10843 ************************************************************************
10845 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10848 PARAMETER ( LINP = 10 ,
10852 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
10855 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10857 * Glauber formalism: parameters
10858 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10859 & BMAX(NCOMPX),BSTEP(NCOMPX),
10860 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10863 * Lorentz-parameters of the current interaction
10864 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10865 & UMO,PPCM,EPROJ,PPROJ
10867 * properties of photon/lepton projectiles
10868 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10870 * kinematical cuts for lepton-nucleus interactions
10871 COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
10872 & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
10874 * Glauber formalism: cross sections
10875 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10876 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10877 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10878 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10879 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10880 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10881 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10882 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10883 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10884 & BSLOPE,NEBINI,NQBINI
10886 * cuts for variable energy runs
10887 COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
10889 * nucleon-nucleon event-generator
10892 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10894 * Glauber formalism: flags and parameters for statistics
10897 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10899 DATA NTARG,ICOUT,IVEOUT /0,0,0/
10905 IF (MODE.EQ.99) NTARG = 1
10907 IF (MODE.EQ.-1) NIDX = NTARG
10909 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) ICOUT = ICOUT+1
10910 IF (ICOUT.EQ.1) WRITE(LOUT,1000)
10911 1000 FORMAT(//,1X,'SHMAKI: Glauber formalism (Shmakov et. al) -',
10912 & ' initialization',/,12X,'--------------------------',
10913 & '-------------------------',/)
10915 IF (MODE.EQ.2) THEN
10916 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10917 CALL DT_SHFAST(MODE,PPN,IBACK)
10918 STOP ' Glauber pre-initialization done'
10920 IF (MODE.EQ.1) THEN
10921 CALL DT_PROFBI(NA,NB,PPN,NTARG)
10924 IF (MODE.EQ.3) CALL DT_SHFAST(MODE,PPN,IBACK)
10925 IF (IBACK.EQ.1) THEN
10926 * lepton-nucleus (variable energy runs)
10927 IF ((IJP.EQ. 3).OR.(IJP.EQ. 4).OR.
10928 & (IJP.EQ.10).OR.(IJP.EQ.11)) THEN
10929 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10930 & WRITE(LOUT,1002) NB,NCB
10931 1002 FORMAT(1X,'variable energy run: projectile-id: 7',
10932 & ' target A/Z: ',I3,' /',I3,/,/,8X,
10933 & 'E_cm (GeV) Q^2 (GeV^2)',
10934 & ' Sigma_tot (mb) Sigma_in (mb)',/,7X,
10935 & '--------------------------------',
10936 & '------------------------------')
10937 AECMLO = LOG10(MIN(UMO,ECMLI))
10938 AECMHI = LOG10(MIN(UMO,ECMHI))
10940 DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
10941 IF (AECMLO.EQ.AECMHI) IESTEP = 0
10943 ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10944 IF (Q2HI.GT.0.1D0) THEN
10945 IF (Q2LI.LT.0.01D0) THEN
10946 CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10947 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10949 & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10956 AQ2LO = LOG10(Q2LI)
10957 AQ2HI = LOG10(Q2HI)
10958 DAQ2 = (AQ2HI-AQ2LO)/MAX(DBLE(IQSTEP),ONE)
10959 DO 2 J=IBIN,IQSTEP+IBIN
10960 Q2 = 10.0D0**(AQ2LO+DBLE(J-IBIN)*DAQ2)
10961 CALL DT_XSGLAU(NA,NB,7,ZERO,Q2,ECM,I,J,NIDX)
10962 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10963 & WRITE(LOUT,1003) ECMNN(I),
10964 & Q2G(J),XSTOT(I,J,NTARG),XSPRO(I,J,NTARG)
10967 CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10968 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10970 & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10972 1003 FORMAT(9X,F6.1,9X,F6.2,8X,F8.3,11X,F8.3)
10976 * hadron/photon/nucleus-nucleus
10977 IF ((ABS(VAREHI).GT.ZERO).AND.
10978 & (ABS(VAREHI).GT.ABS(VARELO))) THEN
10979 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) THEN
10980 WRITE(LOUT,1004) NA,NB,NCB
10981 1004 FORMAT(1X,'variable energy run: projectile-id:',
10982 & I3,' target A/Z: ',I3,' /',I3,/)
10984 1005 FORMAT(' E_cm (GeV) E_Lab (GeV) sig_tot^pp (mb)'
10985 & ,' Sigma_tot (mb) Sigma_prod (mb)',/,
10986 & ' -------------------------------------',
10987 & '--------------------------------------')
10989 AECMLO = LOG10(VARCLO)
10990 AECMHI = LOG10(VARCHI)
10992 DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
10993 IF (AECMLO.EQ.AECMHI) IESTEP = 0
10995 ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
11000 ELAB = (ECM**2-AMP2-AMT2)/(TWO*AMT)
11001 PLAB = SQRT((ELAB+AMP)*(ELAB-AMP))
11002 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,ECM,I,1,NIDX)
11003 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
11005 & ECM,PLAB,SIGSH,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
11006 1006 FORMAT(1X,F9.1,1X,E11.3,1X,F12.2,8X,F10.3,8X,F8.3)
11010 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
11016 IF ((ICOUT.LT.15).AND.(IVEOUT.EQ.0).AND.(MCGENE.NE.4).AND.
11017 & (IOGLB.NE.100)) THEN
11018 WRITE(LOUT,1001) NA,NCA,NB,NCB,ECMNN(1),SIGSH*10.0D0,ROSH,
11019 & BSLOPE,NSITEB,NSTATB,XSPRO(1,1,NTARG)
11020 1001 FORMAT(38X,'projectile',
11021 & ' target',/,1X,'Mass number / charge',
11022 & 17X,I3,' /',I3,6X,I3,' /',I3,/,/,1X,
11023 & 'Nucleon-nucleon c.m. energy',9X,F10.2,' GeV',/,/,1X,
11024 & 'Parameters of elastic scattering amplitude:',/,5X,
11025 & 'sigma =',F7.2,' mb',6X,'rho = ',F9.4,6X,'slope = ',
11026 & F4.1,' GeV^-2',/,/,1X,'Number of b-steps',4X,I3,8X,
11027 & 'statistics at each b-step',4X,I5,/,/,1X,
11028 & 'Prod. cross section ',5X,F10.4,' mb',/)
11034 *$ CREATE DT_PROFBI.FOR
11037 *===profbi=============================================================*
11039 SUBROUTINE DT_PROFBI(NA,NB,PPN,NTARG)
11041 ************************************************************************
11042 * Integral over profile function (to be used for impact-parameter *
11043 * sampling during event generation). *
11044 * Fitted results are used. *
11045 * NA / NB mass numbers of proj./target nuclei *
11046 * PPN projectile momentum (for projectile nuclei: *
11047 * momentum per nucleon) in target rest system *
11048 * NTARG index of target material (i.e. kind of nucleus) *
11049 * This version dated 31.05.95 is revised by S. Roesler *
11050 ************************************************************************
11052 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11055 PARAMETER ( LINP = 10 ,
11061 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
11066 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11068 * Glauber formalism: parameters
11069 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11070 & BMAX(NCOMPX),BSTEP(NCOMPX),
11071 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11074 * Glauber formalism: cross sections
11075 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11076 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11077 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11078 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11079 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11080 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11081 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11082 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11083 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11084 & BSLOPE,NEBINI,NQBINI
11086 PARAMETER (NGLMAX=8000)
11087 DIMENSION NGLIT(NGLMAX),NGLIP(NGLMAX),GLAPPN(NGLMAX),
11088 & GLASIG(NGLMAX),GLAFIT(5,NGLMAX)
11090 DATA LSTART /.TRUE./
11093 * read fit-parameters from file
11094 OPEN(47,FILE='inpdata/glpara.dat',STATUS='UNKNOWN')
11097 READ(47,'(A80)') CNAME
11098 IF (CNAME.EQ.'STOP') GOTO 2
11100 READ(CNAME,*) NGLIP(I),NGLIT(I),GLAPPN(I),GLASIG(I),
11101 & GLAFIT(1,I),GLAFIT(2,I),GLAFIT(3,I),
11102 & GLAFIT(4,I),GLAFIT(5,I)
11103 IF (I+1.GT.NGLMAX) THEN
11105 1000 FORMAT(1X,'PROFBI: warning! array size exceeded - ',
11106 & 'program stopped')
11123 IF ((NNB.LT.NGLIT(J)).OR.(J.EQ.NGLPAR)) THEN
11124 IF (NNB.NE.NGLIT(J-1)) NNB = NGLIT(J-1)
11127 IF (J.EQ.NGLPAR) IPOINT = J+1-K
11128 IF ((NNA.GT.NGLIP(IPOINT)).OR.
11129 & (NNB.NE.NGLIT(IPOINT)).OR.(IPOINT.EQ.1)) THEN
11130 IF (IPOINT.EQ.1) IPOINT = 0
11131 NATMP = NGLIP(IPOINT+1)
11132 IF (PPN.LT.GLAPPN(IPOINT+1)) THEN
11138 C IF (J.EQ.NGLPAR) THEN
11142 DO 5 J1=J1BEG,J1END
11143 IF (NGLIP(J1).EQ.NATMP) THEN
11144 IF (PPN.LT.GLAPPN(J1)) THEN
11153 IF ((J.EQ.NGLPAR).AND.(PPN.GT.GLAPPN(NGLPAR)))
11162 IF (IDXGLA.EQ.0) THEN
11163 WRITE(LOUT,1001) NNA,NNB,PPN
11164 1001 FORMAT(1X,'PROFBI: configuration (NA,NB,PPN = ',
11165 & 2I4,F6.0,') not found ')
11169 * no interpolation yet available
11170 XSPRO(1,1,NTARG) = GLASIG(IDXGLA)
11172 BSITE(1,1,NTARG,1) = ZERO
11175 POLY = GLAFIT(1,IDXGLA)+GLAFIT(2,IDXGLA)*XX+
11176 & GLAFIT(3,IDXGLA)*XX**2+GLAFIT(4,IDXGLA)*XX**3+
11177 & GLAFIT(5,IDXGLA)*XX**4
11178 IF (ABS(POLY).GT.35.0D0) POLY = SIGN(35.0D0,POLY)
11179 BSITE(1,1,NTARG,I) = (1.0D0-EXP(-POLY))
11180 IF (BSITE(1,1,NTARG,I).LT.ZERO) BSITE(1,1,NTARG,I) = ZERO
11186 *$ CREATE DT_GLAUBE.FOR
11189 *===glaube=============================================================*
11191 SUBROUTINE DT_GLAUBE(NA,NB,IJPROJ,B,INTT,INTA,INTB,JS,JT,NIDX)
11193 ************************************************************************
11194 * Calculation of configuartion of interacting nucleons for one event. *
11195 * NB / NB mass numbers of proj./target nuclei (input) *
11196 * B impact parameter (output) *
11197 * INTT total number of wounded nucleons " *
11198 * INTA / INTB number of wounded nucleons in proj. / target " *
11199 * JS / JT(i) number of collisions proj. / target nucleon i is *
11200 * involved (output) *
11201 * NIDX index of projectile/target material (input) *
11202 * = -2 call within FLUKA transport calculation *
11203 * This is an update of the original routine SHMAKO by J.Ranft/HJM *
11204 * This version dated 22.03.96 is revised by S. Roesler *
11206 * Last change 27.12.2006 by S. Roesler. *
11207 ************************************************************************
11209 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11212 PARAMETER ( LINP = 10 ,
11216 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
11217 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
11219 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11221 PARAMETER ( MAXNCL = 260,
11224 & MAXSQU = 20*MAXVQU,
11225 & MAXINT = MAXVQU+MAXSQU)
11227 * Glauber formalism: parameters
11228 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11229 & BMAX(NCOMPX),BSTEP(NCOMPX),
11230 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11233 * Glauber formalism: cross sections
11234 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11235 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11236 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11237 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11238 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11239 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11240 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11241 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11242 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11243 & BSLOPE,NEBINI,NQBINI
11245 * Lorentz-parameters of the current interaction
11246 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
11247 & UMO,PPCM,EPROJ,PPROJ
11249 * properties of photon/lepton projectiles
11250 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
11252 * Glauber formalism: collision properties
11253 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
11254 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
11256 * Glauber formalism: flags and parameters for statistics
11259 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11261 DIMENSION JS(MAXNCL),JT(MAXNCL)
11265 * get actual energy from /DTLTRA/
11269 * new patch for pre-initialized variable projectile/target/energy runs,
11270 * bypassed for use within FLUKA (Nidx=-2)
11271 IF (IOGLB.EQ.100) THEN
11272 IF (NIDX.NE.-2) CALL DT_GLBSET(IJPROJ,NA,NB,EPROJ,1)
11274 * variable energy run, interpolate profile function
11279 IF (NEBINI.GT.1) THEN
11280 IF (ECMNOW.GE.ECMNN(NEBINI)) THEN
11284 ELSEIF (ECMNOW.GT.ECMNN(1)) THEN
11286 IF (ECMNOW.LT.ECMNN(I)) THEN
11289 RATE = (ECMNOW-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
11299 IF (NQBINI.GT.1) THEN
11300 IF (Q2.GE.Q2G(NQBINI)) THEN
11304 ELSEIF (Q2.GT.Q2G(1)) THEN
11306 IF (Q2.LT.Q2G(I)) THEN
11309 RATQ = LOG10( Q2/MAX(Q2G(J1),TINY14))/
11310 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
11311 C RATQ = (Q2-Q2G(J1))/(Q2G(J2)-Q2G(J1))
11320 BSITE(0,1,NTARG,I) = BSITE(I1,J1,NTARG,I)+
11321 & RATE*(BSITE(I2,J1,NTARG,I)-BSITE(I1,J1,NTARG,I))+
11322 & RATQ*(BSITE(I1,J2,NTARG,I)-BSITE(I1,J1,NTARG,I))+
11323 & RATE*RATQ*(BSITE(I2,J2,NTARG,I)-BSITE(I1,J2,NTARG,I)+
11324 & BSITE(I1,J1,NTARG,I)-BSITE(I2,J1,NTARG,I))
11328 CALL DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,INTT,INTA,INTB,IDIREC,NIDX)
11329 IF (NIDX.LE.-1) THEN
11331 RTARG = RBSH(NTARG)
11333 RPROJ = RASH(NTARG)
11340 *$ CREATE DT_DIAGR.FOR
11343 *===diagr==============================================================*
11345 SUBROUTINE DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,JNT,INTA,INTB,IDIREC,
11348 ************************************************************************
11349 * Based on the original version by Shmakov et al. *
11350 * This version dated 21.04.95 is revised by S. Roesler *
11351 ************************************************************************
11353 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11356 PARAMETER ( LINP = 10 ,
11360 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
11361 PARAMETER (TWOPI = 6.283185307179586454D+00,
11363 & GEV2MB = 0.38938D0,
11364 & GEV2FM = 0.1972D0,
11365 & ALPHEM = ONE/137.0D0,
11374 PARAMETER ( MAXNCL = 260,
11377 & MAXSQU = 20*MAXVQU,
11378 & MAXINT = MAXVQU+MAXSQU)
11380 * particle properties (BAMJET index convention)
11382 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11383 & IICH(210),IIBAR(210),K1(210),K2(210)
11385 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11387 * emulsion treatment
11388 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11391 * Glauber formalism: parameters
11392 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11393 & BMAX(NCOMPX),BSTEP(NCOMPX),
11394 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11397 * Glauber formalism: cross sections
11398 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11399 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11400 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11401 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11402 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11403 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11404 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11405 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11406 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11407 & BSLOPE,NEBINI,NQBINI
11409 * VDM parameter for photon-nucleus interactions
11410 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
11412 * nucleon-nucleon event-generator
11415 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
11417 C COMMON /CUTOFF/ PTCUT(4),CUTMU(4),FPS(4),FPH(4),PSOMIN,XSOMIN
11420 C obsolete cut-off information
11421 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
11422 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
11425 * coordinates of nucleons
11426 COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
11428 * interface between Glauber formalism and DPM
11429 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
11430 & INTER1(MAXINT),INTER2(MAXINT)
11432 * statistics: Glauber-formalism
11433 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
11435 * n-n cross section fluctuations
11436 PARAMETER (NBINS = 1000)
11437 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
11439 DIMENSION JS(MAXNCL),JT(MAXNCL),
11440 & JS0(MAXNCL),JT0(MAXNCL,MAXNCL),
11441 & JI1(MAXNCL,MAXNCL),JI2(MAXNCL,MAXNCL),JNT0(MAXNCL)
11442 DIMENSION NWA(0:210),NWB(0:210)
11445 DATA LFIRST /.TRUE./
11447 DATA NTARGO,ICNT /0,0/
11453 IF (NCOMPO.EQ.0) THEN
11463 IF (NTARG.EQ.-1) THEN
11464 IF (NCOMPO.EQ.0) THEN
11465 WRITE(LOUT,*) ' DIAGR: distribution of wounded nucleons'
11466 WRITE(LOUT,'(8X,A,3I7)') 'NCALL,NWAMAX,NWBMAX = ',
11467 & NCALL,NWAMAX,NWBMAX
11468 DO 18 I=1,MAX(NWAMAX,NWBMAX)
11469 WRITE(LOUT,'(8X,2I7,E12.4,I7,E12.4)')
11470 & I,NWA(I),DBLE(NWA(I))/DBLE(NCALL),
11471 & NWB(I),DBLE(NWB(I))/DBLE(NCALL)
11481 IF (SQ2.LE.ZERO) SQ2 = 0.0001D0
11483 X = SQ2/(S+SQ2-AMP2)
11484 XNU = (S+SQ2-AMP2)/(TWO*AMP)
11485 * photon projectiles: recalculate photon-nucleon amplitude
11486 IF (IJPROJ.EQ.7) THEN
11488 * VDM assumption: mass of V-meson
11489 AMV2 = DT_SAM2(SQ2,ECMNOW)
11491 IF (AMV.GT.2.0D0*PTCUT(1)) GOTO 15
11492 * check for pointlike interaction
11493 CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,1)
11495 C SIGSH = DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
11496 SIGSH = (ONE-RPNT)*DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
11499 BSLOPE = 2.0D0*(2.0D0+AMRHO0**2/(AMV2+SQ2)
11500 & +0.25D0*LOG(S/(AMV2+SQ2)))
11502 IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+SQ2)*GEV2FM
11503 ELSEIF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
11504 IF (MCGENE.EQ.2) THEN
11506 CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SDUM1,SDUM2,SDUM3,
11509 BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
11511 IF (ECMNOW.LE.3.0D0) THEN
11513 ELSEIF ((ECMNOW.GT.3.0D0).AND.(ECMNOW.LE.50.D0)) THEN
11514 ROSH = -0.63D0+0.175D0*LOG(ECMNOW)
11515 ELSEIF (ECMNOW.GT.50.0D0) THEN
11518 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
11519 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
11520 IF (MCGENE.EQ.2) THEN
11522 CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SIGSH,SDUM2,SDUM3,
11524 SIGSH = SIGSH/10.0D0
11526 C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
11528 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
11529 SIGSH = SIGSH/10.0D0
11532 BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
11534 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
11535 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
11536 C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
11538 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
11539 SIGSH = SIGSH/10.0D0
11541 GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
11543 RCA = GAM*SIGSH/TWOPI
11545 CA = DCMPLX(RCA,FCA)
11546 CI = DCMPLX(ONE,ZERO)
11550 IF (MCGENE.NE.3) CALL DT_MODB(B,NIDX)
11563 IF (IJPROJ.EQ.7) THEN
11573 * nucleon configuration
11574 C IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,5).EQ.0)) THEN
11575 IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,1).EQ.0)) THEN
11576 C CALL DT_CONUCL(PKOO,NA,RASH,2)
11577 C CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),1)
11578 IF (NIDX.LE.-1) THEN
11579 CALL DT_CONUCL(PKOO,NA,RASH(1),0)
11580 CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),0)
11582 CALL DT_CONUCL(PKOO,NA,RASH(NTARG),0)
11583 CALL DT_CONUCL(TKOO,NB,RBSH(1),0)
11589 * LEPTO: pick out one struck nucleon
11590 IF (MCGENE.EQ.3) THEN
11593 IDX = INT(DT_RNDM(X)*NB)+1
11600 * cross section fluctuations
11602 IF (IFLUCT.EQ.1) THEN
11603 IFLUK = INT((DT_RNDM(X)+0.001D0)*1000.0D0)
11604 AFLUC = FLUIXX(IFLUK)
11609 * photon-projectile: check for supression by coherence length
11610 IF (IJPROJ.EQ.7) THEN
11611 IF (ABS(TKOO(3,INB)-TKOO(3,KK1)).GT.DCOH) THEN
11616 QQ1 = B+TKOO(1,INB)-PKOO(1,INA)
11617 QQ2 = TKOO(2,INB)-PKOO(2,INA)
11618 XY = GAM*(QQ1*QQ1+QQ2*QQ2)
11619 IF (XY.LE.15.0D0) THEN
11620 C = CI-CA*AFLUC*EXP(-XY)
11624 IF (DT_RNDM(XY).GE.P) THEN
11626 IF (IJPROJ.EQ.7) THEN
11627 JNT0(KINT) = JNT0(KINT)+1
11628 IF (JNT0(KINT).GT.MAXNCL) THEN
11629 WRITE(LOUT,1001) MAXNCL
11631 & 'DIAGR: no. of requested interactions',
11632 & ' exceeds array dimensions ',I4)
11635 JS0(KINT) = JS0(KINT)+1
11636 JT0(KINT,INB) = JT0(KINT,INB)+1
11637 JI1(KINT,JNT0(KINT)) = INA
11638 JI2(KINT,JNT0(KINT)) = INB
11640 IF (JNT.GT.MAXINT) THEN
11641 WRITE(LOUT,1000) JNT, MAXINT
11643 & 'DIAGR: no. of requested interactions ('
11644 & ,I4,') exceeds array dimensions (',I4,')')
11647 JS(INA) = JS(INA)+1
11648 JT(INB) = JT(INB)+1
11658 IF (NTRY.LT.500) THEN
11661 C WRITE(6,*) ' new impact parameter required (old= ',B,')'
11667 IF (IJPROJ.EQ.7) THEN
11668 K = INT(ONE+DT_RNDM(X)*DBLE(KINT))
11670 IF (JNT0(K).EQ.0) THEN
11672 IF (K.GT.KINT) K = 1
11675 * supress Glauber-cascade by direct photon processes
11676 CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,2)
11677 IF (IPNT.GT.0) THEN
11681 JT(INB) = JT0(K,INB)
11682 IF (JT(INB).GT.0) GOTO 12
11692 JT(INB) = JT0(K,INB)
11695 INTER1(I) = JI1(K,I)
11696 INTER2(I) = JI2(K,I)
11705 IF (JS(I).NE.0) INTA=INTA+1
11708 IF (JT(I).NE.0) INTB=INTB+1
11717 IF (NCOMPO.EQ.0) THEN
11719 NWA(INTA) = NWA(INTA)+1
11720 NWB(INTB) = NWB(INTB)+1
11726 *$ CREATE DT_MODB.FOR
11729 *===modb===============================================================*
11731 SUBROUTINE DT_MODB(B,NIDX)
11733 ************************************************************************
11734 * Sampling of impact parameter of collision. *
11735 * B impact parameter (output) *
11736 * NIDX index of projectile/target material (input)*
11737 * Based on the original version by Shmakov et al. *
11738 * This version dated 21.04.95 is revised by S. Roesler *
11740 * Last change 27.12.2006 by S. Roesler. *
11741 ************************************************************************
11743 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11746 PARAMETER ( LINP = 10 ,
11750 PARAMETER (ZERO=0.0D0,TINY15=1.0D-15,ONE=1.0D0,TWO=2.0D0)
11752 LOGICAL LEFT,LFIRST
11754 * central particle production, impact parameter biasing
11755 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
11757 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11759 * Glauber formalism: parameters
11760 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11761 & BMAX(NCOMPX),BSTEP(NCOMPX),
11762 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11765 * Glauber formalism: cross sections
11766 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11767 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11768 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11769 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11770 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11771 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11772 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11773 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11774 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11775 & BSLOPE,NEBINI,NQBINI
11777 DATA LFIRST /.TRUE./
11780 IF (NIDX.LE.-1) THEN
11788 IF (ICENTR.EQ.2) THEN
11790 BB = DT_RNDM(B)*(0.3D0*RA)**2
11792 ELSEIF(RA.LT.RB)THEN
11793 BB = DT_RNDM(B)*1.4D0*(RB-RA)**2
11795 ELSEIF(RA.GT.RB)THEN
11796 BB = DT_RNDM(B)*1.4D0*(RA-RB)**2
11806 LEFT = ((BSITE(0,1,NTARG,I0)-Y)
11807 & *(BSITE(0,1,NTARG,I1)-Y)).LT.ZERO
11814 IF (I2-I0-2) 40,50,60
11817 IF (I1.GT.NSITEB) I1 = I0-1
11825 X0 = DBLE(I0-1)*BSTEP(NTARG)
11826 X1 = DBLE(I1-1)*BSTEP(NTARG)
11827 X2 = DBLE(I2-1)*BSTEP(NTARG)
11828 Y0 = BSITE(0,1,NTARG,I0)
11829 Y1 = BSITE(0,1,NTARG,I1)
11830 Y2 = BSITE(0,1,NTARG,I2)
11832 B = X0*(Y-Y1)*(Y-Y2)/((Y0-Y1)*(Y0-Y2)+TINY15)+
11833 & X1*(Y-Y0)*(Y-Y2)/((Y1-Y0)*(Y1-Y2)+TINY15)+
11834 & X2*(Y-Y0)*(Y-Y1)/((Y2-Y0)*(Y2-Y1)+TINY15)
11835 **sr 5.4.98: shift B by half the bin width to be in agreement with BPROD
11836 B = B+0.5D0*BSTEP(NTARG)
11837 IF (B.LT.ZERO) B = X1
11838 IF (B.GT.BMAX(NTARG)) B = BMAX(NTARG)
11839 IF (ICENTR.LT.0) THEN
11842 IF (ICENTR.LE.-100) THEN
11847 CALL DT_GETBXS(XSFRAC,BIMIN,BIMAX,NTARG)
11848 WRITE(LOUT,1000) RASH(1),RBSH(NTARG),BMAX(NTARG),
11849 & BIMIN,BIMAX,XSFRAC*100.0D0,
11850 & XSFRAC*XSPRO(1,1,NTARG)
11851 10000 FORMAT(/,1X,'DT_MODB: Biasing in impact parameter',
11852 & /,15X,'---------------------------'/,/,4X,
11853 & 'average radii of proj / targ :',F10.3,' fm /',
11854 & F7.3,' fm',/,4X,'corresp. b_max (4*(r_p+r_t)) :',
11855 & F10.3,' fm',/,/,21X,'b_lo / b_hi :',
11856 & F10.3,' fm /',F7.3,' fm',/,5X,'percentage of',
11857 & ' cross section :',F10.3,' %',/,5X,
11858 & 'corresponding cross section :',F10.3,' mb',/)
11860 IF (ABS(BIMAX-BIMIN).LT.1.0D-3) THEN
11863 IF ((B.LT.BIMIN).OR.(B.GT.BIMAX)) GOTO 9
11871 *$ CREATE DT_SHFAST.FOR
11874 *===shfast=============================================================*
11876 SUBROUTINE DT_SHFAST(MODE,PPN,IBACK)
11878 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11881 PARAMETER ( LINP = 10 ,
11885 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY1=1.0D-1,
11886 & ONE=1.0D0,TWO=2.0D0)
11888 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11890 * Glauber formalism: parameters
11891 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11892 & BMAX(NCOMPX),BSTEP(NCOMPX),
11893 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11896 * properties of interacting particles
11897 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11899 * Glauber formalism: cross sections
11900 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11901 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11902 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11903 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11904 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11905 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11906 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11907 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11908 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11909 & BSLOPE,NEBINI,NQBINI
11913 IF (MODE.EQ.2) THEN
11914 OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11915 WRITE(47,1000) IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG,PPN
11916 1000 FORMAT(1X,8I5,E15.5)
11917 WRITE(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11918 1001 FORMAT(1X,4E15.5)
11919 WRITE(47,1002) SIGSH,ROSH,GSH
11920 1002 FORMAT(1X,3E15.5)
11922 WRITE(47,'(1X,E15.5)') BSITE(1,1,1,I)
11924 WRITE(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11925 1003 FORMAT(1X,2I10,3E15.5)
11928 OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11929 READ(47,1000) JT,JTZ,JP,JPZ,JJPROJ,JBPROJ,JJTARG,JBTARG,PP
11930 IF ((JT.EQ.IT).AND.(JTZ.EQ.ITZ).AND.(JP.EQ.IP).AND.
11931 & (JPZ.EQ.IPZ).AND.(JJPROJ.EQ.IJPROJ).AND.(JBPROJ.EQ.IBPROJ)
11932 & .AND.(JJTARG.EQ.IJTARG).AND.(JBTARG.EQ.IBTARG).AND.
11933 & (ABS(PP-PPN).LT.(PPN*0.01D0))) THEN
11934 READ(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11935 READ(47,1002) SIGSH,ROSH,GSH
11937 READ(47,'(1X,E15.5)') BSITE(1,1,1,I)
11939 READ(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11949 *$ CREATE DT_POILIK.FOR
11952 *===poilik=============================================================*
11954 SUBROUTINE DT_POILIK(NB,NTARG,ECM,VIRT,IPNT,RPNT,MODE)
11956 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
11959 PARAMETER ( LINP = 10 ,
11963 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.0D0)
11967 C CHARACTER*8 MDLNA
11968 C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
11969 C PARAMETER (IEETAB=10)
11970 C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
11973 C model switches and parameters
11975 INTEGER ISWMDL,IPAMDL
11976 DOUBLE PRECISION PARMDL
11977 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11979 C energy-interpolation table
11981 PARAMETER ( IEETA2 = 20 )
11983 DOUBLE PRECISION SIGTAB,SIGECM
11984 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
11987 * VDM parameter for photon-nucleus interactions
11988 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
11991 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11993 * Glauber formalism: cross sections
11994 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11995 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11996 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11997 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11998 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11999 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
12000 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
12001 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
12002 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
12003 & BSLOPE,NEBINI,NQBINI
12006 DATA ECMOLD,Q2OLD /-1.0D0,-1.0D0/
12008 IF ((ECM.EQ.ECMOLD).AND.(VIRT.EQ.Q2OLD)) GOTO 3
12010 * load cross sections from interpolation table
12012 IF(ECM.LE.SIGECM(IP,1)) THEN
12015 ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
12017 IF(ECM.LE.SIGECM(IP,I)) GOTO 200
12023 WRITE(LOUT,'(/1X,A,2E12.3)')
12024 & 'POILIK:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
12029 IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
12030 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
12033 SIGANO = DT_SANO(ECM)
12035 * cross section dependence on photon virtuality
12038 FSUP1 = FSUP1+PARMDL(26+I)*(ONE+VIRT/(4.D0*PARMDL(30+I)))
12039 & /(ONE+VIRT/PARMDL(30+I))**2
12041 FSUP1 = FSUP1+PARMDL(30)/(ONE+VIRT/PARMDL(34))
12051 C SIGTOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
12052 CALL DT_SIGGP(ZERO,VIRT,ECM,ZERO,SIGTOT,DUM1,DUM2)
12053 IF (ISHAD(1).EQ.1) THEN
12054 SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
12058 SIGANO = FSUP1*FSUP2*SIGANO
12059 SIGTOT = SIGTOT-SIGDIR-SIGANO
12060 SIGDIR = SIGDIR/(FSUP1*FSUP2)
12061 SIGANO = SIGANO/(FSUP1*FSUP2)
12062 SIGTOT = SIGTOT+SIGDIR+SIGANO
12064 RR = DT_RNDM(SIGTOT)
12065 IF (RR.LT.SIGDIR/SIGTOT) THEN
12067 ELSEIF ((RR.GE.SIGDIR/SIGTOT).AND.
12068 & (RR.LT.(SIGDIR+SIGANO)/SIGTOT)) THEN
12073 RPNT = (SIGDIR+SIGANO)/SIGTOT
12074 C WRITE(LOUT,'(I3,2F15.5)') ISHAD(1),FAC1,FAC2
12075 C WRITE(LOUT,'(I3,2F15.5)') MODE,SIGDIR,SIGANO
12076 C WRITE(LOUT,'(I3,4F15.5)') MODE,SIGDIR+SIGANO,SIGTOT,RPNT,ECM
12077 C WRITE(LOUT,'(1X,6E12.4)') ECM,VIRT,SIGTOT,SIGDIR,SIGANO,RPNT
12078 IF (MODE.EQ.1) RETURN
12084 IF (ECM.GE.ECMNN(NEBINI)) THEN
12088 ELSEIF (ECM.GT.ECMNN(1)) THEN
12090 IF (ECM.LT.ECMNN(I)) THEN
12093 RATE = (ECM-ECMNN(K1))/(ECMNN(K2)-ECMNN(K1))
12102 IF (NQBINI.GT.1) THEN
12103 IF (VIRT.GE.Q2G(NQBINI)) THEN
12107 ELSEIF (VIRT.GT.Q2G(1)) THEN
12109 IF (VIRT.LT.Q2G(I)) THEN
12112 RATQ = LOG10( VIRT/MAX(Q2G(J1),TINY14))/
12113 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
12120 SGA = XSPRO(K1,J1,NTARG)+
12121 & RATE*(XSPRO(K2,J1,NTARG)-XSPRO(K1,J1,NTARG))+
12122 & RATQ*(XSPRO(K1,J2,NTARG)-XSPRO(K1,J1,NTARG))+
12123 & RATE*RATQ*(XSPRO(K2,J2,NTARG)-XSPRO(K1,J2,NTARG)+
12124 & XSPRO(K1,J1,NTARG)-XSPRO(K2,J1,NTARG))
12125 SDI = DBLE(NB)*SIGDIR
12126 SAN = DBLE(NB)*SIGANO
12129 IF (RR.LT.SDI/SGA) THEN
12131 ELSEIF ((RR.GE.SDI/SGA).AND.
12132 & (RR.LT.SPL/SGA)) THEN
12138 C WRITE(LOUT,'(I3,4F15.5)') MODE,SPL,SGA,RPNT,ECM
12144 *$ CREATE DT_GLBINI.FOR
12147 *===glbini=============================================================*
12149 SUBROUTINE DT_GLBINI(WHAT)
12151 ************************************************************************
12152 * Pre-initialization of profile function *
12153 * This version dated 28.11.00 is written by S. Roesler. *
12155 * Last change 27.12.2006 by S. Roesler. *
12156 ************************************************************************
12158 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12161 PARAMETER ( LINP = 10 ,
12165 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.D-14)
12169 * particle properties (BAMJET index convention)
12171 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12172 & IICH(210),IIBAR(210),K1(210),K2(210)
12174 * properties of interacting particles
12175 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
12177 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
12179 * emulsion treatment
12180 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
12183 * Glauber formalism: flags and parameters for statistics
12186 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
12188 * number of data sets other than protons and nuclei
12189 * at the moment = 2 (pions and kaons)
12190 PARAMETER (MAXOFF=2)
12191 DIMENSION IJPINI(5),IOFFST(25)
12192 DATA IJPINI / 13, 15, 0, 0, 0/
12193 * Glauber data-set to be used for hadron projectiles
12194 * (0=proton, 1=pion, 2=kaon)
12195 DATA (IOFFST(K),K=1,25) /
12196 & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
12198 * Acceptance interval for target nucleus mass
12199 PARAMETER (KBACC = 6)
12201 * flags for input different options
12202 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
12203 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
12204 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
12206 PARAMETER (MAXMSS = 100)
12207 DIMENSION IASAV(MAXMSS),IBSAV(MAXMSS)
12210 DATA JPEACH,JPSTEP / 18, 5 /
12212 * temporary patch until fix has been implemented in phojet:
12213 * maximum energy for pion projectile
12214 DATA ECMXPI / 100000.0D0 /
12216 *--------------------------------------------------------------------------
12217 * general initializations
12219 * steps in projectile mass number for initialization
12220 IF (WHAT(4).GT.ZERO) JPEACH = INT(WHAT(4))
12221 IF (WHAT(5).GT.ZERO) JPSTEP = INT(WHAT(5))
12223 * energy range and binning
12226 IF (ELO.GT.EHI) ELO = EHI
12227 NEBIN = MAX(INT(WHAT(3)),1)
12228 IF (ELO.EQ.EHI) NEBIN = 0
12229 LCMS = (WHAT(1).LT.ZERO).OR.(WHAT(2).LT.ZERO)
12233 ECMINI = SQRT(AAM(IJPROJ)**2+AAM(IJTARG)**2
12234 & +2.0D0*AAM(IJTARG)*EHI)
12237 * default arguments for Glauber-routine
12241 * initialize nuclear parameters, etc.
12243 * initialize evaporation if the code is not used as Fluka event generator
12244 IF (ITRSPT.NE.1) THEN
12250 * open Glauber-data output file
12251 IDX = INDEX(CGLB,' ')
12253 IF (IDX.GT.1) K = IDX-1
12254 OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
12256 *--------------------------------------------------------------------------
12257 * Glauber-initialization for proton and nuclei projectiles
12259 * initialize phojet for proton-proton interactions
12262 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
12265 * record projectile masses
12267 NPROJ = MIN(IP,JPEACH)
12268 DO 10 KPROJ=1,NPROJ
12270 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12271 IASAV(NASAV) = KPROJ
12273 IF (IP.GT.JPEACH) THEN
12274 NPROJ = DBLE(IP-JPEACH)/DBLE(JPSTEP)
12275 IF (NPROJ.EQ.0) THEN
12277 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12280 DO 11 IPROJ=1,NPROJ
12281 KPROJ = JPEACH+IPROJ*JPSTEP
12283 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12284 IASAV(NASAV) = KPROJ
12286 IF (KPROJ.LT.IP) THEN
12288 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12294 * record target masses
12297 IF (NCOMPO.GT.0) NTARG = NCOMPO
12298 DO 12 ITARG=1,NTARG
12300 IF (NBSAV.GT.MAXMSS) STOP ' GLBINI: NBSAV > MAXMSS ! '
12301 IF (NCOMPO.GT.0) THEN
12302 IBSAV(NBSAV) = IEMUMA(ITARG)
12309 WRITE(LDAT,1000) NEBIN,': ',SIGN(ELO,WHAT(1)),SIGN(EHI,WHAT(2))
12310 1000 FORMAT(I4,A,1P,2E13.5)
12311 NLINES = DBLE(NASAV)/18.0D0
12312 IF (NLINES.GT.0) THEN
12315 WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=1,18)
12317 WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=18*I-17,18*I)
12322 IF (I0.LE.NASAV) THEN
12324 WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=I0,NASAV)
12326 WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=I0,NASAV)
12329 NLINES = DBLE(NBSAV)/18.0D0
12330 IF (NLINES.GT.0) THEN
12333 WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=1,18)
12335 WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=18*I-17,18*I)
12340 IF (I0.LE.NBSAV) THEN
12342 WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=I0,NBSAV)
12344 WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=I0,NBSAV)
12348 * calculate Glauber-data for each energy and mass combination
12350 * loop over energy bins
12353 DEBIN = (EHI-ELO)/MAX(DBLE(NEBIN),ONE)
12355 E = ELO+DBLE(IE-1)*DEBIN
12358 E = MAX(2.0D0*AAM(IJPROJ)+0.1D0,E)
12363 E = MAX(AAM(IJPROJ)+0.1D0,E)
12364 CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
12367 * loop over projectile and target masses
12370 CALL DT_XSGLAU(IASAV(IPROJ),IBSAV(ITARG),IJPROJ,
12371 & XI,Q2I,ECM,1,1,-1)
12377 *--------------------------------------------------------------------------
12378 * Glauber-initialization for pion, kaon, ... projectiles
12382 * initialize phojet for this interaction
12385 IJPROJ = IJPINI(IJ)
12389 * temporary patch until fix has been implemented in phojet:
12390 IF (ECMINI.GT.ECMXPI) THEN
12391 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMXPI,1)
12393 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
12397 * calculate Glauber-data for each energy and mass combination
12399 * loop over energy bins
12401 E = ELO+DBLE(IE-1)*DEBIN
12404 E = MAX(2.0D0*AAM(IJPROJ)+TINY14,E)
12409 E = MAX(AAM(IJPROJ)+TINY14,E)
12410 CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
12413 * loop over projectile and target masses
12415 CALL DT_XSGLAU(1,IBSAV(ITARG),IJPROJ,XI,Q2I,ECM,1,1,-1)
12422 *--------------------------------------------------------------------------
12423 * close output unit(s), etc.
12430 *$ CREATE DT_GLBSET.FOR
12433 *===glbset=============================================================*
12435 SUBROUTINE DT_GLBSET(IDPROJ,NA,NB,ELAB,MODE)
12436 ************************************************************************
12437 * Interpolation of pre-initialized profile functions *
12438 * This version dated 28.11.00 is written by S. Roesler. *
12439 ************************************************************************
12441 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12444 PARAMETER ( LINP = 10 ,
12448 PARAMETER (ZERO=0.0D0,ONE=1.0D0)
12450 LOGICAL LCMS,LREAD,LFRST1,LFRST2
12452 * particle properties (BAMJET index convention)
12454 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12455 & IICH(210),IIBAR(210),K1(210),K2(210)
12457 * Glauber formalism: flags and parameters for statistics
12460 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
12462 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
12464 * Glauber formalism: parameters
12465 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
12466 & BMAX(NCOMPX),BSTEP(NCOMPX),
12467 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
12470 * Glauber formalism: cross sections
12471 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
12472 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
12473 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
12474 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
12475 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
12476 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
12477 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
12478 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
12479 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
12480 & BSLOPE,NEBINI,NQBINI
12482 * number of data sets other than protons and nuclei
12483 * at the moment = 2 (pions and kaons)
12484 PARAMETER (MAXOFF=2)
12485 DIMENSION IJPINI(5),IOFFST(25)
12486 DATA IJPINI / 13, 15, 0, 0, 0/
12487 * Glauber data-set to be used for hadron projectiles
12488 * (0=proton, 1=pion, 2=kaon)
12489 DATA (IOFFST(K),K=1,25) /
12490 & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
12492 * Acceptance interval for target nucleus mass
12493 PARAMETER (KBACC = 6)
12495 * emulsion treatment
12496 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
12499 PARAMETER (MAXSET=5000,
12501 DIMENSION XSIG(MAXSET,6),XERR(MAXSET,6),BPROFL(MAXSET,KSITEB)
12502 DIMENSION IABIN(MAXBIN),IBBIN(MAXBIN),XS(6),XE(6),
12503 & BPRO0(KSITEB),BPRO1(KSITEB),BPRO(KSITEB),
12506 DATA LREAD,LFRST1,LFRST2 /.FALSE.,.TRUE.,.TRUE./
12508 * read data from file
12510 IF (MODE.EQ.0) THEN
12533 IDX = INDEX(CGLB,' ')
12535 IF (IDX.GT.1) K = IDX-1
12536 OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
12537 WRITE(LOUT,1000) CGLB(1:K)//'.glb'
12538 1000 FORMAT(/,' GLBSET: impact parameter distributions read from ',
12541 * read binning information
12542 READ(LDAT,'(I4,2X,2E13.5)') NEBIN,ELO,EHI
12543 * return lower energy threshold to Fluka-interface
12546 WRITE(LOUT,'(1X,A)') ' equidistant logarithmic energy binning:'
12548 WRITE(LOUT,1001) '(cms)',ABS(ELO),ABS(EHI),NEBIN
12550 WRITE(LOUT,1001) '(lab)',ABS(ELO),ABS(EHI),NEBIN
12552 1001 FORMAT(2X,A5,' E_lo = ',1P,E9.3,' E_hi = ',1P,E9.3,4X,
12553 & 'No. of bins:',I5,/)
12554 ELO = LOG10(ABS(ELO))
12555 EHI = LOG10(ABS(EHI))
12556 DEBIN = (EHI-ELO)/ABS(DBLE(NEBIN))
12557 WRITE(LOUT,'(/,1X,A)') ' projectiles: (mass number)'
12558 READ(LDAT,'(I4,2X,18I4)') NABIN,(IABIN(J),J=1,18)
12559 IF (NABIN.LT.18) THEN
12560 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,NABIN)
12562 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,18)
12564 IF (NABIN.GT.MAXBIN) STOP ' GLBSET: NABIN > MAXBIN !'
12565 IF (NABIN.GT.18) THEN
12566 NLINES = DBLE(NABIN-18)/18.0D0
12567 IF (NLINES.GT.0) THEN
12570 READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
12571 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
12574 I0 = 18*(NLINES+1)+1
12575 IF (I0.LE.NABIN) THEN
12576 READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
12577 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
12580 WRITE(LOUT,'(/,1X,A)') ' targets: (mass number)'
12581 READ(LDAT,'(I4,2X,18I4)') NBBIN,(IBBIN(J),J=1,18)
12582 IF (NBBIN.LT.18) THEN
12583 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,NBBIN)
12585 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,18)
12587 IF (NBBIN.GT.MAXBIN) STOP ' GLBSET: NBBIN > MAXBIN !'
12588 IF (NBBIN.GT.18) THEN
12589 NLINES = DBLE(NBBIN-18)/18.0D0
12590 IF (NLINES.GT.0) THEN
12593 READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12594 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12597 I0 = 18*(NLINES+1)+1
12598 IF (I0.LE.NBBIN) THEN
12599 READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12600 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12603 * number of data sets to follow in the Glauber data file
12604 * this variable is used for checks of consistency of projectile
12605 * and target mass configurations given in header of Glauber data
12606 * file and the data-sets which follow in this file
12607 NSET0 = (NEBIN+1)*(NABIN+MAXOFF)*NBBIN
12609 * read profile function data
12615 IF (NSET.GT.MAXSET) STOP ' GLBSET: NSET > MAXSET ! '
12616 READ(LDAT,1002,END=100) IP,IA,IB,ISTATB,ISITEB,ECM
12617 1002 FORMAT(5I10,E15.5)
12618 IF ((IP.NE.1).AND.(IP.NE.IPOLD)) THEN
12620 IF (NAIDX.GT.10) STOP ' GLBSET: NAIDX > 10 !'
12624 READ(LDAT,'(6E12.5)') (XSIG(NSET,I),I=1,6)
12625 READ(LDAT,'(6E12.5)') (XERR(NSET,I),I=1,6)
12626 NLINES = INT(DBLE(ISITEB)/7.0D0)
12627 IF (NLINES.GT.0) THEN
12629 READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=7*I-6,7*I)
12634 & READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=I0,ISITEB)
12638 IF (NSET.NE.NSET0) STOP ' GLBSET: NSET.NE.NSET0 !'
12639 WRITE(LOUT,'(/,1X,A)')
12640 & ' projectiles other than protons and nuclei: (particle index)'
12641 IF (NAIDX.GT.0) THEN
12642 WRITE(LOUT,'(6X,18I4)') (IAIDX(J),J=1,NAIDX)
12644 WRITE(LOUT,'(6X,A)') 'none'
12651 IF (NCOMPO.EQ.0) THEN
12654 IEMUMA(NCOMPO) = IBBIN(J)
12655 IEMUCH(NCOMPO) = IEMUMA(NCOMPO)/2
12656 EMUFRA(NCOMPO) = 1.0D0
12661 * calculate profile function for certain set of parameters
12665 c write(*,*) 'glbset called for ',IDPROJ,NA,NB,ELAB,MODE
12667 * check for type of projectile and set index-offset to entry in
12668 * Glauber data array correspondingly
12669 IF (IDPROJ.GT.25) STOP ' GLBSET: IDPROJ > 25 !'
12670 IF (IOFFST(IDPROJ).EQ.-1) THEN
12671 STOP ' GLBSET: no data for this projectile !'
12672 ELSEIF (IOFFST(IDPROJ).GT.0) THEN
12673 IDXOFF = (NEBIN+1)*(NABIN+IOFFST(IDPROJ)-1)*NBBIN
12678 * get energy bin and interpolation factor
12680 E = SQRT(AAM(IDPROJ)**2+AAM(1)**2+2.0D0*AAM(1)*ELAB)
12687 WRITE(LOUT,*) ' GLBSET: Too low energy! (E_lo,E) ',ELO,E
12694 WRITE(LOUT,*) ' GLBSET: Too high energy! (E_hi,E) ',EHI,E
12699 IE0 = (E-ELO)/DEBIN+1
12701 FACE = (E-(ELO+DBLE(IE0-1)*DEBIN))/DEBIN
12703 * get target nucleus index
12707 NBDIFF = ABS(NB-IBBIN(I))
12708 IF (NB.EQ.IBBIN(I)) THEN
12711 ELSEIF (NBDIFF.LE.NBACC) THEN
12716 IF (KB.NE.0) GOTO 21
12717 WRITE(LOUT,*) ' GLBSET: data not found for target ',NB
12721 * get projectile nucleus bin and interpolation factor
12725 IF (IDXOFF.GT.0) THEN
12730 IF (NA.GT.IABIN(NABIN)) STOP ' GLBSET: NA > IABIN(NABIN) !'
12732 IF (NA.EQ.IABIN(I)) THEN
12736 ELSEIF (NA.LT.IABIN(I)) THEN
12742 WRITE(LOUT,*) ' GLBSET: data not found for projectile ',NA
12746 & FACNA = DBLE(NA-IABIN(KA0))/DBLE(IABIN(KA1)-IABIN(KA0))
12750 * interpolate profile functions for interactions ka0-kb and ka1-kb
12751 * for energy E separately
12752 IDX0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12753 IDX1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12754 IDY0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12755 IDY1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12757 BPRO0(I) = BPROFL(IDX0,I)
12758 & +FACE*(BPROFL(IDX1,I)-BPROFL(IDX0,I))
12759 BPRO1(I) = BPROFL(IDY0,I)
12760 & +FACE*(BPROFL(IDY1,I)-BPROFL(IDY0,I))
12762 RADB = DT_RNCLUS(NB)
12763 BSTP0 = 2.0D0*(DT_RNCLUS(IABIN(KA0))+RADB)/DBLE(ISITEB-1)
12764 BSTP1 = 2.0D0*(DT_RNCLUS(IABIN(KA1))+RADB)/DBLE(ISITEB-1)
12766 * interpolate cross sections for energy E and projectile mass
12768 XS0 = XSIG(IDX0,I)+FACE*(XSIG(IDX1,I)-XSIG(IDX0,I))
12769 XS1 = XSIG(IDY0,I)+FACE*(XSIG(IDY1,I)-XSIG(IDY0,I))
12770 XS(I) = XS0+FACNA*(XS1-XS0)
12771 XE0 = XERR(IDX0,I)+FACE*(XERR(IDX1,I)-XERR(IDX0,I))
12772 XE1 = XERR(IDY0,I)+FACE*(XERR(IDY1,I)-XERR(IDY0,I))
12773 XE(I) = XE0+FACNA*(XE1-XE0)
12776 * interpolate between ka0 and ka1
12777 RADA = DT_RNCLUS(NA)
12778 BMX = 2.0D0*(RADA+RADB)
12779 BSTP = BMX/DBLE(ISITEB-1)
12784 * calculate values of profile functions at B
12786 IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12787 IDX1 = MIN(IDX0+1,ISITEB)
12788 FACB = (B-DBLE(IDX0-1)*BSTP0)/BSTP0
12789 BPR0 = BPRO0(IDX0)+FACB*(BPRO0(IDX1)-BPRO0(IDX0))
12791 IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12792 IDX1 = MIN(IDX0+1,ISITEB)
12793 FACB = (B-DBLE(IDX0-1)*BSTP1)/BSTP1
12794 BPR1 = BPRO1(IDX0)+FACB*(BPRO1(IDX1)-BPRO1(IDX0))
12796 BPRO(I+1) = BPR0+FACNA*(BPR1-BPR0)
12799 * fill common dtglam
12806 BSITE(0,1,1,I) = BPRO(I)
12809 * fill common dtglxs
12810 XSTOT(1,1,1) = XS(1)
12811 XSELA(1,1,1) = XS(2)
12812 XSQEP(1,1,1) = XS(3)
12813 XSQET(1,1,1) = XS(4)
12814 XSQE2(1,1,1) = XS(5)
12815 XSPRO(1,1,1) = XS(6)
12816 XETOT(1,1,1) = XE(1)
12817 XEELA(1,1,1) = XE(2)
12818 XEQEP(1,1,1) = XE(3)
12819 XEQET(1,1,1) = XE(4)
12820 XEQE2(1,1,1) = XE(5)
12821 XEPRO(1,1,1) = XE(6)
12827 *$ CREATE DT_XKSAMP.FOR
12830 *===xksamp=============================================================*
12832 SUBROUTINE DT_XKSAMP(NN,ECM)
12834 ************************************************************************
12835 * Sampling of parton x-values and chain system for one interaction. *
12836 * processed by S. Roesler, 9.8.95 *
12837 ************************************************************************
12839 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12842 PARAMETER ( LINP = 10 ,
12846 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
12850 * lower cuts for (valence-sea/sea-valence) chain masses
12851 * antiquark-quark (u/d-sea quark) (s-sea quark)
12852 & AMIU = 0.5D0, AMIS = 0.8D0,
12853 * quark-diquark (u/d-sea quark) (s-sea quark)
12854 & AMAU = 2.6D0, AMAS = 2.6D0,
12855 * maximum lower valence-x threshold
12857 * fraction of sea-diquarks sampled out of sea-partons
12859 C & FRCDIQ = 0.9D0,
12864 * maximum number of trials to generate x's for the required number
12865 * of sea quark pairs for a given hadron
12870 LOGICAL ZUOVP,ZUOSP,ZUOVT,ZUOST,INTLO
12872 PARAMETER ( MAXNCL = 260,
12875 & MAXSQU = 20*MAXVQU,
12876 & MAXINT = MAXVQU+MAXSQU)
12880 PARAMETER (NMXHKK=200000)
12882 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
12883 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
12884 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
12886 * particle properties (BAMJET index convention)
12888 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12889 & IICH(210),IIBAR(210),K1(210),K2(210)
12891 * interface between Glauber formalism and DPM
12892 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
12893 & INTER1(MAXINT),INTER2(MAXINT)
12895 * properties of interacting particles
12896 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
12898 * threshold values for x-sampling (DTUNUC 1.x)
12899 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
12902 * x-values of partons (DTUNUC 1.x)
12903 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
12904 & XTVQ(MAXVQU),XTVD(MAXVQU),
12905 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
12906 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
12908 * flavors of partons (DTUNUC 1.x)
12909 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
12910 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
12911 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
12912 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
12913 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
12914 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
12915 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
12917 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12918 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
12919 & IXPV,IXPS,IXTV,IXTS,
12920 & INTVV1(MAXVQU),INTVV2(MAXVQU),
12921 & INTSV1(MAXVQU),INTSV2(MAXVQU),
12922 & INTVS1(MAXVQU),INTVS2(MAXVQU),
12923 & INTSS1(MAXSQU),INTSS2(MAXSQU),
12924 & INTDV1(MAXVQU),INTDV2(MAXVQU),
12925 & INTVD1(MAXVQU),INTVD2(MAXVQU),
12926 & INTDS1(MAXSQU),INTDS2(MAXSQU),
12927 & INTSD1(MAXSQU),INTSD2(MAXSQU)
12929 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12930 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
12931 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
12933 * auxiliary common for chain system storage (DTUNUC 1.x)
12934 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
12936 * flags for input different options
12937 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
12938 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
12939 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
12941 * various options for treatment of partons (DTUNUC 1.x)
12942 * (chain recombination, Cronin,..)
12943 LOGICAL LCO2CR,LINTPT
12944 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
12947 DIMENSION ZUOVP(MAXVQU),ZUOSP(MAXSQU),ZUOVT(MAXVQU),ZUOST(MAXSQU),
12950 * (1) initializations
12951 *-----------------------------------------------------------------------
12954 IF (ECM.LT.4.5D0) THEN
12957 ELSEIF ((ECM.GE.4.5D0).AND.(ECM.LT.7.5)) THEN
12958 C FRCDIQ = 0.6D0+(ECM-4.5D0)/3.0D0*0.3D0
12959 FRCDIQ = 0.4D0+(ECM-4.5D0)/3.0D0*0.3D0
12968 IF (I.LE.MAXVQU) THEN
12974 * lower thresholds for x-selection
12975 * sea-quarks (default: CSEA=0.2)
12976 IF (ECM.LT.10.0D0) THEN
12978 XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM
12979 C XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM**2.0D0
12981 C XSTHR = ONE/ECM**2
12985 XSTHR = CSEA/ECM**2
12986 C XSTHR = ONE/ECM**2
12988 IF ((IP.GE.150).AND.(IT.GE.150))
12989 & XSTHR = 2.5D0/(ECM*SQRT(ECM))
12992 * (default: SSMIMA=0.14) used for sea-diquarks (?)
12993 XSSTHR = SSMIMA/ECM
12995 * valence-quarks (default: CVQ=1.0)
12997 * valence-diquarks (default: CDQ=2.0)
13000 * maximum-x for sea-quarks
13001 XVCUT = XVTHR+XDTHR
13002 IF (XVCUT.GT.XVMAX) THEN
13004 XVTHR = XVCUT/3.0D0
13005 XDTHR = XVCUT-XVTHR
13008 **sr 18.4. test: DPMJET
13009 C XXSEAM=1.0 - XVTHR*(1.D0+0.3D0*DT_RNDM(V1))
13010 C & - XDTHR*(1.D0+0.3D0*DT_RNDM(V2))
13011 C & -0.01*(1.D0+1.5D0*DT_RNDM(V3))
13013 * maximum number of sea-pairs allowed kinematically
13014 C NSMAX = INT(OHALF*XXSEAM/XSTHR)
13015 RNSMAX = OHALF*XXSEAM/XSTHR
13016 IF (RNSMAX.GT.10000.0D0) THEN
13019 NSMAX = INT(OHALF*XXSEAM/XSTHR)
13021 * check kinematical limit for valence-x thresholds
13022 * (should be obsolete now)
13023 IF (XVCUT.GT.XVMAX) THEN
13024 WRITE(LOUT,1000) XVCUT,ECM
13025 1000 FORMAT(' XKSAMP: kin. limit for valence-x',
13026 & ' thresholds not allowed (',2E9.3,')')
13027 C XVTHR = XVMAX-XDTHR
13028 C IF (XVTHR.LT.ZERO) STOP
13032 * set eta for valence-x sampling (BETREJ)
13033 * (UNON per default, UNOM used for projectile mesons only)
13034 IF ((IJPROJ.NE.0).AND.(IBPROJ.EQ.0)) THEN
13040 * (2) select parton x-values of interacting projectile nucleons
13041 *-----------------------------------------------------------------------
13047 * get interacting projectile nucleon as sampled by Glauber
13048 IF (JSSH(IPP).NE.0) THEN
13054 * JIPP is the actual number of sea-pairs sampled for this nucleon
13055 JIPP = MIN(JSSH(IPP)-1,NSMAX)
13058 IF (JIPP.GT.0) THEN
13059 XSMAX = XXSEAM-2.0D0*DBLE(JIPP)*XSTHR
13061 IF (XSTHR.GE.XSMAX) THEN
13066 *>>>get x-values of sea-quark pairs
13070 * accumulator for sea x-values
13073 IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
13074 IF (NSCOUN.GT.NSEA) THEN
13075 * decrease the number of interactions after NSEA trials
13081 IF (IPSQ(IXPS+1).LE.2) THEN
13082 **sr 8.4.98 (1/sqrt(x))
13083 C XPSQI = DT_SAMPEX(XSTHR,XSMAX)
13084 C XPSQI = DT_SAMSQX(XSTHR,XSMAX)
13085 XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13088 IF (XSMAX.GT.XSTHR+BSQMA) THEN
13089 XPSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13091 **sr 8.4.98 (1/sqrt(x))
13092 C XPSQI = DT_SAMPEX(XSTHR,XSMAX)
13093 C XPSQI = DT_SAMSQX(XSTHR,XSMAX)
13094 XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13099 IF (IPSAQ(IXPS+1).GE.-2) THEN
13100 **sr 8.4.98 (1/sqrt(x))
13101 C XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
13102 C XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
13103 XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13106 IF (XSMAX.GT.XSTHR+BSQMA) THEN
13107 XPSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13109 **sr 8.4.98 (1/sqrt(x))
13110 C XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
13111 C XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
13112 XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13116 XXSEA = XXSEA+XPSQI+XPSAQI
13117 * check for maximum allowed sea x-value
13118 IF (XXSEA.GE.XXSEAM) THEN
13122 * accept this sea-quark pair
13125 XPSAQ(IXPS) = XPSAQI
13127 ZUOSP(IXPS) = .TRUE.
13131 *>>>get x-values of valence partons
13133 IF (XVTHR.GT.0.05D0) THEN
13134 XVHI = ONE-XXSEA-XDTHR
13135 XPVQI = DT_BETREJ(OHALF,UNOPRV,XVTHR,XVHI)
13138 XPVQI = DT_DBETAR(OHALF,UNOPRV)
13139 IF ((XPVQI.LT.XVTHR).OR.(ONE-XPVQI-XXSEA.LT.XDTHR))
13143 XPVDI = ONE-XPVQI-XXSEA
13144 * reject according to x**1.5
13145 XDTMP = XPVDI**1.5D0
13146 IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 99
13147 * accept these valence partons
13153 ZUOVP(IXPV) = .TRUE.
13158 * (3) select parton x-values of interacting target nucleons
13159 *-----------------------------------------------------------------------
13165 * get interacting target nucleon as sampled by Glauber
13166 IF (JTSH(ITT).NE.0) THEN
13172 * JITT is the actual number of sea-pairs sampled for this nucleon
13173 JITT = MIN(JTSH(ITT)-1,NSMAX)
13176 IF (JITT.GT.0) THEN
13177 XSMAX = XXSEAM-2.0D0*DBLE(JITT)*XSTHR
13179 IF (XSTHR.GE.XSMAX) THEN
13184 *>>>get x-values of sea-quark pairs
13188 * accumulator for sea x-values
13191 IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
13192 IF (NSCOUN.GT.NSEA)THEN
13193 * decrease the number of interactions after NSEA trials
13199 IF (ITSQ(IXTS+1).LE.2) THEN
13200 **sr 8.4.98 (1/sqrt(x))
13201 C XTSQI = DT_SAMPEX(XSTHR,XSMAX)
13202 C XTSQI = DT_SAMSQX(XSTHR,XSMAX)
13203 XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13206 IF (XSMAX.GT.XSTHR+BSQMA) THEN
13207 XTSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13209 **sr 8.4.98 (1/sqrt(x))
13210 C XTSQI = DT_SAMPEX(XSTHR,XSMAX)
13211 C XTSQI = DT_SAMSQX(XSTHR,XSMAX)
13212 XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13217 IF (ITSAQ(IXTS+1).GE.-2) THEN
13218 **sr 8.4.98 (1/sqrt(x))
13219 C XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
13220 C XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
13221 XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13224 IF (XSMAX.GT.XSTHR+BSQMA) THEN
13225 XTSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13227 **sr 8.4.98 (1/sqrt(x))
13228 C XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
13229 C XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
13230 XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13234 XXSEA = XXSEA+XTSQI+XTSAQI
13235 * check for maximum allowed sea x-value
13236 IF (XXSEA.GE.XXSEAM) THEN
13240 * accept this sea-quark pair
13243 XTSAQ(IXTS) = XTSAQI
13245 ZUOST(IXTS) = .TRUE.
13249 *>>>get x-values of valence partons
13251 IF (XVTHR.GT.0.05D0) THEN
13252 XVHI = ONE-XXSEA-XDTHR
13253 XTVQI = DT_BETREJ(OHALF,UNON,XVTHR,XVHI)
13256 XTVQI = DT_DBETAR(OHALF,UNON)
13257 IF ((XTVQI.LT.XVTHR).OR.(ONE-XTVQI-XXSEA.LT.XDTHR))
13261 XTVDI = ONE-XTVQI-XXSEA
13262 * reject according to x**1.5
13263 XDTMP = XTVDI**1.5D0
13264 IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 169
13265 * accept these valence partons
13271 ZUOVT(IXTV) = .TRUE.
13276 * (4) get valence-valence chains
13277 *-----------------------------------------------------------------------
13282 IPVAL = ITOVP(INTER1(I))
13283 ITVAL = ITOVT(INTER2(I))
13284 IF (ZUOVP(IPVAL).AND.ZUOVT(ITVAL)) THEN
13286 ZUOVP(IPVAL) = .FALSE.
13287 ZUOVT(ITVAL) = .FALSE.
13290 INTVV1(NVV) = IPVAL
13291 INTVV2(NVV) = ITVAL
13295 * (5) get sea-valence chains
13296 *-----------------------------------------------------------------------
13303 IPVAL = ITOVP(INTER1(I))
13304 ITVAL = ITOVT(INTER2(I))
13306 IF (ZUOSP(J).AND.(IFROSP(J).EQ.INTER1(I)).AND.
13307 & ZUOVT(ITVAL)) THEN
13309 ZUOVT(ITVAL) = .FALSE.
13311 IF (LSEADI.AND.(DT_RNDM(PLW).GT.FRCDIQ)) THEN
13312 * sample sea-diquark pair
13313 CALL DT_SAMSDQ(ECM,ITVAL,J,2,IREJ1)
13314 IF (IREJ1.EQ.0) GOTO 260
13319 INTSV2(NSV) = ITVAL
13321 *>>>correct chain kinematics according to minimum chain masses
13322 * the actual chain masses
13323 AMSVQ1 = XPSQ(J) *XTVD(ITVAL)*ECM**2
13324 AMSVQ2 = XPSAQ(J)*XTVQ(ITVAL)*ECM**2
13325 * get lower mass cuts
13326 IF (IPSQ(J).EQ.3) THEN
13331 * q being u/d-quark
13336 * chain mass above minimum - resampling of sea-q x-value
13337 IF (AMSVQ1.GT.AMCHK1) THEN
13338 XPSQTH = AMCHK1/(XTVD(ITVAL)*ECM**2)
13339 **sr 8.4.98 (1/sqrt(x))
13340 C XPSQXX = DT_SAMPEX(XPSQTH,XPSQ(J))
13341 C XPSQXX = DT_SAMSQX(XPSQTH,XPSQ(J))
13342 XPSQXX = DT_SAMPLW(XPSQTH,XPSQ(J),PLW)
13344 XPVD(IPVAL) = XPVD(IPVAL)+XPSQ(J)-XPSQXX
13346 * chain mass below minimum - reset sea-q x-value and correct
13347 * diquark-x of the same nucleon
13348 ELSEIF (AMSVQ1.LT.AMCHK1) THEN
13349 XPSQW = AMCHK1/(XTVD(ITVAL)*ECM**2)
13350 DXPSQ = XPSQW-XPSQ(J)
13351 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
13352 XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
13357 * chain mass below minimum - reset sea-aq x-value and correct
13358 * diquark-x of the same nucleon
13359 IF (AMSVQ2.LT.AMCHK2) THEN
13360 XPSQW = AMCHK2/(XTVQ(ITVAL)*ECM**2)
13361 DXPSQ = XPSQW-XPSAQ(J)
13362 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
13363 XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
13367 *>>>end of chain mass correction
13376 * (6) get valence-sea chains
13377 *-----------------------------------------------------------------------
13383 IPVAL = ITOVP(INTER1(I))
13384 ITVAL = ITOVT(INTER2(I))
13386 IF (ZUOVP(IPVAL).AND.ZUOST(J).AND.
13387 & (IFROST(J).EQ.INTER2(I))) THEN
13389 ZUOVP(IPVAL) = .FALSE.
13391 IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
13392 * sample sea-diquark pair
13393 CALL DT_SAMSDQ(ECM,IPVAL,J,1,IREJ1)
13394 IF (IREJ1.EQ.0) GOTO 290
13398 INTVS1(NVS) = IPVAL
13401 *>>>correct chain kinematics according to minimum chain masses
13402 * the actual chain masses
13403 AMVSQ1 = XPVQ(IPVAL)*XTSAQ(J)*ECM**2
13404 AMVSQ2 = XPVD(IPVAL)*XTSQ(J) *ECM**2
13405 * get lower mass cuts
13406 IF (ITSQ(J).EQ.3) THEN
13411 * q being u/d-quark
13416 * chain mass below minimum - reset sea-aq x-value and correct
13417 * diquark-x of the same nucleon
13418 IF (AMVSQ1.LT.AMCHK1) THEN
13419 XTSQW = AMCHK1/(XPVQ(IPVAL)*ECM**2)
13420 DXTSQ = XTSQW-XTSAQ(J)
13421 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
13422 XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
13427 * chain mass above minimum - resampling of sea-q x-value
13428 IF (AMVSQ2.GT.AMCHK2) THEN
13429 XTSQTH = AMCHK2/(XPVD(IPVAL)*ECM**2)
13430 **sr 8.4.98 (1/sqrt(x))
13431 C XTSQXX = DT_SAMPEX(XTSQTH,XTSQ(J))
13432 C XTSQXX = DT_SAMSQX(XTSQTH,XTSQ(J))
13433 XTSQXX = DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
13435 XTVD(ITVAL) = XTVD(ITVAL)+XTSQ(J)-XTSQXX
13437 * chain mass below minimum - reset sea-q x-value and correct
13438 * diquark-x of the same nucleon
13439 ELSEIF (AMVSQ2.LT.AMCHK2) THEN
13440 XTSQW = AMCHK2/(XPVD(IPVAL)*ECM**2)
13441 DXTSQ = XTSQW-XTSQ(J)
13442 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
13443 XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
13447 *>>>end of chain mass correction
13456 * (7) get sea-sea chains
13457 *-----------------------------------------------------------------------
13464 IPVAL = ITOVP(INTER1(I))
13465 ITVAL = ITOVT(INTER2(I))
13466 * loop over target partons not yet matched
13468 IF (ZUOST(J).AND.(IFROST(J).EQ.INTER2(I))) THEN
13469 * loop over projectile partons not yet matched
13471 IF (ZUOSP(JJ).AND.(IFROSP(JJ).EQ.INTER1(I))) THEN
13472 ZUOSP(JJ) = .FALSE.
13480 *---->chain recombination option
13481 VALFRA = DBLE(NVV/(NVV+IXPS+IXTS))
13482 IF (IRECOM.EQ.1.AND.(DT_RNDM(BSQMA).GT.VALFRA))
13484 * sea-sea chains may recombine with valence-valence chains
13485 * only if they have the same projectile or target nucleon
13487 IF (ISKPCH(8,IVV).NE.99) THEN
13488 IXVPR = INTVV1(IVV)
13489 IXVTA = INTVV2(IVV)
13490 IF ((INTER1(I).EQ.IFROVP(IXVPR)).OR.
13491 & (INTER2(I).EQ.IFROVT(IXVTA))) THEN
13492 * recombination possible, drop old v-v and s-s chains
13496 * (a) assign new s-v chains
13497 * ~~~~~~~~~~~~~~~~~~~~~~~~~
13499 & (DT_RNDM(VALFRA).GT.FRCDIQ))
13501 * sample sea-diquark pair
13502 CALL DT_SAMSDQ(ECM,IXVTA,JJ,2,
13504 IF (IREJ1.EQ.0) GOTO 4202
13509 INTSV2(NSV) = IXVTA
13510 *>>>>>>>>>>>correct chain kinematics according to minimum chain masses
13511 * the actual chain masses
13512 AMSVQ1 = XPSQ(JJ) *XTVD(IXVTA)
13514 AMSVQ2 = XPSAQ(JJ)*XTVQ(IXVTA)
13516 * get lower mass cuts
13517 IF (IPSQ(JJ).EQ.3) THEN
13522 * q being u/d-quark
13527 * chain mass above minimum - resampling of sea-q x-value
13528 IF (AMSVQ1.GT.AMCHK1) THEN
13530 & AMCHK1/(XTVD(IXVTA)*ECM**2)
13531 **sr 8.4.98 (1/sqrt(x))
13533 & DT_SAMPLW(XPSQTH,XPSQ(JJ),PLW)
13534 C & DT_SAMSQX(XPSQTH,XPSQ(JJ))
13535 C & DT_SAMPEX(XPSQTH,XPSQ(JJ))
13538 & XPVD(IPVAL)+XPSQ(JJ)-XPSQXX
13540 * chain mass below minimum - reset sea-q x-value and correct
13541 * diquark-x of the same nucleon
13542 ELSEIF (AMSVQ1.LT.AMCHK1) THEN
13544 & AMCHK1/(XTVD(IXVTA)*ECM**2)
13545 DXPSQ = XPSQW-XPSQ(JJ)
13546 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
13549 & XPVD(IPVAL)-DXPSQ
13554 * chain mass below minimum - reset sea-aq x-value and correct
13555 * diquark-x of the same nucleon
13556 IF (AMSVQ2.LT.AMCHK2) THEN
13558 & AMCHK2/(XTVQ(IXVTA)*ECM**2)
13559 DXPSQ = XPSQW-XPSAQ(JJ)
13560 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
13563 & XPVD(IPVAL)-DXPSQ
13567 *>>>>>>>>>>>end of chain mass correction
13570 * (b) assign new v-s chains
13571 * ~~~~~~~~~~~~~~~~~~~~~~~~~
13573 & DT_RNDM(AMSVQ2).GT.FRCDIQ))
13575 * sample sea-diquark pair
13576 CALL DT_SAMSDQ(ECM,IXVPR,J,1,
13578 IF (IREJ1.EQ.0) GOTO 4203
13582 INTVS1(NVS) = IXVPR
13584 *>>>>>>>>>>>correct chain kinematics according to minimum chain masses
13585 * the actual chain masses
13586 AMVSQ1 = XPVQ(IXVPR)*XTSAQ(J)*ECM**2
13587 AMVSQ2 = XPVD(IXVPR)*XTSQ(J) *ECM**2
13588 * get lower mass cuts
13589 IF (ITSQ(J).EQ.3) THEN
13594 * q being u/d-quark
13599 * chain mass below minimum - reset sea-aq x-value and correct
13600 * diquark-x of the same nucleon
13601 IF (AMVSQ1.LT.AMCHK1) THEN
13603 & AMCHK1/(XPVQ(IXVPR)*ECM**2)
13604 DXTSQ = XTSQW-XTSAQ(J)
13605 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13608 & XTVD(ITVAL)-DXTSQ
13612 IF (AMVSQ2.GT.AMCHK2) THEN
13614 & AMCHK2/(XPVD(IXVPR)*ECM**2)
13615 **sr 8.4.98 (1/sqrt(x))
13617 & DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
13618 C & DT_SAMSQX(XTSQTH,XTSQ(J))
13619 C & DT_SAMPEX(XTSQTH,XTSQ(J))
13622 & XTVD(ITVAL)+XTSQ(J)-XTSQXX
13624 ELSEIF (AMVSQ2.LT.AMCHK2) THEN
13626 & AMCHK2/(XPVD(IXVPR)*ECM**2)
13627 DXTSQ = XTSQW-XTSQ(J)
13628 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13631 & XTVD(ITVAL)-DXTSQ
13635 *>>>>>>>>>end of chain mass correction
13637 * jump out of s-s chain loop
13643 *---->end of chain recombination option
13645 * sample sea-diquark pair (projectile)
13646 IF (LSEADI.AND.(DT_RNDM(BSQMA).GT.FRCDIQ)) THEN
13647 CALL DT_SAMSDQ(ECM,J,JJ,4,IREJ1)
13648 IF (IREJ1.EQ.0) THEN
13653 * sample sea-diquark pair (target)
13654 IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
13655 CALL DT_SAMSDQ(ECM,JJ,J,3,IREJ1)
13656 IF (IREJ1.EQ.0) THEN
13661 *>>>>>correct chain kinematics according to minimum chain masses
13662 * the actual chain masses
13663 SSMA1Q = XPSQ(JJ) *XTSAQ(J)*ECM**2
13664 SSMA2Q = XPSAQ(JJ)*XTSQ(J) *ECM**2
13665 * check for lower mass cuts
13666 IF ((SSMA1Q.LT.SSMIMQ).OR.
13667 & (SSMA2Q.LT.SSMIMQ)) THEN
13668 IPVAL = ITOVP(INTER1(I))
13669 ITVAL = ITOVT(INTER2(I))
13670 IF ((XPVD(IPVAL).GT.XDTHR+3.5D0*XSSTHR).AND.
13671 & (XTVD(ITVAL).GT.XDTHR+3.5D0*XSSTHR))THEN
13672 * maximum allowed x values for sea quarks
13673 XSPMAX = ONE-XPVQ(IPVAL)-XDTHR-
13675 XSTMAX = ONE-XTVQ(ITVAL)-XDTHR-
13677 * resampling of x values not possible - skip sea-sea chains
13678 IF ((XSPMAX.LE.XSSTHR+0.05D0).OR.
13679 & (XSTMAX.LE.XSSTHR+0.05D0)) GOTO 380
13680 * resampling of x for projectile sea quark pair
13684 IF (XSSTHR.GT.0.05D0) THEN
13685 XPSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13687 XPSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13691 XPSQI = DT_DBETAR(XSEACU,UNOSEA)
13692 IF ((XPSQI.LT.XSSTHR).OR.
13693 & (XPSQI.GT.XSPMAX)) GOTO 320
13695 XPSAQI = DT_DBETAR(XSEACU,UNOSEA)
13696 IF ((XPSAQI.LT.XSSTHR).OR.
13697 & (XPSAQI.GT.XSPMAX)) GOTO 330
13699 * final test of remaining x for projectile diquark
13700 XPVDCO = XPVD(IPVAL)-XPSQI-XPSAQI
13701 & +XPSQ(JJ)+XPSAQ(JJ)
13702 IF (XPVDCO.LE.XDTHR) THEN
13704 C IF (ICOUS.LT.5) GOTO 310
13705 IF (ICOUS.LT.0.5D0) GOTO 310
13708 * resampling of x for target sea quark pair
13712 IF (XSSTHR.GT.0.05D0) THEN
13713 XTSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13715 XTSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13719 XTSQI = DT_DBETAR(XSEACU,UNOSEA)
13720 IF ((XTSQI.LT.XSSTHR).OR.
13721 & (XTSQI.GT.XSTMAX)) GOTO 360
13723 XTSAQI = DT_DBETAR(XSEACU,UNOSEA)
13724 IF ((XTSAQI.LT.XSSTHR).OR.
13725 & (XTSAQI.GT.XSTMAX)) GOTO 370
13727 * final test of remaining x for target diquark
13728 XTVDCO = XTVD(ITVAL)-XTSQI-XTSAQI
13729 & +XTSQ(J)+XTSAQ(J)
13730 IF (XTVDCO.LT.XDTHR) THEN
13731 IF (ICOUS.LT.5) GOTO 350
13734 XPVD(IPVAL) = XPVDCO
13735 XTVD(ITVAL) = XTVDCO
13740 *>>>>>end of chain mass correction
13743 * come here to discard s-s interaction
13744 * resampling of x values not allowed or unsuccessful
13751 * consider next s-s interaction
13761 * correct x-values of valence quarks for non-matching sea quarks
13764 IPVAL = ITOVP(IFROSP(I))
13765 XPVQ(IPVAL) = XPVQ(IPVAL)+XPSQ(I)+XPSAQ(I)
13773 ITVAL = ITOVT(IFROST(I))
13774 XTVQ(ITVAL) = XTVQ(ITVAL)+XTSQ(I)+XTSAQ(I)
13781 IF (ZUOVP(I)) ISTHKK(IFROVP(I)) = 13
13784 IF (ZUOVT(I)) ISTHKK(IFROVT(I)+IP) = 14
13790 *$ CREATE DT_SAMSDQ.FOR
13793 *===samsdq=============================================================*
13795 SUBROUTINE DT_SAMSDQ(ECM,IDX1,IDX2,MODE,IREJ)
13797 ************************************************************************
13798 * SAMpling of Sea-DiQuarks *
13799 * ECM cm-energy of the nucleon-nucleon system *
13800 * IDX1,2 indices of x-values of the participating *
13801 * partons (IDX2 is always the sea-q-pair to be *
13802 * changed to sea-qq-pair) *
13803 * MODE = 1 valence-q - sea-diq *
13804 * = 2 sea-diq - valence-q *
13805 * = 3 sea-q - sea-diq *
13806 * = 4 sea-diq - sea-q *
13807 * Based on DIQVS, DIQSV, DIQSSD, DIQDSS. *
13808 * This version dated 17.10.95 is written by S. Roesler *
13809 ************************************************************************
13811 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13814 PARAMETER (ZERO=0.0D0)
13816 * threshold values for x-sampling (DTUNUC 1.x)
13817 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
13820 * various options for treatment of partons (DTUNUC 1.x)
13821 * (chain recombination, Cronin,..)
13822 LOGICAL LCO2CR,LINTPT
13823 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
13826 PARAMETER ( MAXNCL = 260,
13829 & MAXSQU = 20*MAXVQU,
13830 & MAXINT = MAXVQU+MAXSQU)
13832 * x-values of partons (DTUNUC 1.x)
13833 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
13834 & XTVQ(MAXVQU),XTVD(MAXVQU),
13835 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
13836 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
13838 * flavors of partons (DTUNUC 1.x)
13839 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
13840 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
13841 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
13842 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
13843 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
13844 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
13845 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
13847 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13848 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
13849 & IXPV,IXPS,IXTV,IXTS,
13850 & INTVV1(MAXVQU),INTVV2(MAXVQU),
13851 & INTSV1(MAXVQU),INTSV2(MAXVQU),
13852 & INTVS1(MAXVQU),INTVS2(MAXVQU),
13853 & INTSS1(MAXSQU),INTSS2(MAXSQU),
13854 & INTDV1(MAXVQU),INTDV2(MAXVQU),
13855 & INTVD1(MAXVQU),INTVD2(MAXVQU),
13856 & INTDS1(MAXSQU),INTDS2(MAXSQU),
13857 & INTSD1(MAXSQU),INTSD2(MAXSQU)
13859 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13860 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
13861 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
13863 * auxiliary common for chain system storage (DTUNUC 1.x)
13864 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
13867 * threshold-x for valence diquarks
13870 GOTO (1,2,3,4) MODE
13872 *---------------------------------------------------------------------
13873 * proj. valence partons - targ. sea partons
13874 * get x-values and flavors for target sea-diquark pair
13880 * index of corr. val-diquark-x in target nucleon
13881 IDXVT = ITOVT(IFROST(IDXST))
13882 * available x above diquark thresholds for valence- and sea-diquarks
13883 XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13885 IF (XXD.GE.ZERO) THEN
13886 * x-values for the three diquarks of the target nucleon
13890 SR123 = RR1+RR2+RR3
13891 XXTV = XDTHR+RR1*XXD/SR123
13892 XXTSQ = XDTHR+RR2*XXD/SR123
13893 XXTSAQ = XDTHR+RR3*XXD/SR123
13896 XXTSQ = XTSQ(IDXST)
13897 XXTSAQ = XTSAQ(IDXST)
13899 * flavor of the second quarks in the sea-diquark pair
13900 ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13901 ITSAQ2(IDXST) = -ITSQ2(IDXST)
13902 * check masses of the new val-q - sea-qq, val-qq - sea-aqaq chains
13903 AM1 = XXTSQ *XPVQ(IDXVP)*ECM**2
13904 AM2 = XXTSAQ*XPVD(IDXVP)*ECM**2
13905 IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13907 & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN
13910 ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13911 * at least one strange quark
13912 & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN
13915 ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13919 * accept the new sea-diquark
13921 XTSQ(IDXST) = XXTSQ
13922 XTSAQ(IDXST) = XXTSAQ
13924 INTVD1(NVD) = IDXVP
13925 INTVD2(NVD) = IDXST
13929 *---------------------------------------------------------------------
13930 * proj. sea partons - targ. valence partons
13931 * get x-values and flavors for projectile sea-diquark pair
13937 * index of corr. val-diquark-x in projectile nucleon
13938 IDXVP = ITOVP(IFROSP(IDXSP))
13939 * available x above diquark thresholds for valence- and sea-diquarks
13940 XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13942 IF (XXD.GE.ZERO) THEN
13943 * x-values for the three diquarks of the projectile nucleon
13947 SR123 = RR1+RR2+RR3
13948 XXPV = XDTHR+RR1*XXD/SR123
13949 XXPSQ = XDTHR+RR2*XXD/SR123
13950 XXPSAQ = XDTHR+RR3*XXD/SR123
13953 XXPSQ = XPSQ(IDXSP)
13954 XXPSAQ = XPSAQ(IDXSP)
13956 * flavor of the second quarks in the sea-diquark pair
13957 IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13958 IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13959 * check masses of the new sea-qq - val-q, sea-aqaq - val-qq chains
13960 AM1 = XXPSQ *XTVQ(IDXVT)*ECM**2
13961 AM2 = XXPSAQ*XTVD(IDXVT)*ECM**2
13962 IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13964 & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN
13967 ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13968 * at least one strange quark
13969 & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN
13972 ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13976 * accept the new sea-diquark
13978 XPSQ(IDXSP) = XXPSQ
13979 XPSAQ(IDXSP) = XXPSAQ
13981 INTDV1(NDV) = IDXSP
13982 INTDV2(NDV) = IDXVT
13986 *---------------------------------------------------------------------
13987 * proj. sea partons - targ. sea partons
13988 * get x-values and flavors for target sea-diquark pair
13994 * index of corr. val-diquark-x in target nucleon
13995 IDXVT = ITOVT(IFROST(IDXST))
13996 * available x above diquark thresholds for valence- and sea-diquarks
13997 XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13999 IF (XXD.GE.ZERO) THEN
14000 * x-values for the three diquarks of the target nucleon
14004 SR123 = RR1+RR2+RR3
14005 XXTV = XDTHR+RR1*XXD/SR123
14006 XXTSQ = XDTHR+RR2*XXD/SR123
14007 XXTSAQ = XDTHR+RR3*XXD/SR123
14010 XXTSQ = XTSQ(IDXST)
14011 XXTSAQ = XTSAQ(IDXST)
14013 * flavor of the second quarks in the sea-diquark pair
14014 ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
14015 ITSAQ2(IDXST) = -ITSQ2(IDXST)
14016 * check masses of the new sea-q - sea-qq, sea-aq - sea-aqaq chains
14017 AM1 = XXTSQ *XPSQ(IDXSP)*ECM**2
14018 AM2 = XXTSAQ*XPSAQ(IDXSP)*ECM**2
14019 IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
14021 & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN
14024 ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
14025 * at least one strange quark
14026 & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN
14029 ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
14033 * accept the new sea-diquark
14035 XTSQ(IDXST) = XXTSQ
14036 XTSAQ(IDXST) = XXTSAQ
14038 INTSD1(NSD) = IDXSP
14039 INTSD2(NSD) = IDXST
14043 *---------------------------------------------------------------------
14044 * proj. sea partons - targ. sea partons
14045 * get x-values and flavors for projectile sea-diquark pair
14051 * index of corr. val-diquark-x in projectile nucleon
14052 IDXVP = ITOVP(IFROSP(IDXSP))
14053 * available x above diquark thresholds for valence- and sea-diquarks
14054 XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
14056 IF (XXD.GE.ZERO) THEN
14057 * x-values for the three diquarks of the projectile nucleon
14061 SR123 = RR1+RR2+RR3
14062 XXPV = XDTHR+RR1*XXD/SR123
14063 XXPSQ = XDTHR+RR2*XXD/SR123
14064 XXPSAQ = XDTHR+RR3*XXD/SR123
14067 XXPSQ = XPSQ(IDXSP)
14068 XXPSAQ = XPSAQ(IDXSP)
14070 * flavor of the second quarks in the sea-diquark pair
14071 IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
14072 IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
14073 * check masses of the new sea-qq - sea-q, sea-aqaq - sea-qq chains
14074 AM1 = XXPSQ *XTSQ(IDXST)*ECM**2
14075 AM2 = XXPSAQ*XTSAQ(IDXST)*ECM**2
14076 IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
14078 & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN
14081 ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
14082 * at least one strange quark
14083 & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN
14086 ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
14090 * accept the new sea-diquark
14092 XPSQ(IDXSP) = XXPSQ
14093 XPSAQ(IDXSP) = XXPSAQ
14095 INTDS1(NDS) = IDXSP
14096 INTDS2(NDS) = IDXST
14100 *$ CREATE DT_DIFEVT.FOR
14103 *===difevt=============================================================*
14105 SUBROUTINE DT_DIFEVT(IFP1,IFP2,PP,MOP,
14106 & IFT1,IFT2,PT,MOT,JDIFF,NCSY,IREJ)
14108 ************************************************************************
14109 * Interface to treatment of diffractive interactions. *
14110 * (input) IFP1/2 PDG-indizes of projectile partons *
14111 * (baryon: IFP2 - adiquark) *
14112 * PP(4) projectile 4-momentum *
14113 * IFT1/2 PDG-indizes of target partons *
14114 * (baryon: IFT1 - adiquark) *
14115 * PT(4) target 4-momentum *
14116 * (output) JDIFF = 0 no diffraction *
14117 * = 1/-1 LMSD/LMDD *
14118 * = 2/-2 HMSD/HMDD *
14119 * NCSY counter for two-chain systems *
14120 * dumped to DTEVT1 *
14121 * This version dated 14.02.95 is written by S. Roesler *
14122 ************************************************************************
14124 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14127 PARAMETER ( LINP = 10 ,
14131 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5,
14136 PARAMETER (NMXHKK=200000)
14138 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14139 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14140 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14142 * extended event history
14143 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14144 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14147 * flags for diffractive interactions (DTUNUC 1.x)
14148 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
14150 DIMENSION PP(4),PT(4)
14153 DATA LFIRST /.TRUE./
14160 XM = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
14161 & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
14162 * identities of projectile hadron / target nucleon
14163 KPROJ = IDT_ICIHAD(IDHKK(MOP))
14164 KTARG = IDT_ICIHAD(IDHKK(MOT))
14166 * single diffractive xsections
14167 CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM)
14168 * double diffractive xsections
14169 **!! no double diff yet
14170 C CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM,DDTOT,DDHM)
14174 * total inelastic xsection
14175 C SIGIN = DT_SHNTOT(KPROJ,KTARG,XM,ZERO)-DT_SHNELA(KPROJ,KTARG,XM)
14177 CALL DT_XSHN(KPROJ,KTARG,DUMZER,XM,SIGTO,SIGEL)
14178 SIGIN = MAX(SIGTO-SIGEL,ZERO)
14180 * fraction of diffractive processes
14181 FRADIF = (SDTOT+DDTOT)/SIGIN
14184 WRITE(LOUT,1000) XM,SDTOT,SIGIN
14185 1000 FORMAT(1X,'DIFEVT: single diffraction requested at E_cm = ',
14186 & F5.1,' GeV',/,9X,'sigma_sd = ',F4.1,' mb, sigma_in = ',
14191 IF ((DT_RNDM(DDHM).LE.FRADIF).OR.
14192 & (ISINGD.GT.1).OR.(IDOUBD.GT.1)) THEN
14193 * diffractive interaction requested by x-section or by user
14194 FRASD = SDTOT/(SDTOT+DDTOT)
14195 FRASDH = SDHM/SDTOT
14196 **sr needs to be specified!!
14197 C FRADDH = DDHM/DDTOT
14200 IF ((DT_RNDM(FRASD).LE.FRASD).OR.(ISINGD.GT.1)) THEN
14201 * single diffraction
14203 IF (DT_RNDM(DDTOT).LE.FRASDH) THEN
14206 IF (((ISINGD.EQ.4).OR.(DT_RNDM(DDTOT).GE.OHALF)).AND.
14207 & ISINGD.NE.3) THEN
14214 IF (((ISINGD.EQ.4).OR.(DT_RNDM(FRADDH).GE.OHALF)).AND.
14215 & ISINGD.NE.3) THEN
14221 * double diffraction
14223 IF (DT_RNDM(FRADDH).LE.FRADDH) THEN
14231 CALL DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
14232 & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
14233 IF (IREJ1.EQ.0) THEN
14235 IF ((KP.EQ.1).OR.(KT.EQ.1)) IFLAGD = KDIFF
14249 *$ CREATE DT_DIFFKI.FOR
14252 *===difkin=============================================================*
14254 SUBROUTINE DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
14255 & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ)
14257 ************************************************************************
14258 * Kinematics of diffractive nucleon-nucleon interaction. *
14259 * IFP1/2 PDG-indizes of projectile partons *
14260 * (baryon: IFP2 - adiquark) *
14261 * PP(4) projectile 4-momentum *
14262 * IFT1/2 PDG-indizes of target partons *
14263 * (baryon: IFT1 - adiquark) *
14264 * PT(4) target 4-momentum *
14265 * KP = 0 projectile quasi-elastically scattered *
14266 * = 1 excited to low-mass diff. state *
14267 * = 2 excited to high-mass diff. state *
14268 * KT = 0 target quasi-elastically scattered *
14269 * = 1 excited to low-mass diff. state *
14270 * = 2 excited to high-mass diff. state *
14271 * This version dated 12.02.95 is written by S. Roesler *
14272 ************************************************************************
14274 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14277 PARAMETER ( LINP = 10 ,
14281 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5)
14285 * particle properties (BAMJET index convention)
14287 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
14288 & IICH(210),IIBAR(210),K1(210),K2(210)
14290 * flags for input different options
14291 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14292 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14293 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14295 * rejection counter
14296 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
14297 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
14298 & IREXCI(3),IRDIFF(2),IRINC
14300 * kinematics of diffractive interactions (DTUNUC 1.x)
14301 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14303 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14304 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14306 DIMENSION PITOT(4),BGTOT(4),PP1(4),PT1(4),PPBLOB(4),PTBLOB(4),
14307 & PP(4),PT(4),PPOM1(4),DEV1(4),DEV2(4)
14309 DATA LSTART /.TRUE./
14313 2000 FORMAT(/,1X,'DIFEVT: diffractive interactions treated ')
14319 * initialize common /DTDIKI/
14321 * store momenta of initial incoming particles for emc-check
14323 CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM,IDUM)
14324 CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM,IDUM)
14327 * masses of initial particles
14328 XMP2 = PP(4)**2-PP(1)**2-PP(2)**2-PP(3)**2
14329 XMT2 = PT(4)**2-PT(1)**2-PT(2)**2-PT(3)**2
14330 IF ((XMP2.LT.ZERO).OR.(XMT2.LT.ZERO)) GOTO 9999
14333 * check quark-input (used to adjust coherence cond. for M-selection)
14335 IF ((ABS(IFP1).GE.1000).OR.(ABS(IFP2).GE.1000)) IBP = 1
14337 IF ((ABS(IFT1).GE.1000).OR.(ABS(IFT2).GE.1000)) IBT = 1
14339 * parameter for Lorentz-transformation into nucleon-nucleon cms
14341 PITOT(K) = PP(K)+PT(K)
14343 XMTOT2 = PITOT(4)**2-PITOT(1)**2-PITOT(2)**2-PITOT(3)**2
14344 IF (XMTOT2.LE.ZERO) THEN
14345 WRITE(LOUT,1000) XMTOT2
14346 1000 FORMAT(1X,'DIFEVT: negative cm. energy! ',
14347 & 'XMTOT2 = ',E12.3)
14350 XMTOT = SQRT(XMTOT2)
14352 BGTOT(K) = PITOT(K)/XMTOT
14354 * transformation of nucleons into cms
14355 CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PP(1),PP(2),
14356 & PP(3),PP(4),PPTOT,PP1(1),PP1(2),PP1(3),PP1(4))
14357 CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PT(1),PT(2),
14358 & PT(3),PT(4),PTTOT,PT1(1),PT1(2),PT1(3),PT1(4))
14361 C SID = SQRT((ONE-COD)*(ONE+COD))
14362 PPT = SQRT(PP1(1)**2+PP1(2)**2)
14366 IF(PPTOT*SID.GT.TINY10) THEN
14367 COF = PP1(1)/(SID*PPTOT)
14368 SIF = PP1(2)/(SID*PPTOT)
14369 ANORF = SQRT(COF*COF+SIF*SIF)
14373 * check consistency
14375 DEV1(K) = ABS(PP1(K)+PT1(K))
14377 DEV1(4) = ABS(DEV1(4)-XMTOT)
14378 IF ((DEV1(1).GT.TINY10).OR.(DEV1(2).GT.TINY10).OR.
14379 & (DEV1(3).GT.TINY10).OR.(DEV1(4).GT.TINY10)) THEN
14380 WRITE(LOUT,1001) DEV1
14381 1001 FORMAT(1X,'DIFEVT: inconsitent Lorentz-transformation! ',
14386 * select x-fractions in high-mass diff. interactions
14387 IF ((KP.EQ.2).OR.(KT.EQ.2)) CALL DT_XVALHM(KP,KT)
14389 * select diffractive masses
14392 XMPF = DT_XMLMD(XMTOT)
14393 CALL DT_LM2RES(IFP1,IFP2,XMPF,IDPR,IDXPR,IREJ1)
14394 IF (IREJ1.GT.0) GOTO 9999
14395 ELSEIF (KP.EQ.2) THEN
14396 XMPF = DT_XMHMD(XMTOT,IBP,1)
14402 XMTF = DT_XMLMD(XMTOT)
14403 CALL DT_LM2RES(IFT1,IFT2,XMTF,IDTR,IDXTR,IREJ1)
14404 IF (IREJ1.GT.0) GOTO 9999
14405 ELSEIF (KT.EQ.2) THEN
14406 XMTF = DT_XMHMD(XMTOT,IBT,2)
14411 * kinematical treatment of "two-particle" system (masses - XMPF,XMTF)
14414 PPBLOB(3) = DT_YLAMB(XMTOT2,XMPF2,XMTF2)/(2.D0*XMTOT)
14415 PPBLOB(4) = SQRT(XMPF2+PPBLOB(3)**2)
14417 * select momentum transfer (all t-values used here are <0)
14418 * minimum absolute value to produce diffractive masses
14419 TMIN = XMP2+XMPF2-2.0D0*(PP1(4)*PPBLOB(4)-PPTOT*PPBLOB(3))
14420 TT = DT_TDIFF(XMTOT,TMIN,XMPF,KP,XMTF,KT,IREJ1)
14421 IF (IREJ1.GT.0) GOTO 9999
14423 * longitudinal momentum of excited/elastically scattered projectile
14424 PPBLOB(3) = (TT-XMP2-XMPF2+2.0D0*PP1(4)*PPBLOB(4))/(2.0D0*PPTOT)
14425 * total transverse momentum due to t-selection
14426 PPBLT2 = PPBLOB(4)**2-PPBLOB(3)**2-XMPF2
14427 IF (PPBLT2.LT.ZERO) THEN
14428 WRITE(LOUT,1002) PPBLT2,KP,PP1,XMPF,KT,PT1,XMTF,TT
14429 1002 FORMAT(1X,'DIFEVT: inconsistent transverse momentum! ',
14430 & E12.3,2(/,1X,I2,5E12.3),/,1X,E12.3)
14433 CALL DT_DSFECF(SINPHI,COSPHI)
14434 PPBLT = SQRT(PPBLT2)
14435 PPBLOB(1) = COSPHI*PPBLT
14436 PPBLOB(2) = SINPHI*PPBLT
14438 * rotate excited/elastically scattered projectile into n-n cms.
14439 CALL DT_MYTRAN(1,PPBLOB(1),PPBLOB(2),PPBLOB(3),COD,SID,COF,SIF,
14445 * 4-momentum of excited/elastically scattered target and of exchanged
14448 IF (K.LT.4) PTBLOB(K) = -PPBLOB(K)
14449 PPOM1(K) = PP1(K)-PPBLOB(K)
14451 PTBLOB(4) = XMTOT-PPBLOB(4)
14453 * Lorentz-transformation back into system of initial diff. collision
14454 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
14455 & PPBLOB(1),PPBLOB(2),PPBLOB(3),PPBLOB(4),
14456 & PPTOTF,PPF(1),PPF(2),PPF(3),PPF(4))
14457 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
14458 & PTBLOB(1),PTBLOB(2),PTBLOB(3),PTBLOB(4),
14459 & PTTOTF,PTF(1),PTF(2),PTF(3),PTF(4))
14460 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
14461 & PPOM1(1),PPOM1(2),PPOM1(3),PPOM1(4),
14462 & PPOMTO,PPOM(1),PPOM(2),PPOM(3),PPOM(4))
14464 * store 4-momentum of elastically scattered particle (in single diff.
14470 ELSEIF (KT.EQ.0) THEN
14476 * check consistency of kinematical treatment so far
14478 CALL DT_EVTEMC(-PPF(1),-PPF(2),-PPF(3),-PPF(4),2,IDUM,IDUM)
14479 CALL DT_EVTEMC(-PTF(1),-PTF(2),-PTF(3),-PTF(4),2,IDUM,IDUM)
14480 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,60,IREJ1)
14481 IF (IREJ1.NE.0) GOTO 9999
14484 DEV1(K) = ABS(PP(K)-PPF(K)-PPOM(K))
14485 DEV2(K) = ABS(PT(K)-PTF(K)+PPOM(K))
14487 IF ((DEV1(1).GT.TINY5).OR.(DEV1(2).GT.TINY5).OR.
14488 & (DEV1(3).GT.TINY5).OR.(DEV1(4).GT.TINY5).OR.
14489 & (DEV2(1).GT.TINY5).OR.(DEV2(2).GT.TINY5).OR.
14490 & (DEV2(3).GT.TINY5).OR.(DEV2(4).GT.TINY5)) THEN
14491 WRITE(LOUT,1003) DEV1,DEV2
14492 1003 FORMAT(1X,'DIFEVT: inconsitent kinematical treatment! ',
14497 * kinematical treatment for low-mass diffraction
14498 CALL DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ1)
14499 IF (IREJ1.NE.0) GOTO 9999
14501 * dump diffractive chains into DTEVT1
14502 CALL DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
14503 IF (IREJ1.NE.0) GOTO 9999
14508 IRDIFF(1) = IRDIFF(1)+1
14513 *$ CREATE DT_XMHMD.FOR
14516 *===xmhmd==============================================================*
14518 DOUBLE PRECISION FUNCTION DT_XMHMD(ECM,IB,MODE)
14520 ************************************************************************
14521 * Diffractive mass in high mass single/double diffractive events. *
14522 * This version dated 11.02.95 is written by S. Roesler *
14523 ************************************************************************
14525 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14528 PARAMETER ( LINP = 10 ,
14532 PARAMETER (OHALF=0.5D0,ONE=1.0D0,ZERO=0.0D0)
14534 * kinematics of diffractive interactions (DTUNUC 1.x)
14535 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14537 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14538 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14540 C DATA XCOLOW /0.05D0/
14541 DATA XCOLOW /0.15D0/
14545 IF (MODE.EQ.2) XH = XTH(2)
14547 * minimum Pomeron-x for high-mass diffraction
14548 * (adjusted to get a smooth transition between HM and LM component)
14550 XDIMIN = (3.0D0+400.0D0*R**2)/(XH*ECM**2)
14551 IF (ECM.LE.300.0D0) THEN
14552 RR = (1.0D0-EXP(-((ECM/140.0D0)**4)))
14553 XDIMIN = (3.0D0+400.0D0*(R**2)*RR)/(XH*ECM**2)
14555 * maximum Pomeron-x for high-mass diffraction
14556 * (coherence condition, adjusted to fit to experimental data)
14558 * baryon-diffraction
14559 XDIMAX = XCOLOW*(1.0D0+EXP(-((ECM/420.0D0)**2)))
14561 * meson-diffraction
14562 XDIMAX = XCOLOW*(1.0D0+4.0D0*EXP(-((ECM/420.0D0)**2)))
14565 IF (XDIMIN.GE.XDIMAX) THEN
14566 XDIMIN = OHALF*XDIMAX
14572 IF (KLOOP.GT.20) RETURN
14573 * sample Pomeron-x from 1/x-distribution (critical Pomeron)
14574 XDIFF = DT_SAMPEX(XDIMIN,XDIMAX)
14575 * corr. diffr. mass
14576 DT_XMHMD = ECM*SQRT(XDIFF)
14577 IF (DT_XMHMD.LT.2.5D0) GOTO 1
14582 *$ CREATE DT_XMLMD.FOR
14585 *===xmlmd==============================================================*
14587 DOUBLE PRECISION FUNCTION DT_XMLMD(ECM)
14589 ************************************************************************
14590 * Diffractive mass in high mass single/double diffractive events. *
14591 * This version dated 11.02.95 is written by S. Roesler *
14592 ************************************************************************
14594 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14597 PARAMETER ( LINP = 10 ,
14601 * minimum Pomeron-x for low-mass diffraction
14604 * maximum Pomeron-x for low-mass diffraction
14605 * (adjusted to get a smooth transition between HM and LM component)
14608 IF (ECM.LE.300.0D0) SAM = 1.0D0-EXP(-((ECM/200.0D0)**4))
14609 R = DT_RNDM(AMO)*SAM
14610 AMAX= (1.0D0-SAM)*SQRT(0.1D0*ECM**2)+SAM*SQRT(400.0D0)
14611 AMU = R*SQRT(100.0D0)+(1.0D0-R)*AMAX
14613 * selection of diffractive mass
14614 * (adjusted to get a smooth transition between HM and LM component)
14616 IF (ECM.LE.50.0D0) THEN
14617 DT_XMLMD = AMO*(AMU/AMO)**R
14620 IF (ECM.LE.300.0D0) A = 0.7D0*(1.0D0-EXP(-((ECM/100.0D0)**2)))
14621 DT_XMLMD = 1.0D0/((R/(AMU**A)+(1.0D0-R)/(AMO**A))**(1.0D0/A))
14627 *$ CREATE DT_TDIFF.FOR
14630 *===tdiff==============================================================*
14632 DOUBLE PRECISION FUNCTION DT_TDIFF(ECM,TMIN,XM1I,K1,XM2I,K2,IREJ)
14634 ************************************************************************
14635 * t-selection for single/double diffractive interactions. *
14637 * TMIN minimum momentum transfer to produce diff. masses *
14638 * XM1/XM2 diffractively produced masses *
14639 * (for single diffraction XM2 is obsolete) *
14640 * K1/K2= 0 not excited *
14641 * = 1 low-mass excitation *
14642 * = 2 high-mass excitation *
14643 * This version dated 11.02.95 is written by S. Roesler *
14644 ************************************************************************
14646 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14649 PARAMETER ( LINP = 10 ,
14653 PARAMETER (ZERO=0.0D0)
14655 PARAMETER ( BTP0 = 3.7D0,
14656 & ALPHAP = 0.24D0 )
14669 IF ((K1.EQ.0).OR.(K2.EQ.0)) THEN
14670 * slope for single diffraction
14671 SLOPE = BTP0-2.0D0*ALPHAP*LOG(XDI)
14673 * slope for double diffraction
14674 SLOPE = -2.0D0*ALPHAP*LOG(XDI*XM2**2)
14679 IF (MOD(NCLOOP,1000).EQ.0) GOTO 9999
14681 T = -LOG(1.0D0-Y)/SLOPE
14682 IF (ABS(T).LE.ABS(TMIN)) GOTO 1
14688 WRITE(LOUT,1000) ECM,TMIN,XM1I,XM2I,K1,K2
14689 1000 FORMAT(1X,'DT_TDIFF: t-selection rejected!',/,
14690 & 1X,'ECM = ',E12.3,' TMIN = ',E12.2,/,1X,'XM1I = ',
14691 & E12.3,' XM2I = ',E12.3,' K1 = ',I2,' K2 = ',I2)
14696 *$ CREATE DT_XVALHM.FOR
14699 *===xvalhm=============================================================*
14701 SUBROUTINE DT_XVALHM(KP,KT)
14703 ************************************************************************
14704 * Sampling of parton x-values in high-mass diffractive interactions. *
14705 * This version dated 12.02.95 is written by S. Roesler *
14706 ************************************************************************
14708 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14711 PARAMETER ( LINP = 10 ,
14715 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0,TINY2=1.0D-2)
14717 * kinematics of diffractive interactions (DTUNUC 1.x)
14718 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14720 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14721 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14723 * various options for treatment of partons (DTUNUC 1.x)
14724 * (chain recombination, Cronin,..)
14725 LOGICAL LCO2CR,LINTPT
14726 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
14729 DATA UNON,XVQTHR /2.0D0,0.8D0/
14732 * x-fractions of projectile valence partons
14734 XPH(1) = DT_DBETAR(OHALF,UNON)
14735 IF (XPH(1).GE.XVQTHR) GOTO 1
14736 XPH(2) = ONE-XPH(1)
14737 * x-fractions of Pomeron q-aq-pair
14740 XPPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14741 XPPO(2) = ONE-XPPO(1)
14742 * flavors of Pomeron q-aq-pair
14743 IFLAV = INT(ONE+DT_RNDM(UNON)*(2.0D0+SEASQ))
14746 IF (DT_RNDM(UNON).GT.OHALF) THEN
14753 * x-fractions of projectile target partons
14755 XTH(1) = DT_DBETAR(OHALF,UNON)
14756 IF (XTH(1).GE.XVQTHR) GOTO 2
14757 XTH(2) = ONE-XTH(1)
14758 * x-fractions of Pomeron q-aq-pair
14761 XTPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14762 XTPO(2) = ONE-XTPO(1)
14763 * flavors of Pomeron q-aq-pair
14764 IFLAV = INT(ONE+DT_RNDM(XPOLO)*(2.0D0+SEASQ))
14767 IF (DT_RNDM(XPOLO).GT.OHALF) THEN
14776 *$ CREATE DT_LM2RES.FOR
14779 *===lm2res=============================================================*
14781 SUBROUTINE DT_LM2RES(IF1,IF2,XM,IDR,IDXR,IREJ)
14783 ************************************************************************
14784 * Check low-mass diffractive excitation for resonance mass. *
14785 * (input) IF1/2 PDG-indizes of valence partons *
14786 * (in/out) XM diffractive mass requested/corrected *
14787 * (output) IDR/IDXR id./BAMJET-index of resonance *
14788 * This version dated 12.02.95 is written by S. Roesler *
14789 ************************************************************************
14791 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14794 PARAMETER ( LINP = 10 ,
14798 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14800 * kinematics of diffractive interactions (DTUNUC 1.x)
14801 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14803 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14804 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14811 * BAMJET indices of partons
14812 IF1A = IDT_IPDG2B(IF1,1,2)
14813 IF (ABS(IF1).GE.1000) IF1B = IDT_IPDG2B(IF1,2,2)
14814 IF2A = IDT_IPDG2B(IF2,1,2)
14815 IF (ABS(IF2).GE.1000) IF2B = IDT_IPDG2B(IF2,2,2)
14817 * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq)
14819 IF ((IF1B.EQ.0).AND.(IF2B.EQ.0)) IDCH = 1
14821 * check for resonance mass
14822 CALL DT_CH2RES(IF1A,IF1B,IF2A,IF2B,IDR,IDXR,XMI,XMN,IDCH,IREJ1)
14823 IF (IREJ1.NE.0) GOTO 9999
14833 *$ CREATE DT_LMKINE.FOR
14836 *===lmkine=============================================================*
14838 SUBROUTINE DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ)
14840 ************************************************************************
14841 * Kinematical treatment of low-mass excitations. *
14842 * This version dated 12.02.95 is written by S. Roesler *
14843 ************************************************************************
14845 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14848 PARAMETER ( LINP = 10 ,
14852 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14854 * flags for input different options
14855 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14856 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14857 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14859 * kinematics of diffractive interactions (DTUNUC 1.x)
14860 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14862 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14863 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14865 DIMENSION P1(4),P2(4)
14870 PABS = SQRT(PPF(1)**2+PPF(2)**2+PPF(3)**2)
14872 FAC1 = OHALF*(POE+ONE)
14873 FAC2 = -OHALF*(POE-ONE)
14875 PPLM1(K) = FAC1*PPF(K)
14876 PPLM2(K) = FAC2*PPF(K)
14878 PPLM1(4) = FAC1*PABS
14879 PPLM2(4) = -FAC2*PABS
14880 IF (IMSHL.EQ.1) THEN
14885 CALL DT_MASHEL(PPLM1,PPLM2,XM1,XM2,P1,P2,IREJ1)
14886 IF (IREJ1.NE.0) GOTO 9999
14895 PABS = SQRT(PTF(1)**2+PTF(2)**2+PTF(3)**2)
14897 FAC1 = OHALF*(POE+ONE)
14898 FAC2 = -OHALF*(POE-ONE)
14900 PTLM2(K) = FAC1*PTF(K)
14901 PTLM1(K) = FAC2*PTF(K)
14903 PTLM2(4) = FAC1*PABS
14904 PTLM1(4) = -FAC2*PABS
14905 IF (IMSHL.EQ.1) THEN
14910 CALL DT_MASHEL(PTLM1,PTLM2,XM1,XM2,P1,P2,IREJ1)
14911 IF (IREJ1.NE.0) GOTO 9999
14922 WRITE(LOUT,'(A)') 'LMKINE: kinematical treatment rejected'
14927 *$ CREATE DT_DIFINI.FOR
14930 *===difini=============================================================*
14932 SUBROUTINE DT_DIFINI
14934 ************************************************************************
14935 * Initialization of common /DTDIKI/ *
14936 * This version dated 12.02.95 is written by S. Roesler *
14937 ************************************************************************
14939 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14942 PARAMETER ( LINP = 10 ,
14946 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14948 * kinematics of diffractive interactions (DTUNUC 1.x)
14949 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14951 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14952 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14980 *$ CREATE DT_DIFPUT.FOR
14983 *===difput=============================================================*
14985 SUBROUTINE DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,
14988 ************************************************************************
14989 * Dump diffractive chains into DTEVT1 *
14990 * This version dated 12.02.95 is written by S. Roesler *
14991 ************************************************************************
14993 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14996 PARAMETER ( LINP = 10 ,
15000 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
15004 * kinematics of diffractive interactions (DTUNUC 1.x)
15005 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
15007 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
15008 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
15012 PARAMETER (NMXHKK=200000)
15014 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15015 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15016 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15018 * extended event history
15019 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15020 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15023 * rejection counter
15024 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
15025 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
15026 & IREXCI(3),IRDIFF(2),IRINC
15028 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PCH(4),PP(4),PT(4),
15029 & P1(4),P2(4),P3(4),P4(4)
15035 PCH(K) = PPLM1(K)+PPLM2(K)
15039 IF (DT_RNDM(PT).GT.OHALF) THEN
15043 CALL DT_EVTPUT(21,ID1,MOP,0,PPLM1(1),PPLM1(2),PPLM1(3),
15045 CALL DT_EVTPUT(21,ID2,MOP,0,PPLM2(1),PPLM2(2),PPLM2(3),
15047 CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
15049 ELSEIF (KP.EQ.2) THEN
15051 PP1(K) = XPH(1)*PP(K)
15052 PP2(K) = XPH(2)*PP(K)
15053 PT1(K) = -XPPO(1)*PPOM(K)
15054 PT2(K) = -XPPO(2)*PPOM(K)
15056 CALL DT_CHKCSY(IFP1,IFPPO(1),LCHK)
15060 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
15061 IF (IREJ1.NE.0) GOTO 9999
15062 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
15063 IF (IREJ1.NE.0) GOTO 9999
15070 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
15072 CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
15074 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
15076 CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
15079 CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
15080 IF (IREJ1.NE.0) GOTO 9999
15081 CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
15082 IF (IREJ1.NE.0) GOTO 9999
15089 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
15091 CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
15093 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
15095 CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
15100 CALL DT_EVTPUT(1,IDHKK(MOP),MOP,0,PSC(1),PSC(2),PSC(3),PSC(4),
15106 PCH(K) = PTLM1(K)+PTLM2(K)
15110 IF (DT_RNDM(PT).GT.OHALF) THEN
15114 CALL DT_EVTPUT(22,ID1,MOT,0,PTLM1(1),PTLM1(2),PTLM1(3),
15116 CALL DT_EVTPUT(22,ID2,MOT,0,PTLM2(1),PTLM2(2),PTLM2(3),
15118 CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
15120 ELSEIF (KT.EQ.2) THEN
15122 PP1(K) = XTPO(1)*PPOM(K)
15123 PP2(K) = XTPO(2)*PPOM(K)
15124 PT1(K) = XTH(2)*PT(K)
15125 PT2(K) = XTH(1)*PT(K)
15127 CALL DT_CHKCSY(IFTPO(1),IFT1,LCHK)
15131 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
15132 IF (IREJ1.NE.0) GOTO 9999
15133 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
15134 IF (IREJ1.NE.0) GOTO 9999
15141 CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
15143 CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
15145 CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
15147 CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
15150 CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
15151 IF (IREJ1.NE.0) GOTO 9999
15152 CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
15153 IF (IREJ1.NE.0) GOTO 9999
15160 CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
15162 CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
15164 CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
15166 CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
15171 CALL DT_EVTPUT(1,IDHKK(MOT),MOT,0,PSC(1),PSC(2),PSC(3),PSC(4),
15178 IRDIFF(2) = IRDIFF(2)+1
15182 *$ CREATE DT_EVTFRG.FOR
15185 *===evtfrg=============================================================*
15187 SUBROUTINE DT_EVTFRG(KMODE,NFRG,NPYMEM,IREJ)
15189 ************************************************************************
15190 * Hadronization of chains in DTEVT1. *
15193 * KMODE = 1 hadronization of PHOJET-chains (id=77xxx) *
15194 * = 2 hadronization of DTUNUC-chains (id=88xxx) *
15195 * NFRG if KMODE = 1 : upper index of PHOJET-scatterings to be *
15196 * hadronized with one PYEXEC call *
15197 * if KMODE = 2 : max. number of DTUNUC-chains to be hadronized *
15198 * with one PYEXEC call *
15200 * NPYMEM number of entries in JETSET-common after hadronization *
15201 * IREJ rejection flag *
15203 * This version dated 17.09.00 is written by S. Roesler *
15204 ************************************************************************
15206 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15209 PARAMETER ( LINP = 10 ,
15213 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1)
15214 PARAMETER (ONE=1.0D0,ZERO=0.0D0)
15218 PARAMETER (MXJOIN=200)
15222 PARAMETER (NMXHKK=200000)
15224 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15225 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15226 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15228 * extended event history
15229 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15230 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15233 * flags for input different options
15234 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15235 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15236 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15239 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
15240 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
15243 * flags for diffractive interactions (DTUNUC 1.x)
15244 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
15246 * nucleon-nucleon event-generator
15249 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
15252 C model switches and parameters
15254 INTEGER ISWMDL,IPAMDL
15255 DOUBLE PRECISION PARMDL
15256 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15259 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15260 PARAMETER (MAXLND=4000)
15261 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
15265 DIMENSION IJOIN(MXJOIN),ISJOIN(MXJOIN),IHISMO(8000),IFLG(4000)
15269 IF (MODE.NE.1) ISTSTG = 8
15278 IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
15279 DO 10 I=NPOINT(3),NEND
15280 * sr 14.02.00: seems to be not necessary anymore, commented
15281 C LACCEP = ((NOBAM(I).EQ.0).AND.(MODE.EQ.1)).OR.
15282 C & ((NOBAM(I).NE.0).AND.(MODE.EQ.2))
15284 * pick up chains from dtevt1
15285 IDCHK = IDHKK(I)/10000
15286 IF ((IDCHK.EQ.ISTSTG).AND.LACCEP) THEN
15287 IF (IDCHK.EQ.7) THEN
15288 IPJE = IDHKK(I)-IDCHK*10000
15289 IF (IPJE.NE.IFRG) THEN
15291 IF (IFRG.GT.NFRG) GOTO 16
15296 IF (IFRG.GT.NFRG) THEN
15301 * statistics counter
15302 c IF (IDCH(I).LE.8)
15303 c & ICCHAI(2,IDCH(I)) = ICCHAI(2,IDCH(I))+1
15304 c IF (IDRES(I).NE.0) ICRES(IDCH(I)) = ICRES(IDCH(I))+1
15305 * special treatment for small chains already corrected to hadrons
15306 IF (IDRES(I).NE.0) THEN
15307 IF (IDRES(I).EQ.11) THEN
15310 ID = IDT_IPDGHA(IDXRES(I))
15313 CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
15314 & PHKK(4,I),INIEMC,IDUM,IDUM)
15318 IF (IP.GT.MSTU(4)) STOP ' NEWFRA 1: IP.GT.MSTU(4) !'
15319 P(IP,1) = PHKK(1,I)
15320 P(IP,2) = PHKK(2,I)
15321 P(IP,3) = PHKK(3,I)
15322 P(IP,4) = PHKK(4,I)
15323 P(IP,5) = PHKK(5,I)
15329 IHIST(2,I) = 10000*IPJE+IP
15330 IF (IHIST(1,I).LE.-100) THEN
15332 IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
15339 DO 11 KK=JMOHKK(1,I),JMOHKK(2,I)
15341 CALL DT_EVTEMC(PHKK(1,KK),PHKK(2,KK),PHKK(3,KK),
15342 & PHKK(4,KK),INIEMC,IDUM,IDUM)
15343 CALL DT_EVTFLC(IDHKK(KK),1,INIEMC,IDUM,IDUM)
15347 IF (ID.EQ.0) ID = 21
15348 c PTOT = SQRT(PHKK(1,KK)**2+PHKK(2,KK)**2+PHKK(3,KK)**2)
15349 c AM0 = SQRT(ABS((PHKK(4,KK)-PTOT)*(PHKK(4,KK)+PTOT)))
15351 c AMRQ = PYMASS(ID)
15353 c AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
15354 c IF ((ABS(AMDIF2).GT.TINY3).AND.(PTOT.GT.ZERO).AND.
15355 c & (ABS(IDIFF).EQ.0)) THEN
15356 cC WRITE(LOUT,*)'here: ',NEVHKK,AM0,AMRQ
15357 c DELTA = -AMDIF2/(2.0D0*(PHKK(4,KK)+PTOT))
15358 c PHKK(4,KK) = PHKK(4,KK)+DELTA
15359 c PTOT1 = PTOT-DELTA
15360 c PHKK(1,KK) = PHKK(1,KK)*PTOT1/PTOT
15361 c PHKK(2,KK) = PHKK(2,KK)*PTOT1/PTOT
15362 c PHKK(3,KK) = PHKK(3,KK)*PTOT1/PTOT
15363 c PHKK(5,KK) = AMRQ
15366 IF (IP.GT.MSTU(4)) STOP ' NEWFRA 2: IP.GT.MSTU(4) !'
15367 P(IP,1) = PHKK(1,KK)
15368 P(IP,2) = PHKK(2,KK)
15369 P(IP,3) = PHKK(3,KK)
15370 P(IP,4) = PHKK(4,KK)
15371 P(IP,5) = PHKK(5,KK)
15377 IHIST(2,KK) = 10000*IPJE+IP
15378 IF (IHIST(1,KK).LE.-100) THEN
15380 IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
15384 IF (IJ.GT.MXJOIN) STOP 'IJ > MXJOIN !'
15389 * join the two-parton system
15391 CALL PYJOIN(IJ,IJOIN)
15402 * final state parton shower
15404 IF ((MCGENE.EQ.2).AND.(ISH.GE.2)) THEN
15405 IF ((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
15407 IF (ISJOIN(K1).EQ.0) GOTO 130
15409 IF ((IPAMDL(102).EQ.1).AND.(IHIST(1,I).NE.-100))
15411 IH1 = IHIST(2,I)/10000
15412 IF (IH1.NE.NPJE) GOTO 130
15413 IH1 = IHIST(2,I)-IH1*10000
15415 IF (ISJOIN(K2).EQ.0) GOTO 135
15417 IH2 = IHIST(2,II)/10000
15418 IF (IH2.NE.NPJE) GOTO 135
15419 IH2 = IHIST(2,II)-IH2*10000
15420 IF (IHIST(1,I).EQ.IHIST(1,II)) THEN
15421 PT1 = SQRT(PHKK(1,II)**2+PHKK(2,II)**2)
15422 PT2 = SQRT(PHKK(1, I)**2+PHKK(2, I)**2)
15424 RQLUN = MIN(PT1,PT2)
15425 CALL PYSHOW(IH1,IH2,RQLUN)
15437 CALL DT_INITJS(MODE)
15442 IF (MSTU(24).NE.0) THEN
15443 WRITE(LOUT,*) ' JETSET-reject at event',
15444 & NEVHKK,MSTU(24),KMODE
15445 C CALL DT_EVTOUT(4)
15452 * number of entries in LUJETS
15464 IF ((PYK(II,7).EQ.1).AND.(IFLG(II).NE.1)) THEN
15466 * pick up mother resonance if possible and put it together with
15467 * their decay-products into the common
15469 IF ((IDXMOR.GE.1).AND.(IDXMOR.LE.MAXLND)) THEN
15470 KFMOR = K(IDXMOR,2)
15471 ISMOR = K(IDXMOR,1)
15476 IF ((KFMOR.NE.91).AND.(KFMOR.NE.92).AND.
15477 & (KFMOR.NE.94).AND.(ISMOR.EQ.11)) THEN
15479 MO = IHISMO(PYK(IDXMOR,15))
15485 CALL DT_EVTPUT(2,ID,MO,0,PX,PY,PZ,PE,0,0,0)
15488 DO 15 JDAUG=K(IDXMOR,4),K(IDXMOR,5)
15489 IF (PYK(JDAUG,7).EQ.1) THEN
15496 CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
15503 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
15509 * there was no mother resonance
15510 MO = IHISMO(PYK(II,15))
15517 CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
15524 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
15531 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,6,IREJ1)
15532 C IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
15535 * global energy-momentum & flavor conservation check
15536 **sr 16.5. this check is skipped in case of phojet-treatment
15538 & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,12,IREJ3)
15540 * update statistics-counter for diffraction
15541 c IF (IFLAGD.NE.0) THEN
15542 c ICDIFF(1) = ICDIFF(1)+1
15543 c IF (IFLAGD.EQ. 1) ICDIFF(2) = ICDIFF(2)+1
15544 c IF (IFLAGD.EQ. 2) ICDIFF(3) = ICDIFF(3)+1
15545 c IF (IFLAGD.EQ.-1) ICDIFF(4) = ICDIFF(4)+1
15546 c IF (IFLAGD.EQ.-2) ICDIFF(5) = ICDIFF(5)+1
15558 *$ CREATE DT_DECAYS.FOR
15561 *===decay==============================================================*
15563 SUBROUTINE DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
15565 ************************************************************************
15566 * Resonance-decay. *
15567 * This subroutine replaces DDECAY/DECHKK. *
15568 * PIN(4) 4-momentum of resonance (input) *
15569 * IDXIN BAMJET-index of resonance (input) *
15570 * POUT(20,4) 4-momenta of decay-products (output) *
15571 * IDXOUT(20) BAMJET-indices of decay-products (output) *
15572 * NSEC number of secondaries (output) *
15573 * Adopted from the original version DECHKK. *
15574 * This version dated 09.01.95 is written by S. Roesler *
15575 ************************************************************************
15577 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15580 PARAMETER ( LINP = 10 ,
15584 PARAMETER (TINY17=1.0D-17)
15586 * HADRIN: decay channel information
15587 PARAMETER (IDMAX9=602)
15589 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
15591 * particle properties (BAMJET index convention)
15593 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
15594 & IICH(210),IIBAR(210),K1(210),K2(210)
15596 * flags for input different options
15597 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15598 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15599 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15601 DIMENSION PIN(4),PI(20,4),POUT(20,4),IDXOUT(20),
15602 & EF(3),PF(3),PFF(3),IDXSTK(20),IDX(3),
15603 & CODF(3),COFF(3),SIFF(3),DCOS(3),DCOSF(3)
15605 * ISTAB = 1 strong and weak decays
15606 * = 2 strong decays only
15607 * = 3 strong decays, weak decays for charmed particles and tau
15613 * put initial resonance to stack
15615 IDXSTK(NSTK) = IDXIN
15617 PI(NSTK,I) = PIN(I)
15620 * store initial configuration for energy-momentum cons. check
15621 IF (LEMCCK) CALL DT_EVTEMC(PI(NSTK,1),PI(NSTK,2),PI(NSTK,3),
15622 & PI(NSTK,4),1,IDUM,IDUM)
15625 * get particle from stack
15626 IDXI = IDXSTK(NSTK)
15627 * skip stable particles
15628 IF (ISTAB.EQ.1) THEN
15629 IF ((IDXI.EQ.135).OR. (IDXI.EQ.136)) GOTO 10
15630 IF ((IDXI.GE. 1).AND.(IDXI.LE. 7)) GOTO 10
15631 ELSEIF (ISTAB.EQ.2) THEN
15632 IF ((IDXI.GE. 1).AND.(IDXI.LE. 30)) GOTO 10
15633 IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
15634 IF ((IDXI.GE.115).AND.(IDXI.LE.122)) GOTO 10
15635 IF ((IDXI.GE.131).AND.(IDXI.LE.136)) GOTO 10
15636 IF ( IDXI.EQ.109) GOTO 10
15637 IF ((IDXI.GE.137).AND.(IDXI.LE.160)) GOTO 10
15638 ELSEIF (ISTAB.EQ.3) THEN
15639 IF ((IDXI.GE. 1).AND.(IDXI.LE. 23)) GOTO 10
15640 IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
15641 IF ((IDXI.GE.109).AND.(IDXI.LE.115)) GOTO 10
15642 IF ((IDXI.GE.133).AND.(IDXI.LE.136)) GOTO 10
15645 * calculate direction cosines and Lorentz-parameter of decaying part.
15646 PTOT = SQRT(PI(NSTK,1)**2+PI(NSTK,2)**2+PI(NSTK,3)**2)
15647 PTOT = MAX(PTOT,TINY17)
15649 DCOS(I) = PI(NSTK,I)/PTOT
15651 GAM = PI(NSTK,4)/AAM(IDXI)
15652 BGAM = PTOT/AAM(IDXI)
15654 * get decay-channel
15658 IF ((DT_RNDM(GAM)-TINY17).GT.WT(KCHAN)) GOTO 2
15660 * identities of secondaries
15661 IDX(1) = NZK(KCHAN,1)
15662 IDX(2) = NZK(KCHAN,2)
15663 IF (IDX(2).LT.1) GOTO 9999
15664 IDX(3) = NZK(KCHAN,3)
15666 * handle decay in rest system of decaying particle
15667 IF (IDX(3).EQ.0) THEN
15668 * two-particle decay
15670 CALL DT_DTWOPD(AAM(IDXI),EF(1),EF(2),PF(1),PF(2),
15671 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
15672 & AAM(IDX(1)),AAM(IDX(2)))
15674 * three-particle decay
15676 CALL DT_DTHREP(AAM(IDXI),EF(1),EF(2),EF(3),PF(1),PF(2),PF(3),
15677 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
15678 & CODF(3),COFF(3),SIFF(3),
15679 & AAM(IDX(1)),AAM(IDX(2)),AAM(IDX(3)))
15683 * transform decay products back
15686 CALL DT_DTRAFO(GAM,BGAM,DCOS(1),DCOS(2),DCOS(3),
15687 & CODF(I),COFF(I),SIFF(I),PF(I),EF(I),
15688 & PFF(I),DCOSF(1),DCOSF(2),DCOSF(3),PI(NSTK,4))
15689 * add particle to stack
15690 IDXSTK(NSTK) = IDX(I)
15692 PI(NSTK,J) = DCOSF(J)*PFF(I)
15698 * stable particle, put to output-arrays
15701 POUT(NSEC,I) = PI(NSTK,I)
15703 IDXOUT(NSEC) = IDXSTK(NSTK)
15704 * store secondaries for energy-momentum conservation check
15706 &CALL DT_EVTEMC(-POUT(NSEC,1),-POUT(NSEC,2),-POUT(NSEC,3),
15707 & -POUT(NSEC,4),2,IDUM,IDUM)
15709 IF (NSTK.GT.0) GOTO 100
15711 * check energy-momentum conservation
15713 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,5,IREJ1)
15714 IF (IREJ1.NE.0) GOTO 9999
15724 *$ CREATE DT_DECAY1.FOR
15727 *===decay1=============================================================*
15729 SUBROUTINE DT_DECAY1
15731 ************************************************************************
15732 * Decay of resonances stored in DTEVT1. *
15733 * This version dated 20.01.95 is written by S. Roesler *
15734 ************************************************************************
15736 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15739 PARAMETER ( LINP = 10 ,
15745 PARAMETER (NMXHKK=200000)
15747 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15748 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15749 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15751 * extended event history
15752 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15753 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15756 DIMENSION PIN(4),POUT(20,4),IDXOUT(20)
15759 C DO 1 I=NPOINT(5),NEND
15760 DO 1 I=NPOINT(4),NEND
15761 IF (ABS(ISTHKK(I)).EQ.1) THEN
15766 CALL DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
15767 IF (NSEC.GT.1) THEN
15769 IDHAD = IDT_IPDGHA(IDXOUT(N))
15770 CALL DT_EVTPUT(1,IDHAD,I,0,POUT(N,1),POUT(N,2),
15771 & POUT(N,3),POUT(N,4),0,0,0)
15780 *$ CREATE DT_DECPI0.FOR
15783 *===decpi0=============================================================*
15785 SUBROUTINE DT_DECPI0
15787 ************************************************************************
15788 * Decay of pi0 handled with JETSET. *
15789 * This version dated 18.02.96 is written by S. Roesler *
15790 ************************************************************************
15792 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15795 PARAMETER ( LINP = 10 ,
15799 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0,ZERO=0.0D0)
15803 PARAMETER (NMXHKK=200000)
15805 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15806 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15807 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15809 * extended event history
15810 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15811 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15814 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
15815 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15816 PARAMETER (MAXLND=4000)
15817 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
15819 * flags for input different options
15820 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15821 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15822 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15826 DIMENSION IHISMO(NMXHKK),P1(4)
15828 TWOPI = 2.0D0*ATAN2(0.0D0,-1.0D0)
15840 IF ((ISTHKK(I).EQ.1).AND.(IDHKK(I).EQ.111)) THEN
15846 IF (LEMCCK) CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
15847 & PHKK(4,I),INI,IDUM,IDUM)
15848 PT = SQRT(PHKK(1,I)**2+PHKK(2,I)**2)
15849 PTOT = SQRT(PT**2+PHKK(3,I)**2)
15850 COSTH = PHKK(3,I)/(PTOT+TINY10)
15851 IF (COSTH.GT.ONE) THEN
15853 ELSEIF (COSTH.LT.-ONE) THEN
15854 THETA = TWOPI/2.0D0
15856 THETA = ACOS(COSTH)
15858 PHI = ASIN(PHKK(2,I)/(PT +TINY10))
15859 IF (PHKK(1,I).LT.0.0D0)
15861 & PHI = SIGN(TWOPI/2.0D0-ABS(PHI),PHI)
15867 P(NN,5) = PHKK(5,I)
15869 CALL PY1ENT(NN,111,ENER,THETA,PHI)
15883 IF (PYK(II,7).EQ.1) THEN
15887 P1(KK) = PYP(II,KK)
15892 MO = IHISMO(PYK(II,15))
15894 CALL DT_EVTPUT(1,ID,MO,0,P1(1),P1(2),P1(3),P1(4),0,0,0)
15896 & CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,
15898 *sr: flag with neg. sign (for HELIOS p/A-W jobs)
15902 IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,7000,IREJ1)
15909 *$ CREATE DT_DTWOPD.FOR
15912 *===dtwopd=============================================================*
15914 SUBROUTINE DT_DTWOPD(UMO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,COD2,
15915 & COF2,SIF2,AM1,AM2)
15917 ************************************************************************
15918 * Two-particle decay. *
15919 * UMO cm-energy of the decaying system (input) *
15920 * AM1/AM2 masses of the decay products (input) *
15921 * ECM1,ECM2/PCM1,PCM2 cm-energies/momenta of the decay prod. (output) *
15922 * COD,COF,SIF direction cosines of the decay prod. (output) *
15923 * Revised by S. Roesler, 20.11.95 *
15924 ************************************************************************
15926 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15929 PARAMETER ( LINP = 10 ,
15933 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,ZERO=0.0D0)
15935 IF (UMO.LT.(AM1+AM2)) THEN
15936 WRITE(LOUT,1000) UMO,AM1,AM2
15937 1000 FORMAT(1X,'DTWOPD: inconsistent kinematics - UMO,AM1,AM2 ',
15942 ECM1 = ((UMO-AM2)*(UMO+AM2)+AM1*AM1)/(TWO*UMO)
15944 PCM1 = SQRT((ECM1-AM1)*(ECM1+AM1))
15946 CALL DT_DSFECF(SIF1,COF1)
15947 COD1 = TWO*DT_RNDM(PCM2)-ONE
15955 *$ CREATE DT_DTHREP.FOR
15958 *===dthrep=============================================================*
15960 SUBROUTINE DT_DTHREP(UMO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,
15961 & SIF1,COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
15963 ************************************************************************
15964 * Three-particle decay. *
15965 * UMO cm-energy of the decaying system (input) *
15966 * AM1/2/3 masses of the decay products (input) *
15967 * ECM1/2/2,PCM1/2/3 cm-energies/momenta of the decay prod. (output) *
15968 * COD,COF,SIF direction cosines of the decay prod. (output) *
15970 * Threpd89: slight revision by A. Ferrari *
15971 * Last change on 11-oct-93 by Alfredo Ferrari, INFN - Milan *
15972 * Revised by S. Roesler, 20.11.95 *
15973 ************************************************************************
15975 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15978 PARAMETER ( LINP = 10 ,
15982 PARAMETER ( ANGLSQ = 2.5D-31 )
15983 PARAMETER ( AZRZRZ = 1.0D-30 )
15984 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
15985 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
15986 PARAMETER ( ONEONE = 1.D+00 )
15987 PARAMETER ( TWOTWO = 2.D+00 )
15988 PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
15990 COMMON /HNGAMR/ REDU,AMO,AMM(15)
15992 * flags for input different options
15993 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15994 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15995 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15997 DIMENSION F(5),XX(5)
16001 C***S1, S2, S3 ARE THE INVARIANT MASSES OF THE PARTICLES 1, 2, 3
16002 C***J. VON NEUMANN - RANDOM - SELECTION OF S2
16003 C***CALCULATION OF THE MAXIMUM OF THE S2 - DISTRIBUTION
16010 * UFAK=1.0000000000001D0
16011 * IF (GU.GT.GO) UFAK=0.9999999999999D0
16029 S22=GU+(I-1.D0)*DS2
16031 RHO2=DT_YLAMB(S22,UMO2,AM11)*DT_YLAMB(S22,AM22,AM33)/
16033 IF(RHO2.LT.RHO1) GO TO 125
16035 125 S2SUP=(S22-S21)*.5D0+S21
16036 SUPRHO=DT_YLAMB(S2SUP,UMO2,AM11)*DT_YLAMB(S2SUP,AM22,AM33)/
16038 SUPRHO=SUPRHO*1.05D0
16040 IF (GU.LT.GO.AND.XO.LT.GU) XO=GU
16041 IF (GU.GT.GO.AND.XO.GT.GU) XO=GU
16047 F(1)=DT_YLAMB(XO,UMO2,AM11)*DT_YLAMB(XO,AM22,AM33)/(XO+EPS)
16048 F(2)=DT_YLAMB(X1,UMO2,AM11)*DT_YLAMB(X1,AM22,AM33)/(X1+EPS)
16050 X4=(XX(1)+XX(2))*0.5D0
16051 X5=(XX(2)+XX(3))*0.5D0
16052 F(4)=DT_YLAMB(X4,UMO2,AM11)*DT_YLAMB(X4,AM22,AM33)/
16054 F(5)=DT_YLAMB(X5,UMO2,AM11)*DT_YLAMB(X5,AM22,AM33)/
16061 IF (F (II).GE.F (III)) GO TO 128
16074 IF (XX(II).GE.XX(III)) GO TO 129
16088 IF (ITH.GT.200) REDU=-9.D0
16089 IF (ITH.GT.200) GO TO 400
16091 * S2=AM23+C*((UMO-AM1)**2-AM23)
16092 S2=AM23+C*(UMO-AM1-AM2-AM3)*(UMO-AM1+AM2+AM3)
16095 RHO=DT_YLAMB(S2,UMO2,AM11)*DT_YLAMB(S2,AM22,AM33)/S2
16096 IF(Y.GT.RHO) GO TO 1
16097 C***RANDOM SELECTION OF S3 AND CALCULATION OF S1
16099 S1=S1*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)/(2.D0*S2)-
16101 S3=UMO2+AM11+AM22+AM33-S1-S2
16102 ECM1=(UMO2+AM11-S2)/UMOO
16103 ECM2=(UMO2+AM22-S3)/UMOO
16104 ECM3=(UMO2+AM33-S1)/UMOO
16105 PCM1=SQRT((ECM1+AM1)*(ECM1-AM1))
16106 PCM2=SQRT((ECM2+AM2)*(ECM2-AM2))
16107 PCM3=SQRT((ECM3+AM3)*(ECM3-AM3))
16108 CALL DT_DSFECF(SFE,CFE)
16109 C***TH IS THE ANGLE BETWEEN PARTICLES 1 AND 2
16110 C***TH1, TH2 ARE THE ANGLES BETWEEN PARTICLES 1, 2 AND THE DIRECTION OF
16111 PCM12 = PCM1 * PCM2
16112 IF ( PCM12 .LT. ANGLSQ ) GO TO 200
16113 COSTH=(ECM1*ECM2+0.5D+00*(AM11+AM22-S1))/PCM12
16117 COSTH=(UW-0.5D+00)*2.D+00
16119 * IF(ABS(COSTH).GT.0.9999999999999999D0)
16120 * &COSTH=SIGN(0.9999999999999999D0,COSTH)
16121 IF(ABS(COSTH).GT.ONEONE)
16122 &COSTH=SIGN(ONEONE,COSTH)
16123 IF (REDU.LT.1.D+00) RETURN
16124 COSTH2=(PCM3*PCM3+PCM2*PCM2-PCM1*PCM1)/(2.D+00*PCM2*PCM3)
16125 * IF(ABS(COSTH2).GT.0.9999999999999999D0)
16126 * &COSTH2=SIGN(0.9999999999999999D0,COSTH2)
16127 IF(ABS(COSTH2).GT.ONEONE)
16128 &COSTH2=SIGN(ONEONE,COSTH2)
16129 SINTH2=SQRT((ONEONE-COSTH2)*(ONEONE+COSTH2))
16130 SINTH =SQRT((ONEONE-COSTH)*(ONEONE+COSTH))
16131 SINTH1=COSTH2*SINTH-COSTH*SINTH2
16132 COSTH1=COSTH*COSTH2+SINTH2*SINTH
16133 C***RANDOM SELECTION OF THE SPHERICAL COORDINATES OF THE DIRECTION OF PA
16134 C***CFE, SFE ARE COS AND SIN OF THE ROTATION ANGLE OF THE SYSTEM 1, 2 AR
16135 C***THE DIRECTION OF PARTICLE 3
16136 C***CALCULATION OF THE SPHERICAL COORDINATES OF PARTICLES 1, 2
16143 CALL DT_DSFECF(SIF3,COF3)
16144 COD3=TWOTWO*DT_RNDM(CX11)-ONEONE
16145 SID3=SQRT((1.D+00-COD3)*(1.D+00+COD3))
16147 COD1=CX11*COD3+CZ11*SID3
16148 CHLP=(ONEONE-COD1)*(ONEONE+COD1)
16149 IF(CHLP.LT.1.D-14)WRITE(LOUT,2)COD1,COF3,SID3,
16152 COF1=(CX11*SID3*COF3-CY11*SIF3-CZ11*COD3*COF3)/SID1
16153 SIF1=(CX11*SID3*SIF3+CY11*COF3-CZ11*COD3*SIF3)/SID1
16154 COD2=CX22*COD3+CZ22*SID3
16155 SID2=SQRT((ONEONE-COD2)*(ONEONE+COD2))
16156 COF2=(CX22*SID3*COF3-CY22*SIF3-CZ22*COD3*COF3)/SID2
16157 SIF2=(CX22*SID3*SIF3+CY22*COF3-CZ22*COD3*SIF3)/SID2
16159 * === Energy conservation check: === *
16160 EOCHCK = UMO - ECM1 - ECM2 - ECM3
16161 * SID1 = SQRT ( ( ONEONE - COD1 ) * ( ONEONE + COD1 ) )
16162 * SID2 = SQRT ( ( ONEONE - COD2 ) * ( ONEONE + COD2 ) )
16163 * SID3 = SQRT ( ( ONEONE - COD3 ) * ( ONEONE + COD3 ) )
16164 PZCHCK = PCM1 * COD1 + PCM2 * COD2 + PCM3 * COD3
16165 PXCHCK = PCM1 * COF1 * SID1 + PCM2 * COF2 * SID2
16166 & + PCM3 * COF3 * SID3
16167 PYCHCK = PCM1 * SIF1 * SID1 + PCM2 * SIF2 * SID2
16168 & + PCM3 * SIF3 * SID3
16169 EOCMPR = 1.D-12 * UMO
16170 IF ( ABS (EOCHCK) + ABS (PXCHCK) + ABS (PYCHCK) + ABS (PZCHCK)
16171 & .GT. EOCMPR ) THEN
16172 **sr 5.5.95 output-unit changed
16173 IF (IOULEV(1).GT.0) THEN
16175 & ' *** Threpd: energy/momentum conservation failure! ***',
16176 & EOCHCK,PXCHCK,PYCHCK,PZCHCK
16177 WRITE(LOUT,*)' *** SID1,SID2,SID3',SID1,SID2,SID3
16184 *$ CREATE DT_DBKLAS.FOR
16187 *===dbklas=============================================================*
16189 SUBROUTINE DT_DBKLAS(I,J,K,I8,I10)
16191 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16194 PARAMETER ( LINP = 10 ,
16198 * quark-content to particle index conversion (DTUNUC 1.x)
16199 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
16200 & IA08(6,21),IA10(6,21)
16205 CALL DT_INDEXD(J,K,IND)
16208 IF (I8.LE.0) I8 = I10
16215 CALL DT_INDEXD(JJ,KK,IND)
16218 IF (I8.LE.0) I8 = I10
16223 *$ CREATE DT_INDEXD.FOR
16226 *===indexd=============================================================*
16228 SUBROUTINE DT_INDEXD(KA,KB,IND)
16230 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16233 PARAMETER ( LINP = 10 ,
16242 IF ((KP.EQ.4).AND.(KS.EQ.5)) IND=4
16244 IF ((KP.EQ.6).AND.(KS.EQ.7)) IND=6
16245 IF ((KP.EQ.4).AND.(KS.EQ.4)) IND=7
16246 IF ((KP.EQ.6).AND.(KS.EQ.5)) IND=8
16248 IF (KP.EQ.10) IND=10
16249 IF ((KP.EQ.12).AND.(KS.EQ.8)) IND=11
16250 IF (KP.EQ.9) IND=12
16251 IF ((KP.EQ.12).AND.(KS.EQ.7)) IND=13
16252 IF (KP.EQ.15) IND=14
16253 IF (KP.EQ.18) IND=15
16254 IF (KP.EQ.16) IND=16
16255 IF (KP.EQ.20) IND=17
16256 IF (KP.EQ.24) IND=18
16257 IF (KP.EQ.25) IND=19
16258 IF (KP.EQ.30) IND=20
16259 IF (KP.EQ.36) IND=21
16264 *$ CREATE DT_DCHANT.FOR
16267 *===dchant=============================================================*
16269 SUBROUTINE DT_DCHANT
16271 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16274 PARAMETER ( LINP = 10 ,
16278 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
16280 * HADRIN: decay channel information
16281 PARAMETER (IDMAX9=602)
16283 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
16285 * particle properties (BAMJET index convention)
16287 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
16288 & IICH(210),IIBAR(210),K1(210),K2(210)
16290 DIMENSION HWT(IDMAX9)
16292 * change of weights wt from absolut values into the sum of wt of a dec.
16297 C WRITE(LOUT,'(A8,F5.2,2E10.3,2I4,2I10)')
16298 C & ANAME(KKK),AAM(KKK),GA(KKK),TAU(KKK),IICH(KKK),IIBAR(KKK),
16299 C & K1(KKK),K2(KKK)
16310 IF (HWT(J).GT.1.0001) WRITE(LOUT,1000) HWT(J),J,I,IK1
16311 1000 FORMAT(2X,15H ERROR IN HWT =,1F10.5,8H J,I,K1=,3I5)
16321 *$ CREATE DT_DDATAR.FOR
16324 *===ddatar=============================================================*
16326 SUBROUTINE DT_DDATAR
16328 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16331 PARAMETER ( LINP = 10 ,
16335 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
16337 * quark-content to particle index conversion (DTUNUC 1.x)
16338 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
16339 & IA08(6,21),IA10(6,21)
16341 DIMENSION IV(36),IP(36),IB(126),IBB(126),IA(126),IAA(126)
16343 DATA IV/ 33, 34, 38,123, 0, 0, 32, 33, 39,124,
16344 & 0, 0, 36, 37, 96,127, 0, 0,126,125,
16346 DATA IP/ 23, 14, 16,116, 0, 0, 13, 23, 25,117,
16347 & 0, 0, 15, 24, 31,120, 0, 0,119,118,
16349 DATA IB/ 0, 1, 21,140, 0, 0, 8, 22,137, 0,
16350 & 0, 97,138, 0, 0,146, 0, 0, 0, 0,
16351 & 0, 1, 8, 22,137, 0, 0, 0, 20,142,
16352 & 0, 0, 98,139, 0, 0,147, 0, 0, 0,
16353 & 0, 0, 21, 22, 97,138, 0, 0, 20, 98,
16354 & 139, 0, 0, 0,145, 0, 0,148, 0, 0,
16355 & 0, 0, 0,140,137,138,146, 0, 0,142,
16356 & 139,147, 0, 0,145,148, 50*0/
16357 DATA IBB/53, 54,104,161, 0, 0, 55,105,162, 0,
16358 & 0,107,164, 0, 0,167, 0, 0, 0, 0,
16359 & 0, 54, 55,105,162, 0, 0, 56,106,163,
16360 & 0, 0,108,165, 0, 0,168, 0, 0, 0,
16361 & 0, 0,104,105,107,164, 0, 0,106,108,
16362 & 165, 0, 0,109,166, 0, 0,169, 0, 0,
16363 & 0, 0, 0,161,162,164,167, 0, 0,163,
16364 & 165,168, 0, 0,166,169, 0, 0,170,47*0/
16365 DATA IA/ 0, 2, 99,152, 0, 0, 9,100,149, 0,
16366 & 0,102,150, 0, 0,158, 0, 0, 0, 0,
16367 & 0, 2, 9,100,149, 0, 0, 0,101,154,
16368 & 0, 0,103,151, 0, 0,159, 0, 0, 0,
16369 & 0, 0, 99,100,102,150, 0, 0,101,103,
16370 & 151, 0, 0, 0,157, 0, 0,160, 0, 0,
16371 & 0, 0, 0,152,149,150,158, 0, 0,154,
16372 & 151,159, 0, 0,157,160, 50*0/
16373 DATA IAA/67, 68,110,171, 0, 0, 69,111,172, 0,
16374 & 0,113,174, 0, 0,177, 0, 0, 0, 0,
16375 & 0, 68, 69,111,172, 0, 0, 70,112,173,
16376 & 0, 0,114,175, 0, 0,178, 0, 0, 0,
16377 & 0, 0,110,111,113,174, 0, 0,112,114,
16378 & 175, 0, 0,115,176, 0, 0,179, 0, 0,
16379 & 0, 0, 0,171,172,174,177, 0, 0,173,
16380 & 175,178, 0, 0,176,179, 0, 0,180,47*0/
16416 *$ CREATE DT_INITJS.FOR
16419 *===initjs=============================================================*
16421 SUBROUTINE DT_INITJS(MODE)
16423 ************************************************************************
16424 * Initialize JETSET paramters. *
16425 * MODE = 0 default settings *
16426 * = 1 PHOJET settings *
16427 * = 2 DTUNUC settings *
16428 * This version dated 16.02.96 is written by S. Roesler *
16430 * Last change 27.12.2006 by S. Roesler. *
16431 ************************************************************************
16433 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16436 PARAMETER ( LINP = 10 ,
16440 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
16442 LOGICAL LFIRST,LFIRDT,LFIRPH
16444 * INCLUDE '(DIMPAR)'
16445 * DIMPAR taken from FLUKA
16446 PARAMETER ( MXXRGN =20000 )
16447 PARAMETER ( MXXMDF = 710 )
16448 PARAMETER ( MXXMDE = 702 )
16449 PARAMETER ( MFSTCK =40000 )
16450 PARAMETER ( MESTCK = 100 )
16451 PARAMETER ( MOSTCK = 2000 )
16452 PARAMETER ( MXPRSN = 100 )
16453 PARAMETER ( MXPDPM = 800 )
16454 PARAMETER ( MXPSCS =30000 )
16455 PARAMETER ( MXGLWN = 300 )
16456 PARAMETER ( MXOUTU = 50 )
16457 PARAMETER ( NALLWP = 64 )
16458 PARAMETER ( NELEMX = 80 )
16459 PARAMETER ( MPDPDX = 18 )
16460 PARAMETER ( MXHTTR = 260 )
16461 PARAMETER ( MXSEAX = 20 )
16462 PARAMETER ( MXHTNC = MXSEAX + 1 )
16463 PARAMETER ( ICOMAX = 2400 )
16464 PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
16465 PARAMETER ( NSTBIS = 304 )
16466 PARAMETER ( NQSTIS = 46 )
16467 PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
16468 PARAMETER ( MXPABL = 120 )
16469 PARAMETER ( IDMAXP = 450 )
16470 PARAMETER ( IDMXDC = 2000 )
16471 PARAMETER ( MXMCIN = 410 )
16472 PARAMETER ( IHYPMX = 4 )
16473 PARAMETER ( MKBMX1 = 11 )
16474 PARAMETER ( MKBMX2 = 11 )
16475 PARAMETER ( MXIRRD = 2500 )
16476 PARAMETER ( MXTRDC = 1500 )
16477 PARAMETER ( NKTL = 17 )
16478 PARAMETER ( NBLNMX = 40000000 )
16481 * PART taken from FLUKA
16482 PARAMETER ( KPETA0 = 31 )
16483 PARAMETER ( KPRHOP = 32 )
16484 PARAMETER ( KPRHO0 = 33 )
16485 PARAMETER ( KPRHOM = 34 )
16486 PARAMETER ( KPOME0 = 35 )
16487 PARAMETER ( KPPHI0 = 96 )
16488 PARAMETER ( KPDEPP = 53 )
16489 PARAMETER ( KPDELP = 54 )
16490 PARAMETER ( KPDEL0 = 55 )
16491 PARAMETER ( KPDELM = 56 )
16492 PARAMETER ( KPN14P = 91 )
16493 PARAMETER ( KPN140 = 92 )
16494 * Low mass diffraction partners:
16495 PARAMETER ( KDETA0 = 0 )
16496 PARAMETER ( KDRHOP = 0 )
16497 PARAMETER ( KDRHO0 = 210 )
16498 PARAMETER ( KDRHOM = 0 )
16499 PARAMETER ( KDOME0 = 210 )
16500 PARAMETER ( KDPHI0 = 210 )
16501 PARAMETER ( KDDEPP = 0 )
16502 PARAMETER ( KDDELP = 0 )
16503 PARAMETER ( KDDEL0 = 0 )
16504 PARAMETER ( KDDELM = 0 )
16505 PARAMETER ( KDN14P = 0 )
16506 PARAMETER ( KDN140 = 0 )
16509 COMMON / PART / AM (-6:IDMAXP), GA (-6:IDMAXP),
16510 & TAU (-6:IDMAXP), AMDISC (-6:IDMAXP),
16511 & ZMNABS (-6:IDMAXP), ATNMNA (-6:IDMAXP),
16512 & ATXN14, ATMN14, RNRN14 (-10:10),
16513 & ICH (-6:IDMAXP), IBAR (-6:IDMAXP),
16514 & ISOSYM (-6:IDMAXP), ICHCON (-6:IDMAXP),
16515 & K1 (-6:IDMAXP), K2 (-6:IDMAXP),
16516 & KPTOIP (-6:IDMAXP), IPTOKP (-6:NALLWP),
16517 & KPTOIA (-6:IDMAXP), IATOKP (-6:MXPABL),
16518 & IDCFLG (-6:NALLWP), IPTYPE (-6:NALLWP)
16520 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16521 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
16522 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
16524 * flags for particle decays
16525 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
16526 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
16527 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
16529 * flags for input different options
16530 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16531 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16532 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16536 DIMENSION IDXSTA(40)
16538 * K0s pi0 lam alam sig+ asig+ sig- asig- tet0 atet0
16539 & / 310, 111, 3122,-3122, 3222,-3222, 3112,-3112, 3322,-3322,
16540 * tet- atet- om- aom- D+ D- D0 aD0 Ds+ aDs+
16541 & 3312,-3312, 3334,-3334, 411, -411, 421, -421, 431, -431,
16542 * etac lamc+alamc+sigc++ sigc+ sigc0asigc++asigc+asigc0 Ksic+
16543 & 441, 4122,-4122, 4222, 4212, 4112,-4222,-4212,-4112, 4232,
16544 * Ksic0 aKsic+aKsic0 sig0 asig0
16545 & 4132,-4232,-4132, 3212,-3212, 5*0/
16547 DATA LFIRST,LFIRDT,LFIRPH /.TRUE.,.TRUE.,.TRUE./
16550 * save default settings
16562 * LUJETS / PYJETS array-dimensions
16566 * increase maximum number of JETSET-error prints
16568 * prevent particles decaying
16572 KC = PYCOMP(IDXSTA(I))
16580 C ELSEIF ((I.EQ.4).OR.(I.EQ. 6).OR.
16581 C & (I.EQ.8).OR.(I.EQ.10)) THEN
16582 C ELSEIF (I.EQ.4) THEN
16589 ELSEIF (((I.EQ.34).OR.(I.EQ.35)).AND.(ISIG0.EQ.0)) THEN
16591 KC = PYCOMP(IDXSTA(I))
16600 * as Fluka event-generator: allow only paprop particles to be stable
16601 * and let all other particles decay (i.e. those with strong decays)
16602 IF (ITRSPT.EQ.1) THEN
16604 IF (KPTOIP(I).NE.0) THEN
16610 IF (MDCY(KC,1).EQ.1) THEN
16612 & ' DT_INITJS: Decay flag for FLUKA-',
16613 & 'transport : particle should not ',
16614 & 'decay : ',IDPDG,' ',ANAME(I)
16624 IF ((MDCY(KC,1).EQ.0).AND.(KPTOIP(KP).EQ.0).AND.
16625 & (ANAME(KP).NE.'BLANK ').AND.
16626 & (ANAME(KP).NE.'RNDFLV ')) THEN
16627 WRITE(LOUT,*) ' DT_INITJS: Decay flag for FLUKA-',
16628 & 'transport: particle should decay ',
16629 & ': ',IDPDG,' ',ANAME(KP)
16638 IF (PDB.LE.ZERO) THEN
16639 * no popcorn-mechanism
16645 * set JETSET-parameter requested by input cards
16646 IF (NMSTU.GT.0) THEN
16648 MSTU(IMSTU(I)) = MSTUX(I)
16651 IF (NMSTJ.GT.0) THEN
16653 MSTJ(IMSTJ(I)) = MSTJX(I)
16656 IF (NPARU.GT.0) THEN
16658 PARU(IPARU(I)) = PARUX(I)
16664 * PARJ(1) suppression of qq-aqaq pair prod. compared to
16665 * q-aq pair prod. (default: 0.1)
16666 * PARJ(2) strangeness suppression (default: 0.3)
16667 * PARJ(3) extra suppression of strange diquarks (default: 0.4)
16668 * PARJ(6) extra suppression of sas-pair shared by B and
16669 * aB in BMaB (default: 0.5)
16670 * PARJ(7) extra suppression of strange meson M in BMaB
16671 * configuration (default: 0.5)
16672 * PARJ(18) spin 3/2 baryon suppression (default: 1.0)
16673 * PARJ(21) width sigma in Gaussian p_x, p_y transverse
16674 * momentum distrib. for prim. hadrons (default: 0.35)
16675 * PARJ(42) b-parameter for symmetric Lund-fragmentation
16676 * function (default: 0.9 GeV^-2)
16679 IF (MODE.EQ.1) THEN
16686 C PARJ(18) = PDEF18
16687 C PARJ(21) = PDEF21
16688 C PARJ(42) = PDEF42
16689 **sr 18.11.98 parameter tuning
16690 C PARJ(1) = 0.092D0
16694 C PARJ(21) = 0.45D0
16696 **sr 28.04.99 parameter tuning (May 99 minor modifications)
16706 IF (NPARJ.GT.0) THEN
16708 IF (IPARJ(I).GT.0) PARJ(IPARJ(I)) = PARJX(I)
16712 WRITE(LOUT,'(1X,A)')
16713 & 'DT_INITJS: JETSET-parameter for PHOJET'
16718 ELSEIF (MODE.EQ.2) THEN
16719 IF (IFRAG(2).EQ.1) THEN
16720 **sr parameters before 9.3.96
16725 C PARJ(21) = 0.55D0
16727 **sr 18.11.98 parameter tuning
16732 C PARJ(21) = 0.45D0
16734 **sr 28.04.99 parameter tuning
16742 IF (NPARJ.GT.0) THEN
16744 IF (IPARJ(I).LT.0) THEN
16745 IDX = ABS(IPARJ(I))
16746 PARJ(IDX) = PARJX(I)
16751 WRITE(LOUT,'(1X,A)')
16752 & 'DT_INITJS: JETSET-parameter for DTUNUC'
16756 ELSEIF (IFRAG(2).EQ.2) THEN
16763 C PARJ(21) = 0.55D0
16794 *$ CREATE DT_JSPARA.FOR
16797 *===jspara=============================================================*
16799 SUBROUTINE DT_JSPARA(MODE)
16801 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16804 PARAMETER ( LINP = 10 ,
16808 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1,
16809 & ONE=1.0D0,ZERO=0.0D0)
16813 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16815 DIMENSION ISTU(200),QARU(200),ISTJ(200),QARJ(200)
16817 DATA LFIRST /.TRUE./
16819 * save the default JETSET-parameter on the first call
16831 1000 FORMAT(1X,'DT_JSPARA: new value (default value)')
16833 * compare the default JETSET-parameter with the present values
16835 IF ((MSTU(I).NE.ISTU(I)).AND.(I.NE.31)) THEN
16836 WRITE(LOUT,1002) 'MSTU(',I,MSTU(I),ISTU(I)
16837 C ISTU(I) = MSTU(I)
16839 DIFF = ABS(PARU(I)-QARU(I))
16840 IF ((DIFF.GE.1.0D-5).AND.(I.NE.21)) THEN
16841 WRITE(LOUT,1001) 'PARU(',I,PARU(I),QARU(I)
16842 C QARU(I) = PARU(I)
16844 IF (MSTJ(I).NE.ISTJ(I)) THEN
16845 WRITE(LOUT,1002) 'MSTJ(',I,MSTJ(I),ISTJ(I)
16846 C ISTJ(I) = MSTJ(I)
16848 DIFF = ABS(PARJ(I)-QARJ(I))
16849 IF (DIFF.GE.1.0D-5) THEN
16850 WRITE(LOUT,1001) 'PARJ(',I,PARJ(I),QARJ(I)
16851 C QARJ(I) = PARJ(I)
16854 1001 FORMAT(12X,A5,I3,'): ',F6.3,' (',F6.3,')')
16855 1002 FORMAT(12X,A5,I3,'): ',I6,' (',I6,')')
16859 *$ CREATE DT_FOZOCA.FOR
16862 *===fozoca=============================================================*
16864 SUBROUTINE DT_FOZOCA(LFZC,IREJ)
16866 ************************************************************************
16867 * This subroutine treats the complete FOrmation ZOne supressed intra- *
16868 * nuclear CAscade. *
16869 * LFZC = .true. cascade has been treated *
16870 * = .false. cascade skipped *
16871 * This is a completely revised version of the original FOZOKL. *
16872 * This version dated 18.11.95 is written by S. Roesler *
16873 ************************************************************************
16875 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16878 PARAMETER ( LINP = 10 ,
16882 PARAMETER (DLARGE=1.0D10,OHALF=0.5D0,ZERO=0.0D0)
16883 PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16885 LOGICAL LSTART,LCAS,LFZC
16889 PARAMETER (NMXHKK=200000)
16891 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16892 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16893 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16895 * extended event history
16896 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16897 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16900 * rejection counter
16901 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
16902 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
16903 & IREXCI(3),IRDIFF(2),IRINC
16905 * properties of interacting particles
16906 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
16908 * Glauber formalism: collision properties
16909 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
16910 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
16912 * flags for input different options
16913 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16914 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16915 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16917 * final state after intranuclear cascade step
16918 COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16920 * parameter for intranuclear cascade
16922 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16924 DIMENSION NCWOUN(2)
16926 DATA LSTART /.TRUE./
16931 * skip cascade if hadron-hadron interaction or if supressed by user
16932 IF (((IP.EQ.1).AND.(IT.EQ.1)).OR.(KTAUGE.LT.1)) GOTO 9999
16933 * skip cascade if not all possible chains systems are hadronized
16935 IF (.NOT.LHADRO(I)) GOTO 9999
16939 WRITE(LOUT,1000) KTAUGE,TAUFOR,INCMOD
16940 1000 FORMAT(/,1X,'FOZOCA: intranuclear cascade treated for a ',
16941 & 'maximum of',I4,' generations',/,10X,'formation time ',
16942 & 'parameter:',F5.1,' fm/c',9X,'modus:',I2)
16943 IF (ITAUVE.EQ.1) WRITE(LOUT,1001)
16944 IF (ITAUVE.EQ.2) WRITE(LOUT,1002)
16945 1001 FORMAT(10X,'p_t dependent formation zone',/)
16946 1002 FORMAT(10X,'constant formation zone',/)
16950 * in order to avoid wasting of cpu-time the DTEVT1-indices of nucleons
16951 * which may interact with final state particles are stored in a seperate
16952 * array - here all proj./target nucleon-indices (just for simplicity)
16954 DO 9 I=1,NPOINT(1)-1
16959 * initialize Pauli-principle treatment (find wounded nucleons)
16966 IF (ISTHKK(J).EQ.10+I) THEN
16967 NWOUND(I) = NWOUND(I)+1
16968 EWOUND(I,NWOUND(I)) = PHKK(4,J)
16969 IF (IDHKK(J).EQ.2212) NCWOUN(I) = NCWOUN(I)+1
16974 * modify nuclear potential for wounded nucleons
16975 IPRCL = IP -NWOUND(1)
16976 IPZRCL = IPZ-NCWOUN(1)
16977 ITRCL = IT -NWOUND(2)
16978 ITZRCL = ITZ-NCWOUN(2)
16979 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
16987 IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDCH(I).LT.KTAUGE)) THEN
16988 * select nucleus the cascade starts first (proj. - 1, target - -1)
16990 * projectile/target with probab. 1/2
16991 IF ((INCMOD.EQ.1).OR.(IDCH(I).GT.0)) THEN
16992 IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16993 * in the nucleus with highest mass
16994 ELSEIF (INCMOD.EQ.2) THEN
16997 ELSEIF (IP.EQ.IT) THEN
16998 IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
17000 * the nucleus the cascade starts first is requested to be the one
17001 * moving in the direction of the secondary
17002 ELSEIF (INCMOD.EQ.3) THEN
17003 NCAS = INT(SIGN(1.0D0,PHKK(3,I)))
17005 * check that the selected "nucleus" is not a hadron
17006 IF (((NCAS.EQ. 1).AND.(IP.LE.1)).OR.
17007 & ((NCAS.EQ.-1).AND.(IT.LE.1))) NCAS = -NCAS
17009 * treat intranuclear cascade in the nucleus selected first
17011 CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
17012 IF (IREJ1.NE.0) GOTO 9998
17013 * treat intranuclear cascade in the other nucleus if this isn't a had.
17015 IF (((NCAS.EQ. 1).AND.(IP.GT.1)).OR.
17016 & ((NCAS.EQ.-1).AND.(IT.GT.1))) THEN
17017 IF (LCAS) CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
17018 IF (IREJ1.NE.0) GOTO 9998
17026 IF (NSTART.LE.NEND) GOTO 7
17031 * reject this event
17036 * intranucl. cascade not treated because of interaction properties or
17037 * it is supressed by user or it was rejected or...
17039 * reset flag characterizing direction of motion in n-n-cms
17041 C DO 9990 I=NPOINT(5),NHKK
17042 C IF (ISTHKK(I).EQ.-1) ISTHKK(I)=1
17048 *$ CREATE DT_INUCAS.FOR
17051 *===inucas=============================================================*
17053 SUBROUTINE DT_INUCAS(IT,IP,IDXCAS,LCAS,NCAS,IREJ)
17055 ************************************************************************
17056 * Formation zone supressed IntraNUclear CAScade for one final state *
17058 * IT, IP mass numbers of target, projectile nuclei *
17059 * IDXCAS index of final state particle in DTEVT1 *
17060 * NCAS = 1 intranuclear cascade in projectile *
17061 * = -1 intranuclear cascade in target *
17062 * This version dated 18.11.95 is written by S. Roesler *
17063 ************************************************************************
17065 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17068 PARAMETER ( LINP = 10 ,
17072 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
17073 & OHALF=0.5D0,ONE=1.0D0)
17074 PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
17075 PARAMETER (TWOPI=6.283185307179586454D+00)
17076 PARAMETER (PLOWH=0.01D0,PHIH=9.0D0)
17078 LOGICAL LABSOR,LCAS
17082 PARAMETER (NMXHKK=200000)
17084 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17085 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17086 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17088 * extended event history
17089 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17090 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17093 * final state after inc step
17094 PARAMETER (MAXFSP=10)
17095 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17097 * flags for input different options
17098 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17099 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17100 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17102 * particle properties (BAMJET index convention)
17104 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17105 & IICH(210),IIBAR(210),K1(210),K2(210)
17107 * Glauber formalism: collision properties
17108 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
17109 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
17111 * nuclear potential
17113 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17114 & EBINDP(2),EBINDN(2),EPOT(2,210),
17115 & ETACOU(2),ICOUL,LFERMI
17117 * parameter for intranuclear cascade
17119 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
17121 * final state after intranuclear cascade step
17122 COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
17124 * nucleon-nucleon event-generator
17127 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
17129 * statistics: residual nuclei
17130 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
17131 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
17132 & NINCST(2,4),NINCEV(2),
17133 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
17134 & NRESPB(2),NRESCH(2),NRESEV(4),
17135 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
17138 DIMENSION PCAS(2,5),PTOCAS(2),COSCAS(2,3),VTXCAS(2,4),VTXCA1(2,4),
17139 & PCAS1(5),PNUC(5),BGTA(4),
17140 & BGCAS(2),GACAS(2),BECAS(2),
17141 & RNUC(2),BIMPC(2),VTXDST(3),IDXSPE(2),IDSPE(2),NWTMP(2)
17143 DATA PDIF /0.545D0/
17148 IF (NINCEV(1).NE.NEVHKK) THEN
17150 NINCEV(2) = NINCEV(2)+1
17153 * "BAMJET-index" of this hadron
17154 IDCAS = IDBAM(IDXCAS)
17155 IF (IDT_MCHAD(IDCAS).EQ.-1) RETURN
17157 * skip gammas, electrons, etc..
17158 IF (AAM(IDCAS).LT.TINY2) RETURN
17160 * Lorentz-trsf. into projectile rest system
17162 CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
17163 & PHKK(4,IDXCAS),PCAS(1,1),PCAS(1,2),PCAS(1,3),
17164 & PCAS(1,4),IDCAS,-2)
17165 PTOCAS(1) = SQRT(PCAS(1,1)**2+PCAS(1,2)**2+PCAS(1,3)**2)
17166 PCAS(1,5) = (PCAS(1,4)-PTOCAS(1))*(PCAS(1,4)+PTOCAS(1))
17167 IF (PCAS(1,5).GT.ZERO) THEN
17168 PCAS(1,5) = SQRT(PCAS(1,5))
17170 PCAS(1,5) = AAM(IDCAS)
17173 COSCAS(1,K) = PCAS(1,K)/MAX(PTOCAS(1),TINY10)
17175 * Lorentz-parameters
17176 * particle rest system --> projectile rest system
17177 BGCAS(1) = PTOCAS(1)/MAX(PCAS(1,5),TINY10)
17178 GACAS(1) = PCAS(1,4)/MAX(PCAS(1,5),TINY10)
17179 BECAS(1) = BGCAS(1)/GACAS(1)
17183 IF (K.LE.3) COSCAS(1,K) = ZERO
17190 * Lorentz-trsf. into target rest system
17192 * LEPTO: final state particles are already in target rest frame
17193 C IF (MCGENE.EQ.3) THEN
17194 C PCAS(2,1) = PHKK(1,IDXCAS)
17195 C PCAS(2,2) = PHKK(2,IDXCAS)
17196 C PCAS(2,3) = PHKK(3,IDXCAS)
17197 C PCAS(2,4) = PHKK(4,IDXCAS)
17199 CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
17200 & PHKK(4,IDXCAS),PCAS(2,1),PCAS(2,2),PCAS(2,3),
17201 & PCAS(2,4),IDCAS,-3)
17203 PTOCAS(2) = SQRT(PCAS(2,1)**2+PCAS(2,2)**2+PCAS(2,3)**2)
17204 PCAS(2,5) = (PCAS(2,4)-PTOCAS(2))*(PCAS(2,4)+PTOCAS(2))
17205 IF (PCAS(2,5).GT.ZERO) THEN
17206 PCAS(2,5) = SQRT(PCAS(2,5))
17208 PCAS(2,5) = AAM(IDCAS)
17211 COSCAS(2,K) = PCAS(2,K)/MAX(PTOCAS(2),TINY10)
17213 * Lorentz-parameters
17214 * particle rest system --> target rest system
17215 BGCAS(2) = PTOCAS(2)/MAX(PCAS(2,5),TINY10)
17216 GACAS(2) = PCAS(2,4)/MAX(PCAS(2,5),TINY10)
17217 BECAS(2) = BGCAS(2)/GACAS(2)
17221 IF (K.LE.3) COSCAS(2,K) = ZERO
17229 * radii of nuclei (mm) modified by the wall-depth of the Woods-Saxon-
17230 * potential (see CONUCL)
17231 RNUC(1) = (RPROJ+4.605D0*PDIF)*FM2MM
17232 RNUC(2) = (RTARG+4.605D0*PDIF)*FM2MM
17233 * impact parameter (the projectile moving along z)
17235 BIMPC(2) = BIMPAC*FM2MM
17237 * get position of initial hadron in projectile/target rest-syst.
17239 VTXCAS(1,K) = WHKK(K,IDXCAS)
17240 VTXCAS(2,K) = VHKK(K,IDXCAS)
17245 IF (NCAS.EQ.-1) THEN
17250 IF (PTOCAS(ICAS).LT.TINY10) THEN
17251 WRITE(LOUT,1000) PTOCAS
17252 1000 FORMAT(1X,'INUCAS: warning! zero momentum of initial',
17253 & ' hadron ',/,20X,2E12.4)
17257 * reset spectator flags
17264 * formation length (in fm)
17268 DEL0 = TAUFOR*BGCAS(ICAS)
17269 IF (ITAUVE.EQ.1) THEN
17270 AMT = PCAS(ICAS,1)**2+PCAS(ICAS,2)**2+PCAS(ICAS,5)**2
17271 DEL0 = DEL0*PCAS(ICAS,5)**2/AMT
17274 * sample from exp(-del/del0)
17275 DEL1 = -DEL0*LOG(MAX(DT_RNDM(DEL0),TINY10))
17276 * save formation time
17277 TAUSA1 = DEL1/BGCAS(ICAS)
17278 REL1 = TAUSA1*BGCAS(I2)
17281 TAUSAM = DEL/BGCAS(ICAS)
17282 REL = TAUSAM*BGCAS(I2)
17284 * special treatment for negative particles unable to escape
17285 * nuclear potential (implemented for ap, pi-, K- only)
17287 IF ((IICH(IDCAS).EQ.-1).AND.(IDCAS.LT.20)) THEN
17288 * threshold energy = nuclear potential + Coulomb potential
17289 * (nuclear potential for hadron-nucleus interactions only)
17290 ETHR = AAM(IDCAS)+EPOT(ICAS,IDCAS)+ETACOU(ICAS)
17291 IF (PCAS(ICAS,4).LT.ETHR) THEN
17293 PCAS1(K) = PCAS(ICAS,K)
17295 * "absorb" negative particle in nucleus
17296 CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,0,IREJ1)
17297 IF (IREJ1.NE.0) GOTO 9999
17298 IF (NSPE.GE.1) LABSOR = .TRUE.
17302 * if the initial particle has not been absorbed proceed with
17304 IF (.NOT.LABSOR) THEN
17306 * calculate coordinates of hadron at the end of the formation zone
17307 * transport-time and -step in the rest system where this step is
17310 DTIME = DSTEP/BECAS(ICAS)
17312 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17313 RTIME = RSTEP/BECAS(I2)
17317 * save step whithout considering the overlapping region
17318 DSTEP1 = DEL1*FM2MM
17319 DTIME1 = DSTEP1/BECAS(ICAS)
17320 RSTEP1 = REL1*FM2MM
17321 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17322 RTIME1 = RSTEP1/BECAS(I2)
17326 * transport to the end of the formation zone in this system
17328 VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+DSTEP1*COSCAS(ICAS,K)
17329 VTXCA1(I2,K) = VTXCAS(I2,K) +RSTEP1*COSCAS(I2,K)
17330 VTXCAS(ICAS,K) = VTXCAS(ICAS,K)+DSTEP*COSCAS(ICAS,K)
17331 VTXCAS(I2,K) = VTXCAS(I2,K) +RSTEP*COSCAS(I2,K)
17333 VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME1
17334 VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME1
17335 VTXCAS(ICAS,4) = VTXCAS(ICAS,4)+DTIME
17336 VTXCAS(I2,4) = VTXCAS(I2,4) +RTIME
17338 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17339 XCAS = VTXCAS(ICAS,1)
17340 YCAS = VTXCAS(ICAS,2)
17341 XNCLTA = BIMPAC*FM2MM
17342 RNCLPR = (RPROJ+RNUCLE)*FM2MM
17343 RNCLTA = (RTARG+RNUCLE)*FM2MM
17344 C RNCLPR = (RPROJ+1.605D0*PDIF)*FM2MM
17345 C RNCLTA = (RTARG+1.605D0*PDIF)*FM2MM
17346 C RNCLPR = (RPROJ)*FM2MM
17347 C RNCLTA = (RTARG)*FM2MM
17348 RCASPR = SQRT( XCAS**2 +YCAS**2)
17349 RCASTA = SQRT((XCAS-XNCLTA)**2+YCAS**2)
17350 IF ((RCASPR.LT.RNCLPR).AND.(RCASTA.LT.RNCLTA)) THEN
17351 IF (IDCH(IDXCAS).EQ.0) NOBAM(IDXCAS) = 3
17355 * check if particle is already outside of the corresp. nucleus
17356 RDIST = SQRT((VTXCAS(ICAS,1)-BIMPC(ICAS))**2+
17357 & VTXCAS(ICAS,2)**2+VTXCAS(ICAS,3)**2)
17358 IF (RDIST.GE.RNUC(ICAS)) THEN
17359 * here: IDCH is the generation of the final state part. starting
17360 * with zero for hadronization products
17361 * flag particles of generation 0 being outside the nuclei after
17362 * formation time (to be used for excitation energy calculation)
17363 IF ((IDCH(IDXCAS).EQ.0).AND.(NOBAM(IDXCAS).LT.3))
17364 & NOBAM(IDXCAS) = NOBAM(IDXCAS)+ICAS
17373 * already here: skip particles being outside HADRIN "energy-window"
17374 * to avoid wasting of time
17375 NINCHR(ICAS,1) = NINCHR(ICAS,1)+1
17376 IF ((PTOCAS(ICAS).LE.PLOWH).OR.(PTOCAS(ICAS).GE.PHIH)) THEN
17377 NINCHR(ICAS,2) = NINCHR(ICAS,2)+1
17378 C WRITE(LOUT,1002) IDXCAS,IDCAS,ICAS,PTOCAS(ICAS),NEVHKK
17379 C1002 FORMAT(1X,'INUCAS: warning! momentum of particle with ',
17380 C & 'index ',I5,' (id: ',I3,') ',I3,/,11X,'p_tot = ',
17381 C & E12.4,', above or below HADRIN-thresholds',I6)
17386 DO 7 IDXHKK=1,NOINC
17388 * scan DTEVT1 for unwounded or excited nucleons
17389 IF ((ISTHKK(I).EQ.12+ICAS).OR.(ISTHKK(I).EQ.14+ICAS)) THEN
17391 IF (ICAS.EQ.1) THEN
17392 VTXDST(K) = WHKK(K,I)-VTXCAS(1,K)
17393 ELSEIF (ICAS.EQ.2) THEN
17394 VTXDST(K) = VHKK(K,I)-VTXCAS(2,K)
17397 POSNUC = VTXDST(1)*COSCAS(ICAS,1)+
17398 & VTXDST(2)*COSCAS(ICAS,2)+
17399 & VTXDST(3)*COSCAS(ICAS,3)
17400 * check if nucleon is situated in forward direction
17401 IF (POSNUC.GT.ZERO) THEN
17402 * distance between hadron and this nucleon
17403 DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17406 BIMNU2 = DISTNU**2-POSNUC**2
17407 IF (BIMNU2.LT.ZERO) THEN
17408 WRITE(LOUT,1001) DISTNU,POSNUC,BIMNU2
17409 1001 FORMAT(1X,'INUCAS: warning! inconsistent impact',
17410 & ' parameter ',/,20X,3E12.4)
17413 BIMNU = SQRT(BIMNU2)
17414 * maximum impact parameter to have interaction
17415 IDNUC = IDT_ICIHAD(IDHKK(I))
17416 IDNUC1 = IDT_MCHAD(IDNUC)
17417 IDCAS1 = IDT_MCHAD(IDCAS)
17419 PCAS1(K) = PCAS(ICAS,K)
17420 PNUC(K) = PHKK(K,I)
17422 * Lorentz-parameter for trafo into rest-system of target
17424 BGTA(K) = PNUC(K)/MAX(PNUC(5),TINY10)
17426 * transformation of projectile into rest-system of target
17427 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
17428 & PCAS1(1),PCAS1(2),PCAS1(3),PCAS1(4),
17429 & PPTOT,PX,PY,PZ,PE)
17431 C CALL DT_SIHNIN(IDCAS1,IDNUC1,PPTOT,SIGIN)
17432 C CALL DT_SIHNEL(IDCAS1,IDNUC1,PPTOT,SIGEL)
17434 CALL DT_XSHN(IDCAS1,IDNUC1,PPTOT,DUMZER,SIGTOT,SIGEL)
17435 CALL DT_SIHNAB(IDCAS1,IDNUC1,PPTOT,SIGAB)
17436 IF (((IDCAS1.EQ.13).OR.(IDCAS1.EQ.14)).AND.
17437 & (PPTOT.LT.0.15D0)) SIGEL = SIGEL/2.0D0
17438 SIGIN = SIGTOT-SIGEL-SIGAB
17439 C SIGTOT = SIGIN+SIGEL+SIGAB
17441 BIMMAX = SQRT(SIGTOT/(5.0D0*TWOPI))*FM2MM
17442 * check if interaction is possible
17443 IF (BIMNU.LE.BIMMAX) THEN
17444 * get nucleon with smallest distance and kind of interaction
17445 * (elastic/inelastic)
17446 IF (DISTNU.LT.DIST) THEN
17449 IF (IDNUC.NE.IDSPE(1)) THEN
17450 IDSPE(2) = IDSPE(1)
17451 IDXSPE(2) = IDXSPE(1)
17460 C IF ((IDCAS.EQ.2).OR.(IDCAS.EQ.9)) THEN
17462 C STOT = SIGIN+SIGEL
17464 C SELA = SIGEL+0.75D0*SIGIN
17465 C STOT = 0.25D0*SIGIN+SELA
17471 DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17473 IDNUC = IDT_ICIHAD(IDHKK(I))
17474 IF (IDNUC.EQ.1) THEN
17475 IF (DISTNU.LT.DISTP) THEN
17480 ELSEIF (IDNUC.EQ.8) THEN
17481 IF (DISTNU.LT.DISTN) THEN
17490 * there is no nucleon for a secondary interaction
17491 IF (NSPE.EQ.0) GOTO 9997
17493 C IF ((IDCAS.EQ.13).AND.((PCAS(ICAS,4)-PCAS(ICAS,5)).LT.0.1D0))
17494 C & WRITE(LOUT,*) STOT,SELA,SABS,IDXSPE
17495 IF (IDXSPE(2).EQ.0) THEN
17496 IF ((IDSPE(1).EQ.1).AND.(IDXN.GT.0)) THEN
17498 C IF (ICAS.EQ.1) THEN
17499 C VTXDST(K) = WHKK(K,IDXN)-WHKK(K,IDXSPE(1))
17500 C ELSEIF (ICAS.EQ.2) THEN
17501 C VTXDST(K) = VHKK(K,IDXN)-VHKK(K,IDXSPE(1))
17504 C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17506 C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSN.GT.ZERO)) THEN
17513 ELSEIF ((IDSPE(1).EQ.8).AND.(IDXP.GT.0)) THEN
17515 C IF (ICAS.EQ.1) THEN
17516 C VTXDST(K) = WHKK(K,IDXP)-WHKK(K,IDXSPE(1))
17517 C ELSEIF (ICAS.EQ.2) THEN
17518 C VTXDST(K) = VHKK(K,IDXP)-VHKK(K,IDXSPE(1))
17521 C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17523 C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSP.GT.ZERO)) THEN
17536 IF (RR.LT.SELA/STOT) THEN
17538 ELSEIF ((RR.GE.SELA/STOT).AND.(RR.LT.(SELA+SABS)/STOT)) THEN
17545 PCAS1(K) = PCAS(ICAS,K)
17546 PNUC(K) = PHKK(K,IDXSPE(1))
17548 IF (IPROC.EQ.3) THEN
17549 * 2-nucleon absorption of pion
17551 CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,1,IREJ1)
17552 IF (IREJ1.NE.0) GOTO 9999
17553 IF (NSPE.GE.1) LABSOR = .TRUE.
17555 * sample secondary interaction
17556 IDNUC = IDBAM(IDXSPE(1))
17557 CALL DT_HADRIN(IDCAS,PCAS1,IDNUC,PNUC,IPROC,IREJ1)
17558 IF (IREJ1.EQ.1) GOTO 9999
17559 IF (IREJ1.GT.1) GOTO 9998
17563 * update arrays to include Pauli-principle
17565 IF (NWOUND(ICAS).LE.299) THEN
17566 NWOUND(ICAS) = NWOUND(ICAS)+1
17567 EWOUND(ICAS,NWOUND(ICAS)) = PHKK(4,IDXSPE(I))
17571 * dump initial hadron for energy-momentum conservation check
17573 & CALL DT_EVTEMC(PCAS(ICAS,1),PCAS(ICAS,2),PCAS(ICAS,3),
17574 & PCAS(ICAS,4),1,IDUM,IDUM)
17576 * dump final state particles into DTEVT1
17578 * check if Pauli-principle is fulfilled
17580 NWTMP(1) = NWOUND(1)
17581 NWTMP(2) = NWOUND(2)
17585 IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
17586 & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1
17588 IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 117
17595 IF (IDX.EQ.1) MODE = -1
17596 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,MODE)
17598 * first check if cascade step is forbidden due to Pauli-principle
17599 * (in case of absorpion this step is forced)
17600 IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
17601 & (IDFSP(I).EQ.8))) THEN
17602 * get nuclear potential barrier
17603 POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
17604 IF (IDFSP(I).EQ.1) THEN
17605 POTLOW = POT-EBINDP(IDX)
17607 POTLOW = POT-EBINDN(IDX)
17609 * final state particle not able to escape nucleus
17610 IF (PE.LE.POTLOW) THEN
17611 * check if there are wounded nucleons
17612 IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
17613 & EWOUND(IDX,NWOUND(IDX)))) THEN
17615 NWOUND(IDX) = NWOUND(IDX)-1
17617 * interaction prohibited by Pauli-principle
17618 NWOUND(1) = NWTMP(1)
17619 NWOUND(2) = NWTMP(2)
17628 NWOUND(1) = NWTMP(1)
17629 NWOUND(2) = NWTMP(2)
17633 IST = ISTHKK(IDXCAS)
17637 IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
17638 & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1
17640 IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 17
17645 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,NCAS)
17647 * first check if cascade step is forbidden due to Pauli-principle
17648 * (in case of absorpion this step is forced)
17649 IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
17650 & (IDFSP(I).EQ.8))) THEN
17651 * get nuclear potential barrier
17652 POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
17653 IF (IDFSP(I).EQ.1) THEN
17654 POTLOW = POT-EBINDP(IDX)
17656 POTLOW = POT-EBINDN(IDX)
17658 * final state particle not able to escape nucleus
17659 IF (PE.LE.POTLOW) THEN
17660 * check if there are wounded nucleons
17661 IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
17662 & EWOUND(IDX,NWOUND(IDX)))) THEN
17663 NWOUND(IDX) = NWOUND(IDX)-1
17667 * interaction prohibited by Pauli-principle
17668 NWOUND(1) = NWTMP(1)
17669 NWOUND(2) = NWTMP(2)
17673 c ELSEIF (PE.LE.POT) THEN
17674 cC ELSEIF ((PE.LE.POT).AND.(NWOUND(IDX).GE.1)) THEN
17675 cC NWOUND(IDX) = NWOUND(IDX)-1
17677 c NPAULI = NPAULI+1
17683 * dump final state particles for energy-momentum conservation check
17684 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),-PFSP(3,I),
17685 & -PFSP(4,I),2,IDUM,IDUM)
17691 IF (ABS(IST).EQ.1) THEN
17692 * transform particles back into n-n cms
17693 * LEPTO: leave final state particles in target rest frame
17694 C IF (MCGENE.EQ.3) THEN
17701 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17702 & PFSP(4,I),IDFSP(I),IMODE)
17704 ELSEIF ((ICAS.EQ.2).AND.(IST.EQ.15)) THEN
17705 * target cascade but fsp got stuck in proj. --> transform it into
17706 * proj. rest system
17707 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17708 & PFSP(4,I),IDFSP(I),-1)
17709 ELSEIF ((ICAS.EQ.1).AND.(IST.EQ.16)) THEN
17710 * proj. cascade but fsp got stuck in target --> transform it into
17711 * target rest system
17712 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17713 & PFSP(4,I),IDFSP(I),1)
17716 * dump final state particles into DTEVT1
17717 IGEN = IDCH(IDXCAS)+1
17718 ID = IDT_IPDGHA(IDFSP(I))
17720 IF (LABSOR) IXR = 99
17721 CALL DT_EVTPUT(IST,ID,IDXCAS,IDXSPE(1),PFSP(1,I),
17722 & PFSP(2,I),PFSP(3,I),PFSP(4,I),0,IXR,IGEN)
17724 * update the counter for particles which got stuck inside the nucleus
17725 IF ((IST.EQ.15).OR.(IST.EQ.16)) THEN
17727 IDXINC(NOINC) = NHKK
17730 * in case of absorption the spatial treatment is an approximate
17731 * solution anyway (the positions of the nucleons which "absorb" the
17732 * cascade particle are not taken into consideration) therefore the
17733 * particles are produced at the position of the cascade particle
17735 WHKK(K,NHKK) = WHKK(K,IDXCAS)
17736 VHKK(K,NHKK) = VHKK(K,IDXCAS)
17739 * DDISTL - distance the cascade particle moves to the intera. point
17740 * (the position where impact-parameter = distance to the interacting
17741 * nucleon), DIST - distance to the interacting nucleon at the time of
17742 * formation of the cascade particle, BINT - impact-parameter of this
17743 * cascade-interaction
17744 DDISTL = SQRT(DIST**2-BINT**2)
17745 DTIME = DDISTL/BECAS(ICAS)
17746 DTIMEL = DDISTL/BGCAS(ICAS)
17747 RDISTL = DTIMEL*BGCAS(I2)
17748 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17749 RTIME = RDISTL/BECAS(I2)
17753 * RDISTL, RTIME are this step and time in the rest system of the other
17756 VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+COSCAS(ICAS,K)*DDISTL
17757 VTXCA1(I2,K) = VTXCAS(I2,K) +COSCAS(I2,K) *RDISTL
17759 VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME
17760 VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME
17761 * position of particle production is half the impact-parameter to
17762 * the interacting nucleon
17764 WHKK(K,NHKK) = OHALF*(VTXCA1(1,K)+WHKK(K,IDXSPE(1)))
17765 VHKK(K,NHKK) = OHALF*(VTXCA1(2,K)+VHKK(K,IDXSPE(1)))
17767 * time of production of secondary = time of interaction
17768 WHKK(4,NHKK) = VTXCA1(1,4)
17769 VHKK(4,NHKK) = VTXCA1(2,4)
17774 * modify status and position of cascade particle (the latter for
17775 * statistics reasons only)
17777 IF (LABSOR) ISTHKK(IDXCAS) = 19
17778 IF (.NOT.LABSOR) THEN
17780 WHKK(K,IDXCAS) = VTXCA1(1,K)
17781 VHKK(K,IDXCAS) = VTXCA1(2,K)
17787 * dump interacting nucleons for energy-momentum conservation check
17789 & CALL DT_EVTEMC(PHKK(1,IS),PHKK(2,IS),PHKK(3,IS),PHKK(4,IS),
17791 * modify entry for interacting nucleons
17792 IF (ISTHKK(IS).EQ.12+ICAS) ISTHKK(IS)=16+ICAS
17793 IF (ISTHKK(IS).EQ.14+ICAS) ISTHKK(IS)=2
17795 JDAHKK(1,IS) = JDAHKK(1,IDXSPE(1))
17796 JDAHKK(2,IS) = JDAHKK(2,IDXSPE(1))
17800 * check energy-momentum conservation
17802 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,500,IREJ1)
17803 IF (IREJ1.NE.0) GOTO 9999
17808 NINCCO(ICAS,1) = NINCCO(ICAS,1)+1
17810 IF (IPROC.EQ.1) NINCCO(ICAS,2) = NINCCO(ICAS,2)+1
17811 IF (IPROC.EQ.2) NINCCO(ICAS,3) = NINCCO(ICAS,3)+1
17818 * transport-step but no cascade step due to configuration (i.e. there
17819 * is no nucleon for interaction etc.)
17822 C WHKK(K,IDXCAS) = VTXCAS(1,K)
17823 C VHKK(K,IDXCAS) = VTXCAS(2,K)
17824 WHKK(K,IDXCAS) = VTXCA1(1,K)
17825 VHKK(K,IDXCAS) = VTXCA1(2,K)
17830 * no cascade-step because of configuration
17831 * (i.e. hadron outside nucleus etc.)
17841 *$ CREATE DT_ABSORP.FOR
17844 *===absorp=============================================================*
17846 SUBROUTINE DT_ABSORP(IDCAS,PCAS,NCAS,NSPE,IDSPE,IDXSPE,MODE,IREJ)
17848 ************************************************************************
17849 * Two-nucleon absorption of antiprotons, pi-, and K-. *
17850 * Antiproton absorption is handled by HADRIN. *
17851 * The following channels for meson-absorption are considered: *
17852 * pi- + p + p ---> n + p *
17853 * pi- + p + n ---> n + n *
17854 * K- + p + p ---> sigma+ + n / Lam + p / sigma0 + p *
17855 * K- + p + n ---> sigma- + n / Lam + n / sigma0 + n *
17856 * K- + p + p ---> sigma- + n *
17857 * IDCAS, PCAS identity, momentum of particle to be absorbed *
17858 * NCAS = 1 intranuclear cascade in projectile *
17859 * = -1 intranuclear cascade in target *
17860 * NSPE number of spectator nucleons involved *
17861 * IDXSPE(2) DTEVT1-indices of spectator nucleons involved *
17862 * Revised version of the original STOPIK written by HJM and J. Ranft. *
17863 * This version dated 24.02.95 is written by S. Roesler *
17864 ************************************************************************
17866 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17869 PARAMETER ( LINP = 10 ,
17873 PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,ONE=1.0D0,
17874 & ONETHI=0.3333D0,TWOTHI=0.6666D0)
17878 PARAMETER (NMXHKK=200000)
17880 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17881 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17882 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17884 * extended event history
17885 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17886 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17889 * flags for input different options
17890 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17891 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17892 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17894 * final state after inc step
17895 PARAMETER (MAXFSP=10)
17896 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17898 * particle properties (BAMJET index convention)
17900 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17901 & IICH(210),IIBAR(210),K1(210),K2(210)
17903 DIMENSION PCAS(5),IDXSPE(2),IDSPE(2),PSPE(2,5),PSPE1(5),
17904 & PTOT3P(4),BG3P(4),
17905 & ECMF(2),PCMF(2),CODF(2),COFF(2),SIFF(2)
17910 * skip particles others than ap, pi-, K- for mode=0
17911 IF ((MODE.EQ.0).AND.
17912 & (IDCAS.NE.2).AND.(IDCAS.NE.14).AND.(IDCAS.NE.16)) RETURN
17913 * skip particles others than pions for mode=1
17914 * (2-nucleon absorption in intranuclear cascade)
17915 IF ((MODE.EQ.1).AND.
17916 & (IDCAS.NE.13).AND.(IDCAS.NE.14).AND.(IDCAS.NE.23)) RETURN
17919 IF (NUCAS.EQ.-1) NUCAS = 2
17921 IF (MODE.EQ.0) THEN
17922 * scan spectator nucleons for nucleons being able to "absorb"
17927 IF ((ISTHKK(I).EQ.12+NUCAS).OR.(ISTHKK(I).EQ.14+NUCAS)) THEN
17930 IDSPE(NSPE) = IDBAM(I)
17931 IF ((NSPE.EQ.1).AND.(IDCAS.EQ.2)) GOTO 2
17932 IF (NSPE.EQ.2) THEN
17933 IF ((IDCAS.EQ.14).AND.(IDSPE(1).EQ.8).AND.
17934 & (IDSPE(2).EQ.8)) THEN
17935 * there is no pi-+n+n channel
17947 * transform excited projectile nucleons (status=15) into proj. rest s.
17950 PSPE(I,K) = PHKK(K,IDXSPE(I))
17954 * antiproton absorption
17955 IF ((IDCAS.EQ.2).AND.(NSPE.GE.1)) THEN
17957 PSPE1(K) = PSPE(1,K)
17959 CALL DT_HADRIN(IDCAS,PCAS,IDSPE(1),PSPE1,1,IREJ1)
17960 IF (IREJ1.NE.0) GOTO 9999
17963 ELSEIF (((IDCAS.EQ.13).OR.(IDCAS.EQ.14).OR.(IDCAS.EQ.23)
17964 & .OR.(IDCAS.EQ.16)).AND.(NSPE.GE.2)) THEN
17965 IF (IDCAS.EQ.14) THEN
17969 IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) IDFSP(2) = 1
17970 ELSEIF (IDCAS.EQ.13) THEN
17974 IF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) IDFSP(2) = 8
17975 ELSEIF (IDCAS.EQ.23) THEN
17977 IDFSP(1) = IDSPE(1)
17978 IDFSP(2) = IDSPE(2)
17979 ELSEIF (IDCAS.EQ.16) THEN
17982 IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) THEN
17983 IF (R.LT.ONETHI) THEN
17986 ELSEIF (R.LT.TWOTHI) THEN
17993 ELSEIF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) THEN
17997 IF (R.LT.ONETHI) THEN
18000 ELSEIF (R.LT.TWOTHI) THEN
18009 * dump initial particles for energy-momentum cons. check
18011 CALL DT_EVTEMC(PCAS(1),PCAS(2),PCAS(3),PCAS(4),1,IDUM,IDUM)
18012 CALL DT_EVTEMC(PSPE(1,1),PSPE(1,2),PSPE(1,3),PSPE(1,4),2,
18014 CALL DT_EVTEMC(PSPE(2,1),PSPE(2,2),PSPE(2,3),PSPE(2,4),2,
18017 * get Lorentz-parameter of 3 particle initial state
18019 PTOT3P(K) = PCAS(K)+PSPE(1,K)+PSPE(2,K)
18021 P3P = SQRT(PTOT3P(1)**2+PTOT3P(2)**2+PTOT3P(3)**2)
18022 AM3P = SQRT( (PTOT3P(4)-P3P)*(PTOT3P(4)+P3P) )
18024 BG3P(K) = PTOT3P(K)/MAX(AM3P,TINY10)
18026 * 2-particle decay of the 3-particle compound system
18027 CALL DT_DTWOPD(AM3P,ECMF(1),ECMF(2),PCMF(1),PCMF(2),
18028 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
18029 & AAM(IDFSP(1)),AAM(IDFSP(2)))
18031 SDF = SQRT((ONE-CODF(I))*(ONE+CODF(I)))
18032 PX = PCMF(I)*COFF(I)*SDF
18033 PY = PCMF(I)*SIFF(I)*SDF
18034 PZ = PCMF(I)*CODF(I)
18035 CALL DT_DALTRA(BG3P(4),BG3P(1),BG3P(2),BG3P(3),PX,PY,PZ,
18036 & ECMF(I),PTOFSP,PFSP(1,I),PFSP(2,I),PFSP(3,I),
18038 PFSP(5,I) = SQRT( (PFSP(4,I)-PTOFSP)*(PFSP(4,I)+PTOFSP) )
18039 * check consistency of kinematics
18040 IF (ABS(AAM(IDFSP(I))-PFSP(5,I)).GT.TINY5) THEN
18041 WRITE(LOUT,1001) IDFSP(I),AAM(IDFSP(I)),PFSP(5,I)
18042 1001 FORMAT(1X,'ABSORP: warning! inconsistent',
18043 & ' tree-particle kinematics',/,20X,'id: ',I3,
18044 & ' AAM = ',E10.4,' MFSP = ',E10.4)
18046 * dump final state particles for energy-momentum cons. check
18047 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
18048 & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
18052 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,100,IREJ1)
18053 IF (IREJ1.NE.0) THEN
18054 WRITE(LOUT,*)'ABSORB: EMC ',AAM(IDFSP(1)),AAM(IDFSP(2)),
18060 IF (IOULEV(3).GT.0) WRITE(LOUT,1000) IDCAS,NSPE
18061 1000 FORMAT(1X,'ABSORP: warning! absorption for particle ',I3,
18062 & ' impossible',/,20X,'too few spectators (',I2,')')
18069 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in ABSORP'
18074 *$ CREATE DT_HADRIN.FOR
18077 *===hadrin=============================================================*
18079 SUBROUTINE DT_HADRIN(IDPR,PPR,IDTA,PTA,MODE,IREJ)
18081 ************************************************************************
18082 * Interface to the HADRIN-routines for inelastic and elastic *
18084 * IDPR,PPR(5) identity, momentum of projectile *
18085 * IDTA,PTA(5) identity, momentum of target *
18086 * MODE = 1 inelastic interaction *
18087 * = 2 elastic interaction *
18088 * Revised version of the original FHAD. *
18089 * This version dated 27.10.95 is written by S. Roesler *
18090 ************************************************************************
18092 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18095 PARAMETER ( LINP = 10 ,
18099 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,
18100 & TINY2=1.0D-2,TINY1=1.0D-1,ONE=1.0D0)
18102 LOGICAL LCORR,LMSSG
18104 * flags for input different options
18105 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18106 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18107 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18109 * final state after inc step
18110 PARAMETER (MAXFSP=10)
18111 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
18113 * particle properties (BAMJET index convention)
18115 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18116 & IICH(210),IIBAR(210),K1(210),K2(210)
18117 * output-common for DHADRI/ELHAIN
18119 * final state from HADRIN interaction
18120 PARAMETER (MAXFIN=10)
18121 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
18122 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
18124 DIMENSION PPR(5),PPR1(5),PTA(5),BGTA(4),
18125 & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4),IMCORR(2)
18127 DATA LMSSG /.TRUE./
18136 * dump initial particles for energy-momentum cons. check
18138 CALL DT_EVTEMC(PPR(1),PPR(2),PPR(3),PPR(4),1,IDUM,IDUM)
18139 CALL DT_EVTEMC(PTA(1),PTA(2),PTA(3),PTA(4),2,IDUM,IDUM)
18142 AMP2 = PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2
18143 AMT2 = PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2
18144 IF ((AMP2.LT.ZERO).OR.(AMT2.LT.ZERO).OR.
18145 & (ABS(AMP2-AAM(IDPR)**2).GT.TINY5).OR.
18146 & (ABS(AMT2-AAM(IDTA)**2).GT.TINY5)) THEN
18147 IF (LMSSG.AND.(IOULEV(3).GT.0))
18148 & WRITE(LOUT,1000) AMP2,AAM(IDPR)**2,AMT2,AAM(IDTA)**2
18149 1000 FORMAT(1X,'HADRIN: warning! inconsistent projectile/target',
18150 & ' mass',/,20X,'AMP2 = ',E12.4,', AAM(IDPR)**2 = ',
18151 & E12.4,/,20X,'AMT2 = ',E12.4,', AAM(IDTA)**2 = ',E12.4)
18156 * convert initial state particles into particles which can be
18157 * handled by HADRIN
18160 IF ((IDHPR.LE.0).OR.(IDHPR.GE.111).OR.LCORR) THEN
18161 IF ((IDHPR.LE.0).OR.(IDHPR.GE.111)) IDHPR = 1
18168 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
18169 IF (IREJ1.GT.0) THEN
18170 WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.'
18177 PPR(5) = SQRT(PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2)
18178 PTA(5) = SQRT(PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2)
18181 * Lorentz-parameter for trafo into rest-system of target
18183 BGTA(K) = PTA(K)/PTA(5)
18185 * transformation of projectile into rest-system of target
18186 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),PPR(1),PPR(2),
18187 & PPR(3),PPR(4),PPRTO1,PPR1(1),PPR1(2),PPR1(3),
18190 * direction cosines of projectile in target rest system
18191 CX = PPR1(1)/PPRTO1
18192 CY = PPR1(2)/PPRTO1
18193 CZ = PPR1(3)/PPRTO1
18195 * sample inelastic interaction
18196 IF (MODE.EQ.1) THEN
18197 CALL DT_DHADRI(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA)
18198 IF (IRH.EQ.1) GOTO 9998
18199 * sample elastic interaction
18200 ELSEIF (MODE.EQ.2) THEN
18201 CALL DT_ELHAIN(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA,IREJ1)
18202 IF (IREJ1.NE.0) THEN
18203 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in HADRIN'
18206 IF (IRH.EQ.1) GOTO 9998
18208 WRITE(LOUT,1001) MODE,INTHAD
18209 1001 FORMAT(1X,'HADRIN: warning! inconsistent interaction mode',
18210 & I4,' (INTHAD =',I4,')')
18214 * transform final state particles back into Lab.
18217 PX = CXRH(I)*PLRH(I)
18218 PY = CYRH(I)*PLRH(I)
18219 PZ = CZRH(I)*PLRH(I)
18220 CALL DT_DALTRA(BGTA(4),BGTA(1),BGTA(2),BGTA(3),
18221 & PX,PY,PZ,ELRH(I),PTOFSP,PFSP(1,NFSP),
18222 & PFSP(2,NFSP),PFSP(3,NFSP),PFSP(4,NFSP))
18223 IDFSP(NFSP) = ITRH(I)
18224 AMFSP2 = PFSP(4,NFSP)**2-PFSP(1,NFSP)**2-PFSP(2,NFSP)**2-
18226 IF (AMFSP2.LT.-TINY3) THEN
18227 WRITE(LOUT,1002) IDFSP(NFSP),PFSP(1,NFSP),PFSP(2,NFSP),
18228 & PFSP(3,NFSP),PFSP(4,NFSP),AMFSP2
18229 1002 FORMAT(1X,'HADRIN: warning! final state particle (id = ',
18230 & I2,') with negative mass^2',/,1X,5E12.4)
18233 PFSP(5,NFSP) = SQRT(ABS(AMFSP2))
18234 IF (ABS(PFSP(5,NFSP)-AAM(IDFSP(NFSP))).GT.TINY1) THEN
18235 WRITE(LOUT,1003) IDFSP(NFSP),AAM(IDFSP(NFSP)),
18237 1003 FORMAT(1X,'HADRIN: warning! final state particle',
18238 & ' (id = ',I2,') with inconsistent mass',/,1X,
18241 IF (KCORR.GT.2) GOTO 9999
18242 IMCORR(KCORR) = NFSP
18245 * dump final state particles for energy-momentum cons. check
18246 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
18247 & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
18250 * transform momenta on mass shell in case of inconsistencies in
18252 IF (KCORR.GT.0) THEN
18253 IF (KCORR.EQ.2) THEN
18257 IF (IMCORR(1).EQ.1) THEN
18265 IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I1),PFSP(2,I1),
18266 & PFSP(3,I1),PFSP(4,I1),2,IDUM,IDUM)
18267 IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I2),PFSP(2,I2),
18268 & PFSP(3,I2),PFSP(4,I2),2,IDUM,IDUM)
18270 P1IN(K) = PFSP(K,I1)
18271 P2IN(K) = PFSP(K,I2)
18273 XM1 = AAM(IDFSP(I1))
18274 XM2 = AAM(IDFSP(I2))
18275 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
18276 IF (IREJ1.GT.0) THEN
18277 WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.'
18281 PFSP(K,I1) = P1OUT(K)
18282 PFSP(K,I2) = P2OUT(K)
18284 PFSP(5,I1) = SQRT(PFSP(4,I1)**2-PFSP(1,I1)**2
18285 & -PFSP(2,I1)**2-PFSP(3,I1)**2)
18286 PFSP(5,I2) = SQRT(PFSP(4,I2)**2-PFSP(1,I2)**2
18287 & -PFSP(2,I2)**2-PFSP(3,I2)**2)
18288 * dump final state particles for energy-momentum cons. check
18289 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I1),-PFSP(2,I1),
18290 & -PFSP(3,I1),-PFSP(4,I1),2,IDUM,IDUM)
18291 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I2),-PFSP(2,I2),
18292 & -PFSP(3,I2),-PFSP(4,I2),2,IDUM,IDUM)
18295 * check energy-momentum conservation
18297 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,102,IREJ1)
18298 IF (IREJ1.NE.0) GOTO 9999
18312 *$ CREATE DT_HADCOL.FOR
18315 *===hadcol=============================================================*
18317 SUBROUTINE DT_HADCOL(IDPROJ,PPN,IDXTAR,IREJ)
18319 ************************************************************************
18320 * Interface to the HADRIN-routines for inelastic and elastic *
18321 * scattering. This subroutine samples hadron-nucleus interactions *
18322 * below DPM-threshold. *
18323 * IDPROJ BAMJET-index of projectile hadron *
18324 * PPN projectile momentum in target rest frame *
18325 * IDXTAR DTEVT1-index of target nucleon undergoing *
18326 * interaction with projectile hadron *
18327 * This subroutine replaces HADHAD. *
18328 * This version dated 5.5.95 is written by S. Roesler *
18329 ************************************************************************
18331 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18334 PARAMETER ( LINP = 10 ,
18338 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0)
18344 PARAMETER (NMXHKK=200000)
18346 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18347 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18348 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18350 * extended event history
18351 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18352 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18355 * nuclear potential
18357 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18358 & EBINDP(2),EBINDN(2),EPOT(2,210),
18359 & ETACOU(2),ICOUL,LFERMI
18361 * interface HADRIN-DPM
18362 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
18364 * parameter for intranuclear cascade
18366 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
18368 * final state after inc step
18369 PARAMETER (MAXFSP=10)
18370 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
18372 * particle properties (BAMJET index convention)
18374 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18375 & IICH(210),IIBAR(210),K1(210),K2(210)
18377 DIMENSION PPROJ(5),PNUC(5)
18379 DATA LSTART /.TRUE./
18386 **sr 6/9/01 commented
18387 C TAUFOR = TAUFOR/2.0D0
18391 1000 FORMAT(/,1X,'HADCOL: Scattering handled by HADRIN')
18392 WRITE(LOUT,1001) TAUFOR
18393 1001 FORMAT(/,1X,'HADCOL: Formation zone parameter set to ',
18398 IDNUC = IDBAM(IDXTAR)
18399 IDNUC1 = IDT_MCHAD(IDNUC)
18400 IDPRO1 = IDT_MCHAD(IDPROJ)
18402 IF ((INTHAD.EQ.1).OR.(INTHAD.EQ.2)) THEN
18406 C CALL DT_SIHNIN(IDPRO1,IDNUC1,PPN,SIGIN)
18407 C CALL DT_SIHNEL(IDPRO1,IDNUC1,PPN,SIGEL)
18409 CALL DT_XSHN(IDPRO1,IDNUC1,PPN,DUMZER,SIGTOT,SIGEL)
18410 SIGIN = SIGTOT-SIGEL
18411 C SIGTOT = SIGIN+SIGEL
18414 IF (DT_RNDM(SIGIN).LT.SIGEL/SIGTOT) IPROC = 2
18420 PPROJ(5) = AAM(IDPROJ)
18421 PPROJ(4) = SQRT(PPROJ(5)**2+PPROJ(3)**2)
18423 PNUC(K) = PHKK(K,IDXTAR)
18429 IF (ILOOP.GT.100) GOTO 9999
18431 CALL DT_HADRIN(IDPROJ,PPROJ,IDNUC,PNUC,IPROC,IREJ1)
18432 IF (IREJ1.EQ.1) GOTO 9999
18434 IF (IREJ1.GT.1) THEN
18435 * no interaction possible
18436 * require Pauli blocking
18437 IF ((IDPROJ.EQ.1).AND.(PPROJ(4).LE.PFERMP(2)+PPROJ(5))) GOTO 2
18438 IF ((IDPROJ.EQ.8).AND.(PPROJ(4).LE.PFERMN(2)+PPROJ(5))) GOTO 2
18439 IF ((IIBAR(IDPROJ).NE.1).AND.
18440 & (PPROJ(4).LE.EPOT(2,IDPROJ)+PPROJ(5))) GOTO 2
18441 * store incoming particle as final state particle
18442 CALL DT_LTNUC(PPROJ(3),PPROJ(4),PCMS,ECMS,3)
18443 CALL DT_EVTPUT(1,IDPROJ,1,0,PPROJ(1),PPROJ(2),PCMS,ECMS,0,0,0)
18446 * require Pauli blocking for final state nucleons
18448 IF ((IDFSP(I).EQ.1).AND.
18449 & (PFSP(4,I).LE.PFERMP(2)+AAM(IDFSP(I)))) GOTO 2
18450 IF ((IDFSP(I).EQ.8).AND.
18451 & (PFSP(4,I).LE.PFERMN(2)+AAM(IDFSP(I)))) GOTO 2
18452 IF ((IIBAR(IDFSP(I)).NE.1).AND.
18453 & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I))))GOTO 2
18455 * store final state particles
18458 IF ((IIBAR(IDFSP(I)).EQ.1).AND.
18459 & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I)))) IST = 16
18460 IDHAD = IDT_IPDGHA(IDFSP(I))
18461 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PCMS,ECMS,3)
18462 CALL DT_EVTPUT(IST,IDHAD,1,IDXTAR,PFSP(1,I),PFSP(2,I),
18464 IF (I.EQ.1) NPOINT(4) = NHKK
18465 VHKK(1,NHKK) = 0.5D0*(VHKK(1,1)+VHKK(1,IDXTAR))
18466 VHKK(2,NHKK) = 0.5D0*(VHKK(2,1)+VHKK(2,IDXTAR))
18467 VHKK(3,NHKK) = VHKK(3,IDXTAR)
18468 VHKK(4,NHKK) = VHKK(4,IDXTAR)
18469 WHKK(1,NHKK) = 0.5D0*(WHKK(1,1)+WHKK(1,IDXTAR))
18470 WHKK(2,NHKK) = 0.5D0*(WHKK(2,1)+WHKK(2,IDXTAR))
18471 WHKK(3,NHKK) = WHKK(3,1)
18472 WHKK(4,NHKK) = WHKK(4,1)
18483 *$ CREATE DT_GETEMU.FOR
18486 *===getemu=============================================================*
18488 SUBROUTINE DT_GETEMU(IT,ITZ,KKMAT,MODE)
18490 ************************************************************************
18491 * Sampling of emulsion component to be considered as target-nucleus. *
18492 * This version dated 6.5.95 is written by S. Roesler. *
18493 ************************************************************************
18495 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18498 PARAMETER ( LINP = 10 ,
18502 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
18504 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
18506 * emulsion treatment
18507 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
18510 * Glauber formalism: flags and parameters for statistics
18513 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
18515 IF (MODE.EQ.0) THEN
18517 RR = DT_RNDM(SUMFRA)
18520 DO 1 ICOMP=1,NCOMPO
18521 SUMFRA = SUMFRA+EMUFRA(ICOMP)
18522 IF (SUMFRA.GT.RR) THEN
18524 ITZ = IEMUCH(ICOMP)
18531 WRITE(LOUT,'(1X,A,E12.3)')
18532 & 'Warning! norm. failure within emulsion fractions',
18536 ELSEIF (MODE.EQ.1) THEN
18539 IDIFF = ABS(IT-IEMUMA(I))
18540 IF (IDIFF.LT.NDIFF) THEN
18549 * bypass for variable projectile/target/energy runs: the correct
18550 * Glauber data will be always loaded on kkmat=1
18551 IF (IOGLB.EQ.100) THEN
18558 *$ CREATE DT_NCLPOT.FOR
18561 *===nclpot=============================================================*
18563 SUBROUTINE DT_NCLPOT(IPZ,IP,ITZ,IT,AFERP,AFERT,MODE)
18565 ************************************************************************
18566 * Calculation of Coulomb and nuclear potential for a given configurat. *
18567 * IPZ, IP charge/mass number of proj. *
18568 * ITZ, IT charge/mass number of targ. *
18569 * AFERP,AFERT factors modifying proj./target pot. *
18570 * if =0, FERMOD is used *
18571 * MODE = 0 calculation of binding energy *
18572 * = 1 pre-calculated binding energy is used *
18573 * This version dated 16.11.95 is written by S. Roesler. *
18575 * Last change 28.12.2006 by S. Roesler. *
18576 ************************************************************************
18578 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18581 PARAMETER ( LINP = 10 ,
18585 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
18590 * particle properties (BAMJET index convention)
18592 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18593 & IICH(210),IIBAR(210),K1(210),K2(210)
18595 * nuclear potential
18597 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18598 & EBINDP(2),EBINDN(2),EPOT(2,210),
18599 & ETACOU(2),ICOUL,LFERMI
18601 DIMENSION IDXPOT(14)
18602 * ap an lam alam sig- sig+ sig0 tet0 tet- asig-
18603 DATA IDXPOT / 2, 9, 17, 18, 20, 21, 22, 97, 98, 99,
18604 * asig0 asig+ atet0 atet+
18605 & 100, 101, 102, 103/
18608 DATA LSTART /.TRUE./
18610 IF (MODE.EQ.0) THEN
18622 IF (AFERP.LE.ZERO) FERMIP = FERMOD
18624 IF (AFERT.LE.ZERO) FERMIT = FERMOD
18626 * Fermi momenta and binding energy for projectile
18627 IF ((IP.GT.1).AND.LFERMI) THEN
18628 IF (MODE.EQ.0) THEN
18629 C EBINDP(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ-1)
18630 C EBINDN(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ)
18634 C EBINDP(1) = 1.0D-3*(ENERGY(ONE,ONE)+ENERGY(BIP,BIPZ)
18635 C & -ENERGY(AIP,AIPZ))
18636 EBINDP(1) = 1.0D-3*(EXMSAZ(ONE,ONE ,.TRUE.,IZDUM)
18637 & +EXMSAZ(BIP,BIPZ,.TRUE.,IZDUM)
18638 & -EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM))
18640 IF (AIP.LE.AIPZ) THEN
18641 EBINDN(1) = EBINDP(1)
18642 WRITE(LOUT,*) ' DT_NCLPOT: AIP.LE.AIPZ (',AIP,AIPZ,')'
18645 C EBINDN(1) = 1.0D-3*(ENERGY(ONE,ZERO)+ENERGY(BIP,AIPZ)
18646 C & -ENERGY(AIP,AIPZ))
18647 EBINDN(1) = 1.0D-3*(EXMSAZ(ONE,ZERO,.TRUE.,IZDUM)
18648 & +EXMSAZ(BIP,AIPZ,.TRUE.,IZDUM)
18649 & -EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM))
18653 PFERMP(1) = FERMIP*AN*(AIPZ/AIP)**0.333333D0
18654 PFERMN(1) = FERMIP*AN*((AIP-AIPZ)/AIP)**0.33333D0
18659 * effective nuclear potential for projectile
18660 C EPOT(1,1) = PFERMP(1)**2/(2.0D0*AAM(1)) + EBINDP(1)
18661 C EPOT(1,8) = PFERMN(1)**2/(2.0D0*AAM(8)) + EBINDN(1)
18662 EPOT(1,1) = SQRT(PFERMP(1)**2+AAM(1)**2) -AAM(1) + EBINDP(1)
18663 EPOT(1,8) = SQRT(PFERMN(1)**2+AAM(8)**2) -AAM(8) + EBINDN(1)
18665 * Fermi momenta and binding energy for target
18666 IF ((IT.GT.1).AND.LFERMI) THEN
18667 IF (MODE.EQ.0) THEN
18668 C EBINDP(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ-1)
18669 C EBINDN(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ)
18673 C EBINDP(2) = 1.0D-3*(ENERGY(ONE,ONE)+ENERGY(BIT,BITZ)
18674 C & -ENERGY(AIT,AITZ))
18675 EBINDP(2) = 1.0D-3*(EXMSAZ(ONE,ONE, .TRUE.,IZDUM)
18676 & +EXMSAZ(BIT,BITZ,.TRUE.,IZDUM)
18677 & -EXMSAZ(AIT,AITZ,.TRUE.,IZDUM))
18679 IF (AIT.LE.AITZ) THEN
18680 EBINDN(2) = EBINDP(2)
18681 WRITE(LOUT,*) ' DT_NCLPOT: AIT.LE.AIPT (',AIT,AIPT,')'
18684 C EBINDN(2) = 1.0D-3*(ENERGY(ONE,ZERO)+ENERGY(BIT,AITZ)
18685 C & -ENERGY(AIT,AITZ))
18686 EBINDN(2) = 1.0D-3*(EXMSAZ(ONE,ZERO,.TRUE.,IZDUM)
18687 & +EXMSAZ(BIT,AITZ,.TRUE.,IZDUM)
18688 & -EXMSAZ(AIT,AITZ,.TRUE.,IZDUM))
18692 PFERMP(2) = FERMIT*AN*(AITZ/AIT)**0.333333D0
18693 PFERMN(2) = FERMIT*AN*((AIT-AITZ)/AIT)**0.33333D0
18698 * effective nuclear potential for target
18699 C EPOT(2,1) = PFERMP(2)**2/(2.0D0*AAM(1)) + EBINDP(2)
18700 C EPOT(2,8) = PFERMN(2)**2/(2.0D0*AAM(8)) + EBINDN(2)
18701 EPOT(2,1) = SQRT(PFERMP(2)**2+AAM(1)**2) -AAM(1) + EBINDP(2)
18702 EPOT(2,8) = SQRT(PFERMN(2)**2+AAM(8)**2) -AAM(8) + EBINDN(2)
18705 EPOT(1,IDXPOT(I)) = EPOT(1,8)
18706 EPOT(2,IDXPOT(I)) = EPOT(2,8)
18712 IF (ICOUL.EQ.1) THEN
18714 & ETACOU(1) = 0.001116D0*AIPZ/(1.0D0+AIP**0.333D0)
18716 & ETACOU(2) = 0.001116D0*AITZ/(1.0D0+AIT**0.333D0)
18720 WRITE(LOUT,1000) IP,IPZ,IT,ITZ,EBINDP,EBINDN,
18721 & EPOT(1,1)-EBINDP(1),EPOT(2,1)-EBINDP(2),
18722 & EPOT(1,8)-EBINDN(1),EPOT(2,8)-EBINDN(2),
18724 1000 FORMAT(/,/,1X,'NCLPOT: quantities for inclusion of nuclear'
18725 & ,' effects',/,12X,'---------------------------',
18726 & '----------------',/,/,38X,'projectile',
18727 & ' target',/,/,1X,'Mass number / charge',
18728 & 17X,I3,' /',I3,6X,I3,' /',I3,/,1X,'Binding energy -',
18729 & ' proton (GeV) ',2E14.4,/,17X,'- neutron (GeV)'
18730 & ,1X,2E14.4,/,1X,'Fermi-potential - proton (GeV)',
18731 & 1X,2E14.4,/,17X,'- neutron (GeV) ',2E14.4,/,/,
18732 & 1X,'Scale factor for Fermi-momentum ',F4.2,/,
18733 & /,1X,'Coulomb-energy ',2(E14.4,' GeV '),/,/)
18740 *$ CREATE DT_RESNCL.FOR
18743 *===resncl=============================================================*
18745 SUBROUTINE DT_RESNCL(EPN,NLOOP,MODE)
18747 ************************************************************************
18748 * Treatment of residual nuclei and nuclear effects. *
18749 * MODE = 1 initializations *
18750 * = 2 treatment of final state *
18751 * This version dated 16.11.95 is written by S. Roesler. *
18753 * Last change 05.01.2007 by S. Roesler. *
18754 ************************************************************************
18756 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18759 PARAMETER ( LINP = 10 ,
18763 PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,THREE=3.D0,TINY3=1.0D-3,
18764 & TINY2=1.0D-2,TINY1=1.0D-1,TINY4=1.0D-4,TINY10=1.0D-10,
18765 & ONETHI=ONE/THREE)
18766 PARAMETER (AMUAMU = 0.93149432D0,
18769 PARAMETER ( EMVGEV = 1.0 D-03 )
18770 PARAMETER ( AMUGEV = 0.93149432 D+00 )
18771 PARAMETER ( AMPRTN = 0.93827231 D+00 )
18772 PARAMETER ( AMNTRN = 0.93956563 D+00 )
18773 PARAMETER ( AMELCT = 0.51099906 D-03 )
18774 PARAMETER ( HLFHLF = 0.5D+00 )
18775 PARAMETER ( FERTHO = 14.33 D-09 )
18776 PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
18777 PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
18778 PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
18782 PARAMETER (NMXHKK=200000)
18784 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18785 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18786 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18788 * extended event history
18789 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18790 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18793 * particle properties (BAMJET index convention)
18795 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18796 & IICH(210),IIBAR(210),K1(210),K2(210)
18798 * flags for input different options
18799 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18800 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18801 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18803 * nuclear potential
18805 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18806 & EBINDP(2),EBINDN(2),EPOT(2,210),
18807 & ETACOU(2),ICOUL,LFERMI
18809 * properties of interacting particles
18810 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
18812 * properties of photon/lepton projectiles
18813 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
18815 * Lorentz-parameters of the current interaction
18816 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
18817 & UMO,PPCM,EPROJ,PPROJ
18819 * treatment of residual nuclei: wounded nucleons
18820 COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
18822 * treatment of residual nuclei: 4-momenta
18823 LOGICAL LRCLPR,LRCLTA
18824 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18825 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18827 DIMENSION PFSP(4),PSEC(4),PSEC0(4)
18828 DIMENSION PMOMB(5000),IDXB(5000),PMOMM(10000),IDXM(10000),
18829 & IDXCOR(15000),IDXOTH(NMXHKK)
18833 *------- initializations
18836 * initialize arrays for residual nuclei
18851 * correction of projectile 4-momentum for effective target pot.
18852 * and Coulomb-energy (in case of hadron-nucleus interaction only)
18853 IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
18856 * positively charged hadron - check energy for Coloumb pot.
18857 IF (IICH(IJPROJ).EQ.1) THEN
18858 THRESH = ETACOU(2)+AAM(IJPROJ)
18859 IF (EPNI.LE.THRESH) THEN
18861 1000 FORMAT(/,1X,'KKINC: WARNING! projectile energy',
18862 & ' below Coulomb threshold - event rejected',/)
18866 * negatively charged hadron - increase energy by Coulomb energy
18867 ELSEIF (IICH(IJPROJ).EQ.-1) THEN
18868 EPNI = EPNI+ETACOU(2)
18870 IF ((IJPROJ.EQ.1).OR.(IJPROJ.EQ.8)) THEN
18871 * Effective target potential
18872 *sr 6.6. binding energy only (to avoid negative exc. energies)
18873 C EPNI = EPNI+EPOT(2,IJPROJ)
18875 IF ((IJPROJ.NE.1).AND.(ABS(EPOT(2,IJPROJ)).GT.5.0D-3))
18876 & EBIPOT = EBINDN(2)
18877 EPNI = EPNI+ABS(EBIPOT)
18878 * re-initialization of DTLTRA
18881 CALL DT_LTINI(IJPROJ,IJTARG,EPNI,DUM1,DUM2,0)
18885 * projectile in n-n cms
18886 IF ((IP.LE.1).AND.(IT.GT.1)) THEN
18887 PMASS1 = AAM(IJPROJ)
18889 C IF (IJPROJ.EQ.7) PMASS1 = AAM(33)
18890 IF (IJPROJ.EQ.7) PMASS1 = AAM(IJPROJ)-SQRT(VIRT)
18892 PM1 = SIGN(PMASS1**2,PMASS1)
18893 PM2 = SIGN(PMASS2**2,PMASS2)
18894 PINIPR(4) = (UMO**2-PM2+PM1)/(TWO*UMO)
18896 IF (PMASS1.GT.ZERO) THEN
18897 PINIPR(3) = SQRT((PINIPR(4)-PINIPR(5))
18898 & *(PINIPR(4)+PINIPR(5)))
18900 PINIPR(3) = SQRT(PINIPR(4)**2-PM1)
18905 C PINITA(5) = AIT*AMUAMU+1.0D-3*ENERGY(AIT,AITZ)
18906 PINITA(5) = AIT*AMUC12+EMVGEV*EXMSAZ(AIT,AITZ,.TRUE.,IZDUM)
18908 CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
18909 ELSEIF ((IP.GT.1).AND.(IT.LE.1)) THEN
18911 PMASS2 = AAM(IJTARG)
18912 PM1 = SIGN(PMASS1**2,PMASS1)
18913 PM2 = SIGN(PMASS2**2,PMASS2)
18914 PINITA(4) = (UMO**2-PM1+PM2)/(TWO*UMO)
18916 PINITA(3) = -SQRT((PINITA(4)-PINITA(5))
18917 & *(PINITA(4)+PINITA(5)))
18921 C PINIPR(5) = AIP*AMUAMU+1.0D-3*ENERGY(AIP,AIPZ)
18922 PINIPR(5) = AIP*AMUC12+EMVGEV*EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM)
18924 CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
18925 ELSEIF ((IP.GT.1).AND.(IT.GT.1)) THEN
18929 C PINIPR(5) = AIP*AMUAMU+1.0D-3*ENERGY(AIP,AIPZ)
18930 PINIPR(5) = AIP*AMUC12+EMVGEV*EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM)
18932 CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
18936 C PINITA(5) = AIT*AMUAMU+1.0D-3*ENERGY(AIT,AITZ)
18937 PINITA(5) = AIT*AMUC12+EMVGEV*EXMSAZ(AIT,AITZ,.TRUE.,IZDUM)
18939 CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
18944 *------- treatment of final state
18948 IF (NLOOP.GT.1) SCPOT = 0.10D0
18949 C WRITE(LOUT,*) 'event ',NEVHKK,NLOOP,SCPOT
18961 DO 900 I=NPOINT(4),NHKK
18963 IF (ISTHKK(I).EQ.1) THEN
18964 IF (IDBAM(I).EQ.7) GOTO 900
18967 * particle moving into forward direction
18968 IF (PHKK(3,I).GE.ZERO) THEN
18969 * most likely to be effected by projectile potential
18971 * there is no projectile nucleus, try target
18972 IF ((IP.LE.1).OR.((IP-NPW).LE.1)) THEN
18974 IF (IP.GT.1) IOTHER = 1
18975 * there is no target nucleus --> skip
18976 IF ((IT.LE.1).OR.((IT-NTW).LE.1)) GOTO 900
18978 * particle moving into backward direction
18980 * most likely to be effected by target potential
18982 * there is no target nucleus, try projectile
18983 IF ((IT.LE.1).OR.((IT-NTW).LE.1)) THEN
18985 IF (IT.GT.1) IOTHER = 1
18986 * there is no projectile nucleus --> skip
18987 IF ((IP.LE.1).OR.((IP-NPW).LE.1)) GOTO 900
18991 * nobam=3: particle is in overlap-region or neither inside proj. nor target
18992 * =1: particle is not in overlap-region AND is inside target (2)
18993 * =2: particle is not in overlap-region AND is inside projectile (1)
18994 * flag particles which are inside the nucleus ipot but not in its
18996 IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) IFLG = IPOT
18997 IF (IDBAM(I).NE.0) THEN
18998 * baryons: keep all nucleons and all others where flag is set
18999 IF (IIBAR(IDBAM(I)).NE.0) THEN
19000 IF ((IDBAM(I).EQ.1).OR.(IDBAM(I).EQ.8).OR.(IFLG.GT.0))
19003 PMOMB(NOB) = PHKK(3,I)
19004 IDXB(NOB) = SIGN(10000000*IABS(IFLG)
19005 & +1000000*IOTHER+I,IFLG)
19007 * mesons: keep only those mesons where flag is set
19009 IF (IFLG.GT.0) THEN
19011 PMOMM(NOM) = PHKK(3,I)
19012 IDXM(NOM) = 10000000*IFLG+1000000*IOTHER+I
19019 * sort particles in the arrays according to increasing long. momentum
19020 CALL DT_SORT1(PMOMB,IDXB,NOB,1,NOB,1)
19021 CALL DT_SORT1(PMOMM,IDXM,NOM,1,NOM,1)
19023 * shuffle indices into one and the same array according to the later
19024 * sequence of correction
19028 IF (PMOMB(I).GT.ZERO) GOTO 911
19030 IDXCOR(NCOR) = IDXB(I)
19036 IF (PMOMB(I).LT.ZERO) GOTO 913
19038 IDXCOR(NCOR) = IDXB(I)
19043 IF (PMOMB(I).GT.ZERO) THEN
19045 IDXCOR(NCOR) = IDXB(I)
19053 IDXCOR(NCOR) = IDXB(I)
19057 IF (PMOMM(I).GT.ZERO) GOTO 926
19059 IDXCOR(NCOR) = IDXM(I)
19064 IF (PMOMM(I).LT.ZERO) GOTO 928
19066 IDXCOR(NCOR) = IDXM(I)
19070 C IF (NEVHKK.EQ.484) THEN
19071 C WRITE(LOUT,9000) JPCW,JPW-JPCW,JTCW,JTW-JTCW
19072 C 9000 FORMAT(1X,'wounded nucleons (proj.-p,n targ.-p,n)',/,4I10)
19073 C WRITE(LOUT,9001) NOB,NOM,NCOR
19074 C 9001 FORMAT(1X,'produced particles (baryons,mesons,all)',3I10)
19075 C WRITE(LOUT,'(/,A)') ' baryons '
19077 CC J = IABS(IDXB(I))
19078 CC INDEX = J-IABS(J/10000000)*10000000
19079 C IPOT = IABS(IDXB(I))/10000000
19080 C IOTHER = IABS(IDXB(I))/1000000-IPOT*10
19081 C INDEX = IABS(IDXB(I))-IPOT*10000000-IOTHER*1000000
19082 C WRITE(LOUT,9002) I,INDEX,IDXB(I),IDBAM(INDEX),PMOMB(I)
19084 C WRITE(LOUT,'(/,A)') ' mesons '
19086 CC INDEX = IDXM(I)-IABS(IDXM(I)/10000000)*10000000
19087 C IPOT = IABS(IDXM(I))/10000000
19088 C IOTHER = IABS(IDXM(I))/1000000-IPOT*10
19089 C INDEX = IABS(IDXM(I))-IPOT*10000000-IOTHER*1000000
19090 C WRITE(LOUT,9002) I,INDEX,IDXM(I),IDBAM(INDEX),PMOMM(I)
19092 C 9002 FORMAT(1X,4I14,E14.5)
19093 C WRITE(LOUT,'(/,A)') ' all '
19095 CC J = IABS(IDXCOR(I))
19096 CC INDEX = J-IABS(J/10000000)*10000000
19097 CC IPOT = IABS(IDXCOR(I))/10000000
19098 C IOTHER = IABS(IDXCOR(I))/1000000-IPOT*10
19099 C INDEX = IABS(IDXCOR(I))-IPOT*10000000-IOTHER*1000000
19100 C WRITE(LOUT,9003) I,INDEX,IDXCOR(I),IDBAM(INDEX)
19102 C 9003 FORMAT(1X,4I14)
19106 IPOT = IABS(IDXCOR(ICOR))/10000000
19107 IOTHER = IABS(IDXCOR(ICOR))/1000000-IPOT*10
19108 I = IABS(IDXCOR(ICOR))-IPOT*10000000-IOTHER*1000000
19113 * reduction of particle momentum by corresponding nuclear potential
19114 * (this applies only if Fermi-momenta are requested)
19118 * Lorentz-transformation into the rest system of the selected nucleus
19120 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
19121 & PSEC(1),PSEC(2),PSEC(3),PSEC(4),IDSEC,IMODE)
19122 PSECO = SQRT(PSEC(1)**2+PSEC(2)**2+PSEC(3)**2)
19123 AMSEC = SQRT(ABS((PSEC(4)-PSECO)*(PSEC(4)+PSECO)))
19127 IF ((EPROJ.GE.1.0D4).AND.(IDSEC.EQ.7)) CHKLEV = TINY1
19128 IF (EPROJ.GE.2.0D6) CHKLEV = 1.0D0
19129 IF (ABS(AMSEC-AAM(IDSEC)).GT.CHKLEV) THEN
19130 IF (IOULEV(3).GT.0)
19131 & WRITE(LOUT,2000) I,NEVHKK,IDSEC,AMSEC,AAM(IDSEC)
19132 2000 FORMAT(1X,'RESNCL: inconsistent mass of particle',
19133 & ' at entry ',I5,' (evt.',I8,')',/,' IDSEC: ',
19134 & I4,' AMSEC: ',E12.3,' AAM(IDSEC): ',E12.3,/)
19142 * the correction for nuclear potential effects is applied to as many
19143 * p/n as many nucleons were wounded; the momenta of other final state
19144 * particles are corrected only if they materialize inside the corresp.
19145 * nucleus (here: NOBAM = 1 part. outside proj., = 2 part. outside targ
19146 * = 3 part. outside proj. and targ., >=10 in overlapping region)
19147 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) THEN
19148 IF (IPOT.EQ.1) THEN
19149 IF ((JPW.GT.0).AND.(IOTHER.EQ.0)) THEN
19150 * this is most likely a wounded nucleon
19152 C RDIST = SQRT((VHKK(1,IPW(JPW))/FM2MM)**2
19153 C & +(VHKK(2,IPW(JPW))/FM2MM)**2
19154 C & +(VHKK(3,IPW(JPW))/FM2MM)**2)
19155 C RAD = RNUCLE*DBLE(IP)**ONETHI
19156 C FDEN = 1.4D0*DT_DENSIT(IP,RDIST,RAD)
19157 C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
19159 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19163 * correct only if part. was materialized inside nucleus
19164 * and if it is ouside the overlapping region
19165 IF ((NOBAM(I).NE.1).AND.(NOBAM(I).LT.3)) THEN
19166 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19170 ELSEIF (IPOT.EQ.2) THEN
19171 IF ((JTW.GT.0).AND.(IOTHER.EQ.0)) THEN
19172 * this is most likely a wounded nucleon
19174 C RDIST = SQRT((VHKK(1,ITW(JTW))/FM2MM)**2
19175 C & +(VHKK(2,ITW(JTW))/FM2MM)**2
19176 C & +(VHKK(3,ITW(JTW))/FM2MM)**2)
19177 C RAD = RNUCLE*DBLE(IT)**ONETHI
19178 C FDEN = 1.4D0*DT_DENSIT(IT,RDIST,RAD)
19179 C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
19181 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19185 * correct only if part. was materialized inside nucleus
19186 IF ((NOBAM(I).NE.2).AND.(NOBAM(I).LT.3)) THEN
19187 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19193 IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) THEN
19194 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19199 IF (NLOOP.EQ.1) THEN
19200 * Coulomb energy correction:
19201 * the treatment of Coulomb potential correction is similar to the
19202 * one for nuclear potential
19203 IF (IDSEC.EQ.1) THEN
19204 IF ((IPOT.EQ.1).AND.(JPCW.GT.0)) THEN
19206 ELSEIF ((IPOT.EQ.2).AND.(JTCW.GT.0)) THEN
19209 IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
19212 IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
19214 IF (IICH(IDSEC).EQ.1) THEN
19215 * pos. particles: check if they are able to escape Coulomb potential
19216 IF (PSEC(4).LT.AMSEC+ETACOU(IPOT)) THEN
19217 ISTHKK(I) = 14+IPOT
19218 IF (ISTHKK(I).EQ.15) THEN
19220 PHKK(K,I) = PSEC0(K)
19221 TRCLPR(K) = TRCLPR(K)+PSEC0(K)
19223 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
19224 IF (IDSEC.EQ.1) NPCW = NPCW-1
19225 ELSEIF (ISTHKK(I).EQ.16) THEN
19227 PHKK(K,I) = PSEC0(K)
19228 TRCLTA(K) = TRCLTA(K)+PSEC0(K)
19230 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
19231 IF (IDSEC.EQ.1) NTCW = NTCW-1
19235 ELSEIF (IICH(IDSEC).EQ.-1) THEN
19236 * neg. particles: decrease energy by Coulomb-potential
19237 PSEC(4) = PSEC(4)-ETACOU(IPOT)
19244 IF (PSEC(4).LT.AMSEC) THEN
19245 IF (IOULEV(6).GT.0)
19246 & WRITE(LOUT,2001) I,IDSEC,PSEC(4),AMSEC
19247 2001 FORMAT(1X,'KKINC: particle at DTEVT1-pos. ',I5,
19248 & ' is not allowed to escape nucleus',/,
19249 & 8X,'id : ',I3,' reduced energy: ',E15.4,
19251 ISTHKK(I) = 14+IPOT
19252 IF (ISTHKK(I).EQ.15) THEN
19254 PHKK(K,I) = PSEC0(K)
19255 TRCLPR(K) = TRCLPR(K)+PSEC0(K)
19257 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
19258 IF (IDSEC.EQ.1) NPCW = NPCW-1
19259 ELSEIF (ISTHKK(I).EQ.16) THEN
19261 PHKK(K,I) = PSEC0(K)
19262 TRCLTA(K) = TRCLTA(K)+PSEC0(K)
19264 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
19265 IF (IDSEC.EQ.1) NTCW = NTCW-1
19270 IF (JPMOD.EQ.1) THEN
19271 PSECN = SQRT( (PSEC(4)-AMSEC)*(PSEC(4)+AMSEC) )
19272 * 4-momentum after correction for nuclear potential
19274 PSEC(K) = PSEC(K)*PSECN/PSECO
19277 * store recoil momentum from particles escaping the nuclear potentials
19279 IF (IPOT.EQ.1) THEN
19280 TRCLPR(K) = TRCLPR(K)+PSEC0(K)-PSEC(K)
19281 ELSEIF (IPOT.EQ.2) THEN
19282 TRCLTA(K) = TRCLTA(K)+PSEC0(K)-PSEC(K)
19286 * transform momentum back into n-n cms
19288 CALL DT_LTRANS(PSEC(1),PSEC(2),PSEC(3),PSEC(4),
19289 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
19297 PFSP(K) = PFSP(K)+PHKK(K,I)
19302 DO 33 I=NPOINT(4),NHKK
19303 IF ((ISTHKK(I).EQ.1).AND.(IDXOTH(I).LT.0)) THEN
19304 PFSP(1) = PFSP(1)+PHKK(1,I)
19305 PFSP(2) = PFSP(2)+PHKK(2,I)
19306 PFSP(3) = PFSP(3)+PHKK(3,I)
19307 PFSP(4) = PFSP(4)+PHKK(4,I)
19312 PRCLPR(K) = TRCLPR(K)
19313 PRCLTA(K) = TRCLTA(K)
19316 IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
19317 * hadron-nucleus interactions: get residual momentum from energy-
19318 * momentum conservation
19321 PRCLTA(K) = PINIPR(K)+PINITA(K)-PFSP(K)
19324 * nucleus-hadron, nucleus-nucleus: get residual momentum from
19325 * accumulated recoil momenta of particles leaving the spectators
19326 * transform accumulated recoil momenta of residual nuclei into
19330 CALL DT_LTNUC(PZI,PEI,PRCLPR(3),PRCLPR(4),2)
19333 CALL DT_LTNUC(PZI,PEI,PRCLTA(3),PRCLTA(4),3)
19334 C IF (IP.GT.1) THEN
19335 PRCLPR(3) = PRCLPR(3)+PINIPR(3)
19336 PRCLPR(4) = PRCLPR(4)+PINIPR(4)
19339 PRCLTA(3) = PRCLTA(3)+PINITA(3)
19340 PRCLTA(4) = PRCLTA(4)+PINITA(4)
19344 * check momenta of residual nuclei
19346 CALL DT_EVTEMC(-PINIPR(1),-PINIPR(2),-PINIPR(3),-PINIPR(4),
19348 CALL DT_EVTEMC(-PINITA(1),-PINITA(2),-PINITA(3),-PINITA(4),
19350 CALL DT_EVTEMC(PRCLPR(1),PRCLPR(2),PRCLPR(3),PRCLPR(4),
19352 CALL DT_EVTEMC(PRCLTA(1),PRCLTA(2),PRCLTA(3),PRCLTA(4),
19354 CALL DT_EVTEMC(PFSP(1),PFSP(2),PFSP(3),PFSP(4),2,IDUM,IDUM)
19355 **sr 19.12. changed to avoid output when used with phojet
19358 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,501,IREJ1)
19359 C IF ((NEVHKK.EQ.409).OR.(NEVHKK.EQ.460).OR.(NEVHKK.EQ.765))
19360 C & CALL DT_EVTOUT(4)
19361 IF (IREJ1.GT.0) RETURN
19367 *$ CREATE DT_SCN4BA.FOR
19370 *===scn4ba=============================================================*
19372 SUBROUTINE DT_SCN4BA
19374 ************************************************************************
19375 * SCan /DTEVT1/ 4 BAryons which are not able to escape nuclear pot. *
19376 * This version dated 12.12.95 is written by S. Roesler. *
19377 ************************************************************************
19379 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19382 PARAMETER ( LINP = 10 ,
19386 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
19391 PARAMETER (NMXHKK=200000)
19393 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
19394 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
19395 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
19397 * extended event history
19398 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
19399 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
19402 * particle properties (BAMJET index convention)
19404 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19405 & IICH(210),IIBAR(210),K1(210),K2(210)
19407 * properties of interacting particles
19408 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
19410 * nuclear potential
19412 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
19413 & EBINDP(2),EBINDN(2),EPOT(2,210),
19414 & ETACOU(2),ICOUL,LFERMI
19416 * treatment of residual nuclei: wounded nucleons
19417 COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
19419 * treatment of residual nuclei: 4-momenta
19420 LOGICAL LRCLPR,LRCLTA
19421 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
19422 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
19424 DIMENSION PLAB(2,5),PCMS(4)
19428 * get number of wounded nucleons
19445 * projectile nucleons wounded in primary interaction and in fzc
19446 IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.17)) THEN
19450 IF (IDHKK(I).EQ.2212) NPCW = NPCW+1
19451 IF (ISTHKK(I).EQ.11) NPW0 = NPW0+1
19452 C IF (IP.GT.1) THEN
19454 TRCLPR(K) = TRCLPR(K)-PHKK(K,I)
19457 * target nucleons wounded in primary interaction and in fzc
19458 ELSEIF ((ISTHKK(I).EQ.12).OR.(ISTHKK(I).EQ.18)) THEN
19462 IF (IDHKK(I).EQ.2212) NTCW = NTCW+1
19463 IF (ISTHKK(I).EQ.12) NTW0 = NTW0+1
19466 TRCLTA(K) = TRCLTA(K)-PHKK(K,I)
19469 ELSEIF (ISTHKK(I).EQ.13) THEN
19471 ELSEIF (ISTHKK(I).EQ.14) THEN
19476 DO 11 I=NPOINT(4),NHKK
19477 * baryons which are unable to escape the nuclear potential of proj.
19478 IF (ISTHKK(I).EQ.15) THEN
19481 IF (IIBAR(IDBAM(I)).NE.0) THEN
19483 IF (IICH(IDBAM(I)).GT.0) NPCW = NPCW-1
19486 TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
19488 * baryons which are unable to escape the nuclear potential of targ.
19489 ELSEIF (ISTHKK(I).EQ.16) THEN
19492 IF (IIBAR(IDBAM(I)).NE.0) THEN
19494 IF (IICH(IDBAM(I)).GT.0) NTCW = NTCW-1
19497 TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
19502 * residual nuclei so far
19506 * ckeck for "residual nuclei" consisting of one nucleon only
19507 * treat it as final state particle
19508 IF (IRESP.EQ.1) THEN
19510 IST = ISTHKK(ISGLPR)
19511 CALL DT_LTRANS(PHKK(1,ISGLPR),PHKK(2,ISGLPR),
19512 & PHKK(3,ISGLPR),PHKK(4,ISGLPR),
19513 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,2)
19514 IF (IST.EQ.13) THEN
19515 ISTHKK(ISGLPR) = 11
19519 CALL DT_EVTPUT(1,IDHKK(ISGLPR),ISGLPR,0,
19520 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),
19521 & IDRES(ISGLPR),IDXRES(ISGLPR),IDCH(ISGLPR))
19522 NOBAM(NHKK) = NOBAM(ISGLPR)
19523 JDAHKK(1,ISGLPR) = NHKK
19525 TRCLPR(K) = TRCLPR(K)-PHKK(K,ISGLPR)
19528 IF (IREST.EQ.1) THEN
19530 IST = ISTHKK(ISGLTA)
19531 CALL DT_LTRANS(PHKK(1,ISGLTA),PHKK(2,ISGLTA),
19532 & PHKK(3,ISGLTA),PHKK(4,ISGLTA),
19533 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,3)
19534 IF (IST.EQ.14) THEN
19535 ISTHKK(ISGLTA) = 12
19539 CALL DT_EVTPUT(1,IDHKK(ISGLTA),ISGLTA,0,
19540 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),
19541 & IDRES(ISGLTA),IDXRES(ISGLTA),IDCH(ISGLTA))
19542 NOBAM(NHKK) = NOBAM(ISGLTA)
19543 JDAHKK(1,ISGLTA) = NHKK
19545 TRCLTA(K) = TRCLTA(K)-PHKK(K,ISGLTA)
19549 * get nuclear potential corresp. to the residual nucleus
19554 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
19556 * baryons unable to escape the nuclear potential are treated as
19557 * excited nucleons (ISTHKK=15,16)
19558 DO 3 I=NPOINT(4),NHKK
19559 IF (ISTHKK(I).EQ.1) THEN
19561 IF ( ((ID.EQ.1).OR.(ID.EQ.8)).AND.(NOBAM(I).NE.3) ) THEN
19562 * final state n and p not being outside of both nuclei are considered
19565 IF ( (IP.GT.1) .AND.(IRESP.GT.1).AND.
19566 & (NOBAM(I).NE.1).AND.(NPW.GT.0) ) THEN
19567 * Lorentz-trsf. into proj. rest sys. for those being inside proj.
19568 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
19569 & PHKK(4,I),PLAB(1,1),PLAB(1,2),PLAB(1,3),
19571 PLABT = SQRT(PLAB(1,1)**2+PLAB(1,2)**2+PLAB(1,3)**2)
19572 PLAB(1,5) = SQRT(ABS( (PLAB(1,4)-PLABT)*
19573 & (PLAB(1,4)+PLABT) ))
19574 EKIN = PLAB(1,4)-PLAB(1,5)
19575 IF (EKIN.LE.EPOT(1,ID)) NPOTP = 15
19576 IF ((ID.EQ.1).AND.(NPCW.LE.0)) NPOTP = 1
19578 IF ( (IT.GT.1) .AND.(IREST.GT.1).AND.
19579 & (NOBAM(I).NE.2).AND.(NTW.GT.0) ) THEN
19580 * Lorentz-trsf. into targ. rest sys. for those being inside targ.
19581 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
19582 & PHKK(4,I),PLAB(2,1),PLAB(2,2),PLAB(2,3),
19584 PLABT = SQRT(PLAB(2,1)**2+PLAB(2,2)**2+PLAB(2,3)**2)
19585 PLAB(2,5) = SQRT(ABS( (PLAB(2,4)-PLABT)*
19586 & (PLAB(2,4)+PLABT) ))
19587 EKIN = PLAB(2,4)-PLAB(2,5)
19588 IF (EKIN.LE.EPOT(2,ID)) NPOTT = 16
19589 IF ((ID.EQ.1).AND.(NTCW.LE.0)) NPOTT = 1
19591 IF (PHKK(3,I).GE.ZERO) THEN
19593 IF (NPOTP.NE.1) ISTHKK(I) = NPOTP
19596 IF (NPOTT.NE.1) ISTHKK(I) = NPOTT
19598 IF (ISTHKK(I).NE.1) THEN
19601 PHKK(K,I) = PLAB(J,K)
19603 IF (ISTHKK(I).EQ.15) THEN
19605 IF (ID.EQ.1) NPCW = NPCW-1
19607 TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
19609 ELSEIF (ISTHKK(I).EQ.16) THEN
19611 IF (ID.EQ.1) NTCW = NTCW-1
19613 TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
19621 * again: get nuclear potential corresp. to the residual nucleus
19626 c AFERP = 1.2D0*FERMOD*(ONE+(DBLE(IP+10-NPW0)/DBLE(IP+10))**1.1D0)
19627 cC AFERP = 1.21D0*FERMOD*(ONE+(DBLE(IP+40-NPW0)/DBLE(IP+40))**1.1D0)
19628 c & *(0.94D0+0.3D0*EXP(-DBLE(NPW0)/5.0D0)) /2.0D0
19630 c AFERT = 1.2D0*FERMOD*(ONE+(DBLE(IT+10-NTW0)/DBLE(IT+10))**1.1D0)
19631 cC AFERT = 1.21D0*FERMOD*(ONE+(DBLE(IT+40-NTW0)/DBLE(IT+40))**1.1D0)
19632 c & *(0.94D0+0.3D0*EXP(-DBLE(NTW0)/5.0D0)) /2.0D0
19634 C IF (AFERP.LT.FERMOD) AFERP = FERMOD+0.1
19635 C IF (AFERT.LT.FERMOD) AFERT = FERMOD+0.1
19636 C IF (AFERP.GT.0.85D0) AFERP = 0.85D0
19637 C IF (AFERT.GT.0.85D0) AFERT = 0.85D0
19638 AFERP = FERMOD+0.1D0
19639 AFERT = FERMOD+0.1D0
19641 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,AFERP,AFERT,1)
19646 *$ CREATE DT_FICONF.FOR
19649 *===ficonf=============================================================*
19651 SUBROUTINE DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ)
19653 ************************************************************************
19654 * Treatment of FInal CONFiguration including evaporation, fission and *
19655 * Fermi-break-up (for light nuclei only). *
19656 * Adopted from the original routine FINALE and extended to residual *
19657 * projectile nuclei. *
19658 * This version dated 12.12.95 is written by S. Roesler. *
19660 * Last change 27.12.2006 by S. Roesler. *
19661 ************************************************************************
19663 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19666 PARAMETER ( LINP = 10 ,
19670 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
19671 PARAMETER (ANGLGB=5.0D-16)
19675 PARAMETER (NMXHKK=200000)
19677 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
19678 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
19679 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
19681 * extended event history
19682 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
19683 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
19686 * rejection counter
19687 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
19688 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
19689 & IREXCI(3),IRDIFF(2),IRINC
19691 * central particle production, impact parameter biasing
19692 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
19694 * particle properties (BAMJET index convention)
19696 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19697 & IICH(210),IIBAR(210),K1(210),K2(210)
19699 * treatment of residual nuclei: 4-momenta
19700 LOGICAL LRCLPR,LRCLTA
19701 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
19702 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
19704 * treatment of residual nuclei: properties of residual nuclei
19705 COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
19706 & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
19707 & NTOTFI(2),NPROFI(2)
19709 * statistics: residual nuclei
19710 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
19711 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
19712 & NINCST(2,4),NINCEV(2),
19713 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
19714 & NRESPB(2),NRESCH(2),NRESEV(4),
19715 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
19718 * flags for input different options
19719 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
19720 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
19721 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
19723 * INCLUDE '(DIMPAR)'
19724 * DIMPAR taken from FLUKA
19725 PARAMETER ( MXXRGN =20000 )
19726 PARAMETER ( MXXMDF = 710 )
19727 PARAMETER ( MXXMDE = 702 )
19728 PARAMETER ( MFSTCK =40000 )
19729 PARAMETER ( MESTCK = 100 )
19730 PARAMETER ( MOSTCK = 2000 )
19731 PARAMETER ( MXPRSN = 100 )
19732 PARAMETER ( MXPDPM = 800 )
19733 PARAMETER ( MXPSCS =30000 )
19734 PARAMETER ( MXGLWN = 300 )
19735 PARAMETER ( MXOUTU = 50 )
19736 PARAMETER ( NALLWP = 64 )
19737 PARAMETER ( NELEMX = 80 )
19738 PARAMETER ( MPDPDX = 18 )
19739 PARAMETER ( MXHTTR = 260 )
19740 PARAMETER ( MXSEAX = 20 )
19741 PARAMETER ( MXHTNC = MXSEAX + 1 )
19742 PARAMETER ( ICOMAX = 2400 )
19743 PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
19744 PARAMETER ( NSTBIS = 304 )
19745 PARAMETER ( NQSTIS = 46 )
19746 PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
19747 PARAMETER ( MXPABL = 120 )
19748 PARAMETER ( IDMAXP = 450 )
19749 PARAMETER ( IDMXDC = 2000 )
19750 PARAMETER ( MXMCIN = 410 )
19751 PARAMETER ( IHYPMX = 4 )
19752 PARAMETER ( MKBMX1 = 11 )
19753 PARAMETER ( MKBMX2 = 11 )
19754 PARAMETER ( MXIRRD = 2500 )
19755 PARAMETER ( MXTRDC = 1500 )
19756 PARAMETER ( NKTL = 17 )
19757 PARAMETER ( NBLNMX = 40000000 )
19759 * INCLUDE '(GENSTK)'
19760 * GENSTK taken from FLUKA
19761 COMMON / GENSTK / CXR (MXPSCS), CYR (MXPSCS),
19762 & CZR (MXPSCS), CXRPOL (MXPSCS), CYRPOL (MXPSCS),
19763 & CZRPOL (MXPSCS), TKI (MXPSCS), PLR (MXPSCS),
19764 & WEI (MXPSCS), AGESEC (MXPSCS), TV , TVCMS ,
19765 & TVRECL, TVHEAV, TVBIND,
19766 & KPART (MXPSCS), INFEXT (MXPSCS), NP0 , NP
19768 * INCLUDE '(RESNUC)'
19769 * RESNUC from FLUKA
19770 LOGICAL LRNFSS, LFRAGM
19771 COMMON /RESNUC/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
19772 & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
19773 & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES,
19774 & PYRES, PZRES, PTRES2, ANGRES, ANXRES, ANYRES,
19775 & ANZRES, TVESTR, ANESTR, BHYRES (IHYPMX),
19776 & KTARP, KTARN, IGREYP, IGREYN, IPDPM0, IPDPM1,
19777 & IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE, ICRES,
19778 & IBRES, ISTRES, ISMRES, IHYRES, IEVAPL, IEVAPH,
19779 & IEVPHO, IEVNEU, IEVPRO, IEVDEU, IEVTRI, IEV3HE,
19780 & IEV4HE, IDEEXG, IBTAR, ICHTAR, IBLEFT, ICLEFT,
19781 & ICESTR, IBESTR, IOTHER, KHYRES (IHYPMX),
19784 PARAMETER ( EMVGEV = 1.0 D-03 )
19785 PARAMETER ( AMUGEV = 0.93149432 D+00 )
19786 PARAMETER ( AMPRTN = 0.93827231 D+00 )
19787 PARAMETER ( AMNTRN = 0.93956563 D+00 )
19788 PARAMETER ( AMELCT = 0.51099906 D-03 )
19789 PARAMETER ( ELCCGS = 4.8032068 D-10 )
19790 PARAMETER ( ELCMKS = 1.60217733 D-19 )
19791 PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
19793 PARAMETER ( HLFHLF = 0.5D+00 )
19794 PARAMETER ( FERTHO = 14.33 D-09 )
19795 PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
19796 PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
19797 PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
19799 * INCLUDE '(NUCDAT)'
19801 PARAMETER ( AMUAMU = AMUGEV )
19802 PARAMETER ( AMPROT = AMPRTN )
19803 PARAMETER ( AMNEUT = AMNTRN )
19804 PARAMETER ( AMELEC = AMELCT )
19805 PARAMETER ( R0NUCL = 1.12 D+00 )
19806 PARAMETER ( RCCOUL = 1.7 D+00 )
19807 PARAMETER ( COULPR = COUGFM )
19808 PARAMETER ( AMHYDR = AMPRTN + AMELCT )
19809 PARAMETER ( AMHTON = AMHYDR - AMNTRN )
19810 PARAMETER ( AMNTOU = AMNTRN - AMUC12 )
19811 PARAMETER ( AMUCSQ = AMUC12 * AMUC12 )
19812 PARAMETER ( EBNDAV = HLFHLF * (AMPRTN + AMNTRN) - AMUC12 )
19813 * Gammin : threshold for deexcitation gammas production, set to 1 keV
19814 * (this means that up to 1 keV of energy unbalancing can occur
19816 PARAMETER ( GAMMIN = 1.0D-06 )
19817 PARAMETER ( GAMNSQ = 2.0D+00 * GAMMIN * GAMMIN )
19818 * Tvepsi : "epsilon" for excitation energy, set to gammin / 100
19819 PARAMETER ( TVEPSI = GAMMIN / 100.D+00 )
19821 COMMON /NUCDAT/ AV0WEL, APFRMX, AEFRMX, AEFRMA,
19822 & RDSNUC, V0WELL (2), PFRMMX (2), EFRMMX (2),
19823 & EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2),
19824 & VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2),
19825 & PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2),
19826 & EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2),
19827 & ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV ,
19828 & AMRCSQ , ATO1O3 , ZTO1O3 , FRMRFC ,
19831 * INCLUDE '(PAREVT)'
19833 PARAMETER ( FRDIFF = 0.2D+00 )
19834 PARAMETER ( ETHSEA = 1.0D+00 )
19836 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
19837 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
19838 & LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR,
19839 & LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
19840 COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
19841 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
19842 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
19843 & LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LPHDRC,
19844 & LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, LRVKIN,
19845 & LVP2XX, LV2XNW, LNWV2X, LEVFIN
19847 * INCLUDE '(FHEAVY)'
19849 PARAMETER ( MXHEAV = 100 )
19850 PARAMETER ( KXHEAV = 30 )
19852 COMMON / FHEAVY / CXHEAV (MXHEAV), CYHEAV (MXHEAV),
19853 & CZHEAV (MXHEAV), TKHEAV (MXHEAV),
19854 & PHEAVY (MXHEAV), WHEAVY (MXHEAV),
19855 & AGHEAV (MXHEAV), BHHEAV (IHYPMX,KXHEAV),
19856 & AMHEAV (KXHEAV), AMNHEA (KXHEAV),
19857 & KHEAVY (MXHEAV), INFHEA (MXHEAV),
19858 & ICHEAV (KXHEAV), IBHEAV (KXHEAV),
19859 & IMHEAV (KXHEAV), IHHEAV (KXHEAV),
19860 & KHHEAV (IHYPMX,KXHEAV), NPHEAV
19861 COMMON / FHEAVC / ANHEAV (KXHEAV)
19864 COMMON /DTEVNO/ NEVENT,ICASCA
19866 DIMENSION INUC(2),IDXPAR(2),IDPAR(2),AIF(2),AIZF(2),AMRCL(2),
19867 & PRCL(2,4),MO1(2),MO2(2),VRCL(2,4),WRCL(2,4),
19868 & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4)
19870 DIMENSION EXPNUC(2),EXC(2,260),NEXC(2,260)
19872 DATA EXC,NEXC /520*ZERO,520*0/
19873 DATA EXPNUC /4.0D-3,4.0D-3/
19879 * skip residual nucleus treatment if not requested or in case
19880 * of central collisions
19881 IF ((.NOT.LEVPRT).OR.(ICENTR.GT.0).OR.(ICENTR.EQ.-1)) RETURN
19908 * number of final state particles
19909 IF (ABS(ISTHKK(I)).EQ.1) THEN
19914 * properties of remaining nucleon configurations
19916 IF ((ISTHKK(I).EQ.13).OR.(ISTHKK(I).EQ.15)) KF = 1
19917 IF ((ISTHKK(I).EQ.14).OR.(ISTHKK(I).EQ.16)) KF = 2
19919 IF (MO1(KF).EQ.0) MO1(KF) = I
19921 * position of residual nucleus = average position of nucleons
19923 VRCL(KF,K) = VRCL(KF,K)+VHKK(K,I)
19924 WRCL(KF,K) = WRCL(KF,K)+WHKK(K,I)
19926 * total number of particles contributing to each residual nucleus
19927 NTOT(KF) = NTOT(KF)+1
19930 * total charge of residual nuclei
19931 NQ(KF) = NQ(KF)+IICH(IDTMP)
19932 * number of protons
19933 IF (IDHKK(I).EQ.2212) THEN
19934 NPRO(KF) = NPRO(KF)+1
19935 * number of neutrons
19936 ELSEIF (IDHKK(I).EQ.2112) THEN
19939 * number of baryons other than n, p
19940 IF (IIBAR(IDTMP).EQ.1) THEN
19942 IF (IICH(IDTMP).EQ.1) NHPOS(KF) = NHPOS(KF)+1
19944 * any other mesons (status set to 1)
19945 C WRITE(LOUT,1002) KF,IDTMP
19946 C1002 FORMAT(1X,'FICONF: residual nucleus ',I2,
19947 C & ' containing meson ',I4,', status set to 1')
19950 IDXTMP = IDXPAR(KF)
19951 NTOT(KF) = NTOT(KF)-1
19955 IDXPAR(KF) = IDXTMP
19959 * reject elastic events (def: one final state particle = projectile)
19960 IF ((IP.EQ.1).AND.(NFSP.EQ.1).AND.(IDFSP.EQ.IJPROJ)) THEN
19961 IREXCI(3) = IREXCI(3)+1
19966 * check if one nucleus disappeared..
19967 C IF ((IP.GT.1).AND.(NTOT(1).EQ.0).AND.(NTOT(2).NE.0)) THEN
19969 C PRCLTA(K) = PRCLTA(K)+PRCLPR(K)
19972 C ELSEIF ((IT.GT.1).AND.(NTOT(2).EQ.0).AND.(NTOT(1).NE.0)) THEN
19974 C PRCLPR(K) = PRCLPR(K)+PRCLTA(K)
19983 * get the average of the nucleon positions
19984 VRCL(I,K) = VRCL(I,K)/MAX(NTOT(I),1)
19985 WRCL(I,K) = WRCL(I,K)/MAX(NTOT(I),1)
19986 IF (I.EQ.1) PRCL(1,K) = PRCLPR(K)
19987 IF (I.EQ.2) PRCL(2,K) = PRCLTA(K)
19989 * mass number and charge of residual nuclei
19990 AIF(I) = DBLE(NTOT(I))
19991 AIZF(I) = DBLE(NPRO(I)+NHPOS(I))
19992 IF (NTOT(I).GT.1) THEN
19993 * masses of residual nuclei in ground state
19995 C AMRCL0(I) = AIF(I)*AMUAMU+1.0D-3*ENERGY(AIF(I),AIZF(I))
19996 AMRCL0(I) = AIF(I)*AMUC12
19997 & +EMVGEV*EXMSAZ(AIF(I),AIZF(I),.TRUE.,IZDUM)
19999 * masses of residual nuclei
20000 PTORCL = SQRT(PRCL(I,1)**2+PRCL(I,2)**2+PRCL(I,3)**2)
20001 AMRCL(I) = (PRCL(I,4)-PTORCL)*(PRCL(I,4)+PTORCL)
20002 IF (AMRCL(I).GT.ZERO) AMRCL(I) = SQRT(AMRCL(I))
20004 * M_res^2 < 0 : configuration not allowed
20006 * a) re-calculate E_exc with scaled nuclear potential
20007 * (conditional jump to label 9998)
20008 * b) or reject event if N_loop(max) is exceeded
20009 * (conditional jump to label 9999)
20011 IF (AMRCL(I).LE.ZERO) THEN
20012 IF (IOULEV(3).GT.0)
20013 & WRITE(LOUT,1000) I,PRCL(I,1),PRCL(I,2),PRCL(I,3),
20015 1000 FORMAT(1X,'warning! negative excitation energy',/,
20019 IF (NLOOP.LE.500) THEN
20022 IREXCI(2) = IREXCI(2)+1
20026 * 0 < M_res < M_res0 : mass below ground-state mass
20028 * a) we had residual nuclei with mass N_tot and reasonable E_exc
20029 * before- assign average E_exc of those configurations to this
20030 * one ( Nexc(i,N_tot) > 0 )
20031 * b) or (and this applies always if run in transport codes) go up
20032 * one mass number and
20033 * i) if mass now larger than proj/targ mass or if run in
20034 * transport codes assign average E_exc per wounded nucleon
20035 * x number of wounded nucleons (Inuc-Ntot)
20036 * ii) or assign average E_exc of those configurations to this
20037 * one ( Nexc(i,m) > 0 )
20039 ELSEIF ((AMRCL(I).GT.ZERO).AND.(AMRCL(I).LT.AMRCL0(I)))
20041 M = MIN(NTOT(I),260)
20042 IF (NEXC(I,M).GT.0) THEN
20043 AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
20047 **sr corrected 27.12.06
20048 * IF (M.GE.INUC(I)) THEN
20049 * AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I))
20050 IF ((M.GE.INUC(I)).OR.(ICASCA.GT.0)) THEN
20051 IF ( INUC (I) .GT. NTOT (I) ) THEN
20052 AMRCL(I) = AMRCL0(I)
20053 & + EXPNUC(I)*DBLE(MAX(INUC(I)-NTOT(I),0))
20055 AMRCL(I) = AMRCL0(I) + 0.5D+00 * EXPNUC(I)
20059 IF (NEXC(I,M).GT.0) THEN
20060 AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
20066 EEXC(I) = AMRCL(I)-AMRCL0(I)
20069 * M_res > 2.5 x M_res0 : unreasonably(?) high E_exc
20071 * a) re-calculate E_exc with scaled nuclear potential
20072 * (conditional jump to label 9998)
20073 * b) or reject event if N_loop(max) is exceeded
20074 * (conditional jump to label 9999)
20077 ELSEIF (AMRCL(I).GE.2.5D0*AMRCL0(I)) THEN
20078 IF (IOULEV(3).GT.0)
20079 & WRITE(LOUT,1004) I,AMRCL(I),AMRCL0(I),NTOT,NEVHKK
20080 1004 FORMAT(1X,'warning! too high excitation energy',/,
20081 & I4,1P,2E15.4,3I5)
20084 IF (NLOOP.LE.500) THEN
20087 IREXCI(2) = IREXCI(2)+1
20091 * Otherwise (reasonable E_exc) :
20092 * E_exc = M_res - M_res0
20093 * in addition: calculate and save E_exc per wounded nucleon as
20094 * well as E_exc in <E_exc> counter
20097 * excitation energies of residual nuclei
20098 EEXC(I) = AMRCL(I)-AMRCL0(I)
20099 **sr 27.12.06 new excitation energy correction by A.F.
20101 * all parts with Ilcopt<3 commented since not used
20103 * still to be done/decided:
20104 * Increase Icor and put back both residual nuclei on mass shell
20105 * with the exciting correction further below.
20106 * For the moment the modification in the excitation energy is simply
20107 * corrected by scaling the energy of the residual nucleus.
20112 NNCHIT = MAX ( INUC (I) - NTOT (I), 0 )
20113 IF ( ILCOPT .LE. 2 ) THEN
20114 C* Patch for Fermi momentum reduction correlated with impact parameter:
20115 C FRMRDC = MIN ( (PFRMAV(INUC(I))/APFRMX)**3, ONE )
20116 C DLKPRH = 0.1D+00 + 0.5D+00 / SQRT(DBLE(INUC(I)))
20117 C AKPRHO = ONE - DLKPRH
20118 C* f x K rho_cen + (1-f) x 0.5 x K rho_cen = frmrdc x rho_cen
20119 C FRCFLL = MAX ( 2.D+00 * FRMRDC / AKPRHO - ONE,
20121 C* REDORI = 0.75D+00
20123 C REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
20126 RDCORE = 1.14D+00 * DBLE(INUC(I))**(ONE/3.D+00)
20127 * Take out roughly one/half of the skin:
20128 RDCORE = RDCORE - 0.5D+00
20130 PRSKIN = (RDCORE+2.4D+00)**3 - FRCFLL
20131 PRSKIN = 0.5D+00 * PRSKIN / ( PRSKIN + FRCFLL )
20132 FRCFLL = ONE - PRSKIN
20133 FRMRDC = FRCFLL + 0.5D+00 * PRSKIN
20134 REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
20136 IF ( NNCHIT .GT. 0 ) THEN
20137 C IF ( ILCOPT .EQ. 1 ) THEN
20138 C SKINRH = ONE - FRCFLL / (DBLE(INUC(I))-ONE)
20139 C DO 1220 NCH = 1, 10
20140 C ETAETA = ( ONE - SKINRH**INUC(I)
20141 C & - DBLE(INUC(I))* ( ONE - FRCFLL )
20142 C & * ( ONE - SKINRH ) )
20143 C & / ( SKINRH**INUC(I) - DBLE (INUC(I))
20144 C & * ( ONE - FRCFLL) * SKINRH )
20145 C SKINRH = SKINRH * ( ONE + ETAETA )
20147 C PRSKIN = SKINRH**(NNCHIT-1)
20148 C ELSE IF ( ILCOPT .EQ. 2 ) THEN
20149 C PRSKIN = ONE - FRCFLL
20152 DO 1230 NCH = 1, NNCHIT
20153 IF (DT_RNDM(PRFRMI) .LT. PRSKIN) THEN
20154 PRFRMI = (( ONE - 2.D+00 * DLKPRH )
20155 & * DT_RNDM(PRFRMI))**0.333333333333D+00
20157 PRFRMI = ( ONE - 2.D+00 * DLKPRH
20158 & * DT_RNDM(PRFRMI))**0.333333333333D+00
20160 REDCTN = REDCTN + PRFRMI**2
20162 REDCTN = REDCTN / DBLE (NNCHIT)
20166 EEXC (I) = EEXC (I) * REDCTN / REDORI
20167 AMRCL (I) = AMRCL0 (I) + EEXC (I)
20168 PRCL(I,4) = SQRT ( PTORCL**2 + AMRCL(I)**2 )
20171 IF (ICASCA.EQ.0) THEN
20172 EXPNUC(I) = EEXC(I)/MAX(1,INUC(I)-NTOT(I))
20173 M = MIN(NTOT(I),260)
20174 EXC(I,M) = EXC(I,M)+EEXC(I)
20175 NEXC(I,M) = NEXC(I,M)+1
20178 ELSEIF (NTOT(I).EQ.1) THEN
20180 1003 FORMAT(1X,'FICONF: warning! NTOT(I)=1? (I=',I3,')')
20190 PRCLPR(5) = AMRCL(1)
20191 PRCLTA(5) = AMRCL(2)
20193 IF (ICOR.GT.0) THEN
20194 IF (INORCL.EQ.0) THEN
20195 * one or both residual nuclei consist of one nucleon only, transform
20196 * this nucleon on mass shell
20198 P1IN(K) = PRCL(1,K)
20199 P2IN(K) = PRCL(2,K)
20203 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
20204 IF (IREJ1.GT.0) THEN
20205 WRITE(LOUT,*) 'ficonf-mashel rejection'
20209 PRCL(1,K) = P1OUT(K)
20210 PRCL(2,K) = P2OUT(K)
20211 PRCLPR(K) = P1OUT(K)
20212 PRCLTA(K) = P2OUT(K)
20214 PRCLPR(5) = AMRCL(1)
20215 PRCLTA(5) = AMRCL(2)
20217 IF (IOULEV(3).GT.0)
20218 & WRITE(LOUT,1001) NEVHKK,INT(AIF(1)),INT(AIZF(1)),
20219 & INT(AIF(2)),INT(AIZF(2)),AMRCL0(1),
20220 & AMRCL(1),AMRCL(1)-AMRCL0(1),AMRCL0(2),
20221 & AMRCL(2),AMRCL(2)-AMRCL0(2)
20222 1001 FORMAT(1X,'FICONF: warning! no residual nucleus for',
20223 & ' correction',/,11X,'at event',I8,
20224 & ', nucleon config. 1:',2I4,' 2:',2I4,
20226 IF (NLOOP.LE.500) THEN
20229 IREXCI(1) = IREXCI(1)+1
20235 C IF (NRESEV(1).NE.NEVHKK) THEN
20236 C NRESEV(1) = NEVHKK
20237 C NRESEV(2) = NRESEV(2)+1
20239 NRESEV(2) = NRESEV(2)+1
20241 EXCDPM(I) = EXCDPM(I)+EEXC(I)
20242 EXCDPM(I+2) = EXCDPM(I+2)+(EEXC(I)/MAX(NTOT(I),1))
20243 NRESTO(I) = NRESTO(I)+NTOT(I)
20244 NRESPR(I) = NRESPR(I)+NPRO(I)
20245 NRESNU(I) = NRESNU(I)+NN(I)
20246 NRESBA(I) = NRESBA(I)+NH(I)
20247 NRESPB(I) = NRESPB(I)+NHPOS(I)
20248 NRESCH(I) = NRESCH(I)+NQ(I)
20254 * initialize evaporation counter
20256 IF ((INUC(I).GT.1).AND.(AIF(I).GT.ONE).AND.
20257 & (EEXC(I).GT.ZERO)) THEN
20258 * put residual nuclei into DTEVT1
20260 JMASS = INT( AIF(I))
20261 JCHAR = INT(AIZF(I))
20262 * the following patch is required to transmit the correct excitation
20264 IF (ITRSPT.EQ.1) THEN
20265 IF ((ABS(AMRCL(I)-AMRCL0(I)-EEXC(I)).GT.1.D-04).AND.
20266 & (IOULEV(3).GT.0))
20268 & ' DT_FICONF:AMRCL(I),AMRCL0(I),EEXC(I)',
20269 & AMRCL(I),AMRCL0(I),EEXC(I)
20271 PRCL(I,4) =SQRT(AMRCL(I)**2+PRCL(I,1)**2+PRCL(I,2)**2
20273 IF (ABS(PRCL0-PRCL(I,4)).GT.0.1D0) THEN
20275 & ' PRCL(I,4) recalculated :',PRCL0,PRCL(I,4)
20278 CALL DT_EVTPUT(1000,IDRCL,MO1(I),MO2(I),PRCL(I,1),
20279 & PRCL(I,2),PRCL(I,3),PRCL(I,4),JMASS,JCHAR,0)
20284 VHKK(J,NHKK) = VRCL(I,J)
20285 WHKK(J,NHKK) = WRCL(I,J)
20287 * interface to evaporation module - fill final residual nucleus into
20289 * fill resnuc only if code is not used as event generator in Fluka
20290 IF (ITRSPT.NE.1) THEN
20294 IBRES = NPRO(I)+NN(I)+NH(I)
20295 ICRES = NPRO(I)+NHPOS(I)
20298 PTRES = SQRT(PXRES**2+PYRES**2+PZRES**2)
20299 * ground state mass of the residual nucleus (should be equal to AM0T)
20302 AMMRES = AMNAMA ( AMNRES, IBRES, ICRES )
20306 * kinetic energy of residual nucleus
20307 TVRECL = PRCL(I,4)-AMRCL(I)
20308 * excitation energy of residual nucleus
20311 PTRES = SQRT(ABS(TVRECL*(TVRECL+
20312 & 2.0D0*(AMMRES+TVCMS))))
20313 IF (PTOLD.LT.ANGLGB) THEN
20314 CALL DT_RACO(PXRES,PYRES,PZRES)
20317 PXRES = PXRES*PTRES/PTOLD
20318 PYRES = PYRES*PTRES/PTOLD
20319 PZRES = PZRES*PTRES/PTOLD
20320 * zero counter of secondaries from evaporation
20330 * put evaporated particles and residual nuclei to DTEVT1
20332 CALL DT_EVA2HE(MO,EXCITF,I,IREJ1)
20335 EXCEVA(I) = EXCEVA(I)+EXCITF
20342 C9998 IREXCI(1) = IREXCI(1)+1
20351 *$ CREATE DT_EVA2HE.FOR
20354 *====eva2he============================================================*
20356 SUBROUTINE DT_EVA2HE(MO,EEXCF,IRCL,IREJ)
20358 ************************************************************************
20359 * Interface between common's of evaporation module (FKFINU,FKFHVY) *
20361 * MO DTEVT1-index of "mother" (residual) nucleus before evap. *
20362 * EEXCF exitation energy of residual nucleus after evaporation *
20363 * IRCL = 1 projectile residual nucleus *
20364 * = 2 target residual nucleus *
20365 * This version dated 19.04.95 is written by S. Roesler. *
20367 * Last change 27.12.2006 by S. Roesler. *
20368 ************************************************************************
20370 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20373 PARAMETER ( LINP = 10 ,
20377 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3)
20381 PARAMETER (NMXHKK=200000)
20383 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
20384 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
20385 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
20386 * Note: DTEVT2 - special use for heavy fragments !
20387 * (IDRES(I) = mass number, IDXRES(I) = charge)
20389 * extended event history
20390 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
20391 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
20394 * particle properties (BAMJET index convention)
20396 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20397 & IICH(210),IIBAR(210),K1(210),K2(210)
20399 * flags for input different options
20400 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
20401 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
20402 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
20404 * statistics: residual nuclei
20405 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
20406 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
20407 & NINCST(2,4),NINCEV(2),
20408 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
20409 & NRESPB(2),NRESCH(2),NRESEV(4),
20410 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
20413 * treatment of residual nuclei: properties of residual nuclei
20414 COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
20415 & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
20416 & NTOTFI(2),NPROFI(2)
20418 * INCLUDE '(DIMPAR)'
20420 PARAMETER ( MXXRGN =20000 )
20421 PARAMETER ( MXXMDF = 710 )
20422 PARAMETER ( MXXMDE = 702 )
20423 PARAMETER ( MFSTCK =40000 )
20424 PARAMETER ( MESTCK = 100 )
20425 PARAMETER ( MOSTCK = 2000 )
20426 PARAMETER ( MXPRSN = 100 )
20427 PARAMETER ( MXPDPM = 800 )
20428 PARAMETER ( MXPSCS =30000 )
20429 PARAMETER ( MXGLWN = 300 )
20430 PARAMETER ( MXOUTU = 50 )
20431 PARAMETER ( NALLWP = 64 )
20432 PARAMETER ( NELEMX = 80 )
20433 PARAMETER ( MPDPDX = 18 )
20434 PARAMETER ( MXHTTR = 260 )
20435 PARAMETER ( MXSEAX = 20 )
20436 PARAMETER ( MXHTNC = MXSEAX + 1 )
20437 PARAMETER ( ICOMAX = 2400 )
20438 PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
20439 PARAMETER ( NSTBIS = 304 )
20440 PARAMETER ( NQSTIS = 46 )
20441 PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
20442 PARAMETER ( MXPABL = 120 )
20443 PARAMETER ( IDMAXP = 450 )
20444 PARAMETER ( IDMXDC = 2000 )
20445 PARAMETER ( MXMCIN = 410 )
20446 PARAMETER ( IHYPMX = 4 )
20447 PARAMETER ( MKBMX1 = 11 )
20448 PARAMETER ( MKBMX2 = 11 )
20449 PARAMETER ( MXIRRD = 2500 )
20450 PARAMETER ( MXTRDC = 1500 )
20451 PARAMETER ( NKTL = 17 )
20452 PARAMETER ( NBLNMX = 40000000 )
20454 * INCLUDE '(GENSTK)'
20456 PARAMETER ( MXP = MXPSCS )
20458 COMMON / GENSTK / CXR (MXPSCS), CYR (MXPSCS),
20459 & CZR (MXPSCS), CXRPOL (MXPSCS), CYRPOL (MXPSCS),
20460 & CZRPOL (MXPSCS), TKI (MXPSCS), PLR (MXPSCS),
20461 & WEI (MXPSCS), AGESEC (MXPSCS), TV , TVCMS ,
20462 & TVRECL, TVHEAV, TVBIND,
20463 & KPART (MXPSCS), INFEXT (MXPSCS), NP0 , NP
20465 * INCLUDE '(RESNUC)'
20466 LOGICAL LRNFSS, LFRAGM
20467 COMMON /RESNUC/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
20468 & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
20469 & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES,
20470 & PYRES, PZRES, PTRES2, ANGRES, ANXRES, ANYRES,
20471 & ANZRES, TVESTR, ANESTR, BHYRES (IHYPMX),
20472 & KTARP, KTARN, IGREYP, IGREYN, IPDPM0, IPDPM1,
20473 & IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE, ICRES,
20474 & IBRES, ISTRES, ISMRES, IHYRES, IEVAPL, IEVAPH,
20475 & IEVPHO, IEVNEU, IEVPRO, IEVDEU, IEVTRI, IEV3HE,
20476 & IEV4HE, IDEEXG, IBTAR, ICHTAR, IBLEFT, ICLEFT,
20477 & ICESTR, IBESTR, IOTHER, KHYRES (IHYPMX),
20481 * INCLUDE '(FHEAVY)'
20483 PARAMETER ( MXHEAV = 100 )
20484 PARAMETER ( KXHEAV = 30 )
20486 COMMON / FHEAVY / CXHEAV (MXHEAV), CYHEAV (MXHEAV),
20487 & CZHEAV (MXHEAV), TKHEAV (MXHEAV),
20488 & PHEAVY (MXHEAV), WHEAVY (MXHEAV),
20489 & AGHEAV (MXHEAV), BHHEAV (IHYPMX,KXHEAV),
20490 & AMHEAV (KXHEAV), AMNHEA (KXHEAV),
20491 & KHEAVY (MXHEAV), INFHEA (MXHEAV),
20492 & ICHEAV (KXHEAV), IBHEAV (KXHEAV),
20493 & IMHEAV (KXHEAV), IHHEAV (KXHEAV),
20494 & KHHEAV (IHYPMX,KXHEAV), NPHEAV
20495 COMMON / FHEAVC / ANHEAV (KXHEAV)
20497 DIMENSION IPTOKP(39)
20498 DATA IPTOKP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
20499 & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 99,
20500 & 100, 101, 97, 102, 98, 103, 109, 115 /
20504 * skip if evaporation package is not included
20505 IF (.NOT.LEVAPO) RETURN
20508 IF (NRESEV(3).NE.NEVHKK) THEN
20510 NRESEV(4) = NRESEV(4)+1
20514 & CALL DT_EVTEMC(PHKK(1,MO),PHKK(2,MO),PHKK(3,MO),PHKK(4,MO),1,
20516 * mass number/charge of residual nucleus before evaporation
20520 * protons/neutrons/gammas
20525 ID = IPTOKP(KPART(I))
20526 IDPDG = IDT_IPDGHA(ID)
20527 AM = ((PLR(I)+TKI(I))*(PLR(I)-TKI(I)))/
20528 & (2.0D0*MAX(TKI(I),TINY10))
20529 IF (ABS(AM-AAM(ID)).GT.TINY3) THEN
20530 WRITE(LOUT,1000) ID,AM,AAM(ID)
20531 1000 FORMAT(1X,'EVA2HE: inconsistent mass of evap. ',
20532 & 'particle',I3,2E10.3)
20535 CALL DT_EVTPUT(-1,IDPDG,MO,0,PX,PY,PZ,PE,0,0,0)
20537 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
20538 IBTOT = IBTOT-IIBAR(ID)
20539 IZTOT = IZTOT-IICH(ID)
20544 PX = CXHEAV(I)*PHEAVY(I)
20545 PY = CYHEAV(I)*PHEAVY(I)
20546 PZ = CZHEAV(I)*PHEAVY(I)
20548 AM = ((PHEAVY(I)+TKHEAV(I))*(PHEAVY(I)-TKHEAV(I)))/
20549 & (2.0D0*MAX(TKHEAV(I),TINY10))
20551 CALL DT_EVTPUT(-1,IDHEAV,MO,0,PX,PY,PZ,PE,
20552 & IBHEAV(KHEAVY(I)),ICHEAV(KHEAVY(I)),0)
20554 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
20555 IBTOT = IBTOT-IBHEAV(KHEAVY(I))
20556 IZTOT = IZTOT-ICHEAV(KHEAVY(I))
20559 IF (IBRES.GT.0) THEN
20560 * residual nucleus after evaporation
20562 CALL DT_EVTPUT(1001,IDNUC,MO,0,PXRES,PYRES,PZRES,ERES,
20567 NTOTFI(IRCL) = IBRES
20568 NPROFI(IRCL) = ICRES
20569 IF (LEMCCK) CALL DT_EVTEMC(-PXRES,-PYRES,-PZRES,-ERES,2,IDUM,IDUM)
20570 IBTOT = IBTOT-IBRES
20571 IZTOT = IZTOT-ICRES
20573 * count events with fission
20574 NEVAFI(1,IRCL) = NEVAFI(1,IRCL)+1
20575 IF (LRNFSS) NEVAFI(2,IRCL) = NEVAFI(2,IRCL)+1
20577 * energy-momentum conservation check
20578 IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,40,IREJ)
20579 C IF (IREJ.GT.0) THEN
20580 C CALL DT_EVTOUT(4)
20581 C WRITE(*,*) EEXC(2),EEXCFI(2),NP,NPHEAV
20583 * baryon-number/charge conservation check
20584 IF (IBTOT+IZTOT.NE.0) THEN
20585 WRITE(LOUT,1001) NEVHKK,IBTOT,IZTOT
20586 1001 FORMAT(1X,'EVA2HE: baryon-number/charge conservation ',
20587 & 'failure at event ',I8,' : IBTOT,IZTOT = ',2I3)
20593 *$ CREATE DT_EBIND.FOR
20596 *===ebind==============================================================*
20598 DOUBLE PRECISION FUNCTION DT_EBIND(IA,IZ)
20600 ************************************************************************
20601 * Binding energy for nuclei. *
20602 * (Shirokov & Yudin, Yad. Fizika, Nauka, Moskva 1972) *
20604 * IZ atomic number *
20605 * This version dated 5.5.95 is updated by S. Roesler. *
20606 ************************************************************************
20608 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20611 PARAMETER ( LINP = 10 ,
20615 PARAMETER (ZERO=0.0D0)
20617 DATA A1, A2, A3, A4, A5
20618 & / 0.01575D0, 0.0178D0, 0.000710D0, 0.0237D0, 0.034D0/
20620 IF ((IA.LE.1).OR.(IZ.EQ.0)) THEN
20621 WRITE(LOUT,'(1X,A,2I5)') 'DT_EBIND IA,IZ set EBIND=0. ',IA,IZ
20626 DT_EBIND = A1*AA - A2*AA**0.666667D0-A3*IZ*IZ*AA**(-0.333333D0)
20627 & -A4*(IA-2*IZ)**2/AA
20628 IF (MOD(IA,2).EQ.1) THEN
20630 ELSEIF (MOD(IZ,2).EQ.1) THEN
20635 DT_EBIND = DT_EBIND - IA5*A5*AA**(-0.75D0)
20640 ************************************************************************
20642 * DPMJET 3.0: cross section routines *
20644 ************************************************************************
20647 * SUBROUTINE DT_SHNDIF
20648 * diffractive cross sections (all energies)
20649 * SUBROUTINE DT_PHOXS
20650 * total and inel. cross sections from PHOJET interpol. tables
20651 * SUBROUTINE DT_XSHN
20652 * total and el. cross sections for all energies
20653 * SUBROUTINE DT_SIHNAB
20654 * pion 2-nucleon absorption cross sections
20655 * SUBROUTINE DT_SIGEMU
20656 * cross section for target "compounds"
20657 * SUBROUTINE DT_SIGGA
20658 * photon nucleus cross sections
20659 * SUBROUTINE DT_SIGGAT
20660 * photon nucleus cross sections from tables
20661 * SUBROUTINE DT_SANO
20662 * anomalous hard photon-nucleon cross sections from tables
20663 * SUBROUTINE DT_SIGGP
20664 * photon nucleon cross sections
20665 * SUBROUTINE DT_SIGVEL
20666 * quasi-elastic vector meson prod. cross sections
20667 * DOUBLE PRECISION FUNCTION DT_SIGVP
20669 * DOUBLE PRECISION FUNCTION DT_RRM2
20670 * DOUBLE PRECISION FUNCTION DT_RM2
20671 * DOUBLE PRECISION FUNCTION DT_SAM2
20672 * SUBROUTINE DT_CKMT
20673 * SUBROUTINE DT_CKMTX
20674 * SUBROUTINE DT_PDF0
20675 * SUBROUTINE DT_CKMTQ0
20676 * SUBROUTINE DT_CKMTDE
20677 * SUBROUTINE DT_CKMTPR
20678 * FUNCTION DT_CKMTFF
20680 * SUBROUTINE DT_FLUINI
20681 * total nucleon cross section fluctuation treatment
20683 * SUBROUTINE DT_SIGTBL
20684 * pre-tabulation of low-energy elastic x-sec. using SIHNEL
20685 * SUBROUTINE DT_XSTABL
20689 *$ CREATE DT_SHNDIF.FOR
20692 *===shndif===============================================================*
20694 SUBROUTINE DT_SHNDIF(ECM,KPROJ,KTARG,SIGDIF,SIGDIH)
20696 **********************************************************************
20697 * Single diffractive hadron-nucleon cross sections *
20698 * S.Roesler 14/1/93 *
20700 * The cross sections are calculated from extrapolated single *
20701 * diffractive antiproton-proton cross sections (DTUJET92) using *
20702 * scaling relations between total and single diffractive cross *
20704 **********************************************************************
20706 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20708 PARAMETER (ZERO=0.0D0)
20710 * particle properties (BAMJET index convention)
20712 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20713 & IICH(210),IIBAR(210),K1(210),K2(210)
20715 CSD1 = 4.201483727D0
20716 CSD4 = -0.4763103556D-02
20717 CSD5 = 0.4324148297D0
20719 CHMSD1 = 0.8519297242D0
20720 CHMSD4 = -0.1443076599D-01
20721 CHMSD5 = 0.4014954567D0
20723 EPN = (ECM**2 -AAM(KPROJ)**2 -AAM(KTARG)**2)/(2.0D0*AAM(KTARG))
20724 PPN = SQRT((EPN-AAM(KPROJ))*(EPN+AAM(KPROJ)))
20726 SDIAPP = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
20727 SHMSD = CHMSD1+CHMSD4*LOG(PPN)**2+CHMSD5*LOG(PPN)
20728 FRAC = SHMSD/SDIAPP
20730 GOTO( 10, 20,999,999,999,999,999, 10, 20,999,
20731 & 999, 20, 20, 20, 20, 20, 10, 20, 20, 10,
20732 & 10, 10, 20, 20, 20) KPROJ
20735 *---------------------------- p - p , n - p , sigma0+- - p ,
20737 CSD1 = 6.004476070D0
20738 CSD4 = -0.1257784606D-03
20739 CSD5 = 0.2447335720D0
20740 SIGDIF = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
20741 SIGDIH = FRAC*SIGDIF
20748 C F = SDIAPP/DT_SHNTOT(KPSCAL,KTSCAL,ECM,ZERO)
20750 CALL DT_XSHN(KPSCAL,KTSCAL,DUMZER,ECM,SIGTO,SIGEL)
20753 C SIGDIF = DT_SHNTOT(KPROJ,KT,ECM,ZERO)*F
20754 CALL DT_XSHN(KPROJ,KT,DUMZER,ECM,SIGTO,SIGEL)
20756 SIGDIH = FRAC*SIGDIF
20760 *-------------------------- leptons..
20766 *$ CREATE DT_PHOXS.FOR
20769 *===phoxs================================================================*
20771 SUBROUTINE DT_PHOXS(KPROJ,KTARG,ECM,PLAB,STOT,SINE,SDIF1,BEL,MODE)
20773 ************************************************************************
20774 * Total/inelastic proton-nucleon cross sections taken from PHOJET- *
20775 * interpolation tables. *
20776 * This version dated 05.11.97 is written by S. Roesler *
20777 ************************************************************************
20779 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20782 PARAMETER ( LINP = 10 ,
20786 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
20787 PARAMETER (TWOPI = 6.283185307179586454D+00,
20789 & GEV2MB = 0.38938D0)
20792 DATA LFIRST /.TRUE./
20794 * nucleon-nucleon event-generator
20797 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
20799 * particle properties (BAMJET index convention)
20801 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20802 & IICH(210),IIBAR(210),K1(210),K2(210)
20805 C PARAMETER (IEETAB=10)
20806 C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
20809 C energy-interpolation table
20811 PARAMETER ( IEETA2 = 20 )
20813 DOUBLE PRECISION SIGTAB,SIGECM
20814 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
20817 IF ((MCGENE.NE.2).AND.(MODE.NE.1)) THEN
20818 WRITE(LOUT,*) MCGENE
20819 1000 FORMAT(1X,'PHOXS: warning! PHOJET not initialized (',I2,')')
20823 IF (ECM.LE.ZERO) THEN
20824 EPN = SQRT(AAM(KPROJ)**2+PLAB**2)
20825 ECM = SQRT(AAM(KPROJ)**2+AAM(KTARG)**2+2.0D0*EPN*AAM(KTARG))
20828 IF (MODE.EQ.1) THEN
20833 STOT = 21.7D0*S**DELDL+56.08D0*S**EPSDL
20835 BEL = 8.5D0+2.D0*ALPHAP*LOG(S)
20836 SIGEL = STOT**2/(16.D0*PI*BEL*GEV2MB)
20842 IF(ECM.LE.SIGECM(IP,1)) THEN
20845 ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
20847 IF (ECM.LE.SIGECM(IP,I)) GOTO 2
20854 WRITE(LOUT,'(/1X,A,2E12.3)')
20855 & 'PHOXS: warning! energy above initialization limit (',
20856 & ECM,SIGECM(IP,ISIMAX)
20863 IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
20864 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
20866 STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
20867 SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
20868 SDIF1 = FAC2*(SIGTAB(IP,30,I2)+SIGTAB(IP,32,I2))+
20869 & FAC1*(SIGTAB(IP,30,I1)+SIGTAB(IP,32,I1))
20870 BEL = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
20876 *$ CREATE DT_XSHN.FOR
20879 *===xshn===============================================================*
20881 SUBROUTINE DT_XSHN(IP,IT,PL,ECM,STOT,SELA)
20883 ************************************************************************
20884 * Total and elastic hadron-nucleon cross section. *
20885 * Below 500GeV cross sections are based on the '98 data compilation *
20886 * of the PDG. At higher energies PHOJET results are used (patched to *
20887 * the low energy data at 500GeV). *
20888 * IP projectile index (BAMJET numbering scheme) *
20889 * (should be in the range 1..25) *
20890 * IT target index (BAMJET numbering scheme) *
20891 * (1 = proton, 8 = neutron) *
20892 * PL laboratory momentum *
20893 * ECM cm. energy (ignored if PL>0) *
20894 * STOT total cross section *
20895 * SELA elastic cross section *
20896 * Last change: 24.4.99 by S. Roesler *
20897 ************************************************************************
20899 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20902 PARAMETER ( LINP = 10 ,
20906 PARAMETER (ZERO=0.0D0,ONE=1.0D0)
20908 PARAMETER (NPOIN1 = 54, NPOIN2 = 8,
20909 & PLABLO = 0.1D0, PTHRE = 5.0D0, PLABHI = 500.0D0)
20910 PARAMETER (NPOINT = NPOIN1+NPOIN2+1)
20914 * particle properties (BAMJET index convention)
20916 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20917 & IICH(210),IIBAR(210),K1(210),K2(210)
20919 * nucleon-nucleon event-generator
20922 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
20924 C PARAMETER (IEETAB=10)
20925 C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
20928 C energy-interpolation table
20930 PARAMETER ( IEETA2 = 20 )
20932 DOUBLE PRECISION SIGTAB,SIGECM
20933 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
20935 DIMENSION APL(NPOINT),ASIGTO(10,NPOINT),ASIGEL(10,NPOINT)
20936 DIMENSION IDXDAT(25,2)
20939 &-1.000,-0.969,-0.937,-0.906,-0.874,-0.843,-0.811,-0.780,-0.748,
20940 &-0.717,-0.685,-0.654,-0.622,-0.591,-0.560,-0.528,-0.497,-0.465,
20941 &-0.434,-0.402,-0.371,-0.339,-0.308,-0.276,-0.245,-0.213,-0.182,
20942 &-0.151,-0.119,-0.088,-0.056,-0.025, 0.007, 0.038, 0.070, 0.101,
20943 & 0.133, 0.164, 0.196, 0.227, 0.258, 0.290, 0.321, 0.353, 0.384,
20944 & 0.416, 0.447, 0.479, 0.510, 0.542, 0.573, 0.605, 0.636, 0.668,
20945 & 0.699, 0.949, 1.199, 1.449, 1.699, 1.949, 2.199, 2.449, 2.699/
20947 * total cross sections:
20949 DATA (ASIGTO(1,K),K=1,NPOINT) /
20950 & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
20951 & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
20952 & 1.577, 1.518, 1.462, 1.420, 1.393, 1.375, 1.363, 1.356, 1.352,
20953 & 1.350, 1.351, 1.359, 1.381, 1.410, 1.444, 1.487, 1.544, 1.596,
20954 & 1.650, 1.672, 1.676, 1.677, 1.677, 1.675, 1.675, 1.669, 1.664,
20955 & 1.658, 1.653, 1.645, 1.640, 1.634, 1.630, 1.625, 1.620, 1.617,
20956 & 1.614, 1.602, 1.594, 1.589, 1.581, 1.583, 1.588, 1.596, 1.603/
20958 DATA (ASIGTO(2,K),K=1,NPOINT) /
20959 & 2.778, 2.759, 2.739, 2.718, 2.697, 2.675, 2.651, 2.626, 2.598,
20960 & 2.569, 2.537, 2.502, 2.471, 2.443, 2.420, 2.389, 2.361, 2.329,
20961 & 2.313, 2.304, 2.268, 2.244, 2.222, 2.212, 2.178, 2.162, 2.151,
20962 & 2.132, 2.109, 2.097, 2.089, 2.078, 2.063, 2.049, 2.035, 2.024,
20963 & 2.014, 2.004, 1.993, 1.981, 1.970, 1.958, 1.946, 1.933, 1.921,
20964 & 1.909, 1.894, 1.885, 1.871, 1.854, 1.836, 1.825, 1.816, 1.802,
20965 & 1.790, 1.744, 1.694, 1.663, 1.642, 1.614, 1.623, 1.623, 1.630/
20967 DATA (ASIGTO(3,K),K=1,NPOINT) /
20968 & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
20969 & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
20970 & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
20971 & 1.547, 1.534, 1.526, 1.522, 1.520, 1.525, 1.536, 1.550, 1.566,
20972 & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
20973 & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
20974 & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
20976 DATA (ASIGTO(4,K),K=1,NPOINT) /
20977 & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
20978 & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
20979 & 2.001, 1.875, 1.801, 1.665, 1.609, 1.484, 1.412, 1.334, 1.195,
20980 & 1.160, 1.166, 1.208, 1.309, 1.356, 1.394, 1.406, 1.419, 1.473,
20981 & 1.540, 1.596, 1.570, 1.533, 1.516, 1.484, 1.471, 1.478, 1.492,
20982 & 1.497, 1.491, 1.479, 1.465, 1.453, 1.449, 1.450, 1.444, 1.428,
20983 & 1.422, 1.406, 1.384, 1.369, 1.364, 1.369, 1.374, 1.388, 1.395/
20985 DATA (ASIGTO(5,K),K=1,NPOINT) /
20986 & 0.458, 0.540, 0.626, 0.718, 0.819, 0.933, 1.063, 1.208, 1.226,
20987 & 1.436, 1.470, 1.594, 1.708, 1.786, 1.852, 1.836, 1.763, 1.679,
20988 & 1.590, 1.492, 1.445, 1.426, 1.423, 1.433, 1.473, 1.506, 1.547,
20989 & 1.660, 1.671, 1.545, 1.591, 1.687, 1.808, 1.656, 1.582, 1.543,
20990 & 1.562, 1.560, 1.537, 1.540, 1.549, 1.557, 1.557, 1.551, 1.535,
20991 & 1.527, 1.511, 1.510, 1.507, 1.500, 1.491, 1.483, 1.478, 1.468,
20992 & 1.463, 1.435, 1.408, 1.394, 1.384, 1.380, 1.383, 1.393, 1.411/
20994 DATA (ASIGTO(6,K),K=1,NPOINT) /
20995 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
20996 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
20997 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.096, 1.095,
20998 & 1.098, 1.105, 1.111, 1.139, 1.169, 1.209, 1.248, 1.259, 1.268,
20999 & 1.262, 1.257, 1.254, 1.252, 1.250, 1.249, 1.246, 1.244, 1.244,
21000 & 1.243, 1.240, 1.238, 1.237, 1.236, 1.235, 1.235, 1.236, 1.236,
21001 & 1.236, 1.233, 1.238, 1.248, 1.257, 1.272, 1.292, 1.311, 1.336/
21003 DATA (ASIGTO(7,K),K=1,NPOINT) /
21004 & 2.003, 2.002, 2.001, 2.000, 1.999, 1.998, 1.998, 1.997, 1.997,
21005 & 1.996, 1.995, 1.993, 1.990, 1.992, 1.974, 1.912, 1.865, 1.847,
21006 & 1.896, 1.950, 1.827, 1.681, 1.637, 1.616, 1.589, 1.545, 1.543,
21007 & 1.532, 1.603, 1.604, 1.616, 1.658, 1.700, 1.658, 1.595, 1.508,
21008 & 1.493, 1.514, 1.531, 1.523, 1.501, 1.479, 1.474, 1.467, 1.463,
21009 & 1.450, 1.444, 1.435, 1.426, 1.424, 1.423, 1.415, 1.401, 1.396,
21010 & 1.384, 1.364, 1.330, 1.313, 1.310, 1.309, 1.317, 1.329, 1.338/
21012 DATA (ASIGTO(8,K),K=1,NPOINT) /
21013 & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21014 & 0.631, 0.675, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21015 & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.102, 1.125, 1.147,
21016 & 1.168, 1.187, 1.205, 1.224, 1.248, 1.279, 1.315, 1.324, 1.301,
21017 & 1.285, 1.279, 1.274, 1.273, 1.272, 1.271, 1.267, 1.263, 1.261,
21018 & 1.259, 1.256, 1.252, 1.247, 1.244, 1.241, 1.240, 1.240, 1.240,
21019 & 1.241, 1.243, 1.245, 1.253, 1.265, 1.275, 1.293, 1.314, 1.342/
21021 DATA (ASIGTO(9,K),K=1,NPOINT) /
21022 & 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778,
21023 & 1.778, 1.778, 1.778, 1.778, 1.778, 1.779, 1.779, 1.778, 1.773,
21024 & 1.765, 1.746, 1.703, 1.646, 1.561, 1.488, 1.454, 1.437, 1.437,
21025 & 1.458, 1.505, 1.561, 1.588, 1.593, 1.581, 1.551, 1.500, 1.454,
21026 & 1.427, 1.408, 1.390, 1.372, 1.361, 1.356, 1.351, 1.347, 1.343,
21027 & 1.341, 1.340, 1.338, 1.337, 1.335, 1.334, 1.332, 1.331, 1.330,
21028 & 1.330, 1.313, 1.303, 1.288, 1.288, 1.297, 1.305, 1.320, 1.342/
21030 DATA (ASIGTO(10,K),K=1,NPOINT) /
21031 & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21032 & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.629,
21033 & 1.599, 1.576, 1.558, 1.543, 1.530, 1.520, 1.512, 1.505, 1.499,
21034 & 1.495, 1.495, 1.497, 1.504, 1.514, 1.525, 1.536, 1.550, 1.567,
21035 & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
21036 & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
21037 & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
21039 * elastic cross sections:
21041 DATA (ASIGEL(1,K),K=1,NPOINT) /
21042 & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
21043 & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
21044 & 1.577, 1.518, 1.462, 1.420, 1.393, 1.374, 1.360, 1.353, 1.350,
21045 & 1.351, 1.356, 1.362, 1.369, 1.376, 1.384, 1.385, 1.399, 1.397,
21046 & 1.389, 1.385, 1.379, 1.366, 1.358, 1.344, 1.320, 1.294, 1.275,
21047 & 1.260, 1.248, 1.235, 1.219, 1.199, 1.172, 1.144, 1.126, 1.115,
21048 & 1.104, 1.013, 0.962, 0.905, 0.869, 0.845, 0.846, 0.850, 0.868/
21050 DATA (ASIGEL(2,K),K=1,NPOINT) /
21051 & 1.987, 1.985, 1.983, 1.980, 1.978, 1.975, 1.971, 1.968, 1.963,
21052 & 1.958, 1.951, 1.944, 1.935, 1.925, 1.914, 1.902, 1.889, 1.875,
21053 & 1.859, 1.845, 1.834, 1.817, 1.792, 1.769, 1.754, 1.738, 1.720,
21054 & 1.702, 1.688, 1.676, 1.667, 1.659, 1.652, 1.645, 1.640, 1.636,
21055 & 1.620, 1.591, 1.562, 1.546, 1.540, 1.524, 1.496, 1.475, 1.457,
21056 & 1.429, 1.402, 1.373, 1.344, 1.330, 1.306, 1.294, 1.265, 1.228,
21057 & 1.204, 1.086, 0.977, 0.933, 0.914, 0.850, 0.862, 0.848, 0.845/
21059 DATA (ASIGEL(3,K),K=1,NPOINT) /
21060 & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
21061 & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
21062 & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
21063 & 1.544, 1.527, 1.514, 1.504, 1.495, 1.486, 1.476, 1.466, 1.454,
21064 & 1.440, 1.425, 1.409, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21065 & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21066 & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21068 DATA (ASIGEL(4,K),K=1,NPOINT) /
21069 & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
21070 & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
21071 & 2.001, 1.875, 1.801, 1.664, 1.610, 1.479, 1.423, 1.299, 1.166,
21072 & 1.097, 1.020, 0.958, 0.914, 1.013, 1.088, 1.153, 1.167, 1.235,
21073 & 1.240, 1.237, 1.202, 1.135, 1.090, 1.026, 0.975, 0.941, 0.904,
21074 & 0.894, 0.884, 0.862, 0.850, 0.845, 0.827, 0.805, 0.789, 0.776,
21075 & 0.763, 0.686, 0.626, 0.562, 0.505, 0.518, 0.525, 0.528, 0.528/
21077 DATA (ASIGEL(5,K),K=1,NPOINT) /
21078 & 0.266, 0.278, 0.294, 0.320, 0.360, 0.419, 0.503, 0.608, 0.727,
21079 & 0.850, 0.968, 1.071, 1.167, 1.305, 1.369, 1.404, 1.446, 1.217,
21080 & 1.112, 1.071, 1.014, 1.002, 0.996, 1.008, 1.070, 1.126, 1.209,
21081 & 1.300, 1.281, 1.188, 1.156, 1.341, 1.423, 1.314, 1.171, 1.140,
21082 & 1.106, 1.071, 1.011, 1.037, 1.026, 1.024, 0.988, 0.953, 0.895,
21083 & 0.894, 0.880, 0.871, 0.864, 0.853, 0.837, 0.820, 0.809, 0.800,
21084 & 0.782, 0.674, 0.612, 0.530, 0.521, 0.528, 0.524, 0.542, 0.569/
21086 DATA (ASIGEL(6,K),K=1,NPOINT) /
21087 & 1.064, 1.065, 1.065, 1.066, 1.066, 1.066, 1.066, 1.066, 1.066,
21088 & 1.065, 1.064, 1.063, 1.062, 1.062, 1.062, 1.064, 1.066, 1.070,
21089 & 1.076, 1.082, 1.088, 1.096, 1.103, 1.104, 1.104, 1.102, 1.093,
21090 & 1.087, 1.084, 1.079, 1.075, 1.067, 1.058, 1.040, 1.029, 1.012,
21091 & 1.003, 0.985, 0.935, 0.909, 0.880, 0.846, 0.790, 0.771, 0.759,
21092 & 0.743, 0.718, 0.681, 0.666, 0.645, 0.622, 0.606, 0.594, 0.584,
21093 & 0.575, 0.513, 0.453, 0.403, 0.356, 0.365, 0.389, 0.430, 0.477/
21095 DATA (ASIGEL(7,K),K=1,NPOINT) /
21096 & 1.941, 1.936, 1.931, 1.926, 1.919, 1.912, 1.903, 1.892, 1.878,
21097 & 1.863, 1.844, 1.821, 1.791, 1.755, 1.713, 1.666, 1.615, 1.561,
21098 & 1.533, 1.531, 1.518, 1.511, 1.452, 1.339, 1.265, 1.233, 1.188,
21099 & 1.184, 1.236, 1.316, 1.333, 1.336, 1.333, 1.277, 1.216, 1.077,
21100 & 1.018, 0.912, 0.926, 0.920, 0.910, 0.894, 0.830, 0.825, 0.800,
21101 & 0.788, 0.747, 0.703, 0.707, 0.689, 0.643, 0.633, 0.635, 0.618,
21102 & 0.584, 0.579, 0.461, 0.403, 0.405, 0.399, 0.408, 0.418, 0.413/
21104 DATA (ASIGEL(8,K),K=1,NPOINT) /
21105 & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21106 & 0.631, 0.676, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21107 & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.103, 1.126, 1.148,
21108 & 1.168, 1.187, 1.205, 1.223, 1.248, 1.282, 1.269, 1.185, 1.111,
21109 & 1.063, 1.031, 0.998, 0.964, 0.928, 0.889, 0.849, 0.814, 0.785,
21110 & 0.760, 0.738, 0.720, 0.703, 0.688, 0.674, 0.660, 0.648, 0.635,
21111 & 0.624, 0.536, 0.473, 0.442, 0.428, 0.428, 0.436, 0.453, 0.477/
21113 DATA (ASIGEL(9,K),K=1,NPOINT) /
21114 & 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613,
21115 & 1.613, 1.613, 1.613, 1.612, 1.613, 1.614, 1.614, 1.612, 1.606,
21116 & 1.593, 1.564, 1.498, 1.402, 1.240, 1.071, 0.977, 0.922, 0.914,
21117 & 0.961, 1.077, 1.214, 1.271, 1.290, 1.281, 1.217, 1.096, 0.979,
21118 & 0.896, 0.822, 0.736, 0.655, 0.608, 0.591, 0.580, 0.569, 0.559,
21119 & 0.550, 0.540, 0.531, 0.522, 0.514, 0.507, 0.500, 0.494, 0.489,
21120 & 0.485, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477/
21122 DATA (ASIGEL(10,K),K=1,NPOINT) /
21123 & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21124 & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.630,
21125 & 1.600, 1.577, 1.558, 1.542, 1.528, 1.518, 1.510, 1.505, 1.502,
21126 & 1.501, 1.500, 1.499, 1.496, 1.491, 1.485, 1.477, 1.466, 1.454,
21127 & 1.440, 1.425, 1.408, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21128 & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21129 & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21131 DATA (IDXDAT(K,1),K=1,25) /
21132 & 1, 2, 0, 0, 0, 0, 0, 3, 2, 0, 0,67, 4, 5, 6, 7,10, 2,67, 3,
21134 DATA (IDXDAT(K,2),K=1,25) /
21135 & 3, 2, 0, 0, 0, 0, 0, 1, 2, 0, 0,89, 5, 4, 8, 9, 1, 2,89, 1,
21138 DATA LFIRST /.TRUE./
21141 APLABL = LOG10(PLABLO)
21142 APLABH = LOG10(PLABHI)
21143 APTHRE = LOG10(PTHRE)
21144 ADP1 = (APTHRE-APLABL)/DBLE(NPOIN1)
21145 ADP2 = (APLABH-APTHRE)/DBLE(NPOIN2)
21148 PHOELA = SQRT(AAM(1)**2+PHOPLA**2)
21149 ECMS = SQRT(2.0D0*AAM(1)**2+2.0D0*AAM(1)*PHOELA)
21150 IF (MCGENE.EQ.2) THEN
21151 IF (ECMS.LE.SIGECM(1,ISIMAX)) THEN
21152 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,0)
21154 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21157 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21159 PHOSEL = PHOSTO-PHOSIN
21160 APHOST = LOG10(PHOSTO)
21161 APHOSE = LOG10(PHOSEL)
21168 IF ( (IP.LT.1).OR.((IT.NE.1).AND.(IT.NE.8)) ) THEN
21169 WRITE(LOUT,1000) IP,IT
21170 1000 FORMAT(1X,'DT_XSHN: cross sections not implemented for ',
21171 & 'proj/target',2I4)
21175 IF ((PLAB.LE.ZERO).AND.(ECMS.GT.ZERO)) THEN
21176 ELAB = (ECMS**2-AAM(IP)**2-AAM(IT)**2)/(2.0D0*AAM(IT))
21177 PLAB = SQRT((ELAB-AAM(IP))*(ELAB+AAM(IP)))
21178 ELSEIF ((PLAB.LE.ZERO).AND.(ECMS.LE.ZERO)) THEN
21179 WRITE(LOUT,1001) PLAB,ECMS
21180 1001 FORMAT(1X,'DT_XSHN: invalid momentum/cm-energy ',2E15.5)
21184 * index of spectrum
21187 IF (AAM(IP).GT.ZERO) THEN
21188 IF (ABS(IIBAR(IP)).GT.0) THEN
21198 IF (IT.EQ.8) IDXT = 2
21199 IDXS = IDXDAT(IDXP,IDXT)
21200 IF (IDXS.EQ.0) RETURN
21202 * compute momentum bin indices
21203 IF (PLAB.LT.PLABLO) THEN
21206 ELSEIF (PLAB.GE.PLABHI) THEN
21210 APLAB = LOG10(PLAB)
21211 IF ((PLAB.GE.PLABLO).AND.(PLAB.LT.PTHRE )) THEN
21212 IDX0 = INT((APLAB-APLABL)/ADP1)+1
21213 ELSEIF ((PLAB.GE.PTHRE ).AND.(PLAB.LT.PLABHI)) THEN
21214 IDX0 = INT((APLAB-APTHRE)/ADP2)+NPOIN1+1
21219 * interpolate cross section
21220 IF (IDXS.GT.10) THEN
21222 IDXS2 = IDXS-10*IDXS1
21223 IF (IDX0.EQ.IDX1) THEN
21224 IF (IDX0.EQ.1) THEN
21225 ASTOT = 0.5D0*(ASIGTO(IDXS1,IDX0)+ASIGTO(IDXS2,IDX0))
21226 ASELA = 0.5D0*(ASIGEL(IDXS1,IDX0)+ASIGEL(IDXS2,IDX0))
21229 CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21230 PHOSEL = PHOSTO-PHOSIN
21231 ASTOT1 = ASIGTO(IDXS1,NPOINT)-APHOST+LOG10(PHOSTO)
21232 ASELA1 = ASIGEL(IDXS1,NPOINT)-APHOSE+LOG10(PHOSEL)
21233 ASTOT2 = ASIGTO(IDXS2,NPOINT)-APHOST+LOG10(PHOSTO)
21234 ASELA2 = ASIGEL(IDXS2,NPOINT)-APHOSE+LOG10(PHOSEL)
21235 ASTOT = 0.5D0*(ASTOT1+ASTOT2)
21236 ASELA = 0.5D0*(ASELA1+ASELA2)
21239 FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21240 ASTOT1 = ASIGTO(IDXS1,IDX0)+
21241 & FAC*(ASIGTO(IDXS1,IDX1)-ASIGTO(IDXS1,IDX0))
21242 ASTOT2 = ASIGTO(IDXS2,IDX0)+
21243 & FAC*(ASIGTO(IDXS2,IDX1)-ASIGTO(IDXS2,IDX0))
21244 ASTOT = 0.5D0*(ASTOT1+ASTOT2)
21245 ASELA1 = ASIGEL(IDXS1,IDX0)+
21246 & FAC*(ASIGEL(IDXS1,IDX1)-ASIGEL(IDXS1,IDX0))
21247 ASELA2 = ASIGEL(IDXS2,IDX0)+
21248 & FAC*(ASIGEL(IDXS2,IDX1)-ASIGEL(IDXS2,IDX0))
21249 ASELA = 0.5D0*(ASELA1+ASELA2)
21252 IF (IDX0.EQ.IDX1) THEN
21253 IF (IDX0.EQ.1) THEN
21254 ASTOT = ASIGTO(IDXS,IDX0)
21255 ASELA = ASIGEL(IDXS,IDX0)
21258 CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21259 PHOSEL = PHOSTO-PHOSIN
21260 ASTOT = ASIGTO(IDXS,NPOINT)-APHOST+LOG10(PHOSTO)
21261 ASELA = ASIGEL(IDXS,NPOINT)-APHOSE+LOG10(PHOSEL)
21264 FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21265 ASTOT = ASIGTO(IDXS,IDX0)+
21266 & FAC*(ASIGTO(IDXS,IDX1)-ASIGTO(IDXS,IDX0))
21267 ASELA = ASIGEL(IDXS,IDX0)+
21268 & FAC*(ASIGEL(IDXS,IDX1)-ASIGEL(IDXS,IDX0))
21271 STOT = 10.0D0**ASTOT
21272 SELA = 10.0D0**ASELA
21277 *$ CREATE DT_SIHNAB.FOR
21280 *===sihnab===============================================================*
21282 SUBROUTINE DT_SIHNAB(IDP,IDT,PLAB,SIGABS)
21284 **********************************************************************
21285 * Pion 2-nucleon absorption cross sections. *
21286 * (sigma_tot for pi+ d --> p p, pi- d --> n n *
21287 * taken from Ritchie PRC 28 (1983) 926 ) *
21288 * This version dated 18.05.96 is written by S. Roesler *
21289 **********************************************************************
21291 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21293 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY3=1.0D-3)
21294 PARAMETER (AMPR = 938.0D0,
21304 IF ( ((IDP.NE.13).AND.(IDP.NE.14).AND.(IDP.NE.23))
21305 & .OR.((IDT.NE.1).AND.(IDT.NE.8)) ) RETURN
21307 EKIN = SQRT(AMPI**2+PTOT**2)-AMPI
21308 IF ((EKIN.LT.TINY3).OR.(EKIN.GT.400.0D0)) RETURN
21309 ECM = SQRT( (AMPI+AMDE)**2+TWO*EKIN*AMDE )
21310 SIGABS = A+B/SQRT(EKIN)+C*1.0D4/((ECM-ER)**2+D)
21311 * approximate 3N-abs., I=1-abs. etc.
21312 SIGABS = SIGABS/0.40D0
21313 * pi0-absorption (rough approximation!!)
21314 IF (IDP.EQ.23) SIGABS = 0.5D0*SIGABS
21319 *$ CREATE DT_SIGEMU.FOR
21322 *===sigemu=============================================================*
21324 SUBROUTINE DT_SIGEMU
21326 ************************************************************************
21327 * Combined cross section for target compounds. *
21328 * This version dated 6.4.98 is written by S. Roesler *
21329 ************************************************************************
21331 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21334 PARAMETER ( LINP = 10 ,
21338 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21339 & OHALF=0.5D0,ONE=1.0D0)
21341 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21343 * Glauber formalism: cross sections
21344 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21345 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21346 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21347 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21348 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21349 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21350 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21351 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21352 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21353 & BSLOPE,NEBINI,NQBINI
21355 * emulsion treatment
21356 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
21359 * nucleon-nucleon event-generator
21362 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21364 IF (MCGENE.NE.4) THEN
21365 WRITE(LOUT,'(A)') ' DT_SIGEMU: Combined cross sections'
21366 WRITE(LOUT,'(15X,A)') '-----------------------'
21386 IF (NCOMPO.GT.0) THEN
21388 SIGTOT = SIGTOT+EMUFRA(IC)*XSTOT(IE,IQ,IC)
21389 SIGELA = SIGELA+EMUFRA(IC)*XSELA(IE,IQ,IC)
21390 SIGQEP = SIGQEP+EMUFRA(IC)*XSQEP(IE,IQ,IC)
21391 SIGQET = SIGQET+EMUFRA(IC)*XSQET(IE,IQ,IC)
21392 SIGQE2 = SIGQE2+EMUFRA(IC)*XSQE2(IE,IQ,IC)
21393 SIGPRO = SIGPRO+EMUFRA(IC)*XSPRO(IE,IQ,IC)
21394 SIGDEL = SIGDEL+EMUFRA(IC)*XSDEL(IE,IQ,IC)
21395 SIGDQE = SIGDQE+EMUFRA(IC)*XSDQE(IE,IQ,IC)
21396 ERRTOT = ERRTOT+XETOT(IE,IQ,IC)**2
21397 ERRELA = ERRELA+XEELA(IE,IQ,IC)**2
21398 ERRQEP = ERRQEP+XEQEP(IE,IQ,IC)**2
21399 ERRQET = ERRQET+XEQET(IE,IQ,IC)**2
21400 ERRQE2 = ERRQE2+XEQE2(IE,IQ,IC)**2
21401 ERRPRO = ERRPRO+XEPRO(IE,IQ,IC)**2
21402 ERRDEL = ERRDEL+XEDEL(IE,IQ,IC)**2
21403 ERRDQE = ERRDQE+XEDQE(IE,IQ,IC)**2
21405 ERRTOT = SQRT(ERRTOT)
21406 ERRELA = SQRT(ERRELA)
21407 ERRQEP = SQRT(ERRQEP)
21408 ERRQET = SQRT(ERRQET)
21409 ERRQE2 = SQRT(ERRQE2)
21410 ERRPRO = SQRT(ERRPRO)
21411 ERRDEL = SQRT(ERRDEL)
21412 ERRDQE = SQRT(ERRDQE)
21414 SIGTOT = XSTOT(IE,IQ,1)
21415 SIGELA = XSELA(IE,IQ,1)
21416 SIGQEP = XSQEP(IE,IQ,1)
21417 SIGQET = XSQET(IE,IQ,1)
21418 SIGQE2 = XSQE2(IE,IQ,1)
21419 SIGPRO = XSPRO(IE,IQ,1)
21420 SIGDEL = XSDEL(IE,IQ,1)
21421 SIGDQE = XSDQE(IE,IQ,1)
21422 ERRTOT = XETOT(IE,IQ,1)
21423 ERRELA = XEELA(IE,IQ,1)
21424 ERRQEP = XEQEP(IE,IQ,1)
21425 ERRQET = XEQET(IE,IQ,1)
21426 ERRQE2 = XEQE2(IE,IQ,1)
21427 ERRPRO = XEPRO(IE,IQ,1)
21428 ERRDEL = XEDEL(IE,IQ,1)
21429 ERRDQE = XEDQE(IE,IQ,1)
21431 IF (MCGENE.NE.4) THEN
21432 WRITE(LOUT,1000) ECMNN(IE),Q2G(IQ)
21433 1000 FORMAT(/,1X,'E_cm =',F9.1,' GeV Q^2 =',F6.1,' GeV^2 :',/)
21434 WRITE(LOUT,1001) SIGTOT,ERRTOT
21435 1001 FORMAT(1X,'total',32X,F10.4,' +-',F11.5,' mb')
21436 WRITE(LOUT,1002) SIGELA,ERRELA
21437 1002 FORMAT(1X,'elastic',30X,F10.4,' +-',F11.5,' mb')
21438 WRITE(LOUT,1003) SIGQEP,ERRQEP
21439 1003 FORMAT(1X,'quasi-elastic (A+B-->A+X)',12X,F10.4,' +-',
21441 WRITE(LOUT,1004) SIGQET,ERRQET
21442 1004 FORMAT(1X,'quasi-elastic (A+B-->X+B)',12X,F10.4,' +-',
21444 WRITE(LOUT,1005) SIGQE2,ERRQE2
21445 1005 FORMAT(1X,'quasi-elastic (A+B-->X, excl. 2-4)',3X,F10.4,
21446 & ' +-',F11.5,' mb')
21447 WRITE(LOUT,1006) SIGPRO,ERRPRO
21448 1006 FORMAT(1X,'production',27X,F10.4,' +-',F11.5,' mb')
21449 WRITE(LOUT,1007) SIGDEL,ERRDEL
21450 1007 FORMAT(1X,'diff-el ',27X,F10.4,' +-',F11.5,' mb')
21451 WRITE(LOUT,1008) SIGDQE,ERRDQE
21452 1008 FORMAT(1X,'diff-qel ',27X,F10.4,' +-',F11.5,' mb')
21461 *$ CREATE DT_SIGGA.FOR
21464 *===sigga==============================================================*
21466 SUBROUTINE DT_SIGGA(NTI,XI,Q2I,ECMI,XNUI,STOT,ETOT,SIN,EIN,STOT0)
21468 ************************************************************************
21469 * Total/inelastic photon-nucleus cross sections. *
21470 * !!!! Overwrites SHMAKI-initialization. Do not use it during *
21471 * production runs !!!! *
21472 * This version dated 27.03.96 is written by S. Roesler *
21473 ************************************************************************
21475 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21478 PARAMETER ( LINP = 10 ,
21482 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21483 & OHALF=0.5D0,ONE=1.0D0)
21484 PARAMETER (AMPROT = 0.938D0)
21486 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21488 * Glauber formalism: cross sections
21489 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21490 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21491 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21492 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21493 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21494 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21495 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21496 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21497 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21498 & BSLOPE,NEBINI,NQBINI
21505 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21506 & ECM = SQRT(AMPROT**2-Q2+2.0D0*XNUI*AMPROT)
21507 CALL DT_XSGLAU(1,NT,7,X,Q2,ECM,1,1,-1)
21508 STOT = XSTOT(1,1,1)
21509 ETOT = XETOT(1,1,1)
21516 *$ CREATE DT_SIGGAT.FOR
21519 *===siggat=============================================================*
21521 SUBROUTINE DT_SIGGAT(Q2I,ECMI,STOT,NT)
21523 ************************************************************************
21524 * Total/inelastic photon-nucleus cross sections. *
21525 * Uses pre-tabulated cross section. *
21526 * This version dated 29.07.96 is written by S. Roesler *
21527 ************************************************************************
21529 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21532 PARAMETER ( LINP = 10 ,
21536 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21537 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21539 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21541 * Glauber formalism: cross sections
21542 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21543 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21544 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21545 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21546 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21547 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21548 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21549 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21550 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21551 & BSLOPE,NEBINI,NQBINI
21557 IF (NEBINI.GT.1) THEN
21558 IF (ECMI.GE.ECMNN(NEBINI)) THEN
21562 ELSEIF (ECMI.GT.ECMNN(1)) THEN
21564 IF (ECMI.LT.ECMNN(I)) THEN
21567 RATE = (ECMI-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
21577 IF (NQBINI.GT.1) THEN
21578 IF (Q2I.GE.Q2G(NQBINI)) THEN
21582 ELSEIF (Q2I.GT.Q2G(1)) THEN
21584 IF (Q2I.LT.Q2G(I)) THEN
21587 RATQ = LOG10( Q2I/MAX(Q2G(J1),TINY14))/
21588 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
21589 C RATQ = (Q2I-Q2G(J1))/(Q2G(J2)-Q2G(J1))
21597 STOT = XSTOT(I1,J1,NTARG)+
21598 & RATE*(XSTOT(I2,J1,NTARG)-XSTOT(I1,J1,NTARG))+
21599 & RATQ*(XSTOT(I1,J2,NTARG)-XSTOT(I1,J1,NTARG))+
21600 & RATE*RATQ*(XSTOT(I2,J2,NTARG)-XSTOT(I1,J2,NTARG)+
21601 & XSTOT(I1,J1,NTARG)-XSTOT(I2,J1,NTARG))
21606 *$ CREATE DT_SANO.FOR
21609 *===sigano=============================================================*
21611 DOUBLE PRECISION FUNCTION DT_SANO(ECM)
21613 ************************************************************************
21614 * This version dated 31.07.96 is written by S. Roesler *
21615 ************************************************************************
21617 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21620 PARAMETER ( LINP = 10 ,
21624 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21625 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21628 * VDM parameter for photon-nucleus interactions
21629 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21631 * properties of interacting particles
21632 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
21634 DIMENSION ECMANO(NE),FRAANO(NE),SIGHRD(NE)
21636 & 0.200D+02,0.500D+02,0.100D+03,0.200D+03,0.500D+03,
21637 & 0.100D+04,0.200D+04,0.500D+04
21639 * fixed cut (3 GeV/c)
21641 & 0.085D+00,0.114D+00,0.105D+00,0.091D+00,0.073D+00,
21642 & 0.062D+00,0.054D+00,0.042D+00
21645 & 4.0099D-04,3.3104D-03,1.1905D-02,3.6435D-02,1.3493D-01,
21646 & 3.3086D-01,7.6255D-01,2.1319D+00
21648 * running cut (based on obsolete Phojet-caluclations, bugs..)
21650 C & 0.251E+00,0.313E+00,0.279E+00,0.239E+00,0.186E+00,
21651 C & 0.167E+00,0.150E+00,0.131E+00
21654 C & 6.6569E-04,4.4949E-03,1.4837E-02,4.1466E-02,1.5071E-01,
21655 C & 2.5736E-01,4.5593E-01,8.2550E-01
21659 IF ((ISHAD(2).NE.1).OR.(IJPROJ.NE.7)) RETURN
21663 IF (ECM.GE.ECMANO(NE)) THEN
21666 ELSEIF (ECM.GT.ECMANO(1)) THEN
21668 IF (ECM.LT.ECMANO(IE)) THEN
21671 RATE = LOG10(ECM/ECMANO(J1))/LOG10(ECMANO(J2)/ECMANO(J1))
21677 IF ((J1.GT.0).AND.(J2.GT.0)) THEN
21678 AFRA1 = LOG10(MAX(FRAANO(J1)*SIGHRD(J1),TINY14))
21679 AFRA2 = LOG10(MAX(FRAANO(J2)*SIGHRD(J2),TINY14))
21680 DT_SANO = 10.0D0**(AFRA1+RATE*(AFRA2-AFRA1))
21686 *$ CREATE DT_SIGGP.FOR
21689 *===siggp==============================================================*
21691 SUBROUTINE DT_SIGGP(XI,Q2I,ECMI,XNUI,STOT,SINE,SDIR)
21693 ************************************************************************
21694 * Total/inelastic photon-nucleon cross sections. *
21695 * This version dated 30.04.96 is written by S. Roesler *
21696 ************************************************************************
21698 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21701 PARAMETER ( LINP = 10 ,
21705 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
21706 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
21708 & GEV2MB = 0.38938D0,
21709 & ALPHEM = ONE/137.0D0)
21711 * particle properties (BAMJET index convention)
21713 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21714 & IICH(210),IIBAR(210),K1(210),K2(210)
21716 * VDM parameter for photon-nucleus interactions
21717 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21720 C CHARACTER*8 MDLNA
21721 C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
21722 C PARAMETER (IEETAB=10)
21723 C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
21726 C model switches and parameters
21728 INTEGER ISWMDL,IPAMDL
21729 DOUBLE PRECISION PARMDL
21730 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
21732 C energy-interpolation table
21734 PARAMETER ( IEETA2 = 20 )
21736 DOUBLE PRECISION SIGTAB,SIGECM
21737 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
21740 C PARAMETER (NPOINT=80)
21741 PARAMETER (NPOINT=16)
21742 DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
21749 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21750 & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
21754 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21756 X = Q2/(W2+Q2-AAM(1)**2)
21758 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
21759 X = Q2/(W2+Q2-AAM(1)**2)
21760 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21761 Q2 = (W2-AAM(1)**2)*X/(ONE-X)
21762 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
21763 W2 = Q2*(ONE-X)/X+AAM(1)**2
21765 WRITE(LOUT,*) 'SIGGP: inconsistent input ',W2,Q2,X
21770 IF (MODEGA.EQ.1) THEN
21772 CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
21776 C ALLMF2 = PHO_ALLM97(Q2,W)
21778 C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
21779 STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
21782 ELSEIF (MODEGA.EQ.2) THEN
21783 IF (INTRGE(1).EQ.1) THEN
21784 AMLO2 = (3.0D0*AAM(13))**2
21785 ELSEIF (INTRGE(1).EQ.2) THEN
21790 IF (INTRGE(2).EQ.1) THEN
21792 ELSEIF (INTRGE(2).EQ.2) THEN
21797 AMHI20 = (ECM-AAM(1))**2
21798 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
21799 XAMLO = LOG( AMLO2+Q2 )
21800 XAMHI = LOG( AMHI2+Q2 )
21802 C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
21805 CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
21810 AM2 = EXP(ABSZX(J))-Q2
21811 IF (AM2.LT.16.0D0) THEN
21813 ELSEIF ((AM2.GE.16.0D0).AND.(AM2.LT.121.0D0)) THEN
21818 C FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
21819 FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
21820 & * (ONE+EPSPOL*Q2/AM2)
21821 SUM = SUM+WEIGHT(J)*FAC
21824 SDIR = DT_SIGVP(X,Q2)
21825 STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*SDIR
21826 SDIR = SDIR/(0.588D0+RL2+Q2)
21827 C STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*DT_SIGVP(X,Q2)
21828 ELSEIF (MODEGA.EQ.3) THEN
21829 CALL DT_SIGGA(1,XI,Q2I,ECMI,ZERO,STOT,ETOT,SINE,EINE,DUM)
21830 ELSEIF (MODEGA.EQ.4) THEN
21831 * load cross sections from PHOJET interpolation table
21833 IF(ECM.LE.SIGECM(IP,1)) THEN
21836 ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
21838 IF (ECM.LE.SIGECM(IP,I)) GOTO 3
21844 WRITE(LOUT,'(/1X,A,2E12.3)')
21845 & 'SIGGP:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
21850 IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
21851 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
21853 * cross section dependence on photon virtuality
21856 FSUP1 = FSUP1+PARMDL(26+I)*(1.D0+Q2/(4.D0*PARMDL(30+I)))
21857 & /(1.D0+Q2/PARMDL(30+I))**2
21859 FSUP1 = FSUP1+PARMDL(30)/(1.D0+Q2/PARMDL(34))
21863 STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
21864 SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
21865 SDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
21869 SDIR = SDIR/(FSUP1*FSUP2)
21878 *$ CREATE DT_SIGVEL.FOR
21881 *===sigvel=============================================================*
21883 SUBROUTINE DT_SIGVEL(XI,Q2I,ECMI,XNUI,IDXV,SVEL,SIG1,SIG2)
21885 ************************************************************************
21886 * Cross section for elastic vector meson production *
21887 * This version dated 10.05.96 is written by S. Roesler *
21888 ************************************************************************
21890 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21893 PARAMETER ( LINP = 10 ,
21897 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
21898 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
21900 & GEV2MB = 0.38938D0,
21901 & ALPHEM = ONE/137.0D0)
21903 * particle properties (BAMJET index convention)
21905 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21906 & IICH(210),IIBAR(210),K1(210),K2(210)
21908 * VDM parameter for photon-nucleus interactions
21909 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21912 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21913 & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
21917 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21919 X = Q2/(W2+Q2-AAM(1)**2)
21921 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
21922 X = Q2/(W2+Q2-AAM(1)**2)
21923 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21924 Q2 = (W2-AAM(1)**2)*X/(ONE-X)
21925 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
21926 W2 = Q2*(ONE-X)/X+AAM(1)**2
21928 WRITE(LOUT,*) 'SIGVEL: inconsistent input ',W2,Q2,X
21936 BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
21937 & +0.25D0*LOG(W2/(AMV2+Q2)))*GEV2MB
21939 STOVP = DT_SIGVP(X,Q2)/(AMV2+Q2+RL2)
21940 SELVP = STOVP**2*(ONE+ROSH**2)/(8.0D0*TWOPI*BSLOPE)
21942 IF (IDXV.EQ.33) THEN
21947 SIG1 = (AMV2/(AMV2+Q2))**2 * (ONE+EPSPOL*Q2/AMV2)
21949 SVEL = COUPL * (AMV2/(AMV2+Q2))**2
21950 & * (ONE+EPSPOL*Q2/AMV2) * SELVP
21955 *$ CREATE DT_SIGVP.FOR
21958 *===sigvp==============================================================*
21960 DOUBLE PRECISION FUNCTION DT_SIGVP(XI,Q2I)
21962 ************************************************************************
21964 ************************************************************************
21966 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21969 PARAMETER ( LINP = 10 ,
21973 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
21974 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
21976 & GEV2MB = 0.38938D0,
21977 & AMPROT = 0.938D0,
21978 & ALPHEM = ONE/137.0D0)
21980 * VDM parameter for photon-nucleus interactions
21981 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21985 IF (XI.LE.ZERO) X = 0.0001D0
21986 IF (Q2I.LE.ZERO) Q2 = 0.0001D0
21988 ECM = SQRT( Q2*(ONE-X)/X+AMPROT**2 )
21991 IF (MODEGA.EQ.1) THEN
21992 CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
21996 C ALLMF2 = PHO_ALLM97(Q2,W)
21998 C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
21999 C STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
22000 C DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))
22001 DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))*GEV2MB
22002 ELSEIF (MODEGA.EQ.4) THEN
22003 CALL DT_SIGGP(X,Q2,ECM,DUM1,STOT,DUM2,DUM3)
22004 C F2 = Q2*(ONE-X)/(TWOPI**2*ALPHEM*GEV2MB) * STOT
22005 DT_SIGVP = 3.0D0*PI/(ALPHEM*DT_RRM2(X,Q2)) * STOT
22007 STOP ' DT_SIGVP: F2 not defined for this MODEGA !'
22014 *$ CREATE DT_RRM2.FOR
22017 *===RRM2===============================================================*
22019 DOUBLE PRECISION FUNCTION DT_RRM2(X,Q2)
22021 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22024 PARAMETER ( LINP = 10 ,
22028 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22029 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22031 & GEV2MB = 0.38938D0)
22033 * particle properties (BAMJET index convention)
22035 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22036 & IICH(210),IIBAR(210),K1(210),K2(210)
22038 * VDM parameter for photon-nucleus interactions
22039 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22041 S = Q2*(ONE-X)/X+AAM(1)**2
22044 IF (INTRGE(1).EQ.1) THEN
22045 AMLO2 = (3.0D0*AAM(13))**2
22046 ELSEIF (INTRGE(1).EQ.2) THEN
22051 IF (INTRGE(2).EQ.1) THEN
22053 ELSEIF (INTRGE(2).EQ.2) THEN
22058 AMHI20 = (ECM-AAM(1))**2
22059 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22063 IF (AMHI2.LE.AM1C2) THEN
22064 DT_RRM2 = TWO*DT_RM2(AMLO2,AMHI2,Q2)
22065 ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22066 DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22067 & 10.0D0/3.0D0*DT_RM2(AM1C2,AMHI2,Q2)
22069 DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22070 & 10.0D0/3.0D0*DT_RM2(AM1C2,AM2C2,Q2)+
22071 & 11.0D0/3.0D0*DT_RM2(AM2C2,AMHI2,Q2)
22077 *$ CREATE DT_RM2.FOR
22080 *===RM2================================================================*
22082 DOUBLE PRECISION FUNCTION DT_RM2(AMLO2,AMHI2,Q2)
22084 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22087 PARAMETER ( LINP = 10 ,
22091 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22092 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22094 & GEV2MB = 0.38938D0)
22096 * VDM parameter for photon-nucleus interactions
22097 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22099 IF (RL2.LE.ZERO) THEN
22100 DT_RM2 = -ONE/(AMHI2+Q2)+Q2/(TWO*(AMHI2+Q2)**2) -
22101 & (-ONE/(AMLO2+Q2)+Q2/(TWO*(AMLO2+Q2)**2))
22102 & +EPSPOL*(-Q2/(TWO*(AMHI2+Q2)**2)+Q2/(TWO*(AMLO2+Q2)**2))
22104 TMPMLO = LOG(ONE+RL2/(AMLO2+Q2))
22105 TMPMHI = LOG(ONE+RL2/(AMHI2+Q2))
22106 DT_RM2 = Q2/(RL2*(AMHI2+Q2))-(Q2+RL2)/RL2**2*TMPMHI
22107 & -(Q2/(RL2*(AMLO2+Q2))-(Q2+RL2)/RL2**2*TMPMLO)
22109 & -Q2/(RL2*(AMHI2+Q2))+Q2/RL2**2*TMPMHI
22110 & -(-Q2/(RL2*(AMLO2+Q2))+Q2/RL2**2*TMPMLO))
22116 *$ CREATE DT_SAM2.FOR
22119 *===SAM2===============================================================*
22121 DOUBLE PRECISION FUNCTION DT_SAM2(Q2,ECM)
22123 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22126 PARAMETER ( LINP = 10 ,
22130 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
22131 & TENTRD=10.0D0/3.0D0,ELVTRD=11.0D0/3.0D0)
22132 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22134 & GEV2MB = 0.38938D0)
22136 * particle properties (BAMJET index convention)
22138 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22139 & IICH(210),IIBAR(210),K1(210),K2(210)
22141 * VDM parameter for photon-nucleus interactions
22142 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22145 IF (INTRGE(1).EQ.1) THEN
22146 AMLO2 = (3.0D0*AAM(13))**2
22147 ELSEIF (INTRGE(1).EQ.2) THEN
22152 IF (INTRGE(2).EQ.1) THEN
22154 ELSEIF (INTRGE(2).EQ.2) THEN
22159 AMHI20 = (ECM-AAM(1))**2
22160 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22164 YLO = LOG(AMLO2+Q2)
22165 YC1 = LOG(AM1C2+Q2)
22166 YC2 = LOG(AM2C2+Q2)
22167 YHI = LOG(AMHI2+Q2)
22168 IF (AMHI2.LE.AM1C2) THEN
22170 ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22177 YSAM2 = YLO+(YHI-YLO)*DT_RNDM(AM1C2)
22178 IF (YSAM2.LE.YC1) THEN
22180 ELSEIF ((YSAM2.GT.YC1).AND.(YSAM2.LE.YC2)) THEN
22185 WEIGMX = FACHI*(ONE-Q2*EXP( -YHI))
22186 XSAM2 = FAC *(ONE-Q2*EXP(-YSAM2))
22187 IF (DT_RNDM(YSAM2)*WEIGMX.GT.XSAM2) GOTO 1
22189 DT_SAM2 = EXP(YSAM2)-Q2
22194 *$ CREATE DT_CKMT.FOR
22197 *===ckmt===============================================================*
22199 SUBROUTINE DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,
22202 ************************************************************************
22203 * This version dated 31.01.96 is written by S. Roesler *
22204 ************************************************************************
22206 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22209 PARAMETER ( LINP = 10 ,
22213 PARAMETER (ZERO=0.0D0,TWO=2.0D0,TINY10=1.0D-10)
22215 PARAMETER (Q02 = 2.0D0,
22219 DIMENSION PD(-6:6),SEA(3),VAL(2)
22221 CALL DT_PDF0(Q02,X,F2Q0,VAL,SEA,GLU,IPAR)
22222 CALL DT_PDF0(Q12,X,F2Q1,VAL,SEA,GLU,IPAR)
22223 ADQ2 = LOG10(Q12)-LOG10(Q02)
22224 F2P = (F2Q1-F2Q0)/ADQ2
22225 CALL DT_CKMTX(IPAR,X,Q02,PD,F2PQ0)
22226 CALL DT_CKMTX(IPAR,X,Q12,PD,F2PQ1)
22227 F2PP = (F2PQ1-F2PQ0)/ADQ2
22228 FX = (F2P-F2PP)/(F2PP+LOG(DQ2)*F2PQ0+TINY10)*Q02
22230 Q2 = MAX(SCALE**2.0D0,TINY10)
22231 SMOOTH = 1.0D0+FX*(Q2-Q02)/Q2**2
22232 IF (Q2.LT.Q02) THEN
22233 CALL DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22244 CALL DT_CKMTX(IPAR,X,Q2,PD,F2)
22257 C USEA = USEA*SMOOTH
22258 C DSEA = DSEA*SMOOTH
22268 *$ CREATE DT_CKMTX.FOR
22270 SUBROUTINE DT_CKMTX(IPAR,X,SCALE2,PD,F2)
22271 C**********************************************************************
22273 C PDF based on Regge theory, evolved with .... by ....
22275 C input: IPAR 2212 proton (not installed)
22279 C output: PD(-6:6) x*f(x) parton distribution functions
22280 C (PDFLIB convention: d = PD(1), u = PD(2) )
22282 C**********************************************************************
22285 DOUBLE PRECISION X,SCALE2,PD(-6:6),CDN,CUP,F2
22287 PARAMETER ( LINP = 10 ,
22296 C QCD lambda for evolution
22299 C Q0**2 for evolution
22303 C the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
22304 C q(6)=x*charm, q(7)=x*gluon
22308 2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
22310 IF(IPAR.EQ.2212) THEN
22311 CALL DT_CKMTPR(1,0,XX,SB,QQ(1))
22312 CALL DT_CKMTPR(2,0,XX,SB,QQ(2))
22313 CALL DT_CKMTPR(3,0,XX,SB,QQ(3))
22314 CALL DT_CKMTPR(4,0,XX,SB,QQ(4))
22315 CALL DT_CKMTPR(5,0,XX,SB,QQ(5))
22316 CALL DT_CKMTPR(8,0,XX,SB,QQ(6))
22317 CALL DT_CKMTPR(7,0,XX,SB,QQ(7))
22318 C ELSEIF (IPAR.EQ.45) THEN
22319 C CALL CKMTPO(1,0,XX,SB,QQ(1))
22320 C CALL CKMTPO(2,0,XX,SB,QQ(2))
22321 C CALL CKMTPO(3,0,XX,SB,QQ(3))
22322 C CALL CKMTPO(4,0,XX,SB,QQ(4))
22323 C CALL CKMTPO(5,0,XX,SB,QQ(5))
22324 C CALL CKMTPO(8,0,XX,SB,QQ(6))
22325 C CALL CKMTPO(7,0,XX,SB,QQ(7))
22326 ELSEIF (IPAR.EQ.100) THEN
22327 CALL DT_CKMTDE(1,0,XX,SB,QQ(1))
22328 CALL DT_CKMTDE(2,0,XX,SB,QQ(2))
22329 CALL DT_CKMTDE(3,0,XX,SB,QQ(3))
22330 CALL DT_CKMTDE(4,0,XX,SB,QQ(4))
22331 CALL DT_CKMTDE(5,0,XX,SB,QQ(5))
22332 CALL DT_CKMTDE(8,0,XX,SB,QQ(6))
22333 CALL DT_CKMTDE(7,0,XX,SB,QQ(7))
22335 WRITE(LOUT,'(1X,A,I4,A)')
22336 & 'CKMTX: IPAR =',IPAR,' not implemented!'
22342 PD(-4) = DBLE(QQ(6))
22343 PD(-3) = DBLE(QQ(3))
22344 PD(-2) = DBLE(QQ(4))
22345 PD(-1) = DBLE(QQ(5))
22346 PD(0) = DBLE(QQ(7))
22347 PD(1) = DBLE(QQ(2))
22348 PD(2) = DBLE(QQ(1))
22349 PD(3) = DBLE(QQ(3))
22350 PD(4) = DBLE(QQ(6))
22353 IF(IPAR.EQ.45) THEN
22354 CDN = (PD(1)-PD(-1))/2.D0
22355 CUP = (PD(2)-PD(-2))/2.D0
22356 PD(-1) = PD(-1) + CDN
22357 PD(-2) = PD(-2) + CUP
22361 F2 = 4.0D0/9.0D0*(PD(2)-PD(3)+2.0D0*PD(3))+
22362 & 1.0D0/9.0D0*(PD(1)-PD(3)+2.0D0*PD(3))+
22363 & 1.0D0/9.0D0*(2.0D0*PD(3))+4.0D0/9.0D0*(2.0D0*PD(4))
22367 *$ CREATE DT_PDF0.FOR
22370 *===pdf0===============================================================*
22372 SUBROUTINE DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22374 ************************************************************************
22375 * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 *
22376 * an F_2-ansatz given in Capella et al. PLB 337(1994)358. *
22377 * IPAR = 2212 proton *
22379 * This version dated 31.01.96 is written by S. Roesler *
22380 ************************************************************************
22382 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22385 PARAMETER ( LINP = 10 ,
22389 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22398 & DELTA0 = 0.07684D0,
22403 & ALPHAR = 0.415D0,
22407 PARAMETER (NPOINT=16)
22408 C DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
22409 DIMENSION SEA(3),VAL(2)
22411 DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22412 AN = 1.5D0*(1.0D0+Q2/(Q2+C))
22414 IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22415 CALL DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22416 SEA(1) = 0.75D0*SEA0
22419 VAL(1) = 9.0D0/4.0D0*VALU0
22420 VAL(2) = 9.0D0*VALD0
22421 GLU0 = SEA(1)/(1.0D0-X)
22422 F2 = SEA0+VALU0+VALD0
22423 F2PDF = 4.0D0/9.0D0*(VAL(1)+2.0D0*SEA(1))+
22424 & 1.0D0/9.0D0*(VAL(2)+2.0D0*SEA(2))+
22425 & 1.0D0/9.0D0*(2.0D0*SEA(3))
22426 IF (ABS(F2-F2PDF).GT.TINY9) THEN
22427 WRITE(LOUT,'(1X,A,2E15.5)') 'inconsistent PDF! ',F2,F2PDF
22431 C CALL GSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22434 C CALL PHO_GAUSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22440 C CALL DT_CKMTQ0(Q2,ABSZX(J),IPAR,VALU0,VALD0,SEA0)
22441 C VALU0 = 9.0D0/4.0D0*VALU0
22442 C VALD0 = 9.0D0*VALD0
22443 C SEA0 = 0.75D0*SEA0
22444 C SUMQ = SUMQ+ (VALU0+VALD0+6.0D0*SEA0) *WEIGHT(J)
22445 C SUMG = SUMG+ (SEA0/(1.0D0-ABSZX(J))) *WEIGHT(J)
22447 C GLU = GLU0*(1.0D0-SUMQ)/SUMG
22449 WRITE(LOUT,'(1X,A,I4,A)')
22450 & 'PDF0: IPAR =',IPAR,' not implemented!'
22457 *$ CREATE DT_CKMTQ0.FOR
22460 *===ckmtq0=============================================================*
22462 SUBROUTINE DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22464 ************************************************************************
22465 * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 *
22466 * an F_2-ansatz given in Capella et al. PLB 337(1994)358. *
22467 * IPAR = 2212 proton *
22469 * This version dated 31.01.96 is written by S. Roesler *
22470 ************************************************************************
22472 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22475 PARAMETER ( LINP = 10 ,
22479 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22488 & DELTA0 = 0.07684D0,
22493 & ALPHAR = 0.415D0,
22497 DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22498 AN = 1.5D0*(1.0D0+Q2/(Q2+C))
22500 IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22501 IF (IPAR.EQ.2212) THEN
22508 SEA0 = AA*X**(-DELTA)*(1.0D0-X)**(AN+4.0D0)*
22509 & (Q2/(Q2+A))**(1.0D0+DELTA)
22510 VALU0 = BU*X**(1.0D0-ALPHAR)*(1.0D0-X)**AN*
22511 & (Q2/(Q2+B))**(ALPHAR)
22512 VALD0 = BD*X**(1.0D0-ALPHAR)*(1.0D0-X)**(AN+1.0D0)*
22513 & (Q2/(Q2+B))**(ALPHAR)
22515 WRITE(LOUT,'(1X,A,I4,A)')
22516 & 'CKMTQ0: IPAR =',IPAR,' not implemented!'
22524 *$ CREATE DT_CKMTDE.FOR
22526 SUBROUTINE DT_CKMTDE(I,NDRV,X,S,ANS)
22528 C**********************************************************************
22530 C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
22532 C This version by S. Roesler, 30.01.96
22533 C**********************************************************************
22536 DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
22537 EQUIVALENCE (GF(1,1,1),DL(1))
22540 DATA (DL(K),K= 1, 85) /
22541 &0.351858E+00,0.388489E+00,0.325356E+00,0.325356E+00,0.325356E+00,
22542 &0.325356E+00,0.445218E+01,0.000000E+00,0.419818E+00,0.459249E+00,
22543 &0.391167E+00,0.391143E+00,0.391125E+00,0.391167E+00,0.628186E+01,
22544 &0.703797E-01,0.498333E+00,0.540626E+00,0.467466E+00,0.467423E+00,
22545 &0.467393E+00,0.467466E+00,0.837368E+01,0.151191E+00,0.587839E+00,
22546 &0.633058E+00,0.554689E+00,0.554630E+00,0.554595E+00,0.554689E+00,
22547 &0.107170E+02,0.242877E+00,0.688652E+00,0.736861E+00,0.653150E+00,
22548 &0.653080E+00,0.653046E+00,0.653150E+00,0.132960E+02,0.345760E+00,
22549 &0.800961E+00,0.852226E+00,0.763038E+00,0.762961E+00,0.762933E+00,
22550 &0.763038E+00,0.160884E+02,0.460033E+00,0.924829E+00,0.979213E+00,
22551 &0.884414E+00,0.884335E+00,0.884319E+00,0.884414E+00,0.190679E+02,
22552 &0.585764E+00,0.106016E+01,0.111773E+01,0.101719E+01,0.101711E+01,
22553 &0.101711E+01,0.101719E+01,0.222033E+02,0.722864E+00,0.120670E+01,
22554 &0.126752E+01,0.116110E+01,0.116102E+01,0.116105E+01,0.116110E+01,
22555 &0.254603E+02,0.871079E+00,0.136402E+01,0.142815E+01,0.131571E+01,
22556 &0.131565E+01,0.131570E+01,0.131571E+01,0.288020E+02,0.102998E+01,
22557 &0.153151E+01,0.159900E+01,0.148043E+01,0.148038E+01,0.148046E+01/
22558 DATA (DL(K),K= 86, 170) /
22559 &0.148043E+01,0.321898E+02,0.119897E+01,0.170838E+01,0.177930E+01,
22560 &0.165447E+01,0.165444E+01,0.165455E+01,0.165447E+01,0.355845E+02,
22561 &0.137726E+01,0.189369E+01,0.196807E+01,0.183687E+01,0.183686E+01,
22562 &0.183701E+01,0.183687E+01,0.389473E+02,0.156390E+01,0.208631E+01,
22563 &0.216422E+01,0.202653E+01,0.202654E+01,0.202673E+01,0.202653E+01,
22564 &0.422402E+02,0.175779E+01,0.228501E+01,0.236648E+01,0.222220E+01,
22565 &0.222224E+01,0.222248E+01,0.222220E+01,0.454277E+02,0.195768E+01,
22566 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22567 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22568 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22569 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22570 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22571 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22572 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22573 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22574 &0.326035E+00,0.380777E+00,0.286363E+00,0.286363E+00,0.286363E+00,
22575 &0.286363E+00,0.392252E+01,-.138778E-16,0.380092E+00,0.438587E+00/
22576 DATA (DL(K),K= 171, 255) /
22577 &0.337452E+00,0.337430E+00,0.337424E+00,0.337452E+00,0.532193E+01,
22578 &0.553645E-01,0.440879E+00,0.503177E+00,0.395208E+00,0.395169E+00,
22579 &0.395165E+00,0.395208E+00,0.686454E+01,0.117354E+00,0.508415E+00,
22580 &0.574566E+00,0.459649E+00,0.459600E+00,0.459604E+00,0.459649E+00,
22581 &0.853316E+01,0.185994E+00,0.582647E+00,0.652699E+00,0.530722E+00,
22582 &0.530667E+00,0.530687E+00,0.530722E+00,0.103093E+02,0.261237E+00,
22583 &0.663404E+00,0.737405E+00,0.608254E+00,0.608199E+00,0.608241E+00,
22584 &0.608254E+00,0.121710E+02,0.342917E+00,0.750429E+00,0.828423E+00,
22585 &0.691990E+00,0.691941E+00,0.692009E+00,0.691990E+00,0.140946E+02,
22586 &0.430783E+00,0.843361E+00,0.925391E+00,0.781571E+00,0.781533E+00,
22587 &0.781632E+00,0.781571E+00,0.160553E+02,0.524479E+00,0.941741E+00,
22588 &0.102784E+01,0.876538E+00,0.876515E+00,0.876650E+00,0.876538E+00,
22589 &0.180277E+02,0.623549E+00,0.104501E+01,0.113521E+01,0.976335E+00,
22590 &0.976332E+00,0.976506E+00,0.976335E+00,0.199863E+02,0.727439E+00,
22591 &0.115251E+01,0.124685E+01,0.108031E+01,0.108034E+01,0.108055E+01,
22592 &0.108031E+01,0.219066E+02,0.835506E+00,0.126352E+01,0.136201E+01,
22593 &0.118775E+01,0.118780E+01,0.118806E+01,0.118775E+01,0.237652E+02/
22594 DATA (DL(K),K= 256, 340) /
22595 &0.947020E+00,0.137724E+01,0.147989E+01,0.129783E+01,0.129791E+01,
22596 &0.129822E+01,0.129783E+01,0.255406E+02,0.106119E+01,0.149279E+01,
22597 &0.159961E+01,0.140972E+01,0.140984E+01,0.141019E+01,0.140972E+01,
22598 &0.272135E+02,0.117715E+01,0.160929E+01,0.172028E+01,0.152252E+01,
22599 &0.152267E+01,0.152308E+01,0.152252E+01,0.287669E+02,0.129402E+01,
22600 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22601 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22602 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22603 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22604 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22605 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22606 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22607 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22608 &0.309785E+00,0.391282E+00,0.250518E+00,0.250518E+00,0.250518E+00,
22609 &0.250518E+00,0.343842E+01,-.138778E-16,0.352113E+00,0.438463E+00,
22610 &0.288877E+00,0.288863E+00,0.288878E+00,0.288877E+00,0.446765E+01,
22611 &0.424850E-01,0.398382E+00,0.489596E+00,0.331132E+00,0.331111E+00/
22612 DATA (DL(K),K= 341, 425) /
22613 &0.331148E+00,0.331132E+00,0.555902E+01,0.888369E-01,0.448375E+00,
22614 &0.544458E+00,0.377064E+00,0.377043E+00,0.377108E+00,0.377064E+00,
22615 &0.669490E+01,0.138845E+00,0.501854E+00,0.602811E+00,0.426440E+00,
22616 &0.426425E+00,0.426523E+00,0.426440E+00,0.785892E+01,0.192281E+00,
22617 &0.558506E+00,0.664331E+00,0.478946E+00,0.478944E+00,0.479079E+00,
22618 &0.478946E+00,0.903368E+01,0.248834E+00,0.617972E+00,0.728657E+00,
22619 &0.534229E+00,0.534244E+00,0.534421E+00,0.534229E+00,0.102022E+02,
22620 &0.308155E+00,0.679844E+00,0.795370E+00,0.591883E+00,0.591921E+00,
22621 &0.592141E+00,0.591883E+00,0.113479E+02,0.369841E+00,0.743667E+00,
22622 &0.864009E+00,0.651460E+00,0.651525E+00,0.651792E+00,0.651460E+00,
22623 &0.124553E+02,0.433447E+00,0.808951E+00,0.934073E+00,0.712474E+00,
22624 &0.712571E+00,0.712885E+00,0.712474E+00,0.135102E+02,0.498486E+00,
22625 &0.875171E+00,0.100503E+01,0.774408E+00,0.774541E+00,0.774902E+00,
22626 &0.774408E+00,0.144999E+02,0.564446E+00,0.941784E+00,0.107632E+01,
22627 &0.836726E+00,0.836897E+00,0.837307E+00,0.836726E+00,0.154136E+02,
22628 &0.630788E+00,0.100823E+01,0.114738E+01,0.898879E+00,0.899092E+00,
22629 &0.899551E+00,0.898879E+00,0.162423E+02,0.696967E+00,0.107396E+01/
22630 DATA (DL(K),K= 426, 510) /
22631 &0.121764E+01,0.960319E+00,0.960577E+00,0.961084E+00,0.960319E+00,
22632 &0.169791E+02,0.762433E+00,0.113843E+01,0.128655E+01,0.102051E+01,
22633 &0.102081E+01,0.102137E+01,0.102051E+01,0.176190E+02,0.826647E+00,
22634 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22635 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22636 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22637 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22638 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22639 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22640 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22641 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22642 &0.304680E+00,0.425088E+00,0.216504E+00,0.216504E+00,0.216504E+00,
22643 &0.216504E+00,0.298356E+01,0.000000E+00,0.337300E+00,0.463627E+00,
22644 &0.244023E+00,0.244024E+00,0.244063E+00,0.244023E+00,0.370271E+01,
22645 &0.316585E-01,0.371787E+00,0.503942E+00,0.273415E+00,0.273423E+00,
22646 &0.273505E+00,0.273415E+00,0.443039E+01,0.651685E-01,0.407853E+00,
22647 &0.545739E+00,0.304395E+00,0.304418E+00,0.304545E+00,0.304395E+00/
22648 DATA (DL(K),K= 511, 595) /
22649 &0.515321E+01,0.100252E+00,0.445229E+00,0.588741E+00,0.336700E+00,
22650 &0.336744E+00,0.336918E+00,0.336700E+00,0.586004E+01,0.136648E+00,
22651 &0.483606E+00,0.632629E+00,0.370026E+00,0.370095E+00,0.370318E+00,
22652 &0.370026E+00,0.654027E+01,0.174056E+00,0.522666E+00,0.677074E+00,
22653 &0.404062E+00,0.404162E+00,0.404433E+00,0.404062E+00,0.718442E+01,
22654 &0.212167E+00,0.562075E+00,0.721735E+00,0.438483E+00,0.438618E+00,
22655 &0.438938E+00,0.438483E+00,0.778423E+01,0.250658E+00,0.601494E+00,
22656 &0.766258E+00,0.472959E+00,0.473131E+00,0.473500E+00,0.472959E+00,
22657 &0.833276E+01,0.289199E+00,0.640580E+00,0.810290E+00,0.507156E+00,
22658 &0.507369E+00,0.507784E+00,0.507156E+00,0.882448E+01,0.327457E+00,
22659 &0.678993E+00,0.853479E+00,0.540747E+00,0.541003E+00,0.541463E+00,
22660 &0.540747E+00,0.925529E+01,0.365104E+00,0.716405E+00,0.895483E+00,
22661 &0.573411E+00,0.573714E+00,0.574216E+00,0.573411E+00,0.962250E+01,
22662 &0.401821E+00,0.752501E+00,0.935975E+00,0.604848E+00,0.605197E+00,
22663 &0.605740E+00,0.604848E+00,0.992478E+01,0.437304E+00,0.786987E+00,
22664 &0.974647E+00,0.634775E+00,0.635173E+00,0.635752E+00,0.634775E+00,
22665 &0.101620E+02,0.471269E+00,0.819594E+00,0.101122E+01,0.662936E+00/
22666 DATA (DL(K),K= 596, 680) /
22667 &0.663382E+00,0.663995E+00,0.662936E+00,0.103354E+02,0.503459E+00,
22668 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22669 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22670 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22671 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22672 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22673 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22674 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22675 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22676 &0.312661E+00,0.487836E+00,0.182562E+00,0.182562E+00,0.182562E+00,
22677 &0.182562E+00,0.253626E+01,0.000000E+00,0.336910E+00,0.518440E+00,
22678 &0.200702E+00,0.200721E+00,0.200779E+00,0.200702E+00,0.299460E+01,
22679 &0.224425E-01,0.361554E+00,0.549164E+00,0.219359E+00,0.219402E+00,
22680 &0.219517E+00,0.219359E+00,0.343183E+01,0.453742E-01,0.386348E+00,
22681 &0.579759E+00,0.238296E+00,0.238367E+00,0.238536E+00,0.238296E+00,
22682 &0.384076E+01,0.685610E-01,0.411080E+00,0.610003E+00,0.257305E+00,
22683 &0.257408E+00,0.257630E+00,0.257305E+00,0.421619E+01,0.917987E-01/
22684 DATA (DL(K),K= 681, 765) /
22685 &0.435528E+00,0.639668E+00,0.276174E+00,0.276313E+00,0.276583E+00,
22686 &0.276174E+00,0.455400E+01,0.114876E+00,0.459476E+00,0.668531E+00,
22687 &0.294698E+00,0.294875E+00,0.295191E+00,0.294698E+00,0.485107E+01,
22688 &0.137589E+00,0.482719E+00,0.696375E+00,0.312682E+00,0.312900E+00,
22689 &0.313258E+00,0.312682E+00,0.510539E+01,0.159742E+00,0.505060E+00,
22690 &0.722995E+00,0.329941E+00,0.330200E+00,0.330596E+00,0.329941E+00,
22691 &0.531589E+01,0.181149E+00,0.526315E+00,0.748199E+00,0.346303E+00,
22692 &0.346604E+00,0.347034E+00,0.346303E+00,0.548250E+01,0.201638E+00,
22693 &0.546317E+00,0.771808E+00,0.361613E+00,0.361957E+00,0.362418E+00,
22694 &0.361613E+00,0.560595E+01,0.221052E+00,0.564917E+00,0.793667E+00,
22695 &0.375735E+00,0.376122E+00,0.376609E+00,0.375735E+00,0.568772E+01,
22696 &0.239253E+00,0.581987E+00,0.813638E+00,0.388553E+00,0.388982E+00,
22697 &0.389491E+00,0.388553E+00,0.572992E+01,0.256122E+00,0.597419E+00,
22698 &0.831608E+00,0.399972E+00,0.400443E+00,0.400970E+00,0.399972E+00,
22699 &0.573516E+01,0.271562E+00,0.611129E+00,0.847487E+00,0.409919E+00,
22700 &0.410430E+00,0.410972E+00,0.409919E+00,0.570642E+01,0.285497E+00,
22701 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22702 DATA (DL(K),K= 766, 850) /
22703 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22704 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22705 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22706 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22707 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22708 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22709 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22710 &0.335149E+00,0.582072E+00,0.146415E+00,0.146415E+00,0.146415E+00,
22711 &0.146415E+00,0.206772E+01,0.000000E+00,0.351552E+00,0.603437E+00,
22712 &0.156515E+00,0.156542E+00,0.156595E+00,0.156515E+00,0.231143E+01,
22713 &0.146091E-01,0.367407E+00,0.623737E+00,0.166387E+00,0.166442E+00,
22714 &0.166542E+00,0.166387E+00,0.252488E+01,0.289315E-01,0.382571E+00,
22715 &0.642832E+00,0.175891E+00,0.175976E+00,0.176118E+00,0.175891E+00,
22716 &0.270658E+01,0.428312E-01,0.396926E+00,0.660609E+00,0.184917E+00,
22717 &0.185034E+00,0.185212E+00,0.184917E+00,0.285608E+01,0.561981E-01,
22718 &0.410365E+00,0.676962E+00,0.193365E+00,0.193513E+00,0.193722E+00,
22719 &0.193365E+00,0.297375E+01,0.689319E-01,0.422792E+00,0.691796E+00/
22720 DATA (DL(K),K= 851, 935) /
22721 &0.201144E+00,0.201324E+00,0.201560E+00,0.201144E+00,0.306050E+01,
22722 &0.809434E-01,0.434123E+00,0.705030E+00,0.208181E+00,0.208393E+00,
22723 &0.208650E+00,0.208181E+00,0.311775E+01,0.921567E-01,0.444287E+00,
22724 &0.716596E+00,0.214413E+00,0.214656E+00,0.214931E+00,0.214413E+00,
22725 &0.314738E+01,0.102508E+00,0.453228E+00,0.726441E+00,0.219792E+00,
22726 &0.220066E+00,0.220354E+00,0.219792E+00,0.315156E+01,0.111949E+00,
22727 &0.460906E+00,0.734527E+00,0.224285E+00,0.224589E+00,0.224886E+00,
22728 &0.224285E+00,0.313271E+01,0.120441E+00,0.467291E+00,0.740835E+00,
22729 &0.227870E+00,0.228203E+00,0.228506E+00,0.227870E+00,0.309338E+01,
22730 &0.127963E+00,0.472372E+00,0.745357E+00,0.230541E+00,0.230902E+00,
22731 &0.231208E+00,0.230541E+00,0.303621E+01,0.134506E+00,0.476148E+00,
22732 &0.748105E+00,0.232304E+00,0.232690E+00,0.232996E+00,0.232304E+00,
22733 &0.296381E+01,0.140070E+00,0.478635E+00,0.749103E+00,0.233176E+00,
22734 &0.233586E+00,0.233889E+00,0.233176E+00,0.287874E+01,0.144672E+00,
22735 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22736 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22737 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22738 DATA (DL(K),K= 936, 1020) /
22739 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22740 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22741 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22742 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22743 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22744 &0.370162E+00,0.695827E+00,0.105823E+00,0.105823E+00,0.105823E+00,
22745 &0.105823E+00,0.154556E+01,0.208167E-16,0.378214E+00,0.703794E+00,
22746 &0.109539E+00,0.109554E+00,0.109571E+00,0.109539E+00,0.162770E+01,
22747 &0.818783E-02,0.385258E+00,0.710067E+00,0.112818E+00,0.112847E+00,
22748 &0.112879E+00,0.112818E+00,0.168578E+01,0.158212E-01,0.391264E+00,
22749 &0.714648E+00,0.115620E+00,0.115666E+00,0.115709E+00,0.115620E+00,
22750 &0.172175E+01,0.228667E-01,0.396214E+00,0.717539E+00,0.117923E+00,
22751 &0.117985E+00,0.118037E+00,0.117923E+00,0.173756E+01,0.293009E-01,
22752 &0.400098E+00,0.718759E+00,0.119711E+00,0.119790E+00,0.119848E+00,
22753 &0.119711E+00,0.173541E+01,0.351123E-01,0.402915E+00,0.718332E+00,
22754 &0.120979E+00,0.121074E+00,0.121137E+00,0.120979E+00,0.171755E+01,
22755 &0.402951E-01,0.404672E+00,0.716292E+00,0.121728E+00,0.121840E+00/
22756 DATA (DL(K),K= 1021, 1105) /
22757 &0.121905E+00,0.121728E+00,0.168619E+01,0.448514E-01,0.405385E+00,
22758 &0.712681E+00,0.121967E+00,0.122095E+00,0.122161E+00,0.121967E+00,
22759 &0.164352E+01,0.487902E-01,0.405077E+00,0.707551E+00,0.121712E+00,
22760 &0.121855E+00,0.121920E+00,0.121712E+00,0.159162E+01,0.521265E-01,
22761 &0.403778E+00,0.700963E+00,0.120984E+00,0.121141E+00,0.121204E+00,
22762 &0.120984E+00,0.153245E+01,0.548814E-01,0.401525E+00,0.692984E+00,
22763 &0.119809E+00,0.119980E+00,0.120040E+00,0.119809E+00,0.146780E+01,
22764 &0.570807E-01,0.398361E+00,0.683691E+00,0.118218E+00,0.118402E+00,
22765 &0.118457E+00,0.118218E+00,0.139928E+01,0.587542E-01,0.394333E+00,
22766 &0.673166E+00,0.116244E+00,0.116440E+00,0.116490E+00,0.116244E+00,
22767 &0.132834E+01,0.599355E-01,0.389495E+00,0.661496E+00,0.113924E+00,
22768 &0.114131E+00,0.114175E+00,0.113924E+00,0.125620E+01,0.606602E-01,
22769 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22770 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22771 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22772 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22773 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22774 DATA (DL(K),K= 1106, 1190) /
22775 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22776 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22777 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22778 &0.394012E+00,0.757115E+00,0.772117E-01,0.772117E-01,0.772117E-01,
22779 &0.772117E-01,0.117279E+01,0.346945E-17,0.395841E+00,0.752988E+00,
22780 &0.780501E-01,0.780655E-01,0.780723E-01,0.780501E-01,0.118528E+01,
22781 &0.491697E-02,0.396627E+00,0.747223E+00,0.785386E-01,0.785692E-01,
22782 &0.785806E-01,0.785386E-01,0.118242E+01,0.932754E-02,0.396401E+00,
22783 &0.739901E+00,0.786820E-01,0.787273E-01,0.787413E-01,0.786820E-01,
22784 &0.116673E+01,0.132427E-01,0.395190E+00,0.731092E+00,0.784870E-01,
22785 &0.785464E-01,0.785613E-01,0.784870E-01,0.114033E+01,0.166738E-01,
22786 &0.393030E+00,0.720878E+00,0.779683E-01,0.780410E-01,0.780555E-01,
22787 &0.779683E-01,0.110528E+01,0.196392E-01,0.389962E+00,0.709342E+00,
22788 &0.771427E-01,0.772280E-01,0.772409E-01,0.771427E-01,0.106344E+01,
22789 &0.221591E-01,0.386027E+00,0.696571E+00,0.760304E-01,0.761276E-01,
22790 &0.761378E-01,0.760304E-01,0.101653E+01,0.242567E-01,0.381274E+00,
22791 &0.682657E+00,0.746543E-01,0.747623E-01,0.747692E-01,0.746543E-01/
22792 DATA (DL(K),K= 1191, 1275) /
22793 &0.966057E+00,0.259571E-01,0.375752E+00,0.667695E+00,0.730389E-01,
22794 &0.731569E-01,0.731598E-01,0.730389E-01,0.913345E+00,0.272876E-01,
22795 &0.369514E+00,0.651782E+00,0.712104E-01,0.713374E-01,0.713358E-01,
22796 &0.712104E-01,0.859530E+00,0.282763E-01,0.362616E+00,0.635021E+00,
22797 &0.691957E-01,0.693307E-01,0.693243E-01,0.691957E-01,0.805566E+00,
22798 &0.289524E-01,0.355116E+00,0.617511E+00,0.670220E-01,0.671640E-01,
22799 &0.671526E-01,0.670220E-01,0.752235E+00,0.293453E-01,0.347072E+00,
22800 &0.599357E+00,0.647162E-01,0.648642E-01,0.648478E-01,0.647162E-01,
22801 &0.700161E+00,0.294844E-01,0.338543E+00,0.580659E+00,0.623046E-01,
22802 &0.624578E-01,0.624363E-01,0.623046E-01,0.649828E+00,0.293983E-01,
22803 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22804 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22805 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22806 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22807 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22808 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22809 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22810 DATA (DL(K),K= 1276, 1360) /
22811 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22812 &0.408305E+00,0.775318E+00,0.509141E-01,0.509141E-01,0.509141E-01,
22813 &0.509141E-01,0.818839E+00,-.867362E-17,0.403619E+00,0.758058E+00,
22814 &0.502245E-01,0.502351E-01,0.502337E-01,0.502245E-01,0.795347E+00,
22815 &0.264045E-02,0.398068E+00,0.739709E+00,0.493454E-01,0.493661E-01,
22816 &0.493626E-01,0.493454E-01,0.764942E+00,0.491508E-02,0.391719E+00,
22817 &0.720394E+00,0.482952E-01,0.483253E-01,0.483192E-01,0.482952E-01,
22818 &0.729624E+00,0.685202E-02,0.384627E+00,0.700222E+00,0.470896E-01,
22819 &0.471285E-01,0.471194E-01,0.470896E-01,0.690906E+00,0.847433E-02,
22820 &0.376851E+00,0.679300E+00,0.457475E-01,0.457946E-01,0.457822E-01,
22821 &0.457475E-01,0.650078E+00,0.980774E-02,0.368452E+00,0.657739E+00,
22822 &0.442875E-01,0.443419E-01,0.443261E-01,0.442875E-01,0.608239E+00,
22823 &0.108769E-01,0.359490E+00,0.635646E+00,0.427281E-01,0.427892E-01,
22824 &0.427698E-01,0.427281E-01,0.566280E+00,0.117061E-01,0.350026E+00,
22825 &0.613128E+00,0.410878E-01,0.411549E-01,0.411320E-01,0.410878E-01,
22826 &0.524918E+00,0.123191E-01,0.340122E+00,0.590292E+00,0.393848E-01,
22827 &0.394571E-01,0.394308E-01,0.393848E-01,0.484713E+00,0.127393E-01/
22828 DATA (DL(K),K= 1361, 1445) /
22829 &0.329838E+00,0.567240E+00,0.376363E-01,0.377132E-01,0.376836E-01,
22830 &0.376363E-01,0.446084E+00,0.129888E-01,0.319236E+00,0.544074E+00,
22831 &0.358589E-01,0.359396E-01,0.359068E-01,0.358589E-01,0.409328E+00,
22832 &0.130888E-01,0.308374E+00,0.520890E+00,0.340678E-01,0.341517E-01,
22833 &0.341160E-01,0.340678E-01,0.374641E+00,0.130594E-01,0.297312E+00,
22834 &0.497781E+00,0.322772E-01,0.323636E-01,0.323253E-01,0.322772E-01,
22835 &0.342135E+00,0.129195E-01,0.286106E+00,0.474837E+00,0.304999E-01,
22836 &0.305882E-01,0.305474E-01,0.304999E-01,0.311854E+00,0.126863E-01,
22837 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22838 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22839 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22840 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22841 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22842 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22843 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22844 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22845 &0.407248E+00,0.746438E+00,0.335640E-01,0.335640E-01,0.335640E-01/
22846 DATA (DL(K),K= 1446, 1530) /
22847 &0.335640E-01,0.573540E+00,0.173472E-16,0.397516E+00,0.719825E+00,
22848 &0.324649E-01,0.324735E-01,0.324698E-01,0.324649E-01,0.540770E+00,
22849 &0.147177E-02,0.387197E+00,0.692869E+00,0.312911E-01,0.313075E-01,
22850 &0.313000E-01,0.312911E-01,0.505972E+00,0.269995E-02,0.376365E+00,
22851 &0.665689E+00,0.300576E-01,0.300811E-01,0.300699E-01,0.300576E-01,
22852 &0.470389E+00,0.371147E-02,0.365085E+00,0.638387E+00,0.287770E-01,
22853 &0.288070E-01,0.287922E-01,0.287770E-01,0.434885E+00,0.452768E-02,
22854 &0.353423E+00,0.611066E+00,0.274623E-01,0.274980E-01,0.274797E-01,
22855 &0.274623E-01,0.400103E+00,0.516996E-02,0.341442E+00,0.583823E+00,
22856 &0.261256E-01,0.261663E-01,0.261448E-01,0.261256E-01,0.366541E+00,
22857 &0.565807E-02,0.329207E+00,0.556753E+00,0.247782E-01,0.248234E-01,
22858 &0.247989E-01,0.247782E-01,0.334555E+00,0.601048E-02,0.316777E+00,
22859 &0.529946E+00,0.234308E-01,0.234798E-01,0.234525E-01,0.234308E-01,
22860 &0.304384E+00,0.624451E-02,0.304214E+00,0.503489E+00,0.220932E-01,
22861 &0.221452E-01,0.221155E-01,0.220932E-01,0.276170E+00,0.637618E-02,
22862 &0.291575E+00,0.477462E+00,0.207739E-01,0.208286E-01,0.207966E-01,
22863 &0.207739E-01,0.249976E+00,0.642028E-02,0.278917E+00,0.451941E+00/
22864 DATA (DL(K),K= 1531, 1615) /
22865 &0.194809E-01,0.195376E-01,0.195037E-01,0.194809E-01,0.225809E+00,
22866 &0.639038E-02,0.266293E+00,0.426995E+00,0.182209E-01,0.182791E-01,
22867 &0.182436E-01,0.182209E-01,0.203629E+00,0.629880E-02,0.253754E+00,
22868 &0.402686E+00,0.169996E-01,0.170587E-01,0.170219E-01,0.169996E-01,
22869 &0.183361E+00,0.615665E-02,0.241347E+00,0.379071E+00,0.158217E-01,
22870 &0.158814E-01,0.158436E-01,0.158217E-01,0.164907E+00,0.597385E-02,
22871 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22872 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22873 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22874 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22875 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22876 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22877 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22878 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22879 &0.395106E+00,0.689399E+00,0.218554E-01,0.218554E-01,0.218554E-01,
22880 &0.218554E-01,0.398362E+00,-.173472E-17,0.381441E+00,0.656777E+00,
22881 &0.207816E-01,0.207886E-01,0.207844E-01,0.207816E-01,0.366703E+00/
22882 DATA (DL(K),K= 1616, 1700) /
22883 &0.826643E-03,0.367505E+00,0.624578E+00,0.197001E-01,0.197133E-01,
22884 &0.197053E-01,0.197001E-01,0.335573E+00,0.149886E-02,0.353373E+00,
22885 &0.592889E+00,0.186195E-01,0.186383E-01,0.186266E-01,0.186195E-01,
22886 &0.305590E+00,0.203730E-02,0.339106E+00,0.561783E+00,0.175468E-01,
22887 &0.175705E-01,0.175555E-01,0.175468E-01,0.277136E+00,0.245817E-02,
22888 &0.324766E+00,0.531331E+00,0.164887E-01,0.165166E-01,0.164986E-01,
22889 &0.164887E-01,0.250424E+00,0.277666E-02,0.310411E+00,0.501599E+00,
22890 &0.154510E-01,0.154825E-01,0.154618E-01,0.154510E-01,0.225588E+00,
22891 &0.300658E-02,0.296100E+00,0.472648E+00,0.144390E-01,0.144735E-01,
22892 &0.144504E-01,0.144390E-01,0.202681E+00,0.316040E-02,0.281885E+00,
22893 &0.444535E+00,0.134570E-01,0.134940E-01,0.134689E-01,0.134570E-01,
22894 &0.181693E+00,0.324944E-02,0.267820E+00,0.417309E+00,0.125091E-01,
22895 &0.125481E-01,0.125212E-01,0.125091E-01,0.162572E+00,0.328396E-02,
22896 &0.253953E+00,0.391017E+00,0.115984E-01,0.116389E-01,0.116106E-01,
22897 &0.115984E-01,0.145235E+00,0.327313E-02,0.240328E+00,0.365695E+00,
22898 &0.107275E-01,0.107690E-01,0.107396E-01,0.107275E-01,0.129575E+00,
22899 &0.322510E-02,0.226989E+00,0.341375E+00,0.989805E-02,0.994030E-02/
22900 DATA (DL(K),K= 1701, 1785) /
22901 &0.990998E-02,0.989805E-02,0.115477E+00,0.314713E-02,0.213972E+00,
22902 &0.318081E+00,0.911149E-02,0.915408E-02,0.912316E-02,0.911149E-02,
22903 &0.102820E+00,0.304556E-02,0.201311E+00,0.295830E+00,0.836852E-02,
22904 &0.841111E-02,0.837984E-02,0.836852E-02,0.914804E-01,0.292596E-02,
22905 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22906 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22907 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22908 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22909 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22910 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22911 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22912 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22913 &0.374678E+00,0.616087E+00,0.139531E-01,0.139531E-01,0.139531E-01,
22914 &0.139531E-01,0.272491E+00,-.693889E-17,0.358052E+00,0.580345E+00,
22915 &0.130624E-01,0.130680E-01,0.130641E-01,0.130624E-01,0.245861E+00,
22916 &0.460255E-03,0.341487E+00,0.545719E+00,0.121971E-01,0.122076E-01,
22917 &0.122002E-01,0.121971E-01,0.220877E+00,0.826785E-03,0.325046E+00/
22918 DATA (DL(K),K= 1786, 1870) /
22919 &0.512244E+00,0.113599E-01,0.113748E-01,0.113641E-01,0.113599E-01,
22920 &0.197730E+00,0.111366E-02,0.308783E+00,0.479952E+00,0.105534E-01,
22921 &0.105720E-01,0.105585E-01,0.105534E-01,0.176497E+00,0.133192E-02,
22922 &0.292747E+00,0.448868E+00,0.977938E-02,0.980112E-02,0.978518E-02,
22923 &0.977938E-02,0.157150E+00,0.149139E-02,0.276986E+00,0.419015E+00,
22924 &0.903955E-02,0.906394E-02,0.904584E-02,0.903955E-02,0.139631E+00,
22925 &0.160093E-02,0.261546E+00,0.390412E+00,0.833509E-02,0.836165E-02,
22926 &0.834171E-02,0.833509E-02,0.123850E+00,0.166838E-02,0.246467E+00,
22927 &0.363074E+00,0.766687E-02,0.769516E-02,0.767369E-02,0.766687E-02,
22928 &0.109695E+00,0.170073E-02,0.231787E+00,0.337008E+00,0.703540E-02,
22929 &0.706500E-02,0.704230E-02,0.703540E-02,0.970428E-01,0.170416E-02,
22930 &0.217542E+00,0.312218E+00,0.644083E-02,0.647137E-02,0.644772E-02,
22931 &0.644083E-02,0.857658E-01,0.168409E-02,0.203759E+00,0.288701E+00,
22932 &0.588300E-02,0.591415E-02,0.588981E-02,0.588300E-02,0.757385E-01,
22933 &0.164528E-02,0.190467E+00,0.266449E+00,0.536147E-02,0.539292E-02,
22934 &0.536812E-02,0.536147E-02,0.668383E-01,0.159185E-02,0.177686E+00,
22935 &0.245447E+00,0.487551E-02,0.490698E-02,0.488195E-02,0.487551E-02/
22936 DATA (DL(K),K= 1871, 1955) /
22937 &0.589492E-01,0.152735E-02,0.165434E+00,0.225677E+00,0.442416E-02,
22938 &0.445543E-02,0.443037E-02,0.442416E-02,0.519652E-01,0.145483E-02,
22939 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22940 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22941 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22942 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22943 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22944 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22945 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22946 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22947 &0.348042E+00,0.534691E+00,0.867977E-02,0.867977E-02,0.867977E-02,
22948 &0.867977E-02,0.182547E+00,-.693889E-17,0.329349E+00,0.498248E+00,
22949 &0.800724E-02,0.801198E-02,0.800836E-02,0.800724E-02,0.161948E+00,
22950 &0.250949E-03,0.311047E+00,0.463485E+00,0.737155E-02,0.738040E-02,
22951 &0.737356E-02,0.737155E-02,0.143267E+00,0.447662E-03,0.293181E+00,
22952 &0.430377E+00,0.677169E-02,0.678409E-02,0.677441E-02,0.677169E-02,
22953 &0.126447E+00,0.598803E-03,0.275787E+00,0.398907E+00,0.620726E-02/
22954 DATA (DL(K),K= 1956, 2040) /
22955 &0.622265E-02,0.621051E-02,0.620726E-02,0.111401E+00,0.711280E-03,
22956 &0.258900E+00,0.369051E+00,0.567741E-02,0.569532E-02,0.568106E-02,
22957 &0.567741E-02,0.979944E-01,0.790986E-03,0.242550E+00,0.340785E+00,
22958 &0.518138E-02,0.520134E-02,0.518531E-02,0.518138E-02,0.860936E-01,
22959 &0.843227E-03,0.226765E+00,0.314083E+00,0.471828E-02,0.473987E-02,
22960 &0.472238E-02,0.471828E-02,0.755615E-01,0.872644E-03,0.211568E+00,
22961 &0.288916E+00,0.428714E-02,0.430998E-02,0.429133E-02,0.428714E-02,
22962 &0.662627E-01,0.883319E-03,0.196981E+00,0.265252E+00,0.388691E-02,
22963 &0.391065E-02,0.389112E-02,0.388691E-02,0.580684E-01,0.878818E-03,
22964 &0.183020E+00,0.243053E+00,0.351645E-02,0.354077E-02,0.352060E-02,
22965 &0.351645E-02,0.508578E-01,0.862228E-03,0.169696E+00,0.222280E+00,
22966 &0.317451E-02,0.319914E-02,0.317858E-02,0.317451E-02,0.445190E-01,
22967 &0.836224E-03,0.157017E+00,0.202888E+00,0.285982E-02,0.288450E-02,
22968 &0.286376E-02,0.285982E-02,0.389523E-01,0.803096E-03,0.144987E+00,
22969 &0.184832E+00,0.257101E-02,0.259553E-02,0.257480E-02,0.257101E-02,
22970 &0.340677E-01,0.764787E-03,0.133605E+00,0.168060E+00,0.230670E-02,
22971 &0.233087E-02,0.231031E-02,0.230670E-02,0.297820E-01,0.722929E-03/
22972 DATA (DL(K),K= 2041, 2125) /
22973 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22974 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22975 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22976 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22977 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22978 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22979 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22980 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22981 &0.316867E+00,0.451111E+00,0.522815E-02,0.522815E-02,0.522815E-02,
22982 &0.522815E-02,0.119118E+00,0.889046E-17,0.296950E+00,0.415915E+00,
22983 &0.475497E-02,0.475914E-02,0.475574E-02,0.475497E-02,0.104204E+00,
22984 &0.132513E-03,0.277735E+00,0.382805E+00,0.431809E-02,0.432582E-02,
22985 &0.431944E-02,0.431809E-02,0.910279E-01,0.235347E-03,0.259241E+00,
22986 &0.351694E+00,0.391455E-02,0.392531E-02,0.391637E-02,0.391455E-02,
22987 &0.794222E-01,0.313322E-03,0.241485E+00,0.322517E+00,0.354249E-02,
22988 &0.355575E-02,0.354464E-02,0.354249E-02,0.692354E-01,0.370408E-03,
22989 &0.224480E+00,0.295202E+00,0.319987E-02,0.321518E-02,0.320226E-02/
22990 DATA (DL(K),K= 2126, 2210) /
22991 &0.319987E-02,0.603106E-01,0.409866E-03,0.208235E+00,0.269681E+00,
22992 &0.288490E-02,0.290184E-02,0.288744E-02,0.288490E-02,0.525034E-01,
22993 &0.434663E-03,0.192759E+00,0.245887E+00,0.259589E-02,0.261407E-02,
22994 &0.259852E-02,0.259589E-02,0.456838E-01,0.447393E-03,0.178054E+00,
22995 &0.223752E+00,0.233123E-02,0.235033E-02,0.233390E-02,0.233123E-02,
22996 &0.397318E-01,0.450314E-03,0.164120E+00,0.203207E+00,0.208941E-02,
22997 &0.210910E-02,0.209206E-02,0.208941E-02,0.345396E-01,0.445394E-03,
22998 &0.150954E+00,0.184182E+00,0.186896E-02,0.188897E-02,0.187155E-02,
22999 &0.186896E-02,0.300131E-01,0.434333E-03,0.138548E+00,0.166608E+00,
23000 &0.166844E-02,0.168854E-02,0.167096E-02,0.166844E-02,0.260692E-01,
23001 &0.418584E-03,0.126892E+00,0.150412E+00,0.148650E-02,0.150648E-02,
23002 &0.148891E-02,0.148650E-02,0.226325E-01,0.399380E-03,0.115971E+00,
23003 &0.135523E+00,0.132180E-02,0.134148E-02,0.132409E-02,0.132180E-02,
23004 &0.196374E-01,0.377764E-03,0.105767E+00,0.121870E+00,0.117308E-02,
23005 &0.119231E-02,0.117524E-02,0.117308E-02,0.170312E-01,0.354610E-03,
23006 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23007 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23008 DATA (DL(K),K= 2211, 2295) /
23009 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23010 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23011 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23012 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23013 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23014 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23015 &0.282579E+00,0.369670E+00,0.302765E-02,0.302765E-02,0.302765E-02,
23016 &0.302765E-02,0.752529E-01,-.455365E-17,0.262229E+00,0.337209E+00,
23017 &0.271512E-02,0.271883E-02,0.271564E-02,0.271512E-02,0.651086E-01,
23018 &0.669321E-04,0.242857E+00,0.307069E+00,0.243269E-02,0.243953E-02,
23019 &0.243360E-02,0.243269E-02,0.563252E-01,0.118744E-03,0.224455E+00,
23020 &0.279111E+00,0.217687E-02,0.218631E-02,0.217808E-02,0.217687E-02,
23021 &0.487143E-01,0.157767E-03,0.207014E+00,0.253223E+00,0.194534E-02,
23022 &0.195689E-02,0.194675E-02,0.194534E-02,0.421227E-01,0.186063E-03,
23023 &0.190523E+00,0.229293E+00,0.173585E-02,0.174909E-02,0.173741E-02,
23024 &0.173585E-02,0.364156E-01,0.205286E-03,0.174969E+00,0.207218E+00,
23025 &0.154647E-02,0.156100E-02,0.154811E-02,0.154647E-02,0.314732E-01/
23026 DATA (DL(K),K= 2296, 2380) /
23027 &0.216964E-03,0.160335E+00,0.186895E+00,0.137545E-02,0.139092E-02,
23028 &0.137713E-02,0.137545E-02,0.271927E-01,0.222455E-03,0.146604E+00,
23029 &0.168227E+00,0.122121E-02,0.123733E-02,0.122290E-02,0.122121E-02,
23030 &0.234852E-01,0.222947E-03,0.133756E+00,0.151116E+00,0.108234E-02,
23031 &0.109881E-02,0.108400E-02,0.108234E-02,0.202747E-01,0.219474E-03,
23032 &0.121765E+00,0.135471E+00,0.957502E-03,0.974107E-03,0.959112E-03,
23033 &0.957502E-03,0.174932E-01,0.212928E-03,0.110606E+00,0.121198E+00,
23034 &0.845493E-03,0.862024E-03,0.847037E-03,0.845493E-03,0.150824E-01,
23035 &0.204075E-03,0.100250E+00,0.108210E+00,0.745196E-03,0.761482E-03,
23036 &0.746662E-03,0.745196E-03,0.129965E-01,0.193573E-03,0.906661E-01,
23037 &0.964191E-01,0.655569E-03,0.671466E-03,0.656948E-03,0.655569E-03,
23038 &0.111930E-01,0.181962E-03,0.818218E-01,0.857412E-01,0.575637E-03,
23039 &0.591030E-03,0.576925E-03,0.575637E-03,0.962922E-02,0.169687E-03,
23040 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23041 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23042 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23043 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23044 DATA (DL(K),K= 2381, 2465) /
23045 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23046 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23047 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23048 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23049 &0.246444E+00,0.293515E+00,0.167124E-02,0.167124E-02,0.167124E-02,
23050 &0.167124E-02,0.456929E-01,-.260209E-17,0.226393E+00,0.264836E+00,
23051 &0.147748E-02,0.148085E-02,0.147783E-02,0.147748E-02,0.392393E-01,
23052 &0.318190E-04,0.207552E+00,0.238550E+00,0.130596E-02,0.131212E-02,
23053 &0.130656E-02,0.130596E-02,0.337276E-01,0.566426E-04,0.189877E+00,
23054 &0.214470E+00,0.115347E-02,0.116190E-02,0.115427E-02,0.115347E-02,
23055 &0.290012E-01,0.753776E-04,0.173336E+00,0.192452E+00,0.101789E-02,
23056 &0.102811E-02,0.101881E-02,0.101789E-02,0.249381E-01,0.889466E-04,
23057 &0.157889E+00,0.172355E+00,0.897268E-03,0.908872E-03,0.898270E-03,
23058 &0.897268E-03,0.214419E-01,0.980950E-04,0.143501E+00,0.154046E+00,
23059 &0.789951E-03,0.802565E-03,0.790996E-03,0.789951E-03,0.184296E-01,
23060 &0.103536E-03,0.130132E+00,0.137402E+00,0.694510E-03,0.707811E-03,
23061 &0.695568E-03,0.694510E-03,0.158331E-01,0.105929E-03,0.117743E+00/
23062 DATA (DL(K),K= 2466, 2550) /
23063 &0.122303E+00,0.609684E-03,0.623394E-03,0.610733E-03,0.609684E-03,
23064 &0.135929E-01,0.105853E-03,0.106293E+00,0.108637E+00,0.534365E-03,
23065 &0.548244E-03,0.535386E-03,0.534365E-03,0.116583E-01,0.103825E-03,
23066 &0.957386E-01,0.962976E-01,0.467572E-03,0.481416E-03,0.468551E-03,
23067 &0.467572E-03,0.999103E-02,0.100301E-03,0.860376E-01,0.851820E-01,
23068 &0.408422E-03,0.422062E-03,0.409350E-03,0.408422E-03,0.855563E-02,
23069 &0.956675E-04,0.771455E-01,0.751930E-01,0.356117E-03,0.369416E-03,
23070 &0.356989E-03,0.356117E-03,0.731542E-02,0.902499E-04,0.690178E-01,
23071 &0.662386E-01,0.309950E-03,0.322797E-03,0.310761E-03,0.309950E-03,
23072 &0.624633E-02,0.843305E-04,0.616096E-01,0.582312E-01,0.269281E-03,
23073 &0.281590E-03,0.270030E-03,0.269281E-03,0.533230E-02,0.781441E-04,
23074 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23075 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23076 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23077 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23078 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23079 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23080 DATA (DL(K),K= 2551, 2635) /
23081 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23082 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23083 &0.209608E+00,0.224862E+00,0.869706E-03,0.869706E-03,0.869706E-03,
23084 &0.869706E-03,0.264204E-01,-.138236E-17,0.190523E+00,0.200603E+00,
23085 &0.757542E-03,0.760626E-03,0.757768E-03,0.757542E-03,0.226261E-01,
23086 &0.138827E-04,0.172819E+00,0.178656E+00,0.660281E-03,0.665837E-03,
23087 &0.660670E-03,0.660281E-03,0.194018E-01,0.249832E-04,0.156420E+00,
23088 &0.158805E+00,0.575414E-03,0.582918E-03,0.575917E-03,0.575414E-03,
23089 &0.166434E-01,0.334851E-04,0.141265E+00,0.140883E+00,0.501258E-03,
23090 &0.510252E-03,0.501836E-03,0.501258E-03,0.142710E-01,0.397017E-04,
23091 &0.127291E+00,0.124732E+00,0.436386E-03,0.446473E-03,0.437008E-03,
23092 &0.436386E-03,0.122297E-01,0.439154E-04,0.114437E+00,0.110205E+00,
23093 &0.379575E-03,0.390415E-03,0.380217E-03,0.379575E-03,0.104701E-01,
23094 &0.464110E-04,0.102644E+00,0.971655E-01,0.329805E-03,0.341109E-03,
23095 &0.330448E-03,0.329805E-03,0.895086E-02,0.474758E-04,0.918521E-01,
23096 &0.854876E-01,0.286206E-03,0.297729E-03,0.286836E-03,0.286206E-03,
23097 &0.764249E-02,0.473771E-04,0.820032E-01,0.750529E-01,0.248027E-03/
23098 DATA (DL(K),K= 2636, 2720) /
23099 &0.259564E-03,0.248633E-03,0.248027E-03,0.651744E-02,0.463561E-04,
23100 &0.730394E-01,0.657510E-01,0.214611E-03,0.225995E-03,0.215186E-03,
23101 &0.214611E-03,0.554573E-02,0.446239E-04,0.649040E-01,0.574789E-01,
23102 &0.185396E-03,0.196491E-03,0.185935E-03,0.185396E-03,0.470938E-02,
23103 &0.423722E-04,0.575411E-01,0.501405E-01,0.159891E-03,0.170590E-03,
23104 &0.160391E-03,0.159891E-03,0.399752E-02,0.397689E-04,0.508960E-01,
23105 &0.436466E-01,0.137650E-03,0.147874E-03,0.138111E-03,0.137650E-03,
23106 &0.338807E-02,0.369434E-04,0.449157E-01,0.379141E-01,0.118285E-03,
23107 &0.127973E-03,0.118705E-03,0.118285E-03,0.286125E-02,0.340035E-04,
23108 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23109 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23110 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23111 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23112 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23113 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23114 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23115 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23116 DATA (DL(K),K= 2721, 2805) /
23117 &0.173133E+00,0.165162E+00,0.420483E-03,0.420483E-03,0.420483E-03,
23118 &0.420483E-03,0.143704E-01,0.418773E-17,0.155600E+00,0.145586E+00,
23119 &0.360490E-03,0.363140E-03,0.360629E-03,0.360490E-03,0.123560E-01,
23120 &0.533279E-05,0.139551E+00,0.128113E+00,0.309555E-03,0.314310E-03,
23121 &0.309792E-03,0.309555E-03,0.106262E-01,0.982612E-05,0.124876E+00,
23122 &0.112516E+00,0.265952E-03,0.272344E-03,0.266256E-03,0.265952E-03,
23123 &0.913151E-02,0.133834E-04,0.111490E+00,0.986188E-01,0.228522E-03,
23124 &0.236138E-03,0.228869E-03,0.228522E-03,0.783135E-02,0.160429E-04,
23125 &0.993081E-01,0.862590E-01,0.196336E-03,0.204821E-03,0.196706E-03,
23126 &0.196336E-03,0.670031E-02,0.178799E-04,0.882484E-01,0.752883E-01,
23127 &0.168604E-03,0.177655E-03,0.168981E-03,0.168604E-03,0.572016E-02,
23128 &0.189837E-04,0.782334E-01,0.655714E-01,0.144684E-03,0.154047E-03,
23129 &0.145058E-03,0.144684E-03,0.487276E-02,0.194655E-04,0.691885E-01,
23130 &0.569841E-01,0.124035E-03,0.133497E-03,0.124397E-03,0.124035E-03,
23131 &0.413648E-02,0.194296E-04,0.610420E-01,0.494128E-01,0.106203E-03,
23132 &0.115592E-03,0.106548E-03,0.106203E-03,0.350042E-02,0.189800E-04,
23133 &0.537249E-01,0.427533E-01,0.908141E-04,0.999895E-04,0.911377E-04/
23134 DATA (DL(K),K= 2806, 2890) /
23135 &0.908141E-04,0.295961E-02,0.182192E-04,0.471713E-01,0.369100E-01,
23136 &0.775359E-04,0.863895E-04,0.778360E-04,0.775359E-04,0.249629E-02,
23137 &0.172287E-04,0.413182E-01,0.317957E-01,0.660857E-04,0.745356E-04,
23138 &0.663611E-04,0.660857E-04,0.209482E-02,0.160791E-04,0.361056E-01,
23139 &0.273306E-01,0.562298E-04,0.642173E-04,0.564804E-04,0.562298E-04,
23140 &0.175588E-02,0.148407E-04,0.314766E-01,0.234421E-01,0.477598E-04,
23141 &0.552457E-04,0.479859E-04,0.477598E-04,0.147398E-02,0.135653E-04,
23142 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23143 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23144 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23145 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23146 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23147 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23148 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23149 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23150 &0.138007E+00,0.115214E+00,0.185072E-03,0.185072E-03,0.185072E-03,
23151 &0.185072E-03,0.722856E-02,-.380826E-17,0.122517E+00,0.100251E+00/
23152 DATA (DL(K),K= 2891, 2975) /
23153 &0.155814E-03,0.158287E-03,0.155901E-03,0.155814E-03,0.630580E-02,
23154 &0.155371E-05,0.108535E+00,0.870870E-01,0.131535E-03,0.135909E-03,
23155 &0.131680E-03,0.131535E-03,0.547867E-02,0.304952E-05,0.959260E-01,
23156 &0.754985E-01,0.111183E-03,0.116980E-03,0.111366E-03,0.111183E-03,
23157 &0.473794E-02,0.433106E-05,0.845828E-01,0.653163E-01,0.940433E-04,
23158 &0.100851E-03,0.942493E-04,0.940433E-04,0.407647E-02,0.533613E-05,
23159 &0.744017E-01,0.563870E-01,0.795843E-04,0.870596E-04,0.798007E-04,
23160 &0.795843E-04,0.349165E-02,0.606691E-05,0.652864E-01,0.485720E-01,
23161 &0.673476E-04,0.752069E-04,0.675656E-04,0.673476E-04,0.297273E-02,
23162 &0.652898E-05,0.571466E-01,0.417472E-01,0.569700E-04,0.649812E-04,
23163 &0.571831E-04,0.569700E-04,0.251732E-02,0.675028E-05,0.498975E-01,
23164 &0.358008E-01,0.481618E-04,0.561391E-04,0.483654E-04,0.481618E-04,
23165 &0.212754E-02,0.677236E-05,0.434594E-01,0.306320E-01,0.406746E-04,
23166 &0.484724E-04,0.408657E-04,0.406746E-04,0.179059E-02,0.662814E-05,
23167 &0.377578E-01,0.261500E-01,0.343050E-04,0.418123E-04,0.344818E-04,
23168 &0.343050E-04,0.149563E-02,0.635273E-05,0.327229E-01,0.222734E-01,
23169 &0.288923E-04,0.360279E-04,0.290540E-04,0.288923E-04,0.124695E-02/
23170 DATA (DL(K),K= 2976, 3060) /
23171 &0.598767E-05,0.282894E-01,0.189287E-01,0.242960E-04,0.310036E-04,
23172 &0.244423E-04,0.242960E-04,0.104112E-02,0.556344E-05,0.243968E-01,
23173 &0.160504E-01,0.203920E-04,0.266363E-04,0.205232E-04,0.203920E-04,
23174 &0.863677E-03,0.510070E-05,0.209890E-01,0.135797E-01,0.170822E-04,
23175 &0.228449E-04,0.171989E-04,0.170822E-04,0.711641E-03,0.462338E-05,
23176 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23177 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23178 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23179 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23180 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23181 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23182 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23183 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23184 &0.105155E+00,0.752467E-01,0.719932E-04,0.719932E-04,0.719932E-04,
23185 &0.719932E-04,0.328057E-02,-.758942E-18,0.920856E-01,0.645455E-01,
23186 &0.592305E-04,0.615087E-04,0.592802E-04,0.592305E-04,0.295327E-02,
23187 &0.945234E-07,0.804695E-01,0.552770E-01,0.489125E-04,0.528632E-04/
23188 DATA (DL(K),K= 3061, 3145) /
23189 &0.489946E-04,0.489125E-04,0.261804E-02,0.365139E-06,0.701499E-01,
23190 &0.472409E-01,0.404786E-04,0.456186E-04,0.405807E-04,0.404786E-04,
23191 &0.229460E-02,0.686912E-06,0.610049E-01,0.402864E-01,0.335367E-04,
23192 &0.394631E-04,0.336495E-04,0.335367E-04,0.198445E-02,0.981070E-06,
23193 &0.529201E-01,0.342803E-01,0.278134E-04,0.342044E-04,0.279301E-04,
23194 &0.278134E-04,0.169772E-02,0.122521E-05,0.457907E-01,0.291037E-01,
23195 &0.230821E-04,0.296833E-04,0.231978E-04,0.230821E-04,0.144575E-02,
23196 &0.140819E-05,0.395205E-01,0.246522E-01,0.191553E-04,0.257661E-04,
23197 &0.192666E-04,0.191553E-04,0.122125E-02,0.152152E-05,0.340212E-01,
23198 &0.208330E-01,0.158874E-04,0.223546E-04,0.159921E-04,0.158874E-04,
23199 &0.101912E-02,0.156880E-05,0.292116E-01,0.175644E-01,0.131678E-04,
23200 &0.193783E-04,0.132645E-04,0.131678E-04,0.847586E-03,0.156432E-05,
23201 &0.250173E-01,0.147740E-01,0.109029E-04,0.167762E-04,0.109910E-04,
23202 &0.109029E-04,0.705515E-03,0.151845E-05,0.213702E-01,0.123979E-01,
23203 &0.901273E-05,0.144953E-04,0.909200E-05,0.901273E-05,0.581767E-03,
23204 &0.143817E-05,0.182083E-01,0.103797E-01,0.743733E-05,0.124978E-04,
23205 &0.750792E-05,0.743733E-05,0.475483E-03,0.133574E-05,0.154751E-01/
23206 DATA (DL(K),K= 3146, 3230) /
23207 &0.867011E-02,0.612722E-05,0.107517E-04,0.618950E-05,0.612722E-05,
23208 &0.390116E-03,0.122183E-05,0.131193E-01,0.722560E-02,0.503734E-05,
23209 &0.922584E-05,0.509185E-05,0.503734E-05,0.319980E-03,0.110130E-05,
23210 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23211 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23212 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23213 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23214 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23215 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23216 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23217 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23218 &0.754424E-01,0.449848E-01,0.236444E-04,0.236444E-04,0.236444E-04,
23219 &0.236444E-04,0.129291E-02,0.113079E-17,0.650429E-01,0.379660E-01,
23220 &0.187739E-04,0.207130E-04,0.187990E-04,0.187739E-04,0.124038E-02,
23221 &-.327995E-06,0.559588E-01,0.319936E-01,0.149625E-04,0.182671E-04,
23222 &0.150033E-04,0.149625E-04,0.113497E-02,-.464337E-06,0.480234E-01,
23223 &0.269030E-01,0.119484E-04,0.161746E-04,0.119982E-04,0.119484E-04/
23224 DATA (DL(K),K= 3231, 3315) /
23225 &0.100877E-02,-.490618E-06,0.411091E-01,0.225716E-01,0.954833E-05,
23226 &0.143391E-04,0.960250E-05,0.954833E-05,0.883852E-03,-.461770E-06,
23227 &0.350995E-01,0.188947E-01,0.763738E-05,0.127129E-04,0.769248E-05,
23228 &0.763738E-05,0.760077E-03,-.403363E-06,0.298897E-01,0.157798E-01,
23229 &0.611070E-05,0.112548E-04,0.616439E-05,0.611070E-05,0.639505E-03,
23230 &-.335607E-06,0.253856E-01,0.131470E-01,0.488993E-05,0.994021E-05,
23231 &0.494070E-05,0.488993E-05,0.534131E-03,-.267652E-06,0.215026E-01,
23232 &0.109271E-01,0.391276E-05,0.875190E-05,0.395967E-05,0.391276E-05,
23233 &0.445478E-03,-.205292E-06,0.181648E-01,0.906007E-02,0.312720E-05,
23234 &0.767418E-05,0.316978E-05,0.312720E-05,0.366232E-03,-.154024E-06,
23235 &0.153041E-01,0.749382E-02,0.249633E-05,0.670002E-05,0.253440E-05,
23236 &0.249633E-05,0.297435E-03,-.112673E-06,0.128596E-01,0.618334E-02,
23237 &0.199074E-05,0.582360E-05,0.202435E-05,0.199074E-05,0.242305E-03,
23238 &-.794410E-07,0.107770E-01,0.508977E-02,0.158457E-05,0.503733E-05,
23239 &0.161393E-05,0.158457E-05,0.196927E-03,-.546702E-07,0.900806E-02,
23240 &0.417964E-02,0.125888E-05,0.433619E-05,0.128428E-05,0.125888E-05,
23241 &0.158171E-03,-.364714E-07,0.751006E-02,0.342418E-02,0.998674E-06/
23242 DATA (DL(K),K= 3316, 3400) /
23243 &0.371518E-05,0.102046E-05,0.998674E-06,0.126865E-03,-.228706E-07,
23244 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23245 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23246 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23247 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23248 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23249 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23250 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23251 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23252 &0.496787E-01,0.236961E-01,0.607312E-05,0.607312E-05,0.607312E-05,
23253 &0.607312E-05,0.415108E-03,-.140523E-17,0.420445E-01,0.196196E-01,
23254 &0.443589E-05,0.603481E-05,0.444683E-05,0.443589E-05,0.444425E-03,
23255 &-.375397E-06,0.355108E-01,0.162223E-01,0.321766E-05,0.587645E-05,
23256 &0.323504E-05,0.321766E-05,0.432635E-03,-.593989E-06,0.299148E-01,
23257 &0.133836E-01,0.231504E-05,0.562250E-05,0.233581E-05,0.231504E-05,
23258 &0.395801E-03,-.699904E-06,0.251339E-01,0.110157E-01,0.164651E-05,
23259 &0.526880E-05,0.166853E-05,0.164651E-05,0.344925E-03,-.733095E-06/
23260 DATA (DL(K),K= 3401, 3485) /
23261 &0.210605E-01,0.904539E-02,0.115940E-05,0.485739E-05,0.118122E-05,
23262 &0.115940E-05,0.294439E-03,-.715193E-06,0.175989E-01,0.740944E-02,
23263 &0.808365E-06,0.441709E-05,0.829075E-06,0.808365E-06,0.249093E-03,
23264 &-.665420E-06,0.146656E-01,0.605433E-02,0.555563E-06,0.396078E-05,
23265 &0.574607E-06,0.555563E-06,0.205675E-03,-.600648E-06,0.121872E-01,
23266 &0.493466E-02,0.375914E-06,0.350822E-05,0.393011E-06,0.375914E-06,
23267 &0.166757E-03,-.529210E-06,0.100993E-01,0.401191E-02,0.250032E-06,
23268 &0.307359E-05,0.265094E-06,0.250032E-06,0.135196E-03,-.456996E-06,
23269 &0.834582E-02,0.325348E-02,0.162261E-06,0.266488E-05,0.175325E-06,
23270 &0.162261E-06,0.108862E-03,-.388821E-06,0.687767E-02,0.263179E-02,
23271 &0.102273E-06,0.228913E-05,0.113453E-06,0.102273E-06,0.865539E-04,
23272 &-.326325E-06,0.565221E-02,0.212357E-02,0.620694E-07,0.194975E-05,
23273 &0.715290E-07,0.620694E-07,0.687156E-04,-.270547E-06,0.463248E-02,
23274 &0.170926E-02,0.351992E-07,0.164711E-05,0.431226E-07,0.351992E-07,
23275 &0.543744E-04,-.222379E-06,0.378655E-02,0.137242E-02,0.178902E-07,
23276 &0.138124E-05,0.244675E-07,0.178902E-07,0.426626E-04,-.181158E-06,
23277 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23278 DATA (DL(K),K= 3486, 3570) /
23279 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23280 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23281 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23282 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23283 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23284 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23285 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23286 &0.286141E-01,0.102357E-01,0.105702E-05,0.105702E-05,0.105702E-05,
23287 &0.105702E-05,0.963318E-04,0.591070E-18,0.236608E-01,0.827483E-02,
23288 &0.548552E-06,0.163293E-05,0.551993E-06,0.548552E-06,0.133058E-03,
23289 &-.268677E-06,0.195282E-01,0.668247E-02,0.238780E-06,0.183459E-05,
23290 &0.243802E-06,0.238780E-06,0.135119E-03,-.393414E-06,0.160742E-01,
23291 &0.538444E-02,0.599864E-07,0.183277E-05,0.655085E-07,0.599864E-07,
23292 &0.124554E-03,-.428349E-06,0.131940E-01,0.432750E-02,-.392825E-07,
23293 &0.172071E-05,-.338391E-07,-.392825E-07,0.111121E-03,-.415550E-06,
23294 &0.107996E-01,0.346954E-02,-.875089E-07,0.154604E-05,-.824926E-07,
23295 &-.875089E-07,0.941854E-04,-.376855E-06,0.881435E-02,0.277463E-02/
23296 DATA (DL(K),K= 3571, 3655) /
23297 &-.103962E-06,0.135013E-05,-.995446E-07,-.103962E-06,0.772195E-04,
23298 &-.326008E-06,0.717317E-02,0.221313E-02,-.102844E-06,0.115335E-05,
23299 &-.990733E-07,-.102844E-06,0.626565E-04,-.272858E-06,0.582050E-02,
23300 &0.176061E-02,-.929503E-07,0.967229E-06,-.898064E-07,-.929503E-07,
23301 &0.499930E-04,-.222828E-06,0.470908E-02,0.139692E-02,-.791495E-07,
23302 &0.800414E-06,-.765797E-07,-.791495E-07,0.394181E-04,-.178141E-06,
23303 &0.379875E-02,0.110542E-02,-.647230E-07,0.655119E-06,-.626567E-07,
23304 &-.647230E-07,0.309999E-04,-.140000E-06,0.305549E-02,0.872447E-03,
23305 &-.515215E-07,0.530834E-06,-.498829E-07,-.515215E-07,0.240354E-04,
23306 &-.108633E-06,0.245058E-02,0.686769E-03,-.400234E-07,0.426835E-06,
23307 &-.387401E-07,-.400234E-07,0.184613E-04,-.832544E-07,0.195984E-02,
23308 &0.539209E-03,-.304312E-07,0.341169E-06,-.294373E-07,-.304312E-07,
23309 &0.143512E-04,-.630818E-07,0.156297E-02,0.422273E-03,-.228633E-07,
23310 &0.271199E-06,-.221014E-07,-.228633E-07,0.110898E-04,-.474683E-07,
23311 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23312 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23313 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23314 DATA (DL(K),K= 3656, 3740) /
23315 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23316 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23317 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23318 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23319 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23320 &0.129345E-01,0.308444E-02,0.903693E-07,0.903693E-07,0.903693E-07,
23321 &0.903693E-07,0.123538E-04,-.166230E-18,0.103598E-01,0.241354E-02,
23322 &0.155648E-06,-.205296E-06,0.154889E-06,0.155648E-06,0.267249E-04,
23323 &0.880707E-07,0.828507E-02,0.188764E-02,0.176333E-06,-.341498E-06,
23324 &0.175220E-06,0.176333E-06,0.306432E-04,0.125718E-06,0.660736E-02,
23325 &0.147304E-02,0.173444E-06,-.383695E-06,0.172215E-06,0.173444E-06,
23326 &0.280787E-04,0.135578E-06,0.525320E-02,0.114618E-02,0.158651E-06,
23327 &-.373371E-06,0.157437E-06,0.158651E-06,0.243526E-04,0.130412E-06,
23328 &0.416429E-02,0.889584E-03,0.137131E-06,-.333468E-06,0.136012E-06,
23329 &0.137131E-06,0.203463E-04,0.116115E-06,0.329102E-02,0.688580E-03,
23330 &0.113839E-06,-.280874E-06,0.112853E-06,0.113839E-06,0.161038E-04,
23331 &0.982305E-07,0.259282E-02,0.531508E-03,0.914374E-07,-.225427E-06/
23332 DATA (DL(K),K= 3741, 3825) /
23333 &0.905971E-07,0.914374E-07,0.125639E-04,0.798741E-07,0.203641E-02,
23334 &0.409120E-03,0.709595E-07,-.173123E-06,0.702607E-07,0.709595E-07,
23335 &0.979247E-05,0.624138E-07,0.159441E-02,0.314027E-03,0.532256E-07,
23336 &-.127272E-06,0.526566E-07,0.532256E-07,0.741899E-05,0.469253E-07,
23337 &0.124447E-02,0.240357E-03,0.385509E-07,-.888851E-07,0.380956E-07,
23338 &0.385509E-07,0.554070E-05,0.339174E-07,0.968328E-03,0.183454E-03,
23339 &0.267272E-07,-.580277E-07,0.263687E-07,0.267272E-07,0.420032E-05,
23340 &0.233280E-07,0.751159E-03,0.139632E-03,0.174605E-07,-.342016E-07,
23341 &0.171822E-07,0.174605E-07,0.315522E-05,0.149727E-07,0.580936E-03,
23342 &0.105986E-03,0.104515E-07,-.164567E-07,0.102383E-07,0.104515E-07,
23343 &0.230829E-05,0.863527E-08,0.447955E-03,0.802293E-04,0.531954E-08,
23344 &-.376312E-08,0.515829E-08,0.531954E-08,0.170771E-05,0.399662E-08,
23345 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23346 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23347 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23348 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23349 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23350 DATA (DL(K),K= 3826, 3910) /
23351 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23352 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23353 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23354 &0.324478E-02,0.386879E-03,0.135983E-08,0.135983E-08,0.135983E-08,
23355 &0.135983E-08,0.371787E-06,-.274599E-19,0.246219E-02,0.286505E-03,
23356 &-.106852E-06,0.327611E-06,-.106589E-06,-.106852E-06,0.231631E-05,
23357 &-.107814E-06,0.186777E-02,0.212413E-03,-.161566E-06,0.492001E-06,
23358 &-.161179E-06,-.161566E-06,0.311589E-05,-.162249E-06,0.141322E-02,
23359 &0.157212E-03,-.183398E-06,0.557106E-06,-.182972E-06,-.183398E-06,
23360 &0.267943E-05,-.183884E-06,0.106518E-02,0.115892E-03,-.185231E-06,
23361 &0.562185E-06,-.184809E-06,-.185231E-06,0.203027E-05,-.185573E-06,
23362 &0.800350E-03,0.851995E-04,-.174680E-06,0.530096E-06,-.174290E-06,
23363 &-.174680E-06,0.165870E-05,-.174922E-06,0.599444E-03,0.624676E-04,
23364 &-.157644E-06,0.478420E-06,-.157300E-06,-.157644E-06,0.130112E-05,
23365 &-.157815E-06,0.447433E-03,0.456556E-04,-.137838E-06,0.418429E-06,
23366 &-.137543E-06,-.137838E-06,0.903220E-06,-.137958E-06,0.332836E-03,
23367 &0.332643E-04,-.117616E-06,0.357179E-06,-.117368E-06,-.117616E-06/
23368 DATA (DL(K),K= 3911, 3995) /
23369 &0.636187E-06,-.117699E-06,0.246754E-03,0.241622E-04,-.984560E-07,
23370 &0.299077E-06,-.982529E-07,-.984560E-07,0.481221E-06,-.985144E-07,
23371 &0.182315E-03,0.174961E-04,-.811089E-07,0.246465E-06,-.809446E-07,
23372 &-.811089E-07,0.342859E-06,-.811495E-07,0.134250E-03,0.126299E-04,
23373 &-.659052E-07,0.200354E-06,-.657742E-07,-.659052E-07,0.227840E-06,
23374 &-.659334E-07,0.985288E-04,0.908931E-05,-.529252E-07,0.160947E-06,
23375 &-.528218E-07,-.529252E-07,0.161641E-06,-.529447E-07,0.720750E-04,
23376 &0.652153E-05,-.420621E-07,0.127943E-06,-.419814E-07,-.420621E-07,
23377 &0.119540E-06,-.420756E-07,0.525538E-04,0.466527E-05,-.331141E-07,
23378 &0.100758E-06,-.330516E-07,-.331141E-07,0.808991E-07,-.331233E-07,
23379 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23380 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23381 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23382 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23383 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23384 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23385 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23386 DATA (DL(K),K= 3996, 4000) /
23387 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23390 IF (X.GT.0.9985) RETURN
23391 IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
23397 F1(L) = GF(I,IS,KL)
23398 F2(L) = GF(I,IS1,KL)
23400 A1 = DT_CKMTFF(X,F1)
23401 A2 = DT_CKMTFF(X,F2)
23406 ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
23413 *$ CREATE DT_CKMTPR.FOR
23415 SUBROUTINE DT_CKMTPR(I,NDRV,X,S,ANS)
23417 C**********************************************************************
23419 C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
23421 C This version by S. Roesler, 31.01.96
23422 C**********************************************************************
23425 DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
23426 EQUIVALENCE (GF(1,1,1),DL(1))
23429 DATA (DL(K),K= 1, 85) /
23430 &0.367759E+00,0.350609E+00,0.325356E+00,0.325356E+00,0.325356E+00,
23431 &0.325356E+00,0.533117E+01,0.138778E-16,0.427988E+00,0.409718E+00,
23432 &0.382948E+00,0.382920E+00,0.382933E+00,0.382948E+00,0.686279E+01,
23433 &0.611113E-01,0.494752E+00,0.475328E+00,0.447011E+00,0.446959E+00,
23434 &0.446984E+00,0.447011E+00,0.855688E+01,0.128659E+00,0.568248E+00,
23435 &0.547637E+00,0.517743E+00,0.517671E+00,0.517705E+00,0.517743E+00,
23436 &0.104074E+02,0.202846E+00,0.648622E+00,0.626792E+00,0.595289E+00,
23437 &0.595201E+00,0.595244E+00,0.595289E+00,0.124065E+02,0.283819E+00,
23438 &0.735974E+00,0.712890E+00,0.679748E+00,0.679648E+00,0.679696E+00,
23439 &0.679748E+00,0.145441E+02,0.371679E+00,0.830359E+00,0.805987E+00,
23440 &0.771173E+00,0.771066E+00,0.771119E+00,0.771173E+00,0.168081E+02,
23441 &0.466485E+00,0.931778E+00,0.906084E+00,0.869566E+00,0.869456E+00,
23442 &0.869511E+00,0.869566E+00,0.191850E+02,0.568240E+00,0.104018E+01,
23443 &0.101313E+01,0.974873E+00,0.974763E+00,0.974819E+00,0.974873E+00,
23444 &0.216593E+02,0.676890E+00,0.115544E+01,0.112700E+01,0.108698E+01,
23445 &0.108687E+01,0.108693E+01,0.108698E+01,0.242146E+02,0.792321E+00,
23446 &0.127738E+01,0.124751E+01,0.120570E+01,0.120560E+01,0.120565E+01/
23447 DATA (DL(K),K= 86, 170) /
23448 &0.120570E+01,0.268333E+02,0.914356E+00,0.140577E+01,0.137444E+01,
23449 &0.133079E+01,0.133070E+01,0.133075E+01,0.133079E+01,0.294970E+02,
23450 &0.104275E+01,0.154028E+01,0.150745E+01,0.146194E+01,0.146187E+01,
23451 &0.146192E+01,0.146194E+01,0.321867E+02,0.117720E+01,0.168054E+01,
23452 &0.164619E+01,0.159879E+01,0.159874E+01,0.159877E+01,0.159879E+01,
23453 &0.348836E+02,0.131732E+01,0.182613E+01,0.179020E+01,0.174088E+01,
23454 &0.174086E+01,0.174088E+01,0.174088E+01,0.375685E+02,0.146269E+01,
23455 &0.197653E+01,0.193901E+01,0.188774E+01,0.188774E+01,0.188775E+01,
23456 &0.188774E+01,0.402228E+02,0.161282E+01,0.213121E+01,0.209205E+01,
23457 &0.203880E+01,0.203884E+01,0.203884E+01,0.203880E+01,0.428285E+02,
23458 &0.176714E+01,0.228955E+01,0.224873E+01,0.219348E+01,0.219355E+01,
23459 &0.219353E+01,0.219348E+01,0.453682E+02,0.192507E+01,0.245093E+01,
23460 &0.240840E+01,0.235113E+01,0.235123E+01,0.235120E+01,0.235113E+01,
23461 &0.478258E+02,0.208597E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23462 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23463 &0.349839E+00,0.324128E+00,0.286363E+00,0.286363E+00,0.286363E+00,
23464 &0.286363E+00,0.469694E+01,0.000000E+00,0.398361E+00,0.371065E+00/
23465 DATA (DL(K),K= 171, 255) /
23466 &0.331239E+00,0.331213E+00,0.331227E+00,0.331239E+00,0.586152E+01,
23467 &0.481683E-01,0.451010E+00,0.422096E+00,0.380182E+00,0.380137E+00,
23468 &0.380161E+00,0.380182E+00,0.711349E+01,0.100378E+00,0.507782E+00,
23469 &0.477215E+00,0.433187E+00,0.433128E+00,0.433160E+00,0.433187E+00,
23470 &0.844371E+01,0.156627E+00,0.568644E+00,0.536390E+00,0.490220E+00,
23471 &0.490152E+00,0.490190E+00,0.490220E+00,0.984291E+01,0.216886E+00,
23472 &0.633517E+00,0.599543E+00,0.551204E+00,0.551133E+00,0.551174E+00,
23473 &0.551204E+00,0.113005E+02,0.281079E+00,0.702295E+00,0.666565E+00,
23474 &0.616031E+00,0.615963E+00,0.616004E+00,0.616031E+00,0.128050E+02,
23475 &0.349101E+00,0.774832E+00,0.737311E+00,0.684556E+00,0.684495E+00,
23476 &0.684535E+00,0.684556E+00,0.143447E+02,0.420809E+00,0.850945E+00,
23477 &0.811598E+00,0.756596E+00,0.756547E+00,0.756583E+00,0.756596E+00,
23478 &0.159073E+02,0.496022E+00,0.930413E+00,0.889207E+00,0.831933E+00,
23479 &0.831901E+00,0.831931E+00,0.831933E+00,0.174801E+02,0.574524E+00,
23480 &0.101298E+01,0.969882E+00,0.910312E+00,0.910301E+00,0.910324E+00,
23481 &0.910312E+00,0.190508E+02,0.656061E+00,0.109836E+01,0.105333E+01,
23482 &0.991445E+00,0.991459E+00,0.991471E+00,0.991445E+00,0.206070E+02/
23483 DATA (DL(K),K= 256, 340) /
23484 &0.740345E+00,0.118622E+01,0.113923E+01,0.107501E+01,0.107505E+01,
23485 &0.107505E+01,0.107501E+01,0.221368E+02,0.827056E+00,0.127622E+01,
23486 &0.122724E+01,0.116065E+01,0.116073E+01,0.116072E+01,0.116065E+01,
23487 &0.236287E+02,0.915845E+00,0.136797E+01,0.131696E+01,0.124800E+01,
23488 &0.124812E+01,0.124809E+01,0.124800E+01,0.250721E+02,0.100634E+01,
23489 &0.146107E+01,0.140801E+01,0.133666E+01,0.133681E+01,0.133677E+01,
23490 &0.133666E+01,0.264571E+02,0.109813E+01,0.155511E+01,0.149996E+01,
23491 &0.142621E+01,0.142641E+01,0.142634E+01,0.142621E+01,0.277747E+02,
23492 &0.119081E+01,0.164964E+01,0.159239E+01,0.151622E+01,0.151646E+01,
23493 &0.151638E+01,0.151622E+01,0.290168E+02,0.128396E+01,0.174424E+01,
23494 &0.168485E+01,0.160626E+01,0.160655E+01,0.160645E+01,0.160626E+01,
23495 &0.301765E+02,0.137713E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23496 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23497 &0.345345E+00,0.306823E+00,0.250518E+00,0.250518E+00,0.250518E+00,
23498 &0.250518E+00,0.411726E+01,-.138778E-16,0.384210E+00,0.343514E+00,
23499 &0.284500E+00,0.284487E+00,0.284496E+00,0.284500E+00,0.496835E+01,
23500 &0.371582E-01,0.425419E+00,0.382518E+00,0.320782E+00,0.320762E+00/
23501 DATA (DL(K),K= 341, 425) /
23502 &0.320777E+00,0.320782E+00,0.585504E+01,0.765988E-01,0.468853E+00,
23503 &0.423717E+00,0.359246E+00,0.359226E+00,0.359243E+00,0.359246E+00,
23504 &0.676824E+01,0.118207E+00,0.514392E+00,0.466990E+00,0.399771E+00,
23505 &0.399758E+00,0.399775E+00,0.399771E+00,0.769967E+01,0.161865E+00,
23506 &0.561883E+00,0.512186E+00,0.442209E+00,0.442208E+00,0.442222E+00,
23507 &0.442209E+00,0.864071E+01,0.207426E+00,0.611162E+00,0.559140E+00,
23508 &0.486395E+00,0.486411E+00,0.486420E+00,0.486395E+00,0.958280E+01,
23509 &0.254727E+00,0.662044E+00,0.607667E+00,0.532145E+00,0.532185E+00,
23510 &0.532185E+00,0.532145E+00,0.105176E+02,0.303587E+00,0.714325E+00,
23511 &0.657566E+00,0.579261E+00,0.579328E+00,0.579318E+00,0.579261E+00,
23512 &0.114370E+02,0.353808E+00,0.767786E+00,0.708618E+00,0.627526E+00,
23513 &0.627625E+00,0.627603E+00,0.627526E+00,0.123333E+02,0.405174E+00,
23514 &0.822195E+00,0.760591E+00,0.676711E+00,0.676846E+00,0.676810E+00,
23515 &0.676711E+00,0.131994E+02,0.457458E+00,0.877307E+00,0.813242E+00,
23516 &0.726575E+00,0.726750E+00,0.726697E+00,0.726575E+00,0.140286E+02,
23517 &0.510420E+00,0.932865E+00,0.866317E+00,0.776867E+00,0.777085E+00,
23518 &0.777015E+00,0.776867E+00,0.148150E+02,0.563809E+00,0.988608E+00/
23519 DATA (DL(K),K= 426, 510) /
23520 &0.919556E+00,0.827330E+00,0.827594E+00,0.827505E+00,0.827330E+00,
23521 &0.155533E+02,0.617368E+00,0.104427E+01,0.972694E+00,0.877703E+00,
23522 &0.878016E+00,0.877907E+00,0.877703E+00,0.162391E+02,0.670837E+00,
23523 &0.109958E+01,0.102547E+01,0.927723E+00,0.928088E+00,0.927957E+00,
23524 &0.927723E+00,0.168687E+02,0.723954E+00,0.115428E+01,0.107761E+01,
23525 &0.977132E+00,0.977550E+00,0.977397E+00,0.977132E+00,0.174391E+02,
23526 &0.776458E+00,0.120809E+01,0.112886E+01,0.102567E+01,0.102615E+01,
23527 &0.102597E+01,0.102567E+01,0.179481E+02,0.828097E+00,0.126078E+01,
23528 &0.117898E+01,0.107310E+01,0.107363E+01,0.107343E+01,0.107310E+01,
23529 &0.183942E+02,0.878621E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23530 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23531 &0.357586E+00,0.299938E+00,0.216504E+00,0.216504E+00,0.216504E+00,
23532 &0.216504E+00,0.357260E+01,-.277556E-16,0.388529E+00,0.327984E+00,
23533 &0.241161E+00,0.241168E+00,0.241168E+00,0.241161E+00,0.415893E+01,
23534 &0.278429E-01,0.420472E+00,0.357015E+00,0.266823E+00,0.266844E+00,
23535 &0.266842E+00,0.266823E+00,0.474689E+01,0.566783E-01,0.453271E+00,
23536 &0.386886E+00,0.293349E+00,0.293389E+00,0.293381E+00,0.293349E+00/
23537 DATA (DL(K),K= 511, 595) /
23538 &0.532982E+01,0.863668E-01,0.486793E+00,0.417464E+00,0.320608E+00,
23539 &0.320673E+00,0.320657E+00,0.320608E+00,0.590219E+01,0.116779E+00,
23540 &0.520887E+00,0.448601E+00,0.348454E+00,0.348549E+00,0.348523E+00,
23541 &0.348454E+00,0.645868E+01,0.147773E+00,0.555403E+00,0.480149E+00,
23542 &0.376740E+00,0.376870E+00,0.376831E+00,0.376740E+00,0.699440E+01,
23543 &0.179201E+00,0.590183E+00,0.511950E+00,0.405314E+00,0.405482E+00,
23544 &0.405429E+00,0.405314E+00,0.750493E+01,0.210912E+00,0.625064E+00,
23545 &0.543845E+00,0.434019E+00,0.434229E+00,0.434159E+00,0.434019E+00,
23546 &0.798636E+01,0.242750E+00,0.659882E+00,0.575673E+00,0.462696E+00,
23547 &0.462952E+00,0.462864E+00,0.462696E+00,0.843528E+01,0.274558E+00,
23548 &0.694472E+00,0.607271E+00,0.491188E+00,0.491492E+00,0.491385E+00,
23549 &0.491188E+00,0.884885E+01,0.306178E+00,0.728669E+00,0.638478E+00,
23550 &0.519337E+00,0.519690E+00,0.519563E+00,0.519337E+00,0.922480E+01,
23551 &0.337451E+00,0.762311E+00,0.669133E+00,0.546987E+00,0.547392E+00,
23552 &0.547244E+00,0.546987E+00,0.956139E+01,0.368224E+00,0.795240E+00,
23553 &0.699084E+00,0.573988E+00,0.574447E+00,0.574277E+00,0.573988E+00,
23554 &0.985744E+01,0.398346E+00,0.827302E+00,0.728181E+00,0.600196E+00/
23555 DATA (DL(K),K= 596, 680) /
23556 &0.600710E+00,0.600518E+00,0.600196E+00,0.101123E+02,0.427671E+00,
23557 &0.858354E+00,0.756282E+00,0.625475E+00,0.626044E+00,0.625829E+00,
23558 &0.625475E+00,0.103258E+02,0.456064E+00,0.888257E+00,0.783256E+00,
23559 &0.649696E+00,0.650321E+00,0.650083E+00,0.649696E+00,0.104982E+02,
23560 &0.483395E+00,0.916887E+00,0.808981E+00,0.672742E+00,0.673422E+00,
23561 &0.673161E+00,0.672742E+00,0.106303E+02,0.509546E+00,0.944126E+00,
23562 &0.833345E+00,0.694506E+00,0.695243E+00,0.694958E+00,0.694506E+00,
23563 &0.107231E+02,0.534410E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23564 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23565 &0.390721E+00,0.304671E+00,0.182562E+00,0.182562E+00,0.182562E+00,
23566 &0.182562E+00,0.303699E+01,0.693889E-17,0.414806E+00,0.325059E+00,
23567 &0.199103E+00,0.199133E+00,0.199124E+00,0.199103E+00,0.339971E+01,
23568 &0.198528E-01,0.438929E+00,0.345508E+00,0.215797E+00,0.215862E+00,
23569 &0.215842E+00,0.215797E+00,0.374624E+01,0.398420E-01,0.462973E+00,
23570 &0.365903E+00,0.232531E+00,0.232635E+00,0.232601E+00,0.232531E+00,
23571 &0.407322E+01,0.598565E-01,0.486835E+00,0.386142E+00,0.249208E+00,
23572 &0.249352E+00,0.249304E+00,0.249208E+00,0.437817E+01,0.797987E-01/
23573 DATA (DL(K),K= 681, 765) /
23574 &0.510407E+00,0.406123E+00,0.265725E+00,0.265913E+00,0.265849E+00,
23575 &0.265725E+00,0.465901E+01,0.995694E-01,0.533588E+00,0.425746E+00,
23576 &0.281986E+00,0.282220E+00,0.282139E+00,0.281986E+00,0.491410E+01,
23577 &0.119072E+00,0.556274E+00,0.444912E+00,0.297897E+00,0.298178E+00,
23578 &0.298079E+00,0.297897E+00,0.514220E+01,0.138212E+00,0.578369E+00,
23579 &0.463528E+00,0.313366E+00,0.313696E+00,0.313578E+00,0.313366E+00,
23580 &0.534249E+01,0.156900E+00,0.599777E+00,0.481503E+00,0.328308E+00,
23581 &0.328688E+00,0.328549E+00,0.328308E+00,0.551456E+01,0.175048E+00,
23582 &0.620409E+00,0.498752E+00,0.342642E+00,0.343071E+00,0.342913E+00,
23583 &0.342642E+00,0.565833E+01,0.192575E+00,0.640181E+00,0.515196E+00,
23584 &0.356292E+00,0.356770E+00,0.356592E+00,0.356292E+00,0.577410E+01,
23585 &0.209407E+00,0.659017E+00,0.530764E+00,0.369190E+00,0.369718E+00,
23586 &0.369519E+00,0.369190E+00,0.586243E+01,0.225474E+00,0.676845E+00,
23587 &0.545389E+00,0.381275E+00,0.381852E+00,0.381633E+00,0.381275E+00,
23588 &0.592421E+01,0.240714E+00,0.693604E+00,0.559015E+00,0.392493E+00,
23589 &0.393118E+00,0.392880E+00,0.392493E+00,0.596052E+01,0.255072E+00,
23590 &0.709239E+00,0.571593E+00,0.402799E+00,0.403472E+00,0.403213E+00/
23591 DATA (DL(K),K= 766, 850) /
23592 &0.402799E+00,0.597267E+01,0.268502E+00,0.723703E+00,0.583081E+00,
23593 &0.412157E+00,0.412875E+00,0.412597E+00,0.412157E+00,0.596211E+01,
23594 &0.280966E+00,0.736960E+00,0.593447E+00,0.420536E+00,0.421299E+00,
23595 &0.421002E+00,0.420536E+00,0.593045E+01,0.292434E+00,0.748980E+00,
23596 &0.602669E+00,0.427918E+00,0.428723E+00,0.428408E+00,0.427918E+00,
23597 &0.587934E+01,0.302884E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23598 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23599 &0.448390E+00,0.320678E+00,0.146415E+00,0.146415E+00,0.146415E+00,
23600 &0.146415E+00,0.247594E+01,0.000000E+00,0.465760E+00,0.333734E+00,
23601 &0.155974E+00,0.156013E+00,0.156000E+00,0.155974E+00,0.265633E+01,
23602 &0.130329E-01,0.482525E+00,0.346293E+00,0.165233E+00,0.165311E+00,
23603 &0.165285E+00,0.165233E+00,0.281612E+01,0.257304E-01,0.498626E+00,
23604 &0.358294E+00,0.174131E+00,0.174249E+00,0.174209E+00,0.174131E+00,
23605 &0.295484E+01,0.380345E-01,0.514008E+00,0.369688E+00,0.182622E+00,
23606 &0.182779E+00,0.182724E+00,0.182622E+00,0.307242E+01,0.498976E-01,
23607 &0.528624E+00,0.380432E+00,0.190660E+00,0.190856E+00,0.190786E+00,
23608 &0.190660E+00,0.316911E+01,0.612760E-01,0.542428E+00,0.390485E+00/
23609 DATA (DL(K),K= 851, 935) /
23610 &0.198205E+00,0.198441E+00,0.198356E+00,0.198205E+00,0.324538E+01,
23611 &0.721303E-01,0.555382E+00,0.399810E+00,0.205224E+00,0.205498E+00,
23612 &0.205398E+00,0.205224E+00,0.330192E+01,0.824256E-01,0.567448E+00,
23613 &0.408377E+00,0.211687E+00,0.211997E+00,0.211882E+00,0.211687E+00,
23614 &0.333960E+01,0.921319E-01,0.578597E+00,0.416159E+00,0.217568E+00,
23615 &0.217915E+00,0.217784E+00,0.217568E+00,0.335945E+01,0.101224E+00,
23616 &0.588802E+00,0.423136E+00,0.222847E+00,0.223229E+00,0.223084E+00,
23617 &0.222847E+00,0.336262E+01,0.109681E+00,0.598043E+00,0.429293E+00,
23618 &0.227512E+00,0.227928E+00,0.227768E+00,0.227512E+00,0.335036E+01,
23619 &0.117489E+00,0.606305E+00,0.434619E+00,0.231551E+00,0.232000E+00,
23620 &0.231826E+00,0.231551E+00,0.332398E+01,0.124636E+00,0.613579E+00,
23621 &0.439110E+00,0.234962E+00,0.235442E+00,0.235254E+00,0.234962E+00,
23622 &0.328483E+01,0.131119E+00,0.619860E+00,0.442766E+00,0.237745E+00,
23623 &0.238254E+00,0.238053E+00,0.237745E+00,0.323429E+01,0.136936E+00,
23624 &0.625150E+00,0.445594E+00,0.239905E+00,0.240441E+00,0.240228E+00,
23625 &0.239905E+00,0.317371E+01,0.142091E+00,0.629453E+00,0.447603E+00,
23626 &0.241452E+00,0.242014E+00,0.241788E+00,0.241452E+00,0.310443E+01/
23627 DATA (DL(K),K= 936, 1020) /
23628 &0.146594E+00,0.632782E+00,0.448808E+00,0.242400E+00,0.242987E+00,
23629 &0.242749E+00,0.242400E+00,0.302775E+01,0.150456E+00,0.635151E+00,
23630 &0.449228E+00,0.242767E+00,0.243376E+00,0.243127E+00,0.242767E+00,
23631 &0.294491E+01,0.153694E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23632 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23633 &0.528765E+00,0.341825E+00,0.105823E+00,0.105823E+00,0.105823E+00,
23634 &0.105823E+00,0.185069E+01,-.138778E-16,0.538124E+00,0.347118E+00,
23635 &0.109762E+00,0.109780E+00,0.109774E+00,0.109762E+00,0.189644E+01,
23636 &0.738880E-02,0.546541E+00,0.351712E+00,0.113300E+00,0.113336E+00,
23637 &0.113324E+00,0.113300E+00,0.192700E+01,0.143076E-01,0.554014E+00,
23638 &0.355607E+00,0.116431E+00,0.116485E+00,0.116466E+00,0.116431E+00,
23639 &0.194356E+01,0.207515E-01,0.560546E+00,0.358805E+00,0.119150E+00,
23640 &0.119222E+00,0.119196E+00,0.119150E+00,0.194722E+01,0.267179E-01,
23641 &0.566139E+00,0.361311E+00,0.121459E+00,0.121549E+00,0.121515E+00,
23642 &0.121459E+00,0.193921E+01,0.322084E-01,0.570802E+00,0.363134E+00,
23643 &0.123359E+00,0.123467E+00,0.123426E+00,0.123359E+00,0.192071E+01,
23644 &0.372262E-01,0.574542E+00,0.364286E+00,0.124858E+00,0.124983E+00/
23645 DATA (DL(K),K= 1021, 1105) /
23646 &0.124933E+00,0.124858E+00,0.189295E+01,0.417774E-01,0.577372E+00,
23647 &0.364779E+00,0.125961E+00,0.126103E+00,0.126046E+00,0.125961E+00,
23648 &0.185710E+01,0.458703E-01,0.579307E+00,0.364629E+00,0.126681E+00,
23649 &0.126839E+00,0.126774E+00,0.126681E+00,0.181432E+01,0.495154E-01,
23650 &0.580363E+00,0.363857E+00,0.127029E+00,0.127202E+00,0.127130E+00,
23651 &0.127029E+00,0.176571E+01,0.527252E-01,0.580561E+00,0.362483E+00,
23652 &0.127020E+00,0.127208E+00,0.127128E+00,0.127020E+00,0.171231E+01,
23653 &0.555142E-01,0.579923E+00,0.360529E+00,0.126670E+00,0.126872E+00,
23654 &0.126785E+00,0.126670E+00,0.165511E+01,0.578985E-01,0.578474E+00,
23655 &0.358021E+00,0.125998E+00,0.126213E+00,0.126119E+00,0.125998E+00,
23656 &0.159501E+01,0.598958E-01,0.576241E+00,0.354987E+00,0.125022E+00,
23657 &0.125249E+00,0.125148E+00,0.125022E+00,0.153284E+01,0.615248E-01,
23658 &0.573252E+00,0.351453E+00,0.123762E+00,0.124000E+00,0.123893E+00,
23659 &0.123762E+00,0.146934E+01,0.628056E-01,0.569539E+00,0.347450E+00,
23660 &0.122240E+00,0.122488E+00,0.122375E+00,0.122240E+00,0.140517E+01,
23661 &0.637587E-01,0.565134E+00,0.343008E+00,0.120476E+00,0.120733E+00,
23662 &0.120615E+00,0.120476E+00,0.134093E+01,0.644054E-01,0.560071E+00/
23663 DATA (DL(K),K= 1106, 1190) /
23664 &0.338158E+00,0.118493E+00,0.118758E+00,0.118635E+00,0.118493E+00,
23665 &0.127712E+01,0.647671E-01,0.000000E+00,0.000000E+00,0.000000E+00,
23666 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23667 &0.584093E+00,0.349173E+00,0.772117E-01,0.772117E-01,0.772117E-01,
23668 &0.772117E-01,0.140433E+01,0.346945E-17,0.586736E+00,0.349017E+00,
23669 &0.785355E-01,0.785519E-01,0.785448E-01,0.785355E-01,0.139434E+01,
23670 &0.447504E-02,0.588402E+00,0.348237E+00,0.795437E-01,0.795759E-01,
23671 &0.795617E-01,0.795437E-01,0.137550E+01,0.854114E-02,0.589124E+00,
23672 &0.346861E+00,0.802498E-01,0.802970E-01,0.802758E-01,0.802498E-01,
23673 &0.134918E+01,0.122148E-01,0.588930E+00,0.344912E+00,0.806656E-01,
23674 &0.807271E-01,0.806990E-01,0.806656E-01,0.131652E+01,0.155101E-01,
23675 &0.587849E+00,0.342417E+00,0.808055E-01,0.808805E-01,0.808457E-01,
23676 &0.808055E-01,0.127862E+01,0.184435E-01,0.585912E+00,0.339402E+00,
23677 &0.806843E-01,0.807718E-01,0.807306E-01,0.806843E-01,0.123648E+01,
23678 &0.210315E-01,0.583151E+00,0.335894E+00,0.803173E-01,0.804166E-01,
23679 &0.803692E-01,0.803173E-01,0.119104E+01,0.232909E-01,0.579599E+00,
23680 &0.331923E+00,0.797205E-01,0.798308E-01,0.797775E-01,0.797205E-01/
23681 DATA (DL(K),K= 1191, 1275) /
23682 &0.114317E+01,0.252394E-01,0.575288E+00,0.327516E+00,0.789107E-01,
23683 &0.790310E-01,0.789721E-01,0.789107E-01,0.109362E+01,0.268946E-01,
23684 &0.570253E+00,0.322704E+00,0.779045E-01,0.780341E-01,0.779698E-01,
23685 &0.779045E-01,0.104307E+01,0.282745E-01,0.564530E+00,0.317515E+00,
23686 &0.767190E-01,0.768570E-01,0.767878E-01,0.767190E-01,0.992143E+00,
23687 &0.293974E-01,0.558155E+00,0.311981E+00,0.753713E-01,0.755169E-01,
23688 &0.754432E-01,0.753713E-01,0.941341E+00,0.302812E-01,0.551166E+00,
23689 &0.306131E+00,0.738784E-01,0.740308E-01,0.739528E-01,0.738784E-01,
23690 &0.891113E+00,0.309441E-01,0.543599E+00,0.299995E+00,0.722571E-01,
23691 &0.724154E-01,0.723336E-01,0.722571E-01,0.841829E+00,0.314037E-01,
23692 &0.535494E+00,0.293603E+00,0.705237E-01,0.706871E-01,0.706019E-01,
23693 &0.705237E-01,0.793794E+00,0.316774E-01,0.526888E+00,0.286986E+00,
23694 &0.686941E-01,0.688619E-01,0.687736E-01,0.686941E-01,0.747249E+00,
23695 &0.317823E-01,0.517822E+00,0.280172E+00,0.667836E-01,0.669551E-01,
23696 &0.668640E-01,0.667836E-01,0.702381E+00,0.317346E-01,0.508333E+00,
23697 &0.273189E+00,0.648068E-01,0.649814E-01,0.648879E-01,0.648068E-01,
23698 &0.659330E+00,0.315501E-01,0.000000E+00,0.000000E+00,0.000000E+00/
23699 DATA (DL(K),K= 1276, 1360) /
23700 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23701 &0.622739E+00,0.340676E+00,0.509141E-01,0.509141E-01,0.509141E-01,
23702 &0.509141E-01,0.980502E+00,-.173472E-17,0.617764E+00,0.335457E+00,
23703 &0.507607E-01,0.507701E-01,0.507651E-01,0.507607E-01,0.944375E+00,
23704 &0.242386E-02,0.611957E+00,0.329837E+00,0.504236E-01,0.504417E-01,
23705 &0.504321E-01,0.504236E-01,0.905225E+00,0.455851E-02,0.605372E+00,
23706 &0.323853E+00,0.499207E-01,0.499471E-01,0.499328E-01,0.499207E-01,
23707 &0.864035E+00,0.642656E-02,0.598052E+00,0.317537E+00,0.492668E-01,
23708 &0.493008E-01,0.492822E-01,0.492668E-01,0.821557E+00,0.804638E-02,
23709 &0.590044E+00,0.310919E+00,0.484772E-01,0.485183E-01,0.484955E-01,
23710 &0.484772E-01,0.778444E+00,0.943663E-02,0.581391E+00,0.304033E+00,
23711 &0.475665E-01,0.476142E-01,0.475874E-01,0.475665E-01,0.735263E+00,
23712 &0.106150E-01,0.572137E+00,0.296908E+00,0.465487E-01,0.466024E-01,
23713 &0.465720E-01,0.465487E-01,0.692487E+00,0.115984E-01,0.562326E+00,
23714 &0.289573E+00,0.454376E-01,0.454968E-01,0.454629E-01,0.454376E-01,
23715 &0.650510E+00,0.124032E-01,0.552003E+00,0.282060E+00,0.442463E-01,
23716 &0.443103E-01,0.442733E-01,0.442463E-01,0.609652E+00,0.130451E-01/
23717 DATA (DL(K),K= 1361, 1445) /
23718 &0.541210E+00,0.274395E+00,0.429871E-01,0.430555E-01,0.430156E-01,
23719 &0.429871E-01,0.570164E+00,0.135389E-01,0.529991E+00,0.266608E+00,
23720 &0.416720E-01,0.417443E-01,0.417018E-01,0.416720E-01,0.532237E+00,
23721 &0.138989E-01,0.518389E+00,0.258725E+00,0.403123E-01,0.403879E-01,
23722 &0.403431E-01,0.403123E-01,0.496010E+00,0.141386E-01,0.506446E+00,
23723 &0.250772E+00,0.389186E-01,0.389971E-01,0.389501E-01,0.389186E-01,
23724 &0.461573E+00,0.142708E-01,0.494204E+00,0.242775E+00,0.375006E-01,
23725 &0.375815E-01,0.375327E-01,0.375006E-01,0.428979E+00,0.143074E-01,
23726 &0.481705E+00,0.234757E+00,0.360674E-01,0.361503E-01,0.361000E-01,
23727 &0.360674E-01,0.398246E+00,0.142598E-01,0.468990E+00,0.226741E+00,
23728 &0.346276E-01,0.347120E-01,0.346605E-01,0.346276E-01,0.369363E+00,
23729 &0.141385E-01,0.456098E+00,0.218750E+00,0.331887E-01,0.332743E-01,
23730 &0.332216E-01,0.331887E-01,0.342300E+00,0.139532E-01,0.443068E+00,
23731 &0.210804E+00,0.317576E-01,0.318440E-01,0.317905E-01,0.317576E-01,
23732 &0.317005E+00,0.137130E-01,0.000000E+00,0.000000E+00,0.000000E+00,
23733 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23734 &0.631458E+00,0.318714E+00,0.335640E-01,0.335640E-01,0.335640E-01/
23735 DATA (DL(K),K= 1446, 1530) /
23736 &0.335640E-01,0.686773E+00,0.346945E-17,0.620274E+00,0.310241E+00,
23737 &0.329311E-01,0.329377E-01,0.329337E-01,0.329311E-01,0.646559E+00,
23738 &0.135960E-02,0.608504E+00,0.301610E+00,0.322083E-01,0.322210E-01,
23739 &0.322133E-01,0.322083E-01,0.606503E+00,0.252820E-02,0.596205E+00,
23740 &0.292854E+00,0.314099E-01,0.314281E-01,0.314169E-01,0.314099E-01,
23741 &0.567134E+00,0.352543E-02,0.583429E+00,0.284002E+00,0.305470E-01,
23742 &0.305704E-01,0.305558E-01,0.305470E-01,0.528824E+00,0.436693E-02,
23743 &0.570223E+00,0.275080E+00,0.296307E-01,0.296586E-01,0.296411E-01,
23744 &0.296307E-01,0.491848E+00,0.506768E-02,0.556637E+00,0.266115E+00,
23745 &0.286709E-01,0.287030E-01,0.286827E-01,0.286709E-01,0.456422E+00,
23746 &0.564157E-02,0.542717E+00,0.257131E+00,0.276770E-01,0.277128E-01,
23747 &0.276900E-01,0.276770E-01,0.422697E+00,0.610148E-02,0.528511E+00,
23748 &0.248154E+00,0.266578E-01,0.266968E-01,0.266718E-01,0.266578E-01,
23749 &0.390771E+00,0.645942E-02,0.514062E+00,0.239205E+00,0.256210E-01,
23750 &0.256629E-01,0.256359E-01,0.256210E-01,0.360700E+00,0.672653E-02,
23751 &0.499417E+00,0.230307E+00,0.245741E-01,0.246185E-01,0.245896E-01,
23752 &0.245741E-01,0.332498E+00,0.691312E-02,0.484617E+00,0.221480E+00/
23753 DATA (DL(K),K= 1531, 1615) /
23754 &0.235237E-01,0.235701E-01,0.235397E-01,0.235237E-01,0.306153E+00,
23755 &0.702875E-02,0.469706E+00,0.212745E+00,0.224757E-01,0.225238E-01,
23756 &0.224921E-01,0.224757E-01,0.281624E+00,0.708222E-02,0.454725E+00,
23757 &0.204118E+00,0.214355E-01,0.214850E-01,0.214522E-01,0.214355E-01,
23758 &0.258855E+00,0.708159E-02,0.439713E+00,0.195618E+00,0.204079E-01,
23759 &0.204586E-01,0.204249E-01,0.204079E-01,0.237774E+00,0.703428E-02,
23760 &0.424709E+00,0.187259E+00,0.193972E-01,0.194486E-01,0.194142E-01,
23761 &0.193972E-01,0.218298E+00,0.694702E-02,0.409750E+00,0.179057E+00,
23762 &0.184069E-01,0.184588E-01,0.184239E-01,0.184069E-01,0.200339E+00,
23763 &0.682594E-02,0.394870E+00,0.171023E+00,0.174402E-01,0.174924E-01,
23764 &0.174571E-01,0.174402E-01,0.183804E+00,0.667657E-02,0.380104E+00,
23765 &0.163171E+00,0.164997E-01,0.165519E-01,0.165164E-01,0.164997E-01,
23766 &0.168600E+00,0.650389E-02,0.000000E+00,0.000000E+00,0.000000E+00,
23767 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23768 &0.619056E+00,0.288873E+00,0.218554E-01,0.218554E-01,0.218554E-01,
23769 &0.218554E-01,0.477010E+00,-.867362E-17,0.602890E+00,0.278444E+00,
23770 &0.211480E-01,0.211530E-01,0.211497E-01,0.211480E-01,0.440877E+00/
23771 DATA (DL(K),K= 1616, 1700) /
23772 &0.767466E-03,0.586431E+00,0.268081E+00,0.204081E-01,0.204175E-01,
23773 &0.204113E-01,0.204081E-01,0.406417E+00,0.141432E-02,0.569736E+00,
23774 &0.257807E+00,0.196446E-01,0.196581E-01,0.196491E-01,0.196446E-01,
23775 &0.373808E+00,0.195508E-02,0.552853E+00,0.247642E+00,0.188646E-01,
23776 &0.188816E-01,0.188701E-01,0.188646E-01,0.343145E+00,0.240123E-02,
23777 &0.535829E+00,0.237603E+00,0.180743E-01,0.180945E-01,0.180808E-01,
23778 &0.180743E-01,0.314460E+00,0.276332E-02,0.518710E+00,0.227710E+00,
23779 &0.172796E-01,0.173025E-01,0.172868E-01,0.172796E-01,0.287750E+00,
23780 &0.305100E-02,0.501539E+00,0.217977E+00,0.164854E-01,0.165108E-01,
23781 &0.164933E-01,0.164854E-01,0.262983E+00,0.327305E-02,0.484360E+00,
23782 &0.208420E+00,0.156964E-01,0.157239E-01,0.157049E-01,0.156964E-01,
23783 &0.240098E+00,0.343744E-02,0.467213E+00,0.199053E+00,0.149165E-01,
23784 &0.149457E-01,0.149254E-01,0.149165E-01,0.219021E+00,0.355144E-02,
23785 &0.450140E+00,0.189889E+00,0.141493E-01,0.141800E-01,0.141586E-01,
23786 &0.141493E-01,0.199660E+00,0.362164E-02,0.433177E+00,0.180939E+00,
23787 &0.133978E-01,0.134297E-01,0.134073E-01,0.133978E-01,0.181918E+00,
23788 &0.365401E-02,0.416362E+00,0.172214E+00,0.126646E-01,0.126974E-01/
23789 DATA (DL(K),K= 1701, 1785) /
23790 &0.126742E-01,0.126646E-01,0.165692E+00,0.365394E-02,0.399729E+00,
23791 &0.163725E+00,0.119518E-01,0.119853E-01,0.119615E-01,0.119518E-01,
23792 &0.150875E+00,0.362628E-02,0.383310E+00,0.155477E+00,0.112613E-01,
23793 &0.112952E-01,0.112711E-01,0.112613E-01,0.137364E+00,0.357539E-02,
23794 &0.367138E+00,0.147479E+00,0.105945E-01,0.106287E-01,0.106042E-01,
23795 &0.105945E-01,0.125056E+00,0.350515E-02,0.351239E+00,0.139737E+00,
23796 &0.995250E-02,0.998673E-02,0.996211E-02,0.995250E-02,0.113852E+00,
23797 &0.341903E-02,0.335641E+00,0.132253E+00,0.933610E-02,0.937024E-02,
23798 &0.934557E-02,0.933610E-02,0.103659E+00,0.332009E-02,0.320367E+00,
23799 &0.125033E+00,0.874584E-02,0.877973E-02,0.875514E-02,0.874584E-02,
23800 &0.943886E-01,0.321106E-02,0.000000E+00,0.000000E+00,0.000000E+00,
23801 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23802 &0.591114E+00,0.254807E+00,0.139531E-01,0.139531E-01,0.139531E-01,
23803 &0.139531E-01,0.326288E+00,0.000000E+00,0.571121E+00,0.243424E+00,
23804 &0.133325E-01,0.133362E-01,0.133336E-01,0.133325E-01,0.296956E+00,
23805 &0.429082E-03,0.551151E+00,0.232297E+00,0.127105E-01,0.127175E-01,
23806 &0.127126E-01,0.127105E-01,0.269811E+00,0.785137E-03,0.531253E+00/
23807 DATA (DL(K),K= 1786, 1870) /
23808 &0.221436E+00,0.120916E-01,0.121015E-01,0.120945E-01,0.120916E-01,
23809 &0.244803E+00,0.107790E-02,0.511467E+00,0.210850E+00,0.114794E-01,
23810 &0.114918E-01,0.114829E-01,0.114794E-01,0.221863E+00,0.131504E-02,
23811 &0.491833E+00,0.200545E+00,0.108767E-01,0.108913E-01,0.108808E-01,
23812 &0.108767E-01,0.200886E+00,0.150337E-02,0.472388E+00,0.190531E+00,
23813 &0.102861E-01,0.103027E-01,0.102907E-01,0.102861E-01,0.181762E+00,
23814 &0.164910E-02,0.453170E+00,0.180812E+00,0.970979E-02,0.972799E-02,
23815 &0.971477E-02,0.970979E-02,0.164371E+00,0.175777E-02,0.434213E+00,
23816 &0.171394E+00,0.914959E-02,0.916916E-02,0.915488E-02,0.914959E-02,
23817 &0.148589E+00,0.183434E-02,0.415548E+00,0.162282E+00,0.860700E-02,
23818 &0.862770E-02,0.861252E-02,0.860700E-02,0.134293E+00,0.188328E-02,
23819 &0.397208E+00,0.153479E+00,0.808323E-02,0.810484E-02,0.808891E-02,
23820 &0.808323E-02,0.121361E+00,0.190856E-02,0.379220E+00,0.144989E+00,
23821 &0.757922E-02,0.760152E-02,0.758501E-02,0.757922E-02,0.109676E+00,
23822 &0.191374E-02,0.361611E+00,0.136811E+00,0.709565E-02,0.711846E-02,
23823 &0.710150E-02,0.709565E-02,0.991261E-01,0.190199E-02,0.344406E+00,
23824 &0.128948E+00,0.663300E-02,0.665614E-02,0.663885E-02,0.663300E-02/
23825 DATA (DL(K),K= 1871, 1955) /
23826 &0.896059E-01,0.187610E-02,0.327627E+00,0.121398E+00,0.619152E-02,
23827 &0.621484E-02,0.619734E-02,0.619152E-02,0.810177E-01,0.183856E-02,
23828 &0.311292E+00,0.114161E+00,0.577130E-02,0.579466E-02,0.577706E-02,
23829 &0.577130E-02,0.732709E-01,0.179155E-02,0.295421E+00,0.107235E+00,
23830 &0.537228E-02,0.539554E-02,0.537794E-02,0.537228E-02,0.662824E-01,
23831 &0.173700E-02,0.280026E+00,0.100616E+00,0.499423E-02,0.501728E-02,
23832 &0.499977E-02,0.499423E-02,0.599766E-01,0.167658E-02,0.265121E+00,
23833 &0.943000E-01,0.463683E-02,0.465958E-02,0.464223E-02,0.463683E-02,
23834 &0.542848E-01,0.161174E-02,0.000000E+00,0.000000E+00,0.000000E+00,
23835 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23836 &0.551659E+00,0.219084E+00,0.867977E-02,0.867977E-02,0.867977E-02,
23837 &0.867977E-02,0.218587E+00,-.173472E-16,0.528947E+00,0.207536E+00,
23838 &0.819621E-02,0.819909E-02,0.819696E-02,0.819621E-02,0.196367E+00,
23839 &0.234843E-03,0.506575E+00,0.196391E+00,0.772540E-02,0.773082E-02,
23840 &0.772680E-02,0.772540E-02,0.176280E+00,0.427503E-03,0.484579E+00,
23841 &0.185646E+00,0.726876E-02,0.727639E-02,0.727069E-02,0.726876E-02,
23842 &0.158158E+00,0.583933E-03,0.462988E+00,0.175298E+00,0.682746E-02/
23843 DATA (DL(K),K= 1956, 2040) /
23844 &0.683702E-02,0.682985E-02,0.682746E-02,0.141851E+00,0.708874E-03,
23845 &0.441830E+00,0.165345E+00,0.640226E-02,0.641347E-02,0.640502E-02,
23846 &0.640226E-02,0.127203E+00,0.806409E-03,0.421129E+00,0.155783E+00,
23847 &0.599380E-02,0.600641E-02,0.599686E-02,0.599380E-02,0.114065E+00,
23848 &0.880249E-03,0.400912E+00,0.146609E+00,0.560252E-02,0.561629E-02,
23849 &0.560581E-02,0.560252E-02,0.102296E+00,0.933676E-03,0.381199E+00,
23850 &0.137819E+00,0.522870E-02,0.524342E-02,0.523217E-02,0.522870E-02,
23851 &0.917608E-01,0.969607E-03,0.362011E+00,0.129407E+00,0.487247E-02,
23852 &0.488796E-02,0.487607E-02,0.487247E-02,0.823356E-01,0.990632E-03,
23853 &0.343367E+00,0.121370E+00,0.453385E-02,0.454992E-02,0.453753E-02,
23854 &0.453385E-02,0.739054E-01,0.999042E-03,0.325282E+00,0.113700E+00,
23855 &0.421272E-02,0.422921E-02,0.421644E-02,0.421272E-02,0.663651E-01,
23856 &0.996863E-03,0.307770E+00,0.106393E+00,0.390887E-02,0.392563E-02,
23857 &0.391260E-02,0.390887E-02,0.596195E-01,0.985881E-03,0.290841E+00,
23858 &0.994399E-01,0.362199E-02,0.363889E-02,0.362570E-02,0.362199E-02,
23859 &0.535826E-01,0.967664E-03,0.274506E+00,0.928343E-01,0.335170E-02,
23860 &0.336862E-02,0.335536E-02,0.335170E-02,0.481769E-01,0.943587E-03/
23861 DATA (DL(K),K= 2041, 2125) /
23862 &0.258771E+00,0.865679E-01,0.309756E-02,0.311439E-02,0.310114E-02,
23863 &0.309756E-02,0.433336E-01,0.914850E-03,0.243639E+00,0.806321E-01,
23864 &0.285905E-02,0.287571E-02,0.286255E-02,0.285905E-02,0.389912E-01,
23865 &0.882497E-03,0.229113E+00,0.750177E-01,0.263565E-02,0.265205E-02,
23866 &0.263905E-02,0.263565E-02,0.350948E-01,0.847432E-03,0.215193E+00,
23867 &0.697152E-01,0.242677E-02,0.244285E-02,0.243005E-02,0.242677E-02,
23868 &0.315960E-01,0.810432E-03,0.000000E+00,0.000000E+00,0.000000E+00,
23869 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23870 &0.503850E+00,0.183581E+00,0.522815E-02,0.522815E-02,0.522815E-02,
23871 &0.522815E-02,0.142635E+00,0.123599E-16,0.479478E+00,0.172477E+00,
23872 &0.488093E-02,0.488328E-02,0.488147E-02,0.488093E-02,0.126767E+00,
23873 &0.124505E-03,0.455750E+00,0.161879E+00,0.455054E-02,0.455493E-02,
23874 &0.455153E-02,0.455054E-02,0.112695E+00,0.225968E-03,0.432681E+00,
23875 &0.151771E+00,0.423664E-02,0.424278E-02,0.423800E-02,0.423664E-02,
23876 &0.100212E+00,0.307702E-03,0.410286E+00,0.142140E+00,0.393907E-02,
23877 &0.394671E-02,0.394073E-02,0.393907E-02,0.891488E-01,0.372395E-03,
23878 &0.388577E+00,0.132974E+00,0.365743E-02,0.366634E-02,0.365934E-02/
23879 DATA (DL(K),K= 2126, 2210) /
23880 &0.365743E-02,0.793490E-01,0.422302E-03,0.367563E+00,0.124259E+00,
23881 &0.339138E-02,0.340133E-02,0.339347E-02,0.339138E-02,0.706688E-01,
23882 &0.459484E-03,0.347256E+00,0.115984E+00,0.314049E-02,0.315129E-02,
23883 &0.314273E-02,0.314049E-02,0.629792E-01,0.485762E-03,0.327660E+00,
23884 &0.108136E+00,0.290433E-02,0.291580E-02,0.290667E-02,0.290433E-02,
23885 &0.561642E-01,0.502744E-03,0.308782E+00,0.100701E+00,0.268243E-02,
23886 &0.269440E-02,0.268483E-02,0.268243E-02,0.501207E-01,0.511853E-03,
23887 &0.290625E+00,0.936693E-01,0.247429E-02,0.248663E-02,0.247672E-02,
23888 &0.247429E-02,0.447569E-01,0.514346E-03,0.273189E+00,0.870261E-01,
23889 &0.227939E-02,0.229197E-02,0.228184E-02,0.227939E-02,0.399920E-01,
23890 &0.511328E-03,0.256475E+00,0.807592E-01,0.209722E-02,0.210991E-02,
23891 &0.209965E-02,0.209722E-02,0.357547E-01,0.503769E-03,0.240478E+00,
23892 &0.748555E-01,0.192721E-02,0.193992E-02,0.192961E-02,0.192721E-02,
23893 &0.319825E-01,0.492518E-03,0.225194E+00,0.693019E-01,0.176883E-02,
23894 &0.178147E-02,0.177117E-02,0.176883E-02,0.286209E-01,0.478318E-03,
23895 &0.210615E+00,0.640851E-01,0.162151E-02,0.163400E-02,0.162379E-02,
23896 &0.162151E-02,0.256219E-01,0.461813E-03,0.196733E+00,0.591917E-01/
23897 DATA (DL(K),K= 2211, 2295) /
23898 &0.148471E-02,0.149698E-02,0.148691E-02,0.148471E-02,0.229436E-01,
23899 &0.443561E-03,0.183536E+00,0.546085E-01,0.135786E-02,0.136986E-02,
23900 &0.135998E-02,0.135786E-02,0.205496E-01,0.424043E-03,0.171011E+00,
23901 &0.503219E-01,0.124042E-02,0.125211E-02,0.124246E-02,0.124042E-02,
23902 &0.184079E-01,0.403672E-03,0.000000E+00,0.000000E+00,0.000000E+00,
23903 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23904 &0.450310E+00,0.149685E+00,0.302765E-02,0.302765E-02,0.302765E-02,
23905 &0.302765E-02,0.901099E-01,-.108420E-17,0.425282E+00,0.139479E+00,
23906 &0.279499E-02,0.279691E-02,0.279537E-02,0.279499E-02,0.794239E-01,
23907 &0.632140E-04,0.401169E+00,0.129837E+00,0.257801E-02,0.258157E-02,
23908 &0.257870E-02,0.257801E-02,0.700941E-01,0.114711E-03,0.377966E+00,
23909 &0.120733E+00,0.237556E-02,0.238052E-02,0.237650E-02,0.237556E-02,
23910 &0.619270E-01,0.156107E-03,0.355668E+00,0.112145E+00,0.218688E-02,
23911 &0.219301E-02,0.218802E-02,0.218688E-02,0.547717E-01,0.188777E-03,
23912 &0.334269E+00,0.104052E+00,0.201113E-02,0.201823E-02,0.201243E-02,
23913 &0.201113E-02,0.484974E-01,0.213848E-03,0.313762E+00,0.964335E-01,
23914 &0.184758E-02,0.185546E-02,0.184900E-02,0.184758E-02,0.429879E-01/
23915 DATA (DL(K),K= 2296, 2380) /
23916 &0.232367E-03,0.294139E+00,0.892696E-01,0.169553E-02,0.170402E-02,
23917 &0.169703E-02,0.169553E-02,0.381432E-01,0.245270E-03,0.275389E+00,
23918 &0.825414E-01,0.155431E-02,0.156326E-02,0.155586E-02,0.155431E-02,
23919 &0.338762E-01,0.253383E-03,0.257502E+00,0.762303E-01,0.142329E-02,
23920 &0.143258E-02,0.142487E-02,0.142329E-02,0.301119E-01,0.257441E-03,
23921 &0.240464E+00,0.703180E-01,0.130188E-02,0.131138E-02,0.130347E-02,
23922 &0.130188E-02,0.267853E-01,0.258098E-03,0.224262E+00,0.647867E-01,
23923 &0.118950E-02,0.119912E-02,0.119108E-02,0.118950E-02,0.238409E-01,
23924 &0.255929E-03,0.208879E+00,0.596190E-01,0.108562E-02,0.109526E-02,
23925 &0.108717E-02,0.108562E-02,0.212308E-01,0.251442E-03,0.194298E+00,
23926 &0.547975E-01,0.989698E-03,0.999283E-03,0.991221E-03,0.989698E-03,
23927 &0.189136E-01,0.245082E-03,0.180499E+00,0.503054E-01,0.901248E-03,
23928 &0.910711E-03,0.902726E-03,0.901248E-03,0.168537E-01,0.237238E-03,
23929 &0.167463E+00,0.461263E-01,0.819789E-03,0.829074E-03,0.821215E-03,
23930 &0.819789E-03,0.150206E-01,0.228250E-03,0.155167E+00,0.422438E-01,
23931 &0.744866E-03,0.753925E-03,0.746234E-03,0.744866E-03,0.133878E-01,
23932 &0.218412E-03,0.143590E+00,0.386421E-01,0.676043E-03,0.684836E-03/
23933 DATA (DL(K),K= 2381, 2465) /
23934 &0.677349E-03,0.676043E-03,0.119320E-01,0.207976E-03,0.132706E+00,
23935 &0.353058E-01,0.612907E-03,0.621403E-03,0.614147E-03,0.612907E-03,
23936 &0.106334E-01,0.197159E-03,0.000000E+00,0.000000E+00,0.000000E+00,
23937 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23938 &0.393307E+00,0.118409E+00,0.167124E-02,0.167124E-02,0.167124E-02,
23939 &0.167124E-02,0.547140E-01,0.433681E-17,0.368555E+00,0.109414E+00,
23940 &0.152547E-02,0.152705E-02,0.152573E-02,0.152547E-02,0.479708E-01,
23941 &0.303147E-04,0.344946E+00,0.101001E+00,0.139202E-02,0.139494E-02,
23942 &0.139249E-02,0.139202E-02,0.421517E-01,0.552185E-04,0.322450E+00,
23943 &0.931345E-01,0.126960E-02,0.127363E-02,0.127024E-02,0.126960E-02,
23944 &0.371043E-01,0.753524E-04,0.301043E+00,0.857854E-01,0.115731E-02,
23945 &0.116225E-02,0.115808E-02,0.115731E-02,0.327131E-01,0.913172E-04,
23946 &0.280698E+00,0.789267E-01,0.105427E-02,0.105995E-02,0.105514E-02,
23947 &0.105427E-02,0.288844E-01,0.103605E-03,0.261390E+00,0.725323E-01,
23948 &0.959726E-03,0.965979E-03,0.960659E-03,0.959726E-03,0.255366E-01,
23949 &0.112688E-03,0.243091E+00,0.665774E-01,0.872987E-03,0.879676E-03,
23950 &0.873966E-03,0.872987E-03,0.226017E-01,0.119000E-03,0.225775E+00/
23951 DATA (DL(K),K= 2466, 2550) /
23952 &0.610385E-01,0.793435E-03,0.800438E-03,0.794441E-03,0.793435E-03,
23953 &0.200219E-01,0.122931E-03,0.209414E+00,0.558928E-01,0.720508E-03,
23954 &0.727716E-03,0.721524E-03,0.720508E-03,0.177490E-01,0.124835E-03,
23955 &0.193979E+00,0.511187E-01,0.653691E-03,0.661011E-03,0.654703E-03,
23956 &0.653691E-03,0.157425E-01,0.125031E-03,0.179441E+00,0.466950E-01,
23957 &0.592513E-03,0.599863E-03,0.593511E-03,0.592513E-03,0.139674E-01,
23958 &0.123805E-03,0.165770E+00,0.426018E-01,0.536539E-03,0.543850E-03,
23959 &0.537513E-03,0.536539E-03,0.123945E-01,0.121411E-03,0.152935E+00,
23960 &0.388195E-01,0.485370E-03,0.492584E-03,0.486314E-03,0.485370E-03,
23961 &0.109993E-01,0.118076E-03,0.140905E+00,0.353295E-01,0.438636E-03,
23962 &0.445702E-03,0.439543E-03,0.438636E-03,0.976027E-02,0.113999E-03,
23963 &0.129648E+00,0.321137E-01,0.395992E-03,0.402871E-03,0.396859E-03,
23964 &0.395992E-03,0.865895E-02,0.109353E-03,0.119131E+00,0.291550E-01,
23965 &0.357120E-03,0.363779E-03,0.357945E-03,0.357120E-03,0.767960E-02,
23966 &0.104292E-03,0.109323E+00,0.264366E-01,0.321725E-03,0.328139E-03,
23967 &0.322505E-03,0.321725E-03,0.680866E-02,0.989468E-04,0.100191E+00,
23968 &0.239428E-01,0.289531E-03,0.295679E-03,0.290266E-03,0.289531E-03/
23969 DATA (DL(K),K= 2551, 2635) /
23970 &0.603390E-02,0.934295E-04,0.000000E+00,0.000000E+00,0.000000E+00,
23971 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23972 &0.334851E+00,0.904666E-01,0.869706E-03,0.869706E-03,0.869706E-03,
23973 &0.869706E-03,0.316365E-01,-.311708E-17,0.311223E+00,0.828706E-01,
23974 &0.784673E-03,0.785968E-03,0.784847E-03,0.784673E-03,0.277037E-01,
23975 &0.134749E-04,0.288910E+00,0.758361E-01,0.708234E-03,0.710597E-03,
23976 &0.708543E-03,0.708234E-03,0.243298E-01,0.247881E-04,0.267855E+00,
23977 &0.693222E-01,0.639256E-03,0.642491E-03,0.639671E-03,0.639256E-03,
23978 &0.214125E-01,0.340882E-04,0.248015E+00,0.632964E-01,0.576953E-03,
23979 &0.580887E-03,0.577448E-03,0.576953E-03,0.188764E-01,0.415701E-04,
23980 &0.229343E+00,0.577274E-01,0.520615E-03,0.525096E-03,0.521167E-03,
23981 &0.520615E-03,0.166642E-01,0.474027E-04,0.211794E+00,0.525860E-01,
23982 &0.469624E-03,0.474520E-03,0.470215E-03,0.469624E-03,0.147265E-01,
23983 &0.517615E-04,0.195325E+00,0.478447E-01,0.423445E-03,0.428640E-03,
23984 &0.424060E-03,0.423445E-03,0.130234E-01,0.548213E-04,0.179891E+00,
23985 &0.434776E-01,0.381606E-03,0.387001E-03,0.382232E-03,0.381606E-03,
23986 &0.115226E-01,0.567474E-04,0.165449E+00,0.394601E-01,0.343691E-03/
23987 DATA (DL(K),K= 2636, 2720) /
23988 &0.349200E-03,0.344317E-03,0.343691E-03,0.101965E-01,0.576952E-04,
23989 &0.151958E+00,0.357691E-01,0.309329E-03,0.314879E-03,0.309948E-03,
23990 &0.309329E-03,0.902217E-02,0.578101E-04,0.139374E+00,0.323826E-01,
23991 &0.278192E-03,0.283721E-03,0.278796E-03,0.278192E-03,0.798131E-02,
23992 &0.572266E-04,0.127655E+00,0.292797E-01,0.249984E-03,0.255440E-03,
23993 &0.250569E-03,0.249984E-03,0.705796E-02,0.560672E-04,0.116760E+00,
23994 &0.264406E-01,0.224440E-03,0.229782E-03,0.225002E-03,0.224440E-03,
23995 &0.623793E-02,0.544420E-04,0.106647E+00,0.238467E-01,0.201321E-03,
23996 &0.206513E-03,0.201856E-03,0.201321E-03,0.550962E-02,0.524504E-04,
23997 &0.972762E-01,0.214802E-01,0.180411E-03,0.185425E-03,0.180918E-03,
23998 &0.180411E-03,0.486321E-02,0.501804E-04,0.886073E-01,0.193242E-01,
23999 &0.161512E-03,0.166328E-03,0.161990E-03,0.161512E-03,0.428946E-02,
24000 &0.477087E-04,0.806013E-01,0.173629E-01,0.144446E-03,0.149048E-03,
24001 &0.144894E-03,0.144446E-03,0.378030E-02,0.451020E-04,0.732197E-01,
24002 &0.155814E-01,0.129049E-03,0.133425E-03,0.129467E-03,0.129049E-03,
24003 &0.332897E-02,0.424179E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24004 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24005 DATA (DL(K),K= 2721, 2805) /
24006 &0.276761E+00,0.663170E-01,0.420483E-03,0.420483E-03,0.420483E-03,
24007 &0.420483E-03,0.172075E-01,0.418773E-17,0.255003E+00,0.601925E-01,
24008 &0.374768E-03,0.375776E-03,0.374876E-03,0.374768E-03,0.151410E-01,
24009 &0.540038E-05,0.234664E+00,0.545789E-01,0.334420E-03,0.336252E-03,
24010 &0.334612E-03,0.334420E-03,0.133594E-01,0.101360E-04,0.215665E+00,
24011 &0.494328E-01,0.298611E-03,0.301108E-03,0.298867E-03,0.298611E-03,
24012 &0.118079E-01,0.141555E-04,0.197941E+00,0.447203E-01,0.266766E-03,
24013 &0.269787E-03,0.267068E-03,0.266766E-03,0.104461E-01,0.174750E-04,
24014 &0.181428E+00,0.404089E-01,0.238391E-03,0.241815E-03,0.238726E-03,
24015 &0.238391E-03,0.924609E-02,0.201244E-04,0.166064E+00,0.364687E-01,
24016 &0.213061E-03,0.216782E-03,0.213417E-03,0.213061E-03,0.818507E-02,
24017 &0.221467E-04,0.151790E+00,0.328719E-01,0.190418E-03,0.194343E-03,
24018 &0.190785E-03,0.190418E-03,0.724366E-02,0.235974E-04,0.138548E+00,
24019 &0.295925E-01,0.170150E-03,0.174202E-03,0.170521E-03,0.170150E-03,
24020 &0.640614E-02,0.245354E-04,0.126282E+00,0.266063E-01,0.151991E-03,
24021 &0.156104E-03,0.152359E-03,0.151991E-03,0.566089E-02,0.250221E-04,
24022 &0.114939E+00,0.238907E-01,0.135710E-03,0.139827E-03,0.136071E-03/
24023 DATA (DL(K),K= 2806, 2890) /
24024 &0.135710E-03,0.499773E-02,0.251191E-04,0.104465E+00,0.214245E-01,
24025 &0.121106E-03,0.125180E-03,0.121455E-03,0.121106E-03,0.440691E-02,
24026 &0.248850E-04,0.948101E-01,0.191879E-01,0.108002E-03,0.111994E-03,
24027 &0.108337E-03,0.108002E-03,0.388094E-02,0.243760E-04,0.859247E-01,
24028 &0.171625E-01,0.962435E-04,0.100124E-03,0.965624E-04,0.962435E-04,
24029 &0.341379E-02,0.236445E-04,0.777613E-01,0.153309E-01,0.856948E-04,
24030 &0.894394E-04,0.859960E-04,0.856948E-04,0.299910E-02,0.227378E-04,
24031 &0.702736E-01,0.136770E-01,0.762337E-04,0.798235E-04,0.765166E-04,
24032 &0.762337E-04,0.263116E-02,0.216984E-04,0.634174E-01,0.121859E-01,
24033 &0.677528E-04,0.711742E-04,0.680169E-04,0.677528E-04,0.230551E-02,
24034 &0.205642E-04,0.571500E-01,0.108434E-01,0.601554E-04,0.633990E-04,
24035 &0.604008E-04,0.601554E-04,0.201791E-02,0.193681E-04,0.514305E-01,
24036 &0.963651E-02,0.533545E-04,0.564148E-04,0.535814E-04,0.533545E-04,
24037 &0.176404E-02,0.181381E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24038 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24039 &0.220700E+00,0.461964E-01,0.185072E-03,0.185072E-03,0.185072E-03,
24040 &0.185072E-03,0.865568E-02,-.294090E-17,0.201438E+00,0.415162E-01/
24041 DATA (DL(K),K= 2891, 2975) /
24042 &0.162774E-03,0.163610E-03,0.162842E-03,0.162774E-03,0.772611E-02,
24043 &0.184134E-05,0.183625E+00,0.372730E-01,0.143469E-03,0.144974E-03,
24044 &0.143588E-03,0.143469E-03,0.690038E-02,0.359959E-05,0.167162E+00,
24045 &0.334245E-01,0.126634E-03,0.128666E-03,0.126791E-03,0.126634E-03,
24046 &0.616000E-02,0.518075E-05,0.151966E+00,0.299378E-01,0.111904E-03,
24047 &0.114340E-03,0.112088E-03,0.111904E-03,0.549219E-02,0.654232E-05,
24048 &0.137959E+00,0.267821E-01,0.989836E-04,0.101716E-03,0.991845E-04,
24049 &0.989836E-04,0.488896E-02,0.767008E-05,0.125065E+00,0.239289E-01,
24050 &0.876157E-04,0.905559E-04,0.878269E-04,0.876157E-04,0.434253E-02,
24051 &0.855860E-05,0.113213E+00,0.213524E-01,0.775899E-04,0.806611E-04,
24052 &0.778055E-04,0.775899E-04,0.384886E-02,0.921640E-05,0.102335E+00,
24053 &0.190285E-01,0.687292E-04,0.718676E-04,0.689446E-04,0.687292E-04,
24054 &0.340422E-02,0.965961E-05,0.923671E-01,0.169353E-01,0.608829E-04,
24055 &0.640353E-04,0.610944E-04,0.608829E-04,0.300332E-02,0.990752E-05,
24056 &0.832476E-01,0.150523E-01,0.539242E-04,0.570473E-04,0.541291E-04,
24057 &0.539242E-04,0.264288E-02,0.998320E-05,0.749179E-01,0.133608E-01,
24058 &0.477459E-04,0.508046E-04,0.479422E-04,0.477459E-04,0.232088E-02/
24059 DATA (DL(K),K= 2976, 3060) /
24060 &0.991147E-05,0.673221E-01,0.118435E-01,0.422554E-04,0.452220E-04,
24061 &0.424417E-04,0.422554E-04,0.203376E-02,0.971603E-05,0.604073E-01,
24062 &0.104845E-01,0.373730E-04,0.402263E-04,0.375483E-04,0.373730E-04,
24063 &0.177791E-02,0.941959E-05,0.541231E-01,0.926900E-02,0.330304E-04,
24064 &0.357544E-04,0.331943E-04,0.330304E-04,0.155117E-02,0.904408E-05,
24065 &0.484216E-01,0.818347E-02,0.291681E-04,0.317517E-04,0.293202E-04,
24066 &0.291681E-04,0.135108E-02,0.860921E-05,0.432578E-01,0.721549E-02,
24067 &0.257333E-04,0.281694E-04,0.258738E-04,0.257333E-04,0.117463E-02,
24068 &0.813214E-05,0.385889E-01,0.635362E-02,0.226802E-04,0.249648E-04,
24069 &0.228093E-04,0.226802E-04,0.101941E-02,0.762814E-05,0.343746E-01,
24070 &0.558739E-02,0.199682E-04,0.221003E-04,0.200863E-04,0.199682E-04,
24071 &0.883469E-03,0.711035E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24072 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24073 &0.168205E+00,0.301419E-01,0.719932E-04,0.719932E-04,0.719932E-04,
24074 &0.719932E-04,0.392825E-02,-.205998E-17,0.151922E+00,0.267932E-01,
24075 &0.623634E-04,0.630456E-04,0.624028E-04,0.623634E-04,0.361412E-02,
24076 &0.457084E-06,0.137042E+00,0.237932E-01,0.541981E-04,0.554098E-04/
24077 DATA (DL(K),K= 3061, 3145) /
24078 &0.542663E-04,0.541981E-04,0.330342E-02,0.989813E-06,0.123446E+00,
24079 &0.211038E-01,0.472163E-04,0.488314E-04,0.473050E-04,0.472163E-04,
24080 &0.300140E-02,0.152631E-05,0.111042E+00,0.186954E-01,0.412159E-04,
24081 &0.431273E-04,0.413184E-04,0.412159E-04,0.270826E-02,0.202092E-05,
24082 &0.997395E-01,0.165410E-01,0.360433E-04,0.381615E-04,0.361542E-04,
24083 &0.360433E-04,0.242968E-02,0.245400E-05,0.894558E-01,0.146159E-01,
24084 &0.315670E-04,0.338178E-04,0.316822E-04,0.315670E-04,0.216928E-02,
24085 &0.281218E-05,0.801130E-01,0.128978E-01,0.276779E-04,0.300002E-04,
24086 &0.277940E-04,0.276779E-04,0.192603E-02,0.308878E-05,0.716379E-01,
24087 &0.113663E-01,0.242878E-04,0.266317E-04,0.244024E-04,0.242878E-04,
24088 &0.170100E-02,0.328451E-05,0.639623E-01,0.100031E-01,0.213246E-04,
24089 &0.236502E-04,0.214357E-04,0.213246E-04,0.149649E-02,0.340483E-05,
24090 &0.570222E-01,0.879131E-02,0.187277E-04,0.210033E-04,0.188341E-04,
24091 &0.187277E-04,0.131163E-02,0.345656E-05,0.507574E-01,0.771565E-02,
24092 &0.164465E-04,0.186476E-04,0.165471E-04,0.164465E-04,0.114469E-02,
24093 &0.344782E-05,0.451118E-01,0.676223E-02,0.144396E-04,0.165480E-04,
24094 &0.145339E-04,0.144396E-04,0.995649E-03,0.338831E-05,0.400330E-01/
24095 DATA (DL(K),K= 3146, 3230) /
24096 &0.591841E-02,0.126720E-04,0.146744E-04,0.127597E-04,0.126720E-04,
24097 &0.863829E-03,0.328754E-05,0.354720E-01,0.517273E-02,0.111137E-04,
24098 &0.130013E-04,0.111946E-04,0.111137E-04,0.747293E-03,0.315403E-05,
24099 &0.313830E-01,0.451477E-02,0.973915E-05,0.115067E-04,0.981339E-05,
24100 &0.973915E-05,0.644664E-03,0.299600E-05,0.277237E-01,0.393511E-02,
24101 &0.852687E-05,0.101721E-04,0.859457E-05,0.852687E-05,0.555034E-03,
24102 &0.282099E-05,0.244545E-01,0.342521E-02,0.745784E-05,0.898076E-05,
24103 &0.751926E-05,0.745784E-05,0.476998E-03,0.263530E-05,0.215390E-01,
24104 &0.297737E-02,0.651555E-05,0.791817E-05,0.657100E-05,0.651555E-05,
24105 &0.409096E-03,0.244427E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24106 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24107 &0.120694E+00,0.180081E-01,0.236444E-04,0.236444E-04,0.236444E-04,
24108 &0.236444E-04,0.154817E-02,0.416656E-17,0.107713E+00,0.158098E-01,
24109 &0.200945E-04,0.206098E-04,0.201146E-04,0.200945E-04,0.151249E-02,
24110 &0.192118E-07,0.960063E-01,0.138667E-01,0.171552E-04,0.180593E-04,
24111 &0.171894E-04,0.171552E-04,0.143574E-02,0.116516E-06,0.854477E-01,
24112 &0.121473E-01,0.146986E-04,0.158894E-04,0.147425E-04,0.146986E-04/
24113 DATA (DL(K),K= 3231, 3315) /
24114 &0.133744E-02,0.251060E-06,0.759386E-01,0.106275E-01,0.126329E-04,
24115 &0.140252E-04,0.126830E-04,0.126329E-04,0.122900E-02,0.395272E-06,
24116 &0.673865E-01,0.928577E-02,0.108901E-04,0.124142E-04,0.109436E-04,
24117 &0.108901E-04,0.111367E-02,0.535145E-06,0.597062E-01,0.810254E-02,
24118 &0.941160E-05,0.110108E-04,0.946648E-05,0.941160E-05,0.996785E-03,
24119 &0.659421E-06,0.528194E-01,0.706039E-02,0.815165E-05,0.978016E-05,
24120 &0.820627E-05,0.815165E-05,0.885152E-03,0.762600E-06,0.466540E-01,
24121 &0.614371E-02,0.707299E-05,0.869464E-05,0.712616E-05,0.707299E-05,
24122 &0.780484E-03,0.842072E-06,0.411433E-01,0.533850E-02,0.614470E-05,
24123 &0.773135E-05,0.619559E-05,0.614470E-05,0.682563E-03,0.896683E-06,
24124 &0.362261E-01,0.463223E-02,0.534297E-05,0.687330E-05,0.539102E-05,
24125 &0.534297E-05,0.593317E-03,0.928176E-06,0.318459E-01,0.401364E-02,
24126 &0.464848E-05,0.610690E-05,0.469333E-05,0.464848E-05,0.513720E-03,
24127 &0.939174E-06,0.279510E-01,0.347266E-02,0.404483E-05,0.542054E-05,
24128 &0.408628E-05,0.404483E-05,0.442713E-03,0.932117E-06,0.244935E-01,
24129 &0.300029E-02,0.351893E-05,0.480507E-05,0.355692E-05,0.351893E-05,
24130 &0.379744E-03,0.910085E-06,0.214299E-01,0.258845E-02,0.306021E-05/
24131 DATA (DL(K),K= 3316, 3400) /
24132 &0.425313E-05,0.309476E-05,0.306021E-05,0.324785E-03,0.876365E-06,
24133 &0.187200E-01,0.222996E-02,0.265958E-05,0.375823E-05,0.269081E-05,
24134 &0.265958E-05,0.277080E-03,0.833755E-06,0.163273E-01,0.191840E-02,
24135 &0.230942E-05,0.331477E-05,0.233747E-05,0.230942E-05,0.235661E-03,
24136 &0.784780E-06,0.142185E-01,0.164805E-02,0.200337E-05,0.291797E-05,
24137 &0.202844E-05,0.200337E-05,0.199949E-03,0.731774E-06,0.123631E-01,
24138 &0.141382E-02,0.173596E-05,0.256351E-05,0.175824E-05,0.173596E-05,
24139 &0.169376E-03,0.676674E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24140 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24141 &0.794823E-01,0.948208E-02,0.607312E-05,0.607312E-05,0.607312E-05,
24142 &0.607312E-05,0.497062E-03,-.140523E-17,0.699344E-01,0.820355E-02,
24143 &0.500852E-05,0.538347E-05,0.501731E-05,0.500852E-05,0.542262E-03,
24144 &-.714686E-07,0.614560E-01,0.709106E-02,0.415227E-05,0.479898E-05,
24145 &0.416702E-05,0.415227E-05,0.549985E-03,-.960102E-07,0.539240E-01,
24146 &0.612155E-02,0.345977E-05,0.429563E-05,0.347839E-05,0.345977E-05,
24147 &0.531288E-03,-.894946E-07,0.472426E-01,0.527757E-02,0.289508E-05,
24148 &0.385164E-05,0.291595E-05,0.289508E-05,0.495120E-03,-.668594E-07/
24149 DATA (DL(K),K= 3401, 3485) /
24150 &0.413245E-01,0.454380E-02,0.243524E-05,0.345851E-05,0.245713E-05,
24151 &0.243524E-05,0.452156E-03,-.338861E-07,0.360903E-01,0.390658E-02,
24152 &0.205923E-05,0.310726E-05,0.208123E-05,0.205923E-05,0.406686E-03,
24153 &0.329349E-08,0.314681E-01,0.335393E-02,0.174861E-05,0.278918E-05,
24154 &0.177007E-05,0.174861E-05,0.359402E-03,0.387747E-07,0.273932E-01,
24155 &0.287528E-02,0.149082E-05,0.250013E-05,0.151127E-05,0.149082E-05,
24156 &0.313779E-03,0.705560E-07,0.238068E-01,0.246132E-02,0.127582E-05,
24157 &0.223699E-05,0.129498E-05,0.127582E-05,0.272195E-03,0.975744E-07,
24158 &0.206558E-01,0.210383E-02,0.109488E-05,0.199657E-05,0.111257E-05,
24159 &0.109488E-05,0.234227E-03,0.118651E-06,0.178921E-01,0.179558E-02,
24160 &0.941584E-06,0.177694E-05,0.957733E-06,0.941584E-06,0.199907E-03,
24161 &0.133780E-06,0.154726E-01,0.153020E-02,0.811157E-06,0.157680E-05,
24162 &0.825743E-06,0.811157E-06,0.169849E-03,0.143581E-06,0.133582E-01,
24163 &0.130209E-02,0.699567E-06,0.139481E-05,0.712624E-06,0.699567E-06,
24164 &0.143794E-03,0.148591E-06,0.115137E-01,0.110634E-02,0.603631E-06,
24165 &0.122977E-05,0.615228E-06,0.603631E-06,0.121163E-03,0.149477E-06,
24166 &0.990774E-02,0.938615E-03,0.520920E-06,0.108072E-05,0.531148E-06/
24167 DATA (DL(K),K= 3486, 3570) /
24168 &0.520920E-06,0.101725E-03,0.147055E-06,0.851194E-02,0.795146E-03,
24169 &0.449441E-06,0.946634E-06,0.458405E-06,0.449441E-06,0.852238E-04,
24170 &0.142064E-06,0.730103E-02,0.672622E-03,0.387542E-06,0.826497E-06,
24171 &0.395353E-06,0.387542E-06,0.712290E-04,0.135149E-06,0.625244E-02,
24172 &0.568155E-03,0.333888E-06,0.719316E-06,0.340658E-06,0.333888E-06,
24173 &0.593824E-04,0.126902E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24174 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24175 &0.457819E-01,0.409492E-02,0.105702E-05,0.105702E-05,0.105702E-05,
24176 &0.105702E-05,0.115350E-03,0.265810E-18,0.395724E-01,0.347873E-02,
24177 &0.812397E-06,0.103880E-05,0.815187E-06,0.812397E-06,0.160406E-03,
24178 &-.555147E-07,0.341639E-01,0.295295E-02,0.627904E-06,0.987449E-06,
24179 &0.632305E-06,0.627904E-06,0.174490E-03,-.847266E-07,0.294481E-01,
24180 &0.250329E-02,0.490075E-06,0.920197E-06,0.495305E-06,0.490075E-06,
24181 &0.174490E-03,-.944763E-07,0.253423E-01,0.211912E-02,0.387225E-06,
24182 &0.845257E-06,0.392760E-06,0.387225E-06,0.167111E-03,-.916775E-07,
24183 &0.217735E-01,0.179138E-02,0.309989E-06,0.766697E-06,0.315473E-06,
24184 &0.309989E-06,0.152540E-03,-.819158E-07,0.186760E-01,0.151211E-02/
24185 DATA (DL(K),K= 3571, 3655) /
24186 &0.252109E-06,0.688927E-06,0.257316E-06,0.252109E-06,0.135295E-03,
24187 &-.682145E-07,0.159921E-01,0.127447E-02,0.208612E-06,0.614302E-06,
24188 &0.213410E-06,0.208612E-06,0.118648E-03,-.528734E-07,0.136704E-01,
24189 &0.107254E-02,0.175203E-06,0.543807E-06,0.179526E-06,0.175203E-06,
24190 &0.102484E-03,-.379748E-07,0.116656E-01,0.901214E-03,0.149064E-06,
24191 &0.478363E-06,0.152890E-06,0.149064E-06,0.871530E-04,-.245007E-07,
24192 &0.993760E-02,0.756074E-03,0.128274E-06,0.418496E-06,0.131610E-06,
24193 &0.128274E-06,0.735682E-04,-.128491E-07,0.845081E-02,0.633315E-03,
24194 &0.111313E-06,0.364260E-06,0.114187E-06,0.111313E-06,0.617706E-04,
24195 &-.327698E-08,0.717398E-02,0.529654E-03,0.971373E-07,0.315568E-06,
24196 &0.995871E-07,0.971373E-07,0.514764E-04,0.421954E-08,0.607950E-02,
24197 &0.442265E-03,0.850687E-07,0.272228E-06,0.871375E-07,0.850687E-07,
24198 &0.426580E-04,0.982709E-08,0.514311E-02,0.368716E-03,0.746164E-07,
24199 &0.233927E-06,0.763489E-07,0.746164E-07,0.352463E-04,0.137715E-07,
24200 &0.434349E-02,0.306920E-03,0.654439E-07,0.200291E-06,0.668838E-07,
24201 &0.654439E-07,0.290260E-04,0.163078E-07,0.366196E-02,0.255085E-03,
24202 &0.573307E-07,0.170932E-06,0.585192E-07,0.573307E-07,0.238196E-04/
24203 DATA (DL(K),K= 3656, 3740) /
24204 &0.177037E-07,0.308217E-02,0.211681E-03,0.501185E-07,0.145441E-06,
24205 &0.510931E-07,0.501185E-07,0.195033E-04,0.182028E-07,0.258987E-02,
24206 &0.175396E-03,0.436915E-07,0.123415E-06,0.444860E-07,0.436915E-07,
24207 &0.159423E-04,0.180204E-07,0.000000E+00,0.000000E+00,0.000000E+00,
24208 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24209 &0.206951E-01,0.123383E-02,0.903693E-07,0.903693E-07,0.903693E-07,
24210 &0.903693E-07,0.147928E-04,0.131925E-18,0.174566E-01,0.102241E-02,
24211 &0.892028E-07,0.129792E-07,0.885875E-07,0.892028E-07,0.328931E-04,
24212 &0.168541E-07,0.147092E-01,0.846741E-03,0.841992E-07,-.346085E-07,
24213 &0.832249E-07,0.841992E-07,0.410825E-04,0.262547E-07,0.123736E-01,
24214 &0.700287E-03,0.769173E-07,-.620958E-07,0.757563E-07,0.769173E-07,
24215 &0.418512E-04,0.305542E-07,0.103910E-01,0.578275E-03,0.688622E-07,
24216 &-.753692E-07,0.676306E-07,0.688622E-07,0.392599E-04,0.318183E-07,
24217 &0.871109E-02,0.476815E-03,0.611778E-07,-.782788E-07,0.599557E-07,
24218 &0.611778E-07,0.356221E-04,0.316149E-07,0.728984E-02,0.392546E-03,
24219 &0.537256E-07,-.749101E-07,0.525642E-07,0.537256E-07,0.312295E-04,
24220 &0.301630E-07,0.608951E-02,0.322656E-03,0.466227E-07,-.678673E-07/
24221 DATA (DL(K),K= 3741, 3825) /
24222 &0.455521E-07,0.466227E-07,0.265816E-04,0.278681E-07,0.507758E-02,
24223 &0.264779E-03,0.400790E-07,-.588670E-07,0.391148E-07,0.400790E-07,
24224 &0.223044E-04,0.251720E-07,0.422604E-02,0.216927E-03,0.341205E-07,
24225 &-.492124E-07,0.332680E-07,0.341205E-07,0.185283E-04,0.222885E-07,
24226 &0.351082E-02,0.177427E-03,0.287480E-07,-.397442E-07,0.280058E-07,
24227 &0.287480E-07,0.152122E-04,0.193702E-07,0.291126E-02,0.144878E-03,
24228 &0.239699E-07,-.309608E-07,0.233320E-07,0.239699E-07,0.123840E-04,
24229 &0.165481E-07,0.240962E-02,0.118102E-03,0.197695E-07,-.231453E-07,
24230 &0.192276E-07,0.197695E-07,0.100316E-04,0.139043E-07,0.199075E-02,
24231 &0.961132E-04,0.161186E-07,-.164194E-07,0.156628E-07,0.161186E-07,
24232 &0.808648E-05,0.114903E-07,0.164168E-02,0.780880E-04,0.129826E-07,
24233 &-.107955E-07,0.126029E-07,0.129826E-07,0.648861E-05,0.933575E-08,
24234 &0.135135E-02,0.633381E-04,0.103192E-07,-.622051E-08,0.100055E-07,
24235 &0.103192E-07,0.519042E-05,0.744979E-08,0.111036E-02,0.512898E-04,
24236 &0.808255E-08,-.260101E-08,0.782557E-08,0.808255E-08,0.414192E-05,
24237 &0.582811E-08,0.910718E-03,0.414657E-04,0.622640E-08,0.177583E-09,
24238 &0.601750E-08,0.622640E-08,0.329729E-05,0.445766E-08,0.745657E-03/
24239 DATA (DL(K),K= 3826, 3910) /
24240 &0.334694E-04,0.470431E-08,0.223586E-08,0.453577E-08,0.470431E-08,
24241 &0.261981E-05,0.331859E-08,0.000000E+00,0.000000E+00,0.000000E+00,
24242 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24243 &0.519165E-02,0.154752E-03,0.135983E-08,0.135983E-08,0.135983E-08,
24244 &0.135983E-08,0.445189E-06,0.165858E-19,0.420352E-02,0.123002E-03,
24245 &-.202651E-07,0.730203E-07,-.200511E-07,-.202651E-07,0.358557E-05,
24246 &-.213089E-07,0.340143E-02,0.977718E-04,-.356451E-07,0.114908E-06,
24247 &-.353066E-07,-.356451E-07,0.384652E-05,-.364475E-07,0.274771E-02,
24248 &0.776124E-04,-.435588E-07,0.139200E-06,-.431556E-07,-.435588E-07,
24249 &0.404834E-05,-.441752E-07,0.221524E-02,0.614950E-04,-.471629E-07,
24250 &0.150069E-06,-.467352E-07,-.471629E-07,0.391615E-05,-.476355E-07,
24251 &0.178268E-02,0.486476E-04,-.477545E-07,0.151420E-06,-.473296E-07,
24252 &-.477545E-07,0.334100E-05,-.481163E-07,0.143185E-02,0.384202E-04,
24253 &-.462359E-07,0.146515E-06,-.458316E-07,-.462359E-07,0.275426E-05,
24254 &-.465126E-07,0.114781E-02,0.302894E-04,-.434031E-07,0.137587E-06,
24255 &-.430295E-07,-.434031E-07,0.226010E-05,-.436143E-07,0.918288E-03,
24256 &0.238367E-04,-.398089E-07,0.126321E-06,-.394715E-07,-.398089E-07/
24257 DATA (DL(K),K= 3911, 3995) /
24258 &0.180947E-05,-.399700E-07,0.733193E-03,0.187249E-04,-.358525E-07,
24259 &0.113940E-06,-.355529E-07,-.358525E-07,0.142045E-05,-.359751E-07,
24260 &0.584227E-03,0.146823E-04,-.318183E-07,0.101291E-06,-.315563E-07,
24261 &-.318183E-07,0.110919E-05,-.319115E-07,0.464586E-03,0.114914E-04,
24262 &-.278936E-07,0.889550E-07,-.276671E-07,-.278936E-07,0.860964E-06,
24263 &-.279643E-07,0.368700E-03,0.897731E-05,-.241972E-07,0.773096E-07,
24264 &-.240033E-07,-.241972E-07,0.662825E-06,-.242508E-07,0.292013E-03,
24265 &0.700034E-05,-.208001E-07,0.665779E-07,-.206356E-07,-.208001E-07,
24266 &0.508061E-06,-.208406E-07,0.230814E-03,0.544870E-05,-.177366E-07,
24267 &0.568734E-07,-.175982E-07,-.177366E-07,0.388493E-06,-.177672E-07,
24268 &0.182078E-03,0.423324E-05,-.150157E-07,0.482316E-07,-.149000E-07,
24269 &-.150157E-07,0.296111E-06,-.150387E-07,0.143349E-03,0.328297E-05,
24270 &-.126295E-07,0.406343E-07,-.125335E-07,-.126295E-07,0.225104E-06,
24271 &-.126468E-07,0.112639E-03,0.254145E-05,-.105595E-07,0.340280E-07,
24272 &-.104803E-07,-.105595E-07,0.170871E-06,-.105726E-07,0.883377E-04,
24273 &0.196395E-05,-.878062E-08,0.283380E-07,-.871555E-08,-.878062E-08,
24274 &0.129517E-06,-.879039E-08,0.000000E+00,0.000000E+00,0.000000E+00/
24275 DATA (DL(K),K= 3996, 4000) /
24276 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24279 IF (X.GT.0.9985) RETURN
24280 IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
24286 F1(L) = GF(I,IS,KL)
24287 F2(L) = GF(I,IS1,KL)
24289 A1 = DT_CKMTFF(X,F1)
24290 A2 = DT_CKMTFF(X,F2)
24295 ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
24301 *$ CREATE DT_CKMTFF.FOR
24303 FUNCTION DT_CKMTFF(X,FVL)
24304 C**********************************************************************
24306 C LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
24307 C FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
24308 C NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
24311 C**********************************************************************
24314 DIMENSION FVL(25),XGRID(25)
24315 DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
24316 *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
24320 IF(X.LT.XGRID(I)) GO TO 2
24325 ELSE IF(I.GT.23) THEN
24331 BXI=LOG(1.-XGRID(I))
24333 BXJ=LOG(1.-XGRID(J))
24335 BXK=LOG(1.-XGRID(K))
24336 FI=LOG(ABS(FVL(I)) +1.E-15)
24337 FJ=LOG(ABS(FVL(J)) +1.E-16)
24338 FK=LOG(ABS(FVL(K)) +1.E-17)
24339 DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
24340 ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
24342 ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
24343 BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
24344 IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
24346 C IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
24347 C WRITE(6,2001) X,FVL
24348 C 2001 FORMAT(8E12.4)
24349 C WRITE(6,2001) ALPHA,BETA,ALOGA,DET
24351 DT_CKMTFF=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
24355 *$ CREATE DT_FLUINI.FOR
24358 *===fluini=============================================================*
24360 SUBROUTINE DT_FLUINI
24362 ************************************************************************
24363 * Initialisation of the nucleon-nucleon cross section fluctuation *
24364 * treatment. The original version by J. Ranft. *
24365 * This version dated 21.04.95 is revised by S. Roesler. *
24366 ************************************************************************
24368 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24371 PARAMETER ( LINP = 10 ,
24375 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
24377 PARAMETER ( A = 0.1D0,
24383 * n-n cross section fluctuations
24384 PARAMETER (NBINS = 1000)
24385 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
24386 DIMENSION FLUSI(NBINS),FLUIX(NBINS)
24389 1000 FORMAT(/,1X,'FLUINI: hadronic cross section fluctuations ',
24398 FLUS = ((X-B)/(OM*B))**N
24399 IF (FLUS.LE.20.0D0) THEN
24400 FLUSI(I) = (X/B)*EXP(-FLUS)/(X/B+A)
24404 FLUSU = FLUSU+FLUSI(I)
24407 FLUSUU = FLUSUU+FLUSI(I)/FLUSU
24412 C1001 FORMAT(1X,'FLUCTUATIONS')
24413 C CALL PLOT(FLUIX,FLUSI,1000,1,1000,0.0D0,0.06D0,0.0D0,0.01D0)
24416 AF = DBLE(I)*0.001D0
24418 IF (AF.LE.FLUSI(J)) THEN
24419 FLUIXX(I) = FLUIX(J)
24425 FLUIXX(1) = FLUIX(1)
24426 FLUIXX(NBINS) = FLUIX(NBINS)
24431 *$ CREATE DT_SIGTBL.FOR
24434 *===sigtab=============================================================*
24436 SUBROUTINE DT_SIGTBL(JP,JT,PTOT,SIGE,MODE)
24438 ************************************************************************
24439 * This version dated 18.11.95 is written by S. Roesler *
24440 ************************************************************************
24442 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24445 PARAMETER ( LINP = 10 ,
24449 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24450 & OHALF=0.5D0,ONE=1.0D0)
24451 PARAMETER (PLO=0.01D0,PHI=20.0D0,NBINS=150)
24455 * particle properties (BAMJET index convention)
24457 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24458 & IICH(210),IIBAR(210),K1(210),K2(210)
24460 DIMENSION SIGEP(5,NBINS+1),SIGEN(5,NBINS+1),IDSIG(23)
24461 DATA IDSIG / 1, 0, 0, 0, 0, 0, 0, 2, 0, 0,
24462 & 0, 0, 3, 4, 0, 0, 0, 0, 0, 0,
24464 DATA LINIT /.FALSE./
24466 * precalculation and tabulation of elastic cross sections
24467 IF (ABS(MODE).EQ.1) THEN
24469 & OPEN(LDAT,FILE='outdata0/sigtab.out',STATUS='UNKNOWN')
24470 PLABLX = LOG10(PLO)
24471 PLABHX = LOG10(PHI)
24472 DPLAB = (PLABHX-PLABLX)/DBLE(NBINS)
24474 PLAB = PLABLX+DBLE(I-1)*DPLAB
24479 C CALL DT_SIHNEL(IPROJ,1,PLAB,SIGEP(IDX,I))
24480 C CALL DT_SIHNEL(IPROJ,8,PLAB,SIGEN(IDX,I))
24482 CALL DT_XSHN(IPROJ,1,PLAB,DUMZER,SIGTOT,SIGEP(IDX,I))
24483 CALL DT_XSHN(IPROJ,8,PLAB,DUMZER,SIGTOT,SIGEN(IDX,I))
24486 IF (MODE.EQ.1) THEN
24487 WRITE(LDAT,1000) PLAB,(SIGEP(IDX,I),IDX=1,5),
24488 & (SIGEN(IDX,I),IDX=1,5)
24489 1000 FORMAT(F5.1,10F7.2)
24492 IF (MODE.EQ.1) CLOSE(LDAT)
24496 IF (LINIT.AND.(JP.LE.23).AND.(PTOT.GE.PLO)
24497 & .AND.(PTOT.LE.PHI) ) THEN
24499 IF ( (IDX.GT.0).AND.((JT.EQ.1).OR.(JT.EQ.8)) ) THEN
24500 PLABX = LOG10(PTOT)
24501 IF (PLABX.LE.PLABLX) THEN
24504 ELSEIF (PLABX.GE.PLABHX) THEN
24508 I1 = INT((PLABX-PLABLX)/DPLAB)+1
24511 PLAB1X = PLABLX+DBLE(I1-1)*DPLAB
24512 PLAB2X = PLABLX+DBLE(I2-1)*DPLAB
24513 PBIN = PLAB2X-PLAB1X
24514 IF (PBIN.GT.TINY10) THEN
24515 RATX = (PLABX-PLAB1X)/(PLAB2X-PLAB1X)
24520 SIG1 = SIGEP(IDX,I1)
24521 SIG2 = SIGEP(IDX,I2)
24523 SIG1 = SIGEN(IDX,I1)
24524 SIG2 = SIGEN(IDX,I2)
24526 SIGE = SIG1+RATX*(SIG2-SIG1)
24534 *$ CREATE DT_XSTABL.FOR
24537 *===xstabl=============================================================*
24539 SUBROUTINE DT_XSTABL(WHAT,IXSQEL,IRATIO)
24541 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24544 PARAMETER ( LINP = 10 ,
24548 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24549 & OHALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
24550 LOGICAL LLAB,LELOG,LQLOG
24552 * particle properties (BAMJET index convention)
24554 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24555 & IICH(210),IIBAR(210),K1(210),K2(210)
24557 * properties of interacting particles
24558 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
24560 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
24562 * Glauber formalism: cross sections
24563 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
24564 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
24565 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
24566 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
24567 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
24568 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
24569 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
24570 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
24571 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
24572 & BSLOPE,NEBINI,NQBINI
24574 * emulsion treatment
24575 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
24580 LLAB = (WHAT(1).GT.ZERO).OR.(WHAT(2).GT.ZERO)
24583 IF (ELO.GT.EHI) ELO = EHI
24584 LELOG = WHAT(3).LT.ZERO
24585 NEBINS = MAX(INT(ABS(WHAT(3))),1)
24586 DEBINS = (EHI-ELO)/DBLE(NEBINS)
24590 ADEBIN = (AEHI-AELO)/DBLE(NEBINS)
24594 IF (Q2LO.GT.Q2HI) Q2LO = Q2HI
24595 LQLOG = WHAT(6).LT.ZERO
24596 NQBINS = MAX(INT(ABS(WHAT(6))),1)
24597 DQBINS = (Q2HI-Q2LO)/DBLE(NQBINS)
24599 AQ2LO = LOG10(Q2LO)
24600 AQ2HI = LOG10(Q2HI)
24601 ADQBIN = (AQ2HI-AQ2LO)/DBLE(NQBINS)
24604 IF ( ELO.EQ. EHI) NEBINS = 0
24605 IF (Q2LO.EQ.Q2HI) NQBINS = 0
24607 WRITE(LOUT,1000) ELO,EHI,LLAB,IXSQEL,Q2LO,Q2HI,IJPROJ,IP,IT
24608 1000 FORMAT(/,1X,'XSTABL: E_lo =',E10.3,' GeV E_hi =',E10.3,
24609 & ' GeV Lab = ',L1,' qel: ',I2,/,10X,'Q2_lo =',F10.5,
24610 & ' GeV^2 Q2_hi =',F10.5,' GeV^2',/,10X,'id_p = ',I2,
24611 & ' A_p = ',I3,' A_t = ',I3,/)
24613 C IF (IJPROJ.NE.7) THEN
24614 WRITE(LOUT,'(1X,A,/)')'(E,STOT,SELA,SQEP,SQET,SQE2,SINE,SPROD)'
24615 * normalize fractions of emulsion components
24616 IF (NCOMPO.GT.0) THEN
24619 SUMFRA = SUMFRA+EMUFRA(I)
24621 IF (SUMFRA.GT.ZERO) THEN
24623 EMUFRA(I) = EMUFRA(I)/SUMFRA
24628 C WRITE(LOUT,'(1X,A,/)') '(Q2,E,STOT,ETOT,SIN,EIN,STOT0)'
24632 E = 10**(AELO+DBLE(I-1)*ADEBIN)
24634 E = ELO+DBLE(I-1)*DEBINS
24638 Q2 = 10**(AQ2LO+DBLE(J-1)*ADQBIN)
24640 Q2 = Q2LO+DBLE(J-1)*DQBINS
24642 c IF (IJPROJ.NE.7) THEN
24646 CALL DT_LTINI(IJPROJ,1,E,PPN0,ECM,0)
24652 IF (IJPROJ.EQ.7) Q2I = Q2
24653 IF (NCOMPO.GT.0) THEN
24656 CALL DT_XSGLAU(IP,IIT,IJPROJ,XI,Q2I,ECM,1,1,-IC)
24659 CALL DT_XSGLAU(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,-1)
24660 C CALL AMPLIT(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,1)
24662 IF (NCOMPO.GT.0) THEN
24681 XTOT = XTOT+EMUFRA(IC)*XSTOT(1,1,IC)
24682 ETOT = ETOT+EMUFRA(IC)*XETOT(1,1,IC)**2
24683 XELA = XELA+EMUFRA(IC)*XSELA(1,1,IC)
24684 EELA = EELA+EMUFRA(IC)*XEELA(1,1,IC)**2
24685 XQEP = XQEP+EMUFRA(IC)*XSQEP(1,1,IC)
24686 EQEP = EQEP+EMUFRA(IC)*XEQEP(1,1,IC)**2
24687 XQET = XQET+EMUFRA(IC)*XSQET(1,1,IC)
24688 EQET = EQET+EMUFRA(IC)*XEQET(1,1,IC)**2
24689 XQE2 = XQE2+EMUFRA(IC)*XSQE2(1,1,IC)
24690 EQE2 = EQE2+EMUFRA(IC)*XEQE2(1,1,IC)**2
24691 XPRO = XPRO+EMUFRA(IC)*XSPRO(1,1,IC)
24692 EPRO = EPRO+EMUFRA(IC)*XEPRO(1,1,IC)**2
24693 XDEL = XDEL+EMUFRA(IC)*XSDEL(1,1,IC)
24694 EDEL = EDEL+EMUFRA(IC)*XEDEL(1,1,IC)**2
24695 XDQE = XDQE+EMUFRA(IC)*XSDQE(1,1,IC)
24696 EDQE = EDQE+EMUFRA(IC)*XEDQE(1,1,IC)**2
24697 YPRO = XSTOT(1,1,IC)-XSELA(1,1,IC)
24698 & -XSQEP(1,1,IC)-XSQET(1,1,IC)
24700 XPRO1= XPRO1+EMUFRA(IC)*YPRO
24710 WRITE(LOUT,'(8E9.3)')
24711 & E,XTOT,XELA,XQEP,XQET,XQE2,XPRO,XPRO1
24712 C WRITE(LOUT,'(4E9.3)')
24713 C & E,XDEL,XDQE,XDEL+XDQE
24715 WRITE(LOUT,'(11E10.3)')
24717 & XSTOT(1,1,1),XSELA(1,1,1),XSQEP(1,1,1),XSQET(1,1,1),
24718 & XSQE2(1,1,1),XSPRO(1,1,1),
24719 & XSTOT(1,1,1)-XSELA(1,1,1)-XSQEP(1,1,1)-XSQET(1,1,1)
24720 & -XSQE2(1,1,1),XSDEL(1,1,1),XSDQE(1,1,1),
24721 & XSDEL(1,1,1)+XSDQE(1,1,1)
24722 C WRITE(LOUT,'(4E9.3)') E,XSDEL(1,1,1),XSDQE(1,1,1),
24723 C & XSDEL(1,1,1)+XSDQE(1,1,1)
24727 c IF (IT.GT.1) THEN
24728 c IF (IXSQEL.EQ.0) THEN
24729 cC CALL DT_SIGGA(IT, Q2, E,ZERO,ZERO,
24730 cC CALL DT_SIGGA(IT, E,Q2,ZERO,ZERO,
24731 c CALL DT_SIGGA(IT,ZERO,Q2,ZERO,E,
24732 c & STOT,ETOT,SIN,EIN,STOT0)
24733 c IF (IRATIO.EQ.1) THEN
24734 c CALL DT_SIGGP( Q2, E,ZERO,ZERO,STGP,SIGP,SDGP)
24735 cC CALL DT_SIGGP( E,Q2,ZERO,ZERO,STGP,SIGP,SDGP)
24736 cC CALL DT_SIGGP(ZERO,Q2,ZERO,E,STGP,SIGP,SDGP)
24737 c*!! save cross sections
24742 c STOT = STOT/(DBLE(IT)*STGP)
24743 c SIN = SIN/(DBLE(IT)*SIGP)
24750 c & ' XSTABL: qel. xs. not implemented for nuclei'
24757 c IF (IXSQEL.EQ.0) THEN
24758 c CALL DT_SIGGP(ZERO,Q2,ZERO,E,STOT,SIN,SDIR)
24761 c CALL DT_SIGVEL(ZERO,Q2,ZERO,E,IXSQEL,STOT,SIN,STOT0)
24765 c IF (IT.GT.1) THEN
24766 c IF (IXSQEL.EQ.0) THEN
24767 c CALL DT_SIGGA(IT,ZERO,Q2,E,ZERO,
24768 c & STOT,ETOT,SIN,EIN,STOT0)
24769 c IF (IRATIO.EQ.1) THEN
24770 c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STGP,SIGP,SDGP)
24771 c*!! save cross sections
24776 c STOT = STOT/(DBLE(IT)*STGP)
24777 c SIN = SIN/(DBLE(IT)*SIGP)
24784 c & ' XSTABL: qel. xs. not implemented for nuclei'
24791 c IF (IXSQEL.EQ.0) THEN
24792 c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STOT,SIN,SDIR)
24795 c CALL DT_SIGVEL(ZERO,Q2,E,ZERO,IXSQEL,STOT,SIN,STOT0)
24799 cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,STOTA,ETOTA,STOTP,ZERO
24800 cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,SDIR
24801 cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,STOT0
24802 c WRITE(LOUT,'(1X,6E10.3)')Q2,E,STOT,ETOT,SIN,EIN
24810 *$ CREATE DT_TESTXS.FOR
24813 *===testxs=============================================================*
24815 SUBROUTINE DT_TESTXS
24817 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24820 DIMENSION XSTOT(26,2),XSELA(26,2)
24822 OPEN(10,FILE='testxs_ptot.out',STATUS='UNKNOWN')
24823 OPEN(11,FILE='testxs_pela.out',STATUS='UNKNOWN')
24824 OPEN(12,FILE='testxs_ntot.out',STATUS='UNKNOWN')
24825 OPEN(13,FILE='testxs_nela.out',STATUS='UNKNOWN')
24830 APLABL = LOG10(PLABL)
24831 APLABH = LOG10(PLABH)
24832 ADPLAB = (APLABH-APLABL)/DBLE(NBINS)
24834 ADP = APLABL+DBLE(I-1)*ADPLAB
24837 CALL DT_XSHN(J,1,P,DUMECM,XSTOT(J,1),XSELA(J,1))
24838 CALL DT_XSHN(J,8,P,DUMECM,XSTOT(J,2),XSELA(J,2))
24840 WRITE(10,1000) P,(XSTOT(K,1),K=1,26)
24841 WRITE(11,1000) P,(XSELA(K,1),K=1,26)
24842 WRITE(12,1000) P,(XSTOT(K,2),K=1,26)
24843 WRITE(13,1000) P,(XSELA(K,2),K=1,26)
24845 1000 FORMAT(F8.3,26F9.3)
24849 ************************************************************************
24851 * DTUNUC 2.0: library routines *
24852 * processed by S. Roesler, 6.5.95 *
24854 ************************************************************************
24856 * 1) Handling of parton momenta
24857 * SUBROUTINE MASHEL
24858 * SUBROUTINE DFERMI
24860 * 2) Handling of parton flavors and particle indices
24861 * INTEGER FUNCTION IPDG2B
24862 * INTEGER FUNCTION IB2PDG
24863 * INTEGER FUNCTION IQUARK
24864 * INTEGER FUNCTION IBJQUA
24865 * INTEGER FUNCTION ICIHAD
24866 * INTEGER FUNCTION IPDGHA
24867 * INTEGER FUNCTION MCHAD
24868 * SUBROUTINE FLAHAD
24870 * 3) Energy-momentum and quantum number conservation check routines
24873 * SUBROUTINE EVTEMC
24874 * SUBROUTINE EVTFLC
24875 * SUBROUTINE EVTCHG
24877 * 4) Transformations
24879 * SUBROUTINE LTRANS
24881 * SUBROUTINE DALTRA
24882 * SUBROUTINE DTRAFO
24883 * SUBROUTINE STTRAN
24884 * SUBROUTINE MYTRAN
24885 * SUBROUTINE LT2LAO
24886 * SUBROUTINE LT2LAB
24888 * 5) Sampling from distributions
24889 * INTEGER FUNCTION NPOISS
24890 * DOUBLE PRECISION FUNCTION SAMPXB
24891 * DOUBLE PRECISION FUNCTION SAMPEX
24892 * DOUBLE PRECISION FUNCTION SAMSQX
24893 * DOUBLE PRECISION FUNCTION BETREJ
24894 * DOUBLE PRECISION FUNCTION DGAMRN
24895 * DOUBLE PRECISION FUNCTION DBETAR
24896 * SUBROUTINE RANNOR
24898 * SUBROUTINE DSFECF
24901 * 6) Special functions, algorithms and service routines
24902 * DOUBLE PRECISION FUNCTION YLAMB
24905 * SUBROUTINE DT_XTIME
24907 * 7) Random number generator package
24908 * DOUBLE PRECISION FUNCTION DT_RNDM
24909 * SUBROUTINE DT_RNDMST
24910 * SUBROUTINE DT_RNDMIN
24911 * SUBROUTINE DT_RNDMOU
24912 * SUBROUTINE DT_RNDMTE
24914 ************************************************************************
24916 * 1) Handling of parton momenta *
24918 ************************************************************************
24919 *$ CREATE DT_MASHEL.FOR
24922 *===mashel=============================================================*
24924 SUBROUTINE DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
24926 ************************************************************************
24928 * rescaling of momenta of two partons to put both *
24931 * input: PA1,PA2 input momentum vectors *
24932 * XM1,2 desired masses of particles afterwards *
24933 * P1,P2 changed momentum vectors *
24935 * The original version is written by R. Engel. *
24936 * This version dated 12.12.94 is modified by S. Roesler. *
24937 ************************************************************************
24939 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24942 PARAMETER ( LINP = 10 ,
24946 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
24948 DIMENSION PA1(4),PA2(4),P1(4),P2(4)
24952 * Lorentz transformation into system CMS
24957 XPTOT = SQRT(PX**2+PY**2+PZ**2)
24958 XMS = (EE-XPTOT)*(EE+XPTOT)
24959 IF(XMS.LT.(XM1+XM2)**2) THEN
24960 C WRITE(LOUT,'(3E12.4)')XMS,XM1,XM2
24968 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
24969 & PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
24972 C SID = SQRT((ONE-COD)*(ONE+COD))
24973 PPT = SQRT(P1(1)**2+P1(2)**2)
24977 IF(PTOT1*SID.GT.TINY10) THEN
24978 COF = P1(1)/(SID*PTOT1)
24979 SIF = P1(2)/(SID*PTOT1)
24980 ANORF = SQRT(COF*COF+SIF*SIF)
24984 * new CM momentum and energies (for masses XM1,XM2)
24985 XM12 = SIGN(XM1**2,XM1)
24986 XM22 = SIGN(XM2**2,XM2)
24988 PCMP = DT_YLAMB(SS,XM12,XM22)/(2.D0*XMS)
24989 EE1 = SQRT(XM12+PCMP**2)
24993 CALL DT_MYTRAN(MODE,ZERO,ZERO,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
24994 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
24995 & PTOT1,P1(1),P1(2),P1(3),P1(4))
24996 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
24997 & PTOT2,P2(1),P2(2),P2(3),P2(4))
24998 * check consistency
25000 IF (ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
25002 ELSEIF (ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
25004 ELSEIF (ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
25006 ELSEIF (ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
25011 IF (IDEV.NE.0) THEN
25012 WRITE(LOUT,'(/1X,A,I3)')
25013 & 'MASHEL: inconsistent transformation',IDEV
25014 WRITE(LOUT,'(1X,A)') 'MASHEL: input momenta/masses:'
25015 WRITE(LOUT,'(1X,5E12.5)') (PA1(K),K=1,4),XM1
25016 WRITE(LOUT,'(1X,5E12.5)') (PA2(K),K=1,4),XM2
25017 WRITE(LOUT,'(1X,A)') 'MASHEL: output momenta:'
25018 WRITE(LOUT,'(5X,4E12.5)') (P1(K),K=1,4)
25019 WRITE(LOUT,'(5X,4E12.5)') (P2(K),K=1,4)
25028 *$ CREATE DT_DFERMI.FOR
25031 *===dfermi=============================================================*
25033 SUBROUTINE DT_DFERMI(GPART)
25035 ************************************************************************
25036 * Find largest of three random numbers. *
25037 ************************************************************************
25039 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25045 G(I)=DT_RNDM(GPART)
25047 IF (G(3).LT.G(2)) GOTO 40
25048 IF (G(3).LT.G(1)) GOTO 30
25053 40 IF (G(2).LT.G(1)) GOTO 30
25059 ************************************************************************
25061 * 2) Handling of parton flavors and particle indices *
25063 ************************************************************************
25064 *$ CREATE IDT_IPDG2B.FOR
25067 *===ipdg2b=============================================================*
25069 INTEGER FUNCTION IDT_IPDG2B(ID,NN,MODE)
25071 ************************************************************************
25073 * conversion of quark numbering scheme *
25075 * input: PDG parton numbering *
25076 * for diquarks: NN number of the constituent quark *
25077 * (e.g. ID=2301,NN=1 -> ICONV2=1) *
25079 * output: BAMJET particle codes *
25080 * 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) *
25081 * 2 d 8 a-d -2 a-d *
25082 * 3 s 9 a-s -3 a-s *
25083 * 4 c 10 a-c -4 a-c *
25085 * This is a modified version of ICONV2 written by R. Engel. *
25086 * This version dated 13.12.94 is written by S. Roesler. *
25087 ************************************************************************
25089 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25092 PARAMETER ( LINP = 10 ,
25100 IF (IDA.GE.1000) KF = 4
25101 IDA = IDA/(10**(KF-NN))
25104 * exchange up and dn quarks
25107 ELSEIF (IDA.EQ.2) THEN
25112 IF (MODE.EQ.1) THEN
25123 *$ CREATE IDT_IB2PDG.FOR
25126 *===ib2pdg=============================================================*
25128 INTEGER FUNCTION IDT_IB2PDG(ID1,ID2,MODE)
25130 ************************************************************************
25132 * conversion of quark numbering scheme *
25134 * input: BAMJET particle codes *
25135 * 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) *
25136 * 2 d 8 a-d -2 a-d *
25137 * 3 s 9 a-s -3 a-s *
25138 * 4 c 10 a-c -4 a-c *
25140 * output: PDG parton numbering *
25142 * This version dated 13.12.94 is written by S. Roesler. *
25143 ************************************************************************
25145 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25148 PARAMETER ( LINP = 10 ,
25152 DIMENSION IHKKQ(-6:6),IHKKQQ(-3:3,-3:3)
25153 DATA IHKKQ/-6,-5,-4,-3,-1,-2,0,2,1,3,4,5,6/
25154 DATA IHKKQQ/-3303,-3103,-3203,0,0,0,0, -3103,-1103,-2103,0,0,0,0,
25155 &-3203,-2103,-2203,0,0,0,0, 0,0,0,0,0,0,0, 0,0,0,0,2203,2103,3203,
25156 &0,0,0,0,2103,1103,3103, 0,0,0,0,3203,3103,3303/
25160 IF (MODE.EQ.1) THEN
25161 IF (ID1.GT.6) IDA = -(ID1-6)
25162 IF (ID2.GT.6) IDB = -(ID2-6)
25165 IDT_IB2PDG = IHKKQ(IDA)
25167 IDT_IB2PDG = IHKKQQ(IDA,IDB)
25173 *$ CREATE IDT_IQUARK.FOR
25176 *===ipdgqu=============================================================*
25178 INTEGER FUNCTION IDT_IQUARK(K,IDBAMJ)
25180 ************************************************************************
25182 * quark contents according to PDG conventions *
25183 * (random selection in case of quark mixing) *
25185 * input: IDBAMJ BAMJET particle code *
25186 * K 1..3 quark number *
25188 * output: 1 d (anti --> neg.) *
25193 * This version written by R. Engel. *
25194 ************************************************************************
25196 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25199 IQ = IDT_IBJQUA(K,IDBAMJ)
25204 * exchange of up and down
25205 IF (ABS(IQ).EQ.1) THEN
25207 ELSEIF (ABS(IQ).EQ.2) THEN
25215 *$ CREATE IDT_IBJQUA.FOR
25218 *===ibamq==============================================================*
25220 INTEGER FUNCTION IDT_IBJQUA(K,IDBAMJ)
25222 ************************************************************************
25224 * quark contents according to BAMJET conventions *
25225 * (random selection in case of quark mixing) *
25227 * input: IDBAMJ BAMJET particle code *
25228 * K 1..3 quark number *
25230 * output: 1 u 7 u bar *
25235 * This version written by R. Engel. *
25236 ************************************************************************
25238 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25241 DIMENSION ITAB(3,210)
25242 DATA ((ITAB(I,K),I=1,3),K=1,30) /
25243 & 1, 1, 2, 7, 7, 8, 0, 0, 0,
25244 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25245 & 0, 0, 0, 1, 2, 2, 7, 8, 8,
25247 C & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25248 & 0, 0, 0, 0, 0, 0, 3, 8, 0,
25250 & 1, 8, 0, 2, 7, 0, 1, 9, 0,
25252 C & 3, 7, 0, 0, 0, 0, 0, 0, 0,
25253 & 3, 7, 0, 3, 1, 2, 9, 7, 8,
25255 C & 0, 0, 0, 2, 2, 3, 1, 1, 3,
25256 & 2, 9, 0, 2, 2, 3, 1, 1, 3,
25258 & 1, 2, 3, 201,202, 0, 2, 9, 0,
25259 & 3, 8, 0, 0, 0, 0, 0, 0, 0,
25260 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25261 DATA ((ITAB(I,K),I=1,3),K=31,60) /
25262 & 3, 9, 0, 1, 8, 0, 203,204, 0,
25263 & 2, 7, 0, 0, 0, 0, 1, 9, 0,
25264 & 2, 9, 0, 3, 7, 0, 3, 8, 0,
25265 & 0, 0, 0, 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, 1, 1, 1, 1, 1, 2,
25270 & 1, 2, 2, 2, 2, 2, 0, 0, 0,
25271 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25272 DATA ((ITAB(I,K),I=1,3),K=61,90) /
25273 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25274 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25275 & 7, 7, 7, 7, 7, 8, 7, 8, 8,
25276 & 8, 8, 8, 0, 0, 0, 0, 0, 0,
25277 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25278 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25279 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25280 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25281 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25282 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25283 DATA ((ITAB(I,K),I=1,3),K=91,120) /
25284 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25285 & 0, 0, 0, 0, 0, 0, 3, 9, 0,
25286 & 1, 3, 3, 2, 3, 3, 7, 7, 9,
25287 & 7, 8, 9, 8, 8, 9, 7, 9, 9,
25288 & 8, 9, 9, 1, 1, 3, 1, 2, 3,
25289 & 2, 2, 3, 1, 3, 3, 2, 3, 3,
25290 & 3, 3, 3, 7, 7, 9, 7, 8, 9,
25291 & 8, 8, 9, 7, 9, 9, 8, 9, 9,
25292 & 9, 9, 9, 4, 7, 0, 4, 8, 0,
25293 & 2, 10, 0, 1, 10, 0, 4, 9, 0 /
25294 DATA ((ITAB(I,K),I=1,3),K=121,150) /
25295 & 3, 10, 0, 4, 10, 0, 4, 7, 0,
25296 & 4, 8, 0, 2, 10, 0, 1, 10, 0,
25297 & 4, 9, 0, 3, 10, 0, 4, 10, 0,
25298 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25299 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25300 & 0, 0, 0, 1, 2, 4, 1, 3, 4,
25301 & 2, 3, 4, 1, 1, 4, 0, 0, 0,
25302 & 2, 2, 4, 0, 0, 0, 0, 0, 0,
25303 & 3, 3, 4, 1, 4, 4, 2, 4, 4,
25304 & 3, 4, 4, 7, 8, 10, 7, 9, 10 /
25305 DATA ((ITAB(I,K),I=1,3),K=151,180) /
25306 & 8, 9, 10, 7, 7, 10, 0, 0, 0,
25307 & 8, 8, 10, 0, 0, 0, 0, 0, 0,
25308 & 9, 9, 10, 7, 10, 10, 8, 10, 10,
25309 & 9, 10, 10, 1, 1, 4, 1, 2, 4,
25310 & 2, 2, 4, 1, 3, 4, 2, 3, 4,
25311 & 3, 3, 4, 1, 4, 4, 2, 4, 4,
25312 & 3, 4, 4, 4, 4, 4, 7, 7, 10,
25313 & 7, 8, 10, 8, 8, 10, 7, 9, 10,
25314 & 8, 9, 10, 9, 9, 10, 7, 10, 10,
25315 & 8, 10, 10, 9, 10, 10, 10, 10, 10 /
25316 DATA ((ITAB(I,K),I=1,3),K=181,210) /
25317 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25318 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25319 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25320 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25321 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25322 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25323 & 0, 0, 0, 0, 0, 0, 1, 7, 0,
25324 & 2, 8, 0, 1, 7, 0, 2, 8, 0,
25325 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25326 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25330 IF (ITAB(1,IDBAMJ).LE.200) THEN
25331 ID = ITAB(K,IDBAMJ)
25333 IF(IDOLD.NE.IDBAMJ) THEN
25334 IT = AINT((ITAB(2,IDBAMJ)-ITAB(1,IDBAMJ)+0.999999D0)*
25335 & DT_RNDM(ONE)+ITAB(1,IDBAMJ))
25347 *$ CREATE IDT_ICIHAD.FOR
25350 *===icihad=============================================================*
25352 INTEGER FUNCTION IDT_ICIHAD(MCIND)
25354 ************************************************************************
25355 * Conversion of particle index PDG proposal --> BAMJET-index scheme *
25356 * This is a completely new version dated 25.10.95. *
25357 * Renamed to be not in conflict with the modified PHOJET-version *
25358 ************************************************************************
25360 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25363 * hadron index conversion (BAMJET <--> PDG)
25364 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25365 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25370 IF ((KPDG.EQ.0).OR.(KPDG.GT.70000)) RETURN
25371 IF (MCIND.LT.0) THEN
25376 IF (KPDG.GE.10000) THEN
25378 IDT_ICIHAD = IBAM5(JSIGN,I)
25379 IF (IPDG5(JSIGN,I).EQ.MCIND) GOTO 5
25382 ELSEIF (KPDG.GE.1000) THEN
25384 IDT_ICIHAD = IBAM4(JSIGN,I)
25385 IF (IPDG4(JSIGN,I).EQ.MCIND) GOTO 5
25388 ELSEIF (KPDG.GE.100) THEN
25390 IDT_ICIHAD = IBAM3(JSIGN,I)
25391 IF (IPDG3(JSIGN,I).EQ.MCIND) GOTO 5
25394 ELSEIF (KPDG.GE.10) THEN
25396 IDT_ICIHAD = IBAM2(JSIGN,I)
25397 IF (IPDG2(JSIGN,I).EQ.MCIND) GOTO 5
25406 *$ CREATE IDT_IPDGHA.FOR
25409 *===ipdgha=============================================================*
25411 INTEGER FUNCTION IDT_IPDGHA(MCIND)
25413 ************************************************************************
25414 * Conversion of particle index BAMJET-index scheme --> PDG proposal *
25415 * Adopted from the original by S. Roesler. This version dated 12.5.95 *
25416 * Renamed to be not in conflict with the modified PHOJET-version *
25417 ************************************************************************
25419 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25422 * hadron index conversion (BAMJET <--> PDG)
25423 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25424 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25427 IDT_IPDGHA = IAMCIN(MCIND)
25432 *$ CREATE DT_FLAHAD.FOR
25435 *===flahad=============================================================*
25437 SUBROUTINE DT_FLAHAD(ID,IF1,IF2,IF3)
25439 ************************************************************************
25440 * sampling of FLAvor composition for HADrons/photons *
25441 * ID BAMJET-id of hadron *
25442 * IF1,2,3 flavor content *
25443 * (u,d,s: 1,2,3; au,ad,as: -1,-1,-3) *
25444 * Note: - u,d numbering as in BAMJET *
25445 * - ID .le. 30 !! *
25446 * This version dated 12.03.96 is written by S. Roesler *
25447 ************************************************************************
25449 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25452 * auxiliary common for reggeon exchange (DTUNUC 1.x)
25453 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
25454 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
25455 & IQTCHR(-6:6),MQUARK(3,39)
25457 DIMENSION JSEL(3,6)
25458 DATA JSEL/ 1,2,3, 2,3,1, 3,1,2, 1,3,2, 2,1,3, 3,2,1/
25462 * photon (charge dependent flavour sampling)
25463 K = INT(DT_RNDM(ONE)*6.D0+1.D0)
25467 ELSE IF(K.EQ.5) THEN
25474 IF(DT_RNDM(ONE).LT.0.5D0) THEN
25482 IX = INT(1.0D0+5.99999D0*DT_RNDM(ONE))
25483 IF1 = MQUARK(JSEL(1,IX),ID)
25484 IF2 = MQUARK(JSEL(2,IX),ID)
25485 IF3 = MQUARK(JSEL(3,IX),ID)
25486 IF ((IF1.EQ.0).AND.(IF3.NE.0)) THEN
25489 ELSEIF ((IF2.EQ.0).AND.(IF3.NE.0)) THEN
25498 *$ CREATE IDT_MCHAD.FOR
25501 *===mchad==============================================================*
25503 INTEGER FUNCTION IDT_MCHAD(ITDTU)
25505 ************************************************************************
25506 * Conversion of particle index BAMJET-index scheme --> HADRIN index s. *
25507 * Adopted from the original by S. Roesler. This version dated 6.5.95 *
25509 * Last change 28.12.2006 by S. Roesler. *
25510 ************************************************************************
25512 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25515 DIMENSION ITRANS(210)
25516 DATA ITRANS / 1, 2, -1, -1, -1, -1, -1, 8, 9, -1, -1, 24, 13, 14,
25517 &15, 16, 8, 9, 25, 8, 1, 8, 23, 24, 25, -1, -1, -1, -1, -1, 23, 13,
25518 &23, 14, 23, 15, 24, 16, 25, 15, 24, 16, 25, 15, 24, 16, 25, 1, 8,
25519 &8, 8, 1, 1, 1, 8, 8, 1, 1, 8, 8, 1, 8, 1, 8, 1, 8, 2, 2, 9, 9, 2,
25520 &2, 9, 9, 2, 9, 1, 13, 23, 14, 1, 1, 8, 8, 1, 1, 23, 14, 1, 8, 1,
25521 &8, 1, 8, 23, 23, 8, 8, 2, 9, 9, 9, 9, 1, 8, 8, 8, 8, 8, 2, 9, 9,
25522 &9, 9, 9, 85*- 1,7*-1,1,8,-1/
25524 IF ( ITDTU .GT. 0 ) THEN
25525 IDT_MCHAD = ITRANS(ITDTU)
25533 ************************************************************************
25535 * 3) Energy-momentum and quantum number conservation check routines *
25537 ************************************************************************
25538 *$ CREATE DT_EMC1.FOR
25541 *===emc1===============================================================*
25543 SUBROUTINE DT_EMC1(PP1,PP2,PT1,PT2,MODE,IPOS,IREJ)
25545 ************************************************************************
25546 * This version dated 15.12.94 is written by S. Roesler *
25547 ************************************************************************
25549 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25552 PARAMETER ( LINP = 10 ,
25556 PARAMETER (TINY10=1.0D-10)
25558 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
25562 IF ((MODE.EQ.0).OR.(ABS(MODE).GT.3))
25563 & WRITE(LOUT,'(1X,A,I6)')'EMC1: not supported MODE ',MODE
25565 IF ((MODE.GT.0).AND.(MODE.LT.3)) THEN
25566 IF (MODE.EQ.1) THEN
25567 CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),1,IDUM,IDUM)
25568 ELSEIF (MODE.EQ.2) THEN
25569 CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),2,IDUM,IDUM)
25571 CALL DT_EVTEMC(PP2(1),PP2(2),PP2(3),PP2(4),2,IDUM,IDUM)
25572 CALL DT_EVTEMC(PT1(1),PT1(2),PT1(3),PT1(4),2,IDUM,IDUM)
25573 CALL DT_EVTEMC(PT2(1),PT2(2),PT2(3),PT2(4),2,IDUM,IDUM)
25574 ELSEIF (MODE.LT.0) THEN
25575 IF (MODE.EQ.-1) THEN
25576 CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),1,IDUM,IDUM)
25577 ELSEIF (MODE.EQ.-2) THEN
25578 CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),2,IDUM,IDUM)
25580 CALL DT_EVTEMC(-PP2(1),-PP2(2),-PP2(3),-PP2(4),2,IDUM,IDUM)
25581 CALL DT_EVTEMC(-PT1(1),-PT1(2),-PT1(3),-PT1(4),2,IDUM,IDUM)
25582 CALL DT_EVTEMC(-PT2(1),-PT2(2),-PT2(3),-PT2(4),2,IDUM,IDUM)
25585 IF (ABS(MODE).EQ.3) THEN
25586 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,IPOS,IREJ1)
25587 IF (IREJ1.NE.0) GOTO 9999
25596 *$ CREATE DT_EMC2.FOR
25599 *===emc2===============================================================*
25601 SUBROUTINE DT_EMC2(IP1,IP2,IP3,IP4,IP5,MP,IN1,IN2,IN3,IN4,IN5,MN,
25604 ************************************************************************
25605 * MODE = 1 energy-momentum cons. check *
25606 * = 2 flavor-cons. check *
25607 * = 3 energy-momentum & flavor cons. check *
25608 * = 4 energy-momentum & charge cons. check *
25609 * = 5 energy-momentum & flavor & charge cons. check *
25610 * This version dated 16.01.95 is written by S. Roesler *
25611 ************************************************************************
25613 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25616 PARAMETER ( LINP = 10 ,
25620 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
25624 PARAMETER (NMXHKK=200000)
25626 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25627 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25628 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25630 * extended event history
25631 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
25632 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
25640 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25641 & CALL DT_EVTEMC(ZERO,ZERO,ZERO,ZERO,1,IDUM,IDUM)
25642 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25643 & CALL DT_EVTFLC(0,IDUM,1,IDUM,IDUM)
25644 IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,1,IDUM,IDUM)
25646 IF ((ISTHKK(I).EQ.IP1).OR.(ISTHKK(I).EQ.IP2).OR.
25647 & (ISTHKK(I).EQ.IP3).OR.(ISTHKK(I).EQ.IP4).OR.
25648 & (ISTHKK(I).EQ.IP5)) THEN
25649 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25651 & CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
25653 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25654 & CALL DT_EVTFLC(IDHKK(I),MP,2,IDUM,IDUM)
25655 IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25656 & CALL DT_EVTCHG(IDHKK(I),2,IDUM,IDUM)
25658 IF ((ISTHKK(I).EQ.IN1).OR.(ISTHKK(I).EQ.IN2).OR.
25659 & (ISTHKK(I).EQ.IN3).OR.(ISTHKK(I).EQ.IN4).OR.
25660 & (ISTHKK(I).EQ.IN5)) THEN
25661 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25663 & CALL DT_EVTEMC(-PHKK(1,I),-PHKK(2,I),-PHKK(3,I),-PHKK(4,I),
25665 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25666 & CALL DT_EVTFLC(IDHKK(I),MN,-2,IDUM,IDUM)
25667 IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25668 & CALL DT_EVTCHG(IDHKK(I),-2,IDUM,IDUM)
25671 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25672 & CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,IPOS,IREJ1)
25673 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25674 & CALL DT_EVTFLC(0,IDUM,3,IPOS,IREJ2)
25675 IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,3,IPOS,IREJ3)
25676 IF ((IREJ1.NE.0).OR.(IREJ2.NE.0).OR.(IREJ3.NE.0)) GOTO 9999
25685 *$ CREATE DT_EVTEMC.FOR
25688 *===evtemc=============================================================*
25690 SUBROUTINE DT_EVTEMC(PXIO,PYIO,PZIO,EIO,IMODE,IPOS,IREJ)
25692 ************************************************************************
25693 * This version dated 13.12.94 is written by S. Roesler *
25694 ************************************************************************
25696 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25699 PARAMETER ( LINP = 10 ,
25703 PARAMETER (TINY1=1.0D-1,TINY2=1.0D-2,TINY4=1.0D-4,TINY10=1.0D-10,
25708 PARAMETER (NMXHKK=200000)
25710 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25711 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25712 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25714 * flags for input different options
25715 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
25716 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
25717 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
25723 IF (MODE.EQ.4) THEN
25726 ELSEIF (MODE.EQ.5) THEN
25729 ELSEIF (MODE.EQ.-1) THEN
25734 IF (ABS(MODE).EQ.3) THEN
25739 IF ((IFRAG(1).EQ.2).AND.(CHKLEV.LT.TINY4)) CHKLEV = TINY4
25740 IF ((ABS(PXDEV).GT.CHKLEV).OR.(ABS(PYDEV).GT.CHKLEV).OR.
25741 & (ABS(PZDEV).GT.CHKLEV).OR.(ABS(EDEV).GT.CHKLEV)) THEN
25742 IF (IOULEV(2).GT.0) WRITE(LOUT,'(1X,A,I4,A,I8,A,/,4G10.3)')
25743 & 'EVTEMC: energy-momentum cons. failure at pos. ',IPOS,
25744 & ' event ',NEVHKK,
25745 & ' ! ',PXDEV,PYDEV,PZDEV,EDEV
25759 IF (MODE.EQ.1) THEN
25778 *$ CREATE DT_EVTFLC.FOR
25781 *===evtflc=============================================================*
25783 SUBROUTINE DT_EVTFLC(ID,ID1,MODE,IPOS,IREJ)
25785 ************************************************************************
25786 * Flavor conservation check. *
25787 * ID identity of particle *
25788 * ID1 = 1 ID for q,aq,qq,aqaq in PDG-numbering scheme *
25789 * = 2 ID for particle/resonance in BAMJET numbering scheme *
25790 * = 3 ID for particle/resonance in PDG numbering scheme *
25791 * MODE = 1 initialization and add ID *
25792 * =-1 initialization and subtract ID *
25794 * =-2 subtract ID *
25795 * = 3 check flavor cons. *
25796 * IPOS flag to give position of call of EVTFLC to output *
25797 * unit in case of violation *
25798 * This version dated 10.01.95 is written by S. Roesler *
25799 ************************************************************************
25801 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25804 PARAMETER ( LINP = 10 ,
25808 PARAMETER (TINY10=1.0D-10)
25812 IF (MODE.EQ.3) THEN
25814 WRITE(LOUT,'(1X,A,I3,A,I3)')
25815 & 'EVTFLC: flavor-conservation failure at pos. ',IPOS,
25824 IF (MODE.EQ.1) IFL = 0
25825 IF (ID.EQ.0) RETURN
25830 IF ((IDD.GE.100).AND.(IDD.LT.1000)) NQ = 2
25831 IF (IDD.GE.1000) NQ = 3
25833 IFBAM = IDT_IPDG2B(ID,I,2)
25834 IF (ABS(IFBAM).EQ.1) THEN
25835 IFBAM = SIGN(2,IFBAM)
25836 ELSEIF (ABS(IFBAM).EQ.2) THEN
25837 IFBAM = SIGN(1,IFBAM)
25839 IF (MODE.GT.0) THEN
25849 IF (ID1.EQ.3) IDD = IDT_ICIHAD(ID)
25850 IF ((ID1.EQ.2).OR.(ID1.EQ.3)) THEN
25852 IF (MODE.GT.0) THEN
25853 IFL = IFL+IDT_IQUARK(I,IDD)
25855 IFL = IFL-IDT_IQUARK(I,IDD)
25866 *$ CREATE DT_EVTCHG.FOR
25869 *===evtchg=============================================================*
25871 SUBROUTINE DT_EVTCHG(ID,MODE,IPOS,IREJ)
25873 ************************************************************************
25874 * Charge conservation check. *
25875 * ID identity of particle (PDG-numbering scheme) *
25876 * MODE = 1 initialization *
25877 * =-2 subtract ID-charge *
25878 * = 2 add ID-charge *
25879 * = 3 check charge cons. *
25880 * IPOS flag to give position of call of EVTCHG to output *
25881 * unit in case of violation *
25882 * This version dated 10.01.95 is written by S. Roesler *
25883 * Last change: s.r. 21.01.01 *
25884 ************************************************************************
25886 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25889 PARAMETER ( LINP = 10 ,
25895 PARAMETER (NMXHKK=200000)
25897 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25898 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25899 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25901 * particle properties (BAMJET index convention)
25903 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
25904 & IICH(210),IIBAR(210),K1(210),K2(210)
25908 IF (MODE.EQ.1) THEN
25914 IF (MODE.EQ.3) THEN
25915 IF ((ICH.NE.0).OR.(IBAR.NE.0)) THEN
25916 WRITE(LOUT,'(1X,A,I3,A,2I3,A,I8)')
25917 & 'EVTCHG: charge/baryo.-cons. failure at pos. ',IPOS,
25918 & '! ICH/IBAR= ',ICH,IBAR,' event ',NEVHKK
25928 IF (ID.EQ.0) RETURN
25930 IDD = IDT_ICIHAD(ID)
25931 * modification 21.1.01: use intrinsic phojet-functions to determine charge
25932 * and baryon number
25933 C IF (IDD.GT.0) THEN
25934 C IF (MODE.EQ.2) THEN
25935 C ICH = ICH+IICH(IDD)
25936 C IBAR = IBAR+IIBAR(IDD)
25937 C ELSEIF (MODE.EQ.-2) THEN
25938 C ICH = ICH-IICH(IDD)
25939 C IBAR = IBAR-IIBAR(IDD)
25942 C WRITE(LOUT,'(1X,A,3I6)') 'EVTCHG: (IDD = 0 !), IDD,ID=',IDD,ID
25943 C CALL DT_EVTOUT(4)
25946 IF (MODE.EQ.2) THEN
25947 ICH = ICH+IPHO_CHR3(ID,1)/3
25948 IBAR = IBAR+IPHO_BAR3(ID,1)/3
25949 ELSEIF (MODE.EQ.-2) THEN
25950 ICH = ICH-IPHO_CHR3(ID,1)/3
25951 IBAR = IBAR-IPHO_BAR3(ID,1)/3
25961 ************************************************************************
25963 * 4) Transformations *
25965 ************************************************************************
25966 *$ CREATE DT_LTINI.FOR
25969 *===ltini==============================================================*
25971 SUBROUTINE DT_LTINI(IDPR,IDTA,EPN0,PPN0,ECM0,MODE)
25973 ************************************************************************
25974 * Initializations of Lorentz-transformations, calculation of Lorentz- *
25976 * This version dated 13.11.95 is written by S. Roesler. *
25977 ************************************************************************
25979 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25982 PARAMETER ( LINP = 10 ,
25986 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,
25987 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
25989 * Lorentz-parameters of the current interaction
25990 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
25991 & UMO,PPCM,EPROJ,PPROJ
25993 * properties of photon/lepton projectiles
25994 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
25996 * particle properties (BAMJET index convention)
25998 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
25999 & IICH(210),IIBAR(210),K1(210),K2(210)
26001 * nucleon-nucleon event-generator
26004 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
26008 IF (MCGENE.NE.3) THEN
26009 * lepton-projectiles and PHOJET: initialize real photon instead
26010 IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26011 & (IDPR.EQ.10).OR.(IDPR.EQ.11).OR.
26012 & (IDPR.EQ. 5).OR.(IDPR.EQ. 6)) THEN
26021 AMP = AAM(IDP)-SQRT(ABS(Q2))
26023 AMP2 = SIGN(AMP**2,AMP)
26025 IF (ECM0.GT.ZERO) THEN
26026 EPN = (ECM**2-AMP2-AMT2)/(TWO*AMT)
26027 IF (AMP2.GT.ZERO) THEN
26028 PPN = SQRT((EPN+AMP)*(EPN-AMP))
26030 PPN = SQRT(EPN**2-AMP2)
26033 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26034 IF (IDP.EQ.7) EPN = ABS(EPN)
26035 IF (EPN.LT.ZERO) EPN = ABS(EPN)+AMP
26036 IF (AMP2.GT.ZERO) THEN
26037 PPN = SQRT((EPN+AMP)*(EPN-AMP))
26039 PPN = SQRT(EPN**2-AMP2)
26041 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26042 IF (AMP2.GT.ZERO) THEN
26043 EPN = PPN*SQRT(ONE+(AMP/PPN)**2)
26045 EPN = SQRT(PPN**2+AMP2)
26048 ECM = SQRT(AMP2+AMT2+TWO*AMT*EPN)
26053 IF (AMP2.GT.ZERO) THEN
26054 ETARG = (ECM**2-AMP2-AMT2)/(TWO*AMP)
26055 PTARG = -SQRT((ETARG+AMT)*(ETARG-AMT))
26060 * photon-projectiles (get momentum in cm-frame for virtuality Q^2)
26066 IF (ECM0.GT.ZERO) THEN
26069 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26070 S = AMGAM2+AMT2+TWO*AMT*ABS(EPN0)
26071 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26072 S = AMGAM2+AMT2+TWO*AMT*SQRT(PPN0**2+AMGAM2)
26075 PGAMM(3) = SQRT( (S**2-TWO*AMGAM2*S-TWO*AMT2*S-TWO*AMGAM2*AMT2
26076 & +AMGAM2**2+AMT2**2)/(4.0D0*S) )
26077 PGAMM(4) = SQRT(AMGAM2+PGAMM(3)**2)
26078 IF (MODE.EQ.1) THEN
26081 PNUCL(3) = -PGAMM(3)
26082 PNUCL(4) = SQRT(S)-PGAMM(4)
26085 IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26086 & (IDPR.EQ.10).OR.(IDPR.EQ.11)) THEN
26089 * neglect lepton masses
26090 C AMLPT2 = AAM(IDPR)**2
26093 IF (ECM0.GT.ZERO) THEN
26096 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26097 S = AMLPT2+AMT2+TWO*AMT*ABS(EPN0)
26098 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26099 S = AMLPT2+AMT2+TWO*AMT*SQRT(PPN0**2+AMLPT2)
26102 PLEPT0(3) = SQRT( (S**2-TWO*AMLPT2*S-TWO*AMT2*S-TWO*AMLPT2*AMT2
26103 & +AMLPT2**2+AMT2**2)/(4.0D0*S) )
26104 PLEPT0(4) = SQRT(AMLPT2+PLEPT0(3)**2)
26107 PNUCL(3) = -PLEPT0(3)
26108 PNUCL(4) = SQRT(S)-PLEPT0(4)
26110 * Lorentz-parameter for transformation Lab. - projectile rest system
26111 IF ((IDP.EQ.7).OR.(AMP.LT.TINY10)) THEN
26120 * Lorentz-parameter for transf. proj. rest sys. - nucl.-nucl. cms.
26125 GACMS(1) = (ETARG+AMP)/UMO
26126 BGCMS(1) = PTARG/UMO
26128 * Lorentz-parameter for transformation Lab. - nucl.-nucl. cms.
26129 GACMS(2) = (EPROJ+AMT)/UMO
26130 BGCMS(2) = PPROJ/UMO
26131 PPCM = GACMS(2)*PPROJ-BGCMS(2)*EPROJ
26140 *$ CREATE DT_LTRANS.FOR
26143 *===ltrans=============================================================*
26145 SUBROUTINE DT_LTRANS(PXI,PYI,PZI,PEI,PXO,PYO,PZO,PEO,ID,MODE)
26147 ************************************************************************
26148 * Lorentz-transformations. *
26149 * MODE = 1(-1) projectile rest syst. --> Lab (back) *
26150 * = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) *
26151 * = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) *
26152 * This version dated 01.11.95 is written by S. Roesler. *
26153 ************************************************************************
26155 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26158 PARAMETER ( LINP = 10 ,
26162 PARAMETER (TINY3=1.0D-3,ZERO=0.0D0,TWO=2.0D0)
26164 PARAMETER (SQTINF=1.0D+15)
26166 * particle properties (BAMJET index convention)
26168 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26169 & IICH(210),IIBAR(210),K1(210),K2(210)
26173 CALL DT_LTNUC(PZI,PEI,PZO,PEO,MODE)
26175 * check particle mass for consistency (numerical rounding errors)
26176 PO = SQRT(PXO*PXO+PYO*PYO+PZO*PZO)
26177 AMO2 = (PEO-PO)*(PEO+PO)
26178 AMORQ2 = AAM(ID)**2
26179 AMDIF2 = ABS(AMO2-AMORQ2)
26180 IF ((AMDIF2.GT.TINY3).AND.(PEO.LT.SQTINF).AND.(PO.GT.ZERO)) THEN
26181 DELTA = (AMORQ2-AMO2)/(TWO*(PEO+PO))
26187 C WRITE(6,*) 'LTRANS corrected', AMDIF2,PZI,PEI,PZO,PEO,MODE,ID
26193 *$ CREATE DT_LTNUC.FOR
26196 *===ltnuc==============================================================*
26198 SUBROUTINE DT_LTNUC(PIN,EIN,POUT,EOUT,MODE)
26200 ************************************************************************
26201 * Lorentz-transformations. *
26202 * PIN longitudnal momentum (input) *
26203 * EIN energy (input) *
26204 * POUT transformed long. momentum (output) *
26205 * EOUT transformed energy (output) *
26206 * MODE = 1(-1) projectile rest syst. --> Lab (back) *
26207 * = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) *
26208 * = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) *
26209 * This version dated 01.11.95 is written by S. Roesler. *
26210 ************************************************************************
26212 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26215 PARAMETER ( LINP = 10 ,
26219 PARAMETER (ZERO=0.0D0)
26221 * Lorentz-parameters of the current interaction
26222 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26223 & UMO,PPCM,EPROJ,PPROJ
26229 IF (ABS(MODE).EQ.1) THEN
26230 BG = -SIGN(BGLAB,DBLE(MODE))
26231 CALL DT_DALTRA(GALAB,BDUM1,BDUM2,-BG,PDUM1,PDUM2,PIN,EIN,
26232 & DUM1,DUM2,DUM3,POUT,EOUT)
26233 ELSEIF (ABS(MODE).EQ.2) THEN
26234 BG = SIGN(BGCMS(1),DBLE(MODE))
26235 CALL DT_DALTRA(GACMS(1),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26236 & DUM1,DUM2,DUM3,POUT,EOUT)
26237 ELSEIF (ABS(MODE).EQ.3) THEN
26238 BG = -SIGN(BGCMS(2),DBLE(MODE))
26239 CALL DT_DALTRA(GACMS(2),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26240 & DUM1,DUM2,DUM3,POUT,EOUT)
26242 WRITE(LOUT,1000) MODE
26243 1000 FORMAT(1X,'LTNUC: not supported mode (MODE = ',I3,')')
26251 *$ CREATE DT_DALTRA.FOR
26254 *===daltra=============================================================*
26256 SUBROUTINE DT_DALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
26258 ************************************************************************
26259 * Arbitrary Lorentz-transformation. *
26260 * Adopted from the original by S. Roesler. This version dated 15.01.95 *
26261 ************************************************************************
26263 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26265 PARAMETER (ONE=1.0D0)
26267 EP = PCX*BGX+PCY*BGY+PCZ*BGZ
26268 PE = EP/(GA+ONE)+EC
26272 P = SQRT(PX*PX+PY*PY+PZ*PZ)
26278 *$ CREATE DT_DTRAFO.FOR
26281 *====dtrafo============================================================*
26283 SUBROUTINE DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
26284 & PL,CXL,CYL,CZL,EL)
26286 C LORENTZ TRANSFORMATION INTO THE LAB - SYSTEM
26288 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26291 IF (ABS(COD).GT.1.0D0) COD = SIGN(1.0D0,COD)
26292 SID = SQRT(1.D0-COD*COD)
26296 PLZ = GAM*PCMZ+BGAM*ECM
26297 PL = SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
26298 EL = GAM*ECM+BGAM*PCMZ
26299 C ROTATION INTO THE ORIGINAL DIRECTION
26301 SIZ = SQRT(1.D0-COZ**2)
26302 CALL DT_STTRAN(CX,CY,CZ,COZ,SIZ,SIF,COF,CXL,CYL,CZL)
26307 *$ CREATE DT_STTRAN.FOR
26310 *====sttran============================================================*
26312 SUBROUTINE DT_STTRAN(XO,YO,ZO,CDE,SDE,SFE,CFE,X,Y,Z)
26314 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26316 DATA ANGLSQ/1.D-30/
26317 ************************************************************************
26318 * VERSION BY J. RANFT *
26321 * THIS IS A SUBROUTINE OF FLUKA TO GIVE NEW DIRECTION COSINES *
26323 * INPUT VARIABLES: *
26324 * XO,YO,ZO = ORIGINAL DIRECTION COSINES *
26325 * CDE,SDE = COSINE AND SINE OF THE POLAR (THETA) *
26326 * ANGLE OF "SCATTERING" *
26327 * SDE = SINE OF THE POLAR (THETA) ANGLE OF "SCATTERING" *
26328 * SFE,CFE = SINE AND COSINE OF THE AZIMUTHAL (PHI) ANGLE *
26329 * OF "SCATTERING" *
26331 * OUTPUT VARIABLES: *
26332 * X,Y,Z = NEW DIRECTION COSINES *
26334 * ROTATION OF COORDINATE SYSTEM (SEE CERN 64-47 ) *
26335 ************************************************************************
26338 * Changed by A. Ferrari
26340 * IF (ABS(XO)-0.0001D0) 1,1,2
26341 * 1 IF (ABS(YO)-0.0001D0) 3,3,2
26344 IF ( A .LT. ANGLSQ ) THEN
26353 X=-YO*XI/A-ZO*XO*YI/A+XO*ZI
26354 Y=XO*XI/A-ZO*YO*YI/A+YO*ZI
26361 *$ CREATE DT_MYTRAN.FOR
26364 *===mytran=============================================================*
26366 SUBROUTINE DT_MYTRAN(IMODE,XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
26368 ************************************************************************
26369 * This subroutine rotates the coordinate frame *
26370 * a) theta around y *
26371 * b) phi around z if IMODE = 1 *
26373 * x' cos(ph) -sin(ph) 0 cos(th) 0 sin(th) x *
26374 * y' = A B = sin(ph) cos(ph) 0 . 0 1 0 y *
26375 * z' 0 0 1 -sin(th) 0 cos(th) z *
26377 * and vice versa if IMODE = 0. *
26378 * This version dated 5.4.94 is based on the original version DTRAN *
26379 * by J. Ranft and is written by S. Roesler. *
26380 ************************************************************************
26382 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26385 PARAMETER ( LINP = 10 ,
26389 IF (IMODE.EQ.1) THEN
26390 X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
26391 Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
26392 Z=-SDE *XO +CDE *ZO
26394 X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
26396 Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
26401 *$ CREATE DT_LT2LAO.FOR
26404 *===lt2lab=============================================================*
26406 SUBROUTINE DT_LT2LAO
26408 ************************************************************************
26409 * Lorentz-transformation to lab-system. This subroutine scans DTEVT1 *
26410 * for final state particles/fragments defined in nucleon-nucleon-cms *
26411 * and transforms them back to the lab. *
26412 * This version dated 16.11.95 is written by S. Roesler *
26413 ************************************************************************
26415 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26418 PARAMETER ( LINP = 10 ,
26424 PARAMETER (NMXHKK=200000)
26426 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26427 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26428 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26430 * extended event history
26431 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26432 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26437 IF ( (NPOINT(4).EQ.0).OR.(NEND.LT.NPOINT(4)) ) RETURN
26438 DO 1 I=NPOINT(4),NEND
26440 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26441 & (ISTHKK(I).EQ.1001)) THEN
26442 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26444 CALL DT_EVTPUT(ISTHKK(I),IDHKK(I),I,0,PHKK(1,I),PHKK(2,I),
26445 & PZ,PE,IDRES(I),IDXRES(I),IDCH(I))
26446 IF ((ISTHKK(I).EQ.1000).OR.(ISTHKK(I).EQ.1001)) THEN
26447 ISTHKK(I) = 3*ISTHKK(I)
26450 IF (ISTHKK(I).EQ.-1) NOBAM(NHKK) = NOB
26451 ISTHKK(I) = SIGN(3,ISTHKK(I))
26460 *$ CREATE DT_LT2LAB.FOR
26463 *===lt2lab=============================================================*
26465 SUBROUTINE DT_LT2LAB
26467 ************************************************************************
26468 * Lorentz-transformation to lab-system. This subroutine scans DTEVT1 *
26469 * for final state particles/fragments defined in nucleon-nucleon-cms *
26470 * and transforms them to the lab. *
26471 * This version dated 07.01.96 is written by S. Roesler *
26472 ************************************************************************
26474 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26477 PARAMETER ( LINP = 10 ,
26483 PARAMETER (NMXHKK=200000)
26485 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26486 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26487 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26489 * extended event history
26490 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26491 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26494 IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
26495 DO 1 I=NPOINT(4),NHKK
26496 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26497 & (ISTHKK(I).EQ.1001)) THEN
26498 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26507 ************************************************************************
26509 * 5) Sampling from distributions *
26511 ************************************************************************
26512 *$ CREATE IDT_NPOISS.FOR
26515 *===npoiss=============================================================*
26517 INTEGER FUNCTION IDT_NPOISS(AVN)
26519 ************************************************************************
26520 * Sample according to Poisson distribution with Poisson parameter AVN. *
26521 * The original version written by J. Ranft. *
26522 * This version dated 11.1.95 is written by S. Roesler. *
26523 ************************************************************************
26525 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26528 PARAMETER ( LINP = 10 ,
26538 IF (A.GE.EXPAVN) THEN
26547 *$ CREATE DT_SAMPXB.FOR
26550 *===sampxb=============================================================*
26552 DOUBLE PRECISION FUNCTION DT_SAMPXB(X1,X2,B)
26554 ************************************************************************
26555 * Sampling from f(x)=1./SQRT(X**2+B**2) between x1 and x2. *
26556 * Processed by S. Roesler, 6.5.95 *
26557 ************************************************************************
26559 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26561 PARAMETER (TWO=2.0D0)
26563 A1 = LOG(X1+SQRT(X1**2+B**2))
26564 A2 = LOG(X2+SQRT(X2**2+B**2))
26566 A = AN*DT_RNDM(A1)+A1
26568 DT_SAMPXB = (BB**2-B**2)/(TWO*BB)
26573 *$ CREATE DT_SAMPEX.FOR
26576 *===sampex=============================================================*
26578 DOUBLE PRECISION FUNCTION DT_SAMPEX(X1,X2)
26580 ************************************************************************
26581 * Sampling from f(x)=1./x between x1 and x2. *
26582 * Processed by S. Roesler, 6.5.95 *
26583 ************************************************************************
26585 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26587 PARAMETER (ONE=1.0D0)
26592 DT_SAMPEX = EXP((ONE-R)*AL1+R*AL2)
26597 *$ CREATE DT_SAMSQX.FOR
26600 *===samsqx=============================================================*
26602 DOUBLE PRECISION FUNCTION DT_SAMSQX(X1,X2)
26604 ************************************************************************
26605 * Sampling from f(x)=1./x^0.5 between x1 and x2. *
26606 * Processed by S. Roesler, 6.5.95 *
26607 ************************************************************************
26609 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26611 PARAMETER (ONE=1.0D0)
26614 DT_SAMSQX = (R*SQRT(X2)+(ONE-R)*SQRT(X1))**2
26619 *$ CREATE DT_SAMPLW.FOR
26622 *===samplw=============================================================*
26624 DOUBLE PRECISION FUNCTION DT_SAMPLW(XMIN,XMAX,B)
26626 ************************************************************************
26627 * Sampling from f(x)=1/x^b between x_min and x_max. *
26628 * S. Roesler, 18.4.98 *
26629 ************************************************************************
26631 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26633 PARAMETER (ONE=1.0D0)
26637 DT_SAMPLW = EXP(R*LOG(XMAX)+(ONE-R)*LOG(XMIN))
26640 DT_SAMPLW = (R*XMAX**ONEMB+(ONE-R)*XMIN**ONEMB)**(ONE/ONEMB)
26646 *$ CREATE DT_BETREJ.FOR
26649 *===betrej=============================================================*
26651 DOUBLE PRECISION FUNCTION DT_BETREJ(GAM,ETA,XMIN,XMAX)
26653 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26656 PARAMETER ( LINP = 10 ,
26660 PARAMETER (ONE=1.0D0)
26662 IF (XMIN.GE.XMAX)THEN
26663 WRITE (LOUT,500) XMIN,XMAX
26664 500 FORMAT(1X,'DT_BETREJ: XMIN<XMAX execution stopped ',2F10.5)
26669 XX = XMIN+(XMAX-XMIN)*DT_RNDM(ETA)
26670 BETMAX = XMIN**(GAM-ONE)*(ONE-XMIN)**(ETA-ONE)
26671 YY = BETMAX*DT_RNDM(XX)
26672 BETXX = XX**(GAM-ONE)*(ONE-XX)**(ETA-ONE)
26673 IF (YY.GT.BETXX) GOTO 10
26679 *$ CREATE DT_DGAMRN.FOR
26682 *===dgamrn=============================================================*
26684 DOUBLE PRECISION FUNCTION DT_DGAMRN(ALAM,ETA)
26686 ************************************************************************
26687 * Sampling from Gamma-distribution. *
26688 * F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA) *
26689 * Processed by S. Roesler, 6.5.95 *
26690 ************************************************************************
26692 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26694 PARAMETER (ZERO=0.0D0,TINY9=1.0D-9,ONE=1.0D0)
26699 IF (F.EQ.ZERO) GOTO 20
26702 IF (NCOU.GE.11) GOTO 20
26703 IF (R.LT.F/(F+2.71828D0)) GOTO 30
26704 YYY = LOG(DT_RNDM(R)+TINY9)/F
26705 IF (ABS(YYY).GT.50.0D0) GOTO 20
26707 IF (LOG(DT_RNDM(Y)+TINY9).GT.-Y) GOTO 10
26711 30 Y = ONE-LOG(DT_RNDM(Y)+TINY9)
26712 IF (DT_RNDM(R).GT.Y**(F-ONE)) GOTO 10
26713 40 IF (N.EQ.0) GOTO 70
26716 60 Z = Z*DT_RNDM(Z)
26718 70 DT_DGAMRN = Y/ALAM
26723 *$ CREATE DT_DBETAR.FOR
26726 *===dbetar=============================================================*
26728 DOUBLE PRECISION FUNCTION DT_DBETAR(GAM,ETA)
26730 ************************************************************************
26731 * Sampling from Beta -distribution between 0.0 and 1.0 *
26732 * F(X)=X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM)/(GAMM(GAM)*GAMM(ETA))*
26733 * Processed by S. Roesler, 6.5.95 *
26734 ************************************************************************
26736 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26739 Y = DT_DGAMRN(1.0D0,GAM)
26740 Z = DT_DGAMRN(1.0D0,ETA)
26741 DT_DBETAR = Y/(Y+Z)
26746 *$ CREATE DT_RANNOR.FOR
26749 *===rannor=============================================================*
26751 SUBROUTINE DT_RANNOR(X,Y)
26753 ************************************************************************
26754 * Sampling from Gaussian distribution. *
26755 * Processed by S. Roesler, 6.5.95 *
26756 ************************************************************************
26758 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26760 PARAMETER (TINY10=1.0D-10)
26762 CALL DT_DSFECF(SFE,CFE)
26763 V = MAX(TINY10,DT_RNDM(X))
26764 A = SQRT(-2.D0*LOG(V))
26771 *$ CREATE DT_DPOLI.FOR
26774 *===dpoli==============================================================*
26776 SUBROUTINE DT_DPOLI(CS,SI)
26778 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26783 IF (U.LT.0.5D0) CS=-CS
26784 SI = SQRT(1.0D0-CS*CS+1.0D-10)
26789 *$ CREATE DT_DSFECF.FOR
26792 *===dsfecf=============================================================*
26794 SUBROUTINE DT_DSFECF(SFE,CFE)
26796 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26798 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
26806 IF (XY.GT.ONE) GOTO 1
26809 IF (DT_RNDM(X).LT.OHALF) SFE = -SFE
26813 *$ CREATE DT_RACO.FOR
26816 *===raco===============================================================*
26818 SUBROUTINE DT_RACO(WX,WY,WZ)
26820 ************************************************************************
26821 * Direction cosines of random uniform (isotropic) direction in three *
26822 * dimensional space *
26823 * Processed by S. Roesler, 20.11.95 *
26824 ************************************************************************
26826 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26828 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
26831 X = TWO*DT_RNDM(WX)-ONE
26835 IF (X2+Y2.GT.ONE) GOTO 10
26837 CFE = (X2-Y2)/(X2+Y2)
26838 SFE = TWO*X*Y/(X2+Y2)
26839 * z = 1/2 [ 1 + cos (theta) ]
26842 WZ = SQRT(Z*(ONE-Z))
26850 ************************************************************************
26852 * 6) Special functions, algorithms and service routines *
26854 ************************************************************************
26855 *$ CREATE DT_YLAMB.FOR
26858 *===ylamb==============================================================*
26860 DOUBLE PRECISION FUNCTION DT_YLAMB(X,Y,Z)
26862 ************************************************************************
26864 * auxiliary function for three particle decay mode *
26865 * (standard LAMBDA**(1/2) function) *
26867 * Adopted from an original version written by R. Engel. *
26868 * This version dated 12.12.94 is written by S. Roesler. *
26869 ************************************************************************
26871 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26875 XLAM = X*X-2.D0*X*(Y+Z)+YZ*YZ
26876 IF (XLAM.LE.0.D0) XLAM = ABS(XLAM)
26877 DT_YLAMB = SQRT(XLAM)
26882 *$ CREATE DT_SORT.FOR
26885 *===sort1==============================================================*
26887 SUBROUTINE DT_SORT(A,N,I0,I1,MODE)
26889 ************************************************************************
26890 * This subroutine sorts entries in A in increasing/decreasing order *
26892 * MODE = 1 increasing in A(3,i=1..N) *
26893 * = 2 decreasing in A(3,i=1..N) *
26894 * This version dated 21.04.95 is revised by S. Roesler *
26895 ************************************************************************
26897 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26909 IF (MODE.EQ.1) THEN
26910 IF (A(3,I).LE.A(3,J)) GOTO 20
26912 IF (A(3,I).GE.A(3,J)) GOTO 20
26925 IF (L.EQ.1) GOTO 10
26930 *$ CREATE DT_SORT1.FOR
26933 *===sort1==============================================================*
26935 SUBROUTINE DT_SORT1(A,IDX,N,I0,I1,MODE)
26937 ************************************************************************
26938 * This subroutine sorts entries in A in increasing/decreasing order *
26940 * MODE = 1 increasing in A(i=1..N) *
26941 * = 2 decreasing in A(i=1..N) *
26942 * This version dated 21.04.95 is revised by S. Roesler *
26943 ************************************************************************
26945 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26948 DIMENSION A(N),IDX(N)
26957 IF (MODE.EQ.1) THEN
26958 IF (A(I).LE.A(J)) GOTO 20
26960 IF (A(I).GE.A(J)) GOTO 20
26970 IF (L.EQ.1) GOTO 10
26975 *$ CREATE DT_XTIME.FOR
26978 *===xtime==============================================================*
26980 SUBROUTINE DT_XTIME
26982 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26985 PARAMETER ( LINP = 10 ,
26989 CHARACTER DAT*9,TIM*11
26993 C CALL GETDAT(IYEAR,IMONTH,IDAY)
26994 C CALL GETTIM(IHOUR,IMINUT,ISECND,IHSCND)
26998 C WRITE(LOUT,1000) DAT,TIM
26999 1000 FORMAT(/,2X,'Date: ',A9,3X,'Time: ',A11,/)
27004 ************************************************************************
27006 * 7) Random number generator package *
27008 * THIS IS A PACKAGE CONTAINING A RANDOM NUMBER GENERATOR AND *
27009 * SERVICE ROUTINES. *
27010 * THE ALGORITHM IS FROM *
27011 * 'TOWARD A UNVERSAL RANDOM NUMBER GENERATOR' *
27012 * G.MARSAGLIA, A.ZAMAN ; FSU-SCRI-87-50 *
27013 * IMPLEMENTATION BY K. HAHN DEC. 88, *
27014 * THIS GENERATOR SHOULD NOT DEPEND ON THE HARD WARE ( IF A REAL HAS *
27015 * AT LEAST 24 SIGNIFICANT BITS IN INTERNAL REPRESENTATION ), *
27016 * THE PERIOD IS ABOUT 2**144, *
27017 * TIME FOR ONE CALL AT IBM-XT IS ABOUT 0.7 MILLISECONDS, *
27018 * THE PACKAGE CONTAINS *
27019 * FUNCTION DT_RNDM(I) : GENERATOR *
27020 * SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB4): INITIALIZATION *
27021 * SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) : PUT SEED TO GENERATOR *
27022 * SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) : TAKE SEED FROM GENERATOR *
27023 * SUBROUTINE DT_RNDMTE(IO) : TEST OF GENERATOR *
27025 * FUNCTION DT_RNDM(I) *
27026 * GIVES UNIFORMLY DISTRIBUTED RANDOM NUMBERS IN (0..1) *
27027 * I - DUMMY VARIABLE, NOT USED *
27028 * SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1) *
27029 * INITIALIZES THE GENERATOR, MUST BE CALLED BEFORE USING DT_RNDM *
27030 * NA1,NA2,NA3,NB1 - VALUES FOR INITIALIZING THE GENERATOR *
27031 * NA? MUST BE IN 1..178 AND NOT ALL 1 *
27032 * 12,34,56 ARE THE STANDARD VALUES *
27033 * NB1 MUST BE IN 1..168 *
27034 * 78 IS THE STANDARD VALUE *
27035 * SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) *
27036 * PUTS SEED TO GENERATOR ( BRINGS GENERATOR IN THE SAME STATUS *
27037 * AS AFTER THE LAST DT_RNDMOU CALL ) *
27038 * U(97),C,CD,CM,I,J - SEED VALUES AS TAKEN FROM DT_RNDMOU *
27039 * SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) *
27040 * TAKES SEED FROM GENERATOR *
27041 * U(97),C,CD,CM,I,J - SEED VALUES *
27042 * SUBROUTINE DT_RNDMTE(IO) *
27043 * TEST OF THE GENERATOR *
27044 * IO - DEFINES OUTPUT *
27045 * = 0 OUTPUT ONLY IF AN ERROR IS DETECTED *
27046 * = 1 OUTPUT INDEPENDEND ON AN ERROR *
27047 * DT_RNDMTE USES DT_RNDMIN AND DT_RNDMOU TO BRING GENERATOR TO *
27049 * AS BEFORE CALL OF DT_RNDMTE *
27050 ************************************************************************
27051 *$ CREATE DT_RNDM.FOR
27054 *===rndm===============================================================*
27056 c$$$ DOUBLE PRECISION FUNCTION DT_RNDM(VDUMMY)
27058 c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27061 c$$$* counter of calls to random number generator
27062 c$$$* uncomment if needed
27063 c$$$C COMMON /DTRNCT/ IRNCT0,IRNCT1
27064 c$$$C LOGICAL LFIRST
27065 c$$$C DATA LFIRST /.TRUE./
27067 c$$$* counter of calls to random number generator
27068 c$$$* uncomment if needed
27069 c$$$C IF (LFIRST) THEN
27072 c$$$C LFIRST = .FALSE.
27075 c$$$ DT_RNDM = FLRNDM(VDUMMY)
27076 c$$$* counter of calls to random number generator
27077 c$$$* uncomment if needed
27078 c$$$C IRNCT1 = IRNCT1+1
27083 c$$$*$ CREATE DT_RNDMST.FOR
27084 c$$$*COPY DT_RNDMST
27086 c$$$*===rndmst=============================================================*
27088 c$$$ SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)
27090 c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27093 c$$$* random number generator
27094 c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27102 c$$$ DO 20 II2 = 1,97
27105 c$$$ DO 10 II1 = 1,24
27106 c$$$ MAT = MOD(MOD(MA1*MA2,179)*MA3,179)
27110 c$$$ MB1 = MOD(53*MB1+1,169)
27111 c$$$ IF ( MOD(MB1*MAT,64).GE.32 ) S = S+T
27112 c$$$ 10 T = 0.5D0*T
27114 c$$$ C = 362436.0D0/16777216.0D0
27115 c$$$ CD = 7654321.0D0/16777216.0D0
27116 c$$$ CM = 16777213.0D0/16777216.0D0
27120 c$$$*$ CREATE DT_RNDMIN.FOR
27121 c$$$*COPY DT_RNDMIN
27123 c$$$*===rndmin=============================================================*
27125 c$$$ SUBROUTINE DT_RNDMIN(UIN,CIN,CDIN,CMIN,IIN,JIN)
27127 c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27130 c$$$* random number generator
27131 c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27133 c$$$ DIMENSION UIN(97)
27135 c$$$ DO 10 KKK = 1,97
27136 c$$$ 10 U(KKK) = UIN(KKK)
27146 c$$$*$ CREATE DT_RNDMOU.FOR
27147 c$$$*COPY DT_RNDMOU
27149 c$$$*===rndmou=============================================================*
27151 c$$$ SUBROUTINE DT_RNDMOU(UOUT,COUT,CDOUT,CMOUT,IOUT,JOUT)
27153 c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27156 c$$$* random number generator
27157 c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27159 c$$$ DIMENSION UOUT(97)
27161 c$$$ DO 10 KKK = 1,97
27162 c$$$ 10 UOUT(KKK) = U(KKK)
27172 c$$$*$ CREATE DT_RNDMTE.FOR
27173 c$$$*COPY DT_RNDMTE
27175 c$$$*===rndmte=============================================================*
27177 c$$$ SUBROUTINE DT_RNDMTE(IO)
27179 c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27182 c$$$ DIMENSION UU(97),U(6),X(6),D(6)
27183 c$$$ DATA U / 6533892.D0, 14220222.D0, 7275067.D0, 6172232.D0,
27184 c$$$ +8354498.D0, 10633180.D0/
27186 c$$$ CALL DT_RNDMOU(UU,CC,CCD,CCM,II,JJ)
27187 c$$$ CALL DT_RNDMST(12,34,56,78)
27188 c$$$ DO 10 II1 = 1,20000
27189 c$$$ 10 XX = DT_RNDM(XX)
27191 c$$$ DO 20 II2 = 1,6
27192 c$$$ X(II2) = 4096.D0*(4096.D0*DT_RNDM(SD))
27193 c$$$ D(II2) = X(II2)-U(II2)
27194 c$$$ 20 SD = SD+D(II2)
27195 c$$$ CALL DT_RNDMIN(UU,CC,CCD,CCM,II,JJ)
27197 c$$$C IF ( IO.EQ. 1.OR. SD.NE.0. 0) WRITE(6,500) (U(I),X(I),D(I),I=1,6)
27198 c$$$ IF ((IO.EQ.1).OR.(SD.NE.0.0)) THEN
27199 c$$$C WRITE(6,1000)
27200 c$$$ 1000 FORMAT(/,/,1X,'DT_RNDMTE: Test of random-number generator...',
27205 c$$$ 500 FORMAT(' === TEST OF THE RANDOM-GENERATOR ===',/,
27206 c$$$ &' EXPECTED VALUE CALCULATED VALUE DIFFERENCE',/, 6(F17.
27207 c$$$ &1,F20.1,F15.3,/), ' === END OF TEST ;',
27208 c$$$ &' GENERATOR HAS THE SAME STATUS AS BEFORE CALLING DT_RNDMTE')
27211 *$ CREATE PHO_RNDM.FOR
27214 *===pho_rndm===========================================================*
27216 DOUBLE PRECISION FUNCTION PHO_RNDM(DUMMY)
27218 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27221 PHO_RNDM = DT_RNDM(DUMMY)
27229 *===pyr================================================================*
27231 DOUBLE PRECISION FUNCTION PYR(IDUMMY)
27233 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27236 DUMMY = DBLE(IDUMMY)
27237 PYR = DT_RNDM(DUMMY)
27241 *$ CREATE DT_TITLE.FOR
27244 *===title==============================================================*
27246 SUBROUTINE DT_TITLE
27248 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27251 PARAMETER ( LINP = 10 ,
27256 CHARACTER*11 CCHANG
27257 DATA CVERSI,CCHANG /'3.0-5 ','31 Oct 2008'/
27260 WRITE(LOUT,1000) CVERSI,CCHANG
27261 1000 FORMAT(1X,'+-------------------------------------------------',
27262 & '----------------------+',/,
27263 & 1X,'|',71X,'|',/,
27264 & 1X,'|',26X,'DPMJET version ',A6,24X,'|',/,
27265 & 1X,'|',71X,'|',/,
27266 & 1X,'|',22X,'(Last change: ',A11,')',23X,'|',/,
27267 & 1X,'|',71X,'|',/,
27268 & 1X,'|',12X,'Authors: Stefan Roesler (CERN)',27X,'|',/,
27269 & 1X,'|',21X,'Ralph Engel (FZ Karlsruhe)',19X,'|',/,
27270 & 1X,'|',21X,'Johannes Ranft (Siegen Univ.)',19X,'|',/,
27271 C & 1X,'|',71X,'|',/,
27272 C & 1X,'|',12X,'http://home.cern.ch/~sroesler/dpmjet3.html',
27274 & 1X,'|',71X,'|',/,
27275 & 1X,'+-------------------------------------------------',
27276 & '----------------------+',/,
27277 & 1X,'| Please send suggestions, bug reports, etc. to: ',
27278 & 'Stefan.Roesler@cern.ch |',/,
27279 & 1X,'+-------------------------------------------------',
27280 & '----------------------+',/)
27285 *$ CREATE DT_EVTINI.FOR
27288 *===evtini=============================================================*
27290 SUBROUTINE DT_EVTINI
27292 ************************************************************************
27293 * Initialization of DTEVT1. *
27294 * This version dated 15.01.94 is written by S. Roesler *
27295 ************************************************************************
27297 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27300 PARAMETER ( LINP = 10 ,
27306 PARAMETER (NMXHKK=200000)
27308 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27309 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27310 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27312 * extended event history
27313 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27314 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27318 COMMON /DTEVNO/ NEVENT,ICASCA
27320 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
27322 * emulsion treatment
27323 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
27326 * initialization of DTEVT1/DTEVT2
27328 IF (NEVENT.EQ.1) NEND = NMXHKK
27356 C* initialization of DTLTRA
27357 C IF (NCOMPO.GT.0) CALL DT_LTINI(ID,EPN,PPN,ECM)
27362 *$ CREATE DT_STATIS.FOR
27365 *===statis=============================================================*
27367 SUBROUTINE DT_STATIS(MODE)
27369 ************************************************************************
27370 * Initialization and output of run-statistics. *
27371 * MODE = 1 initialization *
27373 * This version dated 23.01.94 is written by S. Roesler *
27374 ************************************************************************
27376 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27379 PARAMETER ( LINP = 10 ,
27383 PARAMETER (TINY3=1.0D-3)
27386 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
27387 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
27390 * rejection counter
27391 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27392 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27393 & IREXCI(3),IRDIFF(2),IRINC
27395 * central particle production, impact parameter biasing
27396 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
27398 * various options for treatment of partons (DTUNUC 1.x)
27399 * (chain recombination, Cronin,..)
27400 LOGICAL LCO2CR,LINTPT
27401 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
27404 * nucleon-nucleon event-generator
27407 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
27409 * flags for particle decays
27410 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
27411 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
27412 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
27414 * diquark-breaking mechanism
27415 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
27417 DIMENSION PP(4),PT(4)
27424 * initialize statistics counter
27437 * initialize rejection counter
27468 * statistics counter
27470 1000 FORMAT(/,/,1X,'STATIS:',20X,'statistics of the run',/,
27471 & 28X,'---------------------')
27472 IF (ICREQU.GT.0) THEN
27473 WRITE(LOUT,1001) ICREQU,ICSAMP,DBLE(ICSAMP)/DBLE(ICREQU)
27474 1001 FORMAT(/,1X,'number of events requested / sampled',13X,
27475 & I8,' / ',I8,/,1X,'number of samp. evts per requested ',
27476 & 'event',11X,F9.1)
27478 IF (ICDIFF(1).NE.0) THEN
27479 WRITE(LOUT,1009) ICDIFF
27480 1009 FORMAT(/,1X,'diffractive events: total ',I8,/,49X,
27481 & 'low mass high mass',/,24X,'single diffraction',
27482 & 7X,I8,4X,I8,/,24X,'double diffraction',7X,I8,4X,I8)
27484 IF (ICENTR.GT.0.AND.ICSAMP.GT.0.AND.ICCPRO.GT.0) THEN
27485 WRITE(LOUT,1002) DBLE(ICCPRO)/DBLE(ICSAMP),
27486 & DBLE(ICSAMP)/DBLE(ICCPRO)
27487 1002 FORMAT(/,1X,'central production:',/,2X,'mean number',
27488 & ' of sampled Glauber-events per event',9X,F9.1,/,
27489 & 2X,'fraction of production cross section',21X,F10.6)
27491 IF (ICSAMP.GT.0) THEN
27492 WRITE(LOUT,1003) DBLE(ICDPR)/DBLE(ICSAMP),
27493 & DBLE(ICDTA)/DBLE(ICSAMP)
27494 1003 FORMAT(/,54X,'proj. targ.',/,1X,'average number of wounded',
27495 & ' nucleons after x-sampling',2(4X,F6.2))
27498 IF (MCGENE.EQ.1) THEN
27499 IF (ICSAMP.GT.0) THEN
27500 WRITE(LOUT,1004) DBLE(ICRJSS)/DBLE(ICSAMP)
27501 1004 FORMAT(/,1X,'mean number of sea-sea chain rejections per',
27502 & ' event',3X,F9.1)
27503 IF (ISICHA.EQ.1) THEN
27504 WRITE(LOUT,1005) DBLE(ICVV2S)/DBLE(ICSAMP)
27505 1005 FORMAT(/,1X,'Reggeon contribution:',/,1X,'mean number ',
27506 & 'of single chains per event',13X,F9.1)
27509 IF (ICSAMP.GT.0.AND.ICREQU.GT.0) THEN
27511 1006 FORMAT(/,1X,'chain system statistics: (per event)',/,
27512 & 23X,'mean number of chains mean number of chains',/,
27513 & 23X,'sampled hadronized having mass of a reso.')
27514 WRITE(LOUT,1007) (DBLE(ICCHAI(1,J))/(2.0D0*DBLE(ICSAMP)),
27515 & DBLE(ICCHAI(2,J))/(2.0D0*DBLE(ICREQU)),
27516 & DBLE(ICRES(J))/(2.0D0*DBLE(ICREQU)),J=1,8),
27517 & DBLE(ICCHAI(2,9))/MAX(DBLE(ICCHAI(1,9)),TINY3)
27518 1007 FORMAT(1X,'sea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27519 & 1X,'disea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27520 & 1X,'sea - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27521 & 1X,'sea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27522 & 1X,'disea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27523 & 1X,'valence - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27524 & 1X,'valence - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27525 & 1X,'valence - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27526 & 1X,'fused chains ',18X,F4.1,17X,F4.1,/)
27528 & (DBLE(IRCRON(I))/MAX(DBLE(IRCRON(1)),TINY3),I=2,3),
27529 & DBLE(IRPT)/DBLE(ICREQU),(DBLE(IRRES(I))/DBLE(ICREQU),I=1,2),
27530 & DBLE(LOMRES)/DBLE(ICREQU),DBLE(LOBRES)/DBLE(ICREQU),
27531 & (DBLE(IRCHKI(I))/DBLE(ICREQU),I=1,2),
27532 & (DBLE(IRDIFF(I))/DBLE(ICREQU),I=1,2),
27533 & DBLE(IRHHA)/DBLE(ICREQU),
27534 & DBLE(IRFRAG)/DBLE(ICREQU),DBLE(IREVT)/DBLE(ICREQU),
27535 & (DBLE(IREXCI(I))/DBLE(ICREQU),I=1,2),IREXCI(3)
27536 1008 FORMAT(/,1X,'Rejection counter: (NEVT = no. of events)',/,/,
27537 & 1X,'Cronin-effect (CRONIN)',15X,'IRCRON(2)/IRCRON(1) = ',
27538 & F7.2,/,38X,'IRCRON(3)/IRCRON(1) = ',F7.2,/,1X,
27539 & 'Intrins. p_t (GETSPT)',21X,'IRPT /NEVT = ',F7.2,/,
27540 & 1X,'Chain mass corr. for resonances (EVTRES)',2X,
27541 & 'IRRES(1) /NEVT = ',F7.2,/,33X,'(CH2RES) IRRES(2) /',
27542 & 'NEVT = ',F7.2,/,43X,'LOMRES /NEVT = ',F7.2,/,
27543 & 43X,'LOBRES /NEVT = ',F7.2,/,1X,'Kinem. corr. of',
27544 & ' 2-chain systems (CHKINE) IRCHKI(1)/NEVT = ',F7.2,/,
27545 & 43X,'IRCHKI(2)/NEVT = ',F7.2,/,1X,'Diffraction',31X,
27546 & 'IRDIFF(1)/NEVT = ',F7.2,/,43X,'IRDIFF(2)/NEVT = ',
27547 & F7.2,/,1X,'Total no. of rej.',
27548 & ' in chain-systems treatment (GETCSY)',/,43X,
27549 & 'IRHHA /NEVT = ',F7.2,/,1X,'Fragmentation (EVTFRA)',
27550 & ' (not yet used!)',4X,'IRFRAG /NEVT = ',F7.2,/,
27551 & 1X,'Total no. of rej. in DPM-treatment of one event',
27552 & ' (EVENTA)',/,43X,'IREVT /NEVT = ',F7.2,/,1X,
27553 & 'Treatment of final nucleon conf.',10X,'IREXCI(1)/NEVT = '
27554 & ,F7.2,/,43X,'IREXCI(2)/NEVT = ',F7.2,/,48X,
27555 & 'IREXCI(3) = ',I5,/)
27557 ELSEIF (MCGENE.EQ.2) THEN
27558 WRITE(LOUT,1010) ELOJET
27559 1010 FORMAT(/,/,1X,'PHOJET-treatment of chain systems above ',
27562 1011 FORMAT(/,1X,'1. chain system statistics - total numbers:',/,
27563 & 30X,'--------------',/,/,12X,'s-s',5X,'d-s',5X,'s-d',
27564 & 5X,'s-v',5X,'d-v',5X,'v-s',5X,'v-d',5X,'v-v')
27565 WRITE(LOUT,1012) ((ICEVTG(I,J),I=1,8),J=0,1),
27566 & (INT(ICCHAI(2,I)/2.0D0),I=1,8),
27567 & (ICEVTG(I,2),I=1,8),(ICEVTG(I,29),I=1,8),
27568 & ((ICEVTG(I,J),I=1,8),J=3,7),
27569 & ((ICEVTG(I,J),I=1,8),J=19,21),
27570 & (ICEVTG(I,8),I=1,8),
27571 & ((ICEVTG(I,J),I=1,8),J=22,24),
27572 & (ICEVTG(I,9),I=1,8),
27573 & ((ICEVTG(I,J),I=1,8),J=25,28),
27574 & ((ICEVTG(I,J),I=1,8),J=10,18)
27575 1012 FORMAT(/,1X,'req.to.',8I8,/,/,1X,'low rq.',8I8,/,1X,'low ac.',
27576 & 8I8,/,/,1X,'PHOJET ',8I8,/,' sngl ',8I8,/,/,
27577 & ' no-dif.',8I8,/,
27578 & ' el-sca.',8I8,/,' qel-sc.',8I8,/,' dbl-Po.',8I8,/,
27579 & ' diff-1 ',8I8,/,' low ',8I8,/,' high ',8I8,/,
27580 & ' h-diff',8I8,/,' diff-2 ',8I8,/,' low ',8I8,/,
27581 & ' high ',8I8,/,' h-diff',8I8,/,' dbl-di.',8I8,/,
27582 & ' lo-lo ',8I8,/,' hi-hi ',8I8,/,' lo-hi ',8I8,/,
27584 & ' dir-ga.',8I8,/,/,' dir-1 ',8I8,/,' dir-2 ',8I8,/,
27585 & ' dbl-dir',8I8,/,' s-Pom. ',8I8,/,' h-Pom. ',8I8,/,
27586 & ' s-Reg. ',8I8,/,' enh-trg',8I8,/,' enh-log',8I8)
27588 1013 FORMAT(/,1X,'2. chain system statistics -',
27589 & ' mean numbers per evt:',/,30X,'---------------------',
27590 & /,/,16X,'s-s',7X,'d-s',7X,'s-d')
27591 IF (ICSAMP.GT.0) THEN
27593 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=0,1),
27594 & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=1,3),
27595 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=2,18)
27596 1014 FORMAT(/,1X,'req.to. ',3E10.2,/,/,1X,'low rq. ',3E10.2,/,
27597 & 1X,'low ac. ',3E10.2,/,/,1X,'PHOJET ',3E10.2,/,/,
27598 & ' no-dif. ',3E10.2,/,' el-sca. ',3E10.2,/,
27599 & ' qel-sc. ',3E10.2,/,' dbl-Po. ',3E10.2,/,
27600 & ' diff-1 ',3E10.2,/,' diff-2 ',3E10.2,/,
27601 & ' dbl-di. ',3E10.2,/,' dir-ga. ',3E10.2,/,/,
27602 & ' dir-1 ',3E10.2,/,' dir-2 ',3E10.2,/,
27603 & ' dbl-dir ',3E10.2,/,' s-Pom. ',3E10.2,/,
27604 & ' h-Pom. ',3E10.2,/,' s-Reg. ',3E10.2,/,
27605 & ' enh-trg ',3E10.2,/,' enh-log ',3E10.2)
27608 1015 FORMAT(/,16X,'s-v',7X,'d-v',7X,'v-s',7X,'v-d',7X,'v-v')
27609 IF (ICSAMP.GT.0) THEN
27611 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=0,1),
27612 & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=4,8),
27613 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=2,18)
27614 1016 FORMAT(/,1X,'req.to. ',5E10.2,/,/,1X,'low rq. ',5E10.2,/,
27615 & 1X,'low ac. ',5E10.2,/,/,1X,'PHOJET ',5E10.2,/,/,
27616 & ' no-dif. ',5E10.2,/,' el-sca. ',5E10.2,/,
27617 & ' qel-sc. ',5E10.2,/,' dbl-Po. ',5E10.2,/,
27618 & ' diff-1 ',5E10.2,/,' diff-2 ',5E10.2,/,
27619 & ' dbl-di. ',5E10.2,/,' dir-ga. ',5E10.2,/,/,
27620 & ' dir-1 ',5E10.2,/,' dir-2 ',5E10.2,/,
27621 & ' dbl-dir ',5E10.2,/,' s-Pom. ',5E10.2,/,
27622 & ' h-Pom. ',5E10.2,/,' s-Reg. ',5E10.2,/,
27623 & ' enh-trg ',5E10.2,/,' enh-log ',5E10.2)
27629 IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
27630 & .OR.(PDBSEA(3).GT.0.0D0)) THEN
27631 WRITE(LOUT,*)'YGS1S,YGS2S,YUS1S,YUS2S',
27632 & DBRKA(1,1)+DBRKA(2,1),DBRKA(1,2)+DBRKA(2,2),
27633 & DBRKA(1,3)+DBRKA(2,3),DBRKA(1,4)+DBRKA(2,4)
27634 WRITE(LOUT,*)'YGS1R,YGS2R,YUS1R,YUS2R',
27635 & DBRKR(1,1)+DBRKR(2,1),DBRKR(1,2)+DBRKR(2,2),
27636 & DBRKR(1,3)+DBRKR(2,3),DBRKR(1,4)+DBRKR(2,4)
27637 WRITE(LOUT,*)'YGSA1S,YGSA2S,YUSA1S,YUSA2S',
27638 & DBRKA(1,5)+DBRKA(2,5),DBRKA(1,6)+DBRKA(2,6),
27639 & DBRKA(1,7)+DBRKA(2,7),DBRKA(1,8)+DBRKA(2,8)
27640 WRITE(LOUT,*)'YGSA1R,YGSA2R,YUSA1R,YUSA2R',
27641 & DBRKR(1,5)+DBRKR(2,5),DBRKR(1,6)+DBRKR(2,6),
27642 & DBRKR(1,7)+DBRKR(2,7),DBRKR(1,8)+DBRKR(2,8)
27643 WRITE(LOUT,*)'YG31S,YG32S,YU31S,YU32S',
27644 & DBRKA(3,1),DBRKA(3,2),
27645 & DBRKA(3,3),DBRKA(3,4)
27646 WRITE(LOUT,*)'YG31R,YG32R,YU31R,YU32R',
27647 & DBRKR(3,1),DBRKR(3,2),
27648 & DBRKR(3,3),DBRKR(3,4)
27649 WRITE(LOUT,*)'YG3A1S,YG3A2S,YU3A1S,YU3A2S',
27650 & DBRKA(3,5),DBRKA(3,6),
27651 & DBRKA(3,7),DBRKA(3,8)
27652 WRITE(LOUT,*)'YG3A1R,YG3A2R,YU3A1R,YU3A2R',
27653 & DBRKR(3,5),DBRKR(3,6),
27654 & DBRKR(3,7),DBRKR(3,8)
27658 IF (MCGENE.EQ.2) THEN
27660 C CALL PHO_PHIST(-2,SIGMAX)
27661 CALL PHO_EVENT(-2,PP,PT,FAC,IREJ1)
27670 *$ CREATE DT_EVTOUT.FOR
27673 *===evtout=============================================================*
27675 SUBROUTINE DT_EVTOUT(MODE)
27677 ************************************************************************
27678 * MODE = 1 plot content of complete DTEVT1 to out. unit *
27679 * 3 plot entries of extended DTEVT1 (DTEVT2) *
27680 * 4 plot entries of DTEVT1 and DTEVT2 *
27681 * This version dated 11.12.94 is written by S. Roesler *
27682 ************************************************************************
27684 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27687 PARAMETER ( LINP = 10 ,
27693 PARAMETER (NMXHKK=200000)
27695 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27696 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27697 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27699 DIMENSION IRANGE(NMXHKK)
27701 IF (MODE.EQ.2) RETURN
27703 CALL DT_EVTPLO(IRANGE,MODE)
27708 *$ CREATE DT_EVTPLO.FOR
27711 *===evtplo=============================================================*
27713 SUBROUTINE DT_EVTPLO(IRANGE,MODE)
27715 ************************************************************************
27716 * MODE = 1 plot content of complete DTEVT1 to out. unit *
27717 * 2 plot entries of DTEVT1 given by IRANGE *
27718 * 3 plot entries of extended DTEVT1 (DTEVT2) *
27719 * 4 plot entries of DTEVT1 and DTEVT2 *
27720 * 5 plot rejection counter *
27721 * This version dated 11.12.94 is written by S. Roesler *
27722 ************************************************************************
27724 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27727 PARAMETER ( LINP = 10 ,
27735 PARAMETER (NMXHKK=200000)
27737 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27738 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27739 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27741 * extended event history
27742 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27743 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27746 * rejection counter
27747 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27748 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27749 & IREXCI(3),IRDIFF(2),IRINC
27751 DIMENSION IRANGE(NMXHKK)
27753 IF ((MODE.EQ.1).OR.(MODE.EQ.4)) THEN
27755 1000 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTEVT1/',/,
27756 & 15X,' --------------------------',/,/,
27757 & ' ST ID M1 M2 D1 D2 PX PY',
27760 WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27761 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27762 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
27764 C WRITE(LOUT,1011) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27765 C & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27766 C & PHKK(3,I),PHKK(4,I)
27767 C WRITE(LOUT,'(4E15.4)')
27768 C & VHKK(1,I),VHKK(2,I),VHKK(3,I),VHKK(4,I)
27769 1001 FORMAT(I5,I5,I6,4I5,3F7.3,F8.3,F8.4)
27770 1011 FORMAT(I5,I5,I6,4I5,2E15.5)
27774 C WRITE(LOUT,1006) I,ISTHKK(I),
27775 C & VHKK(1,I),VHKK(2,I),VHKK(3,I),WHKK(1,I),
27776 C & WHKK(2,I),WHKK(3,I)
27777 C1006 FORMAT(1X,I4,I6,6E10.3)
27781 IF (MODE.EQ.2) THEN
27786 IF (IRANGE(NC).EQ.-100) GOTO 9999
27788 WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27789 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27790 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
27795 IF ((MODE.EQ.3).OR.(MODE.EQ.4)) THEN
27797 1002 FORMAT(/,1X,'EVTPLO:',14X,
27798 & ' content of COMMON /DTEVT1/,/DTEVT2/',/,
27799 & 15X,' -----------------------------------',/,/,
27800 & ' ST ID M1 M2 D1 D2 IDR IDXR',
27801 & ' NOBAM IDCH M',/)
27803 C IF ((ISTHKK(I).GT.10).OR.(ISTHKK(I).EQ.1)) THEN
27806 IF ((((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
27807 & (KF.NE.80000)).OR.(IDHKK(I).EQ.99999)) KF = 92
27809 CALL PYNAME(KF,CHAU)
27811 WRITE(LOUT,1003) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27812 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27813 & IDRES(I),IDXRES(I),NOBAM(I),IDCH(I),
27815 1003 FORMAT(I5,I5,I6,4I5,4I4,F8.4,2X,A)
27820 IF (MODE.EQ.5) THEN
27822 1004 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTREJC/',/,
27823 & 15X,' --------------------------',/)
27824 WRITE(LOUT,1005) IRPT,IRHHA,IRRES,LOMRES,LOBRES,IREMC,IRFRAG,
27826 1005 FORMAT(1X,'IRPT = ',I5,' IRHHA = ',I5,/,
27827 & 1X,'IRRES = ',2I5,' LOMRES = ',I5,' LOBRES = ',I5,/,
27828 & 1X,'IREMC = ',10I5,/,
27829 & 1X,'IRFRAG = ',I5,' IRSEA = ',I5,' IRCRON = ',I5,/)
27835 *$ CREATE DT_EVTPUT.FOR
27838 *===evtput=============================================================*
27840 SUBROUTINE DT_EVTPUT(IST,ID,M1,M2,PX,PY,PZ,E,IDR,IDXR,IDC)
27842 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27845 PARAMETER ( LINP = 10 ,
27849 PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,TINY3=1.0D-3,
27850 & TINY2=1.0D-2,SQTINF=1.0D+15,ZERO=0.0D0)
27854 PARAMETER (NMXHKK=200000)
27856 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27857 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27858 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27860 * extended event history
27861 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27862 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27865 * Lorentz-parameters of the current interaction
27866 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
27867 & UMO,PPCM,EPROJ,PPROJ
27869 * particle properties (BAMJET index convention)
27871 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
27872 & IICH(210),IIBAR(210),K1(210),K2(210)
27874 C IF (MODE.GT.100) THEN
27875 C WRITE(LOUT,'(1X,A,I5,A,I5)')
27876 C & 'EVTPUT: reset NHKK = ',NHKK,' to NHKK =',NHKK-MODE+100
27877 C NHKK = NHKK-MODE+100
27884 IF (NHKK.GT.NMXHKK) THEN
27885 WRITE(LOUT,1000) NHKK
27886 1000 FORMAT(1X,'EVTPUT: NHKK exeeds NMXHKK = ',I7,
27887 & '! program execution stopped..')
27890 IF (M1.LT.0) MO1 = NHKK+M1
27891 IF (M2.LT.0) MO2 = NHKK+M2
27894 JMOHKK(1,NHKK) = MO1
27895 JMOHKK(2,NHKK) = MO2
27899 IDXRES(NHKK) = IDXR
27901 ** here we need to do something..
27902 IF (ID.EQ.88888) THEN
27903 IDMO1 = ABS(IDHKK(MO1))
27904 IDMO2 = ABS(IDHKK(MO2))
27905 IF ((IDMO1.LT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 3
27906 IF ((IDMO1.LT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 4
27907 IF ((IDMO1.GT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 5
27908 IF ((IDMO1.GT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 6
27912 IDBAM(NHKK) = IDT_ICIHAD(ID)
27914 IF (JDAHKK(1,MO1).NE.0) THEN
27915 JDAHKK(2,MO1) = NHKK
27917 JDAHKK(1,MO1) = NHKK
27921 IF (JDAHKK(1,MO2).NE.0) THEN
27922 JDAHKK(2,MO2) = NHKK
27924 JDAHKK(1,MO2) = NHKK
27927 C IF ((IDBAM(NHKK).GT.0).AND.(IDBAM(NHKK).NE.7)) THEN
27928 C PTOT = SQRT(PX**2+PY**2+PZ**2)
27929 C AM0 = SQRT(ABS( (E-PTOT)*(E+PTOT) ))
27930 C AMRQ = AAM(IDBAM(NHKK))
27931 C AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
27932 C IF ((ABS(AMDIF2).GT.TINY3).AND.(E.LT.SQTINF).AND.
27933 C & (PTOT.GT.ZERO)) THEN
27934 C DELTA = -AMDIF2/(2.0D0*(E+PTOT))
27935 CC DELTA = (AMRQ2-AM2)/(2.0D0*(E+PTOT))
27937 C PTOT1 = PTOT-DELTA
27938 C PX = PX*PTOT1/PTOT
27939 C PY = PY*PTOT1/PTOT
27940 C PZ = PZ*PTOT1/PTOT
27947 PTOT = SQRT( PX**2+PY**2+PZ**2 )
27948 IF ((IDHKK(NHKK).GE.22).AND.(IDHKK(NHKK).LE.24)) THEN
27949 PHKK(5,NHKK) = PHKK(4,NHKK)**2-PTOT**2
27950 PHKK(5,NHKK) = SIGN(SQRT(ABS(PHKK(5,NHKK))),PHKK(5,NHKK))
27952 PHKK(5,NHKK) = (PHKK(4,NHKK)-PTOT)*(PHKK(4,NHKK)+PTOT)
27953 C IF ((PHKK(5,NHKK).LT.0.0D0).AND.(ABS(PHKK(5,NHKK)).GT.TINY4))
27954 C & WRITE(LOUT,'(1X,A,G10.3)')
27955 C & 'EVTPUT: negative mass**2 ',PHKK(5,NHKK)
27956 PHKK(5,NHKK) = SQRT(ABS(PHKK(5,NHKK)))
27959 IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.(ID.NE.80000)) THEN
27960 * special treatment for chains:
27961 * z coordinate of chain in Lab = pos. of target nucleon
27962 * time of chain-creation in Lab = time of passage of projectile
27963 * nucleus at pos. of taget nucleus
27964 C VHKK(1,NHKK) = 0.5D0*(VHKK(1,MO1)+VHKK(1,MO2))
27965 C VHKK(2,NHKK) = 0.5D0*(VHKK(2,MO1)+VHKK(2,MO2))
27966 VHKK(1,NHKK) = VHKK(1,MO2)
27967 VHKK(2,NHKK) = VHKK(2,MO2)
27968 VHKK(3,NHKK) = VHKK(3,MO2)
27969 VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
27970 C WHKK(1,NHKK) = 0.5D0*(WHKK(1,MO1)+WHKK(1,MO2))
27971 C WHKK(2,NHKK) = 0.5D0*(WHKK(2,MO1)+WHKK(2,MO2))
27972 WHKK(1,NHKK) = WHKK(1,MO1)
27973 WHKK(2,NHKK) = WHKK(2,MO1)
27974 WHKK(3,NHKK) = WHKK(3,MO1)
27975 WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
27979 VHKK(I,NHKK) = VHKK(I,MO1)
27980 WHKK(I,NHKK) = WHKK(I,MO1)
27984 VHKK(I,NHKK) = ZERO
27985 WHKK(I,NHKK) = ZERO
27993 *$ CREATE DT_CHASTA.FOR
27996 *===chasta=============================================================*
27998 SUBROUTINE DT_CHASTA(MODE)
28000 ************************************************************************
28001 * This subroutine performs CHAin STAtistics and checks sequence of *
28002 * partons in dtevt1 and sorts them with projectile partons coming *
28003 * first if necessary. *
28005 * This version dated 8.5.00 is written by S. Roesler. *
28006 ************************************************************************
28008 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28011 PARAMETER ( LINP = 10 ,
28019 PARAMETER (NMXHKK=200000)
28021 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28022 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28023 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28025 * extended event history
28026 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28027 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28030 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
28031 PARAMETER (MAXCHN=10000)
28032 COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
28034 DIMENSION ICHCFG(10,10,9,2),ICHTYP(5,5),
28035 & CCHTYP(9),ICHSTA(10),ITOT(10)
28036 DATA ICHCFG /1800*0/
28037 DATA (ICHTYP(1,K),K=1,5) / 0, 1, 3, 0, 0/
28038 DATA (ICHTYP(2,K),K=1,5) / 2, 0, 0, 5, 0/
28039 DATA (ICHTYP(3,K),K=1,5) / 4, 0, 0, 7, 0/
28040 DATA (ICHTYP(4,K),K=1,5) / 0, 6, 8, 0, 0/
28041 DATA (ICHTYP(5,K),K=1,5) / 0, 0, 0, 0, 9/
28042 DATA ICHSTA / 21, 22, 31, 32, 41, 42, 51, 52, 61, 62/
28043 DATA CCHTYP / ' q aq','aq q ',' q d ',' d q ','aq ad',
28044 & 'ad aq',' d ad','ad d ',' g g '/
28048 IF (MODE.EQ.-1) THEN
28051 * loop over DTEVT1 and analyse chain configurations
28053 ELSEIF (MODE.EQ.0) THEN
28054 DO 21 IDX=NPOINT(3),NHKK
28055 IDCHK = IDHKK(IDX)/10000
28056 IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
28057 & (IDHKK(IDX).NE.80000).AND.
28058 & (ISTHKK(IDX).NE.2).AND.(IDRES(IDX).EQ.0)) THEN
28059 IF (JMOHKK(1,IDX).GT.JMOHKK(2,IDX)) THEN
28060 WRITE(LOUT,*) ' CHASTA: JMOHKK(1,x) > JMOHKK(2,x) ',
28065 IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28066 IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28068 IMO1 = IST1-10*IMO1
28070 IMO2 = IST2-10*IMO2
28071 * swop parton entries if necessary since we need projectile partons
28072 * to come first in the common
28073 IF (IMO1.GT.IMO2) THEN
28074 NPTN = JMOHKK(2,IDX)-JMOHKK(1,IDX)+1
28076 I0 = JMOHKK(1,IDX)-1+K
28077 I1 = JMOHKK(2,IDX)+1-K
28079 ISTHKK(I0) = ISTHKK(I1)
28082 IDHKK(I0) = IDHKK(I1)
28084 IF (JDAHKK(1,JMOHKK(1,I0)).EQ.I0)
28085 & JDAHKK(1,JMOHKK(1,I0)) = I1
28086 IF (JDAHKK(2,JMOHKK(1,I0)).EQ.I0)
28087 & JDAHKK(2,JMOHKK(1,I0)) = I1
28088 IF (JDAHKK(1,JMOHKK(2,I0)).EQ.I0)
28089 & JDAHKK(1,JMOHKK(2,I0)) = I1
28090 IF (JDAHKK(2,JMOHKK(2,I0)).EQ.I0)
28091 & JDAHKK(2,JMOHKK(2,I0)) = I1
28092 IF (JDAHKK(1,JMOHKK(1,I1)).EQ.I1)
28093 & JDAHKK(1,JMOHKK(1,I1)) = I0
28094 IF (JDAHKK(2,JMOHKK(1,I1)).EQ.I1)
28095 & JDAHKK(2,JMOHKK(1,I1)) = I0
28096 IF (JDAHKK(1,JMOHKK(2,I1)).EQ.I1)
28097 & JDAHKK(1,JMOHKK(2,I1)) = I0
28098 IF (JDAHKK(2,JMOHKK(2,I1)).EQ.I1)
28099 & JDAHKK(2,JMOHKK(2,I1)) = I0
28100 ITMP = JMOHKK(1,I0)
28101 JMOHKK(1,I0) = JMOHKK(1,I1)
28102 JMOHKK(1,I1) = ITMP
28103 ITMP = JMOHKK(2,I0)
28104 JMOHKK(2,I0) = JMOHKK(2,I1)
28105 JMOHKK(2,I1) = ITMP
28106 ITMP = JDAHKK(1,I0)
28107 JDAHKK(1,I0) = JDAHKK(1,I1)
28108 JDAHKK(1,I1) = ITMP
28109 ITMP = JDAHKK(2,I0)
28110 JDAHKK(2,I0) = JDAHKK(2,I1)
28111 JDAHKK(2,I1) = ITMP
28116 PHKK(J,I0) = PHKK(J,I1)
28117 VHKK(J,I0) = VHKK(J,I1)
28118 WHKK(J,I0) = WHKK(J,I1)
28124 PHKK(5,I0) = PHKK(5,I1)
28127 IDRES(I0) = IDRES(I1)
28130 IDXRES(I0) = IDXRES(I1)
28133 NOBAM(I0) = NOBAM(I1)
28136 IDBAM(I0) = IDBAM(I1)
28139 IDCH(I0) = IDCH(I1)
28142 IHIST(1,I0) = IHIST(1,I1)
28145 IHIST(2,I0) = IHIST(2,I1)
28149 IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28150 IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28152 * parton 1 (projectile side)
28153 IF (IST1.EQ.21) THEN
28155 ELSEIF (IST1.EQ.22) THEN
28157 ELSEIF (IST1.EQ.31) THEN
28159 ELSEIF (IST1.EQ.32) THEN
28161 ELSEIF (IST1.EQ.41) THEN
28163 ELSEIF (IST1.EQ.42) THEN
28165 ELSEIF (IST1.EQ.51) THEN
28167 ELSEIF (IST1.EQ.52) THEN
28169 ELSEIF (IST1.EQ.61) THEN
28171 ELSEIF (IST1.EQ.62) THEN
28175 c & ' CHASTA: unknown parton status flag (',
28176 c & IST1,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28179 ID = IDHKK(JMOHKK(1,IDX))
28180 IF (ABS(ID).LE.4) THEN
28186 ELSEIF (ABS(ID).GE.1000) THEN
28192 ELSEIF (ID.EQ.21) THEN
28196 & ' CHASTA: inconsistent parton identity (',
28197 & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28201 * parton 2 (target side)
28202 IF (IST2.EQ.21) THEN
28204 ELSEIF (IST2.EQ.22) THEN
28206 ELSEIF (IST2.EQ.31) THEN
28208 ELSEIF (IST2.EQ.32) THEN
28210 ELSEIF (IST2.EQ.41) THEN
28212 ELSEIF (IST2.EQ.42) THEN
28214 ELSEIF (IST2.EQ.51) THEN
28216 ELSEIF (IST2.EQ.52) THEN
28218 ELSEIF (IST2.EQ.61) THEN
28220 ELSEIF (IST2.EQ.62) THEN
28224 c & ' CHASTA: unknown parton status flag (',
28225 c & IST2,') at entry ',JMOHKK(2,IDX),'(',IDX,')'
28228 ID = IDHKK(JMOHKK(2,IDX))
28229 IF (ABS(ID).LE.4) THEN
28235 ELSEIF (ABS(ID).GE.1000) THEN
28241 ELSEIF (ID.EQ.21) THEN
28245 & ' CHASTA: inconsistent parton identity (',
28246 & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28251 ITYPE = ICHTYP(ITYP1,ITYP2)
28252 IF (ITYPE.NE.0) THEN
28253 ICHCFG(IDX1,IDX2,ITYPE,1) =ICHCFG(IDX1,IDX2,ITYPE,1)+1
28254 NGLUON = JMOHKK(2,IDX)-JMOHKK(1,IDX)-1
28255 ICHCFG(IDX1,IDX2,ITYPE,2) =
28256 & ICHCFG(IDX1,IDX2,ITYPE,2)+NGLUON
28259 IF (NCHAIN.GT.MAXCHN) THEN
28260 WRITE(LOUT,*) ' CHASTA: NCHAIN > MAXCHN ! ',
28264 IDXCHN(1,NCHAIN) = IDX
28265 IDXCHN(2,NCHAIN) = ITYPE
28268 & ' CHASTA: inconsistent chain at entry ',IDX
28274 * write statistics to output unit
28276 ELSEIF (MODE.EQ.1) THEN
28277 WRITE(LOUT,'(/,A)') ' CHASTA: generated chain configurations'
28279 WRITE(LOUT,'(/,2A)')
28280 & ' -----------------------------------------',
28281 & '------------------------------------'
28283 & ' p\\t 21 22 31 32 41',
28284 & ' 42 51 52 61 62'
28286 & ' -----------------------------------------',
28287 & '------------------------------------'
28291 ITOT(J) = ITOT(J)+ICHCFG(I,J,K,1)
28294 WRITE(LOUT,'(1X,I2,5X,10I7,/)') ICHSTA(I),(ITOT(J),J=1,10)
28298 ISUM = ISUM+ICHCFG(I,J,K,1)
28301 & WRITE(LOUT,'(1X,A5,2X,10I7)')
28302 & CCHTYP(K),(ICHCFG(I,J,K,1),J=1,10)
28304 C WRITE(LOUT,'(2A)')
28305 C & ' -----------------------------------------',
28306 C & '-------------------------------'
28310 WRITE(LOUT,*) ' CHASTA: MODE ',MODE,' not supported !'
28316 *$ CREATE PHO_PHIST.FOR
28319 *===pohist=============================================================*
28321 SUBROUTINE PHO_PHIST(IMODE,WEIGHT)
28323 IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28326 PARAMETER ( LINP = 10 ,
28330 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
28332 * Glauber formalism: cross sections
28333 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
28334 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
28335 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
28336 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
28337 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
28338 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
28339 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
28340 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
28341 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
28342 & BSLOPE,NEBINI,NQBINI
28345 IF (IMODE.EQ.10) THEN
28349 IF (ABS(IMODE).LT.1000) THEN
28350 * PHOJET-statistics
28351 C CALL POHISX(IMODE,WEIGHT)
28352 IF (IMODE.EQ.-1) THEN
28354 XSTOT(1,1,1) = WEIGHT
28356 IF (IMODE.EQ. 1) MODE = 2
28357 IF (IMODE.EQ.-2) MODE = 3
28358 IF (MODE.EQ.2) CALL DT_SWPPHO(ILAB)
28359 C IF (MODE.EQ.3) WRITE(LOUT,*)
28360 C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization'
28361 CALL DT_HISTOG(MODE)
28362 CALL DT_USRHIS(MODE)
28364 * DTUNUC-statistics
28366 C IF (MODE.EQ.3) WRITE(LOUT,*)
28367 C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization'
28368 CALL DT_HISTOG(MODE)
28369 CALL DT_USRHIS(MODE)
28375 *$ CREATE DT_SWPPHO.FOR
28378 *===swppho=============================================================*
28380 SUBROUTINE DT_SWPPHO(ILAB)
28382 IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28385 PARAMETER ( LINP = 10 ,
28389 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28395 PARAMETER (NMXHKK=200000)
28397 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28398 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28399 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28401 * extended event history
28402 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28403 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28406 * flags for input different options
28407 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28408 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28409 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28411 * properties of photon/lepton projectiles
28412 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
28415 C PARAMETER (NMXHEP=2000)
28416 C COMMON/HEPEVS/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28417 C &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
28418 C COMMON /GLOCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28419 C COMMON /PLASAV/ PLAB
28421 C standard particle data interface
28424 PARAMETER (NMXHEP=4000)
28426 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28427 DOUBLE PRECISION PHEP,VHEP
28428 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28429 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28431 C extension to standard particle data interface (PHOJET specific)
28432 INTEGER IMPART,IPHIST,ICOLOR
28433 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28435 C global event kinematics and particle IDs
28436 INTEGER IFPAP,IFPAB
28437 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
28438 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28442 DATA LSTART /.TRUE./
28444 C IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0).AND.LSTART) THEN
28445 IF ((IFRAME.EQ.1).AND.LSTART) THEN
28449 IDP = IDT_ICIHAD(IFPAP(1))
28450 IDT = IDT_ICIHAD(IFPAP(2))
28452 CALL DT_LTINI(IDP,IDT,ELA,PLA,UMO,0)
28461 IF (MOD(ICOUNT,500).EQ.0) WRITE(LOUT,*)' SWPPHO: event # ',ICOUNT
28463 IF (ISTHEP(I).EQ.1) THEN
28466 IDHKK(NHKK) = IDHEP(I)
28472 PHKK(K,NHKK) = PHEP(K,I)
28473 VHKK(K,NHKK) = ZERO
28474 WHKK(K,NHKK) = ZERO
28476 IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0))
28477 & CALL DT_LTNUC(PHEP(3,I),PHEP(4,I),
28478 & PHKK(3,NHKK),PHKK(4,NHKK),-3)
28479 PHKK(5,NHKK) = PHEP(5,I)
28483 IDBAM(NHKK) = IDT_ICIHAD(IDHEP(I))
28491 *$ CREATE DT_HISTOG.FOR
28494 *===histog=============================================================*
28496 SUBROUTINE DT_HISTOG(MODE)
28498 ************************************************************************
28499 * This version dated 25.03.96 is written by S. Roesler *
28500 ************************************************************************
28502 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28505 PARAMETER ( LINP = 10 ,
28513 PARAMETER (NMXHKK=200000)
28515 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28516 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28517 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28519 * extended event history
28520 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28521 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28524 * event flag used for histograms
28525 COMMON /DTNORM/ ICEVT,IEVHKK
28527 * flags for activated histograms
28528 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
28533 *------------------------------------------------------------------
28537 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,1)
28538 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(1)
28541 *------------------------------------------------------------------
28542 * filling of histogram with event-record
28547 CALL DT_SWPFSP(I,LFSP,LRNL)
28549 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,2)
28550 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(2)
28552 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,5)
28554 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,4)
28557 *------------------------------------------------------------------
28560 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,3)
28561 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(3)
28566 *$ CREATE DT_SWPFSP.FOR
28569 *===swpfsp=============================================================*
28571 SUBROUTINE DT_SWPFSP(IDX,LFSP,LRNL)
28573 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28575 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28576 PARAMETER (TWOPI=6.283185307179586476925286766559D+00,
28578 & BOG =TWOPI/360.0D0)
28582 PARAMETER (NMXHKK=200000)
28584 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28585 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28586 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28588 * extended event history
28589 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28590 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28593 * particle properties (BAMJET index convention)
28595 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28596 & IICH(210),IIBAR(210),K1(210),K2(210)
28598 * Lorentz-parameters of the current interaction
28599 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28600 & UMO,PPCM,EPROJ,PPROJ
28602 * flags for input different options
28603 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28604 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28605 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28607 * INCLUDE '(DIMPAR)'
28609 PARAMETER ( MXXRGN =20000 )
28610 PARAMETER ( MXXMDF = 710 )
28611 PARAMETER ( MXXMDE = 702 )
28612 PARAMETER ( MFSTCK =40000 )
28613 PARAMETER ( MESTCK = 100 )
28614 PARAMETER ( MOSTCK = 2000 )
28615 PARAMETER ( MXPRSN = 100 )
28616 PARAMETER ( MXPDPM = 800 )
28617 PARAMETER ( MXPSCS =30000 )
28618 PARAMETER ( MXGLWN = 300 )
28619 PARAMETER ( MXOUTU = 50 )
28620 PARAMETER ( NALLWP = 64 )
28621 PARAMETER ( NELEMX = 80 )
28622 PARAMETER ( MPDPDX = 18 )
28623 PARAMETER ( MXHTTR = 260 )
28624 PARAMETER ( MXSEAX = 20 )
28625 PARAMETER ( MXHTNC = MXSEAX + 1 )
28626 PARAMETER ( ICOMAX = 2400 )
28627 PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
28628 PARAMETER ( NSTBIS = 304 )
28629 PARAMETER ( NQSTIS = 46 )
28630 PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
28631 PARAMETER ( MXPABL = 120 )
28632 PARAMETER ( IDMAXP = 450 )
28633 PARAMETER ( IDMXDC = 2000 )
28634 PARAMETER ( MXMCIN = 410 )
28635 PARAMETER ( IHYPMX = 4 )
28636 PARAMETER ( MKBMX1 = 11 )
28637 PARAMETER ( MKBMX2 = 11 )
28638 PARAMETER ( MXIRRD = 2500 )
28639 PARAMETER ( MXTRDC = 1500 )
28640 PARAMETER ( NKTL = 17 )
28641 PARAMETER ( NBLNMX = 40000000 )
28643 * INCLUDE '(PAREVT)'
28645 PARAMETER ( FRDIFF = 0.2D+00 )
28646 PARAMETER ( ETHSEA = 1.0D+00 )
28648 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
28649 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
28650 & LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR,
28651 & LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
28652 COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
28653 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
28654 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
28655 & LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LPHDRC,
28656 & LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, LRVKIN,
28657 & LVP2XX, LV2XNW, LNWV2X, LEVFIN
28659 * temporary storage for one final state particle
28660 LOGICAL LFRAG,LGREY,LBLACK
28661 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
28662 & SINTHE,COSTHE,THETA,THECMS,
28663 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
28664 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
28665 & LFRAG,LGREY,LBLACK
28673 IF (LEVPRT) ISTRNL = 1001
28675 IF (ABS(ISTHKK(IDX)).EQ.1) THEN
28679 IF (IDHKK(IDX).LT.80000) THEN
28681 IBARY = IIBAR(IDBJT)
28682 ICHAR = IICH(IDBJT)
28684 ELSEIF (IDHKK(IDX).EQ.80000) THEN
28687 ICHAR = IDXRES(IDX)
28688 AMASS = PHKK(5,IDX)
28690 IF ((ICHAR.EQ.1).AND.(INUT.EQ.1)) IDBJT = 116
28691 IF ((ICHAR.EQ.1).AND.(INUT.EQ.2)) IDBJT = 117
28692 IF ((ICHAR.EQ.2).AND.(INUT.EQ.1)) IDBJT = 118
28693 IF ((ICHAR.EQ.2).AND.(INUT.EQ.2)) IDBJT = 119
28694 IF (IDBJT.EQ.0) LFRAG = .TRUE.
28704 PTOT = SQRT(PT2+PZ**2)
28705 SINTHE = PT/MAX(PTOT,TINY14)
28706 COSTHE = PZ/MAX(PTOT,TINY14)
28707 IF (COSTHE.GT.ONE) THEN
28709 ELSEIF (COSTHE.LT.-ONE) THEN
28710 THETA = TWOPI/2.0D0
28712 THETA = ACOS(COSTHE)
28715 **sr 15.4.96 new E_t-definition
28716 IF (IBARY.GT.0) THEN
28718 ELSEIF (IBARY.LT.0) THEN
28719 ET = (EKIN+TWO*AMASS)*SINTHE
28724 XLAB = PZ/MAX(PPROJ,TINY14)
28725 C XLAB = PE/MAX(EPROJ,TINY14)
28726 BETA = SQRT(ABS( (ONE-AMASS/MAX(PE,TINY14))
28727 & *(ONE+AMASS/MAX(PE,TINY14)) ))
28730 IF (PMINUS.GT.TINY14) THEN
28731 YY = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28735 IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
28736 ETA = -LOG(TAN(THETA/TWO))
28740 IF (IFRAME.EQ.1) THEN
28741 CALL DT_LTNUC(PZ,PE,PZCMS,EECMS,3)
28742 PPLUS = EECMS+PZCMS
28743 PMINUS = EECMS-PZCMS
28744 IF ((PPLUS*PMINUS).GT.TINY14) THEN
28745 YYCMS = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28749 PTOTCM = SQRT(PT2+PZCMS**2)
28750 COSTH = PZCMS/MAX(PTOTCM,TINY14)
28751 IF (COSTH.GT.ONE) THEN
28753 ELSEIF (COSTH.LT.-ONE) THEN
28754 THECMS = TWOPI/2.0D0
28756 THECMS = ACOS(COSTH)
28758 IF ((THECMS.GT.TINY14).AND.((PI-THECMS).GT.TINY14)) THEN
28759 ETACMS = -LOG(TAN(THECMS/TWO))
28763 XF = PZCMS/MAX(PPCM,TINY14)
28764 THECMS = THECMS/BOG
28775 * set flag for "grey/black"
28779 IF (IDHKK(IDX).EQ.80000) EK = EKIN/DBLE(IBARY)
28780 IF (MULDEF.EQ.1) THEN
28782 IF ( ( (IDBJT.EQ. 1).AND.(EK.GT. 26.0D-3).AND.
28783 & (EK.LE.375.0D-3) ).OR.
28784 & ( (IDBJT.EQ.13).AND.(EK.GT. 12.0D-3).AND.
28785 & (EK.LE. 56.0D-3) ).OR.
28786 & ( (IDBJT.EQ.14).AND.(EK.GT. 12.0D-3).AND.
28787 & (EK.LE. 56.0D-3) ).OR.
28788 & ( (IDBJT.EQ.15).AND.(EK.GT. 20.0D-3).AND.
28789 & (EK.LE.198.0D-3) ).OR.
28790 & ( (IDBJT.EQ.16).AND.(EK.GT. 20.0D-3).AND.
28791 & (EK.LE.198.0D-3) ).OR.
28792 & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28793 & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28794 & (IDBJT.NE.16).AND.
28795 & (BETA.GT.0.23D0).AND.(BETA.LE.0.70D0) ) )
28797 IF ( ( (IDBJT.EQ. 1).AND.(EK.LE. 26.0D-3) ).OR.
28798 & ( (IDBJT.EQ.13).AND.(EK.LE. 12.0D-3) ).OR.
28799 & ( (IDBJT.EQ.14).AND.(EK.LE. 12.0D-3) ).OR.
28800 & ( (IDBJT.EQ.15).AND.(EK.LE. 20.0D-3) ).OR.
28801 & ( (IDBJT.EQ.16).AND.(EK.LE. 20.0D-3) ).OR.
28802 & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28803 & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28804 & (IDBJT.NE.16).AND.(BETA.LE.0.23D0) ) )
28808 IF ((BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)) LGREY=.TRUE.
28809 IF (BETA.LE.0.23D0) LBLACK=.TRUE.
28812 ELSEIF (ABS(ISTHKK(IDX)).EQ.ISTRNL) THEN
28818 ICHAR = IDXRES(IDX)
28819 AMASS = PHKK(5,IDX)
28826 PTOT = SQRT(PT2+PZ**2)
28827 SINTHE = PT/MAX(PTOT,TINY14)
28828 COSTHE = PZ/MAX(PTOT,TINY14)
28829 IF (COSTHE.GT.ONE) THEN
28831 ELSEIF (COSTHE.LT.-ONE) THEN
28832 THETA = TWOPI/2.0D0
28834 THETA = ACOS(COSTHE)
28837 **sr 15.4.96 new E_t-definition
28841 IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
28842 ETA = -LOG(TAN(THETA/TWO))
28854 *$ CREATE DT_HIMULT.FOR
28857 *===himult=============================================================*
28859 SUBROUTINE DT_HIMULT(MODE)
28861 ************************************************************************
28862 * Tables of average energies/multiplicities. *
28863 * This version dated 30.08.2000 is written by S. Roesler *
28864 ************************************************************************
28866 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28869 PARAMETER ( LINP = 10 ,
28873 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28875 PARAMETER (SWMEXP=1.7D0)
28877 CHARACTER*8 ANAMEH(4)
28879 * particle properties (BAMJET index convention)
28881 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28882 & IICH(210),IIBAR(210),K1(210),K2(210)
28884 * temporary storage for one final state particle
28885 LOGICAL LFRAG,LGREY,LBLACK
28886 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
28887 & SINTHE,COSTHE,THETA,THECMS,
28888 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
28889 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
28890 & LFRAG,LGREY,LBLACK
28892 * event flag used for histograms
28893 COMMON /DTNORM/ ICEVT,IEVHKK
28895 * Lorentz-parameters of the current interaction
28896 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28897 & UMO,PPCM,EPROJ,PPROJ
28899 PARAMETER (NOPART=210)
28900 DIMENSION AVMULT(4,NOPART),AVE(4,NOPART),AVSWM(4,NOPART),
28901 & AVPT(4,NOPART),IAVPT(4,NOPART)
28902 DATA ANAMEH /'DEUTERON','3-H ','3-HE ','4-HE '/
28906 *------------------------------------------------------------------
28921 *------------------------------------------------------------------
28922 * filling of histogram with event-record
28924 IF (PE.LT.0.0D0) THEN
28925 WRITE(LOUT,*) ' HIMULT: PE < 0 ! ',PE
28928 IF (.NOT.LFRAG) THEN
28930 IF (LGREY) IVEL = 3
28931 IF (LBLACK) IVEL = 4
28932 AVE(1,IDBJT) = AVE(1,IDBJT) +PE
28933 AVE(IVEL,IDBJT) = AVE(IVEL,IDBJT)+PE
28934 AVPT(1,IDBJT) = AVPT(1,IDBJT) +PT
28935 AVPT(IVEL,IDBJT) = AVPT(IVEL,IDBJT)+PT
28936 IAVPT(1,IDBJT) = IAVPT(1,IDBJT) +1
28937 IAVPT(IVEL,IDBJT) = IAVPT(IVEL,IDBJT)+1
28938 AVSWM(1,IDBJT) = AVSWM(1,IDBJT) +PE**SWMEXP
28939 AVSWM(IVEL,IDBJT) = AVSWM(IVEL,IDBJT)+PE**SWMEXP
28940 AVMULT(1,IDBJT) = AVMULT(1,IDBJT) +ONE
28941 AVMULT(IVEL,IDBJT) = AVMULT(IVEL,IDBJT)+ONE
28942 IF (IDBJT.LT.116) THEN
28943 * total energy, multiplicity
28944 AVE(1,30) = AVE(1,30) +PE
28945 AVE(IVEL,30) = AVE(IVEL,30)+PE
28946 AVPT(1,30) = AVPT(1,30) +PT
28947 AVPT(IVEL,30) = AVPT(IVEL,30)+PT
28948 IAVPT(1,30) = IAVPT(1,30) +1
28949 IAVPT(IVEL,30) = IAVPT(IVEL,30)+1
28950 AVSWM(1,30) = AVSWM(1,30)+PE**SWMEXP
28951 AVSWM(IVEL,30) = AVSWM(IVEL,30)+PE**SWMEXP
28952 AVMULT(1,30) = AVMULT(1,30) +ONE
28953 AVMULT(IVEL,30) = AVMULT(IVEL,30)+ONE
28954 * charged energy, multiplicity
28955 IF (ICHAR.LT.0) THEN
28956 AVE(1,26) = AVE(1,26) +PE
28957 AVE(IVEL,26) = AVE(IVEL,26)+PE
28958 AVPT(1,26) = AVPT(1,26) +PT
28959 AVPT(IVEL,26) = AVPT(IVEL,26)+PT
28960 IAVPT(1,26) = IAVPT(1,26) +1
28961 IAVPT(IVEL,26) = IAVPT(IVEL,26)+1
28962 AVSWM(1,26) = AVSWM(1,26) +PE**SWMEXP
28963 AVSWM(IVEL,26) = AVSWM(IVEL,26)+PE**SWMEXP
28964 AVMULT(1,26) = AVMULT(1,26) +ONE
28965 AVMULT(IVEL,26) = AVMULT(IVEL,26)+ONE
28967 IF (ICHAR.NE.0) THEN
28968 AVE(1,27) = AVE(1,27) +PE
28969 AVE(IVEL,27) = AVE(IVEL,27)+PE
28970 AVPT(1,27) = AVPT(1,27) +PT
28971 AVPT(IVEL,27) = AVPT(IVEL,27)+PT
28972 IAVPT(1,27) = IAVPT(1,27) +1
28973 IAVPT(IVEL,27) = IAVPT(IVEL,27)+1
28974 AVSWM(1,27) = AVSWM(1,27) +PE**SWMEXP
28975 AVSWM(IVEL,27) = AVSWM(IVEL,27)+PE**SWMEXP
28976 AVMULT(1,27) = AVMULT(1,27) +ONE
28977 AVMULT(IVEL,27) = AVMULT(IVEL,27)+ONE
28984 *------------------------------------------------------------------
28988 3000 FORMAT(/,1X,'HIMULT:',21X,'particle - statistics',/,
28989 & 29X,'---------------------',/)
28990 IF (MULDEF.EQ.1) THEN
28991 WRITE(LOUT,'(1X,A,/)') 'fast/grey/black: EMU-def.'
28995 WRITE(LOUT,3002) BETGRE,BETGRE,BETBLC,BETBLC
28996 3002 FORMAT(1X,'fast: beta > ',F4.2,' grey: ',F4.2,' > beta > '
28997 & ,F4.2,' black: beta < ',F4.2,/)
28999 WRITE(LOUT,3003) SWMEXP
29000 3003 FORMAT(1X,'particle |',12X,'average multiplicity',/,
29001 & 13X,'| total fast',
29002 C & ' grey black K f(',F3.1,')',/,1X,
29003 & ' grey black <pt> f(',F3.1,')',/,1X,
29004 & '------------+--------------',
29005 & '-------------------------------------------------')
29008 AVMULT(J,I) = AVMULT(J,I)/DBLE(MAX(ICEVT,1))
29009 AVE(J,I) = AVE(J,I)/DBLE(MAX(ICEVT,1))/EPROJ
29010 AVPT(J,I) = AVPT(J,I)/DBLE(MAX(IAVPT(J,I),1))
29011 AVSWM(J,I) = AVSWM(J,I)/DBLE(MAX(ICEVT,1))/EPROJ**SWMEXP
29014 WRITE(LOUT,3004) ANAME(I),I,
29015 & AVMULT(1,I),AVMULT(2,I),
29016 & AVMULT(3,I),AVMULT(4,I),
29017 C & AVE(1,I),AVSWM(1,I)
29018 & AVPT(1,I),AVSWM(1,I)
29019 ELSEIF (I.LE.119) THEN
29020 WRITE(LOUT,3004) ANAMEH(I-115),I,
29021 & AVMULT(1,I),AVMULT(2,I),
29022 & AVMULT(3,I),AVMULT(4,I),
29023 C & AVE(1,I),AVSWM(1,I)
29024 & AVPT(1,I),AVSWM(1,I)
29026 3004 FORMAT(1X,A8,I4,'| ',2F13.6,2F9.5,2F9.5)
29029 C WRITE(LOUT,'(A,F7.3)') ' number of charged heavy particles: ',
29030 C & AVMULT(3,27)+AVMULT(4,27)
29036 *$ CREATE DT_HISTAT.FOR
29039 *===histat=============================================================*
29041 SUBROUTINE DT_HISTAT(IDX,MODE)
29043 ************************************************************************
29044 * This version dated 26.02.96 is written by S. Roesler *
29046 * Last change 27.12.2006 by S. Roesler. *
29047 ************************************************************************
29049 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29052 PARAMETER ( LINP = 10 ,
29056 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
29057 PARAMETER (NDIM=199)
29061 PARAMETER (NMXHKK=200000)
29063 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
29064 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
29065 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
29067 * extended event history
29068 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
29069 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
29072 * particle properties (BAMJET index convention)
29074 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29075 & IICH(210),IIBAR(210),K1(210),K2(210)
29077 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
29079 * Glauber formalism: cross sections
29080 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
29081 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
29082 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
29083 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
29084 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
29085 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
29086 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
29087 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
29088 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
29089 & BSLOPE,NEBINI,NQBINI
29091 * emulsion treatment
29092 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
29095 * properties of interacting particles
29096 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
29098 * rejection counter
29099 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
29100 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
29101 & IREXCI(3),IRDIFF(2),IRINC
29103 * statistics: residual nuclei
29104 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
29105 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
29106 & NINCST(2,4),NINCEV(2),
29107 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
29108 & NRESPB(2),NRESCH(2),NRESEV(4),
29109 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
29112 * parameter for intranuclear cascade
29114 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
29116 * INCLUDE '(DIMPAR)'
29118 PARAMETER ( MXXRGN =20000 )
29119 PARAMETER ( MXXMDF = 710 )
29120 PARAMETER ( MXXMDE = 702 )
29121 PARAMETER ( MFSTCK =40000 )
29122 PARAMETER ( MESTCK = 100 )
29123 PARAMETER ( MOSTCK = 2000 )
29124 PARAMETER ( MXPRSN = 100 )
29125 PARAMETER ( MXPDPM = 800 )
29126 PARAMETER ( MXPSCS =30000 )
29127 PARAMETER ( MXGLWN = 300 )
29128 PARAMETER ( MXOUTU = 50 )
29129 PARAMETER ( NALLWP = 64 )
29130 PARAMETER ( NELEMX = 80 )
29131 PARAMETER ( MPDPDX = 18 )
29132 PARAMETER ( MXHTTR = 260 )
29133 PARAMETER ( MXSEAX = 20 )
29134 PARAMETER ( MXHTNC = MXSEAX + 1 )
29135 PARAMETER ( ICOMAX = 2400 )
29136 PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
29137 PARAMETER ( NSTBIS = 304 )
29138 PARAMETER ( NQSTIS = 46 )
29139 PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
29140 PARAMETER ( MXPABL = 120 )
29141 PARAMETER ( IDMAXP = 450 )
29142 PARAMETER ( IDMXDC = 2000 )
29143 PARAMETER ( MXMCIN = 410 )
29144 PARAMETER ( IHYPMX = 4 )
29145 PARAMETER ( MKBMX1 = 11 )
29146 PARAMETER ( MKBMX2 = 11 )
29147 PARAMETER ( MXIRRD = 2500 )
29148 PARAMETER ( MXTRDC = 1500 )
29149 PARAMETER ( NKTL = 17 )
29150 PARAMETER ( NBLNMX = 40000000 )
29152 * INCLUDE '(PAREVT)'
29154 PARAMETER ( FRDIFF = 0.2D+00 )
29155 PARAMETER ( ETHSEA = 1.0D+00 )
29157 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
29158 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
29159 & LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR,
29160 & LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
29161 COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
29162 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
29163 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
29164 & LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LPHDRC,
29165 & LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, LRVKIN,
29166 & LVP2XX, LV2XNW, LNWV2X, LEVFIN
29168 * INCLUDE '(FRBKCM)'
29170 * Maximum number of fragments to be emitted:
29171 PARAMETER ( MXFFBK = 6 )
29172 PARAMETER ( MXZFBK = 10 )
29173 PARAMETER ( MXNFBK = 12 )
29174 PARAMETER ( MXAFBK = 16 )
29175 PARAMETER ( MXASST = 25 )
29176 PARAMETER ( NXAFBK = MXAFBK + 1 )
29177 PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 + MXASST - NXAFBK )
29178 PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 + MXASST - NXAFBK )
29179 PARAMETER ( MXPSST = 700 )
29180 * Maximum number of pre-computed break-up combinations
29181 PARAMETER ( MXPPFB = 42500 )
29182 * Maximum number of break-up combinations, including special
29184 PARAMETER ( MXPSFB = 43000 )
29185 * Base for J multiplicity encoding:
29186 PARAMETER ( IBFRBK = 73 )
29187 * Maximum Ibfrbk exponent to avoid overflow of I*4(roughly at 2.1x10^9)
29188 * it must be (Ibfrbk-1) + (Ibfrbk-1)*Ibfrbk + (Ibfrbk-1)*Ibfrbk^2 + ...
29189 * ... + (Ibfrbk-1)*Ibfrbk^Jpwfbx < 2100000000,
29190 * --> Ibfrbk^(Jpwfbx+1) < 2100000000
29191 PARAMETER ( JPWFBX = 4 )
29192 LOGICAL LFRMBK, LNCMSS
29193 COMMON / FRBKCM / AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
29194 & WEIFBK (MXPSST), GAMFBK (MXPSST), EXFRBK (MXPSFB),
29195 & SDMFBK (MXPSFB), COUFBK (MXPSFB), CENFBK (MXPSFB),
29196 & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK, FRBKLS,
29197 & IFRBKN (MXPSST), IFRBKZ (MXPSST),
29198 & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
29199 & IPSIND (0:NXNFBK,0:NXZFBK,2), JPSIND (0:MXASST),
29200 & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
29201 & IFBCHA (9,MXPSFB), IPOSST, IPOSFB, IFBSTF, IFBPSF,
29202 & IFBFRB, IFBCHN, IFBNC1, IFBNC2, NBUFBK, LFRMBK, LNCMSS
29204 * INCLUDE '(EVAFLG)'
29206 LOGICAL LOLDEV, LUFULL, LNWLOW, LASMEN, LGMCMP, LGDRFT, LDSCLV,
29207 & LDSCGM, LNDSLD, LMNJPR, LBRPEN, LNWBRP, LIFKEY, LOLDSM,
29208 & LNAIPR, LGUSPR, LFLKCO, LLVMOD, LHVEVP, LHVECN, LHVCAL,
29209 & LHVRAL, LHVSGF, LTMCRR, LBZZCR, LQCSKP
29210 COMMON / EVAFLG / BRPNFR (0:2), EBRPFR (0:2), EMVBRP (0:2),
29211 & ILVMOD, JLVMOD, JSIPFL, IMSSFR, JMSSFR, IEVFSS, MXAHEV,
29212 & MXZHEV, IFHVFL, IFKYMX, IGMCMP, MPMODE, MSMODE, MUMODE,
29213 & MFMODE, MEMODE, MRMODE, ITMCRR, IASYCR, IFSBCR, IFSSBR,
29214 & LOLDEV, LUFULL, LNWLOW, LASMEN, LGMCMP, LGDRFT, LDSCLV,
29215 & LDSCGM, LNDSLD, LMNJPR, LBRPEN, LNWBRP, LIFKEY, LOLDSM,
29216 & LNAIPR, LGUSPR, LFLKCO, LLVMOD, LHVEVP, LHVECN, LHVCAL,
29217 & LHVRAL, LHVSGF, LTMCRR, LBZZCR, LQCSKP
29219 * temporary storage for one final state particle
29220 LOGICAL LFRAG,LGREY,LBLACK
29221 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
29222 & SINTHE,COSTHE,THETA,THECMS,
29223 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
29224 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
29225 & LFRAG,LGREY,LBLACK
29227 * event flag used for histograms
29228 COMMON /DTNORM/ ICEVT,IEVHKK
29230 * statistics: double-Pomeron exchange
29231 COMMON /DTFLG2/ INTFLG,IPOPO
29233 DIMENSION EMUSAM(NCOMPX)
29235 CHARACTER*13 CMSG(3)
29236 DATA CMSG /'not requested','not requested','not requested'/
29238 GOTO (1,2,3,4,5) MODE
29240 *------------------------------------------------------------------
29243 * emulsion treatment
29244 IF (NCOMPO.GT.0) THEN
29249 * common /DTSTA2/, statistics on i.n.c., residual nuclei, evap.
29270 IF (J.LE.2) NINCHR(I,J) = 0
29271 IF (J.LE.3) NINCCO(I,J) = 0
29272 IF (J.LE.4) NINCST(I,J) = 0
29281 **dble Po statistics.
29285 *------------------------------------------------------------------
29286 * filling of histogram with event-record
29288 IF (IST.EQ.-1) THEN
29289 IF (.NOT.LFRAG) THEN
29290 IF (IDPDG.EQ.2212) THEN
29291 NEVA(NOBAM(IDX),1) = NEVA(NOBAM(IDX),1)+1
29292 ELSEIF (IDPDG.EQ.2112) THEN
29293 NEVA(NOBAM(IDX),2) = NEVA(NOBAM(IDX),2)+1
29294 ELSEIF (IDPDG.EQ.22) THEN
29295 NEVAGA(NOBAM(IDX)) = NEVAGA(NOBAM(IDX))+1
29296 ELSEIF (IDPDG.EQ.80000) THEN
29297 IF (IDBJT.EQ.116) THEN
29298 NEVA(NOBAM(IDX),3) = NEVA(NOBAM(IDX),3)+1
29299 ELSEIF (IDBJT.EQ.117) THEN
29300 NEVA(NOBAM(IDX),4) = NEVA(NOBAM(IDX),4)+1
29301 ELSEIF (IDBJT.EQ.118) THEN
29302 NEVA(NOBAM(IDX),5) = NEVA(NOBAM(IDX),5)+1
29303 ELSEIF (IDBJT.EQ.119) THEN
29304 NEVA(NOBAM(IDX),6) = NEVA(NOBAM(IDX),6)+1
29308 * heavy fragments (here: fission products only)
29309 NEVAHY(NOBAM(IDX),1,IBARY) = NEVAHY(NOBAM(IDX),1,IBARY)+1
29310 NEVAHY(NOBAM(IDX),2,ICHAR) = NEVAHY(NOBAM(IDX),2,ICHAR)+1
29311 NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29313 ELSEIF ((IST.EQ.1).AND.(.NOT.LFRAG)) THEN
29314 IF (IDCH(IDX).GT.MAXGEN) MAXGEN = IDCH(IDX)
29318 *------------------------------------------------------------------
29322 **dble Po statistics.
29323 C WRITE(LOUT,'(1X,A,2I7,2E12.4)')
29324 C & '# evts. / # dble-Po. evts / s_in / s_popo :',
29325 C & ICEVT,KPOPO,XSPRO(1,1,1),XSPRO(1,1,1)*DBLE(KPOPO)/DBLE(ICEVT)
29327 * emulsion treatment
29328 IF (NCOMPO.GT.0) THEN
29330 3000 FORMAT(/,1X,'HISTAT:',14X,'statistics - target emulsion',/,
29331 & 22X,'----------------------------',/,/,19X,
29332 & 'mass charge fraction',/,39X,
29333 & 'input treated',/)
29335 WRITE(LOUT,3013) I,IEMUMA(I),IEMUCH(I),EMUFRA(I),
29336 & EMUSAM(I)/DBLE(ICEVT)
29337 3013 FORMAT(12X,I2,1X,2I8,6X,F7.3,5X,F7.3)
29341 * i.n.c. statistics: output
29342 WRITE(LOUT,3001) ICEVT,NRESEV(2),IRINC
29343 3001 FORMAT(/,1X,'HISTAT:',14X,'statistics - intranuclear cascade',/,
29344 & 22X,'---------------------------------',/,/,1X,
29345 & 'no. of events for normalization: (accepted final events,',
29346 & ' evt)',4X,I6,/,34X,'(events before evap.-step, evt1)',I6,
29347 & /,1X,'no. of rejected events due to intranuclear',
29348 & ' cascade',15X,I6,/)
29349 ICEV = MAX(ICEVT,1)
29351 IF (LEVPRT) ICEV1 = MAX(NRESEV(2),1)
29353 & (DBLE(NINCWO(I))/DBLE(ICEV),I=1,2),
29354 & ((DBLE(NINCST(I,J))/DBLE(ICEV),I=1,2),J=1,4),
29355 & KTAUGE,DBLE(NINCGE)/DBLE(ICEV),
29356 & (DBLE(NINCCO(I,1)+NINCCO(I,2)+NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29357 & (DBLE(NINCCO(I,2))/DBLE(ICEV1),I=1,2),
29358 & (DBLE(NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29359 & (DBLE(NINCCO(I,1))/DBLE(ICEV1),I=1,2)
29360 3002 FORMAT(1X,'no. of wounded nucl. in proj./ target (mean per evt)',
29361 & 5X,F6.2,' /',F6.2,/,1X,'no. of particles unable to escape',
29362 & ' proj./ target (mean per evt)',/,8X,'baryons: pos. ',
29363 & F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3,/,8X,
29364 & 'mesons: pos. ',F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3,
29365 & /,1X,'maximum no. of generations treated (maximum allowed:'
29366 & ,I4,')',/,43X,'(mean per evt)',5X,F6.2,/,1X,'no. of sec.',
29367 & ' interactions in proj./ target (mean per evt1)',
29368 & F7.3,' /',F7.3,/,8X,'out of which by inelastic',
29369 & ' interactions',12X,F7.3,' /',F7.3,/,21X,'by elastic ',
29370 & 'interactions',14X,F7.3,' /',F7.3,/,21X,'by absorption ',
29371 & '(ap, K-, pi- only) ',F7.3,' /',F7.3,/)
29372 WRITE(LOUT,3003) NRESEV(2),NRESEV(4),IREXCI,
29373 & IREXCI(1)+IREXCI(2)+IREXCI(3)
29374 3003 FORMAT(/,1X,'HISTAT:',14X,'statistics - residual nuclei, ',
29375 & 'evaporation',/,22X,'-----------------------------',
29376 & '------------',/,/,1X,'no. of events for normal.: ',
29377 & '(events handled by FICONF, evt)',7X,I6,/,28X,'(events',
29378 & ' passing the evap.-step, evt1) ',I6,/,1X,'no. of',
29379 & ' rejected events (',I4,',',I4,',',I4,')',22X,I6,/)
29382 3004 FORMAT(/,22X,'1) before evaporation-step:',/)
29383 ICEV = MAX(NRESEV(2),1)
29385 & (DBLE(NRESTO(I))/DBLE(ICEV),I=1,2),
29386 & (DBLE(NRESPR(I))/DBLE(ICEV),I=1,2),
29387 & (DBLE(NRESNU(I))/DBLE(ICEV),I=1,2),
29388 & (DBLE(NRESBA(I))/DBLE(ICEV),I=1,2),
29389 & (DBLE(NRESPB(I))/DBLE(ICEV),I=1,2),
29390 & (DBLE(NRESCH(I))/DBLE(ICEV),I=1,2),
29391 & (EXCDPM(I)/DBLE(ICEV),I=1,2),
29392 & (EXCDPM(I+2)/DBLE(ICEV),I=1,2)
29393 3005 FORMAT(1X,'residual nuclei: (mean values per evt)',12X,
29394 & 'proj. / target',/,/,8X,'total number of particles',15X,
29395 & 2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29396 & 'neutrons',18X,2F9.3,/,22X,'baryons',19X,2F9.3,/,22X,
29397 & 'pos. baryons',14X,2F9.3,/,8X,'total charge',28X,2F9.3,/,
29398 & /,8X,'excitation energy (bef. evap.-step) ',2E11.3,/,
29399 & 8X,'excitation energy per nucleon ',2E11.3,/,/)
29401 * evaporation / fission / fragmentation statistics: output
29402 ICEV = MAX(NRESEV(2),1)
29403 ICEV1 = MAX(NRESEV(4),1)
29405 & NEVA(1,1)+NEVA(1,2)+NEVA(1,3)+NEVA(1,4)+NEVA(1,5)+NEVA(1,6)
29407 & NEVA(2,1)+NEVA(2,2)+NEVA(2,3)+NEVA(2,4)+NEVA(2,5)+NEVA(2,6)
29410 IF (IEVFSS.EQ.1) CMSG(1) = 'requested '
29412 IF (LFRMBK) CMSG(2) = 'requested '
29413 IF (LDEEXG) CMSG(3) = 'requested '
29416 & DBLE(NTEVA1)/DBLE(ICEV1),DBLE(NTEVA2)/DBLE(ICEV1),
29417 & (DBLE(NEVA(I,1))/DBLE(ICEV1),I=1,2),
29418 & (DBLE(NEVA(I,2))/DBLE(ICEV1),I=1,2),
29419 & (DBLE(NEVA(I,3))/DBLE(ICEV1),I=1,2),
29420 & (DBLE(NEVA(I,4))/DBLE(ICEV1),I=1,2),
29421 & (DBLE(NEVA(I,5))/DBLE(ICEV1),I=1,2),
29422 & (DBLE(NEVA(I,6))/DBLE(ICEV1),I=1,2),
29423 & (DBLE(NEVAGA(I))/DBLE(ICEV1),I=1,2),
29424 & (DBLE(NEVAHT(I))/DBLE(ICEV1),I=1,2)
29425 3006 FORMAT(22X,'2) after evaporation-step:',/,/,1X,'Fission:',
29426 & 13X,A13,/,1X,'Fermi-Break-up:',6X,A13,/,1X,'Gamma-',
29427 & 'deexcitation:',2X,A13,/,/,
29428 & 1X,'evaporation/deexcitation: (mean values per evt1) ',
29429 & 'proj. / target',/,/,8X,'total number of evap. particles',
29430 & 9X,2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29431 & 'neutrons',18X,2F9.3,/,22X,'deuterons',17X,2F9.3,/,22X,
29432 & '3-H',23X,2F9.3,/,22X,'3-He',22X,2F9.3,/,22X,'4-He',22X,
29433 & 2F9.3,/,8X,'nucl. deexcit. gammas',19X,2F9.3,/,8X,
29434 & 'heavy fragments',25X,2F9.3,/)
29436 IF (IEVFSS.EQ.1) THEN
29438 WRITE(LOUT,3007) NEVAFI(1,1),NEVAFI(1,2),
29439 & NEVAFI(2,1),NEVAFI(2,2),
29440 & DBLE(NEVAFI(2,1))/DBLE(MAX(NEVAFI(1,1),1))*100.0D0,
29441 & DBLE(NEVAFI(2,2))/DBLE(MAX(NEVAFI(1,2),1))*100.0D0
29442 3007 FORMAT(1X,'Fission: total number of events',14X,2I9,/
29443 & 12X,'out of which fission occured',8X,2I9,/,
29444 & 50X,'(',F5.2,'%) (',F5.2,'%)',/)
29447 C IF ((LFRMBK).OR.(IEVFSS.EQ.1)) THEN
29450 C3008 FORMAT(1X,'heavy fragments - statistics:',7X,'charge',
29451 C & ' proj. / target',/)
29453 C IF ((NEVAHY(1,2,I).NE.0).OR.(NEVAHY(2,2,I).NE.0)) THEN
29454 C WRITE(LOUT,3009) I,
29455 C & (DBLE(NEVAHY(K,2,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29456 C3009 FORMAT(38X,I3,3X,2E12.3)
29460 C3010 FORMAT(1X,'heavy fragments - statistics:',7X,'mass ',
29461 C & ' proj. / target',/)
29463 C IF ((NEVAHY(1,1,I).NE.0).OR.(NEVAHY(2,1,I).NE.0)) THEN
29464 C WRITE(LOUT,3011) I,
29465 C & (DBLE(NEVAHY(K,1,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29466 C3011 FORMAT(38X,I3,3X,2E12.3)
29473 3012 FORMAT(22X,'2) after evaporation-step:',/,/,1X,
29474 & 'Evaporation: not requested',/)
29478 *------------------------------------------------------------------
29479 * filling of histogram with event-record
29481 * emulsion treatment
29482 IF (NCOMPO.GT.0) THEN
29484 IF (IT.EQ.IEMUMA(I)) THEN
29485 EMUSAM(I) = EMUSAM(I)+ONE
29489 NINCGE = NINCGE+MAXGEN
29491 **dble Po statistics.
29492 IF (IPOPO.EQ.1) KPOPO = KPOPO+1
29495 *------------------------------------------------------------------
29496 * filling of histogram with event-record
29498 IF ((ISTHKK(IDX).EQ.15).OR.(ISTHKK(IDX).EQ.16)) THEN
29499 IB = IIBAR(IDBAM(IDX))
29500 IC = IICH(IDBAM(IDX))
29502 IF ( ((ABS(IB).EQ.1).AND.(IC.EQ.1)).OR.(IC.EQ.0) ) THEN
29503 NINCST(J,1) = NINCST(J,1)+1
29504 ELSEIF ((ABS(IB).EQ.1).AND.(IC.EQ.-1)) THEN
29505 NINCST(J,2) = NINCST(J,2)+1
29506 ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ. 1)) THEN
29507 NINCST(J,3) = NINCST(J,3)+1
29508 ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ.-1)) THEN
29509 NINCST(J,4) = NINCST(J,4)+1
29511 ELSEIF (ISTHKK(IDX).EQ.17) THEN
29512 NINCWO(1) = NINCWO(1)+1
29513 ELSEIF (ISTHKK(IDX).EQ.18) THEN
29514 NINCWO(2) = NINCWO(2)+1
29515 ELSEIF (ISTHKK(IDX).EQ.1001) THEN
29519 NEVAHY(NOBAM(IDX),1,IB) = NEVAHY(NOBAM(IDX),1,IB)+1
29520 NEVAHY(NOBAM(IDX),2,IC) = NEVAHY(NOBAM(IDX),2,IC)+1
29522 NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29527 *$ CREATE DT_NEWHGR.FOR
29530 *===newhgr=============================================================*
29532 SUBROUTINE DT_NEWHGR(XLIM1,XLIM2,XLIM3,XLIMB,IBIN,IREFN)
29534 ************************************************************************
29536 * Histogram initialization. *
29538 * input: XLIM1/XLIM2 lower/upper edge of histogram-window *
29540 * IBIN > 0 number of bins in equidistant lin. binning *
29541 * = -1 reset histograms *
29542 * < -1 |IBIN| number of bins in equidistant log. *
29543 * binning or log. binning in user def. struc. *
29544 * XLIMB(*) user defined bin structure *
29546 * The bin structure is sensitive to *
29547 * XLIM1, XLIM3, IBIN if XLIM3 > 0 (lin.) *
29548 * XLIM1, XLIM2, IBIN if XLIM3 = 0 (lin. & log.) *
29549 * XLIMB, IBIN if XLIM3 < 0 *
29552 * output: IREFN histogram index *
29553 * (= -1 for inconsistent histogr. request) *
29555 * This subroutine is based on a original version by R. Engel. *
29556 * This version dated 22.4.95 is written by S. Roesler. *
29557 ************************************************************************
29559 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29562 PARAMETER ( LINP = 10 ,
29568 PARAMETER (ZERO = 0.0D0,
29575 PARAMETER (NHIS=150, NDIM=250)
29577 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29578 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29580 * auxiliary common for histograms
29581 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29583 DATA LSTART /.TRUE./
29585 * reset histogram counter
29586 IF (LSTART.OR.(IBIN.EQ.-1)) THEN
29588 IF (IBIN.EQ.-1) RETURN
29593 * check for maximum number of allowed histograms
29594 IF (IHIS.GT.NHIS) THEN
29595 WRITE(LOUT,1003) IHIS,NHIS,IHIS
29596 1003 FORMAT(1X,'NEWHGR: warning! number of histograms (',
29597 & I4,') exceeds array size (',I4,')',/,21X,
29598 & 'histogram',I3,' skipped!')
29603 IBINS(IHIS) = ABS(IBIN)
29604 * check requested number of bins
29605 IF (IBINS(IHIS).GE.NDIM) THEN
29606 WRITE(LOUT,1000) IBIN,NDIM,NDIM
29607 1000 FORMAT(1X,'NEWHGR: warning! number of bins (',
29608 & I3,') exceeds array size (',I3,')',/,21X,
29609 & 'and will be reset to ',I3)
29612 IF (IBINS(IHIS).EQ.0) THEN
29613 WRITE(LOUT,1001) IBIN,IHIS
29614 1001 FORMAT(1X,'NEWHGR: warning! inconsistent number of',
29615 & ' bins (',I3,')',/,21X,'histogram',I3,' skipped!')
29619 * initialize arrays
29622 HIST(K,IHIS,I) = ZERO
29623 HIST(K+3,IHIS,I) = ZERO
29624 TMPHIS(K,IHIS,I) = ZERO
29626 HIST(7,IHIS,I) = ZERO
29628 DENTRY(1,IHIS)= ZERO
29629 DENTRY(2,IHIS)= ZERO
29631 UNDERF(IHIS) = ZERO
29632 TMPUFL(IHIS) = ZERO
29633 TMPOFL(IHIS) = ZERO
29635 * bin str. sensitive to lower edge, bin size, and numb. of bins
29636 IF (XLIM3.GT.ZERO) THEN
29637 DO 3 K=1,IBINS(IHIS)+1
29638 HIST(1,IHIS,K) = XLIM1+DBLE(K-1)*XLIM3
29641 * bin str. sensitive to lower/upper edge and numb. of bins
29642 ELSEIF (XLIM3.EQ.ZERO) THEN
29644 IF (IBIN.GT.0) THEN
29647 IF (XLIM2.LE.XLIM1) THEN
29648 WRITE(LOUT,1002) XLIM1,XLIM2
29649 1002 FORMAT(1X,'NEWHGR: warning! inconsistent x-range',
29650 & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29654 ELSEIF (IBIN.LT.-1) THEN
29655 * logarithmic binning
29656 IF ((XLIM1.LE.ZERO).OR.(XLIM2.LE.ZERO)) THEN
29657 WRITE(LOUT,1004) XLIM1,XLIM2
29658 1004 FORMAT(1X,'NEWHGR: warning! inconsistent log. ',
29659 & 'binning',/,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29662 IF (XLIM2.LE.XLIM1) THEN
29663 WRITE(LOUT,1005) XLIM1,XLIM2
29664 1005 FORMAT(1X,'NEWHGR: warning! inconsistent x-range',
29665 & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29668 XLOW = LOG10(XLIM1)
29672 DX = ABS(XHI-XLOW)/DBLE(MAX(IBINS(IHIS),1))
29673 DO 4 K=1,IBINS(IHIS)+1
29674 HIST(1,IHIS,K) = XLOW+DBLE(K-1)*DX
29677 * user defined bin structure
29678 DO 5 K=1,IBINS(IHIS)+1
29679 IF (IBIN.GT.0) THEN
29680 HIST(1,IHIS,K) = XLIMB(K)
29682 ELSEIF (IBIN.LT.-1) THEN
29683 HIST(1,IHIS,K) = LOG10(XLIMB(K))
29689 * histogram accepted
29699 *$ CREATE DT_FILHGR.FOR
29702 *===filhgr=============================================================*
29704 SUBROUTINE DT_FILHGR(XI,YI,IHIS,NEVT)
29706 ************************************************************************
29708 * Scoring for histogram IHIS. *
29710 * This subroutine is based on a original version by R. Engel. *
29711 * This version dated 23.4.95 is written by S. Roesler. *
29712 ************************************************************************
29714 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29717 PARAMETER ( LINP = 10 ,
29721 PARAMETER (ZERO = 0.0D0,
29727 PARAMETER (NHIS=150, NDIM=250)
29729 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29730 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29732 * auxiliary common for histograms
29733 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29740 * dump content of temorary arrays into histograms
29741 IF ((NEVT.NE.NCEVT).OR.(NEVT.LT.0)) THEN
29742 CALL DT_EVTHIS(IDUM)
29746 * check histogram index
29747 IF (IHIS.EQ.-1) RETURN
29748 IF ((IHIS.LT.1).OR.(IHIS.GT.IHISL)) THEN
29749 C WRITE(LOUT,1000) IHIS,IHISL
29750 1000 FORMAT(1X,'FILHGR: warning! histogram index',I4,
29751 & ' out of range (1..',I3,')')
29755 IF ((ISWI(IHIS).EQ.1).OR.(ISWI(IHIS).EQ.3)) THEN
29756 * bin structure not explicitly given
29757 IF ((ISWI(IHIS).EQ.3).AND.(X.GT.ZERO)) X = LOG10(X)
29758 DX = ABS(HIST(1,IHIS,2)-HIST(1,IHIS,1))
29759 IF (X.LT.HIST(1,IHIS,1)) THEN
29762 I1 = INT( (X-HIST(1,IHIS,1))/MAX(DX,TINY) )+1
29765 ELSEIF ((ISWI(IHIS).EQ.2).OR.(ISWI(IHIS).EQ.4)) THEN
29766 * user defined bin structure
29767 IF ((ISWI(IHIS).EQ.4).AND.(X.GT.ZERO)) X = LOG10(X)
29768 IF (X.LT.HIST(1,IHIS,1)) THEN
29770 ELSE IF (X.GT.HIST(1,IHIS,IBINS(IHIS)+1)) THEN
29773 * binary sort algorithm
29775 KMAX = IBINS(IHIS)+1
29777 IF ((KMAX-KMIN).EQ.1) GOTO 2
29779 IF (X.LE.HIST(1,IHIS,KK)) THEN
29791 1001 FORMAT(1X,'FILHGR: warning! histogram not initialized')
29797 TMPUFL(IHIS) = TMPUFL(IHIS)+ONE
29798 ELSEIF (I1.LE.IBINS(IHIS)) THEN
29799 TMPHIS(1,IHIS,I1) = TMPHIS(1,IHIS,I1)+ONE
29800 IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
29801 TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+10**X
29803 TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+X
29805 TMPHIS(3,IHIS,I1) = TMPHIS(3,IHIS,I1)+Y
29807 TMPOFL(IHIS) = TMPOFL(IHIS)+ONE
29813 *$ CREATE DT_EVTHIS.FOR
29816 *===evthis=============================================================*
29818 SUBROUTINE DT_EVTHIS(NEVT)
29820 ************************************************************************
29821 * Dump content of temorary histograms into /DTHIS1/. This subroutine *
29822 * is called after each event and for the last event before any call *
29824 * NEVT number of events dumped, this is only needed to *
29825 * get the normalization after the last event *
29826 * This version dated 23.4.95 is written by S. Roesler. *
29827 ************************************************************************
29829 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29832 PARAMETER ( LINP = 10 ,
29838 PARAMETER (ZERO = 0.0D0,
29844 PARAMETER (NHIS=150, NDIM=250)
29846 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29847 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29849 * auxiliary common for histograms
29850 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29860 IF (TMPHIS(1,I,J).GT.ZERO) THEN
29862 HIST(2,I,J) = HIST(2,I,J)+ONE
29863 HIST(7,I,J) = HIST(7,I,J)+TMPHIS(1,I,J)
29864 DENTRY(2,I) = DENTRY(2,I)+TMPHIS(1,I,J)
29865 AVX = TMPHIS(2,I,J)/TMPHIS(1,I,J)
29866 HIST(3,I,J) = HIST(3,I,J)+TMPHIS(3,I,J)*AVX
29867 HIST(4,I,J) = HIST(4,I,J)+TMPHIS(3,I,J)*AVX**2
29868 HIST(5,I,J) = HIST(5,I,J)+TMPHIS(3,I,J)
29869 HIST(6,I,J) = HIST(6,I,J)+TMPHIS(3,I,J)**2
29870 TMPHIS(1,I,J) = ZERO
29871 TMPHIS(2,I,J) = ZERO
29872 TMPHIS(3,I,J) = ZERO
29876 IF (TMPUFL(I).GT.ZERO) THEN
29877 UNDERF(I) = UNDERF(I)+ONE
29879 ELSEIF (TMPOFL(I).GT.ZERO) THEN
29880 OVERF(I) = OVERF(I)+ONE
29884 DENTRY(1,I) = DENTRY(1,I)+ONE
29891 *$ CREATE DT_OUTHGR.FOR
29894 *===outhgr=============================================================*
29896 SUBROUTINE DT_OUTHGR(I1,I2,I3,I4,I5,I6,CHEAD,IHEAD,NEVTS,FAC,
29897 & ILOGY,INORM,NMODE)
29899 ************************************************************************
29901 * Plot histogram(s) to standard output unit *
29903 * I1..6 indices of histograms to be plotted *
29904 * CHEAD,IHEAD header string,integer *
29905 * NEVTS number of events *
29906 * FAC scaling factor *
29907 * ILOGY = 1 logarithmic y-axis *
29908 * INORM normalization *
29909 * = 0 no further normalization (FAC is obsolete) *
29910 * = 1 per event and bin width *
29911 * = 2 per entry and bin width *
29912 * = 3 per bin entry *
29913 * = 4 per event and "bin width" x1^2...x2^2 *
29914 * = 5 per event and "log. bin width" ln x1..ln x2 *
29916 * MODE = 0 no output but normalization applied *
29917 * = 1 all valid histograms separately (small frame) *
29918 * all valid histograms separately (small frame) *
29919 * = -1 and tables as histograms *
29920 * = 2 all valid histograms (one plot, wide frame) *
29921 * all valid histograms (one plot, wide frame) *
29922 * = -2 and tables as histograms *
29925 * Note: All histograms to be plotted with one call to this *
29926 * subroutine and |MODE|=2 must have the same bin structure! *
29927 * There is no test included ensuring this fact. *
29929 * This version dated 23.4.95 is written by S. Roesler. *
29930 ************************************************************************
29932 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29935 PARAMETER ( LINP = 10 ,
29941 PARAMETER (ZERO = 0.0D0,
29953 PARAMETER (NHIS=150, NDIM=250)
29955 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29956 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29958 PARAMETER (NDIM2 = 2*NDIM)
29959 DIMENSION XX(NDIM2),YY(NDIM2)
29961 PARAMETER (NHISTO = 6)
29962 DIMENSION YY1(NDIM,NHISTO),XX1(NDIM,NHISTO),IDX1(NHISTO),
29965 CHARACTER*43 CNORM(0:8)
29966 DATA CNORM /'no further normalization ',
29967 & 'per event and bin width ',
29968 & 'per entry1 and bin width ',
29969 & 'per bin entry ',
29970 & 'per event and "bin width" x1^2...x2^2 ',
29971 & 'per event and "log. bin width" ln x1..ln x2',
29973 & 'per bin entry1 ',
29974 & 'per entry2 and bin width '/
29985 * initialization if "wide frame" is requested
29986 IF (ABS(MODE).EQ.2) THEN
29996 WRITE(LOUT,'(/1X,A,I3,/,1X,70A1)') CHEAD,IHEAD,('=',II=1,70)
29998 * check histogram indices
30001 IF ((IDX1(I).GE.1).AND.(IDX1(I).LE.IHISL)) THEN
30002 IF (ISWI(IDX1(I)).NE.0) THEN
30003 IF (DENTRY(1,IDX1(I)).LT.ONE) THEN
30005 & IDX1(I),UNDERF(IDX1(I)),OVERF(IDX1(I))
30006 1000 FORMAT(/,1X,'OUTHGR: warning! no entries in',
30007 & ' histogram ',I3,/,21X,'underflows:',F10.0,
30008 & ' overflows: ',F10.0)
30018 1001 FORMAT(/,1X,'OUTHGR: warning! histogram indices not valid')
30022 * check normalization request
30023 IF ( ((FAC.EQ.ZERO).AND.(INORM.NE.0)).OR.
30024 & ((NEVTS.LT.1).AND.((INORM.EQ.1).OR.(INORM.EQ.4).OR.
30025 & (INORM.EQ.5).OR.(INORM.EQ.6))).OR.
30026 & (INORM.LT.0).OR.(INORM.GT.8) ) THEN
30027 WRITE(LOUT,1002) NEVTS,INORM,FAC
30028 1002 FORMAT(/,1X,'OUTHGR: warning! normalization request not ',
30029 & 'valid',/,21X,'NEVTS = ',I7,4X,'INORM = ',I2,4X,
30034 WRITE(LOUT,'(/,1X,A,I8)') 'number of events:',NEVTS
30036 * apply normalization
30041 IF (ISWI(I).EQ.1) THEN
30042 WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30043 1003 FORMAT(/,1X,'histo.',I4,', linear binning from',2X,E10.4,
30044 & ' to',2X,E10.4,',',2X,I3,' bins')
30045 ELSEIF (ISWI(I).EQ.2) THEN
30046 WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30048 1007 FORMAT(1X,'user defined bin structure')
30049 ELSEIF (ISWI(I).EQ.3) THEN
30051 & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30052 1004 FORMAT(/,1X,'histo.',I4,', logar. binning from',2X,E10.4,
30053 & ' to',2X,E10.4,',',2X,I3,' bins')
30054 ELSEIF (ISWI(I).EQ.4) THEN
30056 & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30059 WRITE(LOUT,1008) ISWI(I)
30060 1008 FORMAT(/,1X,'warning! inconsistent bin structure flag ',I4)
30062 WRITE(LOUT,1005) DENTRY(1,I),DENTRY(2,I),UNDERF(I),OVERF(I)
30063 1005 FORMAT(13X,'entries:',2F9.0,' underfl.:',F8.0,
30064 & ' overfl.:',F8.0)
30065 WRITE(LOUT,1009) CNORM(INORM)
30066 1009 FORMAT(1X,'normalization: ',A,/)
30069 CALL DT_GETBIN(I,K,NEVTS,INORM,XLOW,XHI,XMEAN,YMEAN,YERR)
30072 WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,YERR,HIST(2,I,K)
30073 WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,YERR,HIST(2,I,K)
30074 1006 FORMAT(1X,5E11.3)
30077 XX(II-1) = HIST(1,I,K)
30078 XX(II) = HIST(1,I,K+1)
30083 IF ((ISWI(I).EQ.3).OR.(ISWI(I).EQ.4))
30084 & XX1(K,N) = LOG10(XMEAN)
30089 IF (ABS(MODE).EQ.1) THEN
30091 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30092 IF(ILOGY.EQ.1) THEN
30093 CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30095 CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30102 IF (ABS(MODE).EQ.2) THEN
30103 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30104 NSIZE = NDIM*NHISTO
30105 DXLOW = HIST(1,IDX(1),1)
30106 DDX = ABS(HIST(1,IDX(1),2)-HIST(1,IDX(1),1))
30111 IF (YY1(J,I).LT.YLOW) THEN
30112 IF (ILOGY.EQ.1) THEN
30113 IF (YY1(J,I).GT.ZERO) YLOW = YY1(J,I)
30118 IF (YY1(J,I).GT.YHI) YHI = YY1(J,I)
30121 DY = (YHI-YLOW)/DBLE(NDIM)
30122 IF (DY.LE.ZERO) THEN
30123 WRITE(LOUT,'(1X,A,6I4,A,2E12.4)')
30124 & 'OUTHGR: warning! zero bin width for histograms ',
30125 & IDX,': ',YLOW,YHI
30128 IF (ILOGY.EQ.1) THEN
30130 DY = (LOG10(YHI)-YLOW)/100.0D0
30133 IF (YY1(J,I).LE.ZERO) THEN
30136 YY1(J,I) = LOG10(YY1(J,I))
30141 CALL DT_SRPLOT(XX1,YY1,NSIZE,NHISTO,NDIM,DXLOW,DDX,YLOW,DY)
30147 *$ CREATE DT_GETBIN.FOR
30150 *===getbin=============================================================*
30152 SUBROUTINE DT_GETBIN(IHIS,IBIN,KEVT,NORM,XLOW,XHI,
30153 & XMEAN,YMEAN,YERR)
30155 ************************************************************************
30156 * This version dated 23.4.95 is written by S. Roesler. *
30157 ************************************************************************
30159 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30162 PARAMETER ( LINP = 10 ,
30166 PARAMETER (ZERO = 0.0D0,
30168 & TINY35 = 1.0D-35)
30172 PARAMETER (NHIS=150, NDIM=250)
30174 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30175 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30177 XLOW = HIST(1,IHIS,IBIN)
30178 XHI = HIST(1,IHIS,IBIN+1)
30179 IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
30183 IF (NORM.EQ.2) THEN
30185 NEVT = INT(DENTRY(1,IHIS))
30186 ELSEIF (NORM.EQ.3) THEN
30188 NEVT = INT(HIST(2,IHIS,IBIN))
30189 ELSEIF (NORM.EQ.4) THEN
30190 DX = XHI**2-XLOW**2
30192 ELSEIF (NORM.EQ.5) THEN
30193 DX = LOG(ABS(XHI))-LOG(ABS(XLOW))
30195 ELSEIF (NORM.EQ.6) THEN
30198 ELSEIF (NORM.EQ.7) THEN
30200 NEVT = INT(HIST(7,IHIS,IBIN))
30201 ELSEIF (NORM.EQ.8) THEN
30203 NEVT = INT(DENTRY(2,IHIS))
30208 IF (ABS(DX).LT.TINY35) DX = ONE
30210 YMEAN = HIST(5,IHIS,IBIN)/DX/DBLE(NEVT)
30211 YMEAN2 = HIST(6,IHIS,IBIN)/DX**2/DBLE(NEVT)
30212 YERR = SQRT(ABS(YMEAN2-YMEAN**2))/SQRT(DBLE(NEVT))
30213 YSUM = HIST(5,IHIS,IBIN)
30214 IF (ABS(YSUM).LT.TINY35) YSUM = ONE
30215 C XMEAN = HIST(3,IHIS,IBIN)/YSUM/MAX(HIST(2,IHIS,IBIN),ONE)
30216 XMEAN = HIST(3,IHIS,IBIN)/YSUM
30217 IF (XMEAN.EQ.ZERO) XMEAN = XLOW
30222 *$ CREATE DT_JOIHIS.FOR
30225 *===joihis=============================================================*
30227 SUBROUTINE DT_JOIHIS(IH1,IH2,COPER,FAC1,FAC2,KEVT,NORM,ILOGY,MODE)
30229 ************************************************************************
30231 * Operation on histograms. *
30233 * input: IH1,IH2 histogram indices to be joined *
30234 * COPER character defining the requested operation, *
30235 * i.e. '+', '-', '*', '/' *
30236 * FAC1,FAC2 factors for joining, i.e. *
30237 * FAC1*histo1 COPER FAC2*histo2 *
30239 * This version dated 23.4.95 is written by S. Roesler. *
30240 ************************************************************************
30242 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30245 PARAMETER ( LINP = 10 ,
30251 PARAMETER (ZERO = 0.0D0,
30260 PARAMETER (NHIS=150, NDIM=250)
30262 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30263 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30265 PARAMETER (NDIM2 = 2*NDIM)
30266 DIMENSION XX(NDIM2),YY(NDIM2),YY1(NDIM),XX1(NDIM)
30268 CHARACTER*43 CNORM(0:6)
30269 DATA CNORM /'no further normalization ',
30270 & 'per event and bin width ',
30271 & 'per entry and bin width ',
30272 & 'per bin entry ',
30273 & 'per event and "bin width" x1^2...x2^2 ',
30274 & 'per event and "log. bin width" ln x1..ln x2',
30277 * check histogram indices
30278 IF ((IH1.LT. 1).OR.(IH2.LT. 1).OR.
30279 & (IH1.GT.IHISL).OR.(IH2.GT.IHISL)) THEN
30280 WRITE(LOUT,1000) IH1,IH2,IHISL
30281 1000 FORMAT(1X,'JOIHIS: warning! inconsistent histogram ',
30282 & 'indices (',I3,',',I3,'),',/,21X,'valid range: 1,',I3)
30286 * check bin structure of histograms to be joined
30287 IF (IBINS(IH1).NE.IBINS(IH2)) THEN
30288 WRITE(LOUT,1001) IH1,IH2,IBINS(IH1),IBINS(IH2)
30289 1001 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3,
30290 & ' and ',I3,' failed',/,21X,
30291 & 'due to different numbers of bins (',I3,',',I3,')')
30294 DO 1 K=1,IBINS(IH1)+1
30295 IF (ABS(HIST(1,IH1,K)-HIST(1,IH2,K)).GT.TINY8) THEN
30296 WRITE(LOUT,1002) IH1,IH2,K,HIST(1,IH1,K),HIST(1,IH2,K)
30297 1002 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3,
30298 & ' and ',I3,' failed at bin edge ',I3,/,21X,
30299 & 'X1,X2 = ',2E11.4)
30304 WRITE(LOUT,1003) IH1,IH2,COPER,FAC1,FAC2
30305 1003 FORMAT(1X,'JOIHIS: joining histograms ',I3,',',I3,' with ',
30306 & 'operation ',A,/,11X,'and factors ',2E11.4)
30307 WRITE(LOUT,1004) CNORM(NORM)
30308 1004 FORMAT(1X,'normalization: ',A,/)
30310 DO 2 K=1,IBINS(IH1)
30311 CALL DT_GETBIN(IH1,K,KEVT,NORM,XLOW1,XHI1,XMEAN1,YMEAN1,YERR1)
30312 CALL DT_GETBIN(IH2,K,KEVT,NORM,XLOW2,XHI2,XMEAN2,YMEAN2,YERR2)
30315 XMEAN = OHALF*(XMEAN1+XMEAN2)
30316 IF (COPER.EQ.'+') THEN
30317 YMEAN = FAC1*YMEAN1+FAC2*YMEAN2
30318 ELSEIF (COPER.EQ.'*') THEN
30319 YMEAN = FAC1*YMEAN1*FAC2*YMEAN2
30320 ELSEIF (COPER.EQ.'/') THEN
30321 IF (YMEAN2.EQ.ZERO) THEN
30324 IF (FAC2.EQ.ZERO) FAC2 = ONE
30325 YMEAN = FAC1*YMEAN1/(FAC2*YMEAN2)
30330 WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30331 WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30332 1006 FORMAT(1X,5E11.3)
30335 XX(II-1) = HIST(1,IH1,K)
30336 XX(II) = HIST(1,IH1,K+1)
30341 IF ((ISWI(IH1).EQ.3).OR.(ISWI(IH1).EQ.4)) XX1(K) = LOG10(XMEAN)
30346 IF (ABS(MODE).EQ.1) THEN
30347 IBIN2 = 2*IBINS(IH1)
30348 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30349 IF(ILOGY.EQ.1) THEN
30350 CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30352 CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30357 IF (ABS(MODE).EQ.2) THEN
30358 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30360 DXLOW = HIST(1,IH1,1)
30361 DDX = ABS(HIST(1,IH1,2)-HIST(1,IH1,1))
30365 IF (YY1(I).LT.YLOW) THEN
30366 IF (ILOGY.EQ.1) THEN
30367 IF (YY1(I).GT.ZERO) YLOW = YY1(I)
30372 IF (YY1(I).GT.YHI) YHI = YY1(I)
30374 DY = (YHI-YLOW)/DBLE(NDIM)
30375 IF (DY.LE.ZERO) THEN
30376 WRITE(LOUT,'(1X,A,2I4,A,2E12.4)')
30377 & 'JOIHIS: warning! zero bin width for histograms ',
30378 & IH1,IH2,': ',YLOW,YHI
30381 IF (ILOGY.EQ.1) THEN
30383 DY = (LOG10(YHI)-YLOW)/100.0D0
30385 IF (YY1(I).LE.ZERO) THEN
30388 YY1(I) = LOG10(YY1(I))
30392 CALL DT_SRPLOT(XX1,YY1,NSIZE,1,NDIM,DXLOW,DDX,YLOW,DY)
30398 WRITE(LOUT,1005) COPER
30399 1005 FORMAT(1X,'JOIHIS: unknown operation ',A)
30405 *$ CREATE DT_XGRAPH.FOR
30408 *===qgraph=============================================================*
30410 SUBROUTINE DT_XGRAPH(N,IARG,X,Y1,Y2)
30411 C***********************************************************************
30413 C calculate quasi graphic picture with 25 lines and 79 columns
30414 C ranges will be chosen automatically
30416 C input N dimension of input fields
30417 C IARG number of curves (fields) to plot
30422 C This subroutine is written by R. Engel.
30423 C***********************************************************************
30424 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30427 PARAMETER ( LINP = 10 ,
30432 DIMENSION X(N),Y1(N),Y2(N)
30433 PARAMETER (EPS=1.D-30)
30434 PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30436 CHARACTER COL(0:149,0:49)
30438 DATA SYMB /'0','e','z','#','x'/
30442 C*** automatic range fitting
30447 XMAX=MAX(X(I),XMAX)
30448 XMIN=MIN(X(I),XMIN)
30450 XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30453 DO 1100 K=0,IZEIL-1
30455 IF (ITEST.EQ.IYRAST) THEN
30456 DO 1010 L=1,ISPALT-1
30461 DO 1020 L=0,ISPALT-1,IXRAST
30465 DO 1030 L=1,ISPALT-1
30468 DO 1040 L=0,ISPALT-1,IXRAST
30480 YMAX=MAX(Y1(I),YMAX)
30481 YMIN=MIN(Y1(I),YMIN)
30485 YMAX=MAX(Y2(I),YMAX)
30486 YMIN=MIN(Y2(I),YMIN)
30489 YMAX=(YMAX-YMIN)/40.0D0+YMAX
30490 YMIN=YMIN-(YMAX-YMIN)/40.0D0
30491 YZOOM=(YMAX-YMIN)/DBLE(IZEIL)
30492 IF(YZOOM.LT.EPS) THEN
30493 WRITE(LOUT,'(1X,A)')
30494 & 'XGRAPH:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30503 L=NINT((X(K)-XMIN)/XZOOM)
30504 I=NINT((YMAX-Y1(K))/YZOOM)
30505 IF(ILAST.GE.0) THEN
30508 DO 55 II=0,LD,SIGN(1,LD)
30509 DO 66 KK=0,ID,SIGN(1,ID)
30510 COL(II+LLAST,KK+ILAST)=SYMB(1)
30525 L=NINT((X(K)-XMIN)/XZOOM)
30526 I=NINT((YMAX-Y2(K))/YZOOM)
30533 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30535 C*** write range of X
30537 XZOOM = (XMAX-XMIN)/DBLE(7)
30538 WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30540 DO 1300 K=0,IZEIL-1
30541 YPOS=YMAX-((DBLE(K)+0.5D0)*YZOOM)
30542 WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30543 110 FORMAT(1X,1PE9.2,70A1)
30546 C*** write range of X
30548 XZOOM = (XMAX-XMIN)/DBLE(7)
30549 WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30550 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30551 120 FORMAT(6X,7(1PE10.3))
30554 *$ CREATE DT_XGLOGY.FOR
30557 *===qglogy=============================================================*
30559 SUBROUTINE DT_XGLOGY(N,IARG,X,Y1,Y2)
30560 C***********************************************************************
30562 C calculate quasi graphic picture with 25 lines and 79 columns
30563 C logarithmic y axis
30564 C ranges will be chosen automatically
30566 C input N dimension of input fields
30567 C IARG number of curves (fields) to plot
30572 C This subroutine is written by R. Engel.
30573 C***********************************************************************
30575 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30578 PARAMETER ( LINP = 10 ,
30582 DIMENSION X(N),Y1(N),Y2(N)
30583 PARAMETER (EPS=1.D-30)
30584 PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30586 CHARACTER COL(0:149,0:49)
30587 PARAMETER (DEPS = 1.D-10)
30589 DATA SYMB /'0','e','z','#','x'/
30593 C*** automatic range fitting
30598 XMAX=MAX(X(I),XMAX)
30599 XMIN=MIN(X(I),XMIN)
30601 XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30604 DO 1100 K=0,IZEIL-1
30606 IF (ITEST.EQ.IYRAST) THEN
30607 DO 1010 L=1,ISPALT-1
30612 DO 1020 L=0,ISPALT-1,IXRAST
30616 DO 1030 L=1,ISPALT-1
30619 DO 1040 L=0,ISPALT-1,IXRAST
30629 YMIN=MAX(Y1(1),EPS)
30631 YMAX =MAX(Y1(I),YMAX)
30632 IF(Y1(I).GT.EPS) THEN
30633 IF(YMIN.EQ.EPS) THEN
30636 YMIN = MIN(Y1(I),YMIN)
30642 YMAX=MAX(Y2(I),YMAX)
30643 IF(Y2(I).GT.EPS) THEN
30644 IF(YMIN.EQ.EPS) THEN
30647 YMIN = MIN(Y2(I),YMIN)
30654 Y1(I) = MAX(Y1(I),YMIN)
30658 Y2(I) = MAX(Y2(I),YMIN)
30662 IF(YMAX.LE.YMIN) THEN
30663 WRITE(LOUT,'(/1X,A,2E12.3,/)')
30664 & 'XGLOGY:ERROR:YMIN,YMAX ',YMIN,YMAX
30665 WRITE(LOUT,'(1X,A)') 'MIN = MAX, OUTPUT SUPPRESSED'
30669 YMA=(LOG10(YMAX)-LOG10(YMIN))/20.0D0+LOG10(YMAX)
30670 YMI=LOG10(YMIN)-(LOG10(YMAX)-LOG10(YMIN))/20.0D0
30671 YZOOM=(YMA-YMI)/DBLE(IZEIL)
30672 IF(YZOOM.LT.EPS) THEN
30673 WRITE(LOUT,'(1X,A)')
30674 & 'XGLOGY:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30683 L=NINT((X(K)-XMIN)/XZOOM)
30684 I=NINT((YMA-LOG10(Y1(K)))/YZOOM)
30685 IF(ILAST.GE.0) THEN
30688 DO 55 II=0,LD,SIGN(1,LD)
30689 DO 66 KK=0,ID,SIGN(1,ID)
30690 COL(II+LLAST,KK+ILAST)=SYMB(1)
30705 L=NINT((X(K)-XMIN)/XZOOM)
30706 I=NINT((YMA-LOG10(Y2(K)))/YZOOM)
30713 WRITE(LOUT,'(2X,A)') '(LOGARITHMIC Y AXIS)'
30714 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30716 C*** write range of X
30718 XZOOM1 = (XMAX-XMIN)/DBLE(7)
30719 WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30721 DO 1300 K=0,IZEIL-1
30722 YPOS=10.D0**(YMA-((DBLE(K)+0.5D0)*YZOOM))
30723 WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30724 110 FORMAT(1X,1PE9.2,70A1)
30727 C*** write range of X
30729 WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30730 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30731 120 FORMAT(6X,7(1PE10.3))
30735 *$ CREATE DT_SRPLOT.FOR
30738 *===plot===============================================================*
30740 SUBROUTINE DT_SRPLOT(X,Y,N,M,MM,XO,DX,YO,DY)
30742 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30745 PARAMETER ( LINP = 10 ,
30751 * J. Ranft, (FORTRAN-Programmierung,J.R.,Teubner, Leipzig, 72)
30752 * This is a subroutine of fluka to plot Y across the page
30753 * as a function of X down the page. Up to 37 curves can be
30754 * plotted in the same picture with different plotting characters.
30755 * Output of first 10 overprinted characters addad by FB 88
30756 * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
30759 * X = array containing the values of X
30760 * Y = array containing the values of Y
30761 * N = number of values in X and in Y
30762 * can exceed the fixed number of lines
30763 * M = number of different curves X,Y are containing
30764 * MM = number of points in each curve i.e. N=M*MM
30765 * XO = smallest value of X to be plotted
30766 * DX = increment of X between subsequent lines
30767 * YO = smallest value of Y to be plotted
30768 * DY = increment of Y between subsequent character spaces
30770 * other variables used inside:
30771 * XX = numbers along the X-coordinate axis
30772 * YY = numbers along the Y-coordinate axis
30773 * LL = ten lines temporary storage for the plot
30774 * L = character set used to plot different curves
30775 * LOV = memorizes overprinted symbols
30776 * the first 10 overprinted symbols are printed on
30777 * the end of the line to avoid ambiguities
30778 * (added by FB as considered quite helpful)
30780 *********************************************************************
30782 DIMENSION XX(61),YY(61),LL(101,10)
30783 DIMENSION X(N),Y(N),L(40),LOV(40,10)
30784 INTEGER*4 LL, L, LOV
30786 11H*,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HZ,
30787 21H+,1HA,1HO,1HB,1HC,1HD,1HE,1HF,1HG,1HH,
30788 31HI,1HJ,1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,
30789 41HS,1HT,1HU,1HV,1HW,1HX,1HY,1H1,1H-,1H /
30798 20 YY(I)=YO+10.0D0*AI*DY
30799 WRITE(LOUT, 500) (YY(I),I=1,11)
30821 AIX=(X(II)-(XO-DX/2.0D0))/DX+1.0D0
30822 AIY=(Y(II)-(YO-DY/2.0D0))/DY+1.0D0
30824 * changed Sept.88 by FB to avoid INTEGER OVERFLOW
30825 IF( AIX .GT. 1.D0.AND. AIX .LT. 11.D0.AND. AIY .GT. 1.D0.AND
30826 + . AIY .LT. 102.D0) THEN
30829 IF( IX.GT. 0.AND. IX.LE. 10.AND. IY.GT. 0.AND. IY.LE. 101)
30831 IF(LL(IY,IX).NE.L(38).AND.LL(IY,IX).NE.L(39)) LOV(I,IX)
30842 WRITE(LOUT,510) XX(II),XX(III) , (LL(J,I),J=1,101) ,
30843 & (LOV(J,I),J=1,10)
30849 WRITE(LOUT, 500) (YY(I),I=1,11)
30852 500 FORMAT(11X,11(1PE10.2),11HOVERPRINTED)
30853 510 FORMAT(1X,2(1PE10.2),101A1,1H ,10A1)
30854 520 FORMAT(20X,10('1---------'),'1')
30856 *$ CREATE DT_DEFSET.FOR
30859 *===defset=============================================================*
30861 BLOCK DATA DT_DEFSET
30863 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30866 * flags for input different options
30867 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
30868 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
30869 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
30871 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
30873 * emulsion treatment
30874 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
30878 DATA IFRAG / 2, 1 /
30882 DATA IOULEV / -1, -1, -1, -1, -1, -1 /
30883 DATA LEMCCK / .FALSE. /
30884 DATA LHADRO / .FALSE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,
30885 & .TRUE.,.TRUE.,.TRUE./
30886 DATA LSEADI / .TRUE. /
30887 DATA LEVAPO / .TRUE. /
30892 DATA EMUFRA / NCOMPX*0.0D0 /
30893 DATA IEMUMA / NCOMPX*1 /
30894 DATA IEMUCH / NCOMPX*1 /
30900 *$ CREATE DT_HADPRP.FOR
30903 *===hadprp=============================================================*
30905 BLOCK DATA DT_HADPRP
30907 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30910 * auxiliary common for reggeon exchange (DTUNUC 1.x)
30911 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
30912 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
30913 & IQTCHR(-6:6),MQUARK(3,39)
30915 * hadron index conversion (BAMJET <--> PDG)
30916 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
30917 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
30920 * names of hadrons used in input-cards
30922 COMMON /DTPAIN/ BTYPE(30)
30925 *----------------------------------------------------------------------*
30927 * Quark content of particles: *
30928 * index quark el. charge bar. charge isospin isospin3 *
30929 * 1 = u 2/3 1/3 1/2 1/2 *
30930 * -1 = ubar -2/3 -1/3 1/2 -1/2 *
30931 * 2 = d -1/3 1/3 1/2 -1/2 *
30932 * -2 = dbar 1/3 -1/3 1/2 1/2 *
30933 * 3 = s -1/3 1/3 0 0 *
30934 * -3 = sbar 1/3 -1/3 0 0 *
30935 * 4 = c 2/3 1/3 0 0 *
30936 * -4 = cbar -2/3 -1/3 0 0 *
30937 * 5 = b -1/3 1/3 0 0 *
30938 * -5 = bbar 1/3 -1/3 0 0 *
30939 * 6 = t 2/3 1/3 0 0 *
30940 * -6 = tbar -2/3 -1/3 0 0 *
30942 * Mquark = particle quark composition (Paprop numbering) *
30943 * Iqechr = electric charge ( in 1/3 unit ) *
30944 * Iqbchr = baryonic charge ( in 1/3 unit ) *
30945 * Iqichr = isospin ( in 1/2 unit ), z component *
30946 * Iqschr = strangeness *
30948 * Iquchr = beauty *
30949 * Iqtchr = ...... *
30951 *----------------------------------------------------------------------*
30952 DATA IQECHR / -2, 1, -2, 1, 1, -2, 0, 2, -1, -1, 2, -1, 2 /
30953 DATA IQBCHR / 6*-1, 0, 6*1 /
30954 DATA IQICHR / 4*0, 1, -1, 0, 1, -1, 4*0 /
30955 DATA IQSCHR / 3*0, 1, 5*0, -1, 3*0 /
30956 DATA IQCCHR / 2*0, -1, 7*0, 1, 2*0 /
30957 DATA IQUCHR / 0, 1, 9*0, -1, 0 /
30958 DATA IQTCHR / -1, 11*0, 1 /
30960 & 2, 1, 1, -2,-1,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
30961 & 0, 0, 0, 0, 0, 0, 2, 2, 1, -2,-2,-1, 0, 0, 0,
30962 & 0, 0, 0, 0, 0, 0, 1,-2, 0, 2,-1, 0, 1,-3, 0,
30963 & 3,-1, 0, 1, 2, 3, -1,-2,-3, 0, 0, 0, 2, 2, 3,
30964 & 1, 1, 3, 1, 2, 3, 1,-1, 0, 2,-3, 0, 3,-2, 0,
30965 & 2,-2, 0, 3,-3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
30966 & -1,-1,-3, -1,-2,-3, -2,-2,-3, 1, 3, 3, -1,-3,-3,
30967 & 2, 3, 3, -2,-3,-3, 3, 3, 3, -3,-3,-3 /
30970 * (renamed) (HAdron InDex COnversion)
30971 * translation table version filled up by r.e. 25.01.94 *
30973 &2212,-2212,11,-11,12, -12,22,2112,-2112,-13,
30974 &13,130,211,-211,321, -321,3122,-3122,310,3112,
30975 &3222,3212,111,311,-311, 0,0,0,0,0,
30976 &221,213,113,-213,223, 323,313,-323,-313,10323,
30977 &10313,-10323,-10313,30323,30313, -30323,-30313,3224,3214,3114,
30978 &3216,3218,2224,2214,2114, 1114,12224,12214,12114,11114,
30979 &99999,99999,22212,22112,32124, 31214,-2224,-2214,-2114,-1114,
30980 &-12224,-12214,-12114,-11114,-2124, -1214,4*99999,
30982 &4*99999,331, 333,3322,3312,-3222,-3212,
30983 &-3112,-3322,-3312,3224,3214, 3114,3324,3314,3334,-3224,
30984 &-3214,-3114,-3324,-3314,-3334, 421,411,-411,-421,431,
30985 &-431,441,423,413,-413, -423,433,-433,20443,443,
30986 &-15,15,16,-16,14, -14,4122,4232,4132,4222,
30987 &4212,4112,3*99999, 3*99999,-4122,-4232,
30988 &-4132,-4222,-4212,-4112,99999, 5*99999,
30991 &5*99999 , 20211,20111,-20211,99999,20321,
30992 &-20321,20311,-20311,7*99999 ,
30993 &7*99999,12212,12112,99999/
30996 * (HAdron InDex COnversion)
30997 DATA (IPDG2(1,K),K=1,7)
30998 & / -11, -12, -13, -15, -16, -14, 0/
30999 DATA (IBAM2(1,K),K=1,7)
31000 & / 4, 6, 10, 131, 134, 136, 0/
31001 DATA (IPDG2(2,K),K=1,7)
31002 & / 11, 12, 22, 13, 15, 16, 14/
31003 DATA (IBAM2(2,K),K=1,7)
31004 & / 3, 5, 7, 11, 132, 133, 135/
31005 DATA (IPDG3(1,K),K=1,22)
31006 & / -211, -321, -311, -213, -323, -313, -411, -421,
31007 & -431, -413, -423, -433, 0, 0, 0, 0,
31008 & 0, 0, 0, 0, 0, 0/
31009 DATA (IBAM3(1,K),K=1,22)
31010 & / 14, 16, 25, 34, 38, 39, 118, 119,
31011 & 121, 125, 126, 128, 0, 0, 0, 0,
31012 & 0, 0, 0, 0, 0, 0/
31013 DATA (IPDG3(2,K),K=1,22)
31014 & / 130, 211, 321, 310, 111, 311, 221, 213,
31015 & 113, 223, 323, 313, 331, 333, 421, 411,
31016 & 431, 441, 423, 413, 433, 443/
31017 DATA (IBAM3(2,K),K=1,22)
31018 & / 12, 13, 15, 19, 23, 24, 31, 32,
31019 & 33, 35, 36, 37, 95, 96, 116, 117,
31020 & 120, 122, 123, 124, 127, 130/
31021 DATA (IPDG4(1,K),K=1,29)
31022 & / -2212, -2112, -3122, -2224, -2214, -2114, -1114, -2124,
31023 & -1214, -3222, -3212, -3112, -3322, -3312, -3224, -3214,
31024 & -3114, -3324, -3314, -3334, -4122, -4232, -4132, -4222,
31025 & -4212, -4112, 0, 0, 0/
31026 DATA (IBAM4(1,K),K=1,29)
31027 & / 2, 9, 18, 67, 68, 69, 70, 75,
31028 & 76, 99, 100, 101, 102, 103, 110, 111,
31029 & 112, 113, 114, 115, 149, 150, 151, 152,
31030 & 153, 154, 0, 0, 0/
31031 DATA (IPDG4(2,K),K=1,29)
31032 & / 2212, 2112, 3122, 3112, 3222, 3212, 3224, 3214,
31033 & 3114, 3216, 3218, 2224, 2214, 2114, 1114, 3322,
31034 & 3312, 3224, 3214, 3114, 3324, 3314, 3334, 4122,
31035 & 4232, 4132, 4222, 4212, 4112/
31036 DATA (IBAM4(2,K),K=1,29)
31037 & / 1, 8, 17, 20, 21, 22, 48, 49,
31038 & 50, 51, 52, 53, 54, 55, 56, 97,
31039 & 98, 104, 105, 106, 107, 108, 109, 137,
31040 & 138, 139, 140, 141, 142/
31041 DATA (IPDG5(1,K),K=1,19)
31042 & /-10323,-10313,-30323,-30313,-12224,-12214,-12114,-11114,
31043 & -20211,-20321,-20311, 0, 0, 0, 0, 0,
31045 DATA (IBAM5(1,K),K=1,19)
31046 & / 42, 43, 46, 47, 71, 72, 73, 74,
31047 & 188, 191, 193, 0, 0, 0, 0, 0,
31049 DATA (IPDG5(2,K),K=1,19)
31050 & / 10323, 10313, 30323, 30313, 12224, 12214, 12114, 11114,
31051 & 22212, 22112, 32124, 31214, 20443, 20211, 20111, 20321,
31052 & 20311, 12212, 12112/
31053 DATA (IBAM5(2,K),K=1,19)
31054 & / 40, 41, 44, 45, 57, 58, 59, 60,
31055 & 63, 64, 65, 66, 129, 186, 187, 190,
31059 * internal particle names
31060 DATA BTYPE / 'PROTON ' , 'APROTON ' , 'ELECTRON' , 'POSITRON' ,
31061 &'NEUTRIE ' , 'ANEUTRIE' , 'PHOTON ' , 'NEUTRON ' , 'ANEUTRON' ,
31062 &'MUON+ ' , 'MUON- ' , 'KAONLONG' , 'PION+ ' , 'PION- ' ,
31063 &'KAON+ ' , 'KAON- ' , 'LAMBDA ' , 'ALAMBDA ' , 'KAONSHRT' ,
31064 &'SIGMA- ' , 'SIGMA+ ' , 'SIGMAZER' , 'PIZERO ' , 'KAONZERO' ,
31065 &'AKAONZER' , 'NEUTRIM ' , 'ANEUTRIM' , 'NEUTRIT ' , 'ANEUTRIT' ,
31070 *$ CREATE DT_BLKD46.FOR
31073 *===blkd46=============================================================*
31075 BLOCK DATA DT_BLKD46
31077 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31080 PARAMETER ( AMELCT = 0.51099906 D-03 )
31081 PARAMETER ( AMMUON = 0.105658389 D+00 )
31083 * particle properties (BAMJET index convention)
31085 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
31086 & IICH(210),IIBAR(210),K1(210),K2(210)
31089 * Particle masses Engel version JETSET compatible
31090 C DATA (AAM(K),K=1,85) /
31091 C & .9383D+00, .9383D+00, AMELCT , AMELCT , .0000D+00,
31092 C & .0000D+00, .0000D+00, .9396D+00, .9396D+00, AMMUON ,
31093 C & AMMUON , .4977D+00, .1396D+00, .1396D+00, .4936D+00,
31094 C & .4936D+00, .1116D+01, .1116D+01, .4977D+00, .1197D+01,
31095 C & .1189D+01, .1193D+01, .1350D+00, .4977D+00, .4977D+00,
31096 C & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31097 C & .5488D+00, .7669D+00, .7700D+00, .7669D+00, .7820D+00,
31098 C & .8921D+00, .8962D+00, .8921D+00, .8962D+00, .1300D+01,
31099 C & .1300D+01, .1300D+01, .1300D+01, .1421D+01, .1421D+01,
31100 C & .1421D+01, .1421D+01, .1383D+01, .1384D+01, .1387D+01,
31101 C & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
31102 C & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
31103 C & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
31104 C & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
31105 C & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
31106 C & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
31107 C & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 /
31108 C DATA (AAM(K),K=86,183) /
31109 C & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
31110 C & .1700D+01, .1700D+01, .1820D+01, .2030D+01, .9575D+00,
31111 C & .1019D+01, .1315D+01, .1321D+01, .1189D+01, .1193D+01,
31112 C & .1197D+01, .1315D+01, .1321D+01, .1383D+01, .1384D+01,
31113 C & .1387D+01, .1532D+01, .1535D+01, .1672D+01, .1383D+01,
31114 C & .1384D+01, .1387D+01, .1532D+01, .1535D+01, .1672D+01,
31115 C & .1865D+01, .1869D+01, .1869D+01, .1865D+01, .1969D+01,
31116 C & .1969D+01, .2980D+01, .2007D+01, .2010D+01, .2010D+01,
31117 C & .2007D+01, .2113D+01, .2113D+01, .3686D+01, .3097D+01,
31118 C & .1784D+01, .1784D+01, .0000D+00, .0000D+00, .0000D+00,
31119 C & .0000D+00, .2285D+01, .2460D+01, .2460D+01, .2452D+01,
31120 C & .2453D+01, .2454D+01, .2560D+01, .2560D+01, .2730D+01,
31121 C & .3610D+01, .3610D+01, .3790D+01, .2285D+01, .2460D+01,
31122 C & .2460D+01, .2452D+01, .2453D+01, .2454D+01, .2560D+01,
31123 C & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
31124 C & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31125 C & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31126 C & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31127 C & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31128 C & .1250D+01, .1250D+01, .1250D+01 /
31129 C DATA (AAM ( I ), I = 184,210 ) /
31130 C & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31131 C & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31132 C & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31133 C & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31134 C & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31135 C & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31136 C & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31137 C & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31138 C & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31139 * sr 25.1.06: particle masses adjusted to Pythia
31140 DATA (AAM(K),K=1,85) /
31141 & .938270E+00,.938270E+00, AMELCT , AMELCT ,.000000E+00,
31142 & .000000E+00,.000000E+00,.939570E+00,.939570E+00, AMMUON ,
31143 & AMMUON ,.497670E+00,.139570E+00,.139570E+00,.493600E+00,
31144 & .493600E+00,.111568E+01,.111568E+01,.497670E+00,.119744E+01,
31145 & .118937E+01,.119255E+01,.134980E+00,.497670E+00,.497670E+00,
31146 & .0000D+00, .0000D+00, .0000D+00 , .0000D+00, .0000D+00,
31147 & .547450E+00,.766900E+00,.768500E+00,.766900E+00,.781940E+00,
31148 & .891600E+00,.896100E+00,.891600E+00,.896100E+00,.129000E+01,
31149 & .129000E+01,.129000E+01,.129000E+01, .1421D+01, .1421D+01,
31150 & .1421D+01, .1421D+01,.138280E+01,.138370E+01,.138720E+01,
31151 & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
31152 & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
31153 & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
31154 & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
31155 & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
31156 & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
31157 & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 /
31158 DATA (AAM(K),K=86,183) /
31159 & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
31160 & .1700D+01, .1700D+01, .1820D+01, .2030D+01,.957770E+00,
31161 & .101940E+01,.131490E+01,.132130E+01,.118937E+01,.119255E+01,
31162 & .119744E+01,.131490E+01,.132130E+01,.138280E+01,.138370E+01,
31163 & .138720E+01,.153180E+01, .1535D+01,.167245E+01,.138280E+01,
31164 & .138370E+01,.138720E+01,.153180E+01, .1535D+01,.167245E+01,
31165 & .186450E+01,.186930E+01,.186930E+01,.186450E+01,.196850E+01,
31166 & .196850E+01,.297980E+01,.200670E+01, .2010D+01, .2010D+01,
31167 & .200670E+01,.211240E+01,.211240E+01, .3686D+01,.309688E+01,
31168 & .177700E+01,.177700E+01, .0000D+00, .0000D+00, .0000D+00,
31169 & .0000D+00,.228490E+01,.246560E+01,.247030E+01,.245290E+01,
31170 & .245350E+01,.245210E+01, .2560D+01, .2560D+01, .2730D+01,
31171 & .3610D+01, .3610D+01, .3790D+01,.228490E+01,.246560E+01,
31172 & .2460D+01,.245290E+01,.245350E+01,.245210E+01, .2560D+01,
31173 & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
31174 & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31175 & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31176 & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31177 & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31178 & .1250D+01, .1250D+01, .1250D+01 /
31179 DATA (AAM ( I ), I = 184,210 ) /
31180 & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31181 & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31182 & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31183 & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31184 & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31185 & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31186 & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31187 & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31188 & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31189 * Particle mean lives
31190 DATA (TAU(K),K=1,183) /
31191 & .1000D+19, .1000D+19, .1000D+19, .1000D+19, .1000D+19,
31192 & .1000D+19, .1000D+19, .9180D+03, .9180D+03, .2200D-05,
31193 & .2200D-05, .5200D-07, .2600D-07, .2600D-07, .1200D-07,
31194 & .1200D-07, .2600D-09, .2600D-09, .9000D-10, .1500D-09,
31195 & .8000D-10, .5000D-14, .8000D-16, .0000D+00, .0000D+00,
31197 & .0000D+00, .3000D-09, .1700D-09, .8000D-10, .1000D-13,
31198 & .1500D-09, .3000D-09, .1700D-09, .0000D+00, .0000D+00,
31199 & .0000D+00, .0000D+00, .0000D+00, .1000D-09, .0000D+00,
31200 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .1000D-09,
31201 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31202 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31203 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31204 & .9000D-11, .9000D-11, .9000D-11, .9000D-11, .1000D+19,
31205 & .1000D+19, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31207 & .0000D+00, .0000D+00, .0000D+00 /
31208 DATA ( TAU ( I ), I = 184,210 ) /
31209 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31210 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31211 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31212 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31213 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31214 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31215 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31216 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31217 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00/
31218 * Resonance width Gamma in GeV
31219 DATA (GA(K),K= 1,85) /
31221 & .8500D-06, .1520D+00, .1520D+00, .1520D+00, .1000D-01,
31222 & .7900D-01, .7900D-01, .7900D-01, .7900D-01, .4500D+00,
31223 & .4500D+00, .4500D+00, .4500D+00, .1080D+00, .1080D+00,
31224 & .1080D+00, .1080D+00, .5000D-01, .5000D-01, .5000D-01,
31225 & .8500D-01, .1800D+00, .1150D+00, .1150D+00, .1150D+00,
31226 & .1150D+00, .2000D+00, .2000D+00, .2000D+00, .2000D+00,
31227 & .2000D+00, .2000D+00, .1000D+00, .1000D+00, .2000D+00,
31228 & .2000D+00, .1150D+00, .1150D+00, .1150D+00, .1150D+00,
31229 & .2000D+00, .2000D+00, .2000D+00, .2000D+00, .1000D+00,
31230 & .1000D+00, .2000D+00, .1000D+00, .1000D+00, .1000D+00,
31231 & .1000D+00, .1000D+00, .1000D+00, .1000D+00, .2000D+00 /
31232 DATA (GA(K),K= 86,183) /
31233 & .2000D+00, .2000D+00, .2000D+00, .1500D+00, .1500D+00,
31234 & .1500D+00, .1500D+00, .8500D-01, .1800D+00, .2000D-02,
31235 & .4000D-02, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31236 & .0000D+00, .0000D+00, .0000D+00, .3400D-01, .3400D-01,
31237 & .3600D-01, .9000D-02, .9000D-02, .0000D+00, .3400D-01,
31238 & .3400D-01, .3600D-01, .9000D-02, .9000D-02, .0000D+00,
31239 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31240 & .0000D+00, .0000D+00, .5000D-02, .2000D-02, .2000D-02,
31241 & .5000D-02, .2000D-02, .2000D-02, .2000D-03, .7000D-03,
31243 & .3000D+00, .3000D+00, .3000D+00 /
31244 DATA ( GA ( I ), I = 184,210 ) /
31245 & 2.00000000000000D-01, 2.00000000000000D-01, 3.00000000000000D-01,
31246 & 3.00000000000000D-01, 3.00000000000000D-01, 2.70000000000000D-01,
31247 & 2.50000000000000D-01, 2.50000000000000D-01, 2.50000000000000D-01,
31248 & 2.50000000000000D-01, 1.50000000000000D-01, 1.50000000000000D-01,
31249 & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31250 & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31251 & 6.00000000000000D-02, 6.00000000000000D-02, 6.00000000000000D-02,
31252 & 6.00000000000000D-02, 5.50000000000000D-02, 5.50000000000000D-02,
31253 & 2.00000000000000D-01, 2.00000000000000D-01, 0.00000000000000D+00/
31255 * S+1385+Sigma+(1385) L02030+Lambda0(2030)
31256 * Rho77=Rho(770) Om783=Omega(783) K*14=K*(1420) and so on
31257 * designation N*@@ means N*@1(@2)
31258 DATA (ANAME(K),K=1,85) /
31259 & 'P ','AP ','E- ','E+ ','NUE ',
31260 & 'ANUE ','GAM ','NEU ','ANEU ','MUE+ ',
31261 & 'MUE- ','K0L ','PI+ ','PI- ','K+ ',
31262 & 'K- ','LAM ','ALAM ','K0S ','SIGM- ',
31263 & 'SIGM+ ','SIGM0 ','PI0 ','K0 ','AK0 ',
31264 & 'BLANK ','BLANK ','BLANK ','BLANK ','BLANK ',
31265 & 'ETA550 ','RHO+77 ','RHO077 ','RHO-77 ','OM0783 ',
31266 & 'K*+892 ','K*0892 ','K*-892 ','AK*089 ','KA+125 ',
31267 & 'KA0125 ','KA-125 ','AKA012 ','K*+142 ','K*0142 ',
31268 & 'K*-142 ','AK*014 ','S+1385 ','S01385 ','S-1385 ',
31269 & 'L01820 ','L02030 ','N*++12 ','N*+ 12 ','N*012 ',
31270 & 'N*-12 ','N*++16 ','N*+16 ','N*016 ','N*-16 ',
31271 & 'N*+14 ','N*014 ','N*+15 ','N*015 ','N*+18 ',
31272 & 'N*018 ','AN--12 ','AN*-12 ','AN*012 ','AN*+12 ',
31273 & 'AN--16 ','AN*-16 ','AN*016 ','AN*+16 ','AN*-15 ',
31274 & 'AN*015 ','DE*=24 ','RPI+49 ','RPI049 ','RPI-49 ',
31275 & 'PIN++ ','PIN+0 ','PIN+- ','PIN-0 ','PPPI ' /
31276 DATA (ANAME(K),K=86,183) /
31277 & 'PNPI ','APPPI ','APNPI ','K+PPI ','K-PPI ',
31278 & 'K+NPI ','K-NPI ','S+1820 ','S-2030 ','ETA* ',
31279 & 'PHI ','TETA0 ','TETA- ','ASIG- ','ASIG0 ',
31280 & 'ASIG+ ','ATETA0 ','ATETA+ ','SIG*+ ','SIG*0 ',
31281 & 'SIG*- ','TETA*0 ','TETA* ','OMEGA- ','ASIG*- ',
31282 & 'ASIG*0 ','ASIG*+ ','ATET*0 ','ATET*+ ','OMEGA+ ',
31283 & 'D0 ','D+ ','D- ','AD0 ','F+ ',
31284 & 'F- ','ETAC ','D*0 ','D*+ ','D*- ',
31285 & 'AD*0 ','F*+ ','F*- ','PSI ','JPSI ',
31286 & 'TAU+ ','TAU- ','NUET ','ANUET ','NUEM ',
31287 & 'ANUEM ','C0+ ','A+ ','A0 ','C1++ ',
31288 & 'C1+ ','C10 ','S+ ','S0 ','T0 ',
31289 & 'XU++ ','XD+ ','XS+ ','AC0- ','AA- ',
31290 & 'AA0 ','AC1-- ','AC1- ','AC10 ','AS- ',
31291 & 'AS0 ','AT0 ','AXU-- ','AXD- ','AXS ',
31292 & 'C1*++ ','C1*+ ','C1*0 ','S*+ ','S*0 ',
31293 & 'T*0 ','XU*++ ','XD*+ ','XS*+ ','TETA++ ',
31294 & 'AC1*-- ','AC1*- ','AC1*0 ','AS*- ','AS*0 ',
31295 & 'AT*0 ','AXU*-- ','AXD*- ','AXS*- ','ATET-- ',
31296 & 'RO ','R+ ','R- ' /
31297 DATA ( ANAME ( I ), I = 184,210 ) /
31298 &'AN*-14 ','AN*014 ','PI+130 ','PI0130 ','PI-130 ','F01400 ',
31299 &'K*+146 ','K*-146 ','K*0146 ','AK0146 ','L01600 ','AL0160 ',
31300 &'S+1660 ','S01660 ','S-1660 ','AS-166 ','AS0166 ','AS+166 ',
31301 &'X01950 ','X-1950 ','AX0195 ','AX+195 ','OM-225 ','AOM+22 ',
31302 &'N*+14 ','N*014 ','BLANK '/
31303 * Charge of particles and resonances
31304 DATA (IICH ( I ), I = 1,210 ) /
31305 & 1, -1, -1, 1, 0, 0, 0, 0, 0, 1, -1, 0, 1, -1, 1,
31306 & -1, 0, 0, 0, -1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31307 & 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0,
31308 & -1, 0, 1, 0, -1, 0, 0, 2, 1, 0, -1, 2, 1, 0, -1,
31309 & 1, 0, 1, 0, 1, 0, -2, -1, 0, 1, -2, -1, 0, 1, -1,
31310 & 0, 1, 1, 0, -1, 2, 1, 0, -1, 2, 1, 0, -1, 2, 0,
31311 & 1, -1, 1, -1, 0, 0, 0, -1, -1, 0, 1, 0, 1, 1, 0,
31312 & -1, 0, -1, -1, -1, 0, 1, 0, 1, 1, 0, 1, -1, 0, 1,
31313 & -1, 0, 0, 1, -1, 0, 1, -1, 0, 0, 1, -1, 0, 0, 0,
31314 & 0, 1, 1, 0, 2, 1, 0, 1, 0, 0, 2, 1, 1, -1, -1,
31315 & 0, -2, -1, 0, -1, 0, 0, -2, -1, -1, 2, 1, 0, 1, 0,
31316 & 0, 2, 1, 1, 2, -2, -1, 0, -1, 0, 0, -2, -1, -1, -2,
31317 & 0, 1, -1, -1, 0, 1, 0, -1, 0, 1, -1, 0, 0, 0, 0,
31318 & 1, 0, -1, -1, 0, 1, 0, -1, 0, 1, -1, 1, 1, 0, 0/
31319 * Particle baryonic charges
31320 DATA (IIBAR ( I ), I = 1,210 ) /
31321 & 1, -1, 0, 0, 0, 0, 0, 1, -1, 0, 0, 0, 0, 0, 0,
31322 & 0, 1, -1, 0, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0,
31323 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31324 & 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
31325 & 1, 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31326 & -1, 2, 0, 0, 0, 1, 1, 1, 1, 2, 2, 0, 0, 1, 1,
31327 & 1, 1, 1, 1, 0, 0, 1, 1, -1, -1, -1, -1, -1, 1, 1,
31328 & 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, 0, 0, 0, 0, 0,
31329 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31330 & 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, -1, -1,
31331 & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 1, 1, 1, 1, 1,
31332 & 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31333 & 0, 0, 0, -1, -1, 0, 0, 0, 0, 0, 0, 0, 0, 1, -1,
31334 & 1, 1, 1, -1, -1, -1, 1, 1, -1, -1, 1, -1, 1, 1, 0/
31335 * First number of decay channels used for resonances
31336 * and decaying particles
31337 DATA K1/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 16, 17,
31338 & 18, 24, 30, 34, 38, 40, 41, 43, 44, 136, 138, 330, 327, 328,
31339 & 2*330, 46, 51, 52, 54, 55, 58,
31341 & 60, 62, 64, 66, 68, 70, 72, 74, 82, 90, 98, 106, 109, 112, 114,
31342 & 123, 140, 141, 143, 145, 146, 150, 157, 164, 168, 174, 180, 187,
31343 & 194, 202, 210, 211, 213, 215, 216, 220, 227, 234, 238, 245, 252,
31345 & 254, 255, 256, 257, 259, 262, 265, 267, 269, 272, 276, 279, 282,
31346 & 286, 290, 293, 299, 331, 335, 339, 340, 341, 343, 344, 345, 346,
31347 & 347, 350, 353, 356, 358, 360, 363, 366, 369, 372, 374, 376, 379,
31348 & 383, 385, 387, 391, 394, 397, 400, 402, 405, 408, 410, 412, 414,
31349 & 417, 420, 425, 430, 431, 432, 433, 434, 448, 452, 457, 458, 459,
31350 & 460, 461, 462, 466, 468, 470, 472, 486, 490, 495, 496, 497, 498,
31351 & 499, 500, 504, 506, 508, 510, 511, 512, 513, 514, 515, 516, 517,
31352 & 518, 519, 522, 523, 524, 525, 526, 527, 528, 529, 530, 531, 534,
31353 & 537, 539, 541, 547, 553, 558, 563, 568, 572, 573, 574, 575, 576,
31354 & 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, 589,
31356 * Last number of decay channels used for resonances
31357 * and decaying particles
31358 DATA K2/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 15, 16, 17,
31359 & 23, 29, 31, 35, 39, 40, 42, 43, 45, 137, 139, 330, 327, 328,
31360 & 2* 330, 50, 51, 53, 54, 57,
31362 & 59, 61, 63, 65, 67, 69, 71, 73, 81, 89, 97, 105, 108, 111, 113,
31363 & 122, 135, 140, 142, 144, 145, 149, 156, 163, 167, 173, 179, 186,
31364 & 193, 201, 209, 210, 212, 214, 215, 219, 226, 233, 237, 244, 251,
31366 & 253, 254, 255, 256, 258, 261, 264, 266, 268, 271, 275, 278, 281,
31367 & 285, 289, 292, 298, 307, 334, 338, 339, 340, 342, 343, 344, 345,
31368 & 346, 349, 352, 355, 357, 359, 362, 365, 368, 371, 373, 375, 378,
31369 & 382, 384, 386, 390, 393, 396, 399, 401, 404, 407, 409, 411, 413,
31370 & 416, 419, 424, 429, 430, 431, 432, 433, 447, 451, 456, 457, 458,
31371 & 459, 460, 461, 465, 467, 469, 471, 485, 489, 494, 495, 496, 497,
31372 & 498, 499, 503, 505, 507, 509, 510, 511, 512, 513, 514, 515, 516,
31373 & 517, 518, 521, 522, 523, 524, 525, 526, 527, 528, 529, 530, 533,
31374 & 536, 538, 540, 546, 552, 557, 562, 567, 571, 572, 573, 574, 575,
31375 & 576, 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588,
31376 & 589, 595, 601, 602 /
31380 *$ CREATE DT_BLKD47.FOR
31383 *===blkd47=============================================================*
31385 BLOCK DATA DT_BLKD47
31387 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31390 * HADRIN: decay channel information
31391 PARAMETER (IDMAX9=602)
31393 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
31395 * Name of decay channel
31396 * Designation N*@ means N*@1(1236)
31397 * @1=# means ++, @1 = = means --
31398 * Designation P+/0/- means Pi+/Pi0/Pi- , respectively
31399 DATA (ZKNAME(K),K= 1, 85) /
31400 & 'P ','AP ','E- ','E+ ','NUE ',
31401 & 'ANUE ','GAM ','PE-NUE ','APEANU ','EANUNU ',
31402 & 'E-NUAN ','3PI0 ','PI+-0 ','PIMUNU ','PIE-NU ',
31403 & 'MU+NUE ','MU-NUE ','MU+NUE ','PI+PI0 ','PI++- ',
31404 & 'PI+00 ','M+P0NU ','E+P0NU ','MU-NU ','PI-0 ',
31405 & 'PI+-- ','PI-00 ','M-P0NU ','E-P0NU ','PPI- ',
31406 & 'NPI0 ','PD-NUE ','PM-NUE ','APPI+ ','ANPI0 ',
31407 & 'APE+NU ','APM+NU ','PI+PI- ','PI0PI0 ','NPI- ',
31408 & 'PPI0 ','NPI+ ','LAGA ','GAGA ','GAE+E- ',
31409 & 'GAGA ','GAGAP0 ','PI000 ','PI+-0 ','PI+-GA ',
31410 & 'PI+0 ','PI+- ','PI00 ','PI-0 ','PI+-0 ',
31411 & 'PI+- ','PI0GA ','K+PI0 ','K0PI+ ','KOPI0 ',
31412 & 'K+PI- ','K-PI0 ','AK0PI- ','AK0PI0 ','K-PI+ ',
31413 & 'K+PI0 ','K0PI+ ','K0PI0 ','K+PI- ','K-PI0 ',
31414 & 'K0PI- ','AK0PI0 ','K-PI+ ','K+PI0 ','K0PI+ ',
31415 & 'K+89P0 ','K08PI+ ','K+RO77 ','K0RO+7 ','K+OM07 ',
31416 & 'K+E055 ','K0PI0 ','K+PI+ ','K089P0 ','K+8PI- ' /
31417 DATA (ZKNAME(K),K= 86,170) /
31418 & 'K0R077 ','K+R-77 ','K+R-77 ','K0OM07 ','K0E055 ',
31419 & 'K-PI0 ','K0PI- ','K-89P0 ','AK08P- ','K-R077 ',
31420 & 'AK0R-7 ','K-OM07 ','K-E055 ','AK0PI0 ','K-PI+ ',
31421 & 'AK08P0 ','K-8PI+ ','AK0R07 ','AK0OM7 ','AK0E05 ',
31422 & 'LA0PI+ ','SI0PI+ ','SI+PI0 ','LA0PI0 ','SI+PI- ',
31423 & 'SI-PI+ ','LA0PI- ','SI0PI- ','NEUAK0 ','PK- ',
31424 & 'SI+PI- ','SI0PI0 ','SI-PI+ ','LA0ET0 ','S+1PI- ',
31425 & 'S-1PI+ ','SO1PI0 ','NEUAK0 ','PK- ','LA0PI0 ',
31426 & 'LA0OM0 ','LA0RO0 ','SI+RO- ','SI-RO+ ','SI0RO0 ',
31427 & 'LA0ET0 ','SI0ET0 ','SI+PI- ','SI-PI+ ','SI0PI0 ',
31428 & 'K0S ','K0L ','K0S ','K0L ','P PI+ ',
31429 & 'P PI0 ','N PI+ ','P PI- ','N PI0 ','N PI- ',
31430 & 'P PI+ ','N*#PI0 ','N*+PI+ ','PRHO+ ','P PI0 ',
31431 & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ',
31432 & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ',
31433 & 'N*-PI+ ','PRHO- ','NRHO0 ','N PI- ','N*0PI- ',
31434 & 'N*-PI0 ','NRHO- ','PETA0 ','N*#PI- ','N*+PI0 ' /
31435 DATA (ZKNAME(K),K=171,255) /
31436 & 'N*0PI+ ','PRHO0 ','NRHO+ ','NETA0 ','N*+PI- ',
31437 & 'N*0PI0 ','N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ',
31438 & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ',
31439 & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ',
31440 & 'N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ','N PI+ ',
31441 & 'PRHO0 ','NRHO+ ','LAMK+ ','S+ K0 ','S0 K+ ',
31442 & 'PETA0 ','P PI- ','N PI0 ','PRHO- ','NRHO0 ',
31443 & 'LAMK0 ','S0 K0 ','S- K+ ','NETA/ ','APPI- ',
31444 & 'APPI0 ','ANPI- ','APPI+ ','ANPI0 ','ANPI+ ',
31445 & 'APPI- ','AN*=P0 ','AN*-P- ','APRHO- ','APPI0 ',
31446 & 'ANPI- ','AN*=P+ ','AN*-P0 ','AN*0P- ','APRHO0 ',
31447 & 'ANRHO- ','APPI+ ','ANPI0 ','AN*-P+ ','AN*0P0 ',
31448 & 'AN*+P- ','APRHO+ ','ANRHO0 ','ANPI+ ','AN*0P+ ',
31449 & 'AN*+P0 ','ANRHO+ ','APPI0 ','ANPI- ','AN*=P+ ',
31450 & 'AN*-P0 ','AN*0P- ','APRHO0 ','ANRHO- ','APPI+, ',
31451 & 'ANPI0 ','AN*-P+ ','AN*0P0 ','AN*+P- ','APRHO+ ',
31452 & 'ANRHO0 ','PN*014 ','NN*=14 ','PI+0 ','PI+- ' /
31453 DATA (ZKNAME(K),K=256,340) /
31454 & 'PI-0 ','P+0 ','N++ ','P+- ','P00 ',
31455 & 'N+0 ','N+- ','N00 ','P-0 ','N-0 ',
31456 & 'P-- ','PPPI0 ','PNPI+ ','PNPI0 ','PPPI- ',
31457 & 'NNPI+ ','APPPI0 ','APNPI+ ','ANNPI0 ','ANPPI- ',
31458 & 'APNPI0 ','APPPI- ','ANNPI- ','K+PPI0 ','K+NPI+ ',
31459 & 'K0PPI0 ','K-PPI0 ','K-NPI+ ','AKPPI- ','AKNPI0 ',
31460 & 'K+NPI0 ','K+PPI- ','K0PPI0 ','K0NPI+ ','K-NPI0 ',
31461 & 'K-PPI- ','AKNPI- ','PAK0 ','SI+PI0 ','SI0PI+ ',
31462 & 'SI+ETA ','S+1PI0 ','S01PI+ ','NEUK- ','LA0PI- ',
31463 & 'SI-OM0 ','LA0RO- ','SI0RO- ','SI-RO0 ','SI-ET0 ',
31464 & 'SI0PI- ','SI-0 ','BLANC ','BLANC ','BLANC ',
31465 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31466 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31467 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31468 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31469 & 'EPI+- ','EPI00 ','GAPI+- ','GAGA* ','K+- ',
31470 & 'KLKS ','PI+-0 ','EGA ','LPI0 ','LPI ' /
31471 DATA (ZKNAME(K),K=341,425) /
31472 & 'APPI0 ','ANPI- ','ALAGA ','ANPI ','ALPI0 ',
31473 & 'ALPI+ ','LAPI+ ','SI+PI0 ','SI0PI+ ','LAPI0 ',
31474 & 'SI+PI- ','SI-PI+ ','LAPI- ','SI-PI0 ','SI0PI- ',
31475 & 'TE0PI0 ','TE-PI+ ','TE0PI- ','TE-PI0 ','TE0PI ',
31476 & 'TE-PI ','LAK- ','ALPI- ','AS-PI0 ','AS0PI- ',
31477 & 'ALPI0 ','AS+PI- ','AS-PI+ ','ALPI+ ','AS+PI0 ',
31478 & 'AS0PI+ ','AT0PI0 ','AT+PI- ','AT0PI+ ','AT+PI0 ',
31479 & 'AT0PI ','AT+PI ','ALK+ ','K-PI+ ','K-PI+0 ',
31480 & 'K0PI+- ','K0PI0 ','K-PI++ ','AK0PI+ ','K+PI-- ',
31481 & 'K0PI- ','K+PI- ','K+PI-0 ','AKPI-+ ','AK0PI0 ',
31482 & 'ETAPIF ','K++- ','K+AK0 ','ETAPI- ','K--+ ',
31483 & 'K-K0 ','PI00 ','PI+- ','GAGA ','D0PI0 ',
31484 & 'D0GA ','D0PI+ ','D+PI0 ','DFGA ','AD0PI- ',
31485 & 'D-PI0 ','D-GA ','AD0PI0 ','AD0GA ','F+GA ',
31486 & 'F+GA ','F-GA ','F-GA ','PSPI+- ','PSPI00 ',
31487 & 'PSETA ','E+E- ','MUE+- ','PI+-0 ','M+NN ',
31488 & 'E+NN ','RHO+NT ','PI+ANT ','K*+ANT ','M-NN ' /
31489 DATA (ZKNAME(K),K=426,510) /
31490 & 'E-NN ','RHO-NT ','PI-NT ','K*-NT ','NUET ',
31491 & 'ANUET ','NUEM ','ANUEM ','SI+ETA ','SI+ET* ',
31492 & 'PAK0 ','TET0K+ ','SI*+ET ','N*+AK0 ','N*++K- ',
31493 & 'LAMRO+ ','SI0RO+ ','SI+RO0 ','SI+OME ','PAK*0 ',
31494 & 'N*+AK* ','N*++K* ','SI+AK0 ','TET0PI ','SI+AK* ',
31495 & 'TET0RO ','SI0AK* ','SI+K*- ','TET0OM ','TET-RO ',
31496 & 'SI*0AK ','C0+PI+ ','C0+PI0 ','C0+PI- ','A+GAM ',
31497 & 'A0GAM ','TET0AK ','TET0K* ','OM-RO+ ','OM-PI+ ',
31498 & 'C1++AK ','A+PI+ ','C0+AK0 ','A0PI+ ','A+AK0 ',
31499 & 'T0PI+ ','ASI-ET ','ASI-E* ','APK0 ','ATET0K ',
31500 & 'ASI*-E ','AN*-K0 ','AN*--K ','ALAMRO ','ASI0RO ',
31501 & 'ASI-RO ','ASI-OM ','APK*0 ','AN*-K* ','AN*--K ',
31502 & 'ASI-K0 ','ATETPI ','ASI-K* ','ATETRO ','ASI0K* ',
31503 & 'ASI-K* ','ATE0OM ','ATE+RO ','ASI*0K ','AC-PI- ',
31504 & 'AC-PI0 ','AC-PI+ ','AA-GAM ','AA0GAM ','ATET0K ',
31505 & 'ATE0K* ','AOM+RO ','AOM+PI ','AC1--K ','AA-PI- ',
31506 & 'AC0-K0 ','AA0PI- ','AA-K0 ','AT0PI- ','C1++GA ' /
31507 DATA (ZKNAME(K),K=511,540) /
31508 & 'C1++GA ','C10GAM ','S+GAM ','S0GAM ','T0GAM ',
31509 & 'XU++GA ','XD+GAM ','XS+GAM ','A+AKPI ','T02PI+ ',
31510 & 'C1++2K ','AC1--G ','AC1-GA ','AC10GA ','AS-GAM ',
31511 & 'AS0GAM ','AT0GAM ','AXU--G ','AXD-GA ','AXS-GA ',
31512 & 'AA-KPI ','AT02PI ','AC1--K ','RH-PI+ ','RH+PI- ',
31513 & 'RH3PI0 ','RH0PI+ ','RH+PI0 ','RH0PI- ','RH-PI0 ' /
31514 DATA (ZKNAME(I),I=541,602)/
31515 & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHO0','ANRHO-','ANETA ',
31516 & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0','RH0PI+','RH+PI0',
31517 & '3PI+00','3PI-++','F0PI+ ','RH+PI-','RH0PI0','3PI000','3PI0+-',
31518 & 'F0PI0 ','RH0PI-','RH-PI0','3PI-00','3PI--+','F0PI- ','PI0PI0',
31519 & 'PI+PI-','K+K- ','K0AK0 ','L01600','AL0160','K*+146','K*-146',
31520 & 'K*0146','AK0146','S+1660','S01660','S-1660','AS-166','AS0166',
31521 & 'AS+166','X01690','X-1690','AX0169','AX+169','OM-225','AOM+22',
31522 & 'N*PPI0','N*NPI+','N*P2P0','N*PP+-','N*D+P0','N*D0P+','N*NPI0',
31523 & 'N*PPI-','N*N2P0','N*NP+-','N*D+P-','N*D0P0','BLANK '/
31524 * Weight of decay channel
31525 DATA (WT(K),K= 1, 85) /
31526 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31527 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31528 & .1000D+01, .2100D+00, .1200D+00, .2700D+00, .4000D+00,
31529 & .1000D+01, .1000D+01, .6400D+00, .2100D+00, .6000D-01,
31530 & .2000D-01, .3000D-01, .4000D-01, .6400D+00, .2100D+00,
31531 & .6000D-01, .2000D-01, .3000D-01, .4000D-01, .6400D+00,
31532 & .3600D+00, .0000D+00, .0000D+00, .6400D+00, .3600D+00,
31533 & .0000D+00, .0000D+00, .6900D+00, .3100D+00, .1000D+01,
31534 & .5200D+00, .4800D+00, .1000D+01, .9900D+00, .1000D-01,
31535 & .3800D+00, .3000D-01, .3000D+00, .2400D+00, .5000D-01,
31536 & .1000D+01, .1000D+01, .0000D+00, .1000D+01, .9000D+00,
31537 & .1000D-01, .9000D-01, .3300D+00, .6700D+00, .3300D+00,
31538 & .6700D+00, .3300D+00, .6700D+00, .3300D+00, .6700D+00,
31539 & .3300D+00, .6700D+00, .3300D+00, .6700D+00, .3300D+00,
31540 & .6700D+00, .3300D+00, .6700D+00, .1900D+00, .3800D+00,
31541 & .9000D-01, .2000D+00, .3000D-01, .4000D-01, .5000D-01,
31542 & .2000D-01, .1900D+00, .3800D+00, .9000D-01, .2000D+00 /
31543 DATA (WT(K),K= 86,170) /
31544 & .3000D-01, .4000D-01, .5000D-01, .2000D-01, .1900D+00,
31545 & .3800D+00, .9000D-01, .2000D+00, .3000D-01, .4000D-01,
31546 & .5000D-01, .2000D-01, .1900D+00, .3800D+00, .9000D-01,
31547 & .2000D+00, .3000D-01, .4000D-01, .5000D-01, .2000D-01,
31548 & .8800D+00, .6000D-01, .6000D-01, .8800D+00, .6000D-01,
31549 & .6000D-01, .8800D+00, .1200D+00, .1900D+00, .1900D+00,
31550 & .1600D+00, .1600D+00, .1700D+00, .3000D-01, .3000D-01,
31551 & .3000D-01, .4000D-01, .1000D+00, .1000D+00, .2000D+00,
31552 & .1200D+00, .1000D+00, .4000D-01, .4000D-01, .5000D-01,
31553 & .7500D-01, .7500D-01, .3000D-01, .3000D-01, .4000D-01,
31554 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01,
31555 & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31556 & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31557 & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31558 & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31559 & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31560 & .2700D+00, .3000D+00, .4000D+00, .2000D+00, .1250D+00 /
31561 DATA (WT(K),K=171,255) /
31562 & .7500D-01, .7500D-01, .1250D+00, .4000D+00, .7500D-01,
31563 & .1250D+00, .2000D+00, .1250D+00, .7500D-01, .1800D+00,
31564 & .3700D+00, .1300D+00, .8000D-01, .4000D-01, .7000D-01,
31565 & .1300D+00, .3700D+00, .1800D+00, .4000D-01, .8000D-01,
31566 & .1300D+00, .1300D+00, .7000D-01, .7000D-01, .1300D+00,
31567 & .2300D+00, .4700D+00, .5000D-01, .2000D-01, .1000D-01,
31568 & .2000D-01, .1300D+00, .7000D-01, .4700D+00, .2300D+00,
31569 & .5000D-01, .1000D-01, .2000D-01, .2000D-01, .1000D+01,
31570 & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31571 & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31572 & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31573 & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31574 & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31575 & .2700D+00, .3000D+00, .1800D+00, .3700D+00, .1300D+00,
31576 & .8000D-01, .4000D-01, .7000D-01, .1300D+00, .3700D+00,
31577 & .1800D+00, .4000D-01, .8000D-01, .1300D+00, .1300D+00,
31578 & .7000D-01, .5000D+00, .5000D+00, .1000D+01, .1000D+01 /
31579 DATA (WT(K),K=256,340) /
31580 & .1000D+01, .8000D+00, .2000D+00, .6000D+00, .3000D+00,
31581 & .1000D+00, .6000D+00, .3000D+00, .1000D+00, .8000D+00,
31582 & .2000D+00, .3300D+00, .6700D+00, .6600D+00, .1700D+00,
31583 & .1700D+00, .3200D+00, .1700D+00, .3200D+00, .1900D+00,
31584 & .3300D+00, .3300D+00, .3400D+00, .3000D+00, .5000D-01,
31585 & .6500D+00, .3800D+00, .1200D+00, .3800D+00, .1200D+00,
31586 & .3800D+00, .1200D+00, .3800D+00, .1200D+00, .3000D+00,
31587 & .5000D-01, .6500D+00, .3800D+00, .2500D+00, .2500D+00,
31588 & .2000D-01, .5000D-01, .5000D-01, .2000D+00, .2000D+00,
31589 & .1200D+00, .1000D+00, .7000D-01, .7000D-01, .1400D+00,
31590 & .5000D-01, .5000D-01, .1000D+01, .1000D+01, .1000D+01,
31591 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31592 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31593 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31594 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31595 & .4800D+00, .2400D+00, .2600D+00, .2000D-01, .4700D+00,
31596 & .3500D+00, .1500D+00, .3000D-01, .1000D+01, .1000D+01 /
31597 DATA (WT(K),K=341,425) /
31598 & .5200D+00, .4800D+00, .1000D+01, .1000D+01, .1000D+01,
31599 & .1000D+01, .9000D+00, .5000D-01, .5000D-01, .9000D+00,
31600 & .5000D-01, .5000D-01, .9000D+00, .5000D-01, .5000D-01,
31601 & .3300D+00, .6700D+00, .6700D+00, .3300D+00, .2500D+00,
31602 & .2500D+00, .5000D+00, .9000D+00, .5000D-01, .5000D-01,
31603 & .9000D+00, .5000D-01, .5000D-01, .9000D+00, .5000D-01,
31604 & .5000D-01, .3300D+00, .6700D+00, .6700D+00, .3300D+00,
31605 & .2500D+00, .2500D+00, .5000D+00, .1000D+00, .5000D+00,
31606 & .1600D+00, .2400D+00, .7000D+00, .3000D+00, .7000D+00,
31607 & .3000D+00, .1000D+00, .5000D+00, .1600D+00, .2400D+00,
31608 & .3000D+00, .4000D+00, .3000D+00, .3000D+00, .4000D+00,
31609 & .3000D+00, .4900D+00, .4900D+00, .2000D-01, .5500D+00,
31610 & .4500D+00, .6800D+00, .3000D+00, .2000D-01, .6800D+00,
31611 & .3000D+00, .2000D-01, .5500D+00, .4500D+00, .9000D+00,
31612 & .1000D+00, .9000D+00, .1000D+00, .6000D+00, .3000D+00,
31613 & .1000D+00, .1000D+00, .1000D+00, .8000D+00, .2800D+00,
31614 & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .2800D+00 /
31615 DATA (WT(K),K=426,510) /
31616 & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .1000D+01,
31617 & .1000D+01, .1000D+01, .1000D+01, .2000D-01, .3000D-01,
31618 & .7000D-01, .2000D-01, .2000D-01, .4000D-01, .1300D+00,
31619 & .7000D-01, .6000D-01, .6000D-01, .2000D+00, .1400D+00,
31620 & .4000D-01, .1000D+00, .2500D+00, .3000D-01, .3000D+00,
31621 & .4200D+00, .2200D+00, .3500D+00, .1900D+00, .1600D+00,
31622 & .8000D-01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31623 & .1000D+01, .3700D+00, .2000D+00, .3600D+00, .7000D-01,
31624 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00,
31625 & .5000D+00, .2000D-01, .3000D-01, .7000D-01, .2000D-01,
31626 & .2000D-01, .4000D-01, .1300D+00, .7000D-01, .6000D-01,
31627 & .6000D-01, .2000D+00, .1400D+00, .4000D-01, .1000D+00,
31628 & .2500D+00, .3000D-01, .3000D+00, .4200D+00, .2200D+00,
31629 & .3500D+00, .1900D+00, .1600D+00, .8000D-01, .1000D+01,
31630 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .3700D+00,
31631 & .2000D+00, .3600D+00, .7000D-01, .5000D+00, .5000D+00,
31632 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01 /
31633 DATA (WT(K),K=511,540) /
31634 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31635 & .1000D+01, .1000D+01, .1000D+01, .3000D+00, .3000D+00,
31636 & .4000D+00, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31637 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31638 & .3000D+00, .3000D+00, .4000D+00, .3300D+00, .3300D+00,
31639 & .3400D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00 /
31641 DATA (WT(I),I=541,602) / .0D+00, .3334D+00, .2083D+00, 2*.125D+00,
31642 & .2083D+00, .0D+00, .125D+00, .2083D+00, .3334D+00, .2083D+00,
31643 & .125D+00, 0.2D+00, 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00,
31644 & 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, 0.2D+00, 0.3D+00,
31645 & 0.3D+00, 0.0D+00, 0.31D+00, 0.62D+00, 0.035D+00, 0.035D+00,
31646 & 18*1.D+00, 0.5D+00, 0.16D+00, 2*0.12D+00, 2*0.05D+00, 0.5D+00,
31647 & 0.16D+00, 2*0.12D+00, 2*0.05D+00, 1.D+00 /
31648 * Particle numbers in decay channel
31649 DATA (NZK(K,1),K= 1,170) /
31650 & 1, 2, 3, 4, 5, 6, 7, 1, 2, 4,
31651 & 3, 23, 13, 13, 13, 10, 11, 10, 13, 13,
31652 & 13, 10, 4, 11, 14, 14, 14, 11, 3, 1,
31653 & 8, 1, 1, 2, 9, 2, 2, 13, 23, 8,
31654 & 1, 8, 17, 7, 7, 7, 23, 23, 13, 13,
31655 & 13, 13, 23, 14, 13, 13, 23, 15, 24, 24,
31656 & 15, 16, 25, 25, 16, 15, 24, 24, 15, 16,
31657 & 24, 25, 16, 15, 24, 36, 37, 15, 24, 15,
31658 & 15, 24, 15, 37, 36, 24, 15, 24, 24, 16,
31659 & 24, 38, 39, 16, 25, 16, 16, 25, 16, 39,
31660 & 38, 25, 16, 25, 25, 17, 22, 21, 17, 21,
31661 & 20, 17, 22, 8, 1, 21, 22, 20, 17, 48,
31662 & 50, 49, 8, 1, 17, 17, 17, 21, 20, 22,
31663 & 17, 22, 21, 20, 22, 19, 12, 19, 12, 1,
31664 & 1, 8, 1, 8, 8, 1, 53, 54, 1, 1,
31665 & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55,
31666 & 56, 1, 8, 8, 55, 56, 8, 1, 53, 54 /
31667 DATA (NZK(K,1),K=171,340) /
31668 & 55, 1, 8, 8, 54, 55, 56, 1, 8, 1,
31669 & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55,
31670 & 56, 1, 8, 1, 8, 1, 8, 17, 21, 22,
31671 & 1, 1, 8, 1, 8, 17, 22, 20, 8, 2,
31672 & 2, 9, 2, 9, 9, 2, 67, 68, 2, 2,
31673 & 9, 67, 68, 69, 2, 9, 2, 9, 68, 69,
31674 & 70, 2, 9, 9, 69, 70, 9, 2, 9, 67,
31675 & 68, 69, 2, 9, 2, 9, 68, 69, 70, 2,
31676 & 9, 1, 8, 13, 13, 14, 1, 8, 1, 1,
31677 & 8, 8, 8, 1, 8, 1, 1, 1, 1, 1,
31678 & 8, 2, 2, 9, 9, 2, 2, 9, 15, 15,
31679 & 24, 16, 16, 25, 25, 15, 15, 24, 24, 16,
31680 & 16, 25, 1, 21, 22, 21, 48, 49, 8, 17,
31681 & 20, 17, 22, 20, 20, 22, 20, 0, 0, 0,
31682 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31683 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31684 & 31, 31, 13, 7, 15, 12, 13, 31, 17, 17 /
31685 DATA (NZK(K,1),K=341,510) /
31686 & 2, 9, 18, 9, 18, 18, 17, 21, 22, 17,
31687 & 21, 20, 17, 20, 22, 97, 98, 97, 98, 97,
31688 & 98, 17, 18, 99, 100, 18, 101, 99, 18, 101,
31689 & 100, 102, 103, 102, 103, 102, 103, 18, 16, 16,
31690 & 24, 24, 16, 25, 15, 24, 15, 15, 25, 25,
31691 & 31, 15, 15, 31, 16, 16, 23, 13, 7, 116,
31692 & 116, 116, 117, 117, 119, 118, 118, 119, 119, 120,
31693 & 120, 121, 121, 130, 130, 130, 4, 10, 13, 10,
31694 & 4, 32, 13, 36, 11, 3, 34, 14, 38, 133,
31695 & 134, 135, 136, 21, 21, 1, 97, 104, 54, 53,
31696 & 17, 22, 21, 21, 1, 54, 53, 21, 97, 21,
31697 & 97, 22, 21, 97, 98, 105, 137, 137, 137, 138,
31698 & 139, 97, 97, 109, 109, 140, 138, 137, 139, 138,
31699 & 145, 99, 99, 2, 102, 110, 68, 67, 18, 100,
31700 & 99, 99, 2, 68, 67, 99, 102, 99, 102, 100,
31701 & 99, 102, 103, 111, 149, 149, 149, 150, 151, 113,
31702 & 113, 115, 115, 152, 150, 149, 151, 150, 157, 140 /
31703 DATA (NZK(K,1),K=511,540) /
31704 & 141, 142, 143, 144, 145, 146, 147, 148, 138, 145,
31705 & 140, 152, 153, 154, 155, 156, 157, 158, 159, 160,
31706 & 150, 157, 152, 34, 32, 33, 33, 32, 33, 34 /
31707 DATA (NZK(I,1),I=541,602) / 2, 67, 68, 69, 2, 9, 9, 68, 69,
31708 & 70, 2, 9, 33, 32, 13, 14, 189, 32, 34, 23, 23, 189, 33, 34, 14,
31709 & 14, 189, 23, 13, 15, 24, 36, 38, 37, 39, 194, 195, 196, 197,
31710 & 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 1, 8, 1, 1, 54,
31711 & 55, 8, 1, 8, 8, 54, 55, 210/
31712 DATA (NZK(K,2),K= 1,170) /
31713 & 0, 0, 0, 0, 0, 0, 0, 3, 4, 6,
31714 & 5, 23, 14, 11, 3, 5, 5, 5, 23, 13,
31715 & 23, 23, 23, 5, 23, 13, 23, 23, 23, 14,
31716 & 23, 3, 11, 13, 23, 4, 10, 14, 23, 14,
31717 & 23, 13, 7, 7, 4, 7, 7, 23, 14, 14,
31718 & 23, 14, 23, 23, 14, 14, 7, 23, 13, 23,
31719 & 14, 23, 14, 23, 13, 23, 13, 23, 14, 23,
31720 & 14, 23, 13, 23, 13, 23, 13, 33, 32, 35,
31721 & 31, 23, 14, 23, 14, 33, 34, 35, 31, 23,
31722 & 14, 23, 14, 33, 34, 35, 31, 23, 13, 23,
31723 & 13, 33, 32, 35, 31, 13, 13, 23, 23, 14,
31724 & 13, 14, 14, 25, 16, 14, 23, 13, 31, 14,
31725 & 13, 23, 25, 16, 23, 35, 33, 34, 32, 33,
31726 & 31, 31, 14, 13, 23, 0, 0, 0, 0, 13,
31727 & 23, 13, 14, 23, 14, 13, 23, 13, 78, 23,
31728 & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23,
31729 & 13, 80, 79, 14, 14, 23, 80, 31, 14, 23 /
31730 DATA (NZK(K,2),K=171,340) /
31731 & 13, 79, 78, 31, 14, 23, 13, 80, 79, 23,
31732 & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23,
31733 & 13, 80, 79, 23, 13, 33, 32, 15, 24, 15,
31734 & 31, 14, 23, 34, 33, 24, 24, 15, 31, 14,
31735 & 23, 14, 13, 23, 13, 14, 23, 14, 80, 23,
31736 & 14, 13, 23, 14, 79, 80, 13, 23, 13, 23,
31737 & 14, 78, 79, 13, 13, 23, 78, 23, 14, 13,
31738 & 23, 14, 79, 80, 13, 23, 13, 23, 14, 78,
31739 & 79, 62, 61, 23, 14, 23, 13, 13, 13, 23,
31740 & 13, 13, 23, 14, 14, 14, 1, 8, 8, 1,
31741 & 8, 1, 8, 8, 1, 8, 1, 8, 1, 8,
31742 & 1, 1, 8, 1, 8, 8, 1, 1, 8, 8,
31743 & 1, 8, 25, 23, 13, 31, 23, 13, 16, 14,
31744 & 35, 34, 34, 33, 31, 14, 23, 0, 0, 0,
31745 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31746 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31747 & 13, 23, 14, 7, 16, 19, 14, 7, 23, 14 /
31748 DATA (NZK(K,2),K=341,510) /
31749 & 23, 14, 7, 13, 23, 13, 13, 23, 13, 23,
31750 & 14, 13, 14, 23, 14, 23, 13, 14, 23, 14,
31751 & 23, 16, 14, 23, 14, 23, 14, 13, 13, 23,
31752 & 13, 23, 14, 13, 23, 13, 23, 15, 13, 13,
31753 & 13, 23, 13, 13, 14, 14, 14, 14, 14, 23,
31754 & 13, 16, 25, 14, 15, 24, 23, 14, 7, 23,
31755 & 7, 13, 23, 7, 14, 23, 7, 23, 7, 7,
31756 & 7, 7, 7, 13, 23, 31, 3, 11, 14, 135,
31757 & 5, 134, 134, 134, 136, 6, 133, 133, 133, 0,
31758 & 0, 0, 0, 31, 95, 25, 15, 31, 95, 16,
31759 & 32, 32, 33, 35, 39, 39, 38, 25, 13, 39,
31760 & 32, 39, 38, 35, 32, 39, 13, 23, 14, 7,
31761 & 7, 25, 37, 32, 13, 25, 13, 25, 13, 25,
31762 & 13, 31, 95, 24, 16, 31, 24, 15, 34, 34,
31763 & 33, 35, 37, 37, 36, 24, 14, 37, 34, 37,
31764 & 36, 35, 34, 37, 14, 23, 13, 7, 7, 24,
31765 & 39, 34, 14, 24, 14, 24, 14, 24, 14, 7 /
31766 DATA (NZK(K,2),K=511,540) /
31767 & 7, 7, 7, 7, 7, 7, 7, 7, 25, 13,
31768 & 25, 7, 7, 7, 7, 7, 7, 7, 7, 7,
31769 & 24, 14, 24, 13, 14, 23, 13, 23, 14, 23 /
31770 DATA (NZK(I,2),I=541,602) / 31, 13, 23, 14, 79, 80, 31, 13, 23,
31771 & 14, 78, 79, 13, 23, 23, 13, 13, 14, 13, 23, 13, 23, 14, 23, 23,
31772 & 14, 14, 23, 14, 16, 25,
31773 & 4*23, 14*0, 23, 13, 23, 13, 23, 13, 23, 14,
31774 & 23, 13, 14, 23, 0 /
31775 DATA (NZK(K,3),K= 1,170) /
31776 & 0, 0, 0, 0, 0, 0, 0, 5, 6, 5,
31777 & 6, 23, 23, 5, 5, 0, 0, 0, 0, 14,
31778 & 23, 5, 5, 0, 0, 14, 23, 5, 5, 0,
31779 & 0, 5, 5, 0, 0, 5, 5, 0, 0, 0,
31780 & 0, 0, 0, 0, 3, 0, 7, 23, 23, 7,
31781 & 0, 0, 0, 0, 23, 0, 0, 0, 0, 0,
31783 DATA (NZK(K,3),K=171,340) /
31785 & 0, 0, 0, 0, 0, 0, 23, 13, 14, 23,
31786 & 23, 14, 23, 23, 23, 14, 23, 13, 23, 14,
31787 & 13, 23, 13, 23, 14, 23, 14, 14, 23, 13,
31788 & 13, 23, 13, 14, 23, 23, 14, 23, 13, 23,
31789 & 14, 14, 0, 0, 0, 0, 0, 0, 0, 0,
31791 & 14, 23, 7, 0, 0, 0, 23, 0, 0, 0 /
31792 DATA (NZK(K,3),K=341,510) /
31794 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 23,
31795 & 14, 0, 13, 0, 14, 0, 0, 23, 13, 0,
31796 & 0, 15, 0, 0, 16, 0, 0, 0, 0, 0,
31797 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31798 & 0, 0, 0, 14, 23, 0, 0, 0, 23, 134,
31799 & 134, 0, 0, 0, 133, 133, 0, 0, 0, 0,
31801 DATA (NZK(K,3),K=511,540) /
31802 & 0, 0, 0, 0, 0, 0, 0, 0, 13, 13,
31803 & 25, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31804 & 14, 14, 24, 0, 0, 0, 0, 0, 0, 0 /
31805 DATA (NZK(I,3),I=541,602) / 12*0, 2*0, 23, 13, 0, 2*0, 23, 14, 0,
31806 & 2*0, 23, 13, 0, 4*0, 18*0, 2*0, 23, 14, 2*0, 2*0, 23, 14, 2*0, 0/
31810 *$ CREATE DT_XHOINI.FOR
31813 *====phoini============================================================*
31815 SUBROUTINE DT_XHOINI
31816 C SUBROUTINE DT_PHOINI
31818 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31821 PARAMETER ( LINP = 10 ,
31828 *$ CREATE DT_XVENTB.FOR
31831 *====eventb============================================================*
31833 SUBROUTINE DT_XVENTB(NCSY,IREJ)
31834 C SUBROUTINE DT_EVENTB(NCSY,IREJ)
31836 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31839 PARAMETER ( LINP = 10 ,
31844 1000 FORMAT(1X,'EVENTB: PHOJET-package requested but not linked!')
31849 *$ CREATE DT_XVENT.FOR
31852 *===event==============================================================*
31854 SUBROUTINE DT_XVENT(IDUM,PP,PT,DUM,IREJ)
31855 C SUBROUTINE EVENT(IDUM,PP,PT,DUM,IREJ)
31857 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31860 DIMENSION PP(4),PT(4)
31865 *$ CREATE DT_XOHISX.FOR
31868 *===pohisx=============================================================*
31870 SUBROUTINE DT_XOHISX(I,X)
31871 C SUBROUTINE POHISX(I,X)
31873 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31879 *$ CREATE PHO_LHIST.FOR
31882 *===poluhi=============================================================*
31884 SUBROUTINE PHO_LHIST(I,X)
31888 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31894 *$ CREATE PDFSET.FOR
31897 C**********************************************************************
31899 C dummy subroutines, remove to link PDFLIB
31901 C**********************************************************************
31902 SUBROUTINE PDFSET(PARAM,VALUE)
31903 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31904 DIMENSION PARAM(20),VALUE(20)
31908 *$ CREATE STRUCTM.FOR
31911 SUBROUTINE STRUCTM(XI,SCALE2,UV,DV,US,DS,SS,CS,BS,TS,GL)
31912 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31915 *$ CREATE STRUCTP.FOR
31918 SUBROUTINE STRUCTP(XI,SCALE2,P2,IP2,UV,DV,US,DS,SS,CS,BS,TS,GL)
31919 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31922 *$ CREATE DT_DIQBRK.FOR
31925 *===diqbrk=============================================================*
31927 SUBROUTINE DT_XIQBRK
31928 C SUBROUTINE DT_DIQBRK
31930 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31933 STOP 'diquark-breaking not implemeted !'
31937 *$ CREATE DT_ELHAIN.FOR
31940 *===elhain=============================================================*
31942 SUBROUTINE DT_ELHAIN(IP,PLA,ELAB,CX,CY,CZ,IT,IREJ)
31944 ************************************************************************
31945 * Elastic hadron-hadron scattering. *
31946 * This is a revised version of the original. *
31947 * This version dated 03.04.98 is written by S. Roesler *
31948 ************************************************************************
31950 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31953 PARAMETER ( LINP = 10 ,
31957 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
31960 PARAMETER (ENNTHR = 3.5D0)
31961 PARAMETER (PLOWH=0.01D0,PHIH=9.0D0,
31962 & BLOWB=0.05D0,BHIB=0.2D0,
31963 & BLOWM=0.1D0, BHIM=2.0D0)
31965 * particle properties (BAMJET index convention)
31967 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
31968 & IICH(210),IIBAR(210),K1(210),K2(210)
31970 * final state from HADRIN interaction
31971 PARAMETER (MAXFIN=10)
31972 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
31973 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
31975 C DATA TSLOPE /10.0D0/
31981 PLAB = SQRT( (ELAB-AAM(IP))*(ELAB+AAM(IP)) )
31982 EKIN = ELAB-AAM(IP)
31983 * kinematical quantities in cms of the hadrons
31986 S = AMP2+AMT2+TWO*ELAB*AAM(IT)
31988 ECMP = OHALF*ECM+(AMP2-AMT2)/(TWO*ECM)
31989 PCM = SQRT( (ECMP-AAM(IP))*(ECMP+AAM(IP)) )
31991 * nucleon-nucleon scattering at E_kin<3.5: use DT_TSAMCS(HETC-KFA)
31992 IF ( ((IP.EQ.1).OR.(IP.EQ.8)).AND.
31993 & ((IT.EQ.1).OR.(IT.EQ.8)).AND.(EKIN.LT.ENNTHR) ) THEN
31994 * TSAMCS treats pp and np only, therefore change pn into np and
32000 IF (IP.EQ.8) KPROJ = 1
32002 CALL DT_TSAMCS(KPROJ,EKIN,CTCMS)
32003 T = TWO*PCM**2*(CTCMS-ONE)
32005 * very crude treatment otherwise: sample t from exponential dist.
32007 * momentum transfer t
32008 TMAX = TWO*TWO*PCM**2
32009 RR = (PLAB-PLOWH)/(PHIH-PLOWH)
32010 IF (IIBAR(IP).NE.0) THEN
32011 TSLOPE = BLOWB+RR*(BHIB-BLOWB)
32013 TSLOPE = BLOWM+RR*(BHIM-BLOWM)
32015 FMAX = EXP(-TSLOPE*TMAX)-ONE
32017 T = LOG(ONE+R*FMAX+TINY10)/TSLOPE
32018 IF (T.GT.ZERO) T = LOG(ONE+R*FMAX)/TSLOPE
32021 * target hadron in Lab after scattering
32022 ELRH(2) = (TWO*AMT2-T)/(TWO*AAM(IT))
32023 PLRH(2) = SQRT( ABS(ELRH(2)-AAM(IT))*(ELRH(2)+AAM(IT)) )
32024 IF (PLRH(2).LE.TINY10) THEN
32025 C WRITE(*,*)'ELHAIN: T,PLRH(2) ',T,PLRH(2)
32028 * projectile hadron in Lab after scattering
32029 ELRH(1) = ELAB+AAM(IT)-ELRH(2)
32030 PLRH(1) = SQRT( ABS(ELRH(1)-AAM(IP))*(ELRH(1)+AAM(IP)) )
32031 * scattering angle of projectile in Lab
32032 CTLABP = (T-TWO*AMP2+TWO*ELAB*ELRH(1))/(TWO*PLAB*PLRH(1))
32033 STLABP = SQRT( (ONE-CTLABP)*(ONE+CTLABP) )
32034 CALL DT_DSFECF(SPLABP,CPLABP)
32035 * direction cosines of projectile in Lab
32036 CALL DT_STTRAN(CX,CY,CZ,CTLABP,STLABP,SPLABP,CPLABP,
32037 & CXRH(1),CYRH(1),CZRH(1))
32038 * scattering angle of target in Lab
32039 PLLABT = PLAB-CTLABP*PLRH(1)
32040 CTLABT = PLLABT/PLRH(2)
32041 STLABT = SQRT( (ONE-CTLABT)*(ONE+CTLABT) )
32042 * direction cosines of target in Lab
32043 CALL DT_STTRAN(CX,CY,CZ,CTLABT,STLABT,-SPLABP,-CPLABP,
32044 & CXRH(2),CYRH(2),CZRH(2))
32053 *$ CREATE DT_TSAMCS.FOR
32056 *===tsamcs=============================================================*
32058 SUBROUTINE DT_TSAMCS(KPROJ,EKIN,CST)
32060 ************************************************************************
32061 * Sampling of cos(theta) for nucleon-proton scattering according to *
32062 * hetkfa2/bertini parametrization. *
32063 * This is a revised version of the original (HJM 24/10/88) *
32064 * This version dated 28.10.95 is written by S. Roesler *
32065 ************************************************************************
32067 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32070 PARAMETER ( LINP = 10 ,
32074 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
32077 DIMENSION DCLIN(195),DCHN(143),DCHNA(36),DCHNB(60)
32078 DIMENSION PDCI(60),PDCH(55)
32080 DATA (DCLIN(I),I=1,80) /
32081 & 5.000D-01, 1.000D+00, 0.000D+00, 1.000D+00, 0.000D+00,
32082 & 4.993D-01, 9.881D-01, 5.963D-02, 9.851D-01, 5.945D-02,
32083 & 4.936D-01, 8.955D-01, 5.224D-01, 8.727D-01, 5.091D-01,
32084 & 4.889D-01, 8.228D-01, 8.859D-01, 7.871D-01, 8.518D-01,
32085 & 4.874D-01, 7.580D-01, 1.210D+00, 7.207D-01, 1.117D+00,
32086 & 4.912D-01, 6.969D-01, 1.516D+00, 6.728D-01, 1.309D+00,
32087 & 5.075D-01, 6.471D-01, 1.765D+00, 6.667D-01, 1.333D+00,
32088 & 5.383D-01, 6.054D-01, 1.973D+00, 7.059D-01, 1.176D+00,
32089 & 5.397D-01, 5.990D-01, 2.005D+00, 7.023D-01, 1.191D+00,
32090 & 5.336D-01, 6.083D-01, 1.958D+00, 6.959D-01, 1.216D+00,
32091 & 5.317D-01, 6.075D-01, 1.962D+00, 6.897D-01, 1.241D+00,
32092 & 5.300D-01, 6.016D-01, 1.992D+00, 6.786D-01, 1.286D+00,
32093 & 5.281D-01, 6.063D-01, 1.969D+00, 6.786D-01, 1.286D+00,
32094 & 5.280D-01, 5.960D-01, 2.020D+00, 6.667D-01, 1.333D+00,
32095 & 5.273D-01, 5.920D-01, 2.040D+00, 6.604D-01, 1.358D+00,
32096 & 5.273D-01, 5.862D-01, 2.069D+00, 6.538D-01, 1.385D+00/
32097 DATA (DCLIN(I),I=81,160) /
32098 & 5.223D-01, 5.980D-01, 2.814D+00, 6.538D-01, 1.385D+00,
32099 & 5.202D-01, 5.969D-01, 2.822D+00, 6.471D-01, 1.412D+00,
32100 & 5.183D-01, 5.881D-01, 2.883D+00, 6.327D-01, 1.469D+00,
32101 & 5.159D-01, 5.866D-01, 2.894D+00, 6.250D-01, 1.500D+00,
32102 & 5.133D-01, 5.850D-01, 2.905D+00, 6.170D-01, 1.532D+00,
32103 & 5.106D-01, 5.833D-01, 2.917D+00, 6.087D-01, 1.565D+00,
32104 & 5.084D-01, 5.801D-01, 2.939D+00, 6.000D-01, 1.600D+00,
32105 & 5.063D-01, 5.763D-01, 2.966D+00, 5.909D-01, 1.636D+00,
32106 & 5.036D-01, 5.730D-01, 2.989D+00, 5.814D-01, 1.674D+00,
32107 & 5.014D-01, 5.683D-01, 3.022D+00, 5.714D-01, 1.714D+00,
32108 & 4.986D-01, 5.641D-01, 3.051D+00, 5.610D-01, 1.756D+00,
32109 & 4.964D-01, 5.580D-01, 3.094D+00, 5.500D-01, 1.800D+00,
32110 & 4.936D-01, 5.573D-01, 3.099D+00, 5.431D-01, 1.827D+00,
32111 & 4.909D-01, 5.509D-01, 3.144D+00, 5.313D-01, 1.875D+00,
32112 & 4.885D-01, 5.512D-01, 3.142D+00, 5.263D-01, 1.895D+00,
32113 & 4.857D-01, 5.437D-01, 3.194D+00, 5.135D-01, 1.946D+00/
32114 DATA (DCLIN(I),I=161,195) /
32115 & 4.830D-01, 5.353D-01, 3.253D+00, 5.000D-01, 2.000D+00,
32116 & 4.801D-01, 5.323D-01, 3.274D+00, 4.915D-01, 2.034D+00,
32117 & 4.770D-01, 5.228D-01, 3.341D+00, 4.767D-01, 2.093D+00,
32118 & 4.738D-01, 5.156D-01, 3.391D+00, 4.643D-01, 2.143D+00,
32119 & 4.701D-01, 5.010D-01, 3.493D+00, 4.444D-01, 2.222D+00,
32120 & 4.672D-01, 4.990D-01, 3.507D+00, 4.375D-01, 2.250D+00,
32121 & 4.634D-01, 4.856D-01, 3.601D+00, 4.194D-01, 2.323D+00/
32124 & 4.400D+02, 1.896D-01, 1.931D-01, 1.982D-01, 1.015D-01,
32125 & 1.029D-01, 4.180D-02, 4.228D-02, 4.282D-02, 4.350D-02,
32126 & 2.204D-02, 2.236D-02, 5.900D+02, 1.433D-01, 1.555D-01,
32127 & 1.774D-01, 1.000D-01, 1.128D-01, 5.132D-02, 5.600D-02,
32128 & 6.158D-02, 6.796D-02, 3.660D-02, 3.820D-02, 6.500D+02,
32129 & 1.192D-01, 1.334D-01, 1.620D-01, 9.527D-02, 1.141D-01,
32130 & 5.283D-02, 5.952D-02, 6.765D-02, 7.878D-02, 4.796D-02,
32131 & 6.957D-02, 8.000D+02, 4.872D-02, 6.694D-02, 1.152D-01,
32132 & 9.348D-02, 1.368D-01, 6.912D-02, 7.953D-02, 9.577D-02,
32133 & 1.222D-01, 7.755D-02, 9.525D-02, 1.000D+03, 3.997D-02,
32134 & 5.456D-02, 9.804D-02, 8.084D-02, 1.208D-01, 6.520D-02,
32135 & 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02, 1.093D-01/
32138 & 1.000D+03, 9.453D-02, 9.804D-02, 8.084D-02, 1.208D-01,
32139 & 6.520D-02, 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02,
32140 & 1.093D-01, 1.400D+03, 1.072D-01, 7.450D-02, 6.645D-02,
32141 & 1.136D-01, 6.750D-02, 8.580D-02, 1.110D-01, 1.530D-01,
32142 & 1.010D-01, 1.350D-01, 2.170D+03, 4.004D-02, 3.013D-02,
32143 & 2.664D-02, 5.511D-02, 4.240D-02, 7.660D-02, 1.364D-01,
32144 & 2.300D-01, 1.670D-01, 2.010D-01, 2.900D+03, 1.870D-02,
32145 & 1.804D-02, 1.320D-02, 2.970D-02, 2.860D-02, 5.160D-02,
32146 & 1.020D-01, 2.400D-01, 2.250D-01, 3.370D-01, 4.400D+03,
32147 & 1.196D-03, 8.784D-03, 1.517D-02, 2.874D-02, 2.488D-02,
32148 & 4.464D-02, 8.330D-02, 2.008D-01, 2.360D-01, 3.567D-01/
32150 DATA (DCHN(I),I=1,90) /
32151 & 4.770D-01, 4.750D-01, 4.715D-01, 4.685D-01, 4.650D-01,
32152 & 4.610D-01, 4.570D-01, 4.550D-01, 4.500D-01, 4.450D-01,
32153 & 4.405D-01, 4.350D-01, 4.300D-01, 4.250D-01, 4.200D-01,
32154 & 4.130D-01, 4.060D-01, 4.000D-01, 3.915D-01, 3.840D-01,
32155 & 3.760D-01, 3.675D-01, 3.580D-01, 3.500D-01, 3.400D-01,
32156 & 3.300D-01, 3.200D-01, 3.100D-01, 3.000D-01, 2.900D-01,
32157 & 2.800D-01, 2.700D-01, 2.600D-01, 2.500D-01, 2.400D-01,
32158 & 2.315D-01, 2.240D-01, 2.150D-01, 2.060D-01, 2.000D-01,
32159 & 1.915D-01, 1.850D-01, 1.780D-01, 1.720D-01, 1.660D-01,
32160 & 1.600D-01, 1.550D-01, 1.500D-01, 1.450D-01, 1.400D-01,
32161 & 1.360D-01, 1.320D-01, 1.280D-01, 1.250D-01, 1.210D-01,
32162 & 1.180D-01, 1.150D-01, 1.120D-01, 1.100D-01, 1.070D-01,
32163 & 1.050D-01, 1.030D-01, 1.010D-01, 9.900D-02, 9.700D-02,
32164 & 9.550D-02, 9.480D-02, 9.400D-02, 9.200D-02, 9.150D-02,
32165 & 9.100D-02, 9.000D-02, 8.990D-02, 8.900D-02, 8.850D-02,
32166 & 8.750D-02, 8.700D-02, 8.650D-02, 8.550D-02, 8.500D-02,
32167 & 8.499D-02, 8.450D-02, 8.350D-02, 8.300D-02, 8.250D-02,
32168 & 8.150D-02, 8.100D-02, 8.030D-02, 8.000D-02, 7.990D-02/
32169 DATA (DCHN(I),I=91,143) /
32170 & 7.980D-02, 7.950D-02, 7.900D-02, 7.860D-02, 7.800D-02,
32171 & 7.750D-02, 7.650D-02, 7.620D-02, 7.600D-02, 7.550D-02,
32172 & 7.530D-02, 7.500D-02, 7.499D-02, 7.498D-02, 7.480D-02,
32173 & 7.450D-02, 7.400D-02, 7.350D-02, 7.300D-02, 7.250D-02,
32174 & 7.230D-02, 7.200D-02, 7.100D-02, 7.050D-02, 7.020D-02,
32175 & 7.000D-02, 6.999D-02, 6.995D-02, 6.993D-02, 6.991D-02,
32176 & 6.990D-02, 6.870D-02, 6.850D-02, 6.800D-02, 6.780D-02,
32177 & 6.750D-02, 6.700D-02, 6.650D-02, 6.630D-02, 6.600D-02,
32178 & 6.550D-02, 6.525D-02, 6.510D-02, 6.500D-02, 6.499D-02,
32179 & 6.498D-02, 6.496D-02, 6.494D-02, 6.493D-02, 6.490D-02,
32180 & 6.488D-02, 6.485D-02, 6.480D-02/
32183 & 6.300D+02, 7.810D-02, 1.421D-01, 1.979D-01, 2.479D-01,
32184 & 3.360D-01, 5.400D-01, 7.236D-01, 1.000D+00, 1.540D+03,
32185 & 2.225D-01, 3.950D-01, 5.279D-01, 6.298D-01, 7.718D-01,
32186 & 9.405D-01, 9.835D-01, 1.000D+00, 2.560D+03, 2.625D-01,
32187 & 4.550D-01, 5.963D-01, 7.020D-01, 8.380D-01, 9.603D-01,
32188 & 9.903D-01, 1.000D+00, 3.520D+03, 4.250D-01, 6.875D-01,
32189 & 8.363D-01, 9.163D-01, 9.828D-01, 1.000D+00, 1.000D+00,
32193 & 6.300D+02, 3.800D-02, 7.164D-02, 1.275D-01, 2.171D-01,
32194 & 3.227D-01, 4.091D-01, 5.051D-01, 6.061D-01, 7.074D-01,
32195 & 8.434D-01, 1.000D+00, 2.040D+03, 1.200D-01, 2.115D-01,
32196 & 3.395D-01, 5.295D-01, 7.251D-01, 8.511D-01, 9.487D-01,
32197 & 9.987D-01, 1.000D+00, 1.000D+00, 1.000D+00, 2.200D+03,
32198 & 1.344D-01, 2.324D-01, 3.754D-01, 5.674D-01, 7.624D-01,
32199 & 8.896D-01, 9.808D-01, 1.000D+00, 1.000D+00, 1.000D+00,
32200 & 1.000D+00, 2.850D+03, 2.330D-01, 4.130D-01, 6.610D-01,
32201 & 9.010D-01, 9.970D-01, 1.000D+00, 1.000D+00, 1.000D+00,
32202 & 1.000D+00, 1.000D+00, 1.000D+00, 3.500D+03, 3.300D-01,
32203 & 5.450D-01, 7.950D-01, 1.000D+00, 1.000D+00, 1.000D+00,
32204 & 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00/
32207 IF (EKIN.GT.3.5D0) RETURN
32209 IF(KPROJ.EQ.8) GOTO 101
32210 IF(KPROJ.EQ.1) GOTO 102
32211 C* INVALID REACTION
32212 WRITE(LOUT,'(A,I5/A)')
32213 & ' INVALID PARTICLE TYPE IN DNUPRE - KPROJ=',KPROJ,
32214 & ' COS(THETA) = 1D0 RETURNED'
32216 C-------------------------------- NP ELASTIC SCATTERING----------
32218 IF (EKIN.GT.0.740D0)GOTO 1000
32219 IF (EKIN.LT.0.300D0)THEN
32220 C EKIN .LT. 300 MEV
32223 C 300 MEV < EKIN < 740 MEV
32228 IE=INT(ABS(ENER/0.020D0))
32229 UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
32230 C FORWARD/BACKWARD DECISION
32232 BWFW=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
32233 IF (DT_RNDM(CST).LT.BWFW)THEN
32241 COEF=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
32244 IF(RND.LT.COEF)THEN
32253 IF(VALUE2.GT.0.0)THEN
32254 CST=MAX(R1,R2,R3,R4)
32260 CST=-MAX(R1,R2,R3,R4,R5)
32264 CST=-MAX(R1,R2,R3,R4,R5,R6,R7)
32273 C******** EKIN .GT. 0.74 GEV
32275 1000 ENER=EKIN - 0.66D0
32276 C IE=ABS(ENER/0.02)
32277 IE=INT(ENER/0.02D0)
32280 UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
32282 BWFW=(DCHN(K+1)-DCHN(K))*UNIV + DCHN(K)
32285 IF (RND.GE.BWFW)THEN
32287 IF (DCHNA(K).GT.EMEV) THEN
32288 UNIVE=(EMEV-DCHNA(K-9))/(DCHNA(K)-DCHNA(K-9))
32289 UNIV=DT_RNDM(UNIVE)
32292 P=(DCHNA(II)-DCHNA(II-9))*UNIVE + DCHNA(II-9)
32295 UNIV=DT_RNDM(UNIVE)
32297 GOTO(290,290,290,290,330,340,350,360) I
32306 IF (DCHNB(K).GT.EMEV) THEN
32307 UNIVE=(EMEV-DCHNB(K-12))/(DCHNB(K)-DCHNB(K-12))
32308 UNIV=DT_RNDM(UNIVE)
32311 P=(DCHNB(II)-DCHNB(II-12))*UNIVE + DCHNB(II-12)
32316 GOTO(120,120,140,150,160,160,180,190,200,210,220) I
32323 120 CST=1.0D-2*FLTI-1.0D0
32325 140 CST=2.0D-2*UNIV-0.98D0
32327 150 CST=4.0D-2*UNIV-0.96D0
32329 160 CST=6.0D-2*FLTI-1.16D0
32331 180 CST=8.0D-2*UNIV-0.80D0
32333 190 CST=1.0D-1*UNIV-0.72D0
32335 200 CST=1.2D-1*UNIV-0.62D0
32337 210 CST=2.0D-1*UNIV-0.50D0
32339 220 CST=3.0D-1*(UNIV-1.0D0)
32342 290 CST=1.0D0-2.5d-2*FLTI
32344 330 CST=0.85D0+0.5D-1*UNIV
32346 340 CST=0.70D0+1.5D-1*UNIV
32348 350 CST=0.50D0+2.0D-1*UNIV
32350 360 CST=0.50D0*UNIV
32354 C----------------------------------- PP ELASTIC SCATTERING -------
32359 IF (EKIN.LE.0.500D0) THEN
32361 CST=2.0D0*RND-1.0D0
32364 ELSEIF (EKIN.LT.1.0D0) THEN
32366 IF (PDCI(K).GT.EMEV) THEN
32367 UNIVE=(EMEV-PDCI(K-12))/(PDCI(K)-PDCI(K-12))
32368 UNIV=DT_RNDM(UNIVE)
32372 SUM=SUM + (PDCI(II)-PDCI(II-12))*UNIVE + PDCI(II-12)
32374 IF (UNIV.LT.SUM)THEN
32377 GOTO(55,55,55,60,60,65,65,65,65,70,70) I
32384 IF (PDCH(K).GT.EMEV) THEN
32385 UNIVE=(EMEV-PDCH(K-11))/(PDCH(K)-PDCH(K-11))
32386 UNIV=DT_RNDM(UNIVE)
32390 SUM=SUM + (PDCH(II)-PDCH(II-11))*UNIVE + PDCH(II-11)
32392 IF (UNIV.LT.SUM)THEN
32395 GOTO(50,55,60,60,65,65,65,65,70,70) I
32406 60 CST=0.3D0+0.1D0*FLTI
32408 65 CST=0.6D0+0.04D0*FLTI
32410 70 CST=0.78D0+0.02D0*FLTI
32413 IF (DT_RNDM(CST).GT.0.5D0) CST=-CST
32418 *$ CREATE DT_DHADRI.FOR
32421 *===dhadri=============================================================*
32423 SUBROUTINE DT_DHADRI(N,PLAB,ELAB,CX,CY,CZ,ITTA)
32425 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32428 PARAMETER ( LINP = 10 ,
32433 C-----------------------------
32434 C*** INPUT VARIABLES LIST:
32435 C*** SAMPLING OF HADRON NUCLEON INTERACTION FOR (ABOUT) 0.1 LE PLAB LE 6
32436 C*** GEV/C LABORATORY MOMENTUM REGION
32437 C*** N - PROJECTILE HADRON INDEX
32438 C*** PLAB - LABORATORY MOMENTUM OF N (GEV/C)
32439 C*** ELAB - LABORATORY ENERGY OF N (GEV)
32440 C*** CX,CY,CZ - DIRECTION COSINES OF N IN THE LABORATORY SYSTEM
32441 C*** ITTA - TARGET NUCLEON INDEX
32442 C*** OUTPUT VARIABLES LIST OF PARTICLE CHARACTERISTICS IN /FINLSP/
32443 C IR COUNTS THE NUMBER OF PRODUCED PARTICLES
32444 C*** ITR - PARTICLE INDEX, CXR,CYR,CZR - DIRECTION COSINES (LAB. SYST.)
32445 C*** ELR,PLR LAB. ENERGY AND LAB. MOMENTUM OF THE SAMPLED PARTICLE
32446 C*** RESPECT., UNITS (GEV/C AND GEV)
32447 C----------------------------
32449 COMMON /HNGAMR/ REDU,AMO,AMM(15)
32451 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
32453 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
32454 & NRK(2,268),NURE(30,2)
32456 * particle properties (BAMJET index convention),
32457 * (dublicate of DTPART for HADRIN)
32458 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
32459 & K1H(110),K2H(110)
32461 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
32463 COMMON /HNMETL/ CXS(149),CYS(149),CZS(149),ELS(149),PLS(149),
32466 COMMON /HNDRUN/ RUNTES,EFTES
32468 * particle properties (BAMJET index convention)
32470 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
32471 & IICH(210),IIBAR(210),K1(210),K2(210)
32473 * final state from HADRIN interaction
32474 PARAMETER (MAXFIN=10)
32475 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
32476 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
32478 DIMENSION ITPRF(110)
32481 DATA ITPRF/-1,-1,5*1,-1,-1,1,1,1,-1,-1,-1,-1,6*1,-1,-1,-1,85*1/
32483 IF (N.LE.0.OR.N.GE.111)N=1
32484 IF (ITPRF( N ).GT.0 .OR. ITTA.GT.8) THEN
32487 * + ' FALSE USE OF THE PARTICLE TYPE INDEX: N, ITTA', N, ITTA
32489 *1000 FORMAT (3(5H ****/),A,2I4,3(5H ****/))
32490 * + 45H FALSE USE OF THE PARTICLE TYPE INDEX, N,LUE ,I4,3(5H ****/))
32493 IF (ABS(PLAB-5.0D0).LT.4.99999D0) GO TO 20
32494 C IF(IPRI.GE.1) WRITE (6,1010) PLAB
32496 1010 FORMAT ( ' PROJECTILE HADRON MOMENTUM OUTSIDE OF THE
32497 + ALLOWED REGION, PLAB=',1E15.5)
32500 UMODAT=N*1.11111D0+ITTA*2.19291D0
32501 IF(UMODAT.NE.UMODA) CALL DT_DCALUM(N,ITTA)
32508 IF (LOWP.GT.20) THEN
32509 C WRITE(LOUT,*) ' jump 1'
32513 IF (NNN.EQ.N) GO TO 50
32522 IF(ITTA.GT.1) IRE=NURE(N,2)
32524 C-----------------------------
32525 C*** IE,AMT,ECM,SI DETERMINATION
32526 C----------------------------
32527 CALL DT_DSIGIN(IRE,PLAB,N,IE,AMT ,AMN,ECM,SI,ITTA)
32530 C IF (AMH(1).NE.0.93828D0) IANTH=1
32531 IF (AMH(1).NE.0.9383D0) IANTH=1
32533 IF (IANTH.GE.0) SI=1.0D0
32536 C-----------------------------
32538 C IRE CHARACTERIZES THE REACTION
32539 C IE IS THE ENERGY INDEX
32540 C----------------------------
32541 IF (SI.LT.1.D-6) THEN
32542 C WRITE(LOUT,*) ' jump 2'
32545 IF (N.LE.NSTAB) GO TO 60
32546 RUNTES=RUNTES+1.0D0
32547 IF (RUNTES.LT.20.D0) WRITE(LOUT,1020)N
32548 1020 FORMAT(3H N=,I10,30H THE PROEKTILE IS A RESONANCE )
32549 IF(IBARH(N).EQ.1) N=8
32550 IF(IBARH(N).EQ.-1) N=9
32553 **sr 19.2.97: loop for direct channel suppression
32554 C IF (IMACH.GT.10) THEN
32555 IF (IMACH.GT.1000) THEN
32557 C WRITE(LOUT,*) ' jump 3'
32563 ECMN=(ECM**2+AMN2-AMT2)/(2.0D0*ECM )
32564 IF(ECMN.LE.AMN) ECMN=AMN
32565 PCMN=SQRT(ECMN**2-AMN2)
32568 IF (IANTH.GE.0) ECM=2.1D0
32570 C-----------------------------
32571 C*** RANDOM CHOICE OF REACTION CHANNEL
32572 C----------------------------
32577 C-----------------------------
32578 C*** PLACE REDUCED VERSION
32579 C----------------------------
32581 IDWK=IEII(IRE+1)-IIEI
32585 C-----------------------------
32586 C*** SHRINKAGE TO THE CONSIDERED ENERGY REGION FOR THE USE OF WEIGHTS
32587 C----------------------------
32589 HUMO=2.0D0*UMO(IIEI+IDWK)-UMO(IIEI+IDWK-1)
32590 IF (HUMO.LT.ECM) ECM=HUMO
32592 C-----------------------------
32593 C*** INTERPOLATION PREPARATION
32594 C----------------------------
32600 C-----------------------------
32602 C----------------------------
32607 IWK=IIWK+(IK-1)*IDWK+IE-IIEI
32611 C-----------------------------
32612 C*** TESTVARIABLE WICO/WICOR: IF CHANNEL IK HAS THE SAME WEIGHTS LIKE IK
32613 C GO TO NEXT CHANNEL, BECAUSE WKK((IK))-WKK((IK-1))=0, IK CAN NOT
32615 C----------------------------
32616 IF (PLAB.LT.PLABF(IIEI+2)) WDK=0.0D0
32617 WICO=WOK*1.23459876D0+WDK*1.735218469D0
32618 IF (WICO.EQ.WICOR) GO TO 70
32619 IF (UMO(IIEI+IDWK).LT.HECM) WDK=0.0D0
32622 C-----------------------------
32623 C*** INTERPOLATION IN CHANNEL WEIGHTS
32624 C----------------------------
32625 EKLIM=-THRESH(IIKI+IK)
32626 IELIM=IDT_IEFUND(EKLIM,IRE)
32627 DELIM=UMO(IELIM)+EKLIM
32629 DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
32630 IF (DELIM*DELIM-DETE*DETE) 90,90,80
32635 WKK=WOK-WDK*DEC/(DECC+1.D-9)
32637 C-----------------------------
32639 C----------------------------
32641 IF (VV.GT.WKK) GO TO 70
32643 C***IK IS THE REACTION CHANNEL
32644 C----------------------------
32656 IF (I1001.GT.50) GO TO 60
32658 IF (IT2*AMS.GT.IT2*ECM) GO TO 110
32661 IF (IANTH.GE.0) ECM=ELAB+AMT+0.00001D0
32664 IF (IT2.GT.0) GO TO 120
32665 **sr 19.2.97: supress direct channel for pp-collisions
32666 IF ((N.EQ.1).AND.(ITTA.EQ.1).AND.(IT2.LE.0)) THEN
32668 IF (RR.LE.0.75D0) GOTO 60
32672 C-----------------------------
32673 C INCLUSION OF DIRECT RESONANCES
32674 C RANDOM CHOICE OF DECAY CHANNELS OF THE DIRECT RESONANCE IT1
32675 C------------------------
32688 IF(WW.LT. 0.5D0) GO TO 130
32695 C-----------------------------
32696 C THE FIRST PARTICLE IS DEFINED TO BE THE FORWARD GOING ONE AT SMALL T
32703 IF(IB1.EQ.IBN) GO TO 140
32709 C-----------------------------
32710 C***IT1,IT2 ARE THE CREATED PARTICLES
32711 C***MOMENTA AND DIRECTION COSINA IN THE CM - SYSTEM
32712 C------------------------
32713 CALL DT_DTWOPA(ECM1,ECM2,PCM1,PCM2,COD1,COD2,COF1,COF2,SIF1,SIF2,
32714 *IT1,IT2,ECM,ECMN,PCMN,N,AM1,AM2)
32719 C-----------------------------
32720 C***TRANSFORMATION INTO LAB SYSTEM AND ROTATION
32721 C----------------------------
32722 CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD1,COF1,SIF1,
32723 &PCM1,ECM1,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32727 CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD2,COF2,SIF2,
32728 *PCM2,ECM2,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32731 C-----------------------------
32732 C***TEST STABLE OR UNSTABLE
32733 C----------------------------
32734 IF(ITS(IST).GT.NSTAB) GO TO 160
32737 C-----------------------------
32738 C***IRH IS THE NUMBER OF THE FINAL STABLE PARTICLE
32739 C----------------------------
32740 C* IF (REDU.LT.0.D0) GO TO 1009
32748 IF(IST.GE.1) GO TO 150
32752 C RANDOM CHOICE OF DECAY CHANNELS
32753 C----------------------------
32767 IF (VV.GT.WTI(IIK)) GO TO 180
32769 C IIK IS THE DECAY CHANNEL
32770 C----------------------------
32778 IF (IT2-1.LT.0) GO TO 240
32783 C IF IIK-KIN.LIM.GT.ACTUAL TOTAL CM-ENERGY, DO AGAIN RANDOM IIK-CHOICE
32784 C----------------------------
32785 IF (IECO.LE.10) GO TO 200
32787 IF(IATMPT.GT.3) THEN
32788 C WRITE(LOUT,*) ' jump 4'
32793 IF (I310.GT.50) GO TO 170
32794 IF (AMS.GT.ECO) GO TO 190
32796 C FOR THE DECAY CHANNEL
32797 C IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM IT
32798 C----------------------------
32799 IF (REDU.LT.0.D0) GO TO 30
32802 IF(IT3.EQ.0) GO TO 220
32805 CALL DT_DTHREP(ECO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,SIF1,
32806 *COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
32808 220 CALL DT_DTWOPD(ECO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,
32809 &COD2,COF2,SIF2,AM1,AM2)
32814 IF (REDU.GT.0.D0) GO TO 240
32816 IF (ITWTHC.GT.100) GO TO 30
32817 IF (ITWTH) 220,220,210
32820 IF (IT2-1.LT.0) GO TO 250
32827 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD1,COF1,SIF1,PCM1,ECM1,
32828 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32831 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD2,COF2,SIF2,PCM2,ECM2,
32832 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32833 IF (IT3.LE.0) GO TO 250
32836 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD3,COF3,SIF3,PCM3,ECM3,
32837 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32845 C----------------------------
32847 C ZERO CROSS SECTION CASE
32848 C----------------------------
32860 *$ CREATE DT_RUNTT.FOR
32863 *===runtt==============================================================*
32865 BLOCK DATA DT_RUNTT
32867 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32870 COMMON /HNDRUN/ RUNTES,EFTES
32872 DATA RUNTES,EFTES /100.D0,100.D0/
32876 *$ CREATE DT_NONAME.FOR
32879 *===noname=============================================================*
32881 BLOCK DATA DT_NONAME
32883 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32886 * slope parameters for HADRIN interactions
32887 COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
32889 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
32891 C DATAS DATAS DATAS DATAS DATAS
32893 DATA IKII/ 0, 15, 41, 67, 82, 93, 110, 133, 148, 159, 172, 183,
32894 & 207, 224, 241, 252, 268 /
32895 DATA IEII/ 0, 21, 46, 71, 92, 109, 126, 143, 160, 173, 186, 199,
32896 & 220, 241, 262, 279, 296 /
32897 DATA IRII/ 0, 315, 965, 1615, 1930, 2117, 2406, 2797, 3052, 3195,
32898 & 3364, 3507, 4011, 4368, 4725, 4912, 5184/
32901 C MASSES FOR THE SLOPE B(M) IN GEV
32902 C SLOPE B(M) FOR AN MESONIC SYSTEM
32903 C SLOPE B(M) FOR A BARYONIC SYSTEM
32906 DATA SM,BBM,BBB/ 0.8D0, 0.85D0, 0.9D0, 0.95D0, 1.D0,
32907 & 1.05D0, 1.1D0, 1.15D0, 1.2D0, 1.25D0,
32908 & 1.3D0, 1.35D0, 1.4D0, 1.45D0, 1.5D0,
32909 & 1.55D0, 1.6D0, 1.65D0, 1.7D0, 1.75D0,
32910 & 1.8D0, 1.85D0, 1.9D0, 1.95D0, 2.D0,
32911 & 15.6D0, 14.95D0, 14.3D0, 13.65D0, 13.D0,
32912 & 12.35D0, 11.7D0, 10.85D0, 10.D0, 9.15D0,
32913 & 8.3D0, 7.8D0, 7.3D0, 7.25D0, 7.2D0,
32914 & 6.95D0, 6.7D0, 6.6D0, 6.5D0, 6.3D0,
32915 & 6.1D0, 5.85D0, 5.6D0, 5.35D0, 5.1D0,
32916 & 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0,
32917 & 14.2D0, 13.4D0, 12.6D0,
32918 & 11.8D0, 11.2D0, 10.6D0, 9.8D0, 9.D0,
32919 & 8.25D0, 7.5D0, 6.25D0, 5.D0, 4.5D0, 5*4.D0 /
32923 *$ CREATE DT_DAMG.FOR
32926 *===damg===============================================================*
32928 DOUBLE PRECISION FUNCTION DT_DAMG(IT)
32930 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32933 * particle properties (BAMJET index convention),
32934 * (dublicate of DTPART for HADRIN)
32935 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
32936 & K1H(110),K2H(110)
32938 DIMENSION GASUNI(14)
32940 *-1.D0,-.98D0,-.95D0,-.87D0,-.72D0,-.48D0,
32941 *-.17D0,.17D0,.48D0,.72D0,.87D0,.95D0,.98D0,1.D0/
32942 DATA GAUNO/2.352D0/
32948 IF (IT.LE.0) GO TO 30
32949 IF (IT.LE.NSTAB) GO TO 20
32950 DGAUNI=GAUNO*GAUNON/DBLE(IO-1)
32952 VV=VV*2.0D0-1.0D0+1.D-16
32957 IF (VV.GT.V1) GO TO 10
32958 UNIGA=DGAUNI*(DBLE(I)-2.0D0+(VV-VO+1.D-16)/
32959 & (V1-VO)-(DBLE(IO)-1.0D0)*0.5D0)
32960 DAM=GAH(IT)*UNIGA/GAUNO
32972 *$ CREATE DT_DCALUM.FOR
32975 *===dcalum=============================================================*
32977 SUBROUTINE DT_DCALUM(N,ITTA)
32979 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32982 C*** C.M.S.-ENERGY AND REACTION CHANNEL THRESHOLD CALCULATION
32984 * particle properties (BAMJET index convention),
32985 * (dublicate of DTPART for HADRIN)
32986 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
32987 & K1H(110),K2H(110)
32989 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
32991 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
32993 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
32994 & NRK(2,268),NURE(30,2)
32996 IRE=NURE(N,ITTA/8+1)
33005 ELAB=SQRT(AM12+AM22+2.0D0*SQRT(PLAB2+AM12)*AM2)
33012 IF(NRK(2,IK).GT.0) GO TO 30
33021 IF(IN.GT.0)AMS=AMS+AMH(IN)
33023 IF(IN.GT.0) AMS=AMS+AMH(IN)
33024 IF (AMS.LT.AMSS) AMSS=AMS
33026 IF(UMOO.LT.AMSS) UMOO=AMSS
33032 *$ CREATE DT_DCHANH.FOR
33035 *===dchanh=============================================================*
33037 SUBROUTINE DT_DCHANH
33039 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33042 PARAMETER ( LINP = 10 ,
33046 * particle properties (BAMJET index convention),
33047 * (dublicate of DTPART for HADRIN)
33048 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33049 & K1H(110),K2H(110)
33051 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
33053 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33055 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33056 & NRK(2,268),NURE(30,2)
33058 DIMENSION HWT(460),HWK(40),SI(5184)
33059 EQUIVALENCE (WK(1),SI(1))
33060 C--------------------
33061 C*** USE ONLY FOR DATAPREPARATION OF PURE HADRIN
33062 C*** CALCULATION OF REACTION- AND DECAY-CHANNEL-WEIGHTS,
33063 C*** THRESHOLD ENERGIES+MOMENTA OF REACTION CHNLS.
33064 C*** CHANGE OF WT- AND WK-INPUTDATA INTO WEIGHTS FOR THE M.-C.-PROCEDURE
33065 C*** (ADDED ONE TO EACH OTHER FOR CORRESPONDING CHANNELS)
33066 C--------------------------
33070 IEE=IEII(IRE+1)-IEII(IRE)
33071 IKE=IKII(IRE+1)-IKII(IRE)
33074 * modifications to suppress elestic scattering 24/07/91
33079 IWK=IWKO+IEE*(IK-1)+IE
33080 IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
33081 SIS=SIS+SI(IWK)*SINORC
33085 IF (SIS.GE.1.D-12) GO TO 20
33091 IWK=IWKO+IEE*(IK-1)+IE
33092 IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
33093 SIO=SIO+SI(IWK)*SINORC/SIS
33097 IWK=IWKO+IEE*(IK-1)+IE
33102 INRK1=NRK(1,IIKI+IK)
33103 IF (INRK1.GT.0) AM111=AMH(INRK1)
33105 INRK2=NRK(2,IIKI+IK)
33106 IF (INRK2.GT.0) AM222=AMH(INRK2)
33107 THRESH(IIKI+IK)=AM111 +AM222
33108 IF (INRK2-1.GE.0) GO TO 60
33112 DO 50 INRK1=INRKK,INRKO
33113 INZK1=NZKI(INRK1,1)
33114 INZK2=NZKI(INRK1,2)
33115 INZK3=NZKI(INRK1,3)
33116 IF (INZK1.LE.0.OR.INZK1.GT.110) GO TO 50
33117 IF (INZK2.LE.0.OR.INZK2.GT.110) GO TO 50
33118 IF (INZK3.LE.0.OR.INZK3.GT.110) GO TO 50
33119 C WRITE (6,310)INRK1,INZK1,INZK2,INZK3
33121 AMS=AMH(INZK1)+AMH(INZK2)
33122 IF (INZK3-1.GE.0) AMS=AMS+AMH(INZK3)
33123 IF (AMSS.GT.AMS) AMSS=AMS
33126 IF (AMS.LT.UMO(IEO)) AMS=UMO(IEO)
33127 THRESH(IIKI+IK)=AMS
33138 IF (IK2.GT.460)IK2=460
33145 IF (ABS(HV-1.0D0).GT.1.D-4) WRITE(LOUT,1010)I,JI,HV
33146 1010 FORMAT (35H ERROR IN HWT, FALSE USE OF CHANWH ,2I6,F10.2)
33153 *$ CREATE DT_DHADDE.FOR
33156 *===dhadde=============================================================*
33158 SUBROUTINE DT_DHADDE
33160 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33163 * particle properties (BAMJET index convention)
33165 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
33166 & IICH(210),IIBAR(210),K1(210),K2(210)
33168 * HADRIN: decay channel information
33169 PARAMETER (IDMAX9=602)
33171 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
33173 * particle properties (BAMJET index convention),
33174 * (dublicate of DTPART for HADRIN)
33175 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33176 & K1H(110),K2H(110)
33178 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
33180 * decay channel information for HADRIN
33181 COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
33182 & K1Z(16),K2Z(16),WTZ(153),II22,
33183 & NZK1(153),NZK2(153),NZK3(153)
33189 IF (IRETUR.GT.1) RETURN
33195 IBARH(I) = IIBAR(I)
33210 NZKI(I,1) = NZK(I,1)
33211 NZKI(I,2) = NZK(I,2)
33212 NZKI(I,3) = NZK(I,3)
33227 NZKI(L,3) = NZK3(I)
33228 NZKI(L,2) = NZK2(I)
33229 NZKI(L,1) = NZK1(I)
33234 *$ CREATE IDT_IEFUND.FOR
33237 *===iefund=============================================================*
33239 INTEGER FUNCTION IDT_IEFUND(PL,IRE)
33241 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33244 C*****IEFUN CALCULATES A MOMENTUM INDEX
33246 PARAMETER ( LINP = 10 ,
33250 COMMON /HNDRUN/ RUNTES,EFTES
33252 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33254 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33255 & NRK(2,268),NURE(30,2)
33260 IF (PL.LT.0.) GO TO 30
33263 IF (PL.LE.PLABF(I)) GO TO 60
33266 IF ( EFTES.GT.40.D0) GO TO 20
33268 WRITE(LOUT,1000)PL,J
33274 IF (-PL.LE.UMO(I)) GO TO 60
33277 IF ( EFTES.GT.40.D0) GO TO 50
33279 WRITE(LOUT,1000)PL,I
33285 1000 FORMAT(14H PLAB OR -ECM=,E12.4,27H IS OUT OF CONSIDERED RANGE ,
33289 *$ CREATE DT_DSIGIN.FOR
33292 *===dsigin=============================================================*
33294 SUBROUTINE DT_DSIGIN(IRE ,PLAB,N,IE ,AMT ,AMN,ECM ,SI ,ITAR)
33296 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33299 * particle properties (BAMJET index convention),
33300 * (dublicate of DTPART for HADRIN)
33301 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33302 & K1H(110),K2H(110)
33304 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33306 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33307 & NRK(2,268),NURE(30,2)
33309 IE=IDT_IEFUND(PLAB,IRE)
33310 IF (IE.LE.IEII(IRE)) IE=IE+1
33315 ECM=SQRT(AMN2+AMT2+2.0D0*AMT*SQRT(AMN2+PLAB**2))
33316 C*** INTERPOLATION PREPARATION
33322 EKLIM=-THRESH(IIKI)
33325 IF (ECM.GT.ECMO) WDK=0.0D0
33326 C*** INTERPOLATION IN CHANNEL WEIGHTS
33327 IELIM=IDT_IEFUND(EKLIM,IRE)
33328 DELIM=UMO(IELIM)+EKLIM
33330 DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
33331 IF (DELIM*DELIM-DETE*DETE) 20,20,10
33336 WKK=WOK-WDK*DEC/(DECC+1.D-9)
33337 IF (WKK.LT.0.0D0) WKK=0.0D0
33339 IF (-EKLIM.GT.ECM) SI=1.D-14
33343 *$ CREATE DT_DTCHOI.FOR
33346 *===dtchoi=============================================================*
33348 SUBROUTINE DT_DTCHOI(T,P,PP,E,EE,I,II,N,AM1,AM2)
33350 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33353 C ****************************
33354 C TCHOIC CALCULATES A RANDOM VALUE
33355 C FOR THE FOUR-MOMENTUM-TRANSFER T
33356 C ****************************
33358 * particle properties (BAMJET index convention),
33359 * (dublicate of DTPART for HADRIN)
33360 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33361 & K1H(110),K2H(110)
33363 * slope parameters for HADRIN interactions
33364 COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
33368 IF (I.GT.30.AND.II.GT.30) GO TO 20
33371 IF (I.LE.30) GO TO 10
33379 IF (AMA.LE.AMB) GO TO 30
33385 K=INT((AMA-0.75D0)/0.05D0)
33387 IF (K-26.GE.0) K=25
33394 TMIN=-2.0D0*(E*EE-P*PP)+AMH(N)**2+AM1 **2
33395 TMAX=-2.0D0*(E*EE+P*PP)+AMH(N)**2+AM1 **2
33398 C IF (VB.LT.0.2D0) BM=BM*0.1
33405 IF (ABS(TMA).GT.120.D0) GO TO 70
33408 AN=(1.0D0/BM)*(EXP(TMI)-ETMA)
33409 C*** RANDOM CHOICE OF THE T - VALUE
33411 T=(1.0D0/BM)*LOG(ETMA+R*AN*BM)
33415 *$ CREATE DT_DTWOPA.FOR
33418 *===dtwopa=============================================================*
33420 SUBROUTINE DT_DTWOPA(E1,E2,P1,P2,COD1,COD2,COF1,COF2,SIF1,SIF2,
33421 &IT1,IT2,UMOO,ECM,P,N,AM1,AM2)
33423 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33426 C ******************************************************
33427 C QUASI TWO PARTICLE PRODUCTION
33428 C TWOPAR CALCULATES THE ENERGYS AND THE MOMENTA
33429 C FOR THE CREATED PARTICLES OR RESONANCES IT1 AND IT2
33430 C IN THE CM - SYSTEM
33431 C COD1,COD2,COF1,COF2,SIF1,SIF2 ARE THE ANGLES FOR
33432 C SPHERICAL COORDINATES
33433 C ******************************************************
33435 * particle properties (BAMJET index convention),
33436 * (dublicate of DTPART for HADRIN)
33437 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33438 & K1H(110),K2H(110)
33443 E1=((UMOO-AMB)*(UMOO+AMB) + AMA2)/(2.0D0*UMOO)
33445 IF (E1.LT.AMA*1.00001D0) E1=AMA*1.00001D0
33446 AMTE=(E1-AMA)*(E1+AMA)
33450 C / P2 / = / P1 / BUT OPPOSITE DIRECTIONS
33451 C DETERMINATION OF THE ANGLES
33452 C COS(THETA1)=COD1 COS(THETA2)=COD2
33453 C SIN(PHI1)=SIF1 SIN(PHI2)=SIF2
33454 C COS(PHI1)=COF1 COS(PHI2)=COF2
33455 C PHI IS UNIFORMLY DISTRIBUTED IN ( 0,2*PI )
33456 CALL DT_DSFECF(COF1,SIF1)
33459 C CALCULATION OF THETA1
33460 CALL DT_DTCHOI(TR,P,P1,ECM,E1,IT1,IT2,N,AM1,AM2)
33461 COD1=(TR-AMA2-AMH(N)*AMH(N)+2.0D0*ECM*E1)/(2.0D0*P*P1+1.D-18)
33462 IF (COD1.GT.0.9999999D0) COD1=0.9999999D0
33467 *$ CREATE DT_ZK.FOR
33470 *===zk=================================================================*
33474 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33477 * decay channel information for HADRIN
33478 COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
33479 & K1Z(16),K2Z(16),WTZ(153),II22,
33480 & NZK1(153),NZK2(153),NZK3(153)
33482 * decay channel information for HADRIN
33483 CHARACTER*8 ANAMZ,ZKNAM4,ZKNAM5,ZKNAM6
33484 COMMON /HNADDN/ ANAMZ(16),ZKNAM4(9),ZKNAM5(90),ZKNAM6(54)
33486 * Particle masses in GeV *
33487 DATA AMZ/ 3*2.2D0, 0.9576D0, 3*1.887D0, 2.4D0, 2.03D0, 2*1.44D0,
33489 * Resonance width Gamma in GeV *
33490 DATA GAZ/ 3*.2D0, .1D0, 4*.2D0, .18D0, 2*.2D0, 2*.15D0, 3*0.D0 /
33491 * Mean life time in seconds *
33492 DATA TAUZ / 16*0.D0 /
33493 * Charge of particles and resonances *
33494 DATA ICHZ/ 0, 1, 3*0, 1, -1, 0, 1, -1, 0, 0, 1 , 3*0 /
33495 * Baryonic charge *
33496 DATA IBARZ/ 2, 7*0, 1, -1, -1, 1, 1, 3*0 /
33497 * First number of decay channels used for resonances *
33498 * and decaying particles *
33499 DATA K1Z/ 308,310,313,317,322,365,393,421,425,434,440,446,449,
33501 * Last number of decay channels used for resonances *
33502 * and decaying particles *
33503 DATA K2Z/ 309,312,316,321,364,392,420,424,433,439,445,448,451,
33505 * Weight of decay channel *
33506 DATA WTZ/ .17D0, .83D0, 2*.33D0, .34D0, .17D0, 2*.33D0, .17D0,
33507 & .01D0, .13D0, .36D0, .27D0, .23D0, .0014D0, .0029D0, .0014D0,
33508 & .0029D0, 4*.0007D0, .0517D0, .0718D0, .0144D0, .0431D0, .0359D0,
33509 & .0718D0, .0014D0, .0273D0, .0014D0, .0431D0, 2*.0129D0, .0259D0,
33510 & .0517D0, .0359D0, .0014D0, 2*.0144D0, .0129D0, .0014D0, .0259D0,
33511 & .0359D0, .0072D0, .0474D0, .0948D0, .0259D0, .0072D0, .0144D0,
33512 & .0287D0, .0431D0, .0144D0, .0287D0, .0474D0, .0144D0, .0075D0,
33513 & .0057D0, .0019D0, .0038D0, .0095D0, 2*.0014D0, .0191D0, .0572D0,
33514 & .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0, .0686D0,.0172D0,
33515 & .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, .0190D0,
33516 & .0057D0, .0019D0, .0038D0, .0095D0, .0014D0, .0014D0, .0191D0,
33517 & .0572D0, .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0,.0686D0,
33518 & .0172D0, .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0,
33519 & .0190D0, 4*.25D0, 2*.2D0, .12D0, .1D0, .07D0, .07D0, .14D0,
33520 & 2*.05D0, .0D0, .3334D0, .2083D0, 2*.125D0, .2083D0, .0D0, .125D0,
33521 & .2083D0, .3334D0, .2083D0, .125D0, .3D0, .05D0, .65D0, .3D0,
33522 & .05D0, .65D0, 9*1.D0 /
33523 * Particle numbers in decay channel *
33524 DATA NZK1/ 8, 1, 2, 9, 1, 2, 9, 2, 9, 7, 13, 31, 15, 24, 23, 13,
33525 & 23, 13, 2*23, 14, 13, 23, 31, 98, 2*33, 32, 23, 14, 13, 35, 2*23,
33526 & 14, 13, 33, 23, 98, 31, 23, 14, 13, 35, 2*33, 32, 23, 35, 33, 32,
33527 & 98, 5*35, 4*13, 23, 13, 98, 32, 33, 23, 13, 23, 13, 14, 13, 32,
33528 & 13, 98, 23, 13, 2*32, 13, 33, 32, 98, 2*35, 4*14, 23, 14, 98,
33529 & 2*34, 23, 14, 23, 2*14, 13, 34, 14, 98, 23, 14, 2*34, 14, 33, 32,
33530 & 98, 2*35, 104, 61, 105, 62, 1, 17, 21, 17, 22, 2*21, 22, 21, 2,
33531 & 67, 68, 69, 2, 2*9, 68, 69, 70, 2, 9, 2*24, 15, 2*25, 16, 9*0/
33532 DATA NZK2/ 2*8, 1, 8, 9, 2*8, 2*1, 7, 14, 13, 16, 25, 23, 14, 23,
33533 & 14, 31, 33, 32, 34, 35, 31, 23, 31, 33, 34, 31, 32, 34, 31, 33,
33534 & 32, 2*33, 35, 31, 33, 31, 33, 32, 34, 35, 31, 33, 34, 35, 31,
33535 & 4*33, 32, 3*35, 2*23, 13, 31, 32, 33, 13, 31, 32, 2*31, 32, 33,
33536 & 32, 32, 35, 31, 2*32, 33, 31, 33, 35, 33, 3*32, 35, 2*23, 14,
33537 & 31, 34, 33, 14, 31, 33, 2*31, 34, 32, 33, 34, 35, 31, 2*34, 33,
33538 & 31, 33, 35, 33, 2*34, 33, 35, 1, 2, 8, 9, 25, 13, 35, 2*32, 33,
33539 & 31, 13, 23, 31, 13, 23, 14, 79, 80, 31, 13, 23, 14, 78, 79, 8,
33540 & 1, 8, 1, 8, 1, 9*0 /
33541 DATA NZK3/ 23, 14, 2*13, 23, 13, 2*23, 14, 0, 7, 14, 4*0, 2*23,
33542 & 10*0, 33, 2*31, 0, 33, 34, 32, 34, 0, 35, 0, 31, 3*35, 0, 3*31,
33543 & 35, 31, 33, 34, 31, 33, 34, 31, 33, 35, 0, 23, 14, 6*0, 32, 3*33,
33544 & 32, 34, 0, 35, 0, 2*35, 2*31, 35, 32, 34, 31, 33, 32, 0, 23, 13,
33545 & 6*0, 34, 2*33, 34, 33, 34, 0, 35, 0,2*35, 2*31, 35, 2*34, 31,
33546 & 2*34, 25*0, 23, 2*14, 23, 2*13, 9*0 /
33548 DATA ANAMZ / 'NNPI', 'ANPPI', 'ANNPI', ' ETS ',' PAP ',' PAN ',
33549 & 'APN', 'DEO ', 'S+2030', 'AN*-14', 'AN*014','KONPI ','AKOPPI',
33551 * Name of decay channel *
33552 DATA ZKNAM4/'NNPI0','PNPI-','APPPI+','ANNPI+','ANPPI0','APNPI+',
33553 & 'ANNPI0','APPPI0','ANPPI-'/
33554 DATA ZKNAM5/' GAGA ','P+P-GA','ETP+P-','K+K- ','K0AK0 ',
33555 & ' POPO ',' P+P- ','POPOPO','P+P0P-','P0ET ','&0R0 ','P-R+ ',
33556 & 'P+R- ','POOM ',' ETET ','ETSP0 ','R0ET ',' R0R0 ','R+R- ',
33557 & 'P0ETR0','P-ETR+','P+ETR-',' OMET ','P0R0R0','P0R+R-','P-R+R0',
33558 & 'P+R-R0','R0OM ','P0ETOM','ETSR0 ','ETETET','P0R0OM','P-R+OM',
33559 & 'P+R-OM','OMOM ','R0ETET','R0R0ET','R+R-ET','P0OMOM','OMETET',
33560 & 'R0R0R0','R+R0R-','ETSRET','OMR0R0','OMR+R-','OMOMET','OMOMR0',
33562 & ' P+PO ','P+POPO','P+P+P-','P+ET ','P0R+ ','P+R0 ','ETSP+ ',
33563 & 'R+ET ',' R0R+ ','POETR+','P+ETR0','POR+R-','P+R0R0','P-R+R+',
33564 & 'P+R-R+','R+OM ','P+ETOM','ETSR+ ','POR+OM','P+R0OM','R+ETET',
33565 & 'R+R0ET','P+OMOM','R0R0R+','R+R+R-','ETSR+E','OMR+R0','OMOMR+',
33566 & 'P-PO ','P-POPO','P-P-P+','P-ET ','POR- ','P-R0 ','ETSP- ',
33567 & 'R-ET ','R-R0 ','POETR-','P-ETR0','POR-R0','P-R+R-','P-R0R0'/
33568 DATA ZKNAM6/'P+R-R-','R-OM ','P-ETOM','ETSR- ','POR-OM','P-R0OM',
33569 & 'R-ETET','R-R0ET','P-OMOM','R0R0R-','R+R-R-','ETSR-E','OMR0R-',
33570 & 'OMOMR-', 'PAN-14','APN+14','NAN014','ANN014','PAKO ','LPI+ ',
33571 & 'SI+OM','LAMRO+','SI0RO+','SI+RO0','SI+ETA','SI0PI+','SI+PI0',
33572 & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHOO','ANRHO-','ANETA ',
33573 & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0',
33574 & 'KONPIO','KOPPI-','K+NPI-','AKOPPO','AKONP+','K-PPI+',
33579 *$ CREATE DT_BLKD43.FOR
33582 *===blkd43=============================================================*
33584 BLOCK DATA DT_BLKD43
33586 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33590 *=== reac =============================================================*
33592 *----------------------------------------------------------------------*
33594 * Created on 10 december 1991 by Alfredo Ferrari & Paola Sala *
33597 * Last change on 10-dec-91 by Alfredo Ferrari *
33599 * This is the original common reac of Hadrin *
33601 *----------------------------------------------------------------------*
33604 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33605 & NRK(2,268),NURE(30,2)
33608 & UMOPI(92), UMOKC(68), UMOP(39), UMON(63), UMOK0(34),
33609 & PLAPI(92), PLAKC(68), PLAP(39), PLAN(63), PLAK0(34),
33610 & SPIKP1(315), SPIKPU(278), SPIKPV(372),
33611 & SPIKPW(278), SPIKPX(372), SPIKP4(315),
33612 & SPIKP5(187), SPIKP6(289),
33613 & SKMPEL(102), SPIKP7(289), SKMNEL(68), SPIKP8(187),
33614 & SPIKP9(143), SPIKP0(169), SPKPV(143),
33615 & SAPPEL(105), SPIKPE(399), SAPNEL(84), SPIKPZ(273),
33616 & SANPEL(84) , SPIKPF(273),
33617 & SPKP15(187), SPKP16(272),
33618 & NRKPI(164), NRKKC(132), NRKP(70), NRKN(116), NRKK0(54),
33621 DIMENSION NRKLIN(532)
33622 EQUIVALENCE (NRK(1,1), NRKLIN(1))
33623 EQUIVALENCE ( UMO( 1), UMOPI(1)), ( UMO( 93), UMOKC(1))
33624 EQUIVALENCE ( UMO(161), UMOP(1)), ( UMO(200), UMON(1))
33625 EQUIVALENCE ( UMO(263), UMOK0(1))
33626 EQUIVALENCE ( PLABF( 1), PLAPI(1)), ( PLABF( 93), PLAKC(1))
33627 EQUIVALENCE ( PLABF(161), PLAP(1)), ( PLABF(200), PLAN(1))
33628 EQUIVALENCE ( PLABF(263), PLAK0(1))
33629 EQUIVALENCE ( WK( 1), SPIKP1(1)), ( WK( 316), SPIKPU(1))
33630 EQUIVALENCE ( WK( 594), SPIKPV(1)), ( WK( 966), SPIKPW(1))
33631 EQUIVALENCE ( WK(1244), SPIKPX(1)), ( WK(1616), SPIKP4(1))
33632 EQUIVALENCE ( WK(1931), SPIKP5(1)), ( WK(2118), SPIKP6(1))
33633 EQUIVALENCE ( WK(2407), SKMPEL(1)), ( WK(2509), SPIKP7(1))
33634 EQUIVALENCE ( WK(2798), SKMNEL(1)), ( WK(2866), SPIKP8(1))
33635 EQUIVALENCE ( WK(3053), SPIKP9(1)), ( WK(3196), SPIKP0(1))
33636 EQUIVALENCE ( WK(3365), SPKPV(1)), ( WK(3508), SAPPEL(1))
33637 EQUIVALENCE ( WK(3613), SPIKPE(1)), ( WK(4012), SAPNEL(1))
33638 EQUIVALENCE ( WK(4096), SPIKPZ(1)), ( WK(4369), SANPEL(1))
33639 EQUIVALENCE ( WK(4453), SPIKPF(1)), ( WK(4726), SPKP15(1))
33640 EQUIVALENCE ( WK(4913), SPKP16(1))
33641 EQUIVALENCE (NRK(1,1), NRKLIN(1))
33642 EQUIVALENCE (NRKLIN( 1), NRKPI(1)), (NRKLIN( 165), NRKKC(1))
33643 EQUIVALENCE (NRKLIN( 297), NRKP(1)), (NRKLIN( 367), NRKN(1))
33644 EQUIVALENCE (NRKLIN( 483), NRKK0(1))
33645 EQUIVALENCE (NURE(1,1), NURELN(1))
33649 DATA PLAPI / 0.D0, .3D0, .5D0, .6D0, .7D0, .8D0, .9D0, .95D0,1.D0,
33650 & 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0,
33651 & 3.D0, 3.5D0, 4.D0, 0.D0, .285D0, .4D0, .45D0, .5D0, .6D0, .7D0,
33652 & .75D0, .8D0, .85D0, .9D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0,
33653 & 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0,
33654 & .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, .75D0, .8D0, .85D0, .9D0,
33655 & 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0,
33656 & 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, .3D0, .5D0, .6D0, .7D0,
33657 & .8D0, .9D0, .95D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0,
33658 & 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0 /
33660 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33661 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33662 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33663 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33664 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33665 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33666 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33667 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33668 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33669 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33670 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33671 & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
33673 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33674 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33675 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33676 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33677 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33678 & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
33681 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33682 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33683 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33684 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33685 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33686 & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
33687 * app apn anp ann *
33689 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
33690 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33691 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33692 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
33693 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33694 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33695 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
33696 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33697 & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
33698 DATA SIIN / 296*0.D0 /
33699 DATA UMOPI/ 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
33700 & 1.557D0,1.615D0,1.6435D0,
33701 & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
33702 & 2.286D0,2.366D0,2.482D0,2.56D0,
33704 & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
33705 & 1.496D0,1.527D0,1.557D0,
33706 & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
33707 & 2.071D0,2.159D0,2.286D0,2.366D0,
33708 & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
33709 & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
33710 & 1.496D0,1.527D0,1.557D0,
33711 & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
33712 & 2.071D0,2.159D0,2.286D0,2.366D0,
33713 & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
33714 & 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
33715 & 1.557D0,1.615D0,1.6435D0,
33716 & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
33717 & 2.286D0,2.366D0,2.482D0,2.56D0,
33719 DATA UMOKC/ 1.44D0,
33720 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33721 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33723 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33724 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33726 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33727 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33729 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33730 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33732 DATA UMOK0/ 1.44D0,
33733 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33734 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33736 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33737 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33741 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33742 & 3.D0,3.1D0,3.2D0,
33743 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33744 & 3.D0,3.1D0,3.2D0,
33745 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33746 & 3.D0,3.1D0,3.2D0/
33747 * app apn anp ann *
33749 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
33750 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33751 & 3.D0,3.1D0,3.2D0,
33752 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
33753 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33754 & 3.D0,3.1D0,3.2D0,
33755 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
33756 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33757 & 3.D0,3.1D0,3.2D0/
33758 **** reaction channel state particles *
33759 DATA NRKPI / 13, 1, 15, 21, 81, 0, 13, 54, 23, 53, 13, 63, 13, 58,
33760 & 23, 57, 13, 65, 1, 32, 53, 31, 54, 32, 53, 33, 53, 35, 63, 32,
33761 & 13, 8, 23, 1, 17, 15, 21, 24, 22, 15, 82, 0, 61, 0, 13, 55, 23,
33762 & 54, 14, 53, 13, 64, 23, 63, 13, 59, 23, 58, 14, 57, 13, 66, 23,
33763 & 65, 1, 31, 8, 32, 1, 33, 1, 35, 54, 31, 55, 32, 54, 33, 53, 34,
33764 & 54, 35, 14, 1, 23, 8, 17, 24, 20, 15, 22, 24, 83, 0, 62, 0, 14,
33765 & 54, 23, 55, 13, 56, 14, 63, 23, 64, 14, 58, 23, 59, 13, 60, 14,
33766 & 65, 23, 66, 8, 31, 1, 34, 8, 33, 8, 35, 55, 31, 54, 34, 55, 33,
33767 & 56, 32, 55, 35, 14, 8, 24, 20, 84, 0, 14, 55, 23, 56, 14, 64, 14,
33768 & 59, 23, 60, 14, 66, 8, 34, 56, 31, 55, 34, 56, 33, 56, 35, 64,34/
33769 DATA NRKKC/ 15, 1, 89, 0, 24, 53, 15, 54, 1, 36, 1, 40, 1, 44, 36,
33770 & 63, 15, 63, 45, 53, 44, 54, 15, 8, 24, 1, 91, 0, 24, 54, 15, 55,
33771 & 8, 36, 1, 37, 8, 40, 1, 41, 8, 44, 1, 45, 36, 64, 37, 63, 15, 64,
33772 & 24, 63, 45, 54, 44, 55, 16, 1, 25, 8, 17, 23, 21, 14, 20,
33773 & 13, 22, 23, 90, 0, 38, 1, 39, 8, 16, 54, 25, 55, 1, 42, 8, 43,
33774 & 16, 63, 25, 64, 39, 64, 38, 63, 46, 54, 47, 55, 8, 47, 1, 46, 52,
33775 & 0, 51, 0, 16, 8, 17, 14, 20, 23, 22, 14, 92, 0, 8, 38, 16, 55,
33776 & 25, 56, 8, 42, 16, 64, 38, 64, 46, 55, 47, 56, 8, 46, 94, 0 /
33778 * k0 p k0 n ak0 p ak/ n *
33780 DATA NRKK0 / 24, 8, 106, 0, 15, 56, 24, 55, 37, 8, 41, 8, 45, 8,
33781 & 37, 64, 24, 64, 44, 56, 45, 55, 25, 1, 17, 13, 22, 13, 21, 23,
33782 & 107, 0, 39, 1, 25, 54, 16, 53, 43, 1, 25, 63, 39, 63, 47, 54, 46,
33783 & 53, 47, 1, 103, 0, 93, 0/
33785 DATA NRKP / 1, 1, 85, 0, 8, 53, 1, 54, 1, 63, 8, 57, 1, 58, 2*54,
33786 & 53, 55, 63, 54, 64, 53, 1, 8, 86, 0, 8, 54, 1, 55, 8, 63, 1, 64,
33787 & 8, 58, 1, 59, 64, 54, 63, 55, 54, 55, 53, 56, 77, 0, 2*8, 95, 0,
33788 & 8, 55, 1, 56, 8, 64, 8, 59, 1, 60, 2*55, 54, 56, 64, 55, 63, 56 /
33789 * app apn anp ann *
33790 DATA NRKN/ 1, 2, 17, 18, 15, 16, 8, 9, 13, 14, 99, 0, 87, 0, 1,
33791 & 68, 8, 69, 2, 54, 9, 55, 102, 0, 2, 63, 9, 64, 1, 75, 8, 76, 53,
33792 & 67, 54, 68, 55, 69, 56, 70, 63, 68, 64, 69, 75, 54, 76, 55, 2, 8,
33793 & 18, 20, 16, 24, 14, 23, 101, 0, 88, 0, 2, 55, 9, 56, 1, 67, 8,
33794 & 68, 2, 64, 8, 75, 2, 59, 8, 72, 68, 55, 67, 54, 69, 56, 1, 9, 18,
33795 & 21, 15, 25, 13, 23, 100, 0, 96, 0, 2, 53, 9, 54, 1, 69, 8, 70, 1,
33796 & 76, 9, 63, 1, 73, 9, 58, 55, 70, 53, 68, 54, 69 /
33797 **** channel cross section *
33798 DATA SPIKP1/ 0.D0, 300.D0, 40.D0, 20.D0, 13.D0,8.5D0,8.D0, 9.5D0,
33799 & 12.D0,14.D0,15.5D0,20.D0,17.D0,13.D0,10.D0,9.D0,8.5D0,8.D0,7.8D0,
33800 & 7.3D0, 6.7D0, 9*0.D0,.23D0,.35D0,.7D0,.52D0,.4D0,.3D0,.2D0,.15D0,
33801 & .13D0, .11D0, .09D0, .07D0, 0.D0, .033D0,.8D0,1.35D0,1.35D0,.5D0,
33802 & 15*0.D0, 3*0.D0,.00D0,0.80D0,2.2D0,3.6D0,4.6D0,4.7D0,3.5D0,2.4D0,
33803 &1.8D0,1.4D0,.75D0,.47D0,.25D0,.13D0,.08D0,6*0.D0,0.D0,1.2D0,3.3D0,
33804 & 5.4D0,6.9D0,7.3D0,5.3D0,3.6D0,2.7D0,2.2D0,1.1D0,.73D0,.4D0,.22D0,
33805 & .12D0,9*0.D0,.0D0,0.D0,2.0D0,4.4D0,6.8D0,9.9D0,7.9D0,6.0D0,3.8D0,
33806 &2.5D0,2.D0,1.4D0,1.D0,.6D0,.35D0,10*0.D0,.25D0,.55D0,.75D0,1.25D0,
33807 & 1.9D0,2.D0,1.8D0,1.5D0,1.25D0,1.D0,.8D0,6*0.D0,4*0.D0,.4D0,.85D0,
33808 & 1.1D0, 1.85D0, 2.8D0, 3.D0,2.7D0,2.2D0,1.85D0,1.5D0,1.2D0,6*0.D0,
33809 & 6*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, 5.6D0,
33810 & 5.2D0, 6*0.D0, 2*0.D0, .0D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0,
33811 & 2.75D0, 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 6*0.D0, 3*0.D0,
33812 & .0D0, .45D0, 1.4D0, 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0,
33813 & 8*0.D0, 5*0.D0, .0D0, .0D0, .6D0, .8D0, .95D0, .8D0, .7D0, .6D0,
33814 & .5D0, .4D0, 6*0.D0, 5*0.D0, .0D0, .00D0, .85D0, 1.2D0, 1.4D0,
33815 & 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 6*0.D0, 5*0.D0, .0D0, .00D0,
33816 & 1.D0, 1.5D0, 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 6*0.D0,
33817 & 10*0.D0, .5D0, 2.0D0, 3.3D0, 5.4D0, 7.D0 /
33819 DATA SPIKPU/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 20.D0,
33820 & 20.D0, 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
33821 & 10.D0, 10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
33822 & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
33823 & 4.2D0, 7.5D0, 3.4D0, 2.5D0, 2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0,
33824 & .6D0, .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0,
33825 & .48D0, .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0,
33826 & .065D0, .05D0, .04D0, 12*0.D0, .2D0, .25D0, .25D0, .2D0, .1D0,
33827 & .08D0, .06D0, .045D0, .03D0, .02D0, .01D0, .005D0, .003D0,
33828 & 12*0.D0, .3D0, .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0,
33829 & .09D0, .08D0, .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0,
33830 & 3.1D0, 4.5D0, 2.D0, 18*0.D0, 3*.0D0, 0.D0, 0.D0, 4.0D0, 11.D0,
33831 & 11.4D0, 10.3D0, 7.5D0, 6.8D0, 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0,
33832 & .35D0, 13*0.D0, .1D0, .34D0, .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0,
33833 & 2.3D0, 1.6D0, .95D0, .45D0, .28D0, .15D0, 10*0.D0, 2*0.D0, .17D0,
33834 & .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0, 6.2D0, 4.4D0, 3.D0, 1.8D0,
33835 & .9D0, .53D0, .28D0, 10*0.D0, 2*0.D0, .25D0, .82D0,
33836 & 1.3D0, 1.9D0, 2.8D0, 5.5D0 , 8.D0, 5.7D0, 3.9D0, 2.35D0, 1.15D0,
33837 & .69D0, .37D0, 10*0.D0, 7*0.D0, .0D0, .34D0, 1.5D0, 3.47D0,
33838 & 5.87D0, 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
33840 DATA SPIKPV/ 7*0.D0, .00D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
33841 & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 6*0.D0, 10*0.D0, .2D0,
33842 & .6D0, .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0,
33843 & 1.D0, .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0,
33844 & 3.5D0, 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0,
33845 & .31D0, .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0,
33846 & .23D0, 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0,
33847 & 5.D0, 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0,
33848 & 2.5D0, 3*0.D0, 3*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0,
33849 & 1.5D0, 1.1D0, .8D0, .7D0, .55D0, .3D0, 10*0.D0, 9*0.D0, .1D0,
33850 & .4D0, 1.D0, 1.4D0, 2.2D0, 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0,
33851 & .8D0, .6D0, .4D0, 12*0.D0, .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0,
33852 & 3.8D0, 3.3D0, 2.45D0, 2.05D0, 1.65D0, 1.2D0, .9D0, .6D0, 3*0.D0,
33853 & 9*0.D0, .10D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0,
33854 & 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, 13*0.D0, .2D0, .5D0, .7D0,
33855 & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
33856 & 17*0.D0, .2D0, .5D0, .85D0, 2.D0, 2.15D0, 2.05D0, 1.75D0, 1.D0,
33857 & 17*0.D0, .13D0, .33D0, .57D0, 1.33D0, 1.43D0, 1.36D0, 1.17D0,
33858 & .67D0, 17*0.D0, .07D0, .17D0, .28D0, .67D0, .72D0, .69D0, .58D0,
33859 & .33D0,17*0.D0,.4D0, .7D0, 1.D0, 1.6D0, 1.8D0, 2.3D0,1.9D0,1.7D0 /
33861 DATA SPIKPW/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 2*20.D0,
33862 & 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
33863 & 2*10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
33864 & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
33865 & 4.2D0, 7.5D0, 3.4D0, 2*2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, .6D0,
33866 & .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, .48D0,
33867 & .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, .065D0,
33868 & .05D0, .04D0, 12*0.D0, .2D0, 2*.25D0, .2D0, .1D0, .08D0, .06D0,
33869 & .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, 12*0.D0, .3D0,
33870 & .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, .09D0, .08D0,
33871 & .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, 3.1D0, 4.5D0,
33872 & 2.D0, 23*0.D0, 4.0D0, 11.D0, 11.4D0, 10.3D0, 7.5D0, 6.8D0,
33873 & 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, .35D0, 13*0.D0, .1D0, .34D0,
33874 & .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, 2.3D0, 1.6D0, .95D0, .45D0,
33875 & .28D0, .15D0, 12*0.D0, .17D0, .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0,
33876 & 6.2D0, 4.4D0, 3.D0, 1.8D0, .9D0, .53D0, .28D0, 12*0.D0, .25D0,
33877 & .82D0, 1.3D0, 1.9D0, 2.8D0, 5.5D0, 8.D0, 5.7D0, 3.9D0, 2.35D0,
33878 & 1.15D0, .69D0, .37D0, 18*0.D0, .34D0, 1.5D0, 3.47D0, 5.87D0,
33879 & 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
33881 DATA SPIKPX/ 8*0.D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
33882 & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 16*0.D0, .2D0, .6D0,
33883 & .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, 1.D0,
33884 & .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, 3.5D0,
33885 & 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, .31D0,
33886 & .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, .23D0,
33887 & 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, 5.D0,
33888 & 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, 2.5D0,
33889 & 6*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, 1.5D0, 1.1D0,
33890 & .8D0, .7D0, .55D0, .3D0, 19*0.D0, .1D0, .4D0, 1.D0, 1.4D0, 2.2D0,
33891 & 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, .8D0, .6D0, .4D0, 12*0.D0,
33892 & .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, 3.8D0, 3.3D0, 2.45D0, 2.05D0,
33893 & 1.65D0, 1.2D0, .9D0, .6D0, 12*0.D0, .10D0, .2D0, .5D0, .7D0,
33894 & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
33895 & 13*0.D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0,
33896 & 1.35D0, 1.15D0, .95D0, .7D0, 17*0.D0, .2D0, .5D0, .85D0, 2.D0,
33897 & 2.15D0, 2.05D0, 1.75D0, 1.D0, 17*0.D0, .13D0, .33D0, .57D0,
33898 & 1.33D0, 1.43D0, 1.36D0, 1.17D0, .67D0, 17*0.D0, .07D0, .17D0,
33899 & .28D0, .67D0, .72D0, .69D0, .58D0, .33D0, 17*0.D0, .4D0, .7D0,
33900 & 1.D0, 1.6D0, 1.8D0, 2.3D0, 1.9D0, 1.7D0 /
33902 DATA SPIKP4 / 0.D0, 300.D0, 40.D0, 20.D0, 13.D0, 8.5D0, 8.D0,
33903 & 9.5D0, 12.D0, 14.D0, 15.5D0, 20.D0, 17.D0, 13.D0, 10.D0, 9.D0,
33904 & 8.5D0, 8.D0, 7.8D0, 7.3D0, 6.7D0, 9*0.D0, .23D0, .35D0, .7D0,
33905 & .52D0, .4D0, .3D0, .2D0, .15D0, .13D0, .11D0, .09D0, .07D0, 0.D0,
33906 & .033D0, .8D0, 2*1.35D0, .5D0, 19*0.D0, 0.8D0, 2.2D0, 3.6D0,
33907 & 4.6D0, 4.7D0, 3.5D0, 2.4D0, 1.8D0, 1.4D0, .75D0, .47D0, .25D0,
33908 & .13D0, .08D0, 7*0.D0, 1.2D0, 3.3D0, 5.4D0, 6.9D0, 7.3D0, 5.3D0,
33909 & 3.6D0, 2.7D0, 2.2D0, 1.1D0, .73D0, .4D0, .22D0, .12D0, 11*0.D0,
33910 & 2.0D0, 4.4D0, 6.8D0, 9.9D0, 7.9D0, 6.0D0, 3.8D0, 2.5D0, 2.D0,
33911 & 1.4D0, 1.D0, .6D0, .35D0, 10*0.D0, .25D0, .55D0, .75D0, 1.25D0,
33912 & 1.9D0, 2.D0, 1.8D0, 1.5D0, 1.25D0, 1.D0, .8D0, 10*0.D0, .4D0,
33913 & .85D0, 1.1D0, 1.85D0, 2.8D0, 3.D0, 2.7D0, 2.2D0, 1.85D0, 1.5D0,
33914 & 1.2D0, 12*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0,
33915 & 5.6D0, 5.2D0, 9*0.D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, 2.75D0,
33916 & 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 10*0.D0, .45D0, 1.4D0,
33917 & 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, 15*0.D0, .6D0,
33918 & .8D0, .95D0, .8D0, .7D0, .6D0, .5D0, .4D0, 13*0.D0, .85D0, 1.2D0,
33919 & 1.4D0, 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 13*0.D0, 1.D0, 1.5D0,
33920 & 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 16*0.D0, .5D0, 2.0D0,
33921 & 3.3D0, 5.4D0, 7.D0 /
33923 DATA SPIKP5/ 0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0,
33924 & 7.D0, 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
33925 & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 13*0.D0, 0.9D0,
33926 & 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0,
33927 & .45D0, .21D0, .2D0, 3*0.D0, .9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
33928 & 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
33929 & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, 1.4D0,
33930 & 1.2D0, 1.05D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, 2*1.D0, .9D0,
33931 & .7D0, .4D0, .3D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.2D0,
33932 & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
33933 & 1.71D0, 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0,
33934 & 3.5D0, 2.85D0, 2.35D0, 2.01D0, 1.8D0, 12*0.D0, .1D0, .8D0,2.05D0,
33935 & 3.31D0, 3.5D0, 12*0.D0, .034D0, .2D0, .75D0, 1.04D0, 1.24D0 /
33937 DATA SPIKP6/ 0.D0, 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0,
33938 & 1.5D0, 1.2D0, 1.D0, .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0,
33939 & 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, 1.5D0, 1.2D0, 1.D0,
33940 & .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, .5D0, 1.3D0, 2.8D0,
33941 & 2.3D0, 1.6D0, .9D0, 13*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
33942 & 2.D0, 1.7D0, 1.5D0,1.2D0,.9D0,.6D0,.45D0,.21D0,.2D0,3*0.D0,0.9D0,
33943 & 2.5D0, 3.D0, 2.5D0, 2.3D0,2.D0,1.7D0,1.5D0,1.2D0,.9D0,.6D0,.45D0,
33944 & .21D0, .2D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.D0,1.8D0,1.7D0,1.4D0,
33945 & 1.2D0,1.15D0,.9D0,.66D0,.5D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.1D0,
33946 & 1.8D0,1.7D0,1.4D0,1.2D0, 1.15D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0,
33947 & 2*1.D0, .9D0, .7D0, .4D0, .35D0, .2D0, 9*0.D0, .3D0, 2*1.D0,.9D0,
33948 & .7D0, .4D0, .35D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.4D0,3.5D0,4.25D0,
33949 & 4.55D0, 4.85D0, 4.9D0, 9*0.D0, .1D0, 1.D0, 2.4D0, 3.5D0, 4.25D0,
33950 & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
33951 & 1.71D0, 1.6D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0,
33952 & 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0,4.4D0,4.D0,3.5D0,2.85D0,
33953 & 2.35D0, 2.01D0, 1.8D0, 6*0.D0, 1.4D0,3.8D0,5.D0,4.7D0,4.4D0,4.D0,
33954 & 3.5D0,2.85D0,2.35D0,2.01D0,1.8D0,12*0.D0,.1D0,.8D0,2.05D0,3.31D0,
33955 & 3.5D0, 12*0.D0, .034D0,.2D0,.75D0,1.04D0,1.24D0 /
33957 DATA SKMPEL/ 0.D0, 35.D0, 22.D0, 25.D0, 17.D0, 9.D0, 9.5D0, 8.D0,
33958 & 7.D0, 6.5D0, 6.1D0, 5.D0, 4.8D0, 4.6D0, 4.45D0, 4.3D0, 4.2D0,
33959 & 0.D0, 8.D0, 3.5D0, 8.D0, 3.D0, 1.9D0, 1.7D0, 1.D0, .9D0, .8D0,
33960 & .75D0, .5D0, .42D0, .38D0, .34D0, .25D0, .2D0,
33961 & 0.D0, 3.D0, 3.2D0, 3.5D0, 1.5D0, 1.4D0, 1.1D0, .6D0, .5D0,
33962 & .35D0, .28D0, .25D0, .18D0, .12D0, .1D0, .08D0, .04D0,
33963 & 0.D0, 8.5D0, 2.4D0, 1.7D0, 1.3D0, 1.3D0, 1.1D0, .5D0,
33964 & .4D0, .4D0, .35D0, .3D0, .28D0, .2D0, .16D0, .13D0, .11D0,
33965 & 0.D0, 7.D0, 4.8D0, 1.4D0, 1.9D0, .9D0, .4D0, .2D0, .13D0,
33966 & .1D0, .08D0, .06D0, .04D0, .02D0, .015D0, .01D0, .01D0,
33967 & 0.D0, 5.5D0, 1.D0, .8D0, .75D0, .32D0, .2D0, .1D0, .09D0,
33968 & .08D0, .065D0, .05D0, .04D0, .022D0, .017D0, 2*.01D0/
33969 DATA SPIKP7 / 0.D0, .56D0, 1.46D0, 3.16D0, 2.01D0, 1.28D0, .74D0,
33970 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
33971 & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 4*0.D0,
33972 & 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, 1.57D0,
33973 & 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0, 3.03D0,
33974 & 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0,
33975 & .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, 2.8D0,
33976 & 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0,
33977 & .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
33978 & .45D0, .39D0, .22D0, .07D0, 0.D0, 7*0.D0, .34D0, 1.12D0, 1.12D0,
33979 & 1.01D0, .78D0, .45D0, .39D0, .22D0, .07D0, 0.D0, 6*0.D0, 1.71D0,
33980 & 4.26D0, 5.6D0, 5.57D0, 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0,
33981 & 2.25D0, 2.D0, 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
33982 & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, .22D0,
33983 & .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 10*0.D0, .22D0, .8D0,
33984 & .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, .3D0, .7D0,1.D0,
33985 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, 1.72D0, 2.69D0,
33986 & 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 9*0.D0, .11D0, 1.72D0,
33987 & 2.69D0, 3.92D0, 4.76D0, 5.1D0, 5.44D0, 5.3D0, 5*0.D0,9.2D0,4.7D0,
33988 & 1.9D0, 10*0.D0, 2.5D0, 15.D0, 21.5D0, 15.3D0, 3.D0, 1.5D0,
33991 DATA SKMNEL/0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
33992 & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0,
33993 & 0.D0, 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0,
33994 & 1.9D0, .9D0, .5D0, .3D0, .24D0, .2D0, .18D0, .1D0, .09D0,
33995 & 0.D0, 1.8D0, 2.D0, 1.1D0, .9D0, .5D0, .5D0, .4D0, .4D0,
33996 & .2D0, .1D0, .06D0, .05D0, .04D0, .03D0, .02D0, .02D0,
33997 & 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, .7D0, .65D0,
33998 & .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, .03D0/
33999 DATA SPIKP8/0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
34000 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
34001 & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,
34002 & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
34003 & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
34004 & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
34005 & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
34006 & 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, .45D0,
34007 & .39D0, .22D0, .07D0, 0.D0,
34008 & 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
34009 & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0,
34010 & 10*0.D0, .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0,
34011 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0,
34012 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0,
34013 & 9*0.D0, .11D0, 1.72D0, 2.69D0, 3.92D0, 4.76D0,
34014 & 5.10D0, 5.44D0, 5.3D0,
34015 & 4*0.D0, 0.00D0, 9.2D0, 4.7D0, 1.9D0, 9*0.D0/
34017 DATA SPIKP9/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
34018 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
34019 & 0.D0, 3.6D0, 1.7D0, 10*0.D0,
34020 & .0D0, 0.D0, 8.7D0, 17.7D0, 18.8D0, 15.9D0,
34021 & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
34022 & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
34023 & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
34024 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
34025 & 16.9D0, 16.5D0, 11.D0, 5.5D0, 3.5D0,
34026 & 10*0.D0, 4.3D0, 7.6D0, 9.D0,
34027 & 10*0.D0, 1.7D0, 2.6D0, 3.D0,
34028 & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
34029 & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
34030 & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
34031 & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/
34033 DATA SPIKP0/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
34034 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
34035 & 0.D0, 1.8D0, .2D0, 12*0.D0,
34036 & 3.2D0, 6.05D0, 9.9D0, 5.1D0,
34037 & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
34038 & 2*.0D0, 3.2D0, 6.05D0, 9.9D0, 5.1D0,
34039 & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
34040 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
34041 & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
34042 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
34043 & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
34044 & 10*0.D0, .7D0, 5.1D0, 8.D0,
34045 & 10*0.D0, .7D0, 5.1D0, 8.D0,
34046 & 10*.0D0, .3D0, 2.8D0, 4.7D0,
34047 & 10*.0D0, .3D0, 2.8D0, 4.7D0,
34048 & 7*0.D0, 1.2D0, 2.5D0, 3.5D0, 6.D0, 5.3D0, 2.9D0,
34049 & 7*0.D0, 1.7D0, 3.6D0, 5.4D0, 9.D0, 7.6D0, 4.2D0,
34050 & 5*0.D0, 7.7D0, 6.1D0, 2.9D0, 5*0.D0/
34053 DATA SPKPV/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
34054 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
34055 & 0.D0, 3.6D0, 1.7D0, 12*0.D0,
34056 & 8.7D0, 17.7D0, 18.8D0, 15.9D0,
34057 & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
34058 & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
34059 & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
34060 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0, 16.9D0, 16.5D0,
34061 & 11.D0, 5.5D0, 3.5D0,
34062 & 10*0.D0, 4.3D0, 7.6D0, 9.D0,
34063 & 10*0.D0, 1.7D0, 2.6D0, 3.D0,
34064 & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
34065 & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
34066 & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
34067 & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/
34068 **************** ap - p - data *
34069 DATA SAPPEL/ 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
34070 & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
34071 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0,
34072 & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
34073 & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
34074 & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
34075 & 0.D0, 55.D0, 50.D0, 25.D0, 15.D0, 15.D0, 14.D0, 12.D0,
34076 & 10.D0, 7.D0, 6.D0, 4.D0, 3.3D0, 2.8D0, 2.4D0, 2.D0, 1.8D0,
34077 & 1.55D0, 1.3D0, .95D0, .75D0,
34078 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
34079 & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
34080 & .01D0, .008D0, .006D0, .005D0/
34081 DATA SPIKPE/0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
34082 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
34083 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0,
34084 & 9*0.D0, 2.D0, 2.5D0, .2D0, 19*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0,
34085 & 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, .3D0, 1.4D0,
34086 & 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0,
34087 & .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0,
34088 & .3D0, 10*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0,
34089 & .6D0, .5D0, .4D0, .3D0, 9*0.D0, .6D0, 2.5D0, 5.D0, 5.2D0, 5.1D0,
34090 & 5.4D0, 5.8D0, 2.8D0, 2.1D0, 1.8D0, 1.6D0, 1.2D0, 13*0.D0, 1.3D0,
34091 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
34092 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
34093 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
34094 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 14*0.D0, .2D0,
34095 & .5D0, 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0,
34096 & 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0,
34097 & 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, 1.6D0,
34098 & 1.4D0, 1.1D0, .9D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0,
34099 & .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0,
34100 & 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0 /
34101 **************** ap - n - data *
34103 & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
34104 & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
34105 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0,
34106 & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0,
34107 & .85D0, 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0,
34108 & .14D0, .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
34109 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
34110 & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
34111 & .01D0, .008D0, .006D0, .005D0 /
34112 DATA SPIKPZ/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
34113 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
34114 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
34115 & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34116 & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
34117 & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
34118 & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
34119 & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34120 & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34121 & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34122 & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
34123 & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
34124 & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
34125 & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
34128 **************** an - p - data *
34131 & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, 50.D0,
34132 & 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
34133 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0, .05D0,
34134 & .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
34135 & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
34136 & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
34137 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, .25D0,
34138 & .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
34139 & .01D0, .008D0, .006D0, .005D0 /
34140 DATA SPIKPF/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
34141 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
34142 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
34143 & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34144 & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
34145 & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
34146 & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
34147 & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34148 & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34149 & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34150 & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
34151 & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
34152 & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
34153 & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
34154 **** ko - n - data *
34155 DATA SPKP15/0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, 7.D0,
34156 & 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
34157 & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 10*0.D0,
34158 & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
34159 & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
34160 & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
34161 & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
34162 & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0,
34163 & 1.4D0, 1.2D0, 1.05D0, .9D0, .66D0, .5D0,
34164 & 7*0.D0, .3D0, 1.D0, 1.D0, .9D0, .7D0, .4D0, .30D0, .2D0,
34165 & 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.20D0, 4.55D0,
34167 & 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, 1.6D0,
34168 & 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, 3.5D0,
34169 & 2.85D0, 2.35D0, 2.01D0, 1.8D0,
34170 & 12*0.D0, .1D0, .8D0, 2.05D0, 3.31D0, 3.5D0,
34171 & 12*0.D0, .034D0, .20D0, .75D0, 1.04D0, 1.24D0 /
34172 **** ako - p - data *
34173 DATA SPKP16/ 0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
34174 & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, 0.D0,
34175 & 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, 1.9D0, .9D0, .5D0,
34176 & .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, 0.D0, 1.8D0, 2.D0, 1.1D0,
34177 & .9D0, .5D0, .5D0, .4D0, .4D0, .2D0, .1D0, .06D0, .05D0, .04D0,
34178 & .03D0, .02D0, .02D0, 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0,
34179 & .7D0, .65D0, .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0,
34180 & .03D0, 0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
34181 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0,
34182 & 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0,
34183 & 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0,
34184 & 1.01D0, .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0,
34185 & 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0,
34186 & .5D0, .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
34187 & .45D0, .39D0, .22D0, .07D0, 7*0.D0, 1.71D0, 4.26D0, 5.6D0,5.57D0,
34188 & 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0,
34189 & .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0,
34190 & .3D0, .7D0, 1.D0, 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0,
34191 & 1.72D0, 2.69D0, 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 5*0.D0,
34192 & 9.2D0, 4.7D0, 1.9D0, 9*0.D0, .0D0,2.5D0,15.D0,
34193 & 21.5D0, 15.3D0, 3.D0, 1.5D0, 10*0.D0 /
34194 DATA NURELN/9, 12, 5*0, 10, 14, 3*0, 1, 3, 5, 7, 6*0, 2, 6, 16,
34195 & 5*0, 10, 13, 5*0, 11, 12, 3*0, 2, 4, 6, 8, 6*0, 3, 15, 7, 5*0 /
34196 *= end*block.blkdt3 *
34198 *$ CREATE DT_QEL_POL.FOR
34201 *===qel_pol============================================================*
34203 SUBROUTINE DT_QEL_POL(ENU,LTYP,P21,P22,P23,P24,P25)
34205 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34209 CALL DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
34214 *$ CREATE DT_GEN_QEL.FOR
34216 C==================================================================
34217 C Generation of a Quasi-Elastic neutrino scattering
34218 C==================================================================
34220 *===gen_qel============================================================*
34222 SUBROUTINE DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
34224 C...Generate a quasi-elastic neutrino/antineutrino
34225 C. Interaction on a nuclear target
34226 C. INPUT : LTYP = neutrino type (1,...,6)
34227 C. ENU (GeV) = neutrino energy
34228 C----------------------------------------------------
34230 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34233 PARAMETER ( LINP = 10 ,
34236 PARAMETER (MAXLND=4000)
34237 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
34239 * nuclear potential
34241 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
34242 & EBINDP(2),EBINDN(2),EPOT(2,210),
34243 & ETACOU(2),ICOUL,LFERMI
34245 * steering flags for qel neutrino scattering modules
34246 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
34247 **sr - removed (not needed)
34248 C COMMON /CBAD/ LBAD, NBAD
34249 C COMMON /CNUC/ XMN,XMN2,PFERMI,EFERMI,EBIND,EB2,C0
34252 DIMENSION PI(3),PO(3)
34257 C REAL*8 MN(2), ML0(6), ML, ML2, MI, MI2, MF, MF2
34258 DIMENSION DBETA(3),DBETB(3),AMN(2),AML0(6)
34259 DATA AMN /0.93827231D0, 0.93956563D0/
34260 DATA AML0 /2*0.51100D-03,2*0.105659D0, 2*1.777D0/
34263 C DATA PFERMI/0.22D0/
34264 CGB+...Binding Energy
34265 DATA EBIND/0.008D0/
34269 IF(ININU.EQ.1)NDSIG=0
34274 AML = AML0(LTYP) ! massa leptoni
34275 AML2 = AML**2 ! massa leptoni **2
34276 C...Particle labels (LUND)
34286 K0 = (LTYP-1)/2 ! 2
34288 KA = 12 + 2*K0 ! 16
34289 IS = -1 + 2*LTYP - 4*K1 ! -1 +10 -8 = 1
34293 LNU = 2 - LTYP + 2*K1 ! 2 - 5 + 2 = - 1
34294 IF (LNU .EQ. 2) THEN
34322 EFMAX = SQRT(PFERMI**2 + AMI2) -AMI ! max. Fermi Energy
34323 ENWELL = EFMAX + EBIND ! depth of nuclear potential well
34328 C...4-momentum initial lepton
34329 P(1,5) = 0. ! massa
34330 P(1,4) = ENU0 ! energia
34335 C PF = PFERMI*PYR(0)**(1./3.)
34336 c write(23,*) PYR(0)
34337 c write(*,*) 'Pfermi=',PF
34340 C IF(ntry.GT.2) WRITE(*,*) ntry,enu0,k2
34341 IF (NTRY .GT. 500) THEN
34343 WRITE (LOUT,1001) NBAD, ENU
34346 C CT = -1. + 2.*PYR(0)
34348 C ST = SQRT(1.-CT*CT)
34349 C F = 2.*3.1415926*PYR(0)
34352 C P(2,4) = SQRT(PF*PF + MI2) - EBIND ! energia
34353 C P(2,1) = PF*ST*COS(F) ! px
34354 C P(2,2) = PF*ST*SIN(F) ! py
34355 C P(2,3) = PF*CT ! pz
34356 C P(2,5) = SQRT(P(2,4)**2-PF*PF) ! massa
34362 beta1=-p(2,1)/p(2,4)
34363 beta2=-p(2,2)/p(2,4)
34364 beta3=-p(2,3)/p(2,4)
34366 C WRITE(6,*)' before transforming into target rest frame'
34368 CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
34370 C print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
34373 phi11=atan(p(1,2)/p(1,3))
34378 CALL DT_TESTROT(PI,Po,PHI11,1)
34380 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34386 phi12=atan(p(1,1)/p(1,3))
34391 CALL DT_TESTROT(Pi,Po,PHI12,2)
34393 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34402 C...Kinematical limits in Q**2
34403 c S = P(2,5)**2 + 2.*ENU*(P(2,4)-P(2,3)) ! ????
34404 S = P(2,5)**2 + 2.*ENU*P(2,5)
34405 SQS = SQRT(S) ! E centro massa
34406 IF (SQS .LT. (AML + AMF + 3.E-03)) GOTO 100
34407 ELF = (S-AMF2+AML2)/(2.*SQS) ! energia leptone finale p
34408 PSTAR = (S-P(2,5)**2)/(2.*SQS) ! p* neutrino nel c.m.
34409 PLF = SQRT(ELF**2-AML2) ! 3-momento leptone finale
34410 Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF) ! + o -
34411 Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF) ! according con cos(theta)
34412 IF (Q2MIN .LT. 0.) Q2MIN = 0. ! ??? non fisico
34415 DSIGMAX = DT_DSQEL_Q2 (LTYP,ENU, Q2MIN)
34416 200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
34417 DSIG = DT_DSQEL_Q2 (LTYP,ENU, Q2)
34418 IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200
34419 CALL DT_QGAUS(Q2MIN,Q2MAX,DSIGEV,ENU,LTYP)
34421 C WRITE(6,*)' Q2,Q2min,Q2MAX,DSIGEV',
34422 C &Q2,Q2min,Q2MAX,DSIGEV
34424 C...c.m. frame. Neutrino along z axis
34425 DETOT = (P(1,4)) + (P(2,4)) ! e totale
34426 DBETA(1) = ((P(1,1)) + (P(2,1)))/DETOT ! px1+px2/etot = beta_x
34427 DBETA(2) = ((P(1,2)) + (P(2,2)))/DETOT !
34428 DBETA(3) = ((P(1,3)) + (P(2,3)))/DETOT !
34431 C WRITE(*,*) 'Input values laboratory frame'
34434 CALL PYROBO(0,0,0.0D0,0.0D0,-DBETA(1),-DBETA(2),-DBETA(3))
34437 c STHETA = ULANGL(P(1,3),P(1,1))
34438 c write(*,*) 'stheta' ,stheta
34440 c CALL PYROBO (0,0,-STHETA,0.,0.D0,0.D0,0.D0)
34443 C WRITE(*,*) 'Output values cm frame'
34444 C...Kinematic in c.m. frame
34445 CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) ! cos(theta) cm
34446 STSTAR = SQRT(1.-CTSTAR**2)
34447 PHI = 6.28319*PYR(0) ! random phi tra 0 e 2*pi
34448 P(4,5) = AML ! massa leptone
34449 P(4,4) = ELF ! e leptone
34450 P(4,3) = PLF*CTSTAR ! px
34451 P(4,1) = PLF*STSTAR*COS(PHI) ! py
34452 P(4,2) = PLF*STSTAR*SIN(PHI) ! pz
34454 P(5,5) = AMF ! barione
34455 P(5,4) = (S+AMF2-AML2)/(2.*SQS)! e barione
34456 P(5,3) = -P(4,3) ! px
34457 P(5,1) = -P(4,1) ! py
34458 P(5,2) = -P(4,2) ! pz
34461 P(3,1) = P(1,1)-P(4,1)
34462 P(3,2) = P(1,2)-P(4,2)
34463 P(3,3) = P(1,3)-P(4,3)
34464 P(3,4) = P(1,4)-P(4,4)
34466 C...Transform back to laboratory frame
34467 C WRITE(*,*) 'before going back to nucl rest frame'
34468 c CALL PYROBO (0,0,STHETA,0.,0.D0,0.D0,0.D0)
34471 CALL PYROBO(0,0,0.0D0,0.0D0,DBETA(1),DBETA(2),DBETA(3))
34473 C WRITE(*,*) 'Now back in nucl rest frame'
34474 IF(LTYP.GE.3) CALL DT_PREPOLA(Q2,LTYP,ENU)
34476 c********************************************
34482 CALL DT_TESTROT(Pi,Po,PHI12,3)
34484 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34490 c********************************************
34496 CALL DT_TESTROT(Pi,Po,PHI11,4)
34498 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34505 c********************************************
34507 C WRITE(*,*) 'Now back in lab frame'
34509 CALL PYROBO(1,5,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
34512 C...test (on final momentum of nucleon) if Fermi-blocking
34514 ENUCL = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2 + P(5,5)**2)
34516 IF (ENUCL.LT. EFMAX) THEN
34517 IF(INIPRI.LT.10)THEN
34519 C WRITE(6,*)' qel: Pauli ENUCL.LT.EFMAX ', ENUCL,EFMAX
34520 C...the interaction is not possible due to Pauli-Blocking and
34521 C...it must be resampled
34524 ELSE IF (ENUCL.LT.ENWELL.and.ENUCL.GE.EFMAX) THEN
34525 IF(INIPRI.LT.10)THEN
34527 C WRITE(6,*)' qel: inside ENUCL.LT.ENWELL ', ENUCL,ENWELL
34529 C Reject (J:R) here all these events
34530 C are otherwise rejected in dpmjet
34532 C...the interaction is possible, but the nucleon remains inside
34533 C...the nucleus. The nucleus is therefore left excited.
34534 C...We treat this case as a nucleon with 0 kinetic energy.
34540 ELSE IF (ENUCL.GE.ENWELL) THEN
34541 C WRITE(6,*)' qel ENUCL.GE.ENWELL ',ENUCL,ENWELL
34542 C...the interaction is possible, the nucleon can exit the nucleus
34543 C...but the nuclear well depth must be subtracted. The nucleus could be
34544 C...left in an excited state.
34545 Pstart = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2)
34546 C P(5,4) = ENUCL-ENWELL + AMF
34547 Pnucl = SQRT(P(5,4)**2-AMF**2)
34548 C...The 3-momentum is scaled assuming that the direction remains
34550 P(5,1) = P(5,1) * Pnucl/Pstart
34551 P(5,2) = P(5,2) * Pnucl/Pstart
34552 P(5,3) = P(5,3) * Pnucl/Pstart
34553 C WRITE(6,*)' qel new P(5,4) ',P(5,4)
34556 DSIGSU=DSIGSU+DSIGEV
34566 IF(NEUDEC.EQ.1.OR.NEUDEC.EQ.2) THEN
34568 CALL PYROBO(6,8,0.0D0,0.0D0,DBETB(1),DBETB(2),DBETB(3))
34572 C PRINT*,' FINE EVENTO '
34576 1001 FORMAT(2X, 'DT_GEN_QEL : event rejected ', I5, G10.3)
34579 *$ CREATE DT_MASS_INI.FOR
34581 C====================================================================
34583 C====================================================================
34585 *===mass_ini===========================================================*
34587 SUBROUTINE DT_MASS_INI
34588 C...Initialize the kinematics for the quasi-elastic cross section
34590 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34593 * particle masses used in qel neutrino scattering modules
34594 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
34595 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
34596 & EMPROTSQ,EMNEUTSQ,EMNSQ
34598 EML(1) = 0.51100D-03 ! e-
34599 EML(2) = EML(1) ! e+
34600 EML(3) = 0.105659D0 ! mu-
34601 EML(4) = EML(3) ! mu+
34602 EML(5) = 1.7777D0 ! tau-
34603 EML(6) = EML(5) ! tau+
34604 EMPROT = 0.93827231D0 ! p
34605 EMNEUT = 0.93956563D0 ! n
34606 EMPROTSQ = EMPROT**2
34607 EMNEUTSQ = EMNEUT**2
34608 EMN = (EMPROT + EMNEUT)/2.
34612 EMN1(J0+1) = EMNEUT
34613 EMN1(J0+2) = EMPROT
34614 EMN2(J0+1) = EMPROT
34615 EMN2(J0+2) = EMNEUT
34618 EMLSQ(J) = EML(J)**2
34619 ETQE(J) = ((EMN2(J)+ EML(J))**2-EMN1(J)**2)/(2.*EMN1(J))
34624 *$ CREATE DT_DSQEL_Q2.FOR
34627 *===dsqel_q2===========================================================*
34629 DOUBLE PRECISION FUNCTION DT_DSQEL_Q2 (JTYP,ENU, Q2)
34631 C...differential cross section for Quasi-Elastic scattering
34632 C. nu + N -> l + N'
34633 C. From Llewellin Smith Phys.Rep. 3C, 261, (1971).
34635 C. INPUT : JTYP = 1,...,6 nu_e, ...., nubar_tau
34636 C. ENU (GeV) = Neutrino energy
34637 C. Q2 (GeV**2) = (Transfer momentum)**2
34639 C. OUTPUT : DSQEL_Q2 = differential cross section :
34640 C. dsigma/dq**2 (10**-38 cm+2/GeV**2)
34641 C------------------------------------------------------------------
34643 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34646 * particle masses used in qel neutrino scattering modules
34647 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
34648 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
34649 & EMPROTSQ,EMNEUTSQ,EMNSQ
34650 **sr - removed (not needed)
34651 C COMMON /CAXIAL/ FA0, AXIAL2
34655 DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
34656 DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
34657 DATA AXIAL2 /1.03D0/ ! to be checked
34661 GVE = 1.D0/ (1.D0 + Q2/0.84D0**2)**2 ! G_e(q**2)
34662 GVM = (1.D0+CSI)*GVE ! G_m (q**2)
34663 X = Q2/(EMN*EMN) ! emn=massa barione
34665 FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
34666 FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
34667 FA = FA0/(1.D0 + Q2/AXIAL2)**2
34671 RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp)
34672 A1 = (4.D0+X)*FFA - (4.D0-X)*FFV1 + X*FFV2*(1.D0-XA)+4*X*FV1*FV2
34673 A2 = -RM * ((FV1 + FV2)**2 + FFA)
34674 AA = (XA+0.25D0*RM)*(A1 + A2)
34675 BB = -X*FA*(FV1 + FV2)
34676 CC = 0.25D0*(FFA + FFV1 + XA*FFV2)
34677 SU = (4.D0*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
34678 DT_DSQEL_Q2 = C0*(AA + SS(JTYP)*BB*SU + CC*SU*SU) / (ENU*ENU) !
34679 IF(DT_DSQEL_Q2 .LT. 0.D0) DT_DSQEL_Q2 = 0.D0
34684 *$ CREATE DT_PREPOLA.FOR
34687 *===prepola============================================================*
34689 SUBROUTINE DT_PREPOLA(Q2,JTYP,ENU)
34691 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34694 c By G. Battistoni and E. Scapparone (sept. 1997)
34696 c Albright & Jarlskog, Nucl Phys B84 (1975) 467
34699 PARAMETER (MAXLND=4000)
34700 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
34702 COMMON /QNPOL/ POLARX(4),PMODUL
34704 * particle masses used in qel neutrino scattering modules
34705 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
34706 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
34707 & EMPROTSQ,EMNEUTSQ,EMNSQ
34709 * steering flags for qel neutrino scattering modules
34710 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
34711 **sr - removed (not needed)
34712 C COMMON /CAXIAL/ FA0, AXIAL2
34713 C COMMON /TAUTAU/Q(4,5),ETL,PXL,PYL,PZL,
34714 C & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN
34716 REAL*8 POL(4,4),BB2(3)
34718 C DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
34719 DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
34720 **sr uncommented since common block CAXIAL is now commented
34721 DATA AXIAL2 /1.03D0/ ! to be checked
34731 GVE = 1.D0/ (1.D0 + Q2/(0.84D+00)**2)**2 ! G_e(q**2)
34732 GVM = (1.D0+CSI)*GVE ! G_m (q**2)
34733 X = Q2/(EMN*EMN) ! emn=massa barione
34735 FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
34736 FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
34737 FA = FA0/(1.D0 + Q2/AXIAL2**2)**2
34741 FP=2.D0*FA*RMM/(MPI**2 + Q2)
34742 RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp)
34743 A1 = (4.D0+X)*FFA-(4.D0-X)*FFV1+X*FFV2*(1.D0-XA)+4.D0*X*FV1*FV2
34744 A2 = -RM * ((FV1 + FV2)**2 + FFA)
34745 AA = (XA+0.25D+00*RM)*(A1 + A2)
34746 BB = -X*FA*(FV1 + FV2)
34747 CC = 0.25D+00*(FFA + FFV1 + XA*FFV2)
34748 SU = (4.D+00*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
34750 OMEGA1=FFA+XA*(FFA+(FV1+FV2)**2 ) ! articolo di ll...-smith
34752 OMEGA3=2.D+00*FA*(FV1+FV2)
34753 OMEGA4P=(-(FV1+FV2)**2-(FA+2*FP)**2+(4.0D+00+
34756 OMEGA4=(OMEGA4P-OMEGA2+2*OMEGA5)/4.D+00
34757 WW1=2.D+00*OMEGA1*EMN**2
34758 WW2=2.D+00*OMEGA2*EMN**2
34759 WW3=2.D+00*OMEGA3*EMN**2
34760 WW4=2.D+00*OMEGA4*EMN**2
34761 WW5=2.D+00*OMEGA5*EMN**2
34764 BB2(I)=-P(4,I)/P(4,4)
34768 c WRITE(*,*) 'Prepola: ready to transform to lepton rest frame'
34771 CALL PYROBO(0,0,0.0D0,0.0D0,BB2(1),BB2(2),BB2(3))
34773 * NOW PARTICLES ARE IN THE SCATTERED LEPTON REST FRAME
34776 c WRITE(*,*) 'Prepola: now in lepton rest frame'
34780 FRAC=QM2*WW1 + (2.D+00*EE*(EE-U) - 0.5D+00*QM2)*WW2 - SS(JTYP)*
34781 + (0.5D+00/(RMM**2))*(2.D+00*RMM*EE*Q2 - U*QM2)*WW3 +
34782 + ((RML**2)/(2.D+00*FM2))*(QM2*WW4-2.D+00*RMM*EE*WW5) !<=FM2 inv di RMM!!
34784 FACTK=2.D+00*WW1 -WW2 -SS(JTYP)*(EE/RMM)*WW3 +((EE-U)/RMM)*WW5
34785 + - ((RML**2)/FM2)*WW4 !<=FM2 inv di RMM!!
34787 FACTP=2.D+00*EE/RMM*WW2 - (QM2/(2.D+00*RMM**2))*(SS(JTYP)*WW3+WW5)
34790 POL(4,I)=RML*SS(JTYP)*(FACTK*P(1,I)+FACTP*P(2,I))/FRAC
34796 PMODUL=PMODUL+POL(4,I)**2
34799 IF(JTYP.GT.4.AND.NEUDEC.GT.0) THEN
34800 IF(NEUDEC.EQ.1) THEN
34801 CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-2),POLARX(3),
34803 + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
34805 c Tau has decayed in muon
34808 IF(NEUDEC.EQ.2) THEN
34809 CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-4),POLARX(3),
34811 + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
34813 c Tau has decayed in electron
34821 c fill common for muon(electron)
34829 IF(NEUDEC.EQ.1) THEN
34832 ELSEIF(NEUDEC.EQ.2) THEN
34836 ELSEIF(JTYP.EQ.6) THEN
34837 IF(NEUDEC.EQ.1) THEN
34839 ELSEIF(NEUDEC.EQ.2) THEN
34847 c fill common for tau_(anti)neutrino
34857 ELSEIF(JTYP.EQ.6) THEN
34864 c Fill common for muon(electron)_(anti)neutrino
34873 IF(NEUDEC.EQ.1) THEN
34875 ELSEIF(NEUDEC.EQ.2) THEN
34878 ELSEIF(JTYP.EQ.6) THEN
34879 IF(NEUDEC.EQ.1) THEN
34881 ELSEIF(NEUDEC.EQ.2) THEN
34892 c IF(PMODUL.GE.1.D+00) THEN
34893 c WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
34894 c write(*,*) pmodul
34896 c POL(4,I)=POL(4,I)/PMODUL
34897 c POLARX(I)=POL(4,I)
34901 c PMODUL=PMODUL+POL(4,I)**2
34903 c WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
34907 c WRITE(*,*) 'PMODUL = ',PMODUL
34911 c WRITE(*,*) 'prepola: Now back to nucl rest frame'
34913 CALL PYROBO(1,5,0.0D0,0.0D0,-BB2(1),-BB2(2),-BB2(3))
34915 XDC = V(4,1)+V(4,5)*P(4,1)/P(4,5)
34916 YDC = V(4,2)+V(4,5)*P(4,2)/P(4,5)
34917 ZDC = V(4,3)+V(4,5)*P(4,3)/P(4,5)
34927 *$ CREATE DT_TESTROT.FOR
34930 *===testrot============================================================*
34932 SUBROUTINE DT_TESTROT(PI,PO,PHI,MODE)
34934 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34937 DIMENSION ROT(3,3),PI(3),PO(3)
34939 IF (MODE.EQ.1) THEN
34944 ROT(2,2) = COS(PHI)
34945 ROT(2,3) = -SIN(PHI)
34947 ROT(3,2) = SIN(PHI)
34948 ROT(3,3) = COS(PHI)
34949 ELSEIF (MODE.EQ.2) THEN
34953 ROT(2,1) = COS(PHI)
34955 ROT(2,3) = -SIN(PHI)
34956 ROT(3,1) = SIN(PHI)
34958 ROT(3,3) = COS(PHI)
34959 ELSEIF (MODE.EQ.3) THEN
34963 ROT(1,2) = COS(PHI)
34965 ROT(3,2) = -SIN(PHI)
34966 ROT(1,3) = SIN(PHI)
34968 ROT(3,3) = COS(PHI)
34969 ELSEIF (MODE.EQ.4) THEN
34974 ROT(2,2) = COS(PHI)
34975 ROT(3,2) = -SIN(PHI)
34977 ROT(2,3) = SIN(PHI)
34978 ROT(3,3) = COS(PHI)
34980 STOP ' TESTROT: mode not supported!'
34983 PO(J) = ROT(J,1)*PI(1)+ROT(J,2)*PI(2)+ROT(J,3)*PI(3)
34989 *$ CREATE DT_LEPDCYP.FOR
34992 *===lepdcyp============================================================*
34994 SUBROUTINE DT_LEPDCYP(AMA,AML,POL,ETL,PXL,PYL,PZL,
34995 & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
34997 C-----------------------------------------------------------------
34999 C Author :- G. Battistoni 10-NOV-1995
35001 C=================================================================
35003 C Purpose : performs decay of polarized lepton in
35004 C its rest frame: a => b + l + anti-nu
35005 C (Example: mu- => nu-mu + e- + anti-nu-e)
35006 C Polarization is assumed along Z-axis
35008 C 1) b AND anti-nu ARE ASSUMED TO BE NEUTRINOS
35009 C OF NEGLIGIBLE MASS
35010 C 2) RADIATIVE CORRECTIONS ARE NOT CONSIDERED
35013 C Method : modifies phase space distribution obtained
35014 C by routine EXPLOD using a rejection against the
35015 C matrix element for unpolarized lepton decay
35017 C Inputs : Mass of a : AMA
35020 C (Example: fully polar. mu- decay: AMA=AMMUON, AML=AMELCT,
35023 C Outputs : kinematic variables in the rest frame of decaying lepton
35024 C ETL,PXL,PYL,PZL 4-moment of l
35025 C ETB,PXB,PYB,PZB 4-moment of b
35026 C ETN,PXN,PYN,PZN 4-moment of anti-nu
35028 C============================================================
35032 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35035 PARAMETER ( LINP = 10 ,
35039 PARAMETER ( KALGNM = 2 )
35040 PARAMETER ( ANGLGB = 5.0D-16 )
35041 PARAMETER ( ANGLSQ = 2.5D-31 )
35042 PARAMETER ( AXCSSV = 0.2D+16 )
35043 PARAMETER ( ANDRFL = 1.0D-38 )
35044 PARAMETER ( AVRFLW = 1.0D+38 )
35045 PARAMETER ( AINFNT = 1.0D+30 )
35046 PARAMETER ( AZRZRZ = 1.0D-30 )
35047 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
35048 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
35049 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
35050 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
35051 PARAMETER ( CSNNRM = 2.0D-15 )
35052 PARAMETER ( DMXTRN = 1.0D+08 )
35053 PARAMETER ( ZERZER = 0.D+00 )
35054 PARAMETER ( ONEONE = 1.D+00 )
35055 PARAMETER ( TWOTWO = 2.D+00 )
35056 PARAMETER ( THRTHR = 3.D+00 )
35057 PARAMETER ( FOUFOU = 4.D+00 )
35058 PARAMETER ( FIVFIV = 5.D+00 )
35059 PARAMETER ( SIXSIX = 6.D+00 )
35060 PARAMETER ( SEVSEV = 7.D+00 )
35061 PARAMETER ( EIGEIG = 8.D+00 )
35062 PARAMETER ( ANINEN = 9.D+00 )
35063 PARAMETER ( TENTEN = 10.D+00 )
35064 PARAMETER ( HLFHLF = 0.5D+00 )
35065 PARAMETER ( ONETHI = ONEONE / THRTHR )
35066 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
35067 PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
35068 PARAMETER ( ENEPER = 2.7182818284590452354 D+00 )
35069 PARAMETER ( SQRENT = 1.6487212707001281468 D+00 )
35070 PARAMETER ( CLIGHT = 2.99792458 D+10 )
35071 PARAMETER ( AVOGAD = 6.0221367 D+23 )
35072 PARAMETER ( AMELGR = 9.1093897 D-28 )
35073 PARAMETER ( PLCKBR = 1.05457266 D-27 )
35074 PARAMETER ( ELCCGS = 4.8032068 D-10 )
35075 PARAMETER ( ELCMKS = 1.60217733 D-19 )
35076 PARAMETER ( AMUGRM = 1.6605402 D-24 )
35077 PARAMETER ( AMMUMU = 0.113428913 D+00 )
35078 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
35079 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
35080 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
35081 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
35082 PARAMETER ( PLABRC = 0.197327053 D+00 )
35083 PARAMETER ( AMELCT = 0.51099906 D-03 )
35084 PARAMETER ( AMUGEV = 0.93149432 D+00 )
35085 PARAMETER ( AMMUON = 0.105658389 D+00 )
35086 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
35087 PARAMETER ( GEVMEV = 1.0 D+03 )
35088 PARAMETER ( EMVGEV = 1.0 D-03 )
35089 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
35090 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
35091 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
35093 C variables for EXPLOD
35095 PARAMETER ( KPMX = 10 )
35096 DIMENSION AMEXPL (KPMX), PXEXPL (KPMX), PYEXPL (KPMX),
35097 & PZEXPL (KPMX), ETEXPL (KPMX)
35101 **sr - removed (not needed)
35102 C COMMON /GBATNU/ ELERAT,NTRY
35105 C Initializes test variables
35110 C Maximum value for matrix element
35112 ELEMAX = ( AMA**2 + AML**2 )**2 / AMA**2 * ( AMA**2 - AML**2 +
35113 & SQRT( AMA**4 + AML**4 - 3.D+00 * AMA**2 * AML**2 ) )
35114 C + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
35115 C Inputs for EXPLOD
35116 C part. no. 1 is l (e- in mu- decay)
35117 C part. no. 2 is b (nu-mu in mu- decay)
35118 C part. no. 3 is anti-nu (anti-nu-e in mu- decay)
35119 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
35126 C phase space distribution
35131 CALL EXPLOD ( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
35135 C Calculates matrix element:
35136 C 64*GF**2{[P(a)-ama*S(a)]*P(anti-nu)}{P(l)*P(b)}
35137 C Here CTH is the cosine of the angle between anti-nu and Z axis
35139 CTH = PZEXPL(3) / SQRT ( PXEXPL(3)**2 + PYEXPL(3)**2 +
35141 PROD1 = ETEXPL(3) * AMA * (1.D+00 - POL * CTH)
35142 PROD2 = ETEXPL(1) * ETEXPL(2) - PXEXPL(1)*PXEXPL(2) -
35143 & PYEXPL(1)*PYEXPL(2) - PZEXPL(1)*PZEXPL(2)
35144 ELEMAT = 16.D+00 * PROD1 * PROD2
35145 IF(ELEMAT.GT.ELEMAX) THEN
35146 WRITE(LOUT,*) 'Problems in LEPDCY',ELEMAX,ELEMAT
35150 C Here performs the rejection
35152 TEST = DT_RNDM(ETOTEX) * ELEMAX
35153 IF ( TEST .GT. ELEMAT ) GO TO 100
35155 C final assignment of variables
35157 ELERAT = ELEMAT/ELEMAX
35173 *$ CREATE DT_GEN_DELTA.FOR
35175 C==================================================================
35176 C. Generation of Delta resonance events
35177 C==================================================================
35179 *===gen_delta==========================================================*
35181 SUBROUTINE DT_GEN_DELTA(ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25)
35183 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35186 PARAMETER ( LINP = 10 ,
35190 C...Generate a Delta-production neutrino/antineutrino
35191 C. CC-interaction on a nucleon
35193 C. INPUT ENU (GeV) = Neutrino Energy
35194 C. LLEP = neutrino type
35195 C. LTARG = nucleon target type 1=p, 2=n.
35196 C. JINT = 1:CC, 2::NC
35198 C. OUTPUT PPL(4) 4-monentum of final lepton
35199 C----------------------------------------------------
35200 PARAMETER (MAXLND=4000)
35201 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
35203 **sr - removed (not needed)
35204 C COMMON /CBAD/ LBAD, NBAD
35207 DIMENSION PI(3),PO(3)
35208 C REAL*4 AMD0, AMD, AMN(2), AML0(6), AML, AML2, AMDMIN
35209 DIMENSION AML0(6),AMN(2)
35210 DATA AMD0 /1.231/, GAMD /0.12/, DELD/0.169/, AMDMIN/1.084/
35211 DATA AMN /0.93827231, 0.93956563/
35212 DATA AML0 /2*0.51100E-03,2*0.105659, 2*1.777/
35214 c WRITE(6,*)' GEN_DEL',ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25
35216 C...Final lepton mass
35217 IF (JINT.EQ.1) THEN
35224 C...Particle labels (LUND)
35232 IF (LTARG .EQ. 1) THEN
35240 IS = -1 + 2*LLEP - 4*K1
35241 LNU = 2 - LLEP + 2*K1
35245 IF (JINT .EQ. 1) THEN ! CC interactions
35249 IF (LTARG .EQ. 1) THEN
35255 IF (LTARG .EQ. 1) THEN
35262 K(3,2) = 23 ! NC (Z0) interactions
35264 **sr 7.5.00: swop Delta's (bug), Delta+ for proton (LTARG=1),
35265 * Delta0 for neutron (LTARG=2)
35266 C IF (LTARG .EQ. 1) THEN
35271 IF (LTARG .EQ. 1) THEN
35279 C...4-momentum initial lepton
35285 C...4-momentum initial nucleon
35286 P(2,5) = AMN(LTARG)
35297 beta1=-p(2,1)/p(2,4)
35298 beta2=-p(2,2)/p(2,4)
35299 beta3=-p(2,3)/p(2,4)
35302 CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
35304 C print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
35306 phi11=atan(p(1,2)/p(1,3))
35311 CALL DT_TESTROT(PI,Po,PHI11,1)
35313 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35318 phi12=atan(p(1,1)/p(1,3))
35323 CALL DT_TESTROT(Pi,Po,PHI12,2)
35325 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35333 C...Generate the Mass of the Delta
35336 AMD=AMD0+0.5*GAMD*TAN((2.*R-1.)*ATAN(2.*DELD/GAMD))
35338 IF (NTRY .GT. 1000) THEN
35340 WRITE (LOUT,1001) NBAD, ENUU,AMD,AMDMIN,AMD0,GAMD,ET
35343 IF (AMD .LT. AMDMIN) GOTO 100
35344 ET = ((AMD+AML)**2 - AMN(LTARG)**2)/(2.*AMN(LTARG))
35345 IF (ENUU .LT. ET) GOTO 100
35347 C...Kinematical limits in Q**2
35348 S = AMN(LTARG)**2 + 2.*AMN(LTARG)*ENUU
35350 PSTAR = (S - AMN(LTARG)**2)/(2.*SQS)
35351 ELF = (S - AMD**2 + AML2)/(2.*SQS)
35352 PLF = SQRT(ELF**2 - AML2)
35353 Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)
35354 Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)
35355 IF (Q2MIN .LT. 0.) Q2MIN = 0.
35357 DSIGMAX = DT_DSIGMA_DELTA(LNU,-Q2MIN, S, AML, AMD)
35358 200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
35359 DSIG = DT_DSIGMA_DELTA(LNU,-Q2, S, AML, AMD)
35360 IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200
35362 C...Generate the kinematics of the final particles
35363 EISTAR = (S + AMN(LTARG)**2)/(2.*SQS)
35364 GAM = EISTAR/AMN(LTARG)
35366 CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF)
35367 EL = GAM*(ELF + BET*PLF*CTSTAR)
35368 PLZ = GAM*(PLF*CTSTAR + BET*ELF)
35369 PL = SQRT(EL**2 - AML2)
35370 PLT = SQRT(MAX(1.D-06,(PL*PL - PLZ*PLZ)))
35371 PHI = 6.28319*PYR(0)
35372 P(4,1) = PLT*COS(PHI)
35373 P(4,2) = PLT*SIN(PHI)
35378 C...4-momentum of Delta
35381 P(5,3) = ENUU-P(4,3)
35382 P(5,4) = ENUU+AMN(LTARG)-P(4,4)
35385 C...4-momentum of intermediate boson
35387 P(3,4) = P(1,4)-P(4,4)
35388 P(3,1) = P(1,1)-P(4,1)
35389 P(3,2) = P(1,2)-P(4,2)
35390 P(3,3) = P(1,3)-P(4,3)
35397 CALL DT_TESTROT(Pi,Po,PHI12,3)
35399 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35406 c********************************************
35412 CALL DT_TESTROT(Pi,Po,PHI11,4)
35414 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35420 c********************************************
35421 C transform back into Lab.
35423 CALL PYROBO(0,0,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
35425 C WRITE(6,*)' Lab fram ( fermi incl.) '
35430 1001 FORMAT(2X, 'DT_GEN_DELTA : event rejected ', I5, 6G10.3)
35433 *$ CREATE DT_DSIGMA_DELTA.FOR
35434 *COPY DT_DSIGMA_DELTA
35436 *===dsigma_delta=======================================================*
35438 DOUBLE PRECISION FUNCTION DT_DSIGMA_DELTA (LNU, QQ, S, AML, MD)
35440 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35443 C...Reaction nu + N -> lepton + Delta
35444 C. returns the cross section
35446 C. INPUT LNU = 1, 2 (neutrino-antineutrino)
35447 C. QQ = t (always negative) GeV**2
35448 C. S = (c.m energy)**2 GeV**2
35449 C. OUTPUT = 10**-38 cm+2/GeV**2
35450 C-----------------------------------------------------
35451 REAL*8 MN, MN2, MN4, MD,MD2, MD4
35453 DATA PI /3.1415926/
35455 GF = (1.1664 * 1.97)
35463 VQ = (MN2 - MD2 - QQ)/2.
35464 VPI = (MN2 + MD2 - QQ)/2.
35465 VK = (S + QQ - MN2 - AML2)/2.
35467 QK = (AML2 - QQ)/2.
35468 PIQ = (QQ + MN2 - MD2)/2.
35470 C3V = 2.07*SQRT(EXP(-6.3*Q)*(1.+9*Q))
35471 C3 = SQRT(3.)*C3V/MN
35472 C4 = -C3/MD ! attenzione al segno
35473 C5A = 1.18/(1.-QQ/0.4225)**2
35478 IF (LNU .EQ. 1) THEN
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
35503 ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
35504 . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
35505 . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
35506 . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
35507 ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
35508 . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
35509 . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
35510 . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
35511 . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
35512 . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ+
35513 . 4.*MN*C3*C5A*MD2*VK*QQ-4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
35514 . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
35515 . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
35516 . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
35517 . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK+MD*
35518 . C3*C5A*MD2*PIK*QQ-MD*C3*C5A*MD2*QK*PIQ+3.*MD*C3*C5A
35519 . *VK*VPI*QQ-MD*C3*C5A*VK*VQ*PIQ-3.*MD*C3*C5A*VPI*VQ*
35520 . QK+MD*C3*C5A*VQ**2*PIK-C4*C5A*MD2*VK*VPI*QQ-C4*C5A*
35521 . MD2*VK*VQ*PIQ+C4*C5A*MD2*VPI*VQ*QK+C4*C5A*MD2*VQ**2
35522 . *PIK+C4*C5A*MD4*PIK*QQ-C4*C5A*MD4*QK*PIQ-2.*MD2*VK
35523 . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
35524 . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
35525 . *C42-2.*MD2*VPI*QK**2*C32+ANS3
35529 P1CM = (S-MN2)/(2.*SQRT(S))
35530 DT_DSIGMA_DELTA = GF2/2. * ANS/(64.*PI*S*P1CM**2)
35535 *$ CREATE DT_QGAUS.FOR
35538 *===qgaus==============================================================*
35540 SUBROUTINE DT_QGAUS(A,B,SS,ENU,LTYP)
35542 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35545 DIMENSION X(5),W(5)
35546 DATA X/.1488743389D0,.4333953941D0,
35547 & .6794095682D0,.8650633666D0,.9739065285D0
35549 DATA W/.2955242247D0,.2692667193D0,
35550 & .2190863625D0,.1494513491D0,.0666713443D0
35557 SS=SS+W(J)*(DT_DSQEL_Q2(LTYP,ENU,XM+DX)+
35558 & DT_DSQEL_Q2(LTYP,ENU,XM-DX))
35564 *$ CREATE DT_DIQBRK.FOR
35567 *===diqbrk=============================================================*
35569 SUBROUTINE DT_DIQBRK
35571 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35576 PARAMETER (NMXHKK=200000)
35578 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
35579 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
35580 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
35582 * extended event history
35583 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
35584 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
35588 COMMON /DTEVNO/ NEVENT,ICASCA
35590 C IF(DT_RNDM(VV).LE.0.5D0)THEN
35591 C CALL GSQBS1(NHKK)
35592 C CALL GSQBS2(NHKK)
35593 C CALL USQBS1(NHKK)
35594 C CALL USQBS2(NHKK)
35595 C CALL GSABS1(NHKK)
35596 C CALL GSABS2(NHKK)
35597 C CALL USABS1(NHKK)
35598 C CALL USABS2(NHKK)
35600 C CALL GSQBS2(NHKK)
35601 C CALL GSQBS1(NHKK)
35602 C CALL USQBS2(NHKK)
35603 C CALL USQBS1(NHKK)
35604 C CALL GSABS2(NHKK)
35605 C CALL GSABS1(NHKK)
35606 C CALL USABS2(NHKK)
35607 C CALL USABS1(NHKK)
35610 IF(DT_RNDM(VV).LE.0.5D0) THEN
35633 *$ CREATE MUSQBS2.FOR
35637 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
35638 SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35639 * IP1,IP21,IP22,IPP1,IPP2,IPIP,ISQ,IGCOUN)
35641 C USQBS-2 diagram (split target diquark)
35643 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35646 PARAMETER ( LINP = 10 ,
35652 PARAMETER (NMXHKK=200000)
35654 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
35655 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
35656 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
35658 * extended event history
35659 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
35660 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
35663 * Lorentz-parameters of the current interaction
35664 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
35665 & UMO,PPCM,EPROJ,PPROJ
35667 * diquark-breaking mechanism
35668 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
35671 PARAMETER (NTMHKK= 300)
35672 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
35673 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
35676 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
35679 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
35680 COMMON /EVFLAG/ NUMEV
35682 C USQBS-2 diagram (split target diquark)
35685 C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
35686 C Input chain 2(NC2) sea-antiquark(NC2P)-sea-quark(NC2T)
35688 C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
35689 C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
35691 C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
35692 C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
35693 C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
35696 C Put new chains into COMMON /HKKTMP/
35701 C WRITE(LOUT,*)'MUSQBS2: IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
35705 C IF(NUMEV.EQ.-324)THEN
35706 C WRITE(LOUT,*)' MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
35707 C * 'IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN)',
35708 C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35709 C * IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN
35714 C determine x-values of NC1T diquark
35715 XDIQT=PHKK(4,NC1T)*2.D0/UMO
35716 XVQP=PHKK(4,NC1P)*2.D0/UMO
35718 C determine x-values of sea quark pair
35724 IF(ICOU.GE.500)THEN
35727 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 2234 ICOU. GT.500'
35731 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS2 call XSEAPA: UMO,XDIQT,XVQP ',
35736 C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
35737 IF (IPIP.EQ.1) THEN
35738 XQMAX = XDIQT/2.0D0
35739 XAQMAX = 2.D0*XVQP/3.0D0
35741 XQMAX = 2.D0*XVQP/3.0D0
35742 XAQMAX = XDIQT/2.0D0
35744 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
35746 C write(*,*) 'MUSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
35749 & WRITE(LOUT,*)'MUSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
35752 & WRITE(LOUT,*)'MUSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
35757 IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
35758 ELSEIF(IPIP.EQ.2)THEN
35759 IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
35762 WRITE(LOUT,'(A,4E12.4)')' MUSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
35763 & XDIQT,XVQP,XSQ,XSAQ
35766 C subtract xsq,xsaq from NC1T diquark and NC1P quark
35772 ELSEIF(IPIP.EQ.2)THEN
35777 & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
35779 C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
35784 IF(IVTHR.EQ.10)THEN
35787 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 3466 reject IVTHR 10'
35792 XVTHR=XVTHRO/(201-IVTHR)
35795 IF(XVTHR.GT.0.66D0*XDIQT)THEN
35798 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 380 XVTHR large',
35803 IF(DT_RNDM(V).LT.0.5D0)THEN
35804 XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
35807 XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
35811 WRITE(LOUT,'(A,2E12.4)')' MUSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
35814 C Prepare 4 momenta of new chains and chain ends
35816 C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
35817 C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
35820 C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
35821 C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
35822 C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
35824 C SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35825 C * IP1,IP21,IP22,IPP1,IPP2)
35832 ELSEIF(IPIP.EQ.2)THEN
35842 JDAHKT(1,1)=3+IIGLU1
35844 C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
35845 PHKT(1,1) =PHKK(1,NC2P)
35846 PHKT(2,1) =PHKK(2,NC2P)
35847 PHKT(3,1) =PHKK(3,NC2P)
35848 PHKT(4,1) =PHKK(4,NC2P)
35849 C PHKT(5,1) =PHKK(5,NC2P)
35850 XMIST =(PHKT(4,1)**2-
35851 * PHKT(3,1)**2-PHKT(2,1)**2-
35853 IF(XMIST.GT.0.D0)THEN
35854 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
35857 C WRITE(LOUT,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
35860 VHKT(1,1) =VHKK(1,NC2P)
35861 VHKT(2,1) =VHKK(2,NC2P)
35862 VHKT(3,1) =VHKK(3,NC2P)
35863 VHKT(4,1) =VHKK(4,NC2P)
35864 WHKT(1,1) =WHKK(1,NC2P)
35865 WHKT(2,1) =WHKK(2,NC2P)
35866 WHKT(3,1) =WHKK(3,NC2P)
35867 WHKT(4,1) =WHKK(4,NC2P)
35868 C Add here IIGLU1 gluons to this chaina
35873 IF(IIGLU1.GE.1)THEN
35875 DO 61 IIG=2,2+IIGLU1-1
35877 IDHKT(IIG) =IDHKK(KKG)
35881 JDAHKT(1,IIG)=3+IIGLU1
35883 PHKT(1,IIG)=PHKK(1,KKG)
35884 PG1=PG1+ PHKT(1,IIG)
35885 PHKT(2,IIG)=PHKK(2,KKG)
35886 PG2=PG2+ PHKT(2,IIG)
35887 PHKT(3,IIG)=PHKK(3,KKG)
35888 PG3=PG3+ PHKT(3,IIG)
35889 PHKT(4,IIG)=PHKK(4,KKG)
35890 PG4=PG4+ PHKT(4,IIG)
35891 PHKT(5,IIG)=PHKK(5,KKG)
35892 VHKT(1,IIG) =VHKK(1,KKG)
35893 VHKT(2,IIG) =VHKK(2,KKG)
35894 VHKT(3,IIG) =VHKK(3,KKG)
35895 VHKT(4,IIG) =VHKK(4,KKG)
35896 WHKT(1,IIG) =WHKK(1,KKG)
35897 WHKT(2,IIG) =WHKK(2,KKG)
35898 WHKT(3,IIG) =WHKK(3,KKG)
35899 WHKT(4,IIG) =WHKK(4,KKG)
35902 IDHKT(2+IIGLU1) =IP21
35903 ISTHKT(2+IIGLU1) =952
35904 JMOHKT(1,2+IIGLU1)=NC1T
35905 JMOHKT(2,2+IIGLU1)=0
35906 JDAHKT(1,2+IIGLU1)=3+IIGLU1
35907 JDAHKT(2,2+IIGLU1)=0
35908 PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
35909 PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
35910 PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
35911 PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
35912 C PHKT(5,2) =PHKK(5,NC1T)
35913 XMIST =(PHKT(4,2+IIGLU1)**2-
35914 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
35915 *PHKT(1,2+IIGLU1)**2)
35916 IF(XMIST.GT.0.D0)THEN
35917 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
35918 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
35919 *PHKT(1,2+IIGLU1)**2)
35921 C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
35922 PHKT(5,5+IIGLU1)=0.D0
35924 VHKT(1,2+IIGLU1) =VHKK(1,NC1T)
35925 VHKT(2,2+IIGLU1) =VHKK(2,NC1T)
35926 VHKT(3,2+IIGLU1) =VHKK(3,NC1T)
35927 VHKT(4,2+IIGLU1) =VHKK(4,NC1T)
35928 WHKT(1,2+IIGLU1) =WHKK(1,NC1T)
35929 WHKT(2,2+IIGLU1) =WHKK(2,NC1T)
35930 WHKT(3,2+IIGLU1) =WHKK(3,NC1T)
35931 WHKT(4,2+IIGLU1) =WHKK(4,NC1T)
35932 IDHKT(3+IIGLU1) =88888
35933 ISTHKT(3+IIGLU1) =95
35934 JMOHKT(1,3+IIGLU1)=1
35935 JMOHKT(2,3+IIGLU1)=2+IIGLU1
35936 JDAHKT(1,3+IIGLU1)=0
35937 JDAHKT(2,3+IIGLU1)=0
35938 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
35939 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
35940 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
35941 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
35943 * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
35944 * -PHKT(3,3+IIGLU1)**2)
35945 IF(XMIST.GT.0.D0)THEN
35947 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
35948 * -PHKT(3,3+IIGLU1)**2)
35950 C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
35951 PHKT(5,5+IIGLU1)=0.D0
35954 C IF(NUMEV.EQ.-324)THEN
35955 C WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
35957 C *JDAHKT(2,1),(PHKT(III,1),III=1,5)
35958 DO 71 IIG=2,2+IIGLU1-1
35959 C WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
35960 C & JMOHKT(1,IIG),JMOHKT(2,IIG),
35962 C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
35964 C WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
35965 C * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
35966 C *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
35967 C WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
35968 C * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
35969 C *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
35973 IF(IPP1.LE.-3.OR.IP21.GE.3)CHAMAL=CHAM3
35974 ELSEIF(IPIP.EQ.2)THEN
35975 IF(IPP1.GE.3.OR.IP21.LE.-3)CHAMAL=CHAM3
35977 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
35981 C WRITE(LOUT,*)' MUSQBS1 jump back from chain 3'
35984 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
35985 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
35986 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
35987 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
35988 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
35989 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
35990 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
35991 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
35993 IDHKT(4+IIGLU1) =-(ISAQ1-6)
35994 ELSEIF(IPIP.EQ.2)THEN
35995 IDHKT(4+IIGLU1) =ISAQ1
35997 ISTHKT(4+IIGLU1) =951
35998 JMOHKT(1,4+IIGLU1)=NC1P
35999 JMOHKT(2,4+IIGLU1)=0
36000 JDAHKT(1,4+IIGLU1)=6+IIGLU1
36001 JDAHKT(2,4+IIGLU1)=0
36002 C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36003 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
36004 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
36005 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
36006 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
36007 C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
36008 XMIST =(PHKT(4,4+IIGLU1)**2-
36009 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
36010 *PHKT(1,4+IIGLU1)**2)
36011 IF(XMIST.GT.0.D0)THEN
36012 PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2-
36013 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
36014 *PHKT(1,4+IIGLU1)**2)
36016 C WRITE(LOUT,*)'MUSQBS2 parton 4 mass square LT.0 ',XMIST
36017 PHKT(5,4+IIGLU1)=0.D0
36019 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
36020 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
36021 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
36022 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
36023 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
36024 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
36025 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
36026 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
36027 IDHKT(5+IIGLU1) =IP22
36028 ISTHKT(5+IIGLU1) =952
36029 JMOHKT(1,5+IIGLU1)=NC1T
36030 JMOHKT(2,5+IIGLU1)=0
36031 JDAHKT(1,5+IIGLU1)=6+IIGLU1
36032 JDAHKT(2,5+IIGLU1)=0
36033 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
36034 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
36035 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
36036 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
36037 C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
36038 XMIST =(PHKT(4,5+IIGLU1)**2-
36039 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36040 *PHKT(1,5+IIGLU1)**2)
36041 IF(XMIST.GT.0.D0)THEN
36042 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
36043 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36044 *PHKT(1,5+IIGLU1)**2)
36046 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36047 PHKT(5,5+IIGLU1)=0.D0
36049 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
36050 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
36051 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
36052 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
36053 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
36054 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
36055 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
36056 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
36057 IDHKT(6+IIGLU1) =88888
36058 ISTHKT(6+IIGLU1) =95
36059 JMOHKT(1,6+IIGLU1)=4+IIGLU1
36060 JMOHKT(2,6+IIGLU1)=5+IIGLU1
36061 JDAHKT(1,6+IIGLU1)=0
36062 JDAHKT(2,6+IIGLU1)=0
36063 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
36064 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
36065 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
36066 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
36068 * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
36069 * -PHKT(3,6+IIGLU1)**2)
36070 IF(XMIST.GT.0.D0)THEN
36072 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
36073 * -PHKT(3,6+IIGLU1)**2)
36075 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36076 PHKT(5,5+IIGLU1)=0.D0
36078 C IF(IPIP.GE.2)THEN
36079 C IF(NUMEV.EQ.-324)THEN
36080 C WRITE(6,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
36081 C * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
36082 C *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
36083 C WRITE(6,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
36084 C * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
36085 C *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
36086 C WRITE(6,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
36087 C * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
36088 C *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
36092 IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
36093 ELSEIF(IPIP.EQ.2)THEN
36094 IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
36096 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
36100 C WRITE(6,*)' MUSQBS1 jump back from chain 6',
36101 C * CHAMAL,PHKT(5,6+IIGLU1)
36104 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
36105 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
36106 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
36107 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
36108 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
36109 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
36110 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
36111 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
36112 C IDHKT(7) =1000*IPP1+100*ISQ+1
36113 IDHKT(7+IIGLU1) =IP1
36114 ISTHKT(7+IIGLU1) =951
36115 JMOHKT(1,7+IIGLU1)=NC1P
36116 JMOHKT(2,7+IIGLU1)=0
36118 C JDAHKT(1,7+IIGLU1)=9+IIGLU1
36119 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
36121 JDAHKT(2,7+IIGLU1)=0
36122 PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
36123 PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
36124 PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
36125 PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
36126 C PHKT(5,7+IIGLU1) =PHKK(5,NC1P)
36127 XMIST =(PHKT(4,7+IIGLU1)**2-
36128 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
36129 *PHKT(1,7+IIGLU1)**2)
36130 IF(XMIST.GT.0.D0)THEN
36131 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
36132 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
36133 *PHKT(1,7+IIGLU1)**2)
36135 C WRITE(6,*)'MUSQBS2 parton 7 mass square LT.0 ',XMIST
36136 PHKT(5,7+IIGLU1)=0.D0
36138 VHKT(1,7+IIGLU1) =VHKK(1,NC1P)
36139 VHKT(2,7+IIGLU1) =VHKK(2,NC1P)
36140 VHKT(3,7+IIGLU1) =VHKK(3,NC1P)
36141 VHKT(4,7+IIGLU1) =VHKK(4,NC1P)
36142 WHKT(1,7+IIGLU1) =WHKK(1,NC1P)
36143 WHKT(2,7+IIGLU1) =WHKK(2,NC1P)
36144 WHKT(3,7+IIGLU1) =WHKK(3,NC1P)
36145 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
36146 C Insert here the IIGLU2 gluons
36151 IF(IIGLU2.GE.1)THEN
36153 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36154 KKG=JJG+IIG-7-IIGLU1
36155 IDHKT(IIG) =IDHKK(KKG)
36159 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
36161 PHKT(1,IIG)=PHKK(1,KKG)
36162 PG1=PG1+ PHKT(1,IIG)
36163 PHKT(2,IIG)=PHKK(2,KKG)
36164 PG2=PG2+ PHKT(2,IIG)
36165 PHKT(3,IIG)=PHKK(3,KKG)
36166 PG3=PG3+ PHKT(3,IIG)
36167 PHKT(4,IIG)=PHKK(4,KKG)
36168 PG4=PG4+ PHKT(4,IIG)
36169 PHKT(5,IIG)=PHKK(5,KKG)
36170 VHKT(1,IIG) =VHKK(1,KKG)
36171 VHKT(2,IIG) =VHKK(2,KKG)
36172 VHKT(3,IIG) =VHKK(3,KKG)
36173 VHKT(4,IIG) =VHKK(4,KKG)
36174 WHKT(1,IIG) =WHKK(1,KKG)
36175 WHKT(2,IIG) =WHKK(2,KKG)
36176 WHKT(3,IIG) =WHKK(3,KKG)
36177 WHKT(4,IIG) =WHKK(4,KKG)
36181 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3
36182 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
36183 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
36184 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
36185 ELSEIF(IPIP.EQ.2)THEN
36186 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3
36187 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
36188 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
36189 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
36191 ISTHKT(8+IIGLU1+IIGLU2) =952
36192 JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
36193 JMOHKT(2,8+IIGLU1+IIGLU2)=0
36194 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
36195 JDAHKT(2,8+IIGLU1+IIGLU2)=0
36196 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC2T)+
36197 * PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
36198 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC2T)+
36199 * PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
36200 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC2T)+
36201 * PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
36202 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC2T)+
36203 * PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
36204 C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
36205 C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
36206 IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
36208 C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
36209 C * ,PHKT(4,8+IIGLU1+IIGLU2), PHKK(4,NC2T),NC2T
36214 C PHKT(5,8) =PHKK(5,NC2T)
36215 XMIST =(PHKT(4,8+IIGLU1+IIGLU2)**2-
36216 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36217 *PHKT(1,8+IIGLU1+IIGLU2)**2)
36218 IF(XMIST.GT.0.D0)THEN
36219 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
36220 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36221 *PHKT(1,8+IIGLU1+IIGLU2)**2)
36223 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36224 PHKT(5,5+IIGLU1)=0.D0
36226 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T)
36227 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T)
36228 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T)
36229 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T)
36230 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T)
36231 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T)
36232 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T)
36233 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T)
36234 IDHKT(9+IIGLU1+IIGLU2) =88888
36235 ISTHKT(9+IIGLU1+IIGLU2) =95
36236 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
36237 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
36238 JDAHKT(1,9+IIGLU1+IIGLU2)=0
36239 JDAHKT(2,9+IIGLU1+IIGLU2)=0
36241 C PHKT(1,9+IIGLU1+IIGLU2)
36242 C * =PHKT(1,7+IIGLU1+IIGLU2)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
36243 C PHKT(2,9+IIGLU1+IIGLU2)
36244 C * =PHKT(2,7+IIGLU1+IIGLU2)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
36245 C PHKT(3,9+IIGLU1+IIGLU2)
36246 C * =PHKT(3,7+IIGLU1+IIGLU2)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
36247 C PHKT(4,9+IIGLU1+IIGLU2)
36248 C * =PHKT(4,7+IIGLU1+IIGLU2)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
36249 PHKT(1,9+IIGLU1+IIGLU2)
36250 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
36251 PHKT(2,9+IIGLU1+IIGLU2)
36252 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
36253 PHKT(3,9+IIGLU1+IIGLU2)
36254 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
36255 PHKT(4,9+IIGLU1+IIGLU2)
36256 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
36259 * =(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
36260 * -PHKT(2,9+IIGLU1+IIGLU2)**2
36261 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
36262 IF(XMIST.GT.0.D0)THEN
36263 PHKT(5,9+IIGLU1+IIGLU2)
36264 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
36265 * -PHKT(2,9+IIGLU1+IIGLU2)**2
36266 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
36268 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36269 PHKT(5,5+IIGLU1)=0.D0
36272 C IF(NUMEV.EQ.-324)THEN
36273 C WRITE(6,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
36274 C * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
36275 C *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
36276 C DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36277 C WRITE(6,*)IIG,ISTHKT(IIG),IDHKT(IIG),JMOHKT(1,IIG),JMOHKT(2,IIG),
36279 C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36281 C WRITE(6,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
36282 C * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
36283 C *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
36284 C *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
36285 C WRITE(6,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
36286 C * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
36287 C *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
36288 C *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
36292 IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
36293 ELSEIF(IPIP.EQ.2)THEN
36294 IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
36296 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
36300 C WRITE(6,*)' MUSQBS1 jump back from chain 9',
36301 C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
36304 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
36305 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
36306 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
36307 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
36308 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
36309 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
36310 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
36311 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
36314 IGCOUN=9+IIGLU1+IIGLU2
36318 *$ CREATE MGSQBS2.FOR
36322 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
36323 SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36324 * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,ISQ,IGCOUN)
36326 C GSQBS-2 diagram (split target diquark)
36328 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36331 PARAMETER ( LINP = 10 ,
36337 PARAMETER (NMXHKK=200000)
36339 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36340 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36341 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36343 * extended event history
36344 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36345 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36348 * Lorentz-parameters of the current interaction
36349 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
36350 & UMO,PPCM,EPROJ,PPROJ
36352 * diquark-breaking mechanism
36353 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
36356 PARAMETER (NTMHKK= 300)
36357 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
36358 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
36362 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
36365 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
36367 C GSQBS-2 diagram (split target diquark)
36370 C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
36371 C Input chain 2(NC2) valence-diquark(NC2P)-sea-quark(NC2T)
36373 C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
36374 C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
36376 C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
36377 C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36378 C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
36382 C Put new chains into COMMON /HKKTMP/
36387 C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
36390 C IF(IPIP.EQ.2)THEN
36391 C WRITE(6,*)' MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
36392 C * 'IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN)',
36393 C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36394 C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN
36399 C determine x-values of NC1T diquark
36400 XDIQT=PHKK(4,NC1T)*2.D0/UMO
36401 XVQP=PHKK(4,NC1P)*2.D0/UMO
36403 C determine x-values of sea quark pair
36409 IF(ICOU.GE.500)THEN
36413 & WRITE(LOUT,*)' MGSQBS2 Rejection 2234 ICOU. GT.500'
36418 & WRITE(LOUT,*)'MGSQBS2 call XSEAPA: UMO,XDIQT,XVQP ',
36423 C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
36424 IF (IPIP.EQ.1) THEN
36425 XQMAX = XDIQT/2.0D0
36426 XAQMAX = 2.D0*XVQP/3.0D0
36428 XQMAX = 2.D0*XVQP/3.0D0
36429 XAQMAX = XDIQT/2.0D0
36431 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
36433 C write(*,*) 'MGSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
36436 & WRITE(LOUT,*)'MGSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
36439 & WRITE(LOUT,*)'MGSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
36444 IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
36445 ELSEIF(IPIP.EQ.2)THEN
36446 IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
36449 WRITE(LOUT,'(A,4E12.4)')' MGSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
36450 & XDIQT,XVQP,XSQ,XSAQ
36453 C subtract xsq,xsaq from NC1T diquark and NC1P quark
36459 ELSEIF(IPIP.EQ.2)THEN
36464 & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
36466 C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
36471 IF(IVTHR.EQ.10)THEN
36474 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 3466 reject IVTHR 10'
36479 XVTHR=XVTHRO/(201-IVTHR)
36482 IF(XVTHR.GT.0.66D0*XDIQT)THEN
36485 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 Rejection 380 XVTHR large',
36490 IF(DT_RNDM(V).LT.0.5D0)THEN
36491 XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
36494 XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
36498 WRITE(LOUT,'(A,2E12.4)')' MGSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
36501 C Prepare 4 momenta of new chains and chain ends
36503 C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
36504 C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
36507 C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
36508 C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36509 C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
36511 C SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36512 C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IGCOUN)
36519 ELSEIF(IPIP.EQ.2)THEN
36526 C IDHKT(1) =1000*IPP11+100*IPP12+1
36531 IDHKT(4+IIGLU1) =-(ISAQ1-6)
36532 ELSEIF(IPIP.EQ.2)THEN
36533 IDHKT(4+IIGLU1) =ISAQ1
36535 ISTHKT(4+IIGLU1) =961
36536 JMOHKT(1,4+IIGLU1)=NC1P
36537 JMOHKT(2,4+IIGLU1)=0
36538 JDAHKT(1,4+IIGLU1)=6+IIGLU1
36539 JDAHKT(2,4+IIGLU1)=0
36540 C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36541 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
36542 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
36543 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
36544 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
36545 C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
36546 XXMIST=(PHKT(4,4+IIGLU1)**2-
36547 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
36548 *PHKT(1,4+IIGLU1)**2)
36549 IF(XXMIST.GT.0.D0)THEN
36550 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
36552 WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
36554 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
36556 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
36557 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
36558 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
36559 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
36560 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
36561 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
36562 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
36563 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
36564 IDHKT(5+IIGLU1) =IP22
36565 ISTHKT(5+IIGLU1) =962
36566 JMOHKT(1,5+IIGLU1)=NC1T
36567 JMOHKT(2,5+IIGLU1)=0
36568 JDAHKT(1,5+IIGLU1)=6+IIGLU1
36569 JDAHKT(2,5+IIGLU1)=0
36570 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
36571 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
36572 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
36573 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
36574 C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
36575 XXMIST=(PHKT(4,5+IIGLU1)**2-
36576 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36577 *PHKT(1,5+IIGLU1)**2)
36578 IF(XXMIST.GT.0.D0)THEN
36579 PHKT(5,5+IIGLU1) =SQRT(XXMIST)
36581 WRITE(LOUT,*)' MGSQBS2 XXMIST', XXMIST
36583 PHKT(5,5+IIGLU1) =SQRT(XXMIST)
36585 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
36586 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
36587 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
36588 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
36589 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
36590 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
36591 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
36592 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
36593 IDHKT(6+IIGLU1) =88888
36594 ISTHKT(6+IIGLU1) =96
36595 JMOHKT(1,6+IIGLU1)=4+IIGLU1
36596 JMOHKT(2,6+IIGLU1)=5+IIGLU1
36597 JDAHKT(1,6+IIGLU1)=0
36598 JDAHKT(2,6+IIGLU1)=0
36599 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
36600 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
36601 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
36602 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
36604 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
36605 * -PHKT(3,6+IIGLU1)**2)
36608 IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
36609 ELSEIF(IPIP.EQ.2)THEN
36610 IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
36612 C---------------------------------------------------
36613 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
36614 IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
36615 C we drop chain 6 and give the energy to chain 3
36616 IDHKT(6+IIGLU1)=22888
36618 C WRITE(6,*)' drop chain 6 xgive=1'
36620 ELSEIF(IDHKT(4+IIGLU1).EQ.-IP21)THEN
36621 C we drop chain 6 and give the energy to chain 3
36622 C and change KK11 to IDHKT(5)
36623 IDHKT(6+IIGLU1)=22888
36625 C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(5)'
36626 KK11=IDHKT(5+IIGLU1)
36628 ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP11)THEN
36629 C we drop chain 6 and give the energy to chain 3
36630 C and change KK21 to IDHKT(5+IIGLU1)
36631 C IDHKT(1) =1000*IPP11+100*IPP12+1
36632 IDHKT(6+IIGLU1)=22888
36634 C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(5+IIGLU1)'
36635 KK21=IDHKT(5+IIGLU1)
36637 ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP12)THEN
36638 C we drop chain 6 and give the energy to chain 3
36639 C and change KK22 to IDHKT(5)
36640 C IDHKT(1) =1000*IPP11+100*IPP12+1
36641 IDHKT(6+IIGLU1)=22888
36643 C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(5+IIGLU1)'
36644 KK22=IDHKT(5+IIGLU1)
36653 C---------------------------------------------------
36655 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
36656 * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
36657 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
36658 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
36659 * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
36660 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
36661 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
36662 * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
36663 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
36665 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
36666 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
36667 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
36668 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
36669 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
36670 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
36671 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
36672 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
36673 C IDHKT(1) =1000*IPP11+100*IPP12+1
36675 IDHKT(1) =1000*KK21+100*KK22+3
36676 IF(IDHKT(1).EQ.1203)IDHKT(1)=2103
36677 IF(IDHKT(1).EQ.1303)IDHKT(1)=3103
36678 IF(IDHKT(1).EQ.2303)IDHKT(1)=3203
36679 ELSEIF(IPIP.EQ.2)THEN
36680 IDHKT(1) =1000*KK21+100*KK22-3
36681 IF(IDHKT(1).EQ.-1203)IDHKT(1)=-2103
36682 IF(IDHKT(1).EQ.-1303)IDHKT(1)=-3103
36683 IF(IDHKT(1).EQ.-2303)IDHKT(1)=-3203
36688 JDAHKT(1,1)=3+IIGLU1
36690 C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
36691 PHKT(1,1) =PHKK(1,NC2P)
36692 *+XGIVE*PHKT(1,4+IIGLU1)
36693 PHKT(2,1) =PHKK(2,NC2P)
36694 *+XGIVE*PHKT(2,4+IIGLU1)
36695 PHKT(3,1) =PHKK(3,NC2P)
36696 *+XGIVE*PHKT(3,4+IIGLU1)
36697 PHKT(4,1) =PHKK(4,NC2P)
36698 *+XGIVE*PHKT(4,4+IIGLU1)
36699 C PHKT(5,1) =PHKK(5,NC2P)
36700 XXMIST=PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
36702 IF(XXMIST.GT.0.D0)THEN
36703 PHKT(5,1) =SQRT(XXMIST)
36705 WRITE(LOUT,*)'MGSQBS2',XXMIST
36707 PHKT(5,1) =SQRT(XXMIST)
36709 VHKT(1,1) =VHKK(1,NC2P)
36710 VHKT(2,1) =VHKK(2,NC2P)
36711 VHKT(3,1) =VHKK(3,NC2P)
36712 VHKT(4,1) =VHKK(4,NC2P)
36713 WHKT(1,1) =WHKK(1,NC2P)
36714 WHKT(2,1) =WHKK(2,NC2P)
36715 WHKT(3,1) =WHKK(3,NC2P)
36716 WHKT(4,1) =WHKK(4,NC2P)
36717 C Add here IIGLU1 gluons to this chaina
36722 IF(IIGLU1.GE.1)THEN
36724 DO 61 IIG=2,2+IIGLU1-1
36726 IDHKT(IIG) =IDHKK(KKG)
36730 JDAHKT(1,IIG)=3+IIGLU1
36732 PHKT(1,IIG)=PHKK(1,KKG)
36733 PG1=PG1+ PHKT(1,IIG)
36734 PHKT(2,IIG)=PHKK(2,KKG)
36735 PG2=PG2+ PHKT(2,IIG)
36736 PHKT(3,IIG)=PHKK(3,KKG)
36737 PG3=PG3+ PHKT(3,IIG)
36738 PHKT(4,IIG)=PHKK(4,KKG)
36739 PG4=PG4+ PHKT(4,IIG)
36740 PHKT(5,IIG)=PHKK(5,KKG)
36741 VHKT(1,IIG) =VHKK(1,KKG)
36742 VHKT(2,IIG) =VHKK(2,KKG)
36743 VHKT(3,IIG) =VHKK(3,KKG)
36744 VHKT(4,IIG) =VHKK(4,KKG)
36745 WHKT(1,IIG) =WHKK(1,KKG)
36746 WHKT(2,IIG) =WHKK(2,KKG)
36747 WHKT(3,IIG) =WHKK(3,KKG)
36748 WHKT(4,IIG) =WHKK(4,KKG)
36752 IDHKT(2+IIGLU1) =KK11
36753 ISTHKT(2+IIGLU1) =962
36754 JMOHKT(1,2+IIGLU1)=NC1T
36755 JMOHKT(2,2+IIGLU1)=0
36756 JDAHKT(1,2+IIGLU1)=3+IIGLU1
36757 JDAHKT(2,2+IIGLU1)=0
36758 PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
36759 C * +0.5D0*PHKK(1,NC2T)
36760 *+XGIVE*PHKT(1,5+IIGLU1)
36761 PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
36762 C *+0.5D0*PHKK(2,NC2T)
36763 *+XGIVE*PHKT(2,5+IIGLU1)
36764 PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
36765 C *+0.5D0*PHKK(3,NC2T)
36766 *+XGIVE*PHKT(3,5+IIGLU1)
36767 PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
36768 C *+0.5D0*PHKK(4,NC2T)
36769 *+XGIVE*PHKT(4,5+IIGLU1)
36770 C PHKT(5,2) =PHKK(5,NC1T)
36771 XXMIST=(PHKT(4,2+IIGLU1)**2-
36772 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
36773 *PHKT(1,2+IIGLU1)**2)
36774 IF(XXMIST.GT.0.D0)THEN
36775 PHKT(5,2+IIGLU1) =SQRT(XXMIST)
36777 WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
36779 PHKT(5,2+IIGLU1) =SQRT(XXMIST)
36781 VHKT(1,2+IIGLU1) =VHKK(1,NC1T)
36782 VHKT(2,2+IIGLU1) =VHKK(2,NC1T)
36783 VHKT(3,2+IIGLU1) =VHKK(3,NC1T)
36784 VHKT(4,2+IIGLU1) =VHKK(4,NC1T)
36785 WHKT(1,2+IIGLU1) =WHKK(1,NC1T)
36786 WHKT(2,2+IIGLU1) =WHKK(2,NC1T)
36787 WHKT(3,2+IIGLU1) =WHKK(3,NC1T)
36788 WHKT(4,2+IIGLU1) =WHKK(4,NC1T)
36789 IDHKT(3+IIGLU1) =88888
36790 ISTHKT(3+IIGLU1) =96
36791 JMOHKT(1,3+IIGLU1)=1
36792 JMOHKT(2,3+IIGLU1)=2+IIGLU1
36793 JDAHKT(1,3+IIGLU1)=0
36794 JDAHKT(2,3+IIGLU1)=0
36795 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
36796 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
36797 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
36798 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
36800 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
36801 * -PHKT(3,3+IIGLU1)**2)
36803 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
36805 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
36806 DO 71 IIG=2,2+IIGLU1-1
36807 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
36808 & JMOHKT(1,IIG),JMOHKT(2,IIG),
36810 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36812 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
36813 * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
36814 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
36815 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
36816 * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
36817 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
36821 IF(IPP11.GE.3.OR.IPP12.GE.3.OR.IP21.GE.3)CHAMAL=CHAB3
36822 ELSEIF(IPIP.EQ.2)THEN
36823 IF(IPP11.LE.-3.OR.IPP12.LE.-3.OR.IP21.LE.-3)CHAMAL=CHAB3
36825 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
36831 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
36832 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
36833 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
36834 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
36835 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
36836 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
36837 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
36838 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
36839 C IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+1
36840 IDHKT(7+IIGLU1) =IP1
36841 ISTHKT(7+IIGLU1) =961
36842 JMOHKT(1,7+IIGLU1)=NC1P
36843 JMOHKT(2,7+IIGLU1)=0
36844 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
36845 JDAHKT(2,7+IIGLU1)=0
36846 PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
36847 PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
36848 PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
36849 PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
36850 C PHKT(5,7+IIGLU1) =PHKK(5,NC1P)
36851 XXMIST=(PHKT(4,7+IIGLU1)**2-
36852 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
36853 *PHKT(1,7+IIGLU1)**2)
36854 IF(XXMIST.GT.0.D0)THEN
36855 PHKT(5,7+IIGLU1) =SQRT(XXMIST)
36857 WRITE(LOUT,*)' MGSQBS2, XXMIST',XXMIST
36859 PHKT(5,7+IIGLU1) =SQRT(XXMIST)
36861 VHKT(1,7+IIGLU1) =VHKK(1,NC1P)
36862 VHKT(2,7+IIGLU1) =VHKK(2,NC1P)
36863 VHKT(3,7+IIGLU1) =VHKK(3,NC1P)
36864 VHKT(4,7+IIGLU1) =VHKK(4,NC1P)
36865 WHKT(1,7+IIGLU1) =WHKK(1,NC1P)
36866 WHKT(2,7+IIGLU1) =WHKK(2,NC1P)
36867 WHKT(3,7+IIGLU1) =WHKK(3,NC1P)
36868 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
36869 C IDHKT(7) =1000*IPP1+100*ISQ+1
36870 C Insert here the IIGLU2 gluons
36875 IF(IIGLU2.GE.1)THEN
36877 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36878 KKG=JJG+IIG-7-IIGLU1
36879 IDHKT(IIG) =IDHKK(KKG)
36883 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
36885 PHKT(1,IIG)=PHKK(1,KKG)
36886 PG1=PG1+ PHKT(1,IIG)
36887 PHKT(2,IIG)=PHKK(2,KKG)
36888 PG2=PG2+ PHKT(2,IIG)
36889 PHKT(3,IIG)=PHKK(3,KKG)
36890 PG3=PG3+ PHKT(3,IIG)
36891 PHKT(4,IIG)=PHKK(4,KKG)
36892 PG4=PG4+ PHKT(4,IIG)
36893 PHKT(5,IIG)=PHKK(5,KKG)
36894 VHKT(1,IIG) =VHKK(1,KKG)
36895 VHKT(2,IIG) =VHKK(2,KKG)
36896 VHKT(3,IIG) =VHKK(3,KKG)
36897 VHKT(4,IIG) =VHKK(4,KKG)
36898 WHKT(1,IIG) =WHKK(1,KKG)
36899 WHKT(2,IIG) =WHKK(2,KKG)
36900 WHKT(3,IIG) =WHKK(3,KKG)
36901 WHKT(4,IIG) =WHKK(4,KKG)
36905 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3
36906 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
36907 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
36908 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
36909 ELSEIF(IPIP.EQ.2)THEN
36911 C IDHKT(8) =1000*IPP2+100*(-ISQ1+6)-3
36912 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3
36914 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
36915 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
36916 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
36918 ISTHKT(8+IIGLU1+IIGLU2) =962
36919 JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
36920 JMOHKT(2,8+IIGLU1+IIGLU2)=0
36921 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
36922 JDAHKT(2,8+IIGLU1+IIGLU2)=0
36923 C PHKT(1,8) =0.5D0*PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ/(XDIQT+XSQ)
36924 C PHKT(2,8) =0.5D0*PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ/(XDIQT+XSQ)
36925 C PHKT(3,8) =0.5D0*PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ/(XDIQT+XSQ)
36926 C PHKT(4,8) =0.5D0*PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ/(XDIQT+XSQ)
36927 PHKT(1,8+IIGLU1+IIGLU2) =
36928 * PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
36929 PHKT(2,8+IIGLU1+IIGLU2) =
36930 * PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
36931 PHKT(3,8+IIGLU1+IIGLU2) =
36932 * PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
36933 PHKT(4,8+IIGLU1+IIGLU2) =
36934 * PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
36935 C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
36936 C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
36937 IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
36939 C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
36944 C PHKT(5,8) =PHKK(5,NC2T)
36945 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
36946 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36947 *PHKT(1,8+IIGLU1+IIGLU2)**2)
36948 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T)
36949 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T)
36950 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T)
36951 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T)
36952 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T)
36953 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T)
36954 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T)
36955 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T)
36956 IDHKT(9+IIGLU1+IIGLU2) =88888
36957 ISTHKT(9+IIGLU1+IIGLU2) =96
36958 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
36959 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
36960 JDAHKT(1,9+IIGLU1+IIGLU2)=0
36961 JDAHKT(2,9+IIGLU1+IIGLU2)=0
36962 PHKT(1,9+IIGLU1+IIGLU2)
36963 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
36964 PHKT(2,9+IIGLU1+IIGLU2)
36965 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
36966 PHKT(3,9+IIGLU1+IIGLU2)
36967 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
36968 PHKT(4,9+IIGLU1+IIGLU2)
36969 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
36970 PHKT(5,9+IIGLU1+IIGLU2)
36971 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
36972 * PHKT(2,9+IIGLU1+IIGLU2)**2
36973 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
36975 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
36976 * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
36977 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
36978 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36979 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
36980 & JMOHKT(1,IIG),JMOHKT(2,IIG),
36982 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36984 WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
36985 * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
36986 *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
36987 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
36988 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
36989 * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
36990 *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
36991 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
36995 IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
36996 ELSEIF(IPIP.EQ.2)THEN
36997 IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
36999 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
37005 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
37006 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
37007 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
37008 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
37009 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
37010 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
37011 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
37012 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
37015 IGCOUN=9+IIGLU1+IIGLU2
37019 *$ CREATE MUSQBS1.FOR
37023 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
37024 SUBROUTINE MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37025 * IP11,IP12,IP2,IPP1,IPP2,IPIP,ISQ,IGCOUN)
37027 C USQBS-1 diagram (split projectile diquark)
37029 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37032 PARAMETER ( LINP = 10 ,
37038 PARAMETER (NMXHKK=200000)
37040 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
37041 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
37042 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
37044 * extended event history
37045 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
37046 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37049 * Lorentz-parameters of the current interaction
37050 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37051 & UMO,PPCM,EPROJ,PPROJ
37053 * diquark-breaking mechanism
37054 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37057 PARAMETER (NTMHKK= 300)
37058 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37059 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37062 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37065 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37066 COMMON /EVFLAG/ NUMEV
37068 C USQBS-1 diagram (split projectile diquark)
37070 C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
37071 C Input chain 2(NC2) sea-quark(NC2P)-sea-antiquark(NC2T)
37073 C Create quark(qsP)-antiquark(aqsT) pair, energy from NC1P and NC1T
37074 C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37076 C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
37077 C 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
37078 C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37080 C Put new chains into COMMON /HKKTMP/
37085 C WRITE(6,*)'MUSQBS1: IIGLU1,IIGLU2,IPIP ',IIGLU1,IIGLU2,IPIP
37089 C IF(NUMEV.EQ.-324)THEN
37090 WRITE(LOUT,*)' MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37091 * ' IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN)',
37092 *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37093 * IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN
37098 C determine x-values of NC1P diquark
37099 XDIQP=PHKK(4,NC1P)*2.D0/UMO
37100 XVQT=PHKK(4,NC1T)*2.D0/UMO
37102 C determine x-values of sea quark pair
37108 IF(ICOU.GE.500)THEN
37111 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 2234 ICOU. GT.100'
37115 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 call XSEAPA: UMO,XDIQP,XVQT ',
37120 C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37121 IF (IPIP.EQ.1) THEN
37122 XQMAX = XDIQP/2.0D0
37123 XAQMAX = 2.D0*XVQT/3.0D0
37125 XQMAX = 2.D0*XVQT/3.0D0
37126 XAQMAX = XDIQP/2.0D0
37128 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37130 C write(*,*) 'MUSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
37132 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37135 & WRITE(LOUT,*)'MUSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37140 IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37141 ELSEIF(IPIP.EQ.2)THEN
37142 IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37145 WRITE(LOUT,'(A,4E12.4)')' MUSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
37146 & XDIQP,XVQT,XSQ,XSAQ
37149 C subtract xsq,xsaq from NC1P diquark and NC1T quark
37155 ELSEIF(IPIP.EQ.2)THEN
37160 & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
37162 C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37167 IF(IVTHR.EQ.10)THEN
37170 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 3466 reject IVTHR 10'
37175 XVTHR=XVTHRO/(201-IVTHR)
37178 IF(XVTHR.GT.0.66D0*XDIQP)THEN
37181 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 380 XVTHR large',
37186 IF(DT_RNDM(V).LT.0.5D0)THEN
37187 XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37190 XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37194 WRITE(LOUT,'(A,2E12.4)')' MUSQBS1:XVPQI,XVPQII ',XVPQI,XVPQII
37197 C Prepare 4 momenta of new chains and chain ends
37199 C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37200 C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37202 C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
37203 C 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
37204 C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37210 ELSEIF(IPIP.EQ.2)THEN
37220 JDAHKT(1,1)=3+IIGLU1
37222 C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
37223 PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
37224 PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
37225 PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
37226 PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
37227 C PHKT(5,1) =PHKK(5,NC1P)
37228 XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
37230 IF(XMIST.GE.0.D0)THEN
37231 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
37234 C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37237 VHKT(1,1) =VHKK(1,NC1P)
37238 VHKT(2,1) =VHKK(2,NC1P)
37239 VHKT(3,1) =VHKK(3,NC1P)
37240 VHKT(4,1) =VHKK(4,NC1P)
37241 WHKT(1,1) =WHKK(1,NC1P)
37242 WHKT(2,1) =WHKK(2,NC1P)
37243 WHKT(3,1) =WHKK(3,NC1P)
37244 WHKT(4,1) =WHKK(4,NC1P)
37245 C Add here IIGLU1 gluons to this chaina
37250 IF(IIGLU1.GE.1)THEN
37252 DO 61 IIG=2,2+IIGLU1-1
37254 IDHKT(IIG) =IDHKK(KKG)
37258 JDAHKT(1,IIG)=3+IIGLU1
37260 PHKT(1,IIG)=PHKK(1,KKG)
37261 PG1=PG1+ PHKT(1,IIG)
37262 PHKT(2,IIG)=PHKK(2,KKG)
37263 PG2=PG2+ PHKT(2,IIG)
37264 PHKT(3,IIG)=PHKK(3,KKG)
37265 PG3=PG3+ PHKT(3,IIG)
37266 PHKT(4,IIG)=PHKK(4,KKG)
37267 PG4=PG4+ PHKT(4,IIG)
37268 PHKT(5,IIG)=PHKK(5,KKG)
37269 VHKT(1,IIG) =VHKK(1,KKG)
37270 VHKT(2,IIG) =VHKK(2,KKG)
37271 VHKT(3,IIG) =VHKK(3,KKG)
37272 VHKT(4,IIG) =VHKK(4,KKG)
37273 WHKT(1,IIG) =WHKK(1,KKG)
37274 WHKT(2,IIG) =WHKK(2,KKG)
37275 WHKT(3,IIG) =WHKK(3,KKG)
37276 WHKT(4,IIG) =WHKK(4,KKG)
37279 IDHKT(2+IIGLU1) =IPP2
37280 ISTHKT(2+IIGLU1) =932
37281 JMOHKT(1,2+IIGLU1)=NC2T
37282 JMOHKT(2,2+IIGLU1)=0
37283 JDAHKT(1,2+IIGLU1)=3+IIGLU1
37284 JDAHKT(2,2+IIGLU1)=0
37285 PHKT(1,2+IIGLU1) =PHKK(1,NC2T)
37286 PHKT(2,2+IIGLU1) =PHKK(2,NC2T)
37287 PHKT(3,2+IIGLU1) =PHKK(3,NC2T)
37288 PHKT(4,2+IIGLU1) =PHKK(4,NC2T)
37289 C PHKT(5,2+IIGLU1) =PHKK(5,NC2T)
37290 XMIST=(PHKT(4,2+IIGLU1)**2-
37291 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37292 *PHKT(1,2+IIGLU1)**2)
37293 IF(XMIST.GT.0.D0)THEN
37294 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
37295 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37296 *PHKT(1,2+IIGLU1)**2)
37298 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37299 PHKT(5,2+IIGLU1)=0.D0
37301 VHKT(1,2+IIGLU1) =VHKK(1,NC2T)
37302 VHKT(2,2+IIGLU1) =VHKK(2,NC2T)
37303 VHKT(3,2+IIGLU1) =VHKK(3,NC2T)
37304 VHKT(4,2+IIGLU1) =VHKK(4,NC2T)
37305 WHKT(1,2+IIGLU1) =WHKK(1,NC2T)
37306 WHKT(2,2+IIGLU1) =WHKK(2,NC2T)
37307 WHKT(3,2+IIGLU1) =WHKK(3,NC2T)
37308 WHKT(4,2+IIGLU1) =WHKK(4,NC2T)
37309 IDHKT(3+IIGLU1) =88888
37310 ISTHKT(3+IIGLU1) =94
37311 JMOHKT(1,3+IIGLU1)=1
37312 JMOHKT(2,3+IIGLU1)=2+IIGLU1
37313 JDAHKT(1,3+IIGLU1)=0
37314 JDAHKT(2,3+IIGLU1)=0
37315 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
37316 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
37317 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
37318 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
37320 * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37321 * -PHKT(3,3+IIGLU1)**2)
37322 IF(XMIST.GE.0.D0)THEN
37324 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37325 * -PHKT(3,3+IIGLU1)**2)
37327 C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37331 C IF(NUMEV.EQ.-324)THEN
37332 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),
37333 * JMOHKT(2,1),JDAHKT(1,1),
37334 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
37335 DO 71 IIG=2,2+IIGLU1-1
37336 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
37337 & JMOHKT(1,IIG),JMOHKT(2,IIG),
37339 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37341 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
37342 * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
37343 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
37344 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
37345 * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
37346 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
37350 IF(IP11.GE.3.OR.IPP2.GE.3)CHAMAL=CHAM3
37351 ELSEIF(IPIP.EQ.2)THEN
37352 IF(IP11.LE.-3.OR.IPP2.LE.-3)CHAMAL=CHAM3
37354 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
37358 C WRITE(6,*)' MUSQBS1 jump back from chain 3'
37361 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
37362 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
37363 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
37364 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
37365 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
37366 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
37367 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
37368 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
37369 IDHKT(4+IIGLU1) =IP12
37370 ISTHKT(4+IIGLU1) =931
37371 JMOHKT(1,4+IIGLU1)=NC1P
37372 JMOHKT(2,4+IIGLU1)=0
37373 JDAHKT(1,4+IIGLU1)=6+IIGLU1
37374 JDAHKT(2,4+IIGLU1)=0
37375 C create chain 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
37376 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
37377 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
37378 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
37379 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
37380 C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
37381 XMIST =(PHKT(4,4+IIGLU1)**2-
37382 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37383 *PHKT(1,4+IIGLU1)**2)
37384 IF(XMIST.GT.0.D0)THEN
37385 PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2-
37386 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37387 *PHKT(1,4+IIGLU1)**2)
37389 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37390 PHKT(5,4+IIGLU1)=0.D0
37392 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
37393 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
37394 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
37395 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
37396 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
37397 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
37398 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
37399 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
37401 IDHKT(5+IIGLU1) =-(ISAQ1-6)
37402 ELSEIF(IPIP.EQ.2)THEN
37403 IDHKT(5+IIGLU1) =ISAQ1
37405 ISTHKT(5+IIGLU1) =932
37406 JMOHKT(1,5+IIGLU1)=NC1T
37407 JMOHKT(2,5+IIGLU1)=0
37408 JDAHKT(1,5+IIGLU1)=6+IIGLU1
37409 JDAHKT(2,5+IIGLU1)=0
37410 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
37411 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
37412 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
37413 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
37414 C IF( PHKT(4,5).EQ.0.D0)THEN
37419 C PHKT(5,5) =PHKK(5,NC1T)
37420 XMIST=(PHKT(4,5+IIGLU1)**2-
37421 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37422 *PHKT(1,5+IIGLU1)**2)
37423 IF(XMIST.GT.0.D0)THEN
37424 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
37425 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37426 *PHKT(1,5+IIGLU1)**2)
37428 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37429 PHKT(5,5+IIGLU1)=0.D0
37431 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
37432 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
37433 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
37434 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
37435 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
37436 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
37437 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
37438 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
37439 IDHKT(6+IIGLU1) =88888
37440 ISTHKT(6+IIGLU1) =94
37441 JMOHKT(1,6+IIGLU1)=4+IIGLU1
37442 JMOHKT(2,6+IIGLU1)=5+IIGLU1
37443 JDAHKT(1,6+IIGLU1)=0
37444 JDAHKT(2,6+IIGLU1)=0
37445 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37446 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37447 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37448 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37450 * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37451 * -PHKT(3,6+IIGLU1)**2)
37452 IF(XMIST.GE.0.D0)THEN
37454 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37455 * -PHKT(3,6+IIGLU1)**2)
37457 C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37460 C IF(IPIP.EQ.3)THEN
37463 IF(IP12.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
37464 ELSEIF(IPIP.EQ.2)THEN
37465 IF(IP12.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
37467 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37471 C WRITE(6,*)' MGSQBS1 jump back from chain 6',
37472 C & CHAMAL,PHKT(5,6+IIGLU1)
37476 C IF(NUMEV.EQ.-324)THEN
37477 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
37478 * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
37479 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
37480 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
37481 * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
37482 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
37483 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
37484 * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
37485 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
37487 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
37488 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
37489 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
37490 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
37491 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
37492 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
37493 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
37494 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
37496 IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+3
37497 IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
37498 IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
37499 IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
37500 ELSEIF(IPIP.EQ.2)THEN
37501 IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3
37502 IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
37503 IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
37504 IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
37505 C WRITE(6,*)'IDHKT(7+IIGLU1),IPP1,ISQ1',IDHKT(7+IIGLU1),IPP1,ISQ1
37507 ISTHKT(7+IIGLU1) =931
37508 JMOHKT(1,7+IIGLU1)=NC2P
37509 JMOHKT(2,7+IIGLU1)=0
37510 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
37511 JDAHKT(2,7+IIGLU1)=0
37512 C create chain 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37513 PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
37514 PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
37515 PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
37516 PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
37517 C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
37518 C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
37519 IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
37521 C WRITE(6,*)'reject PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P)'
37526 C PHKT(5,7) =PHKK(5,NC2P)
37527 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
37528 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
37529 *PHKT(1,7+IIGLU1)**2)
37530 VHKT(1,7+IIGLU1) =VHKK(1,NC2P)
37531 VHKT(2,7+IIGLU1) =VHKK(2,NC2P)
37532 VHKT(3,7+IIGLU1) =VHKK(3,NC2P)
37533 VHKT(4,7+IIGLU1) =VHKK(4,NC2P)
37534 WHKT(1,7+IIGLU1) =WHKK(1,NC2P)
37535 WHKT(2,7+IIGLU1) =WHKK(2,NC2P)
37536 WHKT(3,7+IIGLU1) =WHKK(3,NC2P)
37537 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
37538 C Insert here the IIGLU2 gluons
37543 IF(IIGLU2.GE.1)THEN
37545 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37546 KKG=JJG+IIG-7-IIGLU1
37547 IDHKT(IIG) =IDHKK(KKG)
37551 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
37553 PHKT(1,IIG)=PHKK(1,KKG)
37554 PG1=PG1+ PHKT(1,IIG)
37555 PHKT(2,IIG)=PHKK(2,KKG)
37556 PG2=PG2+ PHKT(2,IIG)
37557 PHKT(3,IIG)=PHKK(3,KKG)
37558 PG3=PG3+ PHKT(3,IIG)
37559 PHKT(4,IIG)=PHKK(4,KKG)
37560 PG4=PG4+ PHKT(4,IIG)
37561 PHKT(5,IIG)=PHKK(5,KKG)
37562 VHKT(1,IIG) =VHKK(1,KKG)
37563 VHKT(2,IIG) =VHKK(2,KKG)
37564 VHKT(3,IIG) =VHKK(3,KKG)
37565 VHKT(4,IIG) =VHKK(4,KKG)
37566 WHKT(1,IIG) =WHKK(1,KKG)
37567 WHKT(2,IIG) =WHKK(2,KKG)
37568 WHKT(3,IIG) =WHKK(3,KKG)
37569 WHKT(4,IIG) =WHKK(4,KKG)
37572 IDHKT(8+IIGLU1+IIGLU2) =IP2
37573 ISTHKT(8+IIGLU1+IIGLU2) =932
37574 JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
37575 JMOHKT(2,8+IIGLU1+IIGLU2)=0
37576 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
37577 JDAHKT(2,8+IIGLU1+IIGLU2)=0
37578 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
37579 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
37580 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
37581 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
37582 C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T)
37583 XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
37584 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37585 *PHKT(1,8+IIGLU1+IIGLU2)**2)
37586 IF(XMIST.GT.0.D0)THEN
37587 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
37588 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37589 *PHKT(1,8+IIGLU1+IIGLU2)**2)
37591 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37592 PHKT(5,8+IIGLU1+IIGLU2)=0.D0
37594 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T)
37595 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T)
37596 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T)
37597 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T)
37598 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T)
37599 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T)
37600 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T)
37601 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T)
37602 IDHKT(9+IIGLU1+IIGLU2) =88888
37603 ISTHKT(9+IIGLU1+IIGLU2) =94
37604 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
37605 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
37606 JDAHKT(1,9+IIGLU1+IIGLU2)=0
37607 JDAHKT(2,9+IIGLU1+IIGLU2)=0
37608 PHKT(1,9+IIGLU1+IIGLU2)
37609 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
37610 PHKT(2,9+IIGLU1+IIGLU2)
37611 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
37612 PHKT(3,9+IIGLU1+IIGLU2)
37613 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
37614 PHKT(4,9+IIGLU1+IIGLU2)
37615 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
37617 *=(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37618 * -PHKT(2,9+IIGLU1+IIGLU2)**2
37619 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
37620 IF(XMIST.GE.0.D0)THEN
37621 PHKT(5,9+IIGLU1+IIGLU2)
37622 *=SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37623 * -PHKT(2,9+IIGLU1+IIGLU2)**2
37624 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
37626 C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37630 C IF(NUMEV.EQ.-324)THEN
37631 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
37632 * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
37633 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
37634 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37635 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
37636 & JMOHKT(1,IIG),JMOHKT(2,IIG),
37638 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37640 WRITE(LOUT,*)8+IIGLU1+IIGLU2,
37641 * ISTHKT(8+IIGLU1+IIGLU2),IDHKT(8+IIGLU1+IIGLU2),
37642 * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
37643 *JDAHKT(1,8+IIGLU1+IIGLU2),
37644 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
37645 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
37646 * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
37647 *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
37648 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
37652 IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
37653 ELSEIF(IPIP.EQ.2)THEN
37654 IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
37656 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
37660 C WRITE(6,*)' MGSQBS1 jump back from chain 9',
37661 C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
37664 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
37665 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
37666 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
37667 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
37668 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
37669 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
37670 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
37671 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
37674 IGCOUN=9+IIGLU1+IIGLU2
37678 *$ CREATE MGSQBS1.FOR
37681 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
37682 SUBROUTINE MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37683 * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,ISQ,IGCOUN)
37685 C GSQBS-1 diagram (split projectile diquark)
37687 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37690 PARAMETER ( LINP = 10 ,
37696 PARAMETER (NMXHKK=200000)
37698 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
37699 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
37700 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
37702 * extended event history
37703 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
37704 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37707 * Lorentz-parameters of the current interaction
37708 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37709 & UMO,PPCM,EPROJ,PPROJ
37711 * diquark-breaking mechanism
37712 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37715 PARAMETER (NTMHKK= 300)
37716 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37717 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37720 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37723 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37725 C GSQBS-1 diagram (split projectile diquark)
37728 C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
37729 C Input chain 2(NC2) sea-quark(NC2P)-valence-diquark(NC2T)
37731 C Create quark(qs)-antiquark(aqs) pair energy from NC1P and NC1T
37732 C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37734 C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
37735 C 6 valence quark(vq2P 4)-sea-quark(aqsP 5)
37736 C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37738 C Put new chains into COMMON /HKKTMP/
37743 C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
37745 NNNC1=IDHKK(NC1)/1000
37746 MMMC1=IDHKK(NC1)-NNNC1*1000
37748 NNNC2=IDHKK(NC2)/1000
37749 MMMC2=IDHKK(NC2)-NNNC2*1000
37753 WRITE(LOUT,*)' MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37754 * ' IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN)',
37755 *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37756 * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN
37761 C determine x-values of NC1P diquark
37762 XDIQP=PHKK(4,NC1P)*2.D0/UMO
37763 XVQT=PHKK(4,NC1T)*2.D0/UMO
37765 C determine x-values of sea quark pair
37771 IF(ICOU.GE.500)THEN
37774 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 Rejection 2234 ICOU. GT.100'
37778 IF(IPCO.GE.3)WRITE(LOUT,*)'MGSQBS1 call XSEAPA: UMO,XDIQP,XVQT ',
37783 C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37784 IF (IPIP.EQ.1) THEN
37785 XQMAX = XDIQP/2.0D0
37786 XAQMAX = 2.D0*XVQT/3.0D0
37788 XQMAX = 2.D0*XVQT/3.0D0
37789 XAQMAX = XDIQP/2.0D0
37791 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37793 C write(*,*) 'MGSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
37796 & WRITE(LOUT,*)'MGSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37799 & WRITE(LOUT,*)'MGSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37804 IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37805 ELSEIF(IPIP.EQ.2)THEN
37806 IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37809 WRITE(LOUT,'(A,4E12.4)')' MGSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
37810 & XDIQP,XVQT,XSQ,XSAQ
37813 C subtract xsq,xsaq from NC1P diquark and NC1T quark
37819 C IF (XDIQP.LT.0.0D0) WRITE(*,*) ' mgsqbs1: XDIQP<0!!',XDIQP
37822 ELSEIF(IPIP.EQ.2)THEN
37827 & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
37829 C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37834 IF(IVTHR.EQ.10)THEN
37837 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 3466 reject IVTHR 10'
37842 XVTHR=XVTHRO/(201-IVTHR)
37845 IF(XVTHR.GT.0.66D0*XDIQP)THEN
37849 & WRITE(LOUT,*)' MGSQBS1 Rejection 380 XVTHR large',
37854 IF(DT_RNDM(V).LT.0.5D0)THEN
37855 XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37858 XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37862 WRITE(LOUT,'(A,4E12.4)')' MGSQBS1:XVTHR,XDIQP,XVPQI,XVPQII ',
37863 & XVTHR,XDIQP,XVPQI,XVPQII
37866 C Prepare 4 momenta of new chains and chain ends
37868 C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37869 C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37871 C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
37872 C 6 valence quark(vq2P 4)-sea-quark(aqsP 5)
37873 C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37879 ELSEIF(IPIP.EQ.2)THEN
37886 C IDHKT(2) =1000*IPP21+100*IPP22+1
37890 IDHKT(4+IIGLU1) =IP12
37891 ISTHKT(4+IIGLU1) =921
37892 JMOHKT(1,4+IIGLU1)=NC1P
37893 JMOHKT(2,4+IIGLU1)=0
37894 JDAHKT(1,4+IIGLU1)=6+IIGLU1
37895 JDAHKT(2,4+IIGLU1)=0
37897 IF ((XDIQP.LT.0.0D0).OR.(XVPQII.LT.0.0D0).OR.
37898 & (XSQ1.LT.0.0D0)) WRITE(LOUT,*) ' mgsqbs1: ',XDIQP,XVPQII,XSQ1
37900 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
37901 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
37902 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
37903 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
37904 C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
37905 XXMIST=(PHKT(4,4+IIGLU1)**2-
37906 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37907 * PHKT(1,4+IIGLU1)**2)
37908 IF(XXMIST.GT.0.D0)THEN
37909 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
37911 WRITE(LOUT,*)'MGSQBS1 XXMIST',XXMIST
37913 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
37915 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
37916 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
37917 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
37918 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
37919 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
37920 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
37921 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
37922 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
37924 IDHKT(5+IIGLU1) =-(ISAQ1-6)
37925 ELSEIF(IPIP.EQ.2)THEN
37926 IDHKT(5+IIGLU1) =ISAQ1
37928 ISTHKT(5+IIGLU1) =922
37929 JMOHKT(1,5+IIGLU1)=NC1T
37930 JMOHKT(2,5+IIGLU1)=0
37931 JDAHKT(1,5+IIGLU1)=6+IIGLU1
37932 JDAHKT(2,5+IIGLU1)=0
37934 IF ((XSAQ1.LT.0.0D0).OR.(XVQT .LT.0.0D0))
37935 & WRITE(LOUT,*) ' mgsqbs2: ',XSAQ1,XVQT
37937 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
37938 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
37939 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
37940 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
37941 C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
37942 XMIST=(PHKT(4,5+IIGLU1)**2-
37943 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37944 *PHKT(1,5+IIGLU1)**2)
37945 IF(XMIST.GT.0.D0)THEN
37946 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
37947 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37948 *PHKT(1,5+IIGLU1)**2)
37950 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37951 PHKT(5,5+IIGLU1)=0.D0
37953 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
37954 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
37955 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
37956 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
37957 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
37958 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
37959 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
37960 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
37961 IDHKT(6+IIGLU1) =88888
37962 C IDHKT(6) =1000*NNNC1+MMMC1
37963 ISTHKT(6+IIGLU1) =93
37965 JMOHKT(1,6+IIGLU1)=4+IIGLU1
37966 JMOHKT(2,6+IIGLU1)=5+IIGLU1
37967 JDAHKT(1,6+IIGLU1)=0
37968 JDAHKT(2,6+IIGLU1)=0
37969 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37970 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37971 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37972 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37974 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37975 * -PHKT(3,6+IIGLU1)**2)
37978 IF(IP12.GE.3.OR.ISAQ.GE.9)CHAMAL=CHAM3
37979 ELSEIF(IPIP.EQ.2)THEN
37980 IF(IP12.LE.-3.OR.ISAQ.GE.3)CHAMAL=CHAM3
37982 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37983 IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
37984 C we drop chain 6 and give the energy to chain 3
37985 IDHKT(6+IIGLU1)=33888
37987 C WRITE(6,*)' drop chain 6 xgive=1'
37989 ELSEIF(IDHKT(5+IIGLU1).EQ.-IP11)THEN
37990 C we drop chain 6 and give the energy to chain 3
37991 C and change KK11 to IDHKT(4)
37992 IDHKT(6+IIGLU1)=33888
37994 C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(4+IIGLU1)'
37995 KK11=IDHKT(4+IIGLU1)
37997 ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP21)THEN
37998 C we drop chain 6 and give the energy to chain 3
37999 C and change KK21 to IDHKT(4)
38000 C IDHKT(2) =1000*IPP21+100*IPP22+1
38001 IDHKT(6+IIGLU1)=33888
38003 C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(4+IIGLU1)'
38004 KK21=IDHKT(4+IIGLU1)
38006 ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP22)THEN
38007 C we drop chain 6 and give the energy to chain 3
38008 C and change KK22 to IDHKT(4)
38009 C IDHKT(2) =1000*IPP21+100*IPP22+1
38010 IDHKT(6+IIGLU1)=33888
38012 C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(4+IIGLU1)'
38013 KK22=IDHKT(4+IIGLU1)
38019 C WRITE(6,*)' MGSQBS1 jump back from chain 6'
38024 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
38025 * JMOHKT(1,4+IIGLU1),
38026 * JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
38027 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
38028 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
38029 * JMOHKT(1,5+IIGLU1),
38030 * JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
38031 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
38032 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
38033 * JMOHKT(1,6+IIGLU1),
38034 * JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
38035 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
38037 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
38038 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
38039 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
38040 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
38041 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
38042 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
38043 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
38044 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
38050 JDAHKT(1,1)=3+IIGLU1
38052 PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
38053 C * +0.5D0*PHKK(1,NC2P)
38054 *+XGIVE*PHKT(1,4+IIGLU1)
38055 PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
38056 C * +0.5D0*PHKK(2,NC2P)
38057 *+XGIVE*PHKT(2,4+IIGLU1)
38058 PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
38059 C * +0.5D0*PHKK(3,NC2P)
38060 *+XGIVE*PHKT(3,4+IIGLU1)
38061 PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
38062 C * +0.5D0*PHKK(4,NC2P)
38063 *+XGIVE*PHKT(4,4+IIGLU1)
38064 C PHKT(5,1) =PHKK(5,NC1P)
38065 XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38067 IF(XMIST.GE.0.D0)THEN
38068 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38071 C WRITE(6,*)'MGSQBS1 parton 1 mass square LT.0 ',XMIST
38074 VHKT(1,1) =VHKK(1,NC1P)
38075 VHKT(2,1) =VHKK(2,NC1P)
38076 VHKT(3,1) =VHKK(3,NC1P)
38077 VHKT(4,1) =VHKK(4,NC1P)
38078 WHKT(1,1) =WHKK(1,NC1P)
38079 WHKT(2,1) =WHKK(2,NC1P)
38080 WHKT(3,1) =WHKK(3,NC1P)
38081 WHKT(4,1) =WHKK(4,NC1P)
38082 C Add here IIGLU1 gluons to this chaina
38087 IF(IIGLU1.GE.1)THEN
38089 DO 61 IIG=2,2+IIGLU1-1
38091 IDHKT(IIG) =IDHKK(KKG)
38095 JDAHKT(1,IIG)=3+IIGLU1
38097 PHKT(1,IIG)=PHKK(1,KKG)
38098 PG1=PG1+ PHKT(1,IIG)
38099 PHKT(2,IIG)=PHKK(2,KKG)
38100 PG2=PG2+ PHKT(2,IIG)
38101 PHKT(3,IIG)=PHKK(3,KKG)
38102 PG3=PG3+ PHKT(3,IIG)
38103 PHKT(4,IIG)=PHKK(4,KKG)
38104 PG4=PG4+ PHKT(4,IIG)
38105 PHKT(5,IIG)=PHKK(5,KKG)
38106 VHKT(1,IIG) =VHKK(1,KKG)
38107 VHKT(2,IIG) =VHKK(2,KKG)
38108 VHKT(3,IIG) =VHKK(3,KKG)
38109 VHKT(4,IIG) =VHKK(4,KKG)
38110 WHKT(1,IIG) =WHKK(1,KKG)
38111 WHKT(2,IIG) =WHKK(2,KKG)
38112 WHKT(3,IIG) =WHKK(3,KKG)
38113 WHKT(4,IIG) =WHKK(4,KKG)
38116 C IDHKT(2) =1000*IPP21+100*IPP22+1
38118 IDHKT(2+IIGLU1) =1000*KK21+100*KK22+3
38119 IF(IDHKT(2+IIGLU1).EQ.1203)IDHKT(2+IIGLU1)=2103
38120 IF(IDHKT(2+IIGLU1).EQ.1303)IDHKT(2+IIGLU1)=3103
38121 IF(IDHKT(2+IIGLU1).EQ.2303)IDHKT(2+IIGLU1)=3203
38122 ELSEIF(IPIP.EQ.2)THEN
38123 IDHKT(2+IIGLU1) =1000*KK21+100*KK22-3
38124 IF(IDHKT(2+IIGLU1).EQ.-1203)IDHKT(2+IIGLU1)=-2103
38125 IF(IDHKT(2+IIGLU1).EQ.-1303)IDHKT(2+IIGLU1)=-3103
38126 IF(IDHKT(2+IIGLU1).EQ.-2303)IDHKT(2+IIGLU1)=-3203
38128 ISTHKT(2+IIGLU1) =922
38129 JMOHKT(1,2+IIGLU1)=NC2T
38130 JMOHKT(2,2+IIGLU1)=0
38131 JDAHKT(1,2+IIGLU1)=3+IIGLU1
38132 JDAHKT(2,2+IIGLU1)=0
38133 PHKT(1,2+IIGLU1) =PHKK(1,NC2T)
38134 *+XGIVE*PHKT(1,5+IIGLU1)
38135 PHKT(2,2+IIGLU1) =PHKK(2,NC2T)
38136 *+XGIVE*PHKT(2,5+IIGLU1)
38137 PHKT(3,2+IIGLU1) =PHKK(3,NC2T)
38138 *+XGIVE*PHKT(3,5+IIGLU1)
38139 PHKT(4,2+IIGLU1) =PHKK(4,NC2T)
38140 *+XGIVE*PHKT(4,5+IIGLU1)
38141 C PHKT(5,2) =PHKK(5,NC2T)
38142 XMIST=(PHKT(4,2+IIGLU1)**2-
38143 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38144 *PHKT(1,2+IIGLU1)**2)
38145 IF(XMIST.GT.0.D0)THEN
38146 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
38147 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38148 *PHKT(1,2+IIGLU1)**2)
38150 C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
38151 PHKT(5,2+IIGLU1)=0.D0
38153 VHKT(1,2+IIGLU1) =VHKK(1,NC2T)
38154 VHKT(2,2+IIGLU1) =VHKK(2,NC2T)
38155 VHKT(3,2+IIGLU1) =VHKK(3,NC2T)
38156 VHKT(4,2+IIGLU1) =VHKK(4,NC2T)
38157 WHKT(1,2+IIGLU1) =WHKK(1,NC2T)
38158 WHKT(2,2+IIGLU1) =WHKK(2,NC2T)
38159 WHKT(3,2+IIGLU1) =WHKK(3,NC2T)
38160 WHKT(4,2+IIGLU1) =WHKK(4,NC2T)
38161 IDHKT(3+IIGLU1) =88888
38162 C IDHKT(3) =1000*NNNC1+MMMC1+10
38163 ISTHKT(3+IIGLU1) =93
38165 JMOHKT(1,3+IIGLU1)=1
38166 JMOHKT(2,3+IIGLU1)=2+IIGLU1
38167 JDAHKT(1,3+IIGLU1)=0
38168 JDAHKT(2,3+IIGLU1)=0
38169 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
38170 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
38171 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
38172 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
38174 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38175 * -PHKT(3,3+IIGLU1)**2)
38177 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
38179 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
38180 DO 71 IIG=2,2+IIGLU1-1
38181 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38182 & JMOHKT(1,IIG),JMOHKT(2,IIG),
38184 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38186 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),
38187 & IDHKT(2),JMOHKT(1,2+IIGLU1),
38188 * JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
38189 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
38190 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
38191 * JMOHKT(1,3+IIGLU1),
38192 * JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
38193 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
38197 C IF(IPIP.EQ.1)THEN
38198 C IF(IPP21.GE.3.OR.IPP22.GE.3.OR.IP11.GE.3)CHAMAL=CHAB3
38199 C ELSEIF(IPIP.EQ.2)THEN
38200 C IF(IPP21.LE.-3.OR.IPP22.LE.-3.OR.IP11.LE.-3)CHAMAL=CHAB3
38203 IF(KK21.GE.3.OR.KK22.GE.3.OR.KK11.GE.3)CHAMAL=CHAB3
38204 ELSEIF(IPIP.EQ.2)THEN
38205 IF(KK21.LE.-3.OR.KK22.LE.-3.OR.KK11.LE.-3)CHAMAL=CHAB3
38208 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
38212 C WRITE(6,*)' MGSQBS1 jump back from chain 3'
38215 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
38216 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
38217 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
38218 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
38219 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
38220 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
38221 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
38222 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
38224 IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ1+3
38225 IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
38226 IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
38227 IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
38228 ELSEIF(IPIP.EQ.2)THEN
38229 IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3
38230 IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
38231 IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
38232 IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
38233 C WRITE(6,*)'IDHKT(7),IPP1,ISQ1',IDHKT(7),IPP1,ISQ1
38235 ISTHKT(7+IIGLU1) =921
38236 JMOHKT(1,7+IIGLU1)=NC2P
38237 JMOHKT(2,7+IIGLU1)=0
38238 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
38239 JDAHKT(2,7+IIGLU1)=0
38240 C PHKT(1,7) =0.5D0*PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ/(XDIQP+XSQ)
38241 C PHKT(2,7) =0.5D0*PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ/(XDIQP+XSQ)
38242 C PHKT(3,7) =0.5D0*PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ/(XDIQP+XSQ)
38243 C PHKT(4,7+IIGLU1) =0.5D0*PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ/(XDIQP+XSQ)
38245 IF ((XSQ1 .LT.0.0D0).OR.(XDIQP .LT.0.0D0))
38246 & WRITE(LOUT,*) ' mgsqbs3: ',XSQ1,XDIQP
38248 PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
38249 PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
38250 PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
38251 PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
38252 C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
38253 C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
38254 IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
38256 C WRITE(6,*)'reject PHKT(4,7).GE. PHKK(4,NC1P)'
38261 C PHKT(5,7) =PHKK(5,NC2P)
38262 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
38263 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
38264 *PHKT(1,7+IIGLU1)**2)
38265 VHKT(1,7+IIGLU1) =VHKK(1,NC2P)
38266 VHKT(2,7+IIGLU1) =VHKK(2,NC2P)
38267 VHKT(3,7+IIGLU1) =VHKK(3,NC2P)
38268 VHKT(4,7+IIGLU1) =VHKK(4,NC2P)
38269 WHKT(1,7+IIGLU1) =WHKK(1,NC2P)
38270 WHKT(2,7+IIGLU1) =WHKK(2,NC2P)
38271 WHKT(3,7+IIGLU1) =WHKK(3,NC2P)
38272 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
38273 C Insert here the IIGLU2 gluons
38278 IF(IIGLU2.GE.1)THEN
38280 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38281 KKG=JJG+IIG-7-IIGLU1
38282 IDHKT(IIG) =IDHKK(KKG)
38286 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
38288 PHKT(1,IIG)=PHKK(1,KKG)
38289 PG1=PG1+ PHKT(1,IIG)
38290 PHKT(2,IIG)=PHKK(2,KKG)
38291 PG2=PG2+ PHKT(2,IIG)
38292 PHKT(3,IIG)=PHKK(3,KKG)
38293 PG3=PG3+ PHKT(3,IIG)
38294 PHKT(4,IIG)=PHKK(4,KKG)
38295 PG4=PG4+ PHKT(4,IIG)
38296 PHKT(5,IIG)=PHKK(5,KKG)
38297 VHKT(1,IIG) =VHKK(1,KKG)
38298 VHKT(2,IIG) =VHKK(2,KKG)
38299 VHKT(3,IIG) =VHKK(3,KKG)
38300 VHKT(4,IIG) =VHKK(4,KKG)
38301 WHKT(1,IIG) =WHKK(1,KKG)
38302 WHKT(2,IIG) =WHKK(2,KKG)
38303 WHKT(3,IIG) =WHKK(3,KKG)
38304 WHKT(4,IIG) =WHKK(4,KKG)
38307 IDHKT(8+IIGLU1+IIGLU2) =IP2
38308 ISTHKT(8+IIGLU1+IIGLU2) =922
38309 JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
38310 JMOHKT(2,8+IIGLU1+IIGLU2)=0
38311 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
38312 JDAHKT(2,8+IIGLU1+IIGLU2)=0
38314 IF ((XVQT.LT.0.0D0).OR.(XSAQ1 .LT.0.0D0))
38315 & WRITE(LOUT,*) ' mgsqbs4: ',XVQT,XSAQ1
38317 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
38318 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
38319 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
38320 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
38321 C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T)
38322 XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
38323 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38324 *PHKT(1,8+IIGLU1+IIGLU2)**2)
38325 IF(XMIST.GT.0.D0)THEN
38326 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
38327 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38328 *PHKT(1,8+IIGLU1+IIGLU2)**2)
38330 C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
38331 PHKT(5,8+IIGLU1+IIGLU2)=0.D0
38333 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T)
38334 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T)
38335 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T)
38336 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T)
38337 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T)
38338 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T)
38339 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T)
38340 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T)
38341 IDHKT(9+IIGLU1+IIGLU2) =88888
38342 C IDHKT(9) =1000*NNNC2+MMMC2+10
38343 ISTHKT(9+IIGLU1+IIGLU2) =93
38345 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
38346 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
38347 JDAHKT(1,9+IIGLU1+IIGLU2)=0
38348 JDAHKT(2,9+IIGLU1+IIGLU2)=0
38349 PHKT(1,9+IIGLU1+IIGLU2) =PHKT(1,7+IIGLU1)
38350 * +PHKT(1,8+IIGLU1+IIGLU2)+PG1
38351 PHKT(2,9+IIGLU1+IIGLU2) =PHKT(2,7+IIGLU1)
38352 * +PHKT(2,8+IIGLU1+IIGLU2)+PG2
38353 PHKT(3,9+IIGLU1+IIGLU2) =PHKT(3,7+IIGLU1)
38354 * +PHKT(3,8+IIGLU1+IIGLU2)+PG3
38355 PHKT(4,9+IIGLU1+IIGLU2) =PHKT(4,7+IIGLU1)
38356 * +PHKT(4,8+IIGLU1+IIGLU2)+PG4
38357 PHKT(5,9+IIGLU1+IIGLU2)
38358 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
38359 * PHKT(2,9+IIGLU1+IIGLU2)**2
38360 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
38362 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
38363 * JMOHKT(1,7+IIGLU1),
38364 * JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
38365 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
38366 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38367 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38368 & JMOHKT(1,IIG),JMOHKT(2,IIG),
38370 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38372 WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
38373 * IDHKT(8+IIGLU1+IIGLU2),
38374 * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
38375 * JDAHKT(1,8+IIGLU1+IIGLU2),
38376 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
38377 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
38378 * IDHKT(9+IIGLU1+IIGLU2),
38379 * JMOHKT(1,9+IIGLU1+IIGLU2),JMOHKT(2,9+IIGLU1+IIGLU2),
38380 * JDAHKT(1,9+IIGLU1+IIGLU2),
38381 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
38385 IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
38386 ELSEIF(IPIP.EQ.2)THEN
38387 IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
38389 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
38393 C WRITE(6,*)' MGSQBS1 jump back from chain 9',
38394 C & 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
38397 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
38398 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
38399 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
38400 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
38401 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
38402 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
38403 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
38404 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
38406 IGCOUN=9+IIGLU1+IIGLU2
38411 *$ CREATE HKKHKT.FOR
38414 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
38416 SUBROUTINE HKKHKT(I,J)
38417 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38422 PARAMETER (NMXHKK=200000)
38424 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38425 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38426 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38428 * extended event history
38429 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38430 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38433 PARAMETER (NTMHKK= 300)
38434 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38435 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38438 ISTHKK(I) =ISTHKT(J)
38440 C IF(J.EQ.3.OR.J.EQ.6.OR.J.EQ.9)THEN
38441 IF(IDHKK(I).EQ.88888)THEN
38444 JMOHKK(1,I)=I-(J-JMOHKT(1,J))
38445 JMOHKK(2,I)=I-(J-JMOHKT(2,J))
38447 JMOHKK(1,I)=JMOHKT(1,J)
38448 JMOHKK(2,I)=JMOHKT(2,J)
38450 JDAHKK(1,I)=JDAHKT(1,J)
38451 JDAHKK(2,I)=JDAHKT(2,J)
38452 C IF(J.EQ.1.OR.J.EQ.4.OR.J.EQ.7)THEN
38454 C ELSEIF(J.EQ.2.OR.J.EQ.5.OR.J.EQ.8)THEN
38457 IF(JDAHKT(1,J).GT.0)THEN
38458 JDAHKK(1,I)=I+(JDAHKT(1,J)-J)
38460 PHKK(1,I) =PHKT(1,J)
38461 PHKK(2,I) =PHKT(2,J)
38462 PHKK(3,I) =PHKT(3,J)
38463 PHKK(4,I) =PHKT(4,J)
38464 PHKK(5,I) =PHKT(5,J)
38465 VHKK(1,I) =VHKT(1,J)
38466 VHKK(2,I) =VHKT(2,J)
38467 VHKK(3,I) =VHKT(3,J)
38468 VHKK(4,I) =VHKT(4,J)
38469 WHKK(1,I) =WHKT(1,J)
38470 WHKK(2,I) =WHKT(2,J)
38471 WHKK(3,I) =WHKT(3,J)
38472 WHKK(4,I) =WHKT(4,J)
38476 *$ CREATE DT_DBREAK.FOR
38479 *===dbreak=============================================================*
38481 SUBROUTINE DT_DBREAK(MODE)
38483 ************************************************************************
38484 * This is the steering subroutine for the different diquark breaking *
38487 * MODE = 1 breaking of projectile diquark in qq-q chain using *
38488 * a sea quark (q-qq chain) of the same projectile *
38489 * = 2 breaking of target diquark in q-qq chain using *
38490 * a sea quark (qq-q chain) of the same target *
38491 * = 3 breaking of projectile diquark in qq-q chain using *
38492 * a sea quark (q-aq chain) of the same projectile *
38493 * = 4 breaking of target diquark in q-qq chain using *
38494 * a sea quark (aq-q chain) of the same target *
38495 * = 5 breaking of projectile anti-diquark in aqaq-aq chain using *
38496 * a sea anti-quark (aq-aqaq chain) of the same projectile *
38497 * = 6 breaking of target anti-diquark in aq-aqaq chain using *
38498 * a sea anti-quark (aqaq-aq chain) of the same target *
38499 * = 7 breaking of projectile anti-diquark in aqaq-aq chain using *
38500 * a sea anti-quark (aq-q chain) of the same projectile *
38501 * = 8 breaking of target anti-diquark in aq-aqaq chain using *
38502 * a sea anti-quark (q-aq chain) of the same target *
38504 * Original version by J. Ranft. *
38505 * This version dated 17.5.00 is written by S. Roesler. *
38506 ************************************************************************
38508 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38511 PARAMETER ( LINP = 10 ,
38517 PARAMETER (NMXHKK=200000)
38519 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38520 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38521 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38523 * extended event history
38524 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38525 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38528 * flags for input different options
38529 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
38530 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
38531 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
38533 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
38534 PARAMETER (MAXCHN=10000)
38535 COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
38537 * diquark-breaking mechanism
38538 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
38540 * flags for particle decays
38541 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
38542 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
38543 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
38546 * chain identifiers
38547 * ( 1 = q-aq, 2 = aq-q, 3 = q-qq, 4 = qq-q,
38548 * 5 = aq-adq, 6 = adq-aq, 7 = dq-adq, 8 = adq-dq )
38549 DIMENSION IDCHN1(8),IDCHN2(8)
38550 DATA IDCHN1 / 4, 3, 4, 3, 6, 5, 6, 5/
38551 DATA IDCHN2 / 3, 4, 1, 2, 5, 6, 2, 1/
38553 * parton identifiers
38554 * ( +-21/22 = valence, +-31/32 = Glauber-sea, +-41/42 = Pomeron (diff),
38555 * +-51/52 = unitarity-sea, +-61/62 = gluons )
38556 DIMENSION ISP1P(8,3),ISP1T(8,3),ISP2P(8,3),ISP2T(8,3)
38557 DATA ISP1P / 21, 21, 21, 21, 21, 21, 21, 21,
38558 & 31, 31, 31, 31, 31, 31, 31, 31,
38559 & 41, 41, 41, 41, 51, 51, 51, 51/
38560 DATA ISP1T / 22, 22, 22, 22, 22, 22, 22, 22,
38561 & 32, 32, 32, 32, 32, 32, 32, 32,
38562 & 42, 42, 42, 42, 52, 52, 52, 52/
38563 DATA ISP2P / 31, 21, 31, 31, 21, 21, 21, 21,
38564 & 51, 31, 41, 41, 31, 31, 31, 31,
38565 & 0, 41, 51, 51, 51, 51, 51, 51/
38566 DATA ISP2T / 22, 32, 32, 32, 22, 22, 22, 22,
38567 & 32, 52, 42, 42, 32, 32, 32, 32,
38568 & 42, 0, 52, 52, 52, 52, 52, 52/
38570 IF (NCHAIN.LE.0) RETURN
38573 IS1P = ABS(ISTHKK(JMOHKK(1,IDX1)))
38574 IS1T = ABS(ISTHKK(JMOHKK(2,IDX1)))
38575 IF ( (IDXCHN(2,I).EQ.IDCHN1(MODE))
38577 & ((IS1P.EQ.ISP1P(MODE,1)).OR.(IS1P.EQ.ISP1P(MODE,2)).OR.
38578 & (IS1P.EQ.ISP1P(MODE,3)))
38580 & ((IS1T.EQ.ISP1T(MODE,1)).OR.(IS1T.EQ.ISP1T(MODE,2)).OR.
38581 & (IS1T.EQ.ISP1T(MODE,3)))
38585 IS2P = ABS(ISTHKK(JMOHKK(1,IDX2)))
38586 IS2T = ABS(ISTHKK(JMOHKK(2,IDX2)))
38587 IF ( (IDXCHN(2,J).EQ.IDCHN2(MODE))
38589 & ((IS2P.EQ.ISP2P(MODE,1)).OR.(IS2P.EQ.ISP2P(MODE,2))
38590 & .OR.(IS2P.EQ.ISP2P(MODE,3)))
38592 & ((IS2T.EQ.ISP2T(MODE,1)).OR.(IS2T.EQ.ISP2T(MODE,2))
38593 & .OR.(IS2T.EQ.ISP2T(MODE,3)))
38595 * find mother nucleons of the diquark to be splitted and of the
38596 * sea-quark and reject this combination if it is not the same
38597 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.
38598 & (MODE.EQ.5).OR.(MODE.EQ.7)) THEN
38603 IDXMO1 = JMOHKK(IANCES,IDX1)
38605 IF ((JMOHKK(1,IDXMO1).NE.0).AND.
38606 & (JMOHKK(2,IDXMO1).NE.0)) THEN
38611 IF (JMOHKK(IANC,IDXMO1).NE.0) THEN
38612 IDXMO1 = JMOHKK(IANC,IDXMO1)
38615 IDXMO2 = JMOHKK(IANCES,IDX2)
38617 IF ((JMOHKK(1,IDXMO2).NE.0).AND.
38618 & (JMOHKK(2,IDXMO2).NE.0)) THEN
38623 IF (JMOHKK(IANC,IDXMO2).NE.0) THEN
38624 IDXMO2 = JMOHKK(IANC,IDXMO2)
38627 IF (IDXMO1.NE.IDXMO2) GOTO 2
38628 * quark content of projectile parton
38629 IP1 = IDHKK(JMOHKK(1,IDX1))
38631 IP12 = (IP1-1000*IP11)/100
38632 IP2 = IDHKK(JMOHKK(2,IDX1))
38634 IP22 = (IP2-1000*IP21)/100
38635 * quark content of target parton
38636 IT1 = IDHKK(JMOHKK(1,IDX2))
38638 IT12 = (IT1-1000*IT11)/100
38639 IT2 = IDHKK(JMOHKK(2,IDX2))
38641 IT22 = (IT2-1000*IT21)/100
38642 * split diquark and form new chains
38643 IF (MODE.EQ.1) THEN
38644 IF (IT1.EQ.4) GOTO 2
38645 CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38646 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38647 & IP11,IP12,IP2,IT1,IT21,IT22,1,IPQ,IGCOUN)
38648 ELSEIF (MODE.EQ.2) THEN
38649 IF (IT2.EQ.4) GOTO 2
38650 CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38651 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38652 & IP1,IP21,IP22,IT11,IT12,IT2,1,IPQ,IGCOUN)
38653 ELSEIF (MODE.EQ.3) THEN
38654 IF (IT1.EQ.4) GOTO 2
38655 CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38656 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38657 & IP11,IP12,IP2,IT1,IT2,1,IPQ,IGCOUN)
38658 ELSEIF (MODE.EQ.4) THEN
38659 IF (IT2.EQ.4) GOTO 2
38660 CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38661 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38662 & IP1,IP21,IP22,IT1,IT2,1,IPQ,IGCOUN)
38663 ELSEIF (MODE.EQ.5) THEN
38664 CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38665 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38666 & IP11,IP12,IP2,IT1,IT21,IT22,2,IPQ,IGCOUN)
38667 ELSEIF (MODE.EQ.6) THEN
38668 CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38669 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38670 & IP1,IP21,IP22,IT11,IT12,IT2,2,IPQ,IGCOUN)
38671 ELSEIF (MODE.EQ.7) THEN
38672 CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38673 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38674 & IP11,IP12,IP2,IT1,IT2,2,IPQ,IGCOUN)
38675 ELSEIF (MODE.EQ.8) THEN
38676 CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38677 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38678 & IP1,IP21,IP22,IT1,IT2,2,IPQ,IGCOUN)
38680 IF (IREJ.GE.1) THEN
38681 if ((ipq.lt.0).or.(ipq.ge.4))
38682 & write(LOUT,*) 'ipq !!!',ipq,mode
38683 DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
38684 * accept or reject new chains corresponding to PDBSEA
38686 IF ((IPQ.EQ.1).OR.(IPQ.EQ.2)) THEN
38687 ACC = DBRKA(1,MODE)+DBRKA(2,MODE)
38688 REJ = DBRKR(1,MODE)+DBRKR(2,MODE)
38689 ELSEIF (IPQ.EQ.3) THEN
38690 ACC = DBRKA(3,MODE)
38691 REJ = DBRKR(3,MODE)
38693 WRITE(LOUT,*) ' inconsistent IPQ ! ',IPQ
38696 IF (ACC/(ACC+REJ).LE.PDBSEA(IPQ)) THEN
38697 DBRKA(IPQ,MODE) = DBRKA(IPQ,MODE)+1.0D0
38700 DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
38703 * new chains have been accepted and are now copied into HKKEVT
38704 IF (IACC.EQ.1) THEN
38706 CALL DT_EVTEMC(PHKK(1,IDX1),PHKK(2,IDX1),
38707 & PHKK(3,IDX1),PHKK(4,IDX1),
38709 CALL DT_EVTEMC(PHKK(1,IDX2),PHKK(2,IDX2),
38710 & PHKK(3,IDX2),PHKK(4,IDX2),
38713 IDHKK(IDX1) = 99888
38714 IDHKK(IDX2) = 99888
38719 CALL HKKHKT(NHKK,K)
38720 IF ((LEMCCK).AND.(IDHKK(NHKK).EQ.88888))THEN
38725 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
38730 CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,9000,
38732 IF (IREJ.NE.0) CALL DT_EVTOUT(4)
38744 *$ CREATE DT_CQPAIR.FOR
38747 *===cqpair=============================================================*
38749 SUBROUTINE DT_CQPAIR(XQMAX,XAQMAX,XQ,XAQ,IFLV,IREJ)
38751 ************************************************************************
38752 * This subroutine Creates a Quark-antiquark PAIR from the sea. *
38754 * XQMAX maxium energy fraction of quark (input) *
38755 * XAQMAX maxium energy fraction of antiquark (input) *
38756 * XQ energy fraction of quark (output) *
38757 * XAQ energy fraction of antiquark (output) *
38758 * IFLV quark flavour (- antiquark flavor) (output) *
38760 * This version dated 14.5.00 is written by S. Roesler. *
38761 ************************************************************************
38763 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38766 PARAMETER ( LINP = 10 ,
38770 * Lorentz-parameters of the current interaction
38771 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
38772 & UMO,PPCM,EPROJ,PPROJ
38779 * sample quark flavour
38781 * set seasq here (the one from DTCHAI should be used in the future)
38783 IFLV = INT(1.0D0+DT_RNDM(XQMAX)*(2.0D0+SEASQ))
38785 * sample energy fractions of sea pair
38786 * we first sample the energy fraction of a gluon and then split the gluon
38788 * maximum energy fraction of the gluon forced via input
38789 XGMAXI = XQMAX+XAQMAX
38790 * minimum energy fraction of the gluon
38791 XTHR1 = 4.0D0 /UMO**2
38792 XTHR2 = 0.54D0/UMO**1.5D0
38793 XGMIN = MAX(XTHR1,XTHR2)
38794 * maximum energy fraction of the gluon
38796 XGMAX = MIN(XGMAXI,XGMAX)
38797 IF (XGMIN.GE.XGMAX) THEN
38802 * sample energy fraction of the gluon
38806 IF (NLOOP.GE.50) THEN
38810 XGLUON = DT_SAMSQX(XGMIN,XGMAX)
38811 EGLUON = XGLUON*UMO/2.0D0
38813 * split gluon into q-aq pair (we follow PHOJET's subroutine PHO_GLU2QU)
38814 ZMIN = MIN(0.1D0,0.5D0/EGLUON)
38817 XHLP = ((1.0D0-RZ)*ZMIN**3+RZ*ZMAX**3)**0.33333
38819 IF (RQ.LT.0.5D0) THEN
38826 IF ((XQ.GT.XQMAX).OR.(XAQ.GT.XAQMAX)) GOTO 1