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)
57 * names of hadrons used in input-cards
59 COMMON /DTPAIN/ BTYPE(30)
60 * (original name: PAREVT)
61 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
62 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
63 PARAMETER ( NALLWP = 39 )
64 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
65 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
66 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
67 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
68 * (original name: INPFLG)
69 COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
70 * (original name: FRBKCM)
71 PARAMETER ( MXFFBK = 6 )
72 PARAMETER ( MXZFBK = 9 )
73 PARAMETER ( MXNFBK = 10 )
74 PARAMETER ( MXAFBK = 16 )
75 PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
76 PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
77 PARAMETER ( NXAFBK = MXAFBK + 1 )
78 PARAMETER ( MXPSST = 300 )
79 PARAMETER ( MXPSFB = 41000 )
80 LOGICAL LFRMBK, LNCMSS
81 COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
82 & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
83 & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
84 & IFRBKN (MXPSST), IFRBKZ (MXPSST),
85 & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
86 & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
87 & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
88 & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
89 & IFBFRB, NBUFBK, LFRMBK, LNCMSS
90 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
92 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
94 * Glauber formalism: parameters
95 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
96 & BMAX(NCOMPX),BSTEP(NCOMPX),
97 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
99 * Glauber formalism: cross sections
100 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
101 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
102 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
103 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
104 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
105 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
106 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
107 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
108 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
109 & BSLOPE,NEBINI,NQBINI
110 * interface HADRIN-DPM
111 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
112 * central particle production, impact parameter biasing
113 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
114 * parameter for intranuclear cascade
116 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
117 * various options for treatment of partons (DTUNUC 1.x)
118 * (chain recombination, Cronin,..)
119 LOGICAL LCO2CR,LINTPT
120 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
122 * threshold values for x-sampling (DTUNUC 1.x)
123 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
125 * flags for input different options
126 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
127 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
128 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
131 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
132 & EBINDP(2),EBINDN(2),EPOT(2,210),
133 & ETACOU(2),ICOUL,LFERMI
134 * n-n cross section fluctuations
135 PARAMETER (NBINS = 1000)
136 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
137 * flags for particle decays
138 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
139 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
140 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
141 * diquark-breaking mechanism
142 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
143 * nucleon-nucleon event-generator
146 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
147 * properties of interacting particles
148 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
149 * properties of photon/lepton projectiles
150 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
151 * flags for diffractive interactions (DTUNUC 1.x)
152 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
153 * parameters for hA-diffraction
154 COMMON /DTDIHA/ DIBETA,DIALPH
155 * Lorentz-parameters of the current interaction
156 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
157 & UMO,PPCM,EPROJ,PPROJ
158 * kinematical cuts for lepton-nucleus interactions
159 COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
160 & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
161 * VDM parameter for photon-nucleus interactions
162 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
163 * Glauber formalism: flags and parameters for statistics
166 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
167 * cuts for variable energy runs
168 COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
169 * flags for activated histograms
170 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
171 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
172 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
174 **LUND single / double precision
175 REAL CUT,PARL,TMPX,TMPY,TMPW2,TMPQ2,TMPU
176 COMMON /LEPTOU/ CUT(14),LST(40),PARL(30),
177 & TMPX,TMPY,TMPW2,TMPQ2,TMPU
180 COMMON /LEPTOI/ RPPN,LEPIN,INTER
181 * steering flags for qel neutrino scattering modules
182 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
184 COMMON /DTEVNO/ NEVENT,ICASCA
189 DIMENSION XDUMB(40),IPRANG(5)
191 PARAMETER (MXCARD=58)
192 CHARACTER*78 CLINE,CTITLE
194 CHARACTER*8 BLANK,SDUM
195 CHARACTER*10 CODE,CODEWD
197 LOGICAL LSTART,LEINP,LXSTAB
198 DIMENSION WHAT(6),CODE(MXCARD)
200 & 'TITLE ','PROJPAR ','TARPAR ','ENERGY ',
201 & 'MOMENTUM ','CMENERGY ','EMULSION ','FERMI ',
202 & 'TAUFOR ','PAULI ','COULOMB ','HADRIN ',
203 & 'EVAP ','EMCCHECK ','MODEL ','PHOINPUT ',
204 & 'GLAUBERI ','FLUCTUAT ','CENTRAL ','RECOMBIN ',
205 & 'COMBIJET ','XCUTS ','INTPT ','CRONINPT ',
206 & 'SEADISTR ','SEASU3 ','DIQUARKS ','RESONANC ',
207 & 'DIFFRACT ','SINGLECH ','NOFRAGME ','HADRONIZE ',
208 & 'POPCORN ','PARDECAY ','BEAM ','LUND-MSTU ',
209 & 'LUND-MSTJ ','LUND-MDCY ','LUND-PARJ ','LUND-PARU ',
210 & 'OUTLEVEL ','FRAME ','L-TAG ','L-ETAG ',
211 & 'ECMS-CUT ','VDM-PAR1 ','HISTOGRAM ','XS-TABLE ',
212 & 'GLAUB-PAR ','GLAUB-INI ','VDM-PAR2 ','XS-QELPRO ',
213 & 'RNDMINIT ','LEPTO-CUT ','LEPTO-LST ','LEPTO-PARL',
217 DATA LSTART,LXSTAB,IFIRST /.TRUE.,.FALSE.,1/
220 *---------------------------------------------------------------------
221 * at the first call of INIT: initialize event generation
225 * initialization and test of the random number generator
226 IF (ITRSPT.NE.1) THEN
227 CALL DT_RNDMST(22,54,76,92)
230 * initialization of BAMJET, DECAY and HADRIN
235 * set default values for input variables
236 CALL DT_DEFAUL(EPN,PPN)
239 * flag for collision energy input
244 *---------------------------------------------------------------------
247 * bypass reading input cards (e.g. for use with Fluka)
248 * in this case Epn is expected to carry the beam momentum
249 IF (NCASES.EQ.-1) THEN
263 * read control card from input-unit LINP
264 READ(LINP,'(A78)',END=9999) CLINE
265 IF (CLINE(1:1).EQ.'*') THEN
267 WRITE(LOUT,'(A78)') CLINE
270 C READ(CLINE,1000,END=9999) CODEWD,(WHAT(I),I=1,6),SDUM
271 C1000 FORMAT(A10,6E10.0,A8)
275 READ(CLINE,1006,END=9999) CODEWD,CWHAT,SDUM
276 1006 FORMAT(A10,A60,A8)
277 READ(CWHAT,*,END=1007) (WHAT(I),I=1,6)
279 WRITE(LOUT,1001) CODEWD,(WHAT(I),I=1,6),SDUM
280 1001 FORMAT(A10,6G10.3,A8)
284 * check for valid control card and get card index
287 IF (CODEWD.EQ.CODE(I)) ICW = I
290 WRITE(LOUT,1002) CODEWD
291 1002 FORMAT(/,1X,'---> ',A10,': invalid control-card !',/)
296 *------------------------------------------------------------
297 * TITLE , PROJPAR , TARPAR , ENERGY , MOMENTUM,
298 & 100 , 110 , 120 , 130 , 140 ,
300 *------------------------------------------------------------
301 * CMENERGY, EMULSION, FERMI , TAUFOR , PAULI ,
302 & 150 , 160 , 170 , 180 , 190 ,
304 *------------------------------------------------------------
305 * COULOMB , HADRIN , EVAP , EMCCHECK, MODEL ,
306 & 200 , 210 , 220 , 230 , 240 ,
308 *------------------------------------------------------------
309 * PHOINPUT, GLAUBERI, FLUCTUAT, CENTRAL , RECOMBIN,
310 & 250 , 260 , 270 , 280 , 290 ,
312 *------------------------------------------------------------
313 * COMBIJET, XCUTS , INTPT , CRONINPT, SEADISTR,
314 & 300 , 310 , 320 , 330 , 340 ,
316 *------------------------------------------------------------
317 * SEASU3 , DIQUARKS, RESONANC, DIFFRACT, SINGLECH,
318 & 350 , 360 , 370 , 380 , 390 ,
320 *------------------------------------------------------------
321 * NOFRAGME, HADRONIZE, POPCORN , PARDECAY, BEAM ,
322 & 400 , 410 , 420 , 430 , 440 ,
324 *------------------------------------------------------------
325 * LUND-MSTU, LUND-MSTJ, LUND-MDCY, LUND-PARJ, LUND-PARU,
326 & 450 , 451 , 452 , 460 , 470 ,
328 *------------------------------------------------------------
329 * OUTLEVEL, FRAME , L-TAG , L-ETAG , ECMS-CUT,
330 & 480 , 490 , 500 , 510 , 520 ,
332 *------------------------------------------------------------
333 * VDM-PAR1, HISTOGRAM, XS-TABLE , GLAUB-PAR, GLAUB-INI,
334 & 530 , 540 , 550 , 560 , 565 ,
336 *------------------------------------------------------------
337 * , , VDM-PAR2, XS-QELPRO, RNDMINIT ,
340 *------------------------------------------------------------
341 * LEPTO-CUT, LEPTO-LST,LEPTO-PARL, START , STOP )
342 & 600 , 610 , 620 , 630 , 640 ) , ICW
344 *------------------------------------------------------------
348 *********************************************************************
350 * control card: codewd = TITLE *
352 * what (1..6), sdum no meaning *
354 * Note: The control-card following this must consist of *
355 * a string of characters usually giving the title of *
358 *********************************************************************
361 READ(LINP,'(A78)') CTITLE
362 WRITE(LOUT,'(//,5X,A78,//)') CTITLE
365 *********************************************************************
367 * control card: codewd = PROJPAR *
369 * what (1) = mass number of projectile nucleus default: 1 *
370 * what (2) = charge of projectile nucleus default: 1 *
371 * what (3..6) no meaning *
372 * sdum projectile particle code word *
374 * Note: If sdum is defined what (1..2) have no meaning. *
376 *********************************************************************
379 IF (SDUM.EQ.BLANK) THEN
387 IF (SDUM.EQ.BTYPE(II)) THEN
392 ELSEIF (II.EQ.27) THEN
394 ELSEIF (II.EQ.28) THEN
396 ELSEIF (II.EQ.29) THEN
401 IBPROJ = IIBAR(IJPROJ)
403 IF ((IJPROJ.EQ.7).AND.(WHAT(1).GT.ZERO)) VIRT = WHAT(1)
405 IF (((IJPROJ.EQ. 3).OR.(IJPROJ.EQ. 4).OR.
406 & (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11)).AND.
407 & (WHAT(1).GT.ZERO)) Q2HI = WHAT(1)
410 IF (IJPROJ.EQ.0) THEN
412 1110 FORMAT(/,1X,'invalid PROJPAR card !',/)
418 *********************************************************************
420 * control card: codewd = TARPAR *
422 * what (1) = mass number of target nucleus default: 1 *
423 * what (2) = charge of target nucleus default: 1 *
424 * what (3..6) no meaning *
425 * sdum target particle code word *
427 * Note: If sdum is defined what (1..2) have no meaning. *
429 *********************************************************************
432 IF (SDUM.EQ.BLANK) THEN
440 IF (SDUM.EQ.BTYPE(II)) THEN
444 IBTARG = IIBAR(IJTARG)
447 IF (IJTARG.EQ.0) THEN
449 1120 FORMAT(/,1X,'invalid TARPAR card !',/)
455 *********************************************************************
457 * control card: codewd = ENERGY *
459 * what (1) = energy (GeV) of projectile in Lab. *
460 * if what(1) < 0: |what(1)| = kinetic energy *
462 * if |what(2)| > 0: min. energy for variable *
464 * what (2) = max. energy for variable energy runs *
465 * if what(2) < 0: |what(2)| = kinetic energy *
467 *********************************************************************
473 IF ((ABS(WHAT(2)).GT.ZERO).AND.
474 & (ABS(WHAT(2)).GT.ABS(WHAT(1)))) THEN
482 *********************************************************************
484 * control card: codewd = MOMENTUM *
486 * what (1) = momentum (GeV/c) of projectile in Lab. *
487 * default: 200 GeV/c *
488 * what (2..6), sdum no meaning *
490 *********************************************************************
499 *********************************************************************
501 * control card: codewd = CMENERGY *
503 * what (1) = energy in nucleon-nucleon cms. *
505 * what (2..6), sdum no meaning *
507 *********************************************************************
516 *********************************************************************
518 * control card: codewd = EMULSION *
520 * definition of nuclear emulsions *
522 * what(1) mass number of emulsion component *
523 * what(2) charge of emulsion component *
524 * what(3) fraction of events in which a scattering on a *
525 * nucleus of this properties is performed *
526 * what(4,5,6) as what(1,2,3) but for another component *
527 * default: no emulsion *
530 * Note: If this input-card is once used with valid parameters *
531 * TARPAR is obsolete. *
532 * Not the absolute values of the fractions are important *
533 * but only the ratios of fractions of different comp. *
534 * This control card can be repeatedly used to define *
535 * emulsions consisting of up to 10 elements. *
537 *********************************************************************
540 IF ((WHAT(1).GT.ZERO).AND.(WHAT(2).GT.ZERO)
541 & .AND.(ABS(WHAT(3)).GT.ZERO)) THEN
543 IF (NCOMPO.GT.NCOMPX) THEN
547 IEMUMA(NCOMPO) = INT(WHAT(1))
548 IEMUCH(NCOMPO) = INT(WHAT(2))
549 EMUFRA(NCOMPO) = WHAT(3)
551 C CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO))
553 IF ((WHAT(4).GT.ZERO).AND.(WHAT(5).GT.ZERO)
554 & .AND.(ABS(WHAT(6)).GT.ZERO)) THEN
556 IF (NCOMPO.GT.NCOMPX) THEN
560 IEMUMA(NCOMPO) = INT(WHAT(4))
561 IEMUCH(NCOMPO) = INT(WHAT(5))
562 EMUFRA(NCOMPO) = WHAT(6)
563 C CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO))
565 1600 FORMAT(1X,'too many emulsion components - program stopped')
568 *********************************************************************
570 * control card: codewd = FERMI *
572 * what (1) = -1 Fermi-motion of nucleons not treated *
574 * what (2) = scale factor for Fermi-momentum *
576 * what (3..6), sdum no meaning *
578 *********************************************************************
581 IF (WHAT(1).EQ.-1.0D0) THEN
587 IF (XMOD.GE.ZERO) FERMOD = XMOD
590 *********************************************************************
592 * control card: codewd = TAUFOR *
594 * formation time supressed intranuclear cascade *
596 * what (1) formation time (in fm/c) *
597 * note: what(1)=10. corresponds roughly to an *
598 * average formation time of 1 fm/c *
600 * what (2) number of generations followed *
602 * what (3) = 1. p_t-dependent formation zone *
603 * = 2. constant formation zone *
605 * what (4) modus of selection of nucleus where the *
606 * cascade if followed first *
607 * = 1. proj./target-nucleus with probab. 1/2 *
608 * = 2. nucleus with highest mass *
609 * = 3. proj. nucleus if particle is moving in pos. z *
610 * targ. nucleus if particle is moving in neg. z *
612 * what (5..6), sdum no meaning *
614 *********************************************************************
618 KTAUGE = INT(WHAT(2))
620 IF ((WHAT(3).GE.1.0D0).AND.(WHAT(3).LE.2.0D0))
621 & ITAUVE = INT(WHAT(3))
622 IF ((WHAT(4).GE.1.0D0).AND.(WHAT(4).LE.3.0D0))
623 & INCMOD = INT(WHAT(4))
626 *********************************************************************
628 * control card: codewd = PAULI *
630 * what (1) = -1 Pauli's principle for secondary *
631 * interactions not treated *
633 * what (2..6), sdum no meaning *
635 *********************************************************************
638 IF (WHAT(1).EQ.-1.0D0) THEN
645 *********************************************************************
647 * control card: codewd = COULOMB *
649 * what (1) = -1. Coulomb-energy treatment switched off *
651 * what (2..6), sdum no meaning *
653 *********************************************************************
657 IF (WHAT(1).EQ.-1.0D0) THEN
664 *********************************************************************
666 * control card: codewd = HADRIN *
670 * what (1) = 0. elastic/inelastic interactions with probab. *
671 * as defined by cross-sections *
672 * = 1. inelastic interactions forced *
673 * = 2. elastic interactions forced *
675 * what (2) upper threshold in total energy (GeV) below *
676 * which interactions are sampled by HADRIN *
678 * what (3..6), sdum no meaning *
680 *********************************************************************
684 IF ((IWHAT.GE.0).AND.(IWHAT.LE.2)) INTHAD = IWHAT
685 IF ((WHAT(2).GT.ZERO).AND.(WHAT(2).LT.15.0D0)) EHADTH = WHAT(2)
688 *********************************************************************
690 * control card: codewd = EVAP *
692 * evaporation module *
694 * what (1) =< -1 ==> evaporation is switched off *
695 * >= 1 ==> evaporation is performed *
697 * what (1) = i1 + i2*10 + i3*100 + i4*10000 *
698 * (i1, i2, i3, i4 >= 0 ) *
700 * i1 is the flag for selecting the T=0 level density option used *
701 * = 1: standard EVAP level densities with Cook pairing *
703 * = 2: Z,N-dependent Gilbert & Cameron level densities *
705 * = 3: Julich A-dependent level densities *
706 * = 4: Z,N-dependent Brancazio & Cameron level densities *
708 * i2 >= 1: high energy fission activated *
709 * (default high energy fission activated) *
711 * i3 = 0: No energy dependence for level densities *
712 * = 1: Standard Ignyatuk (1975, 1st) energy dependence *
713 * for level densities (default) *
714 * = 2: Standard Ignyatuk (1975, 1st) energy dependence *
715 * for level densities with NOT used set of parameters *
716 * = 3: Standard Ignyatuk (1975, 1st) energy dependence *
717 * for level densities with NOT used set of parameters *
718 * = 4: Second Ignyatuk (1975, 2nd) energy dependence *
719 * for level densities *
720 * = 5: Second Ignyatuk (1975, 2nd) energy dependence *
721 * for level densities with fit 1 Iljinov & Mebel set of *
723 * = 6: Second Ignyatuk (1975, 2nd) energy dependence *
724 * for level densities with fit 2 Iljinov & Mebel set of *
726 * = 7: Second Ignyatuk (1975, 2nd) energy dependence *
727 * for level densities with fit 3 Iljinov & Mebel set of *
729 * = 8: Second Ignyatuk (1975, 2nd) energy dependence *
730 * for level densities with fit 4 Iljinov & Mebel set of *
733 * i4 >= 1: Original Gilbert and Cameron pairing energies used *
734 * (default Cook's modified pairing energies) *
736 * what (2) = ig + 10 * if (ig and if must have the same sign) *
738 * ig =< -1 ==> deexcitation gammas are not produced *
739 * (if the evaporation step is not performed *
740 * they are never produced) *
741 * if =< -1 ==> Fermi Break Up is not invoked *
742 * (if the evaporation step is not performed *
743 * it is never invoked) *
744 * The default is: deexcitation gamma produced and Fermi break up *
745 * activated for the new preequilibrium, not *
746 * activated otherwise. *
747 * what (3..6), sdum no meaning *
749 *********************************************************************
753 1009 FORMAT(1X,/,'Warning! Evaporation request rejected since',
754 & ' evaporation modules not available with this version.')
764 *********************************************************************
766 * control card: codewd = EMCCHECK *
768 * extended energy-momentum / quantum-number conservation check *
770 * what (1) = -1 extended check not performed *
772 * what (2..6), sdum no meaning *
774 *********************************************************************
777 IF (WHAT(1).EQ.-1) THEN
784 *********************************************************************
786 * control card: codewd = MODEL *
788 * Model to be used to treat nucleon-nucleon interactions *
790 * sdum = DTUNUC two-chain model *
791 * = PHOJET multiple chains including minijets *
793 * = QNEUTRIN quasi-elastic neutrino scattering *
797 * what (1) (variable INTER) *
798 * = 1 gamma exchange *
801 * = 4 gamma/Z0 exchange *
803 * if sdum = QNEUTRIN: *
804 * what (1) = 0 elastic scattering on nucleon and *
805 * tau does not decay (default) *
806 * = 1 decay of tau into mu.. *
807 * = 2 decay of tau into e.. *
808 * = 10 CC events on p and n *
809 * = 11 NC events on p and n *
811 * what (2..6) no meaning *
813 *********************************************************************
816 IF (SDUM.EQ.CMODEL(1)) THEN
818 ELSEIF (SDUM.EQ.CMODEL(2)) THEN
820 ELSEIF (SDUM.EQ.CMODEL(3)) THEN
822 IF ((WHAT(1).GE.1.0D0).AND.(WHAT(1).LE.4.0D0))
823 & INTER = INT(WHAT(1))
824 ELSEIF (SDUM.EQ.CMODEL(4)) THEN
827 IF ((IWHAT.EQ.1 ).OR.(IWHAT.EQ.2 ).OR.
828 & (IWHAT.EQ.10).OR.(IWHAT.EQ.11))
831 STOP ' Unknown model !'
835 *********************************************************************
837 * control card: codewd = PHOINPUT *
839 * Start of input-section for PHOJET-specific input-cards *
840 * Note: This section will not be finished before giving *
842 * what (1..6), sdum no meaning *
844 *********************************************************************
848 CALL PHO_INIT(LINP,LOUT,IREJ1)
850 WRITE(LOUT,'(1X,A)')'INIT: reading PHOJET-input failed'
857 *********************************************************************
859 * control card: codewd = GLAUBERI *
861 * Pre-initialization of impact parameter selection *
863 * what (1..6), sdum no meaning *
865 *********************************************************************
868 IF (IFIRST.NE.99) THEN
869 CALL DT_RNDMST(12,34,56,78)
871 OPEN(40,FILE='outdata0/shm.out',STATUS='UNKNOWN')
872 C OPEN(11,FILE='outdata0/shm.dbg',STATUS='UNKNOWN')
883 ADP = (APHI-APLOW)/DBLE(IPPN)
904 IT = ITLOW+(NCIT-1)*IDIT
907 C IIP = (IPHI-IPLOW)/IDIP
908 C IF (IIP.EQ.0) IIP = 1
909 C IF (IT.EQ.IPLOW) IIP = 0
913 CC IF (NCIP.LE.IIP) THEN
914 C IP = IPLOW+(NCIP-1)*IDIP
918 IF (IP.GT.IT) GOTO 472
921 APPN = APLOW+DBLE(NCP-1)*ADP
924 OPEN(12,FILE='outdata0/shm.sta',STATUS='UNKNOWN')
925 WRITE(12,'(1X,2I5,E15.3)') IP,IT,PPN
932 CALL DT_NEWHGR(XDUM,XDUM,XDUM,XDUMB,-1,IHDUM)
933 CALL DT_NEWHGR(XLIM1,XLIM2,XLIM3,XDUMB,IBIN,IHSHMA)
936 C IF ((IP.GT.10).OR.(IT.GT.10)) THEN
944 CALL DT_SHMAKI(IP,IDUM1,IT,IDUM1,IJPROJ,PPN,99)
945 SIGAV = SIGAV+XSPRO(1,1,1)
948 CALL DT_FILHGR(XC,BSITE(1,1,1,J),IHSHMA,I)
954 C CALL OUTGEN(IHSHMA,0,0,0,0,0,HEADER,0,NEVFIT,ONE,0,1,-1)
957 C WRITE(40,'(2I4,E11.3,F6.0,5E11.3)')
958 C & IP,IT,PPN,SIGAV/DBLE(NEVFIT),XPARA
968 *********************************************************************
970 * control card: codewd = FLUCTUAT *
972 * Treatment of cross section fluctuations *
974 * what (1) = 1 treat cross section fluctuations *
976 * what (1..6), sdum no meaning *
978 *********************************************************************
982 IF (WHAT(1).EQ.ONE) THEN
988 *********************************************************************
990 * control card: codewd = CENTRAL *
992 * what (1) = 1. central production forced default: 0 *
993 * if what (1) < 0 and > -100 *
994 * what (2) = min. impact parameter default: 0 *
995 * what (3) = max. impact parameter default: b_max *
996 * if what (1) < -99 *
997 * what (2) = fraction of cross section default: 1 *
998 * if what (1) = -1 : evaporation/fzc suppressed *
999 * if what (1) < -1 : evaporation/fzc allowed *
1001 * what (4..6), sdum no meaning *
1003 *********************************************************************
1006 ICENTR = INT(WHAT(1))
1007 IF (ICENTR.LT.0) THEN
1008 IF (ICENTR.GT.-100) THEN
1017 *********************************************************************
1019 * control card: codewd = RECOMBIN *
1021 * Chain recombination *
1022 * (recombine S-S and V-V chains to V-S chains) *
1024 * what (1) = -1. recombination switched off default: 1 *
1025 * what (2..6), sdum no meaning *
1027 *********************************************************************
1031 IF (WHAT(1).EQ.-1.0D0) IRECOM = 0
1034 *********************************************************************
1036 * control card: codewd = COMBIJET *
1038 * chain fusion (2 q-aq --> qq-aqaq) *
1040 * what (1) = 1 fusion treated *
1042 * what (2) minimum number of uncombined chains from *
1043 * single projectile or target nucleons *
1045 * what (3..6), sdum no meaning *
1047 *********************************************************************
1051 IF (INT(WHAT(1)).EQ.1) LCO2CR = .TRUE.
1052 IF (WHAT(2).GE.ZERO) CUTOF = WHAT(2)
1055 *********************************************************************
1057 * control card: codewd = XCUTS *
1059 * thresholds for x-sampling *
1061 * what (1) defines lower threshold for val.-q x-value (CVQ) *
1063 * what (2) defines lower threshold for val.-qq x-value (CDQ) *
1065 * what (3) defines lower threshold for sea-q x-value (CSEA) *
1067 * what (4) sea-q x-values in S-S chains (SSMIMA) *
1069 * what (5) not used *
1071 * what (6), sdum no meaning *
1073 * Note: Lower thresholds (what(1..3)) are def. as x_thr=CXXX/ECM *
1075 *********************************************************************
1078 IF (WHAT(1).GE.0.5D0) CVQ = WHAT(1)
1079 IF (WHAT(2).GE.ONE) CDQ = WHAT(2)
1080 IF (WHAT(3).GE.0.1D0) CSEA = WHAT(3)
1081 IF (WHAT(4).GE.ZERO) THEN
1085 IF (WHAT(5).GT.2.0D0) VVMTHR = WHAT(5)
1088 *********************************************************************
1090 * control card: codewd = INTPT *
1092 * what (1) = -1 intrinsic transverse momenta of partons *
1093 * not treated default: 1 *
1094 * what (2..6), sdum no meaning *
1096 *********************************************************************
1099 IF (WHAT(1).EQ.-1.0D0) THEN
1106 *********************************************************************
1108 * control card: codewd = CRONINPT *
1110 * Cronin effect (multiple scattering of partons at chain ends) *
1112 * what (1) = -1 Cronin effect not treated default: 1 *
1113 * what (2) = 0 scattering parameter default: 0.64 *
1114 * what (3..6), sdum no meaning *
1116 *********************************************************************
1119 IF (WHAT(1).EQ.-1.0D0) THEN
1127 *********************************************************************
1129 * control card: codewd = SEADISTR *
1131 * what (1) (XSEACO) sea(x) prop. 1/x**what (1) default: 1. *
1132 * what (2) (UNON) default: 2. *
1133 * what (3) (UNOM) default: 1.5 *
1134 * what (4) (UNOSEA) default: 5. *
1135 * qdis(x) prop. (1-x)**what (1) etc. *
1136 * what (5..6), sdum no meaning *
1138 *********************************************************************
1142 XSEACU = 1.05D0-XSEACO
1144 IF (UNON.LT.0.1D0) UNON = 2.0D0
1146 IF (UNOM.LT.0.1D0) UNOM = 1.5D0
1148 IF (UNOSEA.LT.0.1D0) UNOSEA = 5.0D0
1151 *********************************************************************
1153 * control card: codewd = SEASU3 *
1155 * Treatment of strange-quarks at chain ends *
1157 * what (1) (SEASQ) strange-quark supression factor *
1158 * iflav = 1.+rndm*(2.+SEASQ) *
1160 * what (2..6), sdum no meaning *
1162 *********************************************************************
1168 *********************************************************************
1170 * control card: codewd = DIQUARKS *
1172 * what (1) = -1. sea-diquark/antidiquark-pairs not treated *
1174 * what (2..6), sdum no meaning *
1176 *********************************************************************
1179 IF (WHAT(1).EQ.-1.0D0) THEN
1186 *********************************************************************
1188 * control card: codewd = RESONANC *
1190 * treatment of low mass chains *
1192 * what (1) = -1 low chain masses are not corrected for resonance *
1193 * masses (obsolete for BAMJET-fragmentation) *
1195 * what (2) = -1 massless partons default: 1. (massive) *
1196 * default: 1. (massive) *
1197 * what (3) = -1 chain-system containing chain of too small *
1198 * mass is rejected (note: this does not fully *
1199 * apply to S-S chains) default: 0. *
1200 * what (4..6), sdum no meaning *
1202 *********************************************************************
1208 IF (WHAT(1).EQ.-ONE) IRESCO = 0
1209 IF (WHAT(2).EQ.-ONE) IMSHL = 0
1210 IF (WHAT(3).EQ.-ONE) IRESRJ = 1
1213 *********************************************************************
1215 * control card: codewd = DIFFRACT *
1217 * Treatment of diffractive events *
1219 * what (1) = (ISINGD) 0 no single diffraction *
1220 * 1 single diffraction included *
1221 * +-2 single diffractive events only *
1222 * +-3 projectile single diffraction only *
1223 * +-4 target single diffraction only *
1224 * -5 double pomeron exchange only *
1225 * (neg. sign applies to PHOJET events) *
1228 * what (2) = (IDOUBD) 0 no double diffraction *
1229 * 1 double diffraction included *
1230 * 2 double diffractive events only *
1232 * what (3) = 1 projectile diffraction treated (2-channel form.) *
1234 * what (4) = alpha-parameter in projectile diffraction *
1236 * what (5..6), sdum no meaning *
1238 *********************************************************************
1241 IF (ABS(WHAT(1)).GT.ZERO) ISINGD = INT(WHAT(1))
1242 IF (ABS(WHAT(2)).GT.ZERO) IDOUBD = INT(WHAT(2))
1243 IF ((ISINGD.GT.1).AND.(IDOUBD.GT.1)) THEN
1245 1380 FORMAT(1X,'INIT: inconsistent DIFFRACT - input !',/,
1246 & 11X,'IDOUBD is reset to zero')
1249 IF (WHAT(3).GT.ZERO) DIBETA = WHAT(3)
1250 IF (WHAT(4).GT.ZERO) DIALPH = WHAT(4)
1253 *********************************************************************
1255 * control card: codewd = SINGLECH *
1257 * what (1) = 1. Regge contribution (one chain) included *
1259 * what (2..6), sdum no meaning *
1261 *********************************************************************
1265 IF (WHAT(1).EQ.ONE) ISICHA = 1
1268 *********************************************************************
1270 * control card: codewd = NOFRAGME *
1272 * biased chain hadronization *
1274 * what (1..6) = -1 no of hadronizsation of S-S chains *
1275 * = -2 no of hadronizsation of D-S chains *
1276 * = -3 no of hadronizsation of S-D chains *
1277 * = -4 no of hadronizsation of S-V chains *
1278 * = -5 no of hadronizsation of D-V chains *
1279 * = -6 no of hadronizsation of V-S chains *
1280 * = -7 no of hadronizsation of V-D chains *
1281 * = -8 no of hadronizsation of V-V chains *
1282 * = -9 no of hadronizsation of comb. chains *
1283 * default: complete hadronization *
1286 *********************************************************************
1290 ICHAIN = INT(WHAT(I))
1291 IF ((ICHAIN.LE.-1).AND.(ICHAIN.GE.-9))
1292 & LHADRO(ABS(ICHAIN)) = .FALSE.
1296 *********************************************************************
1298 * control card: codewd = HADRONIZE *
1300 * hadronization model and parameter switch *
1302 * what (1) = 1 hadronization via BAMJET *
1303 * = 2 hadronization via JETSET *
1305 * what (2) = 1..3 parameter set to be used *
1306 * JETSET: 3 sets available *
1307 * ( = 3 default JETSET-parameters) *
1308 * BAMJET: 1 set available *
1310 * what (3..6), sdum no meaning *
1312 *********************************************************************
1315 IWHAT1 = INT(WHAT(1))
1316 IWHAT2 = INT(WHAT(2))
1317 IF ((IWHAT1.EQ.1).OR.(IWHAT1.EQ.2)) IFRAG(1) = IWHAT1
1318 IF ((IWHAT1.EQ.2).AND.(IWHAT2.GE.1).AND.(IWHAT2.LE.3))
1322 *********************************************************************
1324 * control card: codewd = POPCORN *
1326 * "Popcorn-effect" in fragmentation and diquark breaking diagrams *
1328 * what (1) = (PDB) frac. of diquark fragmenting directly into *
1329 * baryons (PYTHIA/JETSET fragmentation) *
1330 * (JETSET: = 0. Popcorn mechanism switched off) *
1332 * what (2) = probability for accepting a diquark breaking *
1333 * diagram involving the generation of a u/d quark- *
1334 * antiquark pair default: 0.0 *
1335 * what (3) = same a what (2), here for s quark-antiquark pair *
1337 * what (4..6), sdum no meaning *
1339 *********************************************************************
1342 IF (WHAT(1).GE.0.0D0) PDB = WHAT(1)
1343 IF (WHAT(2).GE.0.0D0) THEN
1347 IF (WHAT(3).GE.0.0D0) PDBSEA(3) = WHAT(3)
1349 DBRKA(1,I) = DBRKR(1,I)*PDBSEA(1)/(1.D0-PDBSEA(1))
1350 DBRKA(2,I) = DBRKR(2,I)*PDBSEA(2)/(1.D0-PDBSEA(2))
1351 DBRKA(3,I) = DBRKR(3,I)*PDBSEA(3)/(1.D0-PDBSEA(3))
1355 *********************************************************************
1357 * control card: codewd = PARDECAY *
1359 * what (1) = 1. Sigma0/Asigma0 are decaying within JETSET *
1360 * = 2. pion^0 decay after intranucl. cascade *
1361 * default: no decay *
1362 * what (2..6), sdum no meaning *
1364 *********************************************************************
1367 IF (WHAT(1).EQ.ONE) ISIG0 = 1
1368 IF (WHAT(1).EQ.2.0D0) IPI0 = 1
1371 *********************************************************************
1373 * control card: codewd = BEAM *
1375 * definition of beam parameters *
1377 * what (1/2) > 0 : energy of beam 1/2 (GeV) *
1378 * < 0 : abs(what(1/2)) energy per charge of *
1380 * (beam 1 is directed into positive z-direction) *
1381 * what (3) beam crossing angle, defined as 2x angle between *
1382 * one beam and the z-axis (micro rad) *
1383 * what (4) angle with x-axis defining the collision plane *
1384 * what (5..6), sdum no meaning *
1386 * Note: this card requires previously defined projectile and *
1387 * target identities (PROJPAR, TARPAR) *
1389 *********************************************************************
1392 CALL DT_BEAMPR(WHAT,PPN,1)
1398 *********************************************************************
1400 * control card: codewd = LUND-MSTU *
1402 * set parameter MSTU in JETSET-common /LUDAT1/ *
1404 * what (1) = index according to LUND-common block *
1405 * what (2) = new value of MSTU( int(what(1)) ) *
1406 * what (3), what(4) and what (5), what(6) further *
1407 * parameter in the same way as what (1) and *
1409 * default: default-Lund or corresponding to *
1410 * the set given in HADRONIZE *
1412 *********************************************************************
1415 IF (WHAT(1).GT.ZERO) THEN
1417 IMSTU(NMSTU) = INT(WHAT(1))
1418 MSTUX(NMSTU) = INT(WHAT(2))
1420 IF (WHAT(3).GT.ZERO) THEN
1422 IMSTU(NMSTU) = INT(WHAT(3))
1423 MSTUX(NMSTU) = INT(WHAT(4))
1425 IF (WHAT(5).GT.ZERO) THEN
1427 IMSTU(NMSTU) = INT(WHAT(5))
1428 MSTUX(NMSTU) = INT(WHAT(6))
1432 *********************************************************************
1434 * control card: codewd = LUND-MSTJ *
1436 * set parameter MSTJ in JETSET-common /LUDAT1/ *
1438 * what (1) = index according to LUND-common block *
1439 * what (2) = new value of MSTJ( int(what(1)) ) *
1440 * what (3), what(4) and what (5), what(6) further *
1441 * parameter in the same way as what (1) and *
1443 * default: default-Lund or corresponding to *
1444 * the set given in HADRONIZE *
1446 *********************************************************************
1449 IF (WHAT(1).GT.ZERO) THEN
1451 IMSTJ(NMSTJ) = INT(WHAT(1))
1452 MSTJX(NMSTJ) = INT(WHAT(2))
1454 IF (WHAT(3).GT.ZERO) THEN
1456 IMSTJ(NMSTJ) = INT(WHAT(3))
1457 MSTJX(NMSTJ) = INT(WHAT(4))
1459 IF (WHAT(5).GT.ZERO) THEN
1461 IMSTJ(NMSTJ) = INT(WHAT(5))
1462 MSTJX(NMSTJ) = INT(WHAT(6))
1466 *********************************************************************
1468 * control card: codewd = LUND-MDCY *
1470 * set parameter MDCY(I,1) for particle decays in JETSET-common *
1473 * what (1-6) = PDG particle index of particle which should *
1475 * default: default-Lund or forced in *
1478 *********************************************************************
1482 IF (WHAT(I).NE.ZERO) THEN
1483 KC = PYCOMP(INT(WHAT(I)))
1489 *********************************************************************
1491 * control card: codewd = LUND-PARJ *
1493 * set parameter PARJ in JETSET-common /LUDAT1/ *
1495 * what (1) = index according to LUND-common block *
1496 * what (2) = new value of PARJ( int(what(1)) ) *
1497 * what (3), what(4) and what (5), what(6) further *
1498 * parameter in the same way as what (1) and *
1500 * default: default-Lund or corresponding to *
1501 * the set given in HADRONIZE *
1503 *********************************************************************
1506 IF (WHAT(1).NE.ZERO) THEN
1508 IPARJ(NPARJ) = INT(WHAT(1))
1509 PARJX(NPARJ) = WHAT(2)
1511 IF (WHAT(3).NE.ZERO) THEN
1513 IPARJ(NPARJ) = INT(WHAT(3))
1514 PARJX(NPARJ) = WHAT(4)
1516 IF (WHAT(5).NE.ZERO) THEN
1518 IPARJ(NPARJ) = INT(WHAT(5))
1519 PARJX(NPARJ) = WHAT(6)
1523 *********************************************************************
1525 * control card: codewd = LUND-PARU *
1527 * set parameter PARJ in JETSET-common /LUDAT1/ *
1529 * what (1) = index according to LUND-common block *
1530 * what (2) = new value of PARU( int(what(1)) ) *
1531 * what (3), what(4) and what (5), what(6) further *
1532 * parameter in the same way as what (1) and *
1534 * default: default-Lund or corresponding to *
1535 * the set given in HADRONIZE *
1537 *********************************************************************
1540 IF (WHAT(1).GT.ZERO) THEN
1542 IPARU(NPARU) = INT(WHAT(1))
1543 PARUX(NPARU) = WHAT(2)
1545 IF (WHAT(3).GT.ZERO) THEN
1547 IPARU(NPARU) = INT(WHAT(3))
1548 PARUX(NPARU) = WHAT(4)
1550 IF (WHAT(5).GT.ZERO) THEN
1552 IPARU(NPARU) = INT(WHAT(5))
1553 PARUX(NPARU) = WHAT(6)
1557 *********************************************************************
1559 * control card: codewd = OUTLEVEL *
1561 * output control switches *
1563 * what (1) = internal rejection informations default: 0 *
1564 * what (2) = energy-momentum conservation check output *
1566 * what (3) = internal warning messages default: 0 *
1567 * what (4..6), sdum not yet used *
1569 *********************************************************************
1573 IOULEV(K) = INT(WHAT(K))
1577 *********************************************************************
1579 * control card: codewd = FRAME *
1581 * frame in which final state is given in DTEVT1 *
1583 * what (1) = 1 target rest frame (laboratory) *
1584 * = 2 nucleon-nucleon cms *
1587 *********************************************************************
1590 KFRAME = INT(WHAT(1))
1591 IF ((KFRAME.GE.1).AND.(KFRAME.LE.2)) IFRAME = KFRAME
1594 *********************************************************************
1596 * control card: codewd = L-TAG *
1599 * definition of kinematical cuts for radiated photon and *
1600 * outgoing lepton detection in lepton-nucleus interactions *
1602 * what (1) = y_min *
1603 * what (2) = y_max *
1604 * what (3) = Q^2_min *
1605 * what (4) = Q^2_max *
1606 * what (5) = theta_min (Lab) *
1607 * what (6) = theta_max (Lab) *
1608 * default: no cuts *
1611 *********************************************************************
1622 *********************************************************************
1624 * control card: codewd = L-ETAG *
1627 * what (1) = min. outgoing lepton energy (in Lab) *
1628 * what (2) = min. photon energy (in Lab) *
1629 * what (3) = max. photon energy (in Lab) *
1630 * default: no cuts *
1631 * what (2..6), sdum no meaning *
1633 *********************************************************************
1636 ELMIN = MAX(WHAT(1),ZERO)
1637 EGMIN = MAX(WHAT(2),ZERO)
1638 EGMAX = MAX(WHAT(3),ZERO)
1641 *********************************************************************
1643 * control card: codewd = ECMS-CUT *
1645 * what (1) = min. c.m. energy to be sampled *
1646 * what (2) = max. c.m. energy to be sampled *
1647 * what (3) = min x_Bj to be sampled *
1648 * default: no cuts *
1649 * what (3..6), sdum no meaning *
1651 *********************************************************************
1656 IF (ECMIN.GT.ECMAX) ECMIN = ECMAX
1657 XBJMIN = MAX(WHAT(3),ZERO)
1660 *********************************************************************
1662 * control card: codewd = VDM-PAR1 *
1664 * parameters in gamma-nucleus cross section calculation *
1666 * what (1) = Lambda^2 default: 2. *
1667 * what (2) lower limit in M^2 integration *
1670 * = 3 (m_phi)^2 default: 1 *
1671 * what (3) upper limit in M^2 integration *
1674 * = 3 s default: 3 *
1675 * what (4) CKMT F_2 structure function *
1677 * = 100 deuteron default: 2212 *
1678 * what (5) calculation of gamma-nucleon xsections *
1679 * = 1 according to CKMT-parametrization of F_2 *
1680 * = 2 integrating SIGVP over M^2 *
1682 * = 4 PHOJET cross sections default: 4 *
1684 * what (6), sdum no meaning *
1686 *********************************************************************
1689 IF (WHAT(1).GE.ZERO) RL2 = WHAT(1)
1690 IF ((WHAT(2).GE.1).AND.(WHAT(2).LE.3)) INTRGE(1) = INT(WHAT(2))
1691 IF ((WHAT(3).GE.1).AND.(WHAT(3).LE.3)) INTRGE(2) = INT(WHAT(3))
1692 IF ((WHAT(4).EQ.2212).OR.(WHAT(4).EQ.100)) IDPDF = INT(WHAT(4))
1693 IF ((WHAT(5).GE.1).AND.(WHAT(5).LE.4)) MODEGA = INT(WHAT(5))
1696 *********************************************************************
1698 * control card: codewd = HISTOGRAM *
1700 * activate different classes of histograms *
1702 * default: no histograms *
1704 *********************************************************************
1708 IF ((WHAT(J).GE.100).AND.(WHAT(J).LE.150)) THEN
1709 IHISPP(INT(WHAT(J))-100) = 1
1710 ELSEIF ((ABS(WHAT(J)).GE.200).AND.(ABS(WHAT(J)).LE.250)) THEN
1711 IHISXS(INT(ABS(WHAT(J)))-200) = 1
1712 IF (WHAT(J).LT.ZERO) IXSTBL = 1
1717 *********************************************************************
1719 * control card: codewd = XS-TABLE *
1721 * output of cross section table for requested interaction *
1722 * - particle production deactivated ! - *
1724 * what (1) lower energy limit for tabulation *
1726 * < 0 nucleon-nucleon cms *
1727 * what (2) upper energy limit for tabulation *
1729 * < 0 nucleon-nucleon cms *
1730 * what (3) > 0 # of equidistant lin. bins in E *
1731 * < 0 # of equidistant log. bins in E *
1732 * what (4) lower limit of particle virtuality (photons) *
1733 * what (5) upper limit of particle virtuality (photons) *
1734 * what (6) > 0 # of equidistant lin. bins in Q^2 *
1735 * < 0 # of equidistant log. bins in Q^2 *
1737 *********************************************************************
1740 IF (WHAT(1).EQ.99999.0D0) THEN
1741 IRATIO = INT(WHAT(2))
1744 CMENER = ABS(WHAT(2))
1745 IF (.NOT.LXSTAB) THEN
1749 IF ((.NOT.LXSTAB).OR.(CMENER.NE.CMEOLD)) THEN
1751 IF (WHAT(2).GT.ZERO)
1752 & CMENER = SQRT(2.0D0*AAM(1)**2+2.0D0*WHAT(2)*AAM(1))
1755 C WRITE(LOUT,*) 'CMENER = ',CMENER
1756 CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,CMENER,1)
1759 CALL DT_XSTABL(WHAT,IXSQEL,IRATIO)
1764 *********************************************************************
1766 * control card: codewd = GLAUB-PAR *
1768 * parameters in Glauber-formalism *
1770 * what (1) # of nucleon configurations sampled in integration *
1771 * over nuclear desity default: 1000 *
1772 * what (2) # of bins for integration over impact-parameter and *
1773 * for profile-function calculation default: 49 *
1774 * what (3) = 1 calculation of tot., el. and qel. cross sections *
1776 * what (4) = 1 read pre-calculated impact-parameter distrib. *
1778 * =-1 dump pre-calculated impact-parameter distrib. *
1780 * = 100 read pre-calculated impact-parameter distrib. *
1781 * for variable projectile/target/energy runs *
1784 * what (5..6) no meaning *
1785 * sdum if |what (4)| = 1 name of in/output-file (sdum.glb) *
1787 *********************************************************************
1790 IF (WHAT(1).GT.ZERO) JSTATB = INT(WHAT(1))
1791 IF (WHAT(2).GT.ZERO) JBINSB = INT(WHAT(2))
1792 IF (WHAT(3).EQ.ONE) LPROD = .FALSE.
1793 IF ((ABS(WHAT(4)).EQ.ONE).OR.(WHAT(4).EQ.100)) THEN
1794 IOGLB = INT(WHAT(4))
1799 *********************************************************************
1801 * control card: codewd = GLAUB-INI *
1803 * pre-initialization of profile function *
1805 * what (1) lower energy limit for initialization *
1807 * < 0 nucleon-nucleon cms *
1808 * what (2) upper energy limit for initialization *
1810 * < 0 nucleon-nucleon cms *
1811 * what (3) > 0 # of equidistant lin. bins in E *
1812 * < 0 # of equidistant log. bins in E *
1813 * what (4) maximum projectile mass number for which the *
1814 * Glauber data are initialized for each *
1815 * projectile mass number *
1816 * (if <= mass given with the PROJPAR-card) *
1818 * what (5) steps in mass number starting from what (4) *
1819 * up to mass number defined with PROJPAR-card *
1820 * for which Glauber data are initialized *
1822 * what (6) no meaning *
1825 *********************************************************************
1829 CALL DT_GLBINI(WHAT)
1832 *********************************************************************
1834 * control card: codewd = VDM-PAR2 *
1836 * parameters in gamma-nucleus cross section calculation *
1838 * what (1) = 0 no suppression of shadowing by direct photon *
1840 * = 1 suppression .. default: 1 *
1841 * what (2) = 0 no suppression of shadowing by anomalous *
1842 * component if photon-F_2 *
1843 * = 1 suppression .. default: 1 *
1844 * what (3) = 0 no suppression of shadowing by coherence *
1845 * length of the photon *
1846 * = 1 suppression .. default: 1 *
1847 * what (4) = 1 longitudinal polarized photons are taken into *
1849 * eps*R*Q^2/M^2 = what(4)*Q^2/M^2 default: 0 *
1850 * what (5..6), sdum no meaning *
1852 *********************************************************************
1855 IF ((WHAT(1).EQ.ZERO).OR.(WHAT(1).EQ.ONE)) ISHAD(1) = INT(WHAT(1))
1856 IF ((WHAT(2).EQ.ZERO).OR.(WHAT(2).EQ.ONE)) ISHAD(2) = INT(WHAT(2))
1857 IF ((WHAT(3).EQ.ZERO).OR.(WHAT(3).EQ.ONE)) ISHAD(3) = INT(WHAT(3))
1861 *********************************************************************
1863 * control card: XS-QELPRO *
1865 * what (1..6), sdum no meaning *
1867 *********************************************************************
1870 IXSQEL = ABS(WHAT(1))
1873 *********************************************************************
1875 * control card: RNDMINIT *
1877 * initialization of random number generator *
1879 * what (1..4) values for initialization (= 1..168) *
1880 * what (5..6), sdum no meaning *
1882 *********************************************************************
1885 IF ((WHAT(1).LT.1.0D0).OR.(WHAT(1).GT.168.0D0)) THEN
1890 IF ((WHAT(2).LT.1.0D0).OR.(WHAT(2).GT.168.0D0)) THEN
1895 IF ((WHAT(3).LT.1.0D0).OR.(WHAT(3).GT.168.0D0)) THEN
1900 IF ((WHAT(4).LT.1.0D0).OR.(WHAT(4).GT.168.0D0)) THEN
1905 CALL DT_RNDMST(NA1,NA2,NA3,NA4)
1908 *********************************************************************
1910 * control card: codewd = LEPTO-CUT *
1912 * set parameter CUT in LEPTO-common /LEPTOU/ *
1914 * what (1) = index in CUT-array *
1915 * what (2) = new value of CUT( int(what(1)) ) *
1916 * what (3), what(4) and what (5), what(6) further *
1917 * parameter in the same way as what (1) and *
1919 * default: default-LEPTO parameters *
1921 *********************************************************************
1924 IF (WHAT(1).GT.ZERO) CUT(INT(WHAT(1))) = WHAT(2)
1925 IF (WHAT(3).GT.ZERO) CUT(INT(WHAT(3))) = WHAT(4)
1926 IF (WHAT(5).GT.ZERO) CUT(INT(WHAT(5))) = WHAT(6)
1929 *********************************************************************
1931 * control card: codewd = LEPTO-LST *
1933 * set parameter LST in LEPTO-common /LEPTOU/ *
1935 * what (1) = index in LST-array *
1936 * what (2) = new value of LST( int(what(1)) ) *
1937 * what (3), what(4) and what (5), what(6) further *
1938 * parameter in the same way as what (1) and *
1940 * default: default-LEPTO parameters *
1942 *********************************************************************
1945 IF (WHAT(1).GT.ZERO) LST(INT(WHAT(1))) = INT(WHAT(2))
1946 IF (WHAT(3).GT.ZERO) LST(INT(WHAT(3))) = INT(WHAT(4))
1947 IF (WHAT(5).GT.ZERO) LST(INT(WHAT(5))) = INT(WHAT(6))
1950 *********************************************************************
1952 * control card: codewd = LEPTO-PARL *
1954 * set parameter PARL in LEPTO-common /LEPTOU/ *
1956 * what (1) = index in PARL-array *
1957 * what (2) = new value of PARL( int(what(1)) ) *
1958 * what (3), what(4) and what (5), what(6) further *
1959 * parameter in the same way as what (1) and *
1961 * default: default-LEPTO parameters *
1963 *********************************************************************
1966 IF (WHAT(1).GT.ZERO) PARL(INT(WHAT(1))) = WHAT(2)
1967 IF (WHAT(3).GT.ZERO) PARL(INT(WHAT(3))) = WHAT(4)
1968 IF (WHAT(5).GT.ZERO) PARL(INT(WHAT(5))) = WHAT(6)
1971 *********************************************************************
1973 * control card: codewd = START *
1975 * what (1) = number of events default: 100. *
1976 * what (2) = 0 Glauber initialization follows *
1977 * = 1 Glauber initialization supressed, fitted *
1978 * results are used instead *
1979 * (this does not apply if emulsion-treatment *
1981 * = 2 Glauber initialization is written to *
1982 * output-file shmakov.out *
1983 * = 3 Glauber initialization is read from input-file *
1984 * shmakov.out default: 0 *
1985 * what (3..6) no meaning *
1986 * what (3..6) no meaning *
1988 *********************************************************************
1992 * check for cross-section table output only
1995 NCASES = INT(WHAT(1))
1996 IF (NCASES.LE.0) NCASES = 100
1997 IGLAU = INT(WHAT(2))
1998 IF ((IGLAU.NE.1).AND.(IGLAU.NE.2).AND.(IGLAU.NE.3))
2007 IF (IDP.LE.0) IDP = 1
2008 * muon neutrinos: temporary (missing index)
2009 * (new patch in projpar: therefore the following this is probably not
2010 * necessary anymore..)
2011 C IF (IDP.EQ.26) IDP = 5
2012 C IF (IDP.EQ.27) IDP = 6
2014 * redefine collision energy
2016 IF (ABS(VAREHI).GT.ZERO) THEN
2018 IF (VARELO.LT.EHADLO) VARELO = EHADLO
2019 CALL DT_LTINI(IDP,IDT,VARELO,PDUM,VARCLO,1)
2021 CALL DT_LTINI(IDP,IDT,VAREHI,PDUM,VARCHI,1)
2023 CALL DT_LTINI(IDP,IDT,EPN,PPN,CMENER,1)
2026 1003 FORMAT(1X,'INIT: collision energy not defined!',/,
2027 & 1X,' -program stopped- ')
2031 * switch off evaporation (even if requested) if central coll. requ.
2032 IF ((ICENTR.EQ.-1).OR.(ICENTR.GT.0).OR.(XSFRAC.LT.0.5D0)) THEN
2035 1004 FORMAT(1X,/,'Warning! Evaporation request rejected since',
2036 & ' central collisions forced.')
2043 * initialization of evaporation-module
2046 1010 FORMAT(1X,/,'Warning! No evaporation performed since',
2047 & ' evaporation modules not available with this version.')
2057 * save the default JETSET-parameter
2060 * force use of phojet for g-A
2061 IF ((IDP.EQ.7).AND.(MCGENE.NE.3)) MCGENE = 2
2062 * initialization of nucleon-nucleon event generator
2063 IF (MCGENE.EQ.2) CALL DT_PHOINI
2064 * initialization of LEPTO event generator
2065 IF (MCGENE.EQ.3) THEN
2067 STOP ' This version does not contain LEPTO !'
2071 * initialization of quasi-elastic neutrino scattering
2072 IF (MCGENE.EQ.4) THEN
2073 IF (IJPROJ.EQ.5) THEN
2075 ELSEIF (IJPROJ.EQ.6) THEN
2077 ELSEIF (IJPROJ.EQ.135) THEN
2079 ELSEIF (IJPROJ.EQ.136) THEN
2081 ELSEIF (IJPROJ.EQ.133) THEN
2083 ELSEIF (IJPROJ.EQ.134) THEN
2088 * normalize fractions of emulsion components
2089 IF (NCOMPO.GT.0) THEN
2092 SUMFRA = SUMFRA+EMUFRA(I)
2094 IF (SUMFRA.GT.ZERO) THEN
2096 EMUFRA(I) = EMUFRA(I)/SUMFRA
2101 * disallow Cronin's multiple scattering for nucleus-nucleus interactions
2102 IF ((IP.GT.1).AND. (IT.GT.1) .AND. (MKCRON.GT.0)) THEN
2104 1005 FORMAT(/,1X,'INIT: multiple scattering disallowed',/)
2108 * initialization of Glauber-formalism (moved to xAEVT, sr 26.3.96)
2109 C IF (NCOMPO.LE.0) THEN
2110 C CALL DT_SHMAKI(IP,IPZ,IT,ITZ,IDP,PPN,IGLAU)
2113 C CALL DT_SHMAKI(IP,IPZ,IEMUMA(I),IEMUCH(I),IDP,PPN,0)
2117 * pre-tabulation of elastic cross-sections
2118 CALL DT_SIGTBL(JDUM,JDUM,DUM,DUM,-1)
2124 *********************************************************************
2126 * control card: codewd = STOP *
2128 * stop of the event generation *
2130 * what (1..6) no meaning *
2132 *********************************************************************
2136 9000 FORMAT(1X,'---> unexpected end of input !')
2143 *$ CREATE DT_KKINC.FOR
2146 *===kkinc==============================================================*
2148 SUBROUTINE DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,
2151 ************************************************************************
2152 * Treatment of complete nucleus-nucleus or hadron-nucleus scattering *
2153 * This subroutine is an update of the previous version written *
2154 * by J. Ranft/ H.-J. Moehring. *
2155 * This version dated 19.11.95 is written by S. Roesler *
2156 ************************************************************************
2158 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2160 PARAMETER ( LINP = 10 ,
2163 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY5=1.0D-5,
2164 & TINY2=1.0D-2,TINY3=1.0D-3)
2170 PARAMETER (NMXHEP=4000)
2171 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
2172 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
2173 & VHEP(4,NMXHEP), NSD1, NSD2, NDD
2175 PARAMETER (NMXHKK=200000)
2176 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
2177 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
2178 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
2179 * extended event history
2180 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
2181 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
2183 * particle properties (BAMJET index convention)
2185 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2186 & IICH(210),IIBAR(210),K1(210),K2(210)
2187 * properties of interacting particles
2188 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2189 * Lorentz-parameters of the current interaction
2190 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
2191 & UMO,PPCM,EPROJ,PPROJ
2192 * flags for input different options
2193 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2194 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2195 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2196 * flags for particle decays
2197 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
2198 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
2199 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
2200 * cuts for variable energy runs
2201 COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
2202 * Glauber formalism: flags and parameters for statistics
2205 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
2206 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
2207 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
2218 IF (ILOOP.EQ.4) THEN
2219 WRITE(LOUT,1000) NEVHKK
2220 1000 FORMAT(1X,'KKINC: event ',I8,' rejected!')
2225 * variable energy-runs, recalculate parameters for LT's
2226 IF ((ABS(VAREHI).GT.ZERO).OR.(IOGLB.EQ.100)) THEN
2229 CALL DT_LTINI(IDP,1,EPN,PDUM,CDUM,1)
2231 IF (EPN.GT.EPROJ) THEN
2232 WRITE(LOUT,'(A,E9.3,2A,E9.3,A)')
2233 & ' Requested energy (',EPN,'GeV) exceeds',
2234 & ' initialization energy (',EPROJ,'GeV) !'
2238 * re-initialize /DTPRTA/
2244 IBPROJ = IIBAR(IJPROJ)
2246 * calculate nuclear potentials (common /DTNPOT/)
2247 CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
2249 * initialize treatment for residual nuclei
2250 CALL DT_RESNCL(EPN,NLOOP,1)
2252 * sample hadron/nucleus-nucleus interaction
2253 CALL DT_KKEVNT(KKMAT,IREJ1)
2254 IF (IREJ1.GT.0) THEN
2255 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKINC'
2259 IF ((NPMASS.GT.1).OR.(NTMASS.GT.1)) THEN
2261 * intranuclear cascade of final state particles for KTAUGE generations
2263 CALL DT_FOZOCA(LFZC,IREJ1)
2264 IF (IREJ1.GT.0) THEN
2265 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKINC'
2269 * baryons unable to escape the nuclear potential are treated as
2270 * excited nucleons (ISTHKK=15,16)
2273 * decay of resonances produced in intranuclear cascade processes
2274 **sr 15-11-95 should be obsolete
2275 C IF (LFZC) CALL DT_DECAY1
2278 * treatment of residual nuclei
2279 CALL DT_RESNCL(EPN,NLOOP,2)
2281 * evaporation / fission / fragmentation
2282 * (if intranuclear cascade was sampled only)
2284 CALL DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ1)
2285 IF (IREJ1.GT.1) GOTO 101
2286 IF (IREJ1.EQ.1) GOTO 100
2291 * rejection of unphysical configurations
2292 CALL DT_REJUCO(1,IREJ1)
2293 IF (IREJ1.GT.0) THEN
2295 & WRITE(LOUT,*) 'rejected 3 in KKINC: too large x'
2299 * transform finale state into Lab.
2301 CALL DT_BEAMPR(WHAT,DUM,IFLAG)
2302 IF ((IFRAME.EQ.1).AND.(IFLAG.EQ.-1)) CALL DT_LT2LAB
2304 IF (IPI0.EQ.1) CALL DT_DECPI0
2306 C IF (NEVHKK.EQ.5) CALL DT_EVTOUT(4)
2315 *$ CREATE DT_DEFAUL.FOR
2318 *===defaul=============================================================*
2320 SUBROUTINE DT_DEFAUL(EPN,PPN)
2322 ************************************************************************
2323 * Variables are set to default values. *
2324 * This version dated 8.5.95 is written by S. Roesler. *
2325 ************************************************************************
2327 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2329 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
2330 PARAMETER (TWOPI = 6.283185307179586454D+00)
2332 * particle properties (BAMJET index convention)
2334 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2335 & IICH(210),IIBAR(210),K1(210),K2(210)
2338 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
2339 & EBINDP(2),EBINDN(2),EPOT(2,210),
2340 & ETACOU(2),ICOUL,LFERMI
2341 * interface HADRIN-DPM
2342 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
2343 * central particle production, impact parameter biasing
2344 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
2345 * properties of interacting particles
2346 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2347 * properties of photon/lepton projectiles
2348 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
2349 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2350 * emulsion treatment
2351 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2353 * parameter for intranuclear cascade
2355 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
2356 * various options for treatment of partons (DTUNUC 1.x)
2357 * (chain recombination, Cronin,..)
2358 LOGICAL LCO2CR,LINTPT
2359 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
2361 * threshold values for x-sampling (DTUNUC 1.x)
2362 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
2364 * flags for input different options
2365 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2366 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2367 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2368 * n-n cross section fluctuations
2369 PARAMETER (NBINS = 1000)
2370 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
2371 * flags for particle decays
2372 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
2373 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
2374 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
2375 * diquark-breaking mechanism
2376 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
2377 * nucleon-nucleon event-generator
2380 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
2381 * flags for diffractive interactions (DTUNUC 1.x)
2382 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
2383 * VDM parameter for photon-nucleus interactions
2384 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
2385 * Glauber formalism: flags and parameters for statistics
2388 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
2389 * kinematical cuts for lepton-nucleus interactions
2390 COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
2391 & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
2392 * flags for activated histograms
2393 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
2394 * cuts for variable energy runs
2395 COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
2396 * parameters for hA-diffraction
2397 COMMON /DTDIHA/ DIBETA,DIALPH
2400 COMMON /LEPTOI/ RPPN,LEPIN,INTER
2401 * steering flags for qel neutrino scattering modules
2402 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
2404 COMMON /DTEVNO/ NEVENT,ICASCA
2406 DATA POTMES /0.002D0/
2417 * nucleus independent meson potential
2465 **sr 7.4.98: changed after corrected B-sampling
2484 * definition of soft quark distributions
2489 * cutoff parameters for x-sampling
2535 CMODEL(1) = 'DTUNUC '
2536 CMODEL(2) = 'PHOJET '
2537 CMODEL(3) = 'LEPTO '
2538 CMODEL(4) = 'QNEUTRIN'
2575 IF (ITRSPT.EQ.1) THEN
2610 IF (ITRSPT.EQ.1) THEN
2616 * default Lab.-energy
2618 PPN = SQRT((EPN-AAM(IJPROJ))*(EPN+AAM(IJPROJ)))
2623 *$ CREATE DT_AAEVT.FOR
2626 *===aaevt==============================================================*
2628 SUBROUTINE DT_AAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
2631 ************************************************************************
2632 * This version dated 22.03.96 is written by S. Roesler. *
2633 ************************************************************************
2635 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2637 PARAMETER ( LINP = 10 ,
2641 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2642 * emulsion treatment
2643 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2646 COMMON /DTEVNO/ NEVENT,ICASCA
2647 CHARACTER*8 DATE,HHMMSS
2653 NMSG = MAX(NEVTS/100,1)
2655 * initialization of run-statistics and histograms
2657 CALL PHO_PHIST(1000,DUM)
2659 * initialization of Glauber-formalism
2660 IF (NCOMPO.LE.0) THEN
2661 CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
2664 CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
2670 WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2671 & IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
2673 WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)')
2674 & IDMNYR(1),IDMNYR(2),IDMNYR(3)
2675 WRITE(LOUT,1001) DATE,HHMMSS
2676 1001 FORMAT(/,' DT_AAEVT: Initialisation finished. ( Date: ',A8,
2677 & ' Time: ',A8,' )')
2679 * generate NEVTS events
2682 * print run-status message
2683 IF (MOD(IEVT,NMSG).EQ.0) THEN
2685 WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2686 & IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
2688 WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)')
2689 & IDMNYR(1),IDMNYR(2),IDMNYR(3)
2690 WRITE(LOUT,1000) IEVT-1,NEVTS,DATE,HHMMSS
2691 1000 FORMAT(/,1X,I8,' out of ',I8,' events sampled ( Date: ',A,
2692 & ' Time: ',A,' )',/)
2693 C WRITE(LOUT,1000) IEVT-1
2694 C1000 FORMAT(1X,I8,' events sampled')
2697 * treat nuclear emulsions
2698 IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
2699 * composite targets only
2702 CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,IREJ)
2704 CALL PHO_PHIST(2000,DUM)
2706 write(6,*) "Diffractive collisions", NSD1, NSD2, NDD
2710 * print run-statistics and histograms to output-unit 6
2711 CALL PHO_PHIST(3000,DUM)
2716 *$ CREATE DT_LAEVT.FOR
2719 *===laevt==============================================================*
2721 SUBROUTINE DT_LAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
2724 ************************************************************************
2725 * Interface to run DPMJET for lepton-nucleus interactions. *
2726 * Kinematics is sampled using the equivalent photon approximation *
2727 * Based on GPHERA-routine by R. Engel. *
2728 * This version dated 23.03.96 is written by S. Roesler. *
2729 ************************************************************************
2731 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2733 PARAMETER ( LINP = 10 ,
2736 PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,
2737 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
2738 PARAMETER (TWOPI = 6.283185307179586454D+00,
2740 & ALPHEM = ONE/137.0D0)
2742 C CHARACTER*72 HEADER
2744 * particle properties (BAMJET index convention)
2746 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2747 & IICH(210),IIBAR(210),K1(210),K2(210)
2749 PARAMETER (NMXHKK=200000)
2750 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
2751 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
2752 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
2753 * extended event history
2754 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
2755 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
2757 * kinematical cuts for lepton-nucleus interactions
2758 COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
2759 & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
2760 * properties of interacting particles
2761 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2762 * properties of photon/lepton projectiles
2763 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
2764 * kinematics at lepton-gamma vertex
2765 COMMON /DTLGVX/ PPL0(4),PPL1(4),PPG(4),PPA(4)
2766 * flags for activated histograms
2767 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
2768 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2769 * emulsion treatment
2770 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2772 * Glauber formalism: cross sections
2773 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
2774 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
2775 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
2776 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
2777 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
2778 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
2779 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
2780 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
2781 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
2782 & BSLOPE,NEBINI,NQBINI
2783 * nucleon-nucleon event-generator
2786 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
2787 * flags for input different options
2788 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2789 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2790 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2792 COMMON /DTEVNO/ NEVENT,ICASCA
2794 DIMENSION XDUMB(40),BGTA(4)
2797 IF (MCGENE.EQ.3) THEN
2798 STOP ' This version does not contain LEPTO !'
2802 NMSG = MAX(NEVTS/10,1)
2804 * mass of incident lepton
2807 IDPPDG = IDT_IPDGHA(IDP)
2809 * consistency of kinematical limits
2810 Q2MIN = MAX(Q2MIN,TINY10)
2811 Q2MAX = MAX(Q2MAX,TINY10)
2812 YMIN = MIN(MAX(YMIN,TINY10),0.999D0)
2813 YMAX = MIN(MAX(YMAX,TINY10),0.999D0)
2815 * total energy of the lepton-nucleon system
2816 PTOTLN = SQRT( (PLEPT0(1)+PNUCL(1))**2+(PLEPT0(2)+PNUCL(2))**2
2817 & +(PLEPT0(3)+PNUCL(3))**2 )
2818 ETOTLN = PLEPT0(4)+PNUCL(4)
2819 ECMLN = SQRT((ETOTLN-PTOTLN)*(ETOTLN+PTOTLN))
2820 ECMAX = MIN(ECMAX,ECMLN)
2821 WRITE(LOUT,1003) ECMIN,ECMAX,YMIN,YMAX,Q2MIN,Q2MAX,EGMIN,
2823 1003 FORMAT(1X,'LAEVT:',16X,'kinematical cuts',/,22X,
2824 & '------------------',/,9X,'W (min) =',
2825 & F7.1,' GeV (max) =',F7.1,' GeV',/,9X,'y (min) =',
2826 & F7.3,8X,'(max) =',F7.3,/,9X,'Q^2 (min) =',F7.1,
2827 & ' GeV^2 (max) =',F7.1,' GeV^2',/,' (Lab) E_g (min) ='
2828 & ,F7.1,' GeV',/,' (Lab) theta (min) =',F7.4,8X,'(max) =',
2829 & F7.4,' for E_lpt >',F7.1,' GeV',/)
2831 * Lorentz-parameter for transf. into Lab
2832 BGTA(1) = PNUCL(1)/AAM(1)
2833 BGTA(2) = PNUCL(2)/AAM(1)
2834 BGTA(3) = PNUCL(3)/AAM(1)
2835 BGTA(4) = PNUCL(4)/AAM(1)
2836 * LT of incident lepton into Lab and dump it in DTEVT1
2837 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
2838 & PLEPT0(1),PLEPT0(2),PLEPT0(3),PLEPT0(4),
2839 & PLTOT,PPL0(1),PPL0(2),PPL0(3),PPL0(4))
2840 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
2841 & PNUCL(1),PNUCL(2),PNUCL(3),PNUCL(4),
2842 & PLTOT,PPA(1),PPA(2),PPA(3),PPA(4))
2843 * maximum energy of photon nucleon system
2844 PTOTGN = SQRT((YMAX*PPL0(1)+PPA(1))**2+(YMAX*PPL0(2)+PPA(2))**2
2845 & +(YMAX*PPL0(3)+PPA(3))**2)
2846 ETOTGN = YMAX*PPL0(4)+PPA(4)
2847 EGNMAX = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN))
2848 EGNMAX = MIN(EGNMAX,ECMAX)
2849 * minimum energy of photon nucleon system
2850 PTOTGN = SQRT((YMIN*PPL0(1)+PPA(1))**2+(YMIN*PPL0(2)+PPA(2))**2
2851 & +(YMIN*PPL0(3)+PPA(3))**2)
2852 ETOTGN = YMIN*PPL0(4)+PPA(4)
2853 EGNMIN = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN))
2854 EGNMIN = MAX(EGNMIN,ECMIN)
2856 * limits for Glauber-initialization
2858 Q2HI = MAX(Q2LI,MIN(Q2HI,Q2MAX))
2859 ECMLI = MAX(EGNMIN,THREE)
2861 WRITE(LOUT,1004) EGNMIN,EGNMAX,ECMLI,ECMHI,Q2LI,Q2HI
2862 1004 FORMAT(1X,'resulting limits:',/,9X,'W (min) =',F7.1,
2863 & ' GeV (max) =',F7.1,' GeV',/,/,' limits for ',
2864 & 'Glauber-initialization:',/,9X,'W (min) =',F7.1,
2865 & ' GeV (max) =',F7.1,' GeV',/,9X,'Q^2 (min) =',F7.1,
2866 & ' GeV^2 (max) =',F7.1,' GeV^2',/)
2867 * initialization of Glauber-formalism
2868 IF (NCOMPO.LE.0) THEN
2869 CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
2872 CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
2877 * initialization of run-statistics and histograms
2879 CALL PHO_PHIST(1000,DUM)
2881 * maximum photon-nucleus cross section
2885 IF (EGNMAX.GE.ECMNN(NEBINI)) THEN
2889 ELSEIF (EGNMAX.GT.ECMNN(1)) THEN
2891 IF (EGNMAX.LT.ECMNN(I)) THEN
2894 RAT = (EGNMAX-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
2900 SIGMAX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
2905 IF (EGNMIN.GE.ECMNN(NEBINI)) THEN
2909 ELSEIF (EGNMIN.GT.ECMNN(1)) THEN
2911 IF (EGNMIN.LT.ECMNN(I)) THEN
2914 RAT = (EGNMIN-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
2920 SIGXX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
2921 IF (SIGXX.GT.SIGMAX) EGNXX = EGNMIN
2922 SIGMAX = MAX(SIGMAX,SIGXX)
2923 WRITE(LOUT,'(9X,A,F8.3,A)') 'Sigma_tot (max) =',SIGMAX,' mb'
2925 * plot photon flux table
2930 ADY = LOG(YMAX/YMIN)/DBLE(MAXTAB-1)
2931 C WRITE(LOUT,'(/,1X,A)') 'LAEVT: photon flux '
2933 Y = EXP(AYMIN+ADY*DBLE(I-1))
2934 Q2LOW = MAX(Q2MIN,AMLPT2*Y**2/(ONE-Y))
2935 FF1 = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
2936 & -TWO*AMLPT2*Y*(ONE/Q2LOW-ONE/Q2MAX))
2937 FF2 = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
2938 & -TWO*(ONE-Y)/Y*(ONE-Q2LOW/Q2MAX))
2939 C WRITE(LOUT,'(5X,3E15.4)') Y,FF1,FF2
2942 * maximum residual weight for flux sampling (dy/y)
2944 Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY))
2945 WGHMAX = (ONE+(ONE-YY)**2)*LOG(Q2MAX/Q2LOW)
2946 & -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY
2948 CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY0)
2949 CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY1)
2950 CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY2)
2951 CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ0)
2952 CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ1)
2953 CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ2)
2954 CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE0)
2955 CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE1)
2956 CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE2)
2957 CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU0)
2958 CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU1)
2959 CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU2)
2961 CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX0)
2962 CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX1)
2963 CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX2)
2972 IF (MOD(IEVT,NMSG).EQ.0) THEN
2973 C OPEN(LDAT,FILE='/scrtch3/hr/sroesler/statusd5.out',
2974 C & STATUS='UNKNOWN')
2975 WRITE(LOUT,'(1X,I8,A)') IEVT-1,' events sampled'
2986 YY = EXP(AYRGE*DT_RNDM(RAT)+AYMIN)
2987 Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY))
2988 Q2LOG = LOG(Q2MAX/Q2LOW)
2989 WGH = (ONE+(ONE-YY)**2)*Q2LOG
2990 & -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY
2991 IF (WGHMAX.LT.WGH) WRITE(LOUT,1000) YY,WGHMAX,WGH
2992 1000 FORMAT(1X,'LAEVT: weight error!',3E12.5)
2993 IF (DT_RNDM(YY)*WGHMAX.GT.WGH) GOTO 101
2996 YEFF = ONE+(ONE-YY)**2
2998 Q2 = Q2LOW*EXP(Q2LOG*DT_RNDM(YY))
2999 WGH = (YEFF-TWO*(ONE-YY)*Q2LOW/Q2)/YEFF
3000 IF (WGH.LT.DT_RNDM(Q2)) GOTO 102
3003 c CALL DT_FILHGR(YY,ONE,IHFLY0,NC0)
3004 c CALL DT_FILHGR(Q2,ONE,IHFLQ0,NC0)
3006 * kinematics at lepton-photon vertex
3007 * scattered electron
3008 YQ2 = SQRT((ONE-YY)*Q2)
3009 Q2E = Q2/(4.0D0*PLEPT0(4))
3010 E1Y = (ONE-YY)*PLEPT0(4)
3011 CALL DT_DSFECF(SIF,COF)
3016 C THETA = ACOS( (E1Y-Q2E)/(E1Y+Q2E) )
3018 PGAMM(1) = -PLEPT1(1)
3019 PGAMM(2) = -PLEPT1(2)
3020 PGAMM(3) = PLEPT0(3)-PLEPT1(3)
3021 PGAMM(4) = PLEPT0(4)-PLEPT1(4)
3023 PTOTGN = SQRT( (PGAMM(1)+PNUCL(1))**2+(PGAMM(2)+PNUCL(2))**2
3024 & +(PGAMM(3)+PNUCL(3))**2 )
3025 ETOTGN = PGAMM(4)+PNUCL(4)
3026 ECMGN = (ETOTGN-PTOTGN)*(ETOTGN+PTOTGN)
3027 IF (ECMGN.LT.0.1D0) GOTO 101
3029 IF ((ECMGN.LT.ECMIN).OR.(ECMGN.GT.ECMAX)) GOTO 101
3031 * Lorentz-transformation into nucleon-rest system
3032 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3033 & PGAMM(1),PGAMM(2),PGAMM(3),PGAMM(4),
3034 & PGTOT,PPG(1),PPG(2),PPG(3),PPG(4))
3035 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3036 & PLEPT1(1),PLEPT1(2),PLEPT1(3),PLEPT1(4),
3037 & PLTOT,PPL1(1),PPL1(2),PPL1(3),PPL1(4))
3038 * temporary checks..
3039 Q2TMP = ABS(PPG(4)**2-PGTOT**2)
3040 IF (ABS(Q2-Q2TMP).GT.0.01D0) WRITE(LOUT,1001) Q2,Q2TMP
3041 1001 FORMAT(1X,'LAEVT: inconsistent kinematics (Q2,Q2TMP) ',
3043 ECMTMP = SQRT((PPG(4)+AAM(1)-PGTOT)*(PPG(4)+AAM(1)+PGTOT))
3044 IF (ABS(ECMGN-ECMTMP).GT.TINY10) WRITE(LOUT,1002) ECMGN,ECMTMP
3045 1002 FORMAT(1X,'LAEVT: inconsistent kinematics (ECMGN,ECMTMP) ',
3047 YYTMP = PPG(4)/PPL0(4)
3048 IF (ABS(YY-YYTMP).GT.0.01D0) WRITE(LOUT,1005) YY,YYTMP
3049 1005 FORMAT(1X,'LAEVT: inconsistent kinematics (YY,YYTMP) ',
3052 * lepton tagger (Lab)
3053 THETA = ACOS( PPL1(3)/PLTOT )
3054 IF (PPL1(4).GT.ELMIN) THEN
3055 IF ((THETA.LT.THMIN).OR.(THETA.GT.THMAX)) GOTO 101
3057 * photon energy-cut (Lab)
3058 IF (PPG(4).LT.EGMIN) GOTO 101
3059 IF (PPG(4).GT.EGMAX) GOTO 101
3061 XBJ = ABS(Q2/(1.876D0*PPG(4)))
3062 IF (XBJ.LT.XBJMIN) GOTO 101
3065 CALL DT_FILHGR( Q2,ONE,IHFLQ0,NC0)
3066 CALL DT_FILHGR( YY,ONE,IHFLY0,NC0)
3067 CALL DT_FILHGR( XBJ,ONE,IHFLX0,NC0)
3068 CALL DT_FILHGR(PPG(4),ONE,IHFLU0,NC0)
3069 CALL DT_FILHGR( ECMGN,ONE,IHFLE0,NC0)
3071 * rotation angles against z-axis
3073 C SID = SQRT((ONE-COD)*(ONE+COD))
3074 PPT = SQRT(PPG(1)**2+PPG(2)**2)
3078 IF (PGTOT*SID.GT.TINY10) THEN
3079 COF = PPG(1)/(SID*PGTOT)
3080 SIF = PPG(2)/(SID*PGTOT)
3081 ANORF = SQRT(COF*COF+SIF*SIF)
3086 IF (IXSTBL.EQ.0) THEN
3087 * change to photon projectile
3091 * re-initialize LTs with new kinematics
3092 * !!PGAMM ist set in cms (ECMGN) along z
3095 CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,ECMGN,0)
3098 * get emulsion component if requested
3099 IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
3100 * convolute with cross section
3101 CALL DT_SIGGAT(Q2LOW,EGNXX,STOTX,KKMAT)
3102 CALL DT_SIGGAT(Q2,ECMGN,STOT,KKMAT)
3103 IF (STOTX.LT.STOT) WRITE(LOUT,'(1X,A,/,6E12.3)')
3104 & 'LAEVT: warning STOTX<STOT ! ',Q2LOW,EGNMAX,STOTX,
3106 IF (DT_RNDM(Q2)*STOTX.GT.STOT) GOTO 100
3108 CALL DT_FILHGR( Q2,ONE,IHFLQ1,NC1)
3109 CALL DT_FILHGR( YY,ONE,IHFLY1,NC1)
3110 CALL DT_FILHGR( XBJ,ONE,IHFLX1,NC1)
3111 CALL DT_FILHGR(PPG(4),ONE,IHFLU1,NC1)
3112 CALL DT_FILHGR( ECMGN,ONE,IHFLE1,NC1)
3113 * composite targets only
3116 CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IJPROJ,EPN,KKMAT,
3118 * rotate momenta of final state particles back in photon-nucleon syst.
3119 DO 4 I=NPOINT(4),NHKK
3120 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
3121 & (ISTHKK(I).EQ.1001)) THEN
3125 CALL DT_MYTRAN(1,PX,PY,PZ,COD,SID,COF,SIF,
3126 & PHKK(1,I),PHKK(2,I),PHKK(3,I))
3131 CALL DT_FILHGR( Q2,ONE,IHFLQ2,NC1)
3132 CALL DT_FILHGR( YY,ONE,IHFLY2,NC1)
3133 CALL DT_FILHGR( XBJ,ONE,IHFLX2,NC1)
3134 CALL DT_FILHGR(PPG(4),ONE,IHFLU2,NC1)
3135 CALL DT_FILHGR( ECMGN,ONE,IHFLE2,NC1)
3137 * dump this event to histograms
3138 CALL PHO_PHIST(2000,DUM)
3142 WGY = ALPHEM/TWOPI*WGHMAX*DBLE(ITRY)/DBLE(ITRW)
3143 WGY = WGY*LOG(YMAX/YMIN)
3144 WEIGHT = WGY*SIGMAX*DBLE(NEVTS)/DBLE(ITRY)
3146 C HEADER = ' LAEVT: Q^2 distribution 0'
3147 C CALL DT_OUTHGR(IHFLQ0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3148 C HEADER = ' LAEVT: Q^2 distribution 1'
3149 C CALL DT_OUTHGR(IHFLQ1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3150 C HEADER = ' LAEVT: Q^2 distribution 2'
3151 C CALL DT_OUTHGR(IHFLQ2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3152 C HEADER = ' LAEVT: y distribution 0'
3153 C CALL DT_OUTHGR(IHFLY0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3154 C HEADER = ' LAEVT: y distribution 1'
3155 C CALL DT_OUTHGR(IHFLY1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3156 C HEADER = ' LAEVT: y distribution 2'
3157 C CALL DT_OUTHGR(IHFLY2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3158 C HEADER = ' LAEVT: x distribution 0'
3159 C CALL DT_OUTHGR(IHFLX0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3160 C HEADER = ' LAEVT: x distribution 1'
3161 C CALL DT_OUTHGR(IHFLX1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3162 C HEADER = ' LAEVT: x distribution 2'
3163 C CALL DT_OUTHGR(IHFLX2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3164 C HEADER = ' LAEVT: E_g distribution 0'
3165 C CALL DT_OUTHGR(IHFLU0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3166 C HEADER = ' LAEVT: E_g distribution 1'
3167 C CALL DT_OUTHGR(IHFLU1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3168 C HEADER = ' LAEVT: E_g distribution 2'
3169 C CALL DT_OUTHGR(IHFLU2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3170 C HEADER = ' LAEVT: E_c distribution 0'
3171 C CALL DT_OUTHGR(IHFLE0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3172 C HEADER = ' LAEVT: E_c distribution 1'
3173 C CALL DT_OUTHGR(IHFLE1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3174 C HEADER = ' LAEVT: E_c distribution 2'
3175 C CALL DT_OUTHGR(IHFLE2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3177 * print run-statistics and histograms to output-unit 6
3178 CALL PHO_PHIST(3000,DUM)
3179 IF (IXSTBL.EQ.0) CALL DT_STATIS(2)
3184 *$ CREATE DT_DTUINI.FOR
3187 *===dtuini=============================================================*
3189 SUBROUTINE DT_DTUINI(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
3192 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3195 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
3196 * emulsion treatment
3197 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
3199 * Glauber formalism: flags and parameters for statistics
3202 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
3204 CALL DT_INIT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,IGLAU)
3206 CALL PHO_PHIST(1000,DUM)
3207 IF (NCOMPO.LE.0) THEN
3208 CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
3211 CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
3214 IF (IOGLB.NE.100) CALL DT_SIGEMU
3220 *$ CREATE DT_DTUOUT.FOR
3223 *===dtuout=============================================================*
3225 SUBROUTINE DT_DTUOUT
3227 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3230 CALL PHO_PHIST(3000,DUM)
3236 *$ CREATE DT_BEAMPR.FOR
3239 *===beampr=============================================================*
3241 SUBROUTINE DT_BEAMPR(WHAT,PLAB,MODE)
3243 ************************************************************************
3244 * Initialization of event generation *
3245 * This version dated 7.4.98 is written by S. Roesler. *
3246 ************************************************************************
3248 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3251 PARAMETER ( LINP = 10 ,
3254 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
3255 PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
3260 PARAMETER (NMXHKK=200000)
3261 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3262 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3263 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3264 * extended event history
3265 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3266 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3268 * properties of interacting particles
3269 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
3270 * particle properties (BAMJET index convention)
3272 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
3273 & IICH(210),IIBAR(210),K1(210),K2(210)
3275 COMMON /DTBEAM/ P1(4),P2(4)
3277 C DIMENSION WHAT(6),P1(4),P2(4),P1CMS(4),P2CMS(4)
3278 DIMENSION WHAT(6),P1CMS(4),P2CMS(4)
3280 DATA LBEAM /.FALSE./
3287 IF (E1.LT.ZERO) E1 = DBLE(IPZ)/DBLE(IP)*ABS(WHAT(1))
3289 IF (E2.LT.ZERO) E2 = DBLE(ITZ)/DBLE(IT)*ABS(WHAT(2))
3290 PP1 = SQRT( (E1+AAM(IJPROJ))*(E1-AAM(IJPROJ)) )
3291 PP2 = SQRT( (E2+AAM(IJTARG))*(E2-AAM(IJTARG)) )
3292 TH = 1.D-6*WHAT(3)/2.D0
3294 P1(1) = PP1*SIN(TH)*COS(PH)
3295 P1(2) = PP1*SIN(TH)*SIN(PH)
3298 P2(1) = PP2*SIN(TH)*COS(PH)
3299 P2(2) = PP2*SIN(TH)*SIN(PH)
3300 P2(3) = -PP2*COS(TH)
3302 ECM = SQRT( (P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))**2
3303 & -(P1(3)+P2(3))**2 )
3304 ELAB = (ECM**2-AAM(IJPROJ)**2-AAM(IJTARG)**2)/(2.0D0*AAM(IJTARG))
3305 PLAB = SQRT( (ELAB+AAM(IJPROJ))*(ELAB-AAM(IJPROJ)) )
3306 BGX = (P1(1)+P2(1))/ECM
3307 BGY = (P1(2)+P2(2))/ECM
3308 BGZ = (P1(3)+P2(3))/ECM
3309 BGE = (P1(4)+P2(4))/ECM
3310 CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P1(1),P1(2),P1(3),P1(4),
3311 & P1TOT,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4))
3312 CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P2(1),P2(2),P2(3),P2(4),
3313 & P2TOT,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4))
3314 COD = P1CMS(3)/P1TOT
3315 C SID = SQRT((ONE-COD)*(ONE+COD))
3316 PPT = SQRT(P1CMS(1)**2+P1CMS(2)**2)
3320 IF (P1TOT*SID.GT.TINY10) THEN
3321 COF = P1CMS(1)/(SID*P1TOT)
3322 SIF = P1CMS(2)/(SID*P1TOT)
3323 ANORF = SQRT(COF*COF+SIF*SIF)
3328 C WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
3329 C WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
3330 C WRITE(LOUT,'(5E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),P1TOT
3331 C WRITE(LOUT,'(5E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),P2TOT
3335 C PAE = SQRT(AAM(IJPROJ)**2+PAZ**2)
3339 C PBE = SQRT(AAM(IJTARG)**2+PBZ**2)
3340 C WRITE(LOUT,'(4E15.4)') PAX,PAY,PAZ,PAE
3341 C WRITE(LOUT,'(4E15.4)') PBX,PBY,PBZ,PBE
3342 C CALL DT_MYTRAN(1,PAX,PAY,PAZ,COD,SID,COF,SIF,
3343 C & P1CMS(1),P1CMS(2),P1CMS(3))
3344 C CALL DT_MYTRAN(1,PBX,PBY,PBZ,COD,SID,COF,SIF,
3345 C & P2CMS(1),P2CMS(2),P2CMS(3))
3346 C WRITE(LOUT,'(4E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4)
3347 C WRITE(LOUT,'(4E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4)
3348 C CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),
3349 C & P1TOT,P1(1),P1(2),P1(3),P1(4))
3350 C CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),
3351 C & P2TOT,P2(1),P2(2),P2(3),P2(4))
3352 C WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
3353 C WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
3364 IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
3365 DO 20 I=NPOINT(4),NHKK
3366 IF ((ABS(ISTHKK(I)).EQ.1) .OR.
3367 & (ABS(ISTHKK(I)).EQ.2) .OR.
3368 & (ISTHKK(I).EQ.1000) .OR.
3369 & (ISTHKK(I).EQ.1001)) THEN
3371 CALL DT_MYTRAN(1,PHKK(1,I),PHKK(2,I),PHKK(3,I),
3372 & COD,SID,COF,SIF,PXCMS,PYCMS,PZCMS)
3374 CALL DT_DALTRA(BGE,BGX,BGY,BGZ,PXCMS,PYCMS,PZCMS,PECMS,
3375 & PTOT,PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I))
3385 *$ CREATE DT_REJUCO.FOR
3388 *===rejuco=============================================================*
3390 SUBROUTINE DT_REJUCO(MODE,IREJ)
3392 ************************************************************************
3393 * REJection of Unphysical COnfigurations *
3394 * MODE = 1 rejection of particles with unphysically large energy *
3396 * This version dated 27.12.2006 is written by S. Roesler. *
3397 ************************************************************************
3399 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3402 PARAMETER ( LINP = 10 ,
3405 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
3406 PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
3408 * maximum x_cms of final state particle
3409 PARAMETER (XCMSMX = 1.4D0)
3412 PARAMETER (NMXHKK=200000)
3413 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3414 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3415 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3416 * extended event history
3417 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3418 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3420 * Lorentz-parameters of the current interaction
3421 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
3422 & UMO,PPCM,EPROJ,PPROJ
3427 IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
3429 DO 10 I=NPOINT(4),NHKK
3430 IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDHKK(I).NE.80000)) THEN
3431 XCMS = ABS(PHKK(4,I))/ECMHLF
3432 IF (XCMS.GT.XCMSMX) GOTO 9999
3443 *$ CREATE DT_EVENTB.FOR
3446 *===eventb=============================================================*
3448 SUBROUTINE DT_EVENTB(NCSY,IREJ)
3450 ************************************************************************
3451 * Treatment of nucleon-nucleon interactions with full two-component *
3452 * Dual Parton Model. *
3453 * NCSY number of nucleon-nucleon interactions *
3454 * IREJ rejection flag *
3455 * This version dated 14.01.2000 is written by S. Roesler *
3456 ************************************************************************
3458 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3460 PARAMETER ( LINP = 10 ,
3463 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
3466 PARAMETER (NMXHKK=200000)
3467 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3468 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3469 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3470 * extended event history
3471 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3472 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3474 *! uncomment this line for internal phojet-fragmentation
3475 C #include "dtu_dtevtp.inc"
3476 * particle properties (BAMJET index convention)
3478 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
3479 & IICH(210),IIBAR(210),K1(210),K2(210)
3480 * flags for input different options
3481 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
3482 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
3483 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
3485 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
3486 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
3487 & IREXCI(3),IRDIFF(2),IRINC
3488 * properties of interacting particles
3489 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
3490 * properties of photon/lepton projectiles
3491 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
3492 * various options for treatment of partons (DTUNUC 1.x)
3493 * (chain recombination, Cronin,..)
3494 LOGICAL LCO2CR,LINTPT
3495 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
3498 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
3499 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
3501 * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
3502 COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
3503 * Glauber formalism: collision properties
3504 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
3505 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
3507 * flags for diffractive interactions (DTUNUC 1.x)
3508 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
3509 * statistics: double-Pomeron exchange
3510 COMMON /DTFLG2/ INTFLG,IPOPO
3511 * flags for particle decays
3512 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
3513 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
3514 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
3515 * nucleon-nucleon event-generator
3518 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
3519 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
3520 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
3521 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
3522 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
3523 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
3524 C model switches and parameters
3526 INTEGER ISWMDL,IPAMDL
3527 DOUBLE PRECISION PARMDL
3528 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
3529 C initial state parton radiation (internal part)
3530 INTEGER MXISR3,MXISR4
3531 PARAMETER ( MXISR3 = 50, MXISR4 = 100 )
3532 INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC
3533 DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT
3534 COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3),
3535 & ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3),
3536 & IFL1(2,MXISR3),IFL2(2,MXISR3),
3537 & IBRA(2,MXISR4),IFANO(2),ISH(2),NACC
3538 C event debugging information
3540 PARAMETER (NMAXD=100)
3541 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
3542 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3543 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
3544 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3545 C general process information
3546 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
3547 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
3549 DIMENSION PP(4),PT(4),PTOT(4),PP1(4),PP2(4),PT1(4),PT2(4),
3550 & PPNN(4),PTNN(4),PTOTNN(4),PPSUB(4),PTSUB(4),
3551 & PPTCMS(4),PTTCMS(4),PPTMP(4),PTTMP(4),
3552 & KPRON(15),ISINGL(2000)
3554 * initial values for max. number of phojet scatterings and dtunuc chains
3555 * to be fragmented with one pyexec call
3556 DATA MXPHFR,MXDTFR /10,100/
3559 * pointer to first parton of the first chain in dtevt common
3561 * special flag for double-Pomeron statistics
3563 * counter for low-mass (DTUNUC) interactions
3565 * counter for interactions treated by PHOJET
3568 * scan interactions for single nucleon-nucleon interactions
3569 * (this has to be checked here because Cronin modifies parton momenta)
3571 IF (NCSY.GT.2000) STOP ' DT_EVENTB: NCSY > 2000 ! '
3575 MOT = JMOHKK(1,NC+1)
3576 DIFF1 = ABS(PHKK(4,MOP)-PHKK(4, NC)-PHKK(4,NC+2))
3577 DIFF2 = ABS(PHKK(4,MOT)-PHKK(4,NC+1)-PHKK(4,NC+3))
3578 IF ((DIFF1.LT.TINY10).AND.(DIFF2.LT.TINY10)) ISINGL(I) = 1
3582 * multiple scattering of chain ends
3583 IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
3584 IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
3586 * switch to PHOJET-settings for JETSET parameter
3589 * loop over nucleon-nucleon interaction
3593 * pick up one nucleon-nucleon interaction from DTEVT1
3594 * ppnn / ptnn - momenta of the interacting nucleons (cms)
3595 * ptotnn - total momentum of the interacting nucleons (cms)
3596 * pp1,2 / pt1,2 - momenta of the four partons
3597 * pp / pt - total momenta of the proj / targ partons
3598 * ptot - total momentum of the four partons
3600 MOT = JMOHKK(1,NC+1)
3602 PPNN(K) = PHKK(K,MOP)
3603 PTNN(K) = PHKK(K,MOT)
3604 PTOTNN(K) = PPNN(K)+PTNN(K)
3606 PT1(K) = PHKK(K,NC+1)
3607 PP2(K) = PHKK(K,NC+2)
3608 PT2(K) = PHKK(K,NC+3)
3609 PP(K) = PP1(K)+PP2(K)
3610 PT(K) = PT1(K)+PT2(K)
3611 PTOT(K) = PP(K)+PT(K)
3614 *-----------------------------------------------------------------------
3615 * this is a complete nucleon-nucleon interaction
3617 IF (ISINGL(I).EQ.1) THEN
3619 * initialize PHOJET-variables for remnant/valence-partons
3626 * save current settings of PHOJET process and min. bias flags
3628 KPRON(K) = IPRON(K,1)
3632 * check if forced sampling of diffractive interaction requested
3633 IF (ISINGD.LT.-1) THEN
3637 IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-3)) IPRON(5,1) = 1
3638 IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-4)) IPRON(6,1) = 1
3639 IF (ISINGD.EQ.-5) IPRON(4,1) = 1
3642 * for photons: a direct/anomalous interaction is not sampled
3643 * in PHOJET but already in Glauber-formalism. Here we check if such
3644 * an interaction is requested
3645 IF (IJPROJ.EQ.7) THEN
3646 * first switch off direct interactions
3648 * this is a direct interactions
3649 IF (IDIREC.EQ.1) THEN
3654 * this is an anomalous interactions
3655 * (iswmdl(2) = 0 only hard int. generated ( = 1 min. bias) )
3656 ELSEIF (IDIREC.EQ.2) THEN
3660 IF (IDIREC.NE.0) STOP ' DT_EVENTB: IDIREC > 0 ! '
3663 * make sure that total momenta of partons, pp and pt, are on mass
3664 * shell (Cronin may have srewed this up..)
3665 CALL DT_MASHEL(PP,PT,PHKK(5,MOP),PHKK(5,MOT),PPNN,PTNN,IR1)
3667 IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A)')
3668 & 'EVENTB: mass shell correction rejected'
3672 * initialize the incoming particles in PHOJET
3673 IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
3674 CALL PHO_SETPAR(1,22,0,VIRT)
3676 CALL PHO_SETPAR(1,IDHKK(MOP),0,ZERO)
3678 CALL PHO_SETPAR(2,IDHKK(MOT),0,ZERO)
3680 * initialize rejection loop counter for anomalous processes
3685 * temporary fix for ifano problem
3689 * generate complete hadron/nucleon/photon-nucleon event with PHOJET
3690 CALL PHO_EVENT(2,PPNN,PTNN,DUM,IREJ1)
3692 * for photons: special consistency check for anomalous interactions
3693 IF (IJPROJ.EQ.7) THEN
3694 IF (IRJANO.LT.30) THEN
3695 IF (IFANO(1).NE.0) THEN
3696 * here, an anomalous interaction was generated. Check if it
3697 * was also requested. Otherwise reject this event.
3698 IF (IDIREC.EQ.0) GOTO 800
3700 * here, an anomalous interaction was not generated. Check if it
3701 * was requested in which case we need to reject this event.
3702 IF (IDIREC.EQ.2) GOTO 800
3705 WRITE(LOUT,*) ' DT_EVENTB: Warning! IRJANO > 30 ',
3706 & IRJANO,IDIREC,NEVHKK
3710 * copy back original settings of PHOJET process and min. bias flags
3712 IPRON(K,1) = KPRON(K)
3716 * check if PHOJET has rejected this event
3717 IF (IREJ1.NE.0) THEN
3718 C IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
3719 WRITE(LOUT,'(1X,A,I4)')
3720 & 'EVENTB: chain system rejected',IDIREC
3725 * copy partons and strings from PHOJET common back into DTEVT for
3726 * external fragmentation
3729 *! uncomment this line for internal phojet-fragmentation
3730 C CALL DT_GETFSP(MO1,MO2,PPNN,PTNN,-1)
3732 CALL DT_GETPJE(MO1,MO2,PPNN,PTNN,-1,NPHOSC,IREJ1)
3733 IF (IREJ1.NE.0) THEN
3735 & WRITE(LOUT,'(1X,A,I4)') 'EVENTB: chain system rejected 1'
3739 * update statistics counter
3740 ICEVTG(IDCH(NC),29) = ICEVTG(IDCH(NC),29)+1
3742 *-----------------------------------------------------------------------
3743 * this interaction involves "remnants"
3747 * total mass of this system
3748 PPTOT = SQRT(PTOT(1)**2+PTOT(2)**2+PTOT(3)**2)
3749 AMTOT2 = (PTOT(4)-PPTOT)*(PTOT(4)+PPTOT)
3750 IF (AMTOT2.LT.ZERO) THEN
3753 AMTOT = SQRT(AMTOT2)
3756 * systems with masses larger than elojet are treated with PHOJET
3757 IF (AMTOT.GT.ELOJET) THEN
3759 * initialize PHOJET-variables for remnant/valence-partons
3760 * projectile parton flavors and valence flag
3761 IHFLD(1,1) = IDHKK(NC)
3762 IHFLD(1,2) = IDHKK(NC+2)
3764 IF ((IDCH(NC).EQ.6).OR.(IDCH(NC).EQ.7)
3765 & .OR.(IDCH(NC).EQ.8)) IHFLS(1) = 1
3766 * target parton flavors and valence flag
3767 IHFLD(2,1) = IDHKK(NC+1)
3768 IHFLD(2,2) = IDHKK(NC+3)
3770 IF ((IDCH(NC).EQ.4).OR.(IDCH(NC).EQ.5)
3771 & .OR.(IDCH(NC).EQ.8)) IHFLS(2) = 1
3772 * flag signalizing PHOJET how to treat the remnant:
3773 * iremn = -1 sea-quark remnant: PHOJET takes flavors from ihfld
3774 * iremn > -1 valence remnant: PHOJET assumes flavors according
3775 * to mother particle
3779 * initialize the incoming particles in PHOJET
3780 IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
3781 CALL PHO_SETPAR(1,22,IREMN1,VIRT)
3783 CALL PHO_SETPAR(1,IDHKK(MOP),IREMN1,ZERO)
3785 CALL PHO_SETPAR(2,IDHKK(MOT),IREMN2,ZERO)
3787 * calculate Lorentz parameter of the nucleon-nucleon cm-system
3788 PPTOTN = SQRT(PTOTNN(1)**2+PTOTNN(2)**2+PTOTNN(3)**2)
3789 AMNN = SQRT( (PTOTNN(4)-PPTOTN)*(PTOTNN(4)+PPTOTN) )
3790 BGX = PTOTNN(1)/AMNN
3791 BGY = PTOTNN(2)/AMNN
3792 BGZ = PTOTNN(3)/AMNN
3793 GAM = PTOTNN(4)/AMNN
3794 * transform interacting nucleons into nucleon-nucleon cm-system
3795 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3796 & PPNN(1),PPNN(2),PPNN(3),PPNN(4),PPCMS,
3797 & PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4))
3798 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3799 & PTNN(1),PTNN(2),PTNN(3),PTNN(4),PTCMS,
3800 & PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4))
3801 * transform (total) momenta of the proj and targ partons into
3802 * nucleon-nucleon cm-system
3803 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3804 & PP(1),PP(2),PP(3),PP(4),
3805 & PPTSUB,PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4))
3806 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3807 & PT(1),PT(2),PT(3),PT(4),
3808 & PTTSUB,PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4))
3809 * energy fractions of the proj and targ partons
3810 XPSUB = MIN(PPSUB(4)/PPTCMS(4),ONE)
3811 XTSUB = MIN(PTSUB(4)/PTTCMS(4),ONE)
3814 c PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
3815 c & (PPTCMS(2)+PTTCMS(2))**2 +
3816 c & (PPTCMS(3)+PTTCMS(3))**2 )
3817 c EOLDCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
3818 c & (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
3819 c PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
3820 c & (PPSUB(2)+PTSUB(2))**2 +
3821 c & (PPSUB(3)+PTSUB(3))**2 )
3822 c EOLDSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
3823 c & (PPSUB(4)+PTSUB(4)+PTOTSU) )
3826 * save current settings of PHOJET process and min. bias flags
3828 KPRON(K) = IPRON(K,1)
3830 * disallow direct photon int. (does not make sense here anyway)
3832 * disallow double pomeron processes (due to technical problems
3833 * in PHOJET, needs to be solved sometime)
3835 * disallow diffraction for sea-diquarks
3836 IF ((IABS(IHFLD(1,1)).GT.1100).AND.
3837 & (IABS(IHFLD(1,2)).GT.1100)) THEN
3841 IF ((IABS(IHFLD(2,1)).GT.1100).AND.
3842 & (IABS(IHFLD(2,2)).GT.1100)) THEN
3847 * we need massless partons: transform them on mass shell
3854 CALL DT_MASHEL(PPTMP,PTTMP,XMP,XMT,PPSUB,PTSUB,IREJ1)
3855 PPSUTO = SQRT(PPSUB(1)**2+PPSUB(2)**2+PPSUB(3)**2)
3856 PTSUTO = SQRT(PTSUB(1)**2+PTSUB(2)**2+PTSUB(3)**2)
3857 PSUTOT = SQRT((PPSUB(1)+PTSUB(1))**2+
3858 & (PPSUB(2)+PTSUB(2))**2+(PPSUB(3)+PTSUB(3))**2)
3859 * total energy of the subsysten after mass transformation
3860 * (should be the same as before..)
3861 SECM = SQRT( (PPSUB(4)+PTSUB(4)-PSUTOT)*
3862 & (PPSUB(4)+PTSUB(4)+PSUTOT) )
3864 * after mass shell transformation the x_sub - relation has to be
3865 * corrected. We therefore create "pseudo-momenta" of mother-nucleons.
3867 * The old version was to scale based on the original x_sub and the
3868 * 4-momenta of the subsystem. At very high energy this could lead to
3869 * "pseudo-cm energies" of the parent system considerably exceeding
3870 * the true cm energy. Now we keep the true cm energy and calculate
3871 * new x_sub instead.
3872 C old version PPTCMS(4) = PPSUB(4)/XPSUB
3873 PPTCMS(4) = MAX(PPTCMS(4),PPSUB(4))
3874 XPSUB = PPSUB(4)/PPTCMS(4)
3875 IF (IJPROJ.EQ.7) THEN
3876 AMP2 = PHKK(5,MOT)**2
3877 PTOT1 = SQRT(PPTCMS(4)**2-AMP2)
3880 PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOP))
3881 & *(PPTCMS(4)+PHKK(5,MOP)))
3882 C PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOT))
3883 C & *(PPTCMS(4)+PHKK(5,MOT)))
3885 C old version PTTCMS(4) = PTSUB(4)/XTSUB
3886 PTTCMS(4) = MAX(PTTCMS(4),PTSUB(4))
3887 XTSUB = PTSUB(4)/PTTCMS(4)
3888 PTOT2 = SQRT((PTTCMS(4)-PHKK(5,MOT))
3889 & *(PTTCMS(4)+PHKK(5,MOT)))
3891 PPTCMS(K) = PTOT1*PPSUB(K)/PPSUTO
3892 PTTCMS(K) = PTOT2*PTSUB(K)/PTSUTO
3897 * ppnn / ptnn - momenta of the int. nucleons (cms, negl. Fermi)
3898 * ptotnn - total momentum of the int. nucleons (cms, negl. Fermi)
3899 * pptcms/ pttcms - momenta of the interacting nucleons (cms)
3900 * pp1,2 / pt1,2 - momenta of the four partons
3902 * pp / pt - total momenta of the pr/ta partons (cms, negl. Fermi)
3903 * ptot - total momentum of the four partons (cms, negl. Fermi)
3904 * ppsub / ptsub - total momenta of the proj / targ partons (cms)
3906 c PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
3907 c & (PPTCMS(2)+PTTCMS(2))**2 +
3908 c & (PPTCMS(3)+PTTCMS(3))**2 )
3909 c ENEWCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
3910 c & (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
3911 c PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
3912 c & (PPSUB(2)+PTSUB(2))**2 +
3913 c & (PPSUB(3)+PTSUB(3))**2 )
3914 c ENEWSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
3915 c & (PPSUB(4)+PTSUB(4)+PTOTSU) )
3916 c IF (ENEWCM/EOLDCM.GT.1.1D0) THEN
3917 c WRITE(*,*) ' EOLDCM, ENEWCM : ',EOLDCM,ENEWCM
3918 c WRITE(*,*) ' EOLDSU, ENEWSU : ',EOLDSU,ENEWSU
3919 c WRITE(*,*) ' XPSUB, XTSUB : ',XPSUB,XTSUB
3921 c BBGX = (PPTCMS(1)+PTTCMS(1))/ENEWCM
3922 c BBGY = (PPTCMS(2)+PTTCMS(2))/ENEWCM
3923 c BBGZ = (PPTCMS(3)+PTTCMS(3))/ENEWCM
3924 c BGAM = (PPTCMS(4)+PTTCMS(4))/ENEWCM
3925 * transform interacting nucleons into nucleon-nucleon cm-system
3926 c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3927 c & PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4),PPTOT,
3928 c & PPNEW1,PPNEW2,PPNEW3,PPNEW4)
3929 c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3930 c & PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4),PTTOT,
3931 c & PTNEW1,PTNEW2,PTNEW3,PTNEW4)
3932 c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3933 c & PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4),PPTOT,
3934 c & PPSUB1,PPSUB2,PPSUB3,PPSUB4)
3935 c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3936 c & PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4),PTTOT,
3937 c & PTSUB1,PTSUB2,PTSUB3,PTSUB4)
3938 c PTSTCM = SQRT( (PPNEW1+PTNEW1)**2 +
3939 c & (PPNEW2+PTNEW2)**2 +
3940 c & (PPNEW3+PTNEW3)**2 )
3941 c ETSTCM = SQRT( (PPNEW4+PTNEW4-PTSTCM) *
3942 c & (PPNEW4+PTNEW4+PTSTCM) )
3943 c PTSTSU = SQRT( (PPSUB1+PTSUB1)**2 +
3944 c & (PPSUB2+PTSUB2)**2 +
3945 c & (PPSUB3+PTSUB3)**2 )
3946 c ETSTSU = SQRT( (PPSUB4+PTSUB4-PTSTSU) *
3947 c & (PPSUB4+PTSUB4+PTSTSU) )
3948 C WRITE(*,*) ' mother cmE :'
3949 C WRITE(*,*) ETSTCM,ENEWCM
3950 C WRITE(*,*) ' subsystem cmE :'
3951 C WRITE(*,*) ETSTSU,ENEWSU
3952 C WRITE(*,*) ' projectile mother :'
3953 C WRITE(*,*) PPNEW1,PPNEW2,PPNEW3,PPNEW4
3954 C WRITE(*,*) ' target mother :'
3955 C WRITE(*,*) PTNEW1,PTNEW2,PTNEW3,PTNEW4
3956 C WRITE(*,*) ' projectile subsystem:'
3957 C WRITE(*,*) PPSUB1,PPSUB2,PPSUB3,PPSUB4
3958 C WRITE(*,*) ' target subsystem:'
3959 C WRITE(*,*) PTSUB1,PTSUB2,PTSUB3,PTSUB4
3960 C WRITE(*,*) ' projectile subsystem should be:'
3961 C WRITE(*,*) ZERO,ZERO,XPSUB*ETSTCM/2.0D0,
3962 C & XPSUB*ETSTCM/2.0D0
3963 C WRITE(*,*) ' target subsystem should be:'
3964 C WRITE(*,*) ZERO,ZERO,-XTSUB*ETSTCM/2.0D0,
3965 C & XTSUB*ETSTCM/2.0D0
3966 C WRITE(*,*) ' subsystem cmE should be: '
3967 C WRITE(*,*) SQRT(XPSUB*XTSUB)*ETSTCM,XPSUB,XTSUB
3970 * generate complete remnant - nucleon/remnant event with PHOJET
3971 CALL PHO_EVENT(3,PPTCMS,PTTCMS,DUM,IREJ1)
3973 * copy back original settings of PHOJET process flags
3975 IPRON(K,1) = KPRON(K)
3978 * check if PHOJET has rejected this event
3979 IF (IREJ1.NE.0) THEN
3981 & WRITE(LOUT,'(1X,A)') 'EVENTB: chain system rejected'
3983 & 'XPSUB,XTSUB,SECM ',XPSUB,XTSUB,SECM,AMTOT
3988 * copy partons and strings from PHOJET common back into DTEVT for
3989 * external fragmentation
3992 *! uncomment this line for internal phojet-fragmentation
3993 C CALL DT_GETFSP(MO1,MO2,PP,PT,1)
3995 CALL DT_GETPJE(MO1,MO2,PP,PT,1,NPHOSC,IREJ1)
3996 IF (IREJ1.NE.0) THEN
3997 IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
3998 & 'EVENTB: chain system rejected 2'
4002 * update statistics counter
4003 ICEVTG(IDCH(NC),2) = ICEVTG(IDCH(NC),2)+1
4005 *-----------------------------------------------------------------------
4006 * two-chain approx. for smaller systems
4011 * special flag for double-Pomeron statistics
4014 * pick up flavors at the ends of the two chains
4019 * ..and the indices of the mothers
4024 CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
4025 & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
4027 * check if this chain system was rejected
4028 IF (IREJ1.GT.0) THEN
4029 IF (IOULEV(1).GT.0) THEN
4030 WRITE(LOUT,*) 'rejected 1 in EVENTB'
4031 WRITE(LOUT,'(1X,4(I6,4E12.3,/),E12.3)')
4032 & IFP1,PP1,IFT1,PT1,IFP2,PP2,IFT2,PT2,AMTOT
4037 * the following lines are for sea-sea chains rejected in GETCSY
4038 IF (IREJ1.EQ.-1) NDTUSC = NDTUSC-1
4039 ICEVTG(IDCH(NC),1) = ICEVTG(IDCH(NC),1)+1
4044 * update statistics counter
4045 ICEVTG(IDCH(NC),0) = ICEVTG(IDCH(NC),0)+1
4051 *-----------------------------------------------------------------------
4052 * treatment of low-mass chains (if there are any)
4054 IF (NDTUSC.GT.0) THEN
4056 * correct chains of very low masses for possible resonances
4057 IF (IRESCO.EQ.1) THEN
4058 CALL DT_EVTRES(IREJ1)
4059 IF (IREJ1.GT.0) THEN
4060 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2a in EVENTB'
4061 IRRES(1) = IRRES(1)+1
4065 * fragmentation of low-mass chains
4066 *! uncomment this line for internal phojet-fragmentation
4067 * (of course it will still be fragmented by DPMJET-routines but it
4068 * has to be done here instead of further below)
4069 C CALL DT_EVTFRA(IREJ1)
4070 C IF (IREJ1.GT.0) THEN
4071 C IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2b in EVENTB'
4076 *! uncomment this line for internal phojet-fragmentation
4077 C NPOINT(4) = NHKK+1
4078 IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
4081 *-----------------------------------------------------------------------
4082 * new di-quark breaking mechanisms
4086 IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
4087 & .OR.(PDBSEA(3).GT.0.0D0)) THEN
4092 *-----------------------------------------------------------------------
4093 * hadronize this event
4095 * hadronize PHOJET chain systems
4097 NPJE = NPHOSC/MXPHFR
4098 IF (MXPHFR.LT.MXLEFT) MXLEFT = 2
4100 NLEFT = NPHOSC-NPJE*MXPHFR
4103 IF ((JFRG.EQ.NPJE).AND.(NLEFT.LE.MXLEFT)) THEN
4104 CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4105 IF (IREJ1.GT.0) GOTO 22
4108 CALL DT_EVTFRG(1,NFRG,NPYMEM,IREJ1)
4109 IF (IREJ1.GT.0) GOTO 22
4111 IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4113 IF (NLEFT.GT.0) THEN
4114 CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4115 IF (IREJ1.GT.0) GOTO 22
4116 IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4119 CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4120 IF (IREJ1.GT.0) GOTO 22
4121 IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4124 * check max. filling level of jetset common and
4125 * reduce mxphfr if necessary
4126 IF (NPYMAX.GT.3000) THEN
4127 IF (NPYMAX.GT.3500) THEN
4128 MXPHFR = MAX(1,MXPHFR-2)
4130 MXPHFR = MAX(1,MXPHFR-1)
4132 C WRITE(LOUT,*) ' EVENTB: Mxphfr reduced to ',MXPHFR
4135 * hadronize DTUNUC chain systems
4138 CALL DT_EVTFRG(2,IBACK,NPYMEM,IREJ2)
4139 IF (IREJ2.GT.0) GOTO 22
4141 * check max. filling level of jetset common and
4142 * reduce mxdtfr if necessary
4143 IF (NPYMEM.GT.3000) THEN
4144 IF (NPYMEM.GT.3500) THEN
4145 MXDTFR = MAX(1,MXDTFR-20)
4147 MXDTFR = MAX(1,MXDTFR-10)
4149 C WRITE(LOUT,*) ' EVENTB: Mxdtfr reduced to ',MXDTFR
4152 IF (IBACK.EQ.-1) GOTO 23
4155 C CALL DT_EVTFRG(1,IREJ1)
4156 C CALL DT_EVTFRG(2,IREJ2)
4157 IF ((IREJ1.GT.0).OR.(IREJ2.GT.0)) THEN
4158 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTB'
4163 * get final state particles from /DTEVTP/
4164 *! uncomment this line for internal phojet-fragmentation
4165 C CALL DT_GETFSP(IDUM,IDUM,PP,PT,2)
4168 & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,88,IREJ3)
4169 C IF (IREJ3.NE.0) GOTO 9999
4179 *$ CREATE DT_GETPJE.FOR
4182 *===getpje=============================================================*
4184 SUBROUTINE DT_GETPJE(MO1,MO2,PP,PT,MODE,IPJE,IREJ)
4186 ************************************************************************
4187 * This subroutine copies PHOJET partons and strings from POEVT1 into *
4189 * MO1,MO2 indices of first and last mother-parton in DTEVT1 *
4190 * PP,PT 4-momenta of projectile/target being handled by *
4192 * This version dated 11.12.99 is written by S. Roesler *
4193 ************************************************************************
4195 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4197 PARAMETER ( LINP = 10 ,
4200 PARAMETER (TINY10=1.0D-10,TINY1=1.0D-1,
4201 & ZERO=0.0D0,ONE=1.0D0,OHALF=0.5D0)
4206 PARAMETER (NMXHKK=200000)
4207 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
4208 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
4209 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
4210 * extended event history
4211 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
4212 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
4214 * Lorentz-parameters of the current interaction
4215 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4216 & UMO,PPCM,EPROJ,PPROJ
4217 * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
4218 COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
4219 * flags for input different options
4220 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
4221 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
4222 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
4223 * statistics: double-Pomeron exchange
4224 COMMON /DTFLG2/ INTFLG,IPOPO
4226 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
4227 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
4230 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
4231 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
4232 & IREXCI(3),IRDIFF(2),IRINC
4233 C standard particle data interface
4235 PARAMETER (NMXHEP=4000)
4236 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
4237 DOUBLE PRECISION PHEP,VHEP
4238 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
4239 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
4240 & VHEP(4,NMXHEP), NSD1, NSD2, NDD
4241 C extension to standard particle data interface (PHOJET specific)
4242 INTEGER IMPART,IPHIST,ICOLOR
4243 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
4244 C color string configurations including collapsed strings and hadrons
4246 PARAMETER (MSTR=500)
4247 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
4248 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
4249 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
4250 & NNCH(MSTR),IBHAD(MSTR),ISTR
4251 C general process information
4252 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
4253 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
4254 C model switches and parameters
4256 INTEGER ISWMDL,IPAMDL
4257 DOUBLE PRECISION PARMDL
4258 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4259 C event debugging information
4261 PARAMETER (NMAXD=100)
4262 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4263 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4264 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4265 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4267 DIMENSION PP(4),PT(4)
4277 * store initial momenta for energy-momentum conservation check
4279 CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM1,IDUM2)
4280 CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM1,IDUM2)
4282 * copy partons and strings from POEVT1 into DTEVT1
4284 C IF ((NCODE(I).EQ.-99).AND.(IPAMDL(17).EQ.0)) THEN
4285 IF (NCODE(I).EQ.-99) THEN
4287 IDSTG = IDHEP(IDXSTG)
4294 CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PX,PY,PZ,PE,
4301 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4304 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4307 CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PPX,PPY,PPZ,PPE,
4314 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4318 IHIST(1,NHKK) = IPHIST(1,IDXSTG)
4320 ELSEIF (NCODE(I).GE.0) THEN
4321 * indices of partons and string in POEVT1
4322 IDX1 = ABS(JMOHEP(1,NPOS(1,I)))
4323 IDX2 = ABS(JMOHEP(2,NPOS(1,I)))
4324 IF ((IDX1.GT.IDX2).OR.(JMOHEP(2,NPOS(1,I)).GT.0)) THEN
4325 WRITE(LOUT,*) ' GETPJE: IDX1.GT.IDX2 ',IDX1,IDX2,
4326 & ' or JMOHEP(2,NPOS(1,I)).GT.0 ',JMOHEP(2,NPOS(1,I)),' ! '
4330 * find "mother" string of the string
4331 IDXMS1 = ABS(JMOHEP(1,IDX1))
4332 IDXMS2 = ABS(JMOHEP(1,IDX2))
4333 IF (IDXMS1.NE.IDXMS2) THEN
4336 C STOP ' GETPJE: IDXMS1.NE.IDXMS2 !'
4338 * search POEVT1 for the original hadron of the parton
4343 IF (IDHEP(IDXMS1).EQ.990) IPOM1 = 1
4344 IDXMS1 = ABS(JMOHEP(1,IDXMS1))
4345 IF ((IDXMS1.NE.1).AND.(IDXMS1.NE.2).AND.
4346 & (ILOOP.LT.MAXLOP)) GOTO 14
4347 IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 1 ! '
4352 IF (IDHEP(IDXMS2).EQ.990) IPOM2 = 1
4353 IF ((ILOOP.EQ.1).OR.(IDHEP(IDXMS2).GE.7777)) THEN
4354 IDXMS2 = ABS(JMOHEP(2,IDXMS2))
4356 IDXMS2 = ABS(JMOHEP(1,IDXMS2))
4358 IF ((IDXMS2.NE.1).AND.(IDXMS2.NE.2).AND.
4359 & (ILOOP.LT.MAXLOP)) GOTO 15
4360 IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 5 ! '
4362 IF (IDXMS1.EQ.1) THEN
4363 ISPTN1 = ISTHKK(MO1)
4367 ISPTN1 = ISTHKK(MO2)
4372 IF (IDXMS2.EQ.1) THEN
4373 ISPTN2 = ISTHKK(MO1)
4377 ISPTN2 = ISTHKK(MO2)
4381 * check for mis-identified mothers and switch mother indices if necessary
4382 IF ((IDXMS1.EQ.IDXMS2).AND.(IPROCE.NE.5).AND.(IPROCE.NE.6)
4383 & .AND.((IDHEP(IDX1).NE.21).OR.(IDHEP(IDX2).NE.21)).AND.
4385 IF (PHEP(3,IDX1).GT.PHEP(3,IDX2)) THEN
4386 ISPTN1 = ISTHKK(MO1)
4389 ISPTN2 = ISTHKK(MO2)
4393 ISPTN1 = ISTHKK(MO2)
4396 ISPTN2 = ISTHKK(MO1)
4401 * register partons in temporary common
4402 * parton at chain end
4407 * flag only partons coming from Pomeron with 41/42
4408 C IF ((IPOM1.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4409 IF (IPOM1.NE.0) THEN
4410 ISTX = ABS(ISPTN1)/10
4411 IMO = ABS(ISPTN1)-10*ISTX
4414 IF ((ICOLOR(2,IDX1).EQ.0).OR.(IDHEP(IDX1).EQ.21)) THEN
4415 ISTX = ABS(ISPTN1)/10
4416 IMO = ABS(ISPTN1)-10*ISTX
4417 IF ((IDHEP(IDX1).EQ.21).OR.
4418 & (ABS(IPHIST(1,IDX1)).GE.100)) THEN
4425 IF (ISPTN1.EQ.-21) NPVAL = NPVAL+1
4426 IF (ISPTN1.EQ.-22) NTVAL = NTVAL+1
4428 CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PX,PY,
4431 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4433 CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PPX,PPY,
4436 IHIST(1,NHKK) = IPHIST(1,IDX1)
4439 VHKK(KK,NHKK) = VHKK(KK,M2PTN1)
4440 WHKK(KK,NHKK) = WHKK(KK,M1PTN1)
4442 VHKK(4,NHKK) = VHKK(3,M2PTN1)/BLAB-VHKK(3,M1PTN1)/BGLAB
4443 WHKK(4,NHKK) = -WHKK(3,M1PTN1)/BLAB+WHKK(3,M2PTN1)/BGLAB
4446 NGLUON = IDX2-IDX1-1
4447 IF (NGLUON.GT.0) THEN
4448 DO 17 IGLUON=1,NGLUON
4450 IDXMS = ABS(JMOHEP(1,IDX))
4451 IF ((IDXMS.NE.1).AND.(IDXMS.NE.2)) THEN
4455 IDXMS = ABS(JMOHEP(1,IDXMS))
4456 IF ((IDXMS.NE.1).AND.(IDXMS.NE.2).AND.
4457 & (ILOOP.LT.MAXLOP)) GOTO 16
4458 IF (ILOOP.EQ.MAXLOP)
4459 & WRITE(LOUT,*) ' GETPJE: MAXLOP in 3 ! '
4461 IF (IDXMS.EQ.1) THEN
4474 IF ((ICOLOR(2,IDX).EQ.0).OR.(IDHEP(IDX).EQ.21)) THEN
4475 ISTX = ABS(ISPTN)/10
4476 IMO = ABS(ISPTN)-10*ISTX
4477 IF ((IDHEP(IDX).EQ.21).OR.
4478 & (ABS(IPHIST(1,IDX)).GE.100)) THEN
4484 IF (ISPTN.EQ.-21) NPVAL = NPVAL+1
4485 IF (ISPTN.EQ.-22) NTVAL = NTVAL+1
4487 CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4488 & PX,PY,PZ,PE,0,0,0)
4490 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4492 CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4493 & PPX,PPY,PPZ,PPE,0,0,0)
4495 IHIST(1,NHKK) = IPHIST(1,IDX)
4498 VHKK(KK,NHKK) = VHKK(KK,M2PTN)
4499 WHKK(KK,NHKK) = WHKK(KK,M1PTN)
4501 VHKK(4,NHKK)= VHKK(3,M2PTN)/BLAB-VHKK(3,M1PTN)/BGLAB
4502 WHKK(4,NHKK)= -WHKK(3,M1PTN)/BLAB+WHKK(3,M2PTN)/BGLAB
4505 * parton at chain end
4510 * flag only partons coming from Pomeron with 41/42
4511 C IF ((IPOM2.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4512 IF (IPOM2.NE.0) THEN
4513 ISTX = ABS(ISPTN2)/10
4514 IMO = ABS(ISPTN2)-10*ISTX
4517 IF ((ICOLOR(2,IDX2).EQ.0).OR.(IDHEP(IDX2).EQ.21)) THEN
4518 ISTX = ABS(ISPTN2)/10
4519 IMO = ABS(ISPTN2)-10*ISTX
4520 IF ((IDHEP(IDX2).EQ.21).OR.
4521 & (ABS(IPHIST(1,IDX2)).GE.100)) THEN
4528 IF (ISPTN2.EQ.-21) NPVAL = NPVAL+1
4529 IF (ISPTN2.EQ.-22) NTVAL = NTVAL+1
4531 CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4532 & PX,PY,PZ,PE,0,0,0)
4534 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4536 CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4537 & PPX,PPY,PPZ,PPE,0,0,0)
4539 IHIST(1,NHKK) = IPHIST(1,IDX2)
4542 VHKK(KK,NHKK) = VHKK(KK,M2PTN2)
4543 WHKK(KK,NHKK) = WHKK(KK,M1PTN2)
4545 VHKK(4,NHKK) = VHKK(3,M2PTN2)/BLAB-VHKK(3,M1PTN2)/BGLAB
4546 WHKK(4,NHKK) = -WHKK(3,M1PTN2)/BLAB+WHKK(3,M2PTN2)/BGLAB
4549 JSTRG = 100*IPROCE+NCODE(I)
4556 CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4557 & PX,PY,PZ,PE,0,0,0)
4563 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4566 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4569 CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4570 & PPX,PPY,PPZ,PPE,0,0,0)
4576 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4583 VHKK(KK,NHKK) = VHKK(KK,MO2)
4584 WHKK(KK,NHKK) = WHKK(KK,MO1)
4586 VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
4587 WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
4591 IF ( ((NPVAL.GT.2).OR.(NTVAL.GT.2)).AND.(LFLIP) ) THEN
4598 IF (UMO.GT.1.0D5) THEN
4603 CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,1000,IREJ2)
4604 IF (IREJ2.GT.ZERO) CALL PHO_PREVNT(0)
4607 * internal statistics
4608 * dble-Po statistics.
4609 IF (IPROCE.NE.4) IPOPO = 0
4613 IF ((IPROCE.GE.1).AND.(IPROCE.LE.8)) THEN
4614 ICEVTG(IDCHSY,IPROCE+2) = ICEVTG(IDCHSY,IPROCE+2)+1
4616 WRITE(LOUT,1000) IPROCE,NEVHKK,MO1
4617 1000 FORMAT(1X,'GETFSP: warning! incons. process id. (',I2,
4618 & ') at evt(chain) ',I6,'(',I2,')')
4620 IF (IPROCE.EQ.5) THEN
4621 IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3)) THEN
4622 ICEVTG(IDCHSY,18+IDIFR1) = ICEVTG(IDCHSY,18+IDIFR1)+1
4624 C WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4625 1001 FORMAT(1X,'GETFSP: warning! incons. diffrac. id. ',
4626 & '(IPROCE,IDIFR1,IDIFR2=',3I3,')')
4628 ELSEIF (IPROCE.EQ.6) THEN
4629 IF ((IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4630 ICEVTG(IDCHSY,21+IDIFR2) = ICEVTG(IDCHSY,21+IDIFR2)+1
4632 C WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4634 ELSEIF (IPROCE.EQ.7) THEN
4635 IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3).AND.
4636 & (IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4637 IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.1))
4638 & ICEVTG(IDCHSY,25) = ICEVTG(IDCHSY,25)+1
4639 IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.2))
4640 & ICEVTG(IDCHSY,26) = ICEVTG(IDCHSY,26)+1
4641 IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.2))
4642 & ICEVTG(IDCHSY,27) = ICEVTG(IDCHSY,27)+1
4643 IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.1))
4644 & ICEVTG(IDCHSY,28) = ICEVTG(IDCHSY,28)+1
4646 WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4649 IF ((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GE.1).AND.(KHDIR.LE.3))
4651 ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4652 ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4653 ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4655 ICEVTG(IDCHSY,14) = ICEVTG(IDCHSY,14)+KSPOM
4656 ICEVTG(IDCHSY,15) = ICEVTG(IDCHSY,15)+KHPOM
4657 ICEVTG(IDCHSY,16) = ICEVTG(IDCHSY,16)+KSREG
4658 ICEVTG(IDCHSY,17) = ICEVTG(IDCHSY,17)+(KSTRG+KHTRG)
4659 ICEVTG(IDCHSY,18) = ICEVTG(IDCHSY,18)+(KSLOO+KHLOO)
4668 *$ CREATE DT_PHOINI.FOR
4671 *===phoini=============================================================*
4673 SUBROUTINE DT_PHOINI
4675 ************************************************************************
4676 * Initialization PHOJET-event generator for nucleon-nucleon interact. *
4677 * This version dated 16.11.95 is written by S. Roesler *
4679 * Last change 27.12.2006 by S. Roesler. *
4680 ************************************************************************
4682 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4684 PARAMETER ( LINP = 10 ,
4687 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
4689 * nucleon-nucleon event-generator
4692 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
4693 * particle properties (BAMJET index convention)
4695 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
4696 & IICH(210),IIBAR(210),K1(210),K2(210)
4697 * Lorentz-parameters of the current interaction
4698 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4699 & UMO,PPCM,EPROJ,PPROJ
4700 * properties of interacting particles
4701 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
4702 * properties of photon/lepton projectiles
4703 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
4704 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
4705 * emulsion treatment
4706 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
4708 * VDM parameter for photon-nucleus interactions
4709 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
4712 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
4713 & EBINDP(2),EBINDN(2),EPOT(2,210),
4714 & ETACOU(2),ICOUL,LFERMI
4715 * Glauber formalism: flags and parameters for statistics
4718 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
4720 * parameters for cascade calculations:
4721 * maximum mumber of PDF's which can be defined in phojet (limited
4722 * by the dimension of ipdfs in pho_setpdf)
4723 PARAMETER (MAXPDF = 20)
4724 * PDF parametrization and number of set for the first 30 hadrons in
4725 * the bamjet-code list
4726 * negative numbers mean that the PDF is set in phojet,
4727 * zero stands for "not a hadron"
4728 DIMENSION IPARPD(30),ISETPD(30)
4729 * PDF parametrization
4731 & -5,-5, 0, 0, 0, 0,-5,-5,-5, 0, 0, 5,-5,-5, 5, 5, 5, 5, 5, 5,
4732 & 5, 5,-5, 5, 5, 0, 0, 0, 0, 0/
4735 & -6,-6, 0, 0, 0, 0,-3,-6,-6, 0, 0, 2,-2,-2, 2, 2, 6, 6, 2, 6,
4736 & 6, 6,-2, 2, 2, 0, 0, 0, 0, 0/
4739 C COMMON /GLOCMS/ XECM,XPCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
4740 C PARAMETER ( MAXPRO = 16 )
4741 C PARAMETER ( MAXTAB = 20 )
4742 C COMMON /HAXSEC/ XSECTA(4,-1:MAXPRO,4,MAXTAB),XSECT(6,-1:MAXPRO),
4743 C & MXSECT(0:4,-1:MAXPRO,4),ECMSH(4,MAXTAB),ISTTAB
4745 C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
4746 C COMMON /PROCES/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15)
4748 C global event kinematics and particle IDs
4750 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
4751 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
4752 C hard cross sections and MC selection weights
4754 PARAMETER ( Max_pro_2 = 16 )
4755 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
4757 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
4758 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
4759 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
4760 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
4761 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
4762 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
4763 C model switches and parameters
4765 INTEGER ISWMDL,IPAMDL
4766 DOUBLE PRECISION PARMDL
4767 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4768 C general process information
4769 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
4770 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
4772 DIMENSION PP(4),PT(4)
4775 DATA LSTART /.TRUE./
4780 * lepton-projectiles: initialize real photon instead
4781 IF ((IJP.EQ.3).OR.(IJP.EQ.4).OR.(IJP.EQ.10).OR.(IJP.EQ.11)) THEN
4785 IF (LPHOIN) CALL PHO_INIT(-1,LOUT,IDUM)
4786 * switch Reggeon off
4789 IFPAP(1) = IDT_IPDGHA(IJP)
4793 IFPAB(1) = IDT_ICIHAD(IFPAP(1))
4795 PMASS(1) = AAM(IFPAB(1))-SQRT(Q2)
4796 PVIRT(1) = PMASS(1)**2
4798 IFPAP(2) = IDT_IPDGHA(IJT)
4802 IFPAB(2) = IDT_ICIHAD(IFPAP(2))
4804 PMASS(2) = AAM(IFPAB(2))
4810 * get max. possible momenta of incoming particles to be used for PHOJET ini.
4814 IF (UMO.GE.1.E5) THEN
4817 IF (NCOMPO.GT.0) THEN
4820 CALL DT_NCLPOT(IEMUCH(I),IEMUMA(I),ITZ,IT,ZERO,ZERO,0)
4822 CALL DT_NCLPOT(IPZ,IP,IEMUCH(I),IEMUMA(I),ZERO,ZERO,0)
4824 PPFTMP = MAX(PFERMP(1),PFERMN(1))
4825 PTFTMP = MAX(PFERMP(2),PFERMN(2))
4826 IF (PPFTMP.GT.PPF) PPF = PPFTMP
4827 IF (PTFTMP.GT.PTF) PTF = PTFTMP
4830 CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
4831 PPF = MAX(PFERMP(1),PFERMN(1))
4832 PTF = MAX(PFERMP(2),PFERMN(2))
4838 AMP2 = SIGN(PMASS(1)**2,PMASS(1))
4840 PP(4) = SQRT(AMP2+PP(3)**2)
4842 EPF = SQRT(PPF**2+PMASS(1)**2)
4843 CALL DT_LTNUC(PPF,EPF,PP(3),PP(4),2)
4845 ETF = SQRT(PTF**2+PMASS(2)**2)
4846 CALL DT_LTNUC(PTF,ETF,PT(3),PT(4),3)
4847 ECMINI = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
4848 & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
4850 WRITE(LOUT,1001) IP,IPZ,SCPF,PPF,PP
4852 & ' DT_PHOINI: PHOJET initialized for projectile A,Z = ',
4853 & I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
4854 IF (NCOMPO.GT.0) THEN
4855 WRITE(LOUT,1002) SCPF,PTF,PT
4857 WRITE(LOUT,1003) IT,ITZ,SCPF,PTF,PT
4860 & ' DT_PHOINI: PHOJET initialized for target emulsion ',
4861 & /,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
4863 & ' DT_PHOINI: PHOJET initialized for target A,Z = ',
4864 & I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
4865 WRITE(LOUT,1004) ECMINI
4866 1004 FORMAT(' E_cm = ',E10.3)
4867 IF (IJP.EQ.8) WRITE(LOUT,1005)
4869 & ' DT_PHOINI: warning! proton parameters used for neutron',
4873 * switch off new diffractive cross sections at low energies for nuclei
4874 * (temporary solution)
4875 IF ((ISWMDL(30).NE.0).AND.((IP.GT.1).OR.(IT.GT.1))) THEN
4876 WRITE(LOUT,'(1X,A)')
4877 & ' DT_PHOINI: model-switch 30 for nuclei re-set !'
4878 CALL PHO_SETMDL(30,0,1)
4881 C IF (IJP.EQ.7) THEN
4882 C AMP2 = SIGN(PMASS(1)**2,PMASS(1))
4884 C PP(4) = SQRT(AMP2+PP(3)**2)
4887 C IF (IP.GT.1) PFERMX = 0.5D0
4888 C EFERMX = SQRT(PFERMX**2+PMASS(1)**2)
4889 C CALL DT_LTNUC(PFERMX,EFERMX,PP(3),PP(4),2)
4892 C IF ((IT.GT.1).OR.(NCOMPO.GT.0)) PFERMX = -0.5D0
4893 C EFERMX = SQRT(PFERMX**2+PMASS(2)**2)
4894 C CALL DT_LTNUC(PFERMX,EFERMX,PT(3),PT(4),3)
4897 IF ((ISHAD(2).EQ.1).AND.
4898 & ((IJPROJ.EQ. 7).OR.(IJPROJ.EQ.3).OR.(IJPROJ.EQ.4).OR.
4899 & (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11))) IPAMDL(13) = 1
4901 CALL PHO_EVENT(-1,PP,PT,SIGMAX,IREJ1)
4906 * patch for cascade calculations:
4907 * define parton distribution functions for other hadrons, i.e. other
4908 * then defined already in phojet
4909 IF (IOGLB.EQ.100) THEN
4911 1006 FORMAT(/,1X,'PHOINI: additional parton distribution functions',
4912 & ' assiged (ID,IPAR,ISET)',/)
4915 IF (IPARPD(I).NE.0) THEN
4917 IF (NPDF.GT.MAXPDF) STOP ' PHOINI: npdf > maxpdf !'
4918 IF ((IPARPD(I).GT.0).AND.(ISETPD(I).GT.0)) THEN
4919 IDPDG = IDT_IPDGHA(I)
4922 WRITE(LOUT,'(13X,A8,3I6)') ANAME(I),IDPDG,IPAR,ISET
4923 CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,0,0,-1)
4929 C CALL PHO_PHIST(-1,SIGMAX)
4930 IF (IREJ1.NE.0) THEN
4932 1000 FORMAT(1X,'PHOINI: PHOJET event-initialization failed!')
4939 *$ CREATE DT_EVENTD.FOR
4942 *===eventd=============================================================*
4944 SUBROUTINE DT_EVENTD(IREJ)
4946 ************************************************************************
4947 * Quasi-elastic neutrino nucleus scattering. *
4948 * This version dated 29.04.00 is written by S. Roesler. *
4949 ************************************************************************
4951 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4953 PARAMETER ( LINP = 10 ,
4956 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY5=1.0D-5)
4957 PARAMETER (SQTINF=1.0D+15)
4962 PARAMETER (NMXHKK=200000)
4963 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
4964 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
4965 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
4966 * extended event history
4967 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
4968 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
4970 * flags for input different options
4971 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
4972 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
4973 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
4974 PARAMETER (MAXLND=4000)
4975 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
4976 * properties of interacting particles
4977 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
4978 * Lorentz-parameters of the current interaction
4979 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4980 & UMO,PPCM,EPROJ,PPROJ
4983 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
4984 & EBINDP(2),EBINDN(2),EPOT(2,210),
4985 & ETACOU(2),ICOUL,LFERMI
4986 * steering flags for qel neutrino scattering modules
4987 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
4988 COMMON /QNPOL/ POLARX(4),PMODUL
4991 DATA LFIRST /.TRUE./
5003 * interacting target nucleon
5005 IF (NEUDEC.LE.9) THEN
5006 IF ((LTYP.EQ.1).OR.(LTYP.EQ.3).OR.(LTYP.EQ.5)) THEN
5014 RTYP = DT_RNDM(RTYP)
5015 ZFRAC = DBLE(ITZ)/DBLE(IT)
5016 IF (RTYP.LE.ZFRAC) THEN
5025 * select first nucleon in list with matching id and reset all other
5026 * nucleons which have been marked as "wounded" by ININUC
5029 IF ((IDHKK(I).EQ.NUCTYP).AND.(IFOUND.EQ.0)) THEN
5034 IF (ISTHKK(I).EQ.12) ISTHKK(I) = 14
5038 & STOP ' EVENTD: interacting target nucleon not found! '
5040 * correct position of proj. lepton: assume position of target nucleon
5042 VHKK(I,1) = VHKK(I,IDX)
5043 WHKK(I,1) = WHKK(I,IDX)
5046 * load initial momenta for conservation check
5048 CALL DT_EVTEMC(ZERO,ZERO,PPROJ,EPROJ,1,IDUM,IDUM)
5049 CALL DT_EVTEMC(PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),PHKK(4,IDX),
5053 * quasi-elastic scattering
5054 IF (NEUDEC.LT.9) THEN
5055 CALL DT_QEL_POL(EPROJ,LTYP,PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),
5056 & PHKK(4,IDX),PHKK(5,IDX))
5057 * CC event on p or n
5058 ELSEIF (NEUDEC.EQ.10) THEN
5059 CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,1,PHKK(1,IDX),PHKK(2,IDX),
5060 & PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5061 * NC event on p or n
5062 ELSEIF (NEUDEC.EQ.11) THEN
5063 CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,2,PHKK(1,IDX),PHKK(2,IDX),
5064 & PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5067 * get final state particles from Lund-common and write them into HKKEVT
5073 IF (K(I,1).EQ.1) THEN
5079 CALL DT_EVTPUT(1,ID,1,IDX,PX,PY,PZ,PE,0,0,0)
5080 IDBJ = IDT_ICIHAD(ID)
5081 EKIN = PHKK(4,NHKK)-PHKK(5,NHKK)
5082 IF ((IDBJ.EQ.1).OR.(IDBJ.EQ.8)) THEN
5083 IF (EKIN.LE.EPOT(2,IDBJ)) ISTHKK(NHKK) = 16
5085 VHKK(1,NHKK) = VHKK(1,IDX)
5086 VHKK(2,NHKK) = VHKK(2,IDX)
5087 VHKK(3,NHKK) = VHKK(3,IDX)
5088 VHKK(4,NHKK) = VHKK(4,IDX)
5090 C WHKK(1,NHKK) = POLARX(1)
5091 C WHKK(2,NHKK) = POLARX(2)
5092 C WHKK(3,NHKK) = POLARX(3)
5093 C WHKK(4,NHKK) = POLARX(4)
5095 WHKK(1,NHKK) = WHKK(1,IDX)
5096 WHKK(2,NHKK) = WHKK(2,IDX)
5097 WHKK(3,NHKK) = WHKK(3,IDX)
5098 WHKK(4,NHKK) = WHKK(4,IDX)
5100 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
5106 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,778,IREJ1)
5107 IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
5110 * transform momenta into cms (as required for inc etc.)
5112 IF (ISTHKK(I).EQ.1) THEN
5113 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,3)
5122 *$ CREATE DT_KKEVNT.FOR
5125 *===kkevnt=============================================================*
5127 SUBROUTINE DT_KKEVNT(KKMAT,IREJ)
5129 ************************************************************************
5130 * Treatment of complete nucleus-nucleus or hadron-nucleus scattering *
5131 * without nuclear effects (one event). *
5132 * This subroutine is an update of the previous version (KKEVT) written *
5133 * by J. Ranft/ H.-J. Moehring. *
5134 * This version dated 20.04.95 is written by S. Roesler *
5135 ************************************************************************
5137 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5139 PARAMETER ( LINP = 10 ,
5142 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10)
5144 PARAMETER ( MAXNCL = 260,
5146 & MAXSQU = 20*MAXVQU,
5147 & MAXINT = MAXVQU+MAXSQU)
5149 PARAMETER (NMXHKK=200000)
5150 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5151 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5152 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5153 * extended event history
5154 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5155 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5157 * flags for input different options
5158 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5159 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5160 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5162 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
5163 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
5164 & IREXCI(3),IRDIFF(2),IRINC
5166 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5167 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5169 * properties of interacting particles
5170 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5171 * Lorentz-parameters of the current interaction
5172 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5173 & UMO,PPCM,EPROJ,PPROJ
5174 * flags for diffractive interactions (DTUNUC 1.x)
5175 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
5176 * interface HADRIN-DPM
5177 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5178 * nucleon-nucleon event-generator
5181 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
5182 * coordinates of nucleons
5183 COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
5184 * interface between Glauber formalism and DPM
5185 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
5186 & INTER1(MAXINT),INTER2(MAXINT)
5187 * Glauber formalism: collision properties
5188 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5189 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
5191 * central particle production, impact parameter biasing
5192 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5194 * statistics: Glauber-formalism
5195 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
5198 DATA NEVOLD,IPOLD,ITOLD,JJPOLD,EPROLD /4*0,0.0D0/
5207 IF (MOD(NC,10).EQ.0) THEN
5208 WRITE(LOUT,1000) NEVHKK
5209 1000 FORMAT(1X,'KKEVNT: event ',I8,' rejected!')
5213 * initialize DTEVT1/DTEVT2
5216 * We need the following only in order to sample nucleon coordinates.
5217 * However we don't have parameters (cross sections, slope etc.)
5218 * for neutrinos available. Therefore switch projectile to proton
5220 IF (MCGENE.EQ.4) THEN
5227 IF ( (NEVHKK.NE.NEVOLD).OR.(ICENTR.GT.0).OR.
5228 * make sure that Glauber-formalism is called each time the interaction
5229 * configuration changed
5230 & (IP.NE.IPOLD).OR.(IT.NE.ITOLD).OR.(JJPROJ.NE.JJPOLD).OR.
5231 & (ABS(EPROJ-EPROLD).GT.TINY10) ) THEN
5232 * sample number of nucleon-nucleon coll. according to Glauber-form.
5233 CALL DT_GLAUBE(IP,IT,JJPROJ,BIMPAC,NN,NP,NT,JSSH,JTSH,KKMAT)
5247 * WRITE(6,*)' PROJ.NUCL. ',I,' NCOLL = ',NCP
5249 write(6,*) "why this (1)", NCP, NCT
5252 * WRITE(6,*)' TAR.NUCL. ',I,' NCOLL = ',NCT
5256 * force diffractive particle production in h-K interactions
5257 IF (((ABS(ISINGD).GT.1).OR.(ABS(IDOUBD).GT.1)).AND.
5258 & (IP.EQ.1).AND.(NN.NE.1)) THEN
5263 * check number of involved proj. nucl. (NP) if central prod.is requested
5264 IF (ICENTR.GT.0) THEN
5265 CALL DT_CHKCEN(IP,IT,NP,NT,IBACK)
5266 IF (IBACK.GT.0) GOTO 10
5269 * get initial nucleon-configuration in projectile and target
5270 * rest-system (including Fermi-momenta if requested)
5271 CALL DT_ININUC(IJPROJ,IP,IPZ,PKOO,JSSH,1)
5273 IF (EPROJ.LE.EHADTH) MODE = 3
5274 CALL DT_ININUC(IJTARG,IT,ITZ,TKOO,JTSH,MODE)
5276 IF ((MCGENE.NE.3).AND.(MCGENE.NE.4)) THEN
5278 * activate HADRIN at low energies (implemented for h-N scattering only)
5279 IF (EPROJ.LE.EHADHI) THEN
5280 IF (EHADTH.LT.ZERO) THEN
5281 * smooth transition btwn. DPM and HADRIN
5282 FRAC = (EPROJ-EHADLO)/(EHADHI-EHADLO)
5284 IF (RR.GT.FRAC) THEN
5286 CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5287 IF (IREJ1.GT.0) GOTO 1
5290 WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5294 * fixed threshold for onset of production via HADRIN
5295 IF (EPROJ.LE.EHADTH) THEN
5297 CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5298 IF (IREJ1.GT.0) GOTO 1
5301 WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5306 1001 FORMAT(1X,'KKEVNT: warning! interaction of proj. (m=',
5307 & I3,') with target (m=',I3,')',/,11X,
5308 & 'at E_lab=',F5.1,'GeV (threshold-energy: ',F3.1,
5309 & 'GeV) cannot be handled')
5311 * sampling of momentum-x fractions & flavors of chain ends
5314 * Lorentz-transformation of wounded nucleons into nucl.-nucl. cms
5317 * collect momenta of chain ends and put them into DTEVT1
5318 CALL DT_GETPTN(IP,NN,NCSY,IREJ1)
5319 IF (IREJ1.NE.0) GOTO 1
5323 * handle chains including fragmentation (two-chain approximation)
5324 IF (MCGENE.EQ.1) THEN
5325 * two-chain approximation
5326 CALL DT_EVENTA(IJPROJ,IP,IT,NCSY,IREJ1)
5327 IF (IREJ1.NE.0) THEN
5328 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKEVNT'
5331 ELSEIF (MCGENE.EQ.2) THEN
5332 * multiple-Po exchange including minijets
5333 CALL DT_EVENTB(NCSY,IREJ1)
5334 IF (IREJ1.NE.0) THEN
5335 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKEVNT'
5338 ELSEIF (MCGENE.EQ.3) THEN
5339 STOP ' This version does not contain LEPTO !'
5340 ELSEIF (MCGENE.EQ.4) THEN
5341 * quasi-elastic neutrino scattering
5342 CALL DT_EVENTD(IREJ1)
5343 IF (IREJ1.NE.0) THEN
5344 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 4 in KKEVNT'
5348 WRITE(LOUT,1002) MCGENE
5349 1002 FORMAT(1X,'KKEVNT: warning! event-generator',I4,
5350 & ' not available - program stopped')
5361 *$ CREATE DT_CHKCEN.FOR
5364 *===chkcen=============================================================*
5366 SUBROUTINE DT_CHKCEN(IP,IT,NP,NT,IBACK)
5368 ************************************************************************
5369 * Check of number of involved projectile nucleons if central production*
5371 * Adopted from a part of the old KKEVT routine which was written by *
5372 * J. Ranft/H.-J.Moehring. *
5373 * This version dated 13.01.95 is written by S. Roesler *
5374 ************************************************************************
5376 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5378 PARAMETER ( LINP = 10 ,
5383 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5384 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5386 * central particle production, impact parameter biasing
5387 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5392 IF (ICENTR.EQ.2) THEN
5395 IF (NP.LT.IP-1) IBACK = 1
5396 ELSEIF (IP.LE.16) THEN
5397 IF (NP.LT.IP-2) IBACK = 1
5398 ELSEIF (IP.LE.32) THEN
5399 IF (NP.LT.IP-3) IBACK = 1
5400 ELSEIF (IP.GE.33) THEN
5401 IF (NP.LT.IP-5) IBACK = 1
5403 ELSEIF (IP.EQ.IT) THEN
5405 IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5407 IF (NP.LT.IP-IP/8) IBACK = 1
5409 ELSEIF (ABS(IP-IT).LT.3) THEN
5410 IF (NP.LT.IP-IP/8) IBACK = 1
5413 * new version (DPMJET, 5.6.99)
5416 IF (NP.LT.IP-1) IBACK = 1
5417 ELSEIF (IP.LE.16) THEN
5418 IF (NP.LT.IP-2) IBACK = 1
5419 ELSEIF (IP.LT.32) THEN
5420 IF (NP.LT.IP-3) IBACK = 1
5421 ELSEIF (IP.GE.32) THEN
5424 IF (NP.LT.IP-1) IBACK = 1
5427 IF (NP.LT.IP) IBACK = 1
5430 ELSEIF (IP.EQ.IT) THEN
5433 IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5436 IF (NP.LT.IP-IP/4) IBACK = 1
5438 ELSEIF (ABS(IP-IT).LT.3) THEN
5439 IF (NP.LT.IP-IP/8) IBACK = 1
5448 *$ CREATE DT_ININUC.FOR
5451 *===ininuc=============================================================*
5453 SUBROUTINE DT_ININUC(ID,NMASS,NCH,COORD,JS,IMODE)
5455 ************************************************************************
5456 * Samples initial configuration of nucleons in nucleus with mass NMASS *
5457 * including Fermi-momenta (if reqested). *
5458 * ID BAMJET-code for hadrons (instead of nuclei) *
5459 * NMASS mass number of nucleus (number of nucleons) *
5460 * NCH charge of nucleus *
5461 * COORD(3,NMASS) coordinates of nucleons inside nucleus in fm *
5462 * JS(NMASS) > 0 nucleon undergoes nucleon-nucleon interact. *
5463 * IMODE = 1 projectile nucleus *
5464 * = 2 target nucleus *
5465 * = 3 target nucleus (E_lab<E_thr for HADRIN) *
5466 * Adopted from a part of the old KKEVT routine which was written by *
5467 * J. Ranft/H.-J.Moehring. *
5468 * This version dated 13.01.95 is written by S. Roesler *
5469 ************************************************************************
5471 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5473 PARAMETER ( LINP = 10 ,
5476 PARAMETER (FM2MM=1.0D-12)
5478 PARAMETER ( MAXNCL = 260,
5480 & MAXSQU = 20*MAXVQU,
5481 & MAXINT = MAXVQU+MAXSQU)
5483 PARAMETER (NMXHKK=200000)
5484 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5485 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5486 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5487 * extended event history
5488 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5489 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5491 * flags for input different options
5492 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5493 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5494 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5495 * auxiliary common for chain system storage (DTUNUC 1.x)
5496 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
5499 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5500 & EBINDP(2),EBINDN(2),EPOT(2,210),
5501 & ETACOU(2),ICOUL,LFERMI
5502 * properties of photon/lepton projectiles
5503 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5504 * particle properties (BAMJET index convention)
5506 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5507 & IICH(210),IIBAR(210),K1(210),K2(210)
5508 * Glauber formalism: collision properties
5509 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5510 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
5512 * flavors of partons (DTUNUC 1.x)
5513 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5514 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5515 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
5516 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5517 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
5518 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5519 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
5520 * interface HADRIN-DPM
5521 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5523 DIMENSION PF(4),PFTOT(4),COORD(3,MAXNCL),JS(MAXNCL)
5525 * number of neutrons
5534 IF (IMODE.GT.2) MODE = 2
5535 **sr 29.5. new NPOINT(1)-definition
5536 C IF (IMODE.GE.2) NPOINT(1) = NHKK+1
5541 * get initial configuration
5544 IF (JS(I).GT.0) THEN
5545 ISTHKK(NHKK) = 10+MODE
5546 IF (IMODE.EQ.3) THEN
5547 * additional treatment if HADRIN-generator is requested
5549 IF (NHADRI.EQ.1) IDXTA = NHKK
5550 IF (NHADRI.GT.1) ISTHKK(NHKK) = 14
5553 ISTHKK(NHKK) = 12+MODE
5555 IF (NMASS.GE.2) THEN
5556 * treatment for nuclei
5557 FRAC = 1.0D0-DBLE(NCH)/DBLE(NMASS)
5559 IF ((RR.LT.FRAC).AND.(NN.LT.NNEU)) THEN
5562 ELSEIF ((RR.GE.FRAC).AND.(NP.LT.NCH)) THEN
5565 ELSEIF (NN.LT.NNEU) THEN
5568 ELSEIF (NP.LT.NCH) THEN
5572 IDHKK(NHKK) = IDT_IPDGHA(IDX)
5583 PBIN = SQRT(2.0D0*EBINDP(MODE)*AAM(1))
5586 PBIN = SQRT(2.0D0*EBINDN(MODE)*AAM(8))
5588 CALL DT_FER4M(PFER,PBIN,PF(1),PF(2),PF(3),PF(4),IDX)
5590 PFTOT(K) = PFTOT(K)+PF(K)
5591 PHKK(K,NHKK) = PF(K)
5593 PHKK(5,NHKK) = AAM(IDX)
5595 * treatment for hadrons
5596 IDHKK(NHKK) = IDT_IPDGHA(ID)
5598 PHKK(4,NHKK) = AAM(ID)
5599 PHKK(5,NHKK) = AAM(ID)
5601 C IF (IDHKK(NHKK).EQ.22) THEN
5602 C PHKK(4,NHKK) = AAM(33)
5603 C PHKK(5,NHKK) = AAM(33)
5608 PHKK(5,NHKK) = PHKK(5,NHKK)-SQRT(VIRT)
5615 VHKK(K,NHKK) = COORD(K,I)*FM2MM
5616 WHKK(K,NHKK) = COORD(K,I)*FM2MM
5618 IF (MODE.EQ.2) VHKK(1,NHKK) = VHKK(1,NHKK)+BIMPAC*FM2MM
5619 IF (MODE.EQ.2) WHKK(1,NHKK) = WHKK(1,NHKK)+BIMPAC*FM2MM
5620 VHKK(4,NHKK) = 0.0D0
5621 WHKK(4,NHKK) = 0.0D0
5624 * balance Fermi-momenta
5625 IF (NMASS.GE.2) THEN
5629 PHKK(K,NC) = PHKK(K,NC)-PFTOT(K)/DBLE(NMASS)
5631 PHKK(4,NC) = SQRT(PHKK(5,NC)**2+PHKK(1,NC)**2+
5632 & PHKK(2,NC)**2+PHKK(3,NC)**2)
5639 *$ CREATE DT_FER4M.FOR
5642 *===fer4m==============================================================*
5644 SUBROUTINE DT_FER4M(PFERM,PBIND,PXT,PYT,PZT,ET,KT)
5646 ************************************************************************
5647 * Sampling of nucleon Fermi-momenta from distributions at T=0. *
5648 * processed by S. Roesler, 17.10.95 *
5649 ************************************************************************
5651 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5653 PARAMETER ( LINP = 10 ,
5659 * particle properties (BAMJET index convention)
5661 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5662 & IICH(210),IIBAR(210),K1(210),K2(210)
5665 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5666 & EBINDP(2),EBINDN(2),EPOT(2,210),
5667 & ETACOU(2),ICOUL,LFERMI
5669 DATA LSTART /.TRUE./
5675 1000 FORMAT(/,1X,'FER4M: sampling of Fermi-momenta activated')
5679 CALL DT_DFERMI(PABS)
5681 C IF (PABS.GE.PBIND) THEN
5683 C IF (MOD(ILOOP,500).EQ.0) THEN
5684 C WRITE(LOUT,1001) PABS,PBIND,ILOOP
5685 C1001 FORMAT(1X,'FER4M: Fermi-mom. corr. for binding',
5686 C & ' energy ',2E12.3,I6)
5690 CALL DT_DPOLI(POLC,POLS)
5691 CALL DT_DSFECF(SFE,CFE)
5695 ET = SQRT(PABS*PABS+AAM(KT)**2)
5709 *$ CREATE DT_NUC2CM.FOR
5712 *===nuc2cm=============================================================*
5714 SUBROUTINE DT_NUC2CM
5716 ************************************************************************
5717 * Lorentz-transformation of all wounded nucleons from Lab. to nucl.- *
5718 * nucl. cms. (This subroutine replaces NUCMOM.) *
5719 * This version dated 15.01.95 is written by S. Roesler *
5720 ************************************************************************
5722 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5724 PARAMETER ( LINP = 10 ,
5727 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
5730 PARAMETER (NMXHKK=200000)
5731 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5732 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5733 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5734 * extended event history
5735 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5736 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5739 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5740 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5742 * properties of photon/lepton projectiles
5743 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5744 * particle properties (BAMJET index convention)
5746 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5747 & IICH(210),IIBAR(210),K1(210),K2(210)
5748 * Glauber formalism: collision properties
5749 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5750 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
5753 * statistics: Glauber-formalism
5754 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
5766 IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.12)) THEN
5767 IF (ISTHKK(I).EQ.11) NWAACC = NWAACC+1
5768 IF (ISTHKK(I).EQ.12) NWBACC = NWBACC+1
5770 C IF (IDHKK(I).EQ.22) THEN
5778 C CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PEIN,
5779 C & PX,PY,PZ,PE,IDB,MODE)
5780 IF (PHKK(5,I).GT.ZERO) THEN
5781 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
5782 & PX,PY,PZ,PE,IDBAM(I),MODE)
5792 C IF (ID.EQ.22) ID = 113
5793 CALL DT_EVTPUT(IST,ID,I,0,PX,PY,PZ,PE,0,0,0)
5794 IF (ISTHKK(I).EQ.11) ICWP = ICWP+1
5795 IF (ISTHKK(I).EQ.12) ICWT = ICWT+1
5799 NWTACC = MAX(NWAACC,NWBACC)
5803 IF ((ICWP.EQ.0).OR.(ICWT.EQ.0)) THEN
5811 *$ CREATE DT_SPLPTN.FOR
5814 *===splptn=============================================================*
5816 SUBROUTINE DT_SPLPTN(NN)
5818 ************************************************************************
5819 * SamPLing of ParToN momenta and flavors. *
5820 * This version dated 15.01.95 is written by S. Roesler *
5821 ************************************************************************
5823 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5825 PARAMETER ( LINP = 10 ,
5829 * Lorentz-parameters of the current interaction
5830 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5831 & UMO,PPCM,EPROJ,PPROJ
5833 * sample flavors of sea-quarks
5834 CALL DT_SPLFLA(NN,1)
5836 * sample x-values of partons at chain ends
5838 CALL DT_XKSAMP(NN,ECM)
5841 CALL DT_SPLFLA(NN,2)
5846 *$ CREATE DT_SPLFLA.FOR
5849 *===splfla=============================================================*
5851 SUBROUTINE DT_SPLFLA(NN,MODE)
5853 ************************************************************************
5854 * SamPLing of FLAvors of partons at chain ends. *
5855 * This subroutine replaces FLKSAA/FLKSAM. *
5856 * NN number of nucleon-nucleon interactions *
5857 * MODE = 1 sea-flavors *
5858 * = 2 valence-flavors *
5859 * Based on the original version written by J. Ranft/H.-J. Moehring. *
5860 * This version dated 16.01.95 is written by S. Roesler *
5861 ************************************************************************
5863 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5865 PARAMETER ( LINP = 10 ,
5869 PARAMETER ( MAXNCL = 260,
5871 & MAXSQU = 20*MAXVQU,
5872 & MAXINT = MAXVQU+MAXSQU)
5873 * flavors of partons (DTUNUC 1.x)
5874 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5875 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5876 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
5877 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5878 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
5879 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5880 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
5881 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5882 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
5883 & IXPV,IXPS,IXTV,IXTS,
5884 & INTVV1(MAXVQU),INTVV2(MAXVQU),
5885 & INTSV1(MAXVQU),INTSV2(MAXVQU),
5886 & INTVS1(MAXVQU),INTVS2(MAXVQU),
5887 & INTSS1(MAXSQU),INTSS2(MAXSQU),
5888 & INTDV1(MAXVQU),INTDV2(MAXVQU),
5889 & INTVD1(MAXVQU),INTVD2(MAXVQU),
5890 & INTDS1(MAXSQU),INTDS2(MAXSQU),
5891 & INTSD1(MAXSQU),INTSD2(MAXSQU)
5892 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5893 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
5894 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
5895 * particle properties (BAMJET index convention)
5897 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5898 & IICH(210),IIBAR(210),K1(210),K2(210)
5899 * various options for treatment of partons (DTUNUC 1.x)
5900 * (chain recombination, Cronin,..)
5901 LOGICAL LCO2CR,LINTPT
5902 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
5908 IPSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
5912 ITSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
5915 ELSEIF (MODE.EQ.2) THEN
5918 CALL DT_FLAHAD(KKPROJ(IFROVP(I)),IPVQ(I),IPPV1(I),IPPV2(I))
5921 CALL DT_FLAHAD(KKTARG(IFROVT(I)),ITVQ(I),ITTV1(I),ITTV2(I))
5928 *$ CREATE DT_GETPTN.FOR
5931 *===getptn=============================================================*
5933 SUBROUTINE DT_GETPTN(IP,NN,NCSY,IREJ)
5935 ************************************************************************
5936 * This subroutine collects partons at chain ends from temporary *
5937 * commons and puts them into DTEVT1. *
5938 * This version dated 15.01.95 is written by S. Roesler *
5939 ************************************************************************
5941 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5943 PARAMETER ( LINP = 10 ,
5946 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0)
5950 PARAMETER ( MAXNCL = 260,
5952 & MAXSQU = 20*MAXVQU,
5953 & MAXINT = MAXVQU+MAXSQU)
5955 PARAMETER (NMXHKK=200000)
5956 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5957 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5958 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5959 * extended event history
5960 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5961 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5963 * flags for input different options
5964 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5965 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5966 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5967 * auxiliary common for chain system storage (DTUNUC 1.x)
5968 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
5970 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5971 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5973 * flags for diffractive interactions (DTUNUC 1.x)
5974 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
5975 * x-values of partons (DTUNUC 1.x)
5976 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
5977 & XTVQ(MAXVQU),XTVD(MAXVQU),
5978 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
5979 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
5980 * flavors of partons (DTUNUC 1.x)
5981 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5982 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5983 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
5984 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5985 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
5986 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5987 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
5988 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5989 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
5990 & IXPV,IXPS,IXTV,IXTS,
5991 & INTVV1(MAXVQU),INTVV2(MAXVQU),
5992 & INTSV1(MAXVQU),INTSV2(MAXVQU),
5993 & INTVS1(MAXVQU),INTVS2(MAXVQU),
5994 & INTSS1(MAXSQU),INTSS2(MAXSQU),
5995 & INTDV1(MAXVQU),INTDV2(MAXVQU),
5996 & INTVD1(MAXVQU),INTVD2(MAXVQU),
5997 & INTDS1(MAXSQU),INTDS2(MAXSQU),
5998 & INTSD1(MAXSQU),INTSD2(MAXSQU)
5999 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6000 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
6001 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
6003 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PP(4),PT(4)
6005 DATA AMSS,AMVS,AMDS,AMVD,AMVV/0.4D0,2.0D0,2.0D0,2.5D0,2.0D0/
6013 IF (ISKPCH(1,I).EQ.99) GOTO 10
6014 ICCHAI(1,1) = ICCHAI(1,1)+2
6017 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6018 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6020 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6021 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6022 PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6023 PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6025 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6026 & +(PP1(3)+PT1(3))**2)
6028 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6029 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6030 & +(PP2(3)+PT2(3))**2)
6032 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6033 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6036 IF ((AM1.LT.AMSS).OR.(AM2.LT.AMSS)) THEN
6037 C WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6038 5000 FORMAT(1X,'incon. chain mass SS: ',2I5,2E10.3)
6041 WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6043 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6044 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6045 IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6046 IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6047 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6049 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6051 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6053 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6060 IF (ISKPCH(2,I).EQ.99) GOTO 20
6061 ICCHAI(1,2) = ICCHAI(1,2)+2
6064 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6065 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6067 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6068 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6069 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6070 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6072 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6073 & +(PP1(3)+PT1(3))**2)
6075 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6076 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6077 & +(PP2(3)+PT2(3))**2)
6079 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6080 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6083 IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6084 C WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6085 5001 FORMAT(1X,'incon. chain mass DS: ',2I5,2E10.3)
6088 WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6090 IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6091 IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6092 IFT1 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6093 IFT2 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6094 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6096 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6098 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6100 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6107 IF (ISKPCH(3,I).EQ.99) GOTO 30
6108 ICCHAI(1,3) = ICCHAI(1,3)+2
6111 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6112 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6114 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6115 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6116 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6117 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6119 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6120 & +(PP1(3)+PT1(3))**2)
6122 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6123 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6124 & +(PP2(3)+PT2(3))**2)
6126 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6127 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6130 IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6131 C WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6132 5002 FORMAT(1X,'incon. chain mass SD: ',2I5,2E10.3)
6135 WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6137 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6138 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6139 IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6140 IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6141 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6143 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6145 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6147 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6152 * disea-valence chains
6154 IF (ISKPCH(5,I).EQ.99) GOTO 50
6155 ICCHAI(1,5) = ICCHAI(1,5)+2
6158 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6159 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6161 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6162 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6163 PT1(K) = XTVQ(IDXT) *PHKK(K,MOT)
6164 PT2(K) = XTVD(IDXT) *PHKK(K,MOT)
6166 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6167 & +(PP1(3)+PT1(3))**2)
6169 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6170 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6171 & +(PP2(3)+PT2(3))**2)
6173 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6174 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6177 IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6178 C WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6179 5003 FORMAT(1X,'incon. chain mass DV: ',2I5,2E10.3)
6182 WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6184 IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6185 IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6186 IFT1 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6187 IFT2 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6188 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6190 CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6192 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6194 CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6199 * valence-sea chains
6201 IF (ISKPCH(6,I).EQ.99) GOTO 60
6202 ICCHAI(1,6) = ICCHAI(1,6)+2
6205 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6206 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6208 PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6209 PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6210 PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6211 PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6213 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6214 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6215 IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6216 IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6217 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6219 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6221 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6223 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6225 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6227 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6228 & +(PP1(3)+PT1(3))**2)
6230 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6231 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6232 & +(PP2(3)+PT2(3))**2)
6234 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6236 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6238 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6240 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6242 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6244 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6245 & +(PP1(3)+PT2(3))**2)
6247 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6248 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6249 & +(PP2(3)+PT1(3))**2)
6251 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6253 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6256 IF ((AM1.LT.AMSS).OR.(AM2.LT.AMVS)) THEN
6257 C WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6258 5004 FORMAT(1X,'incon. chain mass VS: ',2I5,2E10.3)
6261 WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6266 * sea-valence chains
6268 IF (ISKPCH(4,I).EQ.99) GOTO 40
6269 ICCHAI(1,4) = ICCHAI(1,4)+2
6272 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6273 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6275 PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6276 PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6277 PT1(K) = XTVD(IDXT) *PHKK(K,MOT)
6278 PT2(K) = XTVQ(IDXT) *PHKK(K,MOT)
6280 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6281 & +(PP1(3)+PT1(3))**2)
6283 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6284 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6285 & +(PP2(3)+PT2(3))**2)
6287 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6288 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6291 IF ((AM1.LT.AMVS).OR.(AM2.LT.AMSS)) THEN
6292 C WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6293 5005 FORMAT(1X,'incon. chain mass SV: ',2I5,2E10.3)
6296 WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6298 IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6299 IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6300 IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6301 IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6302 CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6304 CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6306 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6308 CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6313 * valence-disea chains
6315 IF (ISKPCH(7,I).EQ.99) GOTO 70
6316 ICCHAI(1,7) = ICCHAI(1,7)+2
6319 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6320 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6322 PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6323 PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6324 PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6325 PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6327 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6328 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6329 IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6330 IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6331 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6333 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6335 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6337 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6339 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6341 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6342 & +(PP1(3)+PT1(3))**2)
6344 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6345 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6346 & +(PP2(3)+PT2(3))**2)
6348 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6350 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6352 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6354 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6356 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6358 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6359 & +(PP1(3)+PT2(3))**2)
6361 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6362 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6363 & +(PP2(3)+PT1(3))**2)
6365 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6367 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6370 IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6371 C WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6372 5006 FORMAT(1X,'incon. chain mass VD: ',2I5,2E10.3)
6375 WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6380 * valence-valence chains
6382 IF (ISKPCH(8,I).EQ.99) GOTO 80
6383 ICCHAI(1,8) = ICCHAI(1,8)+2
6386 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6387 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6389 PP1(K) = XPVQ(IDXP)*PHKK(K,MOP)
6390 PP2(K) = XPVD(IDXP)*PHKK(K,MOP)
6391 PT1(K) = XTVD(IDXT)*PHKK(K,MOT)
6392 PT2(K) = XTVQ(IDXT)*PHKK(K,MOT)
6394 IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6395 IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6396 IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6397 IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6399 * check for diffractive event
6401 IF (((ISINGD.GT.0).OR.(IDOUBD.GT.0)).AND.
6402 & (IP.EQ.1).AND.(NN.EQ.1)) THEN
6404 PP(K) = PP1(K)+PP2(K)
6405 PT(K) = PT1(K)+PT2(K)
6408 CALL DT_DIFEVT(IFP1,IFP2,PP,MOP,
6409 & IFT1,IFT2,PT,MOT,IDIFF,NCSY,IREJ1)
6410 C IF (IREJ1.NE.0) GOTO 9999
6411 IF (IREJ1.NE.0) THEN
6419 IF (IDIFF.EQ.0) THEN
6420 * valence-valence chain system
6421 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6424 CALL DT_EVTPUT(-21,IFP1,MOP,0,
6425 & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6426 CALL DT_EVTPUT(-22,IFT1,MOT,0,
6427 & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6428 CALL DT_EVTPUT(-21,IFP2,MOP,0,
6429 & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6430 CALL DT_EVTPUT(-22,IFT2,MOT,0,
6431 & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6432 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6433 & +(PP1(3)+PT1(3))**2)
6435 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6436 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6437 & +(PP2(3)+PT2(3))**2)
6439 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6442 CALL DT_EVTPUT(-21,IFP1,MOP,0,
6443 & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6444 CALL DT_EVTPUT(-22,IFT2,MOT,0,
6445 & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6446 CALL DT_EVTPUT(-21,IFP2,MOP,0,
6447 & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6448 CALL DT_EVTPUT(-22,IFT1,MOT,0,
6449 & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6450 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6451 & +(PP1(3)+PT2(3))**2)
6453 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6454 PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6455 & +(PP2(3)+PT1(3))**2)
6457 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6459 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6462 IF ((AM1.LT.AMVV).OR.(AM2.LT.AMVV)) THEN
6463 C WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6464 5007 FORMAT(1X,'incon. chain mass VV: ',2I5,2E10.3)
6467 WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6472 IF (ISTHKK(NPOINT(2)).EQ.1) NPOINT(2) = NPOINT(2)+1
6474 * energy-momentum & flavor conservation check
6475 IF (ABS(IDIFF).NE.1) THEN
6476 IF (IDIFF.NE.0) THEN
6477 IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-41,1,0,
6480 IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-31,-32,0,
6496 *$ CREATE DT_CHKCSY.FOR
6499 *===chkcsy=============================================================*
6501 SUBROUTINE DT_CHKCSY(ID1,ID2,LCHK)
6503 ************************************************************************
6504 * CHeCk Chain SYstem for consistency of partons at chain ends. *
6505 * ID1,ID2 PDG-numbers of partons at chain ends *
6506 * LCHK = .true. consistent chain *
6507 * = .false. inconsistent chain *
6508 * This version dated 18.01.95 is written by S. Roesler *
6509 ************************************************************************
6511 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6513 PARAMETER ( LINP = 10 ,
6522 IF ((ABS(ID1).LE.6).AND.(ABS(ID2).LE.6)) THEN
6523 IF (ID1*ID2.GT.0) LCHK = .FALSE.
6524 * q-qq, aq-aqaq chain
6525 ELSEIF (((ABS(ID1).LE.6).AND.(ABS(ID2).GT.6)).OR.
6526 & ((ABS(ID1).GT.6).AND.(ABS(ID2).LE.6))) THEN
6527 IF (ID1*ID2.LT.0) LCHK = .FALSE.
6529 ELSEIF ((ABS(ID1).GT.6).AND.(ABS(ID2).GT.6)) THEN
6530 IF (ID1*ID2.GT.0) LCHK = .FALSE.
6536 *$ CREATE DT_EVENTA.FOR
6539 *===eventa=============================================================*
6541 SUBROUTINE DT_EVENTA(ID,IP,IT,NCSY,IREJ)
6543 ************************************************************************
6544 * Treatment of nucleon-nucleon interactions in a two-chain *
6546 * (input) ID BAMJET-index of projectile hadron (in case of *
6548 * IP/IT mass number of projectile/target nucleus *
6549 * NCSY number of two chain systems *
6550 * IREJ rejection flag *
6551 * This version dated 15.01.95 is written by S. Roesler *
6552 ************************************************************************
6554 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6556 PARAMETER ( LINP = 10 ,
6559 PARAMETER (TINY10=1.0D-10)
6562 PARAMETER (NMXHKK=200000)
6563 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6564 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6565 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6566 * extended event history
6567 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6568 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6571 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6572 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6573 & IREXCI(3),IRDIFF(2),IRINC
6574 * flags for diffractive interactions (DTUNUC 1.x)
6575 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6576 * particle properties (BAMJET index convention)
6578 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6579 & IICH(210),IIBAR(210),K1(210),K2(210)
6580 * flags for input different options
6581 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6582 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6583 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6584 * various options for treatment of partons (DTUNUC 1.x)
6585 * (chain recombination, Cronin,..)
6586 LOGICAL LCO2CR,LINTPT
6587 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
6590 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
6595 * skip following treatment for low-mass diffraction
6596 IF (ABS(IFLAGD).EQ.1) THEN
6597 NPOINT(3) = NPOINT(2)
6601 * multiple scattering of chain ends
6602 IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
6603 IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
6606 * get a two-chain system from DTEVT1
6614 PT1(K) = PHKK(K,NC+1)
6615 PP2(K) = PHKK(K,NC+2)
6616 PT2(K) = PHKK(K,NC+3)
6622 CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
6623 & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
6624 IF (IREJ1.GT.0) THEN
6626 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTA'
6632 * meson/antibaryon projectile:
6633 * sample single-chain valence-valence systems (Reggeon contrib.)
6634 IF ((IP.EQ.1).AND.(ISICHA.EQ.1)) THEN
6635 IF (IIBAR(ID).LE.0) CALL DT_VV2SCH
6638 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6639 * check DTEVT1 for remaining resonance mass corrections
6640 CALL DT_EVTRES(IREJ1)
6641 IF (IREJ1.GT.0) THEN
6642 IRRES(1) = IRRES(1)+1
6643 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in EVENTA'
6648 * assign p_t to two-"chain" systems consisting of two resonances only
6649 * since only entries for chains will be affected, this is obsolete
6650 * in case of JETSET-fragmetation
6653 * combine q-aq chains to color ropes (qq-aqaq) (chain fusion)
6654 IF (LCO2CR) CALL DT_COM2CR
6658 * fragmentation of the complete event
6659 **uncomment for internal phojet-fragmentation
6660 C CALL DT_EVTFRA(IREJ1)
6661 CALL DT_EVTFRG(2,IDUM,NPYMEM,IREJ1)
6662 IF (IREJ1.GT.0) THEN
6664 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 3 in EVENTA'
6668 * decay of possible resonances (should be obsolete)
6679 *$ CREATE DT_GETCSY.FOR
6682 *===getcsy=============================================================*
6684 SUBROUTINE DT_GETCSY(IFPR1,PP1,MOP1,IFPR2,PP2,MOP2,
6685 & IFTA1,PT1,MOT1,IFTA2,PT2,MOT2,IREJ)
6687 ************************************************************************
6688 * This version dated 15.01.95 is written by S. Roesler *
6689 ************************************************************************
6691 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6693 PARAMETER ( LINP = 10 ,
6696 PARAMETER (TINY10=1.0D-10)
6699 PARAMETER (NMXHKK=200000)
6700 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6701 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6702 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6703 * extended event history
6704 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6705 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6708 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6709 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6710 & IREXCI(3),IRDIFF(2),IRINC
6711 * flags for input different options
6712 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6713 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6714 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6715 * flags for diffractive interactions (DTUNUC 1.x)
6716 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6718 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),
6719 & IFP1(2),IFP2(2),IFT1(2),IFT2(2),PCH1(4),PCH2(4)
6723 * get quark content of partons
6730 IFP1(1) = IDT_IPDG2B(IFPR1,1,2)
6731 IF (ABS(IFPR1).GE.1000) IFP1(2) = IDT_IPDG2B(IFPR1,2,2)
6732 IFP2(1) = IDT_IPDG2B(IFPR2,1,2)
6733 IF (ABS(IFPR2).GE.1000) IFP2(2) = IDT_IPDG2B(IFPR2,2,2)
6734 IFT1(1) = IDT_IPDG2B(IFTA1,1,2)
6735 IF (ABS(IFTA1).GE.1000) IFT1(2) = IDT_IPDG2B(IFTA1,2,2)
6736 IFT2(1) = IDT_IPDG2B(IFTA2,1,2)
6737 IF (ABS(IFTA2).GE.1000) IFT2(2) = IDT_IPDG2B(IFTA2,2,2)
6739 * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq, 3 - qq-aqaq)
6741 IF ((IFP1(2).EQ.0).AND.(IFT1(2).EQ.0)) IDCH1 = 1
6742 IF ((IFP1(2).NE.0).AND.(IFT1(2).NE.0)) IDCH1 = 3
6744 IF ((IFP2(2).EQ.0).AND.(IFT2(2).EQ.0)) IDCH2 = 1
6745 IF ((IFP2(2).NE.0).AND.(IFT2(2).NE.0)) IDCH2 = 3
6747 * store initial configuration for energy-momentum cons. check
6748 IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IDUM)
6750 * sample intrinsic p_t at chain-ends
6751 CALL DT_GETSPT(PP1,IFPR1,IFP1,PP2,IFPR2,IFP2,
6752 & PT1,IFTA1,IFT1,PT2,IFTA2,IFT2,
6753 & AMCH1,IDCH1,AMCH2,IDCH2,IDCH(MOP1),IREJ1)
6754 IF (IREJ1.NE.0) THEN
6755 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in GETCSY'
6760 C IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6761 C IF ((IDCH1.EQ.3).OR.((IDCH1.GT.1).AND.(IDCH2.EQ.1))) THEN
6762 C* check second chain for resonance
6763 C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6764 C & AMCH2,AMCH2N,IDCH2,IREJ1)
6765 C IF (IREJ1.NE.0) GOTO 9999
6766 C IF (IDR2.NE.0) THEN
6767 C CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6768 C & AMCH2,AMCH2N,AMCH1,IREJ1)
6769 C IF (IREJ1.NE.0) GOTO 9999
6771 C* check first chain for resonance
6772 C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6773 C & AMCH1,AMCH1N,IDCH1,IREJ1)
6774 C IF (IREJ1.NE.0) GOTO 9999
6775 C IF (IDR1.NE.0) IDR1 = 100*IDR1
6777 C* check first chain for resonance
6778 C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6779 C & AMCH1,AMCH1N,IDCH1,IREJ1)
6780 C IF (IREJ1.NE.0) GOTO 9999
6781 C IF (IDR1.NE.0) THEN
6782 C CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6783 C & AMCH1,AMCH1N,AMCH2,IREJ1)
6784 C IF (IREJ1.NE.0) GOTO 9999
6786 C* check second chain for resonance
6787 C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6788 C & AMCH2,AMCH2N,IDCH2,IREJ1)
6789 C IF (IREJ1.NE.0) GOTO 9999
6790 C IF (IDR2.NE.0) IDR2 = 100*IDR2
6794 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6795 * check chains for resonances
6796 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6797 & AMCH1,AMCH1N,IDCH1,IREJ1)
6798 IF (IREJ1.NE.0) GOTO 9999
6799 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6800 & AMCH2,AMCH2N,IDCH2,IREJ1)
6801 IF (IREJ1.NE.0) GOTO 9999
6802 * change kinematics corresponding to resonance-masses
6803 IF ( (IDR1.NE.0).AND.(IDR2.EQ.0) ) THEN
6804 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6805 & AMCH1,AMCH1N,AMCH2,IREJ1)
6806 IF (IREJ1.GT.0) GOTO 9999
6807 IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
6808 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6809 & AMCH2,AMCH2N,IDCH2,IREJ1)
6810 IF (IREJ1.NE.0) GOTO 9999
6811 IF (IDR2.NE.0) IDR2 = 100*IDR2
6812 ELSEIF ( (IDR1.EQ.0).AND.(IDR2.NE.0) ) THEN
6813 CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6814 & AMCH2,AMCH2N,AMCH1,IREJ1)
6815 IF (IREJ1.GT.0) GOTO 9999
6816 IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
6817 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6818 & AMCH1,AMCH1N,IDCH1,IREJ1)
6819 IF (IREJ1.NE.0) GOTO 9999
6820 IF (IDR1.NE.0) IDR1 = 100*IDR1
6821 ELSEIF ( (IDR1.NE.0).AND.(IDR2.NE.0) ) THEN
6822 AMDIF1 = ABS(AMCH1-AMCH1N)
6823 AMDIF2 = ABS(AMCH2-AMCH2N)
6824 IF (AMDIF2.LT.AMDIF1) THEN
6825 CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6826 & AMCH2,AMCH2N,AMCH1,IREJ1)
6827 IF (IREJ1.GT.0) GOTO 9999
6828 IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
6829 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),
6830 & IDR1,IDXR1,AMCH1,AMCH1N,IDCH1,IREJ1)
6831 IF (IREJ1.NE.0) GOTO 9999
6832 IF (IDR1.NE.0) IDR1 = 100*IDR1
6834 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6835 & AMCH1,AMCH1N,AMCH2,IREJ1)
6836 IF (IREJ1.GT.0) GOTO 9999
6837 IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
6838 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),
6839 & IDR2,IDXR2,AMCH2,AMCH2N,IDCH2,IREJ1)
6840 IF (IREJ1.NE.0) GOTO 9999
6841 IF (IDR2.NE.0) IDR2 = 100*IDR2
6846 * store final configuration for energy-momentum cons. check
6848 CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IDUM)
6849 CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
6850 IF (IREJ1.NE.0) GOTO 9999
6853 * put partons and chains into DTEVT1
6855 PCH1(I) = PP1(I)+PT1(I)
6856 PCH2(I) = PP2(I)+PT2(I)
6858 CALL DT_EVTPUT(-ISTHKK(MOP1),IFPR1,MOP1,0,PP1(1),PP1(2),
6859 & PP1(3),PP1(4),0,0,0)
6860 CALL DT_EVTPUT(-ISTHKK(MOT1),IFTA1,MOT1,0,PT1(1),PT1(2),
6861 & PT1(3),PT1(4),0,0,0)
6862 KCH = 100+IDCH(MOP1)*10+1
6863 CALL DT_EVTPUT(KCH,88888,-2,-1,
6864 & PCH1(1),PCH1(2),PCH1(3),PCH1(4),IDR1,IDXR1,IDCH(MOP1))
6865 CALL DT_EVTPUT(-ISTHKK(MOP2),IFPR2,MOP2,0,PP2(1),PP2(2),
6866 & PP2(3),PP2(4),0,0,0)
6867 CALL DT_EVTPUT(-ISTHKK(MOT2),IFTA2,MOT2,0,PT2(1),PT2(2),
6868 & PT2(3),PT2(4),0,0,0)
6870 CALL DT_EVTPUT(KCH,88888,-2,-1,
6871 & PCH2(1),PCH2(2),PCH2(3),PCH2(4),IDR2,IDXR2,IDCH(MOP2))
6876 IF ((IDCH(MOP1).LE.3).AND.(IDCH(MOP2).LE.3)) THEN
6877 * "cancel" sea-sea chains
6878 CALL DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ1)
6879 IF (IREJ1.NE.0) GOTO 9998
6880 **sr 16.5. flag for EVENTB
6889 *$ CREATE DT_CHKINE.FOR
6892 *===chkine=============================================================*
6894 SUBROUTINE DT_CHKINE(PP1I,IFP1,PP2I,IFP2,PT1I,IFT1,PT2I,IFT2,
6895 & AMCH1,AMCH1N,AMCH2,IREJ)
6897 ************************************************************************
6898 * This subroutine replaces CORMOM. *
6899 * This version dated 05.01.95 is written by S. Roesler *
6900 ************************************************************************
6902 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6904 PARAMETER ( LINP = 10 ,
6907 PARAMETER (TINY10=1.0D-10)
6909 * flags for input different options
6910 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6911 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6912 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6914 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6915 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6916 & IREXCI(3),IRDIFF(2),IRINC
6918 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),P1(4),P2(4),
6919 & PP1I(4),PP2I(4),PT1I(4),PT2I(4)
6924 SCALE = AMCH1N/MAX(AMCH1,TINY10)
6930 PP2(I) = PP2(I)+(1.0D0-SCALE)*PP1(I)
6931 PT2(I) = PT2(I)+(1.0D0-SCALE)*PT1(I)
6932 PP1(I) = SCALE*PP1(I)
6933 PT1(I) = SCALE*PT1(I)
6935 IF ((PP1(4).LT.0.0D0).OR.(PP2(4).LT.0.0D0).OR.
6936 & (PT1(4).LT.0.0D0).OR.(PT2(4).LT.0.0D0)) GOTO 9997
6939 PCH = SQRT( (PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2+
6940 & (PP2(3)+PT2(3))**2 )
6941 AMCH22 = (ECH-PCH)*(ECH+PCH)
6942 IF (AMCH22.LT.0.0D0) THEN
6944 & WRITE(LOUT,'(1X,A)') 'CHKINE: inconsistent treatment!'
6949 AMCH2 = SQRT(AMCH22)
6951 * put partons again on mass shell
6955 IF (JMSHL.EQ.1) THEN
6959 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
6960 IF (IREJ1.NE.0) THEN
6961 IF (JMSHL.EQ.0) GOTO 9998
6973 IF (JMSHL.EQ.1) THEN
6977 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P1,P2,IREJ1)
6978 IF (IREJ1.NE.0) THEN
6979 IF (JMSHL.EQ.0) GOTO 9998
6995 9997 IRCHKI(1) = IRCHKI(1)+1
7001 9998 IRCHKI(2) = IRCHKI(2)+1
7004 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in CHKINE'
7009 *$ CREATE DT_CH2RES.FOR
7012 *===ch2res=============================================================*
7014 SUBROUTINE DT_CH2RES(IF1,IF2,IF3,IF4,IDR,IDXR,
7015 & AM,AMN,IMODE,IREJ)
7017 ************************************************************************
7018 * Check chains for resonance production. *
7019 * This subroutine replaces COMCMA/COBCMA/COMCM2 *
7021 * IF1,2,3,4 input flavors (q,aq in any order) *
7023 * MODE = 1 check q-aq chain for meson-resonance *
7024 * = 2 check q-qq, aq-aqaq chain for baryon-resonance *
7025 * = 3 check qq-aqaq chain for lower mass cut *
7027 * IDR = 0 no resonances found *
7028 * = -1 pseudoscalar meson/octet baryon *
7029 * = 1 vector-meson/decuplet baryon *
7030 * IDXR BAMJET-index of corresponding resonance *
7031 * AMN mass of corresponding resonance *
7033 * IREJ rejection flag *
7034 * This version dated 06.01.95 is written by S. Roesler *
7035 ************************************************************************
7037 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7039 PARAMETER ( LINP = 10 ,
7043 * particle properties (BAMJET index convention)
7045 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7046 & IICH(210),IIBAR(210),K1(210),K2(210)
7047 * quark-content to particle index conversion (DTUNUC 1.x)
7048 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
7049 & IA08(6,21),IA10(6,21)
7051 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7052 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7053 & IREXCI(3),IRDIFF(2),IRINC
7054 * flags for input different options
7055 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7056 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7057 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7059 DIMENSION IF(4),JF(4)
7062 C DATA AMLOM,AMLOB /0.08D0,0.2D0/
7063 DATA AMLOM,AMLOB /0.1D0,0.7D0/
7065 C DATA AMLOM,AMLOB /0.001D0,0.001D0/
7069 IF ((MODE.LT.1).OR.(MODE.GT.3)) THEN
7070 WRITE(LOUT,1000) MODE
7071 1000 FORMAT(1X,'CH2RES: MODE ',I4,' not supported!',/,
7072 & 1X,' program stopped')
7081 IF ((AM.LE.0.0D0).AND.(MODE.EQ.1)) AMX = AMLOM
7082 IF ((AM.LE.0.0D0).AND.(MODE.EQ.2)) AMX = AMLOB
7090 IF (IF(I).NE.0) THEN
7095 IF (NF.LE.MODE) THEN
7096 WRITE(LOUT,1001) MODE,IF
7097 1001 FORMAT(1X,'CH2RES: inconsistent input flavors in MODE ',
7098 & I4,' IF1 = ',I4,' IF2 = ',I4,' IF3 = ',I4,' IF4 = ',I4)
7104 * check for meson resonance
7108 IF (JF(2).GT.0) THEN
7112 IFPS = IMPS(IFAQ,IFQ)
7113 IFV = IMVE(IFAQ,IFQ)
7117 IF (AMX.LT.AMV) THEN
7118 IF (AMX.LT.AMPS) THEN
7119 IF (IMODE.GT.0) THEN
7120 IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOM)) GOTO 9999
7122 IF (AMX.LT.0.8D0*AMPS) GOTO 9999
7126 * replace chain by pseudoscalar meson
7130 ELSEIF (AMX.LT.AMHI) THEN
7131 * replace chain by vector-meson
7138 * check for baryon resonance
7140 CALL DT_DBKLAS(JF(1),JF(2),JF(3),JB8,JB10)
7144 IF (AMX.LT.AM10) THEN
7145 IF (AMX.LT.AM8) THEN
7146 IF (IMODE.GT.0) THEN
7147 IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOB)) GOTO 9999
7149 IF (AMX.LT.0.8D0*AM8) GOTO 9999
7153 * replace chain by oktet baryon
7157 ELSEIF (AMX.LT.AMHI) THEN
7164 * check qq-aqaq for lower mass cut
7166 * empirical definition of AMHI to allow for (b-antib)-pair prod.
7168 IF (AMX.LT.AMHI) GOTO 9999
7172 IF ((IOULEV(1).GT.0).AND.(IMODE.GT.0))
7173 & WRITE(LOUT,*) 'rejected 1 in CH2RES',IMODE
7175 IRRES(2) = IRRES(2)+1
7179 *$ CREATE DT_RJSEAC.FOR
7182 *===rjseac=============================================================*
7184 SUBROUTINE DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ)
7186 ************************************************************************
7187 * ReJection of SEA-sea Chains. *
7188 * MOP1/2 entries of projectile sea-partons in DTEVT1 *
7189 * MOT1/2 entries of projectile sea-partons in DTEVT1 *
7190 * This version dated 16.01.95 is written by S. Roesler *
7191 ************************************************************************
7193 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7195 PARAMETER ( LINP = 10 ,
7198 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
7201 PARAMETER (NMXHKK=200000)
7202 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7203 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7204 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7205 * extended event history
7206 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7207 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7210 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7211 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7214 DIMENSION IDXSEA(2,2),IDXNUC(2),ISTVAL(2)
7218 * projectile sea q-aq-pair
7219 * indices of sea-pair
7222 * index of mother-nucleon
7223 IDXNUC(1) = JMOHKK(1,MOP1)
7224 * status of valence quarks to be corrected
7227 * target sea q-aq-pair
7228 * indices of sea-pair
7231 * index of mother-nucleon
7232 IDXNUC(2) = JMOHKK(1,MOT1)
7233 * status of valence quarks to be corrected
7238 DO 2 I=NPOINT(2),NHKK
7239 IF ((ISTHKK(I).EQ.ISTVAL(N)).AND.
7240 & (JMOHKK(1,I).EQ.IDXNUC(N))) THEN
7241 * valence parton found
7242 * inrease 4-momentum by sea 4-momentum
7244 PHKK(K,I) = PHKK(K,I)+PHKK(K,IDXSEA(N,1))+
7245 & PHKK(K,IDXSEA(N,2))
7247 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
7248 & PHKK(2,I)**2-PHKK(3,I)**2))
7251 ISTHKK(IDXSEA(N,J)) = 100
7252 IDHKK(IDXSEA(N,J)) = 0
7253 JMOHKK(1,IDXSEA(N,J)) = 0
7254 JMOHKK(2,IDXSEA(N,J)) = 0
7255 JDAHKK(1,IDXSEA(N,J)) = 0
7256 JDAHKK(2,IDXSEA(N,J)) = 0
7258 PHKK(K,IDXSEA(N,J)) = ZERO
7259 VHKK(K,IDXSEA(N,J)) = ZERO
7260 WHKK(K,IDXSEA(N,J)) = ZERO
7262 PHKK(5,IDXSEA(N,J)) = ZERO
7267 IF (IDONE.NE.1) THEN
7268 WRITE(LOUT,1000) NEVHKK,MOP1,MOP2,MOT1,MOT2
7269 1000 FORMAT(1X,'RJSEAC: event ',I8,': inconsistent event',
7270 & '-record!',/,1X,' sea-quark pairs ',
7271 & 2I5,4X,2I5,' could not be canceled!')
7283 *$ CREATE DT_VV2SCH.FOR
7286 *===vv2sch=============================================================*
7288 SUBROUTINE DT_VV2SCH
7290 ************************************************************************
7291 * Change Valence-Valence chain systems to Single CHain systems for *
7292 * hadron-nucleus collisions with meson or antibaryon projectile. *
7293 * (Reggeon contribution) *
7294 * The single chain system is approximately treated as one chain and a *
7296 * This version dated 18.01.95 is written by S. Roesler *
7297 ************************************************************************
7299 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7301 PARAMETER ( LINP = 10 ,
7304 PARAMETER (ZERO=0.0D0,TINY7=1.0D-7,TINY3=1.0D-3)
7309 PARAMETER (NMXHKK=200000)
7310 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7311 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7312 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7313 * extended event history
7314 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7315 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7317 * flags for input different options
7318 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7319 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7320 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7322 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7323 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7326 DIMENSION IF(4,2),MO(4),PP1(4),PP2(4),PT1(4),PT2(4),PCH1(4),
7329 DATA LSTART /.TRUE./
7334 1000 FORMAT(/,1X,'VV2SCH: Reggeon contribution to valance-',
7335 & 'valence chains treated')
7341 * get index of first chain
7342 DO 1 I=NPOINT(3),NHKK
7343 IF (IDHKK(I).EQ.88888) THEN
7350 IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)
7351 & .AND.(NC.LT.NSTOP)) THEN
7352 * get valence-valence chains
7353 IF ((IDCH(NC).EQ.8).AND.(IDCH(NC+3).EQ.8)) THEN
7354 * get "mother"-hadron indices
7355 MO1 = JMOHKK(1,JMOHKK(1,JMOHKK(1,NC)))
7356 MO2 = JMOHKK(1,JMOHKK(1,JMOHKK(2,NC)))
7357 KPROJ = IDT_ICIHAD(IDHKK(MO1))
7358 KTARG = IDT_ICIHAD(IDHKK(MO2))
7359 * Lab momentum of projectile hadron
7360 CALL DT_LTNUC(PHKK(3,MO1),PHKK(4,MO1),PPZ,PPE,-3)
7361 PTOT = SQRT(PHKK(1,MO1)**2+PHKK(2,MO1)**2+
7364 SICHAP = DT_PHNSCH(KPROJ,KTARG,PTOT)
7365 IF (DT_RNDM(PTOT).LE.SICHAP) THEN
7367 * single chain requested
7368 * get flavors of chain-end partons
7369 MO(1) = JMOHKK(1,NC)
7370 MO(2) = JMOHKK(2,NC)
7371 MO(3) = JMOHKK(1,NC+3)
7372 MO(4) = JMOHKK(2,NC+3)
7374 IF(I,1) = IDT_IPDG2B(IDHKK(MO(I)),1,2)
7376 IF (ABS(IDHKK(MO(I))).GE.1000)
7377 & IF(I,2) = IDT_IPDG2B(IDHKK(MO(I)),2,2)
7379 * which one is the q-aq chain?
7380 * N1,N1+1 - DTEVT1-entries for q-aq system
7381 * N2,N2+1 - DTEVT1-entries for the other chain
7382 IF ((IF(1,2).EQ.0).AND.(IF(2,2).EQ.0)) THEN
7387 ELSEIF ((IF(3,2).EQ.0).AND.(IF(4,2).EQ.0)) THEN
7397 PT1(K) = PHKK(K,N1+1)
7399 PT2(K) = PHKK(K,N2+1)
7401 AMCH1 = PHKK(5,N1+2)
7402 AMCH2 = PHKK(5,N2+2)
7403 * get meson-identity corresponding to flavors of q-aq chain
7406 CALL DT_CH2RES(IF(K1,1),IF(K1+1,1),0,0,IDR1,IDXR1,
7407 & ZERO,AMCH1N,1,IDUM)
7409 * change kinematics of chains
7410 CALL DT_CHKINE(PP1,IDHKK(N1), PP2,IDHKK(N2),
7411 & PT1,IDHKK(N1+1),PT2,IDHKK(N2+1),
7412 & AMCH1,AMCH1N,AMCH2,IREJ1)
7413 IF (IREJ1.NE.0) GOTO 10
7414 * check second chain for resonance
7416 IF ((IF(K2,2).NE.0).AND.(IF(K2+1,2).NE.0)) IDCHAI = 3
7417 CALL DT_CH2RES(IF(K2,1),IF(K2,2),IF(K2+1,1),IF(K2+1,2),
7418 & IDR2,IDXR2,AMCH2,AMCH2N,IDCHAI,IREJ1)
7419 IF (IREJ1.NE.0) GOTO 10
7420 IF (IDR2.NE.0) IDR2 = 100*IDR2
7421 * add partons and chains to DTEVT1
7423 PCH1(K) = PP1(K)+PT1(K)
7424 PCH2(K) = PP2(K)+PT2(K)
7426 CALL DT_EVTPUT(ISTHKK(N1),IDHKK(N1),N1,0,PP1(1),PP1(2),
7427 & PP1(3),PP1(4),0,0,0)
7428 CALL DT_EVTPUT(ISTHKK(N1+1),IDHKK(N1+1),N1+1,0,PT1(1),
7429 & PT1(2),PT1(3),PT1(4),0,0,0)
7430 KCH = ISTHKK(N1+2)+100
7431 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH1(1),PCH1(2),PCH1(3),
7432 & PCH1(4),IDR1,IDXR1,IDCH(N1+2))
7434 CALL DT_EVTPUT(ISTHKK(N2),IDHKK(N2),N2,0,PP2(1),PP2(2),
7435 & PP2(3),PP2(4),0,0,0)
7436 CALL DT_EVTPUT(ISTHKK(N2+1),IDHKK(N2+1),N2+1,0,PT2(1),
7437 & PT2(2),PT2(3),PT2(4),0,0,0)
7438 KCH = ISTHKK(N2+2)+100
7439 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH2(1),PCH2(2),PCH2(3),
7440 & PCH2(4),IDR2,IDXR2,IDCH(N2+2))
7456 *$ CREATE DT_PHNSCH.FOR
7459 *=== phnsch ===========================================================*
7461 DOUBLE PRECISION FUNCTION DT_PHNSCH( KP, KTARG, PLAB )
7463 *----------------------------------------------------------------------*
7465 * Probability for Hadron Nucleon Single CHain interactions: *
7467 * Created on 30 december 1993 by Alfredo Ferrari & Paola Sala *
7470 * Last change on 04-jan-94 by Alfredo Ferrari *
7472 * modified by J.R.for use in DTUNUC 6.1.94 *
7474 * Input variables: *
7475 * Kp = hadron projectile index (Part numbering *
7477 * Ktarg = target nucleon index (1=proton, 8=neutron) *
7478 * Plab = projectile laboratory momentum (GeV/c) *
7479 * Output variable: *
7480 * Phnsch = probability per single chain (particle *
7481 * exchange) interactions *
7483 *----------------------------------------------------------------------*
7485 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7488 PARAMETER ( LUNOUT = 6 )
7489 PARAMETER ( LUNERR = 6 )
7490 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
7491 PARAMETER ( ZERZER = 0.D+00 )
7492 PARAMETER ( ONEONE = 1.D+00 )
7493 PARAMETER ( TWOTWO = 2.D+00 )
7494 PARAMETER ( FIVFIV = 5.D+00 )
7495 PARAMETER ( HLFHLF = 0.5D+00 )
7497 PARAMETER ( NALLWP = 39 )
7498 PARAMETER ( IDMAXP = 210 )
7500 DIMENSION ICHRGE(39),AM(39)
7502 * particle properties (BAMJET index convention)
7504 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7505 & IICH(210),IIBAR(210),K1(210),K2(210)
7507 DIMENSION KPTOIP(210)
7508 * auxiliary common for reggeon exchange (DTUNUC 1.x)
7509 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
7510 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
7511 & IQTCHR(-6:6),MQUARK(3,39)
7513 DIMENSION SGTCOE (5,33), IHLP (NALLWP)
7514 DIMENSION SGTCO1(5,10),SGTCO2(5,8),SGTCO3(5,15)
7515 CPH SAVE SGTCOE, IHLP
7516 CPH SAVE IQFSC1, IQFSC2, IQBSC1, IQBSC2
7517 EQUIVALENCE (SGTCO1(1,1),SGTCOE(1,1))
7518 EQUIVALENCE (SGTCO2(1,1),SGTCOE(1,11))
7519 EQUIVALENCE (SGTCO3(1,1),SGTCOE(1,19))
7521 * Conversion from part to paprop numbering
7522 DATA KPTOIP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
7523 & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 66*0,
7524 & 34, 36, 31, 32, 33, 35, 37, 5*0, 38, 5*0, 39, 19*0, 27, 28, 74*0/
7526 * 1=baryon, 2=pion, 3=kaon, 4=antibaryon:
7527 DATA IHLP/1,4,5*0,1,4,2*0,3,2*2,2*3,1,4,3,3*1,2,
7528 & 2*3, 2, 4*0, 3*4, 1, 4, 1, 4, 1, 4 /
7529 C DATA ( ( SGTCOE (J,I), J=1,5 ), I=1,10 ) /
7531 * 1st reaction: gamma p total
7532 &0.147 D+00, ZERZER , ZERZER , 0.0022D+00, -0.0170D+00,
7533 * 2nd reaction: gamma d total
7534 &0.300 D+00, ZERZER , ZERZER , 0.0095D+00, -0.057 D+00,
7535 * 3rd reaction: pi+ p total
7536 &16.4 D+00, 19.3D+00, -0.42D+00, 0.19 D+00, ZERZER ,
7537 * 4th reaction: pi- p total
7538 &33.0 D+00, 14.0D+00, -1.36D+00, 0.456 D+00, -4.03 D+00,
7539 * 5th reaction: pi+/- d total
7540 &56.8 D+00, 42.2D+00, -1.45D+00, 0.65 D+00, -5.39 D+00,
7541 * 6th reaction: K+ p total
7542 &18.1 D+00, ZERZER , ZERZER , 0.26 D+00, -1.0 D+00,
7543 * 7th reaction: K+ n total
7544 &18.7 D+00, ZERZER , ZERZER , 0.21 D+00, -0.89 D+00,
7545 * 8th reaction: K+ d total
7546 &34.2 D+00, 7.9 D+00, -2.1 D+00, 0.346 D+00, -0.99 D+00,
7547 * 9th reaction: K- p total
7548 &32.1 D+00, ZERZER , ZERZER , 0.66 D+00, -5.6 D+00,
7549 * 10th reaction: K- n total
7550 &25.2 D+00, ZERZER , ZERZER , 0.38 D+00, -2.9 D+00/
7551 C DATA ( ( SGTCOE (J,I), J=1,5 ), I=11,18 ) /
7553 * 11th reaction: K- d total
7554 &57.6 D+00, ZERZER , ZERZER , 1.17 D+00, -9.5 D+00,
7555 * 12th reaction: p p total
7556 &48.0 D+00, ZERZER , ZERZER , 0.522 D+00, -4.51 D+00,
7557 * 13th reaction: p n total
7558 &47.30 D+00, ZERZER , ZERZER , 0.513 D+00, -4.27 D+00,
7559 * 14th reaction: p d total
7560 &91.3 D+00, ZERZER , ZERZER , 1.05 D+00, -8.8 D+00,
7561 * 15th reaction: pbar p total
7562 &38.4 D+00, 77.6D+00, -0.64D+00, 0.26 D+00, -1.2 D+00,
7563 * 16th reaction: pbar n total
7564 &ZERZER ,133.6D+00, -0.70D+00, -1.22 D+00, 13.7 D+00,
7565 * 17th reaction: pbar d total
7566 &112. D+00, 125.D+00, -1.08D+00, 1.14 D+00, -12.4 D+00,
7567 * 18th reaction: Lamda p total
7568 &30.4 D+00, ZERZER , ZERZER , ZERZER , 1.6 D+00/
7569 C DATA ( ( SGTCOE (J,I), J=1,5 ), I=19,33 ) /
7571 * 19th reaction: pi+ p elastic
7572 &ZERZER , 11.4D+00, -0.4 D+00, 0.079 D+00, ZERZER ,
7573 * 20th reaction: pi- p elastic
7574 &1.76 D+00, 11.2D+00, -0.64D+00, 0.043 D+00, ZERZER ,
7575 * 21st reaction: K+ p elastic
7576 &5.0 D+00, 8.1 D+00, -1.8 D+00, 0.16 D+00, -1.3 D+00,
7577 * 22nd reaction: K- p elastic
7578 &7.3 D+00, ZERZER , ZERZER , 0.29 D+00, -2.40 D+00,
7579 * 23rd reaction: p p elastic
7580 &11.9 D+00, 26.9D+00, -1.21D+00, 0.169 D+00, -1.85 D+00,
7581 * 24th reaction: p d elastic
7582 &16.1 D+00, ZERZER , ZERZER , 0.32 D+00, -3.4 D+00,
7583 * 25th reaction: pbar p elastic
7584 &10.2 D+00, 52.7D+00, -1.16D+00, 0.125 D+00, -1.28 D+00,
7585 * 26th reaction: pbar p elastic bis
7586 &10.6 D+00, 53.1D+00, -1.19D+00, 0.136 D+00, -1.41 D+00,
7587 * 27th reaction: pbar n elastic
7588 &36.5 D+00, ZERZER , ZERZER , ZERZER , -11.9 D+00,
7589 * 28th reaction: Lamda p elastic
7590 &12.3 D+00, ZERZER , ZERZER , ZERZER , -2.4 D+00,
7591 * 29th reaction: K- p ela bis
7592 &7.24 D+00, 46.0D+00, -4.71D+00, 0.279 D+00, -2.35 D+00,
7593 * 30th reaction: pi- p cx
7594 &ZERZER ,0.912D+00, -1.22D+00, ZERZER , ZERZER ,
7595 * 31st reaction: K- p cx
7596 &ZERZER , 3.39D+00, -1.75D+00, ZERZER , ZERZER ,
7597 * 32nd reaction: K+ n cx
7598 &ZERZER , 7.18D+00, -2.01D+00, ZERZER , ZERZER ,
7599 * 33rd reaction: pbar p cx
7600 &ZERZER , 18.8D+00, -2.01D+00, ZERZER , ZERZER /
7602 * +-------------------------------------------------------------------*
7603 ICHRGE(KTARG)=IICH(KTARG)
7604 AM (KTARG)=AAM (KTARG)
7605 * | Check for pi0 (d-dbar)
7606 IF ( KP .NE. 26 ) THEN
7612 * +-------------------------------------------------------------------*
7619 * +-------------------------------------------------------------------*
7620 * +-------------------------------------------------------------------*
7621 * | No such interactions for baryon-baryon
7622 IF ( IIBAR (KP) .GT. 0 ) THEN
7626 * +-------------------------------------------------------------------*
7627 * | No "annihilation" diagram possible for K+ p/n
7628 ELSE IF ( IP .EQ. 15 ) THEN
7632 * +-------------------------------------------------------------------*
7633 * | No "annihilation" diagram possible for K0 p/n
7634 ELSE IF ( IP .EQ. 24 ) THEN
7638 * +-------------------------------------------------------------------*
7639 * | No "annihilation" diagram possible for Omebar p/n
7640 ELSE IF ( IP .GE. 38 ) THEN
7645 * +-------------------------------------------------------------------*
7646 * +-------------------------------------------------------------------*
7647 * | If the momentum is larger than 50 GeV/c, compute the single
7648 * | chain probability at 50 GeV/c and extrapolate to the present
7649 * | momentum according to 1/sqrt(s)
7650 * | sigma = sigma_sch (50) * sqrt (s(50)/s) + sigma_dch
7651 * | P_sch (50) = sigma_sch (50) / ( sigma_dch + sigma_sch (50) )
7652 * | sigma_dch / sigma_sch (50) = 1 / P_sch (50) - 1
7653 * | sigma_dch / sigma_sch = 1 / P_sch - 1 = ( 1 / P_sch (50) - 1 )
7655 * | P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
7656 IF ( PLAB .GT. 50.D+00 ) THEN
7659 AMTSQ = AM (KTARG)**2
7660 EPROJ = SQRT ( PLAB**2 + AMPSQ )
7661 UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7662 EPROJ = SQRT ( PLA**2 + AMPSQ )
7663 UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7664 UMORAT = SQRT ( UMOSQ / UMO50 )
7666 * +-------------------------------------------------------------------*
7668 ELSE IF ( PLAB .LT. 3.D+00 ) THEN
7671 AMTSQ = AM (KTARG)**2
7672 EPROJ = SQRT ( PLAB**2 + AMPSQ )
7673 UMOSQ = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7674 EPROJ = SQRT ( PLA**2 + AMPSQ )
7675 UMO50 = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7676 UMORAT = SQRT ( UMOSQ / UMO50 )
7678 * +-------------------------------------------------------------------*
7685 * +-------------------------------------------------------------------*
7687 * +-------------------------------------------------------------------*
7689 IF ( IHLP (IP) .EQ. 2 ) THEN
7695 * | Compute the pi+ p total cross section:
7696 SPPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7698 ACOF = SGTCOE (1,19)
7699 BCOF = SGTCOE (2,19)
7700 ENNE = SGTCOE (3,19)
7701 CCOF = SGTCOE (4,19)
7702 DCOF = SGTCOE (5,19)
7703 * | Compute the pi+ p elastic cross section:
7704 SPPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7706 * | Compute the pi+ p inelastic cross section:
7707 SPPPIN = SPPPTT - SPPPEL
7713 * | Compute the pi- p total cross section:
7714 SPMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7716 ACOF = SGTCOE (1,20)
7717 BCOF = SGTCOE (2,20)
7718 ENNE = SGTCOE (3,20)
7719 CCOF = SGTCOE (4,20)
7720 DCOF = SGTCOE (5,20)
7721 * | Compute the pi- p elastic cross section:
7722 SPMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7724 * | Compute the pi- p inelastic cross section:
7725 SPMPIN = SPMPTT - SPMPEL
7726 SIGDIA = SPMPIN - SPPPIN
7727 * | +----------------------------------------------------------------*
7728 * | | Charged pions: besides isospin consideration it is supposed
7729 * | | that (pi+ n)el is almost equal to (pi- p)el
7730 * | | and (pi+ p)el " " " " (pi- n)el
7731 * | | and all are almost equal among each others
7732 * | | (reasonable above 5 GeV/c)
7733 IF ( ICHRGE (IP) .NE. 0 ) THEN
7735 JREAC = 3 + IP - 13 + ICHRGE (IP) * KHELP
7736 ACOF = SGTCOE (1,JREAC)
7737 BCOF = SGTCOE (2,JREAC)
7738 ENNE = SGTCOE (3,JREAC)
7739 CCOF = SGTCOE (4,JREAC)
7740 DCOF = SGTCOE (5,JREAC)
7741 * | | Compute the total cross section:
7742 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7744 JREAC = 19 + IP - 13 + ICHRGE (IP) * KHELP
7745 ACOF = SGTCOE (1,JREAC)
7746 BCOF = SGTCOE (2,JREAC)
7747 ENNE = SGTCOE (3,JREAC)
7748 CCOF = SGTCOE (4,JREAC)
7749 DCOF = SGTCOE (5,JREAC)
7750 * | | Compute the elastic cross section:
7751 SHNCEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7753 * | | Compute the inelastic cross section:
7754 SHNCIN = SHNCTT - SHNCEL
7755 * | | Number of diagrams:
7756 NDIAGR = 1 + IP - 13 + ICHRGE (IP) * KHELP
7757 * | | Now compute the chain end (anti)quark-(anti)diquark
7758 IQFSC1 = 1 + IP - 13
7761 IQBSC2 = 1 + IP - 13
7763 * | +----------------------------------------------------------------*
7764 * | | pi0: besides isospin consideration it is supposed that the
7765 * | | elastic cross section is not very different from
7766 * | | pi+ p and/or pi- p (reasonable above 5 GeV/c)
7769 K2HLP = ( KP - 23 ) / 3
7770 * | | Number of diagrams:
7771 * | | For u ubar (k2hlp=0):
7772 * NDIAGR = 2 - KHELP
7773 * | | For d dbar (k2hlp=1):
7774 * NDIAGR = 2 + KHELP - K2HLP
7775 NDIAGR = 2 + KHELP * ( 2 * K2HLP - 1 ) - K2HLP
7776 SHNCIN = HLFHLF * ( SPPPIN + SPMPIN )
7777 * | | Now compute the chain end (anti)quark-(anti)diquark
7784 * | +----------------------------------------------------------------*
7786 * +-------------------------------------------------------------------*
7788 ELSE IF ( IHLP (IP) .EQ. 3 ) THEN
7794 * | Compute the K+ p total cross section:
7795 SKPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7797 ACOF = SGTCOE (1,21)
7798 BCOF = SGTCOE (2,21)
7799 ENNE = SGTCOE (3,21)
7800 CCOF = SGTCOE (4,21)
7801 DCOF = SGTCOE (5,21)
7802 * | Compute the K+ p elastic cross section:
7803 SKPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7805 * | Compute the K+ p inelastic cross section:
7806 SKPPIN = SKPPTT - SKPPEL
7812 * | Compute the K- p total cross section:
7813 SKMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7815 ACOF = SGTCOE (1,22)
7816 BCOF = SGTCOE (2,22)
7817 ENNE = SGTCOE (3,22)
7818 CCOF = SGTCOE (4,22)
7819 DCOF = SGTCOE (5,22)
7820 * | Compute the K- p elastic cross section:
7821 SKMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7823 * | Compute the K- p inelastic cross section:
7824 SKMPIN = SKMPTT - SKMPEL
7825 SIGDIA = HLFHLF * ( SKMPIN - SKPPIN )
7826 * | +----------------------------------------------------------------*
7827 * | | Charged Kaons: actually only K-
7828 IF ( ICHRGE (IP) .NE. 0 ) THEN
7830 * | | +-------------------------------------------------------------*
7831 * | | | Proton target:
7832 IF ( KHELP .EQ. 0 ) THEN
7834 * | | | Number of diagrams:
7837 * | | +-------------------------------------------------------------*
7838 * | | | Neutron target: besides isospin consideration it is supposed
7839 * | | | that (K- n)el is almost equal to (K- p)el
7840 * | | | (reasonable above 5 GeV/c)
7842 ACOF = SGTCOE (1,10)
7843 BCOF = SGTCOE (2,10)
7844 ENNE = SGTCOE (3,10)
7845 CCOF = SGTCOE (4,10)
7846 DCOF = SGTCOE (5,10)
7847 * | | | Compute the total cross section:
7848 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7850 * | | | Compute the elastic cross section:
7852 * | | | Compute the inelastic cross section:
7853 SHNCIN = SHNCTT - SHNCEL
7854 * | | | Number of diagrams:
7858 * | | +-------------------------------------------------------------*
7859 * | | Now compute the chain end (anti)quark-(anti)diquark
7865 * | +----------------------------------------------------------------*
7866 * | | K0's: (actually only K0bar)
7869 * | | +-------------------------------------------------------------*
7870 * | | | Proton target: (K0bar p)in supposed to be given by
7871 * | | | (K- p)in - Sig_diagr
7872 IF ( KHELP .EQ. 0 ) THEN
7873 SHNCIN = SKMPIN - SIGDIA
7874 * | | | Number of diagrams:
7877 * | | +-------------------------------------------------------------*
7878 * | | | Neutron target: (K0bar n)in supposed to be given by
7879 * | | | (K- n)in + Sig_diagr
7880 * | | | besides isospin consideration it is supposed
7881 * | | | that (K- n)el is almost equal to (K- p)el
7882 * | | | (reasonable above 5 GeV/c)
7884 ACOF = SGTCOE (1,10)
7885 BCOF = SGTCOE (2,10)
7886 ENNE = SGTCOE (3,10)
7887 CCOF = SGTCOE (4,10)
7888 DCOF = SGTCOE (5,10)
7889 * | | | Compute the total cross section:
7890 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7892 * | | | Compute the elastic cross section:
7894 * | | | Compute the inelastic cross section:
7895 SHNCIN = SHNCTT - SHNCEL + SIGDIA
7896 * | | | Number of diagrams:
7900 * | | +-------------------------------------------------------------*
7901 * | | Now compute the chain end (anti)quark-(anti)diquark
7908 * | +----------------------------------------------------------------*
7910 * +-------------------------------------------------------------------*
7912 ELSE IF ( IHLP (IP) .EQ. 4 .AND. IP .LE. 9 ) THEN
7913 * | For momenta between 3 and 5 GeV/c the use of tabulated data
7914 * | should be implemented!
7915 ACOF = SGTCOE (1,15)
7916 BCOF = SGTCOE (2,15)
7917 ENNE = SGTCOE (3,15)
7918 CCOF = SGTCOE (4,15)
7919 DCOF = SGTCOE (5,15)
7920 * | Compute the pbar p total cross section:
7921 SAPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7923 IF ( PLA .LT. FIVFIV ) THEN
7928 ACOF = SGTCOE (1,JREAC)
7929 BCOF = SGTCOE (2,JREAC)
7930 ENNE = SGTCOE (3,JREAC)
7931 CCOF = SGTCOE (4,JREAC)
7932 DCOF = SGTCOE (5,JREAC)
7933 * | Compute the pbar p elastic cross section:
7934 SAPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7936 * | Compute the pbar p inelastic cross section:
7937 SAPPIN = SAPPTT - SAPPEL
7938 ACOF = SGTCOE (1,12)
7939 BCOF = SGTCOE (2,12)
7940 ENNE = SGTCOE (3,12)
7941 CCOF = SGTCOE (4,12)
7942 DCOF = SGTCOE (5,12)
7943 * | Compute the p p total cross section:
7944 SPPTOT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7946 ACOF = SGTCOE (1,23)
7947 BCOF = SGTCOE (2,23)
7948 ENNE = SGTCOE (3,23)
7949 CCOF = SGTCOE (4,23)
7950 DCOF = SGTCOE (5,23)
7951 * | Compute the p p elastic cross section:
7952 SPPELA = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7954 * | Compute the K- p inelastic cross section:
7955 SPPINE = SPPTOT - SPPELA
7956 SIGDIA = ( SAPPIN - SPPINE ) / FIVFIV
7958 * | +----------------------------------------------------------------*
7960 IF ( ICHRGE (IP) .NE. 0 ) THEN
7962 * | | +-------------------------------------------------------------*
7963 * | | | Proton target:
7964 IF ( KHELP .EQ. 0 ) THEN
7965 * | | | Number of diagrams:
7969 * | | +-------------------------------------------------------------*
7970 * | | | Neutron target: it is supposed that (ap n)el is almost equal
7971 * | | | to (ap p)el (reasonable above 5 GeV/c)
7973 ACOF = SGTCOE (1,16)
7974 BCOF = SGTCOE (2,16)
7975 ENNE = SGTCOE (3,16)
7976 CCOF = SGTCOE (4,16)
7977 DCOF = SGTCOE (5,16)
7978 * | | | Compute the total cross section:
7979 SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7981 * | | | Compute the elastic cross section:
7983 * | | | Compute the inelastic cross section:
7984 SHNCIN = SHNCTT - SHNCEL
7988 * | | +-------------------------------------------------------------*
7989 * | | Now compute the chain end (anti)quark-(anti)diquark
7990 * | | there are different possibilities, make a random choiche:
7992 RNCHEN = DT_RNDM(PUUBAR)
7993 IF ( RNCHEN .LT. PUUBAR ) THEN
7998 IQBSC1 = -IQFSC1 + KHELP
8001 * | +----------------------------------------------------------------*
8005 * | | +-------------------------------------------------------------*
8006 * | | | Proton target: (nbar p)in supposed to be given by
8007 * | | | (pbar p)in - Sig_diagr
8008 IF ( KHELP .EQ. 0 ) THEN
8009 SHNCIN = SAPPIN - SIGDIA
8012 * | | +-------------------------------------------------------------*
8013 * | | | Neutron target: (nbar n)el is supposed to be equal to
8014 * | | | (pbar p)el (reasonable above 5 GeV/c)
8016 * | | | Compute the total cross section:
8018 * | | | Compute the elastic cross section:
8020 * | | | Compute the inelastic cross section:
8021 SHNCIN = SHNCTT - SHNCEL
8025 * | | +-------------------------------------------------------------*
8026 * | | Now compute the chain end (anti)quark-(anti)diquark
8027 * | | there are different possibilities, make a random choiche:
8029 RNCHEN = DT_RNDM(RNCHEN)
8030 IF ( RNCHEN .LT. PDDBAR ) THEN
8035 IQBSC1 = -IQFSC1 + KHELP - 1
8039 * | +----------------------------------------------------------------*
8041 * +-------------------------------------------------------------------*
8042 * | Others: not yet implemented
8051 * +-------------------------------------------------------------------*
8052 DT_PHNSCH = NDIAGR * SIGDIA / SHNCIN
8053 IQECHC = IQECHR (IQFSC1) + IQECHR (IQFSC2) + IQECHR (IQBSC1)
8055 IQBCHC = IQBCHR (IQFSC1) + IQBCHR (IQFSC2) + IQBCHR (IQBSC1)
8059 IQSCHC = IQSCHR (IQFSC1) + IQSCHR (IQFSC2) + IQSCHR (IQBSC1)
8061 IQSPRO = IQSCHR (MQUARK(1,IP)) + IQSCHR (MQUARK(2,IP))
8062 & + IQSCHR (MQUARK(3,IP))
8063 * +-------------------------------------------------------------------*
8064 * | Consistency check:
8065 IF ( DT_PHNSCH .LE. ZERZER .OR. DT_PHNSCH .GT. ONEONE ) THEN
8066 WRITE (LUNOUT,*)' *** Phnsch,kp,ktarg,pla',
8067 & DT_PHNSCH,KP,KTARG,PLA,' ****'
8068 WRITE (LUNERR,*)' *** Phnsch,kp,ktarg,pla',
8069 & DT_PHNSCH,KP,KTARG,PLA,' ****'
8070 DT_PHNSCH = MAX ( DT_PHNSCH, ZERZER )
8071 DT_PHNSCH = MIN ( DT_PHNSCH, ONEONE )
8074 * +-------------------------------------------------------------------*
8075 * +-------------------------------------------------------------------*
8076 * | Consistency check:
8077 IF ( IQSPRO .NE. IQSCHC .OR. ICHRGE (IP) + ICHRGE (KTARG)
8078 & .NE. IQECHC .OR. IIBAR (KP) + IIBAR (KTARG) .NE. IQBCHC) THEN
8080 &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8081 & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8083 &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8084 & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8087 * +-------------------------------------------------------------------*
8088 * P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
8089 IF ( UMORAT .GT. ONEPLS )
8090 & DT_PHNSCH = ONEONE / ( ( ONEONE / DT_PHNSCH
8091 & - ONEONE ) * UMORAT + ONEONE )
8094 ENTRY DT_SCHQUA ( JQFSC1, JQFSC2, JQBSC1, JQBSC2 )
8100 *=== End of function Phnsch ===========================================*
8104 *$ CREATE DT_RESPT.FOR
8107 *===respt==============================================================*
8111 ************************************************************************
8112 * Check DTEVT1 for two-resonance systems and sample intrinsic p_t. *
8113 * This version dated 18.01.95 is written by S. Roesler *
8114 ************************************************************************
8116 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8118 PARAMETER ( LINP = 10 ,
8121 PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8124 PARAMETER (NMXHKK=200000)
8125 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8126 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8127 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8128 * extended event history
8129 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8130 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8133 * get index of first chain
8134 DO 1 I=NPOINT(3),NHKK
8135 IF (IDHKK(I).EQ.88888) THEN
8142 IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)) THEN
8143 C WRITE(LOUT,*)NC,NC+3,IDRES(NC),IDRES(NC+3)
8144 * skip VV-,SS- systems
8145 IF ((IDCH(NC ).NE.1).AND.(IDCH(NC ).NE.8).AND.
8146 & (IDCH(NC+3).NE.1).AND.(IDCH(NC+3).NE.8)) THEN
8147 * check if both "chains" are resonances
8148 IF ((IDRES(NC).NE.0).AND.(IDRES(NC+3).NE.0)) THEN
8149 CALL DT_SAPTRE(NC,NC+3)
8163 *$ CREATE DT_EVTRES.FOR
8166 *===evtres=============================================================*
8168 SUBROUTINE DT_EVTRES(IREJ)
8170 ************************************************************************
8171 * This version dated 14.12.94 is written by S. Roesler *
8172 ************************************************************************
8174 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8176 PARAMETER ( LINP = 10 ,
8179 PARAMETER (TINY5=1.0D-5,TINY10=1.0D-10)
8182 PARAMETER (NMXHKK=200000)
8183 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8184 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8185 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8186 * extended event history
8187 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8188 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8190 * flags for input different options
8191 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8192 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8193 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8194 * particle properties (BAMJET index convention)
8196 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
8197 & IICH(210),IIBAR(210),K1(210),K2(210)
8199 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),IFP(2),IFT(2)
8203 DO 1 I=NPOINT(3),NHKK
8204 IF (ABS(IDRES(I)).GE.100) THEN
8206 DO 2 J=NPOINT(3),NHKK
8207 IF (IDHKK(J).EQ.88888) THEN
8208 IF (PHKK(5,J).GT.AMMX) THEN
8214 IF (IDRES(IMMX).NE.0) THEN
8215 IF (IOULEV(3).GT.0) THEN
8216 WRITE(LOUT,'(1X,A)')
8217 & 'EVTRES: no chain for correc. found'
8226 IF (PHKK(3,IMO11).LT.0.0D0) THEN
8230 IMO21 = JMOHKK(1,IMMX)
8231 IMO22 = JMOHKK(2,IMMX)
8232 IF (PHKK(3,IMO21).LT.0.0D0) THEN
8233 IMO21 = JMOHKK(2,IMMX)
8234 IMO22 = JMOHKK(1,IMMX)
8237 AMCH1N = AAM(IDXRES(I))
8239 IFPR1 = IDHKK(IMO11)
8240 IFPR2 = IDHKK(IMO21)
8241 IFTA1 = IDHKK(IMO12)
8242 IFTA2 = IDHKK(IMO22)
8244 PP1(J) = PHKK(J,IMO11)
8245 PP2(J) = PHKK(J,IMO21)
8246 PT1(J) = PHKK(J,IMO12)
8247 PT2(J) = PHKK(J,IMO22)
8249 * store initial configuration for energy-momentum cons. check
8250 IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IREJ1)
8251 * correct kinematics of second chain
8252 CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
8253 & AMCH1,AMCH1N,AMCH2,IREJ1)
8254 IF (IREJ1.NE.0) GOTO 9999
8255 * check now this chain for resonance mass
8256 IFP(1) = IDT_IPDG2B(IFPR2,1,2)
8258 IF (ABS(IFPR2).GE.1000) IFP(2) = IDT_IPDG2B(IFPR2,2,2)
8259 IFT(1) = IDT_IPDG2B(IFTA2,1,2)
8261 IF (ABS(IFTA2).GE.1000) IFT(2) = IDT_IPDG2B(IFTA2,2,2)
8263 IF ((IFP(2).EQ.0).AND.(IFT(2).EQ.0)) IDCH2 = 1
8264 IF ((IFP(2).NE.0).AND.(IFT(2).NE.0)) IDCH2 = 3
8265 CALL DT_CH2RES(IFP(1),IFP(2),IFT(1),IFT(2),IDR2,IDXR2,
8266 & AMCH2,AMCH2N,IDCH2,IREJ1)
8267 IF ((IREJ1.NE.0).OR.(IDR2.NE.0)) THEN
8269 & WRITE(LOUT,*) ' correction for resonance not poss.'
8275 * store final configuration for energy-momentum cons. check
8277 CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IREJ1)
8278 CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
8279 IF (IREJ1.NE.0) GOTO 9999
8282 PHKK(J,IMO11) = PP1(J)
8283 PHKK(J,IMO21) = PP2(J)
8284 PHKK(J,IMO12) = PT1(J)
8285 PHKK(J,IMO22) = PT2(J)
8287 * correct entries of chains
8289 PHKK(K,I) = PHKK(K,IMO11)+PHKK(K,IMO12)
8290 PHKK(K,IMMX) = PHKK(K,IMO21)+PHKK(K,IMO22)
8292 AM1 = PHKK(4,I)**2-PHKK(1,I)**2-PHKK(2,I)**2-PHKK(3,I)**2
8293 AM2 = PHKK(4,IMMX)**2-PHKK(1,IMMX)**2-PHKK(2,IMMX)**2-
8295 * ?? the following should now be obsolete
8297 C IF ((AM1.LT.0.0D0).OR.(AM2.LT.1.0D0)) THEN
8298 IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8300 WRITE(LOUT,'(1X,A,4G10.3)')
8301 & 'EVTRES: inonsistent mass-corr.',AM1,AM2
8305 PHKK(5,I) = SQRT(AM1)
8306 PHKK(5,IMMX) = SQRT(AM2)
8307 IDRES(I) = IDRES(I)/100
8308 IF ((ABS(PHKK(5,I)-AMCH1N).GT.TINY5).OR.
8309 & (ABS(PHKK(5,IMMX)-AMCH2).GT.TINY5)) THEN
8310 WRITE(LOUT,'(1X,A,4G10.3)')
8311 & 'EVTRES: inconsistent chain-masses',
8312 & PHKK(5,I),AMCH1N,PHKK(5,IMMX),AMCH2
8325 *$ CREATE DT_GETSPT.FOR
8328 *===getspt=============================================================*
8330 SUBROUTINE DT_GETSPT(PP1I,IFPR1,IFP1,PP2I,IFPR2,IFP2,
8331 & PT1I,IFTA1,IFT1,PT2I,IFTA2,IFT2,
8332 & AM1,IDCH1,AM2,IDCH2,IDCHAI,IREJ)
8334 ************************************************************************
8335 * This version dated 12.12.94 is written by S. Roesler *
8336 ************************************************************************
8338 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8340 PARAMETER ( LINP = 10 ,
8343 PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,ZERO=0.0D0)
8345 * various options for treatment of partons (DTUNUC 1.x)
8346 * (chain recombination, Cronin,..)
8347 LOGICAL LCO2CR,LINTPT
8348 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8350 * flags for input different options
8351 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8352 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8353 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8354 * flags for diffractive interactions (DTUNUC 1.x)
8355 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
8357 DIMENSION PP1(4),PP1I(4),PP2(4),PP2I(4),PT1(4),PT1I(4),
8358 & PT2(4),PT2I(4),P1(4),P2(4),
8359 & IFP1(2),IFP2(2),IFT1(2),IFT2(2),
8360 & PTOTI(4),PTOTF(4),DIFF(4)
8366 C IF ((IDCHAI.EQ.6).OR.(IDCHAI.EQ.7).OR.(IDCHAI.EQ.8)) B33P = 2.0D0
8367 C IF ((IDCHAI.EQ.4).OR.(IDCHAI.EQ.5).OR.(IDCHAI.EQ.8)) B33T = 2.0D0
8373 IF (IDIFF.NE.0) THEN
8379 PTOTI(I) = PP1I(I)+PP2I(I)+PT1I(I)+PT2I(I)
8385 * get initial chain masses
8386 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8387 & +(PP1(3)+PT1(3))**2)
8389 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
8390 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8391 & +(PP2(3)+PT2(3))**2)
8393 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
8394 IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8396 & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 1',
8406 C IF ((AM1.GE.3.0D0).AND.(AM2.GE.3.0D0)) THEN
8410 C IF (AM1.LT.0.6) THEN
8412 C ELSEIF ((AM1.GE.1.2).AND.(AM1.LT.3.0D0)) THEN
8415 C IF (AM2.LT.0.6) THEN
8417 C ELSEIF ((AM2.GE.1.2).AND.(AM2.LT.3.0D0)) THEN
8422 * check chain masses for very low mass chains
8423 C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8424 C & AM1,DUM,-IDCH1,IREJ1)
8425 C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8426 C & AM2,DUM,-IDCH2,IREJ2)
8427 C IF ((IREJ1.NE.0).OR.(IREJ2.NE.0)) THEN
8436 IF (MOD(IC,15).EQ.0) B33P = 2.0D0*B33P
8437 IF (MOD(IC,15).EQ.0) B33T = 2.0D0*B33T
8438 IF (MOD(IC,18).EQ.0) REDU = 0.0D0
8439 C IF (MOD(IC,19).EQ.0) JMSHL = 0
8440 IF (MOD(IC,20).EQ.0) GOTO 7
8441 C WRITE(LOUT,'(1X,A)') 'GETSPT: rejection '
8446 * get transverse momentum
8448 ES = -2.0D0/(B33P**2)
8449 & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8450 HPSP = SQRT(ES*ES+2.0D0*ES*0.94D0)
8452 ES = -2.0D0/(B33T**2)
8453 & *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8454 HPST = SQRT(ES*ES+2.0D0*ES*0.94D0)
8460 CALL DT_DSFECF(SFE1,CFE1)
8461 CALL DT_DSFECF(SFE2,CFE2)
8463 PP1(1) = PP1I(1)+HPSP*CFE1
8464 PP1(2) = PP1I(2)+HPSP*SFE1
8465 PP2(1) = PP2I(1)-HPSP*CFE1
8466 PP2(2) = PP2I(2)-HPSP*SFE1
8467 PT1(1) = PT1I(1)+HPST*CFE2
8468 PT1(2) = PT1I(2)+HPST*SFE2
8469 PT2(1) = PT2I(1)-HPST*CFE2
8470 PT2(2) = PT2I(2)-HPST*SFE2
8472 PP1(1) = PP1I(1)+HPSP*CFE1
8473 PP1(2) = PP1I(2)+HPSP*SFE1
8474 PT1(1) = PT1I(1)-HPSP*CFE1
8475 PT1(2) = PT1I(2)-HPSP*SFE1
8476 PP2(1) = PP2I(1)+HPST*CFE2
8477 PP2(2) = PP2I(2)+HPST*SFE2
8478 PT2(1) = PT2I(1)-HPST*CFE2
8479 PT2(2) = PT2I(2)-HPST*SFE2
8482 * put partons on mass shell
8485 IF (JMSHL.EQ.1) THEN
8486 XMP1 = PYMASS(IFPR1)
8487 XMT1 = PYMASS(IFTA1)
8489 CALL DT_MASHEL(PP1,PT1,XMP1,XMT1,P1,P2,IREJ1)
8490 IF (IREJ1.NE.0) GOTO 2
8492 PTOTF(I) = P1(I)+P2(I)
8498 IF (JMSHL.EQ.1) THEN
8499 XMP2 = PYMASS(IFPR2)
8500 XMT2 = PYMASS(IFTA2)
8502 CALL DT_MASHEL(PP2,PT2,XMP2,XMT2,P1,P2,IREJ1)
8503 IF (IREJ1.NE.0) GOTO 2
8505 PTOTF(I) = PTOTF(I)+P1(I)+P2(I)
8512 DIFF(I) = PTOTI(I)-PTOTF(I)
8514 IF ((ABS(DIFF(1)).GT.TINY5).OR.(ABS(DIFF(2)).GT.TINY5).OR.
8515 & (ABS(DIFF(3)).GT.TINY5).OR.(ABS(DIFF(4)).GT.TINY5)) THEN
8516 WRITE(LOUT,'(1X,A,4G10.3)') 'GETSPT: inconsistencies ',DIFF
8519 PTOTP1 = SQRT(PP1(1)**2+PP1(2)**2+PP1(3)**2)
8520 AMP1 = SQRT(ABS( (PP1(4)-PTOTP1)*(PP1(4)+PTOTP1) ))
8521 PTOTP2 = SQRT(PP2(1)**2+PP2(2)**2+PP2(3)**2)
8522 AMP2 = SQRT(ABS( (PP2(4)-PTOTP2)*(PP2(4)+PTOTP2) ))
8523 PTOTT1 = SQRT(PT1(1)**2+PT1(2)**2+PT1(3)**2)
8524 AMT1 = SQRT(ABS( (PT1(4)-PTOTT1)*(PT1(4)+PTOTT1) ))
8525 PTOTT2 = SQRT(PT2(1)**2+PT2(2)**2+PT2(3)**2)
8526 AMT2 = SQRT(ABS( (PT2(4)-PTOTT2)*(PT2(4)+PTOTT2) ))
8527 IF ((ABS(AMP1-XMP1).GT.TINY3).OR.(ABS(AMP2-XMP2).GT.TINY3).OR.
8528 & (ABS(AMT1-XMT1).GT.TINY3).OR.(ABS(AMT2-XMT2).GT.TINY3))
8530 WRITE(LOUT,'(1X,A,2(4G10.3,/))')
8531 & 'GETSPT: inconsistent masses',
8532 & AMP1,XMP1,AMP2,XMP2,AMT1,XMT1,AMT2,XMT2
8533 * sr 22.11.00: commented. It should only have inconsistent masses for
8534 * ultrahigh energies due to rounding problems
8539 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8540 & +(PP1(3)+PT1(3))**2)
8542 AM1N = (ECH+PTOCH)*(ECH-PTOCH)
8543 PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8544 & +(PP2(3)+PT2(3))**2)
8546 AM2N = (ECH+PTOCH)*(ECH-PTOCH)
8547 IF ((AM1N.LT.0.0D0).OR.(AM2N.LT.0.0D0)) THEN
8549 & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 2',
8556 * check chain masses for very low mass chains
8557 CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8558 & AM1N,DUM,-IDCH1,IREJ1)
8559 IF (IREJ1.NE.0) GOTO 2
8560 CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8561 & AM2N,DUM,-IDCH2,IREJ2)
8562 IF (IREJ2.NE.0) GOTO 2
8565 IF (AM1N.GT.ZERO) THEN
8583 *$ CREATE DT_SAPTRE.FOR
8586 *===saptre=============================================================*
8588 SUBROUTINE DT_SAPTRE(IDX1,IDX2)
8590 ************************************************************************
8591 * p-t sampling for two-resonance systems. ("BAMJET-like" method) *
8592 * IDX1,IDX2 indices of resonances ("chains") in DTEVT1 *
8593 * Adopted from the original SAPTRE written by J. Ranft. *
8594 * This version dated 18.01.95 is written by S. Roesler *
8595 ************************************************************************
8597 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8599 PARAMETER ( LINP = 10 ,
8602 PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8605 PARAMETER (NMXHKK=200000)
8606 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8607 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8608 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8609 * extended event history
8610 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8611 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8613 * flags for input different options
8614 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8615 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8616 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8618 DIMENSION PA1(4),PA2(4),P1(4),P2(4)
8622 ESMAX1 = PHKK(4,IDX1)-PHKK(5,IDX1)
8623 ESMAX2 = PHKK(4,IDX2)-PHKK(5,IDX2)
8624 ESMAX = MIN(ESMAX1,ESMAX2)
8625 IF (ESMAX.LE.0.05D0) RETURN
8629 PA1(K) = PHKK(K,IDX1)
8630 PA2(K) = PHKK(K,IDX2)
8634 CALL DT_EVTEMC(PA1(1),PA1(2),PA1(3),PA1(4),1,IDUM,IDUM)
8635 CALL DT_EVTEMC(PA2(1),PA2(2),PA2(3),PA2(4),2,IDUM,IDUM)
8639 IF (B3*ESMAX.LE.60.0D0) EXEB = EXP(-B3*ESMAX)
8640 BEXP = HMA*(1.0D0-EXEB)/B3
8641 AXEXP = (1.0D0-(B3*ESMAX-1.0D0)*EXEB)/B3**2
8642 WA = AXEXP/(BEXP+AXEXP)
8645 * ES is the transverse kinetic energy
8649 ES = -2.0D0/(B3**2)*LOG(X*Y+TINY7)
8652 ES = ABS(-LOG(X+TINY7)/B3)
8654 IF (ES.GT.ESMAX) GOTO 10
8656 * transverse momentum
8657 HPS = SQRT((ES-HMA)*(ES+HMA))
8659 CALL DT_DSFECF(SFE,CFE)
8662 PZ1NSQ = PA1(3)**2-HPS**2-2.0D0*PA1(1)*HPX-2.0D0*PA1(2)*HPY
8663 PZ2NSQ = PA2(3)**2-HPS**2+2.0D0*PA2(1)*HPX+2.0D0*PA2(2)*HPY
8664 IF ((PZ1NSQ.LT.TINY3).OR.(PZ2NSQ.LT.TINY3)) RETURN
8666 C PA1(3) = SIGN(SQRT(PZ1NSQ),PA1(3))
8667 C PA2(3) = SIGN(SQRT(PZ2NSQ),PA2(3))
8673 * put resonances on mass-shell again
8676 CALL DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ1)
8677 IF (IREJ1.NE.0) RETURN
8680 CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,IDUM,IDUM)
8681 CALL DT_EVTEMC(-P2(1),-P2(2),-P2(3),-P2(4),2,IDUM,IDUM)
8682 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,12,IREJ1)
8683 IF (IREJ1.NE.0) RETURN
8687 PHKK(K,IDX1) = P1(K)
8688 PHKK(K,IDX2) = P2(K)
8694 *$ CREATE DT_CRONIN.FOR
8697 *===cronin=============================================================*
8699 SUBROUTINE DT_CRONIN(INCL)
8701 ************************************************************************
8702 * Cronin-Effect. Multiple scattering of partons at chain ends. *
8703 * INCL = 1 multiple sc. in projectile *
8704 * = 2 multiple sc. in target *
8705 * This version dated 05.01.96 is written by S. Roesler. *
8706 ************************************************************************
8708 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8710 PARAMETER ( LINP = 10 ,
8713 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
8716 PARAMETER (NMXHKK=200000)
8717 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8718 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8719 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8720 * extended event history
8721 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8722 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8725 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
8726 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
8727 & IREXCI(3),IRDIFF(2),IRINC
8728 * Glauber formalism: collision properties
8729 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
8730 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
8732 DIMENSION R(3),PIN(4),POUT(4),DEV(4)
8738 DO 2 I=NPOINT(2),NHKK
8739 IF (ISTHKK(I).LT.0) THEN
8740 * get z-position of the chain
8741 R(1) = VHKK(1,I)*1.0D12
8742 IF (INCL.EQ.2) R(1) = VHKK(1,I)*1.0D12-BIMPAC
8743 R(2) = VHKK(2,I)*1.0D12
8745 IF ( (INCL.EQ.1).AND.(ISTHKK(IDXNU).EQ.10) )
8746 & IDXNU = JMOHKK(1,I-1)
8747 IF ( (INCL.EQ.2).AND.(ISTHKK(IDXNU).EQ. 9) )
8748 & IDXNU = JMOHKK(1,I+1)
8749 R(3) = VHKK(3,IDXNU)*1.0D12
8750 * position of target parton the chain is connected to
8754 * multiple scattering of parton with DTEVT1-index I
8755 CALL DT_CROMSC(PIN,R,POUT,INCL)
8757 C IF (NEVHKK.EQ.5) THEN
8758 C AMIN = PIN(4)**2-PIN(1)**2-PIN(2)**2-PIN(3)**2
8759 C AMOU = POUT(4)**2-POUT(1)**2-POUT(2)**2-POUT(3)**2
8760 C AMIN = SIGN(SQRT(ABS(AMIN)),AMIN)
8761 C AMOU = SIGN(SQRT(ABS(AMOU)),AMOU)
8762 C WRITE(6,'(A,I4,2E15.5)')'I,AMIN,AMOU: ',I,AMIN,AMOU
8763 C WRITE(6,'(A,4E15.5)')'PIN: ',PIN
8764 C WRITE(6,'(A,4E15.5)')'POUT: ',POUT
8767 * increase accumulator by energy-momentum difference
8769 DEV(K) = DEV(K)+POUT(K)-PIN(K)
8772 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
8773 & PHKK(2,I)**2-PHKK(3,I)**2))
8777 * dump accumulator to momenta of valence partons
8780 DO 5 I=NPOINT(2),NHKK
8781 IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
8783 ETOT = ETOT+PHKK(4,I)
8786 C WRITE(LOUT,1000) NVAL,(DEV(K)/DBLE(NVAL),K=1,4)
8787 1000 FORMAT(1X,'CRONIN : number of val. partons ',I4,/,
8789 DO 6 I=NPOINT(2),NHKK
8790 IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
8793 C PHKK(K,I) = PHKK(K,I)-DEV(K)/DBLE(NVAL)
8794 PHKK(K,I) = PHKK(K,I)-DEV(K)*E/ETOT
8796 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
8797 & PHKK(2,I)**2-PHKK(3,I)**2))
8804 *$ CREATE DT_CROMSC.FOR
8807 *===cromsc=============================================================*
8809 SUBROUTINE DT_CROMSC(PIN,R,POUT,INCL)
8811 ************************************************************************
8812 * Cronin-Effect. Multiple scattering of one parton passing through *
8814 * PIN(4) input 4-momentum of parton *
8815 * POUT(4) 4-momentum of parton after mult. scatt. *
8816 * R(3) spatial position of parton in target nucleus *
8817 * INCL = 1 multiple sc. in projectile *
8818 * = 2 multiple sc. in target *
8819 * This is a revised version of the original version written by J. Ranft*
8820 * This version dated 17.01.95 is written by S. Roesler. *
8821 ************************************************************************
8823 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8825 PARAMETER ( LINP = 10 ,
8828 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
8833 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
8834 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
8835 & IREXCI(3),IRDIFF(2),IRINC
8836 * Glauber formalism: collision properties
8837 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
8838 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
8840 * various options for treatment of partons (DTUNUC 1.x)
8841 * (chain recombination, Cronin,..)
8842 LOGICAL LCO2CR,LINTPT
8843 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8846 DIMENSION PIN(4),POUT(4),R(3)
8848 DATA LSTART /.TRUE./
8850 IRCRON(1) = IRCRON(1)+1
8853 WRITE(LOUT,1000) CRONCO
8854 1000 FORMAT(/,1X,'CROMSC: multiple scattering of chain ends',
8855 & ' treated',/,10X,'with parameter CRONCO = ',F5.2)
8861 IF (INCL.EQ.2) RNCL = RTARG
8863 * Lorentz-transformation into Lab.
8865 CALL DT_LTNUC(PIN(3),PIN(4),PZ,PE,MODE)
8867 PTOT = SQRT(PIN(1)**2+PIN(2)**2+PZ**2)
8868 IF (PTOT.LE.8.0D0) GOTO 9997
8870 * direction cosines of parton before mult. scattering
8875 RTESQ = R(1)**2+R(2)**2+R(3)**2-RNCL**2
8876 IF (RTESQ.GE.-TINY3) GOTO 9999
8878 * calculate distance (DIST) from R to surface of nucleus (radius RNCL)
8879 * in the direction of particle motion
8881 A = COSX*R(1)+COSY*R(2)+COSZ*R(3)
8883 IF (TMP.LT.ZERO) GOTO 9998
8886 * multiple scattering angle
8887 THETO = CRONCO*SQRT(DIST)/PTOT
8888 IF (THETO.GT.0.1D0) THETO=0.1D0
8891 * Gaussian sampling of spatial angle
8892 CALL DT_RANNOR(R1,R2)
8893 THETA = ABS(R1*THETO)
8894 IF (THETA.GT.0.3D0) GOTO 9997
8895 CALL DT_DSFECF(SFE,CFE)
8899 * new direction cosines
8900 CALL DT_MYTRAN(1,COSX,COSY,COSZ,COSTH,SINTH,SFE,CFE,
8901 & COSXN,COSYN,COSZN)
8903 POUT(1) = COSXN*PTOT
8904 POUT(2) = COSYN*PTOT
8906 * Lorentz-transformation into nucl.-nucl. cms
8908 CALL DT_LTNUC(PZ,PE,POUT(3),POUT(4),MODE)
8910 C IF (ABS(PIN(4)-POUT(4)).GT.0.2D0) THEN
8911 C IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.1D0 ) THEN
8912 IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.05D0 ) THEN
8915 IF (MOD(NCBACK,200).EQ.0) THEN
8916 WRITE(LOUT,1001) THETO,PIN,POUT
8917 1001 FORMAT(1X,'CROMSC: inconsistent scattering angle ',
8918 & E12.4,/,1X,' PIN :',4E12.4,/,
8919 & 1X,' POUT:',4E12.4)
8927 9997 IRCRON(2) = IRCRON(2)+1
8929 9998 IRCRON(3) = IRCRON(3)+1
8938 *$ CREATE DT_COM2CR.FOR
8941 *===com2sr=============================================================*
8943 SUBROUTINE DT_COM2CR
8945 ************************************************************************
8946 * COMbine q-aq chains to Color Ropes (qq-aqaq). *
8947 * CUTOF parameter determining minimum number of not *
8948 * combined q-aq chains *
8949 * This subroutine replaces KKEVCC etc. *
8950 * This version dated 11.01.95 is written by S. Roesler. *
8951 ************************************************************************
8953 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8955 PARAMETER ( LINP = 10 ,
8960 PARAMETER (NMXHKK=200000)
8961 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8962 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8963 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8964 * extended event history
8965 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8966 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8969 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
8970 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
8972 * various options for treatment of partons (DTUNUC 1.x)
8973 * (chain recombination, Cronin,..)
8974 LOGICAL LCO2CR,LINTPT
8975 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8978 DIMENSION IDXQA(248),IDXAQ(248)
8980 ICCHAI(1,9) = ICCHAI(1,9)+1
8983 * scan DTEVT1 for q-aq, aq-q chains
8984 DO 10 I=NPOINT(3),NHKK
8985 * skip "chains" which are resonances
8986 IF ((IDHKK(I).EQ.88888).AND.(IDRES(I).EQ.0)) THEN
8989 IF ((ABS(IDHKK(MO1)).LE.6).AND.(ABS(IDHKK(MO2)).LE.6)) THEN
8990 * q-aq, aq-q chain found, keep index
8991 IF (IDHKK(MO1).GT.0) THEN
9002 * minimum number of q-aq chains requested for the same projectile/
9004 NCHMIN = IDT_NPOISS(CUTOF)
9006 * combine q-aq chains of the same projectile
9007 CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,1)
9008 * combine q-aq chains of the same target
9009 CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,2)
9010 * combine aq-q chains of the same projectile
9011 CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,1)
9012 * combine aq-q chains of the same target
9013 CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,2)
9018 *$ CREATE DT_SCN4CR.FOR
9021 *===scn4cr=============================================================*
9023 SUBROUTINE DT_SCN4CR(NCH,IDXCH,NCHMIN,MODE)
9025 ************************************************************************
9026 * SCan q-aq chains for Color Ropes. *
9027 * This version dated 11.01.95 is written by S. Roesler. *
9028 ************************************************************************
9030 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9032 PARAMETER ( LINP = 10 ,
9037 PARAMETER (NMXHKK=200000)
9038 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9039 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9040 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9041 * extended event history
9042 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9043 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9046 DIMENSION IDXCH(248),IDXJN(248)
9049 IF (IDXCH(I).GT.0) THEN
9051 IDXMO = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(I))))
9055 IF (IDXCH(J).GT.0) THEN
9056 IDXMO1 = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(J))))
9057 IF (IDXMO.EQ.IDXMO1) THEN
9064 IF (NJOIN.GE.NCHMIN+2) THEN
9065 NJ = INT(DBLE(NJOIN-NCHMIN)/2.0D0)
9067 CALL DT_JOIN(IDXCH(IDXJN(J)),IDXCH(IDXJN(J+1)),IREJ1)
9068 IF (IREJ1.NE.0) GOTO 3
9070 IDXCH(IDXJN(J+1)) = 0
9079 *$ CREATE DT_JOIN.FOR
9082 *===join===============================================================*
9084 SUBROUTINE DT_JOIN(IDX1,IDX2,IREJ)
9086 ************************************************************************
9087 * This subroutine joins two q-aq chains to one qq-aqaq chain. *
9088 * IDX1, IDX2 DTEVT1 indices of chains to be joined *
9089 * This version dated 11.01.95 is written by S. Roesler. *
9090 ************************************************************************
9092 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9094 PARAMETER ( LINP = 10 ,
9099 PARAMETER (NMXHKK=200000)
9100 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9101 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9102 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9103 * extended event history
9104 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9105 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9107 * flags for input different options
9108 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
9109 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
9110 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
9112 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9113 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9116 DIMENSION MO(2,2),ID(2,2),IDX(2),PCH(4),PP(4),PT(4),P1(4),P2(4)
9124 MO(I,J) = JMOHKK(J,IDX(I))
9125 ID(I,J) = IDT_IPDG2B(IDHKK(MO(I,J)),1,2)
9130 IF ((ABS(ID(1,1)).GT.6).OR.(ABS(ID(1,2)).GT.6).OR.
9131 & (ABS(ID(2,1)).GT.6).OR.(ABS(ID(2,2)).GT.6).OR.
9132 & ((ID(1,1)*ID(2,1)).LT.0).OR.
9133 & ((ID(1,2)*ID(2,2)).LT.0)) THEN
9134 WRITE(LOUT,1000) IDX(1),MO(1,1),MO(1,2),IDX(2),MO(2,1),
9136 1000 FORMAT(1X,'JOIN: incons. chain system! chain ',I4,':',
9137 & 2I5,' chain ',I4,':',2I5)
9142 PP(K) = PHKK(K,MO(1,1))+PHKK(K,MO(2,1))
9143 PT(K) = PHKK(K,MO(1,2))+PHKK(K,MO(2,2))
9145 IF1 = IDT_IB2PDG(ID(1,1),ID(2,1),2)
9146 IF2 = IDT_IB2PDG(ID(1,2),ID(2,2),2)
9147 IST1 = ISTHKK(MO(1,1))
9148 IST2 = ISTHKK(MO(1,2))
9150 * put partons again on mass shell
9153 IF (IMSHL.EQ.1) THEN
9157 CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1)
9158 IF (IREJ1.NE.0) GOTO 9999
9164 * store new partons in DTEVT1
9165 CALL DT_EVTPUT(IST1,IF1,MO(1,1),MO(2,1),PP(1),PP(2),PP(3),PP(4),
9167 CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4),
9170 PCH(K) = PP(K)+PT(K)
9173 * check new chain for lower mass limit
9174 IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
9175 AMCH = SQRT(ABS(PCH(4)**2-PCH(1)**2-PCH(2)**2-PCH(3)**2))
9176 CALL DT_CH2RES(ID(1,1),ID(2,1),ID(1,2),ID(2,2),IDUM,IDUM,
9177 & AMCH,AMCHN,3,IREJ1)
9178 IF (IREJ1.NE.0) THEN
9184 ICCHAI(2,9) = ICCHAI(2,9)+1
9185 * store new chain in DTEVT1
9187 CALL DT_EVTPUT(KCH,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),0,0,9)
9188 IDHKK(IDX(1)) = 22222
9189 IDHKK(IDX(2)) = 22222
9190 * special treatment for space-time coordinates
9192 VHKK(K,NHKK) = (VHKK(K,IDX(1))+VHKK(K,IDX(2)))/2.0D0
9193 WHKK(K,NHKK) = (WHKK(K,IDX(1))+WHKK(K,IDX(2)))/2.0D0
9202 *$ CREATE DT_XSGLAU.FOR
9205 *===xsglau=============================================================*
9207 SUBROUTINE DT_XSGLAU(NA,NB,JJPROJ,XI,Q2I,ECMI,IE,IQ,NIDX)
9209 ************************************************************************
9210 * Total, elastic, quasi-elastic, inelastic cross sections according to *
9211 * Glauber's approach. *
9212 * NA / NB mass numbers of proj./target nuclei *
9213 * JJPROJ bamjet-index of projectile (=1 in case of proj.nucleus) *
9214 * XI,Q2I,ECMI kinematical variables x, Q^2, E_cm *
9215 * IE,IQ indices of energy and virtuality (the latter for gamma *
9216 * projectiles only) *
9217 * NIDX index of projectile/target nucleus *
9218 * This version dated 17.3.98 is written by S. Roesler *
9219 ************************************************************************
9221 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9223 PARAMETER ( LINP = 10 ,
9227 COMPLEX*16 CZERO,CONE,CTWO
9229 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
9230 & ONETHI=ONE/THREE,TINY25=1.0D-25)
9231 PARAMETER (TWOPI = 6.283185307179586454D+00,
9233 & GEV2MB = 0.38938D0,
9234 & GEV2FM = 0.1972D0,
9235 & ALPHEM = ONE/137.0D0,
9239 * approx. nucleon radius
9242 * particle properties (BAMJET index convention)
9244 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
9245 & IICH(210),IIBAR(210),K1(210),K2(210)
9246 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
9247 PARAMETER ( MAXNCL = 260,
9249 & MAXSQU = 20*MAXVQU,
9250 & MAXINT = MAXVQU+MAXSQU)
9251 * Glauber formalism: parameters
9252 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
9253 & BMAX(NCOMPX),BSTEP(NCOMPX),
9254 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
9256 * Glauber formalism: cross sections
9257 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
9258 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
9259 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
9260 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
9261 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
9262 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
9263 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
9264 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
9265 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
9266 & BSLOPE,NEBINI,NQBINI
9267 * Glauber formalism: flags and parameters for statistics
9270 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
9271 * nucleon-nucleon event-generator
9274 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
9275 * VDM parameter for photon-nucleus interactions
9276 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
9277 * parameters for hA-diffraction
9278 COMMON /DTDIHA/ DIBETA,DIALPH
9280 COMPLEX*16 PP11(MAXNCL),PP12(MAXNCL),PP21(MAXNCL),PP22(MAXNCL),
9281 & OMPP11,OMPP12,OMPP21,OMPP22,
9282 & DIPP11,DIPP12,DIPP21,DIPP22,AVDIPP,
9285 DIMENSION COOP1(3,MAXNCL),COOT1(3,MAXNCL),
9286 & COOP2(3,MAXNCL),COOT2(3,MAXNCL),
9289 PARAMETER (NPOINT=16)
9290 DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
9292 LOGICAL LFIRST,LOPEN
9293 DATA LFIRST,LOPEN /.TRUE.,.FALSE./
9296 * for quasi-elastic neutrino scattering set projectile to proton
9297 * it should not have an effect since the whole Glauber-formalism is
9298 * not needed for these interactions..
9299 IF (MCGENE.EQ.4) THEN
9305 IF ((ABS(IOGLB).EQ.1).AND.(.NOT.LOPEN)) THEN
9308 CFILE = CGLB//'.glb'
9309 OPEN(LDAT,FILE=CGLB//'.glb',STATUS='UNKNOWN')
9310 ELSEIF (I.GT.1) THEN
9311 CFILE = CGLB(1:I-1)//'.glb'
9312 OPEN(LDAT,FILE=CGLB(1:I-1)//'.glb',STATUS='UNKNOWN')
9319 CZERO = DCMPLX(ZERO,ZERO)
9320 CONE = DCMPLX(ONE,ZERO)
9321 CTWO = DCMPLX(TWO,ZERO)
9325 * re-define kinematics
9329 * g(Q2=0)-A, h-A, A-A scattering
9330 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9333 * g(Q2>0)-A scattering
9334 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(S.GT.ZERO)) THEN
9336 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9337 Q2 = (S-AMP2)*X/(ONE-X)
9338 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
9339 S = Q2*(ONE-X)/X+AMP2
9341 WRITE(LOUT,*) 'XSGLAU: inconsistent input ',S,Q2,X
9346 XNU = (S+Q2-AMP2)/(TWO*AMP)
9348 * parameters determining statistics in evaluating Glauber-xsection
9351 IF (NSITEB.GT.KSITEB) NSITEB = KSITEB
9353 * set up interaction geometry (common /DTGLAM/)
9354 * projectile/target radii
9355 RPRNCL = DT_RNCLUS(NA)
9356 RTANCL = DT_RNCLUS(NB)
9357 IF (IJPROJ.EQ.7) THEN
9359 RBSH(NTARG) = RTANCL
9360 BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9362 IF (NIDX.LE.-1) THEN
9364 RBSH(NTARG) = RTANCL
9365 BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9367 RASH(NTARG) = RPRNCL
9369 BMAX(NTARG) = 2.0D0*(RASH(NTARG)+RBSH(1))
9372 * maximum impact-parameter
9373 BSTEP(NTARG)= BMAX(NTARG)/DBLE(NSITEB-1)
9375 * slope, rho ( Re(f(0))/Im(f(0)) )
9376 IF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
9377 IF (MCGENE.EQ.2) THEN
9379 CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,SDUM1,SDUM2,SDUM3,
9382 BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
9384 IF (ECMNN(IE).LE.3.0D0) THEN
9386 ELSEIF ((ECMNN(IE).GT.3.0D0).AND.(ECMNN(IE).LE.50.D0)) THEN
9387 ROSH = -0.63D0+0.175D0*LOG(ECMNN(IE))
9388 ELSEIF (ECMNN(IE).GT.50.0D0) THEN
9391 ELSEIF (IJPROJ.EQ.7) THEN
9394 BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
9398 * projectile-nucleon xsection (in fm)
9399 IF (IJPROJ.EQ.7) THEN
9400 SIGSH = DT_SIGVP(X,Q2)/10.0D0
9402 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
9403 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
9404 C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
9406 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
9407 SIGSH = SIGSH/10.0D0
9410 * parameters for projectile diffraction (hA scattering only)
9411 IF ((MCGENE.EQ.2).AND.(NA.EQ.1).AND.(NB.GT.1).AND.(IJPROJ.NE.7)
9412 & .AND.(DIBETA.GE.ZERO)) THEN
9414 CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,STOT,SDUM2,SDIF1,BDUM,0)
9415 C DIBETA = SDIF1/STOT
9417 DIGAMM = SQRT(DIALPH**2+DIBETA**2)
9418 IF (DIBETA.LE.ZERO) THEN
9421 ALPGAM = DIALPH/DIGAMM
9425 FACDI = SQRT(FACDI1*FACDI2)
9426 WRITE(LOUT,*)'DIBETA,DIALPH,DIGAMM: ',DIBETA,DIALPH,DIGAMM
9438 BSITE( 0,IQ,NTARG,I) = ZERO
9439 BSITE(IE,IQ,NTARG,I) = ZERO
9458 FACN = ONE/DBLE(NSTATB)
9463 * initialize Gauss-integration for photon-proj.
9465 IF (IJPROJ.EQ.7) THEN
9466 IF (INTRGE(1).EQ.1) THEN
9467 AMLO2 = (3.0D0*AAM(13))**2
9468 ELSEIF (INTRGE(1).EQ.2) THEN
9473 IF (INTRGE(2).EQ.1) THEN
9475 ELSEIF (INTRGE(2).EQ.2) THEN
9480 AMHI20 = (ECMNN(IE)-AMP)**2
9481 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
9482 XAMLO = LOG( AMLO2+Q2 )
9483 XAMHI = LOG( AMHI2+Q2 )
9485 C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9487 CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9490 * ratio direct/total photon-nucleon xsection
9491 CALL DT_POILIK(NB,NTARG,ECMNN(IE),Q2,IPNT,RPNT,1)
9494 * read pre-initialized profile-function from file
9495 IF (IOGLB.EQ.1) THEN
9496 READ(LDAT,'(5I10,E15.5)') KJPROJ,IA,IB,ISTATB,ISITEB,DUM
9497 IF ((IA.NE.NA).OR.(IB.NE.NB)) THEN
9498 WRITE(LOUT,1000) CFILE,IA,IB,ISTATB,ISITEB,
9499 & NA,NB,NSTATB,NSITEB
9500 1000 FORMAT(' XSGLAU: inconsistent input data in file ',A12,/,
9501 & ' (IA,IB,ISTATB,ISITEB) ',4I10,/,
9502 & ' (NA,NB,NSTATB,NSITEB) ',4I10)
9505 IF (LFIRST) WRITE(LOUT,1001) CFILE
9506 1001 FORMAT(/,' XSGLAU: impact parameter distribution read from ',
9508 READ(LDAT,'(6E12.5)') XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),
9509 & XSQEP(IE,IQ,NTARG),XSQET(IE,IQ,NTARG),
9510 & XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
9511 READ(LDAT,'(6E12.5)') XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),
9512 & XEQEP(IE,IQ,NTARG),XEQET(IE,IQ,NTARG),
9513 & XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
9514 NLINES = INT(DBLE(NSITEB)/7.0D0)
9515 IF (NLINES.GT.0) THEN
9518 READ(LDAT,'(7E11.4)')
9519 & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
9523 IF (ISTART.LE.NSITEB) THEN
9524 READ(LDAT,'(7E11.4)')
9525 & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
9529 * variable projectile/target/energy runs:
9530 * read pre-initialized profile-functions from file
9531 ELSEIF (IOGLB.EQ.100) THEN
9532 CALL DT_GLBSET(IJPROJ,IINA,IINB,RRELAB,0)
9536 * cross sections averaged over NSTATB nucleon configurations
9538 C IF ((NA.EQ.207).AND.(NB.EQ.207)) WRITE(LOUT,*) 'conf. ',IS
9548 IF (NIDX.LE.-1) THEN
9549 CALL DT_CONUCL(COOP1,NA,RASH(1),0)
9550 CALL DT_CONUCL(COOT1,NB,RBSH(NTARG),1)
9551 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9552 CALL DT_CONUCL(COOP2,NA,RASH(1),0)
9553 CALL DT_CONUCL(COOT2,NB,RBSH(NTARG),1)
9556 CALL DT_CONUCL(COOP1,NA,RASH(NTARG),0)
9557 CALL DT_CONUCL(COOT1,NB,RBSH(1),1)
9558 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9559 CALL DT_CONUCL(COOP2,NA,RASH(NTARG),0)
9560 CALL DT_CONUCL(COOT2,NB,RBSH(1),1)
9564 * integration over impact parameter B
9575 B = DBLE(IB)*BSTEP(NTARG)
9576 FACB = 10.0D0*TWOPI*B*BSTEP(NTARG)
9578 * integration over M_V^2 for photon-proj.
9584 IF (IJPROJ.EQ.7) THEN
9596 IF (IJPROJ.EQ.7) THEN
9597 AMV2 = EXP(ABSZX(IM))-Q2
9599 IF (AMV2.LT.16.0D0) THEN
9601 ELSEIF ((AMV2.GE.16.0D0).AND.(AMV2.LT.121.0D0)) THEN
9606 * define M_V dependent properties of nucleon scattering amplitude
9607 * V_M-nucleon xsection
9608 SIGMVD = RPNT*SIGSH/(AMV2+Q2+RL2)*10.0D0
9609 SIGMV = (ONE-RPNT)*SIGSH/(AMV2+Q2+RL2)
9610 * slope-parametrisation a la Kaidalov
9611 BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
9612 & +0.25D0*LOG(S/(AMV2+Q2)))
9614 IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+Q2)*GEV2FM
9615 * integration weight factor
9616 FACM = ALPHEM/(3.0D0*PI*(ONE-X))*
9617 & R*AMV2/(AMV2+Q2)*(ONE+EPSPOL*Q2/AMV2)*WEIGHT(IM)
9619 GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
9621 IF (IJPROJ.EQ.7) THEN
9622 RCA = GAM*SIGMV/TWOPI
9624 RCA = GAM*SIGSH/TWOPI
9627 CA = DCMPLX(RCA,FCA)
9636 * photon-projectile: check for supression by coherence length
9637 IF (IJPROJ.EQ.7) THEN
9638 IF (ABS(COOT1(3,INB)-COOT1(3,KK1)).GT.DCOH)THEN
9642 IF (ABS(COOT2(3,INB)-COOT2(3,KK2)).GT.DCOH)THEN
9648 X11 = B+COOT1(1,INB)-COOP1(1,INA)
9649 Y11 = COOT1(2,INB)-COOP1(2,INA)
9650 XY11 = GAM*(X11*X11+Y11*Y11)
9651 IF (XY11.LE.15.0D0) THEN
9652 C = CONE-CA*EXP(-XY11)
9653 AR = DBLE(PP11(INT1))
9654 AI = DIMAG(PP11(INT1))
9655 IF (ABS(AR).LT.TINY25) AR = ZERO
9656 IF (ABS(AI).LT.TINY25) AI = ZERO
9657 PP11(INT1) = DCMPLX(AR,AI)
9658 PP11(INT1) = PP11(INT1)*C
9661 SHI = SHI+LOG(AR*AR+AI*AI)
9663 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9664 X12 = B+COOT2(1,INB)-COOP1(1,INA)
9665 Y12 = COOT2(2,INB)-COOP1(2,INA)
9666 XY12 = GAM*(X12*X12+Y12*Y12)
9667 IF (XY12.LE.15.0D0) THEN
9668 C = CONE-CA*EXP(-XY12)
9669 AR = DBLE(PP12(INT2))
9670 AI = DIMAG(PP12(INT2))
9671 IF (ABS(AR).LT.TINY25) AR = ZERO
9672 IF (ABS(AI).LT.TINY25) AI = ZERO
9673 PP12(INT2) = DCMPLX(AR,AI)
9674 PP12(INT2) = PP12(INT2)*C
9676 X21 = B+COOT1(1,INB)-COOP2(1,INA)
9677 Y21 = COOT1(2,INB)-COOP2(2,INA)
9678 XY21 = GAM*(X21*X21+Y21*Y21)
9679 IF (XY21.LE.15.0D0) THEN
9680 C = CONE-CA*EXP(-XY21)
9681 AR = DBLE(PP21(INT1))
9682 AI = DIMAG(PP21(INT1))
9683 IF (ABS(AR).LT.TINY25) AR = ZERO
9684 IF (ABS(AI).LT.TINY25) AI = ZERO
9685 PP21(INT1) = DCMPLX(AR,AI)
9686 PP21(INT1) = PP21(INT1)*C
9688 X22 = B+COOT2(1,INB)-COOP2(1,INA)
9689 Y22 = COOT2(2,INB)-COOP2(2,INA)
9690 XY22 = GAM*(X22*X22+Y22*Y22)
9691 IF (XY22.LE.15.0D0) THEN
9692 C = CONE-CA*EXP(-XY22)
9693 AR = DBLE(PP22(INT2))
9694 AI = DIMAG(PP22(INT2))
9695 IF (ABS(AR).LT.TINY25) AR = ZERO
9696 IF (ABS(AI).LT.TINY25) AI = ZERO
9697 PP22(INT2) = DCMPLX(AR,AI)
9698 PP22(INT2) = PP22(INT2)*C
9709 IF (PP11(K).EQ.CZERO) THEN
9713 PPTMP1 = PP11(K)**(ONE-DIALPH-DIGAMM)
9714 PPTMP2 = PP11(K)**(ONE-DIALPH+DIGAMM)
9717 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9718 OMPP11 = OMPP11+AVDIPP
9719 C OMPP11 = OMPP11+(CONE-PP11(K))
9720 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9721 DIPP11 = DIPP11+AVDIPP
9722 IF (PP21(K).EQ.CZERO) THEN
9726 PPTMP1 = PP21(K)**(ONE-DIALPH-DIGAMM)
9727 PPTMP2 = PP21(K)**(ONE-DIALPH+DIGAMM)
9730 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9731 OMPP21 = OMPP21+AVDIPP
9732 C OMPP21 = OMPP21+(CONE-PP21(K))
9733 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9734 DIPP21 = DIPP21+AVDIPP
9741 IF (PP12(K).EQ.CZERO) THEN
9745 PPTMP1 = PP12(K)**(ONE-DIALPH-DIGAMM)
9746 PPTMP2 = PP12(K)**(ONE-DIALPH+DIGAMM)
9749 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9750 OMPP12 = OMPP12+AVDIPP
9751 C OMPP12 = OMPP12+(CONE-PP12(K))
9752 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9753 DIPP12 = DIPP12+AVDIPP
9754 IF (PP22(K).EQ.CZERO) THEN
9758 PPTMP1 = PP22(K)**(ONE-DIALPH-DIGAMM)
9759 PPTMP2 = PP22(K)**(ONE-DIALPH+DIGAMM)
9762 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9763 OMPP22 = OMPP22+AVDIPP
9764 C OMPP22 = OMPP22+(CONE-PP22(K))
9765 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9766 DIPP22 = DIPP22+AVDIPP
9769 SPROM = ONE-EXP(SHI)
9770 SPROB = SPROB+FACM*SPROM
9771 IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9772 STOTM = DBLE(OMPP11+OMPP22)
9773 SELAM = DBLE(OMPP11*DCONJG(OMPP22))
9774 SQEPM = DBLE(OMPP11*DCONJG(OMPP21))-SELAM
9775 SQETM = DBLE(OMPP11*DCONJG(OMPP12))-SELAM
9776 SQE2M = DBLE(OMPP11*DCONJG(OMPP11))-SELAM-SQEPM-SQETM
9777 SDELM = DBLE(DIPP11*DCONJG(DIPP22))
9778 SDQEM = DBLE(DIPP11*DCONJG(DIPP21))-SDELM
9779 STOTB = STOTB+FACM*STOTM
9780 SELAB = SELAB+FACM*SELAM
9781 SDELB = SDELB+FACM*SDELM
9783 SQEPB = SQEPB+FACM*SQEPM
9784 SDQEB = SDQEB+FACM*SDQEM
9786 IF (NA.GT.1) SQETB = SQETB+FACM*SQETM
9787 IF ((NA.GT.1).AND.(NB.GT.1)) SQE2B = SQE2B+FACM*SQE2M
9788 IF (IJPROJ.EQ.7) SDIR = SDIR+FACM*SIGMVD
9793 STOTN = STOTN+FACB*STOTB
9794 SELAN = SELAN+FACB*SELAB
9795 SQEPN = SQEPN+FACB*SQEPB
9796 SQETN = SQETN+FACB*SQETB
9797 SQE2N = SQE2N+FACB*SQE2B
9798 SPRON = SPRON+FACB*SPROB
9799 SDELN = SDELN+FACB*SDELB
9800 SDQEN = SDQEN+FACB*SDQEB
9802 IF (IJPROJ.EQ.7) THEN
9803 BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*(STOTB-SELAB-SQEPB)
9805 IF (DIBETA.GT.ZERO) THEN
9806 BPROD(IB+1)= BPROD(IB+1)
9807 & +FACN*FACB*(STOTB-SELAB-SQEPB-SQETB-SQE2B)
9809 BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*SPROB
9815 STOT = STOT +FACN*STOTN
9816 STOT2 = STOT2+FACN*STOTN**2
9817 SELA = SELA +FACN*SELAN
9818 SELA2 = SELA2+FACN*SELAN**2
9819 SQEP = SQEP +FACN*SQEPN
9820 SQEP2 = SQEP2+FACN*SQEPN**2
9821 SQET = SQET +FACN*SQETN
9822 SQET2 = SQET2+FACN*SQETN**2
9823 SQE2 = SQE2 +FACN*SQE2N
9824 SQE22 = SQE22+FACN*SQE2N**2
9825 SPRO = SPRO +FACN*SPRON
9826 SPRO2 = SPRO2+FACN*SPRON**2
9827 SDEL = SDEL +FACN*SDELN
9828 SDEL2 = SDEL2+FACN*SDELN**2
9829 SDQE = SDQE +FACN*SDQEN
9830 SDQE2 = SDQE2+FACN*SDQEN**2
9834 * final cross sections
9836 XSTOT(IE,IQ,NTARG) = STOT
9838 & XSTOT(IE,IQ,NTARG) = XSTOT(IE,IQ,NTARG)+DBLE(NB)*SDIR
9840 XSELA(IE,IQ,NTARG) = SELA
9841 * 3) quasi-el.: A+B-->A+X (excluding 2)
9842 XSQEP(IE,IQ,NTARG) = SQEP
9843 * 4) quasi-el.: A+B-->X+B (excluding 2)
9844 XSQET(IE,IQ,NTARG) = SQET
9845 * 5) quasi-el.: A+B-->X (excluding 2-4)
9846 XSQE2(IE,IQ,NTARG) = SQE2
9847 * 6) production (= STOT-SELA-SQEP-SQET-SQE2!)
9848 IF (SDEL.GT.ZERO) THEN
9849 XSPRO(IE,IQ,NTARG) = STOT-SELA-SQEP-SQET-SQE2
9851 XSPRO(IE,IQ,NTARG) = SPRO
9853 * 7) projectile diffraction (el. scatt. off target)
9854 XSDEL(IE,IQ,NTARG) = SDEL
9855 * 8) projectile diffraction (quasi-el. scatt. off target)
9856 XSDQE(IE,IQ,NTARG) = SDQE
9858 XETOT(IE,IQ,NTARG) = SQRT(ABS(STOT2-STOT**2)/DBLE(NSTATB-1))
9859 XEELA(IE,IQ,NTARG) = SQRT(ABS(SELA2-SELA**2)/DBLE(NSTATB-1))
9860 XEQEP(IE,IQ,NTARG) = SQRT(ABS(SQEP2-SQEP**2)/DBLE(NSTATB-1))
9861 XEQET(IE,IQ,NTARG) = SQRT(ABS(SQET2-SQET**2)/DBLE(NSTATB-1))
9862 XEQE2(IE,IQ,NTARG) = SQRT(ABS(SQE22-SQE2**2)/DBLE(NSTATB-1))
9863 XEPRO(IE,IQ,NTARG) = SQRT(ABS(SPRO2-SPRO**2)/DBLE(NSTATB-1))
9864 XEDEL(IE,IQ,NTARG) = SQRT(ABS(SDEL2-SDEL**2)/DBLE(NSTATB-1))
9865 XEDQE(IE,IQ,NTARG) = SQRT(ABS(SDQE2-SDQE**2)/DBLE(NSTATB-1))
9867 IF (IJPROJ.EQ.7) THEN
9868 BNORM = XSTOT(IE,IQ,NTARG)-XSELA(IE,IQ,NTARG)
9869 & -XSQEP(IE,IQ,NTARG)
9871 BNORM = XSPRO(IE,IQ,NTARG)
9874 BSITE(IE,IQ,NTARG,I) = BPROD(I)/BNORM+BSITE(IE,IQ,NTARG,I-1)
9875 IF ((IE.EQ.1).AND.(IQ.EQ.1))
9876 & BSITE(0,1,NTARG,I) = BPROD(I)/BNORM+BSITE(0,1,NTARG,I-1)
9879 * write profile function data into file
9880 IF ((IOGLB.EQ.-1).OR.(IOGLB.EQ.-100)) THEN
9881 WRITE(LDAT,'(5I10,1P,E15.5)')
9882 & IJPROJ,NA,NB,NSTATB,NSITEB,ECMNN(IE)
9883 WRITE(LDAT,'(1P,6E12.5)')
9884 & XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),XSQEP(IE,IQ,NTARG),
9885 & XSQET(IE,IQ,NTARG),XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
9886 WRITE(LDAT,'(1P,6E12.5)')
9887 & XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),XEQEP(IE,IQ,NTARG),
9888 & XEQET(IE,IQ,NTARG),XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
9889 NLINES = INT(DBLE(NSITEB)/7.0D0)
9890 IF (NLINES.GT.0) THEN
9893 WRITE(LDAT,'(1P,7E11.4)')
9894 & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
9898 IF (ISTART.LE.NSITEB) THEN
9899 WRITE(LDAT,'(1P,7E11.4)')
9900 & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
9906 C IF (ABS(IOGLB).EQ.1) CLOSE(LDAT)
9911 *$ CREATE DT_GETBXS.FOR
9914 *===getbxs=============================================================*
9916 SUBROUTINE DT_GETBXS(XSFRAC,BLO,BHI,NIDX)
9918 ************************************************************************
9919 * Biasing in impact parameter space. *
9920 * XSFRAC = 0 : BLO - minimum impact parameter (input) *
9921 * BHI - maximum impact parameter (input) *
9922 * XSFRAC - fraction of cross section corresponding *
9923 * to impact parameter range (BLO,BHI) *
9925 * XSFRAC > 0 : XSFRAC - fraction of cross section (input) *
9926 * BHI - maximum impact parameter giving requested *
9927 * fraction of cross section in impact *
9928 * parameter range (0,BMAX) (output) *
9929 * This version dated 17.03.00 is written by S. Roesler *
9930 ************************************************************************
9932 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9934 PARAMETER ( LINP = 10 ,
9938 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
9939 * Glauber formalism: parameters
9940 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
9941 & BMAX(NCOMPX),BSTEP(NCOMPX),
9942 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
9946 IF (XSFRAC.LE.0.0D0) THEN
9947 ILO = MIN(NSITEB-1,INT(BLO/BSTEP(NTARG)))
9948 IHI = MIN(NSITEB-1,INT(BHI/BSTEP(NTARG)))
9949 IF (ILO.GE.IHI) THEN
9953 IF (ILO.EQ.NSITEB-1) THEN
9954 FRCLO = BSITE(0,1,NTARG,NSITEB)
9956 FRCLO = BSITE(0,1,NTARG,ILO+1)
9957 & +(BLO-ILO*BSTEP(NTARG))/BSTEP(NTARG)
9958 & *(BSITE(0,1,NTARG,ILO+2)-BSITE(0,1,NTARG,ILO+1))
9960 IF (IHI.EQ.NSITEB-1) THEN
9961 FRCHI = BSITE(0,1,NTARG,NSITEB)
9963 FRCHI = BSITE(0,1,NTARG,IHI+1)
9964 & +(BHI-IHI*BSTEP(NTARG))/BSTEP(NTARG)
9965 & *(BSITE(0,1,NTARG,IHI+2)-BSITE(0,1,NTARG,IHI+1))
9967 XSFRAC = FRCHI-FRCLO
9972 IF (XSFRAC.LT.BSITE(0,1,NTARG,I+1)) THEN
9973 FAC = (XSFRAC -BSITE(0,1,NTARG,I))/
9974 & (BSITE(0,1,NTARG,I+1)-BSITE(0,1,NTARG,I))
9975 BHI = DBLE(I-1)*BSTEP(NTARG)+BSTEP(NTARG)*FAC
9985 *$ CREATE DT_CONUCL.FOR
9988 *===conucl=============================================================*
9990 SUBROUTINE DT_CONUCL(X,N,R,MODE)
9992 ************************************************************************
9993 * Calculation of coordinates of nucleons within nuclei. *
9994 * X(3,N) spatial coordinates of nucleons (in fm) (output) *
9995 * N / R number of nucleons / radius of nucleus (input) *
9996 * MODE = 0 coordinates not sorted *
9997 * = 1 coordinates sorted with increasing X(3,i) *
9998 * = 2 coordinates sorted with decreasing X(3,i) *
9999 * This version dated 26.10.95 is revised by S. Roesler *
10000 ************************************************************************
10002 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10004 PARAMETER ( LINP = 10 ,
10008 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10009 & ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10011 PARAMETER (TWOPI = 6.283185307179586454D+00 )
10013 PARAMETER (NSRT=10)
10014 DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10015 DIMENSION X(3,N),XTMP(3,260)
10017 CALL DT_COORDI(XTMP,IDXSRT,ICSRT,N,R)
10019 IF ((MODE.NE.0).AND.(N.GT.4)) THEN
10022 IF (MODE.EQ.2) THEN
10028 DO 2 J=1,ICSRT(ISRT)
10030 X(1,K) = XTMP(1,IDXSRT(ISRT,J))
10031 X(2,K) = XTMP(2,IDXSRT(ISRT,J))
10032 X(3,K) = XTMP(3,IDXSRT(ISRT,J))
10034 IF (ICSRT(ISRT).GT.1) THEN
10037 CALL DT_SORT(X,N,I0,I1,MODE)
10040 ELSEIF ((MODE.NE.0).AND.(N.GE.2).AND.(N.LE.4)) THEN
10046 CALL DT_SORT(X,N,1,N,MODE)
10058 *$ CREATE DT_COORDI.FOR
10061 *===coordi=============================================================*
10063 SUBROUTINE DT_COORDI(X,IDXSRT,ICSRT,N,R)
10065 ************************************************************************
10066 * Calculation of coordinates of nucleons within nuclei. *
10067 * X(3,N) spatial coordinates of nucleons (in fm) (output) *
10068 * N / R number of nucleons / radius of nucleus (input) *
10069 * Based on the original version by Shmakov et al. *
10070 * This version dated 26.10.95 is revised by S. Roesler *
10071 ************************************************************************
10073 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10075 PARAMETER ( LINP = 10 ,
10079 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10080 & ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10082 PARAMETER (TWOPI = 6.283185307179586454D+00 )
10086 PARAMETER (NSRT=10)
10087 DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10088 DIMENSION X(3,260),WD(4),RD(3)
10090 DATA PDIF/0.545D0/,R2MIN/0.16D0/
10091 DATA WD / 0.0D0, 0.178D0, 0.465D0, 1.0D0/
10092 DATA RD /2.09D0, 0.935D0, 0.697D0/
10102 ELSEIF (N.EQ.2) THEN
10103 EPS = DT_RNDM(RD(1))
10105 IF ((EPS.GE.WD(I)).AND.(EPS.LE.WD(I+1))) GOTO 40
10109 CALL DT_RANNOR(X1,X2)
10113 ELSEIF ((N.EQ.3).OR.(N.EQ.4)) THEN
10116 CALL DT_RANNOR(X3,X4)
10118 CALL DT_RANNOR(X1,X2)
10121 IF (LSTART) GOTO 80
10123 CALL DT_RANNOR(X3,X4)
10128 LSTART = .NOT.LSTART
10129 X1SUM = X1SUM+X(1,I)
10130 X2SUM = X2SUM+X(2,I)
10131 X3SUM = X3SUM+X(3,I)
10133 X1SUM = X1SUM/DBLE(N)
10134 X2SUM = X2SUM/DBLE(N)
10135 X3SUM = X3SUM/DBLE(N)
10137 X(1,I) = X(1,I)-X1SUM
10138 X(2,I) = X(2,I)-X2SUM
10139 X(3,I) = X(3,I)-X3SUM
10143 * maximum nuclear radius for coordinate sampling
10144 RMAX = R+4.605D0*PDIF
10146 * initialize pre-sorting
10150 DR = TWO*RMAX/DBLE(NSRT)
10152 * sample coordinates for N nucleons
10155 RAD = RMAX*(DT_RNDM(DR))**ONETHI
10156 F = DT_DENSIT(N,RAD,R)
10157 IF (DT_RNDM(RAD).GT.F) GOTO 120
10158 * theta, phi uniformly distributed
10159 CT = ONE-TWO*DT_RNDM(F)
10160 ST = SQRT((ONE-CT)*(ONE+CT))
10161 CALL DT_DSFECF(SFE,CFE)
10162 X(1,I) = RAD*ST*CFE
10163 X(2,I) = RAD*ST*SFE
10165 * ensure that distance between two nucleons is greater than R2MIN
10166 IF (I.LT.2) GOTO 122
10169 DIST2 = (X(1,I)-X(1,I2))**2+(X(2,I)-X(2,I2))**2+
10170 & (X(3,I)-X(3,I2))**2
10171 IF (DIST2.LE.R2MIN) GOTO 120
10174 * save index according to z-bin
10175 IDXZ = INT( (X(3,I)+RMAX)/DR )+1
10176 ICSRT(IDXZ) = ICSRT(IDXZ)+1
10177 IDXSRT(IDXZ,ICSRT(IDXZ)) = I
10178 X1SUM = X1SUM+X(1,I)
10179 X2SUM = X2SUM+X(2,I)
10180 X3SUM = X3SUM+X(3,I)
10182 X1SUM = X1SUM/DBLE(N)
10183 X2SUM = X2SUM/DBLE(N)
10184 X3SUM = X3SUM/DBLE(N)
10186 X(1,I) = X(1,I)-X1SUM
10187 X(2,I) = X(2,I)-X2SUM
10188 X(3,I) = X(3,I)-X3SUM
10196 *$ CREATE DT_DENSIT.FOR
10199 *===densit=============================================================*
10201 DOUBLE PRECISION FUNCTION DT_DENSIT(NA,R,RA)
10203 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10206 PARAMETER ( LINP = 10 ,
10209 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10210 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
10213 DIMENSION R0(18),FNORM(18)
10214 DATA R0 / ZERO, ZERO, ZERO, ZERO, 2.12D0,
10215 & 2.56D0, 2.41D0, 2.46D0, 2.52D0, 2.45D0,
10216 & 2.37D0, 2.46D0, 2.44D0, 2.54D0, 2.58D0,
10217 & 2.72D0, 2.66D0, 2.79D0/
10218 DATA FNORM /.1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10219 & .1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10220 & .1012D+01,.1039D+01,.1075D+01,.1118D+01,.1164D+01,
10221 & .1214D+01,.1265D+01,.1318D+01/
10222 DATA PDIF /0.545D0/
10228 ELSEIF ((NA.GT.4).AND.(NA.LE.18)) THEN
10229 R1 = R0(NA)/SQRT(2.5D0-4.0D0/DBLE(NA))
10230 DT_DENSIT = (ONE+(DBLE(NA)-4.0D0)/6.0D0*(R/R1)**2)
10231 & *EXP(-(R/R1)**2)/FNORM(NA)
10233 ELSEIF (NA.GT.18) THEN
10234 DT_DENSIT = ONE/(ONE+EXP((R-RA)/PDIF))
10240 *$ CREATE DT_RNCLUS.FOR
10243 *===rnclus=============================================================*
10245 DOUBLE PRECISION FUNCTION DT_RNCLUS(N)
10247 ************************************************************************
10248 * Nuclear radius for nucleus with mass number N. *
10249 * This version dated 26.9.00 is written by S. Roesler *
10250 ************************************************************************
10252 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10255 PARAMETER (ONE=1.0D0,THREE=3.0D0,ONETHI=ONE/THREE)
10258 PARAMETER (RNUCLE = 1.12D0)
10260 * nuclear radii for selected nuclei
10261 DIMENSION RADNUC(18)
10262 DATA RADNUC / 8*0.0D0,2.52D0,2.45D0,2.37D0,2.45D0,2.44D0,2.55D0,
10263 & 2.58D0,2.71D0,2.66D0,2.71D0/
10266 IF (RADNUC(N).GT.0.0D0) THEN
10267 DT_RNCLUS = RADNUC(N)
10269 DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10272 DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10278 *$ CREATE DT_DENTST.FOR
10281 *===dentst=============================================================*
10283 C PROGRAM DT_DENTST
10284 SUBROUTINE DT_DENTST
10286 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10289 OPEN(40,FILE='dentst.out',STATUS='UNKNOWN')
10290 OPEN(41,FILE='denmax.out',STATUS='UNKNOWN')
10295 DR = (RMAX-RMIN)/DBLE(NBINS)
10299 R = RMIN+DBLE(IR-1)*DR
10300 F = DT_DENSIT(IA,R,R)
10301 IF (F.GT.FMAX) FMAX = F
10302 WRITE(40,'(1X,I3,2E15.5)') IA,R,F
10304 WRITE(41,'(1X,I3,E15.5)') IA,FMAX
10312 *$ CREATE DT_SHMAKI.FOR
10315 *===shmaki=============================================================*
10317 SUBROUTINE DT_SHMAKI(NA,NCA,NB,NCB,IJP,PPN,MODE)
10319 ************************************************************************
10320 * Initialisation of Glauber formalism. This subroutine has to be *
10321 * called once (in case of target emulsions as often as many different *
10322 * target nuclei are considered) before events are sampled. *
10323 * NA / NCA mass number/charge of projectile nucleus *
10324 * NB / NCB mass number/charge of target nucleus *
10325 * IJP identity of projectile (hadrons/leptons/photons) *
10326 * PPN projectile momentum (for projectile nuclei: *
10327 * momentum per nucleon) in target rest system *
10328 * MODE = 0 Glauber formalism invoked *
10329 * = 1 fitted results are loaded from data-file *
10330 * = 99 NTARG is forced to be 1 *
10331 * (used in connection with GLAUBERI-card only) *
10332 * This version dated 22.03.96 is based on the original SHMAKI-routine *
10333 * and revised by S. Roesler. *
10334 ************************************************************************
10336 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10338 PARAMETER ( LINP = 10 ,
10341 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
10344 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10345 * Glauber formalism: parameters
10346 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10347 & BMAX(NCOMPX),BSTEP(NCOMPX),
10348 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10350 * Lorentz-parameters of the current interaction
10351 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10352 & UMO,PPCM,EPROJ,PPROJ
10353 * properties of photon/lepton projectiles
10354 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10355 * kinematical cuts for lepton-nucleus interactions
10356 COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
10357 & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
10358 * Glauber formalism: cross sections
10359 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10360 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10361 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10362 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10363 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10364 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10365 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10366 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10367 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10368 & BSLOPE,NEBINI,NQBINI
10369 * cuts for variable energy runs
10370 COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
10371 * nucleon-nucleon event-generator
10374 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10375 * Glauber formalism: flags and parameters for statistics
10378 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10380 DATA NTARG,ICOUT,IVEOUT /0,0,0/
10386 IF (MODE.EQ.99) NTARG = 1
10388 IF (MODE.EQ.-1) NIDX = NTARG
10390 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) ICOUT = ICOUT+1
10391 IF (ICOUT.EQ.1) WRITE(LOUT,1000)
10392 1000 FORMAT(//,1X,'SHMAKI: Glauber formalism (Shmakov et. al) -',
10393 & ' initialization',/,12X,'--------------------------',
10394 & '-------------------------',/)
10396 IF (MODE.EQ.2) THEN
10397 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10398 CALL DT_SHFAST(MODE,PPN,IBACK)
10399 STOP ' Glauber pre-initialization done'
10401 IF (MODE.EQ.1) THEN
10402 CALL DT_PROFBI(NA,NB,PPN,NTARG)
10405 IF (MODE.EQ.3) CALL DT_SHFAST(MODE,PPN,IBACK)
10406 IF (IBACK.EQ.1) THEN
10407 * lepton-nucleus (variable energy runs)
10408 IF ((IJP.EQ. 3).OR.(IJP.EQ. 4).OR.
10409 & (IJP.EQ.10).OR.(IJP.EQ.11)) THEN
10410 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10411 & WRITE(LOUT,1002) NB,NCB
10412 1002 FORMAT(1X,'variable energy run: projectile-id: 7',
10413 & ' target A/Z: ',I3,' /',I3,/,/,8X,
10414 & 'E_cm (GeV) Q^2 (GeV^2)',
10415 & ' Sigma_tot (mb) Sigma_in (mb)',/,7X,
10416 & '--------------------------------',
10417 & '------------------------------')
10418 AECMLO = LOG10(MIN(UMO,ECMLI))
10419 AECMHI = LOG10(MIN(UMO,ECMHI))
10421 DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
10422 IF (AECMLO.EQ.AECMHI) IESTEP = 0
10424 ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10425 IF (Q2HI.GT.0.1D0) THEN
10426 IF (Q2LI.LT.0.01D0) THEN
10427 CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10428 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10430 & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10437 AQ2LO = LOG10(Q2LI)
10438 AQ2HI = LOG10(Q2HI)
10439 DAQ2 = (AQ2HI-AQ2LO)/MAX(DBLE(IQSTEP),ONE)
10440 DO 2 J=IBIN,IQSTEP+IBIN
10441 Q2 = 10.0D0**(AQ2LO+DBLE(J-IBIN)*DAQ2)
10442 CALL DT_XSGLAU(NA,NB,7,ZERO,Q2,ECM,I,J,NIDX)
10443 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10444 & WRITE(LOUT,1003) ECMNN(I),
10445 & Q2G(J),XSTOT(I,J,NTARG),XSPRO(I,J,NTARG)
10448 CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10449 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10451 & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10453 1003 FORMAT(9X,F6.1,9X,F6.2,8X,F8.3,11X,F8.3)
10457 * hadron/photon/nucleus-nucleus
10458 IF ((ABS(VAREHI).GT.ZERO).AND.
10459 & (ABS(VAREHI).GT.ABS(VARELO))) THEN
10460 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) THEN
10461 WRITE(LOUT,1004) NA,NB,NCB
10462 1004 FORMAT(1X,'variable energy run: projectile-id:',
10463 & I3,' target A/Z: ',I3,' /',I3,/)
10465 1005 FORMAT(' E_cm (GeV) E_Lab (GeV) sig_tot^pp (mb)'
10466 & ,' Sigma_tot (mb) Sigma_prod (mb)',/,
10467 & ' -------------------------------------',
10468 & '--------------------------------------')
10470 AECMLO = LOG10(VARCLO)
10471 AECMHI = LOG10(VARCHI)
10473 DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
10474 IF (AECMLO.EQ.AECMHI) IESTEP = 0
10476 ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10481 ELAB = (ECM**2-AMP2-AMT2)/(TWO*AMT)
10482 PLAB = SQRT((ELAB+AMP)*(ELAB-AMP))
10483 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,ECM,I,1,NIDX)
10484 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10486 & ECM,PLAB,SIGSH,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10487 1006 FORMAT(1X,F9.1,1X,E11.3,1X,F12.2,8X,F10.3,8X,F8.3)
10491 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10497 IF ((ICOUT.LT.15).AND.(IVEOUT.EQ.0).AND.(MCGENE.NE.4).AND.
10498 & (IOGLB.NE.100)) THEN
10499 WRITE(LOUT,1001) NA,NCA,NB,NCB,ECMNN(1),SIGSH*10.0D0,ROSH,
10500 & BSLOPE,NSITEB,NSTATB,XSPRO(1,1,NTARG)
10501 1001 FORMAT(38X,'projectile',
10502 & ' target',/,1X,'Mass number / charge',
10503 & 17X,I3,' /',I3,6X,I3,' /',I3,/,/,1X,
10504 & 'Nucleon-nucleon c.m. energy',9X,F10.2,' GeV',/,/,1X,
10505 & 'Parameters of elastic scattering amplitude:',/,5X,
10506 & 'sigma =',F7.2,' mb',6X,'rho = ',F9.4,6X,'slope = ',
10507 & F4.1,' GeV^-2',/,/,1X,'Number of b-steps',4X,I3,8X,
10508 & 'statistics at each b-step',4X,I5,/,/,1X,
10509 & 'Prod. cross section ',5X,F10.4,' mb',/)
10515 *$ CREATE DT_PROFBI.FOR
10518 *===profbi=============================================================*
10520 SUBROUTINE DT_PROFBI(NA,NB,PPN,NTARG)
10522 ************************************************************************
10523 * Integral over profile function (to be used for impact-parameter *
10524 * sampling during event generation). *
10525 * Fitted results are used. *
10526 * NA / NB mass numbers of proj./target nuclei *
10527 * PPN projectile momentum (for projectile nuclei: *
10528 * momentum per nucleon) in target rest system *
10529 * NTARG index of target material (i.e. kind of nucleus) *
10530 * This version dated 31.05.95 is revised by S. Roesler *
10531 ************************************************************************
10533 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10535 PARAMETER ( LINP = 10 ,
10540 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
10545 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10546 * Glauber formalism: parameters
10547 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10548 & BMAX(NCOMPX),BSTEP(NCOMPX),
10549 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10551 * Glauber formalism: cross sections
10552 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10553 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10554 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10555 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10556 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10557 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10558 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10559 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10560 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10561 & BSLOPE,NEBINI,NQBINI
10563 PARAMETER (NGLMAX=8000)
10564 DIMENSION NGLIT(NGLMAX),NGLIP(NGLMAX),GLAPPN(NGLMAX),
10565 & GLASIG(NGLMAX),GLAFIT(5,NGLMAX)
10567 DATA LSTART /.TRUE./
10570 * read fit-parameters from file
10571 OPEN(47,FILE='inpdata/glpara.dat',STATUS='UNKNOWN')
10574 READ(47,'(A80)') CNAME
10575 IF (CNAME.EQ.'STOP') GOTO 2
10577 READ(CNAME,*) NGLIP(I),NGLIT(I),GLAPPN(I),GLASIG(I),
10578 & GLAFIT(1,I),GLAFIT(2,I),GLAFIT(3,I),
10579 & GLAFIT(4,I),GLAFIT(5,I)
10580 IF (I+1.GT.NGLMAX) THEN
10582 1000 FORMAT(1X,'PROFBI: warning! array size exceeded - ',
10583 & 'program stopped')
10600 IF ((NNB.LT.NGLIT(J)).OR.(J.EQ.NGLPAR)) THEN
10601 IF (NNB.NE.NGLIT(J-1)) NNB = NGLIT(J-1)
10604 IF (J.EQ.NGLPAR) IPOINT = J+1-K
10605 IF ((NNA.GT.NGLIP(IPOINT)).OR.
10606 & (NNB.NE.NGLIT(IPOINT)).OR.(IPOINT.EQ.1)) THEN
10607 IF (IPOINT.EQ.1) IPOINT = 0
10608 NATMP = NGLIP(IPOINT+1)
10609 IF (PPN.LT.GLAPPN(IPOINT+1)) THEN
10615 C IF (J.EQ.NGLPAR) THEN
10619 DO 5 J1=J1BEG,J1END
10620 IF (NGLIP(J1).EQ.NATMP) THEN
10621 IF (PPN.LT.GLAPPN(J1)) THEN
10630 IF ((J.EQ.NGLPAR).AND.(PPN.GT.GLAPPN(NGLPAR)))
10639 IF (IDXGLA.EQ.0) THEN
10640 WRITE(LOUT,1001) NNA,NNB,PPN
10641 1001 FORMAT(1X,'PROFBI: configuration (NA,NB,PPN = ',
10642 & 2I4,F6.0,') not found ')
10646 * no interpolation yet available
10647 XSPRO(1,1,NTARG) = GLASIG(IDXGLA)
10649 BSITE(1,1,NTARG,1) = ZERO
10652 POLY = GLAFIT(1,IDXGLA)+GLAFIT(2,IDXGLA)*XX+
10653 & GLAFIT(3,IDXGLA)*XX**2+GLAFIT(4,IDXGLA)*XX**3+
10654 & GLAFIT(5,IDXGLA)*XX**4
10655 IF (ABS(POLY).GT.35.0D0) POLY = SIGN(35.0D0,POLY)
10656 BSITE(1,1,NTARG,I) = (1.0D0-EXP(-POLY))
10657 IF (BSITE(1,1,NTARG,I).LT.ZERO) BSITE(1,1,NTARG,I) = ZERO
10663 *$ CREATE DT_GLAUBE.FOR
10666 *===glaube=============================================================*
10668 SUBROUTINE DT_GLAUBE(NA,NB,IJPROJ,B,INTT,INTA,INTB,JS,JT,NIDX)
10670 ************************************************************************
10671 * Calculation of configuartion of interacting nucleons for one event. *
10672 * NB / NB mass numbers of proj./target nuclei (input) *
10673 * B impact parameter (output) *
10674 * INTT total number of wounded nucleons " *
10675 * INTA / INTB number of wounded nucleons in proj. / target " *
10676 * JS / JT(i) number of collisions proj. / target nucleon i is *
10677 * involved (output) *
10678 * NIDX index of projectile/target material (input) *
10679 * = -2 call within FLUKA transport calculation *
10680 * This is an update of the original routine SHMAKO by J.Ranft/HJM *
10681 * This version dated 22.03.96 is revised by S. Roesler *
10683 * Last change 27.12.2006 by S. Roesler. *
10684 ************************************************************************
10686 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10688 PARAMETER ( LINP = 10 ,
10691 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
10692 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
10694 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10695 PARAMETER ( MAXNCL = 260,
10697 & MAXSQU = 20*MAXVQU,
10698 & MAXINT = MAXVQU+MAXSQU)
10699 * Glauber formalism: parameters
10700 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10701 & BMAX(NCOMPX),BSTEP(NCOMPX),
10702 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10704 * Glauber formalism: cross sections
10705 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10706 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10707 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10708 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10709 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10710 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10711 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10712 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10713 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10714 & BSLOPE,NEBINI,NQBINI
10715 * Lorentz-parameters of the current interaction
10716 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10717 & UMO,PPCM,EPROJ,PPROJ
10718 * properties of photon/lepton projectiles
10719 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10720 * Glauber formalism: collision properties
10721 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
10722 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
10724 * Glauber formalism: flags and parameters for statistics
10727 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10729 DIMENSION JS(MAXNCL),JT(MAXNCL)
10733 * get actual energy from /DTLTRA/
10737 * new patch for pre-initialized variable projectile/target/energy runs,
10738 * bypassed for use within FLUKA (Nidx=-2)
10739 IF (IOGLB.EQ.100) THEN
10740 IF (NIDX.NE.-2) CALL DT_GLBSET(IJPROJ,NA,NB,EPROJ,1)
10742 * variable energy run, interpolate profile function
10747 IF (NEBINI.GT.1) THEN
10748 IF (ECMNOW.GE.ECMNN(NEBINI)) THEN
10752 ELSEIF (ECMNOW.GT.ECMNN(1)) THEN
10754 IF (ECMNOW.LT.ECMNN(I)) THEN
10757 RATE = (ECMNOW-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
10767 IF (NQBINI.GT.1) THEN
10768 IF (Q2.GE.Q2G(NQBINI)) THEN
10772 ELSEIF (Q2.GT.Q2G(1)) THEN
10774 IF (Q2.LT.Q2G(I)) THEN
10777 RATQ = LOG10( Q2/MAX(Q2G(J1),TINY14))/
10778 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
10779 C RATQ = (Q2-Q2G(J1))/(Q2G(J2)-Q2G(J1))
10788 BSITE(0,1,NTARG,I) = BSITE(I1,J1,NTARG,I)+
10789 & RATE*(BSITE(I2,J1,NTARG,I)-BSITE(I1,J1,NTARG,I))+
10790 & RATQ*(BSITE(I1,J2,NTARG,I)-BSITE(I1,J1,NTARG,I))+
10791 & RATE*RATQ*(BSITE(I2,J2,NTARG,I)-BSITE(I1,J2,NTARG,I)+
10792 & BSITE(I1,J1,NTARG,I)-BSITE(I2,J1,NTARG,I))
10796 CALL DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,INTT,INTA,INTB,IDIREC,NIDX)
10797 IF (NIDX.LE.-1) THEN
10799 RTARG = RBSH(NTARG)
10801 RPROJ = RASH(NTARG)
10808 *$ CREATE DT_DIAGR.FOR
10811 *===diagr==============================================================*
10813 SUBROUTINE DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,JNT,INTA,INTB,IDIREC,
10816 ************************************************************************
10817 * Based on the original version by Shmakov et al. *
10818 * This version dated 21.04.95 is revised by S. Roesler *
10819 ************************************************************************
10821 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10823 PARAMETER ( LINP = 10 ,
10826 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10827 PARAMETER (TWOPI = 6.283185307179586454D+00,
10829 & GEV2MB = 0.38938D0,
10830 & GEV2FM = 0.1972D0,
10831 & ALPHEM = ONE/137.0D0,
10839 PARAMETER ( MAXNCL = 260,
10841 & MAXSQU = 20*MAXVQU,
10842 & MAXINT = MAXVQU+MAXSQU)
10843 * particle properties (BAMJET index convention)
10845 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
10846 & IICH(210),IIBAR(210),K1(210),K2(210)
10847 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10848 * emulsion treatment
10849 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
10851 * Glauber formalism: parameters
10852 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10853 & BMAX(NCOMPX),BSTEP(NCOMPX),
10854 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10856 * Glauber formalism: cross sections
10857 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10858 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10859 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10860 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10861 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10862 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10863 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10864 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10865 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10866 & BSLOPE,NEBINI,NQBINI
10867 * VDM parameter for photon-nucleus interactions
10868 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
10869 * nucleon-nucleon event-generator
10872 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10874 C COMMON /CUTOFF/ PTCUT(4),CUTMU(4),FPS(4),FPH(4),PSOMIN,XSOMIN
10876 C obsolete cut-off information
10877 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
10878 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
10880 * coordinates of nucleons
10881 COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
10882 * interface between Glauber formalism and DPM
10883 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
10884 & INTER1(MAXINT),INTER2(MAXINT)
10885 * statistics: Glauber-formalism
10886 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
10887 * n-n cross section fluctuations
10888 PARAMETER (NBINS = 1000)
10889 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
10891 DIMENSION JS(MAXNCL),JT(MAXNCL),
10892 & JS0(MAXNCL),JT0(MAXNCL,MAXNCL),
10893 & JI1(MAXNCL,MAXNCL),JI2(MAXNCL,MAXNCL),JNT0(MAXNCL)
10894 DIMENSION NWA(0:210),NWB(0:210)
10897 DATA LFIRST /.TRUE./
10899 DATA NTARGO,ICNT /0,0/
10905 IF (NCOMPO.EQ.0) THEN
10915 IF (NTARG.EQ.-1) THEN
10916 IF (NCOMPO.EQ.0) THEN
10917 WRITE(LOUT,*) ' DIAGR: distribution of wounded nucleons'
10918 WRITE(LOUT,'(8X,A,3I7)') 'NCALL,NWAMAX,NWBMAX = ',
10919 & NCALL,NWAMAX,NWBMAX
10920 DO 18 I=1,MAX(NWAMAX,NWBMAX)
10921 WRITE(LOUT,'(8X,2I7,E12.4,I7,E12.4)')
10922 & I,NWA(I),DBLE(NWA(I))/DBLE(NCALL),
10923 & NWB(I),DBLE(NWB(I))/DBLE(NCALL)
10933 IF (SQ2.LE.ZERO) SQ2 = 0.0001D0
10935 X = SQ2/(S+SQ2-AMP2)
10936 XNU = (S+SQ2-AMP2)/(TWO*AMP)
10937 * photon projectiles: recalculate photon-nucleon amplitude
10938 IF (IJPROJ.EQ.7) THEN
10940 * VDM assumption: mass of V-meson
10941 AMV2 = DT_SAM2(SQ2,ECMNOW)
10943 IF (AMV.GT.2.0D0*PTCUT(1)) GOTO 15
10944 * check for pointlike interaction
10945 CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,1)
10947 C SIGSH = DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
10948 SIGSH = (ONE-RPNT)*DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
10951 BSLOPE = 2.0D0*(2.0D0+AMRHO0**2/(AMV2+SQ2)
10952 & +0.25D0*LOG(S/(AMV2+SQ2)))
10954 IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+SQ2)*GEV2FM
10955 ELSEIF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
10956 IF (MCGENE.EQ.2) THEN
10958 CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SDUM1,SDUM2,SDUM3,
10961 BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
10963 IF (ECMNOW.LE.3.0D0) THEN
10965 ELSEIF ((ECMNOW.GT.3.0D0).AND.(ECMNOW.LE.50.D0)) THEN
10966 ROSH = -0.63D0+0.175D0*LOG(ECMNOW)
10967 ELSEIF (ECMNOW.GT.50.0D0) THEN
10970 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
10971 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
10972 IF (MCGENE.EQ.2) THEN
10974 CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SIGSH,SDUM2,SDUM3,
10976 SIGSH = SIGSH/10.0D0
10978 C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
10980 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
10981 SIGSH = SIGSH/10.0D0
10984 BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
10986 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
10987 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
10988 C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
10990 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
10991 SIGSH = SIGSH/10.0D0
10993 GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
10995 RCA = GAM*SIGSH/TWOPI
10997 CA = DCMPLX(RCA,FCA)
10998 CI = DCMPLX(ONE,ZERO)
11002 IF (MCGENE.NE.3) CALL DT_MODB(B,NIDX)
11015 IF (IJPROJ.EQ.7) THEN
11025 * nucleon configuration
11026 C IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,5).EQ.0)) THEN
11027 IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,1).EQ.0)) THEN
11028 C CALL DT_CONUCL(PKOO,NA,RASH,2)
11029 C CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),1)
11030 IF (NIDX.LE.-1) THEN
11031 CALL DT_CONUCL(PKOO,NA,RASH(1),0)
11032 CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),0)
11034 CALL DT_CONUCL(PKOO,NA,RASH(NTARG),0)
11035 CALL DT_CONUCL(TKOO,NB,RBSH(1),0)
11041 * LEPTO: pick out one struck nucleon
11042 IF (MCGENE.EQ.3) THEN
11045 IDX = INT(DT_RNDM(X)*NB)+1
11052 * cross section fluctuations
11054 IF (IFLUCT.EQ.1) THEN
11055 IFLUK = INT((DT_RNDM(X)+0.001D0)*1000.0D0)
11056 AFLUC = FLUIXX(IFLUK)
11061 * photon-projectile: check for supression by coherence length
11062 IF (IJPROJ.EQ.7) THEN
11063 IF (ABS(TKOO(3,INB)-TKOO(3,KK1)).GT.DCOH) THEN
11068 QQ1 = B+TKOO(1,INB)-PKOO(1,INA)
11069 QQ2 = TKOO(2,INB)-PKOO(2,INA)
11070 XY = GAM*(QQ1*QQ1+QQ2*QQ2)
11071 IF (XY.LE.15.0D0) THEN
11072 C = CI-CA*AFLUC*EXP(-XY)
11076 IF (DT_RNDM(XY).GE.P) THEN
11078 IF (IJPROJ.EQ.7) THEN
11079 JNT0(KINT) = JNT0(KINT)+1
11080 IF (JNT0(KINT).GT.MAXNCL) THEN
11081 WRITE(LOUT,1001) MAXNCL
11083 & 'DIAGR: no. of requested interactions',
11084 & ' exceeds array dimensions ',I4)
11087 JS0(KINT) = JS0(KINT)+1
11088 JT0(KINT,INB) = JT0(KINT,INB)+1
11089 JI1(KINT,JNT0(KINT)) = INA
11090 JI2(KINT,JNT0(KINT)) = INB
11092 IF (JNT.GT.MAXINT) THEN
11093 WRITE(LOUT,1000) JNT, MAXINT
11095 & 'DIAGR: no. of requested interactions ('
11096 & ,I4,') exceeds array dimensions (',I4,')')
11099 JS(INA) = JS(INA)+1
11100 JT(INB) = JT(INB)+1
11110 IF (NTRY.LT.500) THEN
11113 C WRITE(6,*) ' new impact parameter required (old= ',B,')'
11119 IF (IJPROJ.EQ.7) THEN
11120 K = INT(ONE+DT_RNDM(X)*DBLE(KINT))
11122 IF (JNT0(K).EQ.0) THEN
11124 IF (K.GT.KINT) K = 1
11127 * supress Glauber-cascade by direct photon processes
11128 CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,2)
11129 IF (IPNT.GT.0) THEN
11133 JT(INB) = JT0(K,INB)
11134 IF (JT(INB).GT.0) GOTO 12
11144 JT(INB) = JT0(K,INB)
11147 INTER1(I) = JI1(K,I)
11148 INTER2(I) = JI2(K,I)
11157 IF (JS(I).NE.0) INTA=INTA+1
11160 IF (JT(I).NE.0) INTB=INTB+1
11169 IF (NCOMPO.EQ.0) THEN
11171 NWA(INTA) = NWA(INTA)+1
11172 NWB(INTB) = NWB(INTB)+1
11178 *$ CREATE DT_MODB.FOR
11181 *===modb===============================================================*
11183 SUBROUTINE DT_MODB(B,NIDX)
11185 ************************************************************************
11186 * Sampling of impact parameter of collision. *
11187 * B impact parameter (output) *
11188 * NIDX index of projectile/target material (input)*
11189 * Based on the original version by Shmakov et al. *
11190 * This version dated 21.04.95 is revised by S. Roesler *
11192 * Last change 27.12.2006 by S. Roesler. *
11193 ************************************************************************
11195 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11197 PARAMETER ( LINP = 10 ,
11200 PARAMETER (ZERO=0.0D0,TINY15=1.0D-15,ONE=1.0D0,TWO=2.0D0)
11202 LOGICAL LEFT,LFIRST
11204 * central particle production, impact parameter biasing
11205 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
11206 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11207 * Glauber formalism: parameters
11208 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11209 & BMAX(NCOMPX),BSTEP(NCOMPX),
11210 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11212 * Glauber formalism: cross sections
11213 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11214 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11215 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11216 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11217 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11218 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11219 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11220 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11221 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11222 & BSLOPE,NEBINI,NQBINI
11224 DATA LFIRST /.TRUE./
11227 IF (NIDX.LE.-1) THEN
11235 IF (ICENTR.EQ.2) THEN
11237 BB = DT_RNDM(B)*(0.3D0*RA)**2
11239 ELSEIF(RA.LT.RB)THEN
11240 BB = DT_RNDM(B)*1.4D0*(RB-RA)**2
11242 ELSEIF(RA.GT.RB)THEN
11243 BB = DT_RNDM(B)*1.4D0*(RA-RB)**2
11253 LEFT = ((BSITE(0,1,NTARG,I0)-Y)
11254 & *(BSITE(0,1,NTARG,I1)-Y)).LT.ZERO
11261 IF (I2-I0-2) 40,50,60
11264 IF (I1.GT.NSITEB) I1 = I0-1
11272 X0 = DBLE(I0-1)*BSTEP(NTARG)
11273 X1 = DBLE(I1-1)*BSTEP(NTARG)
11274 X2 = DBLE(I2-1)*BSTEP(NTARG)
11275 Y0 = BSITE(0,1,NTARG,I0)
11276 Y1 = BSITE(0,1,NTARG,I1)
11277 Y2 = BSITE(0,1,NTARG,I2)
11279 B = X0*(Y-Y1)*(Y-Y2)/((Y0-Y1)*(Y0-Y2)+TINY15)+
11280 & X1*(Y-Y0)*(Y-Y2)/((Y1-Y0)*(Y1-Y2)+TINY15)+
11281 & X2*(Y-Y0)*(Y-Y1)/((Y2-Y0)*(Y2-Y1)+TINY15)
11282 **sr 5.4.98: shift B by half the bin width to be in agreement with BPROD
11283 B = B+0.5D0*BSTEP(NTARG)
11284 IF (B.LT.ZERO) B = X1
11285 IF (B.GT.BMAX(NTARG)) B = BMAX(NTARG)
11286 IF (ICENTR.LT.0) THEN
11289 IF (ICENTR.LE.-100) THEN
11294 CALL DT_GETBXS(XSFRAC,BIMIN,BIMAX,NTARG)
11295 WRITE(LOUT,1000) RASH(1),RBSH(NTARG),BMAX(NTARG),
11296 & BIMIN,BIMAX,XSFRAC*100.0D0,
11297 & XSFRAC*XSPRO(1,1,NTARG)
11298 10000 FORMAT(/,1X,'DT_MODB: Biasing in impact parameter',
11299 & /,15X,'---------------------------'/,/,4X,
11300 & 'average radii of proj / targ :',F10.3,' fm /',
11301 & F7.3,' fm',/,4X,'corresp. b_max (4*(r_p+r_t)) :',
11302 & F10.3,' fm',/,/,21X,'b_lo / b_hi :',
11303 & F10.3,' fm /',F7.3,' fm',/,5X,'percentage of',
11304 & ' cross section :',F10.3,' %',/,5X,
11305 & 'corresponding cross section :',F10.3,' mb',/)
11307 IF (ABS(BIMAX-BIMIN).LT.1.0D-3) THEN
11310 IF ((B.LT.BIMIN).OR.(B.GT.BIMAX)) GOTO 9
11318 *$ CREATE DT_SHFAST.FOR
11321 *===shfast=============================================================*
11323 SUBROUTINE DT_SHFAST(MODE,PPN,IBACK)
11325 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11327 PARAMETER ( LINP = 10 ,
11330 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY1=1.0D-1,
11331 & ONE=1.0D0,TWO=2.0D0)
11333 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11334 * Glauber formalism: parameters
11335 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11336 & BMAX(NCOMPX),BSTEP(NCOMPX),
11337 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11339 * properties of interacting particles
11340 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11341 * Glauber formalism: cross sections
11342 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11343 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11344 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11345 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11346 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11347 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11348 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11349 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11350 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11351 & BSLOPE,NEBINI,NQBINI
11355 IF (MODE.EQ.2) THEN
11356 OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11357 WRITE(47,1000) IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG,PPN
11358 1000 FORMAT(1X,8I5,E15.5)
11359 WRITE(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11360 1001 FORMAT(1X,4E15.5)
11361 WRITE(47,1002) SIGSH,ROSH,GSH
11362 1002 FORMAT(1X,3E15.5)
11364 WRITE(47,'(1X,E15.5)') BSITE(1,1,1,I)
11366 WRITE(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11367 1003 FORMAT(1X,2I10,3E15.5)
11370 OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11371 READ(47,1000) JT,JTZ,JP,JPZ,JJPROJ,JBPROJ,JJTARG,JBTARG,PP
11372 IF ((JT.EQ.IT).AND.(JTZ.EQ.ITZ).AND.(JP.EQ.IP).AND.
11373 & (JPZ.EQ.IPZ).AND.(JJPROJ.EQ.IJPROJ).AND.(JBPROJ.EQ.IBPROJ)
11374 & .AND.(JJTARG.EQ.IJTARG).AND.(JBTARG.EQ.IBTARG).AND.
11375 & (ABS(PP-PPN).LT.(PPN*0.01D0))) THEN
11376 READ(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11377 READ(47,1002) SIGSH,ROSH,GSH
11379 READ(47,'(1X,E15.5)') BSITE(1,1,1,I)
11381 READ(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11391 *$ CREATE DT_POILIK.FOR
11394 *===poilik=============================================================*
11396 SUBROUTINE DT_POILIK(NB,NTARG,ECM,VIRT,IPNT,RPNT,MODE)
11398 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
11401 PARAMETER ( LINP = 10 ,
11404 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.0D0)
11408 C CHARACTER*8 MDLNA
11409 C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
11410 C PARAMETER (IEETAB=10)
11411 C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
11413 C model switches and parameters
11415 INTEGER ISWMDL,IPAMDL
11416 DOUBLE PRECISION PARMDL
11417 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11418 C energy-interpolation table
11420 PARAMETER ( IEETA2 = 20 )
11422 DOUBLE PRECISION SIGTAB,SIGECM
11423 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
11425 * VDM parameter for photon-nucleus interactions
11426 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
11428 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11429 * Glauber formalism: cross sections
11430 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11431 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11432 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11433 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11434 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11435 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11436 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11437 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11438 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11439 & BSLOPE,NEBINI,NQBINI
11442 DATA ECMOLD,Q2OLD /-1.0D0,-1.0D0/
11444 IF ((ECM.EQ.ECMOLD).AND.(VIRT.EQ.Q2OLD)) GOTO 3
11446 * load cross sections from interpolation table
11448 IF(ECM.LE.SIGECM(IP,1)) THEN
11451 ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
11453 IF(ECM.LE.SIGECM(IP,I)) GOTO 200
11459 WRITE(LOUT,'(/1X,A,2E12.3)')
11460 & 'POILIK:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
11465 IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
11466 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
11469 SIGANO = DT_SANO(ECM)
11471 * cross section dependence on photon virtuality
11474 FSUP1 = FSUP1+PARMDL(26+I)*(ONE+VIRT/(4.D0*PARMDL(30+I)))
11475 & /(ONE+VIRT/PARMDL(30+I))**2
11477 FSUP1 = FSUP1+PARMDL(30)/(ONE+VIRT/PARMDL(34))
11487 C SIGTOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
11488 CALL DT_SIGGP(ZERO,VIRT,ECM,ZERO,SIGTOT,DUM1,DUM2)
11489 IF (ISHAD(1).EQ.1) THEN
11490 SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
11494 SIGANO = FSUP1*FSUP2*SIGANO
11495 SIGTOT = SIGTOT-SIGDIR-SIGANO
11496 SIGDIR = SIGDIR/(FSUP1*FSUP2)
11497 SIGANO = SIGANO/(FSUP1*FSUP2)
11498 SIGTOT = SIGTOT+SIGDIR+SIGANO
11500 RR = DT_RNDM(SIGTOT)
11501 IF (RR.LT.SIGDIR/SIGTOT) THEN
11503 ELSEIF ((RR.GE.SIGDIR/SIGTOT).AND.
11504 & (RR.LT.(SIGDIR+SIGANO)/SIGTOT)) THEN
11509 RPNT = (SIGDIR+SIGANO)/SIGTOT
11510 C WRITE(LOUT,'(I3,2F15.5)') ISHAD(1),FAC1,FAC2
11511 C WRITE(LOUT,'(I3,2F15.5)') MODE,SIGDIR,SIGANO
11512 C WRITE(LOUT,'(I3,4F15.5)') MODE,SIGDIR+SIGANO,SIGTOT,RPNT,ECM
11513 C WRITE(LOUT,'(1X,6E12.4)') ECM,VIRT,SIGTOT,SIGDIR,SIGANO,RPNT
11514 IF (MODE.EQ.1) RETURN
11520 IF (ECM.GE.ECMNN(NEBINI)) THEN
11524 ELSEIF (ECM.GT.ECMNN(1)) THEN
11526 IF (ECM.LT.ECMNN(I)) THEN
11529 RATE = (ECM-ECMNN(K1))/(ECMNN(K2)-ECMNN(K1))
11538 IF (NQBINI.GT.1) THEN
11539 IF (VIRT.GE.Q2G(NQBINI)) THEN
11543 ELSEIF (VIRT.GT.Q2G(1)) THEN
11545 IF (VIRT.LT.Q2G(I)) THEN
11548 RATQ = LOG10( VIRT/MAX(Q2G(J1),TINY14))/
11549 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
11556 SGA = XSPRO(K1,J1,NTARG)+
11557 & RATE*(XSPRO(K2,J1,NTARG)-XSPRO(K1,J1,NTARG))+
11558 & RATQ*(XSPRO(K1,J2,NTARG)-XSPRO(K1,J1,NTARG))+
11559 & RATE*RATQ*(XSPRO(K2,J2,NTARG)-XSPRO(K1,J2,NTARG)+
11560 & XSPRO(K1,J1,NTARG)-XSPRO(K2,J1,NTARG))
11561 SDI = DBLE(NB)*SIGDIR
11562 SAN = DBLE(NB)*SIGANO
11565 IF (RR.LT.SDI/SGA) THEN
11567 ELSEIF ((RR.GE.SDI/SGA).AND.
11568 & (RR.LT.SPL/SGA)) THEN
11574 C WRITE(LOUT,'(I3,4F15.5)') MODE,SPL,SGA,RPNT,ECM
11580 *$ CREATE DT_GLBINI.FOR
11583 *===glbini=============================================================*
11585 SUBROUTINE DT_GLBINI(WHAT)
11587 ************************************************************************
11588 * Pre-initialization of profile function *
11589 * This version dated 28.11.00 is written by S. Roesler. *
11591 * Last change 27.12.2006 by S. Roesler. *
11592 ************************************************************************
11594 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11597 PARAMETER ( LINP = 10 ,
11600 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.D-14)
11604 * particle properties (BAMJET index convention)
11606 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11607 & IICH(210),IIBAR(210),K1(210),K2(210)
11608 * properties of interacting particles
11609 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11610 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11611 * emulsion treatment
11612 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11614 * Glauber formalism: flags and parameters for statistics
11617 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11618 * number of data sets other than protons and nuclei
11619 * at the moment = 2 (pions and kaons)
11620 PARAMETER (MAXOFF=2)
11621 DIMENSION IJPINI(5),IOFFST(25)
11622 DATA IJPINI / 13, 15, 0, 0, 0/
11623 * Glauber data-set to be used for hadron projectiles
11624 * (0=proton, 1=pion, 2=kaon)
11625 DATA (IOFFST(K),K=1,25) /
11626 & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
11628 * Acceptance interval for target nucleus mass
11629 PARAMETER (KBACC = 6)
11630 * flags for input different options
11631 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
11632 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
11633 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
11635 PARAMETER (MAXMSS = 100)
11636 DIMENSION IASAV(MAXMSS),IBSAV(MAXMSS)
11639 DATA JPEACH,JPSTEP / 18, 5 /
11641 * temporary patch until fix has been implemented in phojet:
11642 * maximum energy for pion projectile
11643 DATA ECMXPI / 100000.0D0 /
11645 *--------------------------------------------------------------------------
11646 * general initializations
11648 * steps in projectile mass number for initialization
11649 IF (WHAT(4).GT.ZERO) JPEACH = INT(WHAT(4))
11650 IF (WHAT(5).GT.ZERO) JPSTEP = INT(WHAT(5))
11652 * energy range and binning
11655 IF (ELO.GT.EHI) ELO = EHI
11656 NEBIN = MAX(INT(WHAT(3)),1)
11657 IF (ELO.EQ.EHI) NEBIN = 0
11658 LCMS = (WHAT(1).LT.ZERO).OR.(WHAT(2).LT.ZERO)
11662 ECMINI = SQRT(AAM(IJPROJ)**2+AAM(IJTARG)**2
11663 & +2.0D0*AAM(IJTARG)*EHI)
11666 * default arguments for Glauber-routine
11670 * initialize nuclear parameters, etc.
11674 * open Glauber-data output file
11675 IDX = INDEX(CGLB,' ')
11677 IF (IDX.GT.1) K = IDX-1
11678 OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
11680 *--------------------------------------------------------------------------
11681 * Glauber-initialization for proton and nuclei projectiles
11683 * initialize phojet for proton-proton interactions
11686 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
11689 * record projectile masses
11691 NPROJ = MIN(IP,JPEACH)
11692 DO 10 KPROJ=1,NPROJ
11694 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11695 IASAV(NASAV) = KPROJ
11697 IF (IP.GT.JPEACH) THEN
11698 NPROJ = DBLE(IP-JPEACH)/DBLE(JPSTEP)
11699 IF (NPROJ.EQ.0) THEN
11701 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11704 DO 11 IPROJ=1,NPROJ
11705 KPROJ = JPEACH+IPROJ*JPSTEP
11707 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11708 IASAV(NASAV) = KPROJ
11710 IF (KPROJ.LT.IP) THEN
11712 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11718 * record target masses
11721 IF (NCOMPO.GT.0) NTARG = NCOMPO
11722 DO 12 ITARG=1,NTARG
11724 IF (NBSAV.GT.MAXMSS) STOP ' GLBINI: NBSAV > MAXMSS ! '
11725 IF (NCOMPO.GT.0) THEN
11726 IBSAV(NBSAV) = IEMUMA(ITARG)
11733 WRITE(LDAT,1000) NEBIN,': ',SIGN(ELO,WHAT(1)),SIGN(EHI,WHAT(2))
11734 1000 FORMAT(I4,A,1P,2E13.5)
11735 NLINES = DBLE(NASAV)/18.0D0
11736 IF (NLINES.GT.0) THEN
11739 WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=1,18)
11741 WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=18*I-17,18*I)
11746 IF (I0.LE.NASAV) THEN
11748 WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=I0,NASAV)
11750 WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=I0,NASAV)
11753 NLINES = DBLE(NBSAV)/18.0D0
11754 IF (NLINES.GT.0) THEN
11757 WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=1,18)
11759 WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=18*I-17,18*I)
11764 IF (I0.LE.NBSAV) THEN
11766 WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=I0,NBSAV)
11768 WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=I0,NBSAV)
11772 * calculate Glauber-data for each energy and mass combination
11774 * loop over energy bins
11777 DEBIN = (EHI-ELO)/MAX(DBLE(NEBIN),ONE)
11779 E = ELO+DBLE(IE-1)*DEBIN
11782 E = MAX(2.0D0*AAM(IJPROJ)+0.1D0,E)
11787 E = MAX(AAM(IJPROJ)+0.1D0,E)
11788 CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
11791 * loop over projectile and target masses
11794 CALL DT_XSGLAU(IASAV(IPROJ),IBSAV(ITARG),IJPROJ,
11795 & XI,Q2I,ECM,1,1,-1)
11801 *--------------------------------------------------------------------------
11802 * Glauber-initialization for pion, kaon, ... projectiles
11806 * initialize phojet for this interaction
11809 IJPROJ = IJPINI(IJ)
11813 * temporary patch until fix has been implemented in phojet:
11814 IF (ECMINI.GT.ECMXPI) THEN
11815 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMXPI,1)
11817 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
11821 * calculate Glauber-data for each energy and mass combination
11823 * loop over energy bins
11825 E = ELO+DBLE(IE-1)*DEBIN
11828 E = MAX(2.0D0*AAM(IJPROJ)+TINY14,E)
11833 E = MAX(AAM(IJPROJ)+TINY14,E)
11834 CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
11837 * loop over projectile and target masses
11839 CALL DT_XSGLAU(1,IBSAV(ITARG),IJPROJ,XI,Q2I,ECM,1,1,-1)
11846 *--------------------------------------------------------------------------
11847 * close output unit(s), etc.
11854 *$ CREATE DT_GLBSET.FOR
11857 *===glbset=============================================================*
11859 SUBROUTINE DT_GLBSET(IDPROJ,NA,NB,ELAB,MODE)
11860 ************************************************************************
11861 * Interpolation of pre-initialized profile functions *
11862 * This version dated 28.11.00 is written by S. Roesler. *
11863 ************************************************************************
11865 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11868 PARAMETER ( LINP = 10 ,
11871 PARAMETER (ZERO=0.0D0,ONE=1.0D0)
11873 LOGICAL LCMS,LREAD,LFRST1,LFRST2
11875 * particle properties (BAMJET index convention)
11877 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11878 & IICH(210),IIBAR(210),K1(210),K2(210)
11879 * Glauber formalism: flags and parameters for statistics
11882 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11883 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11884 * Glauber formalism: parameters
11885 COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11886 & BMAX(NCOMPX),BSTEP(NCOMPX),
11887 & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11889 * Glauber formalism: cross sections
11890 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11891 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11892 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11893 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11894 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11895 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11896 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11897 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11898 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11899 & BSLOPE,NEBINI,NQBINI
11900 * number of data sets other than protons and nuclei
11901 * at the moment = 2 (pions and kaons)
11902 PARAMETER (MAXOFF=2)
11903 DIMENSION IJPINI(5),IOFFST(25)
11904 DATA IJPINI / 13, 15, 0, 0, 0/
11905 * Glauber data-set to be used for hadron projectiles
11906 * (0=proton, 1=pion, 2=kaon)
11907 DATA (IOFFST(K),K=1,25) /
11908 & 0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
11910 * Acceptance interval for target nucleus mass
11911 PARAMETER (KBACC = 6)
11912 * emulsion treatment
11913 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11916 PARAMETER (MAXSET=5000,
11918 DIMENSION XSIG(MAXSET,6),XERR(MAXSET,6),BPROFL(MAXSET,KSITEB)
11919 DIMENSION IABIN(MAXBIN),IBBIN(MAXBIN),XS(6),XE(6),
11920 & BPRO0(KSITEB),BPRO1(KSITEB),BPRO(KSITEB),
11923 DATA LREAD,LFRST1,LFRST2 /.FALSE.,.TRUE.,.TRUE./
11925 * read data from file
11927 IF (MODE.EQ.0) THEN
11950 IDX = INDEX(CGLB,' ')
11952 IF (IDX.GT.1) K = IDX-1
11953 OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
11954 WRITE(LOUT,1000) CGLB(1:K)//'.glb'
11955 1000 FORMAT(/,' GLBSET: impact parameter distributions read from ',
11958 * read binning information
11959 READ(LDAT,'(I4,2X,2E13.5)') NEBIN,ELO,EHI
11960 * return lower energy threshold to Fluka-interface
11963 WRITE(LOUT,'(1X,A)') ' equidistant logarithmic energy binning:'
11965 WRITE(LOUT,1001) '(cms)',ABS(ELO),ABS(EHI),NEBIN
11967 WRITE(LOUT,1001) '(lab)',ABS(ELO),ABS(EHI),NEBIN
11969 1001 FORMAT(2X,A5,' E_lo = ',1P,E9.3,' E_hi = ',1P,E9.3,4X,
11970 & 'No. of bins:',I5,/)
11971 ELO = LOG10(ABS(ELO))
11972 EHI = LOG10(ABS(EHI))
11973 DEBIN = (EHI-ELO)/ABS(DBLE(NEBIN))
11974 WRITE(LOUT,'(/,1X,A)') ' projectiles: (mass number)'
11975 READ(LDAT,'(I4,2X,18I4)') NABIN,(IABIN(J),J=1,18)
11976 IF (NABIN.LT.18) THEN
11977 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,NABIN)
11979 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,18)
11981 IF (NABIN.GT.MAXBIN) STOP ' GLBSET: NABIN > MAXBIN !'
11982 IF (NABIN.GT.18) THEN
11983 NLINES = DBLE(NABIN-18)/18.0D0
11984 IF (NLINES.GT.0) THEN
11987 READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
11988 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
11991 I0 = 18*(NLINES+1)+1
11992 IF (I0.LE.NABIN) THEN
11993 READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
11994 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
11997 WRITE(LOUT,'(/,1X,A)') ' targets: (mass number)'
11998 READ(LDAT,'(I4,2X,18I4)') NBBIN,(IBBIN(J),J=1,18)
11999 IF (NBBIN.LT.18) THEN
12000 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,NBBIN)
12002 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,18)
12004 IF (NBBIN.GT.MAXBIN) STOP ' GLBSET: NBBIN > MAXBIN !'
12005 IF (NBBIN.GT.18) THEN
12006 NLINES = DBLE(NBBIN-18)/18.0D0
12007 IF (NLINES.GT.0) THEN
12010 READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12011 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12014 I0 = 18*(NLINES+1)+1
12015 IF (I0.LE.NBBIN) THEN
12016 READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12017 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12020 * number of data sets to follow in the Glauber data file
12021 * this variable is used for checks of consistency of projectile
12022 * and target mass configurations given in header of Glauber data
12023 * file and the data-sets which follow in this file
12024 NSET0 = (NEBIN+1)*(NABIN+MAXOFF)*NBBIN
12026 * read profile function data
12032 IF (NSET.GT.MAXSET) STOP ' GLBSET: NSET > MAXSET ! '
12033 READ(LDAT,1002,END=100) IP,IA,IB,ISTATB,ISITEB,ECM
12034 1002 FORMAT(5I10,E15.5)
12035 IF ((IP.NE.1).AND.(IP.NE.IPOLD)) THEN
12037 IF (NAIDX.GT.10) STOP ' GLBSET: NAIDX > 10 !'
12041 READ(LDAT,'(6E12.5)') (XSIG(NSET,I),I=1,6)
12042 READ(LDAT,'(6E12.5)') (XERR(NSET,I),I=1,6)
12043 NLINES = INT(DBLE(ISITEB)/7.0D0)
12044 IF (NLINES.GT.0) THEN
12046 READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=7*I-6,7*I)
12051 & READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=I0,ISITEB)
12055 IF (NSET.NE.NSET0) STOP ' GLBSET: NSET.NE.NSET0 !'
12056 WRITE(LOUT,'(/,1X,A)')
12057 & ' projectiles other than protons and nuclei: (particle index)'
12058 IF (NAIDX.GT.0) THEN
12059 WRITE(LOUT,'(6X,18I4)') (IAIDX(J),J=1,NAIDX)
12061 WRITE(LOUT,'(6X,A)') 'none'
12068 IF (NCOMPO.EQ.0) THEN
12071 IEMUMA(NCOMPO) = IBBIN(J)
12072 IEMUCH(NCOMPO) = IEMUMA(NCOMPO)/2
12073 EMUFRA(NCOMPO) = 1.0D0
12078 * calculate profile function for certain set of parameters
12082 c write(*,*) 'glbset called for ',IDPROJ,NA,NB,ELAB,MODE
12084 * check for type of projectile and set index-offset to entry in
12085 * Glauber data array correspondingly
12086 IF (IDPROJ.GT.25) STOP ' GLBSET: IDPROJ > 25 !'
12087 IF (IOFFST(IDPROJ).EQ.-1) THEN
12088 STOP ' GLBSET: no data for this projectile !'
12089 ELSEIF (IOFFST(IDPROJ).GT.0) THEN
12090 IDXOFF = (NEBIN+1)*(NABIN+IOFFST(IDPROJ)-1)*NBBIN
12095 * get energy bin and interpolation factor
12097 E = SQRT(AAM(IDPROJ)**2+AAM(1)**2+2.0D0*AAM(1)*ELAB)
12104 WRITE(LOUT,*) ' GLBSET: Too low energy! (E_lo,E) ',ELO,E
12111 WRITE(LOUT,*) ' GLBSET: Too high energy! (E_hi,E) ',EHI,E
12116 IE0 = (E-ELO)/DEBIN+1
12118 FACE = (E-(ELO+DBLE(IE0-1)*DEBIN))/DEBIN
12120 * get target nucleus index
12124 NBDIFF = ABS(NB-IBBIN(I))
12125 IF (NB.EQ.IBBIN(I)) THEN
12128 ELSEIF (NBDIFF.LE.NBACC) THEN
12133 IF (KB.NE.0) GOTO 21
12134 WRITE(LOUT,*) ' GLBSET: data not found for target ',NB
12138 * get projectile nucleus bin and interpolation factor
12142 IF (IDXOFF.GT.0) THEN
12147 IF (NA.GT.IABIN(NABIN)) STOP ' GLBSET: NA > IABIN(NABIN) !'
12149 IF (NA.EQ.IABIN(I)) THEN
12153 ELSEIF (NA.LT.IABIN(I)) THEN
12159 WRITE(LOUT,*) ' GLBSET: data not found for projectile ',NA
12163 & FACNA = DBLE(NA-IABIN(KA0))/DBLE(IABIN(KA1)-IABIN(KA0))
12167 * interpolate profile functions for interactions ka0-kb and ka1-kb
12168 * for energy E separately
12169 IDX0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12170 IDX1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12171 IDY0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12172 IDY1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12174 BPRO0(I) = BPROFL(IDX0,I)
12175 & +FACE*(BPROFL(IDX1,I)-BPROFL(IDX0,I))
12176 BPRO1(I) = BPROFL(IDY0,I)
12177 & +FACE*(BPROFL(IDY1,I)-BPROFL(IDY0,I))
12179 RADB = DT_RNCLUS(NB)
12180 BSTP0 = 2.0D0*(DT_RNCLUS(IABIN(KA0))+RADB)/DBLE(ISITEB-1)
12181 BSTP1 = 2.0D0*(DT_RNCLUS(IABIN(KA1))+RADB)/DBLE(ISITEB-1)
12183 * interpolate cross sections for energy E and projectile mass
12185 XS0 = XSIG(IDX0,I)+FACE*(XSIG(IDX1,I)-XSIG(IDX0,I))
12186 XS1 = XSIG(IDY0,I)+FACE*(XSIG(IDY1,I)-XSIG(IDY0,I))
12187 XS(I) = XS0+FACNA*(XS1-XS0)
12188 XE0 = XERR(IDX0,I)+FACE*(XERR(IDX1,I)-XERR(IDX0,I))
12189 XE1 = XERR(IDY0,I)+FACE*(XERR(IDY1,I)-XERR(IDY0,I))
12190 XE(I) = XE0+FACNA*(XE1-XE0)
12193 * interpolate between ka0 and ka1
12194 RADA = DT_RNCLUS(NA)
12195 BMX = 2.0D0*(RADA+RADB)
12196 BSTP = BMX/DBLE(ISITEB-1)
12201 * calculate values of profile functions at B
12203 IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12204 IDX1 = MIN(IDX0+1,ISITEB)
12205 FACB = (B-DBLE(IDX0-1)*BSTP0)/BSTP0
12206 BPR0 = BPRO0(IDX0)+FACB*(BPRO0(IDX1)-BPRO0(IDX0))
12208 IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12209 IDX1 = MIN(IDX0+1,ISITEB)
12210 FACB = (B-DBLE(IDX0-1)*BSTP1)/BSTP1
12211 BPR1 = BPRO1(IDX0)+FACB*(BPRO1(IDX1)-BPRO1(IDX0))
12213 BPRO(I+1) = BPR0+FACNA*(BPR1-BPR0)
12216 * fill common dtglam
12223 BSITE(0,1,1,I) = BPRO(I)
12226 * fill common dtglxs
12227 XSTOT(1,1,1) = XS(1)
12228 XSELA(1,1,1) = XS(2)
12229 XSQEP(1,1,1) = XS(3)
12230 XSQET(1,1,1) = XS(4)
12231 XSQE2(1,1,1) = XS(5)
12232 XSPRO(1,1,1) = XS(6)
12233 XETOT(1,1,1) = XE(1)
12234 XEELA(1,1,1) = XE(2)
12235 XEQEP(1,1,1) = XE(3)
12236 XEQET(1,1,1) = XE(4)
12237 XEQE2(1,1,1) = XE(5)
12238 XEPRO(1,1,1) = XE(6)
12245 *$ CREATE DT_XKSAMP.FOR
12248 *===xksamp=============================================================*
12250 SUBROUTINE DT_XKSAMP(NN,ECM)
12252 ************************************************************************
12253 * Sampling of parton x-values and chain system for one interaction. *
12254 * processed by S. Roesler, 9.8.95 *
12255 ************************************************************************
12257 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12259 PARAMETER ( LINP = 10 ,
12262 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
12266 * lower cuts for (valence-sea/sea-valence) chain masses
12267 * antiquark-quark (u/d-sea quark) (s-sea quark)
12268 & AMIU = 0.5D0, AMIS = 0.8D0,
12269 * quark-diquark (u/d-sea quark) (s-sea quark)
12270 & AMAU = 2.6D0, AMAS = 2.6D0,
12271 * maximum lower valence-x threshold
12273 * fraction of sea-diquarks sampled out of sea-partons
12275 C & FRCDIQ = 0.9D0,
12280 * maximum number of trials to generate x's for the required number
12281 * of sea quark pairs for a given hadron
12286 LOGICAL ZUOVP,ZUOSP,ZUOVT,ZUOST,INTLO
12288 PARAMETER ( MAXNCL = 260,
12290 & MAXSQU = 20*MAXVQU,
12291 & MAXINT = MAXVQU+MAXSQU)
12293 PARAMETER (NMXHKK=200000)
12294 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
12295 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
12296 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
12297 * particle properties (BAMJET index convention)
12299 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12300 & IICH(210),IIBAR(210),K1(210),K2(210)
12301 * interface between Glauber formalism and DPM
12302 COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
12303 & INTER1(MAXINT),INTER2(MAXINT)
12304 * properties of interacting particles
12305 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
12306 * threshold values for x-sampling (DTUNUC 1.x)
12307 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
12309 * x-values of partons (DTUNUC 1.x)
12310 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
12311 & XTVQ(MAXVQU),XTVD(MAXVQU),
12312 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
12313 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
12314 * flavors of partons (DTUNUC 1.x)
12315 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
12316 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
12317 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
12318 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
12319 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
12320 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
12321 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
12322 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12323 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
12324 & IXPV,IXPS,IXTV,IXTS,
12325 & INTVV1(MAXVQU),INTVV2(MAXVQU),
12326 & INTSV1(MAXVQU),INTSV2(MAXVQU),
12327 & INTVS1(MAXVQU),INTVS2(MAXVQU),
12328 & INTSS1(MAXSQU),INTSS2(MAXSQU),
12329 & INTDV1(MAXVQU),INTDV2(MAXVQU),
12330 & INTVD1(MAXVQU),INTVD2(MAXVQU),
12331 & INTDS1(MAXSQU),INTDS2(MAXSQU),
12332 & INTSD1(MAXSQU),INTSD2(MAXSQU)
12333 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12334 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
12335 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
12336 * auxiliary common for chain system storage (DTUNUC 1.x)
12337 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
12338 * flags for input different options
12339 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
12340 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
12341 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
12342 * various options for treatment of partons (DTUNUC 1.x)
12343 * (chain recombination, Cronin,..)
12344 LOGICAL LCO2CR,LINTPT
12345 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
12348 DIMENSION ZUOVP(MAXVQU),ZUOSP(MAXSQU),ZUOVT(MAXVQU),ZUOST(MAXSQU),
12351 * (1) initializations
12352 *-----------------------------------------------------------------------
12355 IF (ECM.LT.4.5D0) THEN
12358 ELSEIF ((ECM.GE.4.5D0).AND.(ECM.LT.7.5)) THEN
12359 C FRCDIQ = 0.6D0+(ECM-4.5D0)/3.0D0*0.3D0
12360 FRCDIQ = 0.4D0+(ECM-4.5D0)/3.0D0*0.3D0
12369 IF (I.LE.MAXVQU) THEN
12375 * lower thresholds for x-selection
12376 * sea-quarks (default: CSEA=0.2)
12377 IF (ECM.LT.10.0D0) THEN
12379 XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM
12380 C XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM**2.0D0
12382 C XSTHR = ONE/ECM**2
12386 XSTHR = CSEA/ECM**2
12387 C XSTHR = ONE/ECM**2
12389 IF ((IP.GE.150).AND.(IT.GE.150))
12390 & XSTHR = 2.5D0/(ECM*SQRT(ECM))
12393 * (default: SSMIMA=0.14) used for sea-diquarks (?)
12394 XSSTHR = SSMIMA/ECM
12396 * valence-quarks (default: CVQ=1.0)
12398 * valence-diquarks (default: CDQ=2.0)
12401 * maximum-x for sea-quarks
12402 XVCUT = XVTHR+XDTHR
12403 IF (XVCUT.GT.XVMAX) THEN
12405 XVTHR = XVCUT/3.0D0
12406 XDTHR = XVCUT-XVTHR
12409 **sr 18.4. test: DPMJET
12410 C XXSEAM=1.0 - XVTHR*(1.D0+0.3D0*DT_RNDM(V1))
12411 C & - XDTHR*(1.D0+0.3D0*DT_RNDM(V2))
12412 C & -0.01*(1.D0+1.5D0*DT_RNDM(V3))
12414 * maximum number of sea-pairs allowed kinematically
12415 C NSMAX = INT(OHALF*XXSEAM/XSTHR)
12416 RNSMAX = OHALF*XXSEAM/XSTHR
12417 IF (RNSMAX.GT.10000.0D0) THEN
12420 NSMAX = INT(OHALF*XXSEAM/XSTHR)
12422 * check kinematical limit for valence-x thresholds
12423 * (should be obsolete now)
12424 IF (XVCUT.GT.XVMAX) THEN
12425 WRITE(LOUT,1000) XVCUT,ECM
12426 1000 FORMAT(' XKSAMP: kin. limit for valence-x',
12427 & ' thresholds not allowed (',2E9.3,')')
12428 C XVTHR = XVMAX-XDTHR
12429 C IF (XVTHR.LT.ZERO) STOP
12433 * set eta for valence-x sampling (BETREJ)
12434 * (UNON per default, UNOM used for projectile mesons only)
12435 IF ((IJPROJ.NE.0).AND.(IBPROJ.EQ.0)) THEN
12441 * (2) select parton x-values of interacting projectile nucleons
12442 *-----------------------------------------------------------------------
12448 * get interacting projectile nucleon as sampled by Glauber
12449 IF (JSSH(IPP).NE.0) THEN
12455 * JIPP is the actual number of sea-pairs sampled for this nucleon
12456 JIPP = MIN(JSSH(IPP)-1,NSMAX)
12459 IF (JIPP.GT.0) THEN
12460 XSMAX = XXSEAM-2.0D0*DBLE(JIPP)*XSTHR
12462 IF (XSTHR.GE.XSMAX) THEN
12467 *>>>get x-values of sea-quark pairs
12471 * accumulator for sea x-values
12474 IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
12475 IF (NSCOUN.GT.NSEA) THEN
12476 * decrease the number of interactions after NSEA trials
12482 IF (IPSQ(IXPS+1).LE.2) THEN
12483 **sr 8.4.98 (1/sqrt(x))
12484 C XPSQI = DT_SAMPEX(XSTHR,XSMAX)
12485 C XPSQI = DT_SAMSQX(XSTHR,XSMAX)
12486 XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12489 IF (XSMAX.GT.XSTHR+BSQMA) THEN
12490 XPSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12492 **sr 8.4.98 (1/sqrt(x))
12493 C XPSQI = DT_SAMPEX(XSTHR,XSMAX)
12494 C XPSQI = DT_SAMSQX(XSTHR,XSMAX)
12495 XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12500 IF (IPSAQ(IXPS+1).GE.-2) THEN
12501 **sr 8.4.98 (1/sqrt(x))
12502 C XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
12503 C XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
12504 XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12507 IF (XSMAX.GT.XSTHR+BSQMA) THEN
12508 XPSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12510 **sr 8.4.98 (1/sqrt(x))
12511 C XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
12512 C XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
12513 XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12517 XXSEA = XXSEA+XPSQI+XPSAQI
12518 * check for maximum allowed sea x-value
12519 IF (XXSEA.GE.XXSEAM) THEN
12523 * accept this sea-quark pair
12526 XPSAQ(IXPS) = XPSAQI
12528 ZUOSP(IXPS) = .TRUE.
12532 *>>>get x-values of valence partons
12534 IF (XVTHR.GT.0.05D0) THEN
12535 XVHI = ONE-XXSEA-XDTHR
12536 XPVQI = DT_BETREJ(OHALF,UNOPRV,XVTHR,XVHI)
12539 XPVQI = DT_DBETAR(OHALF,UNOPRV)
12540 IF ((XPVQI.LT.XVTHR).OR.(ONE-XPVQI-XXSEA.LT.XDTHR))
12544 XPVDI = ONE-XPVQI-XXSEA
12545 * reject according to x**1.5
12546 XDTMP = XPVDI**1.5D0
12547 IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 99
12548 * accept these valence partons
12554 ZUOVP(IXPV) = .TRUE.
12559 * (3) select parton x-values of interacting target nucleons
12560 *-----------------------------------------------------------------------
12566 * get interacting target nucleon as sampled by Glauber
12567 IF (JTSH(ITT).NE.0) THEN
12573 * JITT is the actual number of sea-pairs sampled for this nucleon
12574 JITT = MIN(JTSH(ITT)-1,NSMAX)
12577 IF (JITT.GT.0) THEN
12578 XSMAX = XXSEAM-2.0D0*DBLE(JITT)*XSTHR
12580 IF (XSTHR.GE.XSMAX) THEN
12585 *>>>get x-values of sea-quark pairs
12589 * accumulator for sea x-values
12592 IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
12593 IF (NSCOUN.GT.NSEA)THEN
12594 * decrease the number of interactions after NSEA trials
12600 IF (ITSQ(IXTS+1).LE.2) THEN
12601 **sr 8.4.98 (1/sqrt(x))
12602 C XTSQI = DT_SAMPEX(XSTHR,XSMAX)
12603 C XTSQI = DT_SAMSQX(XSTHR,XSMAX)
12604 XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12607 IF (XSMAX.GT.XSTHR+BSQMA) THEN
12608 XTSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12610 **sr 8.4.98 (1/sqrt(x))
12611 C XTSQI = DT_SAMPEX(XSTHR,XSMAX)
12612 C XTSQI = DT_SAMSQX(XSTHR,XSMAX)
12613 XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12618 IF (ITSAQ(IXTS+1).GE.-2) THEN
12619 **sr 8.4.98 (1/sqrt(x))
12620 C XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
12621 C XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
12622 XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12625 IF (XSMAX.GT.XSTHR+BSQMA) THEN
12626 XTSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12628 **sr 8.4.98 (1/sqrt(x))
12629 C XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
12630 C XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
12631 XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12635 XXSEA = XXSEA+XTSQI+XTSAQI
12636 * check for maximum allowed sea x-value
12637 IF (XXSEA.GE.XXSEAM) THEN
12641 * accept this sea-quark pair
12644 XTSAQ(IXTS) = XTSAQI
12646 ZUOST(IXTS) = .TRUE.
12650 *>>>get x-values of valence partons
12652 IF (XVTHR.GT.0.05D0) THEN
12653 XVHI = ONE-XXSEA-XDTHR
12654 XTVQI = DT_BETREJ(OHALF,UNON,XVTHR,XVHI)
12657 XTVQI = DT_DBETAR(OHALF,UNON)
12658 IF ((XTVQI.LT.XVTHR).OR.(ONE-XTVQI-XXSEA.LT.XDTHR))
12662 XTVDI = ONE-XTVQI-XXSEA
12663 * reject according to x**1.5
12664 XDTMP = XTVDI**1.5D0
12665 IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 169
12666 * accept these valence partons
12672 ZUOVT(IXTV) = .TRUE.
12677 * (4) get valence-valence chains
12678 *-----------------------------------------------------------------------
12683 IPVAL = ITOVP(INTER1(I))
12684 ITVAL = ITOVT(INTER2(I))
12685 IF (ZUOVP(IPVAL).AND.ZUOVT(ITVAL)) THEN
12687 ZUOVP(IPVAL) = .FALSE.
12688 ZUOVT(ITVAL) = .FALSE.
12691 INTVV1(NVV) = IPVAL
12692 INTVV2(NVV) = ITVAL
12696 * (5) get sea-valence chains
12697 *-----------------------------------------------------------------------
12704 IPVAL = ITOVP(INTER1(I))
12705 ITVAL = ITOVT(INTER2(I))
12707 IF (ZUOSP(J).AND.(IFROSP(J).EQ.INTER1(I)).AND.
12708 & ZUOVT(ITVAL)) THEN
12710 ZUOVT(ITVAL) = .FALSE.
12712 IF (LSEADI.AND.(DT_RNDM(PLW).GT.FRCDIQ)) THEN
12713 * sample sea-diquark pair
12714 CALL DT_SAMSDQ(ECM,ITVAL,J,2,IREJ1)
12715 IF (IREJ1.EQ.0) GOTO 260
12720 INTSV2(NSV) = ITVAL
12722 *>>>correct chain kinematics according to minimum chain masses
12723 * the actual chain masses
12724 AMSVQ1 = XPSQ(J) *XTVD(ITVAL)*ECM**2
12725 AMSVQ2 = XPSAQ(J)*XTVQ(ITVAL)*ECM**2
12726 * get lower mass cuts
12727 IF (IPSQ(J).EQ.3) THEN
12732 * q being u/d-quark
12737 * chain mass above minimum - resampling of sea-q x-value
12738 IF (AMSVQ1.GT.AMCHK1) THEN
12739 XPSQTH = AMCHK1/(XTVD(ITVAL)*ECM**2)
12740 **sr 8.4.98 (1/sqrt(x))
12741 C XPSQXX = DT_SAMPEX(XPSQTH,XPSQ(J))
12742 C XPSQXX = DT_SAMSQX(XPSQTH,XPSQ(J))
12743 XPSQXX = DT_SAMPLW(XPSQTH,XPSQ(J),PLW)
12745 XPVD(IPVAL) = XPVD(IPVAL)+XPSQ(J)-XPSQXX
12747 * chain mass below minimum - reset sea-q x-value and correct
12748 * diquark-x of the same nucleon
12749 ELSEIF (AMSVQ1.LT.AMCHK1) THEN
12750 XPSQW = AMCHK1/(XTVD(ITVAL)*ECM**2)
12751 DXPSQ = XPSQW-XPSQ(J)
12752 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
12753 XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
12758 * chain mass below minimum - reset sea-aq x-value and correct
12759 * diquark-x of the same nucleon
12760 IF (AMSVQ2.LT.AMCHK2) THEN
12761 XPSQW = AMCHK2/(XTVQ(ITVAL)*ECM**2)
12762 DXPSQ = XPSQW-XPSAQ(J)
12763 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
12764 XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
12768 *>>>end of chain mass correction
12777 * (6) get valence-sea chains
12778 *-----------------------------------------------------------------------
12784 IPVAL = ITOVP(INTER1(I))
12785 ITVAL = ITOVT(INTER2(I))
12787 IF (ZUOVP(IPVAL).AND.ZUOST(J).AND.
12788 & (IFROST(J).EQ.INTER2(I))) THEN
12790 ZUOVP(IPVAL) = .FALSE.
12792 IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
12793 * sample sea-diquark pair
12794 CALL DT_SAMSDQ(ECM,IPVAL,J,1,IREJ1)
12795 IF (IREJ1.EQ.0) GOTO 290
12799 INTVS1(NVS) = IPVAL
12802 *>>>correct chain kinematics according to minimum chain masses
12803 * the actual chain masses
12804 AMVSQ1 = XPVQ(IPVAL)*XTSAQ(J)*ECM**2
12805 AMVSQ2 = XPVD(IPVAL)*XTSQ(J) *ECM**2
12806 * get lower mass cuts
12807 IF (ITSQ(J).EQ.3) THEN
12812 * q being u/d-quark
12817 * chain mass below minimum - reset sea-aq x-value and correct
12818 * diquark-x of the same nucleon
12819 IF (AMVSQ1.LT.AMCHK1) THEN
12820 XTSQW = AMCHK1/(XPVQ(IPVAL)*ECM**2)
12821 DXTSQ = XTSQW-XTSAQ(J)
12822 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
12823 XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
12828 * chain mass above minimum - resampling of sea-q x-value
12829 IF (AMVSQ2.GT.AMCHK2) THEN
12830 XTSQTH = AMCHK2/(XPVD(IPVAL)*ECM**2)
12831 **sr 8.4.98 (1/sqrt(x))
12832 C XTSQXX = DT_SAMPEX(XTSQTH,XTSQ(J))
12833 C XTSQXX = DT_SAMSQX(XTSQTH,XTSQ(J))
12834 XTSQXX = DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
12836 XTVD(ITVAL) = XTVD(ITVAL)+XTSQ(J)-XTSQXX
12838 * chain mass below minimum - reset sea-q x-value and correct
12839 * diquark-x of the same nucleon
12840 ELSEIF (AMVSQ2.LT.AMCHK2) THEN
12841 XTSQW = AMCHK2/(XPVD(IPVAL)*ECM**2)
12842 DXTSQ = XTSQW-XTSQ(J)
12843 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
12844 XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
12848 *>>>end of chain mass correction
12857 * (7) get sea-sea chains
12858 *-----------------------------------------------------------------------
12865 IPVAL = ITOVP(INTER1(I))
12866 ITVAL = ITOVT(INTER2(I))
12867 * loop over target partons not yet matched
12869 IF (ZUOST(J).AND.(IFROST(J).EQ.INTER2(I))) THEN
12870 * loop over projectile partons not yet matched
12872 IF (ZUOSP(JJ).AND.(IFROSP(JJ).EQ.INTER1(I))) THEN
12873 ZUOSP(JJ) = .FALSE.
12881 *---->chain recombination option
12882 VALFRA = DBLE(NVV/(NVV+IXPS+IXTS))
12883 IF (IRECOM.EQ.1.AND.(DT_RNDM(BSQMA).GT.VALFRA))
12885 * sea-sea chains may recombine with valence-valence chains
12886 * only if they have the same projectile or target nucleon
12888 IF (ISKPCH(8,IVV).NE.99) THEN
12889 IXVPR = INTVV1(IVV)
12890 IXVTA = INTVV2(IVV)
12891 IF ((INTER1(I).EQ.IFROVP(IXVPR)).OR.
12892 & (INTER2(I).EQ.IFROVT(IXVTA))) THEN
12893 * recombination possible, drop old v-v and s-s chains
12897 * (a) assign new s-v chains
12898 * ~~~~~~~~~~~~~~~~~~~~~~~~~
12900 & (DT_RNDM(VALFRA).GT.FRCDIQ))
12902 * sample sea-diquark pair
12903 CALL DT_SAMSDQ(ECM,IXVTA,JJ,2,
12905 IF (IREJ1.EQ.0) GOTO 4202
12910 INTSV2(NSV) = IXVTA
12911 *>>>>>>>>>>>correct chain kinematics according to minimum chain masses
12912 * the actual chain masses
12913 AMSVQ1 = XPSQ(JJ) *XTVD(IXVTA)
12915 AMSVQ2 = XPSAQ(JJ)*XTVQ(IXVTA)
12917 * get lower mass cuts
12918 IF (IPSQ(JJ).EQ.3) THEN
12923 * q being u/d-quark
12928 * chain mass above minimum - resampling of sea-q x-value
12929 IF (AMSVQ1.GT.AMCHK1) THEN
12931 & AMCHK1/(XTVD(IXVTA)*ECM**2)
12932 **sr 8.4.98 (1/sqrt(x))
12934 & DT_SAMPLW(XPSQTH,XPSQ(JJ),PLW)
12935 C & DT_SAMSQX(XPSQTH,XPSQ(JJ))
12936 C & DT_SAMPEX(XPSQTH,XPSQ(JJ))
12939 & XPVD(IPVAL)+XPSQ(JJ)-XPSQXX
12941 * chain mass below minimum - reset sea-q x-value and correct
12942 * diquark-x of the same nucleon
12943 ELSEIF (AMSVQ1.LT.AMCHK1) THEN
12945 & AMCHK1/(XTVD(IXVTA)*ECM**2)
12946 DXPSQ = XPSQW-XPSQ(JJ)
12947 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
12950 & XPVD(IPVAL)-DXPSQ
12955 * chain mass below minimum - reset sea-aq x-value and correct
12956 * diquark-x of the same nucleon
12957 IF (AMSVQ2.LT.AMCHK2) THEN
12959 & AMCHK2/(XTVQ(IXVTA)*ECM**2)
12960 DXPSQ = XPSQW-XPSAQ(JJ)
12961 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
12964 & XPVD(IPVAL)-DXPSQ
12968 *>>>>>>>>>>>end of chain mass correction
12971 * (b) assign new v-s chains
12972 * ~~~~~~~~~~~~~~~~~~~~~~~~~
12974 & DT_RNDM(AMSVQ2).GT.FRCDIQ))
12976 * sample sea-diquark pair
12977 CALL DT_SAMSDQ(ECM,IXVPR,J,1,
12979 IF (IREJ1.EQ.0) GOTO 4203
12983 INTVS1(NVS) = IXVPR
12985 *>>>>>>>>>>>correct chain kinematics according to minimum chain masses
12986 * the actual chain masses
12987 AMVSQ1 = XPVQ(IXVPR)*XTSAQ(J)*ECM**2
12988 AMVSQ2 = XPVD(IXVPR)*XTSQ(J) *ECM**2
12989 * get lower mass cuts
12990 IF (ITSQ(J).EQ.3) THEN
12995 * q being u/d-quark
13000 * chain mass below minimum - reset sea-aq x-value and correct
13001 * diquark-x of the same nucleon
13002 IF (AMVSQ1.LT.AMCHK1) THEN
13004 & AMCHK1/(XPVQ(IXVPR)*ECM**2)
13005 DXTSQ = XTSQW-XTSAQ(J)
13006 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13009 & XTVD(ITVAL)-DXTSQ
13013 IF (AMVSQ2.GT.AMCHK2) THEN
13015 & AMCHK2/(XPVD(IXVPR)*ECM**2)
13016 **sr 8.4.98 (1/sqrt(x))
13018 & DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
13019 C & DT_SAMSQX(XTSQTH,XTSQ(J))
13020 C & DT_SAMPEX(XTSQTH,XTSQ(J))
13023 & XTVD(ITVAL)+XTSQ(J)-XTSQXX
13025 ELSEIF (AMVSQ2.LT.AMCHK2) THEN
13027 & AMCHK2/(XPVD(IXVPR)*ECM**2)
13028 DXTSQ = XTSQW-XTSQ(J)
13029 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13032 & XTVD(ITVAL)-DXTSQ
13036 *>>>>>>>>>end of chain mass correction
13038 * jump out of s-s chain loop
13044 *---->end of chain recombination option
13046 * sample sea-diquark pair (projectile)
13047 IF (LSEADI.AND.(DT_RNDM(BSQMA).GT.FRCDIQ)) THEN
13048 CALL DT_SAMSDQ(ECM,J,JJ,4,IREJ1)
13049 IF (IREJ1.EQ.0) THEN
13054 * sample sea-diquark pair (target)
13055 IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
13056 CALL DT_SAMSDQ(ECM,JJ,J,3,IREJ1)
13057 IF (IREJ1.EQ.0) THEN
13062 *>>>>>correct chain kinematics according to minimum chain masses
13063 * the actual chain masses
13064 SSMA1Q = XPSQ(JJ) *XTSAQ(J)*ECM**2
13065 SSMA2Q = XPSAQ(JJ)*XTSQ(J) *ECM**2
13066 * check for lower mass cuts
13067 IF ((SSMA1Q.LT.SSMIMQ).OR.
13068 & (SSMA2Q.LT.SSMIMQ)) THEN
13069 IPVAL = ITOVP(INTER1(I))
13070 ITVAL = ITOVT(INTER2(I))
13071 IF ((XPVD(IPVAL).GT.XDTHR+3.5D0*XSSTHR).AND.
13072 & (XTVD(ITVAL).GT.XDTHR+3.5D0*XSSTHR))THEN
13073 * maximum allowed x values for sea quarks
13074 XSPMAX = ONE-XPVQ(IPVAL)-XDTHR-
13076 XSTMAX = ONE-XTVQ(ITVAL)-XDTHR-
13078 * resampling of x values not possible - skip sea-sea chains
13079 IF ((XSPMAX.LE.XSSTHR+0.05D0).OR.
13080 & (XSTMAX.LE.XSSTHR+0.05D0)) GOTO 380
13081 * resampling of x for projectile sea quark pair
13085 IF (XSSTHR.GT.0.05D0) THEN
13086 XPSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13088 XPSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13092 XPSQI = DT_DBETAR(XSEACU,UNOSEA)
13093 IF ((XPSQI.LT.XSSTHR).OR.
13094 & (XPSQI.GT.XSPMAX)) GOTO 320
13096 XPSAQI = DT_DBETAR(XSEACU,UNOSEA)
13097 IF ((XPSAQI.LT.XSSTHR).OR.
13098 & (XPSAQI.GT.XSPMAX)) GOTO 330
13100 * final test of remaining x for projectile diquark
13101 XPVDCO = XPVD(IPVAL)-XPSQI-XPSAQI
13102 & +XPSQ(JJ)+XPSAQ(JJ)
13103 IF (XPVDCO.LE.XDTHR) THEN
13105 C IF (ICOUS.LT.5) GOTO 310
13106 IF (ICOUS.LT.0.5D0) GOTO 310
13109 * resampling of x for target sea quark pair
13113 IF (XSSTHR.GT.0.05D0) THEN
13114 XTSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13116 XTSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13120 XTSQI = DT_DBETAR(XSEACU,UNOSEA)
13121 IF ((XTSQI.LT.XSSTHR).OR.
13122 & (XTSQI.GT.XSTMAX)) GOTO 360
13124 XTSAQI = DT_DBETAR(XSEACU,UNOSEA)
13125 IF ((XTSAQI.LT.XSSTHR).OR.
13126 & (XTSAQI.GT.XSTMAX)) GOTO 370
13128 * final test of remaining x for target diquark
13129 XTVDCO = XTVD(ITVAL)-XTSQI-XTSAQI
13130 & +XTSQ(J)+XTSAQ(J)
13131 IF (XTVDCO.LT.XDTHR) THEN
13132 IF (ICOUS.LT.5) GOTO 350
13135 XPVD(IPVAL) = XPVDCO
13136 XTVD(ITVAL) = XTVDCO
13141 *>>>>>end of chain mass correction
13144 * come here to discard s-s interaction
13145 * resampling of x values not allowed or unsuccessful
13152 * consider next s-s interaction
13162 * correct x-values of valence quarks for non-matching sea quarks
13165 IPVAL = ITOVP(IFROSP(I))
13166 XPVQ(IPVAL) = XPVQ(IPVAL)+XPSQ(I)+XPSAQ(I)
13174 ITVAL = ITOVT(IFROST(I))
13175 XTVQ(ITVAL) = XTVQ(ITVAL)+XTSQ(I)+XTSAQ(I)
13182 IF (ZUOVP(I)) ISTHKK(IFROVP(I)) = 13
13185 IF (ZUOVT(I)) ISTHKK(IFROVT(I)+IP) = 14
13191 *$ CREATE DT_SAMSDQ.FOR
13194 *===samsdq=============================================================*
13196 SUBROUTINE DT_SAMSDQ(ECM,IDX1,IDX2,MODE,IREJ)
13198 ************************************************************************
13199 * SAMpling of Sea-DiQuarks *
13200 * ECM cm-energy of the nucleon-nucleon system *
13201 * IDX1,2 indices of x-values of the participating *
13202 * partons (IDX2 is always the sea-q-pair to be *
13203 * changed to sea-qq-pair) *
13204 * MODE = 1 valence-q - sea-diq *
13205 * = 2 sea-diq - valence-q *
13206 * = 3 sea-q - sea-diq *
13207 * = 4 sea-diq - sea-q *
13208 * Based on DIQVS, DIQSV, DIQSSD, DIQDSS. *
13209 * This version dated 17.10.95 is written by S. Roesler *
13210 ************************************************************************
13212 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13215 PARAMETER (ZERO=0.0D0)
13217 * threshold values for x-sampling (DTUNUC 1.x)
13218 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
13220 * various options for treatment of partons (DTUNUC 1.x)
13221 * (chain recombination, Cronin,..)
13222 LOGICAL LCO2CR,LINTPT
13223 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
13225 PARAMETER ( MAXNCL = 260,
13227 & MAXSQU = 20*MAXVQU,
13228 & MAXINT = MAXVQU+MAXSQU)
13229 * x-values of partons (DTUNUC 1.x)
13230 COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
13231 & XTVQ(MAXVQU),XTVD(MAXVQU),
13232 & XPSQ(MAXSQU),XPSAQ(MAXSQU),
13233 & XTSQ(MAXSQU),XTSAQ(MAXSQU)
13234 * flavors of partons (DTUNUC 1.x)
13235 COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
13236 & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
13237 & IPSQ(MAXSQU),IPSQ2(MAXSQU),
13238 & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
13239 & ITSQ(MAXSQU),ITSQ2(MAXSQU),
13240 & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
13241 & KKPROJ(MAXVQU),KKTARG(MAXVQU)
13242 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13243 COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
13244 & IXPV,IXPS,IXTV,IXTS,
13245 & INTVV1(MAXVQU),INTVV2(MAXVQU),
13246 & INTSV1(MAXVQU),INTSV2(MAXVQU),
13247 & INTVS1(MAXVQU),INTVS2(MAXVQU),
13248 & INTSS1(MAXSQU),INTSS2(MAXSQU),
13249 & INTDV1(MAXVQU),INTDV2(MAXVQU),
13250 & INTVD1(MAXVQU),INTVD2(MAXVQU),
13251 & INTDS1(MAXSQU),INTDS2(MAXSQU),
13252 & INTSD1(MAXSQU),INTSD2(MAXSQU)
13253 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13254 COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
13255 & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
13256 * auxiliary common for chain system storage (DTUNUC 1.x)
13257 COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
13260 * threshold-x for valence diquarks
13263 GOTO (1,2,3,4) MODE
13265 *---------------------------------------------------------------------
13266 * proj. valence partons - targ. sea partons
13267 * get x-values and flavors for target sea-diquark pair
13273 * index of corr. val-diquark-x in target nucleon
13274 IDXVT = ITOVT(IFROST(IDXST))
13275 * available x above diquark thresholds for valence- and sea-diquarks
13276 XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13278 IF (XXD.GE.ZERO) THEN
13279 * x-values for the three diquarks of the target nucleon
13283 SR123 = RR1+RR2+RR3
13284 XXTV = XDTHR+RR1*XXD/SR123
13285 XXTSQ = XDTHR+RR2*XXD/SR123
13286 XXTSAQ = XDTHR+RR3*XXD/SR123
13289 XXTSQ = XTSQ(IDXST)
13290 XXTSAQ = XTSAQ(IDXST)
13292 * flavor of the second quarks in the sea-diquark pair
13293 ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13294 ITSAQ2(IDXST) = -ITSQ2(IDXST)
13295 * check masses of the new val-q - sea-qq, val-qq - sea-aqaq chains
13296 AM1 = XXTSQ *XPVQ(IDXVP)*ECM**2
13297 AM2 = XXTSAQ*XPVD(IDXVP)*ECM**2
13298 IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13300 & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN
13303 ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13304 * at least one strange quark
13305 & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN
13308 ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13312 * accept the new sea-diquark
13314 XTSQ(IDXST) = XXTSQ
13315 XTSAQ(IDXST) = XXTSAQ
13317 INTVD1(NVD) = IDXVP
13318 INTVD2(NVD) = IDXST
13322 *---------------------------------------------------------------------
13323 * proj. sea partons - targ. valence partons
13324 * get x-values and flavors for projectile sea-diquark pair
13330 * index of corr. val-diquark-x in projectile nucleon
13331 IDXVP = ITOVP(IFROSP(IDXSP))
13332 * available x above diquark thresholds for valence- and sea-diquarks
13333 XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13335 IF (XXD.GE.ZERO) THEN
13336 * x-values for the three diquarks of the projectile nucleon
13340 SR123 = RR1+RR2+RR3
13341 XXPV = XDTHR+RR1*XXD/SR123
13342 XXPSQ = XDTHR+RR2*XXD/SR123
13343 XXPSAQ = XDTHR+RR3*XXD/SR123
13346 XXPSQ = XPSQ(IDXSP)
13347 XXPSAQ = XPSAQ(IDXSP)
13349 * flavor of the second quarks in the sea-diquark pair
13350 IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13351 IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13352 * check masses of the new sea-qq - val-q, sea-aqaq - val-qq chains
13353 AM1 = XXPSQ *XTVQ(IDXVT)*ECM**2
13354 AM2 = XXPSAQ*XTVD(IDXVT)*ECM**2
13355 IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13357 & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN
13360 ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13361 * at least one strange quark
13362 & ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0)) ) THEN
13365 ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13369 * accept the new sea-diquark
13371 XPSQ(IDXSP) = XXPSQ
13372 XPSAQ(IDXSP) = XXPSAQ
13374 INTDV1(NDV) = IDXSP
13375 INTDV2(NDV) = IDXVT
13379 *---------------------------------------------------------------------
13380 * proj. sea partons - targ. sea partons
13381 * get x-values and flavors for target sea-diquark pair
13387 * index of corr. val-diquark-x in target nucleon
13388 IDXVT = ITOVT(IFROST(IDXST))
13389 * available x above diquark thresholds for valence- and sea-diquarks
13390 XXD = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13392 IF (XXD.GE.ZERO) THEN
13393 * x-values for the three diquarks of the target nucleon
13397 SR123 = RR1+RR2+RR3
13398 XXTV = XDTHR+RR1*XXD/SR123
13399 XXTSQ = XDTHR+RR2*XXD/SR123
13400 XXTSAQ = XDTHR+RR3*XXD/SR123
13403 XXTSQ = XTSQ(IDXST)
13404 XXTSAQ = XTSAQ(IDXST)
13406 * flavor of the second quarks in the sea-diquark pair
13407 ITSQ2(IDXST) = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13408 ITSAQ2(IDXST) = -ITSQ2(IDXST)
13409 * check masses of the new sea-q - sea-qq, sea-aq - sea-aqaq chains
13410 AM1 = XXTSQ *XPSQ(IDXSP)*ECM**2
13411 AM2 = XXTSAQ*XPSAQ(IDXSP)*ECM**2
13412 IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13414 & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN
13417 ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13418 * at least one strange quark
13419 & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN
13422 ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
13426 * accept the new sea-diquark
13428 XTSQ(IDXST) = XXTSQ
13429 XTSAQ(IDXST) = XXTSAQ
13431 INTSD1(NSD) = IDXSP
13432 INTSD2(NSD) = IDXST
13436 *---------------------------------------------------------------------
13437 * proj. sea partons - targ. sea partons
13438 * get x-values and flavors for projectile sea-diquark pair
13444 * index of corr. val-diquark-x in projectile nucleon
13445 IDXVP = ITOVP(IFROSP(IDXSP))
13446 * available x above diquark thresholds for valence- and sea-diquarks
13447 XXD = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13449 IF (XXD.GE.ZERO) THEN
13450 * x-values for the three diquarks of the projectile nucleon
13454 SR123 = RR1+RR2+RR3
13455 XXPV = XDTHR+RR1*XXD/SR123
13456 XXPSQ = XDTHR+RR2*XXD/SR123
13457 XXPSAQ = XDTHR+RR3*XXD/SR123
13460 XXPSQ = XPSQ(IDXSP)
13461 XXPSAQ = XPSAQ(IDXSP)
13463 * flavor of the second quarks in the sea-diquark pair
13464 IPSQ2(IDXSP) = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13465 IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13466 * check masses of the new sea-qq - sea-q, sea-aqaq - sea-qq chains
13467 AM1 = XXPSQ *XTSQ(IDXST)*ECM**2
13468 AM2 = XXPSAQ*XTSAQ(IDXST)*ECM**2
13469 IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13471 & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN
13474 ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13475 * at least one strange quark
13476 & ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0)) ) THEN
13479 ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
13483 * accept the new sea-diquark
13485 XPSQ(IDXSP) = XXPSQ
13486 XPSAQ(IDXSP) = XXPSAQ
13488 INTDS1(NDS) = IDXSP
13489 INTDS2(NDS) = IDXST
13494 *$ CREATE DT_DIFEVT.FOR
13497 *===difevt=============================================================*
13499 SUBROUTINE DT_DIFEVT(IFP1,IFP2,PP,MOP,
13500 & IFT1,IFT2,PT,MOT,JDIFF,NCSY,IREJ)
13502 ************************************************************************
13503 * Interface to treatment of diffractive interactions. *
13504 * (input) IFP1/2 PDG-indizes of projectile partons *
13505 * (baryon: IFP2 - adiquark) *
13506 * PP(4) projectile 4-momentum *
13507 * IFT1/2 PDG-indizes of target partons *
13508 * (baryon: IFT1 - adiquark) *
13509 * PT(4) target 4-momentum *
13510 * (output) JDIFF = 0 no diffraction *
13511 * = 1/-1 LMSD/LMDD *
13512 * = 2/-2 HMSD/HMDD *
13513 * NCSY counter for two-chain systems *
13514 * dumped to DTEVT1 *
13515 * This version dated 14.02.95 is written by S. Roesler *
13516 ************************************************************************
13518 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13520 PARAMETER ( LINP = 10 ,
13523 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5,
13527 PARAMETER (NMXHKK=200000)
13528 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
13529 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
13530 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
13531 * extended event history
13532 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
13533 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
13535 * flags for diffractive interactions (DTUNUC 1.x)
13536 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
13538 DIMENSION PP(4),PT(4)
13541 DATA LFIRST /.TRUE./
13548 XM = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
13549 & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
13550 * identities of projectile hadron / target nucleon
13551 KPROJ = IDT_ICIHAD(IDHKK(MOP))
13552 KTARG = IDT_ICIHAD(IDHKK(MOT))
13554 * single diffractive xsections
13555 CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM)
13556 * double diffractive xsections
13557 **!! no double diff yet
13558 C CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM,DDTOT,DDHM)
13562 * total inelastic xsection
13563 C SIGIN = DT_SHNTOT(KPROJ,KTARG,XM,ZERO)-DT_SHNELA(KPROJ,KTARG,XM)
13565 CALL DT_XSHN(KPROJ,KTARG,DUMZER,XM,SIGTO,SIGEL)
13566 SIGIN = MAX(SIGTO-SIGEL,ZERO)
13568 * fraction of diffractive processes
13569 FRADIF = (SDTOT+DDTOT)/SIGIN
13572 WRITE(LOUT,1000) XM,SDTOT,SIGIN
13573 1000 FORMAT(1X,'DIFEVT: single diffraction requested at E_cm = ',
13574 & F5.1,' GeV',/,9X,'sigma_sd = ',F4.1,' mb, sigma_in = ',
13579 IF ((DT_RNDM(DDHM).LE.FRADIF).OR.
13580 & (ISINGD.GT.1).OR.(IDOUBD.GT.1)) THEN
13581 * diffractive interaction requested by x-section or by user
13582 FRASD = SDTOT/(SDTOT+DDTOT)
13583 FRASDH = SDHM/SDTOT
13584 **sr needs to be specified!!
13585 C FRADDH = DDHM/DDTOT
13588 IF ((DT_RNDM(FRASD).LE.FRASD).OR.(ISINGD.GT.1)) THEN
13589 * single diffraction
13591 IF (DT_RNDM(DDTOT).LE.FRASDH) THEN
13594 IF (((ISINGD.EQ.4).OR.(DT_RNDM(DDTOT).GE.OHALF)).AND.
13595 & ISINGD.NE.3) THEN
13602 IF (((ISINGD.EQ.4).OR.(DT_RNDM(FRADDH).GE.OHALF)).AND.
13603 & ISINGD.NE.3) THEN
13609 * double diffraction
13611 IF (DT_RNDM(FRADDH).LE.FRADDH) THEN
13619 CALL DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
13620 & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
13621 IF (IREJ1.EQ.0) THEN
13623 IF ((KP.EQ.1).OR.(KT.EQ.1)) IFLAGD = KDIFF
13637 *$ CREATE DT_DIFFKI.FOR
13640 *===difkin=============================================================*
13642 SUBROUTINE DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
13643 & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ)
13645 ************************************************************************
13646 * Kinematics of diffractive nucleon-nucleon interaction. *
13647 * IFP1/2 PDG-indizes of projectile partons *
13648 * (baryon: IFP2 - adiquark) *
13649 * PP(4) projectile 4-momentum *
13650 * IFT1/2 PDG-indizes of target partons *
13651 * (baryon: IFT1 - adiquark) *
13652 * PT(4) target 4-momentum *
13653 * KP = 0 projectile quasi-elastically scattered *
13654 * = 1 excited to low-mass diff. state *
13655 * = 2 excited to high-mass diff. state *
13656 * KT = 0 target quasi-elastically scattered *
13657 * = 1 excited to low-mass diff. state *
13658 * = 2 excited to high-mass diff. state *
13659 * This version dated 12.02.95 is written by S. Roesler *
13660 ************************************************************************
13662 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13664 PARAMETER ( LINP = 10 ,
13667 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5)
13671 * particle properties (BAMJET index convention)
13673 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
13674 & IICH(210),IIBAR(210),K1(210),K2(210)
13675 * flags for input different options
13676 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
13677 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
13678 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
13679 * rejection counter
13680 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
13681 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
13682 & IREXCI(3),IRDIFF(2),IRINC
13683 * kinematics of diffractive interactions (DTUNUC 1.x)
13684 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
13686 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
13687 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
13689 DIMENSION PITOT(4),BGTOT(4),PP1(4),PT1(4),PPBLOB(4),PTBLOB(4),
13690 & PP(4),PT(4),PPOM1(4),DEV1(4),DEV2(4)
13692 DATA LSTART /.TRUE./
13696 2000 FORMAT(/,1X,'DIFEVT: diffractive interactions treated ')
13702 * initialize common /DTDIKI/
13704 * store momenta of initial incoming particles for emc-check
13706 CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM,IDUM)
13707 CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM,IDUM)
13710 * masses of initial particles
13711 XMP2 = PP(4)**2-PP(1)**2-PP(2)**2-PP(3)**2
13712 XMT2 = PT(4)**2-PT(1)**2-PT(2)**2-PT(3)**2
13713 IF ((XMP2.LT.ZERO).OR.(XMT2.LT.ZERO)) GOTO 9999
13716 * check quark-input (used to adjust coherence cond. for M-selection)
13718 IF ((ABS(IFP1).GE.1000).OR.(ABS(IFP2).GE.1000)) IBP = 1
13720 IF ((ABS(IFT1).GE.1000).OR.(ABS(IFT2).GE.1000)) IBT = 1
13722 * parameter for Lorentz-transformation into nucleon-nucleon cms
13724 PITOT(K) = PP(K)+PT(K)
13726 XMTOT2 = PITOT(4)**2-PITOT(1)**2-PITOT(2)**2-PITOT(3)**2
13727 IF (XMTOT2.LE.ZERO) THEN
13728 WRITE(LOUT,1000) XMTOT2
13729 1000 FORMAT(1X,'DIFEVT: negative cm. energy! ',
13730 & 'XMTOT2 = ',E12.3)
13733 XMTOT = SQRT(XMTOT2)
13735 BGTOT(K) = PITOT(K)/XMTOT
13737 * transformation of nucleons into cms
13738 CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PP(1),PP(2),
13739 & PP(3),PP(4),PPTOT,PP1(1),PP1(2),PP1(3),PP1(4))
13740 CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PT(1),PT(2),
13741 & PT(3),PT(4),PTTOT,PT1(1),PT1(2),PT1(3),PT1(4))
13744 C SID = SQRT((ONE-COD)*(ONE+COD))
13745 PPT = SQRT(PP1(1)**2+PP1(2)**2)
13749 IF(PPTOT*SID.GT.TINY10) THEN
13750 COF = PP1(1)/(SID*PPTOT)
13751 SIF = PP1(2)/(SID*PPTOT)
13752 ANORF = SQRT(COF*COF+SIF*SIF)
13756 * check consistency
13758 DEV1(K) = ABS(PP1(K)+PT1(K))
13760 DEV1(4) = ABS(DEV1(4)-XMTOT)
13761 IF ((DEV1(1).GT.TINY10).OR.(DEV1(2).GT.TINY10).OR.
13762 & (DEV1(3).GT.TINY10).OR.(DEV1(4).GT.TINY10)) THEN
13763 WRITE(LOUT,1001) DEV1
13764 1001 FORMAT(1X,'DIFEVT: inconsitent Lorentz-transformation! ',
13769 * select x-fractions in high-mass diff. interactions
13770 IF ((KP.EQ.2).OR.(KT.EQ.2)) CALL DT_XVALHM(KP,KT)
13772 * select diffractive masses
13775 XMPF = DT_XMLMD(XMTOT)
13776 CALL DT_LM2RES(IFP1,IFP2,XMPF,IDPR,IDXPR,IREJ1)
13777 IF (IREJ1.GT.0) GOTO 9999
13778 ELSEIF (KP.EQ.2) THEN
13779 XMPF = DT_XMHMD(XMTOT,IBP,1)
13785 XMTF = DT_XMLMD(XMTOT)
13786 CALL DT_LM2RES(IFT1,IFT2,XMTF,IDTR,IDXTR,IREJ1)
13787 IF (IREJ1.GT.0) GOTO 9999
13788 ELSEIF (KT.EQ.2) THEN
13789 XMTF = DT_XMHMD(XMTOT,IBT,2)
13794 * kinematical treatment of "two-particle" system (masses - XMPF,XMTF)
13797 PPBLOB(3) = DT_YLAMB(XMTOT2,XMPF2,XMTF2)/(2.D0*XMTOT)
13798 PPBLOB(4) = SQRT(XMPF2+PPBLOB(3)**2)
13800 * select momentum transfer (all t-values used here are <0)
13801 * minimum absolute value to produce diffractive masses
13802 TMIN = XMP2+XMPF2-2.0D0*(PP1(4)*PPBLOB(4)-PPTOT*PPBLOB(3))
13803 TT = DT_TDIFF(XMTOT,TMIN,XMPF,KP,XMTF,KT,IREJ1)
13804 IF (IREJ1.GT.0) GOTO 9999
13806 * longitudinal momentum of excited/elastically scattered projectile
13807 PPBLOB(3) = (TT-XMP2-XMPF2+2.0D0*PP1(4)*PPBLOB(4))/(2.0D0*PPTOT)
13808 * total transverse momentum due to t-selection
13809 PPBLT2 = PPBLOB(4)**2-PPBLOB(3)**2-XMPF2
13810 IF (PPBLT2.LT.ZERO) THEN
13811 WRITE(LOUT,1002) PPBLT2,KP,PP1,XMPF,KT,PT1,XMTF,TT
13812 1002 FORMAT(1X,'DIFEVT: inconsistent transverse momentum! ',
13813 & E12.3,2(/,1X,I2,5E12.3),/,1X,E12.3)
13816 CALL DT_DSFECF(SINPHI,COSPHI)
13817 PPBLT = SQRT(PPBLT2)
13818 PPBLOB(1) = COSPHI*PPBLT
13819 PPBLOB(2) = SINPHI*PPBLT
13821 * rotate excited/elastically scattered projectile into n-n cms.
13822 CALL DT_MYTRAN(1,PPBLOB(1),PPBLOB(2),PPBLOB(3),COD,SID,COF,SIF,
13828 * 4-momentum of excited/elastically scattered target and of exchanged
13831 IF (K.LT.4) PTBLOB(K) = -PPBLOB(K)
13832 PPOM1(K) = PP1(K)-PPBLOB(K)
13834 PTBLOB(4) = XMTOT-PPBLOB(4)
13836 * Lorentz-transformation back into system of initial diff. collision
13837 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13838 & PPBLOB(1),PPBLOB(2),PPBLOB(3),PPBLOB(4),
13839 & PPTOTF,PPF(1),PPF(2),PPF(3),PPF(4))
13840 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13841 & PTBLOB(1),PTBLOB(2),PTBLOB(3),PTBLOB(4),
13842 & PTTOTF,PTF(1),PTF(2),PTF(3),PTF(4))
13843 CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13844 & PPOM1(1),PPOM1(2),PPOM1(3),PPOM1(4),
13845 & PPOMTO,PPOM(1),PPOM(2),PPOM(3),PPOM(4))
13847 * store 4-momentum of elastically scattered particle (in single diff.
13853 ELSEIF (KT.EQ.0) THEN
13859 * check consistency of kinematical treatment so far
13861 CALL DT_EVTEMC(-PPF(1),-PPF(2),-PPF(3),-PPF(4),2,IDUM,IDUM)
13862 CALL DT_EVTEMC(-PTF(1),-PTF(2),-PTF(3),-PTF(4),2,IDUM,IDUM)
13863 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,60,IREJ1)
13864 IF (IREJ1.NE.0) GOTO 9999
13867 DEV1(K) = ABS(PP(K)-PPF(K)-PPOM(K))
13868 DEV2(K) = ABS(PT(K)-PTF(K)+PPOM(K))
13870 IF ((DEV1(1).GT.TINY5).OR.(DEV1(2).GT.TINY5).OR.
13871 & (DEV1(3).GT.TINY5).OR.(DEV1(4).GT.TINY5).OR.
13872 & (DEV2(1).GT.TINY5).OR.(DEV2(2).GT.TINY5).OR.
13873 & (DEV2(3).GT.TINY5).OR.(DEV2(4).GT.TINY5)) THEN
13874 WRITE(LOUT,1003) DEV1,DEV2
13875 1003 FORMAT(1X,'DIFEVT: inconsitent kinematical treatment! ',
13880 * kinematical treatment for low-mass diffraction
13881 CALL DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ1)
13882 IF (IREJ1.NE.0) GOTO 9999
13884 * dump diffractive chains into DTEVT1
13885 CALL DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
13886 IF (IREJ1.NE.0) GOTO 9999
13891 IRDIFF(1) = IRDIFF(1)+1
13896 *$ CREATE DT_XMHMD.FOR
13899 *===xmhmd==============================================================*
13901 DOUBLE PRECISION FUNCTION DT_XMHMD(ECM,IB,MODE)
13903 ************************************************************************
13904 * Diffractive mass in high mass single/double diffractive events. *
13905 * This version dated 11.02.95 is written by S. Roesler *
13906 ************************************************************************
13908 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13910 PARAMETER ( LINP = 10 ,
13913 PARAMETER (OHALF=0.5D0,ONE=1.0D0,ZERO=0.0D0)
13915 * kinematics of diffractive interactions (DTUNUC 1.x)
13916 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
13918 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
13919 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
13921 C DATA XCOLOW /0.05D0/
13922 DATA XCOLOW /0.15D0/
13926 IF (MODE.EQ.2) XH = XTH(2)
13928 * minimum Pomeron-x for high-mass diffraction
13929 * (adjusted to get a smooth transition between HM and LM component)
13931 XDIMIN = (3.0D0+400.0D0*R**2)/(XH*ECM**2)
13932 IF (ECM.LE.300.0D0) THEN
13933 RR = (1.0D0-EXP(-((ECM/140.0D0)**4)))
13934 XDIMIN = (3.0D0+400.0D0*(R**2)*RR)/(XH*ECM**2)
13936 * maximum Pomeron-x for high-mass diffraction
13937 * (coherence condition, adjusted to fit to experimental data)
13939 * baryon-diffraction
13940 XDIMAX = XCOLOW*(1.0D0+EXP(-((ECM/420.0D0)**2)))
13942 * meson-diffraction
13943 XDIMAX = XCOLOW*(1.0D0+4.0D0*EXP(-((ECM/420.0D0)**2)))
13946 IF (XDIMIN.GE.XDIMAX) THEN
13947 XDIMIN = OHALF*XDIMAX
13953 IF (KLOOP.GT.20) RETURN
13954 * sample Pomeron-x from 1/x-distribution (critical Pomeron)
13955 XDIFF = DT_SAMPEX(XDIMIN,XDIMAX)
13956 * corr. diffr. mass
13957 DT_XMHMD = ECM*SQRT(XDIFF)
13958 IF (DT_XMHMD.LT.2.5D0) GOTO 1
13963 *$ CREATE DT_XMLMD.FOR
13966 *===xmlmd==============================================================*
13968 DOUBLE PRECISION FUNCTION DT_XMLMD(ECM)
13970 ************************************************************************
13971 * Diffractive mass in high mass single/double diffractive events. *
13972 * This version dated 11.02.95 is written by S. Roesler *
13973 ************************************************************************
13975 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13977 PARAMETER ( LINP = 10 ,
13981 * minimum Pomeron-x for low-mass diffraction
13984 * maximum Pomeron-x for low-mass diffraction
13985 * (adjusted to get a smooth transition between HM and LM component)
13988 IF (ECM.LE.300.0D0) SAM = 1.0D0-EXP(-((ECM/200.0D0)**4))
13989 R = DT_RNDM(AMO)*SAM
13990 AMAX= (1.0D0-SAM)*SQRT(0.1D0*ECM**2)+SAM*SQRT(400.0D0)
13991 AMU = R*SQRT(100.0D0)+(1.0D0-R)*AMAX
13993 * selection of diffractive mass
13994 * (adjusted to get a smooth transition between HM and LM component)
13996 IF (ECM.LE.50.0D0) THEN
13997 DT_XMLMD = AMO*(AMU/AMO)**R
14000 IF (ECM.LE.300.0D0) A = 0.7D0*(1.0D0-EXP(-((ECM/100.0D0)**2)))
14001 DT_XMLMD = 1.0D0/((R/(AMU**A)+(1.0D0-R)/(AMO**A))**(1.0D0/A))
14007 *$ CREATE DT_TDIFF.FOR
14010 *===tdiff==============================================================*
14012 DOUBLE PRECISION FUNCTION DT_TDIFF(ECM,TMIN,XM1I,K1,XM2I,K2,IREJ)
14014 ************************************************************************
14015 * t-selection for single/double diffractive interactions. *
14017 * TMIN minimum momentum transfer to produce diff. masses *
14018 * XM1/XM2 diffractively produced masses *
14019 * (for single diffraction XM2 is obsolete) *
14020 * K1/K2= 0 not excited *
14021 * = 1 low-mass excitation *
14022 * = 2 high-mass excitation *
14023 * This version dated 11.02.95 is written by S. Roesler *
14024 ************************************************************************
14026 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14028 PARAMETER ( LINP = 10 ,
14031 PARAMETER (ZERO=0.0D0)
14033 PARAMETER ( BTP0 = 3.7D0,
14034 & ALPHAP = 0.24D0 )
14047 IF ((K1.EQ.0).OR.(K2.EQ.0)) THEN
14048 * slope for single diffraction
14049 SLOPE = BTP0-2.0D0*ALPHAP*LOG(XDI)
14051 * slope for double diffraction
14052 SLOPE = -2.0D0*ALPHAP*LOG(XDI*XM2**2)
14057 IF (MOD(NCLOOP,1000).EQ.0) GOTO 9999
14059 T = -LOG(1.0D0-Y)/SLOPE
14060 IF (ABS(T).LE.ABS(TMIN)) GOTO 1
14066 WRITE(LOUT,1000) ECM,TMIN,XM1I,XM2I,K1,K2
14067 1000 FORMAT(1X,'DT_TDIFF: t-selection rejected!',/,
14068 & 1X,'ECM = ',E12.3,' TMIN = ',E12.2,/,1X,'XM1I = ',
14069 & E12.3,' XM2I = ',E12.3,' K1 = ',I2,' K2 = ',I2)
14074 *$ CREATE DT_XVALHM.FOR
14077 *===xvalhm=============================================================*
14079 SUBROUTINE DT_XVALHM(KP,KT)
14081 ************************************************************************
14082 * Sampling of parton x-values in high-mass diffractive interactions. *
14083 * This version dated 12.02.95 is written by S. Roesler *
14084 ************************************************************************
14086 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14088 PARAMETER ( LINP = 10 ,
14091 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0,TINY2=1.0D-2)
14093 * kinematics of diffractive interactions (DTUNUC 1.x)
14094 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14096 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14097 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14098 * various options for treatment of partons (DTUNUC 1.x)
14099 * (chain recombination, Cronin,..)
14100 LOGICAL LCO2CR,LINTPT
14101 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
14104 DATA UNON,XVQTHR /2.0D0,0.8D0/
14107 * x-fractions of projectile valence partons
14109 XPH(1) = DT_DBETAR(OHALF,UNON)
14110 IF (XPH(1).GE.XVQTHR) GOTO 1
14111 XPH(2) = ONE-XPH(1)
14112 * x-fractions of Pomeron q-aq-pair
14115 XPPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14116 XPPO(2) = ONE-XPPO(1)
14117 * flavors of Pomeron q-aq-pair
14118 IFLAV = INT(ONE+DT_RNDM(UNON)*(2.0D0+SEASQ))
14121 IF (DT_RNDM(UNON).GT.OHALF) THEN
14128 * x-fractions of projectile target partons
14130 XTH(1) = DT_DBETAR(OHALF,UNON)
14131 IF (XTH(1).GE.XVQTHR) GOTO 2
14132 XTH(2) = ONE-XTH(1)
14133 * x-fractions of Pomeron q-aq-pair
14136 XTPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14137 XTPO(2) = ONE-XTPO(1)
14138 * flavors of Pomeron q-aq-pair
14139 IFLAV = INT(ONE+DT_RNDM(XPOLO)*(2.0D0+SEASQ))
14142 IF (DT_RNDM(XPOLO).GT.OHALF) THEN
14151 *$ CREATE DT_LM2RES.FOR
14154 *===lm2res=============================================================*
14156 SUBROUTINE DT_LM2RES(IF1,IF2,XM,IDR,IDXR,IREJ)
14158 ************************************************************************
14159 * Check low-mass diffractive excitation for resonance mass. *
14160 * (input) IF1/2 PDG-indizes of valence partons *
14161 * (in/out) XM diffractive mass requested/corrected *
14162 * (output) IDR/IDXR id./BAMJET-index of resonance *
14163 * This version dated 12.02.95 is written by S. Roesler *
14164 ************************************************************************
14166 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14168 PARAMETER ( LINP = 10 ,
14171 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14173 * kinematics of diffractive interactions (DTUNUC 1.x)
14174 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14176 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14177 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14184 * BAMJET indices of partons
14185 IF1A = IDT_IPDG2B(IF1,1,2)
14186 IF (ABS(IF1).GE.1000) IF1B = IDT_IPDG2B(IF1,2,2)
14187 IF2A = IDT_IPDG2B(IF2,1,2)
14188 IF (ABS(IF2).GE.1000) IF2B = IDT_IPDG2B(IF2,2,2)
14190 * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq)
14192 IF ((IF1B.EQ.0).AND.(IF2B.EQ.0)) IDCH = 1
14194 * check for resonance mass
14195 CALL DT_CH2RES(IF1A,IF1B,IF2A,IF2B,IDR,IDXR,XMI,XMN,IDCH,IREJ1)
14196 IF (IREJ1.NE.0) GOTO 9999
14206 *$ CREATE DT_LMKINE.FOR
14209 *===lmkine=============================================================*
14211 SUBROUTINE DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ)
14213 ************************************************************************
14214 * Kinematical treatment of low-mass excitations. *
14215 * This version dated 12.02.95 is written by S. Roesler *
14216 ************************************************************************
14218 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14220 PARAMETER ( LINP = 10 ,
14223 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14225 * flags for input different options
14226 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14227 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14228 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14229 * kinematics of diffractive interactions (DTUNUC 1.x)
14230 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14232 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14233 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14235 DIMENSION P1(4),P2(4)
14240 PABS = SQRT(PPF(1)**2+PPF(2)**2+PPF(3)**2)
14242 FAC1 = OHALF*(POE+ONE)
14243 FAC2 = -OHALF*(POE-ONE)
14245 PPLM1(K) = FAC1*PPF(K)
14246 PPLM2(K) = FAC2*PPF(K)
14248 PPLM1(4) = FAC1*PABS
14249 PPLM2(4) = -FAC2*PABS
14250 IF (IMSHL.EQ.1) THEN
14253 CALL DT_MASHEL(PPLM1,PPLM2,XM1,XM2,P1,P2,IREJ1)
14254 IF (IREJ1.NE.0) GOTO 9999
14263 PABS = SQRT(PTF(1)**2+PTF(2)**2+PTF(3)**2)
14265 FAC1 = OHALF*(POE+ONE)
14266 FAC2 = -OHALF*(POE-ONE)
14268 PTLM2(K) = FAC1*PTF(K)
14269 PTLM1(K) = FAC2*PTF(K)
14271 PTLM2(4) = FAC1*PABS
14272 PTLM1(4) = -FAC2*PABS
14273 IF (IMSHL.EQ.1) THEN
14276 CALL DT_MASHEL(PTLM1,PTLM2,XM1,XM2,P1,P2,IREJ1)
14277 IF (IREJ1.NE.0) GOTO 9999
14288 WRITE(LOUT,'(A)') 'LMKINE: kinematical treatment rejected'
14293 *$ CREATE DT_DIFINI.FOR
14296 *===difini=============================================================*
14298 SUBROUTINE DT_DIFINI
14300 ************************************************************************
14301 * Initialization of common /DTDIKI/ *
14302 * This version dated 12.02.95 is written by S. Roesler *
14303 ************************************************************************
14305 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14307 PARAMETER ( LINP = 10 ,
14310 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14312 * kinematics of diffractive interactions (DTUNUC 1.x)
14313 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14315 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14316 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14344 *$ CREATE DT_DIFPUT.FOR
14347 *===difput=============================================================*
14349 SUBROUTINE DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,
14352 ************************************************************************
14353 * Dump diffractive chains into DTEVT1 *
14354 * This version dated 12.02.95 is written by S. Roesler *
14355 ************************************************************************
14357 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14359 PARAMETER ( LINP = 10 ,
14362 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14366 * kinematics of diffractive interactions (DTUNUC 1.x)
14367 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14369 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14370 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14372 PARAMETER (NMXHKK=200000)
14373 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14374 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14375 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14376 * extended event history
14377 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14378 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14380 * rejection counter
14381 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
14382 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
14383 & IREXCI(3),IRDIFF(2),IRINC
14385 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PCH(4),PP(4),PT(4),
14386 & P1(4),P2(4),P3(4),P4(4)
14392 PCH(K) = PPLM1(K)+PPLM2(K)
14396 IF (DT_RNDM(PT).GT.OHALF) THEN
14400 CALL DT_EVTPUT(21,ID1,MOP,0,PPLM1(1),PPLM1(2),PPLM1(3),
14402 CALL DT_EVTPUT(21,ID2,MOP,0,PPLM2(1),PPLM2(2),PPLM2(3),
14404 CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
14406 ELSEIF (KP.EQ.2) THEN
14408 PP1(K) = XPH(1)*PP(K)
14409 PP2(K) = XPH(2)*PP(K)
14410 PT1(K) = -XPPO(1)*PPOM(K)
14411 PT2(K) = -XPPO(2)*PPOM(K)
14413 CALL DT_CHKCSY(IFP1,IFPPO(1),LCHK)
14417 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
14418 IF (IREJ1.NE.0) GOTO 9999
14419 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
14420 IF (IREJ1.NE.0) GOTO 9999
14427 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
14429 CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
14431 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
14433 CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
14436 CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
14437 IF (IREJ1.NE.0) GOTO 9999
14438 CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
14439 IF (IREJ1.NE.0) GOTO 9999
14446 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
14448 CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
14450 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
14452 CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
14457 CALL DT_EVTPUT(1,IDHKK(MOP),MOP,0,PSC(1),PSC(2),PSC(3),PSC(4),
14463 PCH(K) = PTLM1(K)+PTLM2(K)
14467 IF (DT_RNDM(PT).GT.OHALF) THEN
14471 CALL DT_EVTPUT(22,ID1,MOT,0,PTLM1(1),PTLM1(2),PTLM1(3),
14473 CALL DT_EVTPUT(22,ID2,MOT,0,PTLM2(1),PTLM2(2),PTLM2(3),
14475 CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
14477 ELSEIF (KT.EQ.2) THEN
14479 PP1(K) = XTPO(1)*PPOM(K)
14480 PP2(K) = XTPO(2)*PPOM(K)
14481 PT1(K) = XTH(2)*PT(K)
14482 PT2(K) = XTH(1)*PT(K)
14484 CALL DT_CHKCSY(IFTPO(1),IFT1,LCHK)
14488 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
14489 IF (IREJ1.NE.0) GOTO 9999
14490 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
14491 IF (IREJ1.NE.0) GOTO 9999
14498 CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
14500 CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
14502 CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
14504 CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
14507 CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
14508 IF (IREJ1.NE.0) GOTO 9999
14509 CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
14510 IF (IREJ1.NE.0) GOTO 9999
14517 CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
14519 CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
14521 CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
14523 CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
14528 CALL DT_EVTPUT(1,IDHKK(MOT),MOT,0,PSC(1),PSC(2),PSC(3),PSC(4),
14535 IRDIFF(2) = IRDIFF(2)+1
14540 *$ CREATE DT_EVTFRG.FOR
14543 *===evtfrg=============================================================*
14545 SUBROUTINE DT_EVTFRG(KMODE,NFRG,NPYMEM,IREJ)
14547 ************************************************************************
14548 * Hadronization of chains in DTEVT1. *
14551 * KMODE = 1 hadronization of PHOJET-chains (id=77xxx) *
14552 * = 2 hadronization of DTUNUC-chains (id=88xxx) *
14553 * NFRG if KMODE = 1 : upper index of PHOJET-scatterings to be *
14554 * hadronized with one PYEXEC call *
14555 * if KMODE = 2 : max. number of DTUNUC-chains to be hadronized *
14556 * with one PYEXEC call *
14558 * NPYMEM number of entries in JETSET-common after hadronization *
14559 * IREJ rejection flag *
14561 * This version dated 17.09.00 is written by S. Roesler *
14562 ************************************************************************
14564 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14566 PARAMETER ( LINP = 10 ,
14569 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1)
14570 PARAMETER (ONE=1.0D0,ZERO=0.0D0)
14574 PARAMETER (MXJOIN=200)
14577 PARAMETER (NMXHKK=200000)
14578 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14579 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14580 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14581 * extended event history
14582 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14583 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14585 * flags for input different options
14586 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14587 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14588 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14590 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
14591 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
14593 * flags for diffractive interactions (DTUNUC 1.x)
14594 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
14595 * nucleon-nucleon event-generator
14598 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
14600 C model switches and parameters
14602 INTEGER ISWMDL,IPAMDL
14603 DOUBLE PRECISION PARMDL
14604 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14606 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14607 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
14608 PARAMETER (MAXLND=4000)
14609 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
14611 DIMENSION IJOIN(MXJOIN),ISJOIN(MXJOIN),IHISMO(8000),IFLG(4000)
14615 IF (MODE.NE.1) ISTSTG = 8
14624 IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
14625 DO 10 I=NPOINT(3),NEND
14626 * sr 14.02.00: seems to be not necessary anymore, commented
14627 C LACCEP = ((NOBAM(I).EQ.0).AND.(MODE.EQ.1)).OR.
14628 C & ((NOBAM(I).NE.0).AND.(MODE.EQ.2))
14630 * pick up chains from dtevt1
14631 IDCHK = IDHKK(I)/10000
14632 IF ((IDCHK.EQ.ISTSTG).AND.LACCEP) THEN
14633 IF (IDCHK.EQ.7) THEN
14634 IPJE = IDHKK(I)-IDCHK*10000
14635 IF (IPJE.NE.IFRG) THEN
14637 IF (IFRG.GT.NFRG) GOTO 16
14642 IF (IFRG.GT.NFRG) THEN
14647 * statistics counter
14648 c IF (IDCH(I).LE.8)
14649 c & ICCHAI(2,IDCH(I)) = ICCHAI(2,IDCH(I))+1
14650 c IF (IDRES(I).NE.0) ICRES(IDCH(I)) = ICRES(IDCH(I))+1
14651 * special treatment for small chains already corrected to hadrons
14652 IF (IDRES(I).NE.0) THEN
14653 IF (IDRES(I).EQ.11) THEN
14656 ID = IDT_IPDGHA(IDXRES(I))
14659 CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
14660 & PHKK(4,I),INIEMC,IDUM,IDUM)
14664 IF (IP.GT.MSTU(4)) STOP ' NEWFRA 1: IP.GT.MSTU(4) !'
14665 P(IP,1) = PHKK(1,I)
14666 P(IP,2) = PHKK(2,I)
14667 P(IP,3) = PHKK(3,I)
14668 P(IP,4) = PHKK(4,I)
14669 P(IP,5) = PHKK(5,I)
14675 IHIST(2,I) = 10000*IPJE+IP
14676 IF (IHIST(1,I).LE.-100) THEN
14678 IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
14685 DO 11 KK=JMOHKK(1,I),JMOHKK(2,I)
14687 CALL DT_EVTEMC(PHKK(1,KK),PHKK(2,KK),PHKK(3,KK),
14688 & PHKK(4,KK),INIEMC,IDUM,IDUM)
14689 CALL DT_EVTFLC(IDHKK(KK),1,INIEMC,IDUM,IDUM)
14693 IF (ID.EQ.0) ID = 21
14694 c PTOT = SQRT(PHKK(1,KK)**2+PHKK(2,KK)**2+PHKK(3,KK)**2)
14695 c AM0 = SQRT(ABS((PHKK(4,KK)-PTOT)*(PHKK(4,KK)+PTOT)))
14696 c AMRQ = PYMASS(ID)
14697 c AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
14698 c IF ((ABS(AMDIF2).GT.TINY3).AND.(PTOT.GT.ZERO).AND.
14699 c & (ABS(IDIFF).EQ.0)) THEN
14700 cC WRITE(LOUT,*)'here: ',NEVHKK,AM0,AMRQ
14701 c DELTA = -AMDIF2/(2.0D0*(PHKK(4,KK)+PTOT))
14702 c PHKK(4,KK) = PHKK(4,KK)+DELTA
14703 c PTOT1 = PTOT-DELTA
14704 c PHKK(1,KK) = PHKK(1,KK)*PTOT1/PTOT
14705 c PHKK(2,KK) = PHKK(2,KK)*PTOT1/PTOT
14706 c PHKK(3,KK) = PHKK(3,KK)*PTOT1/PTOT
14707 c PHKK(5,KK) = AMRQ
14710 IF (IP.GT.MSTU(4)) STOP ' NEWFRA 2: IP.GT.MSTU(4) !'
14711 P(IP,1) = PHKK(1,KK)
14712 P(IP,2) = PHKK(2,KK)
14713 P(IP,3) = PHKK(3,KK)
14714 P(IP,4) = PHKK(4,KK)
14715 P(IP,5) = PHKK(5,KK)
14721 IHIST(2,KK) = 10000*IPJE+IP
14722 IF (IHIST(1,KK).LE.-100) THEN
14724 IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
14728 IF (IJ.GT.MXJOIN) STOP 'IJ > MXJOIN !'
14733 * join the two-parton system
14734 CALL PYJOIN(IJ,IJOIN)
14744 * final state parton shower
14746 IF ((MCGENE.EQ.2).AND.(ISH.GE.2)) THEN
14747 IF ((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
14749 IF (ISJOIN(K1).EQ.0) GOTO 130
14751 IF ((IPAMDL(102).EQ.1).AND.(IHIST(1,I).NE.-100))
14753 IH1 = IHIST(2,I)/10000
14754 IF (IH1.NE.NPJE) GOTO 130
14755 IH1 = IHIST(2,I)-IH1*10000
14757 IF (ISJOIN(K2).EQ.0) GOTO 135
14759 IH2 = IHIST(2,II)/10000
14760 IF (IH2.NE.NPJE) GOTO 135
14761 IH2 = IHIST(2,II)-IH2*10000
14762 IF (IHIST(1,I).EQ.IHIST(1,II)) THEN
14763 PT1 = SQRT(PHKK(1,II)**2+PHKK(2,II)**2)
14764 PT2 = SQRT(PHKK(1, I)**2+PHKK(2, I)**2)
14765 RQLUN = MIN(PT1,PT2)
14766 CALL PYSHOW(IH1,IH2,RQLUN)
14778 CALL DT_INITJS(MODE)
14783 IF (MSTU(24).NE.0) THEN
14784 WRITE(LOUT,*) ' JETSET-reject at event',
14785 & NEVHKK,MSTU(24),KMODE
14786 C CALL DT_EVTOUT(4)
14793 * number of entries in LUJETS
14805 IF ((PYK(II,7).EQ.1).AND.(IFLG(II).NE.1)) THEN
14807 * pick up mother resonance if possible and put it together with
14808 * their decay-products into the common
14810 IF ((IDXMOR.GE.1).AND.(IDXMOR.LE.MAXLND)) THEN
14811 KFMOR = K(IDXMOR,2)
14812 ISMOR = K(IDXMOR,1)
14817 IF ((KFMOR.NE.91).AND.(KFMOR.NE.92).AND.
14818 & (KFMOR.NE.94).AND.(ISMOR.EQ.11)) THEN
14820 MO = IHISMO(PYK(IDXMOR,15))
14825 CALL DT_EVTPUT(2,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14828 DO 15 JDAUG=K(IDXMOR,4),K(IDXMOR,5)
14829 IF (PYK(JDAUG,7).EQ.1) THEN
14835 CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14841 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
14847 * there was no mother resonance
14848 MO = IHISMO(PYK(II,15))
14854 CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14860 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
14867 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,6,IREJ1)
14868 C IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
14871 * global energy-momentum & flavor conservation check
14872 **sr 16.5. this check is skipped in case of phojet-treatment
14874 & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,12,IREJ3)
14876 * update statistics-counter for diffraction
14877 c IF (IFLAGD.NE.0) THEN
14878 c ICDIFF(1) = ICDIFF(1)+1
14879 c IF (IFLAGD.EQ. 1) ICDIFF(2) = ICDIFF(2)+1
14880 c IF (IFLAGD.EQ. 2) ICDIFF(3) = ICDIFF(3)+1
14881 c IF (IFLAGD.EQ.-1) ICDIFF(4) = ICDIFF(4)+1
14882 c IF (IFLAGD.EQ.-2) ICDIFF(5) = ICDIFF(5)+1
14894 *$ CREATE DT_DECAYS.FOR
14897 *===decay==============================================================*
14899 SUBROUTINE DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
14901 ************************************************************************
14902 * Resonance-decay. *
14903 * This subroutine replaces DDECAY/DECHKK. *
14904 * PIN(4) 4-momentum of resonance (input) *
14905 * IDXIN BAMJET-index of resonance (input) *
14906 * POUT(20,4) 4-momenta of decay-products (output) *
14907 * IDXOUT(20) BAMJET-indices of decay-products (output) *
14908 * NSEC number of secondaries (output) *
14909 * Adopted from the original version DECHKK. *
14910 * This version dated 09.01.95 is written by S. Roesler *
14911 ************************************************************************
14913 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14915 PARAMETER ( LINP = 10 ,
14918 PARAMETER (TINY17=1.0D-17)
14920 * HADRIN: decay channel information
14921 PARAMETER (IDMAX9=602)
14923 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
14924 * particle properties (BAMJET index convention)
14926 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
14927 & IICH(210),IIBAR(210),K1(210),K2(210)
14928 * flags for input different options
14929 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14930 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14931 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14933 DIMENSION PIN(4),PI(20,4),POUT(20,4),IDXOUT(20),
14934 & EF(3),PF(3),PFF(3),IDXSTK(20),IDX(3),
14935 & CODF(3),COFF(3),SIFF(3),DCOS(3),DCOSF(3)
14937 * ISTAB = 1 strong and weak decays
14938 * = 2 strong decays only
14939 * = 3 strong decays, weak decays for charmed particles and tau
14945 * put initial resonance to stack
14947 IDXSTK(NSTK) = IDXIN
14949 PI(NSTK,I) = PIN(I)
14952 * store initial configuration for energy-momentum cons. check
14953 IF (LEMCCK) CALL DT_EVTEMC(PI(NSTK,1),PI(NSTK,2),PI(NSTK,3),
14954 & PI(NSTK,4),1,IDUM,IDUM)
14957 * get particle from stack
14958 IDXI = IDXSTK(NSTK)
14959 * skip stable particles
14960 IF (ISTAB.EQ.1) THEN
14961 IF ((IDXI.EQ.135).OR. (IDXI.EQ.136)) GOTO 10
14962 IF ((IDXI.GE. 1).AND.(IDXI.LE. 7)) GOTO 10
14963 ELSEIF (ISTAB.EQ.2) THEN
14964 IF ((IDXI.GE. 1).AND.(IDXI.LE. 30)) GOTO 10
14965 IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
14966 IF ((IDXI.GE.115).AND.(IDXI.LE.122)) GOTO 10
14967 IF ((IDXI.GE.131).AND.(IDXI.LE.136)) GOTO 10
14968 IF ( IDXI.EQ.109) GOTO 10
14969 IF ((IDXI.GE.137).AND.(IDXI.LE.160)) GOTO 10
14970 ELSEIF (ISTAB.EQ.3) THEN
14971 IF ((IDXI.GE. 1).AND.(IDXI.LE. 23)) GOTO 10
14972 IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
14973 IF ((IDXI.GE.109).AND.(IDXI.LE.115)) GOTO 10
14974 IF ((IDXI.GE.133).AND.(IDXI.LE.136)) GOTO 10
14977 * calculate direction cosines and Lorentz-parameter of decaying part.
14978 PTOT = SQRT(PI(NSTK,1)**2+PI(NSTK,2)**2+PI(NSTK,3)**2)
14979 PTOT = MAX(PTOT,TINY17)
14981 DCOS(I) = PI(NSTK,I)/PTOT
14983 GAM = PI(NSTK,4)/AAM(IDXI)
14984 BGAM = PTOT/AAM(IDXI)
14986 * get decay-channel
14990 IF ((DT_RNDM(GAM)-TINY17).GT.WT(KCHAN)) GOTO 2
14992 * identities of secondaries
14993 IDX(1) = NZK(KCHAN,1)
14994 IDX(2) = NZK(KCHAN,2)
14995 IF (IDX(2).LT.1) GOTO 9999
14996 IDX(3) = NZK(KCHAN,3)
14998 * handle decay in rest system of decaying particle
14999 IF (IDX(3).EQ.0) THEN
15000 * two-particle decay
15002 CALL DT_DTWOPD(AAM(IDXI),EF(1),EF(2),PF(1),PF(2),
15003 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
15004 & AAM(IDX(1)),AAM(IDX(2)))
15006 * three-particle decay
15008 CALL DT_DTHREP(AAM(IDXI),EF(1),EF(2),EF(3),PF(1),PF(2),PF(3),
15009 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
15010 & CODF(3),COFF(3),SIFF(3),
15011 & AAM(IDX(1)),AAM(IDX(2)),AAM(IDX(3)))
15015 * transform decay products back
15018 CALL DT_DTRAFO(GAM,BGAM,DCOS(1),DCOS(2),DCOS(3),
15019 & CODF(I),COFF(I),SIFF(I),PF(I),EF(I),
15020 & PFF(I),DCOSF(1),DCOSF(2),DCOSF(3),PI(NSTK,4))
15021 * add particle to stack
15022 IDXSTK(NSTK) = IDX(I)
15024 PI(NSTK,J) = DCOSF(J)*PFF(I)
15030 * stable particle, put to output-arrays
15033 POUT(NSEC,I) = PI(NSTK,I)
15035 IDXOUT(NSEC) = IDXSTK(NSTK)
15036 * store secondaries for energy-momentum conservation check
15038 &CALL DT_EVTEMC(-POUT(NSEC,1),-POUT(NSEC,2),-POUT(NSEC,3),
15039 & -POUT(NSEC,4),2,IDUM,IDUM)
15041 IF (NSTK.GT.0) GOTO 100
15043 * check energy-momentum conservation
15045 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,5,IREJ1)
15046 IF (IREJ1.NE.0) GOTO 9999
15056 *$ CREATE DT_DECAY1.FOR
15059 *===decay1=============================================================*
15061 SUBROUTINE DT_DECAY1
15063 ************************************************************************
15064 * Decay of resonances stored in DTEVT1. *
15065 * This version dated 20.01.95 is written by S. Roesler *
15066 ************************************************************************
15068 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15070 PARAMETER ( LINP = 10 ,
15075 PARAMETER (NMXHKK=200000)
15076 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15077 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15078 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15079 * extended event history
15080 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15081 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15084 DIMENSION PIN(4),POUT(20,4),IDXOUT(20)
15087 C DO 1 I=NPOINT(5),NEND
15088 DO 1 I=NPOINT(4),NEND
15089 IF (ABS(ISTHKK(I)).EQ.1) THEN
15094 CALL DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
15095 IF (NSEC.GT.1) THEN
15097 IDHAD = IDT_IPDGHA(IDXOUT(N))
15098 CALL DT_EVTPUT(1,IDHAD,I,0,POUT(N,1),POUT(N,2),
15099 & POUT(N,3),POUT(N,4),0,0,0)
15108 *$ CREATE DT_DECPI0.FOR
15111 *===decpi0=============================================================*
15113 SUBROUTINE DT_DECPI0
15115 ************************************************************************
15116 * Decay of pi0 handled with JETSET. *
15117 * This version dated 18.02.96 is written by S. Roesler *
15118 ************************************************************************
15120 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15122 PARAMETER ( LINP = 10 ,
15125 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0,ZERO=0.0D0)
15128 PARAMETER (NMXHKK=200000)
15129 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15130 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15131 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15132 * extended event history
15133 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15134 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15136 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
15137 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15138 PARAMETER (MAXLND=4000)
15139 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
15140 * flags for input different options
15141 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15142 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15143 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15147 DIMENSION IHISMO(NMXHKK),P1(4)
15149 TWOPI = 2.0D0*ATAN2(0.0D0,-1.0D0)
15159 IF ((ISTHKK(I).EQ.1).AND.(IDHKK(I).EQ.111)) THEN
15165 IF (LEMCCK) CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
15166 & PHKK(4,I),INI,IDUM,IDUM)
15167 PT = SQRT(PHKK(1,I)**2+PHKK(2,I)**2)
15168 PTOT = SQRT(PT**2+PHKK(3,I)**2)
15169 COSTH = PHKK(3,I)/(PTOT+TINY10)
15170 IF (COSTH.GT.ONE) THEN
15172 ELSEIF (COSTH.LT.-ONE) THEN
15173 THETA = TWOPI/2.0D0
15175 THETA = ACOS(COSTH)
15177 PHI = ASIN(PHKK(2,I)/(PT +TINY10))
15178 IF (PHKK(1,I).LT.0.0D0)
15179 & PHI = SIGN(TWOPI/2.0D0-ABS(PHI),PHI)
15184 P(NN,5) = PHKK(5,I)
15185 CALL PY1ENT(NN,111,ENER,THETA,PHI)
15194 IF (PYK(II,7).EQ.1) THEN
15196 P1(KK) = PYP(II,KK)
15199 MO = IHISMO(PYK(II,15))
15200 CALL DT_EVTPUT(1,ID,MO,0,P1(1),P1(2),P1(3),P1(4),0,0,0)
15202 & CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,
15204 *sr: flag with neg. sign (for HELIOS p/A-W jobs)
15208 IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,7000,IREJ1)
15215 *$ CREATE DT_DTWOPD.FOR
15218 *===dtwopd=============================================================*
15220 SUBROUTINE DT_DTWOPD(UMO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,COD2,
15221 & COF2,SIF2,AM1,AM2)
15223 ************************************************************************
15224 * Two-particle decay. *
15225 * UMO cm-energy of the decaying system (input) *
15226 * AM1/AM2 masses of the decay products (input) *
15227 * ECM1,ECM2/PCM1,PCM2 cm-energies/momenta of the decay prod. (output) *
15228 * COD,COF,SIF direction cosines of the decay prod. (output) *
15229 * Revised by S. Roesler, 20.11.95 *
15230 ************************************************************************
15232 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15234 PARAMETER ( LINP = 10 ,
15237 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,ZERO=0.0D0)
15239 IF (UMO.LT.(AM1+AM2)) THEN
15240 WRITE(LOUT,1000) UMO,AM1,AM2
15241 1000 FORMAT(1X,'DTWOPD: inconsistent kinematics - UMO,AM1,AM2 ',
15246 ECM1 = ((UMO-AM2)*(UMO+AM2)+AM1*AM1)/(TWO*UMO)
15248 PCM1 = SQRT((ECM1-AM1)*(ECM1+AM1))
15250 CALL DT_DSFECF(SIF1,COF1)
15251 COD1 = TWO*DT_RNDM(PCM2)-ONE
15259 *$ CREATE DT_DTHREP.FOR
15262 *===dthrep=============================================================*
15264 SUBROUTINE DT_DTHREP(UMO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,
15265 & SIF1,COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
15267 ************************************************************************
15268 * Three-particle decay. *
15269 * UMO cm-energy of the decaying system (input) *
15270 * AM1/2/3 masses of the decay products (input) *
15271 * ECM1/2/2,PCM1/2/3 cm-energies/momenta of the decay prod. (output) *
15272 * COD,COF,SIF direction cosines of the decay prod. (output) *
15274 * Threpd89: slight revision by A. Ferrari *
15275 * Last change on 11-oct-93 by Alfredo Ferrari, INFN - Milan *
15276 * Revised by S. Roesler, 20.11.95 *
15277 ************************************************************************
15279 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15281 PARAMETER ( LINP = 10 ,
15285 PARAMETER ( ANGLSQ = 2.5D-31 )
15286 PARAMETER ( AZRZRZ = 1.0D-30 )
15287 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
15288 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
15289 PARAMETER ( ONEONE = 1.D+00 )
15290 PARAMETER ( TWOTWO = 2.D+00 )
15291 PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
15293 COMMON /HNGAMR/ REDU,AMO,AMM(15)
15294 * flags for input different options
15295 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15296 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15297 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15299 DIMENSION F(5),XX(5)
15303 C***S1, S2, S3 ARE THE INVARIANT MASSES OF THE PARTICLES 1, 2, 3
15304 C***J. VON NEUMANN - RANDOM - SELECTION OF S2
15305 C***CALCULATION OF THE MAXIMUM OF THE S2 - DISTRIBUTION
15312 * UFAK=1.0000000000001D0
15313 * IF (GU.GT.GO) UFAK=0.9999999999999D0
15331 S22=GU+(I-1.D0)*DS2
15333 RHO2=DT_YLAMB(S22,UMO2,AM11)*DT_YLAMB(S22,AM22,AM33)/
15335 IF(RHO2.LT.RHO1) GO TO 125
15337 125 S2SUP=(S22-S21)*.5D0+S21
15338 SUPRHO=DT_YLAMB(S2SUP,UMO2,AM11)*DT_YLAMB(S2SUP,AM22,AM33)/
15340 SUPRHO=SUPRHO*1.05D0
15342 IF (GU.LT.GO.AND.XO.LT.GU) XO=GU
15343 IF (GU.GT.GO.AND.XO.GT.GU) XO=GU
15349 F(1)=DT_YLAMB(XO,UMO2,AM11)*DT_YLAMB(XO,AM22,AM33)/(XO+EPS)
15350 F(2)=DT_YLAMB(X1,UMO2,AM11)*DT_YLAMB(X1,AM22,AM33)/(X1+EPS)
15352 X4=(XX(1)+XX(2))*0.5D0
15353 X5=(XX(2)+XX(3))*0.5D0
15354 F(4)=DT_YLAMB(X4,UMO2,AM11)*DT_YLAMB(X4,AM22,AM33)/
15356 F(5)=DT_YLAMB(X5,UMO2,AM11)*DT_YLAMB(X5,AM22,AM33)/
15363 IF (F (II).GE.F (III)) GO TO 128
15376 IF (XX(II).GE.XX(III)) GO TO 129
15390 IF (ITH.GT.200) REDU=-9.D0
15391 IF (ITH.GT.200) GO TO 400
15393 * S2=AM23+C*((UMO-AM1)**2-AM23)
15394 S2=AM23+C*(UMO-AM1-AM2-AM3)*(UMO-AM1+AM2+AM3)
15397 RHO=DT_YLAMB(S2,UMO2,AM11)*DT_YLAMB(S2,AM22,AM33)/S2
15398 IF(Y.GT.RHO) GO TO 1
15399 C***RANDOM SELECTION OF S3 AND CALCULATION OF S1
15401 S1=S1*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)/(2.D0*S2)-
15403 S3=UMO2+AM11+AM22+AM33-S1-S2
15404 ECM1=(UMO2+AM11-S2)/UMOO
15405 ECM2=(UMO2+AM22-S3)/UMOO
15406 ECM3=(UMO2+AM33-S1)/UMOO
15407 PCM1=SQRT((ECM1+AM1)*(ECM1-AM1))
15408 PCM2=SQRT((ECM2+AM2)*(ECM2-AM2))
15409 PCM3=SQRT((ECM3+AM3)*(ECM3-AM3))
15410 CALL DT_DSFECF(SFE,CFE)
15411 C***TH IS THE ANGLE BETWEEN PARTICLES 1 AND 2
15412 C***TH1, TH2 ARE THE ANGLES BETWEEN PARTICLES 1, 2 AND THE DIRECTION OF
15413 PCM12 = PCM1 * PCM2
15414 IF ( PCM12 .LT. ANGLSQ ) GO TO 200
15415 COSTH=(ECM1*ECM2+0.5D+00*(AM11+AM22-S1))/PCM12
15419 COSTH=(UW-0.5D+00)*2.D+00
15421 * IF(ABS(COSTH).GT.0.9999999999999999D0)
15422 * &COSTH=SIGN(0.9999999999999999D0,COSTH)
15423 IF(ABS(COSTH).GT.ONEONE)
15424 &COSTH=SIGN(ONEONE,COSTH)
15425 IF (REDU.LT.1.D+00) RETURN
15426 COSTH2=(PCM3*PCM3+PCM2*PCM2-PCM1*PCM1)/(2.D+00*PCM2*PCM3)
15427 * IF(ABS(COSTH2).GT.0.9999999999999999D0)
15428 * &COSTH2=SIGN(0.9999999999999999D0,COSTH2)
15429 IF(ABS(COSTH2).GT.ONEONE)
15430 &COSTH2=SIGN(ONEONE,COSTH2)
15431 SINTH2=SQRT((ONEONE-COSTH2)*(ONEONE+COSTH2))
15432 SINTH =SQRT((ONEONE-COSTH)*(ONEONE+COSTH))
15433 SINTH1=COSTH2*SINTH-COSTH*SINTH2
15434 COSTH1=COSTH*COSTH2+SINTH2*SINTH
15435 C***RANDOM SELECTION OF THE SPHERICAL COORDINATES OF THE DIRECTION OF PA
15436 C***CFE, SFE ARE COS AND SIN OF THE ROTATION ANGLE OF THE SYSTEM 1, 2 AR
15437 C***THE DIRECTION OF PARTICLE 3
15438 C***CALCULATION OF THE SPHERICAL COORDINATES OF PARTICLES 1, 2
15445 CALL DT_DSFECF(SIF3,COF3)
15446 COD3=TWOTWO*DT_RNDM(CX11)-ONEONE
15447 SID3=SQRT((1.D+00-COD3)*(1.D+00+COD3))
15449 COD1=CX11*COD3+CZ11*SID3
15450 CHLP=(ONEONE-COD1)*(ONEONE+COD1)
15451 IF(CHLP.LT.1.D-14)WRITE(LOUT,2)COD1,COF3,SID3,
15454 COF1=(CX11*SID3*COF3-CY11*SIF3-CZ11*COD3*COF3)/SID1
15455 SIF1=(CX11*SID3*SIF3+CY11*COF3-CZ11*COD3*SIF3)/SID1
15456 COD2=CX22*COD3+CZ22*SID3
15457 SID2=SQRT((ONEONE-COD2)*(ONEONE+COD2))
15458 COF2=(CX22*SID3*COF3-CY22*SIF3-CZ22*COD3*COF3)/SID2
15459 SIF2=(CX22*SID3*SIF3+CY22*COF3-CZ22*COD3*SIF3)/SID2
15461 * === Energy conservation check: === *
15462 EOCHCK = UMO - ECM1 - ECM2 - ECM3
15463 * SID1 = SQRT ( ( ONEONE - COD1 ) * ( ONEONE + COD1 ) )
15464 * SID2 = SQRT ( ( ONEONE - COD2 ) * ( ONEONE + COD2 ) )
15465 * SID3 = SQRT ( ( ONEONE - COD3 ) * ( ONEONE + COD3 ) )
15466 PZCHCK = PCM1 * COD1 + PCM2 * COD2 + PCM3 * COD3
15467 PXCHCK = PCM1 * COF1 * SID1 + PCM2 * COF2 * SID2
15468 & + PCM3 * COF3 * SID3
15469 PYCHCK = PCM1 * SIF1 * SID1 + PCM2 * SIF2 * SID2
15470 & + PCM3 * SIF3 * SID3
15471 EOCMPR = 1.D-12 * UMO
15472 IF ( ABS (EOCHCK) + ABS (PXCHCK) + ABS (PYCHCK) + ABS (PZCHCK)
15473 & .GT. EOCMPR ) THEN
15474 **sr 5.5.95 output-unit changed
15475 IF (IOULEV(1).GT.0) THEN
15477 & ' *** Threpd: energy/momentum conservation failure! ***',
15478 & EOCHCK,PXCHCK,PYCHCK,PZCHCK
15479 WRITE(LOUT,*)' *** SID1,SID2,SID3',SID1,SID2,SID3
15486 *$ CREATE DT_DBKLAS.FOR
15489 *===dbklas=============================================================*
15491 SUBROUTINE DT_DBKLAS(I,J,K,I8,I10)
15493 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15495 PARAMETER ( LINP = 10 ,
15499 * quark-content to particle index conversion (DTUNUC 1.x)
15500 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
15501 & IA08(6,21),IA10(6,21)
15506 CALL DT_INDEXD(J,K,IND)
15509 IF (I8.LE.0) I8 = I10
15516 CALL DT_INDEXD(JJ,KK,IND)
15519 IF (I8.LE.0) I8 = I10
15524 *$ CREATE DT_INDEXD.FOR
15527 *===indexd=============================================================*
15529 SUBROUTINE DT_INDEXD(KA,KB,IND)
15531 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15533 PARAMETER ( LINP = 10 ,
15542 IF ((KP.EQ.4).AND.(KS.EQ.5)) IND=4
15544 IF ((KP.EQ.6).AND.(KS.EQ.7)) IND=6
15545 IF ((KP.EQ.4).AND.(KS.EQ.4)) IND=7
15546 IF ((KP.EQ.6).AND.(KS.EQ.5)) IND=8
15548 IF (KP.EQ.10) IND=10
15549 IF ((KP.EQ.12).AND.(KS.EQ.8)) IND=11
15550 IF (KP.EQ.9) IND=12
15551 IF ((KP.EQ.12).AND.(KS.EQ.7)) IND=13
15552 IF (KP.EQ.15) IND=14
15553 IF (KP.EQ.18) IND=15
15554 IF (KP.EQ.16) IND=16
15555 IF (KP.EQ.20) IND=17
15556 IF (KP.EQ.24) IND=18
15557 IF (KP.EQ.25) IND=19
15558 IF (KP.EQ.30) IND=20
15559 IF (KP.EQ.36) IND=21
15564 *$ CREATE DT_DCHANT.FOR
15567 *===dchant=============================================================*
15569 SUBROUTINE DT_DCHANT
15571 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15573 PARAMETER ( LINP = 10 ,
15576 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15578 * HADRIN: decay channel information
15579 PARAMETER (IDMAX9=602)
15581 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
15582 * particle properties (BAMJET index convention)
15584 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
15585 & IICH(210),IIBAR(210),K1(210),K2(210)
15587 DIMENSION HWT(IDMAX9)
15589 * change of weights wt from absolut values into the sum of wt of a dec.
15594 C WRITE(LOUT,'(A8,F5.2,2E10.3,2I4,2I10)')
15595 C & ANAME(KKK),AAM(KKK),GA(KKK),TAU(KKK),IICH(KKK),IIBAR(KKK),
15596 C & K1(KKK),K2(KKK)
15607 IF (HWT(J).GT.1.0001) WRITE(LOUT,1000) HWT(J),J,I,IK1
15608 1000 FORMAT(2X,15H ERROR IN HWT =,1F10.5,8H J,I,K1=,3I5)
15618 *$ CREATE DT_DDATAR.FOR
15621 *===ddatar=============================================================*
15623 SUBROUTINE DT_DDATAR
15625 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15627 PARAMETER ( LINP = 10 ,
15630 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15632 * quark-content to particle index conversion (DTUNUC 1.x)
15633 COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
15634 & IA08(6,21),IA10(6,21)
15636 DIMENSION IV(36),IP(36),IB(126),IBB(126),IA(126),IAA(126)
15638 DATA IV/ 33, 34, 38,123, 0, 0, 32, 33, 39,124,
15639 & 0, 0, 36, 37, 96,127, 0, 0,126,125,
15641 DATA IP/ 23, 14, 16,116, 0, 0, 13, 23, 25,117,
15642 & 0, 0, 15, 24, 31,120, 0, 0,119,118,
15644 DATA IB/ 0, 1, 21,140, 0, 0, 8, 22,137, 0,
15645 & 0, 97,138, 0, 0,146, 0, 0, 0, 0,
15646 & 0, 1, 8, 22,137, 0, 0, 0, 20,142,
15647 & 0, 0, 98,139, 0, 0,147, 0, 0, 0,
15648 & 0, 0, 21, 22, 97,138, 0, 0, 20, 98,
15649 & 139, 0, 0, 0,145, 0, 0,148, 0, 0,
15650 & 0, 0, 0,140,137,138,146, 0, 0,142,
15651 & 139,147, 0, 0,145,148, 50*0/
15652 DATA IBB/53, 54,104,161, 0, 0, 55,105,162, 0,
15653 & 0,107,164, 0, 0,167, 0, 0, 0, 0,
15654 & 0, 54, 55,105,162, 0, 0, 56,106,163,
15655 & 0, 0,108,165, 0, 0,168, 0, 0, 0,
15656 & 0, 0,104,105,107,164, 0, 0,106,108,
15657 & 165, 0, 0,109,166, 0, 0,169, 0, 0,
15658 & 0, 0, 0,161,162,164,167, 0, 0,163,
15659 & 165,168, 0, 0,166,169, 0, 0,170,47*0/
15660 DATA IA/ 0, 2, 99,152, 0, 0, 9,100,149, 0,
15661 & 0,102,150, 0, 0,158, 0, 0, 0, 0,
15662 & 0, 2, 9,100,149, 0, 0, 0,101,154,
15663 & 0, 0,103,151, 0, 0,159, 0, 0, 0,
15664 & 0, 0, 99,100,102,150, 0, 0,101,103,
15665 & 151, 0, 0, 0,157, 0, 0,160, 0, 0,
15666 & 0, 0, 0,152,149,150,158, 0, 0,154,
15667 & 151,159, 0, 0,157,160, 50*0/
15668 DATA IAA/67, 68,110,171, 0, 0, 69,111,172, 0,
15669 & 0,113,174, 0, 0,177, 0, 0, 0, 0,
15670 & 0, 68, 69,111,172, 0, 0, 70,112,173,
15671 & 0, 0,114,175, 0, 0,178, 0, 0, 0,
15672 & 0, 0,110,111,113,174, 0, 0,112,114,
15673 & 175, 0, 0,115,176, 0, 0,179, 0, 0,
15674 & 0, 0, 0,171,172,174,177, 0, 0,173,
15675 & 175,178, 0, 0,176,179, 0, 0,180,47*0/
15711 *$ CREATE DT_INITJS.FOR
15714 *===initjs=============================================================*
15716 SUBROUTINE DT_INITJS(MODE)
15718 ************************************************************************
15719 * Initialize JETSET paramters. *
15720 * MODE = 0 default settings *
15721 * = 1 PHOJET settings *
15722 * = 2 DTUNUC settings *
15723 * This version dated 16.02.96 is written by S. Roesler *
15725 * Last change 27.12.2006 by S. Roesler. *
15726 ************************************************************************
15728 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15730 PARAMETER ( LINP = 10 ,
15733 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15735 LOGICAL LFIRST,LFIRDT,LFIRPH
15737 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15738 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15739 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
15740 * flags for particle decays
15741 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
15742 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
15743 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
15744 * flags for input different options
15745 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15746 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15747 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15751 DIMENSION IDXSTA(40)
15753 * K0s pi0 lam alam sig+ asig+ sig- asig- tet0 atet0
15754 & / 310, 111, 3122,-3122, 3222,-3222, 3112,-3112, 3322,-3322,
15755 * tet- atet- om- aom- D+ D- D0 aD0 Ds+ aDs+
15756 & 3312,-3312, 3334,-3334, 411, -411, 421, -421, 431, -431,
15757 * etac lamc+alamc+sigc++ sigc+ sigc0asigc++asigc+asigc0 Ksic+
15758 & 441, 4122,-4122, 4222, 4212, 4112,-4222,-4212,-4112, 4232,
15759 * Ksic0 aKsic+aKsic0 sig0 asig0
15760 & 4132,-4232,-4132, 3212,-3212, 5*0/
15762 DATA LFIRST,LFIRDT,LFIRPH /.TRUE.,.TRUE.,.TRUE./
15765 * save default settings
15777 * LUJETS / PYJETS array-dimensions
15779 * increase maximum number of JETSET-error prints
15781 * prevent particles decaying
15784 KC = PYCOMP(IDXSTA(I))
15791 C ELSEIF ((I.EQ.4).OR.(I.EQ. 6).OR.
15792 C & (I.EQ.8).OR.(I.EQ.10)) THEN
15793 C ELSEIF (I.EQ.4) THEN
15797 C AM MDCY(KC,1) = 0
15800 ELSEIF (((I.EQ.34).OR.(I.EQ.35)).AND.(ISIG0.EQ.0)) THEN
15801 KC = PYCOMP(IDXSTA(I))
15803 C AM MDCY(KC,1) = 0
15810 IF (PDB.LE.ZERO) THEN
15811 * no popcorn-mechanism
15817 * set JETSET-parameter requested by input cards
15818 IF (NMSTU.GT.0) THEN
15820 MSTU(IMSTU(I)) = MSTUX(I)
15823 IF (NMSTJ.GT.0) THEN
15825 MSTJ(IMSTJ(I)) = MSTJX(I)
15828 IF (NPARU.GT.0) THEN
15830 PARU(IPARU(I)) = PARUX(I)
15836 * PARJ(1) suppression of qq-aqaq pair prod. compared to
15837 * q-aq pair prod. (default: 0.1)
15838 * PARJ(2) strangeness suppression (default: 0.3)
15839 * PARJ(3) extra suppression of strange diquarks (default: 0.4)
15840 * PARJ(6) extra suppression of sas-pair shared by B and
15841 * aB in BMaB (default: 0.5)
15842 * PARJ(7) extra suppression of strange meson M in BMaB
15843 * configuration (default: 0.5)
15844 * PARJ(18) spin 3/2 baryon suppression (default: 1.0)
15845 * PARJ(21) width sigma in Gaussian p_x, p_y transverse
15846 * momentum distrib. for prim. hadrons (default: 0.35)
15847 * PARJ(42) b-parameter for symmetric Lund-fragmentation
15848 * function (default: 0.9 GeV^-2)
15851 IF (MODE.EQ.1) THEN
15858 C PARJ(18) = PDEF18
15859 C PARJ(21) = PDEF21
15860 C PARJ(42) = PDEF42
15861 **sr 18.11.98 parameter tuning
15862 C PARJ(1) = 0.092D0
15866 C PARJ(21) = 0.45D0
15868 **sr 28.04.99 parameter tuning (May 99 minor modifications)
15878 IF (NPARJ.GT.0) THEN
15880 IF (IPARJ(I).GT.0) PARJ(IPARJ(I)) = PARJX(I)
15884 WRITE(LOUT,'(1X,A)')
15885 & 'DT_INITJS: JETSET-parameter for PHOJET'
15890 ELSEIF (MODE.EQ.2) THEN
15891 IF (IFRAG(2).EQ.1) THEN
15892 **sr parameters before 9.3.96
15897 C PARJ(21) = 0.55D0
15899 **sr 18.11.98 parameter tuning
15904 C PARJ(21) = 0.45D0
15906 **sr 28.04.99 parameter tuning
15914 IF (NPARJ.GT.0) THEN
15916 IF (IPARJ(I).LT.0) THEN
15917 IDX = ABS(IPARJ(I))
15918 PARJ(IDX) = PARJX(I)
15923 WRITE(LOUT,'(1X,A)')
15924 & 'DT_INITJS: JETSET-parameter for DTUNUC'
15928 ELSEIF (IFRAG(2).EQ.2) THEN
15935 C PARJ(21) = 0.55D0
15966 *$ CREATE DT_JSPARA.FOR
15969 *===jspara=============================================================*
15971 SUBROUTINE DT_JSPARA(MODE)
15973 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15975 PARAMETER ( LINP = 10 ,
15978 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1,
15979 & ONE=1.0D0,ZERO=0.0D0)
15983 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15985 DIMENSION ISTU(200),QARU(200),ISTJ(200),QARJ(200)
15987 DATA LFIRST /.TRUE./
15989 * save the default JETSET-parameter on the first call
16001 1000 FORMAT(1X,'DT_JSPARA: new value (default value)')
16003 * compare the default JETSET-parameter with the present values
16005 IF ((MSTU(I).NE.ISTU(I)).AND.(I.NE.31)) THEN
16006 WRITE(LOUT,1002) 'MSTU(',I,MSTU(I),ISTU(I)
16007 C ISTU(I) = MSTU(I)
16009 DIFF = ABS(PARU(I)-QARU(I))
16010 IF ((DIFF.GE.1.0D-5).AND.(I.NE.21)) THEN
16011 WRITE(LOUT,1001) 'PARU(',I,PARU(I),QARU(I)
16012 C QARU(I) = PARU(I)
16014 IF (MSTJ(I).NE.ISTJ(I)) THEN
16015 WRITE(LOUT,1002) 'MSTJ(',I,MSTJ(I),ISTJ(I)
16016 C ISTJ(I) = MSTJ(I)
16018 DIFF = ABS(PARJ(I)-QARJ(I))
16019 IF (DIFF.GE.1.0D-5) THEN
16020 WRITE(LOUT,1001) 'PARJ(',I,PARJ(I),QARJ(I)
16021 C QARJ(I) = PARJ(I)
16024 1001 FORMAT(12X,A5,I3,'): ',F6.3,' (',F6.3,')')
16025 1002 FORMAT(12X,A5,I3,'): ',I6,' (',I6,')')
16030 *$ CREATE DT_FOZOCA.FOR
16033 *===fozoca=============================================================*
16035 SUBROUTINE DT_FOZOCA(LFZC,IREJ)
16037 ************************************************************************
16038 * This subroutine treats the complete FOrmation ZOne supressed intra- *
16039 * nuclear CAscade. *
16040 * LFZC = .true. cascade has been treated *
16041 * = .false. cascade skipped *
16042 * This is a completely revised version of the original FOZOKL. *
16043 * This version dated 18.11.95 is written by S. Roesler *
16044 ************************************************************************
16046 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16048 PARAMETER ( LINP = 10 ,
16051 PARAMETER (DLARGE=1.0D10,OHALF=0.5D0,ZERO=0.0D0)
16052 PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16054 LOGICAL LSTART,LCAS,LFZC
16057 PARAMETER (NMXHKK=200000)
16058 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16059 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16060 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16061 * extended event history
16062 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16063 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16065 * rejection counter
16066 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
16067 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
16068 & IREXCI(3),IRDIFF(2),IRINC
16069 * properties of interacting particles
16070 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
16071 * Glauber formalism: collision properties
16072 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
16073 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
16075 * flags for input different options
16076 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16077 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16078 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16079 * final state after intranuclear cascade step
16080 COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16081 * parameter for intranuclear cascade
16083 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16085 DIMENSION NCWOUN(2)
16087 DATA LSTART /.TRUE./
16092 * skip cascade if hadron-hadron interaction or if supressed by user
16093 IF (((IP.EQ.1).AND.(IT.EQ.1)).OR.(KTAUGE.LT.1)) GOTO 9999
16094 * skip cascade if not all possible chains systems are hadronized
16096 IF (.NOT.LHADRO(I)) GOTO 9999
16100 WRITE(LOUT,1000) KTAUGE,TAUFOR,INCMOD
16101 1000 FORMAT(/,1X,'FOZOCA: intranuclear cascade treated for a ',
16102 & 'maximum of',I4,' generations',/,10X,'formation time ',
16103 & 'parameter:',F5.1,' fm/c',9X,'modus:',I2)
16104 IF (ITAUVE.EQ.1) WRITE(LOUT,1001)
16105 IF (ITAUVE.EQ.2) WRITE(LOUT,1002)
16106 1001 FORMAT(10X,'p_t dependent formation zone',/)
16107 1002 FORMAT(10X,'constant formation zone',/)
16111 * in order to avoid wasting of cpu-time the DTEVT1-indices of nucleons
16112 * which may interact with final state particles are stored in a seperate
16113 * array - here all proj./target nucleon-indices (just for simplicity)
16115 DO 9 I=1,NPOINT(1)-1
16120 * initialize Pauli-principle treatment (find wounded nucleons)
16127 IF (ISTHKK(J).EQ.10+I) THEN
16128 NWOUND(I) = NWOUND(I)+1
16129 EWOUND(I,NWOUND(I)) = PHKK(4,J)
16130 IF (IDHKK(J).EQ.2212) NCWOUN(I) = NCWOUN(I)+1
16135 * modify nuclear potential for wounded nucleons
16136 IPRCL = IP -NWOUND(1)
16137 IPZRCL = IPZ-NCWOUN(1)
16138 ITRCL = IT -NWOUND(2)
16139 ITZRCL = ITZ-NCWOUN(2)
16140 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
16148 IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDCH(I).LT.KTAUGE)) THEN
16149 * select nucleus the cascade starts first (proj. - 1, target - -1)
16151 * projectile/target with probab. 1/2
16152 IF ((INCMOD.EQ.1).OR.(IDCH(I).GT.0)) THEN
16153 IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16154 * in the nucleus with highest mass
16155 ELSEIF (INCMOD.EQ.2) THEN
16158 ELSEIF (IP.EQ.IT) THEN
16159 IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16161 * the nucleus the cascade starts first is requested to be the one
16162 * moving in the direction of the secondary
16163 ELSEIF (INCMOD.EQ.3) THEN
16164 NCAS = INT(SIGN(1.0D0,PHKK(3,I)))
16166 * check that the selected "nucleus" is not a hadron
16167 IF (((NCAS.EQ. 1).AND.(IP.LE.1)).OR.
16168 & ((NCAS.EQ.-1).AND.(IT.LE.1))) NCAS = -NCAS
16170 * treat intranuclear cascade in the nucleus selected first
16172 CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
16173 IF (IREJ1.NE.0) GOTO 9998
16174 * treat intranuclear cascade in the other nucleus if this isn't a had.
16176 IF (((NCAS.EQ. 1).AND.(IP.GT.1)).OR.
16177 & ((NCAS.EQ.-1).AND.(IT.GT.1))) THEN
16178 IF (LCAS) CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
16179 IF (IREJ1.NE.0) GOTO 9998
16187 IF (NSTART.LE.NEND) GOTO 7
16192 * reject this event
16197 * intranucl. cascade not treated because of interaction properties or
16198 * it is supressed by user or it was rejected or...
16200 * reset flag characterizing direction of motion in n-n-cms
16202 C DO 9990 I=NPOINT(5),NHKK
16203 C IF (ISTHKK(I).EQ.-1) ISTHKK(I)=1
16209 *$ CREATE DT_INUCAS.FOR
16212 *===inucas=============================================================*
16214 SUBROUTINE DT_INUCAS(IT,IP,IDXCAS,LCAS,NCAS,IREJ)
16216 ************************************************************************
16217 * Formation zone supressed IntraNUclear CAScade for one final state *
16219 * IT, IP mass numbers of target, projectile nuclei *
16220 * IDXCAS index of final state particle in DTEVT1 *
16221 * NCAS = 1 intranuclear cascade in projectile *
16222 * = -1 intranuclear cascade in target *
16223 * This version dated 18.11.95 is written by S. Roesler *
16224 ************************************************************************
16226 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16228 PARAMETER ( LINP = 10 ,
16232 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
16233 & OHALF=0.5D0,ONE=1.0D0)
16234 PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16235 PARAMETER (TWOPI=6.283185307179586454D+00)
16236 PARAMETER (PLOWH=0.01D0,PHIH=9.0D0)
16238 LOGICAL LABSOR,LCAS
16241 PARAMETER (NMXHKK=200000)
16242 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16243 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16244 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16245 * extended event history
16246 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16247 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16249 * final state after inc step
16250 PARAMETER (MAXFSP=10)
16251 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
16252 * flags for input different options
16253 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16254 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16255 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16256 * particle properties (BAMJET index convention)
16258 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
16259 & IICH(210),IIBAR(210),K1(210),K2(210)
16260 * Glauber formalism: collision properties
16261 COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
16262 & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
16264 * nuclear potential
16266 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
16267 & EBINDP(2),EBINDN(2),EPOT(2,210),
16268 & ETACOU(2),ICOUL,LFERMI
16269 * parameter for intranuclear cascade
16271 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16272 * final state after intranuclear cascade step
16273 COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16274 * nucleon-nucleon event-generator
16277 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
16278 * statistics: residual nuclei
16279 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
16280 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
16281 & NINCST(2,4),NINCEV(2),
16282 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
16283 & NRESPB(2),NRESCH(2),NRESEV(4),
16284 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
16287 DIMENSION PCAS(2,5),PTOCAS(2),COSCAS(2,3),VTXCAS(2,4),VTXCA1(2,4),
16288 & PCAS1(5),PNUC(5),BGTA(4),
16289 & BGCAS(2),GACAS(2),BECAS(2),
16290 & RNUC(2),BIMPC(2),VTXDST(3),IDXSPE(2),IDSPE(2),NWTMP(2)
16292 DATA PDIF /0.545D0/
16297 IF (NINCEV(1).NE.NEVHKK) THEN
16299 NINCEV(2) = NINCEV(2)+1
16302 * "BAMJET-index" of this hadron
16303 IDCAS = IDBAM(IDXCAS)
16304 IF (IDT_MCHAD(IDCAS).EQ.-1) RETURN
16306 * skip gammas, electrons, etc..
16307 IF (AAM(IDCAS).LT.TINY2) RETURN
16309 * Lorentz-trsf. into projectile rest system
16311 CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
16312 & PHKK(4,IDXCAS),PCAS(1,1),PCAS(1,2),PCAS(1,3),
16313 & PCAS(1,4),IDCAS,-2)
16314 PTOCAS(1) = SQRT(PCAS(1,1)**2+PCAS(1,2)**2+PCAS(1,3)**2)
16315 PCAS(1,5) = (PCAS(1,4)-PTOCAS(1))*(PCAS(1,4)+PTOCAS(1))
16316 IF (PCAS(1,5).GT.ZERO) THEN
16317 PCAS(1,5) = SQRT(PCAS(1,5))
16319 PCAS(1,5) = AAM(IDCAS)
16322 COSCAS(1,K) = PCAS(1,K)/MAX(PTOCAS(1),TINY10)
16324 * Lorentz-parameters
16325 * particle rest system --> projectile rest system
16326 BGCAS(1) = PTOCAS(1)/MAX(PCAS(1,5),TINY10)
16327 GACAS(1) = PCAS(1,4)/MAX(PCAS(1,5),TINY10)
16328 BECAS(1) = BGCAS(1)/GACAS(1)
16332 IF (K.LE.3) COSCAS(1,K) = ZERO
16339 * Lorentz-trsf. into target rest system
16341 * LEPTO: final state particles are already in target rest frame
16342 C IF (MCGENE.EQ.3) THEN
16343 C PCAS(2,1) = PHKK(1,IDXCAS)
16344 C PCAS(2,2) = PHKK(2,IDXCAS)
16345 C PCAS(2,3) = PHKK(3,IDXCAS)
16346 C PCAS(2,4) = PHKK(4,IDXCAS)
16348 CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
16349 & PHKK(4,IDXCAS),PCAS(2,1),PCAS(2,2),PCAS(2,3),
16350 & PCAS(2,4),IDCAS,-3)
16352 PTOCAS(2) = SQRT(PCAS(2,1)**2+PCAS(2,2)**2+PCAS(2,3)**2)
16353 PCAS(2,5) = (PCAS(2,4)-PTOCAS(2))*(PCAS(2,4)+PTOCAS(2))
16354 IF (PCAS(2,5).GT.ZERO) THEN
16355 PCAS(2,5) = SQRT(PCAS(2,5))
16357 PCAS(2,5) = AAM(IDCAS)
16360 COSCAS(2,K) = PCAS(2,K)/MAX(PTOCAS(2),TINY10)
16362 * Lorentz-parameters
16363 * particle rest system --> target rest system
16364 BGCAS(2) = PTOCAS(2)/MAX(PCAS(2,5),TINY10)
16365 GACAS(2) = PCAS(2,4)/MAX(PCAS(2,5),TINY10)
16366 BECAS(2) = BGCAS(2)/GACAS(2)
16370 IF (K.LE.3) COSCAS(2,K) = ZERO
16378 * radii of nuclei (mm) modified by the wall-depth of the Woods-Saxon-
16379 * potential (see CONUCL)
16380 RNUC(1) = (RPROJ+4.605D0*PDIF)*FM2MM
16381 RNUC(2) = (RTARG+4.605D0*PDIF)*FM2MM
16382 * impact parameter (the projectile moving along z)
16384 BIMPC(2) = BIMPAC*FM2MM
16386 * get position of initial hadron in projectile/target rest-syst.
16388 VTXCAS(1,K) = WHKK(K,IDXCAS)
16389 VTXCAS(2,K) = VHKK(K,IDXCAS)
16394 IF (NCAS.EQ.-1) THEN
16399 IF (PTOCAS(ICAS).LT.TINY10) THEN
16400 WRITE(LOUT,1000) PTOCAS
16401 1000 FORMAT(1X,'INUCAS: warning! zero momentum of initial',
16402 & ' hadron ',/,20X,2E12.4)
16406 * reset spectator flags
16413 * formation length (in fm)
16417 DEL0 = TAUFOR*BGCAS(ICAS)
16418 IF (ITAUVE.EQ.1) THEN
16419 AMT = PCAS(ICAS,1)**2+PCAS(ICAS,2)**2+PCAS(ICAS,5)**2
16420 DEL0 = DEL0*PCAS(ICAS,5)**2/AMT
16423 * sample from exp(-del/del0)
16424 DEL1 = -DEL0*LOG(MAX(DT_RNDM(DEL0),TINY10))
16425 * save formation time
16426 TAUSA1 = DEL1/BGCAS(ICAS)
16427 REL1 = TAUSA1*BGCAS(I2)
16430 TAUSAM = DEL/BGCAS(ICAS)
16431 REL = TAUSAM*BGCAS(I2)
16433 * special treatment for negative particles unable to escape
16434 * nuclear potential (implemented for ap, pi-, K- only)
16436 IF ((IICH(IDCAS).EQ.-1).AND.(IDCAS.LT.20)) THEN
16437 * threshold energy = nuclear potential + Coulomb potential
16438 * (nuclear potential for hadron-nucleus interactions only)
16439 ETHR = AAM(IDCAS)+EPOT(ICAS,IDCAS)+ETACOU(ICAS)
16440 IF (PCAS(ICAS,4).LT.ETHR) THEN
16442 PCAS1(K) = PCAS(ICAS,K)
16444 * "absorb" negative particle in nucleus
16445 CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,0,IREJ1)
16446 IF (IREJ1.NE.0) GOTO 9999
16447 IF (NSPE.GE.1) LABSOR = .TRUE.
16451 * if the initial particle has not been absorbed proceed with
16453 IF (.NOT.LABSOR) THEN
16455 * calculate coordinates of hadron at the end of the formation zone
16456 * transport-time and -step in the rest system where this step is
16459 DTIME = DSTEP/BECAS(ICAS)
16461 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16462 RTIME = RSTEP/BECAS(I2)
16466 * save step whithout considering the overlapping region
16467 DSTEP1 = DEL1*FM2MM
16468 DTIME1 = DSTEP1/BECAS(ICAS)
16469 RSTEP1 = REL1*FM2MM
16470 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16471 RTIME1 = RSTEP1/BECAS(I2)
16475 * transport to the end of the formation zone in this system
16477 VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+DSTEP1*COSCAS(ICAS,K)
16478 VTXCA1(I2,K) = VTXCAS(I2,K) +RSTEP1*COSCAS(I2,K)
16479 VTXCAS(ICAS,K) = VTXCAS(ICAS,K)+DSTEP*COSCAS(ICAS,K)
16480 VTXCAS(I2,K) = VTXCAS(I2,K) +RSTEP*COSCAS(I2,K)
16482 VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME1
16483 VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME1
16484 VTXCAS(ICAS,4) = VTXCAS(ICAS,4)+DTIME
16485 VTXCAS(I2,4) = VTXCAS(I2,4) +RTIME
16487 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16488 XCAS = VTXCAS(ICAS,1)
16489 YCAS = VTXCAS(ICAS,2)
16490 XNCLTA = BIMPAC*FM2MM
16491 RNCLPR = (RPROJ+RNUCLE)*FM2MM
16492 RNCLTA = (RTARG+RNUCLE)*FM2MM
16493 C RNCLPR = (RPROJ+1.605D0*PDIF)*FM2MM
16494 C RNCLTA = (RTARG+1.605D0*PDIF)*FM2MM
16495 C RNCLPR = (RPROJ)*FM2MM
16496 C RNCLTA = (RTARG)*FM2MM
16497 RCASPR = SQRT( XCAS**2 +YCAS**2)
16498 RCASTA = SQRT((XCAS-XNCLTA)**2+YCAS**2)
16499 IF ((RCASPR.LT.RNCLPR).AND.(RCASTA.LT.RNCLTA)) THEN
16500 IF (IDCH(IDXCAS).EQ.0) NOBAM(IDXCAS) = 3
16504 * check if particle is already outside of the corresp. nucleus
16505 RDIST = SQRT((VTXCAS(ICAS,1)-BIMPC(ICAS))**2+
16506 & VTXCAS(ICAS,2)**2+VTXCAS(ICAS,3)**2)
16507 IF (RDIST.GE.RNUC(ICAS)) THEN
16508 * here: IDCH is the generation of the final state part. starting
16509 * with zero for hadronization products
16510 * flag particles of generation 0 being outside the nuclei after
16511 * formation time (to be used for excitation energy calculation)
16512 IF ((IDCH(IDXCAS).EQ.0).AND.(NOBAM(IDXCAS).LT.3))
16513 & NOBAM(IDXCAS) = NOBAM(IDXCAS)+ICAS
16522 * already here: skip particles being outside HADRIN "energy-window"
16523 * to avoid wasting of time
16524 NINCHR(ICAS,1) = NINCHR(ICAS,1)+1
16525 IF ((PTOCAS(ICAS).LE.PLOWH).OR.(PTOCAS(ICAS).GE.PHIH)) THEN
16526 NINCHR(ICAS,2) = NINCHR(ICAS,2)+1
16527 C WRITE(LOUT,1002) IDXCAS,IDCAS,ICAS,PTOCAS(ICAS),NEVHKK
16528 C1002 FORMAT(1X,'INUCAS: warning! momentum of particle with ',
16529 C & 'index ',I5,' (id: ',I3,') ',I3,/,11X,'p_tot = ',
16530 C & E12.4,', above or below HADRIN-thresholds',I6)
16535 DO 7 IDXHKK=1,NOINC
16537 * scan DTEVT1 for unwounded or excited nucleons
16538 IF ((ISTHKK(I).EQ.12+ICAS).OR.(ISTHKK(I).EQ.14+ICAS)) THEN
16540 IF (ICAS.EQ.1) THEN
16541 VTXDST(K) = WHKK(K,I)-VTXCAS(1,K)
16542 ELSEIF (ICAS.EQ.2) THEN
16543 VTXDST(K) = VHKK(K,I)-VTXCAS(2,K)
16546 POSNUC = VTXDST(1)*COSCAS(ICAS,1)+
16547 & VTXDST(2)*COSCAS(ICAS,2)+
16548 & VTXDST(3)*COSCAS(ICAS,3)
16549 * check if nucleon is situated in forward direction
16550 IF (POSNUC.GT.ZERO) THEN
16551 * distance between hadron and this nucleon
16552 DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16555 BIMNU2 = DISTNU**2-POSNUC**2
16556 IF (BIMNU2.LT.ZERO) THEN
16557 WRITE(LOUT,1001) DISTNU,POSNUC,BIMNU2
16558 1001 FORMAT(1X,'INUCAS: warning! inconsistent impact',
16559 & ' parameter ',/,20X,3E12.4)
16562 BIMNU = SQRT(BIMNU2)
16563 * maximum impact parameter to have interaction
16564 IDNUC = IDT_ICIHAD(IDHKK(I))
16565 IDNUC1 = IDT_MCHAD(IDNUC)
16566 IDCAS1 = IDT_MCHAD(IDCAS)
16568 PCAS1(K) = PCAS(ICAS,K)
16569 PNUC(K) = PHKK(K,I)
16571 * Lorentz-parameter for trafo into rest-system of target
16573 BGTA(K) = PNUC(K)/MAX(PNUC(5),TINY10)
16575 * transformation of projectile into rest-system of target
16576 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
16577 & PCAS1(1),PCAS1(2),PCAS1(3),PCAS1(4),
16578 & PPTOT,PX,PY,PZ,PE)
16580 C CALL DT_SIHNIN(IDCAS1,IDNUC1,PPTOT,SIGIN)
16581 C CALL DT_SIHNEL(IDCAS1,IDNUC1,PPTOT,SIGEL)
16583 CALL DT_XSHN(IDCAS1,IDNUC1,PPTOT,DUMZER,SIGTOT,SIGEL)
16584 CALL DT_SIHNAB(IDCAS1,IDNUC1,PPTOT,SIGAB)
16585 IF (((IDCAS1.EQ.13).OR.(IDCAS1.EQ.14)).AND.
16586 & (PPTOT.LT.0.15D0)) SIGEL = SIGEL/2.0D0
16587 SIGIN = SIGTOT-SIGEL-SIGAB
16588 C SIGTOT = SIGIN+SIGEL+SIGAB
16590 BIMMAX = SQRT(SIGTOT/(5.0D0*TWOPI))*FM2MM
16591 * check if interaction is possible
16592 IF (BIMNU.LE.BIMMAX) THEN
16593 * get nucleon with smallest distance and kind of interaction
16594 * (elastic/inelastic)
16595 IF (DISTNU.LT.DIST) THEN
16598 IF (IDNUC.NE.IDSPE(1)) THEN
16599 IDSPE(2) = IDSPE(1)
16600 IDXSPE(2) = IDXSPE(1)
16609 C IF ((IDCAS.EQ.2).OR.(IDCAS.EQ.9)) THEN
16611 C STOT = SIGIN+SIGEL
16613 C SELA = SIGEL+0.75D0*SIGIN
16614 C STOT = 0.25D0*SIGIN+SELA
16620 DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16622 IDNUC = IDT_ICIHAD(IDHKK(I))
16623 IF (IDNUC.EQ.1) THEN
16624 IF (DISTNU.LT.DISTP) THEN
16629 ELSEIF (IDNUC.EQ.8) THEN
16630 IF (DISTNU.LT.DISTN) THEN
16639 * there is no nucleon for a secondary interaction
16640 IF (NSPE.EQ.0) GOTO 9997
16642 C IF ((IDCAS.EQ.13).AND.((PCAS(ICAS,4)-PCAS(ICAS,5)).LT.0.1D0))
16643 C & WRITE(LOUT,*) STOT,SELA,SABS,IDXSPE
16644 IF (IDXSPE(2).EQ.0) THEN
16645 IF ((IDSPE(1).EQ.1).AND.(IDXN.GT.0)) THEN
16647 C IF (ICAS.EQ.1) THEN
16648 C VTXDST(K) = WHKK(K,IDXN)-WHKK(K,IDXSPE(1))
16649 C ELSEIF (ICAS.EQ.2) THEN
16650 C VTXDST(K) = VHKK(K,IDXN)-VHKK(K,IDXSPE(1))
16653 C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16655 C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSN.GT.ZERO)) THEN
16662 ELSEIF ((IDSPE(1).EQ.8).AND.(IDXP.GT.0)) THEN
16664 C IF (ICAS.EQ.1) THEN
16665 C VTXDST(K) = WHKK(K,IDXP)-WHKK(K,IDXSPE(1))
16666 C ELSEIF (ICAS.EQ.2) THEN
16667 C VTXDST(K) = VHKK(K,IDXP)-VHKK(K,IDXSPE(1))
16670 C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16672 C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSP.GT.ZERO)) THEN
16685 IF (RR.LT.SELA/STOT) THEN
16687 ELSEIF ((RR.GE.SELA/STOT).AND.(RR.LT.(SELA+SABS)/STOT)) THEN
16694 PCAS1(K) = PCAS(ICAS,K)
16695 PNUC(K) = PHKK(K,IDXSPE(1))
16697 IF (IPROC.EQ.3) THEN
16698 * 2-nucleon absorption of pion
16700 CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,1,IREJ1)
16701 IF (IREJ1.NE.0) GOTO 9999
16702 IF (NSPE.GE.1) LABSOR = .TRUE.
16704 * sample secondary interaction
16705 IDNUC = IDBAM(IDXSPE(1))
16706 CALL DT_HADRIN(IDCAS,PCAS1,IDNUC,PNUC,IPROC,IREJ1)
16707 IF (IREJ1.EQ.1) GOTO 9999
16708 IF (IREJ1.GT.1) GOTO 9998
16712 * update arrays to include Pauli-principle
16714 IF (NWOUND(ICAS).LE.299) THEN
16715 NWOUND(ICAS) = NWOUND(ICAS)+1
16716 EWOUND(ICAS,NWOUND(ICAS)) = PHKK(4,IDXSPE(I))
16720 * dump initial hadron for energy-momentum conservation check
16722 & CALL DT_EVTEMC(PCAS(ICAS,1),PCAS(ICAS,2),PCAS(ICAS,3),
16723 & PCAS(ICAS,4),1,IDUM,IDUM)
16725 * dump final state particles into DTEVT1
16727 * check if Pauli-principle is fulfilled
16729 NWTMP(1) = NWOUND(1)
16730 NWTMP(2) = NWOUND(2)
16734 IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
16735 & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1
16737 IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 117
16744 IF (IDX.EQ.1) MODE = -1
16745 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,MODE)
16747 * first check if cascade step is forbidden due to Pauli-principle
16748 * (in case of absorpion this step is forced)
16749 IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
16750 & (IDFSP(I).EQ.8))) THEN
16751 * get nuclear potential barrier
16752 POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
16753 IF (IDFSP(I).EQ.1) THEN
16754 POTLOW = POT-EBINDP(IDX)
16756 POTLOW = POT-EBINDN(IDX)
16758 * final state particle not able to escape nucleus
16759 IF (PE.LE.POTLOW) THEN
16760 * check if there are wounded nucleons
16761 IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
16762 & EWOUND(IDX,NWOUND(IDX)))) THEN
16764 NWOUND(IDX) = NWOUND(IDX)-1
16766 * interaction prohibited by Pauli-principle
16767 NWOUND(1) = NWTMP(1)
16768 NWOUND(2) = NWTMP(2)
16777 NWOUND(1) = NWTMP(1)
16778 NWOUND(2) = NWTMP(2)
16782 IST = ISTHKK(IDXCAS)
16786 IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
16787 & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1
16789 IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 17
16794 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,NCAS)
16796 * first check if cascade step is forbidden due to Pauli-principle
16797 * (in case of absorpion this step is forced)
16798 IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
16799 & (IDFSP(I).EQ.8))) THEN
16800 * get nuclear potential barrier
16801 POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
16802 IF (IDFSP(I).EQ.1) THEN
16803 POTLOW = POT-EBINDP(IDX)
16805 POTLOW = POT-EBINDN(IDX)
16807 * final state particle not able to escape nucleus
16808 IF (PE.LE.POTLOW) THEN
16809 * check if there are wounded nucleons
16810 IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
16811 & EWOUND(IDX,NWOUND(IDX)))) THEN
16812 NWOUND(IDX) = NWOUND(IDX)-1
16816 * interaction prohibited by Pauli-principle
16817 NWOUND(1) = NWTMP(1)
16818 NWOUND(2) = NWTMP(2)
16822 c ELSEIF (PE.LE.POT) THEN
16823 cC ELSEIF ((PE.LE.POT).AND.(NWOUND(IDX).GE.1)) THEN
16824 cC NWOUND(IDX) = NWOUND(IDX)-1
16826 c NPAULI = NPAULI+1
16832 * dump final state particles for energy-momentum conservation check
16833 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),-PFSP(3,I),
16834 & -PFSP(4,I),2,IDUM,IDUM)
16840 IF (ABS(IST).EQ.1) THEN
16841 * transform particles back into n-n cms
16842 * LEPTO: leave final state particles in target rest frame
16843 C IF (MCGENE.EQ.3) THEN
16850 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
16851 & PFSP(4,I),IDFSP(I),IMODE)
16853 ELSEIF ((ICAS.EQ.2).AND.(IST.EQ.15)) THEN
16854 * target cascade but fsp got stuck in proj. --> transform it into
16855 * proj. rest system
16856 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
16857 & PFSP(4,I),IDFSP(I),-1)
16858 ELSEIF ((ICAS.EQ.1).AND.(IST.EQ.16)) THEN
16859 * proj. cascade but fsp got stuck in target --> transform it into
16860 * target rest system
16861 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
16862 & PFSP(4,I),IDFSP(I),1)
16865 * dump final state particles into DTEVT1
16866 IGEN = IDCH(IDXCAS)+1
16867 ID = IDT_IPDGHA(IDFSP(I))
16869 IF (LABSOR) IXR = 99
16870 CALL DT_EVTPUT(IST,ID,IDXCAS,IDXSPE(1),PFSP(1,I),
16871 & PFSP(2,I),PFSP(3,I),PFSP(4,I),0,IXR,IGEN)
16873 * update the counter for particles which got stuck inside the nucleus
16874 IF ((IST.EQ.15).OR.(IST.EQ.16)) THEN
16876 IDXINC(NOINC) = NHKK
16879 * in case of absorption the spatial treatment is an approximate
16880 * solution anyway (the positions of the nucleons which "absorb" the
16881 * cascade particle are not taken into consideration) therefore the
16882 * particles are produced at the position of the cascade particle
16884 WHKK(K,NHKK) = WHKK(K,IDXCAS)
16885 VHKK(K,NHKK) = VHKK(K,IDXCAS)
16888 * DDISTL - distance the cascade particle moves to the intera. point
16889 * (the position where impact-parameter = distance to the interacting
16890 * nucleon), DIST - distance to the interacting nucleon at the time of
16891 * formation of the cascade particle, BINT - impact-parameter of this
16892 * cascade-interaction
16893 DDISTL = SQRT(DIST**2-BINT**2)
16894 DTIME = DDISTL/BECAS(ICAS)
16895 DTIMEL = DDISTL/BGCAS(ICAS)
16896 RDISTL = DTIMEL*BGCAS(I2)
16897 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16898 RTIME = RDISTL/BECAS(I2)
16902 * RDISTL, RTIME are this step and time in the rest system of the other
16905 VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+COSCAS(ICAS,K)*DDISTL
16906 VTXCA1(I2,K) = VTXCAS(I2,K) +COSCAS(I2,K) *RDISTL
16908 VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME
16909 VTXCA1(I2,4) = VTXCAS(I2,4) +RTIME
16910 * position of particle production is half the impact-parameter to
16911 * the interacting nucleon
16913 WHKK(K,NHKK) = OHALF*(VTXCA1(1,K)+WHKK(K,IDXSPE(1)))
16914 VHKK(K,NHKK) = OHALF*(VTXCA1(2,K)+VHKK(K,IDXSPE(1)))
16916 * time of production of secondary = time of interaction
16917 WHKK(4,NHKK) = VTXCA1(1,4)
16918 VHKK(4,NHKK) = VTXCA1(2,4)
16923 * modify status and position of cascade particle (the latter for
16924 * statistics reasons only)
16926 IF (LABSOR) ISTHKK(IDXCAS) = 19
16927 IF (.NOT.LABSOR) THEN
16929 WHKK(K,IDXCAS) = VTXCA1(1,K)
16930 VHKK(K,IDXCAS) = VTXCA1(2,K)
16936 * dump interacting nucleons for energy-momentum conservation check
16938 & CALL DT_EVTEMC(PHKK(1,IS),PHKK(2,IS),PHKK(3,IS),PHKK(4,IS),
16940 * modify entry for interacting nucleons
16941 IF (ISTHKK(IS).EQ.12+ICAS) ISTHKK(IS)=16+ICAS
16942 IF (ISTHKK(IS).EQ.14+ICAS) ISTHKK(IS)=2
16944 JDAHKK(1,IS) = JDAHKK(1,IDXSPE(1))
16945 JDAHKK(2,IS) = JDAHKK(2,IDXSPE(1))
16949 * check energy-momentum conservation
16951 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,500,IREJ1)
16952 IF (IREJ1.NE.0) GOTO 9999
16957 NINCCO(ICAS,1) = NINCCO(ICAS,1)+1
16959 IF (IPROC.EQ.1) NINCCO(ICAS,2) = NINCCO(ICAS,2)+1
16960 IF (IPROC.EQ.2) NINCCO(ICAS,3) = NINCCO(ICAS,3)+1
16967 * transport-step but no cascade step due to configuration (i.e. there
16968 * is no nucleon for interaction etc.)
16971 C WHKK(K,IDXCAS) = VTXCAS(1,K)
16972 C VHKK(K,IDXCAS) = VTXCAS(2,K)
16973 WHKK(K,IDXCAS) = VTXCA1(1,K)
16974 VHKK(K,IDXCAS) = VTXCA1(2,K)
16979 * no cascade-step because of configuration
16980 * (i.e. hadron outside nucleus etc.)
16990 *$ CREATE DT_ABSORP.FOR
16993 *===absorp=============================================================*
16995 SUBROUTINE DT_ABSORP(IDCAS,PCAS,NCAS,NSPE,IDSPE,IDXSPE,MODE,IREJ)
16997 ************************************************************************
16998 * Two-nucleon absorption of antiprotons, pi-, and K-. *
16999 * Antiproton absorption is handled by HADRIN. *
17000 * The following channels for meson-absorption are considered: *
17001 * pi- + p + p ---> n + p *
17002 * pi- + p + n ---> n + n *
17003 * K- + p + p ---> sigma+ + n / Lam + p / sigma0 + p *
17004 * K- + p + n ---> sigma- + n / Lam + n / sigma0 + n *
17005 * K- + p + p ---> sigma- + n *
17006 * IDCAS, PCAS identity, momentum of particle to be absorbed *
17007 * NCAS = 1 intranuclear cascade in projectile *
17008 * = -1 intranuclear cascade in target *
17009 * NSPE number of spectator nucleons involved *
17010 * IDXSPE(2) DTEVT1-indices of spectator nucleons involved *
17011 * Revised version of the original STOPIK written by HJM and J. Ranft. *
17012 * This version dated 24.02.95 is written by S. Roesler *
17013 ************************************************************************
17015 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17017 PARAMETER ( LINP = 10 ,
17020 PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,ONE=1.0D0,
17021 & ONETHI=0.3333D0,TWOTHI=0.6666D0)
17024 PARAMETER (NMXHKK=200000)
17025 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17026 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17027 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17028 * extended event history
17029 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17030 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17032 * flags for input different options
17033 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17034 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17035 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17036 * final state after inc step
17037 PARAMETER (MAXFSP=10)
17038 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17039 * particle properties (BAMJET index convention)
17041 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17042 & IICH(210),IIBAR(210),K1(210),K2(210)
17044 DIMENSION PCAS(5),IDXSPE(2),IDSPE(2),PSPE(2,5),PSPE1(5),
17045 & PTOT3P(4),BG3P(4),
17046 & ECMF(2),PCMF(2),CODF(2),COFF(2),SIFF(2)
17051 * skip particles others than ap, pi-, K- for mode=0
17052 IF ((MODE.EQ.0).AND.
17053 & (IDCAS.NE.2).AND.(IDCAS.NE.14).AND.(IDCAS.NE.16)) RETURN
17054 * skip particles others than pions for mode=1
17055 * (2-nucleon absorption in intranuclear cascade)
17056 IF ((MODE.EQ.1).AND.
17057 & (IDCAS.NE.13).AND.(IDCAS.NE.14).AND.(IDCAS.NE.23)) RETURN
17060 IF (NUCAS.EQ.-1) NUCAS = 2
17062 IF (MODE.EQ.0) THEN
17063 * scan spectator nucleons for nucleons being able to "absorb"
17068 IF ((ISTHKK(I).EQ.12+NUCAS).OR.(ISTHKK(I).EQ.14+NUCAS)) THEN
17071 IDSPE(NSPE) = IDBAM(I)
17072 IF ((NSPE.EQ.1).AND.(IDCAS.EQ.2)) GOTO 2
17073 IF (NSPE.EQ.2) THEN
17074 IF ((IDCAS.EQ.14).AND.(IDSPE(1).EQ.8).AND.
17075 & (IDSPE(2).EQ.8)) THEN
17076 * there is no pi-+n+n channel
17088 * transform excited projectile nucleons (status=15) into proj. rest s.
17091 PSPE(I,K) = PHKK(K,IDXSPE(I))
17095 * antiproton absorption
17096 IF ((IDCAS.EQ.2).AND.(NSPE.GE.1)) THEN
17098 PSPE1(K) = PSPE(1,K)
17100 CALL DT_HADRIN(IDCAS,PCAS,IDSPE(1),PSPE1,1,IREJ1)
17101 IF (IREJ1.NE.0) GOTO 9999
17104 ELSEIF (((IDCAS.EQ.13).OR.(IDCAS.EQ.14).OR.(IDCAS.EQ.23)
17105 & .OR.(IDCAS.EQ.16)).AND.(NSPE.GE.2)) THEN
17106 IF (IDCAS.EQ.14) THEN
17110 IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) IDFSP(2) = 1
17111 ELSEIF (IDCAS.EQ.13) THEN
17115 IF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) IDFSP(2) = 8
17116 ELSEIF (IDCAS.EQ.23) THEN
17118 IDFSP(1) = IDSPE(1)
17119 IDFSP(2) = IDSPE(2)
17120 ELSEIF (IDCAS.EQ.16) THEN
17123 IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) THEN
17124 IF (R.LT.ONETHI) THEN
17127 ELSEIF (R.LT.TWOTHI) THEN
17134 ELSEIF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) THEN
17138 IF (R.LT.ONETHI) THEN
17141 ELSEIF (R.LT.TWOTHI) THEN
17150 * dump initial particles for energy-momentum cons. check
17152 CALL DT_EVTEMC(PCAS(1),PCAS(2),PCAS(3),PCAS(4),1,IDUM,IDUM)
17153 CALL DT_EVTEMC(PSPE(1,1),PSPE(1,2),PSPE(1,3),PSPE(1,4),2,
17155 CALL DT_EVTEMC(PSPE(2,1),PSPE(2,2),PSPE(2,3),PSPE(2,4),2,
17158 * get Lorentz-parameter of 3 particle initial state
17160 PTOT3P(K) = PCAS(K)+PSPE(1,K)+PSPE(2,K)
17162 P3P = SQRT(PTOT3P(1)**2+PTOT3P(2)**2+PTOT3P(3)**2)
17163 AM3P = SQRT( (PTOT3P(4)-P3P)*(PTOT3P(4)+P3P) )
17165 BG3P(K) = PTOT3P(K)/MAX(AM3P,TINY10)
17167 * 2-particle decay of the 3-particle compound system
17168 CALL DT_DTWOPD(AM3P,ECMF(1),ECMF(2),PCMF(1),PCMF(2),
17169 & CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
17170 & AAM(IDFSP(1)),AAM(IDFSP(2)))
17172 SDF = SQRT((ONE-CODF(I))*(ONE+CODF(I)))
17173 PX = PCMF(I)*COFF(I)*SDF
17174 PY = PCMF(I)*SIFF(I)*SDF
17175 PZ = PCMF(I)*CODF(I)
17176 CALL DT_DALTRA(BG3P(4),BG3P(1),BG3P(2),BG3P(3),PX,PY,PZ,
17177 & ECMF(I),PTOFSP,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17179 PFSP(5,I) = SQRT( (PFSP(4,I)-PTOFSP)*(PFSP(4,I)+PTOFSP) )
17180 * check consistency of kinematics
17181 IF (ABS(AAM(IDFSP(I))-PFSP(5,I)).GT.TINY5) THEN
17182 WRITE(LOUT,1001) IDFSP(I),AAM(IDFSP(I)),PFSP(5,I)
17183 1001 FORMAT(1X,'ABSORP: warning! inconsistent',
17184 & ' tree-particle kinematics',/,20X,'id: ',I3,
17185 & ' AAM = ',E10.4,' MFSP = ',E10.4)
17187 * dump final state particles for energy-momentum cons. check
17188 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
17189 & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
17193 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,100,IREJ1)
17194 IF (IREJ1.NE.0) THEN
17195 WRITE(LOUT,*)'ABSORB: EMC ',AAM(IDFSP(1)),AAM(IDFSP(2)),
17201 IF (IOULEV(3).GT.0) WRITE(LOUT,1000) IDCAS,NSPE
17202 1000 FORMAT(1X,'ABSORP: warning! absorption for particle ',I3,
17203 & ' impossible',/,20X,'too few spectators (',I2,')')
17210 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in ABSORP'
17215 *$ CREATE DT_HADRIN.FOR
17218 *===hadrin=============================================================*
17220 SUBROUTINE DT_HADRIN(IDPR,PPR,IDTA,PTA,MODE,IREJ)
17222 ************************************************************************
17223 * Interface to the HADRIN-routines for inelastic and elastic *
17225 * IDPR,PPR(5) identity, momentum of projectile *
17226 * IDTA,PTA(5) identity, momentum of target *
17227 * MODE = 1 inelastic interaction *
17228 * = 2 elastic interaction *
17229 * Revised version of the original FHAD. *
17230 * This version dated 27.10.95 is written by S. Roesler *
17231 ************************************************************************
17233 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17235 PARAMETER ( LINP = 10 ,
17238 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,
17239 & TINY2=1.0D-2,TINY1=1.0D-1,ONE=1.0D0)
17241 LOGICAL LCORR,LMSSG
17243 * flags for input different options
17244 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17245 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17246 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17247 * final state after inc step
17248 PARAMETER (MAXFSP=10)
17249 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17250 * particle properties (BAMJET index convention)
17252 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17253 & IICH(210),IIBAR(210),K1(210),K2(210)
17254 * output-common for DHADRI/ELHAIN
17255 * final state from HADRIN interaction
17256 PARAMETER (MAXFIN=10)
17257 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
17258 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
17260 DIMENSION PPR(5),PPR1(5),PTA(5),BGTA(4),
17261 & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4),IMCORR(2)
17263 DATA LMSSG /.TRUE./
17272 * dump initial particles for energy-momentum cons. check
17274 CALL DT_EVTEMC(PPR(1),PPR(2),PPR(3),PPR(4),1,IDUM,IDUM)
17275 CALL DT_EVTEMC(PTA(1),PTA(2),PTA(3),PTA(4),2,IDUM,IDUM)
17278 AMP2 = PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2
17279 AMT2 = PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2
17280 IF ((AMP2.LT.ZERO).OR.(AMT2.LT.ZERO).OR.
17281 & (ABS(AMP2-AAM(IDPR)**2).GT.TINY5).OR.
17282 & (ABS(AMT2-AAM(IDTA)**2).GT.TINY5)) THEN
17283 IF (LMSSG.AND.(IOULEV(3).GT.0))
17284 & WRITE(LOUT,1000) AMP2,AAM(IDPR)**2,AMT2,AAM(IDTA)**2
17285 1000 FORMAT(1X,'HADRIN: warning! inconsistent projectile/target',
17286 & ' mass',/,20X,'AMP2 = ',E12.4,', AAM(IDPR)**2 = ',
17287 & E12.4,/,20X,'AMT2 = ',E12.4,', AAM(IDTA)**2 = ',E12.4)
17292 * convert initial state particles into particles which can be
17293 * handled by HADRIN
17296 IF ((IDHPR.LE.0).OR.(IDHPR.GE.111).OR.LCORR) THEN
17297 IF ((IDHPR.LE.0).OR.(IDHPR.GE.111)) IDHPR = 1
17304 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
17305 IF (IREJ1.GT.0) THEN
17306 WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.'
17313 PPR(5) = SQRT(PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2)
17314 PTA(5) = SQRT(PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2)
17317 * Lorentz-parameter for trafo into rest-system of target
17319 BGTA(K) = PTA(K)/PTA(5)
17321 * transformation of projectile into rest-system of target
17322 CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),PPR(1),PPR(2),
17323 & PPR(3),PPR(4),PPRTO1,PPR1(1),PPR1(2),PPR1(3),
17326 * direction cosines of projectile in target rest system
17327 CX = PPR1(1)/PPRTO1
17328 CY = PPR1(2)/PPRTO1
17329 CZ = PPR1(3)/PPRTO1
17331 * sample inelastic interaction
17332 IF (MODE.EQ.1) THEN
17333 CALL DT_DHADRI(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA)
17334 IF (IRH.EQ.1) GOTO 9998
17335 * sample elastic interaction
17336 ELSEIF (MODE.EQ.2) THEN
17337 CALL DT_ELHAIN(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA,IREJ1)
17338 IF (IREJ1.NE.0) THEN
17339 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in HADRIN'
17342 IF (IRH.EQ.1) GOTO 9998
17344 WRITE(LOUT,1001) MODE,INTHAD
17345 1001 FORMAT(1X,'HADRIN: warning! inconsistent interaction mode',
17346 & I4,' (INTHAD =',I4,')')
17350 * transform final state particles back into Lab.
17353 PX = CXRH(I)*PLRH(I)
17354 PY = CYRH(I)*PLRH(I)
17355 PZ = CZRH(I)*PLRH(I)
17356 CALL DT_DALTRA(BGTA(4),BGTA(1),BGTA(2),BGTA(3),
17357 & PX,PY,PZ,ELRH(I),PTOFSP,PFSP(1,NFSP),
17358 & PFSP(2,NFSP),PFSP(3,NFSP),PFSP(4,NFSP))
17359 IDFSP(NFSP) = ITRH(I)
17360 AMFSP2 = PFSP(4,NFSP)**2-PFSP(1,NFSP)**2-PFSP(2,NFSP)**2-
17362 IF (AMFSP2.LT.-TINY3) THEN
17363 WRITE(LOUT,1002) IDFSP(NFSP),PFSP(1,NFSP),PFSP(2,NFSP),
17364 & PFSP(3,NFSP),PFSP(4,NFSP),AMFSP2
17365 1002 FORMAT(1X,'HADRIN: warning! final state particle (id = ',
17366 & I2,') with negative mass^2',/,1X,5E12.4)
17369 PFSP(5,NFSP) = SQRT(ABS(AMFSP2))
17370 IF (ABS(PFSP(5,NFSP)-AAM(IDFSP(NFSP))).GT.TINY1) THEN
17371 WRITE(LOUT,1003) IDFSP(NFSP),AAM(IDFSP(NFSP)),
17373 1003 FORMAT(1X,'HADRIN: warning! final state particle',
17374 & ' (id = ',I2,') with inconsistent mass',/,1X,
17377 IF (KCORR.GT.2) GOTO 9999
17378 IMCORR(KCORR) = NFSP
17381 * dump final state particles for energy-momentum cons. check
17382 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
17383 & -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
17386 * transform momenta on mass shell in case of inconsistencies in
17388 IF (KCORR.GT.0) THEN
17389 IF (KCORR.EQ.2) THEN
17393 IF (IMCORR(1).EQ.1) THEN
17401 IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I1),PFSP(2,I1),
17402 & PFSP(3,I1),PFSP(4,I1),2,IDUM,IDUM)
17403 IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I2),PFSP(2,I2),
17404 & PFSP(3,I2),PFSP(4,I2),2,IDUM,IDUM)
17406 P1IN(K) = PFSP(K,I1)
17407 P2IN(K) = PFSP(K,I2)
17409 XM1 = AAM(IDFSP(I1))
17410 XM2 = AAM(IDFSP(I2))
17411 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
17412 IF (IREJ1.GT.0) THEN
17413 WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.'
17417 PFSP(K,I1) = P1OUT(K)
17418 PFSP(K,I2) = P2OUT(K)
17420 PFSP(5,I1) = SQRT(PFSP(4,I1)**2-PFSP(1,I1)**2
17421 & -PFSP(2,I1)**2-PFSP(3,I1)**2)
17422 PFSP(5,I2) = SQRT(PFSP(4,I2)**2-PFSP(1,I2)**2
17423 & -PFSP(2,I2)**2-PFSP(3,I2)**2)
17424 * dump final state particles for energy-momentum cons. check
17425 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I1),-PFSP(2,I1),
17426 & -PFSP(3,I1),-PFSP(4,I1),2,IDUM,IDUM)
17427 IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I2),-PFSP(2,I2),
17428 & -PFSP(3,I2),-PFSP(4,I2),2,IDUM,IDUM)
17431 * check energy-momentum conservation
17433 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,102,IREJ1)
17434 IF (IREJ1.NE.0) GOTO 9999
17448 *$ CREATE DT_HADCOL.FOR
17451 *===hadcol=============================================================*
17453 SUBROUTINE DT_HADCOL(IDPROJ,PPN,IDXTAR,IREJ)
17455 ************************************************************************
17456 * Interface to the HADRIN-routines for inelastic and elastic *
17457 * scattering. This subroutine samples hadron-nucleus interactions *
17458 * below DPM-threshold. *
17459 * IDPROJ BAMJET-index of projectile hadron *
17460 * PPN projectile momentum in target rest frame *
17461 * IDXTAR DTEVT1-index of target nucleon undergoing *
17462 * interaction with projectile hadron *
17463 * This subroutine replaces HADHAD. *
17464 * This version dated 5.5.95 is written by S. Roesler *
17465 ************************************************************************
17467 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17469 PARAMETER ( LINP = 10 ,
17472 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0)
17477 PARAMETER (NMXHKK=200000)
17478 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17479 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17480 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17481 * extended event history
17482 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17483 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17485 * nuclear potential
17487 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17488 & EBINDP(2),EBINDN(2),EPOT(2,210),
17489 & ETACOU(2),ICOUL,LFERMI
17490 * interface HADRIN-DPM
17491 COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
17492 * parameter for intranuclear cascade
17494 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
17495 * final state after inc step
17496 PARAMETER (MAXFSP=10)
17497 COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17498 * particle properties (BAMJET index convention)
17500 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17501 & IICH(210),IIBAR(210),K1(210),K2(210)
17503 DIMENSION PPROJ(5),PNUC(5)
17505 DATA LSTART /.TRUE./
17512 **sr 6/9/01 commented
17513 C TAUFOR = TAUFOR/2.0D0
17517 1000 FORMAT(/,1X,'HADCOL: Scattering handled by HADRIN')
17518 WRITE(LOUT,1001) TAUFOR
17519 1001 FORMAT(/,1X,'HADCOL: Formation zone parameter set to ',
17524 IDNUC = IDBAM(IDXTAR)
17525 IDNUC1 = IDT_MCHAD(IDNUC)
17526 IDPRO1 = IDT_MCHAD(IDPROJ)
17528 IF ((INTHAD.EQ.1).OR.(INTHAD.EQ.2)) THEN
17532 C CALL DT_SIHNIN(IDPRO1,IDNUC1,PPN,SIGIN)
17533 C CALL DT_SIHNEL(IDPRO1,IDNUC1,PPN,SIGEL)
17535 CALL DT_XSHN(IDPRO1,IDNUC1,PPN,DUMZER,SIGTOT,SIGEL)
17536 SIGIN = SIGTOT-SIGEL
17537 C SIGTOT = SIGIN+SIGEL
17540 IF (DT_RNDM(SIGIN).LT.SIGEL/SIGTOT) IPROC = 2
17546 PPROJ(5) = AAM(IDPROJ)
17547 PPROJ(4) = SQRT(PPROJ(5)**2+PPROJ(3)**2)
17549 PNUC(K) = PHKK(K,IDXTAR)
17555 IF (ILOOP.GT.100) GOTO 9999
17557 CALL DT_HADRIN(IDPROJ,PPROJ,IDNUC,PNUC,IPROC,IREJ1)
17558 IF (IREJ1.EQ.1) GOTO 9999
17560 IF (IREJ1.GT.1) THEN
17561 * no interaction possible
17562 * require Pauli blocking
17563 IF ((IDPROJ.EQ.1).AND.(PPROJ(4).LE.PFERMP(2)+PPROJ(5))) GOTO 2
17564 IF ((IDPROJ.EQ.8).AND.(PPROJ(4).LE.PFERMN(2)+PPROJ(5))) GOTO 2
17565 IF ((IIBAR(IDPROJ).NE.1).AND.
17566 & (PPROJ(4).LE.EPOT(2,IDPROJ)+PPROJ(5))) GOTO 2
17567 * store incoming particle as final state particle
17568 CALL DT_LTNUC(PPROJ(3),PPROJ(4),PCMS,ECMS,3)
17569 CALL DT_EVTPUT(1,IDPROJ,1,0,PPROJ(1),PPROJ(2),PCMS,ECMS,0,0,0)
17572 * require Pauli blocking for final state nucleons
17574 IF ((IDFSP(I).EQ.1).AND.
17575 & (PFSP(4,I).LE.PFERMP(2)+AAM(IDFSP(I)))) GOTO 2
17576 IF ((IDFSP(I).EQ.8).AND.
17577 & (PFSP(4,I).LE.PFERMN(2)+AAM(IDFSP(I)))) GOTO 2
17578 IF ((IIBAR(IDFSP(I)).NE.1).AND.
17579 & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I))))GOTO 2
17581 * store final state particles
17584 IF ((IIBAR(IDFSP(I)).EQ.1).AND.
17585 & (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I)))) IST = 16
17586 IDHAD = IDT_IPDGHA(IDFSP(I))
17587 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PCMS,ECMS,3)
17588 CALL DT_EVTPUT(IST,IDHAD,1,IDXTAR,PFSP(1,I),PFSP(2,I),
17590 IF (I.EQ.1) NPOINT(4) = NHKK
17591 VHKK(1,NHKK) = 0.5D0*(VHKK(1,1)+VHKK(1,IDXTAR))
17592 VHKK(2,NHKK) = 0.5D0*(VHKK(2,1)+VHKK(2,IDXTAR))
17593 VHKK(3,NHKK) = VHKK(3,IDXTAR)
17594 VHKK(4,NHKK) = VHKK(4,IDXTAR)
17595 WHKK(1,NHKK) = 0.5D0*(WHKK(1,1)+WHKK(1,IDXTAR))
17596 WHKK(2,NHKK) = 0.5D0*(WHKK(2,1)+WHKK(2,IDXTAR))
17597 WHKK(3,NHKK) = WHKK(3,1)
17598 WHKK(4,NHKK) = WHKK(4,1)
17610 *$ CREATE DT_GETEMU.FOR
17613 *===getemu=============================================================*
17615 SUBROUTINE DT_GETEMU(IT,ITZ,KKMAT,MODE)
17617 ************************************************************************
17618 * Sampling of emulsion component to be considered as target-nucleus. *
17619 * This version dated 6.5.95 is written by S. Roesler. *
17620 ************************************************************************
17622 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17624 PARAMETER ( LINP = 10 ,
17627 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
17629 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
17630 * emulsion treatment
17631 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
17633 * Glauber formalism: flags and parameters for statistics
17636 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
17638 IF (MODE.EQ.0) THEN
17640 RR = DT_RNDM(SUMFRA)
17643 DO 1 ICOMP=1,NCOMPO
17644 SUMFRA = SUMFRA+EMUFRA(ICOMP)
17645 IF (SUMFRA.GT.RR) THEN
17647 ITZ = IEMUCH(ICOMP)
17654 WRITE(LOUT,'(1X,A,E12.3)')
17655 & 'Warning! norm. failure within emulsion fractions',
17659 ELSEIF (MODE.EQ.1) THEN
17662 IDIFF = ABS(IT-IEMUMA(I))
17663 IF (IDIFF.LT.NDIFF) THEN
17672 * bypass for variable projectile/target/energy runs: the correct
17673 * Glauber data will be always loaded on kkmat=1
17674 IF (IOGLB.EQ.100) THEN
17681 *$ CREATE DT_NCLPOT.FOR
17684 *===nclpot=============================================================*
17686 SUBROUTINE DT_NCLPOT(IPZ,IP,ITZ,IT,AFERP,AFERT,MODE)
17688 ************************************************************************
17689 * Calculation of Coulomb and nuclear potential for a given configurat. *
17690 * IPZ, IP charge/mass number of proj. *
17691 * ITZ, IT charge/mass number of targ. *
17692 * AFERP,AFERT factors modifying proj./target pot. *
17693 * if =0, FERMOD is used *
17694 * MODE = 0 calculation of binding energy *
17695 * = 1 pre-calculated binding energy is used *
17696 * This version dated 16.11.95 is written by S. Roesler. *
17698 * Last change 28.12.2006 by S. Roesler. *
17699 ************************************************************************
17701 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17703 PARAMETER ( LINP = 10 ,
17706 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
17711 * particle properties (BAMJET index convention)
17713 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17714 & IICH(210),IIBAR(210),K1(210),K2(210)
17715 * nuclear potential
17717 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17718 & EBINDP(2),EBINDN(2),EPOT(2,210),
17719 & ETACOU(2),ICOUL,LFERMI
17721 DIMENSION IDXPOT(14)
17722 * ap an lam alam sig- sig+ sig0 tet0 tet- asig-
17723 DATA IDXPOT / 2, 9, 17, 18, 20, 21, 22, 97, 98, 99,
17724 * asig0 asig+ atet0 atet+
17725 & 100, 101, 102, 103/
17728 DATA LSTART /.TRUE./
17730 IF (MODE.EQ.0) THEN
17742 IF (AFERP.LE.ZERO) FERMIP = FERMOD
17744 IF (AFERT.LE.ZERO) FERMIT = FERMOD
17746 * Fermi momenta and binding energy for projectile
17747 IF ((IP.GT.1).AND.LFERMI) THEN
17748 IF (MODE.EQ.0) THEN
17749 C EBINDP(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ-1)
17750 C EBINDN(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ)
17753 EBINDP(1) = 1.0D-3*(DT_ENERGY(ONE,ONE)+DT_ENERGY(BIP,BIPZ)
17754 & -DT_ENERGY(AIP,AIPZ))
17755 IF (AIP.LE.AIPZ) THEN
17756 EBINDN(1) = EBINDP(1)
17757 WRITE(LOUT,*) ' DT_NCLPOT: AIP.LE.AIPZ (',AIP,AIPZ,')'
17759 EBINDN(1) = 1.0D-3*(DT_ENERGY(ONE,ZERO)
17760 & +DT_ENERGY(BIP,AIPZ)-DT_ENERGY(AIP,AIPZ))
17763 PFERMP(1) = FERMIP*AN*(AIPZ/AIP)**0.333333D0
17764 PFERMN(1) = FERMIP*AN*((AIP-AIPZ)/AIP)**0.33333D0
17769 * effective nuclear potential for projectile
17770 C EPOT(1,1) = PFERMP(1)**2/(2.0D0*AAM(1)) + EBINDP(1)
17771 C EPOT(1,8) = PFERMN(1)**2/(2.0D0*AAM(8)) + EBINDN(1)
17772 EPOT(1,1) = SQRT(PFERMP(1)**2+AAM(1)**2) -AAM(1) + EBINDP(1)
17773 EPOT(1,8) = SQRT(PFERMN(1)**2+AAM(8)**2) -AAM(8) + EBINDN(1)
17775 * Fermi momenta and binding energy for target
17776 IF ((IT.GT.1).AND.LFERMI) THEN
17777 IF (MODE.EQ.0) THEN
17778 C EBINDP(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ-1)
17779 C EBINDN(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ)
17783 EBINDP(2) = 1.0D-3*(DT_ENERGY(ONE,ONE)+DT_ENERGY(BIT,BITZ)
17784 & -DT_ENERGY(AIT,AITZ))
17786 IF (AIT.LE.AITZ) THEN
17787 EBINDN(2) = EBINDP(2)
17788 WRITE(LOUT,*) ' DT_NCLPOT: AIT.LE.AIPT (',AIT,AIPT,')'
17791 EBINDN(2) = 1.0D-3*(DT_ENERGY(ONE,ZERO)
17792 & +DT_ENERGY(BIT,AITZ)-DT_ENERGY(AIT,AITZ))
17796 PFERMP(2) = FERMIT*AN*(AITZ/AIT)**0.333333D0
17797 PFERMN(2) = FERMIT*AN*((AIT-AITZ)/AIT)**0.33333D0
17802 * effective nuclear potential for target
17803 C EPOT(2,1) = PFERMP(2)**2/(2.0D0*AAM(1)) + EBINDP(2)
17804 C EPOT(2,8) = PFERMN(2)**2/(2.0D0*AAM(8)) + EBINDN(2)
17805 EPOT(2,1) = SQRT(PFERMP(2)**2+AAM(1)**2) -AAM(1) + EBINDP(2)
17806 EPOT(2,8) = SQRT(PFERMN(2)**2+AAM(8)**2) -AAM(8) + EBINDN(2)
17809 EPOT(1,IDXPOT(I)) = EPOT(1,8)
17810 EPOT(2,IDXPOT(I)) = EPOT(2,8)
17816 IF (ICOUL.EQ.1) THEN
17818 & ETACOU(1) = 0.001116D0*AIPZ/(1.0D0+AIP**0.333D0)
17820 & ETACOU(2) = 0.001116D0*AITZ/(1.0D0+AIT**0.333D0)
17824 WRITE(LOUT,1000) IP,IPZ,IT,ITZ,EBINDP,EBINDN,
17825 & EPOT(1,1)-EBINDP(1),EPOT(2,1)-EBINDP(2),
17826 & EPOT(1,8)-EBINDN(1),EPOT(2,8)-EBINDN(2),
17828 1000 FORMAT(/,/,1X,'NCLPOT: quantities for inclusion of nuclear'
17829 & ,' effects',/,12X,'---------------------------',
17830 & '----------------',/,/,38X,'projectile',
17831 & ' target',/,/,1X,'Mass number / charge',
17832 & 17X,I3,' /',I3,6X,I3,' /',I3,/,1X,'Binding energy -',
17833 & ' proton (GeV) ',2E14.4,/,17X,'- neutron (GeV)'
17834 & ,1X,2E14.4,/,1X,'Fermi-potential - proton (GeV)',
17835 & 1X,2E14.4,/,17X,'- neutron (GeV) ',2E14.4,/,/,
17836 & 1X,'Scale factor for Fermi-momentum ',F4.2,/,
17837 & /,1X,'Coulomb-energy ',2(E14.4,' GeV '),/,/)
17844 *$ CREATE DT_RESNCL.FOR
17847 *===resncl=============================================================*
17849 SUBROUTINE DT_RESNCL(EPN,NLOOP,MODE)
17851 ************************************************************************
17852 * Treatment of residual nuclei and nuclear effects. *
17853 * MODE = 1 initializations *
17854 * = 2 treatment of final state *
17855 * This version dated 16.11.95 is written by S. Roesler. *
17857 * Last change 05.01.2007 by S. Roesler. *
17858 ************************************************************************
17860 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17862 PARAMETER ( LINP = 10 ,
17865 PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,THREE=3.D0,TINY3=1.0D-3,
17866 & TINY2=1.0D-2,TINY1=1.0D-1,TINY4=1.0D-4,TINY10=1.0D-10,
17867 & ONETHI=ONE/THREE)
17868 PARAMETER (AMUAMU = 0.93149432D0,
17871 PARAMETER ( EMVGEV = 1.0 D-03 )
17872 PARAMETER ( AMUGEV = 0.93149432 D+00 )
17873 PARAMETER ( AMPRTN = 0.93827231 D+00 )
17874 PARAMETER ( AMNTRN = 0.93956563 D+00 )
17875 PARAMETER ( AMELCT = 0.51099906 D-03 )
17876 PARAMETER ( HLFHLF = 0.5D+00 )
17877 PARAMETER ( FERTHO = 14.33 D-09 )
17878 PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
17879 PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
17880 PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
17883 PARAMETER (NMXHKK=200000)
17884 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17885 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17886 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17887 * extended event history
17888 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17889 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17891 * particle properties (BAMJET index convention)
17893 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17894 & IICH(210),IIBAR(210),K1(210),K2(210)
17895 * flags for input different options
17896 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17897 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17898 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17899 * nuclear potential
17901 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17902 & EBINDP(2),EBINDN(2),EPOT(2,210),
17903 & ETACOU(2),ICOUL,LFERMI
17904 * properties of interacting particles
17905 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
17906 * properties of photon/lepton projectiles
17907 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
17908 * Lorentz-parameters of the current interaction
17909 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
17910 & UMO,PPCM,EPROJ,PPROJ
17911 * treatment of residual nuclei: wounded nucleons
17912 COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
17913 * treatment of residual nuclei: 4-momenta
17914 LOGICAL LRCLPR,LRCLTA
17915 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
17916 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
17918 DIMENSION PFSP(4),PSEC(4),PSEC0(4)
17919 DIMENSION PMOMB(5000),IDXB(5000),PMOMM(10000),IDXM(10000),
17920 & IDXCOR(15000),IDXOTH(NMXHKK)
17924 *------- initializations
17927 * initialize arrays for residual nuclei
17942 * correction of projectile 4-momentum for effective target pot.
17943 * and Coulomb-energy (in case of hadron-nucleus interaction only)
17944 * IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
17947 * positively charged hadron - check energy for Coloumb pot.
17948 * IF (IICH(IJPROJ).EQ.1) THEN
17949 * THRESH = ETACOU(2)+AAM(IJPROJ)
17950 * IF (EPNI.LE.THRESH) THEN
17952 * 1000 FORMAT(/,1X,'KKINC: WARNING! projectile energy',
17953 * & ' below Coulomb threshold - event rejected',/)
17957 * negatively charged hadron - increase energy by Coulomb energy
17958 * ELSEIF (IICH(IJPROJ).EQ.-1) THEN
17959 * EPNI = EPNI+ETACOU(2)
17961 * IF ((IJPROJ.EQ.1).OR.(IJPROJ.EQ.8)) THEN
17962 * Effective target potential
17963 *sr 6.6. binding energy only (to avoid negative exc. energies)
17964 C EPNI = EPNI+EPOT(2,IJPROJ)
17965 * EBIPOT = EBINDP(2)
17966 * IF ((IJPROJ.NE.1).AND.(ABS(EPOT(2,IJPROJ)).GT.5.0D-3))
17967 * & EBIPOT = EBINDN(2)
17968 * EPNI = EPNI+ABS(EBIPOT)
17969 * re-initialization of DTLTRA
17973 * CALL DT_LTINI(IJPROJ,IJTARG,EPNI,DUM1,DUM2,0)
17977 * projectile in n-n cms
17978 IF ((IP.LE.1).AND.(IT.GT.1)) THEN
17979 PMASS1 = AAM(IJPROJ)
17981 C IF (IJPROJ.EQ.7) PMASS1 = AAM(33)
17982 IF (IJPROJ.EQ.7) PMASS1 = AAM(IJPROJ)-SQRT(VIRT)
17984 PM1 = SIGN(PMASS1**2,PMASS1)
17985 PM2 = SIGN(PMASS2**2,PMASS2)
17986 PINIPR(4) = (UMO**2-PM2+PM1)/(TWO*UMO)
17988 IF (PMASS1.GT.ZERO) THEN
17989 PINIPR(3) = SQRT((PINIPR(4)-PINIPR(5))
17990 & *(PINIPR(4)+PINIPR(5)))
17992 PINIPR(3) = SQRT(PINIPR(4)**2-PM1)
17996 PINITA(5) = AIT*AMUAMU+1.0D-3*DT_ENERGY(AIT,AITZ)
17997 CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
17998 ELSEIF ((IP.GT.1).AND.(IT.LE.1)) THEN
18000 PMASS2 = AAM(IJTARG)
18001 PM1 = SIGN(PMASS1**2,PMASS1)
18002 PM2 = SIGN(PMASS2**2,PMASS2)
18003 PINITA(4) = (UMO**2-PM1+PM2)/(TWO*UMO)
18005 PINITA(3) = -SQRT((PINITA(4)-PINITA(5))
18006 & *(PINITA(4)+PINITA(5)))
18009 PINIPR(5) = AIP*AMUAMU+1.0D-3*DT_ENERGY(AIP,AIPZ)
18010 CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
18011 ELSEIF ((IP.GT.1).AND.(IT.GT.1)) THEN
18014 PINIPR(5) = AIP*AMUAMU+1.0D-3*DT_ENERGY(AIP,AIPZ)
18015 CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
18018 PINITA(5) = AIT*AMUAMU+1.0D-3*DT_ENERGY(AIT,AITZ)
18019 CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
18024 *------- treatment of final state
18028 IF (NLOOP.GT.1) SCPOT = 0.10D0
18029 C WRITE(LOUT,*) 'event ',NEVHKK,NLOOP,SCPOT
18041 DO 900 I=NPOINT(4),NHKK
18043 IF (ISTHKK(I).EQ.1) THEN
18044 IF (IDBAM(I).EQ.7) GOTO 900
18047 * particle moving into forward direction
18048 IF (PHKK(3,I).GE.ZERO) THEN
18049 * most likely to be effected by projectile potential
18051 * there is no projectile nucleus, try target
18052 IF ((IP.LE.1).OR.((IP-NPW).LE.1)) THEN
18054 IF (IP.GT.1) IOTHER = 1
18055 * there is no target nucleus --> skip
18056 IF ((IT.LE.1).OR.((IT-NTW).LE.1)) GOTO 900
18058 * particle moving into backward direction
18060 * most likely to be effected by target potential
18062 * there is no target nucleus, try projectile
18063 IF ((IT.LE.1).OR.((IT-NTW).LE.1)) THEN
18065 IF (IT.GT.1) IOTHER = 1
18066 * there is no projectile nucleus --> skip
18067 IF ((IP.LE.1).OR.((IP-NPW).LE.1)) GOTO 900
18071 * nobam=3: particle is in overlap-region or neither inside proj. nor target
18072 * =1: particle is not in overlap-region AND is inside target (2)
18073 * =2: particle is not in overlap-region AND is inside projectile (1)
18074 * flag particles which are inside the nucleus ipot but not in its
18076 IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) IFLG = IPOT
18077 IF (IDBAM(I).NE.0) THEN
18078 * baryons: keep all nucleons and all others where flag is set
18079 IF (IIBAR(IDBAM(I)).NE.0) THEN
18080 IF ((IDBAM(I).EQ.1).OR.(IDBAM(I).EQ.8).OR.(IFLG.GT.0))
18083 PMOMB(NOB) = PHKK(3,I)
18084 IDXB(NOB) = SIGN(10000000*IABS(IFLG)
18085 & +1000000*IOTHER+I,IFLG)
18087 * mesons: keep only those mesons where flag is set
18089 IF (IFLG.GT.0) THEN
18091 PMOMM(NOM) = PHKK(3,I)
18092 IDXM(NOM) = 10000000*IFLG+1000000*IOTHER+I
18099 * sort particles in the arrays according to increasing long. momentum
18100 CALL DT_SORT1(PMOMB,IDXB,NOB,1,NOB,1)
18101 CALL DT_SORT1(PMOMM,IDXM,NOM,1,NOM,1)
18103 * shuffle indices into one and the same array according to the later
18104 * sequence of correction
18108 IF (PMOMB(I).GT.ZERO) GOTO 911
18110 IDXCOR(NCOR) = IDXB(I)
18116 IF (PMOMB(I).LT.ZERO) GOTO 913
18118 IDXCOR(NCOR) = IDXB(I)
18123 IF (PMOMB(I).GT.ZERO) THEN
18125 IDXCOR(NCOR) = IDXB(I)
18133 IDXCOR(NCOR) = IDXB(I)
18137 IF (PMOMM(I).GT.ZERO) GOTO 926
18139 IDXCOR(NCOR) = IDXM(I)
18144 IF (PMOMM(I).LT.ZERO) GOTO 928
18146 IDXCOR(NCOR) = IDXM(I)
18150 C IF (NEVHKK.EQ.484) THEN
18151 C WRITE(LOUT,9000) JPCW,JPW-JPCW,JTCW,JTW-JTCW
18152 C 9000 FORMAT(1X,'wounded nucleons (proj.-p,n targ.-p,n)',/,4I10)
18153 C WRITE(LOUT,9001) NOB,NOM,NCOR
18154 C 9001 FORMAT(1X,'produced particles (baryons,mesons,all)',3I10)
18155 C WRITE(LOUT,'(/,A)') ' baryons '
18157 CC J = IABS(IDXB(I))
18158 CC INDEX = J-IABS(J/10000000)*10000000
18159 C IPOT = IABS(IDXB(I))/10000000
18160 C IOTHER = IABS(IDXB(I))/1000000-IPOT*10
18161 C INDEX = IABS(IDXB(I))-IPOT*10000000-IOTHER*1000000
18162 C WRITE(LOUT,9002) I,INDEX,IDXB(I),IDBAM(INDEX),PMOMB(I)
18164 C WRITE(LOUT,'(/,A)') ' mesons '
18166 CC INDEX = IDXM(I)-IABS(IDXM(I)/10000000)*10000000
18167 C IPOT = IABS(IDXM(I))/10000000
18168 C IOTHER = IABS(IDXM(I))/1000000-IPOT*10
18169 C INDEX = IABS(IDXM(I))-IPOT*10000000-IOTHER*1000000
18170 C WRITE(LOUT,9002) I,INDEX,IDXM(I),IDBAM(INDEX),PMOMM(I)
18172 C 9002 FORMAT(1X,4I14,E14.5)
18173 C WRITE(LOUT,'(/,A)') ' all '
18175 CC J = IABS(IDXCOR(I))
18176 CC INDEX = J-IABS(J/10000000)*10000000
18177 CC IPOT = IABS(IDXCOR(I))/10000000
18178 C IOTHER = IABS(IDXCOR(I))/1000000-IPOT*10
18179 C INDEX = IABS(IDXCOR(I))-IPOT*10000000-IOTHER*1000000
18180 C WRITE(LOUT,9003) I,INDEX,IDXCOR(I),IDBAM(INDEX)
18182 C 9003 FORMAT(1X,4I14)
18186 IPOT = IABS(IDXCOR(ICOR))/10000000
18187 IOTHER = IABS(IDXCOR(ICOR))/1000000-IPOT*10
18188 I = IABS(IDXCOR(ICOR))-IPOT*10000000-IOTHER*1000000
18193 * reduction of particle momentum by corresponding nuclear potential
18194 * (this applies only if Fermi-momenta are requested)
18198 * Lorentz-transformation into the rest system of the selected nucleus
18200 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
18201 & PSEC(1),PSEC(2),PSEC(3),PSEC(4),IDSEC,IMODE)
18202 PSECO = SQRT(PSEC(1)**2+PSEC(2)**2+PSEC(3)**2)
18203 AMSEC = SQRT(ABS((PSEC(4)-PSECO)*(PSEC(4)+PSECO)))
18207 IF ((EPROJ.GE.1.0D4).AND.(IDSEC.EQ.7)) CHKLEV = TINY1
18208 IF (EPROJ.GE.2.0D6) CHKLEV = 1.0D0
18209 IF (ABS(AMSEC-AAM(IDSEC)).GT.CHKLEV) THEN
18210 IF (IOULEV(3).GT.0)
18211 & WRITE(LOUT,2000) I,NEVHKK,IDSEC,AMSEC,AAM(IDSEC)
18212 2000 FORMAT(1X,'RESNCL: inconsistent mass of particle',
18213 & ' at entry ',I5,' (evt.',I8,')',/,' IDSEC: ',
18214 & I4,' AMSEC: ',E12.3,' AAM(IDSEC): ',E12.3,/)
18222 * the correction for nuclear potential effects is applied to as many
18223 * p/n as many nucleons were wounded; the momenta of other final state
18224 * particles are corrected only if they materialize inside the corresp.
18225 * nucleus (here: NOBAM = 1 part. outside proj., = 2 part. outside targ
18226 * = 3 part. outside proj. and targ., >=10 in overlapping region)
18227 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) THEN
18228 IF (IPOT.EQ.1) THEN
18229 IF ((JPW.GT.0).AND.(IOTHER.EQ.0)) THEN
18230 * this is most likely a wounded nucleon
18232 C RDIST = SQRT((VHKK(1,IPW(JPW))/FM2MM)**2
18233 C & +(VHKK(2,IPW(JPW))/FM2MM)**2
18234 C & +(VHKK(3,IPW(JPW))/FM2MM)**2)
18235 C RAD = RNUCLE*DBLE(IP)**ONETHI
18236 C FDEN = 1.4D0*DT_DENSIT(IP,RDIST,RAD)
18237 C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
18239 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18243 * correct only if part. was materialized inside nucleus
18244 * and if it is ouside the overlapping region
18245 IF ((NOBAM(I).NE.1).AND.(NOBAM(I).LT.3)) THEN
18246 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18250 ELSEIF (IPOT.EQ.2) THEN
18251 IF ((JTW.GT.0).AND.(IOTHER.EQ.0)) THEN
18252 * this is most likely a wounded nucleon
18254 C RDIST = SQRT((VHKK(1,ITW(JTW))/FM2MM)**2
18255 C & +(VHKK(2,ITW(JTW))/FM2MM)**2
18256 C & +(VHKK(3,ITW(JTW))/FM2MM)**2)
18257 C RAD = RNUCLE*DBLE(IT)**ONETHI
18258 C FDEN = 1.4D0*DT_DENSIT(IT,RDIST,RAD)
18259 C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
18261 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18265 * correct only if part. was materialized inside nucleus
18266 IF ((NOBAM(I).NE.2).AND.(NOBAM(I).LT.3)) THEN
18267 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18273 IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) THEN
18274 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18279 IF (NLOOP.EQ.1) THEN
18280 * Coulomb energy correction:
18281 * the treatment of Coulomb potential correction is similar to the
18282 * one for nuclear potential
18283 IF (IDSEC.EQ.1) THEN
18284 IF ((IPOT.EQ.1).AND.(JPCW.GT.0)) THEN
18286 ELSEIF ((IPOT.EQ.2).AND.(JTCW.GT.0)) THEN
18289 IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
18292 IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
18294 IF (IICH(IDSEC).EQ.1) THEN
18295 * pos. particles: check if they are able to escape Coulomb potential
18296 IF (PSEC(4).LT.AMSEC+ETACOU(IPOT)) THEN
18297 ISTHKK(I) = 14+IPOT
18298 IF (ISTHKK(I).EQ.15) THEN
18300 PHKK(K,I) = PSEC0(K)
18301 TRCLPR(K) = TRCLPR(K)+PSEC0(K)
18303 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
18304 IF (IDSEC.EQ.1) NPCW = NPCW-1
18305 ELSEIF (ISTHKK(I).EQ.16) THEN
18307 PHKK(K,I) = PSEC0(K)
18308 TRCLTA(K) = TRCLTA(K)+PSEC0(K)
18310 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
18311 IF (IDSEC.EQ.1) NTCW = NTCW-1
18315 ELSEIF (IICH(IDSEC).EQ.-1) THEN
18316 * neg. particles: decrease energy by Coulomb-potential
18317 PSEC(4) = PSEC(4)-ETACOU(IPOT)
18324 IF (PSEC(4).LT.AMSEC) THEN
18325 IF (IOULEV(6).GT.0)
18326 & WRITE(LOUT,2001) I,IDSEC,PSEC(4),AMSEC
18327 2001 FORMAT(1X,'KKINC: particle at DTEVT1-pos. ',I5,
18328 & ' is not allowed to escape nucleus',/,
18329 & 8X,'id : ',I3,' reduced energy: ',E15.4,
18331 ISTHKK(I) = 14+IPOT
18332 IF (ISTHKK(I).EQ.15) THEN
18334 PHKK(K,I) = PSEC0(K)
18335 TRCLPR(K) = TRCLPR(K)+PSEC0(K)
18337 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
18338 IF (IDSEC.EQ.1) NPCW = NPCW-1
18339 ELSEIF (ISTHKK(I).EQ.16) THEN
18341 PHKK(K,I) = PSEC0(K)
18342 TRCLTA(K) = TRCLTA(K)+PSEC0(K)
18344 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
18345 IF (IDSEC.EQ.1) NTCW = NTCW-1
18350 IF (JPMOD.EQ.1) THEN
18351 PSECN = SQRT( (PSEC(4)-AMSEC)*(PSEC(4)+AMSEC) )
18352 * 4-momentum after correction for nuclear potential
18354 PSEC(K) = PSEC(K)*PSECN/PSECO
18357 * store recoil momentum from particles escaping the nuclear potentials
18359 IF (IPOT.EQ.1) THEN
18360 TRCLPR(K) = TRCLPR(K)+PSEC0(K)-PSEC(K)
18361 ELSEIF (IPOT.EQ.2) THEN
18362 TRCLTA(K) = TRCLTA(K)+PSEC0(K)-PSEC(K)
18366 * transform momentum back into n-n cms
18368 CALL DT_LTRANS(PSEC(1),PSEC(2),PSEC(3),PSEC(4),
18369 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
18377 PFSP(K) = PFSP(K)+PHKK(K,I)
18382 DO 33 I=NPOINT(4),NHKK
18383 IF ((ISTHKK(I).EQ.1).AND.(IDXOTH(I).LT.0)) THEN
18384 PFSP(1) = PFSP(1)+PHKK(1,I)
18385 PFSP(2) = PFSP(2)+PHKK(2,I)
18386 PFSP(3) = PFSP(3)+PHKK(3,I)
18387 PFSP(4) = PFSP(4)+PHKK(4,I)
18392 PRCLPR(K) = TRCLPR(K)
18393 PRCLTA(K) = TRCLTA(K)
18396 IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
18397 * hadron-nucleus interactions: get residual momentum from energy-
18398 * momentum conservation
18401 PRCLTA(K) = PINIPR(K)+PINITA(K)-PFSP(K)
18404 * nucleus-hadron, nucleus-nucleus: get residual momentum from
18405 * accumulated recoil momenta of particles leaving the spectators
18406 * transform accumulated recoil momenta of residual nuclei into
18410 CALL DT_LTNUC(PZI,PEI,PRCLPR(3),PRCLPR(4),2)
18413 CALL DT_LTNUC(PZI,PEI,PRCLTA(3),PRCLTA(4),3)
18414 C IF (IP.GT.1) THEN
18415 PRCLPR(3) = PRCLPR(3)+PINIPR(3)
18416 PRCLPR(4) = PRCLPR(4)+PINIPR(4)
18419 PRCLTA(3) = PRCLTA(3)+PINITA(3)
18420 PRCLTA(4) = PRCLTA(4)+PINITA(4)
18424 * check momenta of residual nuclei
18426 CALL DT_EVTEMC(-PINIPR(1),-PINIPR(2),-PINIPR(3),-PINIPR(4),
18428 CALL DT_EVTEMC(-PINITA(1),-PINITA(2),-PINITA(3),-PINITA(4),
18430 CALL DT_EVTEMC(PRCLPR(1),PRCLPR(2),PRCLPR(3),PRCLPR(4),
18432 CALL DT_EVTEMC(PRCLTA(1),PRCLTA(2),PRCLTA(3),PRCLTA(4),
18434 CALL DT_EVTEMC(PFSP(1),PFSP(2),PFSP(3),PFSP(4),2,IDUM,IDUM)
18435 **sr 19.12. changed to avoid output when used with phojet
18438 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,501,IREJ1)
18439 C IF ((NEVHKK.EQ.409).OR.(NEVHKK.EQ.460).OR.(NEVHKK.EQ.765))
18440 C & CALL DT_EVTOUT(4)
18441 IF (IREJ1.GT.0) RETURN
18447 *$ CREATE DT_SCN4BA.FOR
18450 *===scn4ba=============================================================*
18452 SUBROUTINE DT_SCN4BA
18454 ************************************************************************
18455 * SCan /DTEVT1/ 4 BAryons which are not able to escape nuclear pot. *
18456 * This version dated 12.12.95 is written by S. Roesler. *
18457 ************************************************************************
18459 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18461 PARAMETER ( LINP = 10 ,
18464 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
18468 PARAMETER (NMXHKK=200000)
18469 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18470 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18471 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18472 * extended event history
18473 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18474 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18476 * particle properties (BAMJET index convention)
18478 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18479 & IICH(210),IIBAR(210),K1(210),K2(210)
18480 * properties of interacting particles
18481 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
18482 * nuclear potential
18484 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18485 & EBINDP(2),EBINDN(2),EPOT(2,210),
18486 & ETACOU(2),ICOUL,LFERMI
18487 * treatment of residual nuclei: wounded nucleons
18488 COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
18489 * treatment of residual nuclei: 4-momenta
18490 LOGICAL LRCLPR,LRCLTA
18491 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18492 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18494 DIMENSION PLAB(2,5),PCMS(4)
18498 * get number of wounded nucleons
18515 * projectile nucleons wounded in primary interaction and in fzc
18516 IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.17)) THEN
18520 IF (IDHKK(I).EQ.2212) NPCW = NPCW+1
18521 IF (ISTHKK(I).EQ.11) NPW0 = NPW0+1
18522 C IF (IP.GT.1) THEN
18524 TRCLPR(K) = TRCLPR(K)-PHKK(K,I)
18527 * target nucleons wounded in primary interaction and in fzc
18528 ELSEIF ((ISTHKK(I).EQ.12).OR.(ISTHKK(I).EQ.18)) THEN
18532 IF (IDHKK(I).EQ.2212) NTCW = NTCW+1
18533 IF (ISTHKK(I).EQ.12) NTW0 = NTW0+1
18536 TRCLTA(K) = TRCLTA(K)-PHKK(K,I)
18539 ELSEIF (ISTHKK(I).EQ.13) THEN
18541 ELSEIF (ISTHKK(I).EQ.14) THEN
18546 DO 11 I=NPOINT(4),NHKK
18547 * baryons which are unable to escape the nuclear potential of proj.
18548 IF (ISTHKK(I).EQ.15) THEN
18551 IF (IIBAR(IDBAM(I)).NE.0) THEN
18553 IF (IICH(IDBAM(I)).GT.0) NPCW = NPCW-1
18556 TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
18558 * baryons which are unable to escape the nuclear potential of targ.
18559 ELSEIF (ISTHKK(I).EQ.16) THEN
18562 IF (IIBAR(IDBAM(I)).NE.0) THEN
18564 IF (IICH(IDBAM(I)).GT.0) NTCW = NTCW-1
18567 TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
18572 * residual nuclei so far
18576 * ckeck for "residual nuclei" consisting of one nucleon only
18577 * treat it as final state particle
18578 IF (IRESP.EQ.1) THEN
18580 IST = ISTHKK(ISGLPR)
18581 CALL DT_LTRANS(PHKK(1,ISGLPR),PHKK(2,ISGLPR),
18582 & PHKK(3,ISGLPR),PHKK(4,ISGLPR),
18583 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,2)
18584 IF (IST.EQ.13) THEN
18585 ISTHKK(ISGLPR) = 11
18589 CALL DT_EVTPUT(1,IDHKK(ISGLPR),ISGLPR,0,
18590 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),
18591 & IDRES(ISGLPR),IDXRES(ISGLPR),IDCH(ISGLPR))
18592 NOBAM(NHKK) = NOBAM(ISGLPR)
18593 JDAHKK(1,ISGLPR) = NHKK
18595 TRCLPR(K) = TRCLPR(K)-PHKK(K,ISGLPR)
18598 IF (IREST.EQ.1) THEN
18600 IST = ISTHKK(ISGLTA)
18601 CALL DT_LTRANS(PHKK(1,ISGLTA),PHKK(2,ISGLTA),
18602 & PHKK(3,ISGLTA),PHKK(4,ISGLTA),
18603 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,3)
18604 IF (IST.EQ.14) THEN
18605 ISTHKK(ISGLTA) = 12
18609 CALL DT_EVTPUT(1,IDHKK(ISGLTA),ISGLTA,0,
18610 & PCMS(1),PCMS(2),PCMS(3),PCMS(4),
18611 & IDRES(ISGLTA),IDXRES(ISGLTA),IDCH(ISGLTA))
18612 NOBAM(NHKK) = NOBAM(ISGLTA)
18613 JDAHKK(1,ISGLTA) = NHKK
18615 TRCLTA(K) = TRCLTA(K)-PHKK(K,ISGLTA)
18619 * get nuclear potential corresp. to the residual nucleus
18624 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
18626 * baryons unable to escape the nuclear potential are treated as
18627 * excited nucleons (ISTHKK=15,16)
18628 DO 3 I=NPOINT(4),NHKK
18629 IF (ISTHKK(I).EQ.1) THEN
18631 IF ( ((ID.EQ.1).OR.(ID.EQ.8)).AND.(NOBAM(I).NE.3) ) THEN
18632 * final state n and p not being outside of both nuclei are considered
18635 IF ( (IP.GT.1) .AND.(IRESP.GT.1).AND.
18636 & (NOBAM(I).NE.1).AND.(NPW.GT.0) ) THEN
18637 * Lorentz-trsf. into proj. rest sys. for those being inside proj.
18638 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
18639 & PHKK(4,I),PLAB(1,1),PLAB(1,2),PLAB(1,3),
18641 PLABT = SQRT(PLAB(1,1)**2+PLAB(1,2)**2+PLAB(1,3)**2)
18642 PLAB(1,5) = SQRT(ABS( (PLAB(1,4)-PLABT)*
18643 & (PLAB(1,4)+PLABT) ))
18644 EKIN = PLAB(1,4)-PLAB(1,5)
18645 IF (EKIN.LE.EPOT(1,ID)) NPOTP = 15
18646 IF ((ID.EQ.1).AND.(NPCW.LE.0)) NPOTP = 1
18648 IF ( (IT.GT.1) .AND.(IREST.GT.1).AND.
18649 & (NOBAM(I).NE.2).AND.(NTW.GT.0) ) THEN
18650 * Lorentz-trsf. into targ. rest sys. for those being inside targ.
18651 CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
18652 & PHKK(4,I),PLAB(2,1),PLAB(2,2),PLAB(2,3),
18654 PLABT = SQRT(PLAB(2,1)**2+PLAB(2,2)**2+PLAB(2,3)**2)
18655 PLAB(2,5) = SQRT(ABS( (PLAB(2,4)-PLABT)*
18656 & (PLAB(2,4)+PLABT) ))
18657 EKIN = PLAB(2,4)-PLAB(2,5)
18658 IF (EKIN.LE.EPOT(2,ID)) NPOTT = 16
18659 IF ((ID.EQ.1).AND.(NTCW.LE.0)) NPOTT = 1
18661 IF (PHKK(3,I).GE.ZERO) THEN
18663 IF (NPOTP.NE.1) ISTHKK(I) = NPOTP
18666 IF (NPOTT.NE.1) ISTHKK(I) = NPOTT
18668 IF (ISTHKK(I).NE.1) THEN
18671 PHKK(K,I) = PLAB(J,K)
18673 IF (ISTHKK(I).EQ.15) THEN
18675 IF (ID.EQ.1) NPCW = NPCW-1
18677 TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
18679 ELSEIF (ISTHKK(I).EQ.16) THEN
18681 IF (ID.EQ.1) NTCW = NTCW-1
18683 TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
18691 * again: get nuclear potential corresp. to the residual nucleus
18696 c AFERP = 1.2D0*FERMOD*(ONE+(DBLE(IP+10-NPW0)/DBLE(IP+10))**1.1D0)
18697 cC AFERP = 1.21D0*FERMOD*(ONE+(DBLE(IP+40-NPW0)/DBLE(IP+40))**1.1D0)
18698 c & *(0.94D0+0.3D0*EXP(-DBLE(NPW0)/5.0D0)) /2.0D0
18700 c AFERT = 1.2D0*FERMOD*(ONE+(DBLE(IT+10-NTW0)/DBLE(IT+10))**1.1D0)
18701 cC AFERT = 1.21D0*FERMOD*(ONE+(DBLE(IT+40-NTW0)/DBLE(IT+40))**1.1D0)
18702 c & *(0.94D0+0.3D0*EXP(-DBLE(NTW0)/5.0D0)) /2.0D0
18704 C IF (AFERP.LT.FERMOD) AFERP = FERMOD+0.1
18705 C IF (AFERT.LT.FERMOD) AFERT = FERMOD+0.1
18706 C IF (AFERP.GT.0.85D0) AFERP = 0.85D0
18707 C IF (AFERT.GT.0.85D0) AFERT = 0.85D0
18708 AFERP = FERMOD+0.1D0
18709 AFERT = FERMOD+0.1D0
18711 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,AFERP,AFERT,1)
18716 *$ CREATE DT_FICONF.FOR
18719 *===ficonf=============================================================*
18721 SUBROUTINE DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ)
18723 ************************************************************************
18724 * Treatment of FInal CONFiguration including evaporation, fission and *
18725 * Fermi-break-up (for light nuclei only). *
18726 * Adopted from the original routine FINALE and extended to residual *
18727 * projectile nuclei. *
18728 * This version dated 12.12.95 is written by S. Roesler. *
18730 * Last change 27.12.2006 by S. Roesler. *
18731 ************************************************************************
18733 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18735 PARAMETER ( LINP = 10 ,
18738 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
18739 PARAMETER (ANGLGB=5.0D-16)
18740 PARAMETER (AMUAMU=0.93149432D0,AMELEC=0.51099906D-3)
18743 PARAMETER (NMXHKK=200000)
18744 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18745 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18746 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18747 * extended event history
18748 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18749 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18751 * rejection counter
18752 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
18753 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
18754 & IREXCI(3),IRDIFF(2),IRINC
18755 * central particle production, impact parameter biasing
18756 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
18757 * particle properties (BAMJET index convention)
18759 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18760 & IICH(210),IIBAR(210),K1(210),K2(210)
18761 * treatment of residual nuclei: 4-momenta
18762 LOGICAL LRCLPR,LRCLTA
18763 COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18764 & TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18765 * treatment of residual nuclei: properties of residual nuclei
18766 COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
18767 & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
18768 & NTOTFI(2),NPROFI(2)
18769 * statistics: residual nuclei
18770 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
18771 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
18772 & NINCST(2,4),NINCEV(2),
18773 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
18774 & NRESPB(2),NRESCH(2),NRESEV(4),
18775 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
18777 * flags for input different options
18778 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18779 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18780 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18781 * (original name: FINUC)
18782 PARAMETER (MXP=999)
18783 COMMON /FKFINU/ CXR (MXP), CYR (MXP), CZR (MXP),
18784 & CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP),
18785 & TKI (MXP), PLR (MXP), WEI (MXP),
18786 & TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP,
18788 * (original name: RESNUC)
18789 LOGICAL LRNFSS, LFRAGM
18790 COMMON /FKRESN/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
18791 & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
18792 & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES,
18793 & PYRES, PZRES, PTRES2, KTARP, KTARN, IGREYP,
18794 & IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,
18795 & ICRES, IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU,
18796 & IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG,
18797 & IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS,
18799 COMMON /FKNDAT/ AV0WEL, APFRMX, AEFRMX, AEFRMA,
18800 & RDSNUC, V0WELL (2), PFRMMX (2), EFRMMX (2),
18801 & EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2),
18802 & VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2),
18803 & PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2),
18804 & EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2),
18805 & ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV ,
18806 & AMRCSQ , ATO1O3 , ZTO1O3 , ELBNDE (0:100)
18807 * (original name: PAREVT)
18808 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
18809 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
18810 PARAMETER ( NALLWP = 39 )
18811 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
18812 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
18813 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
18814 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
18816 COMMON /DTEVNO/ NEVENT,ICASCA
18818 DIMENSION INUC(2),IDXPAR(2),IDPAR(2),AIF(2),AIZF(2),AMRCL(2),
18819 & PRCL(2,4),MO1(2),MO2(2),VRCL(2,4),WRCL(2,4),
18820 & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4)
18822 DIMENSION EXPNUC(2),EXC(2,260),NEXC(2,260)
18824 DATA EXC,NEXC /520*ZERO,520*0/
18825 DATA EXPNUC /4.0D-3,4.0D-3/
18831 * skip residual nucleus treatment if not requested or in case
18832 * of central collisions
18833 IF ((.NOT.LEVPRT).OR.(ICENTR.GT.0).OR.(ICENTR.EQ.-1)) RETURN
18860 * number of final state particles
18861 IF (ABS(ISTHKK(I)).EQ.1) THEN
18866 * properties of remaining nucleon configurations
18868 IF ((ISTHKK(I).EQ.13).OR.(ISTHKK(I).EQ.15)) KF = 1
18869 IF ((ISTHKK(I).EQ.14).OR.(ISTHKK(I).EQ.16)) KF = 2
18871 IF (MO1(KF).EQ.0) MO1(KF) = I
18873 * position of residual nucleus = average position of nucleons
18875 VRCL(KF,K) = VRCL(KF,K)+VHKK(K,I)
18876 WRCL(KF,K) = WRCL(KF,K)+WHKK(K,I)
18878 * total number of particles contributing to each residual nucleus
18879 NTOT(KF) = NTOT(KF)+1
18882 * total charge of residual nuclei
18883 NQ(KF) = NQ(KF)+IICH(IDTMP)
18884 * number of protons
18885 IF (IDHKK(I).EQ.2212) THEN
18886 NPRO(KF) = NPRO(KF)+1
18887 * number of neutrons
18888 ELSEIF (IDHKK(I).EQ.2112) THEN
18891 * number of baryons other than n, p
18892 IF (IIBAR(IDTMP).EQ.1) THEN
18894 IF (IICH(IDTMP).EQ.1) NHPOS(KF) = NHPOS(KF)+1
18896 * any other mesons (status set to 1)
18897 C WRITE(LOUT,1002) KF,IDTMP
18898 C1002 FORMAT(1X,'FICONF: residual nucleus ',I2,
18899 C & ' containing meson ',I4,', status set to 1')
18902 IDXTMP = IDXPAR(KF)
18903 NTOT(KF) = NTOT(KF)-1
18907 IDXPAR(KF) = IDXTMP
18911 * reject elastic events (def: one final state particle = projectile)
18912 IF ((IP.EQ.1).AND.(NFSP.EQ.1).AND.(IDFSP.EQ.IJPROJ)) THEN
18913 IREXCI(3) = IREXCI(3)+1
18918 * check if one nucleus disappeared..
18919 C IF ((IP.GT.1).AND.(NTOT(1).EQ.0).AND.(NTOT(2).NE.0)) THEN
18921 C PRCLTA(K) = PRCLTA(K)+PRCLPR(K)
18924 C ELSEIF ((IT.GT.1).AND.(NTOT(2).EQ.0).AND.(NTOT(1).NE.0)) THEN
18926 C PRCLPR(K) = PRCLPR(K)+PRCLTA(K)
18935 * get the average of the nucleon positions
18936 VRCL(I,K) = VRCL(I,K)/MAX(NTOT(I),1)
18937 WRCL(I,K) = WRCL(I,K)/MAX(NTOT(I),1)
18938 IF (I.EQ.1) PRCL(1,K) = PRCLPR(K)
18939 IF (I.EQ.2) PRCL(2,K) = PRCLTA(K)
18941 * mass number and charge of residual nuclei
18942 AIF(I) = DBLE(NTOT(I))
18943 AIZF(I) = DBLE(NPRO(I)+NHPOS(I))
18944 IF (NTOT(I).GT.1) THEN
18945 * masses of residual nuclei in ground state
18946 AMRCL0(I) = AIF(I)*AMUAMU+1.0D-3*DT_ENERGY(AIF(I),AIZF(I))
18947 * masses of residual nuclei
18948 PTORCL = SQRT(PRCL(I,1)**2+PRCL(I,2)**2+PRCL(I,3)**2)
18949 AMRCL(I) = (PRCL(I,4)-PTORCL)*(PRCL(I,4)+PTORCL)
18950 IF (AMRCL(I).GT.ZERO) AMRCL(I) = SQRT(AMRCL(I))
18952 * M_res^2 < 0 : configuration not allowed
18954 * a) re-calculate E_exc with scaled nuclear potential
18955 * (conditional jump to label 9998)
18956 * b) or reject event if N_loop(max) is exceeded
18957 * (conditional jump to label 9999)
18959 IF (AMRCL(I).LE.ZERO) THEN
18960 IF (IOULEV(3).GT.0)
18961 & WRITE(LOUT,1000) I,PRCL(I,1),PRCL(I,2),PRCL(I,3),
18963 1000 FORMAT(1X,'warning! negative excitation energy',/,
18967 IF (NLOOP.LE.500) THEN
18970 IREXCI(2) = IREXCI(2)+1
18974 * 0 < M_res < M_res0 : mass below ground-state mass
18976 * a) we had residual nuclei with mass N_tot and reasonable E_exc
18977 * before- assign average E_exc of those configurations to this
18978 * one ( Nexc(i,N_tot) > 0 )
18979 * b) or (and this applies always if run in transport codes) go up
18980 * one mass number and
18981 * i) if mass now larger than proj/targ mass or if run in
18982 * transport codes assign average E_exc per wounded nucleon
18983 * x number of wounded nucleons (Inuc-Ntot)
18984 * ii) or assign average E_exc of those configurations to this
18985 * one ( Nexc(i,m) > 0 )
18987 ELSEIF ((AMRCL(I).GT.ZERO).AND.(AMRCL(I).LT.AMRCL0(I)))
18989 M = MIN(NTOT(I),260)
18990 IF (NEXC(I,M).GT.0) THEN
18991 AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
18995 **sr corrected 27.12.06
18996 * IF (M.GE.INUC(I)) THEN
18997 * AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I))
18998 IF ((M.GE.INUC(I)).OR.(ICASCA.GT.0)) THEN
18999 IF ( INUC (I) .GT. NTOT (I) ) THEN
19000 AMRCL(I) = AMRCL0(I)
19001 & + EXPNUC(I)*DBLE(MAX(INUC(I)-NTOT(I),0))
19003 AMRCL(I) = AMRCL0(I) + 0.5D+00 * EXPNUC(I)
19007 IF (NEXC(I,M).GT.0) THEN
19008 AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
19014 EEXC(I) = AMRCL(I)-AMRCL0(I)
19017 * M_res > 2.5 x M_res0 : unreasonably(?) high E_exc
19019 * a) re-calculate E_exc with scaled nuclear potential
19020 * (conditional jump to label 9998)
19021 * b) or reject event if N_loop(max) is exceeded
19022 * (conditional jump to label 9999)
19025 ELSEIF (AMRCL(I).GE.2.5D0*AMRCL0(I)) THEN
19026 IF (IOULEV(3).GT.0)
19027 & WRITE(LOUT,1004) I,AMRCL(I),AMRCL0(I),NTOT,NEVHKK
19028 1004 FORMAT(1X,'warning! too high excitation energy',/,
19029 & I4,1P,2E15.4,3I5)
19032 IF (NLOOP.LE.500) THEN
19035 IREXCI(2) = IREXCI(2)+1
19039 * Otherwise (reasonable E_exc) :
19040 * E_exc = M_res - M_res0
19041 * in addition: calculate and save E_exc per wounded nucleon as
19042 * well as E_exc in <E_exc> counter
19045 * excitation energies of residual nuclei
19046 EEXC(I) = AMRCL(I)-AMRCL0(I)
19047 **sr 27.12.06 new excitation energy correction by A.F.
19049 * all parts with Ilcopt<3 commented since not used
19051 * still to be done/decided:
19052 * Increase Icor and put back both residual nuclei on mass shell
19053 * with the exciting correction further below.
19054 * For the moment the modification in the excitation energy is simply
19055 * corrected by scaling the energy of the residual nucleus.
19060 NNCHIT = MAX ( INUC (I) - NTOT (I), 0 )
19061 IF ( ILCOPT .LE. 2 ) THEN
19062 C* Patch for Fermi momentum reduction correlated with impact parameter:
19063 C FRMRDC = MIN ( (PFRMAV(INUC(I))/APFRMX)**3, ONE )
19064 C DLKPRH = 0.1D+00 + 0.5D+00 / SQRT(DBLE(INUC(I)))
19065 C AKPRHO = ONE - DLKPRH
19066 C* f x K rho_cen + (1-f) x 0.5 x K rho_cen = frmrdc x rho_cen
19067 C FRCFLL = MAX ( 2.D+00 * FRMRDC / AKPRHO - ONE,
19069 C* REDORI = 0.75D+00
19071 C REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
19074 RDCORE = 1.14D+00 * DBLE(INUC(I))**(ONE/3.D+00)
19075 * Take out roughly one/half of the skin:
19076 RDCORE = RDCORE - 0.5D+00
19078 PRSKIN = (RDCORE+2.4D+00)**3 - FRCFLL
19079 PRSKIN = 0.5D+00 * PRSKIN / ( PRSKIN + FRCFLL )
19080 FRCFLL = ONE - PRSKIN
19081 FRMRDC = FRCFLL + 0.5D+00 * PRSKIN
19082 REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
19084 IF ( NNCHIT .GT. 0 ) THEN
19085 C IF ( ILCOPT .EQ. 1 ) THEN
19086 C SKINRH = ONE - FRCFLL / (DBLE(INUC(I))-ONE)
19087 C DO 1220 NCH = 1, 10
19088 C ETAETA = ( ONE - SKINRH**INUC(I)
19089 C & - DBLE(INUC(I))* ( ONE - FRCFLL )
19090 C & * ( ONE - SKINRH ) )
19091 C & / ( SKINRH**INUC(I) - DBLE (INUC(I))
19092 C & * ( ONE - FRCFLL) * SKINRH )
19093 C SKINRH = SKINRH * ( ONE + ETAETA )
19095 C PRSKIN = SKINRH**(NNCHIT-1)
19096 C ELSE IF ( ILCOPT .EQ. 2 ) THEN
19097 C PRSKIN = ONE - FRCFLL
19100 DO 1230 NCH = 1, NNCHIT
19101 IF (DT_RNDM(PRFRMI) .LT. PRSKIN) THEN
19102 PRFRMI = (( ONE - 2.D+00 * DLKPRH )
19103 & * DT_RNDM(PRFRMI))**0.333333333333D+00
19105 PRFRMI = ( ONE - 2.D+00 * DLKPRH
19106 & * DT_RNDM(PRFRMI))**0.333333333333D+00
19108 REDCTN = REDCTN + PRFRMI**2
19110 REDCTN = REDCTN / DBLE (NNCHIT)
19114 EEXC (I) = EEXC (I) * REDCTN / REDORI
19115 AMRCL (I) = AMRCL0 (I) + EEXC (I)
19116 PRCL(I,4) = SQRT ( PTORCL**2 + AMRCL(I)**2 )
19119 IF (ICASCA.EQ.0) THEN
19120 EXPNUC(I) = EEXC(I)/MAX(1,INUC(I)-NTOT(I))
19121 M = MIN(NTOT(I),260)
19122 EXC(I,M) = EXC(I,M)+EEXC(I)
19123 NEXC(I,M) = NEXC(I,M)+1
19126 ELSEIF (NTOT(I).EQ.1) THEN
19128 1003 FORMAT(1X,'FICONF: warning! NTOT(I)=1? (I=',I3,')')
19138 PRCLPR(5) = AMRCL(1)
19139 PRCLTA(5) = AMRCL(2)
19141 IF (ICOR.GT.0) THEN
19142 IF (INORCL.EQ.0) THEN
19143 * one or both residual nuclei consist of one nucleon only, transform
19144 * this nucleon on mass shell
19146 P1IN(K) = PRCL(1,K)
19147 P2IN(K) = PRCL(2,K)
19151 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
19152 IF (IREJ1.GT.0) THEN
19153 WRITE(LOUT,*) 'ficonf-mashel rejection'
19157 PRCL(1,K) = P1OUT(K)
19158 PRCL(2,K) = P2OUT(K)
19159 PRCLPR(K) = P1OUT(K)
19160 PRCLTA(K) = P2OUT(K)
19162 PRCLPR(5) = AMRCL(1)
19163 PRCLTA(5) = AMRCL(2)
19165 IF (IOULEV(3).GT.0)
19166 & WRITE(LOUT,1001) NEVHKK,INT(AIF(1)),INT(AIZF(1)),
19167 & INT(AIF(2)),INT(AIZF(2)),AMRCL0(1),
19168 & AMRCL(1),AMRCL(1)-AMRCL0(1),AMRCL0(2),
19169 & AMRCL(2),AMRCL(2)-AMRCL0(2)
19170 1001 FORMAT(1X,'FICONF: warning! no residual nucleus for',
19171 & ' correction',/,11X,'at event',I8,
19172 & ', nucleon config. 1:',2I4,' 2:',2I4,
19174 IF (NLOOP.LE.500) THEN
19177 IREXCI(1) = IREXCI(1)+1
19183 C IF (NRESEV(1).NE.NEVHKK) THEN
19184 C NRESEV(1) = NEVHKK
19185 C NRESEV(2) = NRESEV(2)+1
19187 NRESEV(2) = NRESEV(2)+1
19189 EXCDPM(I) = EXCDPM(I)+EEXC(I)
19190 EXCDPM(I+2) = EXCDPM(I+2)+(EEXC(I)/MAX(NTOT(I),1))
19191 NRESTO(I) = NRESTO(I)+NTOT(I)
19192 NRESPR(I) = NRESPR(I)+NPRO(I)
19193 NRESNU(I) = NRESNU(I)+NN(I)
19194 NRESBA(I) = NRESBA(I)+NH(I)
19195 NRESPB(I) = NRESPB(I)+NHPOS(I)
19196 NRESCH(I) = NRESCH(I)+NQ(I)
19202 * initialize evaporation counter
19204 IF ((INUC(I).GT.1).AND.(AIF(I).GT.ONE).AND.
19205 & (EEXC(I).GT.ZERO)) THEN
19206 * put residual nuclei into DTEVT1
19208 JMASS = INT( AIF(I))
19209 JCHAR = INT(AIZF(I))
19210 * the following patch is required to transmit the correct excitation
19212 IF (ITRSPT.EQ.1) THEN
19213 IF ((ABS(AMRCL(I)-AMRCL0(I)-EEXC(I)).GT.1.D-04).AND.
19214 & (IOULEV(3).GT.0))
19216 & ' DT_FICONF:AMRCL(I),AMRCL0(I),EEXC(I)',
19217 & AMRCL(I),AMRCL0(I),EEXC(I)
19219 PRCL(I,4) =SQRT(AMRCL(I)**2+PRCL(I,1)**2+PRCL(I,2)**2
19221 IF (ABS(PRCL0-PRCL(I,4)).GT.0.1D0) THEN
19223 & ' PRCL(I,4) recalculated :',PRCL0,PRCL(I,4)
19226 CALL DT_EVTPUT(1000,IDRCL,MO1(I),MO2(I),PRCL(I,1),
19227 & PRCL(I,2),PRCL(I,3),PRCL(I,4),JMASS,JCHAR,0)
19232 VHKK(J,NHKK) = VRCL(I,J)
19233 WHKK(J,NHKK) = WRCL(I,J)
19235 * interface to evaporation module - fill final residual nucleus into
19237 * fill resnuc only if code is not used as event generator in Fluka
19238 IF (ITRSPT.NE.1) THEN
19242 IBRES = NPRO(I)+NN(I)+NH(I)
19243 ICRES = NPRO(I)+NHPOS(I)
19246 PTRES = SQRT(PXRES**2+PYRES**2+PZRES**2)
19247 * ground state mass of the residual nucleus (should be equal to AM0T)
19249 AMNRES = AMMRES-ZNOW*AMELEC+ELBNDE(ICRES)
19252 * kinetic energy of residual nucleus
19253 TVRECL = PRCL(I,4)-AMRCL(I)
19254 * excitation energy of residual nucleus
19257 PTRES = SQRT(ABS(TVRECL*(TVRECL+
19258 & 2.0D0*(AMMRES+TVCMS))))
19259 IF (PTOLD.LT.ANGLGB) THEN
19260 CALL DT_RACO(PXRES,PYRES,PZRES)
19263 PXRES = PXRES*PTRES/PTOLD
19264 PYRES = PYRES*PTRES/PTOLD
19265 PZRES = PZRES*PTRES/PTOLD
19266 * zero counter of secondaries from evaporation
19271 * put evaporated particles and residual nuclei to DTEVT1
19273 CALL DT_EVA2HE(MO,EXCITF,I,IREJ1)
19276 EXCEVA(I) = EXCEVA(I)+EXCITF
19283 C9998 IREXCI(1) = IREXCI(1)+1
19292 *$ CREATE DT_EVA2HE.FOR
19295 *====eva2he============================================================*
19297 SUBROUTINE DT_EVA2HE(MO,EEXCF,IRCL,IREJ)
19299 ************************************************************************
19300 * Interface between common's of evaporation module (FKFINU,FKFHVY) *
19302 * MO DTEVT1-index of "mother" (residual) nucleus before evap. *
19303 * EEXCF exitation energy of residual nucleus after evaporation *
19304 * IRCL = 1 projectile residual nucleus *
19305 * = 2 target residual nucleus *
19306 * This version dated 19.04.95 is written by S. Roesler. *
19308 * Last change 27.12.2006 by S. Roesler. *
19309 ************************************************************************
19311 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19313 PARAMETER ( LINP = 10 ,
19316 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3)
19319 PARAMETER (NMXHKK=200000)
19320 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
19321 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
19322 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
19323 * Note: DTEVT2 - special use for heavy fragments !
19324 * (IDRES(I) = mass number, IDXRES(I) = charge)
19325 * extended event history
19326 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
19327 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
19329 * particle properties (BAMJET index convention)
19331 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19332 & IICH(210),IIBAR(210),K1(210),K2(210)
19333 * flags for input different options
19334 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
19335 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
19336 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
19337 * statistics: residual nuclei
19338 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
19339 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
19340 & NINCST(2,4),NINCEV(2),
19341 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
19342 & NRESPB(2),NRESCH(2),NRESEV(4),
19343 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
19345 * treatment of residual nuclei: properties of residual nuclei
19346 COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
19347 & NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
19348 & NTOTFI(2),NPROFI(2)
19349 * (original name: FINUC)
19350 PARAMETER (MXP=999)
19351 COMMON /FKFINU/ CXR (MXP), CYR (MXP), CZR (MXP),
19352 & CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP),
19353 & TKI (MXP), PLR (MXP), WEI (MXP),
19354 & TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP,
19356 * (original name: FHEAVY,FHEAVC)
19357 PARAMETER ( MXHEAV = 100 )
19359 COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV),
19360 & CZHEAV (MXHEAV), TKHEAV (MXHEAV),
19361 & PHEAVY (MXHEAV), WHEAVY (MXHEAV),
19362 & AMHEAV ( 12 ) , AMNHEA ( 12 ) ,
19363 & KHEAVY (MXHEAV), ICHEAV ( 12 ) ,
19364 & IBHEAV ( 12 ) , NPHEAV
19365 COMMON /FKFHVC/ ANHEAV ( 12 )
19366 * (original name: RESNUC)
19367 LOGICAL LRNFSS, LFRAGM
19368 COMMON /FKRESN/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
19369 & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
19370 & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES,
19371 & PYRES, PZRES, PTRES2, KTARP, KTARN, IGREYP,
19372 & IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,
19373 & ICRES, IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU,
19374 & IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG,
19375 & IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS,
19378 DIMENSION IPTOKP(39)
19379 DATA IPTOKP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
19380 & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 99,
19381 & 100, 101, 97, 102, 98, 103, 109, 115 /
19385 * skip if evaporation package is not included
19386 IF (.NOT.LEVAPO) RETURN
19389 IF (NRESEV(3).NE.NEVHKK) THEN
19391 NRESEV(4) = NRESEV(4)+1
19395 & CALL DT_EVTEMC(PHKK(1,MO),PHKK(2,MO),PHKK(3,MO),PHKK(4,MO),1,
19397 * mass number/charge of residual nucleus before evaporation
19401 * protons/neutrons/gammas
19406 ID = IPTOKP(KPART(I))
19407 IDPDG = IDT_IPDGHA(ID)
19408 AM = ((PLR(I)+TKI(I))*(PLR(I)-TKI(I)))/
19409 & (2.0D0*MAX(TKI(I),TINY10))
19410 IF (ABS(AM-AAM(ID)).GT.TINY3) THEN
19411 WRITE(LOUT,1000) ID,AM,AAM(ID)
19412 1000 FORMAT(1X,'EVA2HE: inconsistent mass of evap. ',
19413 & 'particle',I3,2E10.3)
19416 CALL DT_EVTPUT(-1,IDPDG,MO,0,PX,PY,PZ,PE,0,0,0)
19418 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
19419 IBTOT = IBTOT-IIBAR(ID)
19420 IZTOT = IZTOT-IICH(ID)
19425 PX = CXHEAV(I)*PHEAVY(I)
19426 PY = CYHEAV(I)*PHEAVY(I)
19427 PZ = CZHEAV(I)*PHEAVY(I)
19429 AM = ((PHEAVY(I)+TKHEAV(I))*(PHEAVY(I)-TKHEAV(I)))/
19430 & (2.0D0*MAX(TKHEAV(I),TINY10))
19432 CALL DT_EVTPUT(-1,IDHEAV,MO,0,PX,PY,PZ,PE,
19433 & IBHEAV(KHEAVY(I)),ICHEAV(KHEAVY(I)),0)
19435 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
19436 IBTOT = IBTOT-IBHEAV(KHEAVY(I))
19437 IZTOT = IZTOT-ICHEAV(KHEAVY(I))
19440 IF (IBRES.GT.0) THEN
19441 * residual nucleus after evaporation
19443 CALL DT_EVTPUT(1001,IDNUC,MO,0,PXRES,PYRES,PZRES,ERES,
19448 NTOTFI(IRCL) = IBRES
19449 NPROFI(IRCL) = ICRES
19450 IF (LEMCCK) CALL DT_EVTEMC(-PXRES,-PYRES,-PZRES,-ERES,2,IDUM,IDUM)
19451 IBTOT = IBTOT-IBRES
19452 IZTOT = IZTOT-ICRES
19454 * count events with fission
19455 NEVAFI(1,IRCL) = NEVAFI(1,IRCL)+1
19456 IF (LRNFSS) NEVAFI(2,IRCL) = NEVAFI(2,IRCL)+1
19458 * energy-momentum conservation check
19459 IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,40,IREJ)
19460 C IF (IREJ.GT.0) THEN
19461 C CALL DT_EVTOUT(4)
19462 C WRITE(*,*) EEXC(2),EEXCFI(2),NP,NPHEAV
19464 * baryon-number/charge conservation check
19465 IF (IBTOT+IZTOT.NE.0) THEN
19466 WRITE(LOUT,1001) NEVHKK,IBTOT,IZTOT
19467 1001 FORMAT(1X,'EVA2HE: baryon-number/charge conservation ',
19468 & 'failure at event ',I8,' : IBTOT,IZTOT = ',2I3)
19474 *$ CREATE DT_EBIND.FOR
19477 *===ebind==============================================================*
19479 DOUBLE PRECISION FUNCTION DT_EBIND(IA,IZ)
19481 ************************************************************************
19482 * Binding energy for nuclei. *
19483 * (Shirokov & Yudin, Yad. Fizika, Nauka, Moskva 1972) *
19485 * IZ atomic number *
19486 * This version dated 5.5.95 is updated by S. Roesler. *
19487 ************************************************************************
19489 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19491 PARAMETER ( LINP = 10 ,
19494 PARAMETER (ZERO=0.0D0)
19496 DATA A1, A2, A3, A4, A5
19497 & / 0.01575D0, 0.0178D0, 0.000710D0, 0.0237D0, 0.034D0/
19499 IF ((IA.LE.1).OR.(IZ.EQ.0)) THEN
19500 WRITE(LOUT,'(1X,A,2I5)') 'DT_EBIND IA,IZ set EBIND=0. ',IA,IZ
19505 DT_EBIND = A1*AA - A2*AA**0.666667D0-A3*IZ*IZ*AA**(-0.333333D0)
19506 & -A4*(IA-2*IZ)**2/AA
19507 IF (MOD(IA,2).EQ.1) THEN
19509 ELSEIF (MOD(IZ,2).EQ.1) THEN
19514 DT_EBIND = DT_EBIND - IA5*A5*AA**(-0.75D0)
19519 **sr 30.6. routine replaced completely
19520 *$ CREATE DT_ENERGY.FOR
19523 *=== energy ===========================================================*
19525 DOUBLE PRECISION FUNCTION DT_ENERGY( A, Z )
19527 C INCLUDE '(DBLPRC)'
19529 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19531 * (original name: GLOBAL)
19532 PARAMETER ( KALGNM = 2 )
19533 PARAMETER ( ANGLGB = 5.0D-16 )
19534 PARAMETER ( ANGLSQ = 2.5D-31 )
19535 PARAMETER ( AXCSSV = 0.2D+16 )
19536 PARAMETER ( ANDRFL = 1.0D-38 )
19537 PARAMETER ( AVRFLW = 1.0D+38 )
19538 PARAMETER ( AINFNT = 1.0D+30 )
19539 PARAMETER ( AZRZRZ = 1.0D-30 )
19540 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
19541 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
19542 PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
19543 PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
19544 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
19545 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
19546 PARAMETER ( CSNNRM = 2.0D-15 )
19547 PARAMETER ( DMXTRN = 1.0D+08 )
19548 PARAMETER ( ZERZER = 0.D+00 )
19549 PARAMETER ( ONEONE = 1.D+00 )
19550 PARAMETER ( TWOTWO = 2.D+00 )
19551 PARAMETER ( THRTHR = 3.D+00 )
19552 PARAMETER ( FOUFOU = 4.D+00 )
19553 PARAMETER ( FIVFIV = 5.D+00 )
19554 PARAMETER ( SIXSIX = 6.D+00 )
19555 PARAMETER ( SEVSEV = 7.D+00 )
19556 PARAMETER ( EIGEIG = 8.D+00 )
19557 PARAMETER ( ANINEN = 9.D+00 )
19558 PARAMETER ( TENTEN = 10.D+00 )
19559 PARAMETER ( HLFHLF = 0.5D+00 )
19560 PARAMETER ( ONETHI = ONEONE / THRTHR )
19561 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
19562 PARAMETER ( ONEFOU = ONEONE / FOUFOU )
19563 PARAMETER ( THRTWO = THRTHR / TWOTWO )
19564 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
19565 PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
19566 PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
19567 PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
19568 PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
19569 PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
19570 PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
19571 PARAMETER ( EULERO = 0.577215664901532860606512 D+00 )
19572 PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 )
19573 PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 )
19574 PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 )
19575 PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
19576 PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
19577 PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
19578 PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
19579 PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
19580 PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
19581 PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
19582 PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
19583 PARAMETER ( CLIGHT = 2.99792458 D+10 )
19584 PARAMETER ( AVOGAD = 6.0221367 D+23 )
19585 PARAMETER ( BOLTZM = 1.380658 D-23 )
19586 PARAMETER ( AMELGR = 9.1093897 D-28 )
19587 PARAMETER ( PLCKBR = 1.05457266 D-27 )
19588 PARAMETER ( ELCCGS = 4.8032068 D-10 )
19589 PARAMETER ( ELCMKS = 1.60217733 D-19 )
19590 PARAMETER ( AMUGRM = 1.6605402 D-24 )
19591 PARAMETER ( AMMUMU = 0.113428913 D+00 )
19592 PARAMETER ( AMPRMU = 1.007276470 D+00 )
19593 PARAMETER ( AMNEMU = 1.008664904 D+00 )
19594 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
19595 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
19596 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
19597 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
19598 PARAMETER ( PLABRC = 0.197327053 D+00 )
19599 PARAMETER ( AMELCT = 0.51099906 D-03 )
19600 PARAMETER ( AMUGEV = 0.93149432 D+00 )
19601 PARAMETER ( AMMUON = 0.105658389 D+00 )
19602 PARAMETER ( AMPRTN = 0.93827231 D+00 )
19603 PARAMETER ( AMNTRN = 0.93956563 D+00 )
19604 PARAMETER ( AMDEUT = 1.87561339 D+00 )
19605 PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
19607 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
19608 PARAMETER ( BLTZMN = 8.617385 D-14 )
19609 PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
19610 PARAMETER ( GFOHB3 = 1.16639 D-05 )
19611 PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
19612 PARAMETER ( SIN2TW = 0.2319 D+00 )
19613 PARAMETER ( GEVMEV = 1.0 D+03 )
19614 PARAMETER ( EMVGEV = 1.0 D-03 )
19615 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
19616 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
19617 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
19618 LOGICAL LGBIAS, LGBANA
19619 COMMON /FKGLOB/ LGBIAS, LGBANA
19620 C INCLUDE '(DIMPAR)'
19622 PARAMETER ( MXXRGN = 5000 )
19623 PARAMETER ( MXXMDF = 82 )
19624 PARAMETER ( MXXMDE = 54 )
19625 PARAMETER ( MFSTCK = 1000 )
19626 PARAMETER ( MESTCK = 100 )
19627 PARAMETER ( NALLWP = 39 )
19628 PARAMETER ( NELEMX = 80 )
19629 PARAMETER ( MPDPDX = 8 )
19630 PARAMETER ( ICOMAX = 180 )
19631 PARAMETER ( NSTBIS = 304 )
19632 PARAMETER ( IDMAXP = 220 )
19633 PARAMETER ( IDMXDC = 640 )
19634 PARAMETER ( MKBMX1 = 1 )
19635 PARAMETER ( MKBMX2 = 1 )
19636 C INCLUDE '(IOUNIT)'
19638 PARAMETER ( LUNIN = 5 )
19639 PARAMETER ( LUNOUT = 6 )
19640 **sr 19.5. set error output-unit from 15 to 6
19641 PARAMETER ( LUNERR = 6 )
19642 PARAMETER ( LUNBER = 14 )
19643 PARAMETER ( LUNECH = 8 )
19644 PARAMETER ( LUNFLU = 13 )
19645 PARAMETER ( LUNGEO = 16 )
19646 PARAMETER ( LUNPMF = 12 )
19647 PARAMETER ( LUNRAN = 2 )
19648 PARAMETER ( LUNXSC = 9 )
19649 PARAMETER ( LUNDET = 17 )
19650 PARAMETER ( LUNRAY = 10 )
19651 PARAMETER ( LUNRDB = 1 )
19652 PARAMETER ( LUNPGO = 7 )
19653 PARAMETER ( LUNPGS = 4 )
19654 PARAMETER ( LUNSCR = 3 )
19656 *----------------------------------------------------------------------*
19658 * Revised version of the original routine from EVAP: *
19660 * Created on 15 may 1990 by Alfredo Ferrari & Paola Sala *
19663 * Last change on 19-sep-95 by Alfredo Ferrari *
19665 * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
19666 * !!! It is supposed to be used with the updated atomic !!! *
19667 * !!! mass data file !!! *
19668 * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
19670 *----------------------------------------------------------------------*
19672 * Mass number below which "unknown" isotopes out of the Z-interval
19673 * reported in the mass tabulations are completely unstable and made
19674 * up by Z proton masses + N neutron masses:
19675 PARAMETER ( KAFREE = 4 )
19676 * Mass number below which "unknown" isotopes out of the Z-interval
19677 * reported in the mass tabulations are supposed to be particle unstable
19678 PARAMETER ( KAPUNS = 12 )
19679 * Minimum energy required for particle unstable isotopes
19680 PARAMETER ( DEPUNS = 0.5D+00 )
19682 * (original name: EVA0)
19683 COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
19684 * FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
19685 * CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
19686 * T (4,7), RMASS (297), ALPH (297), BET (297),
19687 * APRIME (250), IA (6), IZ (6)
19688 * (original name: ISOTOP)
19689 PARAMETER ( NAMSMX = 270 )
19690 PARAMETER ( NZGVAX = 15 )
19691 PARAMETER ( NISMMX = 574 )
19692 COMMON /FKISOT/ WAPS (NAMSMX,NZGVAX), T12NUC (NAMSMX,NZGVAX),
19693 & WAPISM (NISMMX), T12ISM (NISMMX),
19694 & ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260),
19695 & AMSSST (100) , ISOMNM (NSTBIS), ISONDX (2,100),
19696 & JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX),
19697 & INWAPS (NAMSMX), JSPISM (NISMMX),
19698 & JPTISM (NISMMX), IZWISM (NISMMX),
19699 & INWISM (0:NAMSMX)
19701 CPH SAVE KA0, KZ0, IZ0
19702 DATA KA0, KZ0, IZ0 / -1, -1, -1 /
19706 *======================================================================*
19708 * Entry ENergy - KNOWn *
19710 *======================================================================*
19711 ENTRY DT_ENKNOW ( A, Z, IZZ0 )
19719 * +-------------------------------------------------------------------*
19720 * | Null residual nucleus:
19721 IF ( KA0 .EQ. 0 .AND. KZ0 .LE. 0 ) THEN
19722 IF ( IFLAG .EQ. 1 ) THEN
19730 * +-------------------------------------------------------------------*
19732 ELSE IF ( N .LE. 0 ) THEN
19733 IF ( N .LT. 0 ) THEN
19734 WRITE ( LUNOUT, * )
19735 & ' DPMJET stopped in energy: mass number =< atomic number !!',
19737 WRITE ( LUNOUT, * )
19738 & ' DPMJET stopped in energy: mass number =< atomic number !!',
19741 & ' ^^^DPMJET stopped in energy: mass number =< atomic number !!',
19743 STOP 'DT_ENERGY:KA0-KZ0'
19746 IF ( IFLAG .EQ. 1 ) THEN
19747 DT_ENERGY = Z * WAPS ( 1, 2 )
19749 DT_ENKNOW = Z * WAPS ( 1, 2 )
19754 * +-------------------------------------------------------------------*
19756 ELSE IF ( KZ0 .LE. 0 ) THEN
19757 IF ( KZ0 .LT. 0 ) THEN
19758 WRITE ( LUNOUT, * )
19759 & ' DPMJET stopped in energy: negative atomic number !!',KA0,KZ0
19760 WRITE ( LUNOUT, * )
19761 & ' DPMJET stopped in energy: negative atomic number !!',KA0,KZ0
19763 &' ^^^DPMJET stopped in energy: negative atomic number !!',KA0,KZ0
19764 STOP 'DT_ENERGY:KZ0<0'
19767 IF ( IFLAG .EQ. 1 ) THEN
19768 DT_ENERGY = A * WAPS ( 1, 1 )
19770 DT_ENKNOW = A * WAPS ( 1, 1 )
19776 * +-------------------------------------------------------------------*
19777 * +-------------------------------------------------------------------*
19778 * | No actual nucleus
19780 * +-------------------------------------------------------------------*
19781 * +-------------------------------------------------------------------*
19782 * | A larger than maximum allowed:
19783 IF ( KA0 .GT. NAMSMX ) THEN
19785 IF ( IFLAG .EQ. 1 ) THEN
19786 DT_ENERGY = DT_ENRG( A, Z )
19788 DT_ENKNOW = DT_ENRG( A, Z )
19794 * +-------------------------------------------------------------------*
19795 IZZ = INWAPS ( KA0 )
19796 * +-------------------------------------------------------------------*
19797 * | Too much neutron rich with respect to the stability line:
19798 IF ( KZ0 .LT. IZZ ) THEN
19799 * | +----------------------------------------------------------------*
19800 * | | Up to A=Kafree all "bound" masses are known, set it unbound:
19801 IF ( KA0 .LE. KAFREE ) THEN
19804 * | +----------------------------------------------------------------*
19805 * | | Up to Kapuns: be sure it is particle unstable
19806 ELSE IF ( KA0 .LE. KAPUNS ) THEN
19807 * | | Exp. excess mass for A,IZZ
19808 ENEEXP = WAPS ( KA0, 1 )
19809 * | | Cameron excess mass for A, IZZ
19810 ENECA1 = DT_ENRG( A, DBLE (IZZ) )
19811 * | | Cameron excess mass for A, Z
19812 DT_ENERGY = DT_ENRG( A, Z )
19813 * | | Use just the difference according to Cameron!!!
19814 DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19815 JZZ = INWAPS ( KA0 - 1 )
19816 LZZ = INWAPS ( KA0 - 2 )
19817 * | | +-------------------------------------------------------------*
19818 * | | | Residual mass for n-decay known:
19819 IF ( KZ0 .GE. JZZ .AND. KZ0 .LE. JZZ + NZGVAX - 1 ) THEN
19820 IZ0 = KZ0 - JZZ + 1
19821 DT_ENERGY = MAX(DT_ENERGY,WAPS (KA0-1,IZ0) + WAPS (1,1)
19824 * | | +-------------------------------------------------------------*
19825 * | | | Residual mass for 2n-decay known:
19826 ELSE IF ( KZ0 .GE. LZZ .AND. KZ0 .LE. LZZ + NZGVAX - 1 )THEN
19827 IZ0 = KZ0 - LZZ + 1
19828 DT_ENERGY = MAX ( DT_ENERGY, WAPS (KA0-2,IZ0) + TWOTWO *
19829 & ( WAPS (1,1) + DEPUNS ) )
19831 * | | +-------------------------------------------------------------*
19832 * | | | Set it unbound:
19837 * | | +-------------------------------------------------------------*
19839 * | +----------------------------------------------------------------*
19840 * | | Proceed as usual:
19842 * | | Exp. excess mass for A,IZZ
19843 ENEEXP = WAPS ( KA0, 1 )
19844 * | | Cameron excess mass for A, IZZ
19845 ENECA1 = DT_ENRG( A, DBLE (IZZ) )
19846 * | | Cameron excess mass for A, Z
19847 DT_ENERGY = DT_ENRG( A, Z )
19848 * | | Use just the difference according to Cameron!!!
19849 DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19852 * | +----------------------------------------------------------------*
19853 * | Be sure not to have a positive energy state:
19854 DT_ENERGY = MIN(DT_ENERGY,(A-Z) * WAPS (1,1) + Z * WAPS (1,2) )
19856 IF ( IFLAG .EQ. 2 ) THEN
19857 DT_ENKNOW = DT_ENERGY
19862 * +-------------------------------------------------------------------*
19863 * | Too much proton rich with respect to the stability line:
19864 ELSE IF ( KZ0 .GT. IZZ + NZGVAX - 1 ) THEN
19865 * | +----------------------------------------------------------------*
19866 * | | Up to A=Kafree all "bound" masses are known, set it unbound:
19867 IF ( KA0 .LE. KAFREE ) THEN
19870 * | +----------------------------------------------------------------*
19871 * | | Up to Kapuns: be sure it is particle unstable
19872 ELSE IF ( KA0 .LE. KAPUNS ) THEN
19873 * | | Exp. excess mass for A,IZZ+NZGVAX-1
19874 ENEEXP = WAPS ( KA0, NZGVAX )
19875 * | | Cameron excess mass for A, IZZ+NZGVAX-1
19876 ENECA1 = DT_ENRG( A, DBLE (IZZ+NZGVAX-1) )
19877 * | | Cameron excess mass for A, Z
19878 DT_ENERGY = DT_ENRG( A, Z )
19879 * | | Use just the difference according to Cameron!!!
19880 DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19881 JZZ = INWAPS ( KA0 - 1 )
19882 LZZ = INWAPS ( KA0 - 2 )
19883 * | | +-------------------------------------------------------------*
19884 * | | | Residual mass for p-decay known:
19885 IF ( KZ0-1 .GE. JZZ .AND. KZ0-1 .LE. JZZ + NZGVAX - 1 ) THEN
19886 IZ0 = KZ0 - 1 - JZZ + 1
19887 DT_ENERGY = MAX (DT_ENERGY, WAPS (KA0-1,IZ0) + WAPS (1,2)
19890 * | | +-------------------------------------------------------------*
19891 * | | | Residual mass for 2p-decay known:
19892 ELSE IF ( KZ0-2 .GE. LZZ .AND. KZ0-2 .LE. LZZ + NZGVAX - 1 )
19894 IZ0 = KZ0 - 2 - LZZ + 1
19895 DT_ENERGY = MAX ( DT_ENERGY, WAPS (KA0-2,IZ0) + TWOTWO *
19896 & ( WAPS (1,2) + DEPUNS ) )
19898 * | | +-------------------------------------------------------------*
19899 * | | | Set it unbound:
19904 * | | +-------------------------------------------------------------*
19906 * | +----------------------------------------------------------------*
19907 * | | Proceed as usual:
19909 * | | Exp. excess mass for A,IZZ+NZGVAX-1
19910 ENEEXP = WAPS ( KA0, NZGVAX )
19911 * | | Cameron excess mass for A, IZZ+NZGVAX-1
19912 ENECA1 = DT_ENRG( A, DBLE (IZZ+NZGVAX-1) )
19913 * | | Cameron excess mass for A, Z
19914 DT_ENERGY = DT_ENRG( A, Z )
19915 * | | Use just the difference according to Cameron!!!
19916 DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19919 * | +----------------------------------------------------------------*
19920 * | Be sure not to have a positive energy state:
19921 DT_ENERGY = MIN(DT_ENERGY,(A-Z) * WAPS (1,1) + Z * WAPS (1,2) )
19923 IF ( IFLAG .EQ. 2 ) THEN
19924 DT_ENKNOW = DT_ENERGY
19929 * +-------------------------------------------------------------------*
19930 * | Known isotope or anyway isotope "inside" the stability zone
19932 IZ0 = KZ0 - IZZ + 1
19933 DT_ENERGY = WAPS ( KA0, IZ0 )
19934 IF ( IFLAG .EQ. 2 ) IZZ0 = IZ0
19935 * | +----------------------------------------------------------------*
19936 * | | Mass not known
19937 IF ( ABS (DT_ENERGY) .LT. ANGLGB .AND. (KA0 .NE. 12 .OR. KZ0
19939 IF ( IFLAG .EQ. 2 ) IZZ0 = -1
19940 * | | +-------------------------------------------------------------*
19941 * | | | Set it unbound:
19942 IF ( KA0 .LE. KAFREE ) THEN
19945 * | | +-------------------------------------------------------------*
19946 * | | | Try to get a reasonable excess mass:
19949 * | | | +----------------------------------------------------------*
19950 * | | | | Check the closest one known:
19951 DO 500 JZZ = 1, NZGVAX
19952 IF ( ABS ( WAPS (KA0,JZZ) ) .GT. ANGLGB .AND.
19953 & ABS (JZZ-IZ0) .LT. ABS (JZ0-IZ0) ) JZ0 = JZZ
19954 IF ( ABS (JZ0-IZ0) .EQ. 1 ) GO TO 550
19957 * | | | +----------------------------------------------------------*
19959 * | | | Exp. excess mass for A,IZZ+JZ0-1
19960 ENEEXP = WAPS ( KA0, JZ0 )
19961 * | | | Cameron excess mass for A, IZZ+JZ0-1
19962 ENECA1 = DT_ENRG( A, DBLE (IZZ+JZ0-1) )
19963 * | | | Cameron excess mass for A, Z
19964 DT_ENERGY = DT_ENRG( A, Z )
19965 * | | | Use just the difference according to Cameron!!!
19966 DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19970 * | | +-------------------------------------------------------------*
19971 * | | Be sure not to have a positive energy state:
19972 DT_ENERGY = MIN(DT_ENERGY,(A-Z)*WAPS(1,1)+Z*WAPS (1,2) )
19975 * | +----------------------------------------------------------------*
19976 IF ( IFLAG .EQ. 2 ) DT_ENKNOW = DT_ENERGY
19980 * +-------------------------------------------------------------------*
19981 *=== End of Function Energy ===========================================*
19986 *$ CREATE DT_ENRG.FOR
19989 *=== enrg =============================================================*
19991 DOUBLE PRECISION FUNCTION DT_ENRG(A,Z)
19993 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19996 PARAMETER ( ZERZER = 0.D+00 )
19997 PARAMETER ( ONEONE = 1.D+00 )
19998 PARAMETER ( LUNIN = 5 )
19999 PARAMETER ( LUNOUT = 6 )
20001 *----------------------------------------------------------------------*
20003 * Revised version of the original routine from EVAP: *
20005 * Created on 15 may 1990 by Alfredo Ferrari & Paola Sala *
20008 * Last change on 01-oct-94 by Alfredo Ferrari *
20010 * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
20011 * !!! It is supposed to be used with the updated atomic !!! *
20012 * !!! mass data file !!! *
20013 * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
20015 *----------------------------------------------------------------------*
20017 PARAMETER ( O16OLD = 931.145 D+00 )
20018 PARAMETER ( O16NEW = 931.19826D+00 )
20019 PARAMETER ( O16RAT = O16NEW / O16OLD )
20020 PARAMETER ( C12NEW = 931.49432D+00 )
20021 PARAMETER ( ADJUST = -8.322737768178909D-02 )
20022 PARAMETER ( AINFNT = 1.0D+30 )
20023 * (original name: EVA0)
20024 COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
20025 * FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
20026 * CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
20027 * T (4,7), RMASS (297), ALPH (297), BET (297),
20028 * APRIME (250), IA (6), IZ (6)
20030 CPH SAVE LFIRST, EXHYDR, EXNEUT
20031 DATA LFIRST / .TRUE. /
20036 C EXHYDR = DT_ENERGY( ONEONE, ONEONE )
20037 C EXNEUT = DT_ENERGY( ONEONE, ZERZER )
20045 IF ( IZ0 .LE. 0 ) THEN
20046 DT_ENRG = A * EXNEUT
20050 IF ( N .LE. 0 ) THEN
20051 DT_ENRG = Z * EXHYDR
20055 AM2ZOA=AM2ZOA*AM2ZOA
20056 A13 = RMASS(NINT(A))
20057 * A13 = A**.3333333333333333D+00
20059 EV=-17.0354D+00*(1.D+00 -1.84619 D+00*AM2ZOA)*A
20060 ES= 25.8357D+00*(1.D+00 -1.712185D+00*AM2ZOA)*
20061 & (1.D+00 -0.62025D+00*AM13*AM13)*
20062 & (A13*A13 -.62025D+00)
20063 EC= 0.799D+00*Z*(Z-1.D+00)*AM13*(((1.5772D+00*AM13 +1.2273D+00)*
20064 & AM13-1.5849D+00)*
20065 & AM13*AM13 +1.D+00)
20066 EEX= -0.4323D+00*AM13*Z**1.3333333D+00*
20067 & (((0.49597D+00*AM13 -0.14518D+00)*AM13 -0.57811D+00) * AM13
20069 DT_ENRG=8.367D+00*A-0.783D+00*Z +EV +ES +EC +EEX+CAM2(IZ0)+CAM3(N)
20070 DT_ENRG=(DT_ENRG + A * O16OLD ) * O16RAT - A * ( C12NEW - ADJUST )
20071 DT_ENRG = MIN ( DT_ENRG, Z * EXHYDR + ( A - Z ) * EXNEUT )
20073 *=== End of function Enrg =============================================*
20076 *$ CREATE DT_INCINI.FOR
20079 *=== incini ===========================================================*
20081 SUBROUTINE DT_INCINI
20083 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20086 PARAMETER ( ZERZER = 0.D+00 )
20087 PARAMETER ( ONEONE = 1.D+00 )
20088 PARAMETER ( TWOTWO = 2.D+00 )
20089 PARAMETER ( THRTHR = 3.D+00 )
20090 PARAMETER ( FOUFOU = 4.D+00 )
20091 PARAMETER ( EIGEIG = 8.D+00 )
20092 PARAMETER ( ANINEN = 9.D+00 )
20093 PARAMETER ( HLFHLF = 0.5D+00 )
20094 PARAMETER ( ONETHI = ONEONE / THRTHR )
20095 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
20096 PARAMETER ( PLABRC = 0.197327053 D+00 )
20097 PARAMETER ( AMELCT = 0.51099906 D-03 )
20098 PARAMETER ( AMUGEV = 0.93149432 D+00 )
20099 PARAMETER ( AMPRTN = 0.93827231 D+00 )
20100 PARAMETER ( AMNTRN = 0.93956563 D+00 )
20101 PARAMETER ( AMDEUT = 1.87561339 D+00 )
20102 PARAMETER ( EMVGEV = 1.0 D-03 )
20104 PARAMETER ( LUNOUT = 6 )
20106 *----------------------------------------------------------------------*
20108 * Created on 10 june 1990 by Alfredo Ferrari & Paola Sala *
20111 * Last change on 02-may-95 by Alfredo Ferrari *
20114 *----------------------------------------------------------------------*
20116 * (original name: FHEAVY,FHEAVC)
20117 PARAMETER ( MXHEAV = 100 )
20119 COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV),
20120 & CZHEAV (MXHEAV), TKHEAV (MXHEAV),
20121 & PHEAVY (MXHEAV), WHEAVY (MXHEAV),
20122 & AMHEAV ( 12 ) , AMNHEA ( 12 ) ,
20123 & KHEAVY (MXHEAV), ICHEAV ( 12 ) ,
20124 & IBHEAV ( 12 ) , NPHEAV
20125 COMMON /FKFHVC/ ANHEAV ( 12 )
20126 * (original name: INPFLG)
20127 COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
20128 * (original name: FRBKCM)
20129 PARAMETER ( MXFFBK = 6 )
20130 PARAMETER ( MXZFBK = 9 )
20131 PARAMETER ( MXNFBK = 10 )
20132 PARAMETER ( MXAFBK = 16 )
20133 PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
20134 PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
20135 PARAMETER ( NXAFBK = MXAFBK + 1 )
20136 PARAMETER ( MXPSST = 300 )
20137 PARAMETER ( MXPSFB = 41000 )
20138 LOGICAL LFRMBK, LNCMSS
20139 COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
20140 & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
20141 & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
20142 & IFRBKN (MXPSST), IFRBKZ (MXPSST),
20143 & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
20144 & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
20145 & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
20146 & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
20147 & IFBFRB, NBUFBK, LFRMBK, LNCMSS
20148 * (original name: NUCDAT)
20149 PARAMETER ( AMUAMU = AMUGEV )
20150 PARAMETER ( AMPROT = AMPRTN )
20151 PARAMETER ( AMNEUT = AMNTRN )
20152 PARAMETER ( AMELEC = AMELCT )
20153 PARAMETER ( R0NUCL = 1.12 D+00 )
20154 PARAMETER ( RCCOUL = 1.7 D+00 )
20155 PARAMETER ( FERTHO = 14.33 D-09 )
20156 PARAMETER ( EXPEBN = 2.39 D+00 )
20157 PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
20158 PARAMETER ( AMUC12 = AMUGEV - HLFHLF * AMELCT + BEXC12 / 12.D+00 )
20159 PARAMETER ( AMHYDR = AMPRTN + AMELCT )
20160 PARAMETER ( AMHTON = AMHYDR - AMNTRN )
20161 PARAMETER ( AMNTOU = AMNTRN - AMUC12 )
20162 PARAMETER ( AMUCSQ = AMUC12 * AMUC12 )
20163 PARAMETER ( EBNDAV = HLFHLF * (AMPRTN + AMNTRN) - AMUC12 )
20164 PARAMETER ( GAMMIN = 1.0D-06 )
20165 PARAMETER ( GAMNSQ = 2.0D+00 * GAMMIN * GAMMIN )
20166 PARAMETER ( TVEPSI = GAMMIN / 100.D+00 )
20167 COMMON /FKNDAT/ AV0WEL, APFRMX, AEFRMX, AEFRMA,
20168 & RDSNUC, V0WELL (2), PFRMMX (2), EFRMMX (2),
20169 & EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2),
20170 & VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2),
20171 & PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2),
20172 & EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2),
20173 & ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV ,
20174 & AMRCSQ , ATO1O3 , ZTO1O3 , ELBNDE (0:100)
20175 * (original name: PAREVT)
20176 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
20177 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
20178 PARAMETER ( NALLWP = 39 )
20179 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
20180 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
20181 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
20182 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
20183 * (original name: NUCOLD)
20184 COMMON /FKNOLD/ HELP (2), HHLP (2), FTVTH (2), FINCX (2),
20185 & EKPOLD (2), BBOLD, ZZOLD, SQROLD, ASEASQ,
20191 APFRMX = PLABRC * ( ANINEN * PIPIPI / EIGEIG )**ONETHI / R0NUCL
20192 AMNUCL (1) = AMPROT
20193 AMNUCL (2) = AMNEUT
20194 AMNUSQ (1) = AMPROT * AMPROT
20195 AMNUSQ (2) = AMNEUT * AMNEUT
20196 AMNHLP = HLFHLF * ( AMNUCL (1) + AMNUCL (2) )
20198 * ASQHLP = HLFHLF * ( AMNUSQ (1) + AMNUSQ (2) )
20199 AEFRMX = SQRT ( ASQHLP + APFRMX**2 ) - AMNHLP
20200 AEFRMA = 0.3D+00 * APFRMX**2 / AMNHLP * ( ONEONE - APFRMX**2 /
20201 & ( 5.6D+00 * ASQHLP ) )
20202 AV0WEL = AEFRMX + EBNDAV
20203 EBNDNG (1) = EBNDAV
20204 EBNDNG (2) = EBNDAV
20205 AEXC12 = EMVGEV * DT_ENERGY( 12.D+00, 6.D+00 )
20206 CEXC12 = EMVGEV * DT_ENRG( 12.D+00, 6.D+00 )
20207 AMMC12 = 12.D+00 * AMUGEV + AEXC12
20208 AMNC12 = AMMC12 - 6.D+00 * AMELCT + FERTHO * 6.D+00**EXPEBN
20209 AEXO16 = EMVGEV * DT_ENERGY( 16.D+00, 8.D+00 )
20210 CEXO16 = EMVGEV * DT_ENRG( 16.D+00, 8.D+00 )
20211 AMMO16 = 16.D+00 * AMUGEV + AEXO16
20212 AMNO16 = AMMO16 - 8.D+00 * AMELCT + FERTHO * 8.D+00**EXPEBN
20213 AEXS28 = EMVGEV * DT_ENERGY( 28.D+00, 14.D+00 )
20214 CEXS28 = EMVGEV * DT_ENRG( 28.D+00, 14.D+00 )
20215 AMMS28 = 28.D+00 * AMUGEV + AEXS28
20216 AMNS28 = AMMS28 - 14.D+00 * AMELCT + FERTHO * 14.D+00**EXPEBN
20217 AEXC40 = EMVGEV * DT_ENERGY( 40.D+00, 20.D+00 )
20218 CEXC40 = EMVGEV * DT_ENRG( 40.D+00, 20.D+00 )
20219 AMMC40 = 40.D+00 * AMUGEV + AEXC40
20220 AMNC40 = AMMC40 - 20.D+00 * AMELCT + FERTHO * 20.D+00**EXPEBN
20221 AEXF56 = EMVGEV * DT_ENERGY( 56.D+00, 26.D+00 )
20222 CEXF56 = EMVGEV * DT_ENRG( 56.D+00, 26.D+00 )
20223 AMMF56 = 56.D+00 * AMUGEV + AEXF56
20224 AMNF56 = AMMF56 - 26.D+00 * AMELCT + FERTHO * 26.D+00**EXPEBN
20225 AEX107 = EMVGEV * DT_ENERGY( 107.D+00, 47.D+00 )
20226 CEX107 = EMVGEV * DT_ENRG( 107.D+00, 47.D+00 )
20227 AMM107 = 107.D+00 * AMUGEV + AEX107
20228 AMN107 = AMM107 - 47.D+00 * AMELCT + FERTHO * 47.D+00**EXPEBN
20229 AEX132 = EMVGEV * DT_ENERGY( 132.D+00, 54.D+00 )
20230 CEX132 = EMVGEV * DT_ENRG( 132.D+00, 54.D+00 )
20231 AMM132 = 132.D+00 * AMUGEV + AEX132
20232 AMN132 = AMM132 - 54.D+00 * AMELCT + FERTHO * 54.D+00**EXPEBN
20233 AEX181 = EMVGEV * DT_ENERGY( 181.D+00, 73.D+00 )
20234 CEX181 = EMVGEV * DT_ENRG( 181.D+00, 73.D+00 )
20235 AMM181 = 181.D+00 * AMUGEV + AEX181
20236 AMN181 = AMM181 - 73.D+00 * AMELCT + FERTHO * 73.D+00**EXPEBN
20237 AEX208 = EMVGEV * DT_ENERGY( 208.D+00, 82.D+00 )
20238 CEX208 = EMVGEV * DT_ENRG( 208.D+00, 82.D+00 )
20239 AMM208 = 208.D+00 * AMUGEV + AEX208
20240 AMN208 = AMM208 - 82.D+00 * AMELCT + FERTHO * 82.D+00**EXPEBN
20241 AEX238 = EMVGEV * DT_ENERGY( 238.D+00, 92.D+00 )
20242 CEX238 = EMVGEV * DT_ENRG( 238.D+00, 92.D+00 )
20243 AMM238 = 238.D+00 * AMUGEV + AEX238
20244 AMN238 = AMM238 - 92.D+00 * AMELCT + FERTHO * 92.D+00**EXPEBN
20246 AMHEAV (1) = AMUGEV + EMVGEV * DT_ENERGY( ONEONE, ZERZER )
20247 AMHEAV (2) = AMUGEV + EMVGEV * DT_ENERGY( ONEONE, ONEONE )
20248 AMHEAV (3) = TWOTWO * AMUGEV
20249 & + EMVGEV * DT_ENERGY( TWOTWO, ONEONE )
20250 AMHEAV (4) = THRTHR * AMUGEV
20251 & + EMVGEV * DT_ENERGY( THRTHR, ONEONE )
20252 AMHEAV (5) = THRTHR * AMUGEV
20253 & + EMVGEV * DT_ENERGY( THRTHR, TWOTWO )
20254 AMHEAV (6) = FOUFOU * AMUGEV
20255 & + EMVGEV * DT_ENERGY( FOUFOU, TWOTWO )
20256 ELBNDE (0) = ZERZER
20257 ELBNDE (1) = 13.6D-09
20258 DO 2000 IZ = 2, 100
20259 ELBNDE ( IZ ) = FERTHO * DBLE ( IZ )**EXPEBN
20261 AMNHEA (1) = AMHEAV (1) + ELBNDE (0)
20262 AMNHEA (2) = AMHEAV (2) - AMELCT + ELBNDE (1)
20263 AMNHEA (3) = AMHEAV (3) - AMELCT + ELBNDE (1)
20264 AMNHEA (4) = AMHEAV (4) - AMELCT + ELBNDE (1)
20265 AMNHEA (5) = AMHEAV (5) - TWOTWO * AMELCT + ELBNDE (2)
20266 AMNHEA (6) = AMHEAV (6) - TWOTWO * AMELCT + ELBNDE (2)
20268 WRITE ( LUNOUT, * )' **** Evaporation from residual nucleus',
20269 & ' activated **** '
20270 IF ( LDEEXG ) WRITE ( LUNOUT, * )' **** Deexcitation gamma',
20271 & ' production activated **** '
20273 * commented, since obsolete
20274 C IF ( LHEAVY ) WRITE ( LUNOUT, * )' **** Evaporated "heavies"',
20275 C & ' transport activated **** '
20276 IF ( IFISS .GT. 0 )
20277 & WRITE ( LUNOUT, * )' **** High Energy fission ',
20278 & ' requested & activated **** '
20280 & WRITE ( LUNOUT, * )' **** Fermi Break Up ',
20281 & ' requested & activated **** '
20282 IF ( LFRMBK ) CALL DT_FRBKIN(.FALSE.,.FALSE.)
20290 *=== End of subroutine incini =========================================*
20293 *$ CREATE DT_STALIN.FOR
20296 *=== stalin ===========================================================*
20298 SUBROUTINE DT_STALIN
20300 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20302 PARAMETER ( ANGLGB = 5.0D-16 )
20303 PARAMETER ( ZERZER = 0.D+00 )
20304 PARAMETER ( ONEONE = 1.D+00 )
20305 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
20306 PARAMETER ( AMUGEV = 0.93149432 D+00 )
20307 PARAMETER ( EMVGEV = 1.0 D-03 )
20308 PARAMETER ( NSTBIS = 304 )
20309 PARAMETER ( LUNIN = 5 )
20310 PARAMETER ( LUNOUT = 6 )
20312 *----------------------------------------------------------------------*
20314 * STAbility LINe calculation: *
20316 * Created on 04 december 1992 by Alfredo Ferrari & Paola Sala *
20319 * Last change on 04-dec-92 by Alfredo Ferrari *
20322 *----------------------------------------------------------------------*
20324 * (original name: ISOTOP)
20325 PARAMETER ( NAMSMX = 270 )
20326 PARAMETER ( NZGVAX = 15 )
20327 PARAMETER ( NISMMX = 574 )
20328 COMMON /FKISOT/ WAPS (NAMSMX,NZGVAX), T12NUC (NAMSMX,NZGVAX),
20329 & WAPISM (NISMMX), T12ISM (NISMMX),
20330 & ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260),
20331 & AMSSST (100) , ISOMNM (NSTBIS), ISONDX (2,100),
20332 & JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX),
20333 & INWAPS (NAMSMX), JSPISM (NISMMX),
20334 & JPTISM (NISMMX), IZWISM (NISMMX),
20335 & INWISM (0:NAMSMX)
20337 DIMENSION ZNORM (260)
20338 * +-------------------------------------------------------------------*
20342 ASTLIN (J,IZ) = ZERZER
20346 * +-------------------------------------------------------------------*
20347 * +-------------------------------------------------------------------*
20350 ZNORM (IA) = ZERZER
20352 ZSTLIN (J,IA) = ZERZER
20356 * +-------------------------------------------------------------------*
20357 * +-------------------------------------------------------------------*
20358 * | Loop on the Atomic Number
20360 AMSSST (IZ) = ZERZER
20363 * | +----------------------------------------------------------------*
20364 * | | Loop on the stable isotopes
20365 DO 2500 IS = ISONDX (1,IZ), ISONDX (2,IZ)
20367 ASTLIN (1,IZ) = ASTLIN (1,IZ) + ABUISO (IS) * IA
20368 ASTLIN (2,IZ) = ASTLIN (2,IZ) + ABUISO (IS) * IA**2
20369 ZNORM (IA) = ZNORM (IA) + ABUISO (IS)
20370 ZSTLIN (1,IA) = ZSTLIN (1,IA) + ABUISO (IS) * IZ
20371 ZSTLIN (2,IA) = ZSTLIN (2,IA) + ABUISO (IS) * IZ**2
20373 IF ( AHELP .LE. 1.00001D+00 ) THEN
20374 ANORM = ONEONE / ( ONEONE - ABUISO (IS) )
20377 AMSSST (IZ) = ABUISO (IS) * ( AHELP * AMUGEV
20378 & + EMVGEV * DT_ENERGY(AHELP,ZTAR) ) + AMSSST (IZ)
20381 * | +----------------------------------------------------------------*
20382 AMSSST (IZ) = ANORM * AMSSST (IZ) / AMUGEV
20383 * | Normalize and print A_stab versus Z data:
20384 ASTLIN (2,IZ) = MAX ( SQRT (ASTLIN(2,IZ)-ASTLIN(1,IZ)**2),
20386 * WRITE (LUNOUT,*)' Z:',IZ,' A_stab:',SNGL(ASTLIN(1,IZ)),
20387 * & ' Sigma_st',SNGL(ASTLIN(2,IZ))
20390 * +-------------------------------------------------------------------*
20391 * +-------------------------------------------------------------------*
20392 * | Normalize and print Z_stab versus A data:
20394 ZSTLIN (1,IA) = ZSTLIN (1,IA) / MAX ( ZNORM (IA), 1.D-10 )
20395 ZSTLIN (2,IA) = ZSTLIN (2,IA) / MAX ( ZNORM (IA), 1.D-10 )
20396 ZSTLIN (2,IA) = MAX ( ZSTLIN (2,IA), ZSTLIN (1,IA)**2 )
20397 IF ( ZNORM (IA) .GT. ANGLGB )
20398 **sr 2.11. avoid underflows at Pentium
20400 & MAX ( SQRT ( ABS(ZSTLIN(2,IA)-ZSTLIN(1,IA)**2) ),
20401 C & ZSTLIN (2,IA) = MAX ( SQRT (ZSTLIN(2,IA)-ZSTLIN(1,IA)**2),
20405 * +-------------------------------------------------------------------*
20406 * +-------------------------------------------------------------------*
20407 * | Normalize and print Z_stab versus A data:
20409 IF ( ZNORM (IA) .LE. ANGLGB ) THEN
20410 DO 4200 JA = IA-1,1,-1
20411 IF ( ZNORM (JA) .GT. ANGLGB ) THEN
20417 DO 4400 JA = IA+1,260
20418 IF ( ZNORM (JA) .GT. ANGLGB ) THEN
20426 ZSTLIN (1,IA) = DBLE (IA-IA1) / DBLE (IA2-IA1)
20427 & * ( ZSTLIN (1,IA2) - ZSTLIN (1,IA1) )
20429 ZSTLIN (2,IA) = DBLE (IA-IA1) / DBLE (IA2-IA1)
20430 & * ( ZSTLIN (2,IA2) - ZSTLIN (2,IA1) )
20433 IZ = MIN ( 100, NINT (ZSTLIN(1,IA)) )
20434 ATOZ = IZ / ASTLIN (1,IZ)
20435 ZSTLIN (2,IA) = MAX ( ZSTLIN (2,IA), ATOZ * ASTLIN (2,IZ) )
20436 * WRITE (LUNOUT,*)' A:',IA,' Z_stab:',SNGL(ZSTLIN(1,IA)),
20437 * & ' Sigma_st',SNGL(ZSTLIN(2,IA))
20440 * +-------------------------------------------------------------------*
20444 *$ CREATE DT_BERTTP.FOR
20447 *=== berttp ===========================================================*
20449 SUBROUTINE DT_BERTTP
20451 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20454 PARAMETER ( CSNNRM = 2.0D-15 )
20455 PARAMETER ( ZERZER = 0.D+00 )
20456 PARAMETER ( ONEONE = 1.D+00 )
20457 PARAMETER ( THRTHR = 3.D+00 )
20458 PARAMETER ( SIXSIX = 6.D+00 )
20459 PARAMETER ( ONETHI = ONEONE / THRTHR )
20460 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
20461 PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
20462 PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
20463 PARAMETER ( EMVGEV = 1.0 D-03 )
20465 PARAMETER ( NSTBIS = 304 )
20467 PARAMETER ( LUNIN = 5 )
20468 PARAMETER ( LUNOUT = 6 )
20469 **sr 19.5. set error output-unit from 15 to 6
20470 PARAMETER ( LUNERR = 6 )
20471 C---------------------------------------------------------------------
20472 C SUBNAME = DT_BERTTP --- READ BERTINI DATA
20473 C---------------------------------------------------------------------
20474 C ---------------------------------- I-N-C DATA
20475 C COMMON R8(2127),R4(64),CRSC(600,4),R8B(336),CS(29849)
20476 C REAL*8 R8,R8B,CRSC,CS
20478 C --------------------------------- EVAPORATION DATA
20479 * (original name: COOKCM)
20480 PARAMETER ( ASMTOG = SIXSIX / PIPIPI**2 )
20481 LOGICAL LDEFOZ, LDEFON
20482 PARAMETER ( INCOOK = 150, IZCOOK = 98 )
20483 COMMON /FKCOOK/ ALPIGN, BETIGN, GAMIGN, POWIGN,
20484 & SZCOOK (IZCOOK), SNCOOK (INCOOK), PZCOOK (IZCOOK),
20485 & PNCOOK (INCOOK), LDEFOZ (IZCOOK), LDEFON (INCOOK)
20486 * (original name: EVA0)
20487 COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
20488 * FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
20489 * CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
20490 * T (4,7), RMASS (297), ALPH (297), BET (297),
20491 * APRIME (250), IA (6), IZ (6)
20492 * (original name: FRBKCM)
20493 PARAMETER ( MXFFBK = 6 )
20494 PARAMETER ( MXZFBK = 9 )
20495 PARAMETER ( MXNFBK = 10 )
20496 PARAMETER ( MXAFBK = 16 )
20497 PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
20498 PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
20499 PARAMETER ( NXAFBK = MXAFBK + 1 )
20500 PARAMETER ( MXPSST = 300 )
20501 PARAMETER ( MXPSFB = 41000 )
20502 LOGICAL LFRMBK, LNCMSS
20503 COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
20504 & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
20505 & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
20506 & IFRBKN (MXPSST), IFRBKZ (MXPSST),
20507 & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
20508 & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
20509 & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
20510 & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
20511 & IFBFRB, NBUFBK, LFRMBK, LNCMSS
20512 * (original name: HETTP)
20513 COMMON /FKHETP/ NHSTP,NBERTP,IOSUB,INSRS
20514 * (original name: INPFLG)
20515 COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
20516 * (original name: ISOTOP)
20517 PARAMETER ( NAMSMX = 270 )
20518 PARAMETER ( NZGVAX = 15 )
20519 PARAMETER ( NISMMX = 574 )
20520 COMMON /FKISOT/ WAPS (NAMSMX,NZGVAX), T12NUC (NAMSMX,NZGVAX),
20521 & WAPISM (NISMMX), T12ISM (NISMMX),
20522 & ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260),
20523 & AMSSST (100) , ISOMNM (NSTBIS), ISONDX (2,100),
20524 & JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX),
20525 & INWAPS (NAMSMX), JSPISM (NISMMX),
20526 & JPTISM (NISMMX), IZWISM (NISMMX),
20527 & INWISM (0:NAMSMX)
20528 * (original name: NUCGID,NUCGEO,NUCGE2,NUCPWI,NUCGII)
20529 PARAMETER ( PI = PIPIPI )
20530 PARAMETER ( PISQ = PIPISQ )
20531 PARAMETER ( SKTOHL = 0.5456645846610345D+00 )
20532 PARAMETER ( RZNUCL = 1.12 D+00 )
20533 PARAMETER ( RMSPRO = 0.8 D+00 )
20534 PARAMETER ( R0PROT = RMSPRO / SQRT12 )
20535 PARAMETER ( ARHPRO = 1.D+00 / 8.D+00 / PI / R0PROT / R0PROT
20537 PARAMETER ( RLLE04 = RZNUCL )
20538 PARAMETER ( RLLE16 = RZNUCL )
20539 PARAMETER ( RLGT16 = RZNUCL )
20540 PARAMETER ( RCLE04 = 0.75D+00 / PI / RLLE04 / RLLE04 / RLLE04 )
20541 PARAMETER ( RCLE16 = 0.75D+00 / PI / RLLE16 / RLLE16 / RLLE16 )
20542 PARAMETER ( RCGT16 = 0.75D+00 / PI / RLGT16 / RLGT16 / RLGT16 )
20543 PARAMETER ( SKLE04 = 1.4D+00 )
20544 PARAMETER ( SKLE16 = 1.9D+00 )
20545 PARAMETER ( SKGT16 = 2.4D+00 )
20546 PARAMETER ( HLLE04 = SKTOHL * SKLE04 )
20547 PARAMETER ( HLLE16 = SKTOHL * SKLE16 )
20548 PARAMETER ( HLGT16 = SKTOHL * SKGT16 )
20549 PARAMETER ( ALPHA0 = 0.1D+00 )
20550 PARAMETER ( OMALH0 = 1.D+00 - ALPHA0 )
20551 PARAMETER ( GAMSK0 = 0.9D+00 )
20552 PARAMETER ( OMGAS0 = 1.D+00 - GAMSK0 )
20553 PARAMETER ( POTME0 = 0.6666666666666667D+00 )
20554 PARAMETER ( POTBA0 = 1.D+00 )
20555 PARAMETER ( PNFRAT = 1.533D+00 )
20556 PARAMETER ( RADPIM = 0.035D+00 )
20557 PARAMETER ( RDPMHL = 14.D+00 )
20558 PARAMETER ( APMRST = 4.D+00 / 44.D+00 )
20559 PARAMETER ( APMPRO = 1.D+00 / 6.D+00 )
20560 PARAMETER ( APPPRO = 5.D+00 / 6.D+00 )
20561 PARAMETER ( AP0PFS = 0.5D+00 )
20562 PARAMETER ( AP0PFP = 1.D+00 / 3.D+00 )
20563 PARAMETER ( AP0NFP = 2.D+00 / 3.D+00 )
20564 PARAMETER ( XPAUCO = 1.88495407241652 D+00 )
20565 PARAMETER ( MXSCIN = 50 )
20566 LOGICAL LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH, LNCDCY,
20567 & LNUSCT, LPREEQ, LNPHTC, LNWRAD, LPNRHO, LFTCMP, LFTCAC
20568 COMMON /FKNGID/ RHOTAB (2:260), RHATAB (2:260), ALPTAB (2:260),
20569 & RADTAB (2:260), SKITAB (2:260), HALTAB (2:260),
20570 & SK3TAB (2:260), SK4TAB (2:260), HABTAB (2:260),
20571 & CWSTAB (2:260), EKATAB (2:260), PFATAB (2:260),
20573 COMMON /FKNGEO/ RADTOT, RADIU1, RADIU0, RAD1O2, SKINDP, HALODP,
20574 & ALPHAL, OMALHL, RADSKN, SKNEFF, CPARWS, RADPRO,
20575 & RADCOR, RADCO2, RADMAX, BIMPTR, RIMPTR, XIMPTR,
20576 & YIMPTR, ZIMPTR, RHOIMT, EKFPRO, PFRPRO, RHOCEN,
20577 & RHOCOR, RHOSKN, EKFCEN (2), PFRCEN (2), EKFBIM,
20578 & PFRBIM, RHOIMP, EKFIMP, PFRIMP, RHOIM2, EKFIM2,
20579 & PFRIM2, RHOIM3, EKFIM3, PFRIM3, VPRWLL, RIMPCT,
20580 & BIMPCT, XIMPCT, YIMPCT, ZIMPCT, RIMPC2, XIMPC2,
20581 & YIMPC2, ZIMPC2, RIMPC3, XIMPC3, YIMPC3, ZIMPC3,
20582 & XBIMPC, YBIMPC, ZBIMPC, CXIMPC, CYIMPC, CZIMPC,
20583 & SQRIMP, SIGMAP, SIGMAN, SIGMAA, RHORED, R0TRAJ,
20584 & R1TRAJ, SBUSED, SBTOT , SBRES , RHOAVE, EKFAVE,
20585 & PFRAVE, AVEBIN, ACOLL , ZCOLL , RADSIG, OPACTY,
20586 & EKECON, PNUCCO, EKEWLL, PPRWLL, PXPROJ, PYPROJ,
20587 & PZPROJ, EKFERM, PNFRMI, PXFERM, PYFERM, PZFERM,
20588 & EKFER2, PNFRM2, PXFER2, PYFER2, PZFER2, EKFER3,
20589 & PNFRM3, PXFER3, PYFER3, PZFER3, RHOMEM, EKFMEM,
20590 & BIMMEM, WLLRED, VPRBIM, POTINC, POTOUT, EEXMIN
20591 COMMON /FKNGE2/ RDTTNC (2), RHONCP (2), RHONC2 (2), RHONC3 (2),
20592 & RHONCT (2), AMOTHR, EKOTHR, AMCREA, EKNCLN,
20593 & EEXDEL, EEXANY, CLMBBR, RDCLMB, BFCLMB, BFCEFF,
20594 & BNPROJ, BNDNUC, DEBRLM, SK4PAR, UBIMPC, VBIMPC,
20595 & WBIMPC, BNDPOT, SIGMAT, SIGABP, SIGABN, WLLRES,
20596 & POTBAR, POTMES, AGEPRI, OPNOPA, ETHRND,
20597 & BNENRG (3), DEFNUC (2), SIGMPR (4), SIGMNU (4),
20598 & SIGPAB (3), SIGNAB (3), HHLP (2), FORTOT (2),
20599 & FPNBLC, DPNBLC, FFTFLG, IFTFLG,
20600 & IPWELL, ITNCMX, KPRIN , NTARGT, KNUCIM, KNUCI2,
20601 & KNUCI3, IEVPRE, ISFCOL, ISFTAR, ISFTA2, ISFTA3,
20602 & NPOTHR, ICOTHR, IBOTHR, NPUMFN, ISTNCL, ITAUCM,
20603 & IABCOU, IADFLG, IGSFLG, IALFLG, ICBFLG, LPREEQ,
20604 & LNPHTC, LPNRHO, LNWRAD, LFTCMP, LFTCAC
20605 COMMON /FKNPWI/ ALMBAR, BIMMAX, SIGGEO, LLLMAX, LLLACT
20606 COMMON /FKNGII/ HOLEXP (2*MXSCIN), XEXPIN (3,0:MXSCIN),
20607 & YEXPIN (3,0:MXSCIN), ZEXPIN (3,0:MXSCIN),
20608 & AGEXIN (0:MXSCIN), RHOEXP (2), EKFEXP, EHLFIX,
20609 & NHLEXP, NHLFIX, IPRTYP, NNCEXI (0:MXSCIN),
20610 & NCEXPI (3,0:MXSCIN), ISEXIN (3,0:MXSCIN),
20611 & ISCTYP (0:MXSCIN), NUSCIN, NEXPEM,
20612 & LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH,
20614 DIMENSION AWSTAB (2:260), SIGMAB (3)
20615 EQUIVALENCE ( DEFPRO, DEFNUC (1) )
20616 EQUIVALENCE ( DEFNEU, DEFNUC (2) )
20617 EQUIVALENCE ( RHOIPP, RHONCP (1) )
20618 EQUIVALENCE ( RHOINP, RHONCP (2) )
20619 EQUIVALENCE ( RHOIP2, RHONC2 (1) )
20620 EQUIVALENCE ( RHOIN2, RHONC2 (2) )
20621 EQUIVALENCE ( RHOIP3, RHONC3 (1) )
20622 EQUIVALENCE ( RHOIN3, RHONC3 (2) )
20623 EQUIVALENCE ( RHOIPT, RHONCT (1) )
20624 EQUIVALENCE ( RHOINT, RHONCT (2) )
20625 EQUIVALENCE ( OMALHL, SK3PAR )
20626 EQUIVALENCE ( ALPHAL, HABPAR )
20627 EQUIVALENCE ( ALPTAB (2), AWSTAB (2) )
20628 EQUIVALENCE ( SIGMPE, SIGMPR (1) )
20629 EQUIVALENCE ( SIGMPC, SIGMPR (2) )
20630 EQUIVALENCE ( SIGMPI, SIGMPR (3) )
20631 EQUIVALENCE ( SIGMPA, SIGMPR (4) )
20632 EQUIVALENCE ( SIGMNE, SIGMNU (1) )
20633 EQUIVALENCE ( SIGMNC, SIGMNU (2) )
20634 EQUIVALENCE ( SIGMNI, SIGMNU (3) )
20635 EQUIVALENCE ( SIGMNA, SIGMNU (4) )
20636 EQUIVALENCE ( SIGMA2, SIGPAB (1) )
20637 EQUIVALENCE ( SIGMA3, SIGPAB (2) )
20638 EQUIVALENCE ( SIGMAS, SIGPAB (3) )
20639 EQUIVALENCE ( SIGPAB (1), SIGMAB (1) )
20640 * (original name: NUCLEV)
20641 LOGICAL LCLVSL, LFLVSL, LRLVSL, LEQSBL
20642 COMMON /FKNLEV/ PAENUC (200,2), SHENUC (200,2), DEFRMI (2),
20643 & DEFMAG (2), ENNCLV (160,2), RANCLV (160,2),
20644 & CUMRAD (0:160,2), RUSNUC (2),
20645 & ENPLVL (114), ENNLVL(164), JUSNUC (160,2),
20646 & NTANUC (2), NAVNUC (2), NLSNUC (2), NCONUC (2),
20647 & NSKNUC (2), NHANUC (2), NUSNUC (2), NACNUC (2),
20648 & JMXNUC (2), IPRNUC (3), JPRNUC (3), MAGNUM (8),
20649 & MAGNUC (2), MGSNUC (8,2), MGSSNC (25,2),
20650 & NSBSHL (2), NMNSBS (2), NPRNUC, INUCLV, LCLVSL,
20651 & LFLVSL, LRLVSL, LEQSBL
20652 DIMENSION JUSPRO (160), JUSNEU (160), MGSPRO (8), MGSNEU (8),
20653 & MGSSPR (19) , MGSSNE (25)
20654 EQUIVALENCE ( RUSNUC (1), RUSPRO )
20655 EQUIVALENCE ( RUSNUC (2), RUSNEU )
20656 EQUIVALENCE ( JUSNUC (1,1), JUSPRO (1) )
20657 EQUIVALENCE ( JUSNUC (1,2), JUSNEU (1) )
20658 EQUIVALENCE ( MGSNUC (1,1), MGSPRO (1) )
20659 EQUIVALENCE ( MGSNUC (1,2), MGSNEU (1) )
20660 EQUIVALENCE ( MGSSNC (1,1), MGSSPR (1) )
20661 EQUIVALENCE ( MGSSNC (1,2), MGSSNE (1) )
20662 EQUIVALENCE ( NTANUC (1), NTAPRO )
20663 EQUIVALENCE ( NTANUC (2), NTANEU )
20664 EQUIVALENCE ( NAVNUC (1), NAVPRO )
20665 EQUIVALENCE ( NAVNUC (2), NAVNEU )
20666 EQUIVALENCE ( NLSNUC (1), NLSPRO )
20667 EQUIVALENCE ( NLSNUC (2), NLSNEU )
20668 EQUIVALENCE ( NCONUC (1), NCOPRO )
20669 EQUIVALENCE ( NCONUC (2), NCONEU )
20670 EQUIVALENCE ( NSKNUC (1), NSKPRO )
20671 EQUIVALENCE ( NSKNUC (2), NSKNEU )
20672 EQUIVALENCE ( NHANUC (1), NHAPRO )
20673 EQUIVALENCE ( NHANUC (2), NHANEU )
20674 EQUIVALENCE ( NUSNUC (1), NUSPRO )
20675 EQUIVALENCE ( NUSNUC (2), NUSNEU )
20676 EQUIVALENCE ( NACNUC (1), NACPRO )
20677 EQUIVALENCE ( NACNUC (2), NACNEU )
20678 EQUIVALENCE ( JMXNUC (1), JMXPRO )
20679 EQUIVALENCE ( JMXNUC (2), JMXNEU )
20680 EQUIVALENCE ( MAGNUC (1), MAGPRO )
20681 EQUIVALENCE ( MAGNUC (2), MAGNEU )
20682 * (original name: PAREVT)
20683 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
20684 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
20685 PARAMETER ( NALLWP = 39 )
20686 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
20687 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
20688 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
20689 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
20690 * (original name: XSEPAR)
20691 COMMON /FKXSEP/ AANXSE (100), BBNXSE (100), CCNXSE (100),
20692 & DDNXSE (100), EENXSE (100), ZZNXSE (100),
20693 & EMNXSE (100), XMNXSE (100),
20694 & AAPXSE (100), BBPXSE (100), CCPXSE (100),
20695 & DDPXSE (100), EEPXSE (100), FFPXSE (100),
20696 & ZZPXSE (100), EMPXSE (100), XMPXSE (100)
20698 C---------------------------------------------------------------------
20700 * modified for use in DPMJET
20701 C WRITE( LUNOUT,'(A,I2)')
20702 C & ' *** Reading evaporation and nuclear data from unit: ', NBERTP
20704 IF (LEVPRT) WRITE(LUNOUT,1000)
20705 1000 FORMAT(/,1X,'BERTTP:',4X,'Initialization of evaporation module',
20706 & /,12X,'------------------------------------',/)
20708 CPH OPEN (UNIT=NBERNW,FILE='dpmjet.dat',STATUS='UNKNOWN')
20711 *!!!! changed to be able to read the ASCII !!!!
20713 C A. Ferrari: first of all read isotopic data
20714 READ (NBERNW,*) ISONDX
20715 READ (NBERNW,*) ISOMNM
20716 READ (NBERNW,*) ABUISO
20717 C READ (NBERTP) ISONDX
20718 C READ (NBERTP) ISOMNM
20719 C READ (NBERTP) ABUISO
20721 C READ (NBERTP) (CRSC(J,I),J=1,600)
20722 C A. Ferrari: commented also the dummy read to save disk space
20726 C A. Ferrari: commented also the dummy read to save disk space
20728 C---------------------------------------------------------------------
20729 READ (NBERNW,*) (P0(I),P1(I),P2(I),I=1,1001)
20730 READ (NBERNW,*) IA,IZ
20735 READ (NBERNW,*) RHO,OMEGA
20736 READ (NBERNW,*) EXMASS
20737 READ (NBERNW,*) CAM2
20738 READ (NBERNW,*) CAM3
20739 READ (NBERNW,*) CAM4
20740 READ (NBERNW,*) CAM5
20741 READ (NBERNW,*) ((T(I,J),J=1,7),I=1,3)
20745 READ (NBERNW,*) RMASS
20746 READ (NBERNW,*) ALPH
20747 READ (NBERNW,*) BET
20748 READ (NBERNW,*) INWAPS
20749 READ (NBERNW,*) WAPS
20750 READ (NBERNW,*) T12NUC
20751 READ (NBERNW,*) JSPNUC
20752 READ (NBERNW,*) JPTNUC
20753 READ (NBERNW,*) INWISM
20754 READ (NBERNW,*) IZWISM
20755 READ (NBERNW,*) WAPISM
20756 READ (NBERNW,*) T12ISM
20757 READ (NBERNW,*) JSPISM
20758 READ (NBERNW,*) JPTISM
20759 READ (NBERNW,*) APRIME
20761 &WRITE( LUNOUT,'(A)' ) ' *** Evaporation: using 1977 Waps data ***'
20762 READ (NBERNW,*) AHELP , BHELP , LRMSCH, LRD1O2, LTRASP
20763 IF ( ABS (AHELP-ALPHA0) .GT. CSNNRM * ALPHA0 .OR.
20764 & ABS (BHELP-GAMSK0) .GT. CSNNRM * GAMSK0 ) THEN
20766 & ' *** Inconsistent Nuclear Geometry data on file ***'
20769 READ (NBERNW,*) RHOTAB, RHATAB, ALPTAB, RADTAB, SKITAB, HALTAB,
20770 & EKATAB, PFATAB, PFRTAB
20771 READ (NBERNW,*) AANXSE, BBNXSE, CCNXSE, DDNXSE, EENXSE, ZZNXSE,
20773 READ (NBERNW,*) AAPXSE, BBPXSE, CCPXSE, DDPXSE, EEPXSE, FFPXSE,
20774 & ZZPXSE, EMPXSE, XMPXSE
20775 * Data about Fermi-breakup:
20776 READ (NBERNW,*) IPOSST, MXPDUM, MXADUM, MXNDUM, MXZDUM, IFBSTF
20777 IF ( MXADUM .NE. MXAFBK .OR. MXNDUM .NE. MXNFBK .OR. MXZDUM .NE.
20778 & MXZFBK .OR. MXPDUM .NE. MXPSST ) THEN
20779 WRITE (LUNOUT,*)' *** Inconsistent Fermi BreakUp data',
20780 & ' in the Nuclear Data file ***'
20781 STOP 'STOP:BERTTP-INCONS-FERMI-BREAKUP-DATA'
20783 READ (NBERNW,*) IFRBKN
20784 READ (NBERNW,*) IFRBKZ
20785 READ (NBERNW,*) IFBKSP
20786 READ (NBERNW,*) IFBKST
20787 READ (NBERNW,*) EEXFBK
20789 CLOSE (UNIT=NBERNW)
20791 C READ (NBERTP) (P0(I),P1(I),P2(I),I=1,1001)
20792 C READ (NBERTP) IA,IZ
20797 C READ (NBERTP) RHO,OMEGA
20798 C READ (NBERTP) EXMASS
20799 C READ (NBERTP) CAM2
20800 C READ (NBERTP) CAM3
20801 C READ (NBERTP) CAM4
20802 C READ (NBERTP) CAM5
20803 C READ (NBERTP) ((T(I,J),J=1,7),I=1,3)
20807 C READ (NBERTP) RMASS
20808 C READ (NBERTP) ALPH
20809 C READ (NBERTP) BET
20810 C READ (NBERTP) INWAPS
20811 C READ (NBERTP) WAPS
20812 C READ (NBERTP) T12NUC
20813 C READ (NBERTP) JSPNUC
20814 C READ (NBERTP) JPTNUC
20815 C READ (NBERTP) INWISM
20816 C READ (NBERTP) IZWISM
20817 C READ (NBERTP) WAPISM
20818 C READ (NBERTP) T12ISM
20819 C READ (NBERTP) JSPISM
20820 C READ (NBERTP) JPTISM
20821 C READ (NBERTP) APRIME
20822 C WRITE( LUNOUT,'(A)' ) ' *** Evaporation: using 1977 Waps data ***'
20823 C READ (NBERTP) AHELP , BHELP , LRMSCH, LRD1O2, LTRASP
20824 C IF ( ABS (AHELP-ALPHA0) .GT. CSNNRM * ALPHA0 .OR.
20825 C & ABS (BHELP-GAMSK0) .GT. CSNNRM * GAMSK0 ) THEN
20827 C & ' *** Inconsistent Nuclear Geometry data on file ***'
20830 C READ (NBERTP) RHOTAB, RHATAB, ALPTAB, RADTAB, SKITAB, HALTAB,
20831 C & EKATAB, PFATAB, PFRTAB
20832 C READ (NBERTP) AANXSE, BBNXSE, CCNXSE, DDNXSE, EENXSE, ZZNXSE,
20834 C READ (NBERTP) AAPXSE, BBPXSE, CCPXSE, DDPXSE, EEPXSE, FFPXSE,
20835 C & ZZPXSE, EMPXSE, XMPXSE
20836 * Data about Fermi-breakup:
20837 C READ (NBERTP) IPOSST, MXPDUM, MXADUM, MXNDUM, MXZDUM, IFBSTF
20838 C IF ( MXADUM .NE. MXAFBK .OR. MXNDUM .NE. MXNFBK .OR. MXZDUM .NE.
20839 C & MXZFBK .OR. MXPDUM .NE. MXPSST ) THEN
20840 C WRITE (LUNOUT,*)' *** Inconsistent Fermi BreakUp data',
20841 C & ' in the Nuclear Data file ***'
20842 C STOP 'STOP:BERTTP-INCONS-FERMI-BREAKUP-DATA'
20844 C READ (NBERTP) IFRBKN
20845 C READ (NBERTP) IFRBKZ
20846 C READ (NBERTP) IFBKSP
20847 C READ (NBERTP) IFBKST
20848 C READ (NBERTP) EEXFBK
20849 C CLOSE (UNIT=NBERTP)
20851 SHENUC ( JZ, 1 ) = EMVGEV * ( CAM2 (JZ) + CAM4 (JZ) )
20854 SHENUC ( JA, 2 ) = EMVGEV * ( CAM3 (JA) + CAM5 (JA) )
20857 IF ( ILVMOD .LE. 0 ) THEN
20863 DO 300 JZ = 1, IZCOOK
20864 CAM4 (JZ) = PZCOOK (JZ)
20866 DO 400 JN = 1, INCOOK
20867 CAM5 (JN) = PNCOOK (JZ)
20873 IF ( ILVMOD .EQ. 1 ) THEN
20875 & ' **** Standard EVAP T=0 level density used ****'
20876 ELSE IF ( ILVMOD .EQ. 2 ) THEN
20878 & ' **** Gilbert & Cameron T=0 N,Z-dep. level density used ****'
20879 ELSE IF ( ILVMOD .EQ. 3 ) THEN
20881 & ' **** Julich A-dependent level density used ****'
20882 ELSE IF ( ILVMOD .EQ. 4 ) THEN
20884 & ' **** Brancazio & Cameron T=0 N,Z-dep. level density used',
20888 & ' **** Unknown T=0 level density option requested ****'
20889 STOP 'BERTTP-ILVMOD'
20891 IF ( JLVMOD .LE. 0 ) THEN
20894 & ' **** No Excitation en. dependence for level densities ****'
20895 ELSE IF ( JLVMOD .EQ. 1 ) THEN
20897 & ' **** Ignyatuk (1975, 1st) level density en. dep. used ****'
20899 & ' **** with Ignyatuk (1975, 1st) set of parameters for T=oo',
20905 ELSE IF ( JLVMOD .EQ. 2 ) THEN
20907 & ' **** Ignyatuk (1975, 1st) level density en. dep. used ****'
20909 & ' **** with UNKNOWN set of parameters for T=oo ****'
20910 STOP 'BERTTP-JLVMOD'
20911 ELSE IF ( JLVMOD .EQ. 3 ) THEN
20913 & ' **** Ignyatuk (1975, 1st) level density en. dep. used ****'
20915 & ' **** with UNKNOWN set of parameters for T=oo ****'
20916 STOP 'BERTTP-JLVMOD'
20917 ELSE IF ( JLVMOD .EQ. 4 ) THEN
20919 & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****'
20921 & ' **** with Ignyatuk (1975, 2nd) set of parameters for T=oo',
20927 ELSE IF ( JLVMOD .EQ. 5 ) THEN
20929 & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****'
20931 & ' **** with Iljinov & Mebel 1st set of parameters for T=oo****'
20936 ELSE IF ( JLVMOD .EQ. 6 ) THEN
20938 & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****'
20940 & ' **** with Iljinov & Mebel 2nd set of parameters for T=oo****'
20945 ELSE IF ( JLVMOD .EQ. 7 ) THEN
20947 & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****'
20949 & ' **** with Iljinov & Mebel 3rd set of parameters for T=oo****'
20954 ELSE IF ( JLVMOD .EQ. 8 ) THEN
20956 & ' **** Ignyatuk (1975, 2nd) level density en. dep. used ****'
20958 & ' **** with Iljinov & Mebel 4th set of parameters for T=oo****'
20965 & ' **** Unknown T=oo level density option requested ****'
20966 STOP 'BERTTP-JLVMOD'
20970 & ' **** Cook''s modified pairing energy used ****'
20973 & ' **** Original Gilbert/Cameron pairing energy used ****'
20980 PAENUC ( JZ, 1 ) = EMVGEV * CAM4 (JZ)
20983 PAENUC ( JA, 2 ) = EMVGEV * CAM5 (JA)
20988 *$ CREATE DT_EVEVAP.FOR
20991 *====evevap============================================================*
20993 SUBROUTINE DT_EVEVAP(WE)
20995 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20997 PARAMETER ( LINP = 10 ,
21001 * flags for input different options
21002 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
21003 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
21004 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
21011 *$ CREATE DT_FRBKIN.FOR
21014 *====frbkin============================================================*
21016 SUBROUTINE DT_FRBKIN(LDUM1,LDUM2)
21018 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21020 PARAMETER ( LINP = 10 ,
21024 LOGICAL LDUM1,LDUM2
21029 *$ CREATE DT_EXPLOD.FOR
21032 *=== explod ===========================================================*
21034 SUBROUTINE DT_EXPLOD( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
21037 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21040 DIMENSION PXEXPL (NPEXPL), PYEXPL (NPEXPL), PZEXPL (NPEXPL),
21041 & ETEXPL (NPEXPL), AMEXPL (NPEXPL)
21046 ************************************************************************
21048 * DPMJET 3.0: cross section routines *
21050 ************************************************************************
21053 * SUBROUTINE DT_SHNDIF
21054 * diffractive cross sections (all energies)
21055 * SUBROUTINE DT_PHOXS
21056 * total and inel. cross sections from PHOJET interpol. tables
21057 * SUBROUTINE DT_XSHN
21058 * total and el. cross sections for all energies
21059 * SUBROUTINE DT_SIHNAB
21060 * pion 2-nucleon absorption cross sections
21061 * SUBROUTINE DT_SIGEMU
21062 * cross section for target "compounds"
21063 * SUBROUTINE DT_SIGGA
21064 * photon nucleus cross sections
21065 * SUBROUTINE DT_SIGGAT
21066 * photon nucleus cross sections from tables
21067 * SUBROUTINE DT_SANO
21068 * anomalous hard photon-nucleon cross sections from tables
21069 * SUBROUTINE DT_SIGGP
21070 * photon nucleon cross sections
21071 * SUBROUTINE DT_SIGVEL
21072 * quasi-elastic vector meson prod. cross sections
21073 * DOUBLE PRECISION FUNCTION DT_SIGVP
21075 * DOUBLE PRECISION FUNCTION DT_RRM2
21076 * DOUBLE PRECISION FUNCTION DT_RM2
21077 * DOUBLE PRECISION FUNCTION DT_SAM2
21078 * SUBROUTINE DT_CKMT
21079 * SUBROUTINE DT_CKMTX
21080 * SUBROUTINE DT_PDF0
21081 * SUBROUTINE DT_CKMTQ0
21082 * SUBROUTINE DT_CKMTDE
21083 * SUBROUTINE DT_CKMTPR
21084 * FUNCTION DT_CKMTFF
21086 * SUBROUTINE DT_FLUINI
21087 * total nucleon cross section fluctuation treatment
21089 * SUBROUTINE DT_SIGTBL
21090 * pre-tabulation of low-energy elastic x-sec. using SIHNEL
21091 * SUBROUTINE DT_XSTABL
21095 *$ CREATE DT_SHNDIF.FOR
21098 *===shndif===============================================================*
21100 SUBROUTINE DT_SHNDIF(ECM,KPROJ,KTARG,SIGDIF,SIGDIH)
21102 **********************************************************************
21103 * Single diffractive hadron-nucleon cross sections *
21104 * S.Roesler 14/1/93 *
21106 * The cross sections are calculated from extrapolated single *
21107 * diffractive antiproton-proton cross sections (DTUJET92) using *
21108 * scaling relations between total and single diffractive cross *
21110 **********************************************************************
21112 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21114 PARAMETER (ZERO=0.0D0)
21116 * particle properties (BAMJET index convention)
21118 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21119 & IICH(210),IIBAR(210),K1(210),K2(210)
21121 CSD1 = 4.201483727D0
21122 CSD4 = -0.4763103556D-02
21123 CSD5 = 0.4324148297D0
21125 CHMSD1 = 0.8519297242D0
21126 CHMSD4 = -0.1443076599D-01
21127 CHMSD5 = 0.4014954567D0
21129 EPN = (ECM**2 -AAM(KPROJ)**2 -AAM(KTARG)**2)/(2.0D0*AAM(KTARG))
21130 PPN = SQRT((EPN-AAM(KPROJ))*(EPN+AAM(KPROJ)))
21132 SDIAPP = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
21133 SHMSD = CHMSD1+CHMSD4*LOG(PPN)**2+CHMSD5*LOG(PPN)
21134 FRAC = SHMSD/SDIAPP
21136 GOTO( 10, 20,999,999,999,999,999, 10, 20,999,
21137 & 999, 20, 20, 20, 20, 20, 10, 20, 20, 10,
21138 & 10, 10, 20, 20, 20) KPROJ
21141 *---------------------------- p - p , n - p , sigma0+- - p ,
21143 CSD1 = 6.004476070D0
21144 CSD4 = -0.1257784606D-03
21145 CSD5 = 0.2447335720D0
21146 SIGDIF = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
21147 SIGDIH = FRAC*SIGDIF
21154 C F = SDIAPP/DT_SHNTOT(KPSCAL,KTSCAL,ECM,ZERO)
21156 CALL DT_XSHN(KPSCAL,KTSCAL,DUMZER,ECM,SIGTO,SIGEL)
21159 C SIGDIF = DT_SHNTOT(KPROJ,KT,ECM,ZERO)*F
21160 CALL DT_XSHN(KPROJ,KT,DUMZER,ECM,SIGTO,SIGEL)
21162 SIGDIH = FRAC*SIGDIF
21166 *-------------------------- leptons..
21172 *$ CREATE DT_PHOXS.FOR
21175 *===phoxs================================================================*
21177 SUBROUTINE DT_PHOXS(KPROJ,KTARG,ECM,PLAB,STOT,SINE,SDIF1,BEL,MODE)
21179 ************************************************************************
21180 * Total/inelastic proton-nucleon cross sections taken from PHOJET- *
21181 * interpolation tables. *
21182 * This version dated 05.11.97 is written by S. Roesler *
21183 ************************************************************************
21185 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21188 PARAMETER ( LINP = 10 ,
21191 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21192 PARAMETER (TWOPI = 6.283185307179586454D+00,
21194 & GEV2MB = 0.38938D0)
21197 DATA LFIRST /.TRUE./
21199 * nucleon-nucleon event-generator
21202 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21203 * particle properties (BAMJET index convention)
21205 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21206 & IICH(210),IIBAR(210),K1(210),K2(210)
21209 C PARAMETER (IEETAB=10)
21210 C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
21212 C energy-interpolation table
21214 PARAMETER ( IEETA2 = 20 )
21216 DOUBLE PRECISION SIGTAB,SIGECM
21217 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
21220 IF ((MCGENE.NE.2).AND.(MODE.NE.1)) THEN
21221 WRITE(LOUT,*) MCGENE
21222 1000 FORMAT(1X,'PHOXS: warning! PHOJET not initialized (',I2,')')
21226 IF (ECM.LE.ZERO) THEN
21227 EPN = SQRT(AAM(KPROJ)**2+PLAB**2)
21228 ECM = SQRT(AAM(KPROJ)**2+AAM(KTARG)**2+2.0D0*EPN*AAM(KTARG))
21231 IF (MODE.EQ.1) THEN
21236 STOT = 21.7D0*S**DELDL+56.08D0*S**EPSDL
21238 BEL = 8.5D0+2.D0*ALPHAP*LOG(S)
21239 SIGEL = STOT**2/(16.D0*PI*BEL*GEV2MB)
21245 IF(ECM.LE.SIGECM(IP,1)) THEN
21248 ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
21250 IF (ECM.LE.SIGECM(IP,I)) GOTO 2
21257 WRITE(LOUT,'(/1X,A,2E12.3)')
21258 & 'PHOXS: warning! energy above initialization limit (',
21259 & ECM,SIGECM(IP,ISIMAX)
21266 IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
21267 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
21269 STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
21270 SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
21271 SDIF1 = FAC2*(SIGTAB(IP,30,I2)+SIGTAB(IP,32,I2))+
21272 & FAC1*(SIGTAB(IP,30,I1)+SIGTAB(IP,32,I1))
21273 BEL = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
21279 *$ CREATE DT_XSHN.FOR
21282 *===xshn===============================================================*
21284 SUBROUTINE DT_XSHN(IP,IT,PL,ECM,STOT,SELA)
21286 ************************************************************************
21287 * Total and elastic hadron-nucleon cross section. *
21288 * Below 500GeV cross sections are based on the '98 data compilation *
21289 * of the PDG. At higher energies PHOJET results are used (patched to *
21290 * the low energy data at 500GeV). *
21291 * IP projectile index (BAMJET numbering scheme) *
21292 * (should be in the range 1..25) *
21293 * IT target index (BAMJET numbering scheme) *
21294 * (1 = proton, 8 = neutron) *
21295 * PL laboratory momentum *
21296 * ECM cm. energy (ignored if PL>0) *
21297 * STOT total cross section *
21298 * SELA elastic cross section *
21299 * Last change: 24.4.99 by S. Roesler *
21300 ************************************************************************
21302 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21305 PARAMETER ( LINP = 10 ,
21308 PARAMETER (ZERO=0.0D0,ONE=1.0D0)
21310 PARAMETER (NPOIN1 = 54, NPOIN2 = 8,
21311 & PLABLO = 0.1D0, PTHRE = 5.0D0, PLABHI = 500.0D0)
21312 PARAMETER (NPOINT = NPOIN1+NPOIN2+1)
21315 * particle properties (BAMJET index convention)
21317 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21318 & IICH(210),IIBAR(210),K1(210),K2(210)
21319 * nucleon-nucleon event-generator
21322 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21324 C PARAMETER (IEETAB=10)
21325 C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
21327 C energy-interpolation table
21329 PARAMETER ( IEETA2 = 20 )
21331 DOUBLE PRECISION SIGTAB,SIGECM
21332 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
21334 DIMENSION APL(NPOINT),ASIGTO(10,NPOINT),ASIGEL(10,NPOINT)
21335 DIMENSION IDXDAT(25,2)
21338 &-1.000,-0.969,-0.937,-0.906,-0.874,-0.843,-0.811,-0.780,-0.748,
21339 &-0.717,-0.685,-0.654,-0.622,-0.591,-0.560,-0.528,-0.497,-0.465,
21340 &-0.434,-0.402,-0.371,-0.339,-0.308,-0.276,-0.245,-0.213,-0.182,
21341 &-0.151,-0.119,-0.088,-0.056,-0.025, 0.007, 0.038, 0.070, 0.101,
21342 & 0.133, 0.164, 0.196, 0.227, 0.258, 0.290, 0.321, 0.353, 0.384,
21343 & 0.416, 0.447, 0.479, 0.510, 0.542, 0.573, 0.605, 0.636, 0.668,
21344 & 0.699, 0.949, 1.199, 1.449, 1.699, 1.949, 2.199, 2.449, 2.699/
21346 * total cross sections:
21348 DATA (ASIGTO(1,K),K=1,NPOINT) /
21349 & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
21350 & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
21351 & 1.577, 1.518, 1.462, 1.420, 1.393, 1.375, 1.363, 1.356, 1.352,
21352 & 1.350, 1.351, 1.359, 1.381, 1.410, 1.444, 1.487, 1.544, 1.596,
21353 & 1.650, 1.672, 1.676, 1.677, 1.677, 1.675, 1.675, 1.669, 1.664,
21354 & 1.658, 1.653, 1.645, 1.640, 1.634, 1.630, 1.625, 1.620, 1.617,
21355 & 1.614, 1.602, 1.594, 1.589, 1.581, 1.583, 1.588, 1.596, 1.603/
21357 DATA (ASIGTO(2,K),K=1,NPOINT) /
21358 & 2.778, 2.759, 2.739, 2.718, 2.697, 2.675, 2.651, 2.626, 2.598,
21359 & 2.569, 2.537, 2.502, 2.471, 2.443, 2.420, 2.389, 2.361, 2.329,
21360 & 2.313, 2.304, 2.268, 2.244, 2.222, 2.212, 2.178, 2.162, 2.151,
21361 & 2.132, 2.109, 2.097, 2.089, 2.078, 2.063, 2.049, 2.035, 2.024,
21362 & 2.014, 2.004, 1.993, 1.981, 1.970, 1.958, 1.946, 1.933, 1.921,
21363 & 1.909, 1.894, 1.885, 1.871, 1.854, 1.836, 1.825, 1.816, 1.802,
21364 & 1.790, 1.744, 1.694, 1.663, 1.642, 1.614, 1.623, 1.623, 1.630/
21366 DATA (ASIGTO(3,K),K=1,NPOINT) /
21367 & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
21368 & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
21369 & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
21370 & 1.547, 1.534, 1.526, 1.522, 1.520, 1.525, 1.536, 1.550, 1.566,
21371 & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
21372 & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
21373 & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
21375 DATA (ASIGTO(4,K),K=1,NPOINT) /
21376 & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
21377 & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
21378 & 2.001, 1.875, 1.801, 1.665, 1.609, 1.484, 1.412, 1.334, 1.195,
21379 & 1.160, 1.166, 1.208, 1.309, 1.356, 1.394, 1.406, 1.419, 1.473,
21380 & 1.540, 1.596, 1.570, 1.533, 1.516, 1.484, 1.471, 1.478, 1.492,
21381 & 1.497, 1.491, 1.479, 1.465, 1.453, 1.449, 1.450, 1.444, 1.428,
21382 & 1.422, 1.406, 1.384, 1.369, 1.364, 1.369, 1.374, 1.388, 1.395/
21384 DATA (ASIGTO(5,K),K=1,NPOINT) /
21385 & 0.458, 0.540, 0.626, 0.718, 0.819, 0.933, 1.063, 1.208, 1.226,
21386 & 1.436, 1.470, 1.594, 1.708, 1.786, 1.852, 1.836, 1.763, 1.679,
21387 & 1.590, 1.492, 1.445, 1.426, 1.423, 1.433, 1.473, 1.506, 1.547,
21388 & 1.660, 1.671, 1.545, 1.591, 1.687, 1.808, 1.656, 1.582, 1.543,
21389 & 1.562, 1.560, 1.537, 1.540, 1.549, 1.557, 1.557, 1.551, 1.535,
21390 & 1.527, 1.511, 1.510, 1.507, 1.500, 1.491, 1.483, 1.478, 1.468,
21391 & 1.463, 1.435, 1.408, 1.394, 1.384, 1.380, 1.383, 1.393, 1.411/
21393 DATA (ASIGTO(6,K),K=1,NPOINT) /
21394 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
21395 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
21396 & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.096, 1.095,
21397 & 1.098, 1.105, 1.111, 1.139, 1.169, 1.209, 1.248, 1.259, 1.268,
21398 & 1.262, 1.257, 1.254, 1.252, 1.250, 1.249, 1.246, 1.244, 1.244,
21399 & 1.243, 1.240, 1.238, 1.237, 1.236, 1.235, 1.235, 1.236, 1.236,
21400 & 1.236, 1.233, 1.238, 1.248, 1.257, 1.272, 1.292, 1.311, 1.336/
21402 DATA (ASIGTO(7,K),K=1,NPOINT) /
21403 & 2.003, 2.002, 2.001, 2.000, 1.999, 1.998, 1.998, 1.997, 1.997,
21404 & 1.996, 1.995, 1.993, 1.990, 1.992, 1.974, 1.912, 1.865, 1.847,
21405 & 1.896, 1.950, 1.827, 1.681, 1.637, 1.616, 1.589, 1.545, 1.543,
21406 & 1.532, 1.603, 1.604, 1.616, 1.658, 1.700, 1.658, 1.595, 1.508,
21407 & 1.493, 1.514, 1.531, 1.523, 1.501, 1.479, 1.474, 1.467, 1.463,
21408 & 1.450, 1.444, 1.435, 1.426, 1.424, 1.423, 1.415, 1.401, 1.396,
21409 & 1.384, 1.364, 1.330, 1.313, 1.310, 1.309, 1.317, 1.329, 1.338/
21411 DATA (ASIGTO(8,K),K=1,NPOINT) /
21412 & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21413 & 0.631, 0.675, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21414 & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.102, 1.125, 1.147,
21415 & 1.168, 1.187, 1.205, 1.224, 1.248, 1.279, 1.315, 1.324, 1.301,
21416 & 1.285, 1.279, 1.274, 1.273, 1.272, 1.271, 1.267, 1.263, 1.261,
21417 & 1.259, 1.256, 1.252, 1.247, 1.244, 1.241, 1.240, 1.240, 1.240,
21418 & 1.241, 1.243, 1.245, 1.253, 1.265, 1.275, 1.293, 1.314, 1.342/
21420 DATA (ASIGTO(9,K),K=1,NPOINT) /
21421 & 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778,
21422 & 1.778, 1.778, 1.778, 1.778, 1.778, 1.779, 1.779, 1.778, 1.773,
21423 & 1.765, 1.746, 1.703, 1.646, 1.561, 1.488, 1.454, 1.437, 1.437,
21424 & 1.458, 1.505, 1.561, 1.588, 1.593, 1.581, 1.551, 1.500, 1.454,
21425 & 1.427, 1.408, 1.390, 1.372, 1.361, 1.356, 1.351, 1.347, 1.343,
21426 & 1.341, 1.340, 1.338, 1.337, 1.335, 1.334, 1.332, 1.331, 1.330,
21427 & 1.330, 1.313, 1.303, 1.288, 1.288, 1.297, 1.305, 1.320, 1.342/
21429 DATA (ASIGTO(10,K),K=1,NPOINT) /
21430 & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21431 & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.629,
21432 & 1.599, 1.576, 1.558, 1.543, 1.530, 1.520, 1.512, 1.505, 1.499,
21433 & 1.495, 1.495, 1.497, 1.504, 1.514, 1.525, 1.536, 1.550, 1.567,
21434 & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
21435 & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
21436 & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
21438 * elastic cross sections:
21440 DATA (ASIGEL(1,K),K=1,NPOINT) /
21441 & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
21442 & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
21443 & 1.577, 1.518, 1.462, 1.420, 1.393, 1.374, 1.360, 1.353, 1.350,
21444 & 1.351, 1.356, 1.362, 1.369, 1.376, 1.384, 1.385, 1.399, 1.397,
21445 & 1.389, 1.385, 1.379, 1.366, 1.358, 1.344, 1.320, 1.294, 1.275,
21446 & 1.260, 1.248, 1.235, 1.219, 1.199, 1.172, 1.144, 1.126, 1.115,
21447 & 1.104, 1.013, 0.962, 0.905, 0.869, 0.845, 0.846, 0.850, 0.868/
21449 DATA (ASIGEL(2,K),K=1,NPOINT) /
21450 & 1.987, 1.985, 1.983, 1.980, 1.978, 1.975, 1.971, 1.968, 1.963,
21451 & 1.958, 1.951, 1.944, 1.935, 1.925, 1.914, 1.902, 1.889, 1.875,
21452 & 1.859, 1.845, 1.834, 1.817, 1.792, 1.769, 1.754, 1.738, 1.720,
21453 & 1.702, 1.688, 1.676, 1.667, 1.659, 1.652, 1.645, 1.640, 1.636,
21454 & 1.620, 1.591, 1.562, 1.546, 1.540, 1.524, 1.496, 1.475, 1.457,
21455 & 1.429, 1.402, 1.373, 1.344, 1.330, 1.306, 1.294, 1.265, 1.228,
21456 & 1.204, 1.086, 0.977, 0.933, 0.914, 0.850, 0.862, 0.848, 0.845/
21458 DATA (ASIGEL(3,K),K=1,NPOINT) /
21459 & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
21460 & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
21461 & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
21462 & 1.544, 1.527, 1.514, 1.504, 1.495, 1.486, 1.476, 1.466, 1.454,
21463 & 1.440, 1.425, 1.409, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21464 & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21465 & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21467 DATA (ASIGEL(4,K),K=1,NPOINT) /
21468 & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
21469 & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
21470 & 2.001, 1.875, 1.801, 1.664, 1.610, 1.479, 1.423, 1.299, 1.166,
21471 & 1.097, 1.020, 0.958, 0.914, 1.013, 1.088, 1.153, 1.167, 1.235,
21472 & 1.240, 1.237, 1.202, 1.135, 1.090, 1.026, 0.975, 0.941, 0.904,
21473 & 0.894, 0.884, 0.862, 0.850, 0.845, 0.827, 0.805, 0.789, 0.776,
21474 & 0.763, 0.686, 0.626, 0.562, 0.505, 0.518, 0.525, 0.528, 0.528/
21476 DATA (ASIGEL(5,K),K=1,NPOINT) /
21477 & 0.266, 0.278, 0.294, 0.320, 0.360, 0.419, 0.503, 0.608, 0.727,
21478 & 0.850, 0.968, 1.071, 1.167, 1.305, 1.369, 1.404, 1.446, 1.217,
21479 & 1.112, 1.071, 1.014, 1.002, 0.996, 1.008, 1.070, 1.126, 1.209,
21480 & 1.300, 1.281, 1.188, 1.156, 1.341, 1.423, 1.314, 1.171, 1.140,
21481 & 1.106, 1.071, 1.011, 1.037, 1.026, 1.024, 0.988, 0.953, 0.895,
21482 & 0.894, 0.880, 0.871, 0.864, 0.853, 0.837, 0.820, 0.809, 0.800,
21483 & 0.782, 0.674, 0.612, 0.530, 0.521, 0.528, 0.524, 0.542, 0.569/
21485 DATA (ASIGEL(6,K),K=1,NPOINT) /
21486 & 1.064, 1.065, 1.065, 1.066, 1.066, 1.066, 1.066, 1.066, 1.066,
21487 & 1.065, 1.064, 1.063, 1.062, 1.062, 1.062, 1.064, 1.066, 1.070,
21488 & 1.076, 1.082, 1.088, 1.096, 1.103, 1.104, 1.104, 1.102, 1.093,
21489 & 1.087, 1.084, 1.079, 1.075, 1.067, 1.058, 1.040, 1.029, 1.012,
21490 & 1.003, 0.985, 0.935, 0.909, 0.880, 0.846, 0.790, 0.771, 0.759,
21491 & 0.743, 0.718, 0.681, 0.666, 0.645, 0.622, 0.606, 0.594, 0.584,
21492 & 0.575, 0.513, 0.453, 0.403, 0.356, 0.365, 0.389, 0.430, 0.477/
21494 DATA (ASIGEL(7,K),K=1,NPOINT) /
21495 & 1.941, 1.936, 1.931, 1.926, 1.919, 1.912, 1.903, 1.892, 1.878,
21496 & 1.863, 1.844, 1.821, 1.791, 1.755, 1.713, 1.666, 1.615, 1.561,
21497 & 1.533, 1.531, 1.518, 1.511, 1.452, 1.339, 1.265, 1.233, 1.188,
21498 & 1.184, 1.236, 1.316, 1.333, 1.336, 1.333, 1.277, 1.216, 1.077,
21499 & 1.018, 0.912, 0.926, 0.920, 0.910, 0.894, 0.830, 0.825, 0.800,
21500 & 0.788, 0.747, 0.703, 0.707, 0.689, 0.643, 0.633, 0.635, 0.618,
21501 & 0.584, 0.579, 0.461, 0.403, 0.405, 0.399, 0.408, 0.418, 0.413/
21503 DATA (ASIGEL(8,K),K=1,NPOINT) /
21504 & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21505 & 0.631, 0.676, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21506 & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.103, 1.126, 1.148,
21507 & 1.168, 1.187, 1.205, 1.223, 1.248, 1.282, 1.269, 1.185, 1.111,
21508 & 1.063, 1.031, 0.998, 0.964, 0.928, 0.889, 0.849, 0.814, 0.785,
21509 & 0.760, 0.738, 0.720, 0.703, 0.688, 0.674, 0.660, 0.648, 0.635,
21510 & 0.624, 0.536, 0.473, 0.442, 0.428, 0.428, 0.436, 0.453, 0.477/
21512 DATA (ASIGEL(9,K),K=1,NPOINT) /
21513 & 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613,
21514 & 1.613, 1.613, 1.613, 1.612, 1.613, 1.614, 1.614, 1.612, 1.606,
21515 & 1.593, 1.564, 1.498, 1.402, 1.240, 1.071, 0.977, 0.922, 0.914,
21516 & 0.961, 1.077, 1.214, 1.271, 1.290, 1.281, 1.217, 1.096, 0.979,
21517 & 0.896, 0.822, 0.736, 0.655, 0.608, 0.591, 0.580, 0.569, 0.559,
21518 & 0.550, 0.540, 0.531, 0.522, 0.514, 0.507, 0.500, 0.494, 0.489,
21519 & 0.485, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477/
21521 DATA (ASIGEL(10,K),K=1,NPOINT) /
21522 & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21523 & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.630,
21524 & 1.600, 1.577, 1.558, 1.542, 1.528, 1.518, 1.510, 1.505, 1.502,
21525 & 1.501, 1.500, 1.499, 1.496, 1.491, 1.485, 1.477, 1.466, 1.454,
21526 & 1.440, 1.425, 1.408, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21527 & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21528 & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21530 DATA (IDXDAT(K,1),K=1,25) /
21531 & 1, 2, 0, 0, 0, 0, 0, 3, 2, 0, 0,67, 4, 5, 6, 7,10, 2,67, 3,
21533 DATA (IDXDAT(K,2),K=1,25) /
21534 & 3, 2, 0, 0, 0, 0, 0, 1, 2, 0, 0,89, 5, 4, 8, 9, 1, 2,89, 1,
21537 DATA LFIRST /.TRUE./
21540 APLABL = LOG10(PLABLO)
21541 APLABH = LOG10(PLABHI)
21542 APTHRE = LOG10(PTHRE)
21543 ADP1 = (APTHRE-APLABL)/DBLE(NPOIN1)
21544 ADP2 = (APLABH-APTHRE)/DBLE(NPOIN2)
21547 PHOELA = SQRT(AAM(1)**2+PHOPLA**2)
21548 ECMS = SQRT(2.0D0*AAM(1)**2+2.0D0*AAM(1)*PHOELA)
21549 IF (MCGENE.EQ.2) THEN
21550 IF (ECMS.LE.SIGECM(1,ISIMAX)) THEN
21551 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,0)
21553 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21556 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21558 PHOSEL = PHOSTO-PHOSIN
21559 APHOST = LOG10(PHOSTO)
21560 APHOSE = LOG10(PHOSEL)
21567 IF ( (IP.LT.1).OR.((IT.NE.1).AND.(IT.NE.8)) ) THEN
21568 WRITE(LOUT,1000) IP,IT
21569 1000 FORMAT(1X,'DT_XSHN: cross sections not implemented for ',
21570 & 'proj/target',2I4)
21574 IF ((PLAB.LE.ZERO).AND.(ECMS.GT.ZERO)) THEN
21575 ELAB = (ECMS**2-AAM(IP)**2-AAM(IT)**2)/(2.0D0*AAM(IT))
21576 PLAB = SQRT((ELAB-AAM(IP))*(ELAB+AAM(IP)))
21577 ELSEIF ((PLAB.LE.ZERO).AND.(ECMS.LE.ZERO)) THEN
21578 WRITE(LOUT,1001) PLAB,ECMS
21579 1001 FORMAT(1X,'DT_XSHN: invalid momentum/cm-energy ',2E15.5)
21583 * index of spectrum
21586 IF (AAM(IP).GT.ZERO) THEN
21587 IF (ABS(IIBAR(IP)).GT.0) THEN
21597 IF (IT.EQ.8) IDXT = 2
21598 IDXS = IDXDAT(IDXP,IDXT)
21599 IF (IDXS.EQ.0) RETURN
21601 * compute momentum bin indices
21602 IF (PLAB.LT.PLABLO) THEN
21605 ELSEIF (PLAB.GE.PLABHI) THEN
21609 APLAB = LOG10(PLAB)
21610 IF ((PLAB.GE.PLABLO).AND.(PLAB.LT.PTHRE )) THEN
21611 IDX0 = INT((APLAB-APLABL)/ADP1)+1
21612 ELSEIF ((PLAB.GE.PTHRE ).AND.(PLAB.LT.PLABHI)) THEN
21613 IDX0 = INT((APLAB-APTHRE)/ADP2)+NPOIN1+1
21618 * interpolate cross section
21619 IF (IDXS.GT.10) THEN
21621 IDXS2 = IDXS-10*IDXS1
21622 IF (IDX0.EQ.IDX1) THEN
21623 IF (IDX0.EQ.1) THEN
21624 ASTOT = 0.5D0*(ASIGTO(IDXS1,IDX0)+ASIGTO(IDXS2,IDX0))
21625 ASELA = 0.5D0*(ASIGEL(IDXS1,IDX0)+ASIGEL(IDXS2,IDX0))
21628 CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21629 PHOSEL = PHOSTO-PHOSIN
21630 ASTOT1 = ASIGTO(IDXS1,NPOINT)-APHOST+LOG10(PHOSTO)
21631 ASELA1 = ASIGEL(IDXS1,NPOINT)-APHOSE+LOG10(PHOSEL)
21632 ASTOT2 = ASIGTO(IDXS2,NPOINT)-APHOST+LOG10(PHOSTO)
21633 ASELA2 = ASIGEL(IDXS2,NPOINT)-APHOSE+LOG10(PHOSEL)
21634 ASTOT = 0.5D0*(ASTOT1+ASTOT2)
21635 ASELA = 0.5D0*(ASELA1+ASELA2)
21638 FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21639 ASTOT1 = ASIGTO(IDXS1,IDX0)+
21640 & FAC*(ASIGTO(IDXS1,IDX1)-ASIGTO(IDXS1,IDX0))
21641 ASTOT2 = ASIGTO(IDXS2,IDX0)+
21642 & FAC*(ASIGTO(IDXS2,IDX1)-ASIGTO(IDXS2,IDX0))
21643 ASTOT = 0.5D0*(ASTOT1+ASTOT2)
21644 ASELA1 = ASIGEL(IDXS1,IDX0)+
21645 & FAC*(ASIGEL(IDXS1,IDX1)-ASIGEL(IDXS1,IDX0))
21646 ASELA2 = ASIGEL(IDXS2,IDX0)+
21647 & FAC*(ASIGEL(IDXS2,IDX1)-ASIGEL(IDXS2,IDX0))
21648 ASELA = 0.5D0*(ASELA1+ASELA2)
21651 IF (IDX0.EQ.IDX1) THEN
21652 IF (IDX0.EQ.1) THEN
21653 ASTOT = ASIGTO(IDXS,IDX0)
21654 ASELA = ASIGEL(IDXS,IDX0)
21657 CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21658 PHOSEL = PHOSTO-PHOSIN
21659 ASTOT = ASIGTO(IDXS,NPOINT)-APHOST+LOG10(PHOSTO)
21660 ASELA = ASIGEL(IDXS,NPOINT)-APHOSE+LOG10(PHOSEL)
21663 FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21664 ASTOT = ASIGTO(IDXS,IDX0)+
21665 & FAC*(ASIGTO(IDXS,IDX1)-ASIGTO(IDXS,IDX0))
21666 ASELA = ASIGEL(IDXS,IDX0)+
21667 & FAC*(ASIGEL(IDXS,IDX1)-ASIGEL(IDXS,IDX0))
21670 STOT = 10.0D0**ASTOT
21671 SELA = 10.0D0**ASELA
21676 *$ CREATE DT_SIHNAB.FOR
21679 *===sihnab===============================================================*
21681 SUBROUTINE DT_SIHNAB(IDP,IDT,PLAB,SIGABS)
21683 **********************************************************************
21684 * Pion 2-nucleon absorption cross sections. *
21685 * (sigma_tot for pi+ d --> p p, pi- d --> n n *
21686 * taken from Ritchie PRC 28 (1983) 926 ) *
21687 * This version dated 18.05.96 is written by S. Roesler *
21688 **********************************************************************
21690 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21692 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY3=1.0D-3)
21693 PARAMETER (AMPR = 938.0D0,
21703 IF ( ((IDP.NE.13).AND.(IDP.NE.14).AND.(IDP.NE.23))
21704 & .OR.((IDT.NE.1).AND.(IDT.NE.8)) ) RETURN
21706 EKIN = SQRT(AMPI**2+PTOT**2)-AMPI
21707 IF ((EKIN.LT.TINY3).OR.(EKIN.GT.400.0D0)) RETURN
21708 ECM = SQRT( (AMPI+AMDE)**2+TWO*EKIN*AMDE )
21709 SIGABS = A+B/SQRT(EKIN)+C*1.0D4/((ECM-ER)**2+D)
21710 * approximate 3N-abs., I=1-abs. etc.
21711 SIGABS = SIGABS/0.40D0
21712 * pi0-absorption (rough approximation!!)
21713 IF (IDP.EQ.23) SIGABS = 0.5D0*SIGABS
21718 *$ CREATE DT_SIGEMU.FOR
21721 *===sigemu=============================================================*
21723 SUBROUTINE DT_SIGEMU
21725 ************************************************************************
21726 * Combined cross section for target compounds. *
21727 * This version dated 6.4.98 is written by S. Roesler *
21728 ************************************************************************
21730 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21732 PARAMETER ( LINP = 10 ,
21735 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21736 & OHALF=0.5D0,ONE=1.0D0)
21738 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21739 * Glauber formalism: cross sections
21740 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21741 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21742 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21743 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21744 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21745 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21746 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21747 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21748 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21749 & BSLOPE,NEBINI,NQBINI
21750 * emulsion treatment
21751 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
21753 * nucleon-nucleon event-generator
21756 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21758 IF (MCGENE.NE.4) THEN
21759 WRITE(LOUT,'(A)') ' DT_SIGEMU: Combined cross sections'
21760 WRITE(LOUT,'(15X,A)') '-----------------------'
21780 IF (NCOMPO.GT.0) THEN
21782 SIGTOT = SIGTOT+EMUFRA(IC)*XSTOT(IE,IQ,IC)
21783 SIGELA = SIGELA+EMUFRA(IC)*XSELA(IE,IQ,IC)
21784 SIGQEP = SIGQEP+EMUFRA(IC)*XSQEP(IE,IQ,IC)
21785 SIGQET = SIGQET+EMUFRA(IC)*XSQET(IE,IQ,IC)
21786 SIGQE2 = SIGQE2+EMUFRA(IC)*XSQE2(IE,IQ,IC)
21787 SIGPRO = SIGPRO+EMUFRA(IC)*XSPRO(IE,IQ,IC)
21788 SIGDEL = SIGDEL+EMUFRA(IC)*XSDEL(IE,IQ,IC)
21789 SIGDQE = SIGDQE+EMUFRA(IC)*XSDQE(IE,IQ,IC)
21790 ERRTOT = ERRTOT+XETOT(IE,IQ,IC)**2
21791 ERRELA = ERRELA+XEELA(IE,IQ,IC)**2
21792 ERRQEP = ERRQEP+XEQEP(IE,IQ,IC)**2
21793 ERRQET = ERRQET+XEQET(IE,IQ,IC)**2
21794 ERRQE2 = ERRQE2+XEQE2(IE,IQ,IC)**2
21795 ERRPRO = ERRPRO+XEPRO(IE,IQ,IC)**2
21796 ERRDEL = ERRDEL+XEDEL(IE,IQ,IC)**2
21797 ERRDQE = ERRDQE+XEDQE(IE,IQ,IC)**2
21799 ERRTOT = SQRT(ERRTOT)
21800 ERRELA = SQRT(ERRELA)
21801 ERRQEP = SQRT(ERRQEP)
21802 ERRQET = SQRT(ERRQET)
21803 ERRQE2 = SQRT(ERRQE2)
21804 ERRPRO = SQRT(ERRPRO)
21805 ERRDEL = SQRT(ERRDEL)
21806 ERRDQE = SQRT(ERRDQE)
21808 SIGTOT = XSTOT(IE,IQ,1)
21809 SIGELA = XSELA(IE,IQ,1)
21810 SIGQEP = XSQEP(IE,IQ,1)
21811 SIGQET = XSQET(IE,IQ,1)
21812 SIGQE2 = XSQE2(IE,IQ,1)
21813 SIGPRO = XSPRO(IE,IQ,1)
21814 SIGDEL = XSDEL(IE,IQ,1)
21815 SIGDQE = XSDQE(IE,IQ,1)
21816 ERRTOT = XETOT(IE,IQ,1)
21817 ERRELA = XEELA(IE,IQ,1)
21818 ERRQEP = XEQEP(IE,IQ,1)
21819 ERRQET = XEQET(IE,IQ,1)
21820 ERRQE2 = XEQE2(IE,IQ,1)
21821 ERRPRO = XEPRO(IE,IQ,1)
21822 ERRDEL = XEDEL(IE,IQ,1)
21823 ERRDQE = XEDQE(IE,IQ,1)
21825 IF (MCGENE.NE.4) THEN
21826 WRITE(LOUT,1000) ECMNN(IE),Q2G(IQ)
21827 1000 FORMAT(/,1X,'E_cm =',F9.1,' GeV Q^2 =',F6.1,' GeV^2 :',/)
21828 WRITE(LOUT,1001) SIGTOT,ERRTOT
21829 1001 FORMAT(1X,'total',32X,F10.4,' +-',F11.5,' mb')
21830 WRITE(LOUT,1002) SIGELA,ERRELA
21831 1002 FORMAT(1X,'elastic',30X,F10.4,' +-',F11.5,' mb')
21832 WRITE(LOUT,1003) SIGQEP,ERRQEP
21833 1003 FORMAT(1X,'quasi-elastic (A+B-->A+X)',12X,F10.4,' +-',
21835 WRITE(LOUT,1004) SIGQET,ERRQET
21836 1004 FORMAT(1X,'quasi-elastic (A+B-->X+B)',12X,F10.4,' +-',
21838 WRITE(LOUT,1005) SIGQE2,ERRQE2
21839 1005 FORMAT(1X,'quasi-elastic (A+B-->X, excl. 2-4)',3X,F10.4,
21840 & ' +-',F11.5,' mb')
21841 WRITE(LOUT,1006) SIGPRO,ERRPRO
21842 1006 FORMAT(1X,'production',27X,F10.4,' +-',F11.5,' mb')
21843 WRITE(LOUT,1007) SIGDEL,ERRDEL
21844 1007 FORMAT(1X,'diff-el ',27X,F10.4,' +-',F11.5,' mb')
21845 WRITE(LOUT,1008) SIGDQE,ERRDQE
21846 1008 FORMAT(1X,'diff-qel ',27X,F10.4,' +-',F11.5,' mb')
21855 *$ CREATE DT_SIGGA.FOR
21858 *===sigga==============================================================*
21860 SUBROUTINE DT_SIGGA(NTI,XI,Q2I,ECMI,XNUI,STOT,ETOT,SIN,EIN,STOT0)
21862 ************************************************************************
21863 * Total/inelastic photon-nucleus cross sections. *
21864 * !!!! Overwrites SHMAKI-initialization. Do not use it during *
21865 * production runs !!!! *
21866 * This version dated 27.03.96 is written by S. Roesler *
21867 ************************************************************************
21869 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21871 PARAMETER ( LINP = 10 ,
21874 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21875 & OHALF=0.5D0,ONE=1.0D0)
21876 PARAMETER (AMPROT = 0.938D0)
21878 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21879 * Glauber formalism: cross sections
21880 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21881 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21882 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21883 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21884 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21885 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21886 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21887 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21888 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21889 & BSLOPE,NEBINI,NQBINI
21896 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21897 & ECM = SQRT(AMPROT**2-Q2+2.0D0*XNUI*AMPROT)
21898 CALL DT_XSGLAU(1,NT,7,X,Q2,ECM,1,1,-1)
21899 STOT = XSTOT(1,1,1)
21900 ETOT = XETOT(1,1,1)
21907 *$ CREATE DT_SIGGAT.FOR
21910 *===siggat=============================================================*
21912 SUBROUTINE DT_SIGGAT(Q2I,ECMI,STOT,NT)
21914 ************************************************************************
21915 * Total/inelastic photon-nucleus cross sections. *
21916 * Uses pre-tabulated cross section. *
21917 * This version dated 29.07.96 is written by S. Roesler *
21918 ************************************************************************
21920 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21922 PARAMETER ( LINP = 10 ,
21925 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21926 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21928 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21929 * Glauber formalism: cross sections
21930 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21931 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21932 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21933 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21934 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21935 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21936 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21937 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21938 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21939 & BSLOPE,NEBINI,NQBINI
21945 IF (NEBINI.GT.1) THEN
21946 IF (ECMI.GE.ECMNN(NEBINI)) THEN
21950 ELSEIF (ECMI.GT.ECMNN(1)) THEN
21952 IF (ECMI.LT.ECMNN(I)) THEN
21955 RATE = (ECMI-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
21965 IF (NQBINI.GT.1) THEN
21966 IF (Q2I.GE.Q2G(NQBINI)) THEN
21970 ELSEIF (Q2I.GT.Q2G(1)) THEN
21972 IF (Q2I.LT.Q2G(I)) THEN
21975 RATQ = LOG10( Q2I/MAX(Q2G(J1),TINY14))/
21976 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
21977 C RATQ = (Q2I-Q2G(J1))/(Q2G(J2)-Q2G(J1))
21985 STOT = XSTOT(I1,J1,NTARG)+
21986 & RATE*(XSTOT(I2,J1,NTARG)-XSTOT(I1,J1,NTARG))+
21987 & RATQ*(XSTOT(I1,J2,NTARG)-XSTOT(I1,J1,NTARG))+
21988 & RATE*RATQ*(XSTOT(I2,J2,NTARG)-XSTOT(I1,J2,NTARG)+
21989 & XSTOT(I1,J1,NTARG)-XSTOT(I2,J1,NTARG))
21994 *$ CREATE DT_SANO.FOR
21997 *===sigano=============================================================*
21999 DOUBLE PRECISION FUNCTION DT_SANO(ECM)
22001 ************************************************************************
22002 * This version dated 31.07.96 is written by S. Roesler *
22003 ************************************************************************
22005 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22007 PARAMETER ( LINP = 10 ,
22010 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
22011 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
22014 * VDM parameter for photon-nucleus interactions
22015 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22016 * properties of interacting particles
22017 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
22019 DIMENSION ECMANO(NE),FRAANO(NE),SIGHRD(NE)
22021 & 0.200D+02,0.500D+02,0.100D+03,0.200D+03,0.500D+03,
22022 & 0.100D+04,0.200D+04,0.500D+04
22024 * fixed cut (3 GeV/c)
22026 & 0.085D+00,0.114D+00,0.105D+00,0.091D+00,0.073D+00,
22027 & 0.062D+00,0.054D+00,0.042D+00
22030 & 4.0099D-04,3.3104D-03,1.1905D-02,3.6435D-02,1.3493D-01,
22031 & 3.3086D-01,7.6255D-01,2.1319D+00
22033 * running cut (based on obsolete Phojet-caluclations, bugs..)
22035 C & 0.251E+00,0.313E+00,0.279E+00,0.239E+00,0.186E+00,
22036 C & 0.167E+00,0.150E+00,0.131E+00
22039 C & 6.6569E-04,4.4949E-03,1.4837E-02,4.1466E-02,1.5071E-01,
22040 C & 2.5736E-01,4.5593E-01,8.2550E-01
22044 IF ((ISHAD(2).NE.1).OR.(IJPROJ.NE.7)) RETURN
22048 IF (ECM.GE.ECMANO(NE)) THEN
22051 ELSEIF (ECM.GT.ECMANO(1)) THEN
22053 IF (ECM.LT.ECMANO(IE)) THEN
22056 RATE = LOG10(ECM/ECMANO(J1))/LOG10(ECMANO(J2)/ECMANO(J1))
22062 IF ((J1.GT.0).AND.(J2.GT.0)) THEN
22063 AFRA1 = LOG10(MAX(FRAANO(J1)*SIGHRD(J1),TINY14))
22064 AFRA2 = LOG10(MAX(FRAANO(J2)*SIGHRD(J2),TINY14))
22065 DT_SANO = 10.0D0**(AFRA1+RATE*(AFRA2-AFRA1))
22071 *$ CREATE DT_SIGGP.FOR
22074 *===siggp==============================================================*
22076 SUBROUTINE DT_SIGGP(XI,Q2I,ECMI,XNUI,STOT,SINE,SDIR)
22078 ************************************************************************
22079 * Total/inelastic photon-nucleon cross sections. *
22080 * This version dated 30.04.96 is written by S. Roesler *
22081 ************************************************************************
22083 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22085 PARAMETER ( LINP = 10 ,
22088 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22089 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22091 & GEV2MB = 0.38938D0,
22092 & ALPHEM = ONE/137.0D0)
22094 * particle properties (BAMJET index convention)
22096 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22097 & IICH(210),IIBAR(210),K1(210),K2(210)
22098 * VDM parameter for photon-nucleus interactions
22099 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22102 C CHARACTER*8 MDLNA
22103 C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
22104 C PARAMETER (IEETAB=10)
22105 C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
22107 C model switches and parameters
22109 INTEGER ISWMDL,IPAMDL
22110 DOUBLE PRECISION PARMDL
22111 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
22112 C energy-interpolation table
22114 PARAMETER ( IEETA2 = 20 )
22116 DOUBLE PRECISION SIGTAB,SIGECM
22117 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
22120 C PARAMETER (NPOINT=80)
22121 PARAMETER (NPOINT=16)
22122 DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
22129 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
22130 & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
22134 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22136 X = Q2/(W2+Q2-AAM(1)**2)
22138 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
22139 X = Q2/(W2+Q2-AAM(1)**2)
22140 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22141 Q2 = (W2-AAM(1)**2)*X/(ONE-X)
22142 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
22143 W2 = Q2*(ONE-X)/X+AAM(1)**2
22145 WRITE(LOUT,*) 'SIGGP: inconsistent input ',W2,Q2,X
22150 IF (MODEGA.EQ.1) THEN
22152 CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
22155 C ALLMF2 = PHO_ALLM97(Q2,W)
22156 C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
22157 STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
22160 ELSEIF (MODEGA.EQ.2) THEN
22161 IF (INTRGE(1).EQ.1) THEN
22162 AMLO2 = (3.0D0*AAM(13))**2
22163 ELSEIF (INTRGE(1).EQ.2) THEN
22168 IF (INTRGE(2).EQ.1) THEN
22170 ELSEIF (INTRGE(2).EQ.2) THEN
22175 AMHI20 = (ECM-AAM(1))**2
22176 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22177 XAMLO = LOG( AMLO2+Q2 )
22178 XAMHI = LOG( AMHI2+Q2 )
22180 C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
22182 CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
22186 AM2 = EXP(ABSZX(J))-Q2
22187 IF (AM2.LT.16.0D0) THEN
22189 ELSEIF ((AM2.GE.16.0D0).AND.(AM2.LT.121.0D0)) THEN
22194 C FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
22195 FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
22196 & * (ONE+EPSPOL*Q2/AM2)
22197 SUM = SUM+WEIGHT(J)*FAC
22200 SDIR = DT_SIGVP(X,Q2)
22201 STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*SDIR
22202 SDIR = SDIR/(0.588D0+RL2+Q2)
22203 C STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*DT_SIGVP(X,Q2)
22204 ELSEIF (MODEGA.EQ.3) THEN
22205 CALL DT_SIGGA(1,XI,Q2I,ECMI,ZERO,STOT,ETOT,SINE,EINE,DUM)
22206 ELSEIF (MODEGA.EQ.4) THEN
22207 * load cross sections from PHOJET interpolation table
22209 IF(ECM.LE.SIGECM(IP,1)) THEN
22212 ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
22214 IF (ECM.LE.SIGECM(IP,I)) GOTO 3
22220 WRITE(LOUT,'(/1X,A,2E12.3)')
22221 & 'SIGGP:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
22226 IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
22227 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
22229 * cross section dependence on photon virtuality
22232 FSUP1 = FSUP1+PARMDL(26+I)*(1.D0+Q2/(4.D0*PARMDL(30+I)))
22233 & /(1.D0+Q2/PARMDL(30+I))**2
22235 FSUP1 = FSUP1+PARMDL(30)/(1.D0+Q2/PARMDL(34))
22239 STOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
22240 SINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
22241 SDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
22245 SDIR = SDIR/(FSUP1*FSUP2)
22254 *$ CREATE DT_SIGVEL.FOR
22257 *===sigvel=============================================================*
22259 SUBROUTINE DT_SIGVEL(XI,Q2I,ECMI,XNUI,IDXV,SVEL,SIG1,SIG2)
22261 ************************************************************************
22262 * Cross section for elastic vector meson production *
22263 * This version dated 10.05.96 is written by S. Roesler *
22264 ************************************************************************
22266 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22268 PARAMETER ( LINP = 10 ,
22271 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22272 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22274 & GEV2MB = 0.38938D0,
22275 & ALPHEM = ONE/137.0D0)
22277 * particle properties (BAMJET index convention)
22279 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22280 & IICH(210),IIBAR(210),K1(210),K2(210)
22281 * VDM parameter for photon-nucleus interactions
22282 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22285 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
22286 & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
22290 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22292 X = Q2/(W2+Q2-AAM(1)**2)
22294 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
22295 X = Q2/(W2+Q2-AAM(1)**2)
22296 ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22297 Q2 = (W2-AAM(1)**2)*X/(ONE-X)
22298 ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
22299 W2 = Q2*(ONE-X)/X+AAM(1)**2
22301 WRITE(LOUT,*) 'SIGVEL: inconsistent input ',W2,Q2,X
22309 BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
22310 & +0.25D0*LOG(W2/(AMV2+Q2)))*GEV2MB
22312 STOVP = DT_SIGVP(X,Q2)/(AMV2+Q2+RL2)
22313 SELVP = STOVP**2*(ONE+ROSH**2)/(8.0D0*TWOPI*BSLOPE)
22315 IF (IDXV.EQ.33) THEN
22320 SIG1 = (AMV2/(AMV2+Q2))**2 * (ONE+EPSPOL*Q2/AMV2)
22322 SVEL = COUPL * (AMV2/(AMV2+Q2))**2
22323 & * (ONE+EPSPOL*Q2/AMV2) * SELVP
22328 *$ CREATE DT_SIGVP.FOR
22331 *===sigvp==============================================================*
22333 DOUBLE PRECISION FUNCTION DT_SIGVP(XI,Q2I)
22335 ************************************************************************
22337 ************************************************************************
22339 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22342 PARAMETER ( LINP = 10 ,
22345 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22346 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22348 & GEV2MB = 0.38938D0,
22349 & AMPROT = 0.938D0,
22350 & ALPHEM = ONE/137.0D0)
22351 * VDM parameter for photon-nucleus interactions
22352 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22356 IF (XI.LE.ZERO) X = 0.0001D0
22357 IF (Q2I.LE.ZERO) Q2 = 0.0001D0
22359 ECM = SQRT( Q2*(ONE-X)/X+AMPROT**2 )
22362 IF (MODEGA.EQ.1) THEN
22363 CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
22366 C ALLMF2 = PHO_ALLM97(Q2,W)
22367 C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
22368 C STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
22369 C DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))
22370 DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))*GEV2MB
22371 ELSEIF (MODEGA.EQ.4) THEN
22372 CALL DT_SIGGP(X,Q2,ECM,DUM1,STOT,DUM2,DUM3)
22373 C F2 = Q2*(ONE-X)/(TWOPI**2*ALPHEM*GEV2MB) * STOT
22374 DT_SIGVP = 3.0D0*PI/(ALPHEM*DT_RRM2(X,Q2)) * STOT
22376 STOP ' DT_SIGVP: F2 not defined for this MODEGA !'
22383 *$ CREATE DT_RRM2.FOR
22386 *===RRM2===============================================================*
22388 DOUBLE PRECISION FUNCTION DT_RRM2(X,Q2)
22390 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22392 PARAMETER ( LINP = 10 ,
22395 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22396 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22398 & GEV2MB = 0.38938D0)
22400 * particle properties (BAMJET index convention)
22402 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22403 & IICH(210),IIBAR(210),K1(210),K2(210)
22404 * VDM parameter for photon-nucleus interactions
22405 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22407 S = Q2*(ONE-X)/X+AAM(1)**2
22410 IF (INTRGE(1).EQ.1) THEN
22411 AMLO2 = (3.0D0*AAM(13))**2
22412 ELSEIF (INTRGE(1).EQ.2) THEN
22417 IF (INTRGE(2).EQ.1) THEN
22419 ELSEIF (INTRGE(2).EQ.2) THEN
22424 AMHI20 = (ECM-AAM(1))**2
22425 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22429 IF (AMHI2.LE.AM1C2) THEN
22430 DT_RRM2 = TWO*DT_RM2(AMLO2,AMHI2,Q2)
22431 ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22432 DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22433 & 10.0D0/3.0D0*DT_RM2(AM1C2,AMHI2,Q2)
22435 DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22436 & 10.0D0/3.0D0*DT_RM2(AM1C2,AM2C2,Q2)+
22437 & 11.0D0/3.0D0*DT_RM2(AM2C2,AMHI2,Q2)
22443 *$ CREATE DT_RM2.FOR
22446 *===RM2================================================================*
22448 DOUBLE PRECISION FUNCTION DT_RM2(AMLO2,AMHI2,Q2)
22450 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22452 PARAMETER ( LINP = 10 ,
22455 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22456 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22458 & GEV2MB = 0.38938D0)
22459 * VDM parameter for photon-nucleus interactions
22460 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22462 IF (RL2.LE.ZERO) THEN
22463 DT_RM2 = -ONE/(AMHI2+Q2)+Q2/(TWO*(AMHI2+Q2)**2) -
22464 & (-ONE/(AMLO2+Q2)+Q2/(TWO*(AMLO2+Q2)**2))
22465 & +EPSPOL*(-Q2/(TWO*(AMHI2+Q2)**2)+Q2/(TWO*(AMLO2+Q2)**2))
22467 TMPMLO = LOG(ONE+RL2/(AMLO2+Q2))
22468 TMPMHI = LOG(ONE+RL2/(AMHI2+Q2))
22469 DT_RM2 = Q2/(RL2*(AMHI2+Q2))-(Q2+RL2)/RL2**2*TMPMHI
22470 & -(Q2/(RL2*(AMLO2+Q2))-(Q2+RL2)/RL2**2*TMPMLO)
22472 & -Q2/(RL2*(AMHI2+Q2))+Q2/RL2**2*TMPMHI
22473 & -(-Q2/(RL2*(AMLO2+Q2))+Q2/RL2**2*TMPMLO))
22479 *$ CREATE DT_SAM2.FOR
22482 *===SAM2===============================================================*
22484 DOUBLE PRECISION FUNCTION DT_SAM2(Q2,ECM)
22486 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22488 PARAMETER ( LINP = 10 ,
22491 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
22492 & TENTRD=10.0D0/3.0D0,ELVTRD=11.0D0/3.0D0)
22493 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22495 & GEV2MB = 0.38938D0)
22497 * particle properties (BAMJET index convention)
22499 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22500 & IICH(210),IIBAR(210),K1(210),K2(210)
22501 * VDM parameter for photon-nucleus interactions
22502 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22505 IF (INTRGE(1).EQ.1) THEN
22506 AMLO2 = (3.0D0*AAM(13))**2
22507 ELSEIF (INTRGE(1).EQ.2) THEN
22512 IF (INTRGE(2).EQ.1) THEN
22514 ELSEIF (INTRGE(2).EQ.2) THEN
22519 AMHI20 = (ECM-AAM(1))**2
22520 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22524 YLO = LOG(AMLO2+Q2)
22525 YC1 = LOG(AM1C2+Q2)
22526 YC2 = LOG(AM2C2+Q2)
22527 YHI = LOG(AMHI2+Q2)
22528 IF (AMHI2.LE.AM1C2) THEN
22530 ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22537 YSAM2 = YLO+(YHI-YLO)*DT_RNDM(AM1C2)
22538 IF (YSAM2.LE.YC1) THEN
22540 ELSEIF ((YSAM2.GT.YC1).AND.(YSAM2.LE.YC2)) THEN
22545 WEIGMX = FACHI*(ONE-Q2*EXP( -YHI))
22546 XSAM2 = FAC *(ONE-Q2*EXP(-YSAM2))
22547 IF (DT_RNDM(YSAM2)*WEIGMX.GT.XSAM2) GOTO 1
22549 DT_SAM2 = EXP(YSAM2)-Q2
22554 *$ CREATE DT_CKMT.FOR
22557 *===ckmt===============================================================*
22559 SUBROUTINE DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,
22562 ************************************************************************
22563 * This version dated 31.01.96 is written by S. Roesler *
22564 ************************************************************************
22566 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22568 PARAMETER ( LINP = 10 ,
22571 PARAMETER (ZERO=0.0D0,TWO=2.0D0,TINY10=1.0D-10)
22573 PARAMETER (Q02 = 2.0D0,
22577 DIMENSION PD(-6:6),SEA(3),VAL(2)
22579 CALL DT_PDF0(Q02,X,F2Q0,VAL,SEA,GLU,IPAR)
22580 CALL DT_PDF0(Q12,X,F2Q1,VAL,SEA,GLU,IPAR)
22581 ADQ2 = LOG10(Q12)-LOG10(Q02)
22582 F2P = (F2Q1-F2Q0)/ADQ2
22583 CALL DT_CKMTX(IPAR,X,Q02,PD,F2PQ0)
22584 CALL DT_CKMTX(IPAR,X,Q12,PD,F2PQ1)
22585 F2PP = (F2PQ1-F2PQ0)/ADQ2
22586 FX = (F2P-F2PP)/(F2PP+LOG(DQ2)*F2PQ0+TINY10)*Q02
22588 Q2 = MAX(SCALE**2.0D0,TINY10)
22589 SMOOTH = 1.0D0+FX*(Q2-Q02)/Q2**2
22590 IF (Q2.LT.Q02) THEN
22591 CALL DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22602 CALL DT_CKMTX(IPAR,X,Q2,PD,F2)
22615 C USEA = USEA*SMOOTH
22616 C DSEA = DSEA*SMOOTH
22626 *$ CREATE DT_CKMTX.FOR
22628 SUBROUTINE DT_CKMTX(IPAR,X,SCALE2,PD,F2)
22629 C**********************************************************************
22631 C PDF based on Regge theory, evolved with .... by ....
22633 C input: IPAR 2212 proton (not installed)
22637 C output: PD(-6:6) x*f(x) parton distribution functions
22638 C (PDFLIB convention: d = PD(1), u = PD(2) )
22640 C**********************************************************************
22643 DOUBLE PRECISION X,SCALE2,PD(-6:6),CDN,CUP,F2
22644 PARAMETER ( LINP = 10 ,
22652 C QCD lambda for evolution
22655 C Q0**2 for evolution
22659 C the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
22660 C q(6)=x*charm, q(7)=x*gluon
22664 2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
22666 IF(IPAR.EQ.2212) THEN
22667 CALL DT_CKMTPR(1,0,XX,SB,QQ(1))
22668 CALL DT_CKMTPR(2,0,XX,SB,QQ(2))
22669 CALL DT_CKMTPR(3,0,XX,SB,QQ(3))
22670 CALL DT_CKMTPR(4,0,XX,SB,QQ(4))
22671 CALL DT_CKMTPR(5,0,XX,SB,QQ(5))
22672 CALL DT_CKMTPR(8,0,XX,SB,QQ(6))
22673 CALL DT_CKMTPR(7,0,XX,SB,QQ(7))
22674 C ELSEIF (IPAR.EQ.45) THEN
22675 C CALL CKMTPO(1,0,XX,SB,QQ(1))
22676 C CALL CKMTPO(2,0,XX,SB,QQ(2))
22677 C CALL CKMTPO(3,0,XX,SB,QQ(3))
22678 C CALL CKMTPO(4,0,XX,SB,QQ(4))
22679 C CALL CKMTPO(5,0,XX,SB,QQ(5))
22680 C CALL CKMTPO(8,0,XX,SB,QQ(6))
22681 C CALL CKMTPO(7,0,XX,SB,QQ(7))
22682 ELSEIF (IPAR.EQ.100) THEN
22683 CALL DT_CKMTDE(1,0,XX,SB,QQ(1))
22684 CALL DT_CKMTDE(2,0,XX,SB,QQ(2))
22685 CALL DT_CKMTDE(3,0,XX,SB,QQ(3))
22686 CALL DT_CKMTDE(4,0,XX,SB,QQ(4))
22687 CALL DT_CKMTDE(5,0,XX,SB,QQ(5))
22688 CALL DT_CKMTDE(8,0,XX,SB,QQ(6))
22689 CALL DT_CKMTDE(7,0,XX,SB,QQ(7))
22691 WRITE(LOUT,'(1X,A,I4,A)')
22692 & 'CKMTX: IPAR =',IPAR,' not implemented!'
22698 PD(-4) = DBLE(QQ(6))
22699 PD(-3) = DBLE(QQ(3))
22700 PD(-2) = DBLE(QQ(4))
22701 PD(-1) = DBLE(QQ(5))
22702 PD(0) = DBLE(QQ(7))
22703 PD(1) = DBLE(QQ(2))
22704 PD(2) = DBLE(QQ(1))
22705 PD(3) = DBLE(QQ(3))
22706 PD(4) = DBLE(QQ(6))
22709 IF(IPAR.EQ.45) THEN
22710 CDN = (PD(1)-PD(-1))/2.D0
22711 CUP = (PD(2)-PD(-2))/2.D0
22712 PD(-1) = PD(-1) + CDN
22713 PD(-2) = PD(-2) + CUP
22717 F2 = 4.0D0/9.0D0*(PD(2)-PD(3)+2.0D0*PD(3))+
22718 & 1.0D0/9.0D0*(PD(1)-PD(3)+2.0D0*PD(3))+
22719 & 1.0D0/9.0D0*(2.0D0*PD(3))+4.0D0/9.0D0*(2.0D0*PD(4))
22723 *$ CREATE DT_PDF0.FOR
22726 *===pdf0===============================================================*
22728 SUBROUTINE DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22730 ************************************************************************
22731 * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 *
22732 * an F_2-ansatz given in Capella et al. PLB 337(1994)358. *
22733 * IPAR = 2212 proton *
22735 * This version dated 31.01.96 is written by S. Roesler *
22736 ************************************************************************
22738 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22740 PARAMETER ( LINP = 10 ,
22743 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22752 & DELTA0 = 0.07684D0,
22757 & ALPHAR = 0.415D0,
22761 PARAMETER (NPOINT=16)
22762 C DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
22763 DIMENSION SEA(3),VAL(2)
22765 DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22766 AN = 1.5D0*(1.0D0+Q2/(Q2+C))
22768 IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22769 CALL DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22770 SEA(1) = 0.75D0*SEA0
22773 VAL(1) = 9.0D0/4.0D0*VALU0
22774 VAL(2) = 9.0D0*VALD0
22775 GLU0 = SEA(1)/(1.0D0-X)
22776 F2 = SEA0+VALU0+VALD0
22777 F2PDF = 4.0D0/9.0D0*(VAL(1)+2.0D0*SEA(1))+
22778 & 1.0D0/9.0D0*(VAL(2)+2.0D0*SEA(2))+
22779 & 1.0D0/9.0D0*(2.0D0*SEA(3))
22780 IF (ABS(F2-F2PDF).GT.TINY9) THEN
22781 WRITE(LOUT,'(1X,A,2E15.5)') 'inconsistent PDF! ',F2,F2PDF
22785 C CALL GSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22787 C CALL PHO_GAUSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22792 C CALL DT_CKMTQ0(Q2,ABSZX(J),IPAR,VALU0,VALD0,SEA0)
22793 C VALU0 = 9.0D0/4.0D0*VALU0
22794 C VALD0 = 9.0D0*VALD0
22795 C SEA0 = 0.75D0*SEA0
22796 C SUMQ = SUMQ+ (VALU0+VALD0+6.0D0*SEA0) *WEIGHT(J)
22797 C SUMG = SUMG+ (SEA0/(1.0D0-ABSZX(J))) *WEIGHT(J)
22799 C GLU = GLU0*(1.0D0-SUMQ)/SUMG
22801 WRITE(LOUT,'(1X,A,I4,A)')
22802 & 'PDF0: IPAR =',IPAR,' not implemented!'
22809 *$ CREATE DT_CKMTQ0.FOR
22812 *===ckmtq0=============================================================*
22814 SUBROUTINE DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22816 ************************************************************************
22817 * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2 *
22818 * an F_2-ansatz given in Capella et al. PLB 337(1994)358. *
22819 * IPAR = 2212 proton *
22821 * This version dated 31.01.96 is written by S. Roesler *
22822 ************************************************************************
22824 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22826 PARAMETER ( LINP = 10 ,
22829 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22838 & DELTA0 = 0.07684D0,
22843 & ALPHAR = 0.415D0,
22847 DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22848 AN = 1.5D0*(1.0D0+Q2/(Q2+C))
22850 IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22851 IF (IPAR.EQ.2212) THEN
22858 SEA0 = AA*X**(-DELTA)*(1.0D0-X)**(AN+4.0D0)*
22859 & (Q2/(Q2+A))**(1.0D0+DELTA)
22860 VALU0 = BU*X**(1.0D0-ALPHAR)*(1.0D0-X)**AN*
22861 & (Q2/(Q2+B))**(ALPHAR)
22862 VALD0 = BD*X**(1.0D0-ALPHAR)*(1.0D0-X)**(AN+1.0D0)*
22863 & (Q2/(Q2+B))**(ALPHAR)
22865 WRITE(LOUT,'(1X,A,I4,A)')
22866 & 'CKMTQ0: IPAR =',IPAR,' not implemented!'
22874 *$ CREATE DT_CKMTDE.FOR
22876 SUBROUTINE DT_CKMTDE(I,NDRV,X,S,ANS)
22878 C**********************************************************************
22880 C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
22882 C This version by S. Roesler, 30.01.96
22883 C**********************************************************************
22886 DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
22887 EQUIVALENCE (GF(1,1,1),DL(1))
22890 DATA (DL(K),K= 1, 85) /
22891 &0.351858E+00,0.388489E+00,0.325356E+00,0.325356E+00,0.325356E+00,
22892 &0.325356E+00,0.445218E+01,0.000000E+00,0.419818E+00,0.459249E+00,
22893 &0.391167E+00,0.391143E+00,0.391125E+00,0.391167E+00,0.628186E+01,
22894 &0.703797E-01,0.498333E+00,0.540626E+00,0.467466E+00,0.467423E+00,
22895 &0.467393E+00,0.467466E+00,0.837368E+01,0.151191E+00,0.587839E+00,
22896 &0.633058E+00,0.554689E+00,0.554630E+00,0.554595E+00,0.554689E+00,
22897 &0.107170E+02,0.242877E+00,0.688652E+00,0.736861E+00,0.653150E+00,
22898 &0.653080E+00,0.653046E+00,0.653150E+00,0.132960E+02,0.345760E+00,
22899 &0.800961E+00,0.852226E+00,0.763038E+00,0.762961E+00,0.762933E+00,
22900 &0.763038E+00,0.160884E+02,0.460033E+00,0.924829E+00,0.979213E+00,
22901 &0.884414E+00,0.884335E+00,0.884319E+00,0.884414E+00,0.190679E+02,
22902 &0.585764E+00,0.106016E+01,0.111773E+01,0.101719E+01,0.101711E+01,
22903 &0.101711E+01,0.101719E+01,0.222033E+02,0.722864E+00,0.120670E+01,
22904 &0.126752E+01,0.116110E+01,0.116102E+01,0.116105E+01,0.116110E+01,
22905 &0.254603E+02,0.871079E+00,0.136402E+01,0.142815E+01,0.131571E+01,
22906 &0.131565E+01,0.131570E+01,0.131571E+01,0.288020E+02,0.102998E+01,
22907 &0.153151E+01,0.159900E+01,0.148043E+01,0.148038E+01,0.148046E+01/
22908 DATA (DL(K),K= 86, 170) /
22909 &0.148043E+01,0.321898E+02,0.119897E+01,0.170838E+01,0.177930E+01,
22910 &0.165447E+01,0.165444E+01,0.165455E+01,0.165447E+01,0.355845E+02,
22911 &0.137726E+01,0.189369E+01,0.196807E+01,0.183687E+01,0.183686E+01,
22912 &0.183701E+01,0.183687E+01,0.389473E+02,0.156390E+01,0.208631E+01,
22913 &0.216422E+01,0.202653E+01,0.202654E+01,0.202673E+01,0.202653E+01,
22914 &0.422402E+02,0.175779E+01,0.228501E+01,0.236648E+01,0.222220E+01,
22915 &0.222224E+01,0.222248E+01,0.222220E+01,0.454277E+02,0.195768E+01,
22916 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22917 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22918 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22919 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22920 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22921 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22922 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22923 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22924 &0.326035E+00,0.380777E+00,0.286363E+00,0.286363E+00,0.286363E+00,
22925 &0.286363E+00,0.392252E+01,-.138778E-16,0.380092E+00,0.438587E+00/
22926 DATA (DL(K),K= 171, 255) /
22927 &0.337452E+00,0.337430E+00,0.337424E+00,0.337452E+00,0.532193E+01,
22928 &0.553645E-01,0.440879E+00,0.503177E+00,0.395208E+00,0.395169E+00,
22929 &0.395165E+00,0.395208E+00,0.686454E+01,0.117354E+00,0.508415E+00,
22930 &0.574566E+00,0.459649E+00,0.459600E+00,0.459604E+00,0.459649E+00,
22931 &0.853316E+01,0.185994E+00,0.582647E+00,0.652699E+00,0.530722E+00,
22932 &0.530667E+00,0.530687E+00,0.530722E+00,0.103093E+02,0.261237E+00,
22933 &0.663404E+00,0.737405E+00,0.608254E+00,0.608199E+00,0.608241E+00,
22934 &0.608254E+00,0.121710E+02,0.342917E+00,0.750429E+00,0.828423E+00,
22935 &0.691990E+00,0.691941E+00,0.692009E+00,0.691990E+00,0.140946E+02,
22936 &0.430783E+00,0.843361E+00,0.925391E+00,0.781571E+00,0.781533E+00,
22937 &0.781632E+00,0.781571E+00,0.160553E+02,0.524479E+00,0.941741E+00,
22938 &0.102784E+01,0.876538E+00,0.876515E+00,0.876650E+00,0.876538E+00,
22939 &0.180277E+02,0.623549E+00,0.104501E+01,0.113521E+01,0.976335E+00,
22940 &0.976332E+00,0.976506E+00,0.976335E+00,0.199863E+02,0.727439E+00,
22941 &0.115251E+01,0.124685E+01,0.108031E+01,0.108034E+01,0.108055E+01,
22942 &0.108031E+01,0.219066E+02,0.835506E+00,0.126352E+01,0.136201E+01,
22943 &0.118775E+01,0.118780E+01,0.118806E+01,0.118775E+01,0.237652E+02/
22944 DATA (DL(K),K= 256, 340) /
22945 &0.947020E+00,0.137724E+01,0.147989E+01,0.129783E+01,0.129791E+01,
22946 &0.129822E+01,0.129783E+01,0.255406E+02,0.106119E+01,0.149279E+01,
22947 &0.159961E+01,0.140972E+01,0.140984E+01,0.141019E+01,0.140972E+01,
22948 &0.272135E+02,0.117715E+01,0.160929E+01,0.172028E+01,0.152252E+01,
22949 &0.152267E+01,0.152308E+01,0.152252E+01,0.287669E+02,0.129402E+01,
22950 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22951 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22952 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22953 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22954 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22955 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22956 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22957 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22958 &0.309785E+00,0.391282E+00,0.250518E+00,0.250518E+00,0.250518E+00,
22959 &0.250518E+00,0.343842E+01,-.138778E-16,0.352113E+00,0.438463E+00,
22960 &0.288877E+00,0.288863E+00,0.288878E+00,0.288877E+00,0.446765E+01,
22961 &0.424850E-01,0.398382E+00,0.489596E+00,0.331132E+00,0.331111E+00/
22962 DATA (DL(K),K= 341, 425) /
22963 &0.331148E+00,0.331132E+00,0.555902E+01,0.888369E-01,0.448375E+00,
22964 &0.544458E+00,0.377064E+00,0.377043E+00,0.377108E+00,0.377064E+00,
22965 &0.669490E+01,0.138845E+00,0.501854E+00,0.602811E+00,0.426440E+00,
22966 &0.426425E+00,0.426523E+00,0.426440E+00,0.785892E+01,0.192281E+00,
22967 &0.558506E+00,0.664331E+00,0.478946E+00,0.478944E+00,0.479079E+00,
22968 &0.478946E+00,0.903368E+01,0.248834E+00,0.617972E+00,0.728657E+00,
22969 &0.534229E+00,0.534244E+00,0.534421E+00,0.534229E+00,0.102022E+02,
22970 &0.308155E+00,0.679844E+00,0.795370E+00,0.591883E+00,0.591921E+00,
22971 &0.592141E+00,0.591883E+00,0.113479E+02,0.369841E+00,0.743667E+00,
22972 &0.864009E+00,0.651460E+00,0.651525E+00,0.651792E+00,0.651460E+00,
22973 &0.124553E+02,0.433447E+00,0.808951E+00,0.934073E+00,0.712474E+00,
22974 &0.712571E+00,0.712885E+00,0.712474E+00,0.135102E+02,0.498486E+00,
22975 &0.875171E+00,0.100503E+01,0.774408E+00,0.774541E+00,0.774902E+00,
22976 &0.774408E+00,0.144999E+02,0.564446E+00,0.941784E+00,0.107632E+01,
22977 &0.836726E+00,0.836897E+00,0.837307E+00,0.836726E+00,0.154136E+02,
22978 &0.630788E+00,0.100823E+01,0.114738E+01,0.898879E+00,0.899092E+00,
22979 &0.899551E+00,0.898879E+00,0.162423E+02,0.696967E+00,0.107396E+01/
22980 DATA (DL(K),K= 426, 510) /
22981 &0.121764E+01,0.960319E+00,0.960577E+00,0.961084E+00,0.960319E+00,
22982 &0.169791E+02,0.762433E+00,0.113843E+01,0.128655E+01,0.102051E+01,
22983 &0.102081E+01,0.102137E+01,0.102051E+01,0.176190E+02,0.826647E+00,
22984 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22985 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22986 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22987 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22988 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22989 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22990 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22991 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22992 &0.304680E+00,0.425088E+00,0.216504E+00,0.216504E+00,0.216504E+00,
22993 &0.216504E+00,0.298356E+01,0.000000E+00,0.337300E+00,0.463627E+00,
22994 &0.244023E+00,0.244024E+00,0.244063E+00,0.244023E+00,0.370271E+01,
22995 &0.316585E-01,0.371787E+00,0.503942E+00,0.273415E+00,0.273423E+00,
22996 &0.273505E+00,0.273415E+00,0.443039E+01,0.651685E-01,0.407853E+00,
22997 &0.545739E+00,0.304395E+00,0.304418E+00,0.304545E+00,0.304395E+00/
22998 DATA (DL(K),K= 511, 595) /
22999 &0.515321E+01,0.100252E+00,0.445229E+00,0.588741E+00,0.336700E+00,
23000 &0.336744E+00,0.336918E+00,0.336700E+00,0.586004E+01,0.136648E+00,
23001 &0.483606E+00,0.632629E+00,0.370026E+00,0.370095E+00,0.370318E+00,
23002 &0.370026E+00,0.654027E+01,0.174056E+00,0.522666E+00,0.677074E+00,
23003 &0.404062E+00,0.404162E+00,0.404433E+00,0.404062E+00,0.718442E+01,
23004 &0.212167E+00,0.562075E+00,0.721735E+00,0.438483E+00,0.438618E+00,
23005 &0.438938E+00,0.438483E+00,0.778423E+01,0.250658E+00,0.601494E+00,
23006 &0.766258E+00,0.472959E+00,0.473131E+00,0.473500E+00,0.472959E+00,
23007 &0.833276E+01,0.289199E+00,0.640580E+00,0.810290E+00,0.507156E+00,
23008 &0.507369E+00,0.507784E+00,0.507156E+00,0.882448E+01,0.327457E+00,
23009 &0.678993E+00,0.853479E+00,0.540747E+00,0.541003E+00,0.541463E+00,
23010 &0.540747E+00,0.925529E+01,0.365104E+00,0.716405E+00,0.895483E+00,
23011 &0.573411E+00,0.573714E+00,0.574216E+00,0.573411E+00,0.962250E+01,
23012 &0.401821E+00,0.752501E+00,0.935975E+00,0.604848E+00,0.605197E+00,
23013 &0.605740E+00,0.604848E+00,0.992478E+01,0.437304E+00,0.786987E+00,
23014 &0.974647E+00,0.634775E+00,0.635173E+00,0.635752E+00,0.634775E+00,
23015 &0.101620E+02,0.471269E+00,0.819594E+00,0.101122E+01,0.662936E+00/
23016 DATA (DL(K),K= 596, 680) /
23017 &0.663382E+00,0.663995E+00,0.662936E+00,0.103354E+02,0.503459E+00,
23018 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23019 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23020 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23021 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23022 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23023 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23024 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23025 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23026 &0.312661E+00,0.487836E+00,0.182562E+00,0.182562E+00,0.182562E+00,
23027 &0.182562E+00,0.253626E+01,0.000000E+00,0.336910E+00,0.518440E+00,
23028 &0.200702E+00,0.200721E+00,0.200779E+00,0.200702E+00,0.299460E+01,
23029 &0.224425E-01,0.361554E+00,0.549164E+00,0.219359E+00,0.219402E+00,
23030 &0.219517E+00,0.219359E+00,0.343183E+01,0.453742E-01,0.386348E+00,
23031 &0.579759E+00,0.238296E+00,0.238367E+00,0.238536E+00,0.238296E+00,
23032 &0.384076E+01,0.685610E-01,0.411080E+00,0.610003E+00,0.257305E+00,
23033 &0.257408E+00,0.257630E+00,0.257305E+00,0.421619E+01,0.917987E-01/
23034 DATA (DL(K),K= 681, 765) /
23035 &0.435528E+00,0.639668E+00,0.276174E+00,0.276313E+00,0.276583E+00,
23036 &0.276174E+00,0.455400E+01,0.114876E+00,0.459476E+00,0.668531E+00,
23037 &0.294698E+00,0.294875E+00,0.295191E+00,0.294698E+00,0.485107E+01,
23038 &0.137589E+00,0.482719E+00,0.696375E+00,0.312682E+00,0.312900E+00,
23039 &0.313258E+00,0.312682E+00,0.510539E+01,0.159742E+00,0.505060E+00,
23040 &0.722995E+00,0.329941E+00,0.330200E+00,0.330596E+00,0.329941E+00,
23041 &0.531589E+01,0.181149E+00,0.526315E+00,0.748199E+00,0.346303E+00,
23042 &0.346604E+00,0.347034E+00,0.346303E+00,0.548250E+01,0.201638E+00,
23043 &0.546317E+00,0.771808E+00,0.361613E+00,0.361957E+00,0.362418E+00,
23044 &0.361613E+00,0.560595E+01,0.221052E+00,0.564917E+00,0.793667E+00,
23045 &0.375735E+00,0.376122E+00,0.376609E+00,0.375735E+00,0.568772E+01,
23046 &0.239253E+00,0.581987E+00,0.813638E+00,0.388553E+00,0.388982E+00,
23047 &0.389491E+00,0.388553E+00,0.572992E+01,0.256122E+00,0.597419E+00,
23048 &0.831608E+00,0.399972E+00,0.400443E+00,0.400970E+00,0.399972E+00,
23049 &0.573516E+01,0.271562E+00,0.611129E+00,0.847487E+00,0.409919E+00,
23050 &0.410430E+00,0.410972E+00,0.409919E+00,0.570642E+01,0.285497E+00,
23051 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23052 DATA (DL(K),K= 766, 850) /
23053 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23054 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23055 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23056 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23057 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23058 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23059 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23060 &0.335149E+00,0.582072E+00,0.146415E+00,0.146415E+00,0.146415E+00,
23061 &0.146415E+00,0.206772E+01,0.000000E+00,0.351552E+00,0.603437E+00,
23062 &0.156515E+00,0.156542E+00,0.156595E+00,0.156515E+00,0.231143E+01,
23063 &0.146091E-01,0.367407E+00,0.623737E+00,0.166387E+00,0.166442E+00,
23064 &0.166542E+00,0.166387E+00,0.252488E+01,0.289315E-01,0.382571E+00,
23065 &0.642832E+00,0.175891E+00,0.175976E+00,0.176118E+00,0.175891E+00,
23066 &0.270658E+01,0.428312E-01,0.396926E+00,0.660609E+00,0.184917E+00,
23067 &0.185034E+00,0.185212E+00,0.184917E+00,0.285608E+01,0.561981E-01,
23068 &0.410365E+00,0.676962E+00,0.193365E+00,0.193513E+00,0.193722E+00,
23069 &0.193365E+00,0.297375E+01,0.689319E-01,0.422792E+00,0.691796E+00/
23070 DATA (DL(K),K= 851, 935) /
23071 &0.201144E+00,0.201324E+00,0.201560E+00,0.201144E+00,0.306050E+01,
23072 &0.809434E-01,0.434123E+00,0.705030E+00,0.208181E+00,0.208393E+00,
23073 &0.208650E+00,0.208181E+00,0.311775E+01,0.921567E-01,0.444287E+00,
23074 &0.716596E+00,0.214413E+00,0.214656E+00,0.214931E+00,0.214413E+00,
23075 &0.314738E+01,0.102508E+00,0.453228E+00,0.726441E+00,0.219792E+00,
23076 &0.220066E+00,0.220354E+00,0.219792E+00,0.315156E+01,0.111949E+00,
23077 &0.460906E+00,0.734527E+00,0.224285E+00,0.224589E+00,0.224886E+00,
23078 &0.224285E+00,0.313271E+01,0.120441E+00,0.467291E+00,0.740835E+00,
23079 &0.227870E+00,0.228203E+00,0.228506E+00,0.227870E+00,0.309338E+01,
23080 &0.127963E+00,0.472372E+00,0.745357E+00,0.230541E+00,0.230902E+00,
23081 &0.231208E+00,0.230541E+00,0.303621E+01,0.134506E+00,0.476148E+00,
23082 &0.748105E+00,0.232304E+00,0.232690E+00,0.232996E+00,0.232304E+00,
23083 &0.296381E+01,0.140070E+00,0.478635E+00,0.749103E+00,0.233176E+00,
23084 &0.233586E+00,0.233889E+00,0.233176E+00,0.287874E+01,0.144672E+00,
23085 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23086 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23087 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23088 DATA (DL(K),K= 936, 1020) /
23089 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23090 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23091 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23092 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23093 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23094 &0.370162E+00,0.695827E+00,0.105823E+00,0.105823E+00,0.105823E+00,
23095 &0.105823E+00,0.154556E+01,0.208167E-16,0.378214E+00,0.703794E+00,
23096 &0.109539E+00,0.109554E+00,0.109571E+00,0.109539E+00,0.162770E+01,
23097 &0.818783E-02,0.385258E+00,0.710067E+00,0.112818E+00,0.112847E+00,
23098 &0.112879E+00,0.112818E+00,0.168578E+01,0.158212E-01,0.391264E+00,
23099 &0.714648E+00,0.115620E+00,0.115666E+00,0.115709E+00,0.115620E+00,
23100 &0.172175E+01,0.228667E-01,0.396214E+00,0.717539E+00,0.117923E+00,
23101 &0.117985E+00,0.118037E+00,0.117923E+00,0.173756E+01,0.293009E-01,
23102 &0.400098E+00,0.718759E+00,0.119711E+00,0.119790E+00,0.119848E+00,
23103 &0.119711E+00,0.173541E+01,0.351123E-01,0.402915E+00,0.718332E+00,
23104 &0.120979E+00,0.121074E+00,0.121137E+00,0.120979E+00,0.171755E+01,
23105 &0.402951E-01,0.404672E+00,0.716292E+00,0.121728E+00,0.121840E+00/
23106 DATA (DL(K),K= 1021, 1105) /
23107 &0.121905E+00,0.121728E+00,0.168619E+01,0.448514E-01,0.405385E+00,
23108 &0.712681E+00,0.121967E+00,0.122095E+00,0.122161E+00,0.121967E+00,
23109 &0.164352E+01,0.487902E-01,0.405077E+00,0.707551E+00,0.121712E+00,
23110 &0.121855E+00,0.121920E+00,0.121712E+00,0.159162E+01,0.521265E-01,
23111 &0.403778E+00,0.700963E+00,0.120984E+00,0.121141E+00,0.121204E+00,
23112 &0.120984E+00,0.153245E+01,0.548814E-01,0.401525E+00,0.692984E+00,
23113 &0.119809E+00,0.119980E+00,0.120040E+00,0.119809E+00,0.146780E+01,
23114 &0.570807E-01,0.398361E+00,0.683691E+00,0.118218E+00,0.118402E+00,
23115 &0.118457E+00,0.118218E+00,0.139928E+01,0.587542E-01,0.394333E+00,
23116 &0.673166E+00,0.116244E+00,0.116440E+00,0.116490E+00,0.116244E+00,
23117 &0.132834E+01,0.599355E-01,0.389495E+00,0.661496E+00,0.113924E+00,
23118 &0.114131E+00,0.114175E+00,0.113924E+00,0.125620E+01,0.606602E-01,
23119 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23120 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23121 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23122 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23123 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23124 DATA (DL(K),K= 1106, 1190) /
23125 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23126 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23127 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23128 &0.394012E+00,0.757115E+00,0.772117E-01,0.772117E-01,0.772117E-01,
23129 &0.772117E-01,0.117279E+01,0.346945E-17,0.395841E+00,0.752988E+00,
23130 &0.780501E-01,0.780655E-01,0.780723E-01,0.780501E-01,0.118528E+01,
23131 &0.491697E-02,0.396627E+00,0.747223E+00,0.785386E-01,0.785692E-01,
23132 &0.785806E-01,0.785386E-01,0.118242E+01,0.932754E-02,0.396401E+00,
23133 &0.739901E+00,0.786820E-01,0.787273E-01,0.787413E-01,0.786820E-01,
23134 &0.116673E+01,0.132427E-01,0.395190E+00,0.731092E+00,0.784870E-01,
23135 &0.785464E-01,0.785613E-01,0.784870E-01,0.114033E+01,0.166738E-01,
23136 &0.393030E+00,0.720878E+00,0.779683E-01,0.780410E-01,0.780555E-01,
23137 &0.779683E-01,0.110528E+01,0.196392E-01,0.389962E+00,0.709342E+00,
23138 &0.771427E-01,0.772280E-01,0.772409E-01,0.771427E-01,0.106344E+01,
23139 &0.221591E-01,0.386027E+00,0.696571E+00,0.760304E-01,0.761276E-01,
23140 &0.761378E-01,0.760304E-01,0.101653E+01,0.242567E-01,0.381274E+00,
23141 &0.682657E+00,0.746543E-01,0.747623E-01,0.747692E-01,0.746543E-01/
23142 DATA (DL(K),K= 1191, 1275) /
23143 &0.966057E+00,0.259571E-01,0.375752E+00,0.667695E+00,0.730389E-01,
23144 &0.731569E-01,0.731598E-01,0.730389E-01,0.913345E+00,0.272876E-01,
23145 &0.369514E+00,0.651782E+00,0.712104E-01,0.713374E-01,0.713358E-01,
23146 &0.712104E-01,0.859530E+00,0.282763E-01,0.362616E+00,0.635021E+00,
23147 &0.691957E-01,0.693307E-01,0.693243E-01,0.691957E-01,0.805566E+00,
23148 &0.289524E-01,0.355116E+00,0.617511E+00,0.670220E-01,0.671640E-01,
23149 &0.671526E-01,0.670220E-01,0.752235E+00,0.293453E-01,0.347072E+00,
23150 &0.599357E+00,0.647162E-01,0.648642E-01,0.648478E-01,0.647162E-01,
23151 &0.700161E+00,0.294844E-01,0.338543E+00,0.580659E+00,0.623046E-01,
23152 &0.624578E-01,0.624363E-01,0.623046E-01,0.649828E+00,0.293983E-01,
23153 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23154 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23155 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23156 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23157 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23158 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23159 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23160 DATA (DL(K),K= 1276, 1360) /
23161 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23162 &0.408305E+00,0.775318E+00,0.509141E-01,0.509141E-01,0.509141E-01,
23163 &0.509141E-01,0.818839E+00,-.867362E-17,0.403619E+00,0.758058E+00,
23164 &0.502245E-01,0.502351E-01,0.502337E-01,0.502245E-01,0.795347E+00,
23165 &0.264045E-02,0.398068E+00,0.739709E+00,0.493454E-01,0.493661E-01,
23166 &0.493626E-01,0.493454E-01,0.764942E+00,0.491508E-02,0.391719E+00,
23167 &0.720394E+00,0.482952E-01,0.483253E-01,0.483192E-01,0.482952E-01,
23168 &0.729624E+00,0.685202E-02,0.384627E+00,0.700222E+00,0.470896E-01,
23169 &0.471285E-01,0.471194E-01,0.470896E-01,0.690906E+00,0.847433E-02,
23170 &0.376851E+00,0.679300E+00,0.457475E-01,0.457946E-01,0.457822E-01,
23171 &0.457475E-01,0.650078E+00,0.980774E-02,0.368452E+00,0.657739E+00,
23172 &0.442875E-01,0.443419E-01,0.443261E-01,0.442875E-01,0.608239E+00,
23173 &0.108769E-01,0.359490E+00,0.635646E+00,0.427281E-01,0.427892E-01,
23174 &0.427698E-01,0.427281E-01,0.566280E+00,0.117061E-01,0.350026E+00,
23175 &0.613128E+00,0.410878E-01,0.411549E-01,0.411320E-01,0.410878E-01,
23176 &0.524918E+00,0.123191E-01,0.340122E+00,0.590292E+00,0.393848E-01,
23177 &0.394571E-01,0.394308E-01,0.393848E-01,0.484713E+00,0.127393E-01/
23178 DATA (DL(K),K= 1361, 1445) /
23179 &0.329838E+00,0.567240E+00,0.376363E-01,0.377132E-01,0.376836E-01,
23180 &0.376363E-01,0.446084E+00,0.129888E-01,0.319236E+00,0.544074E+00,
23181 &0.358589E-01,0.359396E-01,0.359068E-01,0.358589E-01,0.409328E+00,
23182 &0.130888E-01,0.308374E+00,0.520890E+00,0.340678E-01,0.341517E-01,
23183 &0.341160E-01,0.340678E-01,0.374641E+00,0.130594E-01,0.297312E+00,
23184 &0.497781E+00,0.322772E-01,0.323636E-01,0.323253E-01,0.322772E-01,
23185 &0.342135E+00,0.129195E-01,0.286106E+00,0.474837E+00,0.304999E-01,
23186 &0.305882E-01,0.305474E-01,0.304999E-01,0.311854E+00,0.126863E-01,
23187 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23188 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23189 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23190 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23191 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23192 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23193 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23194 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23195 &0.407248E+00,0.746438E+00,0.335640E-01,0.335640E-01,0.335640E-01/
23196 DATA (DL(K),K= 1446, 1530) /
23197 &0.335640E-01,0.573540E+00,0.173472E-16,0.397516E+00,0.719825E+00,
23198 &0.324649E-01,0.324735E-01,0.324698E-01,0.324649E-01,0.540770E+00,
23199 &0.147177E-02,0.387197E+00,0.692869E+00,0.312911E-01,0.313075E-01,
23200 &0.313000E-01,0.312911E-01,0.505972E+00,0.269995E-02,0.376365E+00,
23201 &0.665689E+00,0.300576E-01,0.300811E-01,0.300699E-01,0.300576E-01,
23202 &0.470389E+00,0.371147E-02,0.365085E+00,0.638387E+00,0.287770E-01,
23203 &0.288070E-01,0.287922E-01,0.287770E-01,0.434885E+00,0.452768E-02,
23204 &0.353423E+00,0.611066E+00,0.274623E-01,0.274980E-01,0.274797E-01,
23205 &0.274623E-01,0.400103E+00,0.516996E-02,0.341442E+00,0.583823E+00,
23206 &0.261256E-01,0.261663E-01,0.261448E-01,0.261256E-01,0.366541E+00,
23207 &0.565807E-02,0.329207E+00,0.556753E+00,0.247782E-01,0.248234E-01,
23208 &0.247989E-01,0.247782E-01,0.334555E+00,0.601048E-02,0.316777E+00,
23209 &0.529946E+00,0.234308E-01,0.234798E-01,0.234525E-01,0.234308E-01,
23210 &0.304384E+00,0.624451E-02,0.304214E+00,0.503489E+00,0.220932E-01,
23211 &0.221452E-01,0.221155E-01,0.220932E-01,0.276170E+00,0.637618E-02,
23212 &0.291575E+00,0.477462E+00,0.207739E-01,0.208286E-01,0.207966E-01,
23213 &0.207739E-01,0.249976E+00,0.642028E-02,0.278917E+00,0.451941E+00/
23214 DATA (DL(K),K= 1531, 1615) /
23215 &0.194809E-01,0.195376E-01,0.195037E-01,0.194809E-01,0.225809E+00,
23216 &0.639038E-02,0.266293E+00,0.426995E+00,0.182209E-01,0.182791E-01,
23217 &0.182436E-01,0.182209E-01,0.203629E+00,0.629880E-02,0.253754E+00,
23218 &0.402686E+00,0.169996E-01,0.170587E-01,0.170219E-01,0.169996E-01,
23219 &0.183361E+00,0.615665E-02,0.241347E+00,0.379071E+00,0.158217E-01,
23220 &0.158814E-01,0.158436E-01,0.158217E-01,0.164907E+00,0.597385E-02,
23221 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23222 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23223 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23224 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23225 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23226 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23227 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23228 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23229 &0.395106E+00,0.689399E+00,0.218554E-01,0.218554E-01,0.218554E-01,
23230 &0.218554E-01,0.398362E+00,-.173472E-17,0.381441E+00,0.656777E+00,
23231 &0.207816E-01,0.207886E-01,0.207844E-01,0.207816E-01,0.366703E+00/
23232 DATA (DL(K),K= 1616, 1700) /
23233 &0.826643E-03,0.367505E+00,0.624578E+00,0.197001E-01,0.197133E-01,
23234 &0.197053E-01,0.197001E-01,0.335573E+00,0.149886E-02,0.353373E+00,
23235 &0.592889E+00,0.186195E-01,0.186383E-01,0.186266E-01,0.186195E-01,
23236 &0.305590E+00,0.203730E-02,0.339106E+00,0.561783E+00,0.175468E-01,
23237 &0.175705E-01,0.175555E-01,0.175468E-01,0.277136E+00,0.245817E-02,
23238 &0.324766E+00,0.531331E+00,0.164887E-01,0.165166E-01,0.164986E-01,
23239 &0.164887E-01,0.250424E+00,0.277666E-02,0.310411E+00,0.501599E+00,
23240 &0.154510E-01,0.154825E-01,0.154618E-01,0.154510E-01,0.225588E+00,
23241 &0.300658E-02,0.296100E+00,0.472648E+00,0.144390E-01,0.144735E-01,
23242 &0.144504E-01,0.144390E-01,0.202681E+00,0.316040E-02,0.281885E+00,
23243 &0.444535E+00,0.134570E-01,0.134940E-01,0.134689E-01,0.134570E-01,
23244 &0.181693E+00,0.324944E-02,0.267820E+00,0.417309E+00,0.125091E-01,
23245 &0.125481E-01,0.125212E-01,0.125091E-01,0.162572E+00,0.328396E-02,
23246 &0.253953E+00,0.391017E+00,0.115984E-01,0.116389E-01,0.116106E-01,
23247 &0.115984E-01,0.145235E+00,0.327313E-02,0.240328E+00,0.365695E+00,
23248 &0.107275E-01,0.107690E-01,0.107396E-01,0.107275E-01,0.129575E+00,
23249 &0.322510E-02,0.226989E+00,0.341375E+00,0.989805E-02,0.994030E-02/
23250 DATA (DL(K),K= 1701, 1785) /
23251 &0.990998E-02,0.989805E-02,0.115477E+00,0.314713E-02,0.213972E+00,
23252 &0.318081E+00,0.911149E-02,0.915408E-02,0.912316E-02,0.911149E-02,
23253 &0.102820E+00,0.304556E-02,0.201311E+00,0.295830E+00,0.836852E-02,
23254 &0.841111E-02,0.837984E-02,0.836852E-02,0.914804E-01,0.292596E-02,
23255 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23256 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23257 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23258 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23259 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23260 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23261 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23262 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23263 &0.374678E+00,0.616087E+00,0.139531E-01,0.139531E-01,0.139531E-01,
23264 &0.139531E-01,0.272491E+00,-.693889E-17,0.358052E+00,0.580345E+00,
23265 &0.130624E-01,0.130680E-01,0.130641E-01,0.130624E-01,0.245861E+00,
23266 &0.460255E-03,0.341487E+00,0.545719E+00,0.121971E-01,0.122076E-01,
23267 &0.122002E-01,0.121971E-01,0.220877E+00,0.826785E-03,0.325046E+00/
23268 DATA (DL(K),K= 1786, 1870) /
23269 &0.512244E+00,0.113599E-01,0.113748E-01,0.113641E-01,0.113599E-01,
23270 &0.197730E+00,0.111366E-02,0.308783E+00,0.479952E+00,0.105534E-01,
23271 &0.105720E-01,0.105585E-01,0.105534E-01,0.176497E+00,0.133192E-02,
23272 &0.292747E+00,0.448868E+00,0.977938E-02,0.980112E-02,0.978518E-02,
23273 &0.977938E-02,0.157150E+00,0.149139E-02,0.276986E+00,0.419015E+00,
23274 &0.903955E-02,0.906394E-02,0.904584E-02,0.903955E-02,0.139631E+00,
23275 &0.160093E-02,0.261546E+00,0.390412E+00,0.833509E-02,0.836165E-02,
23276 &0.834171E-02,0.833509E-02,0.123850E+00,0.166838E-02,0.246467E+00,
23277 &0.363074E+00,0.766687E-02,0.769516E-02,0.767369E-02,0.766687E-02,
23278 &0.109695E+00,0.170073E-02,0.231787E+00,0.337008E+00,0.703540E-02,
23279 &0.706500E-02,0.704230E-02,0.703540E-02,0.970428E-01,0.170416E-02,
23280 &0.217542E+00,0.312218E+00,0.644083E-02,0.647137E-02,0.644772E-02,
23281 &0.644083E-02,0.857658E-01,0.168409E-02,0.203759E+00,0.288701E+00,
23282 &0.588300E-02,0.591415E-02,0.588981E-02,0.588300E-02,0.757385E-01,
23283 &0.164528E-02,0.190467E+00,0.266449E+00,0.536147E-02,0.539292E-02,
23284 &0.536812E-02,0.536147E-02,0.668383E-01,0.159185E-02,0.177686E+00,
23285 &0.245447E+00,0.487551E-02,0.490698E-02,0.488195E-02,0.487551E-02/
23286 DATA (DL(K),K= 1871, 1955) /
23287 &0.589492E-01,0.152735E-02,0.165434E+00,0.225677E+00,0.442416E-02,
23288 &0.445543E-02,0.443037E-02,0.442416E-02,0.519652E-01,0.145483E-02,
23289 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23290 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23291 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23292 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23293 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23294 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23295 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23296 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23297 &0.348042E+00,0.534691E+00,0.867977E-02,0.867977E-02,0.867977E-02,
23298 &0.867977E-02,0.182547E+00,-.693889E-17,0.329349E+00,0.498248E+00,
23299 &0.800724E-02,0.801198E-02,0.800836E-02,0.800724E-02,0.161948E+00,
23300 &0.250949E-03,0.311047E+00,0.463485E+00,0.737155E-02,0.738040E-02,
23301 &0.737356E-02,0.737155E-02,0.143267E+00,0.447662E-03,0.293181E+00,
23302 &0.430377E+00,0.677169E-02,0.678409E-02,0.677441E-02,0.677169E-02,
23303 &0.126447E+00,0.598803E-03,0.275787E+00,0.398907E+00,0.620726E-02/
23304 DATA (DL(K),K= 1956, 2040) /
23305 &0.622265E-02,0.621051E-02,0.620726E-02,0.111401E+00,0.711280E-03,
23306 &0.258900E+00,0.369051E+00,0.567741E-02,0.569532E-02,0.568106E-02,
23307 &0.567741E-02,0.979944E-01,0.790986E-03,0.242550E+00,0.340785E+00,
23308 &0.518138E-02,0.520134E-02,0.518531E-02,0.518138E-02,0.860936E-01,
23309 &0.843227E-03,0.226765E+00,0.314083E+00,0.471828E-02,0.473987E-02,
23310 &0.472238E-02,0.471828E-02,0.755615E-01,0.872644E-03,0.211568E+00,
23311 &0.288916E+00,0.428714E-02,0.430998E-02,0.429133E-02,0.428714E-02,
23312 &0.662627E-01,0.883319E-03,0.196981E+00,0.265252E+00,0.388691E-02,
23313 &0.391065E-02,0.389112E-02,0.388691E-02,0.580684E-01,0.878818E-03,
23314 &0.183020E+00,0.243053E+00,0.351645E-02,0.354077E-02,0.352060E-02,
23315 &0.351645E-02,0.508578E-01,0.862228E-03,0.169696E+00,0.222280E+00,
23316 &0.317451E-02,0.319914E-02,0.317858E-02,0.317451E-02,0.445190E-01,
23317 &0.836224E-03,0.157017E+00,0.202888E+00,0.285982E-02,0.288450E-02,
23318 &0.286376E-02,0.285982E-02,0.389523E-01,0.803096E-03,0.144987E+00,
23319 &0.184832E+00,0.257101E-02,0.259553E-02,0.257480E-02,0.257101E-02,
23320 &0.340677E-01,0.764787E-03,0.133605E+00,0.168060E+00,0.230670E-02,
23321 &0.233087E-02,0.231031E-02,0.230670E-02,0.297820E-01,0.722929E-03/
23322 DATA (DL(K),K= 2041, 2125) /
23323 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23324 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23325 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23326 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23327 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23328 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23329 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23330 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23331 &0.316867E+00,0.451111E+00,0.522815E-02,0.522815E-02,0.522815E-02,
23332 &0.522815E-02,0.119118E+00,0.889046E-17,0.296950E+00,0.415915E+00,
23333 &0.475497E-02,0.475914E-02,0.475574E-02,0.475497E-02,0.104204E+00,
23334 &0.132513E-03,0.277735E+00,0.382805E+00,0.431809E-02,0.432582E-02,
23335 &0.431944E-02,0.431809E-02,0.910279E-01,0.235347E-03,0.259241E+00,
23336 &0.351694E+00,0.391455E-02,0.392531E-02,0.391637E-02,0.391455E-02,
23337 &0.794222E-01,0.313322E-03,0.241485E+00,0.322517E+00,0.354249E-02,
23338 &0.355575E-02,0.354464E-02,0.354249E-02,0.692354E-01,0.370408E-03,
23339 &0.224480E+00,0.295202E+00,0.319987E-02,0.321518E-02,0.320226E-02/
23340 DATA (DL(K),K= 2126, 2210) /
23341 &0.319987E-02,0.603106E-01,0.409866E-03,0.208235E+00,0.269681E+00,
23342 &0.288490E-02,0.290184E-02,0.288744E-02,0.288490E-02,0.525034E-01,
23343 &0.434663E-03,0.192759E+00,0.245887E+00,0.259589E-02,0.261407E-02,
23344 &0.259852E-02,0.259589E-02,0.456838E-01,0.447393E-03,0.178054E+00,
23345 &0.223752E+00,0.233123E-02,0.235033E-02,0.233390E-02,0.233123E-02,
23346 &0.397318E-01,0.450314E-03,0.164120E+00,0.203207E+00,0.208941E-02,
23347 &0.210910E-02,0.209206E-02,0.208941E-02,0.345396E-01,0.445394E-03,
23348 &0.150954E+00,0.184182E+00,0.186896E-02,0.188897E-02,0.187155E-02,
23349 &0.186896E-02,0.300131E-01,0.434333E-03,0.138548E+00,0.166608E+00,
23350 &0.166844E-02,0.168854E-02,0.167096E-02,0.166844E-02,0.260692E-01,
23351 &0.418584E-03,0.126892E+00,0.150412E+00,0.148650E-02,0.150648E-02,
23352 &0.148891E-02,0.148650E-02,0.226325E-01,0.399380E-03,0.115971E+00,
23353 &0.135523E+00,0.132180E-02,0.134148E-02,0.132409E-02,0.132180E-02,
23354 &0.196374E-01,0.377764E-03,0.105767E+00,0.121870E+00,0.117308E-02,
23355 &0.119231E-02,0.117524E-02,0.117308E-02,0.170312E-01,0.354610E-03,
23356 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23357 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23358 DATA (DL(K),K= 2211, 2295) /
23359 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23360 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23361 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23362 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23363 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23364 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23365 &0.282579E+00,0.369670E+00,0.302765E-02,0.302765E-02,0.302765E-02,
23366 &0.302765E-02,0.752529E-01,-.455365E-17,0.262229E+00,0.337209E+00,
23367 &0.271512E-02,0.271883E-02,0.271564E-02,0.271512E-02,0.651086E-01,
23368 &0.669321E-04,0.242857E+00,0.307069E+00,0.243269E-02,0.243953E-02,
23369 &0.243360E-02,0.243269E-02,0.563252E-01,0.118744E-03,0.224455E+00,
23370 &0.279111E+00,0.217687E-02,0.218631E-02,0.217808E-02,0.217687E-02,
23371 &0.487143E-01,0.157767E-03,0.207014E+00,0.253223E+00,0.194534E-02,
23372 &0.195689E-02,0.194675E-02,0.194534E-02,0.421227E-01,0.186063E-03,
23373 &0.190523E+00,0.229293E+00,0.173585E-02,0.174909E-02,0.173741E-02,
23374 &0.173585E-02,0.364156E-01,0.205286E-03,0.174969E+00,0.207218E+00,
23375 &0.154647E-02,0.156100E-02,0.154811E-02,0.154647E-02,0.314732E-01/
23376 DATA (DL(K),K= 2296, 2380) /
23377 &0.216964E-03,0.160335E+00,0.186895E+00,0.137545E-02,0.139092E-02,
23378 &0.137713E-02,0.137545E-02,0.271927E-01,0.222455E-03,0.146604E+00,
23379 &0.168227E+00,0.122121E-02,0.123733E-02,0.122290E-02,0.122121E-02,
23380 &0.234852E-01,0.222947E-03,0.133756E+00,0.151116E+00,0.108234E-02,
23381 &0.109881E-02,0.108400E-02,0.108234E-02,0.202747E-01,0.219474E-03,
23382 &0.121765E+00,0.135471E+00,0.957502E-03,0.974107E-03,0.959112E-03,
23383 &0.957502E-03,0.174932E-01,0.212928E-03,0.110606E+00,0.121198E+00,
23384 &0.845493E-03,0.862024E-03,0.847037E-03,0.845493E-03,0.150824E-01,
23385 &0.204075E-03,0.100250E+00,0.108210E+00,0.745196E-03,0.761482E-03,
23386 &0.746662E-03,0.745196E-03,0.129965E-01,0.193573E-03,0.906661E-01,
23387 &0.964191E-01,0.655569E-03,0.671466E-03,0.656948E-03,0.655569E-03,
23388 &0.111930E-01,0.181962E-03,0.818218E-01,0.857412E-01,0.575637E-03,
23389 &0.591030E-03,0.576925E-03,0.575637E-03,0.962922E-02,0.169687E-03,
23390 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23391 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23392 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23393 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23394 DATA (DL(K),K= 2381, 2465) /
23395 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23396 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23397 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23398 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23399 &0.246444E+00,0.293515E+00,0.167124E-02,0.167124E-02,0.167124E-02,
23400 &0.167124E-02,0.456929E-01,-.260209E-17,0.226393E+00,0.264836E+00,
23401 &0.147748E-02,0.148085E-02,0.147783E-02,0.147748E-02,0.392393E-01,
23402 &0.318190E-04,0.207552E+00,0.238550E+00,0.130596E-02,0.131212E-02,
23403 &0.130656E-02,0.130596E-02,0.337276E-01,0.566426E-04,0.189877E+00,
23404 &0.214470E+00,0.115347E-02,0.116190E-02,0.115427E-02,0.115347E-02,
23405 &0.290012E-01,0.753776E-04,0.173336E+00,0.192452E+00,0.101789E-02,
23406 &0.102811E-02,0.101881E-02,0.101789E-02,0.249381E-01,0.889466E-04,
23407 &0.157889E+00,0.172355E+00,0.897268E-03,0.908872E-03,0.898270E-03,
23408 &0.897268E-03,0.214419E-01,0.980950E-04,0.143501E+00,0.154046E+00,
23409 &0.789951E-03,0.802565E-03,0.790996E-03,0.789951E-03,0.184296E-01,
23410 &0.103536E-03,0.130132E+00,0.137402E+00,0.694510E-03,0.707811E-03,
23411 &0.695568E-03,0.694510E-03,0.158331E-01,0.105929E-03,0.117743E+00/
23412 DATA (DL(K),K= 2466, 2550) /
23413 &0.122303E+00,0.609684E-03,0.623394E-03,0.610733E-03,0.609684E-03,
23414 &0.135929E-01,0.105853E-03,0.106293E+00,0.108637E+00,0.534365E-03,
23415 &0.548244E-03,0.535386E-03,0.534365E-03,0.116583E-01,0.103825E-03,
23416 &0.957386E-01,0.962976E-01,0.467572E-03,0.481416E-03,0.468551E-03,
23417 &0.467572E-03,0.999103E-02,0.100301E-03,0.860376E-01,0.851820E-01,
23418 &0.408422E-03,0.422062E-03,0.409350E-03,0.408422E-03,0.855563E-02,
23419 &0.956675E-04,0.771455E-01,0.751930E-01,0.356117E-03,0.369416E-03,
23420 &0.356989E-03,0.356117E-03,0.731542E-02,0.902499E-04,0.690178E-01,
23421 &0.662386E-01,0.309950E-03,0.322797E-03,0.310761E-03,0.309950E-03,
23422 &0.624633E-02,0.843305E-04,0.616096E-01,0.582312E-01,0.269281E-03,
23423 &0.281590E-03,0.270030E-03,0.269281E-03,0.533230E-02,0.781441E-04,
23424 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23425 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23426 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23427 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23428 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23429 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23430 DATA (DL(K),K= 2551, 2635) /
23431 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23432 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23433 &0.209608E+00,0.224862E+00,0.869706E-03,0.869706E-03,0.869706E-03,
23434 &0.869706E-03,0.264204E-01,-.138236E-17,0.190523E+00,0.200603E+00,
23435 &0.757542E-03,0.760626E-03,0.757768E-03,0.757542E-03,0.226261E-01,
23436 &0.138827E-04,0.172819E+00,0.178656E+00,0.660281E-03,0.665837E-03,
23437 &0.660670E-03,0.660281E-03,0.194018E-01,0.249832E-04,0.156420E+00,
23438 &0.158805E+00,0.575414E-03,0.582918E-03,0.575917E-03,0.575414E-03,
23439 &0.166434E-01,0.334851E-04,0.141265E+00,0.140883E+00,0.501258E-03,
23440 &0.510252E-03,0.501836E-03,0.501258E-03,0.142710E-01,0.397017E-04,
23441 &0.127291E+00,0.124732E+00,0.436386E-03,0.446473E-03,0.437008E-03,
23442 &0.436386E-03,0.122297E-01,0.439154E-04,0.114437E+00,0.110205E+00,
23443 &0.379575E-03,0.390415E-03,0.380217E-03,0.379575E-03,0.104701E-01,
23444 &0.464110E-04,0.102644E+00,0.971655E-01,0.329805E-03,0.341109E-03,
23445 &0.330448E-03,0.329805E-03,0.895086E-02,0.474758E-04,0.918521E-01,
23446 &0.854876E-01,0.286206E-03,0.297729E-03,0.286836E-03,0.286206E-03,
23447 &0.764249E-02,0.473771E-04,0.820032E-01,0.750529E-01,0.248027E-03/
23448 DATA (DL(K),K= 2636, 2720) /
23449 &0.259564E-03,0.248633E-03,0.248027E-03,0.651744E-02,0.463561E-04,
23450 &0.730394E-01,0.657510E-01,0.214611E-03,0.225995E-03,0.215186E-03,
23451 &0.214611E-03,0.554573E-02,0.446239E-04,0.649040E-01,0.574789E-01,
23452 &0.185396E-03,0.196491E-03,0.185935E-03,0.185396E-03,0.470938E-02,
23453 &0.423722E-04,0.575411E-01,0.501405E-01,0.159891E-03,0.170590E-03,
23454 &0.160391E-03,0.159891E-03,0.399752E-02,0.397689E-04,0.508960E-01,
23455 &0.436466E-01,0.137650E-03,0.147874E-03,0.138111E-03,0.137650E-03,
23456 &0.338807E-02,0.369434E-04,0.449157E-01,0.379141E-01,0.118285E-03,
23457 &0.127973E-03,0.118705E-03,0.118285E-03,0.286125E-02,0.340035E-04,
23458 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23459 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23460 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23461 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23462 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23463 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23464 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23465 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23466 DATA (DL(K),K= 2721, 2805) /
23467 &0.173133E+00,0.165162E+00,0.420483E-03,0.420483E-03,0.420483E-03,
23468 &0.420483E-03,0.143704E-01,0.418773E-17,0.155600E+00,0.145586E+00,
23469 &0.360490E-03,0.363140E-03,0.360629E-03,0.360490E-03,0.123560E-01,
23470 &0.533279E-05,0.139551E+00,0.128113E+00,0.309555E-03,0.314310E-03,
23471 &0.309792E-03,0.309555E-03,0.106262E-01,0.982612E-05,0.124876E+00,
23472 &0.112516E+00,0.265952E-03,0.272344E-03,0.266256E-03,0.265952E-03,
23473 &0.913151E-02,0.133834E-04,0.111490E+00,0.986188E-01,0.228522E-03,
23474 &0.236138E-03,0.228869E-03,0.228522E-03,0.783135E-02,0.160429E-04,
23475 &0.993081E-01,0.862590E-01,0.196336E-03,0.204821E-03,0.196706E-03,
23476 &0.196336E-03,0.670031E-02,0.178799E-04,0.882484E-01,0.752883E-01,
23477 &0.168604E-03,0.177655E-03,0.168981E-03,0.168604E-03,0.572016E-02,
23478 &0.189837E-04,0.782334E-01,0.655714E-01,0.144684E-03,0.154047E-03,
23479 &0.145058E-03,0.144684E-03,0.487276E-02,0.194655E-04,0.691885E-01,
23480 &0.569841E-01,0.124035E-03,0.133497E-03,0.124397E-03,0.124035E-03,
23481 &0.413648E-02,0.194296E-04,0.610420E-01,0.494128E-01,0.106203E-03,
23482 &0.115592E-03,0.106548E-03,0.106203E-03,0.350042E-02,0.189800E-04,
23483 &0.537249E-01,0.427533E-01,0.908141E-04,0.999895E-04,0.911377E-04/
23484 DATA (DL(K),K= 2806, 2890) /
23485 &0.908141E-04,0.295961E-02,0.182192E-04,0.471713E-01,0.369100E-01,
23486 &0.775359E-04,0.863895E-04,0.778360E-04,0.775359E-04,0.249629E-02,
23487 &0.172287E-04,0.413182E-01,0.317957E-01,0.660857E-04,0.745356E-04,
23488 &0.663611E-04,0.660857E-04,0.209482E-02,0.160791E-04,0.361056E-01,
23489 &0.273306E-01,0.562298E-04,0.642173E-04,0.564804E-04,0.562298E-04,
23490 &0.175588E-02,0.148407E-04,0.314766E-01,0.234421E-01,0.477598E-04,
23491 &0.552457E-04,0.479859E-04,0.477598E-04,0.147398E-02,0.135653E-04,
23492 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23493 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23494 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23495 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23496 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23497 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23498 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23499 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23500 &0.138007E+00,0.115214E+00,0.185072E-03,0.185072E-03,0.185072E-03,
23501 &0.185072E-03,0.722856E-02,-.380826E-17,0.122517E+00,0.100251E+00/
23502 DATA (DL(K),K= 2891, 2975) /
23503 &0.155814E-03,0.158287E-03,0.155901E-03,0.155814E-03,0.630580E-02,
23504 &0.155371E-05,0.108535E+00,0.870870E-01,0.131535E-03,0.135909E-03,
23505 &0.131680E-03,0.131535E-03,0.547867E-02,0.304952E-05,0.959260E-01,
23506 &0.754985E-01,0.111183E-03,0.116980E-03,0.111366E-03,0.111183E-03,
23507 &0.473794E-02,0.433106E-05,0.845828E-01,0.653163E-01,0.940433E-04,
23508 &0.100851E-03,0.942493E-04,0.940433E-04,0.407647E-02,0.533613E-05,
23509 &0.744017E-01,0.563870E-01,0.795843E-04,0.870596E-04,0.798007E-04,
23510 &0.795843E-04,0.349165E-02,0.606691E-05,0.652864E-01,0.485720E-01,
23511 &0.673476E-04,0.752069E-04,0.675656E-04,0.673476E-04,0.297273E-02,
23512 &0.652898E-05,0.571466E-01,0.417472E-01,0.569700E-04,0.649812E-04,
23513 &0.571831E-04,0.569700E-04,0.251732E-02,0.675028E-05,0.498975E-01,
23514 &0.358008E-01,0.481618E-04,0.561391E-04,0.483654E-04,0.481618E-04,
23515 &0.212754E-02,0.677236E-05,0.434594E-01,0.306320E-01,0.406746E-04,
23516 &0.484724E-04,0.408657E-04,0.406746E-04,0.179059E-02,0.662814E-05,
23517 &0.377578E-01,0.261500E-01,0.343050E-04,0.418123E-04,0.344818E-04,
23518 &0.343050E-04,0.149563E-02,0.635273E-05,0.327229E-01,0.222734E-01,
23519 &0.288923E-04,0.360279E-04,0.290540E-04,0.288923E-04,0.124695E-02/
23520 DATA (DL(K),K= 2976, 3060) /
23521 &0.598767E-05,0.282894E-01,0.189287E-01,0.242960E-04,0.310036E-04,
23522 &0.244423E-04,0.242960E-04,0.104112E-02,0.556344E-05,0.243968E-01,
23523 &0.160504E-01,0.203920E-04,0.266363E-04,0.205232E-04,0.203920E-04,
23524 &0.863677E-03,0.510070E-05,0.209890E-01,0.135797E-01,0.170822E-04,
23525 &0.228449E-04,0.171989E-04,0.170822E-04,0.711641E-03,0.462338E-05,
23526 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23527 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23528 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23529 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23530 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23531 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23532 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23533 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23534 &0.105155E+00,0.752467E-01,0.719932E-04,0.719932E-04,0.719932E-04,
23535 &0.719932E-04,0.328057E-02,-.758942E-18,0.920856E-01,0.645455E-01,
23536 &0.592305E-04,0.615087E-04,0.592802E-04,0.592305E-04,0.295327E-02,
23537 &0.945234E-07,0.804695E-01,0.552770E-01,0.489125E-04,0.528632E-04/
23538 DATA (DL(K),K= 3061, 3145) /
23539 &0.489946E-04,0.489125E-04,0.261804E-02,0.365139E-06,0.701499E-01,
23540 &0.472409E-01,0.404786E-04,0.456186E-04,0.405807E-04,0.404786E-04,
23541 &0.229460E-02,0.686912E-06,0.610049E-01,0.402864E-01,0.335367E-04,
23542 &0.394631E-04,0.336495E-04,0.335367E-04,0.198445E-02,0.981070E-06,
23543 &0.529201E-01,0.342803E-01,0.278134E-04,0.342044E-04,0.279301E-04,
23544 &0.278134E-04,0.169772E-02,0.122521E-05,0.457907E-01,0.291037E-01,
23545 &0.230821E-04,0.296833E-04,0.231978E-04,0.230821E-04,0.144575E-02,
23546 &0.140819E-05,0.395205E-01,0.246522E-01,0.191553E-04,0.257661E-04,
23547 &0.192666E-04,0.191553E-04,0.122125E-02,0.152152E-05,0.340212E-01,
23548 &0.208330E-01,0.158874E-04,0.223546E-04,0.159921E-04,0.158874E-04,
23549 &0.101912E-02,0.156880E-05,0.292116E-01,0.175644E-01,0.131678E-04,
23550 &0.193783E-04,0.132645E-04,0.131678E-04,0.847586E-03,0.156432E-05,
23551 &0.250173E-01,0.147740E-01,0.109029E-04,0.167762E-04,0.109910E-04,
23552 &0.109029E-04,0.705515E-03,0.151845E-05,0.213702E-01,0.123979E-01,
23553 &0.901273E-05,0.144953E-04,0.909200E-05,0.901273E-05,0.581767E-03,
23554 &0.143817E-05,0.182083E-01,0.103797E-01,0.743733E-05,0.124978E-04,
23555 &0.750792E-05,0.743733E-05,0.475483E-03,0.133574E-05,0.154751E-01/
23556 DATA (DL(K),K= 3146, 3230) /
23557 &0.867011E-02,0.612722E-05,0.107517E-04,0.618950E-05,0.612722E-05,
23558 &0.390116E-03,0.122183E-05,0.131193E-01,0.722560E-02,0.503734E-05,
23559 &0.922584E-05,0.509185E-05,0.503734E-05,0.319980E-03,0.110130E-05,
23560 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23561 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23562 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23563 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23564 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23565 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23566 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23567 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23568 &0.754424E-01,0.449848E-01,0.236444E-04,0.236444E-04,0.236444E-04,
23569 &0.236444E-04,0.129291E-02,0.113079E-17,0.650429E-01,0.379660E-01,
23570 &0.187739E-04,0.207130E-04,0.187990E-04,0.187739E-04,0.124038E-02,
23571 &-.327995E-06,0.559588E-01,0.319936E-01,0.149625E-04,0.182671E-04,
23572 &0.150033E-04,0.149625E-04,0.113497E-02,-.464337E-06,0.480234E-01,
23573 &0.269030E-01,0.119484E-04,0.161746E-04,0.119982E-04,0.119484E-04/
23574 DATA (DL(K),K= 3231, 3315) /
23575 &0.100877E-02,-.490618E-06,0.411091E-01,0.225716E-01,0.954833E-05,
23576 &0.143391E-04,0.960250E-05,0.954833E-05,0.883852E-03,-.461770E-06,
23577 &0.350995E-01,0.188947E-01,0.763738E-05,0.127129E-04,0.769248E-05,
23578 &0.763738E-05,0.760077E-03,-.403363E-06,0.298897E-01,0.157798E-01,
23579 &0.611070E-05,0.112548E-04,0.616439E-05,0.611070E-05,0.639505E-03,
23580 &-.335607E-06,0.253856E-01,0.131470E-01,0.488993E-05,0.994021E-05,
23581 &0.494070E-05,0.488993E-05,0.534131E-03,-.267652E-06,0.215026E-01,
23582 &0.109271E-01,0.391276E-05,0.875190E-05,0.395967E-05,0.391276E-05,
23583 &0.445478E-03,-.205292E-06,0.181648E-01,0.906007E-02,0.312720E-05,
23584 &0.767418E-05,0.316978E-05,0.312720E-05,0.366232E-03,-.154024E-06,
23585 &0.153041E-01,0.749382E-02,0.249633E-05,0.670002E-05,0.253440E-05,
23586 &0.249633E-05,0.297435E-03,-.112673E-06,0.128596E-01,0.618334E-02,
23587 &0.199074E-05,0.582360E-05,0.202435E-05,0.199074E-05,0.242305E-03,
23588 &-.794410E-07,0.107770E-01,0.508977E-02,0.158457E-05,0.503733E-05,
23589 &0.161393E-05,0.158457E-05,0.196927E-03,-.546702E-07,0.900806E-02,
23590 &0.417964E-02,0.125888E-05,0.433619E-05,0.128428E-05,0.125888E-05,
23591 &0.158171E-03,-.364714E-07,0.751006E-02,0.342418E-02,0.998674E-06/
23592 DATA (DL(K),K= 3316, 3400) /
23593 &0.371518E-05,0.102046E-05,0.998674E-06,0.126865E-03,-.228706E-07,
23594 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23595 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23596 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23597 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23598 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23599 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23600 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23601 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23602 &0.496787E-01,0.236961E-01,0.607312E-05,0.607312E-05,0.607312E-05,
23603 &0.607312E-05,0.415108E-03,-.140523E-17,0.420445E-01,0.196196E-01,
23604 &0.443589E-05,0.603481E-05,0.444683E-05,0.443589E-05,0.444425E-03,
23605 &-.375397E-06,0.355108E-01,0.162223E-01,0.321766E-05,0.587645E-05,
23606 &0.323504E-05,0.321766E-05,0.432635E-03,-.593989E-06,0.299148E-01,
23607 &0.133836E-01,0.231504E-05,0.562250E-05,0.233581E-05,0.231504E-05,
23608 &0.395801E-03,-.699904E-06,0.251339E-01,0.110157E-01,0.164651E-05,
23609 &0.526880E-05,0.166853E-05,0.164651E-05,0.344925E-03,-.733095E-06/
23610 DATA (DL(K),K= 3401, 3485) /
23611 &0.210605E-01,0.904539E-02,0.115940E-05,0.485739E-05,0.118122E-05,
23612 &0.115940E-05,0.294439E-03,-.715193E-06,0.175989E-01,0.740944E-02,
23613 &0.808365E-06,0.441709E-05,0.829075E-06,0.808365E-06,0.249093E-03,
23614 &-.665420E-06,0.146656E-01,0.605433E-02,0.555563E-06,0.396078E-05,
23615 &0.574607E-06,0.555563E-06,0.205675E-03,-.600648E-06,0.121872E-01,
23616 &0.493466E-02,0.375914E-06,0.350822E-05,0.393011E-06,0.375914E-06,
23617 &0.166757E-03,-.529210E-06,0.100993E-01,0.401191E-02,0.250032E-06,
23618 &0.307359E-05,0.265094E-06,0.250032E-06,0.135196E-03,-.456996E-06,
23619 &0.834582E-02,0.325348E-02,0.162261E-06,0.266488E-05,0.175325E-06,
23620 &0.162261E-06,0.108862E-03,-.388821E-06,0.687767E-02,0.263179E-02,
23621 &0.102273E-06,0.228913E-05,0.113453E-06,0.102273E-06,0.865539E-04,
23622 &-.326325E-06,0.565221E-02,0.212357E-02,0.620694E-07,0.194975E-05,
23623 &0.715290E-07,0.620694E-07,0.687156E-04,-.270547E-06,0.463248E-02,
23624 &0.170926E-02,0.351992E-07,0.164711E-05,0.431226E-07,0.351992E-07,
23625 &0.543744E-04,-.222379E-06,0.378655E-02,0.137242E-02,0.178902E-07,
23626 &0.138124E-05,0.244675E-07,0.178902E-07,0.426626E-04,-.181158E-06,
23627 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23628 DATA (DL(K),K= 3486, 3570) /
23629 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23630 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23631 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23632 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23633 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23634 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23635 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23636 &0.286141E-01,0.102357E-01,0.105702E-05,0.105702E-05,0.105702E-05,
23637 &0.105702E-05,0.963318E-04,0.591070E-18,0.236608E-01,0.827483E-02,
23638 &0.548552E-06,0.163293E-05,0.551993E-06,0.548552E-06,0.133058E-03,
23639 &-.268677E-06,0.195282E-01,0.668247E-02,0.238780E-06,0.183459E-05,
23640 &0.243802E-06,0.238780E-06,0.135119E-03,-.393414E-06,0.160742E-01,
23641 &0.538444E-02,0.599864E-07,0.183277E-05,0.655085E-07,0.599864E-07,
23642 &0.124554E-03,-.428349E-06,0.131940E-01,0.432750E-02,-.392825E-07,
23643 &0.172071E-05,-.338391E-07,-.392825E-07,0.111121E-03,-.415550E-06,
23644 &0.107996E-01,0.346954E-02,-.875089E-07,0.154604E-05,-.824926E-07,
23645 &-.875089E-07,0.941854E-04,-.376855E-06,0.881435E-02,0.277463E-02/
23646 DATA (DL(K),K= 3571, 3655) /
23647 &-.103962E-06,0.135013E-05,-.995446E-07,-.103962E-06,0.772195E-04,
23648 &-.326008E-06,0.717317E-02,0.221313E-02,-.102844E-06,0.115335E-05,
23649 &-.990733E-07,-.102844E-06,0.626565E-04,-.272858E-06,0.582050E-02,
23650 &0.176061E-02,-.929503E-07,0.967229E-06,-.898064E-07,-.929503E-07,
23651 &0.499930E-04,-.222828E-06,0.470908E-02,0.139692E-02,-.791495E-07,
23652 &0.800414E-06,-.765797E-07,-.791495E-07,0.394181E-04,-.178141E-06,
23653 &0.379875E-02,0.110542E-02,-.647230E-07,0.655119E-06,-.626567E-07,
23654 &-.647230E-07,0.309999E-04,-.140000E-06,0.305549E-02,0.872447E-03,
23655 &-.515215E-07,0.530834E-06,-.498829E-07,-.515215E-07,0.240354E-04,
23656 &-.108633E-06,0.245058E-02,0.686769E-03,-.400234E-07,0.426835E-06,
23657 &-.387401E-07,-.400234E-07,0.184613E-04,-.832544E-07,0.195984E-02,
23658 &0.539209E-03,-.304312E-07,0.341169E-06,-.294373E-07,-.304312E-07,
23659 &0.143512E-04,-.630818E-07,0.156297E-02,0.422273E-03,-.228633E-07,
23660 &0.271199E-06,-.221014E-07,-.228633E-07,0.110898E-04,-.474683E-07,
23661 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23662 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23663 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23664 DATA (DL(K),K= 3656, 3740) /
23665 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23666 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23667 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23668 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23669 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23670 &0.129345E-01,0.308444E-02,0.903693E-07,0.903693E-07,0.903693E-07,
23671 &0.903693E-07,0.123538E-04,-.166230E-18,0.103598E-01,0.241354E-02,
23672 &0.155648E-06,-.205296E-06,0.154889E-06,0.155648E-06,0.267249E-04,
23673 &0.880707E-07,0.828507E-02,0.188764E-02,0.176333E-06,-.341498E-06,
23674 &0.175220E-06,0.176333E-06,0.306432E-04,0.125718E-06,0.660736E-02,
23675 &0.147304E-02,0.173444E-06,-.383695E-06,0.172215E-06,0.173444E-06,
23676 &0.280787E-04,0.135578E-06,0.525320E-02,0.114618E-02,0.158651E-06,
23677 &-.373371E-06,0.157437E-06,0.158651E-06,0.243526E-04,0.130412E-06,
23678 &0.416429E-02,0.889584E-03,0.137131E-06,-.333468E-06,0.136012E-06,
23679 &0.137131E-06,0.203463E-04,0.116115E-06,0.329102E-02,0.688580E-03,
23680 &0.113839E-06,-.280874E-06,0.112853E-06,0.113839E-06,0.161038E-04,
23681 &0.982305E-07,0.259282E-02,0.531508E-03,0.914374E-07,-.225427E-06/
23682 DATA (DL(K),K= 3741, 3825) /
23683 &0.905971E-07,0.914374E-07,0.125639E-04,0.798741E-07,0.203641E-02,
23684 &0.409120E-03,0.709595E-07,-.173123E-06,0.702607E-07,0.709595E-07,
23685 &0.979247E-05,0.624138E-07,0.159441E-02,0.314027E-03,0.532256E-07,
23686 &-.127272E-06,0.526566E-07,0.532256E-07,0.741899E-05,0.469253E-07,
23687 &0.124447E-02,0.240357E-03,0.385509E-07,-.888851E-07,0.380956E-07,
23688 &0.385509E-07,0.554070E-05,0.339174E-07,0.968328E-03,0.183454E-03,
23689 &0.267272E-07,-.580277E-07,0.263687E-07,0.267272E-07,0.420032E-05,
23690 &0.233280E-07,0.751159E-03,0.139632E-03,0.174605E-07,-.342016E-07,
23691 &0.171822E-07,0.174605E-07,0.315522E-05,0.149727E-07,0.580936E-03,
23692 &0.105986E-03,0.104515E-07,-.164567E-07,0.102383E-07,0.104515E-07,
23693 &0.230829E-05,0.863527E-08,0.447955E-03,0.802293E-04,0.531954E-08,
23694 &-.376312E-08,0.515829E-08,0.531954E-08,0.170771E-05,0.399662E-08,
23695 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23696 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23697 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23698 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23699 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23700 DATA (DL(K),K= 3826, 3910) /
23701 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23702 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23703 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23704 &0.324478E-02,0.386879E-03,0.135983E-08,0.135983E-08,0.135983E-08,
23705 &0.135983E-08,0.371787E-06,-.274599E-19,0.246219E-02,0.286505E-03,
23706 &-.106852E-06,0.327611E-06,-.106589E-06,-.106852E-06,0.231631E-05,
23707 &-.107814E-06,0.186777E-02,0.212413E-03,-.161566E-06,0.492001E-06,
23708 &-.161179E-06,-.161566E-06,0.311589E-05,-.162249E-06,0.141322E-02,
23709 &0.157212E-03,-.183398E-06,0.557106E-06,-.182972E-06,-.183398E-06,
23710 &0.267943E-05,-.183884E-06,0.106518E-02,0.115892E-03,-.185231E-06,
23711 &0.562185E-06,-.184809E-06,-.185231E-06,0.203027E-05,-.185573E-06,
23712 &0.800350E-03,0.851995E-04,-.174680E-06,0.530096E-06,-.174290E-06,
23713 &-.174680E-06,0.165870E-05,-.174922E-06,0.599444E-03,0.624676E-04,
23714 &-.157644E-06,0.478420E-06,-.157300E-06,-.157644E-06,0.130112E-05,
23715 &-.157815E-06,0.447433E-03,0.456556E-04,-.137838E-06,0.418429E-06,
23716 &-.137543E-06,-.137838E-06,0.903220E-06,-.137958E-06,0.332836E-03,
23717 &0.332643E-04,-.117616E-06,0.357179E-06,-.117368E-06,-.117616E-06/
23718 DATA (DL(K),K= 3911, 3995) /
23719 &0.636187E-06,-.117699E-06,0.246754E-03,0.241622E-04,-.984560E-07,
23720 &0.299077E-06,-.982529E-07,-.984560E-07,0.481221E-06,-.985144E-07,
23721 &0.182315E-03,0.174961E-04,-.811089E-07,0.246465E-06,-.809446E-07,
23722 &-.811089E-07,0.342859E-06,-.811495E-07,0.134250E-03,0.126299E-04,
23723 &-.659052E-07,0.200354E-06,-.657742E-07,-.659052E-07,0.227840E-06,
23724 &-.659334E-07,0.985288E-04,0.908931E-05,-.529252E-07,0.160947E-06,
23725 &-.528218E-07,-.529252E-07,0.161641E-06,-.529447E-07,0.720750E-04,
23726 &0.652153E-05,-.420621E-07,0.127943E-06,-.419814E-07,-.420621E-07,
23727 &0.119540E-06,-.420756E-07,0.525538E-04,0.466527E-05,-.331141E-07,
23728 &0.100758E-06,-.330516E-07,-.331141E-07,0.808991E-07,-.331233E-07,
23729 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23730 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23731 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23732 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23733 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23734 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23735 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23736 DATA (DL(K),K= 3996, 4000) /
23737 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23740 IF (X.GT.0.9985) RETURN
23741 IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
23747 F1(L) = GF(I,IS,KL)
23748 F2(L) = GF(I,IS1,KL)
23750 A1 = DT_CKMTFF(X,F1)
23751 A2 = DT_CKMTFF(X,F2)
23756 ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
23763 *$ CREATE DT_CKMTPR.FOR
23765 SUBROUTINE DT_CKMTPR(I,NDRV,X,S,ANS)
23767 C**********************************************************************
23769 C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
23771 C This version by S. Roesler, 31.01.96
23772 C**********************************************************************
23775 DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
23776 EQUIVALENCE (GF(1,1,1),DL(1))
23779 DATA (DL(K),K= 1, 85) /
23780 &0.367759E+00,0.350609E+00,0.325356E+00,0.325356E+00,0.325356E+00,
23781 &0.325356E+00,0.533117E+01,0.138778E-16,0.427988E+00,0.409718E+00,
23782 &0.382948E+00,0.382920E+00,0.382933E+00,0.382948E+00,0.686279E+01,
23783 &0.611113E-01,0.494752E+00,0.475328E+00,0.447011E+00,0.446959E+00,
23784 &0.446984E+00,0.447011E+00,0.855688E+01,0.128659E+00,0.568248E+00,
23785 &0.547637E+00,0.517743E+00,0.517671E+00,0.517705E+00,0.517743E+00,
23786 &0.104074E+02,0.202846E+00,0.648622E+00,0.626792E+00,0.595289E+00,
23787 &0.595201E+00,0.595244E+00,0.595289E+00,0.124065E+02,0.283819E+00,
23788 &0.735974E+00,0.712890E+00,0.679748E+00,0.679648E+00,0.679696E+00,
23789 &0.679748E+00,0.145441E+02,0.371679E+00,0.830359E+00,0.805987E+00,
23790 &0.771173E+00,0.771066E+00,0.771119E+00,0.771173E+00,0.168081E+02,
23791 &0.466485E+00,0.931778E+00,0.906084E+00,0.869566E+00,0.869456E+00,
23792 &0.869511E+00,0.869566E+00,0.191850E+02,0.568240E+00,0.104018E+01,
23793 &0.101313E+01,0.974873E+00,0.974763E+00,0.974819E+00,0.974873E+00,
23794 &0.216593E+02,0.676890E+00,0.115544E+01,0.112700E+01,0.108698E+01,
23795 &0.108687E+01,0.108693E+01,0.108698E+01,0.242146E+02,0.792321E+00,
23796 &0.127738E+01,0.124751E+01,0.120570E+01,0.120560E+01,0.120565E+01/
23797 DATA (DL(K),K= 86, 170) /
23798 &0.120570E+01,0.268333E+02,0.914356E+00,0.140577E+01,0.137444E+01,
23799 &0.133079E+01,0.133070E+01,0.133075E+01,0.133079E+01,0.294970E+02,
23800 &0.104275E+01,0.154028E+01,0.150745E+01,0.146194E+01,0.146187E+01,
23801 &0.146192E+01,0.146194E+01,0.321867E+02,0.117720E+01,0.168054E+01,
23802 &0.164619E+01,0.159879E+01,0.159874E+01,0.159877E+01,0.159879E+01,
23803 &0.348836E+02,0.131732E+01,0.182613E+01,0.179020E+01,0.174088E+01,
23804 &0.174086E+01,0.174088E+01,0.174088E+01,0.375685E+02,0.146269E+01,
23805 &0.197653E+01,0.193901E+01,0.188774E+01,0.188774E+01,0.188775E+01,
23806 &0.188774E+01,0.402228E+02,0.161282E+01,0.213121E+01,0.209205E+01,
23807 &0.203880E+01,0.203884E+01,0.203884E+01,0.203880E+01,0.428285E+02,
23808 &0.176714E+01,0.228955E+01,0.224873E+01,0.219348E+01,0.219355E+01,
23809 &0.219353E+01,0.219348E+01,0.453682E+02,0.192507E+01,0.245093E+01,
23810 &0.240840E+01,0.235113E+01,0.235123E+01,0.235120E+01,0.235113E+01,
23811 &0.478258E+02,0.208597E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23812 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23813 &0.349839E+00,0.324128E+00,0.286363E+00,0.286363E+00,0.286363E+00,
23814 &0.286363E+00,0.469694E+01,0.000000E+00,0.398361E+00,0.371065E+00/
23815 DATA (DL(K),K= 171, 255) /
23816 &0.331239E+00,0.331213E+00,0.331227E+00,0.331239E+00,0.586152E+01,
23817 &0.481683E-01,0.451010E+00,0.422096E+00,0.380182E+00,0.380137E+00,
23818 &0.380161E+00,0.380182E+00,0.711349E+01,0.100378E+00,0.507782E+00,
23819 &0.477215E+00,0.433187E+00,0.433128E+00,0.433160E+00,0.433187E+00,
23820 &0.844371E+01,0.156627E+00,0.568644E+00,0.536390E+00,0.490220E+00,
23821 &0.490152E+00,0.490190E+00,0.490220E+00,0.984291E+01,0.216886E+00,
23822 &0.633517E+00,0.599543E+00,0.551204E+00,0.551133E+00,0.551174E+00,
23823 &0.551204E+00,0.113005E+02,0.281079E+00,0.702295E+00,0.666565E+00,
23824 &0.616031E+00,0.615963E+00,0.616004E+00,0.616031E+00,0.128050E+02,
23825 &0.349101E+00,0.774832E+00,0.737311E+00,0.684556E+00,0.684495E+00,
23826 &0.684535E+00,0.684556E+00,0.143447E+02,0.420809E+00,0.850945E+00,
23827 &0.811598E+00,0.756596E+00,0.756547E+00,0.756583E+00,0.756596E+00,
23828 &0.159073E+02,0.496022E+00,0.930413E+00,0.889207E+00,0.831933E+00,
23829 &0.831901E+00,0.831931E+00,0.831933E+00,0.174801E+02,0.574524E+00,
23830 &0.101298E+01,0.969882E+00,0.910312E+00,0.910301E+00,0.910324E+00,
23831 &0.910312E+00,0.190508E+02,0.656061E+00,0.109836E+01,0.105333E+01,
23832 &0.991445E+00,0.991459E+00,0.991471E+00,0.991445E+00,0.206070E+02/
23833 DATA (DL(K),K= 256, 340) /
23834 &0.740345E+00,0.118622E+01,0.113923E+01,0.107501E+01,0.107505E+01,
23835 &0.107505E+01,0.107501E+01,0.221368E+02,0.827056E+00,0.127622E+01,
23836 &0.122724E+01,0.116065E+01,0.116073E+01,0.116072E+01,0.116065E+01,
23837 &0.236287E+02,0.915845E+00,0.136797E+01,0.131696E+01,0.124800E+01,
23838 &0.124812E+01,0.124809E+01,0.124800E+01,0.250721E+02,0.100634E+01,
23839 &0.146107E+01,0.140801E+01,0.133666E+01,0.133681E+01,0.133677E+01,
23840 &0.133666E+01,0.264571E+02,0.109813E+01,0.155511E+01,0.149996E+01,
23841 &0.142621E+01,0.142641E+01,0.142634E+01,0.142621E+01,0.277747E+02,
23842 &0.119081E+01,0.164964E+01,0.159239E+01,0.151622E+01,0.151646E+01,
23843 &0.151638E+01,0.151622E+01,0.290168E+02,0.128396E+01,0.174424E+01,
23844 &0.168485E+01,0.160626E+01,0.160655E+01,0.160645E+01,0.160626E+01,
23845 &0.301765E+02,0.137713E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23846 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23847 &0.345345E+00,0.306823E+00,0.250518E+00,0.250518E+00,0.250518E+00,
23848 &0.250518E+00,0.411726E+01,-.138778E-16,0.384210E+00,0.343514E+00,
23849 &0.284500E+00,0.284487E+00,0.284496E+00,0.284500E+00,0.496835E+01,
23850 &0.371582E-01,0.425419E+00,0.382518E+00,0.320782E+00,0.320762E+00/
23851 DATA (DL(K),K= 341, 425) /
23852 &0.320777E+00,0.320782E+00,0.585504E+01,0.765988E-01,0.468853E+00,
23853 &0.423717E+00,0.359246E+00,0.359226E+00,0.359243E+00,0.359246E+00,
23854 &0.676824E+01,0.118207E+00,0.514392E+00,0.466990E+00,0.399771E+00,
23855 &0.399758E+00,0.399775E+00,0.399771E+00,0.769967E+01,0.161865E+00,
23856 &0.561883E+00,0.512186E+00,0.442209E+00,0.442208E+00,0.442222E+00,
23857 &0.442209E+00,0.864071E+01,0.207426E+00,0.611162E+00,0.559140E+00,
23858 &0.486395E+00,0.486411E+00,0.486420E+00,0.486395E+00,0.958280E+01,
23859 &0.254727E+00,0.662044E+00,0.607667E+00,0.532145E+00,0.532185E+00,
23860 &0.532185E+00,0.532145E+00,0.105176E+02,0.303587E+00,0.714325E+00,
23861 &0.657566E+00,0.579261E+00,0.579328E+00,0.579318E+00,0.579261E+00,
23862 &0.114370E+02,0.353808E+00,0.767786E+00,0.708618E+00,0.627526E+00,
23863 &0.627625E+00,0.627603E+00,0.627526E+00,0.123333E+02,0.405174E+00,
23864 &0.822195E+00,0.760591E+00,0.676711E+00,0.676846E+00,0.676810E+00,
23865 &0.676711E+00,0.131994E+02,0.457458E+00,0.877307E+00,0.813242E+00,
23866 &0.726575E+00,0.726750E+00,0.726697E+00,0.726575E+00,0.140286E+02,
23867 &0.510420E+00,0.932865E+00,0.866317E+00,0.776867E+00,0.777085E+00,
23868 &0.777015E+00,0.776867E+00,0.148150E+02,0.563809E+00,0.988608E+00/
23869 DATA (DL(K),K= 426, 510) /
23870 &0.919556E+00,0.827330E+00,0.827594E+00,0.827505E+00,0.827330E+00,
23871 &0.155533E+02,0.617368E+00,0.104427E+01,0.972694E+00,0.877703E+00,
23872 &0.878016E+00,0.877907E+00,0.877703E+00,0.162391E+02,0.670837E+00,
23873 &0.109958E+01,0.102547E+01,0.927723E+00,0.928088E+00,0.927957E+00,
23874 &0.927723E+00,0.168687E+02,0.723954E+00,0.115428E+01,0.107761E+01,
23875 &0.977132E+00,0.977550E+00,0.977397E+00,0.977132E+00,0.174391E+02,
23876 &0.776458E+00,0.120809E+01,0.112886E+01,0.102567E+01,0.102615E+01,
23877 &0.102597E+01,0.102567E+01,0.179481E+02,0.828097E+00,0.126078E+01,
23878 &0.117898E+01,0.107310E+01,0.107363E+01,0.107343E+01,0.107310E+01,
23879 &0.183942E+02,0.878621E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23880 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23881 &0.357586E+00,0.299938E+00,0.216504E+00,0.216504E+00,0.216504E+00,
23882 &0.216504E+00,0.357260E+01,-.277556E-16,0.388529E+00,0.327984E+00,
23883 &0.241161E+00,0.241168E+00,0.241168E+00,0.241161E+00,0.415893E+01,
23884 &0.278429E-01,0.420472E+00,0.357015E+00,0.266823E+00,0.266844E+00,
23885 &0.266842E+00,0.266823E+00,0.474689E+01,0.566783E-01,0.453271E+00,
23886 &0.386886E+00,0.293349E+00,0.293389E+00,0.293381E+00,0.293349E+00/
23887 DATA (DL(K),K= 511, 595) /
23888 &0.532982E+01,0.863668E-01,0.486793E+00,0.417464E+00,0.320608E+00,
23889 &0.320673E+00,0.320657E+00,0.320608E+00,0.590219E+01,0.116779E+00,
23890 &0.520887E+00,0.448601E+00,0.348454E+00,0.348549E+00,0.348523E+00,
23891 &0.348454E+00,0.645868E+01,0.147773E+00,0.555403E+00,0.480149E+00,
23892 &0.376740E+00,0.376870E+00,0.376831E+00,0.376740E+00,0.699440E+01,
23893 &0.179201E+00,0.590183E+00,0.511950E+00,0.405314E+00,0.405482E+00,
23894 &0.405429E+00,0.405314E+00,0.750493E+01,0.210912E+00,0.625064E+00,
23895 &0.543845E+00,0.434019E+00,0.434229E+00,0.434159E+00,0.434019E+00,
23896 &0.798636E+01,0.242750E+00,0.659882E+00,0.575673E+00,0.462696E+00,
23897 &0.462952E+00,0.462864E+00,0.462696E+00,0.843528E+01,0.274558E+00,
23898 &0.694472E+00,0.607271E+00,0.491188E+00,0.491492E+00,0.491385E+00,
23899 &0.491188E+00,0.884885E+01,0.306178E+00,0.728669E+00,0.638478E+00,
23900 &0.519337E+00,0.519690E+00,0.519563E+00,0.519337E+00,0.922480E+01,
23901 &0.337451E+00,0.762311E+00,0.669133E+00,0.546987E+00,0.547392E+00,
23902 &0.547244E+00,0.546987E+00,0.956139E+01,0.368224E+00,0.795240E+00,
23903 &0.699084E+00,0.573988E+00,0.574447E+00,0.574277E+00,0.573988E+00,
23904 &0.985744E+01,0.398346E+00,0.827302E+00,0.728181E+00,0.600196E+00/
23905 DATA (DL(K),K= 596, 680) /
23906 &0.600710E+00,0.600518E+00,0.600196E+00,0.101123E+02,0.427671E+00,
23907 &0.858354E+00,0.756282E+00,0.625475E+00,0.626044E+00,0.625829E+00,
23908 &0.625475E+00,0.103258E+02,0.456064E+00,0.888257E+00,0.783256E+00,
23909 &0.649696E+00,0.650321E+00,0.650083E+00,0.649696E+00,0.104982E+02,
23910 &0.483395E+00,0.916887E+00,0.808981E+00,0.672742E+00,0.673422E+00,
23911 &0.673161E+00,0.672742E+00,0.106303E+02,0.509546E+00,0.944126E+00,
23912 &0.833345E+00,0.694506E+00,0.695243E+00,0.694958E+00,0.694506E+00,
23913 &0.107231E+02,0.534410E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23914 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23915 &0.390721E+00,0.304671E+00,0.182562E+00,0.182562E+00,0.182562E+00,
23916 &0.182562E+00,0.303699E+01,0.693889E-17,0.414806E+00,0.325059E+00,
23917 &0.199103E+00,0.199133E+00,0.199124E+00,0.199103E+00,0.339971E+01,
23918 &0.198528E-01,0.438929E+00,0.345508E+00,0.215797E+00,0.215862E+00,
23919 &0.215842E+00,0.215797E+00,0.374624E+01,0.398420E-01,0.462973E+00,
23920 &0.365903E+00,0.232531E+00,0.232635E+00,0.232601E+00,0.232531E+00,
23921 &0.407322E+01,0.598565E-01,0.486835E+00,0.386142E+00,0.249208E+00,
23922 &0.249352E+00,0.249304E+00,0.249208E+00,0.437817E+01,0.797987E-01/
23923 DATA (DL(K),K= 681, 765) /
23924 &0.510407E+00,0.406123E+00,0.265725E+00,0.265913E+00,0.265849E+00,
23925 &0.265725E+00,0.465901E+01,0.995694E-01,0.533588E+00,0.425746E+00,
23926 &0.281986E+00,0.282220E+00,0.282139E+00,0.281986E+00,0.491410E+01,
23927 &0.119072E+00,0.556274E+00,0.444912E+00,0.297897E+00,0.298178E+00,
23928 &0.298079E+00,0.297897E+00,0.514220E+01,0.138212E+00,0.578369E+00,
23929 &0.463528E+00,0.313366E+00,0.313696E+00,0.313578E+00,0.313366E+00,
23930 &0.534249E+01,0.156900E+00,0.599777E+00,0.481503E+00,0.328308E+00,
23931 &0.328688E+00,0.328549E+00,0.328308E+00,0.551456E+01,0.175048E+00,
23932 &0.620409E+00,0.498752E+00,0.342642E+00,0.343071E+00,0.342913E+00,
23933 &0.342642E+00,0.565833E+01,0.192575E+00,0.640181E+00,0.515196E+00,
23934 &0.356292E+00,0.356770E+00,0.356592E+00,0.356292E+00,0.577410E+01,
23935 &0.209407E+00,0.659017E+00,0.530764E+00,0.369190E+00,0.369718E+00,
23936 &0.369519E+00,0.369190E+00,0.586243E+01,0.225474E+00,0.676845E+00,
23937 &0.545389E+00,0.381275E+00,0.381852E+00,0.381633E+00,0.381275E+00,
23938 &0.592421E+01,0.240714E+00,0.693604E+00,0.559015E+00,0.392493E+00,
23939 &0.393118E+00,0.392880E+00,0.392493E+00,0.596052E+01,0.255072E+00,
23940 &0.709239E+00,0.571593E+00,0.402799E+00,0.403472E+00,0.403213E+00/
23941 DATA (DL(K),K= 766, 850) /
23942 &0.402799E+00,0.597267E+01,0.268502E+00,0.723703E+00,0.583081E+00,
23943 &0.412157E+00,0.412875E+00,0.412597E+00,0.412157E+00,0.596211E+01,
23944 &0.280966E+00,0.736960E+00,0.593447E+00,0.420536E+00,0.421299E+00,
23945 &0.421002E+00,0.420536E+00,0.593045E+01,0.292434E+00,0.748980E+00,
23946 &0.602669E+00,0.427918E+00,0.428723E+00,0.428408E+00,0.427918E+00,
23947 &0.587934E+01,0.302884E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23948 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23949 &0.448390E+00,0.320678E+00,0.146415E+00,0.146415E+00,0.146415E+00,
23950 &0.146415E+00,0.247594E+01,0.000000E+00,0.465760E+00,0.333734E+00,
23951 &0.155974E+00,0.156013E+00,0.156000E+00,0.155974E+00,0.265633E+01,
23952 &0.130329E-01,0.482525E+00,0.346293E+00,0.165233E+00,0.165311E+00,
23953 &0.165285E+00,0.165233E+00,0.281612E+01,0.257304E-01,0.498626E+00,
23954 &0.358294E+00,0.174131E+00,0.174249E+00,0.174209E+00,0.174131E+00,
23955 &0.295484E+01,0.380345E-01,0.514008E+00,0.369688E+00,0.182622E+00,
23956 &0.182779E+00,0.182724E+00,0.182622E+00,0.307242E+01,0.498976E-01,
23957 &0.528624E+00,0.380432E+00,0.190660E+00,0.190856E+00,0.190786E+00,
23958 &0.190660E+00,0.316911E+01,0.612760E-01,0.542428E+00,0.390485E+00/
23959 DATA (DL(K),K= 851, 935) /
23960 &0.198205E+00,0.198441E+00,0.198356E+00,0.198205E+00,0.324538E+01,
23961 &0.721303E-01,0.555382E+00,0.399810E+00,0.205224E+00,0.205498E+00,
23962 &0.205398E+00,0.205224E+00,0.330192E+01,0.824256E-01,0.567448E+00,
23963 &0.408377E+00,0.211687E+00,0.211997E+00,0.211882E+00,0.211687E+00,
23964 &0.333960E+01,0.921319E-01,0.578597E+00,0.416159E+00,0.217568E+00,
23965 &0.217915E+00,0.217784E+00,0.217568E+00,0.335945E+01,0.101224E+00,
23966 &0.588802E+00,0.423136E+00,0.222847E+00,0.223229E+00,0.223084E+00,
23967 &0.222847E+00,0.336262E+01,0.109681E+00,0.598043E+00,0.429293E+00,
23968 &0.227512E+00,0.227928E+00,0.227768E+00,0.227512E+00,0.335036E+01,
23969 &0.117489E+00,0.606305E+00,0.434619E+00,0.231551E+00,0.232000E+00,
23970 &0.231826E+00,0.231551E+00,0.332398E+01,0.124636E+00,0.613579E+00,
23971 &0.439110E+00,0.234962E+00,0.235442E+00,0.235254E+00,0.234962E+00,
23972 &0.328483E+01,0.131119E+00,0.619860E+00,0.442766E+00,0.237745E+00,
23973 &0.238254E+00,0.238053E+00,0.237745E+00,0.323429E+01,0.136936E+00,
23974 &0.625150E+00,0.445594E+00,0.239905E+00,0.240441E+00,0.240228E+00,
23975 &0.239905E+00,0.317371E+01,0.142091E+00,0.629453E+00,0.447603E+00,
23976 &0.241452E+00,0.242014E+00,0.241788E+00,0.241452E+00,0.310443E+01/
23977 DATA (DL(K),K= 936, 1020) /
23978 &0.146594E+00,0.632782E+00,0.448808E+00,0.242400E+00,0.242987E+00,
23979 &0.242749E+00,0.242400E+00,0.302775E+01,0.150456E+00,0.635151E+00,
23980 &0.449228E+00,0.242767E+00,0.243376E+00,0.243127E+00,0.242767E+00,
23981 &0.294491E+01,0.153694E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23982 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23983 &0.528765E+00,0.341825E+00,0.105823E+00,0.105823E+00,0.105823E+00,
23984 &0.105823E+00,0.185069E+01,-.138778E-16,0.538124E+00,0.347118E+00,
23985 &0.109762E+00,0.109780E+00,0.109774E+00,0.109762E+00,0.189644E+01,
23986 &0.738880E-02,0.546541E+00,0.351712E+00,0.113300E+00,0.113336E+00,
23987 &0.113324E+00,0.113300E+00,0.192700E+01,0.143076E-01,0.554014E+00,
23988 &0.355607E+00,0.116431E+00,0.116485E+00,0.116466E+00,0.116431E+00,
23989 &0.194356E+01,0.207515E-01,0.560546E+00,0.358805E+00,0.119150E+00,
23990 &0.119222E+00,0.119196E+00,0.119150E+00,0.194722E+01,0.267179E-01,
23991 &0.566139E+00,0.361311E+00,0.121459E+00,0.121549E+00,0.121515E+00,
23992 &0.121459E+00,0.193921E+01,0.322084E-01,0.570802E+00,0.363134E+00,
23993 &0.123359E+00,0.123467E+00,0.123426E+00,0.123359E+00,0.192071E+01,
23994 &0.372262E-01,0.574542E+00,0.364286E+00,0.124858E+00,0.124983E+00/
23995 DATA (DL(K),K= 1021, 1105) /
23996 &0.124933E+00,0.124858E+00,0.189295E+01,0.417774E-01,0.577372E+00,
23997 &0.364779E+00,0.125961E+00,0.126103E+00,0.126046E+00,0.125961E+00,
23998 &0.185710E+01,0.458703E-01,0.579307E+00,0.364629E+00,0.126681E+00,
23999 &0.126839E+00,0.126774E+00,0.126681E+00,0.181432E+01,0.495154E-01,
24000 &0.580363E+00,0.363857E+00,0.127029E+00,0.127202E+00,0.127130E+00,
24001 &0.127029E+00,0.176571E+01,0.527252E-01,0.580561E+00,0.362483E+00,
24002 &0.127020E+00,0.127208E+00,0.127128E+00,0.127020E+00,0.171231E+01,
24003 &0.555142E-01,0.579923E+00,0.360529E+00,0.126670E+00,0.126872E+00,
24004 &0.126785E+00,0.126670E+00,0.165511E+01,0.578985E-01,0.578474E+00,
24005 &0.358021E+00,0.125998E+00,0.126213E+00,0.126119E+00,0.125998E+00,
24006 &0.159501E+01,0.598958E-01,0.576241E+00,0.354987E+00,0.125022E+00,
24007 &0.125249E+00,0.125148E+00,0.125022E+00,0.153284E+01,0.615248E-01,
24008 &0.573252E+00,0.351453E+00,0.123762E+00,0.124000E+00,0.123893E+00,
24009 &0.123762E+00,0.146934E+01,0.628056E-01,0.569539E+00,0.347450E+00,
24010 &0.122240E+00,0.122488E+00,0.122375E+00,0.122240E+00,0.140517E+01,
24011 &0.637587E-01,0.565134E+00,0.343008E+00,0.120476E+00,0.120733E+00,
24012 &0.120615E+00,0.120476E+00,0.134093E+01,0.644054E-01,0.560071E+00/
24013 DATA (DL(K),K= 1106, 1190) /
24014 &0.338158E+00,0.118493E+00,0.118758E+00,0.118635E+00,0.118493E+00,
24015 &0.127712E+01,0.647671E-01,0.000000E+00,0.000000E+00,0.000000E+00,
24016 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24017 &0.584093E+00,0.349173E+00,0.772117E-01,0.772117E-01,0.772117E-01,
24018 &0.772117E-01,0.140433E+01,0.346945E-17,0.586736E+00,0.349017E+00,
24019 &0.785355E-01,0.785519E-01,0.785448E-01,0.785355E-01,0.139434E+01,
24020 &0.447504E-02,0.588402E+00,0.348237E+00,0.795437E-01,0.795759E-01,
24021 &0.795617E-01,0.795437E-01,0.137550E+01,0.854114E-02,0.589124E+00,
24022 &0.346861E+00,0.802498E-01,0.802970E-01,0.802758E-01,0.802498E-01,
24023 &0.134918E+01,0.122148E-01,0.588930E+00,0.344912E+00,0.806656E-01,
24024 &0.807271E-01,0.806990E-01,0.806656E-01,0.131652E+01,0.155101E-01,
24025 &0.587849E+00,0.342417E+00,0.808055E-01,0.808805E-01,0.808457E-01,
24026 &0.808055E-01,0.127862E+01,0.184435E-01,0.585912E+00,0.339402E+00,
24027 &0.806843E-01,0.807718E-01,0.807306E-01,0.806843E-01,0.123648E+01,
24028 &0.210315E-01,0.583151E+00,0.335894E+00,0.803173E-01,0.804166E-01,
24029 &0.803692E-01,0.803173E-01,0.119104E+01,0.232909E-01,0.579599E+00,
24030 &0.331923E+00,0.797205E-01,0.798308E-01,0.797775E-01,0.797205E-01/
24031 DATA (DL(K),K= 1191, 1275) /
24032 &0.114317E+01,0.252394E-01,0.575288E+00,0.327516E+00,0.789107E-01,
24033 &0.790310E-01,0.789721E-01,0.789107E-01,0.109362E+01,0.268946E-01,
24034 &0.570253E+00,0.322704E+00,0.779045E-01,0.780341E-01,0.779698E-01,
24035 &0.779045E-01,0.104307E+01,0.282745E-01,0.564530E+00,0.317515E+00,
24036 &0.767190E-01,0.768570E-01,0.767878E-01,0.767190E-01,0.992143E+00,
24037 &0.293974E-01,0.558155E+00,0.311981E+00,0.753713E-01,0.755169E-01,
24038 &0.754432E-01,0.753713E-01,0.941341E+00,0.302812E-01,0.551166E+00,
24039 &0.306131E+00,0.738784E-01,0.740308E-01,0.739528E-01,0.738784E-01,
24040 &0.891113E+00,0.309441E-01,0.543599E+00,0.299995E+00,0.722571E-01,
24041 &0.724154E-01,0.723336E-01,0.722571E-01,0.841829E+00,0.314037E-01,
24042 &0.535494E+00,0.293603E+00,0.705237E-01,0.706871E-01,0.706019E-01,
24043 &0.705237E-01,0.793794E+00,0.316774E-01,0.526888E+00,0.286986E+00,
24044 &0.686941E-01,0.688619E-01,0.687736E-01,0.686941E-01,0.747249E+00,
24045 &0.317823E-01,0.517822E+00,0.280172E+00,0.667836E-01,0.669551E-01,
24046 &0.668640E-01,0.667836E-01,0.702381E+00,0.317346E-01,0.508333E+00,
24047 &0.273189E+00,0.648068E-01,0.649814E-01,0.648879E-01,0.648068E-01,
24048 &0.659330E+00,0.315501E-01,0.000000E+00,0.000000E+00,0.000000E+00/
24049 DATA (DL(K),K= 1276, 1360) /
24050 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24051 &0.622739E+00,0.340676E+00,0.509141E-01,0.509141E-01,0.509141E-01,
24052 &0.509141E-01,0.980502E+00,-.173472E-17,0.617764E+00,0.335457E+00,
24053 &0.507607E-01,0.507701E-01,0.507651E-01,0.507607E-01,0.944375E+00,
24054 &0.242386E-02,0.611957E+00,0.329837E+00,0.504236E-01,0.504417E-01,
24055 &0.504321E-01,0.504236E-01,0.905225E+00,0.455851E-02,0.605372E+00,
24056 &0.323853E+00,0.499207E-01,0.499471E-01,0.499328E-01,0.499207E-01,
24057 &0.864035E+00,0.642656E-02,0.598052E+00,0.317537E+00,0.492668E-01,
24058 &0.493008E-01,0.492822E-01,0.492668E-01,0.821557E+00,0.804638E-02,
24059 &0.590044E+00,0.310919E+00,0.484772E-01,0.485183E-01,0.484955E-01,
24060 &0.484772E-01,0.778444E+00,0.943663E-02,0.581391E+00,0.304033E+00,
24061 &0.475665E-01,0.476142E-01,0.475874E-01,0.475665E-01,0.735263E+00,
24062 &0.106150E-01,0.572137E+00,0.296908E+00,0.465487E-01,0.466024E-01,
24063 &0.465720E-01,0.465487E-01,0.692487E+00,0.115984E-01,0.562326E+00,
24064 &0.289573E+00,0.454376E-01,0.454968E-01,0.454629E-01,0.454376E-01,
24065 &0.650510E+00,0.124032E-01,0.552003E+00,0.282060E+00,0.442463E-01,
24066 &0.443103E-01,0.442733E-01,0.442463E-01,0.609652E+00,0.130451E-01/
24067 DATA (DL(K),K= 1361, 1445) /
24068 &0.541210E+00,0.274395E+00,0.429871E-01,0.430555E-01,0.430156E-01,
24069 &0.429871E-01,0.570164E+00,0.135389E-01,0.529991E+00,0.266608E+00,
24070 &0.416720E-01,0.417443E-01,0.417018E-01,0.416720E-01,0.532237E+00,
24071 &0.138989E-01,0.518389E+00,0.258725E+00,0.403123E-01,0.403879E-01,
24072 &0.403431E-01,0.403123E-01,0.496010E+00,0.141386E-01,0.506446E+00,
24073 &0.250772E+00,0.389186E-01,0.389971E-01,0.389501E-01,0.389186E-01,
24074 &0.461573E+00,0.142708E-01,0.494204E+00,0.242775E+00,0.375006E-01,
24075 &0.375815E-01,0.375327E-01,0.375006E-01,0.428979E+00,0.143074E-01,
24076 &0.481705E+00,0.234757E+00,0.360674E-01,0.361503E-01,0.361000E-01,
24077 &0.360674E-01,0.398246E+00,0.142598E-01,0.468990E+00,0.226741E+00,
24078 &0.346276E-01,0.347120E-01,0.346605E-01,0.346276E-01,0.369363E+00,
24079 &0.141385E-01,0.456098E+00,0.218750E+00,0.331887E-01,0.332743E-01,
24080 &0.332216E-01,0.331887E-01,0.342300E+00,0.139532E-01,0.443068E+00,
24081 &0.210804E+00,0.317576E-01,0.318440E-01,0.317905E-01,0.317576E-01,
24082 &0.317005E+00,0.137130E-01,0.000000E+00,0.000000E+00,0.000000E+00,
24083 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24084 &0.631458E+00,0.318714E+00,0.335640E-01,0.335640E-01,0.335640E-01/
24085 DATA (DL(K),K= 1446, 1530) /
24086 &0.335640E-01,0.686773E+00,0.346945E-17,0.620274E+00,0.310241E+00,
24087 &0.329311E-01,0.329377E-01,0.329337E-01,0.329311E-01,0.646559E+00,
24088 &0.135960E-02,0.608504E+00,0.301610E+00,0.322083E-01,0.322210E-01,
24089 &0.322133E-01,0.322083E-01,0.606503E+00,0.252820E-02,0.596205E+00,
24090 &0.292854E+00,0.314099E-01,0.314281E-01,0.314169E-01,0.314099E-01,
24091 &0.567134E+00,0.352543E-02,0.583429E+00,0.284002E+00,0.305470E-01,
24092 &0.305704E-01,0.305558E-01,0.305470E-01,0.528824E+00,0.436693E-02,
24093 &0.570223E+00,0.275080E+00,0.296307E-01,0.296586E-01,0.296411E-01,
24094 &0.296307E-01,0.491848E+00,0.506768E-02,0.556637E+00,0.266115E+00,
24095 &0.286709E-01,0.287030E-01,0.286827E-01,0.286709E-01,0.456422E+00,
24096 &0.564157E-02,0.542717E+00,0.257131E+00,0.276770E-01,0.277128E-01,
24097 &0.276900E-01,0.276770E-01,0.422697E+00,0.610148E-02,0.528511E+00,
24098 &0.248154E+00,0.266578E-01,0.266968E-01,0.266718E-01,0.266578E-01,
24099 &0.390771E+00,0.645942E-02,0.514062E+00,0.239205E+00,0.256210E-01,
24100 &0.256629E-01,0.256359E-01,0.256210E-01,0.360700E+00,0.672653E-02,
24101 &0.499417E+00,0.230307E+00,0.245741E-01,0.246185E-01,0.245896E-01,
24102 &0.245741E-01,0.332498E+00,0.691312E-02,0.484617E+00,0.221480E+00/
24103 DATA (DL(K),K= 1531, 1615) /
24104 &0.235237E-01,0.235701E-01,0.235397E-01,0.235237E-01,0.306153E+00,
24105 &0.702875E-02,0.469706E+00,0.212745E+00,0.224757E-01,0.225238E-01,
24106 &0.224921E-01,0.224757E-01,0.281624E+00,0.708222E-02,0.454725E+00,
24107 &0.204118E+00,0.214355E-01,0.214850E-01,0.214522E-01,0.214355E-01,
24108 &0.258855E+00,0.708159E-02,0.439713E+00,0.195618E+00,0.204079E-01,
24109 &0.204586E-01,0.204249E-01,0.204079E-01,0.237774E+00,0.703428E-02,
24110 &0.424709E+00,0.187259E+00,0.193972E-01,0.194486E-01,0.194142E-01,
24111 &0.193972E-01,0.218298E+00,0.694702E-02,0.409750E+00,0.179057E+00,
24112 &0.184069E-01,0.184588E-01,0.184239E-01,0.184069E-01,0.200339E+00,
24113 &0.682594E-02,0.394870E+00,0.171023E+00,0.174402E-01,0.174924E-01,
24114 &0.174571E-01,0.174402E-01,0.183804E+00,0.667657E-02,0.380104E+00,
24115 &0.163171E+00,0.164997E-01,0.165519E-01,0.165164E-01,0.164997E-01,
24116 &0.168600E+00,0.650389E-02,0.000000E+00,0.000000E+00,0.000000E+00,
24117 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24118 &0.619056E+00,0.288873E+00,0.218554E-01,0.218554E-01,0.218554E-01,
24119 &0.218554E-01,0.477010E+00,-.867362E-17,0.602890E+00,0.278444E+00,
24120 &0.211480E-01,0.211530E-01,0.211497E-01,0.211480E-01,0.440877E+00/
24121 DATA (DL(K),K= 1616, 1700) /
24122 &0.767466E-03,0.586431E+00,0.268081E+00,0.204081E-01,0.204175E-01,
24123 &0.204113E-01,0.204081E-01,0.406417E+00,0.141432E-02,0.569736E+00,
24124 &0.257807E+00,0.196446E-01,0.196581E-01,0.196491E-01,0.196446E-01,
24125 &0.373808E+00,0.195508E-02,0.552853E+00,0.247642E+00,0.188646E-01,
24126 &0.188816E-01,0.188701E-01,0.188646E-01,0.343145E+00,0.240123E-02,
24127 &0.535829E+00,0.237603E+00,0.180743E-01,0.180945E-01,0.180808E-01,
24128 &0.180743E-01,0.314460E+00,0.276332E-02,0.518710E+00,0.227710E+00,
24129 &0.172796E-01,0.173025E-01,0.172868E-01,0.172796E-01,0.287750E+00,
24130 &0.305100E-02,0.501539E+00,0.217977E+00,0.164854E-01,0.165108E-01,
24131 &0.164933E-01,0.164854E-01,0.262983E+00,0.327305E-02,0.484360E+00,
24132 &0.208420E+00,0.156964E-01,0.157239E-01,0.157049E-01,0.156964E-01,
24133 &0.240098E+00,0.343744E-02,0.467213E+00,0.199053E+00,0.149165E-01,
24134 &0.149457E-01,0.149254E-01,0.149165E-01,0.219021E+00,0.355144E-02,
24135 &0.450140E+00,0.189889E+00,0.141493E-01,0.141800E-01,0.141586E-01,
24136 &0.141493E-01,0.199660E+00,0.362164E-02,0.433177E+00,0.180939E+00,
24137 &0.133978E-01,0.134297E-01,0.134073E-01,0.133978E-01,0.181918E+00,
24138 &0.365401E-02,0.416362E+00,0.172214E+00,0.126646E-01,0.126974E-01/
24139 DATA (DL(K),K= 1701, 1785) /
24140 &0.126742E-01,0.126646E-01,0.165692E+00,0.365394E-02,0.399729E+00,
24141 &0.163725E+00,0.119518E-01,0.119853E-01,0.119615E-01,0.119518E-01,
24142 &0.150875E+00,0.362628E-02,0.383310E+00,0.155477E+00,0.112613E-01,
24143 &0.112952E-01,0.112711E-01,0.112613E-01,0.137364E+00,0.357539E-02,
24144 &0.367138E+00,0.147479E+00,0.105945E-01,0.106287E-01,0.106042E-01,
24145 &0.105945E-01,0.125056E+00,0.350515E-02,0.351239E+00,0.139737E+00,
24146 &0.995250E-02,0.998673E-02,0.996211E-02,0.995250E-02,0.113852E+00,
24147 &0.341903E-02,0.335641E+00,0.132253E+00,0.933610E-02,0.937024E-02,
24148 &0.934557E-02,0.933610E-02,0.103659E+00,0.332009E-02,0.320367E+00,
24149 &0.125033E+00,0.874584E-02,0.877973E-02,0.875514E-02,0.874584E-02,
24150 &0.943886E-01,0.321106E-02,0.000000E+00,0.000000E+00,0.000000E+00,
24151 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24152 &0.591114E+00,0.254807E+00,0.139531E-01,0.139531E-01,0.139531E-01,
24153 &0.139531E-01,0.326288E+00,0.000000E+00,0.571121E+00,0.243424E+00,
24154 &0.133325E-01,0.133362E-01,0.133336E-01,0.133325E-01,0.296956E+00,
24155 &0.429082E-03,0.551151E+00,0.232297E+00,0.127105E-01,0.127175E-01,
24156 &0.127126E-01,0.127105E-01,0.269811E+00,0.785137E-03,0.531253E+00/
24157 DATA (DL(K),K= 1786, 1870) /
24158 &0.221436E+00,0.120916E-01,0.121015E-01,0.120945E-01,0.120916E-01,
24159 &0.244803E+00,0.107790E-02,0.511467E+00,0.210850E+00,0.114794E-01,
24160 &0.114918E-01,0.114829E-01,0.114794E-01,0.221863E+00,0.131504E-02,
24161 &0.491833E+00,0.200545E+00,0.108767E-01,0.108913E-01,0.108808E-01,
24162 &0.108767E-01,0.200886E+00,0.150337E-02,0.472388E+00,0.190531E+00,
24163 &0.102861E-01,0.103027E-01,0.102907E-01,0.102861E-01,0.181762E+00,
24164 &0.164910E-02,0.453170E+00,0.180812E+00,0.970979E-02,0.972799E-02,
24165 &0.971477E-02,0.970979E-02,0.164371E+00,0.175777E-02,0.434213E+00,
24166 &0.171394E+00,0.914959E-02,0.916916E-02,0.915488E-02,0.914959E-02,
24167 &0.148589E+00,0.183434E-02,0.415548E+00,0.162282E+00,0.860700E-02,
24168 &0.862770E-02,0.861252E-02,0.860700E-02,0.134293E+00,0.188328E-02,
24169 &0.397208E+00,0.153479E+00,0.808323E-02,0.810484E-02,0.808891E-02,
24170 &0.808323E-02,0.121361E+00,0.190856E-02,0.379220E+00,0.144989E+00,
24171 &0.757922E-02,0.760152E-02,0.758501E-02,0.757922E-02,0.109676E+00,
24172 &0.191374E-02,0.361611E+00,0.136811E+00,0.709565E-02,0.711846E-02,
24173 &0.710150E-02,0.709565E-02,0.991261E-01,0.190199E-02,0.344406E+00,
24174 &0.128948E+00,0.663300E-02,0.665614E-02,0.663885E-02,0.663300E-02/
24175 DATA (DL(K),K= 1871, 1955) /
24176 &0.896059E-01,0.187610E-02,0.327627E+00,0.121398E+00,0.619152E-02,
24177 &0.621484E-02,0.619734E-02,0.619152E-02,0.810177E-01,0.183856E-02,
24178 &0.311292E+00,0.114161E+00,0.577130E-02,0.579466E-02,0.577706E-02,
24179 &0.577130E-02,0.732709E-01,0.179155E-02,0.295421E+00,0.107235E+00,
24180 &0.537228E-02,0.539554E-02,0.537794E-02,0.537228E-02,0.662824E-01,
24181 &0.173700E-02,0.280026E+00,0.100616E+00,0.499423E-02,0.501728E-02,
24182 &0.499977E-02,0.499423E-02,0.599766E-01,0.167658E-02,0.265121E+00,
24183 &0.943000E-01,0.463683E-02,0.465958E-02,0.464223E-02,0.463683E-02,
24184 &0.542848E-01,0.161174E-02,0.000000E+00,0.000000E+00,0.000000E+00,
24185 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24186 &0.551659E+00,0.219084E+00,0.867977E-02,0.867977E-02,0.867977E-02,
24187 &0.867977E-02,0.218587E+00,-.173472E-16,0.528947E+00,0.207536E+00,
24188 &0.819621E-02,0.819909E-02,0.819696E-02,0.819621E-02,0.196367E+00,
24189 &0.234843E-03,0.506575E+00,0.196391E+00,0.772540E-02,0.773082E-02,
24190 &0.772680E-02,0.772540E-02,0.176280E+00,0.427503E-03,0.484579E+00,
24191 &0.185646E+00,0.726876E-02,0.727639E-02,0.727069E-02,0.726876E-02,
24192 &0.158158E+00,0.583933E-03,0.462988E+00,0.175298E+00,0.682746E-02/
24193 DATA (DL(K),K= 1956, 2040) /
24194 &0.683702E-02,0.682985E-02,0.682746E-02,0.141851E+00,0.708874E-03,
24195 &0.441830E+00,0.165345E+00,0.640226E-02,0.641347E-02,0.640502E-02,
24196 &0.640226E-02,0.127203E+00,0.806409E-03,0.421129E+00,0.155783E+00,
24197 &0.599380E-02,0.600641E-02,0.599686E-02,0.599380E-02,0.114065E+00,
24198 &0.880249E-03,0.400912E+00,0.146609E+00,0.560252E-02,0.561629E-02,
24199 &0.560581E-02,0.560252E-02,0.102296E+00,0.933676E-03,0.381199E+00,
24200 &0.137819E+00,0.522870E-02,0.524342E-02,0.523217E-02,0.522870E-02,
24201 &0.917608E-01,0.969607E-03,0.362011E+00,0.129407E+00,0.487247E-02,
24202 &0.488796E-02,0.487607E-02,0.487247E-02,0.823356E-01,0.990632E-03,
24203 &0.343367E+00,0.121370E+00,0.453385E-02,0.454992E-02,0.453753E-02,
24204 &0.453385E-02,0.739054E-01,0.999042E-03,0.325282E+00,0.113700E+00,
24205 &0.421272E-02,0.422921E-02,0.421644E-02,0.421272E-02,0.663651E-01,
24206 &0.996863E-03,0.307770E+00,0.106393E+00,0.390887E-02,0.392563E-02,
24207 &0.391260E-02,0.390887E-02,0.596195E-01,0.985881E-03,0.290841E+00,
24208 &0.994399E-01,0.362199E-02,0.363889E-02,0.362570E-02,0.362199E-02,
24209 &0.535826E-01,0.967664E-03,0.274506E+00,0.928343E-01,0.335170E-02,
24210 &0.336862E-02,0.335536E-02,0.335170E-02,0.481769E-01,0.943587E-03/
24211 DATA (DL(K),K= 2041, 2125) /
24212 &0.258771E+00,0.865679E-01,0.309756E-02,0.311439E-02,0.310114E-02,
24213 &0.309756E-02,0.433336E-01,0.914850E-03,0.243639E+00,0.806321E-01,
24214 &0.285905E-02,0.287571E-02,0.286255E-02,0.285905E-02,0.389912E-01,
24215 &0.882497E-03,0.229113E+00,0.750177E-01,0.263565E-02,0.265205E-02,
24216 &0.263905E-02,0.263565E-02,0.350948E-01,0.847432E-03,0.215193E+00,
24217 &0.697152E-01,0.242677E-02,0.244285E-02,0.243005E-02,0.242677E-02,
24218 &0.315960E-01,0.810432E-03,0.000000E+00,0.000000E+00,0.000000E+00,
24219 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24220 &0.503850E+00,0.183581E+00,0.522815E-02,0.522815E-02,0.522815E-02,
24221 &0.522815E-02,0.142635E+00,0.123599E-16,0.479478E+00,0.172477E+00,
24222 &0.488093E-02,0.488328E-02,0.488147E-02,0.488093E-02,0.126767E+00,
24223 &0.124505E-03,0.455750E+00,0.161879E+00,0.455054E-02,0.455493E-02,
24224 &0.455153E-02,0.455054E-02,0.112695E+00,0.225968E-03,0.432681E+00,
24225 &0.151771E+00,0.423664E-02,0.424278E-02,0.423800E-02,0.423664E-02,
24226 &0.100212E+00,0.307702E-03,0.410286E+00,0.142140E+00,0.393907E-02,
24227 &0.394671E-02,0.394073E-02,0.393907E-02,0.891488E-01,0.372395E-03,
24228 &0.388577E+00,0.132974E+00,0.365743E-02,0.366634E-02,0.365934E-02/
24229 DATA (DL(K),K= 2126, 2210) /
24230 &0.365743E-02,0.793490E-01,0.422302E-03,0.367563E+00,0.124259E+00,
24231 &0.339138E-02,0.340133E-02,0.339347E-02,0.339138E-02,0.706688E-01,
24232 &0.459484E-03,0.347256E+00,0.115984E+00,0.314049E-02,0.315129E-02,
24233 &0.314273E-02,0.314049E-02,0.629792E-01,0.485762E-03,0.327660E+00,
24234 &0.108136E+00,0.290433E-02,0.291580E-02,0.290667E-02,0.290433E-02,
24235 &0.561642E-01,0.502744E-03,0.308782E+00,0.100701E+00,0.268243E-02,
24236 &0.269440E-02,0.268483E-02,0.268243E-02,0.501207E-01,0.511853E-03,
24237 &0.290625E+00,0.936693E-01,0.247429E-02,0.248663E-02,0.247672E-02,
24238 &0.247429E-02,0.447569E-01,0.514346E-03,0.273189E+00,0.870261E-01,
24239 &0.227939E-02,0.229197E-02,0.228184E-02,0.227939E-02,0.399920E-01,
24240 &0.511328E-03,0.256475E+00,0.807592E-01,0.209722E-02,0.210991E-02,
24241 &0.209965E-02,0.209722E-02,0.357547E-01,0.503769E-03,0.240478E+00,
24242 &0.748555E-01,0.192721E-02,0.193992E-02,0.192961E-02,0.192721E-02,
24243 &0.319825E-01,0.492518E-03,0.225194E+00,0.693019E-01,0.176883E-02,
24244 &0.178147E-02,0.177117E-02,0.176883E-02,0.286209E-01,0.478318E-03,
24245 &0.210615E+00,0.640851E-01,0.162151E-02,0.163400E-02,0.162379E-02,
24246 &0.162151E-02,0.256219E-01,0.461813E-03,0.196733E+00,0.591917E-01/
24247 DATA (DL(K),K= 2211, 2295) /
24248 &0.148471E-02,0.149698E-02,0.148691E-02,0.148471E-02,0.229436E-01,
24249 &0.443561E-03,0.183536E+00,0.546085E-01,0.135786E-02,0.136986E-02,
24250 &0.135998E-02,0.135786E-02,0.205496E-01,0.424043E-03,0.171011E+00,
24251 &0.503219E-01,0.124042E-02,0.125211E-02,0.124246E-02,0.124042E-02,
24252 &0.184079E-01,0.403672E-03,0.000000E+00,0.000000E+00,0.000000E+00,
24253 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24254 &0.450310E+00,0.149685E+00,0.302765E-02,0.302765E-02,0.302765E-02,
24255 &0.302765E-02,0.901099E-01,-.108420E-17,0.425282E+00,0.139479E+00,
24256 &0.279499E-02,0.279691E-02,0.279537E-02,0.279499E-02,0.794239E-01,
24257 &0.632140E-04,0.401169E+00,0.129837E+00,0.257801E-02,0.258157E-02,
24258 &0.257870E-02,0.257801E-02,0.700941E-01,0.114711E-03,0.377966E+00,
24259 &0.120733E+00,0.237556E-02,0.238052E-02,0.237650E-02,0.237556E-02,
24260 &0.619270E-01,0.156107E-03,0.355668E+00,0.112145E+00,0.218688E-02,
24261 &0.219301E-02,0.218802E-02,0.218688E-02,0.547717E-01,0.188777E-03,
24262 &0.334269E+00,0.104052E+00,0.201113E-02,0.201823E-02,0.201243E-02,
24263 &0.201113E-02,0.484974E-01,0.213848E-03,0.313762E+00,0.964335E-01,
24264 &0.184758E-02,0.185546E-02,0.184900E-02,0.184758E-02,0.429879E-01/
24265 DATA (DL(K),K= 2296, 2380) /
24266 &0.232367E-03,0.294139E+00,0.892696E-01,0.169553E-02,0.170402E-02,
24267 &0.169703E-02,0.169553E-02,0.381432E-01,0.245270E-03,0.275389E+00,
24268 &0.825414E-01,0.155431E-02,0.156326E-02,0.155586E-02,0.155431E-02,
24269 &0.338762E-01,0.253383E-03,0.257502E+00,0.762303E-01,0.142329E-02,
24270 &0.143258E-02,0.142487E-02,0.142329E-02,0.301119E-01,0.257441E-03,
24271 &0.240464E+00,0.703180E-01,0.130188E-02,0.131138E-02,0.130347E-02,
24272 &0.130188E-02,0.267853E-01,0.258098E-03,0.224262E+00,0.647867E-01,
24273 &0.118950E-02,0.119912E-02,0.119108E-02,0.118950E-02,0.238409E-01,
24274 &0.255929E-03,0.208879E+00,0.596190E-01,0.108562E-02,0.109526E-02,
24275 &0.108717E-02,0.108562E-02,0.212308E-01,0.251442E-03,0.194298E+00,
24276 &0.547975E-01,0.989698E-03,0.999283E-03,0.991221E-03,0.989698E-03,
24277 &0.189136E-01,0.245082E-03,0.180499E+00,0.503054E-01,0.901248E-03,
24278 &0.910711E-03,0.902726E-03,0.901248E-03,0.168537E-01,0.237238E-03,
24279 &0.167463E+00,0.461263E-01,0.819789E-03,0.829074E-03,0.821215E-03,
24280 &0.819789E-03,0.150206E-01,0.228250E-03,0.155167E+00,0.422438E-01,
24281 &0.744866E-03,0.753925E-03,0.746234E-03,0.744866E-03,0.133878E-01,
24282 &0.218412E-03,0.143590E+00,0.386421E-01,0.676043E-03,0.684836E-03/
24283 DATA (DL(K),K= 2381, 2465) /
24284 &0.677349E-03,0.676043E-03,0.119320E-01,0.207976E-03,0.132706E+00,
24285 &0.353058E-01,0.612907E-03,0.621403E-03,0.614147E-03,0.612907E-03,
24286 &0.106334E-01,0.197159E-03,0.000000E+00,0.000000E+00,0.000000E+00,
24287 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24288 &0.393307E+00,0.118409E+00,0.167124E-02,0.167124E-02,0.167124E-02,
24289 &0.167124E-02,0.547140E-01,0.433681E-17,0.368555E+00,0.109414E+00,
24290 &0.152547E-02,0.152705E-02,0.152573E-02,0.152547E-02,0.479708E-01,
24291 &0.303147E-04,0.344946E+00,0.101001E+00,0.139202E-02,0.139494E-02,
24292 &0.139249E-02,0.139202E-02,0.421517E-01,0.552185E-04,0.322450E+00,
24293 &0.931345E-01,0.126960E-02,0.127363E-02,0.127024E-02,0.126960E-02,
24294 &0.371043E-01,0.753524E-04,0.301043E+00,0.857854E-01,0.115731E-02,
24295 &0.116225E-02,0.115808E-02,0.115731E-02,0.327131E-01,0.913172E-04,
24296 &0.280698E+00,0.789267E-01,0.105427E-02,0.105995E-02,0.105514E-02,
24297 &0.105427E-02,0.288844E-01,0.103605E-03,0.261390E+00,0.725323E-01,
24298 &0.959726E-03,0.965979E-03,0.960659E-03,0.959726E-03,0.255366E-01,
24299 &0.112688E-03,0.243091E+00,0.665774E-01,0.872987E-03,0.879676E-03,
24300 &0.873966E-03,0.872987E-03,0.226017E-01,0.119000E-03,0.225775E+00/
24301 DATA (DL(K),K= 2466, 2550) /
24302 &0.610385E-01,0.793435E-03,0.800438E-03,0.794441E-03,0.793435E-03,
24303 &0.200219E-01,0.122931E-03,0.209414E+00,0.558928E-01,0.720508E-03,
24304 &0.727716E-03,0.721524E-03,0.720508E-03,0.177490E-01,0.124835E-03,
24305 &0.193979E+00,0.511187E-01,0.653691E-03,0.661011E-03,0.654703E-03,
24306 &0.653691E-03,0.157425E-01,0.125031E-03,0.179441E+00,0.466950E-01,
24307 &0.592513E-03,0.599863E-03,0.593511E-03,0.592513E-03,0.139674E-01,
24308 &0.123805E-03,0.165770E+00,0.426018E-01,0.536539E-03,0.543850E-03,
24309 &0.537513E-03,0.536539E-03,0.123945E-01,0.121411E-03,0.152935E+00,
24310 &0.388195E-01,0.485370E-03,0.492584E-03,0.486314E-03,0.485370E-03,
24311 &0.109993E-01,0.118076E-03,0.140905E+00,0.353295E-01,0.438636E-03,
24312 &0.445702E-03,0.439543E-03,0.438636E-03,0.976027E-02,0.113999E-03,
24313 &0.129648E+00,0.321137E-01,0.395992E-03,0.402871E-03,0.396859E-03,
24314 &0.395992E-03,0.865895E-02,0.109353E-03,0.119131E+00,0.291550E-01,
24315 &0.357120E-03,0.363779E-03,0.357945E-03,0.357120E-03,0.767960E-02,
24316 &0.104292E-03,0.109323E+00,0.264366E-01,0.321725E-03,0.328139E-03,
24317 &0.322505E-03,0.321725E-03,0.680866E-02,0.989468E-04,0.100191E+00,
24318 &0.239428E-01,0.289531E-03,0.295679E-03,0.290266E-03,0.289531E-03/
24319 DATA (DL(K),K= 2551, 2635) /
24320 &0.603390E-02,0.934295E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24321 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24322 &0.334851E+00,0.904666E-01,0.869706E-03,0.869706E-03,0.869706E-03,
24323 &0.869706E-03,0.316365E-01,-.311708E-17,0.311223E+00,0.828706E-01,
24324 &0.784673E-03,0.785968E-03,0.784847E-03,0.784673E-03,0.277037E-01,
24325 &0.134749E-04,0.288910E+00,0.758361E-01,0.708234E-03,0.710597E-03,
24326 &0.708543E-03,0.708234E-03,0.243298E-01,0.247881E-04,0.267855E+00,
24327 &0.693222E-01,0.639256E-03,0.642491E-03,0.639671E-03,0.639256E-03,
24328 &0.214125E-01,0.340882E-04,0.248015E+00,0.632964E-01,0.576953E-03,
24329 &0.580887E-03,0.577448E-03,0.576953E-03,0.188764E-01,0.415701E-04,
24330 &0.229343E+00,0.577274E-01,0.520615E-03,0.525096E-03,0.521167E-03,
24331 &0.520615E-03,0.166642E-01,0.474027E-04,0.211794E+00,0.525860E-01,
24332 &0.469624E-03,0.474520E-03,0.470215E-03,0.469624E-03,0.147265E-01,
24333 &0.517615E-04,0.195325E+00,0.478447E-01,0.423445E-03,0.428640E-03,
24334 &0.424060E-03,0.423445E-03,0.130234E-01,0.548213E-04,0.179891E+00,
24335 &0.434776E-01,0.381606E-03,0.387001E-03,0.382232E-03,0.381606E-03,
24336 &0.115226E-01,0.567474E-04,0.165449E+00,0.394601E-01,0.343691E-03/
24337 DATA (DL(K),K= 2636, 2720) /
24338 &0.349200E-03,0.344317E-03,0.343691E-03,0.101965E-01,0.576952E-04,
24339 &0.151958E+00,0.357691E-01,0.309329E-03,0.314879E-03,0.309948E-03,
24340 &0.309329E-03,0.902217E-02,0.578101E-04,0.139374E+00,0.323826E-01,
24341 &0.278192E-03,0.283721E-03,0.278796E-03,0.278192E-03,0.798131E-02,
24342 &0.572266E-04,0.127655E+00,0.292797E-01,0.249984E-03,0.255440E-03,
24343 &0.250569E-03,0.249984E-03,0.705796E-02,0.560672E-04,0.116760E+00,
24344 &0.264406E-01,0.224440E-03,0.229782E-03,0.225002E-03,0.224440E-03,
24345 &0.623793E-02,0.544420E-04,0.106647E+00,0.238467E-01,0.201321E-03,
24346 &0.206513E-03,0.201856E-03,0.201321E-03,0.550962E-02,0.524504E-04,
24347 &0.972762E-01,0.214802E-01,0.180411E-03,0.185425E-03,0.180918E-03,
24348 &0.180411E-03,0.486321E-02,0.501804E-04,0.886073E-01,0.193242E-01,
24349 &0.161512E-03,0.166328E-03,0.161990E-03,0.161512E-03,0.428946E-02,
24350 &0.477087E-04,0.806013E-01,0.173629E-01,0.144446E-03,0.149048E-03,
24351 &0.144894E-03,0.144446E-03,0.378030E-02,0.451020E-04,0.732197E-01,
24352 &0.155814E-01,0.129049E-03,0.133425E-03,0.129467E-03,0.129049E-03,
24353 &0.332897E-02,0.424179E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24354 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24355 DATA (DL(K),K= 2721, 2805) /
24356 &0.276761E+00,0.663170E-01,0.420483E-03,0.420483E-03,0.420483E-03,
24357 &0.420483E-03,0.172075E-01,0.418773E-17,0.255003E+00,0.601925E-01,
24358 &0.374768E-03,0.375776E-03,0.374876E-03,0.374768E-03,0.151410E-01,
24359 &0.540038E-05,0.234664E+00,0.545789E-01,0.334420E-03,0.336252E-03,
24360 &0.334612E-03,0.334420E-03,0.133594E-01,0.101360E-04,0.215665E+00,
24361 &0.494328E-01,0.298611E-03,0.301108E-03,0.298867E-03,0.298611E-03,
24362 &0.118079E-01,0.141555E-04,0.197941E+00,0.447203E-01,0.266766E-03,
24363 &0.269787E-03,0.267068E-03,0.266766E-03,0.104461E-01,0.174750E-04,
24364 &0.181428E+00,0.404089E-01,0.238391E-03,0.241815E-03,0.238726E-03,
24365 &0.238391E-03,0.924609E-02,0.201244E-04,0.166064E+00,0.364687E-01,
24366 &0.213061E-03,0.216782E-03,0.213417E-03,0.213061E-03,0.818507E-02,
24367 &0.221467E-04,0.151790E+00,0.328719E-01,0.190418E-03,0.194343E-03,
24368 &0.190785E-03,0.190418E-03,0.724366E-02,0.235974E-04,0.138548E+00,
24369 &0.295925E-01,0.170150E-03,0.174202E-03,0.170521E-03,0.170150E-03,
24370 &0.640614E-02,0.245354E-04,0.126282E+00,0.266063E-01,0.151991E-03,
24371 &0.156104E-03,0.152359E-03,0.151991E-03,0.566089E-02,0.250221E-04,
24372 &0.114939E+00,0.238907E-01,0.135710E-03,0.139827E-03,0.136071E-03/
24373 DATA (DL(K),K= 2806, 2890) /
24374 &0.135710E-03,0.499773E-02,0.251191E-04,0.104465E+00,0.214245E-01,
24375 &0.121106E-03,0.125180E-03,0.121455E-03,0.121106E-03,0.440691E-02,
24376 &0.248850E-04,0.948101E-01,0.191879E-01,0.108002E-03,0.111994E-03,
24377 &0.108337E-03,0.108002E-03,0.388094E-02,0.243760E-04,0.859247E-01,
24378 &0.171625E-01,0.962435E-04,0.100124E-03,0.965624E-04,0.962435E-04,
24379 &0.341379E-02,0.236445E-04,0.777613E-01,0.153309E-01,0.856948E-04,
24380 &0.894394E-04,0.859960E-04,0.856948E-04,0.299910E-02,0.227378E-04,
24381 &0.702736E-01,0.136770E-01,0.762337E-04,0.798235E-04,0.765166E-04,
24382 &0.762337E-04,0.263116E-02,0.216984E-04,0.634174E-01,0.121859E-01,
24383 &0.677528E-04,0.711742E-04,0.680169E-04,0.677528E-04,0.230551E-02,
24384 &0.205642E-04,0.571500E-01,0.108434E-01,0.601554E-04,0.633990E-04,
24385 &0.604008E-04,0.601554E-04,0.201791E-02,0.193681E-04,0.514305E-01,
24386 &0.963651E-02,0.533545E-04,0.564148E-04,0.535814E-04,0.533545E-04,
24387 &0.176404E-02,0.181381E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24388 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24389 &0.220700E+00,0.461964E-01,0.185072E-03,0.185072E-03,0.185072E-03,
24390 &0.185072E-03,0.865568E-02,-.294090E-17,0.201438E+00,0.415162E-01/
24391 DATA (DL(K),K= 2891, 2975) /
24392 &0.162774E-03,0.163610E-03,0.162842E-03,0.162774E-03,0.772611E-02,
24393 &0.184134E-05,0.183625E+00,0.372730E-01,0.143469E-03,0.144974E-03,
24394 &0.143588E-03,0.143469E-03,0.690038E-02,0.359959E-05,0.167162E+00,
24395 &0.334245E-01,0.126634E-03,0.128666E-03,0.126791E-03,0.126634E-03,
24396 &0.616000E-02,0.518075E-05,0.151966E+00,0.299378E-01,0.111904E-03,
24397 &0.114340E-03,0.112088E-03,0.111904E-03,0.549219E-02,0.654232E-05,
24398 &0.137959E+00,0.267821E-01,0.989836E-04,0.101716E-03,0.991845E-04,
24399 &0.989836E-04,0.488896E-02,0.767008E-05,0.125065E+00,0.239289E-01,
24400 &0.876157E-04,0.905559E-04,0.878269E-04,0.876157E-04,0.434253E-02,
24401 &0.855860E-05,0.113213E+00,0.213524E-01,0.775899E-04,0.806611E-04,
24402 &0.778055E-04,0.775899E-04,0.384886E-02,0.921640E-05,0.102335E+00,
24403 &0.190285E-01,0.687292E-04,0.718676E-04,0.689446E-04,0.687292E-04,
24404 &0.340422E-02,0.965961E-05,0.923671E-01,0.169353E-01,0.608829E-04,
24405 &0.640353E-04,0.610944E-04,0.608829E-04,0.300332E-02,0.990752E-05,
24406 &0.832476E-01,0.150523E-01,0.539242E-04,0.570473E-04,0.541291E-04,
24407 &0.539242E-04,0.264288E-02,0.998320E-05,0.749179E-01,0.133608E-01,
24408 &0.477459E-04,0.508046E-04,0.479422E-04,0.477459E-04,0.232088E-02/
24409 DATA (DL(K),K= 2976, 3060) /
24410 &0.991147E-05,0.673221E-01,0.118435E-01,0.422554E-04,0.452220E-04,
24411 &0.424417E-04,0.422554E-04,0.203376E-02,0.971603E-05,0.604073E-01,
24412 &0.104845E-01,0.373730E-04,0.402263E-04,0.375483E-04,0.373730E-04,
24413 &0.177791E-02,0.941959E-05,0.541231E-01,0.926900E-02,0.330304E-04,
24414 &0.357544E-04,0.331943E-04,0.330304E-04,0.155117E-02,0.904408E-05,
24415 &0.484216E-01,0.818347E-02,0.291681E-04,0.317517E-04,0.293202E-04,
24416 &0.291681E-04,0.135108E-02,0.860921E-05,0.432578E-01,0.721549E-02,
24417 &0.257333E-04,0.281694E-04,0.258738E-04,0.257333E-04,0.117463E-02,
24418 &0.813214E-05,0.385889E-01,0.635362E-02,0.226802E-04,0.249648E-04,
24419 &0.228093E-04,0.226802E-04,0.101941E-02,0.762814E-05,0.343746E-01,
24420 &0.558739E-02,0.199682E-04,0.221003E-04,0.200863E-04,0.199682E-04,
24421 &0.883469E-03,0.711035E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24422 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24423 &0.168205E+00,0.301419E-01,0.719932E-04,0.719932E-04,0.719932E-04,
24424 &0.719932E-04,0.392825E-02,-.205998E-17,0.151922E+00,0.267932E-01,
24425 &0.623634E-04,0.630456E-04,0.624028E-04,0.623634E-04,0.361412E-02,
24426 &0.457084E-06,0.137042E+00,0.237932E-01,0.541981E-04,0.554098E-04/
24427 DATA (DL(K),K= 3061, 3145) /
24428 &0.542663E-04,0.541981E-04,0.330342E-02,0.989813E-06,0.123446E+00,
24429 &0.211038E-01,0.472163E-04,0.488314E-04,0.473050E-04,0.472163E-04,
24430 &0.300140E-02,0.152631E-05,0.111042E+00,0.186954E-01,0.412159E-04,
24431 &0.431273E-04,0.413184E-04,0.412159E-04,0.270826E-02,0.202092E-05,
24432 &0.997395E-01,0.165410E-01,0.360433E-04,0.381615E-04,0.361542E-04,
24433 &0.360433E-04,0.242968E-02,0.245400E-05,0.894558E-01,0.146159E-01,
24434 &0.315670E-04,0.338178E-04,0.316822E-04,0.315670E-04,0.216928E-02,
24435 &0.281218E-05,0.801130E-01,0.128978E-01,0.276779E-04,0.300002E-04,
24436 &0.277940E-04,0.276779E-04,0.192603E-02,0.308878E-05,0.716379E-01,
24437 &0.113663E-01,0.242878E-04,0.266317E-04,0.244024E-04,0.242878E-04,
24438 &0.170100E-02,0.328451E-05,0.639623E-01,0.100031E-01,0.213246E-04,
24439 &0.236502E-04,0.214357E-04,0.213246E-04,0.149649E-02,0.340483E-05,
24440 &0.570222E-01,0.879131E-02,0.187277E-04,0.210033E-04,0.188341E-04,
24441 &0.187277E-04,0.131163E-02,0.345656E-05,0.507574E-01,0.771565E-02,
24442 &0.164465E-04,0.186476E-04,0.165471E-04,0.164465E-04,0.114469E-02,
24443 &0.344782E-05,0.451118E-01,0.676223E-02,0.144396E-04,0.165480E-04,
24444 &0.145339E-04,0.144396E-04,0.995649E-03,0.338831E-05,0.400330E-01/
24445 DATA (DL(K),K= 3146, 3230) /
24446 &0.591841E-02,0.126720E-04,0.146744E-04,0.127597E-04,0.126720E-04,
24447 &0.863829E-03,0.328754E-05,0.354720E-01,0.517273E-02,0.111137E-04,
24448 &0.130013E-04,0.111946E-04,0.111137E-04,0.747293E-03,0.315403E-05,
24449 &0.313830E-01,0.451477E-02,0.973915E-05,0.115067E-04,0.981339E-05,
24450 &0.973915E-05,0.644664E-03,0.299600E-05,0.277237E-01,0.393511E-02,
24451 &0.852687E-05,0.101721E-04,0.859457E-05,0.852687E-05,0.555034E-03,
24452 &0.282099E-05,0.244545E-01,0.342521E-02,0.745784E-05,0.898076E-05,
24453 &0.751926E-05,0.745784E-05,0.476998E-03,0.263530E-05,0.215390E-01,
24454 &0.297737E-02,0.651555E-05,0.791817E-05,0.657100E-05,0.651555E-05,
24455 &0.409096E-03,0.244427E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24456 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24457 &0.120694E+00,0.180081E-01,0.236444E-04,0.236444E-04,0.236444E-04,
24458 &0.236444E-04,0.154817E-02,0.416656E-17,0.107713E+00,0.158098E-01,
24459 &0.200945E-04,0.206098E-04,0.201146E-04,0.200945E-04,0.151249E-02,
24460 &0.192118E-07,0.960063E-01,0.138667E-01,0.171552E-04,0.180593E-04,
24461 &0.171894E-04,0.171552E-04,0.143574E-02,0.116516E-06,0.854477E-01,
24462 &0.121473E-01,0.146986E-04,0.158894E-04,0.147425E-04,0.146986E-04/
24463 DATA (DL(K),K= 3231, 3315) /
24464 &0.133744E-02,0.251060E-06,0.759386E-01,0.106275E-01,0.126329E-04,
24465 &0.140252E-04,0.126830E-04,0.126329E-04,0.122900E-02,0.395272E-06,
24466 &0.673865E-01,0.928577E-02,0.108901E-04,0.124142E-04,0.109436E-04,
24467 &0.108901E-04,0.111367E-02,0.535145E-06,0.597062E-01,0.810254E-02,
24468 &0.941160E-05,0.110108E-04,0.946648E-05,0.941160E-05,0.996785E-03,
24469 &0.659421E-06,0.528194E-01,0.706039E-02,0.815165E-05,0.978016E-05,
24470 &0.820627E-05,0.815165E-05,0.885152E-03,0.762600E-06,0.466540E-01,
24471 &0.614371E-02,0.707299E-05,0.869464E-05,0.712616E-05,0.707299E-05,
24472 &0.780484E-03,0.842072E-06,0.411433E-01,0.533850E-02,0.614470E-05,
24473 &0.773135E-05,0.619559E-05,0.614470E-05,0.682563E-03,0.896683E-06,
24474 &0.362261E-01,0.463223E-02,0.534297E-05,0.687330E-05,0.539102E-05,
24475 &0.534297E-05,0.593317E-03,0.928176E-06,0.318459E-01,0.401364E-02,
24476 &0.464848E-05,0.610690E-05,0.469333E-05,0.464848E-05,0.513720E-03,
24477 &0.939174E-06,0.279510E-01,0.347266E-02,0.404483E-05,0.542054E-05,
24478 &0.408628E-05,0.404483E-05,0.442713E-03,0.932117E-06,0.244935E-01,
24479 &0.300029E-02,0.351893E-05,0.480507E-05,0.355692E-05,0.351893E-05,
24480 &0.379744E-03,0.910085E-06,0.214299E-01,0.258845E-02,0.306021E-05/
24481 DATA (DL(K),K= 3316, 3400) /
24482 &0.425313E-05,0.309476E-05,0.306021E-05,0.324785E-03,0.876365E-06,
24483 &0.187200E-01,0.222996E-02,0.265958E-05,0.375823E-05,0.269081E-05,
24484 &0.265958E-05,0.277080E-03,0.833755E-06,0.163273E-01,0.191840E-02,
24485 &0.230942E-05,0.331477E-05,0.233747E-05,0.230942E-05,0.235661E-03,
24486 &0.784780E-06,0.142185E-01,0.164805E-02,0.200337E-05,0.291797E-05,
24487 &0.202844E-05,0.200337E-05,0.199949E-03,0.731774E-06,0.123631E-01,
24488 &0.141382E-02,0.173596E-05,0.256351E-05,0.175824E-05,0.173596E-05,
24489 &0.169376E-03,0.676674E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24490 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24491 &0.794823E-01,0.948208E-02,0.607312E-05,0.607312E-05,0.607312E-05,
24492 &0.607312E-05,0.497062E-03,-.140523E-17,0.699344E-01,0.820355E-02,
24493 &0.500852E-05,0.538347E-05,0.501731E-05,0.500852E-05,0.542262E-03,
24494 &-.714686E-07,0.614560E-01,0.709106E-02,0.415227E-05,0.479898E-05,
24495 &0.416702E-05,0.415227E-05,0.549985E-03,-.960102E-07,0.539240E-01,
24496 &0.612155E-02,0.345977E-05,0.429563E-05,0.347839E-05,0.345977E-05,
24497 &0.531288E-03,-.894946E-07,0.472426E-01,0.527757E-02,0.289508E-05,
24498 &0.385164E-05,0.291595E-05,0.289508E-05,0.495120E-03,-.668594E-07/
24499 DATA (DL(K),K= 3401, 3485) /
24500 &0.413245E-01,0.454380E-02,0.243524E-05,0.345851E-05,0.245713E-05,
24501 &0.243524E-05,0.452156E-03,-.338861E-07,0.360903E-01,0.390658E-02,
24502 &0.205923E-05,0.310726E-05,0.208123E-05,0.205923E-05,0.406686E-03,
24503 &0.329349E-08,0.314681E-01,0.335393E-02,0.174861E-05,0.278918E-05,
24504 &0.177007E-05,0.174861E-05,0.359402E-03,0.387747E-07,0.273932E-01,
24505 &0.287528E-02,0.149082E-05,0.250013E-05,0.151127E-05,0.149082E-05,
24506 &0.313779E-03,0.705560E-07,0.238068E-01,0.246132E-02,0.127582E-05,
24507 &0.223699E-05,0.129498E-05,0.127582E-05,0.272195E-03,0.975744E-07,
24508 &0.206558E-01,0.210383E-02,0.109488E-05,0.199657E-05,0.111257E-05,
24509 &0.109488E-05,0.234227E-03,0.118651E-06,0.178921E-01,0.179558E-02,
24510 &0.941584E-06,0.177694E-05,0.957733E-06,0.941584E-06,0.199907E-03,
24511 &0.133780E-06,0.154726E-01,0.153020E-02,0.811157E-06,0.157680E-05,
24512 &0.825743E-06,0.811157E-06,0.169849E-03,0.143581E-06,0.133582E-01,
24513 &0.130209E-02,0.699567E-06,0.139481E-05,0.712624E-06,0.699567E-06,
24514 &0.143794E-03,0.148591E-06,0.115137E-01,0.110634E-02,0.603631E-06,
24515 &0.122977E-05,0.615228E-06,0.603631E-06,0.121163E-03,0.149477E-06,
24516 &0.990774E-02,0.938615E-03,0.520920E-06,0.108072E-05,0.531148E-06/
24517 DATA (DL(K),K= 3486, 3570) /
24518 &0.520920E-06,0.101725E-03,0.147055E-06,0.851194E-02,0.795146E-03,
24519 &0.449441E-06,0.946634E-06,0.458405E-06,0.449441E-06,0.852238E-04,
24520 &0.142064E-06,0.730103E-02,0.672622E-03,0.387542E-06,0.826497E-06,
24521 &0.395353E-06,0.387542E-06,0.712290E-04,0.135149E-06,0.625244E-02,
24522 &0.568155E-03,0.333888E-06,0.719316E-06,0.340658E-06,0.333888E-06,
24523 &0.593824E-04,0.126902E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24524 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24525 &0.457819E-01,0.409492E-02,0.105702E-05,0.105702E-05,0.105702E-05,
24526 &0.105702E-05,0.115350E-03,0.265810E-18,0.395724E-01,0.347873E-02,
24527 &0.812397E-06,0.103880E-05,0.815187E-06,0.812397E-06,0.160406E-03,
24528 &-.555147E-07,0.341639E-01,0.295295E-02,0.627904E-06,0.987449E-06,
24529 &0.632305E-06,0.627904E-06,0.174490E-03,-.847266E-07,0.294481E-01,
24530 &0.250329E-02,0.490075E-06,0.920197E-06,0.495305E-06,0.490075E-06,
24531 &0.174490E-03,-.944763E-07,0.253423E-01,0.211912E-02,0.387225E-06,
24532 &0.845257E-06,0.392760E-06,0.387225E-06,0.167111E-03,-.916775E-07,
24533 &0.217735E-01,0.179138E-02,0.309989E-06,0.766697E-06,0.315473E-06,
24534 &0.309989E-06,0.152540E-03,-.819158E-07,0.186760E-01,0.151211E-02/
24535 DATA (DL(K),K= 3571, 3655) /
24536 &0.252109E-06,0.688927E-06,0.257316E-06,0.252109E-06,0.135295E-03,
24537 &-.682145E-07,0.159921E-01,0.127447E-02,0.208612E-06,0.614302E-06,
24538 &0.213410E-06,0.208612E-06,0.118648E-03,-.528734E-07,0.136704E-01,
24539 &0.107254E-02,0.175203E-06,0.543807E-06,0.179526E-06,0.175203E-06,
24540 &0.102484E-03,-.379748E-07,0.116656E-01,0.901214E-03,0.149064E-06,
24541 &0.478363E-06,0.152890E-06,0.149064E-06,0.871530E-04,-.245007E-07,
24542 &0.993760E-02,0.756074E-03,0.128274E-06,0.418496E-06,0.131610E-06,
24543 &0.128274E-06,0.735682E-04,-.128491E-07,0.845081E-02,0.633315E-03,
24544 &0.111313E-06,0.364260E-06,0.114187E-06,0.111313E-06,0.617706E-04,
24545 &-.327698E-08,0.717398E-02,0.529654E-03,0.971373E-07,0.315568E-06,
24546 &0.995871E-07,0.971373E-07,0.514764E-04,0.421954E-08,0.607950E-02,
24547 &0.442265E-03,0.850687E-07,0.272228E-06,0.871375E-07,0.850687E-07,
24548 &0.426580E-04,0.982709E-08,0.514311E-02,0.368716E-03,0.746164E-07,
24549 &0.233927E-06,0.763489E-07,0.746164E-07,0.352463E-04,0.137715E-07,
24550 &0.434349E-02,0.306920E-03,0.654439E-07,0.200291E-06,0.668838E-07,
24551 &0.654439E-07,0.290260E-04,0.163078E-07,0.366196E-02,0.255085E-03,
24552 &0.573307E-07,0.170932E-06,0.585192E-07,0.573307E-07,0.238196E-04/
24553 DATA (DL(K),K= 3656, 3740) /
24554 &0.177037E-07,0.308217E-02,0.211681E-03,0.501185E-07,0.145441E-06,
24555 &0.510931E-07,0.501185E-07,0.195033E-04,0.182028E-07,0.258987E-02,
24556 &0.175396E-03,0.436915E-07,0.123415E-06,0.444860E-07,0.436915E-07,
24557 &0.159423E-04,0.180204E-07,0.000000E+00,0.000000E+00,0.000000E+00,
24558 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24559 &0.206951E-01,0.123383E-02,0.903693E-07,0.903693E-07,0.903693E-07,
24560 &0.903693E-07,0.147928E-04,0.131925E-18,0.174566E-01,0.102241E-02,
24561 &0.892028E-07,0.129792E-07,0.885875E-07,0.892028E-07,0.328931E-04,
24562 &0.168541E-07,0.147092E-01,0.846741E-03,0.841992E-07,-.346085E-07,
24563 &0.832249E-07,0.841992E-07,0.410825E-04,0.262547E-07,0.123736E-01,
24564 &0.700287E-03,0.769173E-07,-.620958E-07,0.757563E-07,0.769173E-07,
24565 &0.418512E-04,0.305542E-07,0.103910E-01,0.578275E-03,0.688622E-07,
24566 &-.753692E-07,0.676306E-07,0.688622E-07,0.392599E-04,0.318183E-07,
24567 &0.871109E-02,0.476815E-03,0.611778E-07,-.782788E-07,0.599557E-07,
24568 &0.611778E-07,0.356221E-04,0.316149E-07,0.728984E-02,0.392546E-03,
24569 &0.537256E-07,-.749101E-07,0.525642E-07,0.537256E-07,0.312295E-04,
24570 &0.301630E-07,0.608951E-02,0.322656E-03,0.466227E-07,-.678673E-07/
24571 DATA (DL(K),K= 3741, 3825) /
24572 &0.455521E-07,0.466227E-07,0.265816E-04,0.278681E-07,0.507758E-02,
24573 &0.264779E-03,0.400790E-07,-.588670E-07,0.391148E-07,0.400790E-07,
24574 &0.223044E-04,0.251720E-07,0.422604E-02,0.216927E-03,0.341205E-07,
24575 &-.492124E-07,0.332680E-07,0.341205E-07,0.185283E-04,0.222885E-07,
24576 &0.351082E-02,0.177427E-03,0.287480E-07,-.397442E-07,0.280058E-07,
24577 &0.287480E-07,0.152122E-04,0.193702E-07,0.291126E-02,0.144878E-03,
24578 &0.239699E-07,-.309608E-07,0.233320E-07,0.239699E-07,0.123840E-04,
24579 &0.165481E-07,0.240962E-02,0.118102E-03,0.197695E-07,-.231453E-07,
24580 &0.192276E-07,0.197695E-07,0.100316E-04,0.139043E-07,0.199075E-02,
24581 &0.961132E-04,0.161186E-07,-.164194E-07,0.156628E-07,0.161186E-07,
24582 &0.808648E-05,0.114903E-07,0.164168E-02,0.780880E-04,0.129826E-07,
24583 &-.107955E-07,0.126029E-07,0.129826E-07,0.648861E-05,0.933575E-08,
24584 &0.135135E-02,0.633381E-04,0.103192E-07,-.622051E-08,0.100055E-07,
24585 &0.103192E-07,0.519042E-05,0.744979E-08,0.111036E-02,0.512898E-04,
24586 &0.808255E-08,-.260101E-08,0.782557E-08,0.808255E-08,0.414192E-05,
24587 &0.582811E-08,0.910718E-03,0.414657E-04,0.622640E-08,0.177583E-09,
24588 &0.601750E-08,0.622640E-08,0.329729E-05,0.445766E-08,0.745657E-03/
24589 DATA (DL(K),K= 3826, 3910) /
24590 &0.334694E-04,0.470431E-08,0.223586E-08,0.453577E-08,0.470431E-08,
24591 &0.261981E-05,0.331859E-08,0.000000E+00,0.000000E+00,0.000000E+00,
24592 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24593 &0.519165E-02,0.154752E-03,0.135983E-08,0.135983E-08,0.135983E-08,
24594 &0.135983E-08,0.445189E-06,0.165858E-19,0.420352E-02,0.123002E-03,
24595 &-.202651E-07,0.730203E-07,-.200511E-07,-.202651E-07,0.358557E-05,
24596 &-.213089E-07,0.340143E-02,0.977718E-04,-.356451E-07,0.114908E-06,
24597 &-.353066E-07,-.356451E-07,0.384652E-05,-.364475E-07,0.274771E-02,
24598 &0.776124E-04,-.435588E-07,0.139200E-06,-.431556E-07,-.435588E-07,
24599 &0.404834E-05,-.441752E-07,0.221524E-02,0.614950E-04,-.471629E-07,
24600 &0.150069E-06,-.467352E-07,-.471629E-07,0.391615E-05,-.476355E-07,
24601 &0.178268E-02,0.486476E-04,-.477545E-07,0.151420E-06,-.473296E-07,
24602 &-.477545E-07,0.334100E-05,-.481163E-07,0.143185E-02,0.384202E-04,
24603 &-.462359E-07,0.146515E-06,-.458316E-07,-.462359E-07,0.275426E-05,
24604 &-.465126E-07,0.114781E-02,0.302894E-04,-.434031E-07,0.137587E-06,
24605 &-.430295E-07,-.434031E-07,0.226010E-05,-.436143E-07,0.918288E-03,
24606 &0.238367E-04,-.398089E-07,0.126321E-06,-.394715E-07,-.398089E-07/
24607 DATA (DL(K),K= 3911, 3995) /
24608 &0.180947E-05,-.399700E-07,0.733193E-03,0.187249E-04,-.358525E-07,
24609 &0.113940E-06,-.355529E-07,-.358525E-07,0.142045E-05,-.359751E-07,
24610 &0.584227E-03,0.146823E-04,-.318183E-07,0.101291E-06,-.315563E-07,
24611 &-.318183E-07,0.110919E-05,-.319115E-07,0.464586E-03,0.114914E-04,
24612 &-.278936E-07,0.889550E-07,-.276671E-07,-.278936E-07,0.860964E-06,
24613 &-.279643E-07,0.368700E-03,0.897731E-05,-.241972E-07,0.773096E-07,
24614 &-.240033E-07,-.241972E-07,0.662825E-06,-.242508E-07,0.292013E-03,
24615 &0.700034E-05,-.208001E-07,0.665779E-07,-.206356E-07,-.208001E-07,
24616 &0.508061E-06,-.208406E-07,0.230814E-03,0.544870E-05,-.177366E-07,
24617 &0.568734E-07,-.175982E-07,-.177366E-07,0.388493E-06,-.177672E-07,
24618 &0.182078E-03,0.423324E-05,-.150157E-07,0.482316E-07,-.149000E-07,
24619 &-.150157E-07,0.296111E-06,-.150387E-07,0.143349E-03,0.328297E-05,
24620 &-.126295E-07,0.406343E-07,-.125335E-07,-.126295E-07,0.225104E-06,
24621 &-.126468E-07,0.112639E-03,0.254145E-05,-.105595E-07,0.340280E-07,
24622 &-.104803E-07,-.105595E-07,0.170871E-06,-.105726E-07,0.883377E-04,
24623 &0.196395E-05,-.878062E-08,0.283380E-07,-.871555E-08,-.878062E-08,
24624 &0.129517E-06,-.879039E-08,0.000000E+00,0.000000E+00,0.000000E+00/
24625 DATA (DL(K),K= 3996, 4000) /
24626 &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24629 IF (X.GT.0.9985) RETURN
24630 IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
24636 F1(L) = GF(I,IS,KL)
24637 F2(L) = GF(I,IS1,KL)
24639 A1 = DT_CKMTFF(X,F1)
24640 A2 = DT_CKMTFF(X,F2)
24645 ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
24651 *$ CREATE DT_CKMTFF.FOR
24653 FUNCTION DT_CKMTFF(X,FVL)
24654 C**********************************************************************
24656 C LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
24657 C FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
24658 C NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
24661 C**********************************************************************
24664 DIMENSION FVL(25),XGRID(25)
24665 DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
24666 *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
24670 IF(X.LT.XGRID(I)) GO TO 2
24675 ELSE IF(I.GT.23) THEN
24681 BXI=LOG(1.-XGRID(I))
24683 BXJ=LOG(1.-XGRID(J))
24685 BXK=LOG(1.-XGRID(K))
24686 FI=LOG(ABS(FVL(I)) +1.E-15)
24687 FJ=LOG(ABS(FVL(J)) +1.E-16)
24688 FK=LOG(ABS(FVL(K)) +1.E-17)
24689 DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
24690 ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
24692 ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
24693 BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
24694 IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
24696 C IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
24697 C WRITE(6,2001) X,FVL
24698 C 2001 FORMAT(8E12.4)
24699 C WRITE(6,2001) ALPHA,BETA,ALOGA,DET
24701 DT_CKMTFF=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
24705 *$ CREATE DT_FLUINI.FOR
24708 *===fluini=============================================================*
24710 SUBROUTINE DT_FLUINI
24712 ************************************************************************
24713 * Initialisation of the nucleon-nucleon cross section fluctuation *
24714 * treatment. The original version by J. Ranft. *
24715 * This version dated 21.04.95 is revised by S. Roesler. *
24716 ************************************************************************
24718 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24720 PARAMETER ( LINP = 10 ,
24723 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
24725 PARAMETER ( A = 0.1D0,
24731 * n-n cross section fluctuations
24732 PARAMETER (NBINS = 1000)
24733 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
24734 DIMENSION FLUSI(NBINS),FLUIX(NBINS)
24737 1000 FORMAT(/,1X,'FLUINI: hadronic cross section fluctuations ',
24746 FLUS = ((X-B)/(OM*B))**N
24747 IF (FLUS.LE.20.0D0) THEN
24748 FLUSI(I) = (X/B)*EXP(-FLUS)/(X/B+A)
24752 FLUSU = FLUSU+FLUSI(I)
24755 FLUSUU = FLUSUU+FLUSI(I)/FLUSU
24760 C1001 FORMAT(1X,'FLUCTUATIONS')
24761 C CALL PLOT(FLUIX,FLUSI,1000,1,1000,0.0D0,0.06D0,0.0D0,0.01D0)
24764 AF = DBLE(I)*0.001D0
24766 IF (AF.LE.FLUSI(J)) THEN
24767 FLUIXX(I) = FLUIX(J)
24773 FLUIXX(1) = FLUIX(1)
24774 FLUIXX(NBINS) = FLUIX(NBINS)
24779 *$ CREATE DT_SIGTBL.FOR
24782 *===sigtab=============================================================*
24784 SUBROUTINE DT_SIGTBL(JP,JT,PTOT,SIGE,MODE)
24786 ************************************************************************
24787 * This version dated 18.11.95 is written by S. Roesler *
24788 ************************************************************************
24790 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24792 PARAMETER ( LINP = 10 ,
24796 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24797 & OHALF=0.5D0,ONE=1.0D0)
24798 PARAMETER (PLO=0.01D0,PHI=20.0D0,NBINS=150)
24802 * particle properties (BAMJET index convention)
24804 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24805 & IICH(210),IIBAR(210),K1(210),K2(210)
24807 DIMENSION SIGEP(5,NBINS+1),SIGEN(5,NBINS+1),IDSIG(23)
24808 DATA IDSIG / 1, 0, 0, 0, 0, 0, 0, 2, 0, 0,
24809 & 0, 0, 3, 4, 0, 0, 0, 0, 0, 0,
24811 DATA LINIT /.FALSE./
24813 * precalculation and tabulation of elastic cross sections
24814 IF (ABS(MODE).EQ.1) THEN
24816 & OPEN(LDAT,FILE='outdata0/sigtab.out',STATUS='UNKNOWN')
24817 PLABLX = LOG10(PLO)
24818 PLABHX = LOG10(PHI)
24819 DPLAB = (PLABHX-PLABLX)/DBLE(NBINS)
24821 PLAB = PLABLX+DBLE(I-1)*DPLAB
24826 C CALL DT_SIHNEL(IPROJ,1,PLAB,SIGEP(IDX,I))
24827 C CALL DT_SIHNEL(IPROJ,8,PLAB,SIGEN(IDX,I))
24829 CALL DT_XSHN(IPROJ,1,PLAB,DUMZER,SIGTOT,SIGEP(IDX,I))
24830 CALL DT_XSHN(IPROJ,8,PLAB,DUMZER,SIGTOT,SIGEN(IDX,I))
24833 IF (MODE.EQ.1) THEN
24834 WRITE(LDAT,1000) PLAB,(SIGEP(IDX,I),IDX=1,5),
24835 & (SIGEN(IDX,I),IDX=1,5)
24836 1000 FORMAT(F5.1,10F7.2)
24839 IF (MODE.EQ.1) CLOSE(LDAT)
24843 IF (LINIT.AND.(JP.LE.23).AND.(PTOT.GE.PLO)
24844 & .AND.(PTOT.LE.PHI) ) THEN
24846 IF ( (IDX.GT.0).AND.((JT.EQ.1).OR.(JT.EQ.8)) ) THEN
24847 PLABX = LOG10(PTOT)
24848 IF (PLABX.LE.PLABLX) THEN
24851 ELSEIF (PLABX.GE.PLABHX) THEN
24855 I1 = INT((PLABX-PLABLX)/DPLAB)+1
24858 PLAB1X = PLABLX+DBLE(I1-1)*DPLAB
24859 PLAB2X = PLABLX+DBLE(I2-1)*DPLAB
24860 PBIN = PLAB2X-PLAB1X
24861 IF (PBIN.GT.TINY10) THEN
24862 RATX = (PLABX-PLAB1X)/(PLAB2X-PLAB1X)
24867 SIG1 = SIGEP(IDX,I1)
24868 SIG2 = SIGEP(IDX,I2)
24870 SIG1 = SIGEN(IDX,I1)
24871 SIG2 = SIGEN(IDX,I2)
24873 SIGE = SIG1+RATX*(SIG2-SIG1)
24881 *$ CREATE DT_XSTABL.FOR
24884 *===xstabl=============================================================*
24886 SUBROUTINE DT_XSTABL(WHAT,IXSQEL,IRATIO)
24888 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24890 PARAMETER ( LINP = 10 ,
24893 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24894 & OHALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
24895 LOGICAL LLAB,LELOG,LQLOG
24897 * particle properties (BAMJET index convention)
24899 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24900 & IICH(210),IIBAR(210),K1(210),K2(210)
24901 * properties of interacting particles
24902 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
24903 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
24904 * Glauber formalism: cross sections
24905 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
24906 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
24907 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
24908 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
24909 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
24910 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
24911 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
24912 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
24913 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
24914 & BSLOPE,NEBINI,NQBINI
24915 * emulsion treatment
24916 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
24921 LLAB = (WHAT(1).GT.ZERO).OR.(WHAT(2).GT.ZERO)
24924 IF (ELO.GT.EHI) ELO = EHI
24925 LELOG = WHAT(3).LT.ZERO
24926 NEBINS = MAX(INT(ABS(WHAT(3))),1)
24927 DEBINS = (EHI-ELO)/DBLE(NEBINS)
24931 ADEBIN = (AEHI-AELO)/DBLE(NEBINS)
24935 IF (Q2LO.GT.Q2HI) Q2LO = Q2HI
24936 LQLOG = WHAT(6).LT.ZERO
24937 NQBINS = MAX(INT(ABS(WHAT(6))),1)
24938 DQBINS = (Q2HI-Q2LO)/DBLE(NQBINS)
24940 AQ2LO = LOG10(Q2LO)
24941 AQ2HI = LOG10(Q2HI)
24942 ADQBIN = (AQ2HI-AQ2LO)/DBLE(NQBINS)
24945 IF ( ELO.EQ. EHI) NEBINS = 0
24946 IF (Q2LO.EQ.Q2HI) NQBINS = 0
24948 WRITE(LOUT,1000) ELO,EHI,LLAB,IXSQEL,Q2LO,Q2HI,IJPROJ,IP,IT
24949 1000 FORMAT(/,1X,'XSTABL: E_lo =',E10.3,' GeV E_hi =',E10.3,
24950 & ' GeV Lab = ',L1,' qel: ',I2,/,10X,'Q2_lo =',F10.5,
24951 & ' GeV^2 Q2_hi =',F10.5,' GeV^2',/,10X,'id_p = ',I2,
24952 & ' A_p = ',I3,' A_t = ',I3,/)
24954 C IF (IJPROJ.NE.7) THEN
24955 WRITE(LOUT,'(1X,A,/)')'(E,STOT,SELA,SQEP,SQET,SQE2,SINE,SPROD)'
24956 * normalize fractions of emulsion components
24957 IF (NCOMPO.GT.0) THEN
24960 SUMFRA = SUMFRA+EMUFRA(I)
24962 IF (SUMFRA.GT.ZERO) THEN
24964 EMUFRA(I) = EMUFRA(I)/SUMFRA
24969 C WRITE(LOUT,'(1X,A,/)') '(Q2,E,STOT,ETOT,SIN,EIN,STOT0)'
24973 E = 10**(AELO+DBLE(I-1)*ADEBIN)
24975 E = ELO+DBLE(I-1)*DEBINS
24979 Q2 = 10**(AQ2LO+DBLE(J-1)*ADQBIN)
24981 Q2 = Q2LO+DBLE(J-1)*DQBINS
24983 c IF (IJPROJ.NE.7) THEN
24987 CALL DT_LTINI(IJPROJ,1,E,PPN0,ECM,0)
24993 IF (IJPROJ.EQ.7) Q2I = Q2
24994 IF (NCOMPO.GT.0) THEN
24997 CALL DT_XSGLAU(IP,IIT,IJPROJ,XI,Q2I,ECM,1,1,-IC)
25000 CALL DT_XSGLAU(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,-1)
25001 C CALL AMPLIT(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,1)
25003 IF (NCOMPO.GT.0) THEN
25022 XTOT = XTOT+EMUFRA(IC)*XSTOT(1,1,IC)
25023 ETOT = ETOT+EMUFRA(IC)*XETOT(1,1,IC)**2
25024 XELA = XELA+EMUFRA(IC)*XSELA(1,1,IC)
25025 EELA = EELA+EMUFRA(IC)*XEELA(1,1,IC)**2
25026 XQEP = XQEP+EMUFRA(IC)*XSQEP(1,1,IC)
25027 EQEP = EQEP+EMUFRA(IC)*XEQEP(1,1,IC)**2
25028 XQET = XQET+EMUFRA(IC)*XSQET(1,1,IC)
25029 EQET = EQET+EMUFRA(IC)*XEQET(1,1,IC)**2
25030 XQE2 = XQE2+EMUFRA(IC)*XSQE2(1,1,IC)
25031 EQE2 = EQE2+EMUFRA(IC)*XEQE2(1,1,IC)**2
25032 XPRO = XPRO+EMUFRA(IC)*XSPRO(1,1,IC)
25033 EPRO = EPRO+EMUFRA(IC)*XEPRO(1,1,IC)**2
25034 XDEL = XDEL+EMUFRA(IC)*XSDEL(1,1,IC)
25035 EDEL = EDEL+EMUFRA(IC)*XEDEL(1,1,IC)**2
25036 XDQE = XDQE+EMUFRA(IC)*XSDQE(1,1,IC)
25037 EDQE = EDQE+EMUFRA(IC)*XEDQE(1,1,IC)**2
25038 YPRO = XSTOT(1,1,IC)-XSELA(1,1,IC)
25039 & -XSQEP(1,1,IC)-XSQET(1,1,IC)
25041 XPRO1= XPRO1+EMUFRA(IC)*YPRO
25051 WRITE(LOUT,'(8E9.3)')
25052 & E,XTOT,XELA,XQEP,XQET,XQE2,XPRO,XPRO1
25053 C WRITE(LOUT,'(4E9.3)')
25054 C & E,XDEL,XDQE,XDEL+XDQE
25056 WRITE(LOUT,'(11E10.3)')
25058 & XSTOT(1,1,1),XSELA(1,1,1),XSQEP(1,1,1),XSQET(1,1,1),
25059 & XSQE2(1,1,1),XSPRO(1,1,1),
25060 & XSTOT(1,1,1)-XSELA(1,1,1)-XSQEP(1,1,1)-XSQET(1,1,1)
25061 & -XSQE2(1,1,1),XSDEL(1,1,1),XSDQE(1,1,1),
25062 & XSDEL(1,1,1)+XSDQE(1,1,1)
25063 C WRITE(LOUT,'(4E9.3)') E,XSDEL(1,1,1),XSDQE(1,1,1),
25064 C & XSDEL(1,1,1)+XSDQE(1,1,1)
25068 c IF (IT.GT.1) THEN
25069 c IF (IXSQEL.EQ.0) THEN
25070 cC CALL DT_SIGGA(IT, Q2, E,ZERO,ZERO,
25071 cC CALL DT_SIGGA(IT, E,Q2,ZERO,ZERO,
25072 c CALL DT_SIGGA(IT,ZERO,Q2,ZERO,E,
25073 c & STOT,ETOT,SIN,EIN,STOT0)
25074 c IF (IRATIO.EQ.1) THEN
25075 c CALL DT_SIGGP( Q2, E,ZERO,ZERO,STGP,SIGP,SDGP)
25076 cC CALL DT_SIGGP( E,Q2,ZERO,ZERO,STGP,SIGP,SDGP)
25077 cC CALL DT_SIGGP(ZERO,Q2,ZERO,E,STGP,SIGP,SDGP)
25078 c*!! save cross sections
25083 c STOT = STOT/(DBLE(IT)*STGP)
25084 c SIN = SIN/(DBLE(IT)*SIGP)
25091 c & ' XSTABL: qel. xs. not implemented for nuclei'
25098 c IF (IXSQEL.EQ.0) THEN
25099 c CALL DT_SIGGP(ZERO,Q2,ZERO,E,STOT,SIN,SDIR)
25102 c CALL DT_SIGVEL(ZERO,Q2,ZERO,E,IXSQEL,STOT,SIN,STOT0)
25106 c IF (IT.GT.1) THEN
25107 c IF (IXSQEL.EQ.0) THEN
25108 c CALL DT_SIGGA(IT,ZERO,Q2,E,ZERO,
25109 c & STOT,ETOT,SIN,EIN,STOT0)
25110 c IF (IRATIO.EQ.1) THEN
25111 c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STGP,SIGP,SDGP)
25112 c*!! save cross sections
25117 c STOT = STOT/(DBLE(IT)*STGP)
25118 c SIN = SIN/(DBLE(IT)*SIGP)
25125 c & ' XSTABL: qel. xs. not implemented for nuclei'
25132 c IF (IXSQEL.EQ.0) THEN
25133 c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STOT,SIN,SDIR)
25136 c CALL DT_SIGVEL(ZERO,Q2,E,ZERO,IXSQEL,STOT,SIN,STOT0)
25140 cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,STOTA,ETOTA,STOTP,ZERO
25141 cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,SDIR
25142 cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,STOT0
25143 c WRITE(LOUT,'(1X,6E10.3)')Q2,E,STOT,ETOT,SIN,EIN
25151 *$ CREATE DT_TESTXS.FOR
25154 *===testxs=============================================================*
25156 SUBROUTINE DT_TESTXS
25158 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25161 DIMENSION XSTOT(26,2),XSELA(26,2)
25163 OPEN(10,FILE='testxs_ptot.out',STATUS='UNKNOWN')
25164 OPEN(11,FILE='testxs_pela.out',STATUS='UNKNOWN')
25165 OPEN(12,FILE='testxs_ntot.out',STATUS='UNKNOWN')
25166 OPEN(13,FILE='testxs_nela.out',STATUS='UNKNOWN')
25171 APLABL = LOG10(PLABL)
25172 APLABH = LOG10(PLABH)
25173 ADPLAB = (APLABH-APLABL)/DBLE(NBINS)
25175 ADP = APLABL+DBLE(I-1)*ADPLAB
25178 CALL DT_XSHN(J,1,P,DUMECM,XSTOT(J,1),XSELA(J,1))
25179 CALL DT_XSHN(J,8,P,DUMECM,XSTOT(J,2),XSELA(J,2))
25181 WRITE(10,1000) P,(XSTOT(K,1),K=1,26)
25182 WRITE(11,1000) P,(XSELA(K,1),K=1,26)
25183 WRITE(12,1000) P,(XSTOT(K,2),K=1,26)
25184 WRITE(13,1000) P,(XSELA(K,2),K=1,26)
25186 1000 FORMAT(F8.3,26F9.3)
25191 ************************************************************************
25193 * DTUNUC 2.0: library routines *
25194 * processed by S. Roesler, 6.5.95 *
25196 ************************************************************************
25198 * 1) Handling of parton momenta
25199 * SUBROUTINE MASHEL
25200 * SUBROUTINE DFERMI
25202 * 2) Handling of parton flavors and particle indices
25203 * INTEGER FUNCTION IPDG2B
25204 * INTEGER FUNCTION IB2PDG
25205 * INTEGER FUNCTION IQUARK
25206 * INTEGER FUNCTION IBJQUA
25207 * INTEGER FUNCTION ICIHAD
25208 * INTEGER FUNCTION IPDGHA
25209 * INTEGER FUNCTION MCHAD
25210 * SUBROUTINE FLAHAD
25212 * 3) Energy-momentum and quantum number conservation check routines
25215 * SUBROUTINE EVTEMC
25216 * SUBROUTINE EVTFLC
25217 * SUBROUTINE EVTCHG
25219 * 4) Transformations
25221 * SUBROUTINE LTRANS
25223 * SUBROUTINE DALTRA
25224 * SUBROUTINE DTRAFO
25225 * SUBROUTINE STTRAN
25226 * SUBROUTINE MYTRAN
25227 * SUBROUTINE LT2LAO
25228 * SUBROUTINE LT2LAB
25230 * 5) Sampling from distributions
25231 * INTEGER FUNCTION NPOISS
25232 * DOUBLE PRECISION FUNCTION SAMPXB
25233 * DOUBLE PRECISION FUNCTION SAMPEX
25234 * DOUBLE PRECISION FUNCTION SAMSQX
25235 * DOUBLE PRECISION FUNCTION BETREJ
25236 * DOUBLE PRECISION FUNCTION DGAMRN
25237 * DOUBLE PRECISION FUNCTION DBETAR
25238 * SUBROUTINE RANNOR
25240 * SUBROUTINE DSFECF
25243 * 6) Special functions, algorithms and service routines
25244 * DOUBLE PRECISION FUNCTION YLAMB
25247 * SUBROUTINE DT_XTIME
25249 * 7) Random number generator package
25250 * DOUBLE PRECISION FUNCTION DT_RNDM
25251 * SUBROUTINE DT_RNDMST
25252 * SUBROUTINE DT_RNDMIN
25253 * SUBROUTINE DT_RNDMOU
25254 * SUBROUTINE DT_RNDMTE
25256 ************************************************************************
25258 * 1) Handling of parton momenta *
25260 ************************************************************************
25261 *$ CREATE DT_MASHEL.FOR
25264 *===mashel=============================================================*
25266 SUBROUTINE DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
25268 ************************************************************************
25270 * rescaling of momenta of two partons to put both *
25273 * input: PA1,PA2 input momentum vectors *
25274 * XM1,2 desired masses of particles afterwards *
25275 * P1,P2 changed momentum vectors *
25277 * The original version is written by R. Engel. *
25278 * This version dated 12.12.94 is modified by S. Roesler. *
25279 ************************************************************************
25281 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25283 PARAMETER ( LINP = 10 ,
25286 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
25288 DIMENSION PA1(4),PA2(4),P1(4),P2(4)
25292 * Lorentz transformation into system CMS
25297 XPTOT = SQRT(PX**2+PY**2+PZ**2)
25298 XMS = (EE-XPTOT)*(EE+XPTOT)
25299 IF(XMS.LT.(XM1+XM2)**2) THEN
25300 C WRITE(LOUT,'(3E12.4)')XMS,XM1,XM2
25308 CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
25309 & PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
25312 C SID = SQRT((ONE-COD)*(ONE+COD))
25313 PPT = SQRT(P1(1)**2+P1(2)**2)
25317 IF(PTOT1*SID.GT.TINY10) THEN
25318 COF = P1(1)/(SID*PTOT1)
25319 SIF = P1(2)/(SID*PTOT1)
25320 ANORF = SQRT(COF*COF+SIF*SIF)
25324 * new CM momentum and energies (for masses XM1,XM2)
25325 XM12 = SIGN(XM1**2,XM1)
25326 XM22 = SIGN(XM2**2,XM2)
25328 PCMP = DT_YLAMB(SS,XM12,XM22)/(2.D0*XMS)
25329 EE1 = SQRT(XM12+PCMP**2)
25333 CALL DT_MYTRAN(MODE,ZERO,ZERO,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
25334 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
25335 & PTOT1,P1(1),P1(2),P1(3),P1(4))
25336 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
25337 & PTOT2,P2(1),P2(2),P2(3),P2(4))
25338 * check consistency
25340 IF (ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
25342 ELSEIF (ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
25344 ELSEIF (ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
25346 ELSEIF (ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
25351 IF (IDEV.NE.0) THEN
25352 WRITE(LOUT,'(/1X,A,I3)')
25353 & 'MASHEL: inconsistent transformation',IDEV
25354 WRITE(LOUT,'(1X,A)') 'MASHEL: input momenta/masses:'
25355 WRITE(LOUT,'(1X,5E12.5)') (PA1(K),K=1,4),XM1
25356 WRITE(LOUT,'(1X,5E12.5)') (PA2(K),K=1,4),XM2
25357 WRITE(LOUT,'(1X,A)') 'MASHEL: output momenta:'
25358 WRITE(LOUT,'(5X,4E12.5)') (P1(K),K=1,4)
25359 WRITE(LOUT,'(5X,4E12.5)') (P2(K),K=1,4)
25368 *$ CREATE DT_DFERMI.FOR
25371 *===dfermi=============================================================*
25373 SUBROUTINE DT_DFERMI(GPART)
25375 ************************************************************************
25376 * Find largest of three random numbers. *
25377 ************************************************************************
25379 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25385 G(I)=DT_RNDM(GPART)
25387 IF (G(3).LT.G(2)) GOTO 40
25388 IF (G(3).LT.G(1)) GOTO 30
25393 40 IF (G(2).LT.G(1)) GOTO 30
25399 ************************************************************************
25401 * 2) Handling of parton flavors and particle indices *
25403 ************************************************************************
25404 *$ CREATE IDT_IPDG2B.FOR
25407 *===ipdg2b=============================================================*
25409 INTEGER FUNCTION IDT_IPDG2B(ID,NN,MODE)
25411 ************************************************************************
25413 * conversion of quark numbering scheme *
25415 * input: PDG parton numbering *
25416 * for diquarks: NN number of the constituent quark *
25417 * (e.g. ID=2301,NN=1 -> ICONV2=1) *
25419 * output: BAMJET particle codes *
25420 * 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) *
25421 * 2 d 8 a-d -2 a-d *
25422 * 3 s 9 a-s -3 a-s *
25423 * 4 c 10 a-c -4 a-c *
25425 * This is a modified version of ICONV2 written by R. Engel. *
25426 * This version dated 13.12.94 is written by S. Roesler. *
25427 ************************************************************************
25429 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25431 PARAMETER ( LINP = 10 ,
25439 IF (IDA.GE.1000) KF = 4
25440 IDA = IDA/(10**(KF-NN))
25443 * exchange up and dn quarks
25446 ELSEIF (IDA.EQ.2) THEN
25451 IF (MODE.EQ.1) THEN
25462 *$ CREATE IDT_IB2PDG.FOR
25465 *===ib2pdg=============================================================*
25467 INTEGER FUNCTION IDT_IB2PDG(ID1,ID2,MODE)
25469 ************************************************************************
25471 * conversion of quark numbering scheme *
25473 * input: BAMJET particle codes *
25474 * 1 u 7 a-u (MODE=1) -1 a-u (MODE=2) *
25475 * 2 d 8 a-d -2 a-d *
25476 * 3 s 9 a-s -3 a-s *
25477 * 4 c 10 a-c -4 a-c *
25479 * output: PDG parton numbering *
25481 * This version dated 13.12.94 is written by S. Roesler. *
25482 ************************************************************************
25484 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25486 PARAMETER ( LINP = 10 ,
25490 DIMENSION IHKKQ(-6:6),IHKKQQ(-3:3,-3:3)
25491 DATA IHKKQ/-6,-5,-4,-3,-1,-2,0,2,1,3,4,5,6/
25492 DATA IHKKQQ/-3303,-3103,-3203,0,0,0,0, -3103,-1103,-2103,0,0,0,0,
25493 &-3203,-2103,-2203,0,0,0,0, 0,0,0,0,0,0,0, 0,0,0,0,2203,2103,3203,
25494 &0,0,0,0,2103,1103,3103, 0,0,0,0,3203,3103,3303/
25498 IF (MODE.EQ.1) THEN
25499 IF (ID1.GT.6) IDA = -(ID1-6)
25500 IF (ID2.GT.6) IDB = -(ID2-6)
25503 IDT_IB2PDG = IHKKQ(IDA)
25505 IDT_IB2PDG = IHKKQQ(IDA,IDB)
25511 *$ CREATE IDT_IQUARK.FOR
25514 *===ipdgqu=============================================================*
25516 INTEGER FUNCTION IDT_IQUARK(K,IDBAMJ)
25518 ************************************************************************
25520 * quark contents according to PDG conventions *
25521 * (random selection in case of quark mixing) *
25523 * input: IDBAMJ BAMJET particle code *
25524 * K 1..3 quark number *
25526 * output: 1 d (anti --> neg.) *
25531 * This version written by R. Engel. *
25532 ************************************************************************
25534 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25537 IQ = IDT_IBJQUA(K,IDBAMJ)
25542 * exchange of up and down
25543 IF (ABS(IQ).EQ.1) THEN
25545 ELSEIF (ABS(IQ).EQ.2) THEN
25553 *$ CREATE IDT_IBJQUA.FOR
25556 *===ibamq==============================================================*
25558 INTEGER FUNCTION IDT_IBJQUA(K,IDBAMJ)
25560 ************************************************************************
25562 * quark contents according to BAMJET conventions *
25563 * (random selection in case of quark mixing) *
25565 * input: IDBAMJ BAMJET particle code *
25566 * K 1..3 quark number *
25568 * output: 1 u 7 u bar *
25573 * This version written by R. Engel. *
25574 ************************************************************************
25576 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25579 DIMENSION ITAB(3,210)
25580 DATA ((ITAB(I,K),I=1,3),K=1,30) /
25581 & 1, 1, 2, 7, 7, 8, 0, 0, 0,
25582 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25583 & 0, 0, 0, 1, 2, 2, 7, 8, 8,
25585 C & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25586 & 0, 0, 0, 0, 0, 0, 3, 8, 0,
25588 & 1, 8, 0, 2, 7, 0, 1, 9, 0,
25590 C & 3, 7, 0, 0, 0, 0, 0, 0, 0,
25591 & 3, 7, 0, 3, 1, 2, 9, 7, 8,
25593 C & 0, 0, 0, 2, 2, 3, 1, 1, 3,
25594 & 2, 9, 0, 2, 2, 3, 1, 1, 3,
25596 & 1, 2, 3, 201,202, 0, 2, 9, 0,
25597 & 3, 8, 0, 0, 0, 0, 0, 0, 0,
25598 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25599 DATA ((ITAB(I,K),I=1,3),K=31,60) /
25600 & 3, 9, 0, 1, 8, 0, 203,204, 0,
25601 & 2, 7, 0, 0, 0, 0, 1, 9, 0,
25602 & 2, 9, 0, 3, 7, 0, 3, 8, 0,
25603 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25604 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25605 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25606 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25607 & 0, 0, 0, 1, 1, 1, 1, 1, 2,
25608 & 1, 2, 2, 2, 2, 2, 0, 0, 0,
25609 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25610 DATA ((ITAB(I,K),I=1,3),K=61,90) /
25611 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25612 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25613 & 7, 7, 7, 7, 7, 8, 7, 8, 8,
25614 & 8, 8, 8, 0, 0, 0, 0, 0, 0,
25615 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25616 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25617 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25618 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25619 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25620 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25621 DATA ((ITAB(I,K),I=1,3),K=91,120) /
25622 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25623 & 0, 0, 0, 0, 0, 0, 3, 9, 0,
25624 & 1, 3, 3, 2, 3, 3, 7, 7, 9,
25625 & 7, 8, 9, 8, 8, 9, 7, 9, 9,
25626 & 8, 9, 9, 1, 1, 3, 1, 2, 3,
25627 & 2, 2, 3, 1, 3, 3, 2, 3, 3,
25628 & 3, 3, 3, 7, 7, 9, 7, 8, 9,
25629 & 8, 8, 9, 7, 9, 9, 8, 9, 9,
25630 & 9, 9, 9, 4, 7, 0, 4, 8, 0,
25631 & 2, 10, 0, 1, 10, 0, 4, 9, 0 /
25632 DATA ((ITAB(I,K),I=1,3),K=121,150) /
25633 & 3, 10, 0, 4, 10, 0, 4, 7, 0,
25634 & 4, 8, 0, 2, 10, 0, 1, 10, 0,
25635 & 4, 9, 0, 3, 10, 0, 4, 10, 0,
25636 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25637 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25638 & 0, 0, 0, 1, 2, 4, 1, 3, 4,
25639 & 2, 3, 4, 1, 1, 4, 0, 0, 0,
25640 & 2, 2, 4, 0, 0, 0, 0, 0, 0,
25641 & 3, 3, 4, 1, 4, 4, 2, 4, 4,
25642 & 3, 4, 4, 7, 8, 10, 7, 9, 10 /
25643 DATA ((ITAB(I,K),I=1,3),K=151,180) /
25644 & 8, 9, 10, 7, 7, 10, 0, 0, 0,
25645 & 8, 8, 10, 0, 0, 0, 0, 0, 0,
25646 & 9, 9, 10, 7, 10, 10, 8, 10, 10,
25647 & 9, 10, 10, 1, 1, 4, 1, 2, 4,
25648 & 2, 2, 4, 1, 3, 4, 2, 3, 4,
25649 & 3, 3, 4, 1, 4, 4, 2, 4, 4,
25650 & 3, 4, 4, 4, 4, 4, 7, 7, 10,
25651 & 7, 8, 10, 8, 8, 10, 7, 9, 10,
25652 & 8, 9, 10, 9, 9, 10, 7, 10, 10,
25653 & 8, 10, 10, 9, 10, 10, 10, 10, 10 /
25654 DATA ((ITAB(I,K),I=1,3),K=181,210) /
25655 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25656 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25657 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25658 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25659 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25660 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25661 & 0, 0, 0, 0, 0, 0, 1, 7, 0,
25662 & 2, 8, 0, 1, 7, 0, 2, 8, 0,
25663 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
25664 & 0, 0, 0, 0, 0, 0, 0, 0, 0 /
25668 IF (ITAB(1,IDBAMJ).LE.200) THEN
25669 ID = ITAB(K,IDBAMJ)
25671 IF(IDOLD.NE.IDBAMJ) THEN
25672 IT = AINT((ITAB(2,IDBAMJ)-ITAB(1,IDBAMJ)+0.999999D0)*
25673 & DT_RNDM(ONE)+ITAB(1,IDBAMJ))
25685 *$ CREATE IDT_ICIHAD.FOR
25688 *===icihad=============================================================*
25690 INTEGER FUNCTION IDT_ICIHAD(MCIND)
25692 ************************************************************************
25693 * Conversion of particle index PDG proposal --> BAMJET-index scheme *
25694 * This is a completely new version dated 25.10.95. *
25695 * Renamed to be not in conflict with the modified PHOJET-version *
25696 ************************************************************************
25698 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25701 * hadron index conversion (BAMJET <--> PDG)
25702 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25703 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25708 IF ((KPDG.EQ.0).OR.(KPDG.GT.70000)) RETURN
25709 IF (MCIND.LT.0) THEN
25714 IF (KPDG.GE.10000) THEN
25716 IDT_ICIHAD = IBAM5(JSIGN,I)
25717 IF (IPDG5(JSIGN,I).EQ.MCIND) GOTO 5
25720 ELSEIF (KPDG.GE.1000) THEN
25722 IDT_ICIHAD = IBAM4(JSIGN,I)
25723 IF (IPDG4(JSIGN,I).EQ.MCIND) GOTO 5
25726 ELSEIF (KPDG.GE.100) THEN
25728 IDT_ICIHAD = IBAM3(JSIGN,I)
25729 IF (IPDG3(JSIGN,I).EQ.MCIND) GOTO 5
25732 ELSEIF (KPDG.GE.10) THEN
25734 IDT_ICIHAD = IBAM2(JSIGN,I)
25735 IF (IPDG2(JSIGN,I).EQ.MCIND) GOTO 5
25744 *$ CREATE IDT_IPDGHA.FOR
25747 *===ipdgha=============================================================*
25749 INTEGER FUNCTION IDT_IPDGHA(MCIND)
25751 ************************************************************************
25752 * Conversion of particle index BAMJET-index scheme --> PDG proposal *
25753 * Adopted from the original by S. Roesler. This version dated 12.5.95 *
25754 * Renamed to be not in conflict with the modified PHOJET-version *
25755 ************************************************************************
25757 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25760 * hadron index conversion (BAMJET <--> PDG)
25761 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25762 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25765 IDT_IPDGHA = IAMCIN(MCIND)
25770 *$ CREATE DT_FLAHAD.FOR
25773 *===flahad=============================================================*
25775 SUBROUTINE DT_FLAHAD(ID,IF1,IF2,IF3)
25777 ************************************************************************
25778 * sampling of FLAvor composition for HADrons/photons *
25779 * ID BAMJET-id of hadron *
25780 * IF1,2,3 flavor content *
25781 * (u,d,s: 1,2,3; au,ad,as: -1,-1,-3) *
25782 * Note: - u,d numbering as in BAMJET *
25783 * - ID .le. 30 !! *
25784 * This version dated 12.03.96 is written by S. Roesler *
25785 ************************************************************************
25787 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25790 * auxiliary common for reggeon exchange (DTUNUC 1.x)
25791 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
25792 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
25793 & IQTCHR(-6:6),MQUARK(3,39)
25795 DIMENSION JSEL(3,6)
25796 DATA JSEL/ 1,2,3, 2,3,1, 3,1,2, 1,3,2, 2,1,3, 3,2,1/
25800 * photon (charge dependent flavour sampling)
25801 K = INT(DT_RNDM(ONE)*6.D0+1.D0)
25805 ELSE IF(K.EQ.5) THEN
25812 IF(DT_RNDM(ONE).LT.0.5D0) THEN
25820 IX = INT(1.0D0+5.99999D0*DT_RNDM(ONE))
25821 IF1 = MQUARK(JSEL(1,IX),ID)
25822 IF2 = MQUARK(JSEL(2,IX),ID)
25823 IF3 = MQUARK(JSEL(3,IX),ID)
25824 IF ((IF1.EQ.0).AND.(IF3.NE.0)) THEN
25827 ELSEIF ((IF2.EQ.0).AND.(IF3.NE.0)) THEN
25836 *$ CREATE IDT_MCHAD.FOR
25839 *===mchad==============================================================*
25841 INTEGER FUNCTION IDT_MCHAD(ITDTU)
25843 ************************************************************************
25844 * Conversion of particle index BAMJET-index scheme --> HADRIN index s. *
25845 * Adopted from the original by S. Roesler. This version dated 6.5.95 *
25847 * Last change 28.12.2006 by S. Roesler. *
25848 ************************************************************************
25850 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25853 DIMENSION ITRANS(210)
25854 DATA ITRANS / 1, 2, -1, -1, -1, -1, -1, 8, 9, -1, -1, 24, 13, 14,
25855 &15, 16, 8, 9, 25, 8, 1, 8, 23, 24, 25, -1, -1, -1, -1, -1, 23, 13,
25856 &23, 14, 23, 15, 24, 16, 25, 15, 24, 16, 25, 15, 24, 16, 25, 1, 8,
25857 &8, 8, 1, 1, 1, 8, 8, 1, 1, 8, 8, 1, 8, 1, 8, 1, 8, 2, 2, 9, 9, 2,
25858 &2, 9, 9, 2, 9, 1, 13, 23, 14, 1, 1, 8, 8, 1, 1, 23, 14, 1, 8, 1,
25859 &8, 1, 8, 23, 23, 8, 8, 2, 9, 9, 9, 9, 1, 8, 8, 8, 8, 8, 2, 9, 9,
25860 &9, 9, 9, 85*- 1,7*-1,1,8,-1/
25862 IF ( ITDTU .GT. 0 ) THEN
25863 IDT_MCHAD = ITRANS(ITDTU)
25871 ************************************************************************
25873 * 3) Energy-momentum and quantum number conservation check routines *
25875 ************************************************************************
25876 *$ CREATE DT_EMC1.FOR
25879 *===emc1===============================================================*
25881 SUBROUTINE DT_EMC1(PP1,PP2,PT1,PT2,MODE,IPOS,IREJ)
25883 ************************************************************************
25884 * This version dated 15.12.94 is written by S. Roesler *
25885 ************************************************************************
25887 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25889 PARAMETER ( LINP = 10 ,
25892 PARAMETER (TINY10=1.0D-10)
25894 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
25898 IF ((MODE.EQ.0).OR.(ABS(MODE).GT.3))
25899 & WRITE(LOUT,'(1X,A,I6)')'EMC1: not supported MODE ',MODE
25901 IF ((MODE.GT.0).AND.(MODE.LT.3)) THEN
25902 IF (MODE.EQ.1) THEN
25903 CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),1,IDUM,IDUM)
25904 ELSEIF (MODE.EQ.2) THEN
25905 CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),2,IDUM,IDUM)
25907 CALL DT_EVTEMC(PP2(1),PP2(2),PP2(3),PP2(4),2,IDUM,IDUM)
25908 CALL DT_EVTEMC(PT1(1),PT1(2),PT1(3),PT1(4),2,IDUM,IDUM)
25909 CALL DT_EVTEMC(PT2(1),PT2(2),PT2(3),PT2(4),2,IDUM,IDUM)
25910 ELSEIF (MODE.LT.0) THEN
25911 IF (MODE.EQ.-1) THEN
25912 CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),1,IDUM,IDUM)
25913 ELSEIF (MODE.EQ.-2) THEN
25914 CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),2,IDUM,IDUM)
25916 CALL DT_EVTEMC(-PP2(1),-PP2(2),-PP2(3),-PP2(4),2,IDUM,IDUM)
25917 CALL DT_EVTEMC(-PT1(1),-PT1(2),-PT1(3),-PT1(4),2,IDUM,IDUM)
25918 CALL DT_EVTEMC(-PT2(1),-PT2(2),-PT2(3),-PT2(4),2,IDUM,IDUM)
25921 IF (ABS(MODE).EQ.3) THEN
25922 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,IPOS,IREJ1)
25923 IF (IREJ1.NE.0) GOTO 9999
25932 *$ CREATE DT_EMC2.FOR
25935 *===emc2===============================================================*
25937 SUBROUTINE DT_EMC2(IP1,IP2,IP3,IP4,IP5,MP,IN1,IN2,IN3,IN4,IN5,MN,
25940 ************************************************************************
25941 * MODE = 1 energy-momentum cons. check *
25942 * = 2 flavor-cons. check *
25943 * = 3 energy-momentum & flavor cons. check *
25944 * = 4 energy-momentum & charge cons. check *
25945 * = 5 energy-momentum & flavor & charge cons. check *
25946 * This version dated 16.01.95 is written by S. Roesler *
25947 ************************************************************************
25949 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25951 PARAMETER ( LINP = 10 ,
25954 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
25957 PARAMETER (NMXHKK=200000)
25958 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25959 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25960 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25961 * extended event history
25962 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
25963 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
25971 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25972 & CALL DT_EVTEMC(ZERO,ZERO,ZERO,ZERO,1,IDUM,IDUM)
25973 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25974 & CALL DT_EVTFLC(0,IDUM,1,IDUM,IDUM)
25975 IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,1,IDUM,IDUM)
25977 IF ((ISTHKK(I).EQ.IP1).OR.(ISTHKK(I).EQ.IP2).OR.
25978 & (ISTHKK(I).EQ.IP3).OR.(ISTHKK(I).EQ.IP4).OR.
25979 & (ISTHKK(I).EQ.IP5)) THEN
25980 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25982 & CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
25984 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25985 & CALL DT_EVTFLC(IDHKK(I),MP,2,IDUM,IDUM)
25986 IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25987 & CALL DT_EVTCHG(IDHKK(I),2,IDUM,IDUM)
25989 IF ((ISTHKK(I).EQ.IN1).OR.(ISTHKK(I).EQ.IN2).OR.
25990 & (ISTHKK(I).EQ.IN3).OR.(ISTHKK(I).EQ.IN4).OR.
25991 & (ISTHKK(I).EQ.IN5)) THEN
25992 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25994 & CALL DT_EVTEMC(-PHKK(1,I),-PHKK(2,I),-PHKK(3,I),-PHKK(4,I),
25996 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25997 & CALL DT_EVTFLC(IDHKK(I),MN,-2,IDUM,IDUM)
25998 IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25999 & CALL DT_EVTCHG(IDHKK(I),-2,IDUM,IDUM)
26002 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
26003 & CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,IPOS,IREJ1)
26004 IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
26005 & CALL DT_EVTFLC(0,IDUM,3,IPOS,IREJ2)
26006 IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,3,IPOS,IREJ3)
26007 IF ((IREJ1.NE.0).OR.(IREJ2.NE.0).OR.(IREJ3.NE.0)) GOTO 9999
26016 *$ CREATE DT_EVTEMC.FOR
26019 *===evtemc=============================================================*
26021 SUBROUTINE DT_EVTEMC(PXIO,PYIO,PZIO,EIO,IMODE,IPOS,IREJ)
26023 ************************************************************************
26024 * This version dated 13.12.94 is written by S. Roesler *
26025 ************************************************************************
26027 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26029 PARAMETER ( LINP = 10 ,
26032 PARAMETER (TINY1=1.0D-1,TINY2=1.0D-2,TINY4=1.0D-4,TINY10=1.0D-10,
26036 PARAMETER (NMXHKK=200000)
26037 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26038 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26039 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26040 * flags for input different options
26041 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
26042 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
26043 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
26049 IF (MODE.EQ.4) THEN
26052 ELSEIF (MODE.EQ.5) THEN
26055 ELSEIF (MODE.EQ.-1) THEN
26060 IF (ABS(MODE).EQ.3) THEN
26065 IF ((IFRAG(1).EQ.2).AND.(CHKLEV.LT.TINY4)) CHKLEV = TINY4
26066 IF ((ABS(PXDEV).GT.CHKLEV).OR.(ABS(PYDEV).GT.CHKLEV).OR.
26067 & (ABS(PZDEV).GT.CHKLEV).OR.(ABS(EDEV).GT.CHKLEV)) THEN
26068 IF (IOULEV(2).GT.0) WRITE(LOUT,'(1X,A,I4,A,I8,A,/,4G10.3)')
26069 & 'EVTEMC: energy-momentum cons. failure at pos. ',IPOS,
26070 & ' event ',NEVHKK,
26071 & ' ! ',PXDEV,PYDEV,PZDEV,EDEV
26085 IF (MODE.EQ.1) THEN
26104 *$ CREATE DT_EVTFLC.FOR
26107 *===evtflc=============================================================*
26109 SUBROUTINE DT_EVTFLC(ID,ID1,MODE,IPOS,IREJ)
26111 ************************************************************************
26112 * Flavor conservation check. *
26113 * ID identity of particle *
26114 * ID1 = 1 ID for q,aq,qq,aqaq in PDG-numbering scheme *
26115 * = 2 ID for particle/resonance in BAMJET numbering scheme *
26116 * = 3 ID for particle/resonance in PDG numbering scheme *
26117 * MODE = 1 initialization and add ID *
26118 * =-1 initialization and subtract ID *
26120 * =-2 subtract ID *
26121 * = 3 check flavor cons. *
26122 * IPOS flag to give position of call of EVTFLC to output *
26123 * unit in case of violation *
26124 * This version dated 10.01.95 is written by S. Roesler *
26125 ************************************************************************
26127 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26129 PARAMETER ( LINP = 10 ,
26132 PARAMETER (TINY10=1.0D-10)
26136 IF (MODE.EQ.3) THEN
26138 WRITE(LOUT,'(1X,A,I3,A,I3)')
26139 & 'EVTFLC: flavor-conservation failure at pos. ',IPOS,
26148 IF (MODE.EQ.1) IFL = 0
26149 IF (ID.EQ.0) RETURN
26154 IF ((IDD.GE.100).AND.(IDD.LT.1000)) NQ = 2
26155 IF (IDD.GE.1000) NQ = 3
26157 IFBAM = IDT_IPDG2B(ID,I,2)
26158 IF (ABS(IFBAM).EQ.1) THEN
26159 IFBAM = SIGN(2,IFBAM)
26160 ELSEIF (ABS(IFBAM).EQ.2) THEN
26161 IFBAM = SIGN(1,IFBAM)
26163 IF (MODE.GT.0) THEN
26173 IF (ID1.EQ.3) IDD = IDT_ICIHAD(ID)
26174 IF ((ID1.EQ.2).OR.(ID1.EQ.3)) THEN
26176 IF (MODE.GT.0) THEN
26177 IFL = IFL+IDT_IQUARK(I,IDD)
26179 IFL = IFL-IDT_IQUARK(I,IDD)
26190 *$ CREATE DT_EVTCHG.FOR
26193 *===evtchg=============================================================*
26195 SUBROUTINE DT_EVTCHG(ID,MODE,IPOS,IREJ)
26197 ************************************************************************
26198 * Charge conservation check. *
26199 * ID identity of particle (PDG-numbering scheme) *
26200 * MODE = 1 initialization *
26201 * =-2 subtract ID-charge *
26202 * = 2 add ID-charge *
26203 * = 3 check charge cons. *
26204 * IPOS flag to give position of call of EVTCHG to output *
26205 * unit in case of violation *
26206 * This version dated 10.01.95 is written by S. Roesler *
26207 * Last change: s.r. 21.01.01 *
26208 ************************************************************************
26210 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26212 PARAMETER ( LINP = 10 ,
26217 PARAMETER (NMXHKK=200000)
26218 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26219 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26220 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26221 * particle properties (BAMJET index convention)
26223 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26224 & IICH(210),IIBAR(210),K1(210),K2(210)
26228 IF (MODE.EQ.1) THEN
26234 IF (MODE.EQ.3) THEN
26235 IF ((ICH.NE.0).OR.(IBAR.NE.0)) THEN
26236 WRITE(LOUT,'(1X,A,I3,A,2I3,A,I8)')
26237 & 'EVTCHG: charge/baryo.-cons. failure at pos. ',IPOS,
26238 & '! ICH/IBAR= ',ICH,IBAR,' event ',NEVHKK
26248 IF (ID.EQ.0) RETURN
26250 IDD = IDT_ICIHAD(ID)
26251 * modification 21.1.01: use intrinsic phojet-functions to determine charge
26252 * and baryon number
26253 C IF (IDD.GT.0) THEN
26254 C IF (MODE.EQ.2) THEN
26255 C ICH = ICH+IICH(IDD)
26256 C IBAR = IBAR+IIBAR(IDD)
26257 C ELSEIF (MODE.EQ.-2) THEN
26258 C ICH = ICH-IICH(IDD)
26259 C IBAR = IBAR-IIBAR(IDD)
26262 C WRITE(LOUT,'(1X,A,3I6)') 'EVTCHG: (IDD = 0 !), IDD,ID=',IDD,ID
26263 C CALL DT_EVTOUT(4)
26266 IF (MODE.EQ.2) THEN
26267 ICH = ICH+IPHO_CHR3(ID,1)/3
26268 IBAR = IBAR+IPHO_BAR3(ID,1)/3
26269 ELSEIF (MODE.EQ.-2) THEN
26270 ICH = ICH-IPHO_CHR3(ID,1)/3
26271 IBAR = IBAR-IPHO_BAR3(ID,1)/3
26281 ************************************************************************
26283 * 4) Transformations *
26285 ************************************************************************
26286 *$ CREATE DT_LTINI.FOR
26289 *===ltini==============================================================*
26291 SUBROUTINE DT_LTINI(IDPR,IDTA,EPN0,PPN0,ECM0,MODE)
26293 ************************************************************************
26294 * Initializations of Lorentz-transformations, calculation of Lorentz- *
26296 * This version dated 13.11.95 is written by S. Roesler. *
26297 ************************************************************************
26299 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26301 PARAMETER ( LINP = 10 ,
26304 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,
26305 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
26307 * Lorentz-parameters of the current interaction
26308 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26309 & UMO,PPCM,EPROJ,PPROJ
26310 * properties of photon/lepton projectiles
26311 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
26312 * particle properties (BAMJET index convention)
26314 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26315 & IICH(210),IIBAR(210),K1(210),K2(210)
26316 * nucleon-nucleon event-generator
26319 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
26323 IF (MCGENE.NE.3) THEN
26324 * lepton-projectiles and PHOJET: initialize real photon instead
26325 IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26326 & (IDPR.EQ.10).OR.(IDPR.EQ.11).OR.
26327 & (IDPR.EQ. 5).OR.(IDPR.EQ. 6)) THEN
26336 AMP = AAM(IDP)-SQRT(ABS(Q2))
26338 AMP2 = SIGN(AMP**2,AMP)
26340 IF (ECM0.GT.ZERO) THEN
26341 EPN = (ECM**2-AMP2-AMT2)/(TWO*AMT)
26342 IF (AMP2.GT.ZERO) THEN
26343 PPN = SQRT((EPN+AMP)*(EPN-AMP))
26345 PPN = SQRT(EPN**2-AMP2)
26348 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26349 IF (IDP.EQ.7) EPN = ABS(EPN)
26350 IF (EPN.LT.ZERO) EPN = ABS(EPN)+AMP
26351 IF (AMP2.GT.ZERO) THEN
26352 PPN = SQRT((EPN+AMP)*(EPN-AMP))
26354 PPN = SQRT(EPN**2-AMP2)
26356 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26357 IF (AMP2.GT.ZERO) THEN
26358 EPN = PPN*SQRT(ONE+(AMP/PPN)**2)
26360 EPN = SQRT(PPN**2+AMP2)
26363 ECM = SQRT(AMP2+AMT2+TWO*AMT*EPN)
26368 IF (AMP2.GT.ZERO) THEN
26369 ETARG = (ECM**2-AMP2-AMT2)/(TWO*AMP)
26370 PTARG = -SQRT((ETARG+AMT)*(ETARG-AMT))
26375 * photon-projectiles (get momentum in cm-frame for virtuality Q^2)
26381 IF (ECM0.GT.ZERO) THEN
26384 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26385 S = AMGAM2+AMT2+TWO*AMT*ABS(EPN0)
26386 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26387 S = AMGAM2+AMT2+TWO*AMT*SQRT(PPN0**2+AMGAM2)
26390 PGAMM(3) = SQRT( (S**2-TWO*AMGAM2*S-TWO*AMT2*S-TWO*AMGAM2*AMT2
26391 & +AMGAM2**2+AMT2**2)/(4.0D0*S) )
26392 PGAMM(4) = SQRT(AMGAM2+PGAMM(3)**2)
26393 IF (MODE.EQ.1) THEN
26396 PNUCL(3) = -PGAMM(3)
26397 PNUCL(4) = SQRT(S)-PGAMM(4)
26400 IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26401 & (IDPR.EQ.10).OR.(IDPR.EQ.11)) THEN
26404 * neglect lepton masses
26405 C AMLPT2 = AAM(IDPR)**2
26408 IF (ECM0.GT.ZERO) THEN
26411 IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26412 S = AMLPT2+AMT2+TWO*AMT*ABS(EPN0)
26413 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26414 S = AMLPT2+AMT2+TWO*AMT*SQRT(PPN0**2+AMLPT2)
26417 PLEPT0(3) = SQRT( (S**2-TWO*AMLPT2*S-TWO*AMT2*S-TWO*AMLPT2*AMT2
26418 & +AMLPT2**2+AMT2**2)/(4.0D0*S) )
26419 PLEPT0(4) = SQRT(AMLPT2+PLEPT0(3)**2)
26422 PNUCL(3) = -PLEPT0(3)
26423 PNUCL(4) = SQRT(S)-PLEPT0(4)
26425 * Lorentz-parameter for transformation Lab. - projectile rest system
26426 IF ((IDP.EQ.7).OR.(AMP.LT.TINY10)) THEN
26435 * Lorentz-parameter for transf. proj. rest sys. - nucl.-nucl. cms.
26440 GACMS(1) = (ETARG+AMP)/UMO
26441 BGCMS(1) = PTARG/UMO
26443 * Lorentz-parameter for transformation Lab. - nucl.-nucl. cms.
26444 GACMS(2) = (EPROJ+AMT)/UMO
26445 BGCMS(2) = PPROJ/UMO
26446 PPCM = GACMS(2)*PPROJ-BGCMS(2)*EPROJ
26455 *$ CREATE DT_LTRANS.FOR
26458 *===ltrans=============================================================*
26460 SUBROUTINE DT_LTRANS(PXI,PYI,PZI,PEI,PXO,PYO,PZO,PEO,ID,MODE)
26462 ************************************************************************
26463 * Lorentz-transformations. *
26464 * MODE = 1(-1) projectile rest syst. --> Lab (back) *
26465 * = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) *
26466 * = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) *
26467 * This version dated 01.11.95 is written by S. Roesler. *
26468 ************************************************************************
26470 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26472 PARAMETER ( LINP = 10 ,
26475 PARAMETER (TINY3=1.0D-3,ZERO=0.0D0,TWO=2.0D0)
26477 PARAMETER (SQTINF=1.0D+15)
26479 * particle properties (BAMJET index convention)
26481 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26482 & IICH(210),IIBAR(210),K1(210),K2(210)
26486 CALL DT_LTNUC(PZI,PEI,PZO,PEO,MODE)
26488 * check particle mass for consistency (numerical rounding errors)
26489 PO = SQRT(PXO*PXO+PYO*PYO+PZO*PZO)
26490 AMO2 = (PEO-PO)*(PEO+PO)
26491 AMORQ2 = AAM(ID)**2
26492 AMDIF2 = ABS(AMO2-AMORQ2)
26493 IF ((AMDIF2.GT.TINY3).AND.(PEO.LT.SQTINF).AND.(PO.GT.ZERO)) THEN
26494 DELTA = (AMORQ2-AMO2)/(TWO*(PEO+PO))
26500 C WRITE(6,*) 'LTRANS corrected', AMDIF2,PZI,PEI,PZO,PEO,MODE,ID
26506 *$ CREATE DT_LTNUC.FOR
26509 *===ltnuc==============================================================*
26511 SUBROUTINE DT_LTNUC(PIN,EIN,POUT,EOUT,MODE)
26513 ************************************************************************
26514 * Lorentz-transformations. *
26515 * PIN longitudnal momentum (input) *
26516 * EIN energy (input) *
26517 * POUT transformed long. momentum (output) *
26518 * EOUT transformed energy (output) *
26519 * MODE = 1(-1) projectile rest syst. --> Lab (back) *
26520 * = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) *
26521 * = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) *
26522 * This version dated 01.11.95 is written by S. Roesler. *
26523 ************************************************************************
26525 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26527 PARAMETER ( LINP = 10 ,
26530 PARAMETER (ZERO=0.0D0)
26532 * Lorentz-parameters of the current interaction
26533 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26534 & UMO,PPCM,EPROJ,PPROJ
26540 IF (ABS(MODE).EQ.1) THEN
26541 BG = -SIGN(BGLAB,DBLE(MODE))
26542 CALL DT_DALTRA(GALAB,BDUM1,BDUM2,-BG,PDUM1,PDUM2,PIN,EIN,
26543 & DUM1,DUM2,DUM3,POUT,EOUT)
26544 ELSEIF (ABS(MODE).EQ.2) THEN
26545 BG = SIGN(BGCMS(1),DBLE(MODE))
26546 CALL DT_DALTRA(GACMS(1),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26547 & DUM1,DUM2,DUM3,POUT,EOUT)
26548 ELSEIF (ABS(MODE).EQ.3) THEN
26549 BG = -SIGN(BGCMS(2),DBLE(MODE))
26550 CALL DT_DALTRA(GACMS(2),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26551 & DUM1,DUM2,DUM3,POUT,EOUT)
26553 WRITE(LOUT,1000) MODE
26554 1000 FORMAT(1X,'LTNUC: not supported mode (MODE = ',I3,')')
26562 *$ CREATE DT_DALTRA.FOR
26565 *===daltra=============================================================*
26567 SUBROUTINE DT_DALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
26569 ************************************************************************
26570 * Arbitrary Lorentz-transformation. *
26571 * Adopted from the original by S. Roesler. This version dated 15.01.95 *
26572 ************************************************************************
26574 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26576 PARAMETER (ONE=1.0D0)
26578 EP = PCX*BGX+PCY*BGY+PCZ*BGZ
26579 PE = EP/(GA+ONE)+EC
26583 P = SQRT(PX*PX+PY*PY+PZ*PZ)
26589 *$ CREATE DT_DTRAFO.FOR
26592 *====dtrafo============================================================*
26594 SUBROUTINE DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
26595 & PL,CXL,CYL,CZL,EL)
26597 C LORENTZ TRANSFORMATION INTO THE LAB - SYSTEM
26599 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26602 IF (ABS(COD).GT.1.0D0) COD = SIGN(1.0D0,COD)
26603 SID = SQRT(1.D0-COD*COD)
26607 PLZ = GAM*PCMZ+BGAM*ECM
26608 PL = SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
26609 EL = GAM*ECM+BGAM*PCMZ
26610 C ROTATION INTO THE ORIGINAL DIRECTION
26612 SIZ = SQRT(1.D0-COZ**2)
26613 CALL DT_STTRAN(CX,CY,CZ,COZ,SIZ,SIF,COF,CXL,CYL,CZL)
26618 *$ CREATE DT_STTRAN.FOR
26621 *====sttran============================================================*
26623 SUBROUTINE DT_STTRAN(XO,YO,ZO,CDE,SDE,SFE,CFE,X,Y,Z)
26625 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26627 DATA ANGLSQ/1.D-30/
26628 ************************************************************************
26629 * VERSION BY J. RANFT *
26632 * THIS IS A SUBROUTINE OF FLUKA TO GIVE NEW DIRECTION COSINES *
26634 * INPUT VARIABLES: *
26635 * XO,YO,ZO = ORIGINAL DIRECTION COSINES *
26636 * CDE,SDE = COSINE AND SINE OF THE POLAR (THETA) *
26637 * ANGLE OF "SCATTERING" *
26638 * SDE = SINE OF THE POLAR (THETA) ANGLE OF "SCATTERING" *
26639 * SFE,CFE = SINE AND COSINE OF THE AZIMUTHAL (PHI) ANGLE *
26640 * OF "SCATTERING" *
26642 * OUTPUT VARIABLES: *
26643 * X,Y,Z = NEW DIRECTION COSINES *
26645 * ROTATION OF COORDINATE SYSTEM (SEE CERN 64-47 ) *
26646 ************************************************************************
26649 * Changed by A. Ferrari
26651 * IF (ABS(XO)-0.0001D0) 1,1,2
26652 * 1 IF (ABS(YO)-0.0001D0) 3,3,2
26655 IF ( A .LT. ANGLSQ ) THEN
26664 X=-YO*XI/A-ZO*XO*YI/A+XO*ZI
26665 Y=XO*XI/A-ZO*YO*YI/A+YO*ZI
26672 *$ CREATE DT_MYTRAN.FOR
26675 *===mytran=============================================================*
26677 SUBROUTINE DT_MYTRAN(IMODE,XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
26679 ************************************************************************
26680 * This subroutine rotates the coordinate frame *
26681 * a) theta around y *
26682 * b) phi around z if IMODE = 1 *
26684 * x' cos(ph) -sin(ph) 0 cos(th) 0 sin(th) x *
26685 * y' = A B = sin(ph) cos(ph) 0 . 0 1 0 y *
26686 * z' 0 0 1 -sin(th) 0 cos(th) z *
26688 * and vice versa if IMODE = 0. *
26689 * This version dated 5.4.94 is based on the original version DTRAN *
26690 * by J. Ranft and is written by S. Roesler. *
26691 ************************************************************************
26693 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26695 PARAMETER ( LINP = 10 ,
26699 IF (IMODE.EQ.1) THEN
26700 X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
26701 Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
26702 Z=-SDE *XO +CDE *ZO
26704 X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
26706 Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
26711 *$ CREATE DT_LT2LAO.FOR
26714 *===lt2lab=============================================================*
26716 SUBROUTINE DT_LT2LAO
26718 ************************************************************************
26719 * Lorentz-transformation to lab-system. This subroutine scans DTEVT1 *
26720 * for final state particles/fragments defined in nucleon-nucleon-cms *
26721 * and transforms them back to the lab. *
26722 * This version dated 16.11.95 is written by S. Roesler *
26723 ************************************************************************
26725 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26727 PARAMETER ( LINP = 10 ,
26732 PARAMETER (NMXHKK=200000)
26733 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26734 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26735 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26736 * extended event history
26737 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26738 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26743 IF ( (NPOINT(4).EQ.0).OR.(NEND.LT.NPOINT(4)) ) RETURN
26744 DO 1 I=NPOINT(4),NEND
26746 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26747 & (ISTHKK(I).EQ.1001)) THEN
26748 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26750 CALL DT_EVTPUT(ISTHKK(I),IDHKK(I),I,0,PHKK(1,I),PHKK(2,I),
26751 & PZ,PE,IDRES(I),IDXRES(I),IDCH(I))
26752 IF ((ISTHKK(I).EQ.1000).OR.(ISTHKK(I).EQ.1001)) THEN
26753 ISTHKK(I) = 3*ISTHKK(I)
26756 IF (ISTHKK(I).EQ.-1) NOBAM(NHKK) = NOB
26757 ISTHKK(I) = SIGN(3,ISTHKK(I))
26766 *$ CREATE DT_LT2LAB.FOR
26769 *===lt2lab=============================================================*
26771 SUBROUTINE DT_LT2LAB
26773 ************************************************************************
26774 * Lorentz-transformation to lab-system. This subroutine scans DTEVT1 *
26775 * for final state particles/fragments defined in nucleon-nucleon-cms *
26776 * and transforms them to the lab. *
26777 * This version dated 07.01.96 is written by S. Roesler *
26778 ************************************************************************
26780 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26782 PARAMETER ( LINP = 10 ,
26787 PARAMETER (NMXHKK=200000)
26788 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26789 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26790 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26791 * extended event history
26792 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26793 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26796 IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
26797 DO 1 I=NPOINT(4),NHKK
26798 IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26799 & (ISTHKK(I).EQ.1001)) THEN
26801 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26810 ************************************************************************
26812 * 5) Sampling from distributions *
26814 ************************************************************************
26815 *$ CREATE IDT_NPOISS.FOR
26818 *===npoiss=============================================================*
26820 INTEGER FUNCTION IDT_NPOISS(AVN)
26822 ************************************************************************
26823 * Sample according to Poisson distribution with Poisson parameter AVN. *
26824 * The original version written by J. Ranft. *
26825 * This version dated 11.1.95 is written by S. Roesler. *
26826 ************************************************************************
26828 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26830 PARAMETER ( LINP = 10 ,
26840 IF (A.GE.EXPAVN) THEN
26849 *$ CREATE DT_SAMPXB.FOR
26852 *===sampxb=============================================================*
26854 DOUBLE PRECISION FUNCTION DT_SAMPXB(X1,X2,B)
26856 ************************************************************************
26857 * Sampling from f(x)=1./SQRT(X**2+B**2) between x1 and x2. *
26858 * Processed by S. Roesler, 6.5.95 *
26859 ************************************************************************
26861 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26863 PARAMETER (TWO=2.0D0)
26865 A1 = LOG(X1+SQRT(X1**2+B**2))
26866 A2 = LOG(X2+SQRT(X2**2+B**2))
26868 A = AN*DT_RNDM(A1)+A1
26870 DT_SAMPXB = (BB**2-B**2)/(TWO*BB)
26875 *$ CREATE DT_SAMPEX.FOR
26878 *===sampex=============================================================*
26880 DOUBLE PRECISION FUNCTION DT_SAMPEX(X1,X2)
26882 ************************************************************************
26883 * Sampling from f(x)=1./x between x1 and x2. *
26884 * Processed by S. Roesler, 6.5.95 *
26885 ************************************************************************
26887 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26889 PARAMETER (ONE=1.0D0)
26894 DT_SAMPEX = EXP((ONE-R)*AL1+R*AL2)
26899 *$ CREATE DT_SAMSQX.FOR
26902 *===samsqx=============================================================*
26904 DOUBLE PRECISION FUNCTION DT_SAMSQX(X1,X2)
26906 ************************************************************************
26907 * Sampling from f(x)=1./x^0.5 between x1 and x2. *
26908 * Processed by S. Roesler, 6.5.95 *
26909 ************************************************************************
26911 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26913 PARAMETER (ONE=1.0D0)
26916 DT_SAMSQX = (R*SQRT(X2)+(ONE-R)*SQRT(X1))**2
26921 *$ CREATE DT_SAMPLW.FOR
26924 *===samplw=============================================================*
26926 DOUBLE PRECISION FUNCTION DT_SAMPLW(XMIN,XMAX,B)
26928 ************************************************************************
26929 * Sampling from f(x)=1/x^b between x_min and x_max. *
26930 * S. Roesler, 18.4.98 *
26931 ************************************************************************
26933 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26935 PARAMETER (ONE=1.0D0)
26939 DT_SAMPLW = EXP(R*LOG(XMAX)+(ONE-R)*LOG(XMIN))
26942 DT_SAMPLW = (R*XMAX**ONEMB+(ONE-R)*XMIN**ONEMB)**(ONE/ONEMB)
26948 *$ CREATE DT_BETREJ.FOR
26951 *===betrej=============================================================*
26953 DOUBLE PRECISION FUNCTION DT_BETREJ(GAM,ETA,XMIN,XMAX)
26955 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26958 PARAMETER ( LINP = 10 ,
26961 PARAMETER (ONE=1.0D0)
26963 IF (XMIN.GE.XMAX)THEN
26964 WRITE (LOUT,500) XMIN,XMAX
26965 500 FORMAT(1X,'DT_BETREJ: XMIN<XMAX execution stopped ',2F10.5)
26970 XX = XMIN+(XMAX-XMIN)*DT_RNDM(ETA)
26971 BETMAX = XMIN**(GAM-ONE)*(ONE-XMIN)**(ETA-ONE)
26972 YY = BETMAX*DT_RNDM(XX)
26973 BETXX = XX**(GAM-ONE)*(ONE-XX)**(ETA-ONE)
26974 IF (YY.GT.BETXX) GOTO 10
26980 *$ CREATE DT_DGAMRN.FOR
26983 *===dgamrn=============================================================*
26985 DOUBLE PRECISION FUNCTION DT_DGAMRN(ALAM,ETA)
26987 ************************************************************************
26988 * Sampling from Gamma-distribution. *
26989 * F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA) *
26990 * Processed by S. Roesler, 6.5.95 *
26991 ************************************************************************
26993 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26995 PARAMETER (ZERO=0.0D0,TINY9=1.0D-9,ONE=1.0D0)
27000 IF (F.EQ.ZERO) GOTO 20
27003 IF (NCOU.GE.11) GOTO 20
27004 IF (R.LT.F/(F+2.71828D0)) GOTO 30
27005 YYY = LOG(DT_RNDM(R)+TINY9)/F
27006 IF (ABS(YYY).GT.50.0D0) GOTO 20
27008 IF (LOG(DT_RNDM(Y)+TINY9).GT.-Y) GOTO 10
27012 30 Y = ONE-LOG(DT_RNDM(Y)+TINY9)
27013 IF (DT_RNDM(R).GT.Y**(F-ONE)) GOTO 10
27014 40 IF (N.EQ.0) GOTO 70
27017 60 Z = Z*DT_RNDM(Z)
27019 70 DT_DGAMRN = Y/ALAM
27024 *$ CREATE DT_DBETAR.FOR
27027 *===dbetar=============================================================*
27029 DOUBLE PRECISION FUNCTION DT_DBETAR(GAM,ETA)
27031 ************************************************************************
27032 * Sampling from Beta -distribution between 0.0 and 1.0 *
27033 * F(X)=X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM)/(GAMM(GAM)*GAMM(ETA))*
27034 * Processed by S. Roesler, 6.5.95 *
27035 ************************************************************************
27037 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27040 Y = DT_DGAMRN(1.0D0,GAM)
27041 Z = DT_DGAMRN(1.0D0,ETA)
27042 DT_DBETAR = Y/(Y+Z)
27047 *$ CREATE DT_RANNOR.FOR
27050 *===rannor=============================================================*
27052 SUBROUTINE DT_RANNOR(X,Y)
27054 ************************************************************************
27055 * Sampling from Gaussian distribution. *
27056 * Processed by S. Roesler, 6.5.95 *
27057 ************************************************************************
27059 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27061 PARAMETER (TINY10=1.0D-10)
27063 CALL DT_DSFECF(SFE,CFE)
27064 V = MAX(TINY10,DT_RNDM(X))
27065 A = SQRT(-2.D0*LOG(V))
27072 *$ CREATE DT_DPOLI.FOR
27075 *===dpoli==============================================================*
27077 SUBROUTINE DT_DPOLI(CS,SI)
27079 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27084 IF (U.LT.0.5D0) CS=-CS
27085 SI = SQRT(1.0D0-CS*CS+1.0D-10)
27090 *$ CREATE DT_DSFECF.FOR
27093 *===dsfecf=============================================================*
27095 SUBROUTINE DT_DSFECF(SFE,CFE)
27097 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27099 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
27107 IF (XY.GT.ONE) GOTO 1
27110 IF (DT_RNDM(X).LT.OHALF) SFE = -SFE
27114 *$ CREATE DT_RACO.FOR
27117 *===raco===============================================================*
27119 SUBROUTINE DT_RACO(WX,WY,WZ)
27121 ************************************************************************
27122 * Direction cosines of random uniform (isotropic) direction in three *
27123 * dimensional space *
27124 * Processed by S. Roesler, 20.11.95 *
27125 ************************************************************************
27127 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27129 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
27132 X = TWO*DT_RNDM(WX)-ONE
27136 IF (X2+Y2.GT.ONE) GOTO 10
27138 CFE = (X2-Y2)/(X2+Y2)
27139 SFE = TWO*X*Y/(X2+Y2)
27140 * z = 1/2 [ 1 + cos (theta) ]
27143 WZ = SQRT(Z*(ONE-Z))
27151 ************************************************************************
27153 * 6) Special functions, algorithms and service routines *
27155 ************************************************************************
27156 *$ CREATE DT_YLAMB.FOR
27159 *===ylamb==============================================================*
27161 DOUBLE PRECISION FUNCTION DT_YLAMB(X,Y,Z)
27163 ************************************************************************
27165 * auxiliary function for three particle decay mode *
27166 * (standard LAMBDA**(1/2) function) *
27168 * Adopted from an original version written by R. Engel. *
27169 * This version dated 12.12.94 is written by S. Roesler. *
27170 ************************************************************************
27172 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27176 XLAM = X*X-2.D0*X*(Y+Z)+YZ*YZ
27177 IF (XLAM.LE.0.D0) XLAM = ABS(XLAM)
27178 DT_YLAMB = SQRT(XLAM)
27183 *$ CREATE DT_SORT.FOR
27186 *===sort1==============================================================*
27188 SUBROUTINE DT_SORT(A,N,I0,I1,MODE)
27190 ************************************************************************
27191 * This subroutine sorts entries in A in increasing/decreasing order *
27193 * MODE = 1 increasing in A(3,i=1..N) *
27194 * = 2 decreasing in A(3,i=1..N) *
27195 * This version dated 21.04.95 is revised by S. Roesler *
27196 ************************************************************************
27198 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27210 IF (MODE.EQ.1) THEN
27211 IF (A(3,I).LE.A(3,J)) GOTO 20
27213 IF (A(3,I).GE.A(3,J)) GOTO 20
27226 IF (L.EQ.1) GOTO 10
27231 *$ CREATE DT_SORT1.FOR
27234 *===sort1==============================================================*
27236 SUBROUTINE DT_SORT1(A,IDX,N,I0,I1,MODE)
27238 ************************************************************************
27239 * This subroutine sorts entries in A in increasing/decreasing order *
27241 * MODE = 1 increasing in A(i=1..N) *
27242 * = 2 decreasing in A(i=1..N) *
27243 * This version dated 21.04.95 is revised by S. Roesler *
27244 ************************************************************************
27246 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27249 DIMENSION A(N),IDX(N)
27258 IF (MODE.EQ.1) THEN
27259 IF (A(I).LE.A(J)) GOTO 20
27261 IF (A(I).GE.A(J)) GOTO 20
27271 IF (L.EQ.1) GOTO 10
27276 *$ CREATE DT_XTIME.FOR
27279 *===xtime==============================================================*
27281 SUBROUTINE DT_XTIME
27283 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27285 PARAMETER ( LINP = 10 ,
27289 CHARACTER DAT*9,TIM*11
27293 C CALL GETDAT(IYEAR,IMONTH,IDAY)
27294 C CALL GETTIM(IHOUR,IMINUT,ISECND,IHSCND)
27298 C WRITE(LOUT,1000) DAT,TIM
27299 1000 FORMAT(/,2X,'Date: ',A9,3X,'Time: ',A11,/)
27304 ************************************************************************
27306 * 7) Random number generator package *
27308 * THIS IS A PACKAGE CONTAINING A RANDOM NUMBER GENERATOR AND *
27309 * SERVICE ROUTINES. *
27310 * THE ALGORITHM IS FROM *
27311 * 'TOWARD A UNVERSAL RANDOM NUMBER GENERATOR' *
27312 * G.MARSAGLIA, A.ZAMAN ; FSU-SCRI-87-50 *
27313 * IMPLEMENTATION BY K. HAHN DEC. 88, *
27314 * THIS GENERATOR SHOULD NOT DEPEND ON THE HARD WARE ( IF A REAL HAS *
27315 * AT LEAST 24 SIGNIFICANT BITS IN INTERNAL REPRESENTATION ), *
27316 * THE PERIOD IS ABOUT 2**144, *
27317 * TIME FOR ONE CALL AT IBM-XT IS ABOUT 0.7 MILLISECONDS, *
27318 * THE PACKAGE CONTAINS *
27319 * FUNCTION DT_RNDM(I) : GENERATOR *
27320 * SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB4): INITIALIZATION *
27321 * SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) : PUT SEED TO GENERATOR *
27322 * SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) : TAKE SEED FROM GENERATOR *
27323 * SUBROUTINE DT_RNDMTE(IO) : TEST OF GENERATOR *
27325 * FUNCTION DT_RNDM(I) *
27326 * GIVES UNIFORMLY DISTRIBUTED RANDOM NUMBERS IN (0..1) *
27327 * I - DUMMY VARIABLE, NOT USED *
27328 * SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1) *
27329 * INITIALIZES THE GENERATOR, MUST BE CALLED BEFORE USING DT_RNDM *
27330 * NA1,NA2,NA3,NB1 - VALUES FOR INITIALIZING THE GENERATOR *
27331 * NA? MUST BE IN 1..178 AND NOT ALL 1 *
27332 * 12,34,56 ARE THE STANDARD VALUES *
27333 * NB1 MUST BE IN 1..168 *
27334 * 78 IS THE STANDARD VALUE *
27335 * SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J) *
27336 * PUTS SEED TO GENERATOR ( BRINGS GENERATOR IN THE SAME STATUS *
27337 * AS AFTER THE LAST DT_RNDMOU CALL ) *
27338 * U(97),C,CD,CM,I,J - SEED VALUES AS TAKEN FROM DT_RNDMOU *
27339 * SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J) *
27340 * TAKES SEED FROM GENERATOR *
27341 * U(97),C,CD,CM,I,J - SEED VALUES *
27342 * SUBROUTINE DT_RNDMTE(IO) *
27343 * TEST OF THE GENERATOR *
27344 * IO - DEFINES OUTPUT *
27345 * = 0 OUTPUT ONLY IF AN ERROR IS DETECTED *
27346 * = 1 OUTPUT INDEPENDEND ON AN ERROR *
27347 * DT_RNDMTE USES DT_RNDMIN AND DT_RNDMOU TO BRING GENERATOR TO *
27349 * AS BEFORE CALL OF DT_RNDMTE *
27350 ************************************************************************
27351 *$ CREATE DT_RNDM.FOR
27354 c$$$*===rndm===============================================================*
27356 c$$$ DOUBLE PRECISION FUNCTION DT_RNDM(VDUMMY)
27358 c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27361 c$$$* random number generator
27362 c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27364 c$$$* counter of calls to random number generator
27365 c$$$* uncomment if needed
27366 c$$$C COMMON /DTRNCT/ IRNCT0,IRNCT1
27367 c$$$C LOGICAL LFIRST
27368 c$$$C DATA LFIRST /.TRUE./
27370 c$$$* counter of calls to random number generator
27371 c$$$* uncomment if needed
27372 c$$$C IF (LFIRST) THEN
27375 c$$$C LFIRST = .FALSE.
27378 c$$$ DT_RNDM = U(I)-U(J)
27379 c$$$ IF ( DT_RNDM.LT.0.0D0 ) DT_RNDM = DT_RNDM+1.0D0
27380 c$$$ U(I) = DT_RNDM
27382 c$$$ IF ( I.EQ.0 ) I = 97
27384 c$$$ IF ( J.EQ.0 ) J = 97
27386 c$$$ IF ( C.LT.0.0D0 ) C = C+CM
27387 c$$$ DT_RNDM = DT_RNDM-C
27388 c$$$ IF ( DT_RNDM.LT.0.0D0 ) DT_RNDM = DT_RNDM+1.0D0
27390 c$$$ IF ((DT_RNDM.EQ.0.D0).OR.(DT_RNDM.EQ.1.D0)) GOTO 100
27392 c$$$* counter of calls to random number generator
27393 c$$$* uncomment if needed
27394 c$$$C IRNCT0 = IRNCT0+1
27399 c$$$*$ CREATE DT_RNDMST.FOR
27400 c$$$*COPY DT_RNDMST
27402 c$$$*===rndmst=============================================================*
27404 c$$$ SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)
27406 c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27409 c$$$* random number generator
27410 c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27418 c$$$ DO 20 II2 = 1,97
27421 c$$$ DO 10 II1 = 1,24
27422 c$$$ MAT = MOD(MOD(MA1*MA2,179)*MA3,179)
27426 c$$$ MB1 = MOD(53*MB1+1,169)
27427 c$$$ IF ( MOD(MB1*MAT,64).GE.32 ) S = S+T
27428 c$$$ 10 T = 0.5D0*T
27430 c$$$ C = 362436.0D0/16777216.0D0
27431 c$$$ CD = 7654321.0D0/16777216.0D0
27432 c$$$ CM = 16777213.0D0/16777216.0D0
27436 c$$$*$ CREATE DT_RNDMIN.FOR
27437 c$$$*COPY DT_RNDMIN
27439 c$$$*===rndmin=============================================================*
27441 c$$$ SUBROUTINE DT_RNDMIN(UIN,CIN,CDIN,CMIN,IIN,JIN)
27443 c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27446 c$$$* random number generator
27447 c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27449 c$$$ DIMENSION UIN(97)
27451 c$$$ DO 10 KKK = 1,97
27452 c$$$ 10 U(KKK) = UIN(KKK)
27462 c$$$*$ CREATE DT_RNDMOU.FOR
27463 c$$$*COPY DT_RNDMOU
27465 c$$$*===rndmou=============================================================*
27467 c$$$ SUBROUTINE DT_RNDMOU(UOUT,COUT,CDOUT,CMOUT,IOUT,JOUT)
27469 c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27472 c$$$* random number generator
27473 c$$$ COMMON /DTRAND/ U(97),C,CD,CM,I,J
27475 c$$$ DIMENSION UOUT(97)
27477 c$$$ DO 10 KKK = 1,97
27478 c$$$ 10 UOUT(KKK) = U(KKK)
27488 c$$$*$ CREATE DT_RNDMTE.FOR
27489 c$$$*COPY DT_RNDMTE
27491 c$$$*===rndmte=============================================================*
27493 c$$$ SUBROUTINE DT_RNDMTE(IO)
27495 c$$$ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27498 c$$$ DIMENSION UU(97),U(6),X(6),D(6)
27499 c$$$ DATA U / 6533892.D0, 14220222.D0, 7275067.D0, 6172232.D0,
27500 c$$$ +8354498.D0, 10633180.D0/
27502 c$$$ CALL DT_RNDMOU(UU,CC,CCD,CCM,II,JJ)
27503 c$$$ CALL DT_RNDMST(12,34,56,78)
27504 c$$$ DO 10 II1 = 1,20000
27505 c$$$ 10 XX = DT_RNDM(XX)
27507 c$$$ DO 20 II2 = 1,6
27508 c$$$ X(II2) = 4096.D0*(4096.D0*DT_RNDM(SD))
27509 c$$$ D(II2) = X(II2)-U(II2)
27510 c$$$ 20 SD = SD+D(II2)
27511 c$$$ CALL DT_RNDMIN(UU,CC,CCD,CCM,II,JJ)
27513 c$$$C IF ( IO.EQ. 1.OR. SD.NE.0. 0) WRITE(6,500) (U(I),X(I),D(I),I=1,6)
27514 c$$$ IF ((IO.EQ.1).OR.(SD.NE.0.0)) THEN
27515 c$$$C WRITE(6,1000)
27516 c$$$ 1000 FORMAT(/,/,1X,'DT_RNDMTE: Test of random-number generator...',
27521 c$$$ 500 FORMAT(' === TEST OF THE RANDOM-GENERATOR ===',/,
27522 c$$$ &' EXPECTED VALUE CALCULATED VALUE DIFFERENCE',/, 6(F17.
27523 c$$$ &1,F20.1,F15.3,/), ' === END OF TEST ;',
27524 c$$$ &' GENERATOR HAS THE SAME STATUS AS BEFORE CALLING DT_RNDMTE')
27527 *$ CREATE PHO_RNDM.FOR
27530 *===pho_rndm===========================================================*
27532 DOUBLE PRECISION FUNCTION PHO_RNDM(DUMMY)
27534 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27537 PHO_RNDM = DT_RNDM(DUMMY)
27545 *===pyr================================================================*
27547 DOUBLE PRECISION FUNCTION PYR(IDUMMY)
27549 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27552 DUMMY = DBLE(IDUMMY)
27553 PYR = DT_RNDM(DUMMY)
27558 *$ CREATE DT_TITLE.FOR
27561 *===title==============================================================*
27563 SUBROUTINE DT_TITLE
27565 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27567 PARAMETER ( LINP = 10 ,
27572 CHARACTER*11 CCHANG
27573 DATA CVERSI,CCHANG /'3.0-5 ','08 Jan 2007'/
27576 WRITE(LOUT,1000) CVERSI,CCHANG
27577 1000 FORMAT(1X,'+-------------------------------------------------',
27578 & '----------------------+',/,
27579 & 1X,'|',71X,'|',/,
27580 & 1X,'|',26X,'DPMJET version ',A6,24X,'|',/,
27581 & 1X,'|',71X,'|',/,
27582 & 1X,'|',22X,'(Last change: ',A11,')',23X,'|',/,
27583 & 1X,'|',71X,'|',/,
27584 & 1X,'|',12X,'Authors: Stefan Roesler (CERN)',27X,'|',/,
27585 & 1X,'|',21X,'Ralph Engel (FZ Karlsruhe)',19X,'|',/,
27586 & 1X,'|',21X,'Johannes Ranft (Siegen Univ.)',19X,'|',/,
27587 & 1X,'|',71X,'|',/,
27588 & 1X,'|',12X,'http://home.cern.ch/~sroesler/dpmjet3.html',
27590 & 1X,'|',71X,'|',/,
27591 & 1X,'+-------------------------------------------------',
27592 & '----------------------+',/,
27593 & 1X,'| Please send suggestions, bug reports, etc. to: ',
27594 & 'Stefan.Roesler@cern.ch |',/,
27595 & 1X,'+-------------------------------------------------',
27596 & '----------------------+',/)
27601 *$ CREATE DT_EVTINI.FOR
27604 *===evtini=============================================================*
27606 SUBROUTINE DT_EVTINI
27608 ************************************************************************
27609 * Initialization of DTEVT1. *
27610 * This version dated 15.01.94 is written by S. Roesler *
27611 ************************************************************************
27613 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27615 PARAMETER ( LINP = 10 ,
27620 PARAMETER (NMXHKK=200000)
27621 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27622 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27623 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27624 * extended event history
27625 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27626 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27629 COMMON /DTEVNO/ NEVENT,ICASCA
27630 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
27631 * emulsion treatment
27632 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
27635 * initialization of DTEVT1/DTEVT2
27637 IF (NEVENT.EQ.1) NEND = NMXHKK
27665 C* initialization of DTLTRA
27666 C IF (NCOMPO.GT.0) CALL DT_LTINI(ID,EPN,PPN,ECM)
27671 *$ CREATE DT_STATIS.FOR
27674 *===statis=============================================================*
27676 SUBROUTINE DT_STATIS(MODE)
27678 ************************************************************************
27679 * Initialization and output of run-statistics. *
27680 * MODE = 1 initialization *
27682 * This version dated 23.01.94 is written by S. Roesler *
27683 ************************************************************************
27685 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27687 PARAMETER ( LINP = 10 ,
27690 PARAMETER (TINY3=1.0D-3)
27693 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
27694 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
27696 * rejection counter
27697 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27698 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27699 & IREXCI(3),IRDIFF(2),IRINC
27700 * central particle production, impact parameter biasing
27701 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
27702 * various options for treatment of partons (DTUNUC 1.x)
27703 * (chain recombination, Cronin,..)
27704 LOGICAL LCO2CR,LINTPT
27705 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
27707 * nucleon-nucleon event-generator
27710 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
27711 * flags for particle decays
27712 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
27713 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
27714 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
27715 * diquark-breaking mechanism
27716 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
27718 DIMENSION PP(4),PT(4)
27725 * initialize statistics counter
27738 * initialize rejection counter
27769 * statistics counter
27771 1000 FORMAT(/,/,1X,'STATIS:',20X,'statistics of the run',/,
27772 & 28X,'---------------------')
27773 IF (ICREQU.GT.0) THEN
27774 WRITE(LOUT,1001) ICREQU,ICSAMP,DBLE(ICSAMP)/DBLE(ICREQU)
27775 1001 FORMAT(/,1X,'number of events requested / sampled',13X,
27776 & I8,' / ',I8,/,1X,'number of samp. evts per requested ',
27777 & 'event',11X,F9.1)
27779 IF (ICDIFF(1).NE.0) THEN
27780 WRITE(LOUT,1009) ICDIFF
27781 1009 FORMAT(/,1X,'diffractive events: total ',I8,/,49X,
27782 & 'low mass high mass',/,24X,'single diffraction',
27783 & 7X,I8,4X,I8,/,24X,'double diffraction',7X,I8,4X,I8)
27785 IF (ICENTR.GT.0.AND.ICSAMP.GT.0.AND.ICCPRO.GT.0) THEN
27786 WRITE(LOUT,1002) DBLE(ICCPRO)/DBLE(ICSAMP),
27787 & DBLE(ICSAMP)/DBLE(ICCPRO)
27788 1002 FORMAT(/,1X,'central production:',/,2X,'mean number',
27789 & ' of sampled Glauber-events per event',9X,F9.1,/,
27790 & 2X,'fraction of production cross section',21X,F10.6)
27792 IF (ICSAMP.GT.0) THEN
27793 WRITE(LOUT,1003) DBLE(ICDPR)/DBLE(ICSAMP),
27794 & DBLE(ICDTA)/DBLE(ICSAMP)
27795 1003 FORMAT(/,54X,'proj. targ.',/,1X,'average number of wounded',
27796 & ' nucleons after x-sampling',2(4X,F6.2))
27799 IF (MCGENE.EQ.1) THEN
27800 IF (ICSAMP.GT.0) THEN
27801 WRITE(LOUT,1004) DBLE(ICRJSS)/DBLE(ICSAMP)
27802 1004 FORMAT(/,1X,'mean number of sea-sea chain rejections per',
27803 & ' event',3X,F9.1)
27804 IF (ISICHA.EQ.1) THEN
27805 WRITE(LOUT,1005) DBLE(ICVV2S)/DBLE(ICSAMP)
27806 1005 FORMAT(/,1X,'Reggeon contribution:',/,1X,'mean number ',
27807 & 'of single chains per event',13X,F9.1)
27810 IF (ICSAMP.GT.0.AND.ICREQU.GT.0) THEN
27812 1006 FORMAT(/,1X,'chain system statistics: (per event)',/,
27813 & 23X,'mean number of chains mean number of chains',/,
27814 & 23X,'sampled hadronized having mass of a reso.')
27815 WRITE(LOUT,1007) (DBLE(ICCHAI(1,J))/(2.0D0*DBLE(ICSAMP)),
27816 & DBLE(ICCHAI(2,J))/(2.0D0*DBLE(ICREQU)),
27817 & DBLE(ICRES(J))/(2.0D0*DBLE(ICREQU)),J=1,8),
27818 & DBLE(ICCHAI(2,9))/MAX(DBLE(ICCHAI(1,9)),TINY3)
27819 1007 FORMAT(1X,'sea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27820 & 1X,'disea - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27821 & 1X,'sea - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27822 & 1X,'sea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27823 & 1X,'disea - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27824 & 1X,'valence - sea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27825 & 1X,'valence - disea ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27826 & 1X,'valence - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27827 & 1X,'fused chains ',18X,F4.1,17X,F4.1,/)
27829 & (DBLE(IRCRON(I))/MAX(DBLE(IRCRON(1)),TINY3),I=2,3),
27830 & DBLE(IRPT)/DBLE(ICREQU),(DBLE(IRRES(I))/DBLE(ICREQU),I=1,2),
27831 & DBLE(LOMRES)/DBLE(ICREQU),DBLE(LOBRES)/DBLE(ICREQU),
27832 & (DBLE(IRCHKI(I))/DBLE(ICREQU),I=1,2),
27833 & (DBLE(IRDIFF(I))/DBLE(ICREQU),I=1,2),
27834 & DBLE(IRHHA)/DBLE(ICREQU),
27835 & DBLE(IRFRAG)/DBLE(ICREQU),DBLE(IREVT)/DBLE(ICREQU),
27836 & (DBLE(IREXCI(I))/DBLE(ICREQU),I=1,2),IREXCI(3)
27837 1008 FORMAT(/,1X,'Rejection counter: (NEVT = no. of events)',/,/,
27838 & 1X,'Cronin-effect (CRONIN)',15X,'IRCRON(2)/IRCRON(1) = ',
27839 & F7.2,/,38X,'IRCRON(3)/IRCRON(1) = ',F7.2,/,1X,
27840 & 'Intrins. p_t (GETSPT)',21X,'IRPT /NEVT = ',F7.2,/,
27841 & 1X,'Chain mass corr. for resonances (EVTRES)',2X,
27842 & 'IRRES(1) /NEVT = ',F7.2,/,33X,'(CH2RES) IRRES(2) /',
27843 & 'NEVT = ',F7.2,/,43X,'LOMRES /NEVT = ',F7.2,/,
27844 & 43X,'LOBRES /NEVT = ',F7.2,/,1X,'Kinem. corr. of',
27845 & ' 2-chain systems (CHKINE) IRCHKI(1)/NEVT = ',F7.2,/,
27846 & 43X,'IRCHKI(2)/NEVT = ',F7.2,/,1X,'Diffraction',31X,
27847 & 'IRDIFF(1)/NEVT = ',F7.2,/,43X,'IRDIFF(2)/NEVT = ',
27848 & F7.2,/,1X,'Total no. of rej.',
27849 & ' in chain-systems treatment (GETCSY)',/,43X,
27850 & 'IRHHA /NEVT = ',F7.2,/,1X,'Fragmentation (EVTFRA)',
27851 & ' (not yet used!)',4X,'IRFRAG /NEVT = ',F7.2,/,
27852 & 1X,'Total no. of rej. in DPM-treatment of one event',
27853 & ' (EVENTA)',/,43X,'IREVT /NEVT = ',F7.2,/,1X,
27854 & 'Treatment of final nucleon conf.',10X,'IREXCI(1)/NEVT = '
27855 & ,F7.2,/,43X,'IREXCI(2)/NEVT = ',F7.2,/,48X,
27856 & 'IREXCI(3) = ',I5,/)
27858 ELSEIF (MCGENE.EQ.2) THEN
27859 WRITE(LOUT,1010) ELOJET
27860 1010 FORMAT(/,/,1X,'PHOJET-treatment of chain systems above ',
27863 1011 FORMAT(/,1X,'1. chain system statistics - total numbers:',/,
27864 & 30X,'--------------',/,/,12X,'s-s',5X,'d-s',5X,'s-d',
27865 & 5X,'s-v',5X,'d-v',5X,'v-s',5X,'v-d',5X,'v-v')
27866 WRITE(LOUT,1012) ((ICEVTG(I,J),I=1,8),J=0,1),
27867 & (INT(ICCHAI(2,I)/2.0D0),I=1,8),
27868 & (ICEVTG(I,2),I=1,8),(ICEVTG(I,29),I=1,8),
27869 & ((ICEVTG(I,J),I=1,8),J=3,7),
27870 & ((ICEVTG(I,J),I=1,8),J=19,21),
27871 & (ICEVTG(I,8),I=1,8),
27872 & ((ICEVTG(I,J),I=1,8),J=22,24),
27873 & (ICEVTG(I,9),I=1,8),
27874 & ((ICEVTG(I,J),I=1,8),J=25,28),
27875 & ((ICEVTG(I,J),I=1,8),J=10,18)
27876 1012 FORMAT(/,1X,'req.to.',8I8,/,/,1X,'low rq.',8I8,/,1X,'low ac.',
27877 & 8I8,/,/,1X,'PHOJET ',8I8,/,' sngl ',8I8,/,/,
27878 & ' no-dif.',8I8,/,
27879 & ' el-sca.',8I8,/,' qel-sc.',8I8,/,' dbl-Po.',8I8,/,
27880 & ' diff-1 ',8I8,/,' low ',8I8,/,' high ',8I8,/,
27881 & ' h-diff',8I8,/,' diff-2 ',8I8,/,' low ',8I8,/,
27882 & ' high ',8I8,/,' h-diff',8I8,/,' dbl-di.',8I8,/,
27883 & ' lo-lo ',8I8,/,' hi-hi ',8I8,/,' lo-hi ',8I8,/,
27885 & ' dir-ga.',8I8,/,/,' dir-1 ',8I8,/,' dir-2 ',8I8,/,
27886 & ' dbl-dir',8I8,/,' s-Pom. ',8I8,/,' h-Pom. ',8I8,/,
27887 & ' s-Reg. ',8I8,/,' enh-trg',8I8,/,' enh-log',8I8)
27889 1013 FORMAT(/,1X,'2. chain system statistics -',
27890 & ' mean numbers per evt:',/,30X,'---------------------',
27891 & /,/,16X,'s-s',7X,'d-s',7X,'s-d')
27892 IF (ICSAMP.GT.0) THEN
27894 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=0,1),
27895 & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=1,3),
27896 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=2,18)
27897 1014 FORMAT(/,1X,'req.to. ',3E10.2,/,/,1X,'low rq. ',3E10.2,/,
27898 & 1X,'low ac. ',3E10.2,/,/,1X,'PHOJET ',3E10.2,/,/,
27899 & ' no-dif. ',3E10.2,/,' el-sca. ',3E10.2,/,
27900 & ' qel-sc. ',3E10.2,/,' dbl-Po. ',3E10.2,/,
27901 & ' diff-1 ',3E10.2,/,' diff-2 ',3E10.2,/,
27902 & ' dbl-di. ',3E10.2,/,' dir-ga. ',3E10.2,/,/,
27903 & ' dir-1 ',3E10.2,/,' dir-2 ',3E10.2,/,
27904 & ' dbl-dir ',3E10.2,/,' s-Pom. ',3E10.2,/,
27905 & ' h-Pom. ',3E10.2,/,' s-Reg. ',3E10.2,/,
27906 & ' enh-trg ',3E10.2,/,' enh-log ',3E10.2)
27909 1015 FORMAT(/,16X,'s-v',7X,'d-v',7X,'v-s',7X,'v-d',7X,'v-v')
27910 IF (ICSAMP.GT.0) THEN
27912 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=0,1),
27913 & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=4,8),
27914 & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=2,18)
27915 1016 FORMAT(/,1X,'req.to. ',5E10.2,/,/,1X,'low rq. ',5E10.2,/,
27916 & 1X,'low ac. ',5E10.2,/,/,1X,'PHOJET ',5E10.2,/,/,
27917 & ' no-dif. ',5E10.2,/,' el-sca. ',5E10.2,/,
27918 & ' qel-sc. ',5E10.2,/,' dbl-Po. ',5E10.2,/,
27919 & ' diff-1 ',5E10.2,/,' diff-2 ',5E10.2,/,
27920 & ' dbl-di. ',5E10.2,/,' dir-ga. ',5E10.2,/,/,
27921 & ' dir-1 ',5E10.2,/,' dir-2 ',5E10.2,/,
27922 & ' dbl-dir ',5E10.2,/,' s-Pom. ',5E10.2,/,
27923 & ' h-Pom. ',5E10.2,/,' s-Reg. ',5E10.2,/,
27924 & ' enh-trg ',5E10.2,/,' enh-log ',5E10.2)
27930 IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
27931 & .OR.(PDBSEA(3).GT.0.0D0)) THEN
27932 WRITE(LOUT,*)'YGS1S,YGS2S,YUS1S,YUS2S',
27933 & DBRKA(1,1)+DBRKA(2,1),DBRKA(1,2)+DBRKA(2,2),
27934 & DBRKA(1,3)+DBRKA(2,3),DBRKA(1,4)+DBRKA(2,4)
27935 WRITE(LOUT,*)'YGS1R,YGS2R,YUS1R,YUS2R',
27936 & DBRKR(1,1)+DBRKR(2,1),DBRKR(1,2)+DBRKR(2,2),
27937 & DBRKR(1,3)+DBRKR(2,3),DBRKR(1,4)+DBRKR(2,4)
27938 WRITE(LOUT,*)'YGSA1S,YGSA2S,YUSA1S,YUSA2S',
27939 & DBRKA(1,5)+DBRKA(2,5),DBRKA(1,6)+DBRKA(2,6),
27940 & DBRKA(1,7)+DBRKA(2,7),DBRKA(1,8)+DBRKA(2,8)
27941 WRITE(LOUT,*)'YGSA1R,YGSA2R,YUSA1R,YUSA2R',
27942 & DBRKR(1,5)+DBRKR(2,5),DBRKR(1,6)+DBRKR(2,6),
27943 & DBRKR(1,7)+DBRKR(2,7),DBRKR(1,8)+DBRKR(2,8)
27944 WRITE(LOUT,*)'YG31S,YG32S,YU31S,YU32S',
27945 & DBRKA(3,1),DBRKA(3,2),
27946 & DBRKA(3,3),DBRKA(3,4)
27947 WRITE(LOUT,*)'YG31R,YG32R,YU31R,YU32R',
27948 & DBRKR(3,1),DBRKR(3,2),
27949 & DBRKR(3,3),DBRKR(3,4)
27950 WRITE(LOUT,*)'YG3A1S,YG3A2S,YU3A1S,YU3A2S',
27951 & DBRKA(3,5),DBRKA(3,6),
27952 & DBRKA(3,7),DBRKA(3,8)
27953 WRITE(LOUT,*)'YG3A1R,YG3A2R,YU3A1R,YU3A2R',
27954 & DBRKR(3,5),DBRKR(3,6),
27955 & DBRKR(3,7),DBRKR(3,8)
27959 IF (MCGENE.EQ.2) THEN
27960 C CALL PHO_PHIST(-2,SIGMAX)
27961 CALL PHO_EVENT(-2,PP,PT,FAC,IREJ1)
27969 *$ CREATE DT_EVTOUT.FOR
27972 *===evtout=============================================================*
27974 SUBROUTINE DT_EVTOUT(MODE)
27976 ************************************************************************
27977 * MODE = 1 plot content of complete DTEVT1 to out. unit *
27978 * 3 plot entries of extended DTEVT1 (DTEVT2) *
27979 * 4 plot entries of DTEVT1 and DTEVT2 *
27980 * This version dated 11.12.94 is written by S. Roesler *
27981 ************************************************************************
27983 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27985 PARAMETER ( LINP = 10 ,
27989 PARAMETER (NMXHKK=200000)
27990 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27991 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27992 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27994 DIMENSION IRANGE(NMXHKK)
27996 IF (MODE.EQ.2) RETURN
27998 CALL DT_EVTPLO(IRANGE,MODE)
28003 *$ CREATE DT_EVTPLO.FOR
28006 *===evtplo=============================================================*
28008 SUBROUTINE DT_EVTPLO(IRANGE,MODE)
28010 ************************************************************************
28011 * MODE = 1 plot content of complete DTEVT1 to out. unit *
28012 * 2 plot entries of DTEVT1 given by IRANGE *
28013 * 3 plot entries of extended DTEVT1 (DTEVT2) *
28014 * 4 plot entries of DTEVT1 and DTEVT2 *
28015 * 5 plot rejection counter *
28016 * This version dated 11.12.94 is written by S. Roesler *
28017 ************************************************************************
28019 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28021 PARAMETER ( LINP = 10 ,
28028 PARAMETER (NMXHKK=200000)
28029 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28030 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28031 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28032 * extended event history
28033 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28034 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28036 * rejection counter
28037 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
28038 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
28039 & IREXCI(3),IRDIFF(2),IRINC
28041 DIMENSION IRANGE(NMXHKK)
28043 IF ((MODE.EQ.1).OR.(MODE.EQ.4)) THEN
28045 1000 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTEVT1/',/,
28046 & 15X,' --------------------------',/,/,
28047 & ' ST ID M1 M2 D1 D2 PX PY',
28050 WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28051 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28052 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
28054 C WRITE(LOUT,1011) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28055 C & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28056 C & PHKK(3,I),PHKK(4,I)
28057 C WRITE(LOUT,'(4E15.4)')
28058 C & VHKK(1,I),VHKK(2,I),VHKK(3,I),VHKK(4,I)
28059 1001 FORMAT(I5,I5,I6,4I5,3F7.3,F8.3,F8.4)
28060 1011 FORMAT(I5,I5,I6,4I5,2E15.5)
28064 C WRITE(LOUT,1006) I,ISTHKK(I),
28065 C & VHKK(1,I),VHKK(2,I),VHKK(3,I),WHKK(1,I),
28066 C & WHKK(2,I),WHKK(3,I)
28067 C1006 FORMAT(1X,I4,I6,6E10.3)
28071 IF (MODE.EQ.2) THEN
28076 IF (IRANGE(NC).EQ.-100) GOTO 9999
28078 WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28079 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28080 & PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
28085 IF ((MODE.EQ.3).OR.(MODE.EQ.4)) THEN
28087 1002 FORMAT(/,1X,'EVTPLO:',14X,
28088 & ' content of COMMON /DTEVT1/,/DTEVT2/',/,
28089 & 15X,' -----------------------------------',/,/,
28090 & ' ST ID M1 M2 D1 D2 IDR IDXR',
28091 & ' NOBAM IDCH M',/)
28093 C IF ((ISTHKK(I).GT.10).OR.(ISTHKK(I).EQ.1)) THEN
28096 IF ((((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
28097 & (KF.NE.80000)).OR.(IDHKK(I).EQ.99999)) KF = 92
28098 CALL PYNAME(KF,CHAU)
28099 WRITE(LOUT,1003) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28100 & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28101 & IDRES(I),IDXRES(I),NOBAM(I),IDCH(I),
28103 1003 FORMAT(I5,I5,I6,4I5,4I4,F8.4,2X,A)
28108 IF (MODE.EQ.5) THEN
28110 1004 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTREJC/',/,
28111 & 15X,' --------------------------',/)
28112 WRITE(LOUT,1005) IRPT,IRHHA,IRRES,LOMRES,LOBRES,IREMC,IRFRAG,
28114 1005 FORMAT(1X,'IRPT = ',I5,' IRHHA = ',I5,/,
28115 & 1X,'IRRES = ',2I5,' LOMRES = ',I5,' LOBRES = ',I5,/,
28116 & 1X,'IREMC = ',10I5,/,
28117 & 1X,'IRFRAG = ',I5,' IRSEA = ',I5,' IRCRON = ',I5,/)
28123 *$ CREATE DT_EVTPUT.FOR
28126 *===evtput=============================================================*
28128 SUBROUTINE DT_EVTPUT(IST,ID,M1,M2,PX,PY,PZ,E,IDR,IDXR,IDC)
28130 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28132 PARAMETER ( LINP = 10 ,
28135 PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,TINY3=1.0D-3,
28136 & TINY2=1.0D-2,SQTINF=1.0D+15,ZERO=0.0D0)
28139 PARAMETER (NMXHKK=200000)
28140 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28141 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28142 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28143 * extended event history
28144 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28145 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28147 * Lorentz-parameters of the current interaction
28148 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28149 & UMO,PPCM,EPROJ,PPROJ
28150 * particle properties (BAMJET index convention)
28152 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28153 & IICH(210),IIBAR(210),K1(210),K2(210)
28155 C IF (MODE.GT.100) THEN
28156 C WRITE(LOUT,'(1X,A,I5,A,I5)')
28157 C & 'EVTPUT: reset NHKK = ',NHKK,' to NHKK =',NHKK-MODE+100
28158 C NHKK = NHKK-MODE+100
28165 IF (NHKK.GT.NMXHKK) THEN
28166 WRITE(LOUT,1000) NHKK
28167 1000 FORMAT(1X,'EVTPUT: NHKK exeeds NMXHKK = ',I7,
28168 & '! program execution stopped..')
28171 IF (M1.LT.0) MO1 = NHKK+M1
28172 IF (M2.LT.0) MO2 = NHKK+M2
28175 JMOHKK(1,NHKK) = MO1
28176 JMOHKK(2,NHKK) = MO2
28180 IDXRES(NHKK) = IDXR
28182 ** here we need to do something..
28183 IF (ID.EQ.88888) THEN
28184 IDMO1 = ABS(IDHKK(MO1))
28185 IDMO2 = ABS(IDHKK(MO2))
28186 IF ((IDMO1.LT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 3
28187 IF ((IDMO1.LT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 4
28188 IF ((IDMO1.GT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 5
28189 IF ((IDMO1.GT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 6
28193 IDBAM(NHKK) = IDT_ICIHAD(ID)
28195 IF (JDAHKK(1,MO1).NE.0) THEN
28196 JDAHKK(2,MO1) = NHKK
28198 JDAHKK(1,MO1) = NHKK
28202 IF (JDAHKK(1,MO2).NE.0) THEN
28203 JDAHKK(2,MO2) = NHKK
28205 JDAHKK(1,MO2) = NHKK
28208 C IF ((IDBAM(NHKK).GT.0).AND.(IDBAM(NHKK).NE.7)) THEN
28209 C PTOT = SQRT(PX**2+PY**2+PZ**2)
28210 C AM0 = SQRT(ABS( (E-PTOT)*(E+PTOT) ))
28211 C AMRQ = AAM(IDBAM(NHKK))
28212 C AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
28213 C IF ((ABS(AMDIF2).GT.TINY3).AND.(E.LT.SQTINF).AND.
28214 C & (PTOT.GT.ZERO)) THEN
28215 C DELTA = -AMDIF2/(2.0D0*(E+PTOT))
28216 CC DELTA = (AMRQ2-AM2)/(2.0D0*(E+PTOT))
28218 C PTOT1 = PTOT-DELTA
28219 C PX = PX*PTOT1/PTOT
28220 C PY = PY*PTOT1/PTOT
28221 C PZ = PZ*PTOT1/PTOT
28228 PTOT = SQRT( PX**2+PY**2+PZ**2 )
28229 IF ((IDHKK(NHKK).GE.22).AND.(IDHKK(NHKK).LE.24)) THEN
28230 PHKK(5,NHKK) = PHKK(4,NHKK)**2-PTOT**2
28231 PHKK(5,NHKK) = SIGN(SQRT(ABS(PHKK(5,NHKK))),PHKK(5,NHKK))
28233 PHKK(5,NHKK) = (PHKK(4,NHKK)-PTOT)*(PHKK(4,NHKK)+PTOT)
28234 C IF ((PHKK(5,NHKK).LT.0.0D0).AND.(ABS(PHKK(5,NHKK)).GT.TINY4))
28235 C & WRITE(LOUT,'(1X,A,G10.3)')
28236 C & 'EVTPUT: negative mass**2 ',PHKK(5,NHKK)
28237 PHKK(5,NHKK) = SQRT(ABS(PHKK(5,NHKK)))
28240 IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.(ID.NE.80000)) THEN
28241 * special treatment for chains:
28242 * z coordinate of chain in Lab = pos. of target nucleon
28243 * time of chain-creation in Lab = time of passage of projectile
28244 * nucleus at pos. of taget nucleus
28245 C VHKK(1,NHKK) = 0.5D0*(VHKK(1,MO1)+VHKK(1,MO2))
28246 C VHKK(2,NHKK) = 0.5D0*(VHKK(2,MO1)+VHKK(2,MO2))
28247 VHKK(1,NHKK) = VHKK(1,MO2)
28248 VHKK(2,NHKK) = VHKK(2,MO2)
28249 VHKK(3,NHKK) = VHKK(3,MO2)
28250 VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
28251 C WHKK(1,NHKK) = 0.5D0*(WHKK(1,MO1)+WHKK(1,MO2))
28252 C WHKK(2,NHKK) = 0.5D0*(WHKK(2,MO1)+WHKK(2,MO2))
28253 WHKK(1,NHKK) = WHKK(1,MO1)
28254 WHKK(2,NHKK) = WHKK(2,MO1)
28255 WHKK(3,NHKK) = WHKK(3,MO1)
28256 WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
28260 VHKK(I,NHKK) = VHKK(I,MO1)
28261 WHKK(I,NHKK) = WHKK(I,MO1)
28265 VHKK(I,NHKK) = ZERO
28266 WHKK(I,NHKK) = ZERO
28274 *$ CREATE DT_CHASTA.FOR
28277 *===chasta=============================================================*
28279 SUBROUTINE DT_CHASTA(MODE)
28281 ************************************************************************
28282 * This subroutine performs CHAin STAtistics and checks sequence of *
28283 * partons in dtevt1 and sorts them with projectile partons coming *
28284 * first if necessary. *
28286 * This version dated 8.5.00 is written by S. Roesler. *
28287 ************************************************************************
28289 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28291 PARAMETER ( LINP = 10 ,
28298 PARAMETER (NMXHKK=200000)
28299 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28300 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28301 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28302 * extended event history
28303 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28304 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28306 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
28307 PARAMETER (MAXCHN=10000)
28308 COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
28310 DIMENSION ICHCFG(10,10,9,2),ICHTYP(5,5),
28311 & CCHTYP(9),ICHSTA(10),ITOT(10)
28312 DATA ICHCFG /1800*0/
28313 DATA (ICHTYP(1,K),K=1,5) / 0, 1, 3, 0, 0/
28314 DATA (ICHTYP(2,K),K=1,5) / 2, 0, 0, 5, 0/
28315 DATA (ICHTYP(3,K),K=1,5) / 4, 0, 0, 7, 0/
28316 DATA (ICHTYP(4,K),K=1,5) / 0, 6, 8, 0, 0/
28317 DATA (ICHTYP(5,K),K=1,5) / 0, 0, 0, 0, 9/
28318 DATA ICHSTA / 21, 22, 31, 32, 41, 42, 51, 52, 61, 62/
28319 DATA CCHTYP / ' q aq','aq q ',' q d ',' d q ','aq ad',
28320 & 'ad aq',' d ad','ad d ',' g g '/
28324 IF (MODE.EQ.-1) THEN
28327 * loop over DTEVT1 and analyse chain configurations
28329 ELSEIF (MODE.EQ.0) THEN
28330 DO 21 IDX=NPOINT(3),NHKK
28331 IDCHK = IDHKK(IDX)/10000
28332 IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
28333 & (IDHKK(IDX).NE.80000).AND.
28334 & (ISTHKK(IDX).NE.2).AND.(IDRES(IDX).EQ.0)) THEN
28335 IF (JMOHKK(1,IDX).GT.JMOHKK(2,IDX)) THEN
28336 WRITE(LOUT,*) ' CHASTA: JMOHKK(1,x) > JMOHKK(2,x) ',
28341 IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28342 IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28344 IMO1 = IST1-10*IMO1
28346 IMO2 = IST2-10*IMO2
28347 * swop parton entries if necessary since we need projectile partons
28348 * to come first in the common
28349 IF (IMO1.GT.IMO2) THEN
28350 NPTN = JMOHKK(2,IDX)-JMOHKK(1,IDX)+1
28352 I0 = JMOHKK(1,IDX)-1+K
28353 I1 = JMOHKK(2,IDX)+1-K
28355 ISTHKK(I0) = ISTHKK(I1)
28358 IDHKK(I0) = IDHKK(I1)
28360 IF (JDAHKK(1,JMOHKK(1,I0)).EQ.I0)
28361 & JDAHKK(1,JMOHKK(1,I0)) = I1
28362 IF (JDAHKK(2,JMOHKK(1,I0)).EQ.I0)
28363 & JDAHKK(2,JMOHKK(1,I0)) = I1
28364 IF (JDAHKK(1,JMOHKK(2,I0)).EQ.I0)
28365 & JDAHKK(1,JMOHKK(2,I0)) = I1
28366 IF (JDAHKK(2,JMOHKK(2,I0)).EQ.I0)
28367 & JDAHKK(2,JMOHKK(2,I0)) = I1
28368 IF (JDAHKK(1,JMOHKK(1,I1)).EQ.I1)
28369 & JDAHKK(1,JMOHKK(1,I1)) = I0
28370 IF (JDAHKK(2,JMOHKK(1,I1)).EQ.I1)
28371 & JDAHKK(2,JMOHKK(1,I1)) = I0
28372 IF (JDAHKK(1,JMOHKK(2,I1)).EQ.I1)
28373 & JDAHKK(1,JMOHKK(2,I1)) = I0
28374 IF (JDAHKK(2,JMOHKK(2,I1)).EQ.I1)
28375 & JDAHKK(2,JMOHKK(2,I1)) = I0
28376 ITMP = JMOHKK(1,I0)
28377 JMOHKK(1,I0) = JMOHKK(1,I1)
28378 JMOHKK(1,I1) = ITMP
28379 ITMP = JMOHKK(2,I0)
28380 JMOHKK(2,I0) = JMOHKK(2,I1)
28381 JMOHKK(2,I1) = ITMP
28382 ITMP = JDAHKK(1,I0)
28383 JDAHKK(1,I0) = JDAHKK(1,I1)
28384 JDAHKK(1,I1) = ITMP
28385 ITMP = JDAHKK(2,I0)
28386 JDAHKK(2,I0) = JDAHKK(2,I1)
28387 JDAHKK(2,I1) = ITMP
28392 PHKK(J,I0) = PHKK(J,I1)
28393 VHKK(J,I0) = VHKK(J,I1)
28394 WHKK(J,I0) = WHKK(J,I1)
28400 PHKK(5,I0) = PHKK(5,I1)
28403 IDRES(I0) = IDRES(I1)
28406 IDXRES(I0) = IDXRES(I1)
28409 NOBAM(I0) = NOBAM(I1)
28412 IDBAM(I0) = IDBAM(I1)
28415 IDCH(I0) = IDCH(I1)
28418 IHIST(1,I0) = IHIST(1,I1)
28421 IHIST(2,I0) = IHIST(2,I1)
28425 IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28426 IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28428 * parton 1 (projectile side)
28429 IF (IST1.EQ.21) THEN
28431 ELSEIF (IST1.EQ.22) THEN
28433 ELSEIF (IST1.EQ.31) THEN
28435 ELSEIF (IST1.EQ.32) THEN
28437 ELSEIF (IST1.EQ.41) THEN
28439 ELSEIF (IST1.EQ.42) THEN
28441 ELSEIF (IST1.EQ.51) THEN
28443 ELSEIF (IST1.EQ.52) THEN
28445 ELSEIF (IST1.EQ.61) THEN
28447 ELSEIF (IST1.EQ.62) THEN
28451 c & ' CHASTA: unknown parton status flag (',
28452 c & IST1,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28455 ID = IDHKK(JMOHKK(1,IDX))
28456 IF (ABS(ID).LE.4) THEN
28462 ELSEIF (ABS(ID).GE.1000) THEN
28468 ELSEIF (ID.EQ.21) THEN
28472 & ' CHASTA: inconsistent parton identity (',
28473 & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28477 * parton 2 (target side)
28478 IF (IST2.EQ.21) THEN
28480 ELSEIF (IST2.EQ.22) THEN
28482 ELSEIF (IST2.EQ.31) THEN
28484 ELSEIF (IST2.EQ.32) THEN
28486 ELSEIF (IST2.EQ.41) THEN
28488 ELSEIF (IST2.EQ.42) THEN
28490 ELSEIF (IST2.EQ.51) THEN
28492 ELSEIF (IST2.EQ.52) THEN
28494 ELSEIF (IST2.EQ.61) THEN
28496 ELSEIF (IST2.EQ.62) THEN
28500 c & ' CHASTA: unknown parton status flag (',
28501 c & IST2,') at entry ',JMOHKK(2,IDX),'(',IDX,')'
28504 ID = IDHKK(JMOHKK(2,IDX))
28505 IF (ABS(ID).LE.4) THEN
28511 ELSEIF (ABS(ID).GE.1000) THEN
28517 ELSEIF (ID.EQ.21) THEN
28521 & ' CHASTA: inconsistent parton identity (',
28522 & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28527 ITYPE = ICHTYP(ITYP1,ITYP2)
28528 IF (ITYPE.NE.0) THEN
28529 ICHCFG(IDX1,IDX2,ITYPE,1) =ICHCFG(IDX1,IDX2,ITYPE,1)+1
28530 NGLUON = JMOHKK(2,IDX)-JMOHKK(1,IDX)-1
28531 ICHCFG(IDX1,IDX2,ITYPE,2) =
28532 & ICHCFG(IDX1,IDX2,ITYPE,2)+NGLUON
28535 IF (NCHAIN.GT.MAXCHN) THEN
28536 WRITE(LOUT,*) ' CHASTA: NCHAIN > MAXCHN ! ',
28540 IDXCHN(1,NCHAIN) = IDX
28541 IDXCHN(2,NCHAIN) = ITYPE
28544 & ' CHASTA: inconsistent chain at entry ',IDX
28550 * write statistics to output unit
28552 ELSEIF (MODE.EQ.1) THEN
28553 WRITE(LOUT,'(/,A)') ' CHASTA: generated chain configurations'
28555 WRITE(LOUT,'(/,2A)')
28556 & ' -----------------------------------------',
28557 & '------------------------------------'
28559 & ' p\\t 21 22 31 32 41',
28560 & ' 42 51 52 61 62'
28562 & ' -----------------------------------------',
28563 & '------------------------------------'
28567 ITOT(J) = ITOT(J)+ICHCFG(I,J,K,1)
28570 WRITE(LOUT,'(1X,I2,5X,10I7,/)') ICHSTA(I),(ITOT(J),J=1,10)
28574 ISUM = ISUM+ICHCFG(I,J,K,1)
28577 & WRITE(LOUT,'(1X,A5,2X,10I7)')
28578 & CCHTYP(K),(ICHCFG(I,J,K,1),J=1,10)
28580 C WRITE(LOUT,'(2A)')
28581 C & ' -----------------------------------------',
28582 C & '-------------------------------'
28586 WRITE(LOUT,*) ' CHASTA: MODE ',MODE,' not supported !'
28592 *$ CREATE PHO_PHIST.FOR
28595 *===pohist=============================================================*
28597 SUBROUTINE PHO_PHIST(IMODE,WEIGHT)
28599 IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28602 PARAMETER ( LINP = 10 ,
28605 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
28606 * Glauber formalism: cross sections
28607 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
28608 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
28609 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
28610 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
28611 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
28612 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
28613 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
28614 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
28615 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
28616 & BSLOPE,NEBINI,NQBINI
28619 IF (IMODE.EQ.10) THEN
28623 IF (ABS(IMODE).LT.1000) THEN
28624 * PHOJET-statistics
28625 C CALL POHISX(IMODE,WEIGHT)
28626 IF (IMODE.EQ.-1) THEN
28628 XSTOT(1,1,1) = WEIGHT
28630 IF (IMODE.EQ. 1) MODE = 2
28631 IF (IMODE.EQ.-2) MODE = 3
28632 IF (MODE.EQ.2) CALL DT_SWPPHO(ILAB)
28633 C IF (MODE.EQ.3) WRITE(LOUT,*)
28634 C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization'
28635 CALL DT_HISTOG(MODE)
28636 CALL DT_USRHIS(MODE)
28638 * DTUNUC-statistics
28640 C IF (MODE.EQ.3) WRITE(LOUT,*)
28641 C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization'
28642 CALL DT_HISTOG(MODE)
28643 CALL DT_USRHIS(MODE)
28649 *$ CREATE DT_SWPPHO.FOR
28652 *===swppho=============================================================*
28654 SUBROUTINE DT_SWPPHO(ILAB)
28656 IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28658 PARAMETER ( LINP = 10 ,
28661 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28666 PARAMETER (NMXHKK=200000)
28667 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28668 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28669 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28670 * extended event history
28671 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28672 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28674 * flags for input different options
28675 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28676 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28677 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28678 * properties of photon/lepton projectiles
28679 COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
28682 C PARAMETER (NMXHEP=2000)
28683 C COMMON/HEPEVS/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28684 C &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
28685 C COMMON /GLOCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28686 C COMMON /PLASAV/ PLAB
28688 C standard particle data interface
28690 PARAMETER (NMXHEP=4000)
28691 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28692 DOUBLE PRECISION PHEP,VHEP
28693 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28694 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28695 & VHEP(4,NMXHEP),NSD1, NSD2, NDD
28696 C extension to standard particle data interface (PHOJET specific)
28697 INTEGER IMPART,IPHIST,ICOLOR
28698 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28699 C global event kinematics and particle IDs
28700 INTEGER IFPAP,IFPAB
28701 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
28702 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28706 DATA LSTART /.TRUE./
28708 C IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0).AND.LSTART) THEN
28709 IF ((IFRAME.EQ.1).AND.LSTART) THEN
28713 IDP = IDT_ICIHAD(IFPAP(1))
28714 IDT = IDT_ICIHAD(IFPAP(2))
28716 CALL DT_LTINI(IDP,IDT,ELA,PLA,UMO,0)
28725 IF (MOD(ICOUNT,500).EQ.0) WRITE(LOUT,*)' SWPPHO: event # ',ICOUNT
28727 IF (ISTHEP(I).EQ.1) THEN
28730 IDHKK(NHKK) = IDHEP(I)
28736 PHKK(K,NHKK) = PHEP(K,I)
28737 VHKK(K,NHKK) = ZERO
28738 WHKK(K,NHKK) = ZERO
28740 IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0))
28741 & CALL DT_LTNUC(PHEP(3,I),PHEP(4,I),
28742 & PHKK(3,NHKK),PHKK(4,NHKK),-3)
28743 PHKK(5,NHKK) = PHEP(5,I)
28747 IDBAM(NHKK) = IDT_ICIHAD(IDHEP(I))
28755 *$ CREATE DT_HISTOG.FOR
28758 *===histog=============================================================*
28760 SUBROUTINE DT_HISTOG(MODE)
28762 ************************************************************************
28763 * This version dated 25.03.96 is written by S. Roesler *
28764 ************************************************************************
28766 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28768 PARAMETER ( LINP = 10 ,
28775 PARAMETER (NMXHKK=200000)
28776 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28777 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28778 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28779 * extended event history
28780 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28781 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28783 * event flag used for histograms
28784 COMMON /DTNORM/ ICEVT,IEVHKK
28785 * flags for activated histograms
28786 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
28791 *------------------------------------------------------------------
28795 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,1)
28796 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(1)
28799 *------------------------------------------------------------------
28800 * filling of histogram with event-record
28805 CALL DT_SWPFSP(I,LFSP,LRNL)
28807 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,2)
28808 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(2)
28810 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,5)
28812 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,4)
28815 *------------------------------------------------------------------
28818 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,3)
28819 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(3)
28824 *$ CREATE DT_SWPFSP.FOR
28827 *===swpfsp=============================================================*
28829 SUBROUTINE DT_SWPFSP(IDX,LFSP,LRNL)
28831 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28833 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28834 PARAMETER (TWOPI=6.283185307179586476925286766559D+00,
28836 & BOG =TWOPI/360.0D0)
28839 PARAMETER (NMXHKK=200000)
28840 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28841 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28842 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28843 * extended event history
28844 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28845 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28847 * particle properties (BAMJET index convention)
28849 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28850 & IICH(210),IIBAR(210),K1(210),K2(210)
28851 * Lorentz-parameters of the current interaction
28852 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28853 & UMO,PPCM,EPROJ,PPROJ
28854 * flags for input different options
28855 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28856 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28857 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28858 * (original name: PAREVT)
28859 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
28860 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
28861 PARAMETER ( NALLWP = 39 )
28862 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
28863 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
28864 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
28865 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
28866 * temporary storage for one final state particle
28867 LOGICAL LFRAG,LGREY,LBLACK
28868 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
28869 & SINTHE,COSTHE,THETA,THECMS,
28870 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
28871 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
28872 & LFRAG,LGREY,LBLACK
28880 IF (LEVPRT) ISTRNL = 1001
28882 IF (ABS(ISTHKK(IDX)).EQ.1) THEN
28886 IF (IDHKK(IDX).LT.80000) THEN
28888 IBARY = IIBAR(IDBJT)
28889 ICHAR = IICH(IDBJT)
28891 ELSEIF (IDHKK(IDX).EQ.80000) THEN
28894 ICHAR = IDXRES(IDX)
28895 AMASS = PHKK(5,IDX)
28897 IF ((ICHAR.EQ.1).AND.(INUT.EQ.1)) IDBJT = 116
28898 IF ((ICHAR.EQ.1).AND.(INUT.EQ.2)) IDBJT = 117
28899 IF ((ICHAR.EQ.2).AND.(INUT.EQ.1)) IDBJT = 118
28900 IF ((ICHAR.EQ.2).AND.(INUT.EQ.2)) IDBJT = 119
28901 IF (IDBJT.EQ.0) LFRAG = .TRUE.
28911 PTOT = SQRT(PT2+PZ**2)
28912 SINTHE = PT/MAX(PTOT,TINY14)
28913 COSTHE = PZ/MAX(PTOT,TINY14)
28914 IF (COSTHE.GT.ONE) THEN
28916 ELSEIF (COSTHE.LT.-ONE) THEN
28917 THETA = TWOPI/2.0D0
28919 THETA = ACOS(COSTHE)
28922 **sr 15.4.96 new E_t-definition
28923 IF (IBARY.GT.0) THEN
28925 ELSEIF (IBARY.LT.0) THEN
28926 ET = (EKIN+TWO*AMASS)*SINTHE
28931 XLAB = PZ/MAX(PPROJ,TINY14)
28932 C XLAB = PE/MAX(EPROJ,TINY14)
28933 BETA = SQRT(ABS( (ONE-AMASS/MAX(PE,TINY14))
28934 & *(ONE+AMASS/MAX(PE,TINY14)) ))
28937 IF (PMINUS.GT.TINY14) THEN
28938 YY = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28942 IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
28943 ETA = -LOG(TAN(THETA/TWO))
28947 IF (IFRAME.EQ.1) THEN
28948 CALL DT_LTNUC(PZ,PE,PZCMS,EECMS,3)
28949 PPLUS = EECMS+PZCMS
28950 PMINUS = EECMS-PZCMS
28951 IF ((PPLUS*PMINUS).GT.TINY14) THEN
28952 YYCMS = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28956 PTOTCM = SQRT(PT2+PZCMS**2)
28957 COSTH = PZCMS/MAX(PTOTCM,TINY14)
28958 IF (COSTH.GT.ONE) THEN
28960 ELSEIF (COSTH.LT.-ONE) THEN
28961 THECMS = TWOPI/2.0D0
28963 THECMS = ACOS(COSTH)
28965 IF ((THECMS.GT.TINY14).AND.((PI-THECMS).GT.TINY14)) THEN
28966 ETACMS = -LOG(TAN(THECMS/TWO))
28970 XF = PZCMS/MAX(PPCM,TINY14)
28971 THECMS = THECMS/BOG
28982 * set flag for "grey/black"
28986 IF (IDHKK(IDX).EQ.80000) EK = EKIN/DBLE(IBARY)
28987 IF (MULDEF.EQ.1) THEN
28989 IF ( ( (IDBJT.EQ. 1).AND.(EK.GT. 26.0D-3).AND.
28990 & (EK.LE.375.0D-3) ).OR.
28991 & ( (IDBJT.EQ.13).AND.(EK.GT. 12.0D-3).AND.
28992 & (EK.LE. 56.0D-3) ).OR.
28993 & ( (IDBJT.EQ.14).AND.(EK.GT. 12.0D-3).AND.
28994 & (EK.LE. 56.0D-3) ).OR.
28995 & ( (IDBJT.EQ.15).AND.(EK.GT. 20.0D-3).AND.
28996 & (EK.LE.198.0D-3) ).OR.
28997 & ( (IDBJT.EQ.16).AND.(EK.GT. 20.0D-3).AND.
28998 & (EK.LE.198.0D-3) ).OR.
28999 & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
29000 & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
29001 & (IDBJT.NE.16).AND.
29002 & (BETA.GT.0.23D0).AND.(BETA.LE.0.70D0) ) )
29004 IF ( ( (IDBJT.EQ. 1).AND.(EK.LE. 26.0D-3) ).OR.
29005 & ( (IDBJT.EQ.13).AND.(EK.LE. 12.0D-3) ).OR.
29006 & ( (IDBJT.EQ.14).AND.(EK.LE. 12.0D-3) ).OR.
29007 & ( (IDBJT.EQ.15).AND.(EK.LE. 20.0D-3) ).OR.
29008 & ( (IDBJT.EQ.16).AND.(EK.LE. 20.0D-3) ).OR.
29009 & ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
29010 & (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
29011 & (IDBJT.NE.16).AND.(BETA.LE.0.23D0) ) )
29015 IF ((BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)) LGREY=.TRUE.
29016 IF (BETA.LE.0.23D0) LBLACK=.TRUE.
29019 ELSEIF (ABS(ISTHKK(IDX)).EQ.ISTRNL) THEN
29025 ICHAR = IDXRES(IDX)
29026 AMASS = PHKK(5,IDX)
29033 PTOT = SQRT(PT2+PZ**2)
29034 SINTHE = PT/MAX(PTOT,TINY14)
29035 COSTHE = PZ/MAX(PTOT,TINY14)
29036 IF (COSTHE.GT.ONE) THEN
29038 ELSEIF (COSTHE.LT.-ONE) THEN
29039 THETA = TWOPI/2.0D0
29041 THETA = ACOS(COSTHE)
29044 **sr 15.4.96 new E_t-definition
29048 IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
29049 ETA = -LOG(TAN(THETA/TWO))
29061 *$ CREATE DT_HIMULT.FOR
29064 *===himult=============================================================*
29066 SUBROUTINE DT_HIMULT(MODE)
29068 ************************************************************************
29069 * Tables of average energies/multiplicities. *
29070 * This version dated 30.08.2000 is written by S. Roesler *
29071 ************************************************************************
29073 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29075 PARAMETER ( LINP = 10 ,
29078 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
29080 PARAMETER (SWMEXP=1.7D0)
29082 CHARACTER*8 ANAMEH(4)
29084 * particle properties (BAMJET index convention)
29086 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29087 & IICH(210),IIBAR(210),K1(210),K2(210)
29088 * temporary storage for one final state particle
29089 LOGICAL LFRAG,LGREY,LBLACK
29090 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
29091 & SINTHE,COSTHE,THETA,THECMS,
29092 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
29093 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
29094 & LFRAG,LGREY,LBLACK
29095 * event flag used for histograms
29096 COMMON /DTNORM/ ICEVT,IEVHKK
29097 * Lorentz-parameters of the current interaction
29098 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
29099 & UMO,PPCM,EPROJ,PPROJ
29101 PARAMETER (NOPART=210)
29102 DIMENSION AVMULT(4,NOPART),AVE(4,NOPART),AVSWM(4,NOPART),
29103 & AVPT(4,NOPART),IAVPT(4,NOPART)
29104 DATA ANAMEH /'DEUTERON','3-H ','3-HE ','4-HE '/
29108 *------------------------------------------------------------------
29123 *------------------------------------------------------------------
29124 * filling of histogram with event-record
29126 IF (PE.LT.0.0D0) THEN
29127 WRITE(LOUT,*) ' HIMULT: PE < 0 ! ',PE
29130 IF (.NOT.LFRAG) THEN
29132 IF (LGREY) IVEL = 3
29133 IF (LBLACK) IVEL = 4
29134 AVE(1,IDBJT) = AVE(1,IDBJT) +PE
29135 AVE(IVEL,IDBJT) = AVE(IVEL,IDBJT)+PE
29136 AVPT(1,IDBJT) = AVPT(1,IDBJT) +PT
29137 AVPT(IVEL,IDBJT) = AVPT(IVEL,IDBJT)+PT
29138 IAVPT(1,IDBJT) = IAVPT(1,IDBJT) +1
29139 IAVPT(IVEL,IDBJT) = IAVPT(IVEL,IDBJT)+1
29140 AVSWM(1,IDBJT) = AVSWM(1,IDBJT) +PE**SWMEXP
29141 AVSWM(IVEL,IDBJT) = AVSWM(IVEL,IDBJT)+PE**SWMEXP
29142 AVMULT(1,IDBJT) = AVMULT(1,IDBJT) +ONE
29143 AVMULT(IVEL,IDBJT) = AVMULT(IVEL,IDBJT)+ONE
29144 IF (IDBJT.LT.116) THEN
29145 * total energy, multiplicity
29146 AVE(1,30) = AVE(1,30) +PE
29147 AVE(IVEL,30) = AVE(IVEL,30)+PE
29148 AVPT(1,30) = AVPT(1,30) +PT
29149 AVPT(IVEL,30) = AVPT(IVEL,30)+PT
29150 IAVPT(1,30) = IAVPT(1,30) +1
29151 IAVPT(IVEL,30) = IAVPT(IVEL,30)+1
29152 AVSWM(1,30) = AVSWM(1,30)+PE**SWMEXP
29153 AVSWM(IVEL,30) = AVSWM(IVEL,30)+PE**SWMEXP
29154 AVMULT(1,30) = AVMULT(1,30) +ONE
29155 AVMULT(IVEL,30) = AVMULT(IVEL,30)+ONE
29156 * charged energy, multiplicity
29157 IF (ICHAR.LT.0) THEN
29158 AVE(1,26) = AVE(1,26) +PE
29159 AVE(IVEL,26) = AVE(IVEL,26)+PE
29160 AVPT(1,26) = AVPT(1,26) +PT
29161 AVPT(IVEL,26) = AVPT(IVEL,26)+PT
29162 IAVPT(1,26) = IAVPT(1,26) +1
29163 IAVPT(IVEL,26) = IAVPT(IVEL,26)+1
29164 AVSWM(1,26) = AVSWM(1,26) +PE**SWMEXP
29165 AVSWM(IVEL,26) = AVSWM(IVEL,26)+PE**SWMEXP
29166 AVMULT(1,26) = AVMULT(1,26) +ONE
29167 AVMULT(IVEL,26) = AVMULT(IVEL,26)+ONE
29169 IF (ICHAR.NE.0) THEN
29170 AVE(1,27) = AVE(1,27) +PE
29171 AVE(IVEL,27) = AVE(IVEL,27)+PE
29172 AVPT(1,27) = AVPT(1,27) +PT
29173 AVPT(IVEL,27) = AVPT(IVEL,27)+PT
29174 IAVPT(1,27) = IAVPT(1,27) +1
29175 IAVPT(IVEL,27) = IAVPT(IVEL,27)+1
29176 AVSWM(1,27) = AVSWM(1,27) +PE**SWMEXP
29177 AVSWM(IVEL,27) = AVSWM(IVEL,27)+PE**SWMEXP
29178 AVMULT(1,27) = AVMULT(1,27) +ONE
29179 AVMULT(IVEL,27) = AVMULT(IVEL,27)+ONE
29186 *------------------------------------------------------------------
29190 3000 FORMAT(/,1X,'HIMULT:',21X,'particle - statistics',/,
29191 & 29X,'---------------------',/)
29192 IF (MULDEF.EQ.1) THEN
29193 WRITE(LOUT,'(1X,A,/)') 'fast/grey/black: EMU-def.'
29197 WRITE(LOUT,3002) BETGRE,BETGRE,BETBLC,BETBLC
29198 3002 FORMAT(1X,'fast: beta > ',F4.2,' grey: ',F4.2,' > beta > '
29199 & ,F4.2,' black: beta < ',F4.2,/)
29201 WRITE(LOUT,3003) SWMEXP
29202 3003 FORMAT(1X,'particle |',12X,'average multiplicity',/,
29203 & 13X,'| total fast',
29204 C & ' grey black K f(',F3.1,')',/,1X,
29205 & ' grey black <pt> f(',F3.1,')',/,1X,
29206 & '------------+--------------',
29207 & '-------------------------------------------------')
29210 AVMULT(J,I) = AVMULT(J,I)/DBLE(MAX(ICEVT,1))
29211 AVE(J,I) = AVE(J,I)/DBLE(MAX(ICEVT,1))/EPROJ
29212 AVPT(J,I) = AVPT(J,I)/DBLE(MAX(IAVPT(J,I),1))
29213 AVSWM(J,I) = AVSWM(J,I)/DBLE(MAX(ICEVT,1))/EPROJ**SWMEXP
29216 WRITE(LOUT,3004) ANAME(I),I,
29217 & AVMULT(1,I),AVMULT(2,I),
29218 & AVMULT(3,I),AVMULT(4,I),
29219 C & AVE(1,I),AVSWM(1,I)
29220 & AVPT(1,I),AVSWM(1,I)
29221 ELSEIF (I.LE.119) THEN
29222 WRITE(LOUT,3004) ANAMEH(I-115),I,
29223 & AVMULT(1,I),AVMULT(2,I),
29224 & AVMULT(3,I),AVMULT(4,I),
29225 C & AVE(1,I),AVSWM(1,I)
29226 & AVPT(1,I),AVSWM(1,I)
29228 3004 FORMAT(1X,A8,I4,'| ',2F13.6,2F9.5,2F9.5)
29231 C WRITE(LOUT,'(A,F7.3)') ' number of charged heavy particles: ',
29232 C & AVMULT(3,27)+AVMULT(4,27)
29238 *$ CREATE DT_HISTAT.FOR
29241 *===histat=============================================================*
29243 SUBROUTINE DT_HISTAT(IDX,MODE)
29245 ************************************************************************
29246 * This version dated 26.02.96 is written by S. Roesler *
29248 * Last change 27.12.2006 by S. Roesler. *
29249 ************************************************************************
29251 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29253 PARAMETER ( LINP = 10 ,
29256 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
29257 PARAMETER (NDIM=199)
29260 PARAMETER (NMXHKK=200000)
29261 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
29262 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
29263 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
29264 * extended event history
29265 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
29266 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
29268 * particle properties (BAMJET index convention)
29270 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29271 & IICH(210),IIBAR(210),K1(210),K2(210)
29272 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
29273 * Glauber formalism: cross sections
29274 COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
29275 & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
29276 & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
29277 & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
29278 & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
29279 & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
29280 & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
29281 & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
29282 & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
29283 & BSLOPE,NEBINI,NQBINI
29284 * emulsion treatment
29285 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
29287 * properties of interacting particles
29288 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
29289 * rejection counter
29290 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
29291 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
29292 & IREXCI(3),IRDIFF(2),IRINC
29293 * statistics: residual nuclei
29294 COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
29295 & NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
29296 & NINCST(2,4),NINCEV(2),
29297 & NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
29298 & NRESPB(2),NRESCH(2),NRESEV(4),
29299 & NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
29301 * parameter for intranuclear cascade
29303 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
29304 * (original name: PAREVT)
29305 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
29306 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
29307 PARAMETER ( NALLWP = 39 )
29308 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
29309 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
29310 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
29311 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
29312 * (original name: FRBKCM)
29313 PARAMETER ( MXFFBK = 6 )
29314 PARAMETER ( MXZFBK = 9 )
29315 PARAMETER ( MXNFBK = 10 )
29316 PARAMETER ( MXAFBK = 16 )
29317 PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
29318 PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
29319 PARAMETER ( NXAFBK = MXAFBK + 1 )
29320 PARAMETER ( MXPSST = 300 )
29321 PARAMETER ( MXPSFB = 41000 )
29322 LOGICAL LFRMBK, LNCMSS
29323 COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
29324 & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
29325 & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
29326 & IFRBKN (MXPSST), IFRBKZ (MXPSST),
29327 & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
29328 & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
29329 & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
29330 & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
29331 & IFBFRB, NBUFBK, LFRMBK, LNCMSS
29332 * (original name: INPFLG)
29333 COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
29334 * temporary storage for one final state particle
29335 LOGICAL LFRAG,LGREY,LBLACK
29336 COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
29337 & SINTHE,COSTHE,THETA,THECMS,
29338 & BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
29339 & IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
29340 & LFRAG,LGREY,LBLACK
29341 * event flag used for histograms
29342 COMMON /DTNORM/ ICEVT,IEVHKK
29343 * statistics: double-Pomeron exchange
29344 COMMON /DTFLG2/ INTFLG,IPOPO
29346 DIMENSION EMUSAM(NCOMPX)
29348 CHARACTER*13 CMSG(3)
29349 DATA CMSG /'not requested','not requested','not requested'/
29351 GOTO (1,2,3,4,5) MODE
29353 *------------------------------------------------------------------
29356 * emulsion treatment
29357 IF (NCOMPO.GT.0) THEN
29362 * common /DTSTA2/, statistics on i.n.c., residual nuclei, evap.
29383 IF (J.LE.2) NINCHR(I,J) = 0
29384 IF (J.LE.3) NINCCO(I,J) = 0
29385 IF (J.LE.4) NINCST(I,J) = 0
29394 **dble Po statistics.
29398 *------------------------------------------------------------------
29399 * filling of histogram with event-record
29401 IF (IST.EQ.-1) THEN
29402 IF (.NOT.LFRAG) THEN
29403 IF (IDPDG.EQ.2212) THEN
29404 NEVA(NOBAM(IDX),1) = NEVA(NOBAM(IDX),1)+1
29405 ELSEIF (IDPDG.EQ.2112) THEN
29406 NEVA(NOBAM(IDX),2) = NEVA(NOBAM(IDX),2)+1
29407 ELSEIF (IDPDG.EQ.22) THEN
29408 NEVAGA(NOBAM(IDX)) = NEVAGA(NOBAM(IDX))+1
29409 ELSEIF (IDPDG.EQ.80000) THEN
29410 IF (IDBJT.EQ.116) THEN
29411 NEVA(NOBAM(IDX),3) = NEVA(NOBAM(IDX),3)+1
29412 ELSEIF (IDBJT.EQ.117) THEN
29413 NEVA(NOBAM(IDX),4) = NEVA(NOBAM(IDX),4)+1
29414 ELSEIF (IDBJT.EQ.118) THEN
29415 NEVA(NOBAM(IDX),5) = NEVA(NOBAM(IDX),5)+1
29416 ELSEIF (IDBJT.EQ.119) THEN
29417 NEVA(NOBAM(IDX),6) = NEVA(NOBAM(IDX),6)+1
29421 * heavy fragments (here: fission products only)
29422 NEVAHY(NOBAM(IDX),1,IBARY) = NEVAHY(NOBAM(IDX),1,IBARY)+1
29423 NEVAHY(NOBAM(IDX),2,ICHAR) = NEVAHY(NOBAM(IDX),2,ICHAR)+1
29424 NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29426 ELSEIF ((IST.EQ.1).AND.(.NOT.LFRAG)) THEN
29427 IF (IDCH(IDX).GT.MAXGEN) MAXGEN = IDCH(IDX)
29431 *------------------------------------------------------------------
29435 **dble Po statistics.
29436 C WRITE(LOUT,'(1X,A,2I7,2E12.4)')
29437 C & '# evts. / # dble-Po. evts / s_in / s_popo :',
29438 C & ICEVT,KPOPO,XSPRO(1,1,1),XSPRO(1,1,1)*DBLE(KPOPO)/DBLE(ICEVT)
29440 * emulsion treatment
29441 IF (NCOMPO.GT.0) THEN
29443 3000 FORMAT(/,1X,'HISTAT:',14X,'statistics - target emulsion',/,
29444 & 22X,'----------------------------',/,/,19X,
29445 & 'mass charge fraction',/,39X,
29446 & 'input treated',/)
29448 WRITE(LOUT,3013) I,IEMUMA(I),IEMUCH(I),EMUFRA(I),
29449 & EMUSAM(I)/DBLE(ICEVT)
29450 3013 FORMAT(12X,I2,1X,2I8,6X,F7.3,5X,F7.3)
29454 * i.n.c. statistics: output
29455 WRITE(LOUT,3001) ICEVT,NRESEV(2),IRINC
29456 3001 FORMAT(/,1X,'HISTAT:',14X,'statistics - intranuclear cascade',/,
29457 & 22X,'---------------------------------',/,/,1X,
29458 & 'no. of events for normalization: (accepted final events,',
29459 & ' evt)',4X,I6,/,34X,'(events before evap.-step, evt1)',I6,
29460 & /,1X,'no. of rejected events due to intranuclear',
29461 & ' cascade',15X,I6,/)
29462 ICEV = MAX(ICEVT,1)
29464 IF (LEVPRT) ICEV1 = MAX(NRESEV(2),1)
29466 & (DBLE(NINCWO(I))/DBLE(ICEV),I=1,2),
29467 & ((DBLE(NINCST(I,J))/DBLE(ICEV),I=1,2),J=1,4),
29468 & KTAUGE,DBLE(NINCGE)/DBLE(ICEV),
29469 & (DBLE(NINCCO(I,1)+NINCCO(I,2)+NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29470 & (DBLE(NINCCO(I,2))/DBLE(ICEV1),I=1,2),
29471 & (DBLE(NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29472 & (DBLE(NINCCO(I,1))/DBLE(ICEV1),I=1,2)
29473 3002 FORMAT(1X,'no. of wounded nucl. in proj./ target (mean per evt)',
29474 & 5X,F6.2,' /',F6.2,/,1X,'no. of particles unable to escape',
29475 & ' proj./ target (mean per evt)',/,8X,'baryons: pos. ',
29476 & F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3,/,8X,
29477 & 'mesons: pos. ',F7.3,' /',F7.3,' neg. ',F7.3,' /',F7.3,
29478 & /,1X,'maximum no. of generations treated (maximum allowed:'
29479 & ,I4,')',/,43X,'(mean per evt)',5X,F6.2,/,1X,'no. of sec.',
29480 & ' interactions in proj./ target (mean per evt1)',
29481 & F7.3,' /',F7.3,/,8X,'out of which by inelastic',
29482 & ' interactions',12X,F7.3,' /',F7.3,/,21X,'by elastic ',
29483 & 'interactions',14X,F7.3,' /',F7.3,/,21X,'by absorption ',
29484 & '(ap, K-, pi- only) ',F7.3,' /',F7.3,/)
29485 WRITE(LOUT,3003) NRESEV(2),NRESEV(4),IREXCI,
29486 & IREXCI(1)+IREXCI(2)+IREXCI(3)
29487 3003 FORMAT(/,1X,'HISTAT:',14X,'statistics - residual nuclei, ',
29488 & 'evaporation',/,22X,'-----------------------------',
29489 & '------------',/,/,1X,'no. of events for normal.: ',
29490 & '(events handled by FICONF, evt)',7X,I6,/,28X,'(events',
29491 & ' passing the evap.-step, evt1) ',I6,/,1X,'no. of',
29492 & ' rejected events (',I4,',',I4,',',I4,')',22X,I6,/)
29495 3004 FORMAT(/,22X,'1) before evaporation-step:',/)
29496 ICEV = MAX(NRESEV(2),1)
29498 & (DBLE(NRESTO(I))/DBLE(ICEV),I=1,2),
29499 & (DBLE(NRESPR(I))/DBLE(ICEV),I=1,2),
29500 & (DBLE(NRESNU(I))/DBLE(ICEV),I=1,2),
29501 & (DBLE(NRESBA(I))/DBLE(ICEV),I=1,2),
29502 & (DBLE(NRESPB(I))/DBLE(ICEV),I=1,2),
29503 & (DBLE(NRESCH(I))/DBLE(ICEV),I=1,2),
29504 & (EXCDPM(I)/DBLE(ICEV),I=1,2),
29505 & (EXCDPM(I+2)/DBLE(ICEV),I=1,2)
29506 3005 FORMAT(1X,'residual nuclei: (mean values per evt)',12X,
29507 & 'proj. / target',/,/,8X,'total number of particles',15X,
29508 & 2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29509 & 'neutrons',18X,2F9.3,/,22X,'baryons',19X,2F9.3,/,22X,
29510 & 'pos. baryons',14X,2F9.3,/,8X,'total charge',28X,2F9.3,/,
29511 & /,8X,'excitation energy (bef. evap.-step) ',2E11.3,/,
29512 & 8X,'excitation energy per nucleon ',2E11.3,/,/)
29514 * evaporation / fission / fragmentation statistics: output
29515 ICEV = MAX(NRESEV(2),1)
29516 ICEV1 = MAX(NRESEV(4),1)
29518 & NEVA(1,1)+NEVA(1,2)+NEVA(1,3)+NEVA(1,4)+NEVA(1,5)+NEVA(1,6)
29520 & NEVA(2,1)+NEVA(2,2)+NEVA(2,3)+NEVA(2,4)+NEVA(2,5)+NEVA(2,6)
29522 IF (IFISS.EQ.1) CMSG(1) = 'requested '
29523 IF (LFRMBK) CMSG(2) = 'requested '
29524 IF (LDEEXG) CMSG(3) = 'requested '
29527 & DBLE(NTEVA1)/DBLE(ICEV1),DBLE(NTEVA2)/DBLE(ICEV1),
29528 & (DBLE(NEVA(I,1))/DBLE(ICEV1),I=1,2),
29529 & (DBLE(NEVA(I,2))/DBLE(ICEV1),I=1,2),
29530 & (DBLE(NEVA(I,3))/DBLE(ICEV1),I=1,2),
29531 & (DBLE(NEVA(I,4))/DBLE(ICEV1),I=1,2),
29532 & (DBLE(NEVA(I,5))/DBLE(ICEV1),I=1,2),
29533 & (DBLE(NEVA(I,6))/DBLE(ICEV1),I=1,2),
29534 & (DBLE(NEVAGA(I))/DBLE(ICEV1),I=1,2),
29535 & (DBLE(NEVAHT(I))/DBLE(ICEV1),I=1,2)
29536 3006 FORMAT(22X,'2) after evaporation-step:',/,/,1X,'Fission:',
29537 & 13X,A13,/,1X,'Fermi-Break-up:',6X,A13,/,1X,'Gamma-',
29538 & 'deexcitation:',2X,A13,/,/,
29539 & 1X,'evaporation/deexcitation: (mean values per evt1) ',
29540 & 'proj. / target',/,/,8X,'total number of evap. particles',
29541 & 9X,2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29542 & 'neutrons',18X,2F9.3,/,22X,'deuterons',17X,2F9.3,/,22X,
29543 & '3-H',23X,2F9.3,/,22X,'3-He',22X,2F9.3,/,22X,'4-He',22X,
29544 & 2F9.3,/,8X,'nucl. deexcit. gammas',19X,2F9.3,/,8X,
29545 & 'heavy fragments',25X,2F9.3,/)
29546 IF (IFISS.EQ.1) THEN
29547 WRITE(LOUT,3007) NEVAFI(1,1),NEVAFI(1,2),
29548 & NEVAFI(2,1),NEVAFI(2,2),
29549 & DBLE(NEVAFI(2,1))/DBLE(MAX(NEVAFI(1,1),1))*100.0D0,
29550 & DBLE(NEVAFI(2,2))/DBLE(MAX(NEVAFI(1,2),1))*100.0D0
29551 3007 FORMAT(1X,'Fission: total number of events',14X,2I9,/
29552 & 12X,'out of which fission occured',8X,2I9,/,
29553 & 50X,'(',F5.2,'%) (',F5.2,'%)',/)
29555 C IF ((LFRMBK).OR.(IFISS.EQ.1)) THEN
29557 C3008 FORMAT(1X,'heavy fragments - statistics:',7X,'charge',
29558 C & ' proj. / target',/)
29560 C IF ((NEVAHY(1,2,I).NE.0).OR.(NEVAHY(2,2,I).NE.0)) THEN
29561 C WRITE(LOUT,3009) I,
29562 C & (DBLE(NEVAHY(K,2,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29563 C3009 FORMAT(38X,I3,3X,2E12.3)
29567 C3010 FORMAT(1X,'heavy fragments - statistics:',7X,'mass ',
29568 C & ' proj. / target',/)
29570 C IF ((NEVAHY(1,1,I).NE.0).OR.(NEVAHY(2,1,I).NE.0)) THEN
29571 C WRITE(LOUT,3011) I,
29572 C & (DBLE(NEVAHY(K,1,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29573 C3011 FORMAT(38X,I3,3X,2E12.3)
29580 3012 FORMAT(22X,'2) after evaporation-step:',/,/,1X,
29581 & 'Evaporation: not requested',/)
29585 *------------------------------------------------------------------
29586 * filling of histogram with event-record
29588 * emulsion treatment
29589 IF (NCOMPO.GT.0) THEN
29591 IF (IT.EQ.IEMUMA(I)) THEN
29592 EMUSAM(I) = EMUSAM(I)+ONE
29596 NINCGE = NINCGE+MAXGEN
29598 **dble Po statistics.
29599 IF (IPOPO.EQ.1) KPOPO = KPOPO+1
29602 *------------------------------------------------------------------
29603 * filling of histogram with event-record
29605 IF ((ISTHKK(IDX).EQ.15).OR.(ISTHKK(IDX).EQ.16)) THEN
29606 IB = IIBAR(IDBAM(IDX))
29607 IC = IICH(IDBAM(IDX))
29609 IF ( ((ABS(IB).EQ.1).AND.(IC.EQ.1)).OR.(IC.EQ.0) ) THEN
29610 NINCST(J,1) = NINCST(J,1)+1
29611 ELSEIF ((ABS(IB).EQ.1).AND.(IC.EQ.-1)) THEN
29612 NINCST(J,2) = NINCST(J,2)+1
29613 ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ. 1)) THEN
29614 NINCST(J,3) = NINCST(J,3)+1
29615 ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ.-1)) THEN
29616 NINCST(J,4) = NINCST(J,4)+1
29618 ELSEIF (ISTHKK(IDX).EQ.17) THEN
29619 NINCWO(1) = NINCWO(1)+1
29620 ELSEIF (ISTHKK(IDX).EQ.18) THEN
29621 NINCWO(2) = NINCWO(2)+1
29622 ELSEIF (ISTHKK(IDX).EQ.1001) THEN
29626 NEVAHY(NOBAM(IDX),1,IB) = NEVAHY(NOBAM(IDX),1,IB)+1
29627 NEVAHY(NOBAM(IDX),2,IC) = NEVAHY(NOBAM(IDX),2,IC)+1
29629 NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29635 *$ CREATE DT_NEWHGR.FOR
29638 *===newhgr=============================================================*
29640 SUBROUTINE DT_NEWHGR(XLIM1,XLIM2,XLIM3,XLIMB,IBIN,IREFN)
29642 ************************************************************************
29644 * Histogram initialization. *
29646 * input: XLIM1/XLIM2 lower/upper edge of histogram-window *
29648 * IBIN > 0 number of bins in equidistant lin. binning *
29649 * = -1 reset histograms *
29650 * < -1 |IBIN| number of bins in equidistant log. *
29651 * binning or log. binning in user def. struc. *
29652 * XLIMB(*) user defined bin structure *
29654 * The bin structure is sensitive to *
29655 * XLIM1, XLIM3, IBIN if XLIM3 > 0 (lin.) *
29656 * XLIM1, XLIM2, IBIN if XLIM3 = 0 (lin. & log.) *
29657 * XLIMB, IBIN if XLIM3 < 0 *
29660 * output: IREFN histogram index *
29661 * (= -1 for inconsistent histogr. request) *
29663 * This subroutine is based on a original version by R. Engel. *
29664 * This version dated 22.4.95 is written by S. Roesler. *
29665 ************************************************************************
29667 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29669 PARAMETER ( LINP = 10 ,
29675 PARAMETER (ZERO = 0.0D0,
29681 PARAMETER (NHIS=150, NDIM=250)
29682 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29683 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29684 * auxiliary common for histograms
29685 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29687 DATA LSTART /.TRUE./
29689 * reset histogram counter
29690 IF (LSTART.OR.(IBIN.EQ.-1)) THEN
29692 IF (IBIN.EQ.-1) RETURN
29697 * check for maximum number of allowed histograms
29698 IF (IHIS.GT.NHIS) THEN
29699 WRITE(LOUT,1003) IHIS,NHIS,IHIS
29700 1003 FORMAT(1X,'NEWHGR: warning! number of histograms (',
29701 & I4,') exceeds array size (',I4,')',/,21X,
29702 & 'histogram',I3,' skipped!')
29707 IBINS(IHIS) = ABS(IBIN)
29708 * check requested number of bins
29709 IF (IBINS(IHIS).GE.NDIM) THEN
29710 WRITE(LOUT,1000) IBIN,NDIM,NDIM
29711 1000 FORMAT(1X,'NEWHGR: warning! number of bins (',
29712 & I3,') exceeds array size (',I3,')',/,21X,
29713 & 'and will be reset to ',I3)
29716 IF (IBINS(IHIS).EQ.0) THEN
29717 WRITE(LOUT,1001) IBIN,IHIS
29718 1001 FORMAT(1X,'NEWHGR: warning! inconsistent number of',
29719 & ' bins (',I3,')',/,21X,'histogram',I3,' skipped!')
29723 * initialize arrays
29726 HIST(K,IHIS,I) = ZERO
29727 HIST(K+3,IHIS,I) = ZERO
29728 TMPHIS(K,IHIS,I) = ZERO
29730 HIST(7,IHIS,I) = ZERO
29732 DENTRY(1,IHIS)= ZERO
29733 DENTRY(2,IHIS)= ZERO
29735 UNDERF(IHIS) = ZERO
29736 TMPUFL(IHIS) = ZERO
29737 TMPOFL(IHIS) = ZERO
29739 * bin str. sensitive to lower edge, bin size, and numb. of bins
29740 IF (XLIM3.GT.ZERO) THEN
29741 DO 3 K=1,IBINS(IHIS)+1
29742 HIST(1,IHIS,K) = XLIM1+DBLE(K-1)*XLIM3
29745 * bin str. sensitive to lower/upper edge and numb. of bins
29746 ELSEIF (XLIM3.EQ.ZERO) THEN
29748 IF (IBIN.GT.0) THEN
29751 IF (XLIM2.LE.XLIM1) THEN
29752 WRITE(LOUT,1002) XLIM1,XLIM2
29753 1002 FORMAT(1X,'NEWHGR: warning! inconsistent x-range',
29754 & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29758 ELSEIF (IBIN.LT.-1) THEN
29759 * logarithmic binning
29760 IF ((XLIM1.LE.ZERO).OR.(XLIM2.LE.ZERO)) THEN
29761 WRITE(LOUT,1004) XLIM1,XLIM2
29762 1004 FORMAT(1X,'NEWHGR: warning! inconsistent log. ',
29763 & 'binning',/,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29766 IF (XLIM2.LE.XLIM1) THEN
29767 WRITE(LOUT,1005) XLIM1,XLIM2
29768 1005 FORMAT(1X,'NEWHGR: warning! inconsistent x-range',
29769 & /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29772 XLOW = LOG10(XLIM1)
29776 DX = ABS(XHI-XLOW)/DBLE(MAX(IBINS(IHIS),1))
29777 DO 4 K=1,IBINS(IHIS)+1
29778 HIST(1,IHIS,K) = XLOW+DBLE(K-1)*DX
29781 * user defined bin structure
29782 DO 5 K=1,IBINS(IHIS)+1
29783 IF (IBIN.GT.0) THEN
29784 HIST(1,IHIS,K) = XLIMB(K)
29786 ELSEIF (IBIN.LT.-1) THEN
29787 HIST(1,IHIS,K) = LOG10(XLIMB(K))
29793 * histogram accepted
29803 *$ CREATE DT_FILHGR.FOR
29806 *===filhgr=============================================================*
29808 SUBROUTINE DT_FILHGR(XI,YI,IHIS,NEVT)
29810 ************************************************************************
29812 * Scoring for histogram IHIS. *
29814 * This subroutine is based on a original version by R. Engel. *
29815 * This version dated 23.4.95 is written by S. Roesler. *
29816 ************************************************************************
29818 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29820 PARAMETER ( LINP = 10 ,
29824 PARAMETER (ZERO = 0.0D0,
29829 PARAMETER (NHIS=150, NDIM=250)
29830 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29831 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29832 * auxiliary common for histograms
29833 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29840 * dump content of temorary arrays into histograms
29841 IF ((NEVT.NE.NCEVT).OR.(NEVT.LT.0)) THEN
29842 CALL DT_EVTHIS(IDUM)
29846 * check histogram index
29847 IF (IHIS.EQ.-1) RETURN
29848 IF ((IHIS.LT.1).OR.(IHIS.GT.IHISL)) THEN
29849 C WRITE(LOUT,1000) IHIS,IHISL
29850 1000 FORMAT(1X,'FILHGR: warning! histogram index',I4,
29851 & ' out of range (1..',I3,')')
29855 IF ((ISWI(IHIS).EQ.1).OR.(ISWI(IHIS).EQ.3)) THEN
29856 * bin structure not explicitly given
29857 IF ((ISWI(IHIS).EQ.3).AND.(X.GT.ZERO)) X = LOG10(X)
29858 DX = ABS(HIST(1,IHIS,2)-HIST(1,IHIS,1))
29859 IF (X.LT.HIST(1,IHIS,1)) THEN
29862 I1 = INT( (X-HIST(1,IHIS,1))/MAX(DX,TINY) )+1
29865 ELSEIF ((ISWI(IHIS).EQ.2).OR.(ISWI(IHIS).EQ.4)) THEN
29866 * user defined bin structure
29867 IF ((ISWI(IHIS).EQ.4).AND.(X.GT.ZERO)) X = LOG10(X)
29868 IF (X.LT.HIST(1,IHIS,1)) THEN
29870 ELSE IF (X.GT.HIST(1,IHIS,IBINS(IHIS)+1)) THEN
29873 * binary sort algorithm
29875 KMAX = IBINS(IHIS)+1
29877 IF ((KMAX-KMIN).EQ.1) GOTO 2
29879 IF (X.LE.HIST(1,IHIS,KK)) THEN
29891 1001 FORMAT(1X,'FILHGR: warning! histogram not initialized')
29897 TMPUFL(IHIS) = TMPUFL(IHIS)+ONE
29898 ELSEIF (I1.LE.IBINS(IHIS)) THEN
29899 TMPHIS(1,IHIS,I1) = TMPHIS(1,IHIS,I1)+ONE
29900 IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
29901 TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+10**X
29903 TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+X
29905 TMPHIS(3,IHIS,I1) = TMPHIS(3,IHIS,I1)+Y
29907 TMPOFL(IHIS) = TMPOFL(IHIS)+ONE
29913 *$ CREATE DT_EVTHIS.FOR
29916 *===evthis=============================================================*
29918 SUBROUTINE DT_EVTHIS(NEVT)
29920 ************************************************************************
29921 * Dump content of temorary histograms into /DTHIS1/. This subroutine *
29922 * is called after each event and for the last event before any call *
29924 * NEVT number of events dumped, this is only needed to *
29925 * get the normalization after the last event *
29926 * This version dated 23.4.95 is written by S. Roesler. *
29927 ************************************************************************
29929 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29931 PARAMETER ( LINP = 10 ,
29937 PARAMETER (ZERO = 0.0D0,
29942 PARAMETER (NHIS=150, NDIM=250)
29943 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29944 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29945 * auxiliary common for histograms
29946 COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29956 IF (TMPHIS(1,I,J).GT.ZERO) THEN
29958 HIST(2,I,J) = HIST(2,I,J)+ONE
29959 HIST(7,I,J) = HIST(7,I,J)+TMPHIS(1,I,J)
29960 DENTRY(2,I) = DENTRY(2,I)+TMPHIS(1,I,J)
29961 AVX = TMPHIS(2,I,J)/TMPHIS(1,I,J)
29962 HIST(3,I,J) = HIST(3,I,J)+TMPHIS(3,I,J)*AVX
29963 HIST(4,I,J) = HIST(4,I,J)+TMPHIS(3,I,J)*AVX**2
29964 HIST(5,I,J) = HIST(5,I,J)+TMPHIS(3,I,J)
29965 HIST(6,I,J) = HIST(6,I,J)+TMPHIS(3,I,J)**2
29966 TMPHIS(1,I,J) = ZERO
29967 TMPHIS(2,I,J) = ZERO
29968 TMPHIS(3,I,J) = ZERO
29972 IF (TMPUFL(I).GT.ZERO) THEN
29973 UNDERF(I) = UNDERF(I)+ONE
29975 ELSEIF (TMPOFL(I).GT.ZERO) THEN
29976 OVERF(I) = OVERF(I)+ONE
29980 DENTRY(1,I) = DENTRY(1,I)+ONE
29987 *$ CREATE DT_OUTHGR.FOR
29990 *===outhgr=============================================================*
29992 SUBROUTINE DT_OUTHGR(I1,I2,I3,I4,I5,I6,CHEAD,IHEAD,NEVTS,FAC,
29993 & ILOGY,INORM,NMODE)
29995 ************************************************************************
29997 * Plot histogram(s) to standard output unit *
29999 * I1..6 indices of histograms to be plotted *
30000 * CHEAD,IHEAD header string,integer *
30001 * NEVTS number of events *
30002 * FAC scaling factor *
30003 * ILOGY = 1 logarithmic y-axis *
30004 * INORM normalization *
30005 * = 0 no further normalization (FAC is obsolete) *
30006 * = 1 per event and bin width *
30007 * = 2 per entry and bin width *
30008 * = 3 per bin entry *
30009 * = 4 per event and "bin width" x1^2...x2^2 *
30010 * = 5 per event and "log. bin width" ln x1..ln x2 *
30012 * MODE = 0 no output but normalization applied *
30013 * = 1 all valid histograms separately (small frame) *
30014 * all valid histograms separately (small frame) *
30015 * = -1 and tables as histograms *
30016 * = 2 all valid histograms (one plot, wide frame) *
30017 * all valid histograms (one plot, wide frame) *
30018 * = -2 and tables as histograms *
30021 * Note: All histograms to be plotted with one call to this *
30022 * subroutine and |MODE|=2 must have the same bin structure! *
30023 * There is no test included ensuring this fact. *
30025 * This version dated 23.4.95 is written by S. Roesler. *
30026 ************************************************************************
30028 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30030 PARAMETER ( LINP = 10 ,
30036 PARAMETER (ZERO = 0.0D0,
30047 PARAMETER (NHIS=150, NDIM=250)
30048 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30049 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30051 PARAMETER (NDIM2 = 2*NDIM)
30052 DIMENSION XX(NDIM2),YY(NDIM2)
30054 PARAMETER (NHISTO = 6)
30055 DIMENSION YY1(NDIM,NHISTO),XX1(NDIM,NHISTO),IDX1(NHISTO),
30058 CHARACTER*43 CNORM(0:8)
30059 DATA CNORM /'no further normalization ',
30060 & 'per event and bin width ',
30061 & 'per entry1 and bin width ',
30062 & 'per bin entry ',
30063 & 'per event and "bin width" x1^2...x2^2 ',
30064 & 'per event and "log. bin width" ln x1..ln x2',
30066 & 'per bin entry1 ',
30067 & 'per entry2 and bin width '/
30078 * initialization if "wide frame" is requested
30079 IF (ABS(MODE).EQ.2) THEN
30089 WRITE(LOUT,'(/1X,A,I3,/,1X,70A1)') CHEAD,IHEAD,('=',II=1,70)
30091 * check histogram indices
30094 IF ((IDX1(I).GE.1).AND.(IDX1(I).LE.IHISL)) THEN
30095 IF (ISWI(IDX1(I)).NE.0) THEN
30096 IF (DENTRY(1,IDX1(I)).LT.ONE) THEN
30098 & IDX1(I),UNDERF(IDX1(I)),OVERF(IDX1(I))
30099 1000 FORMAT(/,1X,'OUTHGR: warning! no entries in',
30100 & ' histogram ',I3,/,21X,'underflows:',F10.0,
30101 & ' overflows: ',F10.0)
30111 1001 FORMAT(/,1X,'OUTHGR: warning! histogram indices not valid')
30115 * check normalization request
30116 IF ( ((FAC.EQ.ZERO).AND.(INORM.NE.0)).OR.
30117 & ((NEVTS.LT.1).AND.((INORM.EQ.1).OR.(INORM.EQ.4).OR.
30118 & (INORM.EQ.5).OR.(INORM.EQ.6))).OR.
30119 & (INORM.LT.0).OR.(INORM.GT.8) ) THEN
30120 WRITE(LOUT,1002) NEVTS,INORM,FAC
30121 1002 FORMAT(/,1X,'OUTHGR: warning! normalization request not ',
30122 & 'valid',/,21X,'NEVTS = ',I7,4X,'INORM = ',I2,4X,
30127 WRITE(LOUT,'(/,1X,A,I8)') 'number of events:',NEVTS
30129 * apply normalization
30134 IF (ISWI(I).EQ.1) THEN
30135 WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30136 1003 FORMAT(/,1X,'histo.',I4,', linear binning from',2X,E10.4,
30137 & ' to',2X,E10.4,',',2X,I3,' bins')
30138 ELSEIF (ISWI(I).EQ.2) THEN
30139 WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30141 1007 FORMAT(1X,'user defined bin structure')
30142 ELSEIF (ISWI(I).EQ.3) THEN
30144 & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30145 1004 FORMAT(/,1X,'histo.',I4,', logar. binning from',2X,E10.4,
30146 & ' to',2X,E10.4,',',2X,I3,' bins')
30147 ELSEIF (ISWI(I).EQ.4) THEN
30149 & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30152 WRITE(LOUT,1008) ISWI(I)
30153 1008 FORMAT(/,1X,'warning! inconsistent bin structure flag ',I4)
30155 WRITE(LOUT,1005) DENTRY(1,I),DENTRY(2,I),UNDERF(I),OVERF(I)
30156 1005 FORMAT(13X,'entries:',2F9.0,' underfl.:',F8.0,
30157 & ' overfl.:',F8.0)
30158 WRITE(LOUT,1009) CNORM(INORM)
30159 1009 FORMAT(1X,'normalization: ',A,/)
30162 CALL DT_GETBIN(I,K,NEVTS,INORM,XLOW,XHI,XMEAN,YMEAN,YERR)
30165 WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,YERR,HIST(2,I,K)
30166 WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,YERR,HIST(2,I,K)
30167 1006 FORMAT(1X,5E11.3)
30170 XX(II-1) = HIST(1,I,K)
30171 XX(II) = HIST(1,I,K+1)
30176 IF ((ISWI(I).EQ.3).OR.(ISWI(I).EQ.4))
30177 & XX1(K,N) = LOG10(XMEAN)
30182 IF (ABS(MODE).EQ.1) THEN
30184 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30185 IF(ILOGY.EQ.1) THEN
30186 CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30188 CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30195 IF (ABS(MODE).EQ.2) THEN
30196 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30197 NSIZE = NDIM*NHISTO
30198 DXLOW = HIST(1,IDX(1),1)
30199 DDX = ABS(HIST(1,IDX(1),2)-HIST(1,IDX(1),1))
30204 IF (YY1(J,I).LT.YLOW) THEN
30205 IF (ILOGY.EQ.1) THEN
30206 IF (YY1(J,I).GT.ZERO) YLOW = YY1(J,I)
30211 IF (YY1(J,I).GT.YHI) YHI = YY1(J,I)
30214 DY = (YHI-YLOW)/DBLE(NDIM)
30215 IF (DY.LE.ZERO) THEN
30216 WRITE(LOUT,'(1X,A,6I4,A,2E12.4)')
30217 & 'OUTHGR: warning! zero bin width for histograms ',
30218 & IDX,': ',YLOW,YHI
30221 IF (ILOGY.EQ.1) THEN
30223 DY = (LOG10(YHI)-YLOW)/100.0D0
30226 IF (YY1(J,I).LE.ZERO) THEN
30229 YY1(J,I) = LOG10(YY1(J,I))
30234 CALL DT_SRPLOT(XX1,YY1,NSIZE,NHISTO,NDIM,DXLOW,DDX,YLOW,DY)
30240 *$ CREATE DT_GETBIN.FOR
30243 *===getbin=============================================================*
30245 SUBROUTINE DT_GETBIN(IHIS,IBIN,KEVT,NORM,XLOW,XHI,
30246 & XMEAN,YMEAN,YERR)
30248 ************************************************************************
30249 * This version dated 23.4.95 is written by S. Roesler. *
30250 ************************************************************************
30252 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30254 PARAMETER ( LINP = 10 ,
30258 PARAMETER (ZERO = 0.0D0,
30260 & TINY35 = 1.0D-35)
30263 PARAMETER (NHIS=150, NDIM=250)
30264 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30265 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30267 XLOW = HIST(1,IHIS,IBIN)
30268 XHI = HIST(1,IHIS,IBIN+1)
30269 IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
30273 IF (NORM.EQ.2) THEN
30275 NEVT = INT(DENTRY(1,IHIS))
30276 ELSEIF (NORM.EQ.3) THEN
30278 NEVT = INT(HIST(2,IHIS,IBIN))
30279 ELSEIF (NORM.EQ.4) THEN
30280 DX = XHI**2-XLOW**2
30282 ELSEIF (NORM.EQ.5) THEN
30283 DX = LOG(ABS(XHI))-LOG(ABS(XLOW))
30285 ELSEIF (NORM.EQ.6) THEN
30288 ELSEIF (NORM.EQ.7) THEN
30290 NEVT = INT(HIST(7,IHIS,IBIN))
30291 ELSEIF (NORM.EQ.8) THEN
30293 NEVT = INT(DENTRY(2,IHIS))
30298 IF (ABS(DX).LT.TINY35) DX = ONE
30300 YMEAN = HIST(5,IHIS,IBIN)/DX/DBLE(NEVT)
30301 YMEAN2 = HIST(6,IHIS,IBIN)/DX**2/DBLE(NEVT)
30302 YERR = SQRT(ABS(YMEAN2-YMEAN**2))/SQRT(DBLE(NEVT))
30303 YSUM = HIST(5,IHIS,IBIN)
30304 IF (ABS(YSUM).LT.TINY35) YSUM = ONE
30305 C XMEAN = HIST(3,IHIS,IBIN)/YSUM/MAX(HIST(2,IHIS,IBIN),ONE)
30306 XMEAN = HIST(3,IHIS,IBIN)/YSUM
30307 IF (XMEAN.EQ.ZERO) XMEAN = XLOW
30312 *$ CREATE DT_JOIHIS.FOR
30315 *===joihis=============================================================*
30317 SUBROUTINE DT_JOIHIS(IH1,IH2,COPER,FAC1,FAC2,KEVT,NORM,ILOGY,MODE)
30319 ************************************************************************
30321 * Operation on histograms. *
30323 * input: IH1,IH2 histogram indices to be joined *
30324 * COPER character defining the requested operation, *
30325 * i.e. '+', '-', '*', '/' *
30326 * FAC1,FAC2 factors for joining, i.e. *
30327 * FAC1*histo1 COPER FAC2*histo2 *
30329 * This version dated 23.4.95 is written by S. Roesler. *
30330 ************************************************************************
30332 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30334 PARAMETER ( LINP = 10 ,
30340 PARAMETER (ZERO = 0.0D0,
30348 PARAMETER (NHIS=150, NDIM=250)
30349 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30350 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30352 PARAMETER (NDIM2 = 2*NDIM)
30353 DIMENSION XX(NDIM2),YY(NDIM2),YY1(NDIM),XX1(NDIM)
30355 CHARACTER*43 CNORM(0:6)
30356 DATA CNORM /'no further normalization ',
30357 & 'per event and bin width ',
30358 & 'per entry and bin width ',
30359 & 'per bin entry ',
30360 & 'per event and "bin width" x1^2...x2^2 ',
30361 & 'per event and "log. bin width" ln x1..ln x2',
30364 * check histogram indices
30365 IF ((IH1.LT. 1).OR.(IH2.LT. 1).OR.
30366 & (IH1.GT.IHISL).OR.(IH2.GT.IHISL)) THEN
30367 WRITE(LOUT,1000) IH1,IH2,IHISL
30368 1000 FORMAT(1X,'JOIHIS: warning! inconsistent histogram ',
30369 & 'indices (',I3,',',I3,'),',/,21X,'valid range: 1,',I3)
30373 * check bin structure of histograms to be joined
30374 IF (IBINS(IH1).NE.IBINS(IH2)) THEN
30375 WRITE(LOUT,1001) IH1,IH2,IBINS(IH1),IBINS(IH2)
30376 1001 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3,
30377 & ' and ',I3,' failed',/,21X,
30378 & 'due to different numbers of bins (',I3,',',I3,')')
30381 DO 1 K=1,IBINS(IH1)+1
30382 IF (ABS(HIST(1,IH1,K)-HIST(1,IH2,K)).GT.TINY8) THEN
30383 WRITE(LOUT,1002) IH1,IH2,K,HIST(1,IH1,K),HIST(1,IH2,K)
30384 1002 FORMAT(1X,'JOIHIS: warning! joining histograms ',I3,
30385 & ' and ',I3,' failed at bin edge ',I3,/,21X,
30386 & 'X1,X2 = ',2E11.4)
30391 WRITE(LOUT,1003) IH1,IH2,COPER,FAC1,FAC2
30392 1003 FORMAT(1X,'JOIHIS: joining histograms ',I3,',',I3,' with ',
30393 & 'operation ',A,/,11X,'and factors ',2E11.4)
30394 WRITE(LOUT,1004) CNORM(NORM)
30395 1004 FORMAT(1X,'normalization: ',A,/)
30397 DO 2 K=1,IBINS(IH1)
30398 CALL DT_GETBIN(IH1,K,KEVT,NORM,XLOW1,XHI1,XMEAN1,YMEAN1,YERR1)
30399 CALL DT_GETBIN(IH2,K,KEVT,NORM,XLOW2,XHI2,XMEAN2,YMEAN2,YERR2)
30402 XMEAN = OHALF*(XMEAN1+XMEAN2)
30403 IF (COPER.EQ.'+') THEN
30404 YMEAN = FAC1*YMEAN1+FAC2*YMEAN2
30405 ELSEIF (COPER.EQ.'*') THEN
30406 YMEAN = FAC1*YMEAN1*FAC2*YMEAN2
30407 ELSEIF (COPER.EQ.'/') THEN
30408 IF (YMEAN2.EQ.ZERO) THEN
30411 IF (FAC2.EQ.ZERO) FAC2 = ONE
30412 YMEAN = FAC1*YMEAN1/(FAC2*YMEAN2)
30417 WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30418 WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30419 1006 FORMAT(1X,5E11.3)
30422 XX(II-1) = HIST(1,IH1,K)
30423 XX(II) = HIST(1,IH1,K+1)
30428 IF ((ISWI(IH1).EQ.3).OR.(ISWI(IH1).EQ.4)) XX1(K) = LOG10(XMEAN)
30433 IF (ABS(MODE).EQ.1) THEN
30434 IBIN2 = 2*IBINS(IH1)
30435 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30436 IF(ILOGY.EQ.1) THEN
30437 CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30439 CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30444 IF (ABS(MODE).EQ.2) THEN
30445 WRITE(LOUT,'(/,1X,A)') 'Preview:'
30447 DXLOW = HIST(1,IH1,1)
30448 DDX = ABS(HIST(1,IH1,2)-HIST(1,IH1,1))
30452 IF (YY1(I).LT.YLOW) THEN
30453 IF (ILOGY.EQ.1) THEN
30454 IF (YY1(I).GT.ZERO) YLOW = YY1(I)
30459 IF (YY1(I).GT.YHI) YHI = YY1(I)
30461 DY = (YHI-YLOW)/DBLE(NDIM)
30462 IF (DY.LE.ZERO) THEN
30463 WRITE(LOUT,'(1X,A,2I4,A,2E12.4)')
30464 & 'JOIHIS: warning! zero bin width for histograms ',
30465 & IH1,IH2,': ',YLOW,YHI
30468 IF (ILOGY.EQ.1) THEN
30470 DY = (LOG10(YHI)-YLOW)/100.0D0
30472 IF (YY1(I).LE.ZERO) THEN
30475 YY1(I) = LOG10(YY1(I))
30479 CALL DT_SRPLOT(XX1,YY1,NSIZE,1,NDIM,DXLOW,DDX,YLOW,DY)
30485 WRITE(LOUT,1005) COPER
30486 1005 FORMAT(1X,'JOIHIS: unknown operation ',A)
30492 *$ CREATE DT_XGRAPH.FOR
30495 *===qgraph=============================================================*
30497 SUBROUTINE DT_XGRAPH(N,IARG,X,Y1,Y2)
30498 C***********************************************************************
30500 C calculate quasi graphic picture with 25 lines and 79 columns
30501 C ranges will be chosen automatically
30503 C input N dimension of input fields
30504 C IARG number of curves (fields) to plot
30509 C This subroutine is written by R. Engel.
30510 C***********************************************************************
30511 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30514 PARAMETER ( LINP = 10 ,
30518 DIMENSION X(N),Y1(N),Y2(N)
30519 PARAMETER (EPS=1.D-30)
30520 PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30522 CHARACTER COL(0:149,0:49)
30524 DATA SYMB /'0','e','z','#','x'/
30528 C*** automatic range fitting
30533 XMAX=MAX(X(I),XMAX)
30534 XMIN=MIN(X(I),XMIN)
30536 XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30539 DO 1100 K=0,IZEIL-1
30541 IF (ITEST.EQ.IYRAST) THEN
30542 DO 1010 L=1,ISPALT-1
30547 DO 1020 L=0,ISPALT-1,IXRAST
30551 DO 1030 L=1,ISPALT-1
30554 DO 1040 L=0,ISPALT-1,IXRAST
30566 YMAX=MAX(Y1(I),YMAX)
30567 YMIN=MIN(Y1(I),YMIN)
30571 YMAX=MAX(Y2(I),YMAX)
30572 YMIN=MIN(Y2(I),YMIN)
30575 YMAX=(YMAX-YMIN)/40.0D0+YMAX
30576 YMIN=YMIN-(YMAX-YMIN)/40.0D0
30577 YZOOM=(YMAX-YMIN)/DBLE(IZEIL)
30578 IF(YZOOM.LT.EPS) THEN
30579 WRITE(LOUT,'(1X,A)')
30580 & 'XGRAPH:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30589 L=NINT((X(K)-XMIN)/XZOOM)
30590 I=NINT((YMAX-Y1(K))/YZOOM)
30591 IF(ILAST.GE.0) THEN
30594 DO 55 II=0,LD,SIGN(1,LD)
30595 DO 66 KK=0,ID,SIGN(1,ID)
30596 COL(II+LLAST,KK+ILAST)=SYMB(1)
30611 L=NINT((X(K)-XMIN)/XZOOM)
30612 I=NINT((YMAX-Y2(K))/YZOOM)
30619 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30621 C*** write range of X
30623 XZOOM = (XMAX-XMIN)/DBLE(7)
30624 WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30626 DO 1300 K=0,IZEIL-1
30627 YPOS=YMAX-((DBLE(K)+0.5D0)*YZOOM)
30628 WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30629 110 FORMAT(1X,1PE9.2,70A1)
30632 C*** write range of X
30634 XZOOM = (XMAX-XMIN)/DBLE(7)
30635 WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30636 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30637 120 FORMAT(6X,7(1PE10.3))
30640 *$ CREATE DT_XGLOGY.FOR
30643 *===qglogy=============================================================*
30645 SUBROUTINE DT_XGLOGY(N,IARG,X,Y1,Y2)
30646 C***********************************************************************
30648 C calculate quasi graphic picture with 25 lines and 79 columns
30649 C logarithmic y axis
30650 C ranges will be chosen automatically
30652 C input N dimension of input fields
30653 C IARG number of curves (fields) to plot
30658 C This subroutine is written by R. Engel.
30659 C***********************************************************************
30661 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30664 PARAMETER ( LINP = 10 ,
30667 DIMENSION X(N),Y1(N),Y2(N)
30668 PARAMETER (EPS=1.D-30)
30669 PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30671 CHARACTER COL(0:149,0:49)
30672 PARAMETER (DEPS = 1.D-10)
30674 DATA SYMB /'0','e','z','#','x'/
30678 C*** automatic range fitting
30683 XMAX=MAX(X(I),XMAX)
30684 XMIN=MIN(X(I),XMIN)
30686 XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30689 DO 1100 K=0,IZEIL-1
30691 IF (ITEST.EQ.IYRAST) THEN
30692 DO 1010 L=1,ISPALT-1
30697 DO 1020 L=0,ISPALT-1,IXRAST
30701 DO 1030 L=1,ISPALT-1
30704 DO 1040 L=0,ISPALT-1,IXRAST
30714 YMIN=MAX(Y1(1),EPS)
30716 YMAX =MAX(Y1(I),YMAX)
30717 IF(Y1(I).GT.EPS) THEN
30718 IF(YMIN.EQ.EPS) THEN
30721 YMIN = MIN(Y1(I),YMIN)
30727 YMAX=MAX(Y2(I),YMAX)
30728 IF(Y2(I).GT.EPS) THEN
30729 IF(YMIN.EQ.EPS) THEN
30732 YMIN = MIN(Y2(I),YMIN)
30739 Y1(I) = MAX(Y1(I),YMIN)
30743 Y2(I) = MAX(Y2(I),YMIN)
30747 IF(YMAX.LE.YMIN) THEN
30748 WRITE(LOUT,'(/1X,A,2E12.3,/)')
30749 & 'XGLOGY:ERROR:YMIN,YMAX ',YMIN,YMAX
30750 WRITE(LOUT,'(1X,A)') 'MIN = MAX, OUTPUT SUPPRESSED'
30754 YMA=(LOG10(YMAX)-LOG10(YMIN))/20.0D0+LOG10(YMAX)
30755 YMI=LOG10(YMIN)-(LOG10(YMAX)-LOG10(YMIN))/20.0D0
30756 YZOOM=(YMA-YMI)/DBLE(IZEIL)
30757 IF(YZOOM.LT.EPS) THEN
30758 WRITE(LOUT,'(1X,A)')
30759 & 'XGLOGY:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30768 L=NINT((X(K)-XMIN)/XZOOM)
30769 I=NINT((YMA-LOG10(Y1(K)))/YZOOM)
30770 IF(ILAST.GE.0) THEN
30773 DO 55 II=0,LD,SIGN(1,LD)
30774 DO 66 KK=0,ID,SIGN(1,ID)
30775 COL(II+LLAST,KK+ILAST)=SYMB(1)
30790 L=NINT((X(K)-XMIN)/XZOOM)
30791 I=NINT((YMA-LOG10(Y2(K)))/YZOOM)
30798 WRITE(LOUT,'(2X,A)') '(LOGARITHMIC Y AXIS)'
30799 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30801 C*** write range of X
30803 XZOOM1 = (XMAX-XMIN)/DBLE(7)
30804 WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30806 DO 1300 K=0,IZEIL-1
30807 YPOS=10.D0**(YMA-((DBLE(K)+0.5D0)*YZOOM))
30808 WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30809 110 FORMAT(1X,1PE9.2,70A1)
30812 C*** write range of X
30814 WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30815 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30816 120 FORMAT(6X,7(1PE10.3))
30820 *$ CREATE DT_SRPLOT.FOR
30823 *===plot===============================================================*
30825 SUBROUTINE DT_SRPLOT(X,Y,N,M,MM,XO,DX,YO,DY)
30827 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30830 PARAMETER ( LINP = 10 ,
30835 * J. Ranft, (FORTRAN-Programmierung,J.R.,Teubner, Leipzig, 72)
30836 * This is a subroutine of fluka to plot Y across the page
30837 * as a function of X down the page. Up to 37 curves can be
30838 * plotted in the same picture with different plotting characters.
30839 * Output of first 10 overprinted characters addad by FB 88
30840 * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
30843 * X = array containing the values of X
30844 * Y = array containing the values of Y
30845 * N = number of values in X and in Y
30846 * can exceed the fixed number of lines
30847 * M = number of different curves X,Y are containing
30848 * MM = number of points in each curve i.e. N=M*MM
30849 * XO = smallest value of X to be plotted
30850 * DX = increment of X between subsequent lines
30851 * YO = smallest value of Y to be plotted
30852 * DY = increment of Y between subsequent character spaces
30854 * other variables used inside:
30855 * XX = numbers along the X-coordinate axis
30856 * YY = numbers along the Y-coordinate axis
30857 * LL = ten lines temporary storage for the plot
30858 * L = character set used to plot different curves
30859 * LOV = memorizes overprinted symbols
30860 * the first 10 overprinted symbols are printed on
30861 * the end of the line to avoid ambiguities
30862 * (added by FB as considered quite helpful)
30864 *********************************************************************
30866 DIMENSION XX(61),YY(61),LL(101,10)
30867 DIMENSION X(N),Y(N),L(40),LOV(40,10)
30868 INTEGER*4 LL, L, LOV
30870 11H*,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HZ,
30871 21H+,1HA,1HO,1HB,1HC,1HD,1HE,1HF,1HG,1HH,
30872 31HI,1HJ,1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,
30873 41HS,1HT,1HU,1HV,1HW,1HX,1HY,1H1,1H-,1H /
30882 20 YY(I)=YO+10.0D0*AI*DY
30883 WRITE(LOUT, 500) (YY(I),I=1,11)
30905 AIX=(X(II)-(XO-DX/2.0D0))/DX+1.0D0
30906 AIY=(Y(II)-(YO-DY/2.0D0))/DY+1.0D0
30908 * changed Sept.88 by FB to avoid INTEGER OVERFLOW
30909 IF( AIX .GT. 1.D0.AND. AIX .LT. 11.D0.AND. AIY .GT. 1.D0.AND
30910 + . AIY .LT. 102.D0) THEN
30913 IF( IX.GT. 0.AND. IX.LE. 10.AND. IY.GT. 0.AND. IY.LE. 101)
30915 IF(LL(IY,IX).NE.L(38).AND.LL(IY,IX).NE.L(39)) LOV(I,IX)
30926 WRITE(LOUT,510) XX(II),XX(III) , (LL(J,I),J=1,101) ,
30927 & (LOV(J,I),J=1,10)
30933 WRITE(LOUT, 500) (YY(I),I=1,11)
30936 500 FORMAT(11X,11(1PE10.2),11HOVERPRINTED)
30937 510 FORMAT(1X,2(1PE10.2),101A1,1H ,10A1)
30938 520 FORMAT(20X,10('1---------'),'1')
30941 *$ CREATE DT_DEFSET.FOR
30944 *===defset=============================================================*
30946 BLOCK DATA DT_DEFSET
30948 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30951 * flags for input different options
30952 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
30953 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
30954 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
30955 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
30956 * emulsion treatment
30957 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
30961 DATA IFRAG / 2, 1 /
30965 DATA IOULEV / -1, -1, -1, -1, -1, -1 /
30966 DATA LEMCCK / .FALSE. /
30967 DATA LHADRO / .FALSE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,
30968 & .TRUE.,.TRUE.,.TRUE./
30969 DATA LSEADI / .TRUE. /
30970 DATA LEVAPO / .TRUE. /
30975 DATA EMUFRA / NCOMPX*0.0D0 /
30976 DATA IEMUMA / NCOMPX*1 /
30977 DATA IEMUCH / NCOMPX*1 /
30983 *$ CREATE DT_HADPRP.FOR
30986 *===hadprp=============================================================*
30988 BLOCK DATA DT_HADPRP
30990 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30993 * auxiliary common for reggeon exchange (DTUNUC 1.x)
30994 COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
30995 & IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
30996 & IQTCHR(-6:6),MQUARK(3,39)
30997 * hadron index conversion (BAMJET <--> PDG)
30998 COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
30999 & IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
31001 * names of hadrons used in input-cards
31003 COMMON /DTPAIN/ BTYPE(30)
31006 *----------------------------------------------------------------------*
31008 * Quark content of particles: *
31009 * index quark el. charge bar. charge isospin isospin3 *
31010 * 1 = u 2/3 1/3 1/2 1/2 *
31011 * -1 = ubar -2/3 -1/3 1/2 -1/2 *
31012 * 2 = d -1/3 1/3 1/2 -1/2 *
31013 * -2 = dbar 1/3 -1/3 1/2 1/2 *
31014 * 3 = s -1/3 1/3 0 0 *
31015 * -3 = sbar 1/3 -1/3 0 0 *
31016 * 4 = c 2/3 1/3 0 0 *
31017 * -4 = cbar -2/3 -1/3 0 0 *
31018 * 5 = b -1/3 1/3 0 0 *
31019 * -5 = bbar 1/3 -1/3 0 0 *
31020 * 6 = t 2/3 1/3 0 0 *
31021 * -6 = tbar -2/3 -1/3 0 0 *
31023 * Mquark = particle quark composition (Paprop numbering) *
31024 * Iqechr = electric charge ( in 1/3 unit ) *
31025 * Iqbchr = baryonic charge ( in 1/3 unit ) *
31026 * Iqichr = isospin ( in 1/2 unit ), z component *
31027 * Iqschr = strangeness *
31029 * Iquchr = beauty *
31030 * Iqtchr = ...... *
31032 *----------------------------------------------------------------------*
31033 DATA IQECHR / -2, 1, -2, 1, 1, -2, 0, 2, -1, -1, 2, -1, 2 /
31034 DATA IQBCHR / 6*-1, 0, 6*1 /
31035 DATA IQICHR / 4*0, 1, -1, 0, 1, -1, 4*0 /
31036 DATA IQSCHR / 3*0, 1, 5*0, -1, 3*0 /
31037 DATA IQCCHR / 2*0, -1, 7*0, 1, 2*0 /
31038 DATA IQUCHR / 0, 1, 9*0, -1, 0 /
31039 DATA IQTCHR / -1, 11*0, 1 /
31041 & 2, 1, 1, -2,-1,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31042 & 0, 0, 0, 0, 0, 0, 2, 2, 1, -2,-2,-1, 0, 0, 0,
31043 & 0, 0, 0, 0, 0, 0, 1,-2, 0, 2,-1, 0, 1,-3, 0,
31044 & 3,-1, 0, 1, 2, 3, -1,-2,-3, 0, 0, 0, 2, 2, 3,
31045 & 1, 1, 3, 1, 2, 3, 1,-1, 0, 2,-3, 0, 3,-2, 0,
31046 & 2,-2, 0, 3,-3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31047 & -1,-1,-3, -1,-2,-3, -2,-2,-3, 1, 3, 3, -1,-3,-3,
31048 & 2, 3, 3, -2,-3,-3, 3, 3, 3, -3,-3,-3 /
31051 * (renamed) (HAdron InDex COnversion)
31052 * translation table version filled up by r.e. 25.01.94 *
31054 &2212,-2212,11,-11,12, -12,22,2112,-2112,-13,
31055 &13,130,211,-211,321, -321,3122,-3122,310,3112,
31056 &3222,3212,111,311,-311, 0,0,0,0,0,
31057 &221,213,113,-213,223, 323,313,-323,-313,10323,
31058 &10313,-10323,-10313,30323,30313, -30323,-30313,3224,3214,3114,
31059 &3216,3218,2224,2214,2114, 1114,12224,12214,12114,11114,
31060 &99999,99999,22212,22112,32124, 31214,-2224,-2214,-2114,-1114,
31061 &-12224,-12214,-12114,-11114,-2124, -1214,4*99999,
31063 &4*99999,331, 333,3322,3312,-3222,-3212,
31064 &-3112,-3322,-3312,3224,3214, 3114,3324,3314,3334,-3224,
31065 &-3214,-3114,-3324,-3314,-3334, 421,411,-411,-421,431,
31066 &-431,441,423,413,-413, -423,433,-433,20443,443,
31067 &-15,15,16,-16,14, -14,4122,4232,4132,4222,
31068 &4212,4112,3*99999, 3*99999,-4122,-4232,
31069 &-4132,-4222,-4212,-4112,99999, 5*99999,
31072 &5*99999 , 20211,20111,-20211,99999,20321,
31073 &-20321,20311,-20311,7*99999 ,
31074 &7*99999,12212,12112,99999/
31077 * (HAdron InDex COnversion)
31078 DATA (IPDG2(1,K),K=1,7)
31079 & / -11, -12, -13, -15, -16, -14, 0/
31080 DATA (IBAM2(1,K),K=1,7)
31081 & / 4, 6, 10, 131, 134, 136, 0/
31082 DATA (IPDG2(2,K),K=1,7)
31083 & / 11, 12, 22, 13, 15, 16, 14/
31084 DATA (IBAM2(2,K),K=1,7)
31085 & / 3, 5, 7, 11, 132, 133, 135/
31086 DATA (IPDG3(1,K),K=1,22)
31087 & / -211, -321, -311, -213, -323, -313, -411, -421,
31088 & -431, -413, -423, -433, 0, 0, 0, 0,
31089 & 0, 0, 0, 0, 0, 0/
31090 DATA (IBAM3(1,K),K=1,22)
31091 & / 14, 16, 25, 34, 38, 39, 118, 119,
31092 & 121, 125, 126, 128, 0, 0, 0, 0,
31093 & 0, 0, 0, 0, 0, 0/
31094 DATA (IPDG3(2,K),K=1,22)
31095 & / 130, 211, 321, 310, 111, 311, 221, 213,
31096 & 113, 223, 323, 313, 331, 333, 421, 411,
31097 & 431, 441, 423, 413, 433, 443/
31098 DATA (IBAM3(2,K),K=1,22)
31099 & / 12, 13, 15, 19, 23, 24, 31, 32,
31100 & 33, 35, 36, 37, 95, 96, 116, 117,
31101 & 120, 122, 123, 124, 127, 130/
31102 DATA (IPDG4(1,K),K=1,29)
31103 & / -2212, -2112, -3122, -2224, -2214, -2114, -1114, -2124,
31104 & -1214, -3222, -3212, -3112, -3322, -3312, -3224, -3214,
31105 & -3114, -3324, -3314, -3334, -4122, -4232, -4132, -4222,
31106 & -4212, -4112, 0, 0, 0/
31107 DATA (IBAM4(1,K),K=1,29)
31108 & / 2, 9, 18, 67, 68, 69, 70, 75,
31109 & 76, 99, 100, 101, 102, 103, 110, 111,
31110 & 112, 113, 114, 115, 149, 150, 151, 152,
31111 & 153, 154, 0, 0, 0/
31112 DATA (IPDG4(2,K),K=1,29)
31113 & / 2212, 2112, 3122, 3112, 3222, 3212, 3224, 3214,
31114 & 3114, 3216, 3218, 2224, 2214, 2114, 1114, 3322,
31115 & 3312, 3224, 3214, 3114, 3324, 3314, 3334, 4122,
31116 & 4232, 4132, 4222, 4212, 4112/
31117 DATA (IBAM4(2,K),K=1,29)
31118 & / 1, 8, 17, 20, 21, 22, 48, 49,
31119 & 50, 51, 52, 53, 54, 55, 56, 97,
31120 & 98, 104, 105, 106, 107, 108, 109, 137,
31121 & 138, 139, 140, 141, 142/
31122 DATA (IPDG5(1,K),K=1,19)
31123 & /-10323,-10313,-30323,-30313,-12224,-12214,-12114,-11114,
31124 & -20211,-20321,-20311, 0, 0, 0, 0, 0,
31126 DATA (IBAM5(1,K),K=1,19)
31127 & / 42, 43, 46, 47, 71, 72, 73, 74,
31128 & 188, 191, 193, 0, 0, 0, 0, 0,
31130 DATA (IPDG5(2,K),K=1,19)
31131 & / 10323, 10313, 30323, 30313, 12224, 12214, 12114, 11114,
31132 & 22212, 22112, 32124, 31214, 20443, 20211, 20111, 20321,
31133 & 20311, 12212, 12112/
31134 DATA (IBAM5(2,K),K=1,19)
31135 & / 40, 41, 44, 45, 57, 58, 59, 60,
31136 & 63, 64, 65, 66, 129, 186, 187, 190,
31140 * internal particle names
31141 DATA BTYPE / 'PROTON ' , 'APROTON ' , 'ELECTRON' , 'POSITRON' ,
31142 &'NEUTRIE ' , 'ANEUTRIE' , 'PHOTON ' , 'NEUTRON ' , 'ANEUTRON' ,
31143 &'MUON+ ' , 'MUON- ' , 'KAONLONG' , 'PION+ ' , 'PION- ' ,
31144 &'KAON+ ' , 'KAON- ' , 'LAMBDA ' , 'ALAMBDA ' , 'KAONSHRT' ,
31145 &'SIGMA- ' , 'SIGMA+ ' , 'SIGMAZER' , 'PIZERO ' , 'KAONZERO' ,
31146 &'AKAONZER' , 'NEUTRIM ' , 'ANEUTRIM' , 'NEUTRIT ' , 'ANEUTRIT' ,
31151 *$ CREATE DT_BLKD46.FOR
31154 *===blkd46=============================================================*
31156 BLOCK DATA DT_BLKD46
31158 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31161 PARAMETER ( AMELCT = 0.51099906 D-03 )
31162 PARAMETER ( AMMUON = 0.105658389 D+00 )
31164 * particle properties (BAMJET index convention)
31166 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
31167 & IICH(210),IIBAR(210),K1(210),K2(210)
31170 * Particle masses Engel version JETSET compatible
31171 C DATA (AAM(K),K=1,85) /
31172 C & .9383D+00, .9383D+00, AMELCT , AMELCT , .0000D+00,
31173 C & .0000D+00, .0000D+00, .9396D+00, .9396D+00, AMMUON ,
31174 C & AMMUON , .4977D+00, .1396D+00, .1396D+00, .4936D+00,
31175 C & .4936D+00, .1116D+01, .1116D+01, .4977D+00, .1197D+01,
31176 C & .1189D+01, .1193D+01, .1350D+00, .4977D+00, .4977D+00,
31177 C & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31178 C & .5488D+00, .7669D+00, .7700D+00, .7669D+00, .7820D+00,
31179 C & .8921D+00, .8962D+00, .8921D+00, .8962D+00, .1300D+01,
31180 C & .1300D+01, .1300D+01, .1300D+01, .1421D+01, .1421D+01,
31181 C & .1421D+01, .1421D+01, .1383D+01, .1384D+01, .1387D+01,
31182 C & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
31183 C & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
31184 C & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
31185 C & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
31186 C & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
31187 C & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
31188 C & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 /
31189 C DATA (AAM(K),K=86,183) /
31190 C & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
31191 C & .1700D+01, .1700D+01, .1820D+01, .2030D+01, .9575D+00,
31192 C & .1019D+01, .1315D+01, .1321D+01, .1189D+01, .1193D+01,
31193 C & .1197D+01, .1315D+01, .1321D+01, .1383D+01, .1384D+01,
31194 C & .1387D+01, .1532D+01, .1535D+01, .1672D+01, .1383D+01,
31195 C & .1384D+01, .1387D+01, .1532D+01, .1535D+01, .1672D+01,
31196 C & .1865D+01, .1869D+01, .1869D+01, .1865D+01, .1969D+01,
31197 C & .1969D+01, .2980D+01, .2007D+01, .2010D+01, .2010D+01,
31198 C & .2007D+01, .2113D+01, .2113D+01, .3686D+01, .3097D+01,
31199 C & .1784D+01, .1784D+01, .0000D+00, .0000D+00, .0000D+00,
31200 C & .0000D+00, .2285D+01, .2460D+01, .2460D+01, .2452D+01,
31201 C & .2453D+01, .2454D+01, .2560D+01, .2560D+01, .2730D+01,
31202 C & .3610D+01, .3610D+01, .3790D+01, .2285D+01, .2460D+01,
31203 C & .2460D+01, .2452D+01, .2453D+01, .2454D+01, .2560D+01,
31204 C & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
31205 C & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31206 C & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31207 C & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31208 C & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31209 C & .1250D+01, .1250D+01, .1250D+01 /
31210 C DATA (AAM ( I ), I = 184,210 ) /
31211 C & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31212 C & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31213 C & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31214 C & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31215 C & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31216 C & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31217 C & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31218 C & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31219 C & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31220 * sr 25.1.06: particle masses adjusted to Pythia
31221 DATA (AAM(K),K=1,85) /
31222 & .938270E+00,.938270E+00, AMELCT , AMELCT ,.000000E+00,
31223 & .000000E+00,.000000E+00,.939570E+00,.939570E+00, AMMUON ,
31224 & AMMUON ,.497670E+00,.139570E+00,.139570E+00,.493600E+00,
31225 & .493600E+00,.111568E+01,.111568E+01,.497670E+00,.119744E+01,
31226 & .118937E+01,.119255E+01,.134980E+00,.497670E+00,.497670E+00,
31227 & .0000D+00, .0000D+00, .0000D+00 , .0000D+00, .0000D+00,
31228 & .547450E+00,.766900E+00,.768500E+00,.766900E+00,.781940E+00,
31229 & .891600E+00,.896100E+00,.891600E+00,.896100E+00,.129000E+01,
31230 & .129000E+01,.129000E+01,.129000E+01, .1421D+01, .1421D+01,
31231 & .1421D+01, .1421D+01,.138280E+01,.138370E+01,.138720E+01,
31232 & .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
31233 & .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
31234 & .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
31235 & .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
31236 & .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
31237 & .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
31238 & .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01 /
31239 DATA (AAM(K),K=86,183) /
31240 & .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
31241 & .1700D+01, .1700D+01, .1820D+01, .2030D+01,.957770E+00,
31242 & .101940E+01,.131490E+01,.132130E+01,.118937E+01,.119255E+01,
31243 & .119744E+01,.131490E+01,.132130E+01,.138280E+01,.138370E+01,
31244 & .138720E+01,.153180E+01, .1535D+01,.167245E+01,.138280E+01,
31245 & .138370E+01,.138720E+01,.153180E+01, .1535D+01,.167245E+01,
31246 & .186450E+01,.186930E+01,.186930E+01,.186450E+01,.196850E+01,
31247 & .196850E+01,.297980E+01,.200670E+01, .2010D+01, .2010D+01,
31248 & .200670E+01,.211240E+01,.211240E+01, .3686D+01,.309688E+01,
31249 & .177700E+01,.177700E+01, .0000D+00, .0000D+00, .0000D+00,
31250 & .0000D+00,.228490E+01,.246560E+01,.247030E+01,.245290E+01,
31251 & .245350E+01,.245210E+01, .2560D+01, .2560D+01, .2730D+01,
31252 & .3610D+01, .3610D+01, .3790D+01,.228490E+01,.246560E+01,
31253 & .2460D+01,.245290E+01,.245350E+01,.245210E+01, .2560D+01,
31254 & .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
31255 & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31256 & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31257 & .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31258 & .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31259 & .1250D+01, .1250D+01, .1250D+01 /
31260 DATA (AAM ( I ), I = 184,210 ) /
31261 & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31262 & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31263 & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31264 & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31265 & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31266 & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31267 & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31268 & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31269 & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31270 * Particle mean lives
31271 DATA (TAU(K),K=1,183) /
31272 & .1000D+19, .1000D+19, .1000D+19, .1000D+19, .1000D+19,
31273 & .1000D+19, .1000D+19, .9180D+03, .9180D+03, .2200D-05,
31274 & .2200D-05, .5200D-07, .2600D-07, .2600D-07, .1200D-07,
31275 & .1200D-07, .2600D-09, .2600D-09, .9000D-10, .1500D-09,
31276 & .8000D-10, .5000D-14, .8000D-16, .0000D+00, .0000D+00,
31278 & .0000D+00, .3000D-09, .1700D-09, .8000D-10, .1000D-13,
31279 & .1500D-09, .3000D-09, .1700D-09, .0000D+00, .0000D+00,
31280 & .0000D+00, .0000D+00, .0000D+00, .1000D-09, .0000D+00,
31281 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .1000D-09,
31282 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31283 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31284 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31285 & .9000D-11, .9000D-11, .9000D-11, .9000D-11, .1000D+19,
31286 & .1000D+19, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31288 & .0000D+00, .0000D+00, .0000D+00 /
31289 DATA ( TAU ( I ), I = 184,210 ) /
31290 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31291 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31292 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31293 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31294 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31295 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31296 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31297 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31298 & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00/
31299 * Resonance width Gamma in GeV
31300 DATA (GA(K),K= 1,85) /
31302 & .8500D-06, .1520D+00, .1520D+00, .1520D+00, .1000D-01,
31303 & .7900D-01, .7900D-01, .7900D-01, .7900D-01, .4500D+00,
31304 & .4500D+00, .4500D+00, .4500D+00, .1080D+00, .1080D+00,
31305 & .1080D+00, .1080D+00, .5000D-01, .5000D-01, .5000D-01,
31306 & .8500D-01, .1800D+00, .1150D+00, .1150D+00, .1150D+00,
31307 & .1150D+00, .2000D+00, .2000D+00, .2000D+00, .2000D+00,
31308 & .2000D+00, .2000D+00, .1000D+00, .1000D+00, .2000D+00,
31309 & .2000D+00, .1150D+00, .1150D+00, .1150D+00, .1150D+00,
31310 & .2000D+00, .2000D+00, .2000D+00, .2000D+00, .1000D+00,
31311 & .1000D+00, .2000D+00, .1000D+00, .1000D+00, .1000D+00,
31312 & .1000D+00, .1000D+00, .1000D+00, .1000D+00, .2000D+00 /
31313 DATA (GA(K),K= 86,183) /
31314 & .2000D+00, .2000D+00, .2000D+00, .1500D+00, .1500D+00,
31315 & .1500D+00, .1500D+00, .8500D-01, .1800D+00, .2000D-02,
31316 & .4000D-02, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31317 & .0000D+00, .0000D+00, .0000D+00, .3400D-01, .3400D-01,
31318 & .3600D-01, .9000D-02, .9000D-02, .0000D+00, .3400D-01,
31319 & .3400D-01, .3600D-01, .9000D-02, .9000D-02, .0000D+00,
31320 & .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31321 & .0000D+00, .0000D+00, .5000D-02, .2000D-02, .2000D-02,
31322 & .5000D-02, .2000D-02, .2000D-02, .2000D-03, .7000D-03,
31324 & .3000D+00, .3000D+00, .3000D+00 /
31325 DATA ( GA ( I ), I = 184,210 ) /
31326 & 2.00000000000000D-01, 2.00000000000000D-01, 3.00000000000000D-01,
31327 & 3.00000000000000D-01, 3.00000000000000D-01, 2.70000000000000D-01,
31328 & 2.50000000000000D-01, 2.50000000000000D-01, 2.50000000000000D-01,
31329 & 2.50000000000000D-01, 1.50000000000000D-01, 1.50000000000000D-01,
31330 & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31331 & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31332 & 6.00000000000000D-02, 6.00000000000000D-02, 6.00000000000000D-02,
31333 & 6.00000000000000D-02, 5.50000000000000D-02, 5.50000000000000D-02,
31334 & 2.00000000000000D-01, 2.00000000000000D-01, 0.00000000000000D+00/
31336 * S+1385+Sigma+(1385) L02030+Lambda0(2030)
31337 * Rho77=Rho(770) Om783=Omega(783) K*14=K*(1420) and so on
31338 * designation N*@@ means N*@1(@2)
31339 DATA (ANAME(K),K=1,85) /
31340 & 'P ','AP ','E- ','E+ ','NUE ',
31341 & 'ANUE ','GAM ','NEU ','ANEU ','MUE+ ',
31342 & 'MUE- ','K0L ','PI+ ','PI- ','K+ ',
31343 & 'K- ','LAM ','ALAM ','K0S ','SIGM- ',
31344 & 'SIGM+ ','SIGM0 ','PI0 ','K0 ','AK0 ',
31345 & 'BLANK ','BLANK ','BLANK ','BLANK ','BLANK ',
31346 & 'ETA550 ','RHO+77 ','RHO077 ','RHO-77 ','OM0783 ',
31347 & 'K*+892 ','K*0892 ','K*-892 ','AK*089 ','KA+125 ',
31348 & 'KA0125 ','KA-125 ','AKA012 ','K*+142 ','K*0142 ',
31349 & 'K*-142 ','AK*014 ','S+1385 ','S01385 ','S-1385 ',
31350 & 'L01820 ','L02030 ','N*++12 ','N*+ 12 ','N*012 ',
31351 & 'N*-12 ','N*++16 ','N*+16 ','N*016 ','N*-16 ',
31352 & 'N*+14 ','N*014 ','N*+15 ','N*015 ','N*+18 ',
31353 & 'N*018 ','AN--12 ','AN*-12 ','AN*012 ','AN*+12 ',
31354 & 'AN--16 ','AN*-16 ','AN*016 ','AN*+16 ','AN*-15 ',
31355 & 'AN*015 ','DE*=24 ','RPI+49 ','RPI049 ','RPI-49 ',
31356 & 'PIN++ ','PIN+0 ','PIN+- ','PIN-0 ','PPPI ' /
31357 DATA (ANAME(K),K=86,183) /
31358 & 'PNPI ','APPPI ','APNPI ','K+PPI ','K-PPI ',
31359 & 'K+NPI ','K-NPI ','S+1820 ','S-2030 ','ETA* ',
31360 & 'PHI ','TETA0 ','TETA- ','ASIG- ','ASIG0 ',
31361 & 'ASIG+ ','ATETA0 ','ATETA+ ','SIG*+ ','SIG*0 ',
31362 & 'SIG*- ','TETA*0 ','TETA* ','OMEGA- ','ASIG*- ',
31363 & 'ASIG*0 ','ASIG*+ ','ATET*0 ','ATET*+ ','OMEGA+ ',
31364 & 'D0 ','D+ ','D- ','AD0 ','F+ ',
31365 & 'F- ','ETAC ','D*0 ','D*+ ','D*- ',
31366 & 'AD*0 ','F*+ ','F*- ','PSI ','JPSI ',
31367 & 'TAU+ ','TAU- ','NUET ','ANUET ','NUEM ',
31368 & 'ANUEM ','C0+ ','A+ ','A0 ','C1++ ',
31369 & 'C1+ ','C10 ','S+ ','S0 ','T0 ',
31370 & 'XU++ ','XD+ ','XS+ ','AC0- ','AA- ',
31371 & 'AA0 ','AC1-- ','AC1- ','AC10 ','AS- ',
31372 & 'AS0 ','AT0 ','AXU-- ','AXD- ','AXS ',
31373 & 'C1*++ ','C1*+ ','C1*0 ','S*+ ','S*0 ',
31374 & 'T*0 ','XU*++ ','XD*+ ','XS*+ ','TETA++ ',
31375 & 'AC1*-- ','AC1*- ','AC1*0 ','AS*- ','AS*0 ',
31376 & 'AT*0 ','AXU*-- ','AXD*- ','AXS*- ','ATET-- ',
31377 & 'RO ','R+ ','R- ' /
31378 DATA ( ANAME ( I ), I = 184,210 ) /
31379 &'AN*-14 ','AN*014 ','PI+130 ','PI0130 ','PI-130 ','F01400 ',
31380 &'K*+146 ','K*-146 ','K*0146 ','AK0146 ','L01600 ','AL0160 ',
31381 &'S+1660 ','S01660 ','S-1660 ','AS-166 ','AS0166 ','AS+166 ',
31382 &'X01950 ','X-1950 ','AX0195 ','AX+195 ','OM-225 ','AOM+22 ',
31383 &'N*+14 ','N*014 ','BLANK '/
31384 * Charge of particles and resonances
31385 DATA (IICH ( I ), I = 1,210 ) /
31386 & 1, -1, -1, 1, 0, 0, 0, 0, 0, 1, -1, 0, 1, -1, 1,
31387 & -1, 0, 0, 0, -1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31388 & 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0,
31389 & -1, 0, 1, 0, -1, 0, 0, 2, 1, 0, -1, 2, 1, 0, -1,
31390 & 1, 0, 1, 0, 1, 0, -2, -1, 0, 1, -2, -1, 0, 1, -1,
31391 & 0, 1, 1, 0, -1, 2, 1, 0, -1, 2, 1, 0, -1, 2, 0,
31392 & 1, -1, 1, -1, 0, 0, 0, -1, -1, 0, 1, 0, 1, 1, 0,
31393 & -1, 0, -1, -1, -1, 0, 1, 0, 1, 1, 0, 1, -1, 0, 1,
31394 & -1, 0, 0, 1, -1, 0, 1, -1, 0, 0, 1, -1, 0, 0, 0,
31395 & 0, 1, 1, 0, 2, 1, 0, 1, 0, 0, 2, 1, 1, -1, -1,
31396 & 0, -2, -1, 0, -1, 0, 0, -2, -1, -1, 2, 1, 0, 1, 0,
31397 & 0, 2, 1, 1, 2, -2, -1, 0, -1, 0, 0, -2, -1, -1, -2,
31398 & 0, 1, -1, -1, 0, 1, 0, -1, 0, 1, -1, 0, 0, 0, 0,
31399 & 1, 0, -1, -1, 0, 1, 0, -1, 0, 1, -1, 1, 1, 0, 0/
31400 * Particle baryonic charges
31401 DATA (IIBAR ( I ), I = 1,210 ) /
31402 & 1, -1, 0, 0, 0, 0, 0, 1, -1, 0, 0, 0, 0, 0, 0,
31403 & 0, 1, -1, 0, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0,
31404 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31405 & 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
31406 & 1, 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31407 & -1, 2, 0, 0, 0, 1, 1, 1, 1, 2, 2, 0, 0, 1, 1,
31408 & 1, 1, 1, 1, 0, 0, 1, 1, -1, -1, -1, -1, -1, 1, 1,
31409 & 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, 0, 0, 0, 0, 0,
31410 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31411 & 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, -1, -1,
31412 & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 1, 1, 1, 1, 1,
31413 & 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31414 & 0, 0, 0, -1, -1, 0, 0, 0, 0, 0, 0, 0, 0, 1, -1,
31415 & 1, 1, 1, -1, -1, -1, 1, 1, -1, -1, 1, -1, 1, 1, 0/
31416 * First number of decay channels used for resonances
31417 * and decaying particles
31418 DATA K1/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 16, 17,
31419 & 18, 24, 30, 34, 38, 40, 41, 43, 44, 136, 138, 330, 327, 328,
31420 & 2*330, 46, 51, 52, 54, 55, 58,
31422 & 60, 62, 64, 66, 68, 70, 72, 74, 82, 90, 98, 106, 109, 112, 114,
31423 & 123, 140, 141, 143, 145, 146, 150, 157, 164, 168, 174, 180, 187,
31424 & 194, 202, 210, 211, 213, 215, 216, 220, 227, 234, 238, 245, 252,
31426 & 254, 255, 256, 257, 259, 262, 265, 267, 269, 272, 276, 279, 282,
31427 & 286, 290, 293, 299, 331, 335, 339, 340, 341, 343, 344, 345, 346,
31428 & 347, 350, 353, 356, 358, 360, 363, 366, 369, 372, 374, 376, 379,
31429 & 383, 385, 387, 391, 394, 397, 400, 402, 405, 408, 410, 412, 414,
31430 & 417, 420, 425, 430, 431, 432, 433, 434, 448, 452, 457, 458, 459,
31431 & 460, 461, 462, 466, 468, 470, 472, 486, 490, 495, 496, 497, 498,
31432 & 499, 500, 504, 506, 508, 510, 511, 512, 513, 514, 515, 516, 517,
31433 & 518, 519, 522, 523, 524, 525, 526, 527, 528, 529, 530, 531, 534,
31434 & 537, 539, 541, 547, 553, 558, 563, 568, 572, 573, 574, 575, 576,
31435 & 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, 589,
31437 * Last number of decay channels used for resonances
31438 * and decaying particles
31439 DATA K2/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 15, 16, 17,
31440 & 23, 29, 31, 35, 39, 40, 42, 43, 45, 137, 139, 330, 327, 328,
31441 & 2* 330, 50, 51, 53, 54, 57,
31443 & 59, 61, 63, 65, 67, 69, 71, 73, 81, 89, 97, 105, 108, 111, 113,
31444 & 122, 135, 140, 142, 144, 145, 149, 156, 163, 167, 173, 179, 186,
31445 & 193, 201, 209, 210, 212, 214, 215, 219, 226, 233, 237, 244, 251,
31447 & 253, 254, 255, 256, 258, 261, 264, 266, 268, 271, 275, 278, 281,
31448 & 285, 289, 292, 298, 307, 334, 338, 339, 340, 342, 343, 344, 345,
31449 & 346, 349, 352, 355, 357, 359, 362, 365, 368, 371, 373, 375, 378,
31450 & 382, 384, 386, 390, 393, 396, 399, 401, 404, 407, 409, 411, 413,
31451 & 416, 419, 424, 429, 430, 431, 432, 433, 447, 451, 456, 457, 458,
31452 & 459, 460, 461, 465, 467, 469, 471, 485, 489, 494, 495, 496, 497,
31453 & 498, 499, 503, 505, 507, 509, 510, 511, 512, 513, 514, 515, 516,
31454 & 517, 518, 521, 522, 523, 524, 525, 526, 527, 528, 529, 530, 533,
31455 & 536, 538, 540, 546, 552, 557, 562, 567, 571, 572, 573, 574, 575,
31456 & 576, 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588,
31457 & 589, 595, 601, 602 /
31461 *$ CREATE DT_BLKD47.FOR
31464 *===blkd47=============================================================*
31466 BLOCK DATA DT_BLKD47
31468 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31471 * HADRIN: decay channel information
31472 PARAMETER (IDMAX9=602)
31474 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
31476 * Name of decay channel
31477 * Designation N*@ means N*@1(1236)
31478 * @1=# means ++, @1 = = means --
31479 * Designation P+/0/- means Pi+/Pi0/Pi- , respectively
31480 DATA (ZKNAME(K),K= 1, 85) /
31481 & 'P ','AP ','E- ','E+ ','NUE ',
31482 & 'ANUE ','GAM ','PE-NUE ','APEANU ','EANUNU ',
31483 & 'E-NUAN ','3PI0 ','PI+-0 ','PIMUNU ','PIE-NU ',
31484 & 'MU+NUE ','MU-NUE ','MU+NUE ','PI+PI0 ','PI++- ',
31485 & 'PI+00 ','M+P0NU ','E+P0NU ','MU-NU ','PI-0 ',
31486 & 'PI+-- ','PI-00 ','M-P0NU ','E-P0NU ','PPI- ',
31487 & 'NPI0 ','PD-NUE ','PM-NUE ','APPI+ ','ANPI0 ',
31488 & 'APE+NU ','APM+NU ','PI+PI- ','PI0PI0 ','NPI- ',
31489 & 'PPI0 ','NPI+ ','LAGA ','GAGA ','GAE+E- ',
31490 & 'GAGA ','GAGAP0 ','PI000 ','PI+-0 ','PI+-GA ',
31491 & 'PI+0 ','PI+- ','PI00 ','PI-0 ','PI+-0 ',
31492 & 'PI+- ','PI0GA ','K+PI0 ','K0PI+ ','KOPI0 ',
31493 & 'K+PI- ','K-PI0 ','AK0PI- ','AK0PI0 ','K-PI+ ',
31494 & 'K+PI0 ','K0PI+ ','K0PI0 ','K+PI- ','K-PI0 ',
31495 & 'K0PI- ','AK0PI0 ','K-PI+ ','K+PI0 ','K0PI+ ',
31496 & 'K+89P0 ','K08PI+ ','K+RO77 ','K0RO+7 ','K+OM07 ',
31497 & 'K+E055 ','K0PI0 ','K+PI+ ','K089P0 ','K+8PI- ' /
31498 DATA (ZKNAME(K),K= 86,170) /
31499 & 'K0R077 ','K+R-77 ','K+R-77 ','K0OM07 ','K0E055 ',
31500 & 'K-PI0 ','K0PI- ','K-89P0 ','AK08P- ','K-R077 ',
31501 & 'AK0R-7 ','K-OM07 ','K-E055 ','AK0PI0 ','K-PI+ ',
31502 & 'AK08P0 ','K-8PI+ ','AK0R07 ','AK0OM7 ','AK0E05 ',
31503 & 'LA0PI+ ','SI0PI+ ','SI+PI0 ','LA0PI0 ','SI+PI- ',
31504 & 'SI-PI+ ','LA0PI- ','SI0PI- ','NEUAK0 ','PK- ',
31505 & 'SI+PI- ','SI0PI0 ','SI-PI+ ','LA0ET0 ','S+1PI- ',
31506 & 'S-1PI+ ','SO1PI0 ','NEUAK0 ','PK- ','LA0PI0 ',
31507 & 'LA0OM0 ','LA0RO0 ','SI+RO- ','SI-RO+ ','SI0RO0 ',
31508 & 'LA0ET0 ','SI0ET0 ','SI+PI- ','SI-PI+ ','SI0PI0 ',
31509 & 'K0S ','K0L ','K0S ','K0L ','P PI+ ',
31510 & 'P PI0 ','N PI+ ','P PI- ','N PI0 ','N PI- ',
31511 & 'P PI+ ','N*#PI0 ','N*+PI+ ','PRHO+ ','P PI0 ',
31512 & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ',
31513 & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ',
31514 & 'N*-PI+ ','PRHO- ','NRHO0 ','N PI- ','N*0PI- ',
31515 & 'N*-PI0 ','NRHO- ','PETA0 ','N*#PI- ','N*+PI0 ' /
31516 DATA (ZKNAME(K),K=171,255) /
31517 & 'N*0PI+ ','PRHO0 ','NRHO+ ','NETA0 ','N*+PI- ',
31518 & 'N*0PI0 ','N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ',
31519 & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ',
31520 & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ',
31521 & 'N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ','N PI+ ',
31522 & 'PRHO0 ','NRHO+ ','LAMK+ ','S+ K0 ','S0 K+ ',
31523 & 'PETA0 ','P PI- ','N PI0 ','PRHO- ','NRHO0 ',
31524 & 'LAMK0 ','S0 K0 ','S- K+ ','NETA/ ','APPI- ',
31525 & 'APPI0 ','ANPI- ','APPI+ ','ANPI0 ','ANPI+ ',
31526 & 'APPI- ','AN*=P0 ','AN*-P- ','APRHO- ','APPI0 ',
31527 & 'ANPI- ','AN*=P+ ','AN*-P0 ','AN*0P- ','APRHO0 ',
31528 & 'ANRHO- ','APPI+ ','ANPI0 ','AN*-P+ ','AN*0P0 ',
31529 & 'AN*+P- ','APRHO+ ','ANRHO0 ','ANPI+ ','AN*0P+ ',
31530 & 'AN*+P0 ','ANRHO+ ','APPI0 ','ANPI- ','AN*=P+ ',
31531 & 'AN*-P0 ','AN*0P- ','APRHO0 ','ANRHO- ','APPI+, ',
31532 & 'ANPI0 ','AN*-P+ ','AN*0P0 ','AN*+P- ','APRHO+ ',
31533 & 'ANRHO0 ','PN*014 ','NN*=14 ','PI+0 ','PI+- ' /
31534 DATA (ZKNAME(K),K=256,340) /
31535 & 'PI-0 ','P+0 ','N++ ','P+- ','P00 ',
31536 & 'N+0 ','N+- ','N00 ','P-0 ','N-0 ',
31537 & 'P-- ','PPPI0 ','PNPI+ ','PNPI0 ','PPPI- ',
31538 & 'NNPI+ ','APPPI0 ','APNPI+ ','ANNPI0 ','ANPPI- ',
31539 & 'APNPI0 ','APPPI- ','ANNPI- ','K+PPI0 ','K+NPI+ ',
31540 & 'K0PPI0 ','K-PPI0 ','K-NPI+ ','AKPPI- ','AKNPI0 ',
31541 & 'K+NPI0 ','K+PPI- ','K0PPI0 ','K0NPI+ ','K-NPI0 ',
31542 & 'K-PPI- ','AKNPI- ','PAK0 ','SI+PI0 ','SI0PI+ ',
31543 & 'SI+ETA ','S+1PI0 ','S01PI+ ','NEUK- ','LA0PI- ',
31544 & 'SI-OM0 ','LA0RO- ','SI0RO- ','SI-RO0 ','SI-ET0 ',
31545 & 'SI0PI- ','SI-0 ','BLANC ','BLANC ','BLANC ',
31546 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31547 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31548 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31549 & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
31550 & 'EPI+- ','EPI00 ','GAPI+- ','GAGA* ','K+- ',
31551 & 'KLKS ','PI+-0 ','EGA ','LPI0 ','LPI ' /
31552 DATA (ZKNAME(K),K=341,425) /
31553 & 'APPI0 ','ANPI- ','ALAGA ','ANPI ','ALPI0 ',
31554 & 'ALPI+ ','LAPI+ ','SI+PI0 ','SI0PI+ ','LAPI0 ',
31555 & 'SI+PI- ','SI-PI+ ','LAPI- ','SI-PI0 ','SI0PI- ',
31556 & 'TE0PI0 ','TE-PI+ ','TE0PI- ','TE-PI0 ','TE0PI ',
31557 & 'TE-PI ','LAK- ','ALPI- ','AS-PI0 ','AS0PI- ',
31558 & 'ALPI0 ','AS+PI- ','AS-PI+ ','ALPI+ ','AS+PI0 ',
31559 & 'AS0PI+ ','AT0PI0 ','AT+PI- ','AT0PI+ ','AT+PI0 ',
31560 & 'AT0PI ','AT+PI ','ALK+ ','K-PI+ ','K-PI+0 ',
31561 & 'K0PI+- ','K0PI0 ','K-PI++ ','AK0PI+ ','K+PI-- ',
31562 & 'K0PI- ','K+PI- ','K+PI-0 ','AKPI-+ ','AK0PI0 ',
31563 & 'ETAPIF ','K++- ','K+AK0 ','ETAPI- ','K--+ ',
31564 & 'K-K0 ','PI00 ','PI+- ','GAGA ','D0PI0 ',
31565 & 'D0GA ','D0PI+ ','D+PI0 ','DFGA ','AD0PI- ',
31566 & 'D-PI0 ','D-GA ','AD0PI0 ','AD0GA ','F+GA ',
31567 & 'F+GA ','F-GA ','F-GA ','PSPI+- ','PSPI00 ',
31568 & 'PSETA ','E+E- ','MUE+- ','PI+-0 ','M+NN ',
31569 & 'E+NN ','RHO+NT ','PI+ANT ','K*+ANT ','M-NN ' /
31570 DATA (ZKNAME(K),K=426,510) /
31571 & 'E-NN ','RHO-NT ','PI-NT ','K*-NT ','NUET ',
31572 & 'ANUET ','NUEM ','ANUEM ','SI+ETA ','SI+ET* ',
31573 & 'PAK0 ','TET0K+ ','SI*+ET ','N*+AK0 ','N*++K- ',
31574 & 'LAMRO+ ','SI0RO+ ','SI+RO0 ','SI+OME ','PAK*0 ',
31575 & 'N*+AK* ','N*++K* ','SI+AK0 ','TET0PI ','SI+AK* ',
31576 & 'TET0RO ','SI0AK* ','SI+K*- ','TET0OM ','TET-RO ',
31577 & 'SI*0AK ','C0+PI+ ','C0+PI0 ','C0+PI- ','A+GAM ',
31578 & 'A0GAM ','TET0AK ','TET0K* ','OM-RO+ ','OM-PI+ ',
31579 & 'C1++AK ','A+PI+ ','C0+AK0 ','A0PI+ ','A+AK0 ',
31580 & 'T0PI+ ','ASI-ET ','ASI-E* ','APK0 ','ATET0K ',
31581 & 'ASI*-E ','AN*-K0 ','AN*--K ','ALAMRO ','ASI0RO ',
31582 & 'ASI-RO ','ASI-OM ','APK*0 ','AN*-K* ','AN*--K ',
31583 & 'ASI-K0 ','ATETPI ','ASI-K* ','ATETRO ','ASI0K* ',
31584 & 'ASI-K* ','ATE0OM ','ATE+RO ','ASI*0K ','AC-PI- ',
31585 & 'AC-PI0 ','AC-PI+ ','AA-GAM ','AA0GAM ','ATET0K ',
31586 & 'ATE0K* ','AOM+RO ','AOM+PI ','AC1--K ','AA-PI- ',
31587 & 'AC0-K0 ','AA0PI- ','AA-K0 ','AT0PI- ','C1++GA ' /
31588 DATA (ZKNAME(K),K=511,540) /
31589 & 'C1++GA ','C10GAM ','S+GAM ','S0GAM ','T0GAM ',
31590 & 'XU++GA ','XD+GAM ','XS+GAM ','A+AKPI ','T02PI+ ',
31591 & 'C1++2K ','AC1--G ','AC1-GA ','AC10GA ','AS-GAM ',
31592 & 'AS0GAM ','AT0GAM ','AXU--G ','AXD-GA ','AXS-GA ',
31593 & 'AA-KPI ','AT02PI ','AC1--K ','RH-PI+ ','RH+PI- ',
31594 & 'RH3PI0 ','RH0PI+ ','RH+PI0 ','RH0PI- ','RH-PI0 ' /
31595 DATA (ZKNAME(I),I=541,602)/
31596 & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHO0','ANRHO-','ANETA ',
31597 & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0','RH0PI+','RH+PI0',
31598 & '3PI+00','3PI-++','F0PI+ ','RH+PI-','RH0PI0','3PI000','3PI0+-',
31599 & 'F0PI0 ','RH0PI-','RH-PI0','3PI-00','3PI--+','F0PI- ','PI0PI0',
31600 & 'PI+PI-','K+K- ','K0AK0 ','L01600','AL0160','K*+146','K*-146',
31601 & 'K*0146','AK0146','S+1660','S01660','S-1660','AS-166','AS0166',
31602 & 'AS+166','X01690','X-1690','AX0169','AX+169','OM-225','AOM+22',
31603 & 'N*PPI0','N*NPI+','N*P2P0','N*PP+-','N*D+P0','N*D0P+','N*NPI0',
31604 & 'N*PPI-','N*N2P0','N*NP+-','N*D+P-','N*D0P0','BLANK '/
31605 * Weight of decay channel
31606 DATA (WT(K),K= 1, 85) /
31607 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31608 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31609 & .1000D+01, .2100D+00, .1200D+00, .2700D+00, .4000D+00,
31610 & .1000D+01, .1000D+01, .6400D+00, .2100D+00, .6000D-01,
31611 & .2000D-01, .3000D-01, .4000D-01, .6400D+00, .2100D+00,
31612 & .6000D-01, .2000D-01, .3000D-01, .4000D-01, .6400D+00,
31613 & .3600D+00, .0000D+00, .0000D+00, .6400D+00, .3600D+00,
31614 & .0000D+00, .0000D+00, .6900D+00, .3100D+00, .1000D+01,
31615 & .5200D+00, .4800D+00, .1000D+01, .9900D+00, .1000D-01,
31616 & .3800D+00, .3000D-01, .3000D+00, .2400D+00, .5000D-01,
31617 & .1000D+01, .1000D+01, .0000D+00, .1000D+01, .9000D+00,
31618 & .1000D-01, .9000D-01, .3300D+00, .6700D+00, .3300D+00,
31619 & .6700D+00, .3300D+00, .6700D+00, .3300D+00, .6700D+00,
31620 & .3300D+00, .6700D+00, .3300D+00, .6700D+00, .3300D+00,
31621 & .6700D+00, .3300D+00, .6700D+00, .1900D+00, .3800D+00,
31622 & .9000D-01, .2000D+00, .3000D-01, .4000D-01, .5000D-01,
31623 & .2000D-01, .1900D+00, .3800D+00, .9000D-01, .2000D+00 /
31624 DATA (WT(K),K= 86,170) /
31625 & .3000D-01, .4000D-01, .5000D-01, .2000D-01, .1900D+00,
31626 & .3800D+00, .9000D-01, .2000D+00, .3000D-01, .4000D-01,
31627 & .5000D-01, .2000D-01, .1900D+00, .3800D+00, .9000D-01,
31628 & .2000D+00, .3000D-01, .4000D-01, .5000D-01, .2000D-01,
31629 & .8800D+00, .6000D-01, .6000D-01, .8800D+00, .6000D-01,
31630 & .6000D-01, .8800D+00, .1200D+00, .1900D+00, .1900D+00,
31631 & .1600D+00, .1600D+00, .1700D+00, .3000D-01, .3000D-01,
31632 & .3000D-01, .4000D-01, .1000D+00, .1000D+00, .2000D+00,
31633 & .1200D+00, .1000D+00, .4000D-01, .4000D-01, .5000D-01,
31634 & .7500D-01, .7500D-01, .3000D-01, .3000D-01, .4000D-01,
31635 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01,
31636 & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31637 & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31638 & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31639 & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31640 & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31641 & .2700D+00, .3000D+00, .4000D+00, .2000D+00, .1250D+00 /
31642 DATA (WT(K),K=171,255) /
31643 & .7500D-01, .7500D-01, .1250D+00, .4000D+00, .7500D-01,
31644 & .1250D+00, .2000D+00, .1250D+00, .7500D-01, .1800D+00,
31645 & .3700D+00, .1300D+00, .8000D-01, .4000D-01, .7000D-01,
31646 & .1300D+00, .3700D+00, .1800D+00, .4000D-01, .8000D-01,
31647 & .1300D+00, .1300D+00, .7000D-01, .7000D-01, .1300D+00,
31648 & .2300D+00, .4700D+00, .5000D-01, .2000D-01, .1000D-01,
31649 & .2000D-01, .1300D+00, .7000D-01, .4700D+00, .2300D+00,
31650 & .5000D-01, .1000D-01, .2000D-01, .2000D-01, .1000D+01,
31651 & .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31652 & .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31653 & .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31654 & .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31655 & .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31656 & .2700D+00, .3000D+00, .1800D+00, .3700D+00, .1300D+00,
31657 & .8000D-01, .4000D-01, .7000D-01, .1300D+00, .3700D+00,
31658 & .1800D+00, .4000D-01, .8000D-01, .1300D+00, .1300D+00,
31659 & .7000D-01, .5000D+00, .5000D+00, .1000D+01, .1000D+01 /
31660 DATA (WT(K),K=256,340) /
31661 & .1000D+01, .8000D+00, .2000D+00, .6000D+00, .3000D+00,
31662 & .1000D+00, .6000D+00, .3000D+00, .1000D+00, .8000D+00,
31663 & .2000D+00, .3300D+00, .6700D+00, .6600D+00, .1700D+00,
31664 & .1700D+00, .3200D+00, .1700D+00, .3200D+00, .1900D+00,
31665 & .3300D+00, .3300D+00, .3400D+00, .3000D+00, .5000D-01,
31666 & .6500D+00, .3800D+00, .1200D+00, .3800D+00, .1200D+00,
31667 & .3800D+00, .1200D+00, .3800D+00, .1200D+00, .3000D+00,
31668 & .5000D-01, .6500D+00, .3800D+00, .2500D+00, .2500D+00,
31669 & .2000D-01, .5000D-01, .5000D-01, .2000D+00, .2000D+00,
31670 & .1200D+00, .1000D+00, .7000D-01, .7000D-01, .1400D+00,
31671 & .5000D-01, .5000D-01, .1000D+01, .1000D+01, .1000D+01,
31672 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31673 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31674 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31675 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31676 & .4800D+00, .2400D+00, .2600D+00, .2000D-01, .4700D+00,
31677 & .3500D+00, .1500D+00, .3000D-01, .1000D+01, .1000D+01 /
31678 DATA (WT(K),K=341,425) /
31679 & .5200D+00, .4800D+00, .1000D+01, .1000D+01, .1000D+01,
31680 & .1000D+01, .9000D+00, .5000D-01, .5000D-01, .9000D+00,
31681 & .5000D-01, .5000D-01, .9000D+00, .5000D-01, .5000D-01,
31682 & .3300D+00, .6700D+00, .6700D+00, .3300D+00, .2500D+00,
31683 & .2500D+00, .5000D+00, .9000D+00, .5000D-01, .5000D-01,
31684 & .9000D+00, .5000D-01, .5000D-01, .9000D+00, .5000D-01,
31685 & .5000D-01, .3300D+00, .6700D+00, .6700D+00, .3300D+00,
31686 & .2500D+00, .2500D+00, .5000D+00, .1000D+00, .5000D+00,
31687 & .1600D+00, .2400D+00, .7000D+00, .3000D+00, .7000D+00,
31688 & .3000D+00, .1000D+00, .5000D+00, .1600D+00, .2400D+00,
31689 & .3000D+00, .4000D+00, .3000D+00, .3000D+00, .4000D+00,
31690 & .3000D+00, .4900D+00, .4900D+00, .2000D-01, .5500D+00,
31691 & .4500D+00, .6800D+00, .3000D+00, .2000D-01, .6800D+00,
31692 & .3000D+00, .2000D-01, .5500D+00, .4500D+00, .9000D+00,
31693 & .1000D+00, .9000D+00, .1000D+00, .6000D+00, .3000D+00,
31694 & .1000D+00, .1000D+00, .1000D+00, .8000D+00, .2800D+00,
31695 & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .2800D+00 /
31696 DATA (WT(K),K=426,510) /
31697 & .2800D+00, .3500D+00, .7000D-01, .2000D-01, .1000D+01,
31698 & .1000D+01, .1000D+01, .1000D+01, .2000D-01, .3000D-01,
31699 & .7000D-01, .2000D-01, .2000D-01, .4000D-01, .1300D+00,
31700 & .7000D-01, .6000D-01, .6000D-01, .2000D+00, .1400D+00,
31701 & .4000D-01, .1000D+00, .2500D+00, .3000D-01, .3000D+00,
31702 & .4200D+00, .2200D+00, .3500D+00, .1900D+00, .1600D+00,
31703 & .8000D-01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31704 & .1000D+01, .3700D+00, .2000D+00, .3600D+00, .7000D-01,
31705 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00,
31706 & .5000D+00, .2000D-01, .3000D-01, .7000D-01, .2000D-01,
31707 & .2000D-01, .4000D-01, .1300D+00, .7000D-01, .6000D-01,
31708 & .6000D-01, .2000D+00, .1400D+00, .4000D-01, .1000D+00,
31709 & .2500D+00, .3000D-01, .3000D+00, .4200D+00, .2200D+00,
31710 & .3500D+00, .1900D+00, .1600D+00, .8000D-01, .1000D+01,
31711 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .3700D+00,
31712 & .2000D+00, .3600D+00, .7000D-01, .5000D+00, .5000D+00,
31713 & .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01 /
31714 DATA (WT(K),K=511,540) /
31715 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31716 & .1000D+01, .1000D+01, .1000D+01, .3000D+00, .3000D+00,
31717 & .4000D+00, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31718 & .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31719 & .3000D+00, .3000D+00, .4000D+00, .3300D+00, .3300D+00,
31720 & .3400D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00 /
31722 DATA (WT(I),I=541,602) / .0D+00, .3334D+00, .2083D+00, 2*.125D+00,
31723 & .2083D+00, .0D+00, .125D+00, .2083D+00, .3334D+00, .2083D+00,
31724 & .125D+00, 0.2D+00, 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00,
31725 & 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, 0.2D+00, 0.3D+00,
31726 & 0.3D+00, 0.0D+00, 0.31D+00, 0.62D+00, 0.035D+00, 0.035D+00,
31727 & 18*1.D+00, 0.5D+00, 0.16D+00, 2*0.12D+00, 2*0.05D+00, 0.5D+00,
31728 & 0.16D+00, 2*0.12D+00, 2*0.05D+00, 1.D+00 /
31729 * Particle numbers in decay channel
31730 DATA (NZK(K,1),K= 1,170) /
31731 & 1, 2, 3, 4, 5, 6, 7, 1, 2, 4,
31732 & 3, 23, 13, 13, 13, 10, 11, 10, 13, 13,
31733 & 13, 10, 4, 11, 14, 14, 14, 11, 3, 1,
31734 & 8, 1, 1, 2, 9, 2, 2, 13, 23, 8,
31735 & 1, 8, 17, 7, 7, 7, 23, 23, 13, 13,
31736 & 13, 13, 23, 14, 13, 13, 23, 15, 24, 24,
31737 & 15, 16, 25, 25, 16, 15, 24, 24, 15, 16,
31738 & 24, 25, 16, 15, 24, 36, 37, 15, 24, 15,
31739 & 15, 24, 15, 37, 36, 24, 15, 24, 24, 16,
31740 & 24, 38, 39, 16, 25, 16, 16, 25, 16, 39,
31741 & 38, 25, 16, 25, 25, 17, 22, 21, 17, 21,
31742 & 20, 17, 22, 8, 1, 21, 22, 20, 17, 48,
31743 & 50, 49, 8, 1, 17, 17, 17, 21, 20, 22,
31744 & 17, 22, 21, 20, 22, 19, 12, 19, 12, 1,
31745 & 1, 8, 1, 8, 8, 1, 53, 54, 1, 1,
31746 & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55,
31747 & 56, 1, 8, 8, 55, 56, 8, 1, 53, 54 /
31748 DATA (NZK(K,1),K=171,340) /
31749 & 55, 1, 8, 8, 54, 55, 56, 1, 8, 1,
31750 & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55,
31751 & 56, 1, 8, 1, 8, 1, 8, 17, 21, 22,
31752 & 1, 1, 8, 1, 8, 17, 22, 20, 8, 2,
31753 & 2, 9, 2, 9, 9, 2, 67, 68, 2, 2,
31754 & 9, 67, 68, 69, 2, 9, 2, 9, 68, 69,
31755 & 70, 2, 9, 9, 69, 70, 9, 2, 9, 67,
31756 & 68, 69, 2, 9, 2, 9, 68, 69, 70, 2,
31757 & 9, 1, 8, 13, 13, 14, 1, 8, 1, 1,
31758 & 8, 8, 8, 1, 8, 1, 1, 1, 1, 1,
31759 & 8, 2, 2, 9, 9, 2, 2, 9, 15, 15,
31760 & 24, 16, 16, 25, 25, 15, 15, 24, 24, 16,
31761 & 16, 25, 1, 21, 22, 21, 48, 49, 8, 17,
31762 & 20, 17, 22, 20, 20, 22, 20, 0, 0, 0,
31763 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31764 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31765 & 31, 31, 13, 7, 15, 12, 13, 31, 17, 17 /
31766 DATA (NZK(K,1),K=341,510) /
31767 & 2, 9, 18, 9, 18, 18, 17, 21, 22, 17,
31768 & 21, 20, 17, 20, 22, 97, 98, 97, 98, 97,
31769 & 98, 17, 18, 99, 100, 18, 101, 99, 18, 101,
31770 & 100, 102, 103, 102, 103, 102, 103, 18, 16, 16,
31771 & 24, 24, 16, 25, 15, 24, 15, 15, 25, 25,
31772 & 31, 15, 15, 31, 16, 16, 23, 13, 7, 116,
31773 & 116, 116, 117, 117, 119, 118, 118, 119, 119, 120,
31774 & 120, 121, 121, 130, 130, 130, 4, 10, 13, 10,
31775 & 4, 32, 13, 36, 11, 3, 34, 14, 38, 133,
31776 & 134, 135, 136, 21, 21, 1, 97, 104, 54, 53,
31777 & 17, 22, 21, 21, 1, 54, 53, 21, 97, 21,
31778 & 97, 22, 21, 97, 98, 105, 137, 137, 137, 138,
31779 & 139, 97, 97, 109, 109, 140, 138, 137, 139, 138,
31780 & 145, 99, 99, 2, 102, 110, 68, 67, 18, 100,
31781 & 99, 99, 2, 68, 67, 99, 102, 99, 102, 100,
31782 & 99, 102, 103, 111, 149, 149, 149, 150, 151, 113,
31783 & 113, 115, 115, 152, 150, 149, 151, 150, 157, 140 /
31784 DATA (NZK(K,1),K=511,540) /
31785 & 141, 142, 143, 144, 145, 146, 147, 148, 138, 145,
31786 & 140, 152, 153, 154, 155, 156, 157, 158, 159, 160,
31787 & 150, 157, 152, 34, 32, 33, 33, 32, 33, 34 /
31788 DATA (NZK(I,1),I=541,602) / 2, 67, 68, 69, 2, 9, 9, 68, 69,
31789 & 70, 2, 9, 33, 32, 13, 14, 189, 32, 34, 23, 23, 189, 33, 34, 14,
31790 & 14, 189, 23, 13, 15, 24, 36, 38, 37, 39, 194, 195, 196, 197,
31791 & 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 1, 8, 1, 1, 54,
31792 & 55, 8, 1, 8, 8, 54, 55, 210/
31793 DATA (NZK(K,2),K= 1,170) /
31794 & 0, 0, 0, 0, 0, 0, 0, 3, 4, 6,
31795 & 5, 23, 14, 11, 3, 5, 5, 5, 23, 13,
31796 & 23, 23, 23, 5, 23, 13, 23, 23, 23, 14,
31797 & 23, 3, 11, 13, 23, 4, 10, 14, 23, 14,
31798 & 23, 13, 7, 7, 4, 7, 7, 23, 14, 14,
31799 & 23, 14, 23, 23, 14, 14, 7, 23, 13, 23,
31800 & 14, 23, 14, 23, 13, 23, 13, 23, 14, 23,
31801 & 14, 23, 13, 23, 13, 23, 13, 33, 32, 35,
31802 & 31, 23, 14, 23, 14, 33, 34, 35, 31, 23,
31803 & 14, 23, 14, 33, 34, 35, 31, 23, 13, 23,
31804 & 13, 33, 32, 35, 31, 13, 13, 23, 23, 14,
31805 & 13, 14, 14, 25, 16, 14, 23, 13, 31, 14,
31806 & 13, 23, 25, 16, 23, 35, 33, 34, 32, 33,
31807 & 31, 31, 14, 13, 23, 0, 0, 0, 0, 13,
31808 & 23, 13, 14, 23, 14, 13, 23, 13, 78, 23,
31809 & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23,
31810 & 13, 80, 79, 14, 14, 23, 80, 31, 14, 23 /
31811 DATA (NZK(K,2),K=171,340) /
31812 & 13, 79, 78, 31, 14, 23, 13, 80, 79, 23,
31813 & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23,
31814 & 13, 80, 79, 23, 13, 33, 32, 15, 24, 15,
31815 & 31, 14, 23, 34, 33, 24, 24, 15, 31, 14,
31816 & 23, 14, 13, 23, 13, 14, 23, 14, 80, 23,
31817 & 14, 13, 23, 14, 79, 80, 13, 23, 13, 23,
31818 & 14, 78, 79, 13, 13, 23, 78, 23, 14, 13,
31819 & 23, 14, 79, 80, 13, 23, 13, 23, 14, 78,
31820 & 79, 62, 61, 23, 14, 23, 13, 13, 13, 23,
31821 & 13, 13, 23, 14, 14, 14, 1, 8, 8, 1,
31822 & 8, 1, 8, 8, 1, 8, 1, 8, 1, 8,
31823 & 1, 1, 8, 1, 8, 8, 1, 1, 8, 8,
31824 & 1, 8, 25, 23, 13, 31, 23, 13, 16, 14,
31825 & 35, 34, 34, 33, 31, 14, 23, 0, 0, 0,
31826 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31827 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31828 & 13, 23, 14, 7, 16, 19, 14, 7, 23, 14 /
31829 DATA (NZK(K,2),K=341,510) /
31830 & 23, 14, 7, 13, 23, 13, 13, 23, 13, 23,
31831 & 14, 13, 14, 23, 14, 23, 13, 14, 23, 14,
31832 & 23, 16, 14, 23, 14, 23, 14, 13, 13, 23,
31833 & 13, 23, 14, 13, 23, 13, 23, 15, 13, 13,
31834 & 13, 23, 13, 13, 14, 14, 14, 14, 14, 23,
31835 & 13, 16, 25, 14, 15, 24, 23, 14, 7, 23,
31836 & 7, 13, 23, 7, 14, 23, 7, 23, 7, 7,
31837 & 7, 7, 7, 13, 23, 31, 3, 11, 14, 135,
31838 & 5, 134, 134, 134, 136, 6, 133, 133, 133, 0,
31839 & 0, 0, 0, 31, 95, 25, 15, 31, 95, 16,
31840 & 32, 32, 33, 35, 39, 39, 38, 25, 13, 39,
31841 & 32, 39, 38, 35, 32, 39, 13, 23, 14, 7,
31842 & 7, 25, 37, 32, 13, 25, 13, 25, 13, 25,
31843 & 13, 31, 95, 24, 16, 31, 24, 15, 34, 34,
31844 & 33, 35, 37, 37, 36, 24, 14, 37, 34, 37,
31845 & 36, 35, 34, 37, 14, 23, 13, 7, 7, 24,
31846 & 39, 34, 14, 24, 14, 24, 14, 24, 14, 7 /
31847 DATA (NZK(K,2),K=511,540) /
31848 & 7, 7, 7, 7, 7, 7, 7, 7, 25, 13,
31849 & 25, 7, 7, 7, 7, 7, 7, 7, 7, 7,
31850 & 24, 14, 24, 13, 14, 23, 13, 23, 14, 23 /
31851 DATA (NZK(I,2),I=541,602) / 31, 13, 23, 14, 79, 80, 31, 13, 23,
31852 & 14, 78, 79, 13, 23, 23, 13, 13, 14, 13, 23, 13, 23, 14, 23, 23,
31853 & 14, 14, 23, 14, 16, 25,
31854 & 4*23, 14*0, 23, 13, 23, 13, 23, 13, 23, 14,
31855 & 23, 13, 14, 23, 0 /
31856 DATA (NZK(K,3),K= 1,170) /
31857 & 0, 0, 0, 0, 0, 0, 0, 5, 6, 5,
31858 & 6, 23, 23, 5, 5, 0, 0, 0, 0, 14,
31859 & 23, 5, 5, 0, 0, 14, 23, 5, 5, 0,
31860 & 0, 5, 5, 0, 0, 5, 5, 0, 0, 0,
31861 & 0, 0, 0, 0, 3, 0, 7, 23, 23, 7,
31862 & 0, 0, 0, 0, 23, 0, 0, 0, 0, 0,
31864 DATA (NZK(K,3),K=171,340) /
31866 & 0, 0, 0, 0, 0, 0, 23, 13, 14, 23,
31867 & 23, 14, 23, 23, 23, 14, 23, 13, 23, 14,
31868 & 13, 23, 13, 23, 14, 23, 14, 14, 23, 13,
31869 & 13, 23, 13, 14, 23, 23, 14, 23, 13, 23,
31870 & 14, 14, 0, 0, 0, 0, 0, 0, 0, 0,
31872 & 14, 23, 7, 0, 0, 0, 23, 0, 0, 0 /
31873 DATA (NZK(K,3),K=341,510) /
31875 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 23,
31876 & 14, 0, 13, 0, 14, 0, 0, 23, 13, 0,
31877 & 0, 15, 0, 0, 16, 0, 0, 0, 0, 0,
31878 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31879 & 0, 0, 0, 14, 23, 0, 0, 0, 23, 134,
31880 & 134, 0, 0, 0, 133, 133, 0, 0, 0, 0,
31882 DATA (NZK(K,3),K=511,540) /
31883 & 0, 0, 0, 0, 0, 0, 0, 0, 13, 13,
31884 & 25, 0, 0, 0, 0, 0, 0, 0, 0, 0,
31885 & 14, 14, 24, 0, 0, 0, 0, 0, 0, 0 /
31886 DATA (NZK(I,3),I=541,602) / 12*0, 2*0, 23, 13, 0, 2*0, 23, 14, 0,
31887 & 2*0, 23, 13, 0, 4*0, 18*0, 2*0, 23, 14, 2*0, 2*0, 23, 14, 2*0, 0/
31891 *$ CREATE DT_BDEVAP.FOR
31894 *=== bdevap ===========================================================*
31896 BLOCK DATA DT_BDEVAP
31898 C INCLUDE '(DBLPRC)'
31900 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31902 * (original name: GLOBAL)
31903 PARAMETER ( KALGNM = 2 )
31904 PARAMETER ( ANGLGB = 5.0D-16 )
31905 PARAMETER ( ANGLSQ = 2.5D-31 )
31906 PARAMETER ( AXCSSV = 0.2D+16 )
31907 PARAMETER ( ANDRFL = 1.0D-38 )
31908 PARAMETER ( AVRFLW = 1.0D+38 )
31909 PARAMETER ( AINFNT = 1.0D+30 )
31910 PARAMETER ( AZRZRZ = 1.0D-30 )
31911 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
31912 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
31913 PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
31914 PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
31915 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
31916 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
31917 PARAMETER ( CSNNRM = 2.0D-15 )
31918 PARAMETER ( DMXTRN = 1.0D+08 )
31919 PARAMETER ( ZERZER = 0.D+00 )
31920 PARAMETER ( ONEONE = 1.D+00 )
31921 PARAMETER ( TWOTWO = 2.D+00 )
31922 PARAMETER ( THRTHR = 3.D+00 )
31923 PARAMETER ( FOUFOU = 4.D+00 )
31924 PARAMETER ( FIVFIV = 5.D+00 )
31925 PARAMETER ( SIXSIX = 6.D+00 )
31926 PARAMETER ( SEVSEV = 7.D+00 )
31927 PARAMETER ( EIGEIG = 8.D+00 )
31928 PARAMETER ( ANINEN = 9.D+00 )
31929 PARAMETER ( TENTEN = 10.D+00 )
31930 PARAMETER ( HLFHLF = 0.5D+00 )
31931 PARAMETER ( ONETHI = ONEONE / THRTHR )
31932 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
31933 PARAMETER ( ONEFOU = ONEONE / FOUFOU )
31934 PARAMETER ( THRTWO = THRTHR / TWOTWO )
31935 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
31936 PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
31937 PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
31938 PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
31939 PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
31940 PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
31941 PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
31942 PARAMETER ( EULERO = 0.577215664901532860606512 D+00 )
31943 PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 )
31944 PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 )
31945 PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 )
31946 PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
31947 PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
31948 PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
31949 PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
31950 PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
31951 PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
31952 PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
31953 PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
31954 PARAMETER ( CLIGHT = 2.99792458 D+10 )
31955 PARAMETER ( AVOGAD = 6.0221367 D+23 )
31956 PARAMETER ( BOLTZM = 1.380658 D-23 )
31957 PARAMETER ( AMELGR = 9.1093897 D-28 )
31958 PARAMETER ( PLCKBR = 1.05457266 D-27 )
31959 PARAMETER ( ELCCGS = 4.8032068 D-10 )
31960 PARAMETER ( ELCMKS = 1.60217733 D-19 )
31961 PARAMETER ( AMUGRM = 1.6605402 D-24 )
31962 PARAMETER ( AMMUMU = 0.113428913 D+00 )
31963 PARAMETER ( AMPRMU = 1.007276470 D+00 )
31964 PARAMETER ( AMNEMU = 1.008664904 D+00 )
31965 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
31966 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
31967 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
31968 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
31969 PARAMETER ( PLABRC = 0.197327053 D+00 )
31970 PARAMETER ( AMELCT = 0.51099906 D-03 )
31971 PARAMETER ( AMUGEV = 0.93149432 D+00 )
31972 PARAMETER ( AMMUON = 0.105658389 D+00 )
31973 PARAMETER ( AMPRTN = 0.93827231 D+00 )
31974 PARAMETER ( AMNTRN = 0.93956563 D+00 )
31975 PARAMETER ( AMDEUT = 1.87561339 D+00 )
31976 PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
31978 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
31979 PARAMETER ( BLTZMN = 8.617385 D-14 )
31980 PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
31981 PARAMETER ( GFOHB3 = 1.16639 D-05 )
31982 PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
31983 PARAMETER ( SIN2TW = 0.2319 D+00 )
31984 PARAMETER ( GEVMEV = 1.0 D+03 )
31985 PARAMETER ( EMVGEV = 1.0 D-03 )
31986 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
31987 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
31988 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
31989 LOGICAL LGBIAS, LGBANA
31990 COMMON /FKGLOB/ LGBIAS, LGBANA
31991 C INCLUDE '(DIMPAR)'
31993 PARAMETER ( MXXRGN = 5000 )
31994 PARAMETER ( MXXMDF = 82 )
31995 PARAMETER ( MXXMDE = 54 )
31996 PARAMETER ( MFSTCK = 1000 )
31997 PARAMETER ( MESTCK = 100 )
31998 PARAMETER ( NELEMX = 80 )
31999 PARAMETER ( MPDPDX = 8 )
32000 PARAMETER ( ICOMAX = 180 )
32001 PARAMETER ( NSTBIS = 304 )
32002 PARAMETER ( IDMAXP = 220 )
32003 PARAMETER ( IDMXDC = 640 )
32004 PARAMETER ( MKBMX1 = 1 )
32005 PARAMETER ( MKBMX2 = 1 )
32006 C INCLUDE '(IOUNIT)'
32008 PARAMETER ( LUNIN = 5 )
32009 PARAMETER ( LUNOUT = 6 )
32010 **sr 19.5. set error output-unit from 15 to 6
32011 PARAMETER ( LUNERR = 6 )
32012 PARAMETER ( LUNBER = 14 )
32013 PARAMETER ( LUNECH = 8 )
32014 PARAMETER ( LUNFLU = 13 )
32015 PARAMETER ( LUNGEO = 16 )
32016 PARAMETER ( LUNPMF = 12 )
32017 PARAMETER ( LUNRAN = 2 )
32018 PARAMETER ( LUNXSC = 9 )
32019 PARAMETER ( LUNDET = 17 )
32020 PARAMETER ( LUNRAY = 10 )
32021 PARAMETER ( LUNRDB = 1 )
32022 PARAMETER ( LUNPGO = 7 )
32023 PARAMETER ( LUNPGS = 4 )
32024 PARAMETER ( LUNSCR = 3 )
32026 *----------------------------------------------------------------------*
32028 * Block Data for the EVAPoration routines: *
32030 * Created on 20 may 1990 by Alfredo Ferrari & Paola Sala *
32033 * Modified from the original version of J.M.Zazula *
32034 * and, for cookcm, from a LAHET block data kindly provided by *
32037 * Last change on 20-feb-95 by Alfredo Ferrari *
32040 *----------------------------------------------------------------------*
32042 * (original name: COOKCM)
32043 PARAMETER ( ASMTOG = SIXSIX / PIPIPI**2 )
32044 LOGICAL LDEFOZ, LDEFON
32045 PARAMETER ( INCOOK = 150, IZCOOK = 98 )
32046 COMMON /FKCOOK/ ALPIGN, BETIGN, GAMIGN, POWIGN,
32047 & SZCOOK (IZCOOK), SNCOOK (INCOOK), PZCOOK (IZCOOK),
32048 & PNCOOK (INCOOK), LDEFOZ (IZCOOK), LDEFON (INCOOK)
32049 * (original name: EVA0)
32050 COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
32051 * FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
32052 * CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
32053 * T (4,7), RMASS (297), ALPH (297), BET (297),
32054 * APRIME (250), IA (6), IZ (6)
32055 * (original name: HETTP)
32056 COMMON /FKHETP/ NHSTP,NBERTP,IOSUB,INSRS
32057 * (original name: HETC7)
32058 COMMON /FKHET7/ COSKS,SINKS, COSTH,SINTH, COSPHI,SINPHI
32059 * (original name: INPFLG)
32060 COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
32062 DATA B0 / 8.D+00 /, Y0 / 1.5D+00 /
32063 DATA IANG / 1 /, IFISS / 1 /, IB0 / 2 /, IGEOM / 0 /
32064 DATA ISTRAG /0/, KEYDK /0/
32065 DATA NBERTP /LUNBER/
32066 DATA COSTH /ONEONE/, SINTH /ZERZER/, COSPHI /ONEONE/,
32069 DATA ( PZCOOK(I),I = 1, IZCOOK ) /
32070 & 0.000D+00, 5.440D+00, 0.000D+00, 2.760D+00, 0.000D+00, 3.340D+00,
32071 & 0.000D+00, 2.700D+00, 0.000D+00, 2.500D+00, 0.000D+00, 2.460D+00,
32072 & 0.000D+00, 2.090D+00, 0.000D+00, 1.620D+00, 0.000D+00, 1.620D+00,
32073 & 0.000D+00, 1.830D+00, 0.000D+00, 1.730D+00, 0.000D+00, 1.350D+00,
32074 & 0.000D+00, 1.540D+00, 0.000D+00, 1.280D+00, 2.600D-01, 8.800D-01,
32075 & 1.900D-01, 1.350D+00,-5.000D-02, 1.520D+00,-9.000D-02, 1.170D+00,
32076 & 4.000D-02, 1.240D+00, 2.900D-01, 1.090D+00, 2.600D-01, 1.170D+00,
32077 & 2.300D-01, 1.150D+00,-8.000D-02, 1.350D+00, 3.400D-01, 1.050D+00,
32078 & 2.800D-01, 1.270D+00, 0.000D+00, 1.050D+00, 0.000D+00, 1.000D+00,
32079 & 9.000D-02, 1.200D+00, 2.000D-01, 1.400D+00, 9.300D-01, 1.000D+00,
32080 &-2.000D-01, 1.190D+00, 9.000D-02, 9.700D-01, 0.000D+00, 9.200D-01,
32081 & 1.100D-01, 6.800D-01, 5.000D-02, 6.800D-01,-2.200D-01, 7.900D-01,
32082 & 9.000D-02, 6.900D-01, 1.000D-02, 7.200D-01, 0.000D+00, 4.000D-01,
32083 & 1.600D-01, 7.300D-01, 0.000D+00, 4.600D-01, 1.700D-01, 8.900D-01,
32084 & 0.000D+00, 7.900D-01, 0.000D+00, 8.900D-01, 0.000D+00, 8.100D-01,
32085 &-6.000D-02, 6.900D-01,-2.000D-01, 7.100D-01,-1.200D-01, 7.200D-01,
32086 & 0.000D+00, 7.700D-01/
32087 DATA ( PNCOOK(I),I = 1, 90 ) /
32088 & 0.000D+00, 5.980D+00, 0.000D+00, 2.770D+00, 0.000D+00, 3.160D+00,
32089 & 0.000D+00, 3.010D+00, 0.000D+00, 2.500D+00, 0.000D+00, 2.670D+00,
32090 & 0.000D+00, 1.800D+00, 0.000D+00, 1.670D+00, 0.000D+00, 1.860D+00,
32091 & 0.000D+00, 2.040D+00, 0.000D+00, 1.640D+00, 0.000D+00, 1.440D+00,
32092 & 0.000D+00, 1.540D+00, 0.000D+00, 1.300D+00, 0.000D+00, 1.270D+00,
32093 & 0.000D+00, 1.290D+00, 8.000D-02, 1.410D+00,-8.000D-02, 1.500D+00,
32094 &-5.000D-02, 2.240D+00,-4.700D-01, 1.430D+00,-1.500D-01, 1.440D+00,
32095 & 6.000D-02, 1.560D+00, 2.500D-01, 1.570D+00,-1.600D-01, 1.460D+00,
32096 & 0.000D+00, 9.300D-01, 1.000D-02, 6.200D-01,-5.000D-01, 1.420D+00,
32097 & 1.300D-01, 1.520D+00,-6.500D-01, 8.000D-01,-8.000D-02, 1.290D+00,
32098 &-4.700D-01, 1.250D+00,-4.400D-01, 9.700D-01, 8.000D-02, 1.650D+00,
32099 &-1.100D-01, 1.260D+00,-4.600D-01, 1.060D+00, 2.200D-01, 1.550D+00,
32100 &-7.000D-02, 1.370D+00, 1.000D-01, 1.200D+00,-2.700D-01, 9.200D-01,
32101 &-3.500D-01, 1.190D+00, 0.000D+00, 1.050D+00,-2.500D-01, 1.610D+00,
32102 &-2.100D-01, 9.000D-01,-2.100D-01, 7.400D-01,-3.800D-01, 7.200D-01/
32103 DATA ( PNCOOK(I),I = 91, INCOOK ) /
32104 &-3.400D-01, 9.200D-01,-2.600D-01, 9.400D-01, 1.000D-02, 6.500D-01,
32105 &-3.600D-01, 8.300D-01, 1.100D-01, 6.700D-01, 5.000D-02, 1.000D+00,
32106 & 5.100D-01, 1.040D+00, 3.300D-01, 6.800D-01,-2.700D-01, 8.100D-01,
32107 & 9.000D-02, 7.500D-01, 1.700D-01, 8.600D-01, 1.400D-01, 1.100D+00,
32108 &-2.200D-01, 8.400D-01,-4.700D-01, 4.800D-01, 2.000D-02, 8.800D-01,
32109 & 2.400D-01, 5.200D-01, 2.700D-01, 4.100D-01,-5.000D-02, 3.800D-01,
32110 & 1.500D-01, 6.700D-01, 0.000D+00, 6.100D-01, 0.000D+00, 7.800D-01,
32111 & 0.000D+00, 6.700D-01, 0.000D+00, 6.700D-01, 0.000D+00, 7.900D-01,
32112 & 0.000D+00, 6.000D-01, 4.000D-02, 6.400D-01,-6.000D-02, 4.500D-01,
32113 & 5.000D-02, 2.600D-01,-2.200D-01, 3.900D-01, 0.000D+00, 3.900D-01/
32114 DATA ( SZCOOK(I),I = 1, 98) /
32115 & 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
32116 & 0.000D+00, 0.000D+00,-1.100D-01,-8.100D-01,-2.910D+00,-4.170D+00,
32117 &-5.720D+00,-7.800D+00,-8.970D+00,-9.700D+00,-1.010D+01,-1.070D+01,
32118 &-1.138D+01,-1.207D+01,-1.255D+01,-1.324D+01,-1.393D+01,-1.471D+01,
32119 &-1.553D+01,-1.637D+01,-1.736D+01,-1.860D+01,-1.870D+01,-1.801D+01,
32120 &-1.787D+01,-1.708D+01,-1.660D+01,-1.675D+01,-1.650D+01,-1.635D+01,
32121 &-1.622D+01,-1.641D+01,-1.689D+01,-1.643D+01,-1.668D+01,-1.673D+01,
32122 &-1.745D+01,-1.729D+01,-1.744D+01,-1.782D+01,-1.862D+01,-1.827D+01,
32123 &-1.939D+01,-1.991D+01,-1.914D+01,-1.826D+01,-1.740D+01,-1.642D+01,
32124 &-1.577D+01,-1.437D+01,-1.391D+01,-1.310D+01,-1.311D+01,-1.143D+01,
32125 &-1.089D+01,-1.075D+01,-1.062D+01,-1.041D+01,-1.021D+01,-9.850D+00,
32126 &-9.470D+00,-9.030D+00,-8.610D+00,-8.130D+00,-7.460D+00,-7.480D+00,
32127 &-7.200D+00,-7.130D+00,-7.060D+00,-6.780D+00,-6.640D+00,-6.640D+00,
32128 &-7.680D+00,-7.890D+00,-8.410D+00,-8.490D+00,-7.880D+00,-6.300D+00,
32129 &-5.470D+00,-4.780D+00,-4.370D+00,-4.170D+00,-4.130D+00,-4.320D+00,
32130 &-4.550D+00,-5.040D+00,-5.280D+00,-6.060D+00,-6.280D+00,-6.870D+00,
32131 &-7.200D+00,-7.740D+00/
32132 DATA ( SNCOOK(I),I = 1, 90 ) /
32133 & 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
32134 & 0.000D+00, 0.000D+00, 1.030D+01, 5.660D+00, 6.800D+00, 7.530D+00,
32135 & 7.550D+00, 7.210D+00, 7.440D+00, 8.070D+00, 8.940D+00, 9.810D+00,
32136 & 1.060D+01, 1.139D+01, 1.254D+01, 1.368D+01, 1.434D+01, 1.419D+01,
32137 & 1.383D+01, 1.350D+01, 1.300D+01, 1.213D+01, 1.260D+01, 1.326D+01,
32138 & 1.413D+01, 1.492D+01, 1.552D+01, 1.638D+01, 1.716D+01, 1.755D+01,
32139 & 1.803D+01, 1.759D+01, 1.903D+01, 1.871D+01, 1.880D+01, 1.899D+01,
32140 & 1.846D+01, 1.825D+01, 1.776D+01, 1.738D+01, 1.672D+01, 1.562D+01,
32141 & 1.438D+01, 1.288D+01, 1.323D+01, 1.381D+01, 1.490D+01, 1.486D+01,
32142 & 1.576D+01, 1.620D+01, 1.762D+01, 1.773D+01, 1.816D+01, 1.867D+01,
32143 & 1.969D+01, 1.951D+01, 2.017D+01, 1.948D+01, 1.998D+01, 1.983D+01,
32144 & 2.020D+01, 1.972D+01, 1.987D+01, 1.924D+01, 1.844D+01, 1.761D+01,
32145 & 1.710D+01, 1.616D+01, 1.590D+01, 1.533D+01, 1.476D+01, 1.354D+01,
32146 & 1.263D+01, 1.065D+01, 1.010D+01, 8.890D+00, 1.025D+01, 9.790D+00,
32147 & 1.139D+01, 1.172D+01, 1.243D+01, 1.296D+01, 1.343D+01, 1.337D+01/
32148 DATA ( SNCOOK(I),I = 91, INCOOK ) /
32149 & 1.296D+01, 1.211D+01, 1.192D+01, 1.100D+01, 1.080D+01, 1.042D+01,
32150 & 1.039D+01, 9.690D+00, 9.270D+00, 8.930D+00, 8.570D+00, 8.020D+00,
32151 & 7.590D+00, 7.330D+00, 7.230D+00, 7.050D+00, 7.420D+00, 6.750D+00,
32152 & 6.600D+00, 6.380D+00, 6.360D+00, 6.490D+00, 6.250D+00, 5.850D+00,
32153 & 5.480D+00, 4.530D+00, 4.300D+00, 3.390D+00, 2.350D+00, 1.660D+00,
32154 & 8.100D-01, 4.600D-01,-9.600D-01,-1.690D+00,-2.530D+00,-3.160D+00,
32155 &-1.870D+00,-4.100D-01, 7.100D-01, 1.660D+00, 2.620D+00, 3.220D+00,
32156 & 3.760D+00, 4.100D+00, 4.460D+00, 4.830D+00, 5.090D+00, 5.180D+00,
32157 & 5.170D+00, 5.100D+00, 5.010D+00, 4.970D+00, 5.090D+00, 5.030D+00,
32158 & 4.930D+00, 5.280D+00, 5.490D+00, 5.500D+00, 5.370D+00, 5.300D+00/
32159 DATA LDEFOZ / 53*.FALSE.,25*.TRUE.,7*.FALSE.,13*.TRUE. /
32160 DATA LDEFON / 85*.FALSE.,37*.TRUE.,7*.FALSE.,21*.TRUE. /
32161 *=== End of Block Data Bdevap =========================================*
32164 *$ CREATE DT_BDNOPT.FOR
32167 *=== bdnopt ===========================================================*
32169 BLOCK DATA DT_BDNOPT
32171 C INCLUDE '(DBLPRC)'
32173 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32175 * (original name: GLOBAL)
32176 PARAMETER ( KALGNM = 2 )
32177 PARAMETER ( ANGLGB = 5.0D-16 )
32178 PARAMETER ( ANGLSQ = 2.5D-31 )
32179 PARAMETER ( AXCSSV = 0.2D+16 )
32180 PARAMETER ( ANDRFL = 1.0D-38 )
32181 PARAMETER ( AVRFLW = 1.0D+38 )
32182 PARAMETER ( AINFNT = 1.0D+30 )
32183 PARAMETER ( AZRZRZ = 1.0D-30 )
32184 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
32185 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
32186 PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
32187 PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
32188 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
32189 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
32190 PARAMETER ( CSNNRM = 2.0D-15 )
32191 PARAMETER ( DMXTRN = 1.0D+08 )
32192 PARAMETER ( ZERZER = 0.D+00 )
32193 PARAMETER ( ONEONE = 1.D+00 )
32194 PARAMETER ( TWOTWO = 2.D+00 )
32195 PARAMETER ( THRTHR = 3.D+00 )
32196 PARAMETER ( FOUFOU = 4.D+00 )
32197 PARAMETER ( FIVFIV = 5.D+00 )
32198 PARAMETER ( SIXSIX = 6.D+00 )
32199 PARAMETER ( SEVSEV = 7.D+00 )
32200 PARAMETER ( EIGEIG = 8.D+00 )
32201 PARAMETER ( ANINEN = 9.D+00 )
32202 PARAMETER ( TENTEN = 10.D+00 )
32203 PARAMETER ( HLFHLF = 0.5D+00 )
32204 PARAMETER ( ONETHI = ONEONE / THRTHR )
32205 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
32206 PARAMETER ( ONEFOU = ONEONE / FOUFOU )
32207 PARAMETER ( THRTWO = THRTHR / TWOTWO )
32208 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
32209 PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
32210 PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
32211 PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
32212 PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
32213 PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
32214 PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
32215 PARAMETER ( EULERO = 0.577215664901532860606512 D+00 )
32216 PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 )
32217 PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 )
32218 PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 )
32219 PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
32220 PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
32221 PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
32222 PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
32223 PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
32224 PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
32225 PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
32226 PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
32227 PARAMETER ( CLIGHT = 2.99792458 D+10 )
32228 PARAMETER ( AVOGAD = 6.0221367 D+23 )
32229 PARAMETER ( BOLTZM = 1.380658 D-23 )
32230 PARAMETER ( AMELGR = 9.1093897 D-28 )
32231 PARAMETER ( PLCKBR = 1.05457266 D-27 )
32232 PARAMETER ( ELCCGS = 4.8032068 D-10 )
32233 PARAMETER ( ELCMKS = 1.60217733 D-19 )
32234 PARAMETER ( AMUGRM = 1.6605402 D-24 )
32235 PARAMETER ( AMMUMU = 0.113428913 D+00 )
32236 PARAMETER ( AMPRMU = 1.007276470 D+00 )
32237 PARAMETER ( AMNEMU = 1.008664904 D+00 )
32238 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
32239 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
32240 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
32241 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
32242 PARAMETER ( PLABRC = 0.197327053 D+00 )
32243 PARAMETER ( AMELCT = 0.51099906 D-03 )
32244 PARAMETER ( AMUGEV = 0.93149432 D+00 )
32245 PARAMETER ( AMMUON = 0.105658389 D+00 )
32246 PARAMETER ( AMPRTN = 0.93827231 D+00 )
32247 PARAMETER ( AMNTRN = 0.93956563 D+00 )
32248 PARAMETER ( AMDEUT = 1.87561339 D+00 )
32249 PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
32251 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
32252 PARAMETER ( BLTZMN = 8.617385 D-14 )
32253 PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
32254 PARAMETER ( GFOHB3 = 1.16639 D-05 )
32255 PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
32256 PARAMETER ( SIN2TW = 0.2319 D+00 )
32257 PARAMETER ( GEVMEV = 1.0 D+03 )
32258 PARAMETER ( EMVGEV = 1.0 D-03 )
32259 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
32260 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
32261 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
32262 LOGICAL LGBIAS, LGBANA
32263 COMMON /FKGLOB/ LGBIAS, LGBANA
32264 C INCLUDE '(DIMPAR)'
32266 PARAMETER ( MXXRGN = 5000 )
32267 PARAMETER ( MXXMDF = 82 )
32268 PARAMETER ( MXXMDE = 54 )
32269 PARAMETER ( MFSTCK = 1000 )
32270 PARAMETER ( MESTCK = 100 )
32271 PARAMETER ( NELEMX = 80 )
32272 PARAMETER ( MPDPDX = 8 )
32273 PARAMETER ( ICOMAX = 180 )
32274 PARAMETER ( NSTBIS = 304 )
32275 PARAMETER ( IDMAXP = 220 )
32276 PARAMETER ( IDMXDC = 640 )
32277 PARAMETER ( MKBMX1 = 1 )
32278 PARAMETER ( MKBMX2 = 1 )
32279 C INCLUDE '(IOUNIT)'
32281 PARAMETER ( LUNIN = 5 )
32282 PARAMETER ( LUNOUT = 6 )
32283 **sr 19.5. set error output-unit from 15 to 6
32284 PARAMETER ( LUNERR = 6 )
32285 PARAMETER ( LUNBER = 14 )
32286 PARAMETER ( LUNECH = 8 )
32287 PARAMETER ( LUNFLU = 13 )
32288 PARAMETER ( LUNGEO = 16 )
32289 PARAMETER ( LUNPMF = 12 )
32290 PARAMETER ( LUNRAN = 2 )
32291 PARAMETER ( LUNXSC = 9 )
32292 PARAMETER ( LUNDET = 17 )
32293 PARAMETER ( LUNRAY = 10 )
32294 PARAMETER ( LUNRDB = 1 )
32295 PARAMETER ( LUNPGO = 7 )
32296 PARAMETER ( LUNPGS = 4 )
32297 PARAMETER ( LUNSCR = 3 )
32299 *----------------------------------------------------------------------*
32301 * Created on 20 september 1989 by Alfredo Ferrari - Infn Milan *
32303 * Last change on 20-apr-95 by Alfredo Ferrari *
32305 *----------------------------------------------------------------------*
32307 C INCLUDE '(BLNKCM)'
32309 **sr 17.5. commented since not used here
32310 C PARAMETER ( NBLNMX = 1100000 )
32311 C DIMENSION GMSTOR ( NBLNMX ), BRMBRR ( NBLNMX ), BRMEXP ( NBLNMX ),
32312 C & BRMSIG ( NBLNMX ), SIGGTT ( KALGNM*NBLNMX ),
32313 C & COMSCO ( NBLNMX ), LBSTOR ( KALGNM*NBLNMX )
32316 C COMMON NSTOR ( KALGNM*NBLNMX )
32318 **sr 18.5. commented since not used for evap.
32319 C COMMON / ADDRCM / MBLNMX, KBLNKL, KGMBGN, KGMLST, KCMBGN, KCMLST,
32320 C & KISBGN, KISLST, KDTBGN, KDTLST, KUBBGN, KUBLST,
32321 C & KUXBGN, KUXLST, KTCBGN, KTCLST, KRNBGN, KRNLST,
32322 C & KYLBGN, KYLLST, KXSBGN, KXSLST, KIHBGN, KIHLST,
32323 C & KINBGN, KINLST, KIEBGN, KIELST, KETBGN, KETLST,
32324 C & KRRBGN, KRRLST, KGLBGN, KGLLST, KNABGN, KNALST,
32325 C & KGDBGN, KGDLST, KDWBGN, KDWLST, KGCBGN, KGCLST,
32326 C & KWLBGN, KWLLST, KWHBGN, KWHLST, KWMBGN, KWMLST,
32327 C & KWSBGN, KWSLST, KNDBGN, KNDLST, KDPBGN, KDPLST,
32328 C & KRGBGN, KRGLST, KSGBGN, KSGLST, KBRBGN, KBRLST,
32332 C EQUIVALENCE ( NSTOR (1), GMSTOR (1) )
32333 C EQUIVALENCE ( NSTOR (1), BRMBRR (1) )
32334 C EQUIVALENCE ( NSTOR (1), BRMEXP (1) )
32335 C EQUIVALENCE ( NSTOR (1), BRMSIG (1) )
32336 C EQUIVALENCE ( NSTOR (1), COMSCO (1) )
32337 C EQUIVALENCE ( NSTOR (1), SIGGTT (1) )
32338 C EQUIVALENCE ( NSTOR (1), LBSTOR (1) )
32339 C INCLUDE '(BLNTMP)'
32341 **sr 18.5. commented since not used for evap.
32342 C COMMON / BLNTMP / KIHBTM, KINBTM, KIEBTM, KRRBTM, KGLBTM, KNABTM,
32343 C & KGCBTM, KGDWTM, KBDWTM, KWLOTM, KWHITM, KWMUTM,
32344 C & KWSHTM, KEXTTM, KSTXTM, KSTNTM, KECTTM, KPCTTM,
32347 C INCLUDE '(CMMDNR)'
32349 **sr 18.5. commented since not used for evap.
32351 C COMMON / CMMDNR / DDNEAR, LFLDNR
32353 C INCLUDE '(CTITLE)'
32355 **sr 18.5. commented since not used for evap.
32356 C CHARACTER RUNTIT*80, RUNTIM*32, RUNKEY*10
32357 C COMMON / CTITLE / RUNTIT, RUNTIM, RUNKEY
32358 C COMMON / CEXPCK / ITEXPI, ITEXMX
32360 C INCLUDE '(DETECT)'
32362 **sr 18.5. commented since not used for evap.
32363 C PARAMETER (NRGNMX = 10)
32364 C PARAMETER (NDTCMX = 10)
32365 C PARAMETER (NSCRMX = 10)
32366 C PARAMETER (NDTBIN = 1024)
32367 C CHARACTER*10 TITDET,TITSCO
32369 C COMMON /DETCT/ EDTMIN(NDTCMX), EDTBIN(NDTCMX), EDTCUT(NDTCMX),
32370 C & KDTREG(NRGNMX,NDTCMX), KDTDET(NDTCMX,NSCRMX),
32371 C & NDTSCO, NDTDET, LDTCTR, IDTREG(MXXRGN),
32373 C COMMON /DETCH/ TITDET(NDTCMX), TITSCO(NSCRMX)
32375 C INCLUDE '(DETLOC)'
32377 **sr 18.5. commented since not used for evap.
32378 C PARAMETER (NDTCM2 = 10)
32379 C COMMON /DETLOC/ ACCUMP (NDTCM2), ACCUMN (NDTCM2),
32380 C & ICOINC(NDTCM2), NCLAS
32382 C INCLUDE '(EMGTRN)'
32384 **sr 18.5. commented since not used for evap.
32386 C COMMON / EMGTRN / UMCSMG, VMCSMG, WMCSMG, LMCSMG
32388 C INCLUDE '(EMSHO)'
32390 **sr 18.5. commented since not used for evap.
32391 C LOGICAL EMFLO, EMFHLO, EMFELO, LIMPRE, LEXPTE
32392 C COMMON /EMSHO/ EMFETH, EMFPTH, EMFHET, EMFHPT, EMFBIA, EMFLO,
32393 C & EMFHLO, EMFELO, LIMPRE, LEXPTE
32395 C INCLUDE '(EPISOR)'
32397 **sr 18.5. commented since not used for evap.
32399 C COMMON/EPISOR/TKESUM,LUSSRC
32401 * (original name: FHEAVY,FHEAVC)
32402 PARAMETER ( MXHEAV = 100 )
32404 COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV),
32405 & CZHEAV (MXHEAV), TKHEAV (MXHEAV),
32406 & PHEAVY (MXHEAV), WHEAVY (MXHEAV),
32407 & AMHEAV ( 12 ) , AMNHEA ( 12 ) ,
32408 & KHEAVY (MXHEAV), ICHEAV ( 12 ) ,
32409 & IBHEAV ( 12 ) , NPHEAV
32410 COMMON /FKFHVC/ ANHEAV ( 12 )
32411 * (original name: FINUC)
32412 PARAMETER (MXP=999)
32413 COMMON /FKFINU/ CXR (MXP), CYR (MXP), CZR (MXP),
32414 & CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP),
32415 & TKI (MXP), PLR (MXP), WEI (MXP),
32416 & TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP,
32418 C INCLUDE '(GENTHR)'
32420 **sr 18.5. commented since not used for evap.
32421 C COMMON / GENTHR / PEANCT, PEAPIT, PLDNCT, PTHRSH (NALLWP),
32422 C & PTHDFF (NALLWP), IJNUCR (NALLWP)
32424 C INCLUDE '(LOWNEU)'
32426 **sr 18.5. commented since not used for evap.
32427 C PARAMETER ( MXGTHN = 15 )
32428 C PARAMETER ( MXGLWN = 200 )
32429 C PARAMETER ( MXSHPP = 5 )
32430 C LOGICAL LCOMPN, LIMPRN, LBIASN, LDOWNN, LRECPR, LLOWWW, LLOWET
32431 C CHARACTER*10 TITLOW
32432 C COMMON / LOWNEU / ATOLOW (MXXMDF), WSHPLN (MXGLWN,MXSHPP), EXTWWL,
32433 C & SHPIMP (MXGLWN), EXTETL (MXGLWN), WWAMFL,
32434 C & VLLNTH (MXGTHN,MXXMDF), ABLNTH (MXGTHN,MXXMDF),
32435 C & STLNTH (MXGTHN,MXXMDF), TMRTLN (MXXMDF),
32436 C & TMNMLN (MXXMDF), ICHCPT (MXXMDF),
32437 C & IGTMRT (MXXMDF), NEUMED (MXXMDF),
32438 C & ID1MED (MXXMDF), ID2MED (MXXMDF),
32439 C & ID3MED (MXXMDF), MGTMED (MXXMDF),
32440 C & LCOMPN (MXXMDF), LRECPR (MXXMDF), KPRLOW, NMGP,
32441 C & NMTG , IGRTHN, LIMPRN, LBIASN, LDOWNN, LLOWWW,
32442 C & LLOWET, ICLMED, IKRBGN, INABGN, IDWBGN, IETBGN,
32443 C & I0XSEC, IDXSEC, ISENAV, ISVELN, ISPNAV, IWWLWB,
32444 C & IWWLWT, IPXBGN, NPXSEC
32445 C COMMON / CHLWNT / TITLOW (MXXMDF)
32447 C INCLUDE '(LTCLCM)'
32449 **sr 18.5. commented since not used for evap.
32450 C COMMON / LTCLCM / MLATTC, NEWLAT, MLATLD, MLATM1, MLTSEN, MLTSM1
32452 C INCLUDE '(MULBOU)'
32454 **sr 18.5. commented since not used for evap.
32455 C LOGICAL LLDA , LAGAIN, LSTNEW, LARTEF, LNORML, LSENSE, LMGNOR
32456 C COMMON / MULBOU / UOLD , VOLD , WOLD , UMAG , VMAG , WMAG ,
32457 C & UNORML, VNORML, WNORML, USENSE, VSENSE, WSENSE,
32458 C & TSENSE, DDSENS, DSMALL, NSSENS, LLDA , LAGAIN,
32459 C & LSTNEW, LARTEF, LNORML, LSENSE, LMGNOR
32461 C INCLUDE '(MULHD)'
32463 **sr 18.5. commented since not used for evap.
32464 C PARAMETER ( MXXPT1 = 1 )
32465 C PARAMETER ( TIMESS = 2.00D+00 )
32466 C PARAMETER ( TMSRLX = 1.50D+00 )
32467 C PARAMETER ( EPSINS = 0.15D+00 )
32468 C PARAMETER ( EPSRLX = 0.50D+00 )
32469 C PARAMETER ( SQEPSN = 0.3872983346207417 D+00 )
32470 C PARAMETER ( SQEPSR = 0.7071067811865475 D+00 )
32471 C PARAMETER ( PARNSI = 1.732050807568877 D+00 * SQEPSN )
32472 C PARAMETER ( PRNSR0 = 1.732050807568877 D+00 * SQEPSR )
32473 C PARAMETER ( R0NCMS = 1.20 D+00 )
32474 C LOGICAL LTOPT, LSRCRH, LNSCRH
32475 C COMMON / MULHD / BLCC ( MXXMDF ), BLCCRA ( MXXMDF ),
32476 C & XCC ( MXXMDF ), ZTILDE ( MXXMDF, 0:MXXPT1 ),
32477 C & ALPZTL ( MXXMDF, 0:MXXPT1 ), RLDU ( MXXMDF ),
32478 C & ALPZT2 ( MXXMDF, 0:MXXPT1 ), TEFF0 ( MXXMDF ),
32479 C & XR0 ( MXXMDF ), ECUTM ( MXXMDF, 39, 2 ),
32480 C & ESTEPF ( MXXMDF ), HTHNSZ ( MXXMDF, 39 ),
32481 C & AE1O3 ( MXXMDF ), PARNSR ( MXXMDF ),
32482 C & HEESLI ( MXXMDF ), THMSPR, THMSSC, HMSAMP,
32483 C & HMREJE, LSRCRH ( MXXMDF ), LNSCRH ( MXXMDF ),
32484 C & LTOPT ( MXXMDF ), NFSCAT
32486 * (original name: PAREVT)
32487 LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
32488 & LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
32489 PARAMETER ( NALLWP = 39 )
32490 COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
32491 & LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
32492 & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
32493 & ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
32494 * (original name: RESNUC)
32495 LOGICAL LRNFSS, LFRAGM
32496 COMMON /FKRESN/ AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
32497 & ANOW, ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
32498 & ERES, EKRES, AMNRES, AMMRES, PTRES, PXRES,
32499 & PYRES, PZRES, PTRES2, KTARP, KTARN, IGREYP,
32500 & IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,
32501 & ICRES, IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU,
32502 & IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG,
32503 & IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS,
32505 C INCLUDE '(SCOHLP)'
32507 **sr 18.5. commented since not used for evap.
32509 C COMMON / SCOHLP / ISCRNG, JSCRNG, LSCZER
32511 C INCLUDE '(TRACKR)'
32513 **sr 18.5. commented since not used for evap.
32514 C PARAMETER ( MXTRCK = 2500 )
32516 C COMMON / TRACKR / XTRACK ( 0:MXTRCK ), YTRACK ( 0:MXTRCK ),
32517 C & ZTRACK ( 0:MXTRCK ), TTRACK ( MXTRCK ),
32518 C & DTRACK ( MXTRCK ), ETRACK, PTRACK, WTRACK,
32519 C & ATRACK, CTRACK, AKSHRT, AKLONG, WSCRNG,
32520 C & NTRACK, MTRACK, JTRACK, KTRACK, MMTRCK,
32521 C & LT1TRK, LT2TRK, LTRACK, LLOUSE, LFSSSC
32523 C INCLUDE '(USRBDX)'
32525 **sr 18.5. commented since not used for evap.
32526 C PARAMETER ( MXUSBX = 600 )
32527 C LOGICAL LUSBDX, LFUSBX, LWUSBX, LLNUSX
32528 C CHARACTER*10 TITUSX
32529 C COMMON /USRBX/ EBXLOW(MXUSBX), EBXHGH(MXUSBX), ABXLOW(MXUSBX),
32530 C & ABXHGH(MXUSBX), DEBXBN(MXUSBX), DABXBN(MXUSBX),
32531 C & AUSBDX(MXUSBX),
32532 C & NEBXBN(MXUSBX), NABXBN(MXUSBX), NR1USX(MXUSBX),
32533 C & NR2USX(MXUSBX), ITUSBX(MXUSBX), IDUSBX(MXUSBX),
32534 C & KBUSBX(MXUSBX), IPUSBX(MXUSBX), IGMUSX(MXUSBX),
32535 C & LFUSBX(MXUSBX), LWUSBX(MXUSBX), LLNUSX(MXUSBX),
32537 C COMMON /USXCH/ TITUSX(MXUSBX)
32539 C INCLUDE '(USRBIN)'
32541 **sr 18.5. commented since not used for evap.
32542 C PARAMETER ( MXUSBN = 100 )
32543 C LOGICAL LUSBIN, LEVTBN, LNTZER, LUSEVT, LUSTKB, LTRKBN
32544 C CHARACTER*10 TITUSB
32545 C COMMON /USRBN/ XLOW (MXUSBN), XHIGH (MXUSBN), YLOW (MXUSBN),
32546 C & YHIGH (MXUSBN), ZLOW (MXUSBN), ZHIGH (MXUSBN),
32547 C & DXUSBN(MXUSBN), DYUSBN(MXUSBN), DZUSBN(MXUSBN),
32548 C & TCUSBN(MXUSBN), BKUSBN(MXUSBN), B2USBN(MXUSBN),
32549 C & NXBIN (MXUSBN), NYBIN (MXUSBN), NZBIN (MXUSBN),
32550 C & ITUSBN(MXUSBN), IDUSBN(MXUSBN), KBUSBN(MXUSBN),
32551 C & IPUSBN(MXUSBN), LEVTBN(MXUSBN), LNTZER(MXUSBN),
32552 C & LTRKBN(MXUSBN), NUSRBN, LUSBIN, LUSEVT, LUSTKB
32553 C COMMON /USRCH/ TITUSB(MXUSBN)
32555 C INCLUDE '(USRSNC)'
32557 **sr 18.5. commented since not used for evap.
32558 C PARAMETER ( MXRSNC = 400 )
32559 C PARAMETER ( NMZMIN = -5 )
32561 C CHARACTER*10 TIURSN
32562 C COMMON /USRSNC/ VURSNC(MXRSNC), IZRHGH(MXRSNC), IMRHGH(MXRSNC),
32563 C & NRURSN(MXRSNC), ITURSN(MXRSNC), KBURSN(MXRSNC),
32564 C & IPURSN(MXRSNC), NURSNC, LURSNC
32565 C COMMON /USRSCH/ TIURSN(MXRSNC)
32566 C INCLUDE '(USRTRC)'
32568 **sr 18.5. commented since not used for evap.
32569 C PARAMETER ( MXUSTC = 400 )
32570 C LOGICAL LUSRTC, LUSTRK, LUSCLL, LLNUTC
32571 C CHARACTER*10 TITUTC
32572 C COMMON /USRTC/ ETCLOW(MXUSTC), ETCHGH(MXUSTC), DETCBN(MXUSTC),
32573 C & VUSRTC(MXUSTC),
32574 C & IUSTRK(MXUSTC), IUSCLL(MXUSTC), NETCBN(MXUSTC),
32575 C & NRUSTC(MXUSTC), ITUSTC(MXUSTC), IDUSTC(MXUSTC),
32576 C & KBUSTC(MXUSTC), IPUSTC(MXUSTC), IGMUTC(MXUSTC),
32577 C & LLNUTC(MXUSTC), NUSRTC, NUSTRK, NUSCLL, LUSRTC,
32579 C COMMON /USTCH/ TITUTC(MXUSTC)
32581 C INCLUDE '(USRYLD)'
32583 **sr 18.5. commented since not used for evap.
32584 C PARAMETER ( MXUSYL = 500 )
32585 C LOGICAL LUSRYL, LLNUYL, LSCUYL
32586 C CHARACTER*10 TITUYL
32587 C COMMON /USRYL/ EYLLOW(MXUSYL), EYLHGH(MXUSYL), DEYLBN(MXUSYL),
32588 C & USNRYL(MXUSYL), SGUSYL(MXUSYL), AYLLOW(MXUSYL),
32589 C & AYLHGH(MXUSYL), PUSRYL, UUSRYL, VUSRYL, WUSRYL,
32590 C & ETXUYL, ETYUYL, ETZUYL, GAMUYL, SQSUYL, UCMUYL,
32591 C & VCMUYL, WCMUYL, IJUSYL, JTUSYL,
32592 C & NEYLBN(MXUSYL), NR1UYL(MXUSYL), NR2UYL(MXUSYL),
32593 C & IXUSYL(MXUSYL), ITUSYL(MXUSYL), IDUSYL(MXUSYL),
32594 C & KBUSYL(MXUSYL), IPUSYL(MXUSYL), IGMUYL(MXUSYL),
32595 C & IEUSYL(MXUSYL), IAUSYL(MXUSYL), LLNUYL(MXUSYL),
32596 C & NUSRYL, LUSRYL, LSCUYL
32597 C COMMON /USYCH/ TITUYL(MXUSYL)
32599 C INCLUDE '(WWINDW)'
32601 **sr 18.5. commented since not used for evap.
32602 C PARAMETER ( MXWWSP = 3 )
32603 C PARAMETER ( WWSPMX = 50.D+00 )
32604 C LOGICAL LWWNDW, LWWPRM
32605 C COMMON / WWINDW / ETHWW1 (NALLWP), ETHWW2 (NALLWP),
32606 C & WWEXWD (NALLWP), EXTWWN (NALLWP),
32607 C & IWLBGN, IWHBGN, IWMBGN, LWWNDW, LWWPRM
32611 * *** If blank common dimension has to be superseded substitute in the
32612 * *** following two lines the new dimension in real*8 units to Nblnmx
32613 **sr 18.5. commented since not used for evap.
32614 C PARAMETER (MXDUMM = KALGNM * NBLNMX)
32615 C DATA KTMBGN / NBLNMX /
32616 C DATA MBLNMX / MXDUMM /
32617 C DATA KBLNKL, KGMBGN, KGMLST, KCMBGN, KCMLST, KISBGN, KISLST,
32618 C & KDTBGN, KDTLST, KUBBGN, KUBLST, KUXBGN, KUXLST, KTCBGN,
32619 C & KTCLST, KRNBGN, KRNLST, KYLBGN, KYLLST, KXSBGN, KXSLST,
32620 C & KIHBGN, KIHLST, KINBGN, KINLST, KIEBGN, KIELST, KETBGN,
32621 C & KETLST, KRRBGN, KRRLST, KGLBGN, KGLLST, KNABGN, KNALST,
32622 C & KGDBGN, KGDLST, KDWBGN, KDWLST, KGCBGN, KGCLST, KWLBGN,
32623 C & KWLLST, KWHBGN, KWHLST, KWMBGN, KWMLST, KWSBGN, KWSLST,
32624 C & KDPBGN, KDPLST, KRGBGN, KRGLST, KSGBGN, KSGLST, KBRBGN,
32625 C & KBRLST / 57*0 /
32628 **sr 18.5. commented since not used for evap.
32629 C DATA KIHBTM, KINBTM, KIEBTM, KRRBTM, KGLBTM, KNABTM, KGDWTM,
32630 C & KBDWTM, KGCBTM, KWLOTM, KWHITM, KWMUTM, KWSHTM, KEXTTM,
32631 C & KSTXTM, KSTNTM, KECTTM, KPCTTM, KLPBTM / 19*0 /
32634 **sr 18.5. commented since not used for evap.
32635 C DATA DDNEAR / 0.D+00 /, LFLDNR / .FALSE. /
32638 **sr 18.5. commented since not used for evap.
32639 C DATA RUNTIT (1:40) / '****************************************' /
32640 C DATA RUNTIT(41:80) / '****************************************' /
32641 C DATA ITEXPI, ITEXMX / 100000000, 150 /
32643 **sr 18.5. commented since not used for evap.
32644 C PARAMETER (NNN1 = NRGNMX*NDTCMX)
32645 C PARAMETER (NNN2 = NSCRMX*NDTCMX)
32646 C DATA LDTCTR /.FALSE./, NDTSCO /0/, NDTDET /0/
32647 C DATA EDTMIN/NDTCMX*0.D0/, EDTBIN/NDTCMX*0.D0/, EDTCUT/NDTCMX*0.D0/
32648 C DATA KDTREG/NNN1*0/, KDTDET/NNN2*0/, KDTSCD/NSCRMX*0/
32649 C DATA TITDET/NDTCMX*' '/, TITSCO/NSCRMX*' '/
32652 **sr 18.5. commented since not used for evap.
32653 C DATA ACCUMP /NDTCM2*0.D0/, ACCUMN /NDTCM2*0.D0/, ICOINC /NDTCM2*0/
32657 **sr 18.5. commented since not used for evap.
32658 C DATA LMCSMG / .FALSE. /
32661 **sr 18.5. commented since not used for evap.
32662 C DATA LIMPRE, LEXPTE / 2 * .FALSE. /
32665 **sr 18.5. commented since not used for evap.
32666 C DATA TKESUM / 0.D+00 /, LUSSRC / .FALSE. /
32669 DATA AMHEAV / 12 * 0.D+00 /
32670 DATA ANHEAV / 'NEUTRON ', 'PROTON ', 'DEUTERON', '3-H ',
32671 & '3-He ', '4-He ', 'H-FRAG-1', 'H-FRAG-2',
32672 & 'H-FRAG-3', 'H-FRAG-4', 'H-FRAG-5', 'H-FRAG-6'/
32673 DATA ICHEAV / 0, 1, 1, 1, 2, 2, 6*0 /,
32674 & IBHEAV / 1, 1, 2, 3, 3, 4, 6*0 /
32678 DATA NP / 0 /, TV / 0.D+00 /, TVCMS / 0.D+00 /, TVRECL / 0.D+00/,
32679 & TVHEAV / 0.D+00 /, TVBIND / 0.D+00 /
32683 * DATA PEANCT, PEAPIT / 2*1.D+00 /
32684 * DATA PTHRSH / 16*5.D+00,2*2.5D+00,5.D+00,3*2.5D+00,8*5.D+00,
32686 * DATA PTHDFF / 39*5.D+00 /
32689 **sr 18.5. commented since not used for evap.
32690 C DATA PEANCT, PEAPIT / 1.3D+00, 1.1D+00 /
32691 C DATA PTHRSH / 12*5.D+00, 2*3.5D+00, 2*5.D+00, 2*2.5D+00, 5.D+00,
32692 C & 3*2.5D+00, 3.5D+00, 2*5.D+00, 3.5D+00, 4*5.D+00,
32694 C DATA PTHDFF / 12*5.D+00, 2*3.5D+00, 8*5.D+00, 3.5D+00, 2*5.D+00,
32695 C & 3.5D+00, 13*5.D+00 /
32696 C DATA PLDNCT / 0.26D+00 /
32697 C DATA IJNUCR / 16*1, 2*0, 1, 3*0, 8*1, 9*0 /
32700 **sr 18.5. commented since not used for evap.
32701 C DATA WWAMFL / 10.D+00 /, EXTWWL / 1.D+00 /
32702 C DATA IWWLWB, IWWLWT / 2 * 100000000 /
32703 C DATA ICLMED, INABGN, IDWBGN, IETBGN / 4*0 /
32704 C DATA IGRTHN / 1 /
32705 C DATA LIMPRN / .FALSE. /, LBIASN / .FALSE. /, LDOWNN / .FALSE. /,
32706 C & LLOWWW / .FALSE. /, LLOWET / .FALSE. /
32709 **sr 18.5. commented since not used for evap.
32710 C DATA MLATTC, NEWLAT, MLATLD, MLATM1, MLTSEN, MLTSM1 / 6*0 /
32713 **sr 18.5. commented since not used for evap.
32714 C DATA LLDA, LAGAIN, LSTNEW, LARTEF, LSENSE, LNORML, LMGNOR
32715 C & / 7 * .FALSE. /
32716 C DATA TSENSE / AINFNT /, NSSENS / -1 /
32717 C DATA DSMALL / ANGLGB /
32720 **sr 18.5. commented since not used for evap.
32721 C DATA LTOPT / MXXMDF * .FALSE. /, NFSCAT / 0 /
32722 C DATA ESTEPF / MXXMDF * 0.1D+00 /
32723 C DATA LSRCRH / MXXMDF * .FALSE. /, LNSCRH / MXXMDF * .FALSE. /
32724 C DATA THMSPR / 0.02D+00 /, THMSSC / 1.D+00 /
32727 DATA DPOWER /-13.D+00 /, FSPRD0 / 0.6D+00 /, FSHPFN / 0.0D+00 /,
32728 & RN1GSC /-1.0D+00 /, RN2GSC /-1.0D+00 /
32729 DATA LDIFFR / .TRUE., .TRUE., 6 * .TRUE., .TRUE., 8 * .TRUE.,
32730 & .TRUE., 4 * .TRUE., .TRUE., 3 * .TRUE.,
32731 & 4 * .FALSE., 9 * .TRUE./
32733 * default value for LEVPRT changed (reset sr 25.7.97)
32734 * default value for LHEAVY changed 25.7.97
32735 C DATA LPOWER / .TRUE. /, LINCTV / .TRUE. /, LEVPRT / .TRUE. /,
32736 C & LHEAVY / .FALSE. /, LDEEXG / .TRUE. /, LGDHPR / .TRUE. /,
32737 C & LPREEX / .TRUE. /, LHLFIX / .FALSE. /, LPRFIX / .FALSE. /,
32738 C & LPARWV / .TRUE. /, LSNGCH / .TRUE. /, LSCHDF / .TRUE. /
32739 DATA LPOWER / .TRUE. /, LINCTV / .TRUE. /, LEVPRT / .TRUE. /,
32740 & LHEAVY / .TRUE. /, LDEEXG / .TRUE. /, LGDHPR / .TRUE. /,
32741 & LPREEX / .TRUE. /, LHLFIX / .FALSE. /, LPRFIX / .FALSE. /,
32742 & LPARWV / .TRUE. /, LSNGCH / .TRUE. /, LSCHDF / .TRUE. /
32745 * default value for ILVMOD changed
32746 C DATA ILVMOD / 0 /, JLVMOD / 1 /, LLVMOD / .TRUE. /
32747 DATA ILVMOD / 1 /, JLVMOD / 1 /, LLVMOD / .TRUE. /
32751 DATA IPREEH / 0 /, IPRTRI / 0 /, IPRDEU / 0 /, IPR3HE / 0 /,
32753 DATA IEVAPL / 0 /, IEVAPH / 0 /, IEVNEU / 0 /, IEVPRO / 0 /,
32754 & IEVTRI / 0 /, IEVDEU / 0 /, IEV3HE / 0 /, IEV4HE / 0 /,
32756 DATA LRNFSS / .FALSE. /
32759 **sr 18.5. commented since not used for evap.
32760 C DATA ISCRNG, JSCRNG / 2*0 /, LSCZER / .FALSE. /
32763 **sr 18.5. commented since not used for evap.
32764 C DATA ETRACK /0.D+00/, WTRACK /0.D+00/, ATRACK /0.D+00/,
32765 C & CTRACK /0.D+00/, NTRACK /0/, MTRACK /0/, JTRACK /0/
32768 **sr 18.5. commented since not used for evap.
32769 C DATA LUSBIN, LUSEVT, LUSTKB /3*.FALSE./, NUSRBN /0/
32772 **sr 18.5. commented since not used for evap.
32773 C DATA LUSBDX /.FALSE./, NUSRBX /0/
32776 **sr 18.5. commented since not used for evap.
32777 C DATA LURSNC /.FALSE./, NURSNC /0/
32780 **sr 18.5. commented since not used for evap.
32781 C DATA LUSRTC, LUSTRK, LUSCLL / 3*.FALSE. /
32782 C DATA NUSRTC, NUSTRK, NUSCLL / 3*0 /
32785 **sr 18.5. commented since not used for evap.
32786 C DATA LUSRYL / .FALSE./, LSCUYL / .FALSE. /, NUSRYL /0/,
32787 C & IJUSYL /0/, JTUSYL /0/
32788 C DATA PUSRYL, UUSRYL, VUSRYL, WUSRYL / 4*ZERZER /
32791 **sr 18.5. commented since not used for evap.
32792 C DATA IWLBGN, IWHBGN, IWMBGN / 3*0 /
32793 C DATA LWWPRM / .TRUE. /
32795 *= end*block.bdnopt *
32798 *$ CREATE DT_BDPREE.FOR
32801 *=== bdpree ===========================================================*
32803 BLOCK DATA DT_BDPREE
32805 C INCLUDE '(DBLPRC)'
32807 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32809 * (original name: GLOBAL)
32810 PARAMETER ( KALGNM = 2 )
32811 PARAMETER ( ANGLGB = 5.0D-16 )
32812 PARAMETER ( ANGLSQ = 2.5D-31 )
32813 PARAMETER ( AXCSSV = 0.2D+16 )
32814 PARAMETER ( ANDRFL = 1.0D-38 )
32815 PARAMETER ( AVRFLW = 1.0D+38 )
32816 PARAMETER ( AINFNT = 1.0D+30 )
32817 PARAMETER ( AZRZRZ = 1.0D-30 )
32818 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
32819 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
32820 PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
32821 PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
32822 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
32823 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
32824 PARAMETER ( CSNNRM = 2.0D-15 )
32825 PARAMETER ( DMXTRN = 1.0D+08 )
32826 PARAMETER ( ZERZER = 0.D+00 )
32827 PARAMETER ( ONEONE = 1.D+00 )
32828 PARAMETER ( TWOTWO = 2.D+00 )
32829 PARAMETER ( THRTHR = 3.D+00 )
32830 PARAMETER ( FOUFOU = 4.D+00 )
32831 PARAMETER ( FIVFIV = 5.D+00 )
32832 PARAMETER ( SIXSIX = 6.D+00 )
32833 PARAMETER ( SEVSEV = 7.D+00 )
32834 PARAMETER ( EIGEIG = 8.D+00 )
32835 PARAMETER ( ANINEN = 9.D+00 )
32836 PARAMETER ( TENTEN = 10.D+00 )
32837 PARAMETER ( HLFHLF = 0.5D+00 )
32838 PARAMETER ( ONETHI = ONEONE / THRTHR )
32839 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
32840 PARAMETER ( ONEFOU = ONEONE / FOUFOU )
32841 PARAMETER ( THRTWO = THRTHR / TWOTWO )
32842 PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
32843 PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
32844 PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
32845 PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
32846 PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
32847 PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
32848 PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
32849 PARAMETER ( EULERO = 0.577215664901532860606512 D+00 )
32850 PARAMETER ( EULEXP = 1.781072417990197985236504 D+00 )
32851 PARAMETER ( EULLOG =-0.5495393129816448223376619 D+00 )
32852 PARAMETER ( E1M2EU = 0.8569023337737540831433017 D+00 )
32853 PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
32854 PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
32855 PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
32856 PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
32857 PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
32858 PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
32859 PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
32860 PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
32861 PARAMETER ( CLIGHT = 2.99792458 D+10 )
32862 PARAMETER ( AVOGAD = 6.0221367 D+23 )
32863 PARAMETER ( BOLTZM = 1.380658 D-23 )
32864 PARAMETER ( AMELGR = 9.1093897 D-28 )
32865 PARAMETER ( PLCKBR = 1.05457266 D-27 )
32866 PARAMETER ( ELCCGS = 4.8032068 D-10 )
32867 PARAMETER ( ELCMKS = 1.60217733 D-19 )
32868 PARAMETER ( AMUGRM = 1.6605402 D-24 )
32869 PARAMETER ( AMMUMU = 0.113428913 D+00 )
32870 PARAMETER ( AMPRMU = 1.007276470 D+00 )
32871 PARAMETER ( AMNEMU = 1.008664904 D+00 )
32872 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
32873 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
32874 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
32875 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
32876 PARAMETER ( PLABRC = 0.197327053 D+00 )
32877 PARAMETER ( AMELCT = 0.51099906 D-03 )
32878 PARAMETER ( AMUGEV = 0.93149432 D+00 )
32879 PARAMETER ( AMMUON = 0.105658389 D+00 )
32880 PARAMETER ( AMPRTN = 0.93827231 D+00 )
32881 PARAMETER ( AMNTRN = 0.93956563 D+00 )
32882 PARAMETER ( AMDEUT = 1.87561339 D+00 )
32883 PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
32885 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
32886 PARAMETER ( BLTZMN = 8.617385 D-14 )
32887 PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
32888 PARAMETER ( GFOHB3 = 1.16639 D-05 )
32889 PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
32890 PARAMETER ( SIN2TW = 0.2319 D+00 )
32891 PARAMETER ( GEVMEV = 1.0 D+03 )
32892 PARAMETER ( EMVGEV = 1.0 D-03 )
32893 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
32894 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
32895 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
32896 LOGICAL LGBIAS, LGBANA
32897 COMMON /FKGLOB/ LGBIAS, LGBANA
32898 C INCLUDE '(DIMPAR)'
32900 PARAMETER ( MXXRGN = 5000 )
32901 PARAMETER ( MXXMDF = 82 )
32902 PARAMETER ( MXXMDE = 54 )
32903 PARAMETER ( MFSTCK = 1000 )
32904 PARAMETER ( MESTCK = 100 )
32905 PARAMETER ( NALLWP = 39 )
32906 PARAMETER ( NELEMX = 80 )
32907 PARAMETER ( MPDPDX = 8 )
32908 PARAMETER ( ICOMAX = 180 )
32909 PARAMETER ( NSTBIS = 304 )
32910 PARAMETER ( IDMAXP = 220 )
32911 PARAMETER ( IDMXDC = 640 )
32912 PARAMETER ( MKBMX1 = 1 )
32913 PARAMETER ( MKBMX2 = 1 )
32914 C INCLUDE '(IOUNIT)'
32916 PARAMETER ( LUNIN = 5 )
32917 PARAMETER ( LUNOUT = 6 )
32918 **sr 19.5. set error output-unit from 15 to 6
32919 PARAMETER ( LUNERR = 6 )
32920 PARAMETER ( LUNBER = 14 )
32921 PARAMETER ( LUNECH = 8 )
32922 PARAMETER ( LUNFLU = 13 )
32923 PARAMETER ( LUNGEO = 16 )
32924 PARAMETER ( LUNPMF = 12 )
32925 PARAMETER ( LUNRAN = 2 )
32926 PARAMETER ( LUNXSC = 9 )
32927 PARAMETER ( LUNDET = 17 )
32928 PARAMETER ( LUNRAY = 10 )
32929 PARAMETER ( LUNRDB = 1 )
32930 PARAMETER ( LUNPGO = 7 )
32931 PARAMETER ( LUNPGS = 4 )
32932 PARAMETER ( LUNSCR = 3 )
32934 *----------------------------------------------------------------------*
32936 * Created on 16 september 1991 by Alfredo Ferrari & Paola Sala *
32939 * Last change on 03-feb-94 by Alfredo Ferrari *
32942 *----------------------------------------------------------------------*
32944 * (original name: CMPISG,CHPISG)
32945 PARAMETER ( TPPPI0 = 0.279656044337515D+00 )
32946 PARAMETER ( TNNPI0 = 0.279642680857450D+00 )
32947 PARAMETER ( TPPPIP = 0.292295207182790D+00 )
32948 PARAMETER ( TPPDEP = 0.287514778898469D+00 )
32949 PARAMETER ( TNNPIM = 0.286723140900975D+00 )
32950 PARAMETER ( TNNDEM = 0.281949292916434D+00 )
32951 PARAMETER ( TPNPI0 = 0.279456888147740D+00 )
32952 PARAMETER ( TPNDE0 = 0.274693916135245D+00 )
32953 PARAMETER ( TPNPIP = 0.292086756473890D+00 )
32954 PARAMETER ( TNPPI0 = 0.279842093144975D+00 )
32955 PARAMETER ( TNPDE0 = 0.275072555824202D+00 )
32956 PARAMETER ( TNPPIP = 0.292489370554958D+00 )
32957 PARAMETER ( PIRSMX = 1.2D+00 )
32958 PARAMETER ( NPIREA = 10 )
32959 PARAMETER ( NPIRTA = 68 )
32960 PARAMETER ( NPIRLN = 21 )
32961 PARAMETER ( NPIRLG = NPIRTA - NPIRLN )
32962 PARAMETER ( NPISIS = NPIRLN + 20 )
32963 PARAMETER ( NPISEX = NPIRLN + 21 )
32964 PARAMETER ( NPIIMN = 14 )
32965 PARAMETER ( NPIIRC = 6 )
32966 PARAMETER ( DELWLL = 0.035D+00 )
32969 COMMON /FKCMPI/ PMNPIS, PMMPIS, PISPIS, PEXPIS, PMXPIS, DPPISG,
32970 & RTPISG, AMNPIS, AMMPIS, AISPIS, AEXPIS, AMXPIS,
32971 & ARPISG, BPISLO (NPIRLN:NPIRTA,NPIREA),
32972 & CPISLO (NPIRLN:NPIRTA,NPIREA), PPITHR (NPIREA),
32973 & SPISLO (NPIRLN:NPIRTA,NPIREA), APITHR (NPIREA),
32974 & SGPIIN (NPIIMN:NPIRTA,NPIIRC), RHPICR (1:5) ,
32975 & SGPICU (0:20,NPIRTA,NPIREA) , SGRTRS (NPIREA),
32976 & SGPIDF (0:20,NPIRTA,NPIREA) , BRREIN (NPIREA),
32977 & SGPIIS (NPIRTA,NPIREA) , BRREOU (NPIREA),
32978 & BRD3OU (2,2,-1:2), BRDEOU (2,-1:2),
32979 & SGABSR (2,2,4) , PRRSDL,
32980 & IPIREA (2,2,3:5) , IPIINE (2,3:5) , NPIRVR ,
32981 & KPIIRE (2,NPIREA), KPIORE (2,NPIREA) ,
32982 & JSTOKP (5), KPTOJS (23), ITTRRS (3:5), LDLRES
32983 COMMON /FKCHPI/ CHPIRE (NPIREA)
32984 DIMENSION SG2BRS (2,2), SGABSW (2,2), SG3BRS (2,2,2)
32985 EQUIVALENCE ( SG2BRS (1,1), SGABSR (1,1,1) )
32986 EQUIVALENCE ( SGABSW (1,1), SGABSR (1,1,2) )
32987 EQUIVALENCE ( SG3BRS (1,1,1), SGABSR (1,1,3) )
32988 * (original name: FRBKCM)
32989 PARAMETER ( MXFFBK = 6 )
32990 PARAMETER ( MXZFBK = 9 )
32991 PARAMETER ( MXNFBK = 10 )
32992 PARAMETER ( MXAFBK = 16 )
32993 PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
32994 PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
32995 PARAMETER ( NXAFBK = MXAFBK + 1 )
32996 PARAMETER ( MXPSST = 300 )
32997 PARAMETER ( MXPSFB = 41000 )
32998 LOGICAL LFRMBK, LNCMSS
32999 COMMON /FKFRBK/ AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
33000 & EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
33001 & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
33002 & IFRBKN (MXPSST), IFRBKZ (MXPSST),
33003 & IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
33004 & IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
33005 & IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
33006 & IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
33007 & IFBFRB, NBUFBK, LFRMBK, LNCMSS
33008 * (original name: NUCGID,NUCGEO,NUCGE2,NUCPWI,NUCGII)
33009 PARAMETER ( PI = PIPIPI )
33010 PARAMETER ( PISQ = PIPISQ )
33011 PARAMETER ( SKTOHL = 0.5456645846610345D+00 )
33012 PARAMETER ( RZNUCL = 1.12 D+00 )
33013 PARAMETER ( RMSPRO = 0.8 D+00 )
33014 PARAMETER ( R0PROT = RMSPRO / SQRT12 )
33015 PARAMETER ( ARHPRO = 1.D+00 / 8.D+00 / PI / R0PROT / R0PROT
33017 PARAMETER ( RLLE04 = RZNUCL )
33018 PARAMETER ( RLLE16 = RZNUCL )
33019 PARAMETER ( RLGT16 = RZNUCL )
33020 PARAMETER ( RCLE04 = 0.75D+00 / PI / RLLE04 / RLLE04 / RLLE04 )
33021 PARAMETER ( RCLE16 = 0.75D+00 / PI / RLLE16 / RLLE16 / RLLE16 )
33022 PARAMETER ( RCGT16 = 0.75D+00 / PI / RLGT16 / RLGT16 / RLGT16 )
33023 PARAMETER ( SKLE04 = 1.4D+00 )
33024 PARAMETER ( SKLE16 = 1.9D+00 )
33025 PARAMETER ( SKGT16 = 2.4D+00 )
33026 PARAMETER ( HLLE04 = SKTOHL * SKLE04 )
33027 PARAMETER ( HLLE16 = SKTOHL * SKLE16 )
33028 PARAMETER ( HLGT16 = SKTOHL * SKGT16 )
33029 PARAMETER ( ALPHA0 = 0.1D+00 )
33030 PARAMETER ( OMALH0 = 1.D+00 - ALPHA0 )
33031 PARAMETER ( GAMSK0 = 0.9D+00 )
33032 PARAMETER ( OMGAS0 = 1.D+00 - GAMSK0 )
33033 PARAMETER ( POTME0 = 0.6666666666666667D+00 )
33034 PARAMETER ( POTBA0 = 1.D+00 )
33035 PARAMETER ( PNFRAT = 1.533D+00 )
33036 PARAMETER ( RADPIM = 0.035D+00 )
33037 PARAMETER ( RDPMHL = 14.D+00 )
33038 PARAMETER ( APMRST = 4.D+00 / 44.D+00 )
33039 PARAMETER ( APMPRO = 1.D+00 / 6.D+00 )
33040 PARAMETER ( APPPRO = 5.D+00 / 6.D+00 )
33041 PARAMETER ( AP0PFS = 0.5D+00 )
33042 PARAMETER ( AP0PFP = 1.D+00 / 3.D+00 )
33043 PARAMETER ( AP0NFP = 2.D+00 / 3.D+00 )
33044 PARAMETER ( XPAUCO = 1.88495407241652 D+00 )
33045 PARAMETER ( MXSCIN = 50 )
33046 LOGICAL LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH, LNCDCY,
33047 & LNUSCT, LPREEQ, LNPHTC, LNWRAD, LPNRHO, LFTCMP, LFTCAC
33048 COMMON /FKNGID/ RHOTAB (2:260), RHATAB (2:260), ALPTAB (2:260),
33049 & RADTAB (2:260), SKITAB (2:260), HALTAB (2:260),
33050 & SK3TAB (2:260), SK4TAB (2:260), HABTAB (2:260),
33051 & CWSTAB (2:260), EKATAB (2:260), PFATAB (2:260),
33053 COMMON /FKNGEO/ RADTOT, RADIU1, RADIU0, RAD1O2, SKINDP, HALODP,
33054 & ALPHAL, OMALHL, RADSKN, SKNEFF, CPARWS, RADPRO,
33055 & RADCOR, RADCO2, RADMAX, BIMPTR, RIMPTR, XIMPTR,
33056 & YIMPTR, ZIMPTR, RHOIMT, EKFPRO, PFRPRO, RHOCEN,
33057 & RHOCOR, RHOSKN, EKFCEN (2), PFRCEN (2), EKFBIM,
33058 & PFRBIM, RHOIMP, EKFIMP, PFRIMP, RHOIM2, EKFIM2,
33059 & PFRIM2, RHOIM3, EKFIM3, PFRIM3, VPRWLL, RIMPCT,
33060 & BIMPCT, XIMPCT, YIMPCT, ZIMPCT, RIMPC2, XIMPC2,
33061 & YIMPC2, ZIMPC2, RIMPC3, XIMPC3, YIMPC3, ZIMPC3,
33062 & XBIMPC, YBIMPC, ZBIMPC, CXIMPC, CYIMPC, CZIMPC,
33063 & SQRIMP, SIGMAP, SIGMAN, SIGMAA, RHORED, R0TRAJ,
33064 & R1TRAJ, SBUSED, SBTOT , SBRES , RHOAVE, EKFAVE,
33065 & PFRAVE, AVEBIN, ACOLL , ZCOLL , RADSIG, OPACTY,
33066 & EKECON, PNUCCO, EKEWLL, PPRWLL, PXPROJ, PYPROJ,
33067 & PZPROJ, EKFERM, PNFRMI, PXFERM, PYFERM, PZFERM,
33068 & EKFER2, PNFRM2, PXFER2, PYFER2, PZFER2, EKFER3,
33069 & PNFRM3, PXFER3, PYFER3, PZFER3, RHOMEM, EKFMEM,
33070 & BIMMEM, WLLRED, VPRBIM, POTINC, POTOUT, EEXMIN
33071 COMMON /FKNGE2/ RDTTNC (2), RHONCP (2), RHONC2 (2), RHONC3 (2),
33072 & RHONCT (2), AMOTHR, EKOTHR, AMCREA, EKNCLN,
33073 & EEXDEL, EEXANY, CLMBBR, RDCLMB, BFCLMB, BFCEFF,
33074 & BNPROJ, BNDNUC, DEBRLM, SK4PAR, UBIMPC, VBIMPC,
33075 & WBIMPC, BNDPOT, SIGMAT, SIGABP, SIGABN, WLLRES,
33076 & POTBAR, POTMES, AGEPRI, OPNOPA, ETHRND,
33077 & BNENRG (3), DEFNUC (2), SIGMPR (4), SIGMNU (4),
33078 & SIGPAB (3), SIGNAB (3), HHLP (2), FORTOT (2),
33079 & FPNBLC, DPNBLC, FFTFLG, IFTFLG,
33080 & IPWELL, ITNCMX, KPRIN , NTARGT, KNUCIM, KNUCI2,
33081 & KNUCI3, IEVPRE, ISFCOL, ISFTAR, ISFTA2, ISFTA3,
33082 & NPOTHR, ICOTHR, IBOTHR, NPUMFN, ISTNCL, ITAUCM,
33083 & IABCOU, IADFLG, IGSFLG, IALFLG, ICBFLG, LPREEQ,
33084 & LNPHTC, LPNRHO, LNWRAD, LFTCMP, LFTCAC
33085 COMMON /FKNPWI/ ALMBAR, BIMMAX, SIGGEO, LLLMAX, LLLACT
33086 COMMON /FKNGII/ HOLEXP (2*MXSCIN), XEXPIN (3,0:MXSCIN),
33087 & YEXPIN (3,0:MXSCIN), ZEXPIN (3,0:MXSCIN),
33088 & AGEXIN (0:MXSCIN), RHOEXP (2), EKFEXP, EHLFIX,
33089 & NHLEXP, NHLFIX, IPRTYP, NNCEXI (0:MXSCIN),
33090 & NCEXPI (3,0:MXSCIN), ISEXIN (3,0:MXSCIN),
33091 & ISCTYP (0:MXSCIN), NUSCIN, NEXPEM,
33092 & LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH,
33094 DIMENSION AWSTAB (2:260), SIGMAB (3)
33095 EQUIVALENCE ( DEFPRO, DEFNUC (1) )
33096 EQUIVALENCE ( DEFNEU, DEFNUC (2) )
33097 EQUIVALENCE ( RHOIPP, RHONCP (1) )
33098 EQUIVALENCE ( RHOINP, RHONCP (2) )
33099 EQUIVALENCE ( RHOIP2, RHONC2 (1) )
33100 EQUIVALENCE ( RHOIN2, RHONC2 (2) )
33101 EQUIVALENCE ( RHOIP3, RHONC3 (1) )
33102 EQUIVALENCE ( RHOIN3, RHONC3 (2) )
33103 EQUIVALENCE ( RHOIPT, RHONCT (1) )
33104 EQUIVALENCE ( RHOINT, RHONCT (2) )
33105 EQUIVALENCE ( OMALHL, SK3PAR )
33106 EQUIVALENCE ( ALPHAL, HABPAR )
33107 EQUIVALENCE ( ALPTAB (2), AWSTAB (2) )
33108 EQUIVALENCE ( SIGMPE, SIGMPR (1) )
33109 EQUIVALENCE ( SIGMPC, SIGMPR (2) )
33110 EQUIVALENCE ( SIGMPI, SIGMPR (3) )
33111 EQUIVALENCE ( SIGMPA, SIGMPR (4) )
33112 EQUIVALENCE ( SIGMNE, SIGMNU (1) )
33113 EQUIVALENCE ( SIGMNC, SIGMNU (2) )
33114 EQUIVALENCE ( SIGMNI, SIGMNU (3) )
33115 EQUIVALENCE ( SIGMNA, SIGMNU (4) )
33116 EQUIVALENCE ( SIGMA2, SIGPAB (1) )
33117 EQUIVALENCE ( SIGMA3, SIGPAB (2) )
33118 EQUIVALENCE ( SIGMAS, SIGPAB (3) )
33119 EQUIVALENCE ( SIGPAB (1), SIGMAB (1) )
33120 * (original name: NUCLEV)
33121 LOGICAL LCLVSL, LFLVSL, LRLVSL, LEQSBL
33122 COMMON /FKNLEV/ PAENUC (200,2), SHENUC (200,2), DEFRMI (2),
33123 & DEFMAG (2), ENNCLV (160,2), RANCLV (160,2),
33124 & CUMRAD (0:160,2), RUSNUC (2),
33125 & ENPLVL (114), ENNLVL(164), JUSNUC (160,2),
33126 & NTANUC (2), NAVNUC (2), NLSNUC (2), NCONUC (2),
33127 & NSKNUC (2), NHANUC (2), NUSNUC (2), NACNUC (2),
33128 & JMXNUC (2), IPRNUC (3), JPRNUC (3), MAGNUM (8),
33129 & MAGNUC (2), MGSNUC (8,2), MGSSNC (25,2),
33130 & NSBSHL (2), NMNSBS (2), NPRNUC, INUCLV, LCLVSL,
33131 & LFLVSL, LRLVSL, LEQSBL
33132 DIMENSION JUSPRO (160), JUSNEU (160), MGSPRO (8), MGSNEU (8),
33133 & MGSSPR (19) , MGSSNE (25)
33134 EQUIVALENCE ( RUSNUC (1), RUSPRO )
33135 EQUIVALENCE ( RUSNUC (2), RUSNEU )
33136 EQUIVALENCE ( JUSNUC (1,1), JUSPRO (1) )
33137 EQUIVALENCE ( JUSNUC (1,2), JUSNEU (1) )
33138 EQUIVALENCE ( MGSNUC (1,1), MGSPRO (1) )
33139 EQUIVALENCE ( MGSNUC (1,2), MGSNEU (1) )
33140 EQUIVALENCE ( MGSSNC (1,1), MGSSPR (1) )
33141 EQUIVALENCE ( MGSSNC (1,2), MGSSNE (1) )
33142 EQUIVALENCE ( NTANUC (1), NTAPRO )
33143 EQUIVALENCE ( NTANUC (2), NTANEU )
33144 EQUIVALENCE ( NAVNUC (1), NAVPRO )
33145 EQUIVALENCE ( NAVNUC (2), NAVNEU )
33146 EQUIVALENCE ( NLSNUC (1), NLSPRO )
33147 EQUIVALENCE ( NLSNUC (2), NLSNEU )
33148 EQUIVALENCE ( NCONUC (1), NCOPRO )
33149 EQUIVALENCE ( NCONUC (2), NCONEU )
33150 EQUIVALENCE ( NSKNUC (1), NSKPRO )
33151 EQUIVALENCE ( NSKNUC (2), NSKNEU )
33152 EQUIVALENCE ( NHANUC (1), NHAPRO )
33153 EQUIVALENCE ( NHANUC (2), NHANEU )
33154 EQUIVALENCE ( NUSNUC (1), NUSPRO )
33155 EQUIVALENCE ( NUSNUC (2), NUSNEU )
33156 EQUIVALENCE ( NACNUC (1), NACPRO )
33157 EQUIVALENCE ( NACNUC (2), NACNEU )
33158 EQUIVALENCE ( JMXNUC (1), JMXPRO )
33159 EQUIVALENCE ( JMXNUC (2), JMXNEU )
33160 EQUIVALENCE ( MAGNUC (1), MAGPRO )
33161 EQUIVALENCE ( MAGNUC (2), MAGNEU )
33162 * (original name: PARNUC)
33163 PARAMETER ( PIGRK = PIPIPI )
33164 PARAMETER ( ALEVEL = 8.D-03 )
33165 PARAMETER ( RCNUCL = 1.12D+00 )
33166 PARAMETER ( R0SIG = 1.3D+00 )
33167 PARAMETER ( R0SIGK = 1.5D+00 )
33168 PARAMETER ( RCOULB = 1.5D+00 )
33169 PARAMETER ( COULBH = 0.88235D-03 )
33170 PARAMETER ( RHONU0 = 0.75D+00 / PIGRK / RCNUCL / RCNUCL / RCNUCL )
33171 PARAMETER ( TAUFO0 = 10.0D+00 )
33172 PARAMETER ( EKEEXP = 0.03D+00 )
33173 PARAMETER ( EKREXP = 0.05D+00 )
33174 PARAMETER ( EKEMNM = 0.01D+00 )
33175 PARAMETER ( NCPMX = 120 )
33176 COMMON /FKPARN/ EKORI , PXORI , PYORI , PZORI , PTORI , TAUFOR,
33177 & ENNUC (NCPMX), PNUCL (NCPMX), EKFNUC (NCPMX),
33178 & XSTNUC (NCPMX), YSTNUC (NCPMX), ZSTNUC (NCPMX),
33179 & PXNUCL (NCPMX), PYNUCL (NCPMX), PZNUCL (NCPMX),
33180 & RSTNUC (NCPMX), FREEPA (NCPMX), CRRPAN (NCPMX),
33181 & CRRPAP (NCPMX), BSTNUC (NCPMX), AGENUC (NCPMX),
33182 & TAUFPA (NCPMX), RHNUCL(NCPMX,2), BNDGAV, DEFMIN,
33183 & KPNUCL (NCPMX), KRFNUC (NCPMX), ILINUC (NCPMX),
33184 & INUCTS (NCPMX), ISFNUC (NCPMX), KPORI , IBORI ,
33185 & IBNUCL, NPNUC , NNUCTS
33187 DATA LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH / 6*.FALSE. /
33188 DATA POTBAR / POTBA0 /, POTMES / POTME0 /, WLLRES / 0.D+00 /
33189 DATA JUSNUC / 320 * 0 /, INUCLV / 1 /, IEVPRE / 0 /
33190 DATA MAGNUM / 2, 8, 20, 28, 50, 82, 126, 160 /
33191 DATA LPREEQ / .FALSE. /
33193 DATA JSTOKP / 1, 8, 13, 14, 23 /
33194 DATA KPTOJS / 1, 6*0, 2, 4*0, 3, 4, 8*0, 5 /
33195 DATA CHPIRE / 'PI+PPI+P','PI-PPI-P','PI-PPI0N','PI0PPI0P',
33196 & 'PI0PPI+N','PI-NPI-N','PI+NPI+N','PI+NPI0P',
33197 & 'PI0NPI0N','PI0NPI-P' /
33198 DATA KPIIRE / 13, 1, 14, 1, 14, 1, 23, 1, 23, 1, 14, 8,
33199 & 13, 8, 13, 8, 23, 8, 23, 8 /
33200 DATA KPIORE / 13, 1, 14, 1, 23, 8, 23, 1, 13, 8, 14, 8,
33201 & 13, 8, 23, 1, 23, 8, 14, 1 /
33202 DATA IPIREA / 1, 0, 7, 8, 2, 3, 6, 0, 4, 5, 9, 10 /
33203 DATA IPIINE / 1, 2, 3, 4, 5, 6 /
33205 DATA LFRMBK / .FALSE. /
33206 DATA NBUFBK / 500 /
33207 DATA EXMXFB / 80.0 D+00 /
33208 DATA R0FRBK / 1.18 D+00 /
33209 DATA R0CFBK / 2.173D+00 /
33210 DATA C1CFBK / 6.103D-03 /
33211 DATA C2CFBK / 9.443D-03 /
33213 DATA TAUFOR / TAUFO0 /
33214 *=== End of Block Data Bdpree =========================================*
33217 *$ CREATE DT_XHOINI.FOR
33220 *====phoini============================================================*
33222 SUBROUTINE DT_XHOINI
33223 C SUBROUTINE DT_PHOINI
33225 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33227 PARAMETER ( LINP = 10 ,
33234 *$ CREATE DT_XVENTB.FOR
33237 *====eventb============================================================*
33239 SUBROUTINE DT_XVENTB(NCSY,IREJ)
33240 C SUBROUTINE DT_EVENTB(NCSY,IREJ)
33242 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33244 PARAMETER ( LINP = 10 ,
33249 1000 FORMAT(1X,'EVENTB: PHOJET-package requested but not linked!')
33254 *$ CREATE DT_XVENT.FOR
33257 *===event==============================================================*
33259 SUBROUTINE DT_XVENT(IDUM,PP,PT,DUM,IREJ)
33260 C SUBROUTINE EVENT(IDUM,PP,PT,DUM,IREJ)
33262 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33265 DIMENSION PP(4),PT(4)
33270 *$ CREATE DT_XOHISX.FOR
33273 *===pohisx=============================================================*
33275 SUBROUTINE DT_XOHISX(I,X)
33276 C SUBROUTINE POHISX(I,X)
33278 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33284 *$ CREATE PHO_LHIST.FOR
33287 *===poluhi=============================================================*
33289 SUBROUTINE PHO_LHIST(I,X)
33292 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33298 *$ CREATE PDFSET.FOR
33301 C**********************************************************************
33303 C dummy subroutines, remove to link PDFLIB
33305 C**********************************************************************
33306 SUBROUTINE PDFSET(PARAM,VALUE)
33307 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33308 DIMENSION PARAM(20),VALUE(20)
33312 *$ CREATE STRUCTM.FOR
33315 SUBROUTINE STRUCTM(XI,SCALE2,UV,DV,US,DS,SS,CS,BS,TS,GL)
33316 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33319 *$ CREATE STRUCTP.FOR
33322 SUBROUTINE STRUCTP(XI,SCALE2,P2,IP2,UV,DV,US,DS,SS,CS,BS,TS,GL)
33323 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33326 *$ CREATE DT_DIQBRK.FOR
33329 *===diqbrk=============================================================*
33331 SUBROUTINE DT_XIQBRK
33332 C SUBROUTINE DT_DIQBRK
33334 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33337 STOP 'diquark-breaking not implemeted !'
33342 *$ CREATE DT_ELHAIN.FOR
33345 *===elhain=============================================================*
33347 SUBROUTINE DT_ELHAIN(IP,PLA,ELAB,CX,CY,CZ,IT,IREJ)
33349 ************************************************************************
33350 * Elastic hadron-hadron scattering. *
33351 * This is a revised version of the original. *
33352 * This version dated 03.04.98 is written by S. Roesler *
33353 ************************************************************************
33355 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33357 PARAMETER ( LINP = 10 ,
33360 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
33363 PARAMETER (ENNTHR = 3.5D0)
33364 PARAMETER (PLOWH=0.01D0,PHIH=9.0D0,
33365 & BLOWB=0.05D0,BHIB=0.2D0,
33366 & BLOWM=0.1D0, BHIM=2.0D0)
33368 * particle properties (BAMJET index convention)
33370 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
33371 & IICH(210),IIBAR(210),K1(210),K2(210)
33372 * final state from HADRIN interaction
33373 PARAMETER (MAXFIN=10)
33374 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
33375 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
33377 C DATA TSLOPE /10.0D0/
33383 PLAB = SQRT( (ELAB-AAM(IP))*(ELAB+AAM(IP)) )
33384 EKIN = ELAB-AAM(IP)
33385 * kinematical quantities in cms of the hadrons
33388 S = AMP2+AMT2+TWO*ELAB*AAM(IT)
33390 ECMP = OHALF*ECM+(AMP2-AMT2)/(TWO*ECM)
33391 PCM = SQRT( (ECMP-AAM(IP))*(ECMP+AAM(IP)) )
33393 * nucleon-nucleon scattering at E_kin<3.5: use DT_TSAMCS(HETC-KFA)
33394 IF ( ((IP.EQ.1).OR.(IP.EQ.8)).AND.
33395 & ((IT.EQ.1).OR.(IT.EQ.8)).AND.(EKIN.LT.ENNTHR) ) THEN
33396 * TSAMCS treats pp and np only, therefore change pn into np and
33402 IF (IP.EQ.8) KPROJ = 1
33404 CALL DT_TSAMCS(KPROJ,EKIN,CTCMS)
33405 T = TWO*PCM**2*(CTCMS-ONE)
33407 * very crude treatment otherwise: sample t from exponential dist.
33409 * momentum transfer t
33410 TMAX = TWO*TWO*PCM**2
33411 RR = (PLAB-PLOWH)/(PHIH-PLOWH)
33412 IF (IIBAR(IP).NE.0) THEN
33413 TSLOPE = BLOWB+RR*(BHIB-BLOWB)
33415 TSLOPE = BLOWM+RR*(BHIM-BLOWM)
33417 FMAX = EXP(-TSLOPE*TMAX)-ONE
33419 T = LOG(ONE+R*FMAX+TINY10)/TSLOPE
33420 IF (T.GT.ZERO) T = LOG(ONE+R*FMAX)/TSLOPE
33423 * target hadron in Lab after scattering
33424 ELRH(2) = (TWO*AMT2-T)/(TWO*AAM(IT))
33425 PLRH(2) = SQRT( ABS(ELRH(2)-AAM(IT))*(ELRH(2)+AAM(IT)) )
33426 IF (PLRH(2).LE.TINY10) THEN
33427 C WRITE(*,*)'ELHAIN: T,PLRH(2) ',T,PLRH(2)
33430 * projectile hadron in Lab after scattering
33431 ELRH(1) = ELAB+AAM(IT)-ELRH(2)
33432 PLRH(1) = SQRT( ABS(ELRH(1)-AAM(IP))*(ELRH(1)+AAM(IP)) )
33433 * scattering angle of projectile in Lab
33434 CTLABP = (T-TWO*AMP2+TWO*ELAB*ELRH(1))/(TWO*PLAB*PLRH(1))
33435 STLABP = SQRT( (ONE-CTLABP)*(ONE+CTLABP) )
33436 CALL DT_DSFECF(SPLABP,CPLABP)
33437 * direction cosines of projectile in Lab
33438 CALL DT_STTRAN(CX,CY,CZ,CTLABP,STLABP,SPLABP,CPLABP,
33439 & CXRH(1),CYRH(1),CZRH(1))
33440 * scattering angle of target in Lab
33441 PLLABT = PLAB-CTLABP*PLRH(1)
33442 CTLABT = PLLABT/PLRH(2)
33443 STLABT = SQRT( (ONE-CTLABT)*(ONE+CTLABT) )
33444 * direction cosines of target in Lab
33445 CALL DT_STTRAN(CX,CY,CZ,CTLABT,STLABT,-SPLABP,-CPLABP,
33446 & CXRH(2),CYRH(2),CZRH(2))
33455 *$ CREATE DT_TSAMCS.FOR
33458 *===tsamcs=============================================================*
33460 SUBROUTINE DT_TSAMCS(KPROJ,EKIN,CST)
33462 ************************************************************************
33463 * Sampling of cos(theta) for nucleon-proton scattering according to *
33464 * hetkfa2/bertini parametrization. *
33465 * This is a revised version of the original (HJM 24/10/88) *
33466 * This version dated 28.10.95 is written by S. Roesler *
33467 ************************************************************************
33469 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33471 PARAMETER ( LINP = 10 ,
33474 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
33477 DIMENSION DCLIN(195),DCHN(143),DCHNA(36),DCHNB(60)
33478 DIMENSION PDCI(60),PDCH(55)
33480 DATA (DCLIN(I),I=1,80) /
33481 & 5.000D-01, 1.000D+00, 0.000D+00, 1.000D+00, 0.000D+00,
33482 & 4.993D-01, 9.881D-01, 5.963D-02, 9.851D-01, 5.945D-02,
33483 & 4.936D-01, 8.955D-01, 5.224D-01, 8.727D-01, 5.091D-01,
33484 & 4.889D-01, 8.228D-01, 8.859D-01, 7.871D-01, 8.518D-01,
33485 & 4.874D-01, 7.580D-01, 1.210D+00, 7.207D-01, 1.117D+00,
33486 & 4.912D-01, 6.969D-01, 1.516D+00, 6.728D-01, 1.309D+00,
33487 & 5.075D-01, 6.471D-01, 1.765D+00, 6.667D-01, 1.333D+00,
33488 & 5.383D-01, 6.054D-01, 1.973D+00, 7.059D-01, 1.176D+00,
33489 & 5.397D-01, 5.990D-01, 2.005D+00, 7.023D-01, 1.191D+00,
33490 & 5.336D-01, 6.083D-01, 1.958D+00, 6.959D-01, 1.216D+00,
33491 & 5.317D-01, 6.075D-01, 1.962D+00, 6.897D-01, 1.241D+00,
33492 & 5.300D-01, 6.016D-01, 1.992D+00, 6.786D-01, 1.286D+00,
33493 & 5.281D-01, 6.063D-01, 1.969D+00, 6.786D-01, 1.286D+00,
33494 & 5.280D-01, 5.960D-01, 2.020D+00, 6.667D-01, 1.333D+00,
33495 & 5.273D-01, 5.920D-01, 2.040D+00, 6.604D-01, 1.358D+00,
33496 & 5.273D-01, 5.862D-01, 2.069D+00, 6.538D-01, 1.385D+00/
33497 DATA (DCLIN(I),I=81,160) /
33498 & 5.223D-01, 5.980D-01, 2.814D+00, 6.538D-01, 1.385D+00,
33499 & 5.202D-01, 5.969D-01, 2.822D+00, 6.471D-01, 1.412D+00,
33500 & 5.183D-01, 5.881D-01, 2.883D+00, 6.327D-01, 1.469D+00,
33501 & 5.159D-01, 5.866D-01, 2.894D+00, 6.250D-01, 1.500D+00,
33502 & 5.133D-01, 5.850D-01, 2.905D+00, 6.170D-01, 1.532D+00,
33503 & 5.106D-01, 5.833D-01, 2.917D+00, 6.087D-01, 1.565D+00,
33504 & 5.084D-01, 5.801D-01, 2.939D+00, 6.000D-01, 1.600D+00,
33505 & 5.063D-01, 5.763D-01, 2.966D+00, 5.909D-01, 1.636D+00,
33506 & 5.036D-01, 5.730D-01, 2.989D+00, 5.814D-01, 1.674D+00,
33507 & 5.014D-01, 5.683D-01, 3.022D+00, 5.714D-01, 1.714D+00,
33508 & 4.986D-01, 5.641D-01, 3.051D+00, 5.610D-01, 1.756D+00,
33509 & 4.964D-01, 5.580D-01, 3.094D+00, 5.500D-01, 1.800D+00,
33510 & 4.936D-01, 5.573D-01, 3.099D+00, 5.431D-01, 1.827D+00,
33511 & 4.909D-01, 5.509D-01, 3.144D+00, 5.313D-01, 1.875D+00,
33512 & 4.885D-01, 5.512D-01, 3.142D+00, 5.263D-01, 1.895D+00,
33513 & 4.857D-01, 5.437D-01, 3.194D+00, 5.135D-01, 1.946D+00/
33514 DATA (DCLIN(I),I=161,195) /
33515 & 4.830D-01, 5.353D-01, 3.253D+00, 5.000D-01, 2.000D+00,
33516 & 4.801D-01, 5.323D-01, 3.274D+00, 4.915D-01, 2.034D+00,
33517 & 4.770D-01, 5.228D-01, 3.341D+00, 4.767D-01, 2.093D+00,
33518 & 4.738D-01, 5.156D-01, 3.391D+00, 4.643D-01, 2.143D+00,
33519 & 4.701D-01, 5.010D-01, 3.493D+00, 4.444D-01, 2.222D+00,
33520 & 4.672D-01, 4.990D-01, 3.507D+00, 4.375D-01, 2.250D+00,
33521 & 4.634D-01, 4.856D-01, 3.601D+00, 4.194D-01, 2.323D+00/
33524 & 4.400D+02, 1.896D-01, 1.931D-01, 1.982D-01, 1.015D-01,
33525 & 1.029D-01, 4.180D-02, 4.228D-02, 4.282D-02, 4.350D-02,
33526 & 2.204D-02, 2.236D-02, 5.900D+02, 1.433D-01, 1.555D-01,
33527 & 1.774D-01, 1.000D-01, 1.128D-01, 5.132D-02, 5.600D-02,
33528 & 6.158D-02, 6.796D-02, 3.660D-02, 3.820D-02, 6.500D+02,
33529 & 1.192D-01, 1.334D-01, 1.620D-01, 9.527D-02, 1.141D-01,
33530 & 5.283D-02, 5.952D-02, 6.765D-02, 7.878D-02, 4.796D-02,
33531 & 6.957D-02, 8.000D+02, 4.872D-02, 6.694D-02, 1.152D-01,
33532 & 9.348D-02, 1.368D-01, 6.912D-02, 7.953D-02, 9.577D-02,
33533 & 1.222D-01, 7.755D-02, 9.525D-02, 1.000D+03, 3.997D-02,
33534 & 5.456D-02, 9.804D-02, 8.084D-02, 1.208D-01, 6.520D-02,
33535 & 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02, 1.093D-01/
33538 & 1.000D+03, 9.453D-02, 9.804D-02, 8.084D-02, 1.208D-01,
33539 & 6.520D-02, 8.233D-02, 1.084D-01, 1.474D-01, 9.328D-02,
33540 & 1.093D-01, 1.400D+03, 1.072D-01, 7.450D-02, 6.645D-02,
33541 & 1.136D-01, 6.750D-02, 8.580D-02, 1.110D-01, 1.530D-01,
33542 & 1.010D-01, 1.350D-01, 2.170D+03, 4.004D-02, 3.013D-02,
33543 & 2.664D-02, 5.511D-02, 4.240D-02, 7.660D-02, 1.364D-01,
33544 & 2.300D-01, 1.670D-01, 2.010D-01, 2.900D+03, 1.870D-02,
33545 & 1.804D-02, 1.320D-02, 2.970D-02, 2.860D-02, 5.160D-02,
33546 & 1.020D-01, 2.400D-01, 2.250D-01, 3.370D-01, 4.400D+03,
33547 & 1.196D-03, 8.784D-03, 1.517D-02, 2.874D-02, 2.488D-02,
33548 & 4.464D-02, 8.330D-02, 2.008D-01, 2.360D-01, 3.567D-01/
33550 DATA (DCHN(I),I=1,90) /
33551 & 4.770D-01, 4.750D-01, 4.715D-01, 4.685D-01, 4.650D-01,
33552 & 4.610D-01, 4.570D-01, 4.550D-01, 4.500D-01, 4.450D-01,
33553 & 4.405D-01, 4.350D-01, 4.300D-01, 4.250D-01, 4.200D-01,
33554 & 4.130D-01, 4.060D-01, 4.000D-01, 3.915D-01, 3.840D-01,
33555 & 3.760D-01, 3.675D-01, 3.580D-01, 3.500D-01, 3.400D-01,
33556 & 3.300D-01, 3.200D-01, 3.100D-01, 3.000D-01, 2.900D-01,
33557 & 2.800D-01, 2.700D-01, 2.600D-01, 2.500D-01, 2.400D-01,
33558 & 2.315D-01, 2.240D-01, 2.150D-01, 2.060D-01, 2.000D-01,
33559 & 1.915D-01, 1.850D-01, 1.780D-01, 1.720D-01, 1.660D-01,
33560 & 1.600D-01, 1.550D-01, 1.500D-01, 1.450D-01, 1.400D-01,
33561 & 1.360D-01, 1.320D-01, 1.280D-01, 1.250D-01, 1.210D-01,
33562 & 1.180D-01, 1.150D-01, 1.120D-01, 1.100D-01, 1.070D-01,
33563 & 1.050D-01, 1.030D-01, 1.010D-01, 9.900D-02, 9.700D-02,
33564 & 9.550D-02, 9.480D-02, 9.400D-02, 9.200D-02, 9.150D-02,
33565 & 9.100D-02, 9.000D-02, 8.990D-02, 8.900D-02, 8.850D-02,
33566 & 8.750D-02, 8.700D-02, 8.650D-02, 8.550D-02, 8.500D-02,
33567 & 8.499D-02, 8.450D-02, 8.350D-02, 8.300D-02, 8.250D-02,
33568 & 8.150D-02, 8.100D-02, 8.030D-02, 8.000D-02, 7.990D-02/
33569 DATA (DCHN(I),I=91,143) /
33570 & 7.980D-02, 7.950D-02, 7.900D-02, 7.860D-02, 7.800D-02,
33571 & 7.750D-02, 7.650D-02, 7.620D-02, 7.600D-02, 7.550D-02,
33572 & 7.530D-02, 7.500D-02, 7.499D-02, 7.498D-02, 7.480D-02,
33573 & 7.450D-02, 7.400D-02, 7.350D-02, 7.300D-02, 7.250D-02,
33574 & 7.230D-02, 7.200D-02, 7.100D-02, 7.050D-02, 7.020D-02,
33575 & 7.000D-02, 6.999D-02, 6.995D-02, 6.993D-02, 6.991D-02,
33576 & 6.990D-02, 6.870D-02, 6.850D-02, 6.800D-02, 6.780D-02,
33577 & 6.750D-02, 6.700D-02, 6.650D-02, 6.630D-02, 6.600D-02,
33578 & 6.550D-02, 6.525D-02, 6.510D-02, 6.500D-02, 6.499D-02,
33579 & 6.498D-02, 6.496D-02, 6.494D-02, 6.493D-02, 6.490D-02,
33580 & 6.488D-02, 6.485D-02, 6.480D-02/
33583 & 6.300D+02, 7.810D-02, 1.421D-01, 1.979D-01, 2.479D-01,
33584 & 3.360D-01, 5.400D-01, 7.236D-01, 1.000D+00, 1.540D+03,
33585 & 2.225D-01, 3.950D-01, 5.279D-01, 6.298D-01, 7.718D-01,
33586 & 9.405D-01, 9.835D-01, 1.000D+00, 2.560D+03, 2.625D-01,
33587 & 4.550D-01, 5.963D-01, 7.020D-01, 8.380D-01, 9.603D-01,
33588 & 9.903D-01, 1.000D+00, 3.520D+03, 4.250D-01, 6.875D-01,
33589 & 8.363D-01, 9.163D-01, 9.828D-01, 1.000D+00, 1.000D+00,
33593 & 6.300D+02, 3.800D-02, 7.164D-02, 1.275D-01, 2.171D-01,
33594 & 3.227D-01, 4.091D-01, 5.051D-01, 6.061D-01, 7.074D-01,
33595 & 8.434D-01, 1.000D+00, 2.040D+03, 1.200D-01, 2.115D-01,
33596 & 3.395D-01, 5.295D-01, 7.251D-01, 8.511D-01, 9.487D-01,
33597 & 9.987D-01, 1.000D+00, 1.000D+00, 1.000D+00, 2.200D+03,
33598 & 1.344D-01, 2.324D-01, 3.754D-01, 5.674D-01, 7.624D-01,
33599 & 8.896D-01, 9.808D-01, 1.000D+00, 1.000D+00, 1.000D+00,
33600 & 1.000D+00, 2.850D+03, 2.330D-01, 4.130D-01, 6.610D-01,
33601 & 9.010D-01, 9.970D-01, 1.000D+00, 1.000D+00, 1.000D+00,
33602 & 1.000D+00, 1.000D+00, 1.000D+00, 3.500D+03, 3.300D-01,
33603 & 5.450D-01, 7.950D-01, 1.000D+00, 1.000D+00, 1.000D+00,
33604 & 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00, 1.000D+00/
33607 IF (EKIN.GT.3.5D0) RETURN
33609 IF(KPROJ.EQ.8) GOTO 101
33610 IF(KPROJ.EQ.1) GOTO 102
33611 C* INVALID REACTION
33612 WRITE(LOUT,'(A,I5/A)')
33613 & ' INVALID PARTICLE TYPE IN DNUPRE - KPROJ=',KPROJ,
33614 & ' COS(THETA) = 1D0 RETURNED'
33616 C-------------------------------- NP ELASTIC SCATTERING----------
33618 IF (EKIN.GT.0.740D0)GOTO 1000
33619 IF (EKIN.LT.0.300D0)THEN
33620 C EKIN .LT. 300 MEV
33623 C 300 MEV < EKIN < 740 MEV
33628 IE=INT(ABS(ENER/0.020D0))
33629 UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
33630 C FORWARD/BACKWARD DECISION
33632 BWFW=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
33633 IF (DT_RNDM(CST).LT.BWFW)THEN
33641 COEF=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
33644 IF(RND.LT.COEF)THEN
33653 IF(VALUE2.GT.0.0)THEN
33654 CST=MAX(R1,R2,R3,R4)
33660 CST=-MAX(R1,R2,R3,R4,R5)
33664 CST=-MAX(R1,R2,R3,R4,R5,R6,R7)
33673 C******** EKIN .GT. 0.74 GEV
33675 1000 ENER=EKIN - 0.66D0
33676 C IE=ABS(ENER/0.02)
33677 IE=INT(ENER/0.02D0)
33680 UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
33682 BWFW=(DCHN(K+1)-DCHN(K))*UNIV + DCHN(K)
33685 IF (RND.GE.BWFW)THEN
33687 IF (DCHNA(K).GT.EMEV) THEN
33688 UNIVE=(EMEV-DCHNA(K-9))/(DCHNA(K)-DCHNA(K-9))
33689 UNIV=DT_RNDM(UNIVE)
33692 P=(DCHNA(II)-DCHNA(II-9))*UNIVE + DCHNA(II-9)
33695 UNIV=DT_RNDM(UNIVE)
33697 GOTO(290,290,290,290,330,340,350,360) I
33706 IF (DCHNB(K).GT.EMEV) THEN
33707 UNIVE=(EMEV-DCHNB(K-12))/(DCHNB(K)-DCHNB(K-12))
33708 UNIV=DT_RNDM(UNIVE)
33711 P=(DCHNB(II)-DCHNB(II-12))*UNIVE + DCHNB(II-12)
33716 GOTO(120,120,140,150,160,160,180,190,200,210,220) I
33723 120 CST=1.0D-2*FLTI-1.0D0
33725 140 CST=2.0D-2*UNIV-0.98D0
33727 150 CST=4.0D-2*UNIV-0.96D0
33729 160 CST=6.0D-2*FLTI-1.16D0
33731 180 CST=8.0D-2*UNIV-0.80D0
33733 190 CST=1.0D-1*UNIV-0.72D0
33735 200 CST=1.2D-1*UNIV-0.62D0
33737 210 CST=2.0D-1*UNIV-0.50D0
33739 220 CST=3.0D-1*(UNIV-1.0D0)
33742 290 CST=1.0D0-2.5d-2*FLTI
33744 330 CST=0.85D0+0.5D-1*UNIV
33746 340 CST=0.70D0+1.5D-1*UNIV
33748 350 CST=0.50D0+2.0D-1*UNIV
33750 360 CST=0.50D0*UNIV
33754 C----------------------------------- PP ELASTIC SCATTERING -------
33759 IF (EKIN.LE.0.500D0) THEN
33761 CST=2.0D0*RND-1.0D0
33764 ELSEIF (EKIN.LT.1.0D0) THEN
33766 IF (PDCI(K).GT.EMEV) THEN
33767 UNIVE=(EMEV-PDCI(K-12))/(PDCI(K)-PDCI(K-12))
33768 UNIV=DT_RNDM(UNIVE)
33772 SUM=SUM + (PDCI(II)-PDCI(II-12))*UNIVE + PDCI(II-12)
33774 IF (UNIV.LT.SUM)THEN
33777 GOTO(55,55,55,60,60,65,65,65,65,70,70) I
33784 IF (PDCH(K).GT.EMEV) THEN
33785 UNIVE=(EMEV-PDCH(K-11))/(PDCH(K)-PDCH(K-11))
33786 UNIV=DT_RNDM(UNIVE)
33790 SUM=SUM + (PDCH(II)-PDCH(II-11))*UNIVE + PDCH(II-11)
33792 IF (UNIV.LT.SUM)THEN
33795 GOTO(50,55,60,60,65,65,65,65,70,70) I
33806 60 CST=0.3D0+0.1D0*FLTI
33808 65 CST=0.6D0+0.04D0*FLTI
33810 70 CST=0.78D0+0.02D0*FLTI
33813 IF (DT_RNDM(CST).GT.0.5D0) CST=-CST
33818 *$ CREATE DT_DHADRI.FOR
33821 *===dhadri=============================================================*
33823 SUBROUTINE DT_DHADRI(N,PLAB,ELAB,CX,CY,CZ,ITTA)
33825 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33828 PARAMETER ( LINP = 10 ,
33832 C-----------------------------
33833 C*** INPUT VARIABLES LIST:
33834 C*** SAMPLING OF HADRON NUCLEON INTERACTION FOR (ABOUT) 0.1 LE PLAB LE 6
33835 C*** GEV/C LABORATORY MOMENTUM REGION
33836 C*** N - PROJECTILE HADRON INDEX
33837 C*** PLAB - LABORATORY MOMENTUM OF N (GEV/C)
33838 C*** ELAB - LABORATORY ENERGY OF N (GEV)
33839 C*** CX,CY,CZ - DIRECTION COSINES OF N IN THE LABORATORY SYSTEM
33840 C*** ITTA - TARGET NUCLEON INDEX
33841 C*** OUTPUT VARIABLES LIST OF PARTICLE CHARACTERISTICS IN /FINLSP/
33842 C IR COUNTS THE NUMBER OF PRODUCED PARTICLES
33843 C*** ITR - PARTICLE INDEX, CXR,CYR,CZR - DIRECTION COSINES (LAB. SYST.)
33844 C*** ELR,PLR LAB. ENERGY AND LAB. MOMENTUM OF THE SAMPLED PARTICLE
33845 C*** RESPECT., UNITS (GEV/C AND GEV)
33846 C----------------------------
33848 COMMON /HNGAMR/ REDU,AMO,AMM(15)
33849 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33850 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33851 & NRK(2,268),NURE(30,2)
33852 * particle properties (BAMJET index convention),
33853 * (dublicate of DTPART for HADRIN)
33854 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33855 & K1H(110),K2H(110)
33856 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
33857 COMMON /HNMETL/ CXS(149),CYS(149),CZS(149),ELS(149),PLS(149),
33859 COMMON /HNDRUN/ RUNTES,EFTES
33860 * particle properties (BAMJET index convention)
33862 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
33863 & IICH(210),IIBAR(210),K1(210),K2(210)
33864 * final state from HADRIN interaction
33865 PARAMETER (MAXFIN=10)
33866 COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
33867 & CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
33869 DIMENSION ITPRF(110)
33872 DATA ITPRF/-1,-1,5*1,-1,-1,1,1,1,-1,-1,-1,-1,6*1,-1,-1,-1,85*1/
33874 IF (N.LE.0.OR.N.GE.111)N=1
33875 IF (ITPRF( N ).GT.0 .OR. ITTA.GT.8) THEN
33878 * + ' FALSE USE OF THE PARTICLE TYPE INDEX: N, ITTA', N, ITTA
33880 *1000 FORMAT (3(5H ****/),A,2I4,3(5H ****/))
33881 * + 45H FALSE USE OF THE PARTICLE TYPE INDEX, N,LUE ,I4,3(5H ****/))
33884 IF (ABS(PLAB-5.0D0).LT.4.99999D0) GO TO 20
33885 C IF(IPRI.GE.1) WRITE (6,1010) PLAB
33887 1010 FORMAT ( ' PROJECTILE HADRON MOMENTUM OUTSIDE OF THE
33888 + ALLOWED REGION, PLAB=',1E15.5)
33891 UMODAT=N*1.11111D0+ITTA*2.19291D0
33892 IF(UMODAT.NE.UMODA) CALL DT_DCALUM(N,ITTA)
33899 IF (LOWP.GT.20) THEN
33900 C WRITE(LOUT,*) ' jump 1'
33904 IF (NNN.EQ.N) GO TO 50
33913 IF(ITTA.GT.1) IRE=NURE(N,2)
33915 C-----------------------------
33916 C*** IE,AMT,ECM,SI DETERMINATION
33917 C----------------------------
33918 CALL DT_DSIGIN(IRE,PLAB,N,IE,AMT ,AMN,ECM,SI,ITTA)
33921 C IF (AMH(1).NE.0.93828D0) IANTH=1
33922 IF (AMH(1).NE.0.9383D0) IANTH=1
33924 IF (IANTH.GE.0) SI=1.0D0
33927 C-----------------------------
33929 C IRE CHARACTERIZES THE REACTION
33930 C IE IS THE ENERGY INDEX
33931 C----------------------------
33932 IF (SI.LT.1.D-6) THEN
33933 C WRITE(LOUT,*) ' jump 2'
33936 IF (N.LE.NSTAB) GO TO 60
33937 RUNTES=RUNTES+1.0D0
33938 IF (RUNTES.LT.20.D0) WRITE(LOUT,1020)N
33939 1020 FORMAT(3H N=,I10,30H THE PROEKTILE IS A RESONANCE )
33940 IF(IBARH(N).EQ.1) N=8
33941 IF(IBARH(N).EQ.-1) N=9
33944 **sr 19.2.97: loop for direct channel suppression
33945 C IF (IMACH.GT.10) THEN
33946 IF (IMACH.GT.1000) THEN
33948 C WRITE(LOUT,*) ' jump 3'
33954 ECMN=(ECM**2+AMN2-AMT2)/(2.0D0*ECM )
33955 IF(ECMN.LE.AMN) ECMN=AMN
33956 PCMN=SQRT(ECMN**2-AMN2)
33959 IF (IANTH.GE.0) ECM=2.1D0
33961 C-----------------------------
33962 C*** RANDOM CHOICE OF REACTION CHANNEL
33963 C----------------------------
33968 C-----------------------------
33969 C*** PLACE REDUCED VERSION
33970 C----------------------------
33972 IDWK=IEII(IRE+1)-IIEI
33976 C-----------------------------
33977 C*** SHRINKAGE TO THE CONSIDERED ENERGY REGION FOR THE USE OF WEIGHTS
33978 C----------------------------
33980 HUMO=2.0D0*UMO(IIEI+IDWK)-UMO(IIEI+IDWK-1)
33981 IF (HUMO.LT.ECM) ECM=HUMO
33983 C-----------------------------
33984 C*** INTERPOLATION PREPARATION
33985 C----------------------------
33991 C-----------------------------
33993 C----------------------------
33998 IWK=IIWK+(IK-1)*IDWK+IE-IIEI
34002 C-----------------------------
34003 C*** TESTVARIABLE WICO/WICOR: IF CHANNEL IK HAS THE SAME WEIGHTS LIKE IK
34004 C GO TO NEXT CHANNEL, BECAUSE WKK((IK))-WKK((IK-1))=0, IK CAN NOT
34006 C----------------------------
34007 IF (PLAB.LT.PLABF(IIEI+2)) WDK=0.0D0
34008 WICO=WOK*1.23459876D0+WDK*1.735218469D0
34009 IF (WICO.EQ.WICOR) GO TO 70
34010 IF (UMO(IIEI+IDWK).LT.HECM) WDK=0.0D0
34013 C-----------------------------
34014 C*** INTERPOLATION IN CHANNEL WEIGHTS
34015 C----------------------------
34016 EKLIM=-THRESH(IIKI+IK)
34017 IELIM=IDT_IEFUND(EKLIM,IRE)
34018 DELIM=UMO(IELIM)+EKLIM
34020 DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
34021 IF (DELIM*DELIM-DETE*DETE) 90,90,80
34026 WKK=WOK-WDK*DEC/(DECC+1.D-9)
34028 C-----------------------------
34030 C----------------------------
34032 IF (VV.GT.WKK) GO TO 70
34034 C***IK IS THE REACTION CHANNEL
34035 C----------------------------
34047 IF (I1001.GT.50) GO TO 60
34049 IF (IT2*AMS.GT.IT2*ECM) GO TO 110
34052 IF (IANTH.GE.0) ECM=ELAB+AMT+0.00001D0
34055 IF (IT2.GT.0) GO TO 120
34056 **sr 19.2.97: supress direct channel for pp-collisions
34057 IF ((N.EQ.1).AND.(ITTA.EQ.1).AND.(IT2.LE.0)) THEN
34059 IF (RR.LE.0.75D0) GOTO 60
34063 C-----------------------------
34064 C INCLUSION OF DIRECT RESONANCES
34065 C RANDOM CHOICE OF DECAY CHANNELS OF THE DIRECT RESONANCE IT1
34066 C------------------------
34079 IF(WW.LT. 0.5D0) GO TO 130
34086 C-----------------------------
34087 C THE FIRST PARTICLE IS DEFINED TO BE THE FORWARD GOING ONE AT SMALL T
34094 IF(IB1.EQ.IBN) GO TO 140
34100 C-----------------------------
34101 C***IT1,IT2 ARE THE CREATED PARTICLES
34102 C***MOMENTA AND DIRECTION COSINA IN THE CM - SYSTEM
34103 C------------------------
34104 CALL DT_DTWOPA(ECM1,ECM2,PCM1,PCM2,COD1,COD2,COF1,COF2,SIF1,SIF2,
34105 *IT1,IT2,ECM,ECMN,PCMN,N,AM1,AM2)
34110 C-----------------------------
34111 C***TRANSFORMATION INTO LAB SYSTEM AND ROTATION
34112 C----------------------------
34113 CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD1,COF1,SIF1,
34114 &PCM1,ECM1,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34118 CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD2,COF2,SIF2,
34119 *PCM2,ECM2,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34122 C-----------------------------
34123 C***TEST STABLE OR UNSTABLE
34124 C----------------------------
34125 IF(ITS(IST).GT.NSTAB) GO TO 160
34128 C-----------------------------
34129 C***IRH IS THE NUMBER OF THE FINAL STABLE PARTICLE
34130 C----------------------------
34131 C* IF (REDU.LT.0.D0) GO TO 1009
34139 IF(IST.GE.1) GO TO 150
34143 C RANDOM CHOICE OF DECAY CHANNELS
34144 C----------------------------
34158 IF (VV.GT.WTI(IIK)) GO TO 180
34160 C IIK IS THE DECAY CHANNEL
34161 C----------------------------
34169 IF (IT2-1.LT.0) GO TO 240
34174 C IF IIK-KIN.LIM.GT.ACTUAL TOTAL CM-ENERGY, DO AGAIN RANDOM IIK-CHOICE
34175 C----------------------------
34176 IF (IECO.LE.10) GO TO 200
34178 IF(IATMPT.GT.3) THEN
34179 C WRITE(LOUT,*) ' jump 4'
34184 IF (I310.GT.50) GO TO 170
34185 IF (AMS.GT.ECO) GO TO 190
34187 C FOR THE DECAY CHANNEL
34188 C IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM IT
34189 C----------------------------
34190 IF (REDU.LT.0.D0) GO TO 30
34193 IF(IT3.EQ.0) GO TO 220
34196 CALL DT_DTHREP(ECO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,SIF1,
34197 *COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
34199 220 CALL DT_DTWOPD(ECO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,
34200 &COD2,COF2,SIF2,AM1,AM2)
34205 IF (REDU.GT.0.D0) GO TO 240
34207 IF (ITWTHC.GT.100) GO TO 30
34208 IF (ITWTH) 220,220,210
34211 IF (IT2-1.LT.0) GO TO 250
34218 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD1,COF1,SIF1,PCM1,ECM1,
34219 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34222 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD2,COF2,SIF2,PCM2,ECM2,
34223 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34224 IF (IT3.LE.0) GO TO 250
34227 CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD3,COF3,SIF3,PCM3,ECM3,
34228 *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34236 C----------------------------
34238 C ZERO CROSS SECTION CASE
34239 C----------------------------
34251 *$ CREATE DT_RUNTT.FOR
34254 *===runtt==============================================================*
34256 BLOCK DATA DT_RUNTT
34258 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34261 COMMON /HNDRUN/ RUNTES,EFTES
34263 DATA RUNTES,EFTES /100.D0,100.D0/
34267 *$ CREATE DT_NONAME.FOR
34270 *===noname=============================================================*
34272 BLOCK DATA DT_NONAME
34274 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34277 * slope parameters for HADRIN interactions
34278 COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
34279 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34281 C DATAS DATAS DATAS DATAS DATAS
34283 DATA IKII/ 0, 15, 41, 67, 82, 93, 110, 133, 148, 159, 172, 183,
34284 & 207, 224, 241, 252, 268 /
34285 DATA IEII/ 0, 21, 46, 71, 92, 109, 126, 143, 160, 173, 186, 199,
34286 & 220, 241, 262, 279, 296 /
34287 DATA IRII/ 0, 315, 965, 1615, 1930, 2117, 2406, 2797, 3052, 3195,
34288 & 3364, 3507, 4011, 4368, 4725, 4912, 5184/
34291 C MASSES FOR THE SLOPE B(M) IN GEV
34292 C SLOPE B(M) FOR AN MESONIC SYSTEM
34293 C SLOPE B(M) FOR A BARYONIC SYSTEM
34296 DATA SM,BBM,BBB/ 0.8D0, 0.85D0, 0.9D0, 0.95D0, 1.D0,
34297 & 1.05D0, 1.1D0, 1.15D0, 1.2D0, 1.25D0,
34298 & 1.3D0, 1.35D0, 1.4D0, 1.45D0, 1.5D0,
34299 & 1.55D0, 1.6D0, 1.65D0, 1.7D0, 1.75D0,
34300 & 1.8D0, 1.85D0, 1.9D0, 1.95D0, 2.D0,
34301 & 15.6D0, 14.95D0, 14.3D0, 13.65D0, 13.D0,
34302 & 12.35D0, 11.7D0, 10.85D0, 10.D0, 9.15D0,
34303 & 8.3D0, 7.8D0, 7.3D0, 7.25D0, 7.2D0,
34304 & 6.95D0, 6.7D0, 6.6D0, 6.5D0, 6.3D0,
34305 & 6.1D0, 5.85D0, 5.6D0, 5.35D0, 5.1D0,
34306 & 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0, 15.D0,
34307 & 14.2D0, 13.4D0, 12.6D0,
34308 & 11.8D0, 11.2D0, 10.6D0, 9.8D0, 9.D0,
34309 & 8.25D0, 7.5D0, 6.25D0, 5.D0, 4.5D0, 5*4.D0 /
34313 *$ CREATE DT_DAMG.FOR
34316 *===damg===============================================================*
34318 DOUBLE PRECISION FUNCTION DT_DAMG(IT)
34320 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34323 * particle properties (BAMJET index convention),
34324 * (dublicate of DTPART for HADRIN)
34325 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34326 & K1H(110),K2H(110)
34328 DIMENSION GASUNI(14)
34330 *-1.D0,-.98D0,-.95D0,-.87D0,-.72D0,-.48D0,
34331 *-.17D0,.17D0,.48D0,.72D0,.87D0,.95D0,.98D0,1.D0/
34332 DATA GAUNO/2.352D0/
34338 IF (IT.LE.0) GO TO 30
34339 IF (IT.LE.NSTAB) GO TO 20
34340 DGAUNI=GAUNO*GAUNON/DBLE(IO-1)
34342 VV=VV*2.0D0-1.0D0+1.D-16
34347 IF (VV.GT.V1) GO TO 10
34348 UNIGA=DGAUNI*(DBLE(I)-2.0D0+(VV-VO+1.D-16)/
34349 & (V1-VO)-(DBLE(IO)-1.0D0)*0.5D0)
34350 DAM=GAH(IT)*UNIGA/GAUNO
34362 *$ CREATE DT_DCALUM.FOR
34365 *===dcalum=============================================================*
34367 SUBROUTINE DT_DCALUM(N,ITTA)
34369 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34372 C*** C.M.S.-ENERGY AND REACTION CHANNEL THRESHOLD CALCULATION
34374 * particle properties (BAMJET index convention),
34375 * (dublicate of DTPART for HADRIN)
34376 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34377 & K1H(110),K2H(110)
34378 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34379 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
34380 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34381 & NRK(2,268),NURE(30,2)
34383 IRE=NURE(N,ITTA/8+1)
34392 ELAB=SQRT(AM12+AM22+2.0D0*SQRT(PLAB2+AM12)*AM2)
34399 IF(NRK(2,IK).GT.0) GO TO 30
34408 IF(IN.GT.0)AMS=AMS+AMH(IN)
34410 IF(IN.GT.0) AMS=AMS+AMH(IN)
34411 IF (AMS.LT.AMSS) AMSS=AMS
34413 IF(UMOO.LT.AMSS) UMOO=AMSS
34419 *$ CREATE DT_DCHANH.FOR
34422 *===dchanh=============================================================*
34424 SUBROUTINE DT_DCHANH
34426 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34429 PARAMETER ( LINP = 10 ,
34432 * particle properties (BAMJET index convention),
34433 * (dublicate of DTPART for HADRIN)
34434 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34435 & K1H(110),K2H(110)
34436 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
34437 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34438 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34439 & NRK(2,268),NURE(30,2)
34441 DIMENSION HWT(460),HWK(40),SI(5184)
34442 EQUIVALENCE (WK(1),SI(1))
34443 C--------------------
34444 C*** USE ONLY FOR DATAPREPARATION OF PURE HADRIN
34445 C*** CALCULATION OF REACTION- AND DECAY-CHANNEL-WEIGHTS,
34446 C*** THRESHOLD ENERGIES+MOMENTA OF REACTION CHNLS.
34447 C*** CHANGE OF WT- AND WK-INPUTDATA INTO WEIGHTS FOR THE M.-C.-PROCEDURE
34448 C*** (ADDED ONE TO EACH OTHER FOR CORRESPONDING CHANNELS)
34449 C--------------------------
34453 IEE=IEII(IRE+1)-IEII(IRE)
34454 IKE=IKII(IRE+1)-IKII(IRE)
34457 * modifications to suppress elestic scattering 24/07/91
34462 IWK=IWKO+IEE*(IK-1)+IE
34463 IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
34464 SIS=SIS+SI(IWK)*SINORC
34468 IF (SIS.GE.1.D-12) GO TO 20
34474 IWK=IWKO+IEE*(IK-1)+IE
34475 IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
34476 SIO=SIO+SI(IWK)*SINORC/SIS
34480 IWK=IWKO+IEE*(IK-1)+IE
34485 INRK1=NRK(1,IIKI+IK)
34486 IF (INRK1.GT.0) AM111=AMH(INRK1)
34488 INRK2=NRK(2,IIKI+IK)
34489 IF (INRK2.GT.0) AM222=AMH(INRK2)
34490 THRESH(IIKI+IK)=AM111 +AM222
34491 IF (INRK2-1.GE.0) GO TO 60
34495 DO 50 INRK1=INRKK,INRKO
34496 INZK1=NZKI(INRK1,1)
34497 INZK2=NZKI(INRK1,2)
34498 INZK3=NZKI(INRK1,3)
34499 IF (INZK1.LE.0.OR.INZK1.GT.110) GO TO 50
34500 IF (INZK2.LE.0.OR.INZK2.GT.110) GO TO 50
34501 IF (INZK3.LE.0.OR.INZK3.GT.110) GO TO 50
34502 C WRITE (6,310)INRK1,INZK1,INZK2,INZK3
34504 AMS=AMH(INZK1)+AMH(INZK2)
34505 IF (INZK3-1.GE.0) AMS=AMS+AMH(INZK3)
34506 IF (AMSS.GT.AMS) AMSS=AMS
34509 IF (AMS.LT.UMO(IEO)) AMS=UMO(IEO)
34510 THRESH(IIKI+IK)=AMS
34521 IF (IK2.GT.460)IK2=460
34528 IF (ABS(HV-1.0D0).GT.1.D-4) WRITE(LOUT,1010)I,JI,HV
34529 1010 FORMAT (35H ERROR IN HWT, FALSE USE OF CHANWH ,2I6,F10.2)
34536 *$ CREATE DT_DHADDE.FOR
34539 *===dhadde=============================================================*
34541 SUBROUTINE DT_DHADDE
34543 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34546 * particle properties (BAMJET index convention)
34548 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
34549 & IICH(210),IIBAR(210),K1(210),K2(210)
34550 * HADRIN: decay channel information
34551 PARAMETER (IDMAX9=602)
34553 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
34554 * particle properties (BAMJET index convention),
34555 * (dublicate of DTPART for HADRIN)
34556 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34557 & K1H(110),K2H(110)
34558 COMMON /HNSPLI/ WTI(460),NZKI(460,3)
34559 * decay channel information for HADRIN
34560 COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
34561 & K1Z(16),K2Z(16),WTZ(153),II22,
34562 & NZK1(153),NZK2(153),NZK3(153)
34568 IF (IRETUR.GT.1) RETURN
34574 IBARH(I) = IIBAR(I)
34589 NZKI(I,1) = NZK(I,1)
34590 NZKI(I,2) = NZK(I,2)
34591 NZKI(I,3) = NZK(I,3)
34606 NZKI(L,3) = NZK3(I)
34607 NZKI(L,2) = NZK2(I)
34608 NZKI(L,1) = NZK1(I)
34613 *$ CREATE IDT_IEFUND.FOR
34616 *===iefund=============================================================*
34618 INTEGER FUNCTION IDT_IEFUND(PL,IRE)
34620 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34623 C*****IEFUN CALCULATES A MOMENTUM INDEX
34625 PARAMETER ( LINP = 10 ,
34628 COMMON /HNDRUN/ RUNTES,EFTES
34629 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34630 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34631 & NRK(2,268),NURE(30,2)
34636 IF (PL.LT.0.) GO TO 30
34639 IF (PL.LE.PLABF(I)) GO TO 60
34642 IF ( EFTES.GT.40.D0) GO TO 20
34644 WRITE(LOUT,1000)PL,J
34650 IF (-PL.LE.UMO(I)) GO TO 60
34653 IF ( EFTES.GT.40.D0) GO TO 50
34655 WRITE(LOUT,1000)PL,I
34661 1000 FORMAT(14H PLAB OR -ECM=,E12.4,27H IS OUT OF CONSIDERED RANGE ,
34665 *$ CREATE DT_DSIGIN.FOR
34668 *===dsigin=============================================================*
34670 SUBROUTINE DT_DSIGIN(IRE ,PLAB,N,IE ,AMT ,AMN,ECM ,SI ,ITAR)
34672 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34675 * particle properties (BAMJET index convention),
34676 * (dublicate of DTPART for HADRIN)
34677 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34678 & K1H(110),K2H(110)
34679 COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34680 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34681 & NRK(2,268),NURE(30,2)
34683 IE=IDT_IEFUND(PLAB,IRE)
34684 IF (IE.LE.IEII(IRE)) IE=IE+1
34689 ECM=SQRT(AMN2+AMT2+2.0D0*AMT*SQRT(AMN2+PLAB**2))
34690 C*** INTERPOLATION PREPARATION
34696 EKLIM=-THRESH(IIKI)
34699 IF (ECM.GT.ECMO) WDK=0.0D0
34700 C*** INTERPOLATION IN CHANNEL WEIGHTS
34701 IELIM=IDT_IEFUND(EKLIM,IRE)
34702 DELIM=UMO(IELIM)+EKLIM
34704 DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
34705 IF (DELIM*DELIM-DETE*DETE) 20,20,10
34710 WKK=WOK-WDK*DEC/(DECC+1.D-9)
34711 IF (WKK.LT.0.0D0) WKK=0.0D0
34713 IF (-EKLIM.GT.ECM) SI=1.D-14
34717 *$ CREATE DT_DTCHOI.FOR
34720 *===dtchoi=============================================================*
34722 SUBROUTINE DT_DTCHOI(T,P,PP,E,EE,I,II,N,AM1,AM2)
34724 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34727 C ****************************
34728 C TCHOIC CALCULATES A RANDOM VALUE
34729 C FOR THE FOUR-MOMENTUM-TRANSFER T
34730 C ****************************
34732 * particle properties (BAMJET index convention),
34733 * (dublicate of DTPART for HADRIN)
34734 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34735 & K1H(110),K2H(110)
34736 * slope parameters for HADRIN interactions
34737 COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
34741 IF (I.GT.30.AND.II.GT.30) GO TO 20
34744 IF (I.LE.30) GO TO 10
34752 IF (AMA.LE.AMB) GO TO 30
34758 K=INT((AMA-0.75D0)/0.05D0)
34760 IF (K-26.GE.0) K=25
34767 TMIN=-2.0D0*(E*EE-P*PP)+AMH(N)**2+AM1 **2
34768 TMAX=-2.0D0*(E*EE+P*PP)+AMH(N)**2+AM1 **2
34771 C IF (VB.LT.0.2D0) BM=BM*0.1
34778 IF (ABS(TMA).GT.120.D0) GO TO 70
34781 AN=(1.0D0/BM)*(EXP(TMI)-ETMA)
34782 C*** RANDOM CHOICE OF THE T - VALUE
34784 T=(1.0D0/BM)*LOG(ETMA+R*AN*BM)
34788 *$ CREATE DT_DTWOPA.FOR
34791 *===dtwopa=============================================================*
34793 SUBROUTINE DT_DTWOPA(E1,E2,P1,P2,COD1,COD2,COF1,COF2,SIF1,SIF2,
34794 &IT1,IT2,UMOO,ECM,P,N,AM1,AM2)
34796 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34799 C ******************************************************
34800 C QUASI TWO PARTICLE PRODUCTION
34801 C TWOPAR CALCULATES THE ENERGYS AND THE MOMENTA
34802 C FOR THE CREATED PARTICLES OR RESONANCES IT1 AND IT2
34803 C IN THE CM - SYSTEM
34804 C COD1,COD2,COF1,COF2,SIF1,SIF2 ARE THE ANGLES FOR
34805 C SPHERICAL COORDINATES
34806 C ******************************************************
34808 * particle properties (BAMJET index convention),
34809 * (dublicate of DTPART for HADRIN)
34810 COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34811 & K1H(110),K2H(110)
34816 E1=((UMOO-AMB)*(UMOO+AMB) + AMA2)/(2.0D0*UMOO)
34818 IF (E1.LT.AMA*1.00001D0) E1=AMA*1.00001D0
34819 AMTE=(E1-AMA)*(E1+AMA)
34823 C / P2 / = / P1 / BUT OPPOSITE DIRECTIONS
34824 C DETERMINATION OF THE ANGLES
34825 C COS(THETA1)=COD1 COS(THETA2)=COD2
34826 C SIN(PHI1)=SIF1 SIN(PHI2)=SIF2
34827 C COS(PHI1)=COF1 COS(PHI2)=COF2
34828 C PHI IS UNIFORMLY DISTRIBUTED IN ( 0,2*PI )
34829 CALL DT_DSFECF(COF1,SIF1)
34832 C CALCULATION OF THETA1
34833 CALL DT_DTCHOI(TR,P,P1,ECM,E1,IT1,IT2,N,AM1,AM2)
34834 COD1=(TR-AMA2-AMH(N)*AMH(N)+2.0D0*ECM*E1)/(2.0D0*P*P1+1.D-18)
34835 IF (COD1.GT.0.9999999D0) COD1=0.9999999D0
34840 *$ CREATE DT_ZK.FOR
34843 *===zk=================================================================*
34847 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34850 * decay channel information for HADRIN
34851 COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
34852 & K1Z(16),K2Z(16),WTZ(153),II22,
34853 & NZK1(153),NZK2(153),NZK3(153)
34854 * decay channel information for HADRIN
34855 CHARACTER*8 ANAMZ,ZKNAM4,ZKNAM5,ZKNAM6
34856 COMMON /HNADDN/ ANAMZ(16),ZKNAM4(9),ZKNAM5(90),ZKNAM6(54)
34858 * Particle masses in GeV *
34859 DATA AMZ/ 3*2.2D0, 0.9576D0, 3*1.887D0, 2.4D0, 2.03D0, 2*1.44D0,
34861 * Resonance width Gamma in GeV *
34862 DATA GAZ/ 3*.2D0, .1D0, 4*.2D0, .18D0, 2*.2D0, 2*.15D0, 3*0.D0 /
34863 * Mean life time in seconds *
34864 DATA TAUZ / 16*0.D0 /
34865 * Charge of particles and resonances *
34866 DATA ICHZ/ 0, 1, 3*0, 1, -1, 0, 1, -1, 0, 0, 1 , 3*0 /
34867 * Baryonic charge *
34868 DATA IBARZ/ 2, 7*0, 1, -1, -1, 1, 1, 3*0 /
34869 * First number of decay channels used for resonances *
34870 * and decaying particles *
34871 DATA K1Z/ 308,310,313,317,322,365,393,421,425,434,440,446,449,
34873 * Last number of decay channels used for resonances *
34874 * and decaying particles *
34875 DATA K2Z/ 309,312,316,321,364,392,420,424,433,439,445,448,451,
34877 * Weight of decay channel *
34878 DATA WTZ/ .17D0, .83D0, 2*.33D0, .34D0, .17D0, 2*.33D0, .17D0,
34879 & .01D0, .13D0, .36D0, .27D0, .23D0, .0014D0, .0029D0, .0014D0,
34880 & .0029D0, 4*.0007D0, .0517D0, .0718D0, .0144D0, .0431D0, .0359D0,
34881 & .0718D0, .0014D0, .0273D0, .0014D0, .0431D0, 2*.0129D0, .0259D0,
34882 & .0517D0, .0359D0, .0014D0, 2*.0144D0, .0129D0, .0014D0, .0259D0,
34883 & .0359D0, .0072D0, .0474D0, .0948D0, .0259D0, .0072D0, .0144D0,
34884 & .0287D0, .0431D0, .0144D0, .0287D0, .0474D0, .0144D0, .0075D0,
34885 & .0057D0, .0019D0, .0038D0, .0095D0, 2*.0014D0, .0191D0, .0572D0,
34886 & .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0, .0686D0,.0172D0,
34887 & .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, .0190D0,
34888 & .0057D0, .0019D0, .0038D0, .0095D0, .0014D0, .0014D0, .0191D0,
34889 & .0572D0, .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0,.0686D0,
34890 & .0172D0, .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0,
34891 & .0190D0, 4*.25D0, 2*.2D0, .12D0, .1D0, .07D0, .07D0, .14D0,
34892 & 2*.05D0, .0D0, .3334D0, .2083D0, 2*.125D0, .2083D0, .0D0, .125D0,
34893 & .2083D0, .3334D0, .2083D0, .125D0, .3D0, .05D0, .65D0, .3D0,
34894 & .05D0, .65D0, 9*1.D0 /
34895 * Particle numbers in decay channel *
34896 DATA NZK1/ 8, 1, 2, 9, 1, 2, 9, 2, 9, 7, 13, 31, 15, 24, 23, 13,
34897 & 23, 13, 2*23, 14, 13, 23, 31, 98, 2*33, 32, 23, 14, 13, 35, 2*23,
34898 & 14, 13, 33, 23, 98, 31, 23, 14, 13, 35, 2*33, 32, 23, 35, 33, 32,
34899 & 98, 5*35, 4*13, 23, 13, 98, 32, 33, 23, 13, 23, 13, 14, 13, 32,
34900 & 13, 98, 23, 13, 2*32, 13, 33, 32, 98, 2*35, 4*14, 23, 14, 98,
34901 & 2*34, 23, 14, 23, 2*14, 13, 34, 14, 98, 23, 14, 2*34, 14, 33, 32,
34902 & 98, 2*35, 104, 61, 105, 62, 1, 17, 21, 17, 22, 2*21, 22, 21, 2,
34903 & 67, 68, 69, 2, 2*9, 68, 69, 70, 2, 9, 2*24, 15, 2*25, 16, 9*0/
34904 DATA NZK2/ 2*8, 1, 8, 9, 2*8, 2*1, 7, 14, 13, 16, 25, 23, 14, 23,
34905 & 14, 31, 33, 32, 34, 35, 31, 23, 31, 33, 34, 31, 32, 34, 31, 33,
34906 & 32, 2*33, 35, 31, 33, 31, 33, 32, 34, 35, 31, 33, 34, 35, 31,
34907 & 4*33, 32, 3*35, 2*23, 13, 31, 32, 33, 13, 31, 32, 2*31, 32, 33,
34908 & 32, 32, 35, 31, 2*32, 33, 31, 33, 35, 33, 3*32, 35, 2*23, 14,
34909 & 31, 34, 33, 14, 31, 33, 2*31, 34, 32, 33, 34, 35, 31, 2*34, 33,
34910 & 31, 33, 35, 33, 2*34, 33, 35, 1, 2, 8, 9, 25, 13, 35, 2*32, 33,
34911 & 31, 13, 23, 31, 13, 23, 14, 79, 80, 31, 13, 23, 14, 78, 79, 8,
34912 & 1, 8, 1, 8, 1, 9*0 /
34913 DATA NZK3/ 23, 14, 2*13, 23, 13, 2*23, 14, 0, 7, 14, 4*0, 2*23,
34914 & 10*0, 33, 2*31, 0, 33, 34, 32, 34, 0, 35, 0, 31, 3*35, 0, 3*31,
34915 & 35, 31, 33, 34, 31, 33, 34, 31, 33, 35, 0, 23, 14, 6*0, 32, 3*33,
34916 & 32, 34, 0, 35, 0, 2*35, 2*31, 35, 32, 34, 31, 33, 32, 0, 23, 13,
34917 & 6*0, 34, 2*33, 34, 33, 34, 0, 35, 0,2*35, 2*31, 35, 2*34, 31,
34918 & 2*34, 25*0, 23, 2*14, 23, 2*13, 9*0 /
34920 DATA ANAMZ / 'NNPI', 'ANPPI', 'ANNPI', ' ETS ',' PAP ',' PAN ',
34921 & 'APN', 'DEO ', 'S+2030', 'AN*-14', 'AN*014','KONPI ','AKOPPI',
34923 * Name of decay channel *
34924 DATA ZKNAM4/'NNPI0','PNPI-','APPPI+','ANNPI+','ANPPI0','APNPI+',
34925 & 'ANNPI0','APPPI0','ANPPI-'/
34926 DATA ZKNAM5/' GAGA ','P+P-GA','ETP+P-','K+K- ','K0AK0 ',
34927 & ' POPO ',' P+P- ','POPOPO','P+P0P-','P0ET ','&0R0 ','P-R+ ',
34928 & 'P+R- ','POOM ',' ETET ','ETSP0 ','R0ET ',' R0R0 ','R+R- ',
34929 & 'P0ETR0','P-ETR+','P+ETR-',' OMET ','P0R0R0','P0R+R-','P-R+R0',
34930 & 'P+R-R0','R0OM ','P0ETOM','ETSR0 ','ETETET','P0R0OM','P-R+OM',
34931 & 'P+R-OM','OMOM ','R0ETET','R0R0ET','R+R-ET','P0OMOM','OMETET',
34932 & 'R0R0R0','R+R0R-','ETSRET','OMR0R0','OMR+R-','OMOMET','OMOMR0',
34934 & ' P+PO ','P+POPO','P+P+P-','P+ET ','P0R+ ','P+R0 ','ETSP+ ',
34935 & 'R+ET ',' R0R+ ','POETR+','P+ETR0','POR+R-','P+R0R0','P-R+R+',
34936 & 'P+R-R+','R+OM ','P+ETOM','ETSR+ ','POR+OM','P+R0OM','R+ETET',
34937 & 'R+R0ET','P+OMOM','R0R0R+','R+R+R-','ETSR+E','OMR+R0','OMOMR+',
34938 & 'P-PO ','P-POPO','P-P-P+','P-ET ','POR- ','P-R0 ','ETSP- ',
34939 & 'R-ET ','R-R0 ','POETR-','P-ETR0','POR-R0','P-R+R-','P-R0R0'/
34940 DATA ZKNAM6/'P+R-R-','R-OM ','P-ETOM','ETSR- ','POR-OM','P-R0OM',
34941 & 'R-ETET','R-R0ET','P-OMOM','R0R0R-','R+R-R-','ETSR-E','OMR0R-',
34942 & 'OMOMR-', 'PAN-14','APN+14','NAN014','ANN014','PAKO ','LPI+ ',
34943 & 'SI+OM','LAMRO+','SI0RO+','SI+RO0','SI+ETA','SI0PI+','SI+PI0',
34944 & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHOO','ANRHO-','ANETA ',
34945 & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0',
34946 & 'KONPIO','KOPPI-','K+NPI-','AKOPPO','AKONP+','K-PPI+',
34951 *$ CREATE DT_BLKD43.FOR
34954 *===blkd43=============================================================*
34956 BLOCK DATA DT_BLKD43
34958 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34962 *=== reac =============================================================*
34964 *----------------------------------------------------------------------*
34966 * Created on 10 december 1991 by Alfredo Ferrari & Paola Sala *
34969 * Last change on 10-dec-91 by Alfredo Ferrari *
34971 * This is the original common reac of Hadrin *
34973 *----------------------------------------------------------------------*
34975 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34976 & NRK(2,268),NURE(30,2)
34979 & UMOPI(92), UMOKC(68), UMOP(39), UMON(63), UMOK0(34),
34980 & PLAPI(92), PLAKC(68), PLAP(39), PLAN(63), PLAK0(34),
34981 & SPIKP1(315), SPIKPU(278), SPIKPV(372),
34982 & SPIKPW(278), SPIKPX(372), SPIKP4(315),
34983 & SPIKP5(187), SPIKP6(289),
34984 & SKMPEL(102), SPIKP7(289), SKMNEL(68), SPIKP8(187),
34985 & SPIKP9(143), SPIKP0(169), SPKPV(143),
34986 & SAPPEL(105), SPIKPE(399), SAPNEL(84), SPIKPZ(273),
34987 & SANPEL(84) , SPIKPF(273),
34988 & SPKP15(187), SPKP16(272),
34989 & NRKPI(164), NRKKC(132), NRKP(70), NRKN(116), NRKK0(54),
34992 DIMENSION NRKLIN(532)
34993 EQUIVALENCE (NRK(1,1), NRKLIN(1))
34994 EQUIVALENCE ( UMO( 1), UMOPI(1)), ( UMO( 93), UMOKC(1))
34995 EQUIVALENCE ( UMO(161), UMOP(1)), ( UMO(200), UMON(1))
34996 EQUIVALENCE ( UMO(263), UMOK0(1))
34997 EQUIVALENCE ( PLABF( 1), PLAPI(1)), ( PLABF( 93), PLAKC(1))
34998 EQUIVALENCE ( PLABF(161), PLAP(1)), ( PLABF(200), PLAN(1))
34999 EQUIVALENCE ( PLABF(263), PLAK0(1))
35000 EQUIVALENCE ( WK( 1), SPIKP1(1)), ( WK( 316), SPIKPU(1))
35001 EQUIVALENCE ( WK( 594), SPIKPV(1)), ( WK( 966), SPIKPW(1))
35002 EQUIVALENCE ( WK(1244), SPIKPX(1)), ( WK(1616), SPIKP4(1))
35003 EQUIVALENCE ( WK(1931), SPIKP5(1)), ( WK(2118), SPIKP6(1))
35004 EQUIVALENCE ( WK(2407), SKMPEL(1)), ( WK(2509), SPIKP7(1))
35005 EQUIVALENCE ( WK(2798), SKMNEL(1)), ( WK(2866), SPIKP8(1))
35006 EQUIVALENCE ( WK(3053), SPIKP9(1)), ( WK(3196), SPIKP0(1))
35007 EQUIVALENCE ( WK(3365), SPKPV(1)), ( WK(3508), SAPPEL(1))
35008 EQUIVALENCE ( WK(3613), SPIKPE(1)), ( WK(4012), SAPNEL(1))
35009 EQUIVALENCE ( WK(4096), SPIKPZ(1)), ( WK(4369), SANPEL(1))
35010 EQUIVALENCE ( WK(4453), SPIKPF(1)), ( WK(4726), SPKP15(1))
35011 EQUIVALENCE ( WK(4913), SPKP16(1))
35012 EQUIVALENCE (NRK(1,1), NRKLIN(1))
35013 EQUIVALENCE (NRKLIN( 1), NRKPI(1)), (NRKLIN( 165), NRKKC(1))
35014 EQUIVALENCE (NRKLIN( 297), NRKP(1)), (NRKLIN( 367), NRKN(1))
35015 EQUIVALENCE (NRKLIN( 483), NRKK0(1))
35016 EQUIVALENCE (NURE(1,1), NURELN(1))
35020 DATA PLAPI / 0.D0, .3D0, .5D0, .6D0, .7D0, .8D0, .9D0, .95D0,1.D0,
35021 & 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0,
35022 & 3.D0, 3.5D0, 4.D0, 0.D0, .285D0, .4D0, .45D0, .5D0, .6D0, .7D0,
35023 & .75D0, .8D0, .85D0, .9D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0,
35024 & 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0,
35025 & .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, .75D0, .8D0, .85D0, .9D0,
35026 & 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0,
35027 & 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, .3D0, .5D0, .6D0, .7D0,
35028 & .8D0, .9D0, .95D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0,
35029 & 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0 /
35031 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35032 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35033 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
35034 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35035 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35036 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
35037 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35038 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35039 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
35040 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35041 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35042 & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
35044 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35045 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35046 & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
35047 & 0.D0, .58D0, .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35048 & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35049 & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
35052 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35053 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35054 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35055 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35056 & 0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35057 & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
35058 * app apn anp ann *
35060 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
35061 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35062 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35063 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
35064 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35065 & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35066 & 0.D0, 1.D-3, .1D0, .2D0, .3D0, .4D0, .5D0, .6D0,
35067 & .74D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35068 & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
35069 DATA SIIN / 296*0.D0 /
35070 DATA UMOPI/ 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
35071 & 1.557D0,1.615D0,1.6435D0,
35072 & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
35073 & 2.286D0,2.366D0,2.482D0,2.56D0,
35075 & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
35076 & 1.496D0,1.527D0,1.557D0,
35077 & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
35078 & 2.071D0,2.159D0,2.286D0,2.366D0,
35079 & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
35080 & 1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
35081 & 1.496D0,1.527D0,1.557D0,
35082 & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
35083 & 2.071D0,2.159D0,2.286D0,2.366D0,
35084 & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
35085 & 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
35086 & 1.557D0,1.615D0,1.6435D0,
35087 & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
35088 & 2.286D0,2.366D0,2.482D0,2.56D0,
35090 DATA UMOKC/ 1.44D0,
35091 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35092 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35094 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35095 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35097 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35098 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35100 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35101 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35103 DATA UMOK0/ 1.44D0,
35104 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35105 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35107 & 1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35108 & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35112 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35113 & 3.D0,3.1D0,3.2D0,
35114 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35115 & 3.D0,3.1D0,3.2D0,
35116 & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35117 & 3.D0,3.1D0,3.2D0/
35118 * app apn anp ann *
35120 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
35121 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35122 & 3.D0,3.1D0,3.2D0,
35123 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
35124 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35125 & 3.D0,3.1D0,3.2D0,
35126 & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
35127 & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35128 & 3.D0,3.1D0,3.2D0/
35129 **** reaction channel state particles *
35130 DATA NRKPI / 13, 1, 15, 21, 81, 0, 13, 54, 23, 53, 13, 63, 13, 58,
35131 & 23, 57, 13, 65, 1, 32, 53, 31, 54, 32, 53, 33, 53, 35, 63, 32,
35132 & 13, 8, 23, 1, 17, 15, 21, 24, 22, 15, 82, 0, 61, 0, 13, 55, 23,
35133 & 54, 14, 53, 13, 64, 23, 63, 13, 59, 23, 58, 14, 57, 13, 66, 23,
35134 & 65, 1, 31, 8, 32, 1, 33, 1, 35, 54, 31, 55, 32, 54, 33, 53, 34,
35135 & 54, 35, 14, 1, 23, 8, 17, 24, 20, 15, 22, 24, 83, 0, 62, 0, 14,
35136 & 54, 23, 55, 13, 56, 14, 63, 23, 64, 14, 58, 23, 59, 13, 60, 14,
35137 & 65, 23, 66, 8, 31, 1, 34, 8, 33, 8, 35, 55, 31, 54, 34, 55, 33,
35138 & 56, 32, 55, 35, 14, 8, 24, 20, 84, 0, 14, 55, 23, 56, 14, 64, 14,
35139 & 59, 23, 60, 14, 66, 8, 34, 56, 31, 55, 34, 56, 33, 56, 35, 64,34/
35140 DATA NRKKC/ 15, 1, 89, 0, 24, 53, 15, 54, 1, 36, 1, 40, 1, 44, 36,
35141 & 63, 15, 63, 45, 53, 44, 54, 15, 8, 24, 1, 91, 0, 24, 54, 15, 55,
35142 & 8, 36, 1, 37, 8, 40, 1, 41, 8, 44, 1, 45, 36, 64, 37, 63, 15, 64,
35143 & 24, 63, 45, 54, 44, 55, 16, 1, 25, 8, 17, 23, 21, 14, 20,
35144 & 13, 22, 23, 90, 0, 38, 1, 39, 8, 16, 54, 25, 55, 1, 42, 8, 43,
35145 & 16, 63, 25, 64, 39, 64, 38, 63, 46, 54, 47, 55, 8, 47, 1, 46, 52,
35146 & 0, 51, 0, 16, 8, 17, 14, 20, 23, 22, 14, 92, 0, 8, 38, 16, 55,
35147 & 25, 56, 8, 42, 16, 64, 38, 64, 46, 55, 47, 56, 8, 46, 94, 0 /
35149 * k0 p k0 n ak0 p ak/ n *
35151 DATA NRKK0 / 24, 8, 106, 0, 15, 56, 24, 55, 37, 8, 41, 8, 45, 8,
35152 & 37, 64, 24, 64, 44, 56, 45, 55, 25, 1, 17, 13, 22, 13, 21, 23,
35153 & 107, 0, 39, 1, 25, 54, 16, 53, 43, 1, 25, 63, 39, 63, 47, 54, 46,
35154 & 53, 47, 1, 103, 0, 93, 0/
35156 DATA NRKP / 1, 1, 85, 0, 8, 53, 1, 54, 1, 63, 8, 57, 1, 58, 2*54,
35157 & 53, 55, 63, 54, 64, 53, 1, 8, 86, 0, 8, 54, 1, 55, 8, 63, 1, 64,
35158 & 8, 58, 1, 59, 64, 54, 63, 55, 54, 55, 53, 56, 77, 0, 2*8, 95, 0,
35159 & 8, 55, 1, 56, 8, 64, 8, 59, 1, 60, 2*55, 54, 56, 64, 55, 63, 56 /
35160 * app apn anp ann *
35161 DATA NRKN/ 1, 2, 17, 18, 15, 16, 8, 9, 13, 14, 99, 0, 87, 0, 1,
35162 & 68, 8, 69, 2, 54, 9, 55, 102, 0, 2, 63, 9, 64, 1, 75, 8, 76, 53,
35163 & 67, 54, 68, 55, 69, 56, 70, 63, 68, 64, 69, 75, 54, 76, 55, 2, 8,
35164 & 18, 20, 16, 24, 14, 23, 101, 0, 88, 0, 2, 55, 9, 56, 1, 67, 8,
35165 & 68, 2, 64, 8, 75, 2, 59, 8, 72, 68, 55, 67, 54, 69, 56, 1, 9, 18,
35166 & 21, 15, 25, 13, 23, 100, 0, 96, 0, 2, 53, 9, 54, 1, 69, 8, 70, 1,
35167 & 76, 9, 63, 1, 73, 9, 58, 55, 70, 53, 68, 54, 69 /
35168 **** channel cross section *
35169 DATA SPIKP1/ 0.D0, 300.D0, 40.D0, 20.D0, 13.D0,8.5D0,8.D0, 9.5D0,
35170 & 12.D0,14.D0,15.5D0,20.D0,17.D0,13.D0,10.D0,9.D0,8.5D0,8.D0,7.8D0,
35171 & 7.3D0, 6.7D0, 9*0.D0,.23D0,.35D0,.7D0,.52D0,.4D0,.3D0,.2D0,.15D0,
35172 & .13D0, .11D0, .09D0, .07D0, 0.D0, .033D0,.8D0,1.35D0,1.35D0,.5D0,
35173 & 15*0.D0, 3*0.D0,.00D0,0.80D0,2.2D0,3.6D0,4.6D0,4.7D0,3.5D0,2.4D0,
35174 &1.8D0,1.4D0,.75D0,.47D0,.25D0,.13D0,.08D0,6*0.D0,0.D0,1.2D0,3.3D0,
35175 & 5.4D0,6.9D0,7.3D0,5.3D0,3.6D0,2.7D0,2.2D0,1.1D0,.73D0,.4D0,.22D0,
35176 & .12D0,9*0.D0,.0D0,0.D0,2.0D0,4.4D0,6.8D0,9.9D0,7.9D0,6.0D0,3.8D0,
35177 &2.5D0,2.D0,1.4D0,1.D0,.6D0,.35D0,10*0.D0,.25D0,.55D0,.75D0,1.25D0,
35178 & 1.9D0,2.D0,1.8D0,1.5D0,1.25D0,1.D0,.8D0,6*0.D0,4*0.D0,.4D0,.85D0,
35179 & 1.1D0, 1.85D0, 2.8D0, 3.D0,2.7D0,2.2D0,1.85D0,1.5D0,1.2D0,6*0.D0,
35180 & 6*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, 5.6D0,
35181 & 5.2D0, 6*0.D0, 2*0.D0, .0D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0,
35182 & 2.75D0, 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 6*0.D0, 3*0.D0,
35183 & .0D0, .45D0, 1.4D0, 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0,
35184 & 8*0.D0, 5*0.D0, .0D0, .0D0, .6D0, .8D0, .95D0, .8D0, .7D0, .6D0,
35185 & .5D0, .4D0, 6*0.D0, 5*0.D0, .0D0, .00D0, .85D0, 1.2D0, 1.4D0,
35186 & 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 6*0.D0, 5*0.D0, .0D0, .00D0,
35187 & 1.D0, 1.5D0, 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 6*0.D0,
35188 & 10*0.D0, .5D0, 2.0D0, 3.3D0, 5.4D0, 7.D0 /
35190 DATA SPIKPU/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 20.D0,
35191 & 20.D0, 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
35192 & 10.D0, 10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
35193 & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
35194 & 4.2D0, 7.5D0, 3.4D0, 2.5D0, 2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0,
35195 & .6D0, .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0,
35196 & .48D0, .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0,
35197 & .065D0, .05D0, .04D0, 12*0.D0, .2D0, .25D0, .25D0, .2D0, .1D0,
35198 & .08D0, .06D0, .045D0, .03D0, .02D0, .01D0, .005D0, .003D0,
35199 & 12*0.D0, .3D0, .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0,
35200 & .09D0, .08D0, .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0,
35201 & 3.1D0, 4.5D0, 2.D0, 18*0.D0, 3*.0D0, 0.D0, 0.D0, 4.0D0, 11.D0,
35202 & 11.4D0, 10.3D0, 7.5D0, 6.8D0, 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0,
35203 & .35D0, 13*0.D0, .1D0, .34D0, .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0,
35204 & 2.3D0, 1.6D0, .95D0, .45D0, .28D0, .15D0, 10*0.D0, 2*0.D0, .17D0,
35205 & .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0, 6.2D0, 4.4D0, 3.D0, 1.8D0,
35206 & .9D0, .53D0, .28D0, 10*0.D0, 2*0.D0, .25D0, .82D0,
35207 & 1.3D0, 1.9D0, 2.8D0, 5.5D0 , 8.D0, 5.7D0, 3.9D0, 2.35D0, 1.15D0,
35208 & .69D0, .37D0, 10*0.D0, 7*0.D0, .0D0, .34D0, 1.5D0, 3.47D0,
35209 & 5.87D0, 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
35211 DATA SPIKPV/ 7*0.D0, .00D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
35212 & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 6*0.D0, 10*0.D0, .2D0,
35213 & .6D0, .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0,
35214 & 1.D0, .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0,
35215 & 3.5D0, 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0,
35216 & .31D0, .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0,
35217 & .23D0, 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0,
35218 & 5.D0, 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0,
35219 & 2.5D0, 3*0.D0, 3*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0,
35220 & 1.5D0, 1.1D0, .8D0, .7D0, .55D0, .3D0, 10*0.D0, 9*0.D0, .1D0,
35221 & .4D0, 1.D0, 1.4D0, 2.2D0, 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0,
35222 & .8D0, .6D0, .4D0, 12*0.D0, .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0,
35223 & 3.8D0, 3.3D0, 2.45D0, 2.05D0, 1.65D0, 1.2D0, .9D0, .6D0, 3*0.D0,
35224 & 9*0.D0, .10D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0,
35225 & 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, 13*0.D0, .2D0, .5D0, .7D0,
35226 & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
35227 & 17*0.D0, .2D0, .5D0, .85D0, 2.D0, 2.15D0, 2.05D0, 1.75D0, 1.D0,
35228 & 17*0.D0, .13D0, .33D0, .57D0, 1.33D0, 1.43D0, 1.36D0, 1.17D0,
35229 & .67D0, 17*0.D0, .07D0, .17D0, .28D0, .67D0, .72D0, .69D0, .58D0,
35230 & .33D0,17*0.D0,.4D0, .7D0, 1.D0, 1.6D0, 1.8D0, 2.3D0,1.9D0,1.7D0 /
35232 DATA SPIKPW/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 2*20.D0,
35233 & 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
35234 & 2*10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
35235 & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
35236 & 4.2D0, 7.5D0, 3.4D0, 2*2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, .6D0,
35237 & .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, .48D0,
35238 & .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, .065D0,
35239 & .05D0, .04D0, 12*0.D0, .2D0, 2*.25D0, .2D0, .1D0, .08D0, .06D0,
35240 & .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, 12*0.D0, .3D0,
35241 & .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, .09D0, .08D0,
35242 & .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, 3.1D0, 4.5D0,
35243 & 2.D0, 23*0.D0, 4.0D0, 11.D0, 11.4D0, 10.3D0, 7.5D0, 6.8D0,
35244 & 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, .35D0, 13*0.D0, .1D0, .34D0,
35245 & .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, 2.3D0, 1.6D0, .95D0, .45D0,
35246 & .28D0, .15D0, 12*0.D0, .17D0, .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0,
35247 & 6.2D0, 4.4D0, 3.D0, 1.8D0, .9D0, .53D0, .28D0, 12*0.D0, .25D0,
35248 & .82D0, 1.3D0, 1.9D0, 2.8D0, 5.5D0, 8.D0, 5.7D0, 3.9D0, 2.35D0,
35249 & 1.15D0, .69D0, .37D0, 18*0.D0, .34D0, 1.5D0, 3.47D0, 5.87D0,
35250 & 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
35252 DATA SPIKPX/ 8*0.D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
35253 & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 16*0.D0, .2D0, .6D0,
35254 & .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, 1.D0,
35255 & .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, 3.5D0,
35256 & 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, .31D0,
35257 & .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, .23D0,
35258 & 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, 5.D0,
35259 & 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, 2.5D0,
35260 & 6*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, 1.5D0, 1.1D0,
35261 & .8D0, .7D0, .55D0, .3D0, 19*0.D0, .1D0, .4D0, 1.D0, 1.4D0, 2.2D0,
35262 & 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, .8D0, .6D0, .4D0, 12*0.D0,
35263 & .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, 3.8D0, 3.3D0, 2.45D0, 2.05D0,
35264 & 1.65D0, 1.2D0, .9D0, .6D0, 12*0.D0, .10D0, .2D0, .5D0, .7D0,
35265 & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
35266 & 13*0.D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0,
35267 & 1.35D0, 1.15D0, .95D0, .7D0, 17*0.D0, .2D0, .5D0, .85D0, 2.D0,
35268 & 2.15D0, 2.05D0, 1.75D0, 1.D0, 17*0.D0, .13D0, .33D0, .57D0,
35269 & 1.33D0, 1.43D0, 1.36D0, 1.17D0, .67D0, 17*0.D0, .07D0, .17D0,
35270 & .28D0, .67D0, .72D0, .69D0, .58D0, .33D0, 17*0.D0, .4D0, .7D0,
35271 & 1.D0, 1.6D0, 1.8D0, 2.3D0, 1.9D0, 1.7D0 /
35273 DATA SPIKP4 / 0.D0, 300.D0, 40.D0, 20.D0, 13.D0, 8.5D0, 8.D0,
35274 & 9.5D0, 12.D0, 14.D0, 15.5D0, 20.D0, 17.D0, 13.D0, 10.D0, 9.D0,
35275 & 8.5D0, 8.D0, 7.8D0, 7.3D0, 6.7D0, 9*0.D0, .23D0, .35D0, .7D0,
35276 & .52D0, .4D0, .3D0, .2D0, .15D0, .13D0, .11D0, .09D0, .07D0, 0.D0,
35277 & .033D0, .8D0, 2*1.35D0, .5D0, 19*0.D0, 0.8D0, 2.2D0, 3.6D0,
35278 & 4.6D0, 4.7D0, 3.5D0, 2.4D0, 1.8D0, 1.4D0, .75D0, .47D0, .25D0,
35279 & .13D0, .08D0, 7*0.D0, 1.2D0, 3.3D0, 5.4D0, 6.9D0, 7.3D0, 5.3D0,
35280 & 3.6D0, 2.7D0, 2.2D0, 1.1D0, .73D0, .4D0, .22D0, .12D0, 11*0.D0,
35281 & 2.0D0, 4.4D0, 6.8D0, 9.9D0, 7.9D0, 6.0D0, 3.8D0, 2.5D0, 2.D0,
35282 & 1.4D0, 1.D0, .6D0, .35D0, 10*0.D0, .25D0, .55D0, .75D0, 1.25D0,
35283 & 1.9D0, 2.D0, 1.8D0, 1.5D0, 1.25D0, 1.D0, .8D0, 10*0.D0, .4D0,
35284 & .85D0, 1.1D0, 1.85D0, 2.8D0, 3.D0, 2.7D0, 2.2D0, 1.85D0, 1.5D0,
35285 & 1.2D0, 12*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0,
35286 & 5.6D0, 5.2D0, 9*0.D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, 2.75D0,
35287 & 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 10*0.D0, .45D0, 1.4D0,
35288 & 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, 15*0.D0, .6D0,
35289 & .8D0, .95D0, .8D0, .7D0, .6D0, .5D0, .4D0, 13*0.D0, .85D0, 1.2D0,
35290 & 1.4D0, 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 13*0.D0, 1.D0, 1.5D0,
35291 & 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 16*0.D0, .5D0, 2.0D0,
35292 & 3.3D0, 5.4D0, 7.D0 /
35294 DATA SPIKP5/ 0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0,
35295 & 7.D0, 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
35296 & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 13*0.D0, 0.9D0,
35297 & 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0,
35298 & .45D0, .21D0, .2D0, 3*0.D0, .9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
35299 & 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
35300 & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, 1.4D0,
35301 & 1.2D0, 1.05D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, 2*1.D0, .9D0,
35302 & .7D0, .4D0, .3D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.2D0,
35303 & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
35304 & 1.71D0, 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0,
35305 & 3.5D0, 2.85D0, 2.35D0, 2.01D0, 1.8D0, 12*0.D0, .1D0, .8D0,2.05D0,
35306 & 3.31D0, 3.5D0, 12*0.D0, .034D0, .2D0, .75D0, 1.04D0, 1.24D0 /
35308 DATA SPIKP6/ 0.D0, 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0,
35309 & 1.5D0, 1.2D0, 1.D0, .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0,
35310 & 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, 1.5D0, 1.2D0, 1.D0,
35311 & .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, .5D0, 1.3D0, 2.8D0,
35312 & 2.3D0, 1.6D0, .9D0, 13*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
35313 & 2.D0, 1.7D0, 1.5D0,1.2D0,.9D0,.6D0,.45D0,.21D0,.2D0,3*0.D0,0.9D0,
35314 & 2.5D0, 3.D0, 2.5D0, 2.3D0,2.D0,1.7D0,1.5D0,1.2D0,.9D0,.6D0,.45D0,
35315 & .21D0, .2D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.D0,1.8D0,1.7D0,1.4D0,
35316 & 1.2D0,1.15D0,.9D0,.66D0,.5D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.1D0,
35317 & 1.8D0,1.7D0,1.4D0,1.2D0, 1.15D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0,
35318 & 2*1.D0, .9D0, .7D0, .4D0, .35D0, .2D0, 9*0.D0, .3D0, 2*1.D0,.9D0,
35319 & .7D0, .4D0, .35D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.4D0,3.5D0,4.25D0,
35320 & 4.55D0, 4.85D0, 4.9D0, 9*0.D0, .1D0, 1.D0, 2.4D0, 3.5D0, 4.25D0,
35321 & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
35322 & 1.71D0, 1.6D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0,
35323 & 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0,4.4D0,4.D0,3.5D0,2.85D0,
35324 & 2.35D0, 2.01D0, 1.8D0, 6*0.D0, 1.4D0,3.8D0,5.D0,4.7D0,4.4D0,4.D0,
35325 & 3.5D0,2.85D0,2.35D0,2.01D0,1.8D0,12*0.D0,.1D0,.8D0,2.05D0,3.31D0,
35326 & 3.5D0, 12*0.D0, .034D0,.2D0,.75D0,1.04D0,1.24D0 /
35328 DATA SKMPEL/ 0.D0, 35.D0, 22.D0, 25.D0, 17.D0, 9.D0, 9.5D0, 8.D0,
35329 & 7.D0, 6.5D0, 6.1D0, 5.D0, 4.8D0, 4.6D0, 4.45D0, 4.3D0, 4.2D0,
35330 & 0.D0, 8.D0, 3.5D0, 8.D0, 3.D0, 1.9D0, 1.7D0, 1.D0, .9D0, .8D0,
35331 & .75D0, .5D0, .42D0, .38D0, .34D0, .25D0, .2D0,
35332 & 0.D0, 3.D0, 3.2D0, 3.5D0, 1.5D0, 1.4D0, 1.1D0, .6D0, .5D0,
35333 & .35D0, .28D0, .25D0, .18D0, .12D0, .1D0, .08D0, .04D0,
35334 & 0.D0, 8.5D0, 2.4D0, 1.7D0, 1.3D0, 1.3D0, 1.1D0, .5D0,
35335 & .4D0, .4D0, .35D0, .3D0, .28D0, .2D0, .16D0, .13D0, .11D0,
35336 & 0.D0, 7.D0, 4.8D0, 1.4D0, 1.9D0, .9D0, .4D0, .2D0, .13D0,
35337 & .1D0, .08D0, .06D0, .04D0, .02D0, .015D0, .01D0, .01D0,
35338 & 0.D0, 5.5D0, 1.D0, .8D0, .75D0, .32D0, .2D0, .1D0, .09D0,
35339 & .08D0, .065D0, .05D0, .04D0, .022D0, .017D0, 2*.01D0/
35340 DATA SPIKP7 / 0.D0, .56D0, 1.46D0, 3.16D0, 2.01D0, 1.28D0, .74D0,
35341 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
35342 & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 4*0.D0,
35343 & 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, 1.57D0,
35344 & 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0, 3.03D0,
35345 & 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0,
35346 & .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, 2.8D0,
35347 & 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0,
35348 & .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
35349 & .45D0, .39D0, .22D0, .07D0, 0.D0, 7*0.D0, .34D0, 1.12D0, 1.12D0,
35350 & 1.01D0, .78D0, .45D0, .39D0, .22D0, .07D0, 0.D0, 6*0.D0, 1.71D0,
35351 & 4.26D0, 5.6D0, 5.57D0, 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0,
35352 & 2.25D0, 2.D0, 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
35353 & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, .22D0,
35354 & .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 10*0.D0, .22D0, .8D0,
35355 & .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, .3D0, .7D0,1.D0,
35356 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, 1.72D0, 2.69D0,
35357 & 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 9*0.D0, .11D0, 1.72D0,
35358 & 2.69D0, 3.92D0, 4.76D0, 5.1D0, 5.44D0, 5.3D0, 5*0.D0,9.2D0,4.7D0,
35359 & 1.9D0, 10*0.D0, 2.5D0, 15.D0, 21.5D0, 15.3D0, 3.D0, 1.5D0,
35362 DATA SKMNEL/0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
35363 & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0,
35364 & 0.D0, 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0,
35365 & 1.9D0, .9D0, .5D0, .3D0, .24D0, .2D0, .18D0, .1D0, .09D0,
35366 & 0.D0, 1.8D0, 2.D0, 1.1D0, .9D0, .5D0, .5D0, .4D0, .4D0,
35367 & .2D0, .1D0, .06D0, .05D0, .04D0, .03D0, .02D0, .02D0,
35368 & 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, .7D0, .65D0,
35369 & .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, .03D0/
35370 DATA SPIKP8/0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
35371 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
35372 & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,
35373 & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
35374 & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
35375 & 3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
35376 & 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
35377 & 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, .45D0,
35378 & .39D0, .22D0, .07D0, 0.D0,
35379 & 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
35380 & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0,
35381 & 10*0.D0, .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0,
35382 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0,
35383 & 13*0.D0, .1D0, .3D0, .7D0, 1.D0,
35384 & 9*0.D0, .11D0, 1.72D0, 2.69D0, 3.92D0, 4.76D0,
35385 & 5.10D0, 5.44D0, 5.3D0,
35386 & 4*0.D0, 0.00D0, 9.2D0, 4.7D0, 1.9D0, 9*0.D0/
35388 DATA SPIKP9/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
35389 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
35390 & 0.D0, 3.6D0, 1.7D0, 10*0.D0,
35391 & .0D0, 0.D0, 8.7D0, 17.7D0, 18.8D0, 15.9D0,
35392 & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
35393 & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
35394 & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
35395 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
35396 & 16.9D0, 16.5D0, 11.D0, 5.5D0, 3.5D0,
35397 & 10*0.D0, 4.3D0, 7.6D0, 9.D0,
35398 & 10*0.D0, 1.7D0, 2.6D0, 3.D0,
35399 & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
35400 & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
35401 & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
35402 & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/
35404 DATA SPIKP0/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
35405 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
35406 & 0.D0, 1.8D0, .2D0, 12*0.D0,
35407 & 3.2D0, 6.05D0, 9.9D0, 5.1D0,
35408 & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
35409 & 2*.0D0, 3.2D0, 6.05D0, 9.9D0, 5.1D0,
35410 & 3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
35411 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
35412 & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
35413 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0,
35414 & 16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
35415 & 10*0.D0, .7D0, 5.1D0, 8.D0,
35416 & 10*0.D0, .7D0, 5.1D0, 8.D0,
35417 & 10*.0D0, .3D0, 2.8D0, 4.7D0,
35418 & 10*.0D0, .3D0, 2.8D0, 4.7D0,
35419 & 7*0.D0, 1.2D0, 2.5D0, 3.5D0, 6.D0, 5.3D0, 2.9D0,
35420 & 7*0.D0, 1.7D0, 3.6D0, 5.4D0, 9.D0, 7.6D0, 4.2D0,
35421 & 5*0.D0, 7.7D0, 6.1D0, 2.9D0, 5*0.D0/
35424 DATA SPKPV/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
35425 & 19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
35426 & 0.D0, 3.6D0, 1.7D0, 12*0.D0,
35427 & 8.7D0, 17.7D0, 18.8D0, 15.9D0,
35428 & 11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
35429 & .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
35430 & 2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
35431 & 5*0.D0, 4.6D0, 10.2D0, 15.1D0, 16.9D0, 16.5D0,
35432 & 11.D0, 5.5D0, 3.5D0,
35433 & 10*0.D0, 4.3D0, 7.6D0, 9.D0,
35434 & 10*0.D0, 1.7D0, 2.6D0, 3.D0,
35435 & 6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
35436 & 6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
35437 & 1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
35438 & 10*0.D0, 1.9D0, 4.1D0, 5.2D0/
35439 **************** ap - p - data *
35440 DATA SAPPEL/ 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
35441 & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
35442 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0,
35443 & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
35444 & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
35445 & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
35446 & 0.D0, 55.D0, 50.D0, 25.D0, 15.D0, 15.D0, 14.D0, 12.D0,
35447 & 10.D0, 7.D0, 6.D0, 4.D0, 3.3D0, 2.8D0, 2.4D0, 2.D0, 1.8D0,
35448 & 1.55D0, 1.3D0, .95D0, .75D0,
35449 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
35450 & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
35451 & .01D0, .008D0, .006D0, .005D0/
35452 DATA SPIKPE/0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
35453 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
35454 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0,
35455 & 9*0.D0, 2.D0, 2.5D0, .2D0, 19*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0,
35456 & 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, .3D0, 1.4D0,
35457 & 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0,
35458 & .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0,
35459 & .3D0, 10*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0,
35460 & .6D0, .5D0, .4D0, .3D0, 9*0.D0, .6D0, 2.5D0, 5.D0, 5.2D0, 5.1D0,
35461 & 5.4D0, 5.8D0, 2.8D0, 2.1D0, 1.8D0, 1.6D0, 1.2D0, 13*0.D0, 1.3D0,
35462 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
35463 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
35464 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
35465 & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 14*0.D0, .2D0,
35466 & .5D0, 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0,
35467 & 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0,
35468 & 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, 1.6D0,
35469 & 1.4D0, 1.1D0, .9D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0,
35470 & .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0,
35471 & 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0 /
35472 **************** ap - n - data *
35474 & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
35475 & 50.D0, 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
35476 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0,
35477 & .05D0, .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0,
35478 & .85D0, 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0,
35479 & .14D0, .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
35480 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
35481 & .25D0, .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
35482 & .01D0, .008D0, .006D0, .005D0 /
35483 DATA SPIKPZ/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
35484 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
35485 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
35486 & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35487 & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
35488 & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
35489 & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
35490 & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35491 & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35492 & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35493 & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
35494 & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
35495 & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
35496 & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
35499 **************** an - p - data *
35502 & 0.D0, 176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, 50.D0,
35503 & 50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
35504 & 25.D0, 22.D0, 21.D0, 20.D0, 18.D0, 17.D0, 11*0.D0, .05D0,
35505 & .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
35506 & 0.D0, 1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
35507 & .1D0, .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
35508 & 0.D0, 3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, .25D0,
35509 & .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
35510 & .01D0, .008D0, .006D0, .005D0 /
35511 DATA SPIKPF/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
35512 & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
35513 & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
35514 & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35515 & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
35516 & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
35517 & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
35518 & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35519 & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35520 & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35521 & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
35522 & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
35523 & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
35524 & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
35525 **** ko - n - data *
35526 DATA SPKP15/0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, 7.D0,
35527 & 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
35528 & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 10*0.D0,
35529 & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
35530 & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
35531 & 3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
35532 & 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
35533 & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0,
35534 & 1.4D0, 1.2D0, 1.05D0, .9D0, .66D0, .5D0,
35535 & 7*0.D0, .3D0, 1.D0, 1.D0, .9D0, .7D0, .4D0, .30D0, .2D0,
35536 & 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.20D0, 4.55D0,
35538 & 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, 1.6D0,
35539 & 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, 3.5D0,
35540 & 2.85D0, 2.35D0, 2.01D0, 1.8D0,
35541 & 12*0.D0, .1D0, .8D0, 2.05D0, 3.31D0, 3.5D0,
35542 & 12*0.D0, .034D0, .20D0, .75D0, 1.04D0, 1.24D0 /
35543 **** ako - p - data *
35544 DATA SPKP16/ 0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
35545 & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, 0.D0,
35546 & 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, 1.9D0, .9D0, .5D0,
35547 & .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, 0.D0, 1.8D0, 2.D0, 1.1D0,
35548 & .9D0, .5D0, .5D0, .4D0, .4D0, .2D0, .1D0, .06D0, .05D0, .04D0,
35549 & .03D0, .02D0, .02D0, 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0,
35550 & .7D0, .65D0, .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0,
35551 & .03D0, 0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
35552 & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0,
35553 & 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0,
35554 & 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0,
35555 & 1.01D0, .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0,
35556 & 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0,
35557 & .5D0, .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
35558 & .45D0, .39D0, .22D0, .07D0, 7*0.D0, 1.71D0, 4.26D0, 5.6D0,5.57D0,
35559 & 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0,
35560 & .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0,
35561 & .3D0, .7D0, 1.D0, 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0,
35562 & 1.72D0, 2.69D0, 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 5*0.D0,
35563 & 9.2D0, 4.7D0, 1.9D0, 9*0.D0, .0D0,2.5D0,15.D0,
35564 & 21.5D0, 15.3D0, 3.D0, 1.5D0, 10*0.D0 /
35565 DATA NURELN/9, 12, 5*0, 10, 14, 3*0, 1, 3, 5, 7, 6*0, 2, 6, 16,
35566 & 5*0, 10, 13, 5*0, 11, 12, 3*0, 2, 4, 6, 8, 6*0, 3, 15, 7, 5*0 /
35567 *= end*block.blkdt3 *
35570 *$ CREATE DT_QEL_POL.FOR
35573 *===qel_pol============================================================*
35575 SUBROUTINE DT_QEL_POL(ENU,LTYP,P21,P22,P23,P24,P25)
35577 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35581 CALL DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
35586 *$ CREATE DT_GEN_QEL.FOR
35588 C==================================================================
35589 C Generation of a Quasi-Elastic neutrino scattering
35590 C==================================================================
35592 *===gen_qel============================================================*
35594 SUBROUTINE DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
35596 C...Generate a quasi-elastic neutrino/antineutrino
35597 C. Interaction on a nuclear target
35598 C. INPUT : LTYP = neutrino type (1,...,6)
35599 C. ENU (GeV) = neutrino energy
35600 C----------------------------------------------------
35602 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35605 PARAMETER ( LINP = 10 ,
35608 PARAMETER (MAXLND=4000)
35609 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
35610 * nuclear potential
35612 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
35613 & EBINDP(2),EBINDN(2),EPOT(2,210),
35614 & ETACOU(2),ICOUL,LFERMI
35615 * steering flags for qel neutrino scattering modules
35616 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
35617 **sr - removed (not needed)
35618 C COMMON /CBAD/ LBAD, NBAD
35619 C COMMON /CNUC/ XMN,XMN2,PFERMI,EFERMI,EBIND,EB2,C0
35622 DIMENSION PI(3),PO(3)
35627 C REAL*8 MN(2), ML0(6), ML, ML2, MI, MI2, MF, MF2
35628 DIMENSION DBETA(3),DBETB(3),AMN(2),AML0(6)
35629 DATA AMN /0.93827231D0, 0.93956563D0/
35630 DATA AML0 /2*0.51100D-03,2*0.105659D0, 2*1.777D0/
35633 C DATA PFERMI/0.22D0/
35634 CGB+...Binding Energy
35635 DATA EBIND/0.008D0/
35639 IF(ININU.EQ.1)NDSIG=0
35644 AML = AML0(LTYP) ! massa leptoni
35645 AML2 = AML**2 ! massa leptoni **2
35646 C...Particle labels (LUND)
35656 K0 = (LTYP-1)/2 ! 2
35658 KA = 12 + 2*K0 ! 16
35659 IS = -1 + 2*LTYP - 4*K1 ! -1 +10 -8 = 1
35663 LNU = 2 - LTYP + 2*K1 ! 2 - 5 + 2 = - 1
35664 IF (LNU .EQ. 2) THEN
35692 EFMAX = SQRT(PFERMI**2 + AMI2) -AMI ! max. Fermi Energy
35693 ENWELL = EFMAX + EBIND ! depth of nuclear potential well
35698 C...4-momentum initial lepton
35699 P(1,5) = 0. ! massa
35700 P(1,4) = ENU0 ! energia
35705 C PF = PFERMI*PYR(0)**(1./3.)
35706 c write(23,*) PYR(0)
35707 c write(*,*) 'Pfermi=',PF
35710 C IF(ntry.GT.2) WRITE(*,*) ntry,enu0,k2
35711 IF (NTRY .GT. 500) THEN
35713 WRITE (LOUT,1001) NBAD, ENU
35716 C CT = -1. + 2.*PYR(0)
35718 C ST = SQRT(1.-CT*CT)
35719 C F = 2.*3.1415926*PYR(0)
35722 C P(2,4) = SQRT(PF*PF + MI2) - EBIND ! energia
35723 C P(2,1) = PF*ST*COS(F) ! px
35724 C P(2,2) = PF*ST*SIN(F) ! py
35725 C P(2,3) = PF*CT ! pz
35726 C P(2,5) = SQRT(P(2,4)**2-PF*PF) ! massa
35732 beta1=-p(2,1)/p(2,4)
35733 beta2=-p(2,2)/p(2,4)
35734 beta3=-p(2,3)/p(2,4)
35736 C WRITE(6,*)' before transforming into target rest frame'
35737 CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
35738 C print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
35741 phi11=atan(p(1,2)/p(1,3))
35746 CALL DT_TESTROT(PI,Po,PHI11,1)
35748 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35754 phi12=atan(p(1,1)/p(1,3))
35759 CALL DT_TESTROT(Pi,Po,PHI12,2)
35761 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35770 C...Kinematical limits in Q**2
35771 c S = P(2,5)**2 + 2.*ENU*(P(2,4)-P(2,3)) ! ????
35772 S = P(2,5)**2 + 2.*ENU*P(2,5)
35773 SQS = SQRT(S) ! E centro massa
35774 IF (SQS .LT. (AML + AMF + 3.E-03)) GOTO 100
35775 ELF = (S-AMF2+AML2)/(2.*SQS) ! energia leptone finale p
35776 PSTAR = (S-P(2,5)**2)/(2.*SQS) ! p* neutrino nel c.m.
35777 PLF = SQRT(ELF**2-AML2) ! 3-momento leptone finale
35778 Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF) ! + o -
35779 Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF) ! according con cos(theta)
35780 IF (Q2MIN .LT. 0.) Q2MIN = 0. ! ??? non fisico
35783 DSIGMAX = DT_DSQEL_Q2 (LTYP,ENU, Q2MIN)
35784 200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
35785 DSIG = DT_DSQEL_Q2 (LTYP,ENU, Q2)
35786 IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200
35787 CALL DT_QGAUS(Q2MIN,Q2MAX,DSIGEV,ENU,LTYP)
35789 C WRITE(6,*)' Q2,Q2min,Q2MAX,DSIGEV',
35790 C &Q2,Q2min,Q2MAX,DSIGEV
35792 C...c.m. frame. Neutrino along z axis
35793 DETOT = (P(1,4)) + (P(2,4)) ! e totale
35794 DBETA(1) = ((P(1,1)) + (P(2,1)))/DETOT ! px1+px2/etot = beta_x
35795 DBETA(2) = ((P(1,2)) + (P(2,2)))/DETOT !
35796 DBETA(3) = ((P(1,3)) + (P(2,3)))/DETOT !
35799 C WRITE(*,*) 'Input values laboratory frame'
35802 CALL PYROBO(0,0,0.0D0,0.0D0,-DBETA(1),-DBETA(2),-DBETA(3))
35805 c STHETA = ULANGL(P(1,3),P(1,1))
35806 c write(*,*) 'stheta' ,stheta
35808 c CALL PYROBO (0,0,-STHETA,0.,0.D0,0.D0,0.D0)
35811 C WRITE(*,*) 'Output values cm frame'
35812 C...Kinematic in c.m. frame
35813 CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) ! cos(theta) cm
35814 STSTAR = SQRT(1.-CTSTAR**2)
35815 PHI = 6.28319*PYR(0) ! random phi tra 0 e 2*pi
35816 P(4,5) = AML ! massa leptone
35817 P(4,4) = ELF ! e leptone
35818 P(4,3) = PLF*CTSTAR ! px
35819 P(4,1) = PLF*STSTAR*COS(PHI) ! py
35820 P(4,2) = PLF*STSTAR*SIN(PHI) ! pz
35822 P(5,5) = AMF ! barione
35823 P(5,4) = (S+AMF2-AML2)/(2.*SQS)! e barione
35824 P(5,3) = -P(4,3) ! px
35825 P(5,1) = -P(4,1) ! py
35826 P(5,2) = -P(4,2) ! pz
35829 P(3,1) = P(1,1)-P(4,1)
35830 P(3,2) = P(1,2)-P(4,2)
35831 P(3,3) = P(1,3)-P(4,3)
35832 P(3,4) = P(1,4)-P(4,4)
35834 C...Transform back to laboratory frame
35835 C WRITE(*,*) 'before going back to nucl rest frame'
35836 c CALL PYROBO (0,0,STHETA,0.,0.D0,0.D0,0.D0)
35839 CALL PYROBO(0,0,0.0D0,0.0D0,DBETA(1),DBETA(2),DBETA(3))
35841 C WRITE(*,*) 'Now back in nucl rest frame'
35842 IF(LTYP.GE.3) CALL DT_PREPOLA(Q2,LTYP,ENU)
35844 c********************************************
35850 CALL DT_TESTROT(Pi,Po,PHI12,3)
35852 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35858 c********************************************
35864 CALL DT_TESTROT(Pi,Po,PHI11,4)
35866 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35873 c********************************************
35875 C WRITE(*,*) 'Now back in lab frame'
35877 CALL PYROBO(1,5,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
35880 C...test (on final momentum of nucleon) if Fermi-blocking
35882 ENUCL = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2 + P(5,5)**2)
35884 IF (ENUCL.LT. EFMAX) THEN
35885 IF(INIPRI.LT.10)THEN
35887 C WRITE(6,*)' qel: Pauli ENUCL.LT.EFMAX ', ENUCL,EFMAX
35888 C...the interaction is not possible due to Pauli-Blocking and
35889 C...it must be resampled
35892 ELSE IF (ENUCL.LT.ENWELL.and.ENUCL.GE.EFMAX) THEN
35893 IF(INIPRI.LT.10)THEN
35895 C WRITE(6,*)' qel: inside ENUCL.LT.ENWELL ', ENUCL,ENWELL
35897 C Reject (J:R) here all these events
35898 C are otherwise rejected in dpmjet
35900 C...the interaction is possible, but the nucleon remains inside
35901 C...the nucleus. The nucleus is therefore left excited.
35902 C...We treat this case as a nucleon with 0 kinetic energy.
35908 ELSE IF (ENUCL.GE.ENWELL) THEN
35909 C WRITE(6,*)' qel ENUCL.GE.ENWELL ',ENUCL,ENWELL
35910 C...the interaction is possible, the nucleon can exit the nucleus
35911 C...but the nuclear well depth must be subtracted. The nucleus could be
35912 C...left in an excited state.
35913 Pstart = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2)
35914 C P(5,4) = ENUCL-ENWELL + AMF
35915 Pnucl = SQRT(P(5,4)**2-AMF**2)
35916 C...The 3-momentum is scaled assuming that the direction remains
35918 P(5,1) = P(5,1) * Pnucl/Pstart
35919 P(5,2) = P(5,2) * Pnucl/Pstart
35920 P(5,3) = P(5,3) * Pnucl/Pstart
35921 C WRITE(6,*)' qel new P(5,4) ',P(5,4)
35924 DSIGSU=DSIGSU+DSIGEV
35934 IF(NEUDEC.EQ.1.OR.NEUDEC.EQ.2) THEN
35936 CALL PYROBO(6,8,0.0D0,0.0D0,DBETB(1),DBETB(2),DBETB(3))
35940 C PRINT*,' FINE EVENTO '
35944 1001 FORMAT(2X, 'DT_GEN_QEL : event rejected ', I5, G10.3)
35947 *$ CREATE DT_MASS_INI.FOR
35949 C====================================================================
35951 C====================================================================
35953 *===mass_ini===========================================================*
35955 SUBROUTINE DT_MASS_INI
35956 C...Initialize the kinematics for the quasi-elastic cross section
35958 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35961 * particle masses used in qel neutrino scattering modules
35962 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
35963 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
35964 & EMPROTSQ,EMNEUTSQ,EMNSQ
35966 EML(1) = 0.51100D-03 ! e-
35967 EML(2) = EML(1) ! e+
35968 EML(3) = 0.105659D0 ! mu-
35969 EML(4) = EML(3) ! mu+
35970 EML(5) = 1.7777D0 ! tau-
35971 EML(6) = EML(5) ! tau+
35972 EMPROT = 0.93827231D0 ! p
35973 EMNEUT = 0.93956563D0 ! n
35974 EMPROTSQ = EMPROT**2
35975 EMNEUTSQ = EMNEUT**2
35976 EMN = (EMPROT + EMNEUT)/2.
35980 EMN1(J0+1) = EMNEUT
35981 EMN1(J0+2) = EMPROT
35982 EMN2(J0+1) = EMPROT
35983 EMN2(J0+2) = EMNEUT
35986 EMLSQ(J) = EML(J)**2
35987 ETQE(J) = ((EMN2(J)+ EML(J))**2-EMN1(J)**2)/(2.*EMN1(J))
35992 *$ CREATE DT_DSQEL_Q2.FOR
35995 *===dsqel_q2===========================================================*
35997 DOUBLE PRECISION FUNCTION DT_DSQEL_Q2 (JTYP,ENU, Q2)
35999 C...differential cross section for Quasi-Elastic scattering
36000 C. nu + N -> l + N'
36001 C. From Llewellin Smith Phys.Rep. 3C, 261, (1971).
36003 C. INPUT : JTYP = 1,...,6 nu_e, ...., nubar_tau
36004 C. ENU (GeV) = Neutrino energy
36005 C. Q2 (GeV**2) = (Transfer momentum)**2
36007 C. OUTPUT : DSQEL_Q2 = differential cross section :
36008 C. dsigma/dq**2 (10**-38 cm+2/GeV**2)
36009 C------------------------------------------------------------------
36011 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36014 * particle masses used in qel neutrino scattering modules
36015 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
36016 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
36017 & EMPROTSQ,EMNEUTSQ,EMNSQ
36018 **sr - removed (not needed)
36019 C COMMON /CAXIAL/ FA0, AXIAL2
36023 DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
36024 DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
36025 DATA AXIAL2 /1.03D0/ ! to be checked
36029 GVE = 1.D0/ (1.D0 + Q2/0.84D0**2)**2 ! G_e(q**2)
36030 GVM = (1.D0+CSI)*GVE ! G_m (q**2)
36031 X = Q2/(EMN*EMN) ! emn=massa barione
36033 FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
36034 FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
36035 FA = FA0/(1.D0 + Q2/AXIAL2)**2
36039 RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp)
36040 A1 = (4.D0+X)*FFA - (4.D0-X)*FFV1 + X*FFV2*(1.D0-XA)+4*X*FV1*FV2
36041 A2 = -RM * ((FV1 + FV2)**2 + FFA)
36042 AA = (XA+0.25D0*RM)*(A1 + A2)
36043 BB = -X*FA*(FV1 + FV2)
36044 CC = 0.25D0*(FFA + FFV1 + XA*FFV2)
36045 SU = (4.D0*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
36046 DT_DSQEL_Q2 = C0*(AA + SS(JTYP)*BB*SU + CC*SU*SU) / (ENU*ENU) !
36047 IF(DT_DSQEL_Q2 .LT. 0.D0) DT_DSQEL_Q2 = 0.D0
36052 *$ CREATE DT_PREPOLA.FOR
36055 *===prepola============================================================*
36057 SUBROUTINE DT_PREPOLA(Q2,JTYP,ENU)
36059 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36062 c By G. Battistoni and E. Scapparone (sept. 1997)
36064 c Albright & Jarlskog, Nucl Phys B84 (1975) 467
36067 PARAMETER (MAXLND=4000)
36068 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
36069 COMMON /QNPOL/ POLARX(4),PMODUL
36070 * particle masses used in qel neutrino scattering modules
36071 COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
36072 & EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
36073 & EMPROTSQ,EMNEUTSQ,EMNSQ
36074 * steering flags for qel neutrino scattering modules
36075 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
36076 **sr - removed (not needed)
36077 C COMMON /CAXIAL/ FA0, AXIAL2
36078 C COMMON /TAUTAU/Q(4,5),ETL,PXL,PYL,PZL,
36079 C & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN
36081 REAL*8 POL(4,4),BB2(3)
36083 C DATA C0 /0.17590D0 / ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
36084 DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
36085 **sr uncommented since common block CAXIAL is now commented
36086 DATA AXIAL2 /1.03D0/ ! to be checked
36096 GVE = 1.D0/ (1.D0 + Q2/(0.84D+00)**2)**2 ! G_e(q**2)
36097 GVM = (1.D0+CSI)*GVE ! G_m (q**2)
36098 X = Q2/(EMN*EMN) ! emn=massa barione
36100 FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
36101 FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
36102 FA = FA0/(1.D0 + Q2/AXIAL2**2)**2
36106 FP=2.D0*FA*RMM/(MPI**2 + Q2)
36107 RM = EMLSQ(JTYP)/(EMN*EMN) ! emlsq(jtyp)
36108 A1 = (4.D0+X)*FFA-(4.D0-X)*FFV1+X*FFV2*(1.D0-XA)+4.D0*X*FV1*FV2
36109 A2 = -RM * ((FV1 + FV2)**2 + FFA)
36110 AA = (XA+0.25D+00*RM)*(A1 + A2)
36111 BB = -X*FA*(FV1 + FV2)
36112 CC = 0.25D+00*(FFA + FFV1 + XA*FFV2)
36113 SU = (4.D+00*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
36115 OMEGA1=FFA+XA*(FFA+(FV1+FV2)**2 ) ! articolo di ll...-smith
36117 OMEGA3=2.D+00*FA*(FV1+FV2)
36118 OMEGA4P=(-(FV1+FV2)**2-(FA+2*FP)**2+(4.0D+00+
36121 OMEGA4=(OMEGA4P-OMEGA2+2*OMEGA5)/4.D+00
36122 WW1=2.D+00*OMEGA1*EMN**2
36123 WW2=2.D+00*OMEGA2*EMN**2
36124 WW3=2.D+00*OMEGA3*EMN**2
36125 WW4=2.D+00*OMEGA4*EMN**2
36126 WW5=2.D+00*OMEGA5*EMN**2
36129 BB2(I)=-P(4,I)/P(4,4)
36133 c WRITE(*,*) 'Prepola: ready to transform to lepton rest frame'
36135 CALL PYROBO(0,0,0.0D0,0.0D0,BB2(1),BB2(2),BB2(3))
36136 * NOW PARTICLES ARE IN THE SCATTERED LEPTON REST FRAME
36139 c WRITE(*,*) 'Prepola: now in lepton rest frame'
36143 FRAC=QM2*WW1 + (2.D+00*EE*(EE-U) - 0.5D+00*QM2)*WW2 - SS(JTYP)*
36144 + (0.5D+00/(RMM**2))*(2.D+00*RMM*EE*Q2 - U*QM2)*WW3 +
36145 + ((RML**2)/(2.D+00*FM2))*(QM2*WW4-2.D+00*RMM*EE*WW5) !<=FM2 inv di RMM!!
36147 FACTK=2.D+00*WW1 -WW2 -SS(JTYP)*(EE/RMM)*WW3 +((EE-U)/RMM)*WW5
36148 + - ((RML**2)/FM2)*WW4 !<=FM2 inv di RMM!!
36150 FACTP=2.D+00*EE/RMM*WW2 - (QM2/(2.D+00*RMM**2))*(SS(JTYP)*WW3+WW5)
36153 POL(4,I)=RML*SS(JTYP)*(FACTK*P(1,I)+FACTP*P(2,I))/FRAC
36159 PMODUL=PMODUL+POL(4,I)**2
36162 IF(JTYP.GT.4.AND.NEUDEC.GT.0) THEN
36163 IF(NEUDEC.EQ.1) THEN
36164 CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-2),POLARX(3),
36166 + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
36168 c Tau has decayed in muon
36171 IF(NEUDEC.EQ.2) THEN
36172 CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-4),POLARX(3),
36174 + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
36176 c Tau has decayed in electron
36184 c fill common for muon(electron)
36192 IF(NEUDEC.EQ.1) THEN
36195 ELSEIF(NEUDEC.EQ.2) THEN
36199 ELSEIF(JTYP.EQ.6) THEN
36200 IF(NEUDEC.EQ.1) THEN
36202 ELSEIF(NEUDEC.EQ.2) THEN
36210 c fill common for tau_(anti)neutrino
36220 ELSEIF(JTYP.EQ.6) THEN
36227 c Fill common for muon(electron)_(anti)neutrino
36236 IF(NEUDEC.EQ.1) THEN
36238 ELSEIF(NEUDEC.EQ.2) THEN
36241 ELSEIF(JTYP.EQ.6) THEN
36242 IF(NEUDEC.EQ.1) THEN
36244 ELSEIF(NEUDEC.EQ.2) THEN
36255 c IF(PMODUL.GE.1.D+00) THEN
36256 c WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
36257 c write(*,*) pmodul
36259 c POL(4,I)=POL(4,I)/PMODUL
36260 c POLARX(I)=POL(4,I)
36264 c PMODUL=PMODUL+POL(4,I)**2
36266 c WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
36270 c WRITE(*,*) 'PMODUL = ',PMODUL
36274 c WRITE(*,*) 'prepola: Now back to nucl rest frame'
36275 CALL PYROBO(1,5,0.0D0,0.0D0,-BB2(1),-BB2(2),-BB2(3))
36277 XDC = V(4,1)+V(4,5)*P(4,1)/P(4,5)
36278 YDC = V(4,2)+V(4,5)*P(4,2)/P(4,5)
36279 ZDC = V(4,3)+V(4,5)*P(4,3)/P(4,5)
36289 *$ CREATE DT_TESTROT.FOR
36292 *===testrot============================================================*
36294 SUBROUTINE DT_TESTROT(PI,PO,PHI,MODE)
36296 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36299 DIMENSION ROT(3,3),PI(3),PO(3)
36301 IF (MODE.EQ.1) THEN
36306 ROT(2,2) = COS(PHI)
36307 ROT(2,3) = -SIN(PHI)
36309 ROT(3,2) = SIN(PHI)
36310 ROT(3,3) = COS(PHI)
36311 ELSEIF (MODE.EQ.2) THEN
36315 ROT(2,1) = COS(PHI)
36317 ROT(2,3) = -SIN(PHI)
36318 ROT(3,1) = SIN(PHI)
36320 ROT(3,3) = COS(PHI)
36321 ELSEIF (MODE.EQ.3) THEN
36325 ROT(1,2) = COS(PHI)
36327 ROT(3,2) = -SIN(PHI)
36328 ROT(1,3) = SIN(PHI)
36330 ROT(3,3) = COS(PHI)
36331 ELSEIF (MODE.EQ.4) THEN
36336 ROT(2,2) = COS(PHI)
36337 ROT(3,2) = -SIN(PHI)
36339 ROT(2,3) = SIN(PHI)
36340 ROT(3,3) = COS(PHI)
36342 STOP ' TESTROT: mode not supported!'
36345 PO(J) = ROT(J,1)*PI(1)+ROT(J,2)*PI(2)+ROT(J,3)*PI(3)
36351 *$ CREATE DT_LEPDCYP.FOR
36354 *===lepdcyp============================================================*
36356 SUBROUTINE DT_LEPDCYP(AMA,AML,POL,ETL,PXL,PYL,PZL,
36357 & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
36359 C-----------------------------------------------------------------
36361 C Author :- G. Battistoni 10-NOV-1995
36363 C=================================================================
36365 C Purpose : performs decay of polarized lepton in
36366 C its rest frame: a => b + l + anti-nu
36367 C (Example: mu- => nu-mu + e- + anti-nu-e)
36368 C Polarization is assumed along Z-axis
36370 C 1) b AND anti-nu ARE ASSUMED TO BE NEUTRINOS
36371 C OF NEGLIGIBLE MASS
36372 C 2) RADIATIVE CORRECTIONS ARE NOT CONSIDERED
36375 C Method : modifies phase space distribution obtained
36376 C by routine EXPLOD using a rejection against the
36377 C matrix element for unpolarized lepton decay
36379 C Inputs : Mass of a : AMA
36382 C (Example: fully polar. mu- decay: AMA=AMMUON, AML=AMELCT,
36385 C Outputs : kinematic variables in the rest frame of decaying lepton
36386 C ETL,PXL,PYL,PZL 4-moment of l
36387 C ETB,PXB,PYB,PZB 4-moment of b
36388 C ETN,PXN,PYN,PZN 4-moment of anti-nu
36390 C============================================================
36394 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36397 PARAMETER ( LINP = 10 ,
36400 PARAMETER ( KALGNM = 2 )
36401 PARAMETER ( ANGLGB = 5.0D-16 )
36402 PARAMETER ( ANGLSQ = 2.5D-31 )
36403 PARAMETER ( AXCSSV = 0.2D+16 )
36404 PARAMETER ( ANDRFL = 1.0D-38 )
36405 PARAMETER ( AVRFLW = 1.0D+38 )
36406 PARAMETER ( AINFNT = 1.0D+30 )
36407 PARAMETER ( AZRZRZ = 1.0D-30 )
36408 PARAMETER ( EINFNT = +69.07755278982137 D+00 )
36409 PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
36410 PARAMETER ( ONEMNS = 0.999999999999999 D+00 )
36411 PARAMETER ( ONEPLS = 1.000000000000001 D+00 )
36412 PARAMETER ( CSNNRM = 2.0D-15 )
36413 PARAMETER ( DMXTRN = 1.0D+08 )
36414 PARAMETER ( ZERZER = 0.D+00 )
36415 PARAMETER ( ONEONE = 1.D+00 )
36416 PARAMETER ( TWOTWO = 2.D+00 )
36417 PARAMETER ( THRTHR = 3.D+00 )
36418 PARAMETER ( FOUFOU = 4.D+00 )
36419 PARAMETER ( FIVFIV = 5.D+00 )
36420 PARAMETER ( SIXSIX = 6.D+00 )
36421 PARAMETER ( SEVSEV = 7.D+00 )
36422 PARAMETER ( EIGEIG = 8.D+00 )
36423 PARAMETER ( ANINEN = 9.D+00 )
36424 PARAMETER ( TENTEN = 10.D+00 )
36425 PARAMETER ( HLFHLF = 0.5D+00 )
36426 PARAMETER ( ONETHI = ONEONE / THRTHR )
36427 PARAMETER ( TWOTHI = TWOTWO / THRTHR )
36428 PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
36429 PARAMETER ( ENEPER = 2.7182818284590452354 D+00 )
36430 PARAMETER ( SQRENT = 1.6487212707001281468 D+00 )
36431 PARAMETER ( CLIGHT = 2.99792458 D+10 )
36432 PARAMETER ( AVOGAD = 6.0221367 D+23 )
36433 PARAMETER ( AMELGR = 9.1093897 D-28 )
36434 PARAMETER ( PLCKBR = 1.05457266 D-27 )
36435 PARAMETER ( ELCCGS = 4.8032068 D-10 )
36436 PARAMETER ( ELCMKS = 1.60217733 D-19 )
36437 PARAMETER ( AMUGRM = 1.6605402 D-24 )
36438 PARAMETER ( AMMUMU = 0.113428913 D+00 )
36439 PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
36440 PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
36441 PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
36442 PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
36443 PARAMETER ( PLABRC = 0.197327053 D+00 )
36444 PARAMETER ( AMELCT = 0.51099906 D-03 )
36445 PARAMETER ( AMUGEV = 0.93149432 D+00 )
36446 PARAMETER ( AMMUON = 0.105658389 D+00 )
36447 PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
36448 PARAMETER ( GEVMEV = 1.0 D+03 )
36449 PARAMETER ( EMVGEV = 1.0 D-03 )
36450 PARAMETER ( ALGVMV = 6.90775527898214 D+00 )
36451 PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
36452 PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
36454 C variables for EXPLOD
36456 PARAMETER ( KPMX = 10 )
36457 DIMENSION AMEXPL (KPMX), PXEXPL (KPMX), PYEXPL (KPMX),
36458 & PZEXPL (KPMX), ETEXPL (KPMX)
36462 **sr - removed (not needed)
36463 C COMMON /GBATNU/ ELERAT,NTRY
36466 C Initializes test variables
36471 C Maximum value for matrix element
36473 ELEMAX = ( AMA**2 + AML**2 )**2 / AMA**2 * ( AMA**2 - AML**2 +
36474 & SQRT( AMA**4 + AML**4 - 3.D+00 * AMA**2 * AML**2 ) )
36475 C + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
36476 C Inputs for EXPLOD
36477 C part. no. 1 is l (e- in mu- decay)
36478 C part. no. 2 is b (nu-mu in mu- decay)
36479 C part. no. 3 is anti-nu (anti-nu-e in mu- decay)
36480 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
36487 C phase space distribution
36492 CALL DT_EXPLOD ( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
36496 C Calculates matrix element:
36497 C 64*GF**2{[P(a)-ama*S(a)]*P(anti-nu)}{P(l)*P(b)}
36498 C Here CTH is the cosine of the angle between anti-nu and Z axis
36500 CTH = PZEXPL(3) / SQRT ( PXEXPL(3)**2 + PYEXPL(3)**2 +
36502 PROD1 = ETEXPL(3) * AMA * (1.D+00 - POL * CTH)
36503 PROD2 = ETEXPL(1) * ETEXPL(2) - PXEXPL(1)*PXEXPL(2) -
36504 & PYEXPL(1)*PYEXPL(2) - PZEXPL(1)*PZEXPL(2)
36505 ELEMAT = 16.D+00 * PROD1 * PROD2
36506 IF(ELEMAT.GT.ELEMAX) THEN
36507 WRITE(LOUT,*) 'Problems in LEPDCY',ELEMAX,ELEMAT
36511 C Here performs the rejection
36513 TEST = DT_RNDM(ETOTEX) * ELEMAX
36514 IF ( TEST .GT. ELEMAT ) GO TO 100
36516 C final assignment of variables
36518 ELERAT = ELEMAT/ELEMAX
36534 *$ CREATE DT_GEN_DELTA.FOR
36536 C==================================================================
36537 C. Generation of Delta resonance events
36538 C==================================================================
36540 *===gen_delta==========================================================*
36542 SUBROUTINE DT_GEN_DELTA(ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25)
36544 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36547 PARAMETER ( LINP = 10 ,
36550 C...Generate a Delta-production neutrino/antineutrino
36551 C. CC-interaction on a nucleon
36553 C. INPUT ENU (GeV) = Neutrino Energy
36554 C. LLEP = neutrino type
36555 C. LTARG = nucleon target type 1=p, 2=n.
36556 C. JINT = 1:CC, 2::NC
36558 C. OUTPUT PPL(4) 4-monentum of final lepton
36559 C----------------------------------------------------
36560 PARAMETER (MAXLND=4000)
36561 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
36562 **sr - removed (not needed)
36563 C COMMON /CBAD/ LBAD, NBAD
36566 DIMENSION PI(3),PO(3)
36567 C REAL*4 AMD0, AMD, AMN(2), AML0(6), AML, AML2, AMDMIN
36568 DIMENSION AML0(6),AMN(2)
36569 DATA AMD0 /1.231/, GAMD /0.12/, DELD/0.169/, AMDMIN/1.084/
36570 DATA AMN /0.93827231, 0.93956563/
36571 DATA AML0 /2*0.51100E-03,2*0.105659, 2*1.777/
36573 c WRITE(6,*)' GEN_DEL',ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25
36575 C...Final lepton mass
36576 IF (JINT.EQ.1) THEN
36583 C...Particle labels (LUND)
36591 IF (LTARG .EQ. 1) THEN
36599 IS = -1 + 2*LLEP - 4*K1
36600 LNU = 2 - LLEP + 2*K1
36604 IF (JINT .EQ. 1) THEN ! CC interactions
36608 IF (LTARG .EQ. 1) THEN
36614 IF (LTARG .EQ. 1) THEN
36621 K(3,2) = 23 ! NC (Z0) interactions
36623 **sr 7.5.00: swop Delta's (bug), Delta+ for proton (LTARG=1),
36624 * Delta0 for neutron (LTARG=2)
36625 C IF (LTARG .EQ. 1) THEN
36630 IF (LTARG .EQ. 1) THEN
36638 C...4-momentum initial lepton
36644 C...4-momentum initial nucleon
36645 P(2,5) = AMN(LTARG)
36656 beta1=-p(2,1)/p(2,4)
36657 beta2=-p(2,2)/p(2,4)
36658 beta3=-p(2,3)/p(2,4)
36661 CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
36663 C print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
36665 phi11=atan(p(1,2)/p(1,3))
36670 CALL DT_TESTROT(PI,Po,PHI11,1)
36672 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36677 phi12=atan(p(1,1)/p(1,3))
36682 CALL DT_TESTROT(Pi,Po,PHI12,2)
36684 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36692 C...Generate the Mass of the Delta
36695 AMD=AMD0+0.5*GAMD*TAN((2.*R-1.)*ATAN(2.*DELD/GAMD))
36697 IF (NTRY .GT. 1000) THEN
36699 WRITE (LOUT,1001) NBAD, ENUU,AMD,AMDMIN,AMD0,GAMD,ET
36702 IF (AMD .LT. AMDMIN) GOTO 100
36703 ET = ((AMD+AML)**2 - AMN(LTARG)**2)/(2.*AMN(LTARG))
36704 IF (ENUU .LT. ET) GOTO 100
36706 C...Kinematical limits in Q**2
36707 S = AMN(LTARG)**2 + 2.*AMN(LTARG)*ENUU
36709 PSTAR = (S - AMN(LTARG)**2)/(2.*SQS)
36710 ELF = (S - AMD**2 + AML2)/(2.*SQS)
36711 PLF = SQRT(ELF**2 - AML2)
36712 Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)
36713 Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)
36714 IF (Q2MIN .LT. 0.) Q2MIN = 0.
36716 DSIGMAX = DT_DSIGMA_DELTA(LNU,-Q2MIN, S, AML, AMD)
36717 200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
36718 DSIG = DT_DSIGMA_DELTA(LNU,-Q2, S, AML, AMD)
36719 IF (DSIG .LT. DSIGMAX*PYR(0)) GOTO 200
36721 C...Generate the kinematics of the final particles
36722 EISTAR = (S + AMN(LTARG)**2)/(2.*SQS)
36723 GAM = EISTAR/AMN(LTARG)
36725 CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF)
36726 EL = GAM*(ELF + BET*PLF*CTSTAR)
36727 PLZ = GAM*(PLF*CTSTAR + BET*ELF)
36728 PL = SQRT(EL**2 - AML2)
36729 PLT = SQRT(MAX(1.D-06,(PL*PL - PLZ*PLZ)))
36730 PHI = 6.28319*PYR(0)
36731 P(4,1) = PLT*COS(PHI)
36732 P(4,2) = PLT*SIN(PHI)
36737 C...4-momentum of Delta
36740 P(5,3) = ENUU-P(4,3)
36741 P(5,4) = ENUU+AMN(LTARG)-P(4,4)
36744 C...4-momentum of intermediate boson
36746 P(3,4) = P(1,4)-P(4,4)
36747 P(3,1) = P(1,1)-P(4,1)
36748 P(3,2) = P(1,2)-P(4,2)
36749 P(3,3) = P(1,3)-P(4,3)
36756 CALL DT_TESTROT(Pi,Po,PHI12,3)
36758 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36765 c********************************************
36771 CALL DT_TESTROT(Pi,Po,PHI11,4)
36773 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36779 c********************************************
36780 C transform back into Lab.
36782 CALL PYROBO(0,0,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
36784 C WRITE(6,*)' Lab fram ( fermi incl.) '
36789 1001 FORMAT(2X, 'DT_GEN_DELTA : event rejected ', I5, 6G10.3)
36792 *$ CREATE DT_DSIGMA_DELTA.FOR
36793 *COPY DT_DSIGMA_DELTA
36795 *===dsigma_delta=======================================================*
36797 DOUBLE PRECISION FUNCTION DT_DSIGMA_DELTA (LNU, QQ, S, AML, MD)
36799 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36802 C...Reaction nu + N -> lepton + Delta
36803 C. returns the cross section
36805 C. INPUT LNU = 1, 2 (neutrino-antineutrino)
36806 C. QQ = t (always negative) GeV**2
36807 C. S = (c.m energy)**2 GeV**2
36808 C. OUTPUT = 10**-38 cm+2/GeV**2
36809 C-----------------------------------------------------
36810 REAL*8 MN, MN2, MN4, MD,MD2, MD4
36812 DATA PI /3.1415926/
36814 GF = (1.1664 * 1.97)
36822 VQ = (MN2 - MD2 - QQ)/2.
36823 VPI = (MN2 + MD2 - QQ)/2.
36824 VK = (S + QQ - MN2 - AML2)/2.
36826 QK = (AML2 - QQ)/2.
36827 PIQ = (QQ + MN2 - MD2)/2.
36829 C3V = 2.07*SQRT(EXP(-6.3*Q)*(1.+9*Q))
36830 C3 = SQRT(3.)*C3V/MN
36831 C4 = -C3/MD ! attenzione al segno
36832 C5A = 1.18/(1.-QQ/0.4225)**2
36837 IF (LNU .EQ. 1) THEN
36838 ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
36839 . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
36840 . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
36841 . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
36842 ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
36843 . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
36844 . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
36845 . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
36846 . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
36847 . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ-
36848 . 4.*MN*C3*C5A*MD2*VK*QQ+4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
36849 . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
36850 . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
36851 . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
36852 . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK-MD*
36853 . C3*C5A*MD2*PIK*QQ+MD*C3*C5A*MD2*QK*PIQ-3.*MD*C3*C5A
36854 . *VK*VPI*QQ+MD*C3*C5A*VK*VQ*PIQ+3.*MD*C3*C5A*VPI*VQ*
36855 . QK-MD*C3*C5A*VQ**2*PIK+C4*C5A*MD2*VK*VPI*QQ+C4*C5A*
36856 . MD2*VK*VQ*PIQ-C4*C5A*MD2*VPI*VQ*QK-C4*C5A*MD2*VQ**2
36857 . *PIK-C4*C5A*MD4*PIK*QQ+C4*C5A*MD4*QK*PIQ-2.*MD2*VK
36858 . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
36859 . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
36860 . *C42-2.*MD2*VPI*QK**2*C32+ANS3
36862 ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
36863 . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
36864 . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
36865 . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
36866 ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
36867 . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
36868 . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
36869 . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
36870 . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
36871 . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ+
36872 . 4.*MN*C3*C5A*MD2*VK*QQ-4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
36873 . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
36874 . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
36875 . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
36876 . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK+MD*
36877 . C3*C5A*MD2*PIK*QQ-MD*C3*C5A*MD2*QK*PIQ+3.*MD*C3*C5A
36878 . *VK*VPI*QQ-MD*C3*C5A*VK*VQ*PIQ-3.*MD*C3*C5A*VPI*VQ*
36879 . QK+MD*C3*C5A*VQ**2*PIK-C4*C5A*MD2*VK*VPI*QQ-C4*C5A*
36880 . MD2*VK*VQ*PIQ+C4*C5A*MD2*VPI*VQ*QK+C4*C5A*MD2*VQ**2
36881 . *PIK+C4*C5A*MD4*PIK*QQ-C4*C5A*MD4*QK*PIQ-2.*MD2*VK
36882 . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
36883 . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
36884 . *C42-2.*MD2*VPI*QK**2*C32+ANS3
36888 P1CM = (S-MN2)/(2.*SQRT(S))
36889 DT_DSIGMA_DELTA = GF2/2. * ANS/(64.*PI*S*P1CM**2)
36894 *$ CREATE DT_QGAUS.FOR
36897 *===qgaus==============================================================*
36899 SUBROUTINE DT_QGAUS(A,B,SS,ENU,LTYP)
36901 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36904 DIMENSION X(5),W(5)
36905 DATA X/.1488743389D0,.4333953941D0,
36906 & .6794095682D0,.8650633666D0,.9739065285D0
36908 DATA W/.2955242247D0,.2692667193D0,
36909 & .2190863625D0,.1494513491D0,.0666713443D0
36916 SS=SS+W(J)*(DT_DSQEL_Q2(LTYP,ENU,XM+DX)+
36917 * DT_DSQEL_Q2(LTYP,ENU,XM-DX))
36924 *$ CREATE DT_DIQBRK.FOR
36927 *===diqbrk=============================================================*
36929 SUBROUTINE DT_DIQBRK
36931 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36935 PARAMETER (NMXHKK=200000)
36936 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36937 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36938 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36939 * extended event history
36940 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36941 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36944 COMMON /DTEVNO/ NEVENT,ICASCA
36946 C IF(DT_RNDM(VV).LE.0.5D0)THEN
36947 C CALL GSQBS1(NHKK)
36948 C CALL GSQBS2(NHKK)
36949 C CALL USQBS1(NHKK)
36950 C CALL USQBS2(NHKK)
36951 C CALL GSABS1(NHKK)
36952 C CALL GSABS2(NHKK)
36953 C CALL USABS1(NHKK)
36954 C CALL USABS2(NHKK)
36956 C CALL GSQBS2(NHKK)
36957 C CALL GSQBS1(NHKK)
36958 C CALL USQBS2(NHKK)
36959 C CALL USQBS1(NHKK)
36960 C CALL GSABS2(NHKK)
36961 C CALL GSABS1(NHKK)
36962 C CALL USABS2(NHKK)
36963 C CALL USABS1(NHKK)
36966 IF(DT_RNDM(VV).LE.0.5D0) THEN
36989 *$ CREATE MUSQBS2.FOR
36993 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
36994 SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36995 * IP1,IP21,IP22,IPP1,IPP2,IPIP,ISQ,IGCOUN)
36997 C USQBS-2 diagram (split target diquark)
36999 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37002 PARAMETER ( LINP = 10 ,
37006 PARAMETER (NMXHKK=200000)
37007 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
37008 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
37009 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
37010 * extended event history
37011 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
37012 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37014 * Lorentz-parameters of the current interaction
37015 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37016 & UMO,PPCM,EPROJ,PPROJ
37017 * diquark-breaking mechanism
37018 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37021 PARAMETER (NTMHKK= 300)
37022 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37023 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37026 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37029 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37030 COMMON /EVFLAG/ NUMEV
37032 C USQBS-2 diagram (split target diquark)
37035 C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
37036 C Input chain 2(NC2) sea-antiquark(NC2P)-sea-quark(NC2T)
37038 C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
37039 C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37041 C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
37042 C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37043 C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37046 C Put new chains into COMMON /HKKTMP/
37051 C WRITE(LOUT,*)'MUSQBS2: IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
37055 C IF(NUMEV.EQ.-324)THEN
37056 C WRITE(LOUT,*)' MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37057 C * 'IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN)',
37058 C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37059 C * IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN
37064 C determine x-values of NC1T diquark
37065 XDIQT=PHKK(4,NC1T)*2.D0/UMO
37066 XVQP=PHKK(4,NC1P)*2.D0/UMO
37068 C determine x-values of sea quark pair
37074 IF(ICOU.GE.500)THEN
37077 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 2234 ICOU. GT.500'
37081 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS2 call XSEAPA: UMO,XDIQT,XVQP ',
37086 C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37087 IF (IPIP.EQ.1) THEN
37088 XQMAX = XDIQT/2.0D0
37089 XAQMAX = 2.D0*XVQP/3.0D0
37091 XQMAX = 2.D0*XVQP/3.0D0
37092 XAQMAX = XDIQT/2.0D0
37094 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37096 C write(*,*) 'MUSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
37099 & WRITE(LOUT,*)'MUSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37102 & WRITE(LOUT,*)'MUSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37107 IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37108 ELSEIF(IPIP.EQ.2)THEN
37109 IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37112 WRITE(LOUT,'(A,4E12.4)')' MUSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
37113 * XDIQT,XVQP,XSQ,XSAQ
37116 C subtract xsq,xsaq from NC1T diquark and NC1P quark
37122 ELSEIF(IPIP.EQ.2)THEN
37127 & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
37129 C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37134 IF(IVTHR.EQ.10)THEN
37137 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 3466 reject IVTHR 10'
37142 XVTHR=XVTHRO/(201-IVTHR)
37145 IF(XVTHR.GT.0.66D0*XDIQT)THEN
37148 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 380 XVTHR large ',
37153 IF(DT_RNDM(V).LT.0.5D0)THEN
37154 XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37157 XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37161 WRITE(LOUT,'(A,2E12.4)')' MUSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
37164 C Prepare 4 momenta of new chains and chain ends
37166 C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37167 C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37170 C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
37171 C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37172 C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37174 C SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37175 C * IP1,IP21,IP22,IPP1,IPP2)
37182 ELSEIF(IPIP.EQ.2)THEN
37192 JDAHKT(1,1)=3+IIGLU1
37194 C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
37195 PHKT(1,1) =PHKK(1,NC2P)
37196 PHKT(2,1) =PHKK(2,NC2P)
37197 PHKT(3,1) =PHKK(3,NC2P)
37198 PHKT(4,1) =PHKK(4,NC2P)
37199 C PHKT(5,1) =PHKK(5,NC2P)
37200 XMIST =(PHKT(4,1)**2-
37201 * PHKT(3,1)**2-PHKT(2,1)**2-
37203 IF(XMIST.GT.0.D0)THEN
37204 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
37207 C WRITE(LOUT,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
37210 VHKT(1,1) =VHKK(1,NC2P)
37211 VHKT(2,1) =VHKK(2,NC2P)
37212 VHKT(3,1) =VHKK(3,NC2P)
37213 VHKT(4,1) =VHKK(4,NC2P)
37214 WHKT(1,1) =WHKK(1,NC2P)
37215 WHKT(2,1) =WHKK(2,NC2P)
37216 WHKT(3,1) =WHKK(3,NC2P)
37217 WHKT(4,1) =WHKK(4,NC2P)
37218 C Add here IIGLU1 gluons to this chaina
37223 IF(IIGLU1.GE.1)THEN
37225 DO 61 IIG=2,2+IIGLU1-1
37227 IDHKT(IIG) =IDHKK(KKG)
37231 JDAHKT(1,IIG)=3+IIGLU1
37233 PHKT(1,IIG)=PHKK(1,KKG)
37234 PG1=PG1+ PHKT(1,IIG)
37235 PHKT(2,IIG)=PHKK(2,KKG)
37236 PG2=PG2+ PHKT(2,IIG)
37237 PHKT(3,IIG)=PHKK(3,KKG)
37238 PG3=PG3+ PHKT(3,IIG)
37239 PHKT(4,IIG)=PHKK(4,KKG)
37240 PG4=PG4+ PHKT(4,IIG)
37241 PHKT(5,IIG)=PHKK(5,KKG)
37242 VHKT(1,IIG) =VHKK(1,KKG)
37243 VHKT(2,IIG) =VHKK(2,KKG)
37244 VHKT(3,IIG) =VHKK(3,KKG)
37245 VHKT(4,IIG) =VHKK(4,KKG)
37246 WHKT(1,IIG) =WHKK(1,KKG)
37247 WHKT(2,IIG) =WHKK(2,KKG)
37248 WHKT(3,IIG) =WHKK(3,KKG)
37249 WHKT(4,IIG) =WHKK(4,KKG)
37252 IDHKT(2+IIGLU1) =IP21
37253 ISTHKT(2+IIGLU1) =952
37254 JMOHKT(1,2+IIGLU1)=NC1T
37255 JMOHKT(2,2+IIGLU1)=0
37256 JDAHKT(1,2+IIGLU1)=3+IIGLU1
37257 JDAHKT(2,2+IIGLU1)=0
37258 PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
37259 PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
37260 PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
37261 PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
37262 C PHKT(5,2) =PHKK(5,NC1T)
37263 XMIST =(PHKT(4,2+IIGLU1)**2-
37264 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37265 *PHKT(1,2+IIGLU1)**2)
37266 IF(XMIST.GT.0.D0)THEN
37267 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
37268 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37269 *PHKT(1,2+IIGLU1)**2)
37271 C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
37272 PHKT(5,5+IIGLU1)=0.D0
37274 VHKT(1,2+IIGLU1) =VHKK(1,NC1T)
37275 VHKT(2,2+IIGLU1) =VHKK(2,NC1T)
37276 VHKT(3,2+IIGLU1) =VHKK(3,NC1T)
37277 VHKT(4,2+IIGLU1) =VHKK(4,NC1T)
37278 WHKT(1,2+IIGLU1) =WHKK(1,NC1T)
37279 WHKT(2,2+IIGLU1) =WHKK(2,NC1T)
37280 WHKT(3,2+IIGLU1) =WHKK(3,NC1T)
37281 WHKT(4,2+IIGLU1) =WHKK(4,NC1T)
37282 IDHKT(3+IIGLU1) =88888
37283 ISTHKT(3+IIGLU1) =95
37284 JMOHKT(1,3+IIGLU1)=1
37285 JMOHKT(2,3+IIGLU1)=2+IIGLU1
37286 JDAHKT(1,3+IIGLU1)=0
37287 JDAHKT(2,3+IIGLU1)=0
37288 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
37289 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
37290 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
37291 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
37293 * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37294 * -PHKT(3,3+IIGLU1)**2)
37295 IF(XMIST.GT.0.D0)THEN
37297 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37298 * -PHKT(3,3+IIGLU1)**2)
37300 C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
37301 PHKT(5,5+IIGLU1)=0.D0
37304 C IF(NUMEV.EQ.-324)THEN
37305 C WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
37307 C *JDAHKT(2,1),(PHKT(III,1),III=1,5)
37308 DO 71 IIG=2,2+IIGLU1-1
37309 C WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
37310 C & JMOHKT(1,IIG),JMOHKT(2,IIG),
37312 C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37314 C WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
37315 C * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
37316 C *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
37317 C WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
37318 C * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
37319 C *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
37323 IF(IPP1.LE.-3.OR.IP21.GE.3)CHAMAL=CHAM3
37324 ELSEIF(IPIP.EQ.2)THEN
37325 IF(IPP1.GE.3.OR.IP21.LE.-3)CHAMAL=CHAM3
37327 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
37331 C WRITE(LOUT,*)' MUSQBS1 jump back from chain 3'
37334 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
37335 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
37336 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
37337 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
37338 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
37339 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
37340 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
37341 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
37343 IDHKT(4+IIGLU1) =-(ISAQ1-6)
37344 ELSEIF(IPIP.EQ.2)THEN
37345 IDHKT(4+IIGLU1) =ISAQ1
37347 ISTHKT(4+IIGLU1) =951
37348 JMOHKT(1,4+IIGLU1)=NC1P
37349 JMOHKT(2,4+IIGLU1)=0
37350 JDAHKT(1,4+IIGLU1)=6+IIGLU1
37351 JDAHKT(2,4+IIGLU1)=0
37352 C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37353 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
37354 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
37355 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
37356 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
37357 C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
37358 XMIST =(PHKT(4,4+IIGLU1)**2-
37359 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37360 *PHKT(1,4+IIGLU1)**2)
37361 IF(XMIST.GT.0.D0)THEN
37362 PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2-
37363 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37364 *PHKT(1,4+IIGLU1)**2)
37366 C WRITE(LOUT,*)'MUSQBS2 parton 4 mass square LT.0 ',XMIST
37367 PHKT(5,4+IIGLU1)=0.D0
37369 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
37370 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
37371 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
37372 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
37373 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
37374 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
37375 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
37376 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
37377 IDHKT(5+IIGLU1) =IP22
37378 ISTHKT(5+IIGLU1) =952
37379 JMOHKT(1,5+IIGLU1)=NC1T
37380 JMOHKT(2,5+IIGLU1)=0
37381 JDAHKT(1,5+IIGLU1)=6+IIGLU1
37382 JDAHKT(2,5+IIGLU1)=0
37383 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
37384 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
37385 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
37386 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
37387 C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
37388 XMIST =(PHKT(4,5+IIGLU1)**2-
37389 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37390 *PHKT(1,5+IIGLU1)**2)
37391 IF(XMIST.GT.0.D0)THEN
37392 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
37393 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37394 *PHKT(1,5+IIGLU1)**2)
37396 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37397 PHKT(5,5+IIGLU1)=0.D0
37399 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
37400 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
37401 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
37402 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
37403 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
37404 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
37405 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
37406 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
37407 IDHKT(6+IIGLU1) =88888
37408 ISTHKT(6+IIGLU1) =95
37409 JMOHKT(1,6+IIGLU1)=4+IIGLU1
37410 JMOHKT(2,6+IIGLU1)=5+IIGLU1
37411 JDAHKT(1,6+IIGLU1)=0
37412 JDAHKT(2,6+IIGLU1)=0
37413 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37414 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37415 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37416 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37418 * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37419 * -PHKT(3,6+IIGLU1)**2)
37420 IF(XMIST.GT.0.D0)THEN
37422 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37423 * -PHKT(3,6+IIGLU1)**2)
37425 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37426 PHKT(5,5+IIGLU1)=0.D0
37428 C IF(IPIP.GE.2)THEN
37429 C IF(NUMEV.EQ.-324)THEN
37430 C WRITE(6,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
37431 C * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
37432 C *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
37433 C WRITE(6,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
37434 C * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
37435 C *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
37436 C WRITE(6,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
37437 C * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
37438 C *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
37442 IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
37443 ELSEIF(IPIP.EQ.2)THEN
37444 IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
37446 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37450 C WRITE(6,*)' MUSQBS1 jump back from chain 6',
37451 C * CHAMAL,PHKT(5,6+IIGLU1)
37454 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
37455 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
37456 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
37457 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
37458 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
37459 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
37460 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
37461 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
37462 C IDHKT(7) =1000*IPP1+100*ISQ+1
37463 IDHKT(7+IIGLU1) =IP1
37464 ISTHKT(7+IIGLU1) =951
37465 JMOHKT(1,7+IIGLU1)=NC1P
37466 JMOHKT(2,7+IIGLU1)=0
37468 C JDAHKT(1,7+IIGLU1)=9+IIGLU1
37469 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
37471 JDAHKT(2,7+IIGLU1)=0
37472 PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
37473 PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
37474 PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
37475 PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
37476 C PHKT(5,7+IIGLU1) =PHKK(5,NC1P)
37477 XMIST =(PHKT(4,7+IIGLU1)**2-
37478 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
37479 *PHKT(1,7+IIGLU1)**2)
37480 IF(XMIST.GT.0.D0)THEN
37481 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
37482 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
37483 *PHKT(1,7+IIGLU1)**2)
37485 C WRITE(6,*)'MUSQBS2 parton 7 mass square LT.0 ',XMIST
37486 PHKT(5,7+IIGLU1)=0.D0
37488 VHKT(1,7+IIGLU1) =VHKK(1,NC1P)
37489 VHKT(2,7+IIGLU1) =VHKK(2,NC1P)
37490 VHKT(3,7+IIGLU1) =VHKK(3,NC1P)
37491 VHKT(4,7+IIGLU1) =VHKK(4,NC1P)
37492 WHKT(1,7+IIGLU1) =WHKK(1,NC1P)
37493 WHKT(2,7+IIGLU1) =WHKK(2,NC1P)
37494 WHKT(3,7+IIGLU1) =WHKK(3,NC1P)
37495 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
37496 C Insert here the IIGLU2 gluons
37501 IF(IIGLU2.GE.1)THEN
37503 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37504 KKG=JJG+IIG-7-IIGLU1
37505 IDHKT(IIG) =IDHKK(KKG)
37509 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
37511 PHKT(1,IIG)=PHKK(1,KKG)
37512 PG1=PG1+ PHKT(1,IIG)
37513 PHKT(2,IIG)=PHKK(2,KKG)
37514 PG2=PG2+ PHKT(2,IIG)
37515 PHKT(3,IIG)=PHKK(3,KKG)
37516 PG3=PG3+ PHKT(3,IIG)
37517 PHKT(4,IIG)=PHKK(4,KKG)
37518 PG4=PG4+ PHKT(4,IIG)
37519 PHKT(5,IIG)=PHKK(5,KKG)
37520 VHKT(1,IIG) =VHKK(1,KKG)
37521 VHKT(2,IIG) =VHKK(2,KKG)
37522 VHKT(3,IIG) =VHKK(3,KKG)
37523 VHKT(4,IIG) =VHKK(4,KKG)
37524 WHKT(1,IIG) =WHKK(1,KKG)
37525 WHKT(2,IIG) =WHKK(2,KKG)
37526 WHKT(3,IIG) =WHKK(3,KKG)
37527 WHKT(4,IIG) =WHKK(4,KKG)
37531 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3
37532 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
37533 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
37534 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
37535 ELSEIF(IPIP.EQ.2)THEN
37536 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3
37537 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
37538 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
37539 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
37541 ISTHKT(8+IIGLU1+IIGLU2) =952
37542 JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
37543 JMOHKT(2,8+IIGLU1+IIGLU2)=0
37544 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
37545 JDAHKT(2,8+IIGLU1+IIGLU2)=0
37546 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC2T)+
37547 * PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
37548 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC2T)+
37549 * PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
37550 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC2T)+
37551 * PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
37552 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC2T)+
37553 * PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
37554 C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
37555 C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
37556 IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
37558 C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
37559 C * ,PHKT(4,8+IIGLU1+IIGLU2), PHKK(4,NC2T),NC2T
37564 C PHKT(5,8) =PHKK(5,NC2T)
37565 XMIST =(PHKT(4,8+IIGLU1+IIGLU2)**2-
37566 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37567 *PHKT(1,8+IIGLU1+IIGLU2)**2)
37568 IF(XMIST.GT.0.D0)THEN
37569 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
37570 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37571 *PHKT(1,8+IIGLU1+IIGLU2)**2)
37573 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37574 PHKT(5,5+IIGLU1)=0.D0
37576 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T)
37577 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T)
37578 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T)
37579 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T)
37580 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T)
37581 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T)
37582 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T)
37583 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T)
37584 IDHKT(9+IIGLU1+IIGLU2) =88888
37585 ISTHKT(9+IIGLU1+IIGLU2) =95
37586 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
37587 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
37588 JDAHKT(1,9+IIGLU1+IIGLU2)=0
37589 JDAHKT(2,9+IIGLU1+IIGLU2)=0
37591 C PHKT(1,9+IIGLU1+IIGLU2)
37592 C * =PHKT(1,7+IIGLU1+IIGLU2)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
37593 C PHKT(2,9+IIGLU1+IIGLU2)
37594 C * =PHKT(2,7+IIGLU1+IIGLU2)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
37595 C PHKT(3,9+IIGLU1+IIGLU2)
37596 C * =PHKT(3,7+IIGLU1+IIGLU2)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
37597 C PHKT(4,9+IIGLU1+IIGLU2)
37598 C * =PHKT(4,7+IIGLU1+IIGLU2)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
37599 PHKT(1,9+IIGLU1+IIGLU2)
37600 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
37601 PHKT(2,9+IIGLU1+IIGLU2)
37602 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
37603 PHKT(3,9+IIGLU1+IIGLU2)
37604 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
37605 PHKT(4,9+IIGLU1+IIGLU2)
37606 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
37609 * =(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37610 * -PHKT(2,9+IIGLU1+IIGLU2)**2
37611 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
37612 IF(XMIST.GT.0.D0)THEN
37613 PHKT(5,9+IIGLU1+IIGLU2)
37614 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37615 * -PHKT(2,9+IIGLU1+IIGLU2)**2
37616 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
37618 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37619 PHKT(5,5+IIGLU1)=0.D0
37622 C IF(NUMEV.EQ.-324)THEN
37623 C WRITE(6,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
37624 C * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
37625 C *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
37626 C DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37627 C WRITE(6,*)IIG,ISTHKT(IIG),IDHKT(IIG),JMOHKT(1,IIG),JMOHKT(2,IIG),
37629 C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37631 C WRITE(6,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
37632 C * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
37633 C *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
37634 C *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
37635 C WRITE(6,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
37636 C * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
37637 C *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
37638 C *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
37642 IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
37643 ELSEIF(IPIP.EQ.2)THEN
37644 IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
37646 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
37650 C WRITE(6,*)' MUSQBS1 jump back from chain 9',
37651 C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
37654 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
37655 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
37656 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
37657 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
37658 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
37659 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
37660 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
37661 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
37664 IGCOUN=9+IIGLU1+IIGLU2
37668 *$ CREATE MGSQBS2.FOR
37672 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
37673 SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37674 * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,ISQ,IGCOUN)
37676 C GSQBS-2 diagram (split target diquark)
37678 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37681 PARAMETER ( LINP = 10 ,
37685 PARAMETER (NMXHKK=200000)
37686 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
37687 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
37688 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
37689 * extended event history
37690 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
37691 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37693 * Lorentz-parameters of the current interaction
37694 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37695 & UMO,PPCM,EPROJ,PPROJ
37696 * diquark-breaking mechanism
37697 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37700 PARAMETER (NTMHKK= 300)
37701 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37702 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37706 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37709 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37711 C GSQBS-2 diagram (split target diquark)
37714 C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
37715 C Input chain 2(NC2) valence-diquark(NC2P)-sea-quark(NC2T)
37717 C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
37718 C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37720 C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
37721 C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37722 C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37726 C Put new chains into COMMON /HKKTMP/
37731 C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
37734 C IF(IPIP.EQ.2)THEN
37735 C WRITE(6,*)' MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37736 C * 'IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN)',
37737 C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37738 C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN
37743 C determine x-values of NC1T diquark
37744 XDIQT=PHKK(4,NC1T)*2.D0/UMO
37745 XVQP=PHKK(4,NC1P)*2.D0/UMO
37747 C determine x-values of sea quark pair
37753 IF(ICOU.GE.500)THEN
37757 & WRITE(LOUT,*)' MGSQBS2 Rejection 2234 ICOU. GT.500'
37762 & WRITE(LOUT,*)'MGSQBS2 call XSEAPA: UMO,XDIQT,XVQP ',
37767 C CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37768 IF (IPIP.EQ.1) THEN
37769 XQMAX = XDIQT/2.0D0
37770 XAQMAX = 2.D0*XVQP/3.0D0
37772 XQMAX = 2.D0*XVQP/3.0D0
37773 XAQMAX = XDIQT/2.0D0
37775 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37777 C write(*,*) 'MGSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
37780 & WRITE(LOUT,*)'MGSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37783 & WRITE(LOUT,*)'MGSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37788 IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37789 ELSEIF(IPIP.EQ.2)THEN
37790 IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37793 WRITE(LOUT,'(A,4E12.4)')' MGSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
37794 * XDIQT,XVQP,XSQ,XSAQ
37797 C subtract xsq,xsaq from NC1T diquark and NC1P quark
37803 ELSEIF(IPIP.EQ.2)THEN
37808 & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
37810 C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37815 IF(IVTHR.EQ.10)THEN
37818 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 3466 reject IVTHR 10'
37823 XVTHR=XVTHRO/(201-IVTHR)
37826 IF(XVTHR.GT.0.66D0*XDIQT)THEN
37829 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 Rejection 380 XVTHR large ',
37834 IF(DT_RNDM(V).LT.0.5D0)THEN
37835 XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37838 XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37842 WRITE(LOUT,'(A,2E12.4)')' MGSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
37845 C Prepare 4 momenta of new chains and chain ends
37847 C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37848 C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37851 C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
37852 C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37853 C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37855 C SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37856 C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IGCOUN)
37863 ELSEIF(IPIP.EQ.2)THEN
37870 C IDHKT(1) =1000*IPP11+100*IPP12+1
37875 IDHKT(4+IIGLU1) =-(ISAQ1-6)
37876 ELSEIF(IPIP.EQ.2)THEN
37877 IDHKT(4+IIGLU1) =ISAQ1
37879 ISTHKT(4+IIGLU1) =961
37880 JMOHKT(1,4+IIGLU1)=NC1P
37881 JMOHKT(2,4+IIGLU1)=0
37882 JDAHKT(1,4+IIGLU1)=6+IIGLU1
37883 JDAHKT(2,4+IIGLU1)=0
37884 C create chain 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37885 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
37886 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
37887 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
37888 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
37889 C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
37890 XXMIST=(PHKT(4,4+IIGLU1)**2-
37891 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37892 *PHKT(1,4+IIGLU1)**2)
37893 IF(XXMIST.GT.0.D0)THEN
37894 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
37896 WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
37898 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
37900 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
37901 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
37902 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
37903 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
37904 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
37905 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
37906 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
37907 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
37908 IDHKT(5+IIGLU1) =IP22
37909 ISTHKT(5+IIGLU1) =962
37910 JMOHKT(1,5+IIGLU1)=NC1T
37911 JMOHKT(2,5+IIGLU1)=0
37912 JDAHKT(1,5+IIGLU1)=6+IIGLU1
37913 JDAHKT(2,5+IIGLU1)=0
37914 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
37915 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
37916 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
37917 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
37918 C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
37919 XXMIST=(PHKT(4,5+IIGLU1)**2-
37920 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37921 *PHKT(1,5+IIGLU1)**2)
37922 IF(XXMIST.GT.0.D0)THEN
37923 PHKT(5,5+IIGLU1) =SQRT(XXMIST)
37925 WRITE(LOUT,*)' MGSQBS2 XXMIST', XXMIST
37927 PHKT(5,5+IIGLU1) =SQRT(XXMIST)
37929 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
37930 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
37931 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
37932 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
37933 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
37934 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
37935 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
37936 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
37937 IDHKT(6+IIGLU1) =88888
37938 ISTHKT(6+IIGLU1) =96
37939 JMOHKT(1,6+IIGLU1)=4+IIGLU1
37940 JMOHKT(2,6+IIGLU1)=5+IIGLU1
37941 JDAHKT(1,6+IIGLU1)=0
37942 JDAHKT(2,6+IIGLU1)=0
37943 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37944 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37945 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37946 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37948 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37949 * -PHKT(3,6+IIGLU1)**2)
37952 IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
37953 ELSEIF(IPIP.EQ.2)THEN
37954 IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
37956 C---------------------------------------------------
37957 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37958 IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
37959 C we drop chain 6 and give the energy to chain 3
37960 IDHKT(6+IIGLU1)=22888
37962 C WRITE(6,*)' drop chain 6 xgive=1'
37964 ELSEIF(IDHKT(4+IIGLU1).EQ.-IP21)THEN
37965 C we drop chain 6 and give the energy to chain 3
37966 C and change KK11 to IDHKT(5)
37967 IDHKT(6+IIGLU1)=22888
37969 C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(5)'
37970 KK11=IDHKT(5+IIGLU1)
37972 ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP11)THEN
37973 C we drop chain 6 and give the energy to chain 3
37974 C and change KK21 to IDHKT(5+IIGLU1)
37975 C IDHKT(1) =1000*IPP11+100*IPP12+1
37976 IDHKT(6+IIGLU1)=22888
37978 C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(5+IIGLU1)'
37979 KK21=IDHKT(5+IIGLU1)
37981 ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP12)THEN
37982 C we drop chain 6 and give the energy to chain 3
37983 C and change KK22 to IDHKT(5)
37984 C IDHKT(1) =1000*IPP11+100*IPP12+1
37985 IDHKT(6+IIGLU1)=22888
37987 C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(5+IIGLU1)'
37988 KK22=IDHKT(5+IIGLU1)
37997 C---------------------------------------------------
37999 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
38000 * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
38001 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
38002 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
38003 * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
38004 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
38005 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
38006 * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
38007 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
38009 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
38010 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
38011 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
38012 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
38013 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
38014 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
38015 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
38016 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
38017 C IDHKT(1) =1000*IPP11+100*IPP12+1
38019 IDHKT(1) =1000*KK21+100*KK22+3
38020 IF(IDHKT(1).EQ.1203)IDHKT(1)=2103
38021 IF(IDHKT(1).EQ.1303)IDHKT(1)=3103
38022 IF(IDHKT(1).EQ.2303)IDHKT(1)=3203
38023 ELSEIF(IPIP.EQ.2)THEN
38024 IDHKT(1) =1000*KK21+100*KK22-3
38025 IF(IDHKT(1).EQ.-1203)IDHKT(1)=-2103
38026 IF(IDHKT(1).EQ.-1303)IDHKT(1)=-3103
38027 IF(IDHKT(1).EQ.-2303)IDHKT(1)=-3203
38032 JDAHKT(1,1)=3+IIGLU1
38034 C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
38035 PHKT(1,1) =PHKK(1,NC2P)
38036 *+XGIVE*PHKT(1,4+IIGLU1)
38037 PHKT(2,1) =PHKK(2,NC2P)
38038 *+XGIVE*PHKT(2,4+IIGLU1)
38039 PHKT(3,1) =PHKK(3,NC2P)
38040 *+XGIVE*PHKT(3,4+IIGLU1)
38041 PHKT(4,1) =PHKK(4,NC2P)
38042 *+XGIVE*PHKT(4,4+IIGLU1)
38043 C PHKT(5,1) =PHKK(5,NC2P)
38044 XXMIST=PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38046 IF(XXMIST.GT.0.D0)THEN
38047 PHKT(5,1) =SQRT(XXMIST)
38049 WRITE(LOUT,*)'MGSQBS2',XXMIST
38051 PHKT(5,1) =SQRT(XXMIST)
38053 VHKT(1,1) =VHKK(1,NC2P)
38054 VHKT(2,1) =VHKK(2,NC2P)
38055 VHKT(3,1) =VHKK(3,NC2P)
38056 VHKT(4,1) =VHKK(4,NC2P)
38057 WHKT(1,1) =WHKK(1,NC2P)
38058 WHKT(2,1) =WHKK(2,NC2P)
38059 WHKT(3,1) =WHKK(3,NC2P)
38060 WHKT(4,1) =WHKK(4,NC2P)
38061 C Add here IIGLU1 gluons to this chaina
38066 IF(IIGLU1.GE.1)THEN
38068 DO 61 IIG=2,2+IIGLU1-1
38070 IDHKT(IIG) =IDHKK(KKG)
38074 JDAHKT(1,IIG)=3+IIGLU1
38076 PHKT(1,IIG)=PHKK(1,KKG)
38077 PG1=PG1+ PHKT(1,IIG)
38078 PHKT(2,IIG)=PHKK(2,KKG)
38079 PG2=PG2+ PHKT(2,IIG)
38080 PHKT(3,IIG)=PHKK(3,KKG)
38081 PG3=PG3+ PHKT(3,IIG)
38082 PHKT(4,IIG)=PHKK(4,KKG)
38083 PG4=PG4+ PHKT(4,IIG)
38084 PHKT(5,IIG)=PHKK(5,KKG)
38085 VHKT(1,IIG) =VHKK(1,KKG)
38086 VHKT(2,IIG) =VHKK(2,KKG)
38087 VHKT(3,IIG) =VHKK(3,KKG)
38088 VHKT(4,IIG) =VHKK(4,KKG)
38089 WHKT(1,IIG) =WHKK(1,KKG)
38090 WHKT(2,IIG) =WHKK(2,KKG)
38091 WHKT(3,IIG) =WHKK(3,KKG)
38092 WHKT(4,IIG) =WHKK(4,KKG)
38096 IDHKT(2+IIGLU1) =KK11
38097 ISTHKT(2+IIGLU1) =962
38098 JMOHKT(1,2+IIGLU1)=NC1T
38099 JMOHKT(2,2+IIGLU1)=0
38100 JDAHKT(1,2+IIGLU1)=3+IIGLU1
38101 JDAHKT(2,2+IIGLU1)=0
38102 PHKT(1,2+IIGLU1) =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
38103 C * +0.5D0*PHKK(1,NC2T)
38104 *+XGIVE*PHKT(1,5+IIGLU1)
38105 PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
38106 C *+0.5D0*PHKK(2,NC2T)
38107 *+XGIVE*PHKT(2,5+IIGLU1)
38108 PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
38109 C *+0.5D0*PHKK(3,NC2T)
38110 *+XGIVE*PHKT(3,5+IIGLU1)
38111 PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
38112 C *+0.5D0*PHKK(4,NC2T)
38113 *+XGIVE*PHKT(4,5+IIGLU1)
38114 C PHKT(5,2) =PHKK(5,NC1T)
38115 XXMIST=(PHKT(4,2+IIGLU1)**2-
38116 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38117 *PHKT(1,2+IIGLU1)**2)
38118 IF(XXMIST.GT.0.D0)THEN
38119 PHKT(5,2+IIGLU1) =SQRT(XXMIST)
38121 WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
38123 PHKT(5,2+IIGLU1) =SQRT(XXMIST)
38125 VHKT(1,2+IIGLU1) =VHKK(1,NC1T)
38126 VHKT(2,2+IIGLU1) =VHKK(2,NC1T)
38127 VHKT(3,2+IIGLU1) =VHKK(3,NC1T)
38128 VHKT(4,2+IIGLU1) =VHKK(4,NC1T)
38129 WHKT(1,2+IIGLU1) =WHKK(1,NC1T)
38130 WHKT(2,2+IIGLU1) =WHKK(2,NC1T)
38131 WHKT(3,2+IIGLU1) =WHKK(3,NC1T)
38132 WHKT(4,2+IIGLU1) =WHKK(4,NC1T)
38133 IDHKT(3+IIGLU1) =88888
38134 ISTHKT(3+IIGLU1) =96
38135 JMOHKT(1,3+IIGLU1)=1
38136 JMOHKT(2,3+IIGLU1)=2+IIGLU1
38137 JDAHKT(1,3+IIGLU1)=0
38138 JDAHKT(2,3+IIGLU1)=0
38139 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
38140 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
38141 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
38142 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
38144 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38145 * -PHKT(3,3+IIGLU1)**2)
38147 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
38149 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
38150 DO 71 IIG=2,2+IIGLU1-1
38151 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38152 & JMOHKT(1,IIG),JMOHKT(2,IIG),
38154 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38156 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
38157 * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
38158 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
38159 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
38160 * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
38161 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
38165 IF(IPP11.GE.3.OR.IPP12.GE.3.OR.IP21.GE.3)CHAMAL=CHAB3
38166 ELSEIF(IPIP.EQ.2)THEN
38167 IF(IPP11.LE.-3.OR.IPP12.LE.-3.OR.IP21.LE.-3)CHAMAL=CHAB3
38169 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
38175 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
38176 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
38177 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
38178 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
38179 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
38180 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
38181 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
38182 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
38183 C IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+1
38184 IDHKT(7+IIGLU1) =IP1
38185 ISTHKT(7+IIGLU1) =961
38186 JMOHKT(1,7+IIGLU1)=NC1P
38187 JMOHKT(2,7+IIGLU1)=0
38188 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
38189 JDAHKT(2,7+IIGLU1)=0
38190 PHKT(1,7+IIGLU1) =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
38191 PHKT(2,7+IIGLU1) =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
38192 PHKT(3,7+IIGLU1) =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
38193 PHKT(4,7+IIGLU1) =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
38194 C PHKT(5,7+IIGLU1) =PHKK(5,NC1P)
38195 XXMIST=(PHKT(4,7+IIGLU1)**2-
38196 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
38197 *PHKT(1,7+IIGLU1)**2)
38198 IF(XXMIST.GT.0.D0)THEN
38199 PHKT(5,7+IIGLU1) =SQRT(XXMIST)
38201 WRITE(LOUT,*)' MGSQBS2, XXMIST',XXMIST
38203 PHKT(5,7+IIGLU1) =SQRT(XXMIST)
38205 VHKT(1,7+IIGLU1) =VHKK(1,NC1P)
38206 VHKT(2,7+IIGLU1) =VHKK(2,NC1P)
38207 VHKT(3,7+IIGLU1) =VHKK(3,NC1P)
38208 VHKT(4,7+IIGLU1) =VHKK(4,NC1P)
38209 WHKT(1,7+IIGLU1) =WHKK(1,NC1P)
38210 WHKT(2,7+IIGLU1) =WHKK(2,NC1P)
38211 WHKT(3,7+IIGLU1) =WHKK(3,NC1P)
38212 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
38213 C IDHKT(7) =1000*IPP1+100*ISQ+1
38214 C Insert here the IIGLU2 gluons
38219 IF(IIGLU2.GE.1)THEN
38221 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38222 KKG=JJG+IIG-7-IIGLU1
38223 IDHKT(IIG) =IDHKK(KKG)
38227 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
38229 PHKT(1,IIG)=PHKK(1,KKG)
38230 PG1=PG1+ PHKT(1,IIG)
38231 PHKT(2,IIG)=PHKK(2,KKG)
38232 PG2=PG2+ PHKT(2,IIG)
38233 PHKT(3,IIG)=PHKK(3,KKG)
38234 PG3=PG3+ PHKT(3,IIG)
38235 PHKT(4,IIG)=PHKK(4,KKG)
38236 PG4=PG4+ PHKT(4,IIG)
38237 PHKT(5,IIG)=PHKK(5,KKG)
38238 VHKT(1,IIG) =VHKK(1,KKG)
38239 VHKT(2,IIG) =VHKK(2,KKG)
38240 VHKT(3,IIG) =VHKK(3,KKG)
38241 VHKT(4,IIG) =VHKK(4,KKG)
38242 WHKT(1,IIG) =WHKK(1,KKG)
38243 WHKT(2,IIG) =WHKK(2,KKG)
38244 WHKT(3,IIG) =WHKK(3,KKG)
38245 WHKT(4,IIG) =WHKK(4,KKG)
38249 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*ISQ1+3
38250 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
38251 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
38252 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
38253 ELSEIF(IPIP.EQ.2)THEN
38255 C IDHKT(8) =1000*IPP2+100*(-ISQ1+6)-3
38256 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3
38258 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
38259 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
38260 IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
38262 ISTHKT(8+IIGLU1+IIGLU2) =962
38263 JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
38264 JMOHKT(2,8+IIGLU1+IIGLU2)=0
38265 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
38266 JDAHKT(2,8+IIGLU1+IIGLU2)=0
38267 C PHKT(1,8) =0.5D0*PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ/(XDIQT+XSQ)
38268 C PHKT(2,8) =0.5D0*PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ/(XDIQT+XSQ)
38269 C PHKT(3,8) =0.5D0*PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ/(XDIQT+XSQ)
38270 C PHKT(4,8) =0.5D0*PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ/(XDIQT+XSQ)
38271 PHKT(1,8+IIGLU1+IIGLU2) =
38272 * PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
38273 PHKT(2,8+IIGLU1+IIGLU2) =
38274 * PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
38275 PHKT(3,8+IIGLU1+IIGLU2) =
38276 * PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
38277 PHKT(4,8+IIGLU1+IIGLU2) =
38278 * PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
38279 C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
38280 C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
38281 IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
38283 C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
38288 C PHKT(5,8) =PHKK(5,NC2T)
38289 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
38290 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38291 *PHKT(1,8+IIGLU1+IIGLU2)**2)
38292 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC2T)
38293 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC2T)
38294 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC2T)
38295 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC2T)
38296 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC2T)
38297 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC2T)
38298 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC2T)
38299 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC2T)
38300 IDHKT(9+IIGLU1+IIGLU2) =88888
38301 ISTHKT(9+IIGLU1+IIGLU2) =96
38302 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
38303 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
38304 JDAHKT(1,9+IIGLU1+IIGLU2)=0
38305 JDAHKT(2,9+IIGLU1+IIGLU2)=0
38306 PHKT(1,9+IIGLU1+IIGLU2)
38307 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
38308 PHKT(2,9+IIGLU1+IIGLU2)
38309 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
38310 PHKT(3,9+IIGLU1+IIGLU2)
38311 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
38312 PHKT(4,9+IIGLU1+IIGLU2)
38313 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
38314 PHKT(5,9+IIGLU1+IIGLU2)
38315 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
38316 * PHKT(2,9+IIGLU1+IIGLU2)**2
38317 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
38319 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
38320 * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
38321 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
38322 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38323 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38324 & JMOHKT(1,IIG),JMOHKT(2,IIG),
38326 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38328 WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
38329 * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
38330 *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
38331 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
38332 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
38333 * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
38334 *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
38335 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
38339 IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
38340 ELSEIF(IPIP.EQ.2)THEN
38341 IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
38343 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
38349 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
38350 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
38351 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
38352 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
38353 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
38354 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
38355 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
38356 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
38359 IGCOUN=9+IIGLU1+IIGLU2
38363 *$ CREATE MUSQBS1.FOR
38367 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
38368 SUBROUTINE MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
38369 * IP11,IP12,IP2,IPP1,IPP2,IPIP,ISQ,IGCOUN)
38371 C USQBS-1 diagram (split projectile diquark)
38373 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38376 PARAMETER ( LINP = 10 ,
38380 PARAMETER (NMXHKK=200000)
38381 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38382 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38383 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38384 * extended event history
38385 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38386 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38388 * Lorentz-parameters of the current interaction
38389 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
38390 & UMO,PPCM,EPROJ,PPROJ
38391 * diquark-breaking mechanism
38392 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
38395 PARAMETER (NTMHKK= 300)
38396 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38397 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38400 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
38403 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
38404 COMMON /EVFLAG/ NUMEV
38406 C USQBS-1 diagram (split projectile diquark)
38408 C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
38409 C Input chain 2(NC2) sea-quark(NC2P)-sea-antiquark(NC2T)
38411 C Create quark(qsP)-antiquark(aqsT) pair, energy from NC1P and NC1T
38412 C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
38414 C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
38415 C 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
38416 C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
38418 C Put new chains into COMMON /HKKTMP/
38423 C WRITE(6,*)'MUSQBS1: IIGLU1,IIGLU2,IPIP ',IIGLU1,IIGLU2,IPIP
38427 C IF(NUMEV.EQ.-324)THEN
38428 WRITE(LOUT,*)' MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
38429 * ' IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN)',
38430 *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
38431 * IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN
38436 C determine x-values of NC1P diquark
38437 XDIQP=PHKK(4,NC1P)*2.D0/UMO
38438 XVQT=PHKK(4,NC1T)*2.D0/UMO
38440 C determine x-values of sea quark pair
38446 IF(ICOU.GE.500)THEN
38449 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 2234 ICOU. GT.100'
38453 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 call XSEAPA: UMO,XDIQP,XVQT ',
38458 C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
38459 IF (IPIP.EQ.1) THEN
38460 XQMAX = XDIQP/2.0D0
38461 XAQMAX = 2.D0*XVQT/3.0D0
38463 XQMAX = 2.D0*XVQT/3.0D0
38464 XAQMAX = XDIQP/2.0D0
38466 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
38468 C write(*,*) 'MUSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
38470 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
38473 & WRITE(LOUT,*)'MUSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
38478 IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
38479 ELSEIF(IPIP.EQ.2)THEN
38480 IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
38483 WRITE(LOUT,'(A,4E12.4)')' MUSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
38484 * XDIQP,XVQT,XSQ,XSAQ
38487 C subtract xsq,xsaq from NC1P diquark and NC1T quark
38493 ELSEIF(IPIP.EQ.2)THEN
38498 & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
38500 C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
38505 IF(IVTHR.EQ.10)THEN
38508 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 3466 reject IVTHR 10'
38513 XVTHR=XVTHRO/(201-IVTHR)
38516 IF(XVTHR.GT.0.66D0*XDIQP)THEN
38519 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 380 XVTHR large ',
38524 IF(DT_RNDM(V).LT.0.5D0)THEN
38525 XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
38528 XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
38532 WRITE(LOUT,'(A,2E12.4)')' MUSQBS1:XVPQI,XVPQII ',XVPQI,XVPQII
38535 C Prepare 4 momenta of new chains and chain ends
38537 C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38538 C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38540 C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
38541 C 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
38542 C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
38548 ELSEIF(IPIP.EQ.2)THEN
38558 JDAHKT(1,1)=3+IIGLU1
38560 C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
38561 PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
38562 PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
38563 PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
38564 PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
38565 C PHKT(5,1) =PHKK(5,NC1P)
38566 XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38568 IF(XMIST.GE.0.D0)THEN
38569 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38572 C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38575 VHKT(1,1) =VHKK(1,NC1P)
38576 VHKT(2,1) =VHKK(2,NC1P)
38577 VHKT(3,1) =VHKK(3,NC1P)
38578 VHKT(4,1) =VHKK(4,NC1P)
38579 WHKT(1,1) =WHKK(1,NC1P)
38580 WHKT(2,1) =WHKK(2,NC1P)
38581 WHKT(3,1) =WHKK(3,NC1P)
38582 WHKT(4,1) =WHKK(4,NC1P)
38583 C Add here IIGLU1 gluons to this chaina
38588 IF(IIGLU1.GE.1)THEN
38590 DO 61 IIG=2,2+IIGLU1-1
38592 IDHKT(IIG) =IDHKK(KKG)
38596 JDAHKT(1,IIG)=3+IIGLU1
38598 PHKT(1,IIG)=PHKK(1,KKG)
38599 PG1=PG1+ PHKT(1,IIG)
38600 PHKT(2,IIG)=PHKK(2,KKG)
38601 PG2=PG2+ PHKT(2,IIG)
38602 PHKT(3,IIG)=PHKK(3,KKG)
38603 PG3=PG3+ PHKT(3,IIG)
38604 PHKT(4,IIG)=PHKK(4,KKG)
38605 PG4=PG4+ PHKT(4,IIG)
38606 PHKT(5,IIG)=PHKK(5,KKG)
38607 VHKT(1,IIG) =VHKK(1,KKG)
38608 VHKT(2,IIG) =VHKK(2,KKG)
38609 VHKT(3,IIG) =VHKK(3,KKG)
38610 VHKT(4,IIG) =VHKK(4,KKG)
38611 WHKT(1,IIG) =WHKK(1,KKG)
38612 WHKT(2,IIG) =WHKK(2,KKG)
38613 WHKT(3,IIG) =WHKK(3,KKG)
38614 WHKT(4,IIG) =WHKK(4,KKG)
38617 IDHKT(2+IIGLU1) =IPP2
38618 ISTHKT(2+IIGLU1) =932
38619 JMOHKT(1,2+IIGLU1)=NC2T
38620 JMOHKT(2,2+IIGLU1)=0
38621 JDAHKT(1,2+IIGLU1)=3+IIGLU1
38622 JDAHKT(2,2+IIGLU1)=0
38623 PHKT(1,2+IIGLU1) =PHKK(1,NC2T)
38624 PHKT(2,2+IIGLU1) =PHKK(2,NC2T)
38625 PHKT(3,2+IIGLU1) =PHKK(3,NC2T)
38626 PHKT(4,2+IIGLU1) =PHKK(4,NC2T)
38627 C PHKT(5,2+IIGLU1) =PHKK(5,NC2T)
38628 XMIST=(PHKT(4,2+IIGLU1)**2-
38629 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38630 *PHKT(1,2+IIGLU1)**2)
38631 IF(XMIST.GT.0.D0)THEN
38632 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
38633 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38634 *PHKT(1,2+IIGLU1)**2)
38636 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38637 PHKT(5,2+IIGLU1)=0.D0
38639 VHKT(1,2+IIGLU1) =VHKK(1,NC2T)
38640 VHKT(2,2+IIGLU1) =VHKK(2,NC2T)
38641 VHKT(3,2+IIGLU1) =VHKK(3,NC2T)
38642 VHKT(4,2+IIGLU1) =VHKK(4,NC2T)
38643 WHKT(1,2+IIGLU1) =WHKK(1,NC2T)
38644 WHKT(2,2+IIGLU1) =WHKK(2,NC2T)
38645 WHKT(3,2+IIGLU1) =WHKK(3,NC2T)
38646 WHKT(4,2+IIGLU1) =WHKK(4,NC2T)
38647 IDHKT(3+IIGLU1) =88888
38648 ISTHKT(3+IIGLU1) =94
38649 JMOHKT(1,3+IIGLU1)=1
38650 JMOHKT(2,3+IIGLU1)=2+IIGLU1
38651 JDAHKT(1,3+IIGLU1)=0
38652 JDAHKT(2,3+IIGLU1)=0
38653 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
38654 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
38655 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
38656 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
38658 * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38659 * -PHKT(3,3+IIGLU1)**2)
38660 IF(XMIST.GE.0.D0)THEN
38662 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38663 * -PHKT(3,3+IIGLU1)**2)
38665 C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38669 C IF(NUMEV.EQ.-324)THEN
38670 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),
38671 * JMOHKT(2,1),JDAHKT(1,1),
38672 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
38673 DO 71 IIG=2,2+IIGLU1-1
38674 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38675 & JMOHKT(1,IIG),JMOHKT(2,IIG),
38677 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38679 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
38680 * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
38681 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
38682 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
38683 * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
38684 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
38688 IF(IP11.GE.3.OR.IPP2.GE.3)CHAMAL=CHAM3
38689 ELSEIF(IPIP.EQ.2)THEN
38690 IF(IP11.LE.-3.OR.IPP2.LE.-3)CHAMAL=CHAM3
38692 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
38696 C WRITE(6,*)' MUSQBS1 jump back from chain 3'
38699 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
38700 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
38701 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
38702 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
38703 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
38704 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
38705 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
38706 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
38707 IDHKT(4+IIGLU1) =IP12
38708 ISTHKT(4+IIGLU1) =931
38709 JMOHKT(1,4+IIGLU1)=NC1P
38710 JMOHKT(2,4+IIGLU1)=0
38711 JDAHKT(1,4+IIGLU1)=6+IIGLU1
38712 JDAHKT(2,4+IIGLU1)=0
38713 C create chain 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
38714 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
38715 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
38716 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
38717 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
38718 C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
38719 XMIST =(PHKT(4,4+IIGLU1)**2-
38720 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
38721 *PHKT(1,4+IIGLU1)**2)
38722 IF(XMIST.GT.0.D0)THEN
38723 PHKT(5,4+IIGLU1) =SQRT(PHKT(4,4+IIGLU1)**2-
38724 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
38725 *PHKT(1,4+IIGLU1)**2)
38727 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38728 PHKT(5,4+IIGLU1)=0.D0
38730 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
38731 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
38732 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
38733 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
38734 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
38735 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
38736 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
38737 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
38739 IDHKT(5+IIGLU1) =-(ISAQ1-6)
38740 ELSEIF(IPIP.EQ.2)THEN
38741 IDHKT(5+IIGLU1) =ISAQ1
38743 ISTHKT(5+IIGLU1) =932
38744 JMOHKT(1,5+IIGLU1)=NC1T
38745 JMOHKT(2,5+IIGLU1)=0
38746 JDAHKT(1,5+IIGLU1)=6+IIGLU1
38747 JDAHKT(2,5+IIGLU1)=0
38748 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
38749 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
38750 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
38751 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
38752 C IF( PHKT(4,5).EQ.0.D0)THEN
38757 C PHKT(5,5) =PHKK(5,NC1T)
38758 XMIST=(PHKT(4,5+IIGLU1)**2-
38759 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
38760 *PHKT(1,5+IIGLU1)**2)
38761 IF(XMIST.GT.0.D0)THEN
38762 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
38763 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
38764 *PHKT(1,5+IIGLU1)**2)
38766 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38767 PHKT(5,5+IIGLU1)=0.D0
38769 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
38770 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
38771 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
38772 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
38773 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
38774 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
38775 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
38776 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
38777 IDHKT(6+IIGLU1) =88888
38778 ISTHKT(6+IIGLU1) =94
38779 JMOHKT(1,6+IIGLU1)=4+IIGLU1
38780 JMOHKT(2,6+IIGLU1)=5+IIGLU1
38781 JDAHKT(1,6+IIGLU1)=0
38782 JDAHKT(2,6+IIGLU1)=0
38783 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
38784 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
38785 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
38786 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
38788 * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
38789 * -PHKT(3,6+IIGLU1)**2)
38790 IF(XMIST.GE.0.D0)THEN
38792 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
38793 * -PHKT(3,6+IIGLU1)**2)
38795 C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38798 C IF(IPIP.EQ.3)THEN
38801 IF(IP12.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
38802 ELSEIF(IPIP.EQ.2)THEN
38803 IF(IP12.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
38805 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
38809 C WRITE(6,*)' MGSQBS1 jump back from chain 6',
38810 C * CHAMAL,PHKT(5,6+IIGLU1)
38814 C IF(NUMEV.EQ.-324)THEN
38815 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
38816 * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
38817 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
38818 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
38819 * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
38820 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
38821 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
38822 * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
38823 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
38825 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
38826 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
38827 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
38828 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
38829 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
38830 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
38831 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
38832 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
38834 IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ+3
38835 IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
38836 IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
38837 IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
38838 ELSEIF(IPIP.EQ.2)THEN
38839 IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3
38840 IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
38841 IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
38842 IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
38843 C WRITE(6,*)'IDHKT(7+IIGLU1),IPP1,ISQ1',IDHKT(7+IIGLU1),IPP1,ISQ1
38845 ISTHKT(7+IIGLU1) =931
38846 JMOHKT(1,7+IIGLU1)=NC2P
38847 JMOHKT(2,7+IIGLU1)=0
38848 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
38849 JDAHKT(2,7+IIGLU1)=0
38850 C create chain 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
38851 PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
38852 PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
38853 PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
38854 PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
38855 C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
38856 C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
38857 IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
38859 C WRITE(6,*)'reject PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P)'
38864 C PHKT(5,7) =PHKK(5,NC2P)
38865 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
38866 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
38867 *PHKT(1,7+IIGLU1)**2)
38868 VHKT(1,7+IIGLU1) =VHKK(1,NC2P)
38869 VHKT(2,7+IIGLU1) =VHKK(2,NC2P)
38870 VHKT(3,7+IIGLU1) =VHKK(3,NC2P)
38871 VHKT(4,7+IIGLU1) =VHKK(4,NC2P)
38872 WHKT(1,7+IIGLU1) =WHKK(1,NC2P)
38873 WHKT(2,7+IIGLU1) =WHKK(2,NC2P)
38874 WHKT(3,7+IIGLU1) =WHKK(3,NC2P)
38875 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
38876 C Insert here the IIGLU2 gluons
38881 IF(IIGLU2.GE.1)THEN
38883 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38884 KKG=JJG+IIG-7-IIGLU1
38885 IDHKT(IIG) =IDHKK(KKG)
38889 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
38891 PHKT(1,IIG)=PHKK(1,KKG)
38892 PG1=PG1+ PHKT(1,IIG)
38893 PHKT(2,IIG)=PHKK(2,KKG)
38894 PG2=PG2+ PHKT(2,IIG)
38895 PHKT(3,IIG)=PHKK(3,KKG)
38896 PG3=PG3+ PHKT(3,IIG)
38897 PHKT(4,IIG)=PHKK(4,KKG)
38898 PG4=PG4+ PHKT(4,IIG)
38899 PHKT(5,IIG)=PHKK(5,KKG)
38900 VHKT(1,IIG) =VHKK(1,KKG)
38901 VHKT(2,IIG) =VHKK(2,KKG)
38902 VHKT(3,IIG) =VHKK(3,KKG)
38903 VHKT(4,IIG) =VHKK(4,KKG)
38904 WHKT(1,IIG) =WHKK(1,KKG)
38905 WHKT(2,IIG) =WHKK(2,KKG)
38906 WHKT(3,IIG) =WHKK(3,KKG)
38907 WHKT(4,IIG) =WHKK(4,KKG)
38910 IDHKT(8+IIGLU1+IIGLU2) =IP2
38911 ISTHKT(8+IIGLU1+IIGLU2) =932
38912 JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
38913 JMOHKT(2,8+IIGLU1+IIGLU2)=0
38914 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
38915 JDAHKT(2,8+IIGLU1+IIGLU2)=0
38916 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
38917 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
38918 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
38919 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
38920 C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T)
38921 XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
38922 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38923 *PHKT(1,8+IIGLU1+IIGLU2)**2)
38924 IF(XMIST.GT.0.D0)THEN
38925 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
38926 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38927 *PHKT(1,8+IIGLU1+IIGLU2)**2)
38929 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38930 PHKT(5,8+IIGLU1+IIGLU2)=0.D0
38932 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T)
38933 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T)
38934 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T)
38935 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T)
38936 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T)
38937 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T)
38938 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T)
38939 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T)
38940 IDHKT(9+IIGLU1+IIGLU2) =88888
38941 ISTHKT(9+IIGLU1+IIGLU2) =94
38942 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
38943 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
38944 JDAHKT(1,9+IIGLU1+IIGLU2)=0
38945 JDAHKT(2,9+IIGLU1+IIGLU2)=0
38946 PHKT(1,9+IIGLU1+IIGLU2)
38947 * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
38948 PHKT(2,9+IIGLU1+IIGLU2)
38949 * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
38950 PHKT(3,9+IIGLU1+IIGLU2)
38951 * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
38952 PHKT(4,9+IIGLU1+IIGLU2)
38953 * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
38955 *=(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
38956 * -PHKT(2,9+IIGLU1+IIGLU2)**2
38957 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
38958 IF(XMIST.GE.0.D0)THEN
38959 PHKT(5,9+IIGLU1+IIGLU2)
38960 *=SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
38961 * -PHKT(2,9+IIGLU1+IIGLU2)**2
38962 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
38964 C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38968 C IF(NUMEV.EQ.-324)THEN
38969 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
38970 * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
38971 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
38972 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38973 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38974 & JMOHKT(1,IIG),JMOHKT(2,IIG),
38976 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38978 WRITE(LOUT,*)8+IIGLU1+IIGLU2,
38979 * ISTHKT(8+IIGLU1+IIGLU2),IDHKT(8+IIGLU1+IIGLU2),
38980 * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
38981 *JDAHKT(1,8+IIGLU1+IIGLU2),
38982 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
38983 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
38984 * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
38985 *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
38986 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
38990 IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
38991 ELSEIF(IPIP.EQ.2)THEN
38992 IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
38994 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
38998 C WRITE(6,*)' MGSQBS1 jump back from chain 9',
38999 C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
39002 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
39003 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
39004 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
39005 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
39006 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
39007 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
39008 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
39009 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
39012 IGCOUN=9+IIGLU1+IIGLU2
39016 *$ CREATE MGSQBS1.FOR
39019 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
39020 SUBROUTINE MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
39021 * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,ISQ,IGCOUN)
39023 C GSQBS-1 diagram (split projectile diquark)
39025 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39028 PARAMETER ( LINP = 10 ,
39032 PARAMETER (NMXHKK=200000)
39033 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
39034 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
39035 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
39036 * extended event history
39037 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
39038 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
39040 * Lorentz-parameters of the current interaction
39041 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
39042 & UMO,PPCM,EPROJ,PPROJ
39043 * diquark-breaking mechanism
39044 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
39047 PARAMETER (NTMHKK= 300)
39048 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
39049 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
39052 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
39055 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
39057 C GSQBS-1 diagram (split projectile diquark)
39060 C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
39061 C Input chain 2(NC2) sea-quark(NC2P)-valence-diquark(NC2T)
39063 C Create quark(qs)-antiquark(aqs) pair energy from NC1P and NC1T
39064 C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
39066 C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
39067 C 6 valence quark(vq2P 4)-sea-quark(aqsP 5)
39068 C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
39070 C Put new chains into COMMON /HKKTMP/
39075 C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
39077 NNNC1=IDHKK(NC1)/1000
39078 MMMC1=IDHKK(NC1)-NNNC1*1000
39080 NNNC2=IDHKK(NC2)/1000
39081 MMMC2=IDHKK(NC2)-NNNC2*1000
39085 WRITE(LOUT,*)' MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
39086 * ' IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN)',
39087 *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
39088 * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN
39093 C determine x-values of NC1P diquark
39094 XDIQP=PHKK(4,NC1P)*2.D0/UMO
39095 XVQT=PHKK(4,NC1T)*2.D0/UMO
39097 C determine x-values of sea quark pair
39103 IF(ICOU.GE.500)THEN
39106 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 Rejection 2234 ICOU. GT.100'
39110 IF(IPCO.GE.3)WRITE(LOUT,*)'MGSQBS1 call XSEAPA: UMO,XDIQP,XVQT ',
39115 C CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
39116 IF (IPIP.EQ.1) THEN
39117 XQMAX = XDIQP/2.0D0
39118 XAQMAX = 2.D0*XVQT/3.0D0
39120 XQMAX = 2.D0*XVQT/3.0D0
39121 XAQMAX = XDIQP/2.0D0
39123 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
39125 C write(*,*) 'MGSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
39128 & WRITE(LOUT,*)'MGSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
39131 & WRITE(LOUT,*)'MGSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
39136 IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
39137 ELSEIF(IPIP.EQ.2)THEN
39138 IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
39141 WRITE(LOUT,'(A,4E12.4)')' MGSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
39142 * XDIQP,XVQT,XSQ,XSAQ
39145 C subtract xsq,xsaq from NC1P diquark and NC1T quark
39151 C IF (XDIQP.LT.0.0D0) WRITE(*,*) ' mgsqbs1: XDIQP<0!!',XDIQP
39154 ELSEIF(IPIP.EQ.2)THEN
39159 & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
39161 C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
39166 IF(IVTHR.EQ.10)THEN
39169 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 3466 reject IVTHR 10'
39174 XVTHR=XVTHRO/(201-IVTHR)
39177 IF(XVTHR.GT.0.66D0*XDIQP)THEN
39181 & WRITE(LOUT,*)' MGSQBS1 Rejection 380 XVTHR large ',
39186 IF(DT_RNDM(V).LT.0.5D0)THEN
39187 XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
39190 XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
39194 WRITE(LOUT,'(A,4E12.4)')' MGSQBS1:XVTHR,XDIQP,XVPQI,XVPQII ',
39195 * XVTHR,XDIQP,XVPQI,XVPQII
39198 C Prepare 4 momenta of new chains and chain ends
39200 C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
39201 C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
39203 C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
39204 C 6 valence quark(vq2P 4)-sea-quark(aqsP 5)
39205 C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
39211 ELSEIF(IPIP.EQ.2)THEN
39218 C IDHKT(2) =1000*IPP21+100*IPP22+1
39222 IDHKT(4+IIGLU1) =IP12
39223 ISTHKT(4+IIGLU1) =921
39224 JMOHKT(1,4+IIGLU1)=NC1P
39225 JMOHKT(2,4+IIGLU1)=0
39226 JDAHKT(1,4+IIGLU1)=6+IIGLU1
39227 JDAHKT(2,4+IIGLU1)=0
39229 IF ((XDIQP.LT.0.0D0).OR.(XVPQII.LT.0.0D0).OR.
39230 & (XSQ1.LT.0.0D0)) WRITE(LOUT,*) ' mgsqbs1: ',XDIQP,XVPQII,XSQ1
39232 PHKT(1,4+IIGLU1) =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
39233 PHKT(2,4+IIGLU1) =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
39234 PHKT(3,4+IIGLU1) =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
39235 PHKT(4,4+IIGLU1) =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
39236 C PHKT(5,4+IIGLU1) =PHKK(5,NC1P)
39237 XXMIST=(PHKT(4,4+IIGLU1)**2-
39238 * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
39239 * PHKT(1,4+IIGLU1)**2)
39240 IF(XXMIST.GT.0.D0)THEN
39241 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
39243 WRITE(LOUT,*)'MGSQBS1 XXMIST',XXMIST
39245 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
39247 VHKT(1,4+IIGLU1) =VHKK(1,NC1P)
39248 VHKT(2,4+IIGLU1) =VHKK(2,NC1P)
39249 VHKT(3,4+IIGLU1) =VHKK(3,NC1P)
39250 VHKT(4,4+IIGLU1) =VHKK(4,NC1P)
39251 WHKT(1,4+IIGLU1) =WHKK(1,NC1P)
39252 WHKT(2,4+IIGLU1) =WHKK(2,NC1P)
39253 WHKT(3,4+IIGLU1) =WHKK(3,NC1P)
39254 WHKT(4,4+IIGLU1) =WHKK(4,NC1P)
39256 IDHKT(5+IIGLU1) =-(ISAQ1-6)
39257 ELSEIF(IPIP.EQ.2)THEN
39258 IDHKT(5+IIGLU1) =ISAQ1
39260 ISTHKT(5+IIGLU1) =922
39261 JMOHKT(1,5+IIGLU1)=NC1T
39262 JMOHKT(2,5+IIGLU1)=0
39263 JDAHKT(1,5+IIGLU1)=6+IIGLU1
39264 JDAHKT(2,5+IIGLU1)=0
39266 IF ((XSAQ1.LT.0.0D0).OR.(XVQT .LT.0.0D0))
39267 & WRITE(LOUT,*) ' mgsqbs2: ',XSAQ1,XVQT
39269 PHKT(1,5+IIGLU1) =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
39270 PHKT(2,5+IIGLU1) =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
39271 PHKT(3,5+IIGLU1) =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
39272 PHKT(4,5+IIGLU1) =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
39273 C PHKT(5,5+IIGLU1) =PHKK(5,NC1T)
39274 XMIST=(PHKT(4,5+IIGLU1)**2-
39275 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
39276 *PHKT(1,5+IIGLU1)**2)
39277 IF(XMIST.GT.0.D0)THEN
39278 PHKT(5,5+IIGLU1) =SQRT(PHKT(4,5+IIGLU1)**2-
39279 * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
39280 *PHKT(1,5+IIGLU1)**2)
39282 C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
39283 PHKT(5,5+IIGLU1)=0.D0
39285 VHKT(1,5+IIGLU1) =VHKK(1,NC1T)
39286 VHKT(2,5+IIGLU1) =VHKK(2,NC1T)
39287 VHKT(3,5+IIGLU1) =VHKK(3,NC1T)
39288 VHKT(4,5+IIGLU1) =VHKK(4,NC1T)
39289 WHKT(1,5+IIGLU1) =WHKK(1,NC1T)
39290 WHKT(2,5+IIGLU1) =WHKK(2,NC1T)
39291 WHKT(3,5+IIGLU1) =WHKK(3,NC1T)
39292 WHKT(4,5+IIGLU1) =WHKK(4,NC1T)
39293 IDHKT(6+IIGLU1) =88888
39294 C IDHKT(6) =1000*NNNC1+MMMC1
39295 ISTHKT(6+IIGLU1) =93
39297 JMOHKT(1,6+IIGLU1)=4+IIGLU1
39298 JMOHKT(2,6+IIGLU1)=5+IIGLU1
39299 JDAHKT(1,6+IIGLU1)=0
39300 JDAHKT(2,6+IIGLU1)=0
39301 PHKT(1,6+IIGLU1) =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
39302 PHKT(2,6+IIGLU1) =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
39303 PHKT(3,6+IIGLU1) =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
39304 PHKT(4,6+IIGLU1) =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
39306 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
39307 * -PHKT(3,6+IIGLU1)**2)
39310 IF(IP12.GE.3.OR.ISAQ.GE.9)CHAMAL=CHAM3
39311 ELSEIF(IPIP.EQ.2)THEN
39312 IF(IP12.LE.-3.OR.ISAQ.GE.3)CHAMAL=CHAM3
39314 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
39315 IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
39316 C we drop chain 6 and give the energy to chain 3
39317 IDHKT(6+IIGLU1)=33888
39319 C WRITE(6,*)' drop chain 6 xgive=1'
39321 ELSEIF(IDHKT(5+IIGLU1).EQ.-IP11)THEN
39322 C we drop chain 6 and give the energy to chain 3
39323 C and change KK11 to IDHKT(4)
39324 IDHKT(6+IIGLU1)=33888
39326 C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(4+IIGLU1)'
39327 KK11=IDHKT(4+IIGLU1)
39329 ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP21)THEN
39330 C we drop chain 6 and give the energy to chain 3
39331 C and change KK21 to IDHKT(4)
39332 C IDHKT(2) =1000*IPP21+100*IPP22+1
39333 IDHKT(6+IIGLU1)=33888
39335 C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(4+IIGLU1)'
39336 KK21=IDHKT(4+IIGLU1)
39338 ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP22)THEN
39339 C we drop chain 6 and give the energy to chain 3
39340 C and change KK22 to IDHKT(4)
39341 C IDHKT(2) =1000*IPP21+100*IPP22+1
39342 IDHKT(6+IIGLU1)=33888
39344 C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(4+IIGLU1)'
39345 KK22=IDHKT(4+IIGLU1)
39351 C WRITE(6,*)' MGSQBS1 jump back from chain 6'
39356 WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
39357 * JMOHKT(1,4+IIGLU1),
39358 * JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
39359 *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
39360 WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
39361 * JMOHKT(1,5+IIGLU1),
39362 * JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
39363 *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
39364 WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
39365 * JMOHKT(1,6+IIGLU1),
39366 * JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
39367 *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
39369 VHKT(1,6+IIGLU1) =VHKK(1,NC1)
39370 VHKT(2,6+IIGLU1) =VHKK(2,NC1)
39371 VHKT(3,6+IIGLU1) =VHKK(3,NC1)
39372 VHKT(4,6+IIGLU1) =VHKK(4,NC1)
39373 WHKT(1,6+IIGLU1) =WHKK(1,NC1)
39374 WHKT(2,6+IIGLU1) =WHKK(2,NC1)
39375 WHKT(3,6+IIGLU1) =WHKK(3,NC1)
39376 WHKT(4,6+IIGLU1) =WHKK(4,NC1)
39382 JDAHKT(1,1)=3+IIGLU1
39384 PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
39385 C * +0.5D0*PHKK(1,NC2P)
39386 *+XGIVE*PHKT(1,4+IIGLU1)
39387 PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
39388 C * +0.5D0*PHKK(2,NC2P)
39389 *+XGIVE*PHKT(2,4+IIGLU1)
39390 PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
39391 C * +0.5D0*PHKK(3,NC2P)
39392 *+XGIVE*PHKT(3,4+IIGLU1)
39393 PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
39394 C * +0.5D0*PHKK(4,NC2P)
39395 *+XGIVE*PHKT(4,4+IIGLU1)
39396 C PHKT(5,1) =PHKK(5,NC1P)
39397 XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
39399 IF(XMIST.GE.0.D0)THEN
39400 PHKT(5,1) =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
39403 C WRITE(6,*)'MGSQBS1 parton 1 mass square LT.0 ',XMIST
39406 VHKT(1,1) =VHKK(1,NC1P)
39407 VHKT(2,1) =VHKK(2,NC1P)
39408 VHKT(3,1) =VHKK(3,NC1P)
39409 VHKT(4,1) =VHKK(4,NC1P)
39410 WHKT(1,1) =WHKK(1,NC1P)
39411 WHKT(2,1) =WHKK(2,NC1P)
39412 WHKT(3,1) =WHKK(3,NC1P)
39413 WHKT(4,1) =WHKK(4,NC1P)
39414 C Add here IIGLU1 gluons to this chaina
39419 IF(IIGLU1.GE.1)THEN
39421 DO 61 IIG=2,2+IIGLU1-1
39423 IDHKT(IIG) =IDHKK(KKG)
39427 JDAHKT(1,IIG)=3+IIGLU1
39429 PHKT(1,IIG)=PHKK(1,KKG)
39430 PG1=PG1+ PHKT(1,IIG)
39431 PHKT(2,IIG)=PHKK(2,KKG)
39432 PG2=PG2+ PHKT(2,IIG)
39433 PHKT(3,IIG)=PHKK(3,KKG)
39434 PG3=PG3+ PHKT(3,IIG)
39435 PHKT(4,IIG)=PHKK(4,KKG)
39436 PG4=PG4+ PHKT(4,IIG)
39437 PHKT(5,IIG)=PHKK(5,KKG)
39438 VHKT(1,IIG) =VHKK(1,KKG)
39439 VHKT(2,IIG) =VHKK(2,KKG)
39440 VHKT(3,IIG) =VHKK(3,KKG)
39441 VHKT(4,IIG) =VHKK(4,KKG)
39442 WHKT(1,IIG) =WHKK(1,KKG)
39443 WHKT(2,IIG) =WHKK(2,KKG)
39444 WHKT(3,IIG) =WHKK(3,KKG)
39445 WHKT(4,IIG) =WHKK(4,KKG)
39448 C IDHKT(2) =1000*IPP21+100*IPP22+1
39450 IDHKT(2+IIGLU1) =1000*KK21+100*KK22+3
39451 IF(IDHKT(2+IIGLU1).EQ.1203)IDHKT(2+IIGLU1)=2103
39452 IF(IDHKT(2+IIGLU1).EQ.1303)IDHKT(2+IIGLU1)=3103
39453 IF(IDHKT(2+IIGLU1).EQ.2303)IDHKT(2+IIGLU1)=3203
39454 ELSEIF(IPIP.EQ.2)THEN
39455 IDHKT(2+IIGLU1) =1000*KK21+100*KK22-3
39456 IF(IDHKT(2+IIGLU1).EQ.-1203)IDHKT(2+IIGLU1)=-2103
39457 IF(IDHKT(2+IIGLU1).EQ.-1303)IDHKT(2+IIGLU1)=-3103
39458 IF(IDHKT(2+IIGLU1).EQ.-2303)IDHKT(2+IIGLU1)=-3203
39460 ISTHKT(2+IIGLU1) =922
39461 JMOHKT(1,2+IIGLU1)=NC2T
39462 JMOHKT(2,2+IIGLU1)=0
39463 JDAHKT(1,2+IIGLU1)=3+IIGLU1
39464 JDAHKT(2,2+IIGLU1)=0
39465 PHKT(1,2+IIGLU1) =PHKK(1,NC2T)
39466 *+XGIVE*PHKT(1,5+IIGLU1)
39467 PHKT(2,2+IIGLU1) =PHKK(2,NC2T)
39468 *+XGIVE*PHKT(2,5+IIGLU1)
39469 PHKT(3,2+IIGLU1) =PHKK(3,NC2T)
39470 *+XGIVE*PHKT(3,5+IIGLU1)
39471 PHKT(4,2+IIGLU1) =PHKK(4,NC2T)
39472 *+XGIVE*PHKT(4,5+IIGLU1)
39473 C PHKT(5,2) =PHKK(5,NC2T)
39474 XMIST=(PHKT(4,2+IIGLU1)**2-
39475 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
39476 *PHKT(1,2+IIGLU1)**2)
39477 IF(XMIST.GT.0.D0)THEN
39478 PHKT(5,2+IIGLU1) =SQRT(PHKT(4,2+IIGLU1)**2-
39479 * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
39480 *PHKT(1,2+IIGLU1)**2)
39482 C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
39483 PHKT(5,2+IIGLU1)=0.D0
39485 VHKT(1,2+IIGLU1) =VHKK(1,NC2T)
39486 VHKT(2,2+IIGLU1) =VHKK(2,NC2T)
39487 VHKT(3,2+IIGLU1) =VHKK(3,NC2T)
39488 VHKT(4,2+IIGLU1) =VHKK(4,NC2T)
39489 WHKT(1,2+IIGLU1) =WHKK(1,NC2T)
39490 WHKT(2,2+IIGLU1) =WHKK(2,NC2T)
39491 WHKT(3,2+IIGLU1) =WHKK(3,NC2T)
39492 WHKT(4,2+IIGLU1) =WHKK(4,NC2T)
39493 IDHKT(3+IIGLU1) =88888
39494 C IDHKT(3) =1000*NNNC1+MMMC1+10
39495 ISTHKT(3+IIGLU1) =93
39497 JMOHKT(1,3+IIGLU1)=1
39498 JMOHKT(2,3+IIGLU1)=2+IIGLU1
39499 JDAHKT(1,3+IIGLU1)=0
39500 JDAHKT(2,3+IIGLU1)=0
39501 PHKT(1,3+IIGLU1) =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
39502 PHKT(2,3+IIGLU1) =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
39503 PHKT(3,3+IIGLU1) =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
39504 PHKT(4,3+IIGLU1) =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
39506 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
39507 * -PHKT(3,3+IIGLU1)**2)
39509 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
39511 *JDAHKT(2,1),(PHKT(III,1),III=1,5)
39512 DO 71 IIG=2,2+IIGLU1-1
39513 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
39514 & JMOHKT(1,IIG),JMOHKT(2,IIG),
39516 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
39518 WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),
39519 & IDHKT(2),JMOHKT(1,2+IIGLU1),
39520 * JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
39521 *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
39522 WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
39523 * JMOHKT(1,3+IIGLU1),
39524 * JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
39525 *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
39529 C IF(IPIP.EQ.1)THEN
39530 C IF(IPP21.GE.3.OR.IPP22.GE.3.OR.IP11.GE.3)CHAMAL=CHAB3
39531 C ELSEIF(IPIP.EQ.2)THEN
39532 C IF(IPP21.LE.-3.OR.IPP22.LE.-3.OR.IP11.LE.-3)CHAMAL=CHAB3
39535 IF(KK21.GE.3.OR.KK22.GE.3.OR.KK11.GE.3)CHAMAL=CHAB3
39536 ELSEIF(IPIP.EQ.2)THEN
39537 IF(KK21.LE.-3.OR.KK22.LE.-3.OR.KK11.LE.-3)CHAMAL=CHAB3
39540 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
39544 C WRITE(6,*)' MGSQBS1 jump back from chain 3'
39547 VHKT(1,3+IIGLU1) =VHKK(1,NC1)
39548 VHKT(2,3+IIGLU1) =VHKK(2,NC1)
39549 VHKT(3,3+IIGLU1) =VHKK(3,NC1)
39550 VHKT(4,3+IIGLU1) =VHKK(4,NC1)
39551 WHKT(1,3+IIGLU1) =WHKK(1,NC1)
39552 WHKT(2,3+IIGLU1) =WHKK(2,NC1)
39553 WHKT(3,3+IIGLU1) =WHKK(3,NC1)
39554 WHKT(4,3+IIGLU1) =WHKK(4,NC1)
39556 IDHKT(7+IIGLU1) =1000*IPP1+100*ISQ1+3
39557 IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
39558 IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
39559 IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
39560 ELSEIF(IPIP.EQ.2)THEN
39561 IDHKT(7+IIGLU1) =1000*IPP1+100*(-ISQ1+6)-3
39562 IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
39563 IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
39564 IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
39565 C WRITE(6,*)'IDHKT(7),IPP1,ISQ1',IDHKT(7),IPP1,ISQ1
39567 ISTHKT(7+IIGLU1) =921
39568 JMOHKT(1,7+IIGLU1)=NC2P
39569 JMOHKT(2,7+IIGLU1)=0
39570 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
39571 JDAHKT(2,7+IIGLU1)=0
39572 C PHKT(1,7) =0.5D0*PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ/(XDIQP+XSQ)
39573 C PHKT(2,7) =0.5D0*PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ/(XDIQP+XSQ)
39574 C PHKT(3,7) =0.5D0*PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ/(XDIQP+XSQ)
39575 C PHKT(4,7+IIGLU1) =0.5D0*PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ/(XDIQP+XSQ)
39577 IF ((XSQ1 .LT.0.0D0).OR.(XDIQP .LT.0.0D0))
39578 & WRITE(LOUT,*) ' mgsqbs3: ',XSQ1,XDIQP
39580 PHKT(1,7+IIGLU1) =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
39581 PHKT(2,7+IIGLU1) =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
39582 PHKT(3,7+IIGLU1) =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
39583 PHKT(4,7+IIGLU1) =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
39584 C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
39585 C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
39586 IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
39588 C WRITE(6,*)'reject PHKT(4,7).GE. PHKK(4,NC1P)'
39593 C PHKT(5,7) =PHKK(5,NC2P)
39594 PHKT(5,7+IIGLU1) =SQRT(PHKT(4,7+IIGLU1)**2-
39595 * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
39596 *PHKT(1,7+IIGLU1)**2)
39597 VHKT(1,7+IIGLU1) =VHKK(1,NC2P)
39598 VHKT(2,7+IIGLU1) =VHKK(2,NC2P)
39599 VHKT(3,7+IIGLU1) =VHKK(3,NC2P)
39600 VHKT(4,7+IIGLU1) =VHKK(4,NC2P)
39601 WHKT(1,7+IIGLU1) =WHKK(1,NC2P)
39602 WHKT(2,7+IIGLU1) =WHKK(2,NC2P)
39603 WHKT(3,7+IIGLU1) =WHKK(3,NC2P)
39604 WHKT(4,7+IIGLU1) =WHKK(4,NC2P)
39605 C Insert here the IIGLU2 gluons
39610 IF(IIGLU2.GE.1)THEN
39612 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
39613 KKG=JJG+IIG-7-IIGLU1
39614 IDHKT(IIG) =IDHKK(KKG)
39618 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
39620 PHKT(1,IIG)=PHKK(1,KKG)
39621 PG1=PG1+ PHKT(1,IIG)
39622 PHKT(2,IIG)=PHKK(2,KKG)
39623 PG2=PG2+ PHKT(2,IIG)
39624 PHKT(3,IIG)=PHKK(3,KKG)
39625 PG3=PG3+ PHKT(3,IIG)
39626 PHKT(4,IIG)=PHKK(4,KKG)
39627 PG4=PG4+ PHKT(4,IIG)
39628 PHKT(5,IIG)=PHKK(5,KKG)
39629 VHKT(1,IIG) =VHKK(1,KKG)
39630 VHKT(2,IIG) =VHKK(2,KKG)
39631 VHKT(3,IIG) =VHKK(3,KKG)
39632 VHKT(4,IIG) =VHKK(4,KKG)
39633 WHKT(1,IIG) =WHKK(1,KKG)
39634 WHKT(2,IIG) =WHKK(2,KKG)
39635 WHKT(3,IIG) =WHKK(3,KKG)
39636 WHKT(4,IIG) =WHKK(4,KKG)
39639 IDHKT(8+IIGLU1+IIGLU2) =IP2
39640 ISTHKT(8+IIGLU1+IIGLU2) =922
39641 JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
39642 JMOHKT(2,8+IIGLU1+IIGLU2)=0
39643 JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
39644 JDAHKT(2,8+IIGLU1+IIGLU2)=0
39646 IF ((XVQT.LT.0.0D0).OR.(XSAQ1 .LT.0.0D0))
39647 & WRITE(LOUT,*) ' mgsqbs4: ',XVQT,XSAQ1
39649 PHKT(1,8+IIGLU1+IIGLU2) =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
39650 PHKT(2,8+IIGLU1+IIGLU2) =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
39651 PHKT(3,8+IIGLU1+IIGLU2) =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
39652 PHKT(4,8+IIGLU1+IIGLU2) =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
39653 C PHKT(5,8+IIGLU1+IIGLU2) =PHKK(5,NC1T)
39654 XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
39655 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
39656 *PHKT(1,8+IIGLU1+IIGLU2)**2)
39657 IF(XMIST.GT.0.D0)THEN
39658 PHKT(5,8+IIGLU1+IIGLU2) =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
39659 * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
39660 *PHKT(1,8+IIGLU1+IIGLU2)**2)
39662 C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
39663 PHKT(5,8+IIGLU1+IIGLU2)=0.D0
39665 VHKT(1,8+IIGLU1+IIGLU2) =VHKK(1,NC1T)
39666 VHKT(2,8+IIGLU1+IIGLU2) =VHKK(2,NC1T)
39667 VHKT(3,8+IIGLU1+IIGLU2) =VHKK(3,NC1T)
39668 VHKT(4,8+IIGLU1+IIGLU2) =VHKK(4,NC1T)
39669 WHKT(1,8+IIGLU1+IIGLU2) =WHKK(1,NC1T)
39670 WHKT(2,8+IIGLU1+IIGLU2) =WHKK(2,NC1T)
39671 WHKT(3,8+IIGLU1+IIGLU2) =WHKK(3,NC1T)
39672 WHKT(4,8+IIGLU1+IIGLU2) =WHKK(4,NC1T)
39673 IDHKT(9+IIGLU1+IIGLU2) =88888
39674 C IDHKT(9) =1000*NNNC2+MMMC2+10
39675 ISTHKT(9+IIGLU1+IIGLU2) =93
39677 JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
39678 JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
39679 JDAHKT(1,9+IIGLU1+IIGLU2)=0
39680 JDAHKT(2,9+IIGLU1+IIGLU2)=0
39681 PHKT(1,9+IIGLU1+IIGLU2) =PHKT(1,7+IIGLU1)
39682 * +PHKT(1,8+IIGLU1+IIGLU2)+PG1
39683 PHKT(2,9+IIGLU1+IIGLU2) =PHKT(2,7+IIGLU1)
39684 * +PHKT(2,8+IIGLU1+IIGLU2)+PG2
39685 PHKT(3,9+IIGLU1+IIGLU2) =PHKT(3,7+IIGLU1)
39686 * +PHKT(3,8+IIGLU1+IIGLU2)+PG3
39687 PHKT(4,9+IIGLU1+IIGLU2) =PHKT(4,7+IIGLU1)
39688 * +PHKT(4,8+IIGLU1+IIGLU2)+PG4
39689 PHKT(5,9+IIGLU1+IIGLU2)
39690 * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
39691 * PHKT(2,9+IIGLU1+IIGLU2)**2
39692 * -PHKT(3,9+IIGLU1+IIGLU2)**2)
39694 WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
39695 * JMOHKT(1,7+IIGLU1),
39696 * JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
39697 *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
39698 DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
39699 WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
39700 & JMOHKT(1,IIG),JMOHKT(2,IIG),
39702 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
39704 WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
39705 * IDHKT(8+IIGLU1+IIGLU2),
39706 * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
39707 * JDAHKT(1,8+IIGLU1+IIGLU2),
39708 *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
39709 WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
39710 * IDHKT(9+IIGLU1+IIGLU2),
39711 * JMOHKT(1,9+IIGLU1+IIGLU2),JMOHKT(2,9+IIGLU1+IIGLU2),
39712 * JDAHKT(1,9+IIGLU1+IIGLU2),
39713 *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
39717 IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
39718 ELSEIF(IPIP.EQ.2)THEN
39719 IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
39721 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
39725 C WRITE(6,*)' MGSQBS1 jump back from chain 9',
39726 C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
39729 VHKT(1,9+IIGLU1+IIGLU2) =VHKK(1,NC1)
39730 VHKT(2,9+IIGLU1+IIGLU2) =VHKK(2,NC1)
39731 VHKT(3,9+IIGLU1+IIGLU2) =VHKK(3,NC1)
39732 VHKT(4,9+IIGLU1+IIGLU2) =VHKK(4,NC1)
39733 WHKT(1,9+IIGLU1+IIGLU2) =WHKK(1,NC1)
39734 WHKT(2,9+IIGLU1+IIGLU2) =WHKK(2,NC1)
39735 WHKT(3,9+IIGLU1+IIGLU2) =WHKK(3,NC1)
39736 WHKT(4,9+IIGLU1+IIGLU2) =WHKK(4,NC1)
39738 IGCOUN=9+IIGLU1+IIGLU2
39743 *$ CREATE HKKHKT.FOR
39746 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
39748 SUBROUTINE HKKHKT(I,J)
39749 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39753 PARAMETER (NMXHKK=200000)
39754 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
39755 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
39756 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
39757 * extended event history
39758 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
39759 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
39762 PARAMETER (NTMHKK= 300)
39763 COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
39764 +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
39767 ISTHKK(I) =ISTHKT(J)
39769 C IF(J.EQ.3.OR.J.EQ.6.OR.J.EQ.9)THEN
39770 IF(IDHKK(I).EQ.88888)THEN
39773 JMOHKK(1,I)=I-(J-JMOHKT(1,J))
39774 JMOHKK(2,I)=I-(J-JMOHKT(2,J))
39776 JMOHKK(1,I)=JMOHKT(1,J)
39777 JMOHKK(2,I)=JMOHKT(2,J)
39779 JDAHKK(1,I)=JDAHKT(1,J)
39780 JDAHKK(2,I)=JDAHKT(2,J)
39781 C IF(J.EQ.1.OR.J.EQ.4.OR.J.EQ.7)THEN
39783 C ELSEIF(J.EQ.2.OR.J.EQ.5.OR.J.EQ.8)THEN
39786 IF(JDAHKT(1,J).GT.0)THEN
39787 JDAHKK(1,I)=I+(JDAHKT(1,J)-J)
39789 PHKK(1,I) =PHKT(1,J)
39790 PHKK(2,I) =PHKT(2,J)
39791 PHKK(3,I) =PHKT(3,J)
39792 PHKK(4,I) =PHKT(4,J)
39793 PHKK(5,I) =PHKT(5,J)
39794 VHKK(1,I) =VHKT(1,J)
39795 VHKK(2,I) =VHKT(2,J)
39796 VHKK(3,I) =VHKT(3,J)
39797 VHKK(4,I) =VHKT(4,J)
39798 WHKK(1,I) =WHKT(1,J)
39799 WHKK(2,I) =WHKT(2,J)
39800 WHKK(3,I) =WHKT(3,J)
39801 WHKK(4,I) =WHKT(4,J)
39805 *$ CREATE DT_DBREAK.FOR
39808 *===dbreak=============================================================*
39810 SUBROUTINE DT_DBREAK(MODE)
39812 ************************************************************************
39813 * This is the steering subroutine for the different diquark breaking *
39816 * MODE = 1 breaking of projectile diquark in qq-q chain using *
39817 * a sea quark (q-qq chain) of the same projectile *
39818 * = 2 breaking of target diquark in q-qq chain using *
39819 * a sea quark (qq-q chain) of the same target *
39820 * = 3 breaking of projectile diquark in qq-q chain using *
39821 * a sea quark (q-aq chain) of the same projectile *
39822 * = 4 breaking of target diquark in q-qq chain using *
39823 * a sea quark (aq-q chain) of the same target *
39824 * = 5 breaking of projectile anti-diquark in aqaq-aq chain using *
39825 * a sea anti-quark (aq-aqaq chain) of the same projectile *
39826 * = 6 breaking of target anti-diquark in aq-aqaq chain using *
39827 * a sea anti-quark (aqaq-aq chain) of the same target *
39828 * = 7 breaking of projectile anti-diquark in aqaq-aq chain using *
39829 * a sea anti-quark (aq-q chain) of the same projectile *
39830 * = 8 breaking of target anti-diquark in aq-aqaq chain using *
39831 * a sea anti-quark (q-aq chain) of the same target *
39833 * Original version by J. Ranft. *
39834 * This version dated 17.5.00 is written by S. Roesler. *
39835 ************************************************************************
39837 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39839 PARAMETER ( LINP = 10 ,
39844 PARAMETER (NMXHKK=200000)
39845 COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
39846 & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
39847 & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
39848 * extended event history
39849 COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
39850 & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
39852 * flags for input different options
39853 LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
39854 COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
39855 & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
39856 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
39857 PARAMETER (MAXCHN=10000)
39858 COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
39859 * diquark-breaking mechanism
39860 COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
39861 * flags for particle decays
39862 COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
39863 & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
39864 & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
39867 * chain identifiers
39868 * ( 1 = q-aq, 2 = aq-q, 3 = q-qq, 4 = qq-q,
39869 * 5 = aq-adq, 6 = adq-aq, 7 = dq-adq, 8 = adq-dq )
39870 DIMENSION IDCHN1(8),IDCHN2(8)
39871 DATA IDCHN1 / 4, 3, 4, 3, 6, 5, 6, 5/
39872 DATA IDCHN2 / 3, 4, 1, 2, 5, 6, 2, 1/
39874 * parton identifiers
39875 * ( +-21/22 = valence, +-31/32 = Glauber-sea, +-41/42 = Pomeron (diff),
39876 * +-51/52 = unitarity-sea, +-61/62 = gluons )
39877 DIMENSION ISP1P(8,3),ISP1T(8,3),ISP2P(8,3),ISP2T(8,3)
39878 DATA ISP1P / 21, 21, 21, 21, 21, 21, 21, 21,
39879 & 31, 31, 31, 31, 31, 31, 31, 31,
39880 & 41, 41, 41, 41, 51, 51, 51, 51/
39881 DATA ISP1T / 22, 22, 22, 22, 22, 22, 22, 22,
39882 & 32, 32, 32, 32, 32, 32, 32, 32,
39883 & 42, 42, 42, 42, 52, 52, 52, 52/
39884 DATA ISP2P / 31, 21, 31, 31, 21, 21, 21, 21,
39885 & 51, 31, 41, 41, 31, 31, 31, 31,
39886 & 0, 41, 51, 51, 51, 51, 51, 51/
39887 DATA ISP2T / 22, 32, 32, 32, 22, 22, 22, 22,
39888 & 32, 52, 42, 42, 32, 32, 32, 32,
39889 & 42, 0, 52, 52, 52, 52, 52, 52/
39891 IF (NCHAIN.LE.0) RETURN
39894 IS1P = ABS(ISTHKK(JMOHKK(1,IDX1)))
39895 IS1T = ABS(ISTHKK(JMOHKK(2,IDX1)))
39896 IF ( (IDXCHN(2,I).EQ.IDCHN1(MODE))
39898 & ((IS1P.EQ.ISP1P(MODE,1)).OR.(IS1P.EQ.ISP1P(MODE,2)).OR.
39899 & (IS1P.EQ.ISP1P(MODE,3)))
39901 & ((IS1T.EQ.ISP1T(MODE,1)).OR.(IS1T.EQ.ISP1T(MODE,2)).OR.
39902 & (IS1T.EQ.ISP1T(MODE,3)))
39906 IS2P = ABS(ISTHKK(JMOHKK(1,IDX2)))
39907 IS2T = ABS(ISTHKK(JMOHKK(2,IDX2)))
39908 IF ( (IDXCHN(2,J).EQ.IDCHN2(MODE))
39910 & ((IS2P.EQ.ISP2P(MODE,1)).OR.(IS2P.EQ.ISP2P(MODE,2))
39911 & .OR.(IS2P.EQ.ISP2P(MODE,3)))
39913 & ((IS2T.EQ.ISP2T(MODE,1)).OR.(IS2T.EQ.ISP2T(MODE,2))
39914 & .OR.(IS2T.EQ.ISP2T(MODE,3)))
39916 * find mother nucleons of the diquark to be splitted and of the
39917 * sea-quark and reject this combination if it is not the same
39918 IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.
39919 & (MODE.EQ.5).OR.(MODE.EQ.7)) THEN
39924 IDXMO1 = JMOHKK(IANCES,IDX1)
39926 IF ((JMOHKK(1,IDXMO1).NE.0).AND.
39927 & (JMOHKK(2,IDXMO1).NE.0)) THEN
39932 IF (JMOHKK(IANC,IDXMO1).NE.0) THEN
39933 IDXMO1 = JMOHKK(IANC,IDXMO1)
39936 IDXMO2 = JMOHKK(IANCES,IDX2)
39938 IF ((JMOHKK(1,IDXMO2).NE.0).AND.
39939 & (JMOHKK(2,IDXMO2).NE.0)) THEN
39944 IF (JMOHKK(IANC,IDXMO2).NE.0) THEN
39945 IDXMO2 = JMOHKK(IANC,IDXMO2)
39948 IF (IDXMO1.NE.IDXMO2) GOTO 2
39949 * quark content of projectile parton
39950 IP1 = IDHKK(JMOHKK(1,IDX1))
39952 IP12 = (IP1-1000*IP11)/100
39953 IP2 = IDHKK(JMOHKK(2,IDX1))
39955 IP22 = (IP2-1000*IP21)/100
39956 * quark content of target parton
39957 IT1 = IDHKK(JMOHKK(1,IDX2))
39959 IT12 = (IT1-1000*IT11)/100
39960 IT2 = IDHKK(JMOHKK(2,IDX2))
39962 IT22 = (IT2-1000*IT21)/100
39963 * split diquark and form new chains
39964 IF (MODE.EQ.1) THEN
39965 IF (IT1.EQ.4) GOTO 2
39966 CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39967 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39968 & IP11,IP12,IP2,IT1,IT21,IT22,1,IPQ,IGCOUN)
39969 ELSEIF (MODE.EQ.2) THEN
39970 IF (IT2.EQ.4) GOTO 2
39971 CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39972 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39973 & IP1,IP21,IP22,IT11,IT12,IT2,1,IPQ,IGCOUN)
39974 ELSEIF (MODE.EQ.3) THEN
39975 IF (IT1.EQ.4) GOTO 2
39976 CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39977 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39978 & IP11,IP12,IP2,IT1,IT2,1,IPQ,IGCOUN)
39979 ELSEIF (MODE.EQ.4) THEN
39980 IF (IT2.EQ.4) GOTO 2
39981 CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39982 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39983 & IP1,IP21,IP22,IT1,IT2,1,IPQ,IGCOUN)
39984 ELSEIF (MODE.EQ.5) THEN
39985 CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39986 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39987 & IP11,IP12,IP2,IT1,IT21,IT22,2,IPQ,IGCOUN)
39988 ELSEIF (MODE.EQ.6) THEN
39989 CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39990 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39991 & IP1,IP21,IP22,IT11,IT12,IT2,2,IPQ,IGCOUN)
39992 ELSEIF (MODE.EQ.7) THEN
39993 CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39994 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39995 & IP11,IP12,IP2,IT1,IT2,2,IPQ,IGCOUN)
39996 ELSEIF (MODE.EQ.8) THEN
39997 CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39998 & IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39999 & IP1,IP21,IP22,IT1,IT2,2,IPQ,IGCOUN)
40001 IF (IREJ.GE.1) THEN
40002 if ((ipq.lt.0).or.(ipq.ge.4))
40003 & write(LOUT,*) 'ipq !!!',ipq,mode
40004 DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
40005 * accept or reject new chains corresponding to PDBSEA
40007 IF ((IPQ.EQ.1).OR.(IPQ.EQ.2)) THEN
40008 ACC = DBRKA(1,MODE)+DBRKA(2,MODE)
40009 REJ = DBRKR(1,MODE)+DBRKR(2,MODE)
40010 ELSEIF (IPQ.EQ.3) THEN
40011 ACC = DBRKA(3,MODE)
40012 REJ = DBRKR(3,MODE)
40014 WRITE(LOUT,*) ' inconsistent IPQ ! ',IPQ
40017 IF (ACC/(ACC+REJ).LE.PDBSEA(IPQ)) THEN
40018 DBRKA(IPQ,MODE) = DBRKA(IPQ,MODE)+1.0D0
40021 DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
40024 * new chains have been accepted and are now copied into HKKEVT
40025 IF (IACC.EQ.1) THEN
40027 CALL DT_EVTEMC(PHKK(1,IDX1),PHKK(2,IDX1),
40028 & PHKK(3,IDX1),PHKK(4,IDX1),
40030 CALL DT_EVTEMC(PHKK(1,IDX2),PHKK(2,IDX2),
40031 & PHKK(3,IDX2),PHKK(4,IDX2),
40034 IDHKK(IDX1) = 99888
40035 IDHKK(IDX2) = 99888
40040 CALL HKKHKT(NHKK,K)
40041 IF ((LEMCCK).AND.(IDHKK(NHKK).EQ.88888))THEN
40046 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
40051 CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,9000,
40053 IF (IREJ.NE.0) CALL DT_EVTOUT(4)
40065 *$ CREATE DT_CQPAIR.FOR
40068 *===cqpair=============================================================*
40070 SUBROUTINE DT_CQPAIR(XQMAX,XAQMAX,XQ,XAQ,IFLV,IREJ)
40072 ************************************************************************
40073 * This subroutine Creates a Quark-antiquark PAIR from the sea. *
40075 * XQMAX maxium energy fraction of quark (input) *
40076 * XAQMAX maxium energy fraction of antiquark (input) *
40077 * XQ energy fraction of quark (output) *
40078 * XAQ energy fraction of antiquark (output) *
40079 * IFLV quark flavour (- antiquark flavor) (output) *
40081 * This version dated 14.5.00 is written by S. Roesler. *
40082 ************************************************************************
40084 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
40086 PARAMETER ( LINP = 10 ,
40090 * Lorentz-parameters of the current interaction
40091 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
40092 & UMO,PPCM,EPROJ,PPROJ
40099 * sample quark flavour
40101 * set seasq here (the one from DTCHAI should be used in the future)
40103 IFLV = INT(1.0D0+DT_RNDM(XQMAX)*(2.0D0+SEASQ))
40105 * sample energy fractions of sea pair
40106 * we first sample the energy fraction of a gluon and then split the gluon
40108 * maximum energy fraction of the gluon forced via input
40109 XGMAXI = XQMAX+XAQMAX
40110 * minimum energy fraction of the gluon
40111 XTHR1 = 4.0D0 /UMO**2
40112 XTHR2 = 0.54D0/UMO**1.5D0
40113 XGMIN = MAX(XTHR1,XTHR2)
40114 * maximum energy fraction of the gluon
40116 XGMAX = MIN(XGMAXI,XGMAX)
40117 IF (XGMIN.GE.XGMAX) THEN
40122 * sample energy fraction of the gluon
40126 IF (NLOOP.GE.50) THEN
40130 XGLUON = DT_SAMSQX(XGMIN,XGMAX)
40131 EGLUON = XGLUON*UMO/2.0D0
40133 * split gluon into q-aq pair (we follow PHOJET's subroutine PHO_GLU2QU)
40134 ZMIN = MIN(0.1D0,0.5D0/EGLUON)
40137 XHLP = ((1.0D0-RZ)*ZMIN**3+RZ*ZMAX**3)**0.33333
40139 IF (RQ.LT.0.5D0) THEN
40146 IF ((XQ.GT.XQMAX).OR.(XAQ.GT.XAQMAX)) GOTO 1